{-# LANGUAGE FlexibleInstances #-} module Codec.Encryption.DESAux (des_enc, des_dec) where import Data.Word import Data.Bits type Rotation = Int type Key = Word64 type Message = Word64 type Enc = Word64 type BitsX = [Bool] type Bits4 = [Bool] type Bits6 = [Bool] type Bits32 = [Bool] type Bits48 = [Bool] type Bits56 = [Bool] type Bits64 = [Bool] instance Num [Bool] instance Bits [Bool] where [Bool] a xor :: [Bool] -> [Bool] -> [Bool] `xor` [Bool] b = (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith (\Bool x Bool y -> (Bool -> Bool not Bool x Bool -> Bool -> Bool && Bool y) Bool -> Bool -> Bool || (Bool x Bool -> Bool -> Bool && Bool -> Bool not Bool y)) [Bool] a [Bool] b) rotate :: [Bool] -> Int -> [Bool] rotate [Bool] bits Int rot = forall a. Int -> [a] -> [a] drop Int rot' [Bool] bits forall a. [a] -> [a] -> [a] ++ forall a. Int -> [a] -> [a] take Int rot' [Bool] bits where rot' :: Int rot' = Int rot forall a. Integral a => a -> a -> a `mod` (forall (t :: * -> *) a. Foldable t => t a -> Int length [Bool] bits) bitify :: Word64 -> Bits64 bitify :: Word64 -> [Bool] bitify Word64 w = forall a b. (a -> b) -> [a] -> [b] map (\Int b -> Word64 w forall a. Bits a => a -> a -> a .&. (forall a. Bits a => a -> Int -> a shiftL Word64 1 Int b) forall a. Eq a => a -> a -> Bool /= Word64 0) [Int 63,Int 62..Int 0] unbitify :: Bits64 -> Word64 unbitify :: [Bool] -> Word64 unbitify [Bool] bs = forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl (\Word64 i Bool b -> if Bool b then Word64 1 forall a. Num a => a -> a -> a + forall a. Bits a => a -> Int -> a shiftL Word64 i Int 1 else forall a. Bits a => a -> Int -> a shiftL Word64 i Int 1) Word64 0 [Bool] bs initial_permutation :: Bits64 -> Bits64 initial_permutation :: [Bool] -> [Bool] initial_permutation [Bool] mb = forall a b. (a -> b) -> [a] -> [b] map (forall a. [a] -> Int -> a (!!) [Bool] mb) [Int] i where i :: [Int] i = [Int 57, Int 49, Int 41, Int 33, Int 25, Int 17, Int 9, Int 1, Int 59, Int 51, Int 43, Int 35, Int 27, Int 19, Int 11, Int 3, Int 61, Int 53, Int 45, Int 37, Int 29, Int 21, Int 13, Int 5, Int 63, Int 55, Int 47, Int 39, Int 31, Int 23, Int 15, Int 7, Int 56, Int 48, Int 40, Int 32, Int 24, Int 16, Int 8, Int 0, Int 58, Int 50, Int 42, Int 34, Int 26, Int 18, Int 10, Int 2, Int 60, Int 52, Int 44, Int 36, Int 28, Int 20, Int 12, Int 4, Int 62, Int 54, Int 46, Int 38, Int 30, Int 22, Int 14, Int 6] key_transformation :: Bits64 -> Bits56 key_transformation :: [Bool] -> [Bool] key_transformation [Bool] kb = forall a b. (a -> b) -> [a] -> [b] map (forall a. [a] -> Int -> a (!!) [Bool] kb) [Int] i where i :: [Int] i = [Int 56, Int 48, Int 40, Int 32, Int 24, Int 16, Int 8, Int 0, Int 57, Int 49, Int 41, Int 33, Int 25, Int 17, Int 9, Int 1, Int 58, Int 50, Int 42, Int 34, Int 26, Int 18, Int 10, Int 2, Int 59, Int 51, Int 43, Int 35, Int 62, Int 54, Int 46, Int 38, Int 30, Int 22, Int 14, Int 6, Int 61, Int 53, Int 45, Int 37, Int 29, Int 21, Int 13, Int 5, Int 60, Int 52, Int 44, Int 36, Int 28, Int 20, Int 12, Int 4, Int 27, Int 19, Int 11, Int 3] des_enc :: Message -> Key -> Enc des_enc :: Word64 -> Word64 -> Word64 des_enc = [Int] -> Word64 -> Word64 -> Word64 do_des [Int 1,Int 2,Int 4,Int 6,Int 8,Int 10,Int 12,Int 14,Int 15,Int 17,Int 19,Int 21,Int 23,Int 25,Int 27,Int 28] des_dec :: Message -> Key -> Enc des_dec :: Word64 -> Word64 -> Word64 des_dec = [Int] -> Word64 -> Word64 -> Word64 do_des [Int 28,Int 27,Int 25,Int 23,Int 21,Int 19,Int 17,Int 15,Int 14,Int 12,Int 10,Int 8,Int 6,Int 4,Int 2,Int 1] do_des :: [Rotation] -> Message -> Key -> Enc do_des :: [Int] -> Word64 -> Word64 -> Word64 do_des [Int] rots Word64 m Word64 k = [Int] -> ([Bool], [Bool]) -> [Bool] -> Word64 des_work [Int] rots (forall a. Int -> [a] -> ([a], [a]) takeDrop Int 32 [Bool] mb) [Bool] kb where kb :: [Bool] kb = [Bool] -> [Bool] key_transformation forall a b. (a -> b) -> a -> b $ Word64 -> [Bool] bitify Word64 k mb :: [Bool] mb = [Bool] -> [Bool] initial_permutation forall a b. (a -> b) -> a -> b $ Word64 -> [Bool] bitify Word64 m des_work :: [Rotation] -> (Bits32, Bits32) -> Bits56 -> Enc des_work :: [Int] -> ([Bool], [Bool]) -> [Bool] -> Word64 des_work [] ([Bool] ml, [Bool] mr) [Bool] _ = [Bool] -> Word64 unbitify forall a b. (a -> b) -> a -> b $ [Bool] -> [Bool] final_perm forall a b. (a -> b) -> a -> b $ ([Bool] mr forall a. [a] -> [a] -> [a] ++ [Bool] ml) des_work (Int r:[Int] rs) ([Bool], [Bool]) mb [Bool] kb = [Int] -> ([Bool], [Bool]) -> [Bool] -> Word64 des_work [Int] rs ([Bool], [Bool]) mb' [Bool] kb where mb' :: ([Bool], [Bool]) mb' = Int -> ([Bool], [Bool]) -> [Bool] -> ([Bool], [Bool]) do_round Int r ([Bool], [Bool]) mb [Bool] kb do_round :: Rotation -> (Bits32, Bits32) -> Bits56 -> (Bits32, Bits32) do_round :: Int -> ([Bool], [Bool]) -> [Bool] -> ([Bool], [Bool]) do_round Int r ([Bool] ml, [Bool] mr) [Bool] kb = ([Bool] mr, [Bool] m') where kb' :: [Bool] kb' = [Bool] -> Int -> [Bool] get_key [Bool] kb Int r comp_kb :: [Bool] comp_kb = [Bool] -> [Bool] compression_permutation [Bool] kb' expa_mr :: [Bool] expa_mr = [Bool] -> [Bool] expansion_permutation [Bool] mr res :: [Bool] res = [Bool] comp_kb forall a. Bits a => a -> a -> a `xor` [Bool] expa_mr res' :: [([Bool], [Bool])] res' = forall a. [a] -> [a] tail forall a b. (a -> b) -> a -> b $ forall a. (a -> a) -> a -> [a] iterate (forall {a} {a}. Int -> (a, [a]) -> ([a], [a]) trans Int 6) ([], [Bool] res) trans :: Int -> (a, [a]) -> ([a], [a]) trans Int n (a _, [a] b) = (forall a. Int -> [a] -> [a] take Int n [a] b, forall a. Int -> [a] -> [a] drop Int n [a] b) res_s :: [Bool] res_s = forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat forall a b. (a -> b) -> a -> b $ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith (\[Bool] -> [Bool] f ([Bool] x,[Bool] _) -> [Bool] -> [Bool] f [Bool] x) [[Bool] -> [Bool] s_box_1, [Bool] -> [Bool] s_box_2, [Bool] -> [Bool] s_box_3, [Bool] -> [Bool] s_box_4, [Bool] -> [Bool] s_box_5, [Bool] -> [Bool] s_box_6, [Bool] -> [Bool] s_box_7, [Bool] -> [Bool] s_box_8] [([Bool], [Bool])] res' res_p :: [Bool] res_p = [Bool] -> [Bool] p_box [Bool] res_s m' :: [Bool] m' = [Bool] res_p forall a. Bits a => a -> a -> a `xor` [Bool] ml get_key :: Bits56 -> Rotation -> Bits56 get_key :: [Bool] -> Int -> [Bool] get_key [Bool] kb Int r = [Bool] kb' where ([Bool] kl, [Bool] kr) = forall a. Int -> [a] -> ([a], [a]) takeDrop Int 28 [Bool] kb kb' :: [Bool] kb' = forall a. Bits a => a -> Int -> a rotateL [Bool] kl Int r forall a. [a] -> [a] -> [a] ++ forall a. Bits a => a -> Int -> a rotateL [Bool] kr Int r compression_permutation :: Bits56 -> Bits48 compression_permutation :: [Bool] -> [Bool] compression_permutation [Bool] kb = forall a b. (a -> b) -> [a] -> [b] map (forall a. [a] -> Int -> a (!!) [Bool] kb) [Int] i where i :: [Int] i = [Int 13, Int 16, Int 10, Int 23, Int 0, Int 4, Int 2, Int 27, Int 14, Int 5, Int 20, Int 9, Int 22, Int 18, Int 11, Int 3, Int 25, Int 7, Int 15, Int 6, Int 26, Int 19, Int 12, Int 1, Int 40, Int 51, Int 30, Int 36, Int 46, Int 54, Int 29, Int 39, Int 50, Int 44, Int 32, Int 47, Int 43, Int 48, Int 38, Int 55, Int 33, Int 52, Int 45, Int 41, Int 49, Int 35, Int 28, Int 31] expansion_permutation :: Bits32 -> Bits48 expansion_permutation :: [Bool] -> [Bool] expansion_permutation [Bool] mb = forall a b. (a -> b) -> [a] -> [b] map (forall a. [a] -> Int -> a (!!) [Bool] mb) [Int] i where i :: [Int] i = [Int 31, Int 0, Int 1, Int 2, Int 3, Int 4, Int 3, Int 4, Int 5, Int 6, Int 7, Int 8, Int 7, Int 8, Int 9, Int 10, Int 11, Int 12, Int 11, Int 12, Int 13, Int 14, Int 15, Int 16, Int 15, Int 16, Int 17, Int 18, Int 19, Int 20, Int 19, Int 20, Int 21, Int 22, Int 23, Int 24, Int 23, Int 24, Int 25, Int 26, Int 27, Int 28, Int 27, Int 28, Int 29, Int 30, Int 31, Int 0] s_box :: [[Word8]] -> Bits6 -> Bits4 s_box :: [[Word8]] -> [Bool] -> [Bool] s_box [[Word8]] s [Bool a,Bool b,Bool c,Bool d,Bool e,Bool f] = forall {t} {t}. (Eq t, Bits t, Num t, Num t) => t -> t -> [Bool] to_bool Integer 4 forall a b. (a -> b) -> a -> b $ ([[Word8]] s forall a. [a] -> Int -> a !! Int row) forall a. [a] -> Int -> a !! Int col where row :: Int row = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a sum forall a b. (a -> b) -> a -> b $ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith Bool -> Integer -> Int numericise [Bool a,Bool f] [Integer 1, Integer 0] col :: Int col = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a sum forall a b. (a -> b) -> a -> b $ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith Bool -> Integer -> Int numericise [Bool b,Bool c,Bool d,Bool e] [Integer 3, Integer 2, Integer 1, Integer 0] numericise :: Bool -> Integer -> Int numericise = (\Bool x Integer y -> if Bool x then Int 2forall a b. (Num a, Integral b) => a -> b -> a ^Integer y else Int 0) to_bool :: t -> t -> [Bool] to_bool t 0 t _ = [] to_bool t n t i = ((t i forall a. Bits a => a -> a -> a .&. t 8) forall a. Eq a => a -> a -> Bool == t 8)forall a. a -> [a] -> [a] :t -> t -> [Bool] to_bool (t nforall a. Num a => a -> a -> a -t 1) (forall a. Bits a => a -> Int -> a shiftL t i Int 1) s_box_1 :: Bits6 -> Bits4 s_box_1 :: [Bool] -> [Bool] s_box_1 = [[Word8]] -> [Bool] -> [Bool] s_box [[Word8]] i where i :: [[Word8]] i = [[Word8 14, Word8 4, Word8 13, Word8 1, Word8 2, Word8 15, Word8 11, Word8 8, Word8 3, Word8 10, Word8 6, Word8 12, Word8 5, Word8 9, Word8 0, Word8 7], [ Word8 0, Word8 15, Word8 7, Word8 4, Word8 14, Word8 2, Word8 13, Word8 1, Word8 10, Word8 6, Word8 12, Word8 11, Word8 9, Word8 5, Word8 3, Word8 8], [ Word8 4, Word8 1, Word8 14, Word8 8, Word8 13, Word8 6, Word8 2, Word8 11, Word8 15, Word8 12, Word8 9, Word8 7, Word8 3, Word8 10, Word8 5, Word8 0], [Word8 15, Word8 12, Word8 8, Word8 2, Word8 4, Word8 9, Word8 1, Word8 7, Word8 5, Word8 11, Word8 3, Word8 14, Word8 10, Word8 0, Word8 6, Word8 13]] s_box_2 :: Bits6 -> Bits4 s_box_2 :: [Bool] -> [Bool] s_box_2 = [[Word8]] -> [Bool] -> [Bool] s_box [[Word8]] i where i :: [[Word8]] i = [[Word8 15, Word8 1, Word8 8, Word8 14, Word8 6, Word8 11, Word8 3, Word8 4, Word8 9, Word8 7, Word8 2, Word8 13, Word8 12, Word8 0, Word8 5, Word8 10], [Word8 3, Word8 13, Word8 4, Word8 7, Word8 15, Word8 2, Word8 8, Word8 14, Word8 12, Word8 0, Word8 1, Word8 10, Word8 6, Word8 9, Word8 11, Word8 5], [Word8 0, Word8 14, Word8 7, Word8 11, Word8 10, Word8 4, Word8 13, Word8 1, Word8 5, Word8 8, Word8 12, Word8 6, Word8 9, Word8 3, Word8 2, Word8 15], [Word8 13, Word8 8, Word8 10, Word8 1, Word8 3, Word8 15, Word8 4, Word8 2, Word8 11, Word8 6, Word8 7, Word8 12, Word8 0, Word8 5, Word8 14, Word8 9]] s_box_3 :: Bits6 -> Bits4 s_box_3 :: [Bool] -> [Bool] s_box_3 = [[Word8]] -> [Bool] -> [Bool] s_box [[Word8]] i where i :: [[Word8]] i = [[Word8 10, Word8 0, Word8 9, Word8 14 , Word8 6, Word8 3, Word8 15, Word8 5, Word8 1, Word8 13, Word8 12, Word8 7, Word8 11, Word8 4, Word8 2, Word8 8], [Word8 13, Word8 7, Word8 0, Word8 9, Word8 3, Word8 4, Word8 6, Word8 10, Word8 2, Word8 8, Word8 5, Word8 14, Word8 12, Word8 11, Word8 15, Word8 1], [Word8 13, Word8 6, Word8 4, Word8 9, Word8 8, Word8 15, Word8 3, Word8 0, Word8 11, Word8 1, Word8 2, Word8 12, Word8 5, Word8 10, Word8 14, Word8 7], [Word8 1, Word8 10, Word8 13, Word8 0, Word8 6, Word8 9, Word8 8, Word8 7, Word8 4, Word8 15, Word8 14, Word8 3, Word8 11, Word8 5, Word8 2, Word8 12]] s_box_4 :: Bits6 -> Bits4 s_box_4 :: [Bool] -> [Bool] s_box_4 = [[Word8]] -> [Bool] -> [Bool] s_box [[Word8]] i where i :: [[Word8]] i = [[Word8 7, Word8 13, Word8 14, Word8 3, Word8 0, Word8 6, Word8 9, Word8 10, Word8 1, Word8 2, Word8 8, Word8 5, Word8 11, Word8 12, Word8 4, Word8 15], [Word8 13, Word8 8, Word8 11, Word8 5, Word8 6, Word8 15, Word8 0, Word8 3, Word8 4, Word8 7, Word8 2, Word8 12, Word8 1, Word8 10, Word8 14, Word8 9], [Word8 10, Word8 6, Word8 9, Word8 0, Word8 12, Word8 11, Word8 7, Word8 13, Word8 15, Word8 1, Word8 3, Word8 14, Word8 5, Word8 2, Word8 8, Word8 4], [Word8 3, Word8 15, Word8 0, Word8 6, Word8 10, Word8 1, Word8 13, Word8 8, Word8 9, Word8 4, Word8 5, Word8 11, Word8 12, Word8 7, Word8 2, Word8 14]] s_box_5 :: Bits6 -> Bits4 s_box_5 :: [Bool] -> [Bool] s_box_5 = [[Word8]] -> [Bool] -> [Bool] s_box [[Word8]] i where i :: [[Word8]] i = [[Word8 2, Word8 12, Word8 4, Word8 1, Word8 7, Word8 10, Word8 11, Word8 6, Word8 8, Word8 5, Word8 3, Word8 15, Word8 13, Word8 0, Word8 14, Word8 9], [Word8 14, Word8 11, Word8 2, Word8 12, Word8 4, Word8 7, Word8 13, Word8 1, Word8 5, Word8 0, Word8 15, Word8 10, Word8 3, Word8 9, Word8 8, Word8 6], [Word8 4, Word8 2, Word8 1, Word8 11, Word8 10, Word8 13, Word8 7, Word8 8, Word8 15, Word8 9, Word8 12, Word8 5, Word8 6, Word8 3, Word8 0, Word8 14], [Word8 11, Word8 8, Word8 12, Word8 7, Word8 1, Word8 14, Word8 2, Word8 13, Word8 6, Word8 15, Word8 0, Word8 9, Word8 10, Word8 4, Word8 5, Word8 3]] s_box_6 :: Bits6 -> Bits4 s_box_6 :: [Bool] -> [Bool] s_box_6 = [[Word8]] -> [Bool] -> [Bool] s_box [[Word8]] i where i :: [[Word8]] i = [[Word8 12, Word8 1, Word8 10, Word8 15, Word8 9, Word8 2, Word8 6, Word8 8, Word8 0, Word8 13, Word8 3, Word8 4, Word8 14, Word8 7, Word8 5, Word8 11], [Word8 10, Word8 15, Word8 4, Word8 2, Word8 7, Word8 12, Word8 9, Word8 5, Word8 6, Word8 1, Word8 13, Word8 14, Word8 0, Word8 11, Word8 3, Word8 8], [Word8 9, Word8 14, Word8 15, Word8 5, Word8 2, Word8 8, Word8 12, Word8 3, Word8 7, Word8 0, Word8 4, Word8 10, Word8 1, Word8 13, Word8 11, Word8 6], [Word8 4, Word8 3, Word8 2, Word8 12, Word8 9, Word8 5, Word8 15, Word8 10, Word8 11, Word8 14, Word8 1, Word8 7, Word8 6, Word8 0, Word8 8, Word8 13]] s_box_7 :: Bits6 -> Bits4 s_box_7 :: [Bool] -> [Bool] s_box_7 = [[Word8]] -> [Bool] -> [Bool] s_box [[Word8]] i where i :: [[Word8]] i = [[Word8 4, Word8 11, Word8 2, Word8 14, Word8 15, Word8 0, Word8 8, Word8 13, Word8 3, Word8 12, Word8 9, Word8 7, Word8 5, Word8 10, Word8 6, Word8 1], [Word8 13, Word8 0, Word8 11, Word8 7, Word8 4, Word8 9, Word8 1, Word8 10, Word8 14, Word8 3, Word8 5, Word8 12, Word8 2, Word8 15, Word8 8, Word8 6], [Word8 1, Word8 4, Word8 11, Word8 13, Word8 12, Word8 3, Word8 7, Word8 14, Word8 10, Word8 15, Word8 6, Word8 8, Word8 0, Word8 5, Word8 9, Word8 2], [Word8 6, Word8 11, Word8 13, Word8 8, Word8 1, Word8 4, Word8 10, Word8 7, Word8 9, Word8 5, Word8 0, Word8 15, Word8 14, Word8 2, Word8 3, Word8 12]] s_box_8 :: Bits6 -> Bits4 s_box_8 :: [Bool] -> [Bool] s_box_8 = [[Word8]] -> [Bool] -> [Bool] s_box [[Word8]] i where i :: [[Word8]] i = [[Word8 13, Word8 2, Word8 8, Word8 4, Word8 6, Word8 15, Word8 11, Word8 1, Word8 10, Word8 9, Word8 3, Word8 14, Word8 5, Word8 0, Word8 12, Word8 7], [Word8 1, Word8 15, Word8 13, Word8 8, Word8 10, Word8 3, Word8 7, Word8 4, Word8 12, Word8 5, Word8 6, Word8 11, Word8 0, Word8 14, Word8 9, Word8 2], [Word8 7, Word8 11, Word8 4, Word8 1, Word8 9, Word8 12, Word8 14, Word8 2, Word8 0, Word8 6, Word8 10, Word8 13, Word8 15, Word8 3, Word8 5, Word8 8], [Word8 2, Word8 1, Word8 14, Word8 7, Word8 4, Word8 10, Word8 8, Word8 13, Word8 15, Word8 12, Word8 9, Word8 0, Word8 3, Word8 5, Word8 6, Word8 11]] p_box :: Bits32 -> Bits32 p_box :: [Bool] -> [Bool] p_box [Bool] kb = forall a b. (a -> b) -> [a] -> [b] map (forall a. [a] -> Int -> a (!!) [Bool] kb) [Int] i where i :: [Int] i = [Int 15, Int 6, Int 19, Int 20, Int 28, Int 11, Int 27, Int 16, Int 0, Int 14, Int 22, Int 25, Int 4, Int 17, Int 30, Int 9, Int 1, Int 7, Int 23, Int 13, Int 31, Int 26, Int 2, Int 8, Int 18, Int 12, Int 29, Int 5, Int 21, Int 10, Int 3, Int 24] final_perm :: Bits64 -> Bits64 final_perm :: [Bool] -> [Bool] final_perm [Bool] kb = forall a b. (a -> b) -> [a] -> [b] map (forall a. [a] -> Int -> a (!!) [Bool] kb) [Int] i where i :: [Int] i = [Int 39, Int 7, Int 47, Int 15, Int 55, Int 23, Int 63, Int 31, Int 38, Int 6, Int 46, Int 14, Int 54, Int 22, Int 62, Int 30, Int 37, Int 5, Int 45, Int 13, Int 53, Int 21, Int 61, Int 29, Int 36, Int 4, Int 44, Int 12, Int 52, Int 20, Int 60, Int 28, Int 35, Int 3, Int 43, Int 11, Int 51, Int 19, Int 59, Int 27, Int 34, Int 2, Int 42, Int 10, Int 50, Int 18, Int 58, Int 26, Int 33, Int 1, Int 41, Int 9, Int 49, Int 17, Int 57, Int 25, Int 32, Int 0, Int 40 , Int 8, Int 48, Int 16, Int 56, Int 24] takeDrop :: Int -> [a] -> ([a], [a]) takeDrop :: forall a. Int -> [a] -> ([a], [a]) takeDrop Int _ [] = ([], []) takeDrop Int 0 [a] xs = ([], [a] xs) takeDrop Int n (a x:[a] xs) = (a xforall a. a -> [a] -> [a] :[a] ys, [a] zs) where ([a] ys, [a] zs) = forall a. Int -> [a] -> ([a], [a]) takeDrop (Int nforall a. Num a => a -> a -> a -Int 1) [a] xs