1{-# LANGUAGE FlexibleInstances #-}
2
3-----------------------------------------------------------------------------
4-- |
5-- Module      :  Crypto.Cipher.DES.Primitive
6-- License     :  BSD-style
7--
8-- This module is copy of DES module from Crypto package.
9-- http://hackage.haskell.org/package/Crypto
10--
11-----------------------------------------------------------------------------
12
13
14module Crypto.Cipher.DES.Primitive
15    ( encrypt
16    , decrypt
17    , Block(..)
18    ) where
19
20import Data.Word
21import Data.Bits
22
23-- | a DES block (64 bits)
24newtype Block = Block { unBlock :: Word64 }
25
26type Rotation = Int
27type Key     = Word64
28
29type Bits4  = [Bool]
30type Bits6  = [Bool]
31type Bits32 = [Bool]
32type Bits48 = [Bool]
33type Bits56 = [Bool]
34type Bits64 = [Bool]
35
36desXor :: [Bool] -> [Bool] -> [Bool]
37desXor a b = zipWith (/=) a b
38
39desRotate :: [Bool] -> Int -> [Bool]
40desRotate bits rot = drop rot' bits ++ take rot' bits
41  where rot' = rot `mod` length bits
42
43bitify :: Word64 -> Bits64
44bitify w = map (\b -> w .&. (shiftL 1 b) /= 0) [63,62..0]
45
46unbitify :: Bits64 -> Word64
47unbitify bs = foldl (\i b -> if b then 1 + shiftL i 1 else shiftL i 1) 0 bs
48
49initial_permutation :: Bits64 -> Bits64
50initial_permutation mb = map ((!!) mb) i
51 where i = [57, 49, 41, 33, 25, 17,  9, 1, 59, 51, 43, 35, 27, 19, 11, 3,
52            61, 53, 45, 37, 29, 21, 13, 5, 63, 55, 47, 39, 31, 23, 15, 7,
53            56, 48, 40, 32, 24, 16,  8, 0, 58, 50, 42, 34, 26, 18, 10, 2,
54            60, 52, 44, 36, 28, 20, 12, 4, 62, 54, 46, 38, 30, 22, 14, 6]
55
56{-
57"\x39\x31\x29\x21\x19\x11\x09\x01\x3b\x33\x2b\x23\x1b\x13\
58\\x0b\x03\x3d\x35\x2d\x25\x1d\x15\x0d\x05\x3f\x37\x2f\x27\
59\\x1f\x17\x0f\x07\x38\x30\x28\x20\x18\x10\x08\x00\x3a\x32\
60\\x2a\x22\x1a\x12\x0a\x02\x3c\x34\x2c\x24\x1c\x14\x0c\x04\
61\\x3e\x36\x2e\x26\x1e\x16\x0e\x06"
62-}
63
64key_transformation :: Bits64 -> Bits56
65key_transformation kb = map ((!!) kb) i
66 where i = [56, 48, 40, 32, 24, 16,  8,  0, 57, 49, 41, 33, 25, 17,
67             9,  1, 58, 50, 42, 34, 26, 18, 10,  2, 59, 51, 43, 35,
68            62, 54, 46, 38, 30, 22, 14,  6, 61, 53, 45, 37, 29, 21,
69            13,  5, 60, 52, 44, 36, 28, 20, 12,  4, 27, 19, 11,  3]
70{-
71"\x38\x30\x28\x20\x18\x10\x08\x00\x39\x31\x29\x21\x19\x11\
72\\x09\x01\x3a\x32\x2a\x22\x1a\x12\x0a\x02\x3b\x33\x2b\x23\
73\\x3e\x36\x2e\x26\x1e\x16\x0e\x06\x3d\x35\x2d\x25\x1d\x15\
74\\x0d\x05\x3c\x34\x2c\x24\x1c\x14\x0c\x04\x1b\x13\x0b\x03"
75-}
76
77
78des_enc :: Block -> Key -> Block
79des_enc = do_des [1,2,4,6,8,10,12,14,15,17,19,21,23,25,27,28]
80
81des_dec :: Block -> Key -> Block
82des_dec = do_des [28,27,25,23,21,19,17,15,14,12,10,8,6,4,2,1]
83
84do_des :: [Rotation] -> Block -> Key -> Block
85do_des rots (Block m) k = Block $ des_work rots (takeDrop 32 mb) kb
86 where kb = key_transformation $ bitify k
87       mb = initial_permutation $ bitify m
88
89des_work :: [Rotation] -> (Bits32, Bits32) -> Bits56 -> Word64
90des_work [] (ml, mr) _ = unbitify $ final_perm $ (mr ++ ml)
91des_work (r:rs) mb kb = des_work rs mb' kb
92 where mb' = do_round r mb kb
93
94do_round :: Rotation -> (Bits32, Bits32) -> Bits56 -> (Bits32, Bits32)
95do_round r (ml, mr) kb = (mr, m')
96 where kb' = get_key kb r
97       comp_kb = compression_permutation kb'
98       expa_mr = expansion_permutation mr
99       res = comp_kb `desXor` expa_mr
100       res' = tail $ iterate (trans 6) ([], res)
101       trans n (_, b) = (take n b, drop n b)
102       res_s = concat $ zipWith (\f (x,_) -> f x) [s_box_1, s_box_2,
103                                                   s_box_3, s_box_4,
104                                                   s_box_5, s_box_6,
105                                                   s_box_7, s_box_8] res'
106       res_p = p_box res_s
107       m' = res_p `desXor` ml
108
109get_key :: Bits56 -> Rotation -> Bits56
110get_key kb r = kb'
111 where (kl, kr) = takeDrop 28 kb
112       kb' = desRotate kl r ++ desRotate kr r
113
114compression_permutation :: Bits56 -> Bits48
115compression_permutation kb = map ((!!) kb) i
116 where i = [13, 16, 10, 23,  0,  4,  2, 27, 14,  5, 20,  9,
117            22, 18, 11,  3, 25,  7, 15,  6, 26, 19, 12,  1,
118            40, 51, 30, 36, 46, 54, 29, 39, 50, 44, 32, 47,
119            43, 48, 38, 55, 33, 52, 45, 41, 49, 35, 28, 31]
120
121expansion_permutation :: Bits32 -> Bits48
122expansion_permutation mb = map ((!!) mb) i
123 where i = [31,  0,  1,  2,  3,  4,  3,  4,  5,  6,  7,  8,
124             7,  8,  9, 10, 11, 12, 11, 12, 13, 14, 15, 16,
125            15, 16, 17, 18, 19, 20, 19, 20, 21, 22, 23, 24,
126            23, 24, 25, 26, 27, 28, 27, 28, 29, 30, 31,  0]
127
128s_box :: [[Word8]] -> Bits6 -> Bits4
129s_box s [a,b,c,d,e,f] = to_bool 4 $ (s !! row) !! col
130 where row = sum $ zipWith numericise [a,f]     [1, 0]
131       col = sum $ zipWith numericise [b,c,d,e] [3, 2, 1, 0]
132       numericise :: Bool -> Int -> Int
133       numericise = (\x y -> if x then 2^y else 0)
134
135       to_bool :: Int -> Word8 -> [Bool]
136       to_bool 0 _ = []
137       to_bool n i = ((i .&. 8) == 8):to_bool (n-1) (shiftL i 1)
138s_box _ _             = error "DES: internal error bits6 more than 6 elements"
139
140s_box_1 :: Bits6 -> Bits4
141s_box_1 = s_box i
142 where i = [[14,  4, 13,  1,  2, 15, 11,  8,  3, 10,  6, 12,  5,  9,  0,  7],
143            [ 0, 15,  7,  4, 14,  2, 13,  1, 10,  6, 12, 11,  9,  5,  3,  8],
144            [ 4,  1, 14,  8, 13,  6,  2, 11, 15, 12,  9,  7,  3, 10,  5,  0],
145            [15, 12,  8,  2,  4,  9,  1,  7,  5, 11,  3, 14, 10,  0,  6, 13]]
146
147s_box_2 :: Bits6 -> Bits4
148s_box_2 = s_box i
149 where i = [[15,  1,  8, 14,  6, 11,  3,  4,  9,  7,  2, 13, 12,  0,  5, 10],
150            [3,  13,  4,  7, 15,  2,  8, 14, 12,  0,  1, 10,  6,  9,  11, 5],
151            [0,  14,  7, 11, 10,  4, 13,  1,  5,  8, 12,  6,  9,  3,  2, 15],
152            [13,  8, 10,  1,  3, 15,  4,  2, 11,  6,  7, 12,  0,  5,  14, 9]]
153
154s_box_3 :: Bits6 -> Bits4
155s_box_3 = s_box i
156 where i = [[10,  0,  9, 14 , 6,  3, 15,  5,  1, 13, 12,  7, 11,  4,  2,  8],
157            [13,  7,  0,  9,  3,  4,  6, 10,  2,  8,  5, 14, 12, 11, 15,  1],
158            [13,  6,  4,  9,  8, 15,  3,  0, 11,  1,  2, 12,  5, 10, 14,  7],
159            [1,  10, 13,  0,  6,  9,  8,  7,  4, 15, 14,  3, 11,  5,  2, 12]]
160
161s_box_4 :: Bits6 -> Bits4
162s_box_4 = s_box i
163 where i = [[7,  13, 14,  3,  0,  6,  9, 10,  1,  2,  8,  5, 11, 12,  4, 15],
164            [13,  8, 11,  5,  6, 15,  0,  3,  4,  7,  2, 12,  1, 10, 14,  9],
165            [10,  6,  9,  0, 12, 11,  7, 13, 15,  1,  3, 14,  5,  2,  8,  4],
166            [3,  15,  0,  6, 10,  1, 13,  8,  9,  4,  5, 11, 12,  7,  2, 14]]
167
168s_box_5 :: Bits6 -> Bits4
169s_box_5 = s_box i
170 where i = [[2,  12,  4,  1,  7, 10, 11,  6,  8,  5,  3, 15, 13,  0, 14,  9],
171            [14, 11,  2, 12,  4,  7, 13,  1,  5,  0, 15, 10,  3,  9,  8,  6],
172            [4,   2,  1, 11, 10, 13,  7,  8, 15,  9, 12,  5,  6,  3,  0, 14],
173            [11,  8, 12,  7,  1, 14,  2, 13,  6, 15,  0,  9, 10,  4,  5,  3]]
174
175s_box_6 :: Bits6 -> Bits4
176s_box_6 = s_box i
177 where i = [[12,  1, 10, 15,  9,  2,  6,  8,  0, 13,  3,  4, 14,  7,  5, 11],
178            [10, 15,  4,  2,  7, 12,  9,  5,  6,  1, 13, 14,  0, 11,  3,  8],
179            [9,  14, 15,  5,  2,  8, 12,  3,  7,  0,  4, 10,  1, 13, 11,  6],
180            [4,  3,   2, 12,  9,  5, 15, 10, 11, 14,  1,  7,  6,  0,  8, 13]]
181
182s_box_7 :: Bits6 -> Bits4
183s_box_7 = s_box i
184 where i = [[4,  11,  2, 14, 15,  0,  8, 13,  3, 12,  9,  7,  5, 10,  6,  1],
185            [13, 0,  11,  7,  4,  9,  1, 10, 14,  3,  5, 12,  2, 15,  8,  6],
186            [1,  4,  11, 13, 12,  3,  7, 14, 10, 15,  6,  8,  0,  5,  9,  2],
187            [6,  11, 13,  8,  1,  4, 10,  7,  9,  5,  0, 15, 14,  2,  3, 12]]
188
189s_box_8 :: Bits6 -> Bits4
190s_box_8 = s_box i
191 where i = [[13,  2,  8,  4,  6, 15, 11,  1, 10,  9,  3, 14,  5,  0, 12,  7],
192            [1,  15, 13,  8, 10,  3,  7,  4, 12,  5,  6, 11,  0, 14,  9,  2],
193            [7,  11,  4,  1,  9, 12, 14,  2,  0,  6, 10, 13, 15,  3,  5,  8],
194            [2,   1, 14,  7,  4, 10,  8, 13, 15, 12,  9,  0,  3,  5,  6, 11]]
195
196p_box :: Bits32 -> Bits32
197p_box kb = map ((!!) kb) i
198 where i = [15, 6, 19, 20, 28, 11, 27, 16,  0, 14, 22, 25,  4, 17, 30,  9,
199             1, 7, 23, 13, 31, 26,  2,  8, 18, 12, 29,  5, 21, 10,  3, 24]
200
201final_perm :: Bits64 -> Bits64
202final_perm kb = map ((!!) kb) i
203 where i = [39, 7, 47, 15, 55, 23, 63, 31, 38, 6, 46, 14, 54, 22, 62, 30,
204            37, 5, 45, 13, 53, 21, 61, 29, 36, 4, 44, 12, 52, 20, 60, 28,
205            35, 3, 43, 11, 51, 19, 59, 27, 34, 2, 42, 10, 50, 18, 58, 26,
206            33, 1, 41,  9, 49, 17, 57, 25, 32, 0, 40 , 8, 48, 16, 56, 24]
207
208takeDrop :: Int -> [a] -> ([a], [a])
209takeDrop _ [] = ([], [])
210takeDrop 0 xs = ([], xs)
211takeDrop n (x:xs) = (x:ys, zs)
212 where (ys, zs) = takeDrop (n-1) xs
213
214
215-- | Basic DES encryption which takes a key and a block of plaintext
216-- and returns the encrypted block of ciphertext according to the standard.
217encrypt :: Word64 -> Block -> Block
218encrypt = flip des_enc
219
220-- | Basic DES decryption which takes a key and a block of ciphertext and
221-- returns the decrypted block of plaintext according to the standard.
222decrypt :: Word64 -> Block -> Block
223decrypt = flip des_dec
224