module Codec.Encryption.Twofish
(
Key
,TwofishCipher
,mkStdCipher
,mkCipher
,q0o
,q1o
) where
import Data.Array.Unboxed hiding (index)
import Data.Bits
import Data.Cipher
import Data.LargeWord
import Data.Word
import Prelude hiding (length, drop, reverse, take)
import qualified Prelude as P
class (Bits a, Integral a) => Key a where
keyByte :: a -> Int -> Word8
keyByte w n = let w' = fromIntegral w :: Integer
in fromIntegral $ (w' `shiftR` (8 * n)) .&. 0xff
instance Key Word128
instance Key Word192
instance Key Word256
data TwofishCipher = C { eb :: Block -> Block, db :: Block -> Block }
instance Cipher Word128 TwofishCipher where
encrypt c = liftCryptor (eb c)
decrypt c = liftCryptor (db c)
liftCryptor :: (Block -> Block) -> Word128 -> Word128
liftCryptor c = deBlock . c . mkBlock
type Block = (Word32, Word32, Word32, Word32)
mkBlock :: Word128 -> Block
mkBlock b =
let b' = fromIntegral b :: Integer
w0 = b' .&. 0xffffffff
w1 = (b' `shiftR` 32) .&. 0xffffffff
w2 = (b' `shiftR` 64) .&. 0xffffffff
w3 = (b' `shiftR` 96) .&. 0xffffffff
in (fromIntegral w0, fromIntegral w1,
fromIntegral w2, fromIntegral w3)
deBlock :: Block -> Word128
deBlock (w0, w1, w2, w3) =
let w0' = fromIntegral w0
w1' = fromIntegral w1
w2' = fromIntegral w2
w3' = fromIntegral w3
in w0' .|. (w1' `shiftL` 32) .|. (w2' `shiftL` 64) .|.
(w3' `shiftL` 96)
mkStdCipher :: (Key a) => a -> TwofishCipher
mkStdCipher = mkCipher 16
mkCipher :: (Key a) => Int -> a -> TwofishCipher
mkCipher numRounds key =
let s = mkS key
h = mkfH key
k = mkK key numRounds h
g = mkG h s
in C { eb = \(p0, p1, p2, p3) ->
let w = (p0 `xor` k 0, p1 `xor` k 1,
p2 `xor` k 2, p3 `xor` k 3)
(r0, r1, r2, r3) = encryptRounds g k numRounds w
c0 = r2 `xor` k 4
c1 = r3 `xor` k 5
c2 = r0 `xor` k 6
c3 = r1 `xor` k 7
in (c0, c1, c2, c3)
,db = \(c0, c1, c2, c3) ->
let w = (c0 `xor` k 4, c1 `xor` k 5,
c2 `xor` k 6, c3 `xor` k 7)
(r0, r1, r2, r3) = decryptRounds g k numRounds w
p0 = r2 `xor` k 0
p1 = r3 `xor` k 1
p2 = r0 `xor` k 2
p3 = r1 `xor` k 3
in (p0, p1, p2, p3) }
encryptRounds :: GFunc -> KIndexor -> Int -> Block -> Block
encryptRounds g k n b = foldl roundT b [0..(n1)]
where roundT :: Block -> Int -> Block
roundT (r0, r1, r2, r3) r =
let t0 = g r0
t1 = g (r1 `rotateL` 8)
f0 = t0 + t1 + k (2 * r + 8)
f1 = t0 + 2 * t1 + k (2 * r + 9)
r0' = (r2 `xor` f0) `rotateR` 1
r1' = (r3 `rotateL` 1) `xor` f1
r2' = r0
r3' = r1
in (r0', r1', r2', r3')
decryptRounds :: GFunc -> KIndexor -> Int -> Block -> Block
decryptRounds g k n b = foldr roundT b [0..(n1)]
where roundT :: Int -> Block -> Block
roundT r (r0, r1, r2, r3) =
let t0 = g r0
t1 = g (r1 `rotateL` 8)
f0 = t0 + t1 + k (2 * r + 8)
f1 = t0 + 2 * t1 + k (2 * r + 9)
r0' = (r2 `rotateL` 1) `xor` f0
r1' = (r3 `xor` f1) `rotateR` 1
r2' = r0
r3' = r1
in (r0', r1', r2', r3')
type WordVector = UArray Int Word32
type HFunc = Word32 -> WordVector -> Word32
type GFunc = Word32 -> Word32
type SVector = WordVector
type KIndexor = Int -> Word32
fK :: (Key a) => a -> Int
fK key = bitSize key `div` 64
mkG :: HFunc -> SVector -> GFunc
mkG h s x = h x s
mkS :: (Key a) => a -> SVector
mkS key = reverse . mkVector $ [s i | i <- [0..(k 1)]]
where s :: Int -> Word32
s i = rs (selectWord (\j -> 8 * i + j) key)
(selectWord (\j -> 8 * i + j + 4) key)
k = fK key
reverse :: WordVector -> WordVector
reverse = mkVector . P.reverse . elems
mkVector :: [Word32] -> WordVector
mkVector w = listArray (0, P.length w 1) w
mkK :: (Key a) => a -> Int -> HFunc -> KIndexor
mkK key n fH =
let me = mkVector [m i | i <- [0..(2 * k 2)], even i]
mo = mkVector [m i | i <- [1..(2 * k 1)], odd i]
ks = mkVector [getK me mo i | i <- [0..(8 + (n * 2) 1)]]
in (ks !)
where getK :: WordVector -> WordVector -> Int -> Word32
getK me mo i
| even i = ai me (ie i) + bi mo (ie i)
| otherwise = (ai me (io i) + 2 * bi mo (io i)) `rotateL` 9
ie i = i `div` 2
io i = (i 1) `div` 2
ai :: WordVector -> Int -> Word32
ai me i = fH (2 * fromIntegral i * rho) me
bi :: WordVector -> Int -> Word32
bi mo i = fH ((2 * fromIntegral i + 1) * rho) mo `rotateL` 8
m i = selectWord (\j -> 4 * i + j) key
k = fK key
mkfH :: (Key a) => a -> HFunc
mkfH key = let k = fK key
q0 = (q0c !)
q1 = (q1c !)
mxX = mkMdsX
mxY = mkMdsY
in fHGenerator q0 q1 mxX mxY k
fHGenerator :: (Word8 -> Word8) -> (Word8 -> Word8) -> ByteVector -> ByteVector -> Int -> Word32 -> WordVector -> Word32
fHGenerator q0 q1 mxX mxY k x l = mds mxX mxY (y0, y1, y2, y3)
where y0 = q1 $ q0 (q0 (yij 2 0) `xor` lij 1 0) `xor` lij 0 0
y1 = q0 $ q0 (q1 (yij 2 1) `xor` lij 1 1) `xor` lij 0 1
y2 = q1 $ q1 (q0 (yij 2 2) `xor` lij 1 2) `xor` lij 0 2
y3 = q0 $ q1 (q1 (yij 2 3) `xor` lij 1 3) `xor` lij 0 3
yij :: Int -> Int -> Word8
yij 3 j
| k == 4 = let qx = if j `elem` [0, 3] then q1 else q0
in qx (yij 4 j) `xor` lij 3 j
| otherwise = xj j
yij 2 j
| k >= 3 = let qx = if j `elem` [0, 1] then q1 else q0
in qx (yij 3 j) `xor` lij 2 j
| otherwise = xj j
yij _ j = xj j
xj :: Int -> Word8
xj = byteN x
lij :: Int -> Int -> Word8
lij i = byteN (l ! i)
mds :: ByteVector -> ByteVector -> (Word8, Word8, Word8, Word8) -> Word32
mds mxX mxY (x0, x1, x2, x3) =
let r0 = x0 `xor` (mxY ! x1) `xor` (mxX ! x2) `xor` (mxX ! x3)
r1 = (mxX ! x0) `xor` (mxY ! x1) `xor` (mxY ! x2) `xor` x3
r2 = (mxY ! x0) `xor` (mxX ! x1) `xor` x2 `xor` (mxY ! x3)
r3 = (mxY ! x0) `xor` x1 `xor` (mxY ! x2) `xor` (mxX ! x3)
in fromIntegral r0 .|. (fromIntegral r1 `shiftL` 8) .|.
(fromIntegral r2 `shiftL` 16) .|. (fromIntegral r3 `shiftL` 24)
mkMdsX :: ByteVector
mkMdsX = mkByteVector $ map f [0..255]
where f x = x `xor` case (x .&. 0x03) of
1 -> (x `shiftR` 2) `xor` 0x5a
2 -> (x `shiftR` 2) `xor` 0xb4
3 -> (x `shiftR` 2) `xor` 0xee
_ -> (x `shiftR` 2)
mkMdsY :: ByteVector
mkMdsY = mkByteVector $ map f [0..255]
where f x = x `xor` (x `shiftR` 2) `xor` case (x .&. 0x03) of
1 -> (x `shiftR` 1) `xor` 0xee
2 -> (x `shiftR` 1) `xor` 0xb4
3 -> (x `shiftR` 1) `xor` 0x5a
_ -> (x `shiftR` 1)
rs :: Word32 -> Word32 -> Word32
rs k0 k1 =
rsRem4 (rsRem4 k1 `xor` k0)
where rsRem4 = rsRem . rsRem . rsRem .rsRem
rsRem :: Word32 -> Word32
rsRem x = let b = x `shiftR` 24
g2 = case b .&. 0x80 of
0 -> (b `shiftL` 1) .&. 0xff
_ -> ((b `shiftL` 1) `xor` 0x14d) .&. 0xff
g3 = case b .&. 1 of
0 -> ((b `shiftR` 1) .&. 0x7f) `xor` g2
_ -> ((b `shiftR` 1) .&. 0x7f) `xor` (0x14d `shiftR` 1) `xor` g2
in (x `shiftL` 8) `xor` (g3 `shiftL` 24) `xor` (g2 `shiftL` 16) `xor`
(g3 `shiftL` 8) `xor` b
rho :: Word32
rho = 0x1010101
selectWord :: (Key a) => (Int -> Int) -> a -> Word32
selectWord f b = let b0 = select $ f 0
b1 = select $ f 1
b2 = select $ f 2
b3 = select $ f 3
in b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|.
(b3 `shiftL` 24)
where select i = fromIntegral $ keyByte b i
byteN :: (Integral a, Bits a) => a -> Int -> Word8
byteN w n = let s = fromIntegral (n `shiftL` 3)
in fromIntegral $ (w .&. (0xff `shiftL` s)) `shiftR` s
type ByteVector = UArray Word8 Word8
mkByteVector :: [Word8] -> ByteVector
mkByteVector = listArray (0, 255)
q0c :: ByteVector
q0c = mkByteVector [169,103,179,232,4,253,163,118,154,146,128,120,228,221,209,56,13,198,53,152,24,247,236,108,67,117,55,38,250,19,148,72,242,208,139,48,132,84,223,35,25,91,61,89,243,174,162,130,99,1,131,46,217,81,155,124,166,235,165,190,22,12,227,97,192,140,58,245,115,44,37,11,187,78,137,107,83,106,180,241,225,230,189,69,226,244,182,102,204,149,3,86,212,28,30,215,251,195,142,181,233,207,191,186,234,119,57,175,51,201,98,113,129,121,9,173,36,205,249,216,229,197,185,77,68,8,134,231,161,29,170,237,6,112,178,210,65,123,160,17,49,194,39,144,32,246,96,255,150,92,177,171,158,156,82,27,95,147,10,239,145,133,73,238,45,79,143,59,71,135,109,70,214,62,105,100,42,206,203,47,252,151,5,122,172,127,213,26,75,14,167,90,40,20,63,41,136,60,76,2,184,218,176,23,85,31,138,125,87,199,141,116,183,196,159,114,126,21,34,18,88,7,153,52,110,80,222,104,101,188,219,248,200,168,43,64,220,254,50,164,202,16,33,240,211,93,15,0,111,157,54,66,74,94,193,224]
q1c :: ByteVector
q1c = mkByteVector [117,243,198,244,219,123,251,200,74,211,230,107,69,125,232,75,214,50,216,253,55,113,241,225,48,15,248,27,135,250,6,63,94,186,174,91,138,0,188,157,109,193,177,14,128,93,210,213,160,132,7,20,181,144,44,163,178,115,76,84,146,116,54,81,56,176,189,90,252,96,98,150,108,66,247,16,124,40,39,140,19,149,156,199,36,70,59,112,202,227,133,203,17,208,147,184,166,131,32,255,159,119,195,204,3,111,8,191,64,231,43,226,121,12,170,130,65,58,234,185,228,154,164,151,126,218,122,23,102,148,161,29,61,240,222,179,11,114,167,28,239,209,83,62,143,51,38,95,236,118,42,73,129,136,238,33,196,26,235,217,197,57,153,205,173,49,139,1,24,35,221,31,78,45,249,72,79,242,101,142,120,92,88,25,141,229,152,87,103,127,5,100,175,99,182,254,245,183,60,165,206,233,104,68,224,77,67,105,41,46,172,21,89,168,10,158,110,71,223,52,53,106,207,220,34,201,192,155,137,212,237,171,18,162,13,82,187,2,47,169,215,97,30,180,80,4,246,194,22,37,134,86,85,9,190,145]
q0o :: Word8 -> Word8
q0o = let t0 = mkByteVector [0x8, 0x1, 0x7, 0xD, 0x6, 0xF, 0x3, 0x2,
0x0, 0xB, 0x5, 0x9, 0xE, 0xC, 0xA, 0x4]
t1 = mkByteVector [0xE, 0xC, 0xB, 0x8, 0x1, 0x2, 0x3, 0x5,
0xF, 0x4, 0xA, 0x6, 0x7, 0x0, 0x9, 0xD]
t2 = mkByteVector [0xB, 0xA, 0x5, 0xE, 0x6, 0xD, 0x9, 0x0,
0xC, 0x8, 0xF, 0x3, 0x2, 0x4, 0x7, 0x1]
t3 = mkByteVector [0xD, 0x7, 0xF, 0x4, 0x1, 0x2, 0x6, 0xE,
0x9, 0xB, 0x3, 0x0, 0x8, 0x5, 0xC, 0xA]
in q t0 t1 t2 t3
q1o :: Word8 -> Word8
q1o = let t0 = mkByteVector [0x2, 0x8, 0xB, 0xD, 0xF, 0x7, 0x6, 0xE,
0x3, 0x1, 0x9, 0x4, 0x0, 0xA, 0xC, 0x5]
t1 = mkByteVector [0x1, 0xE, 0x2, 0xB, 0x4, 0xC, 0x3, 0x7,
0x6, 0xD, 0xA, 0x5, 0xF, 0x9, 0x0, 0x8]
t2 = mkByteVector [0x4, 0xC, 0x7, 0x5, 0x1, 0x6, 0x9, 0xA,
0x0, 0xE, 0xD, 0x8, 0x2, 0xB, 0x3, 0xF]
t3 = mkByteVector [0xB, 0x9, 0x5, 0x1, 0xC, 0x3, 0xD, 0xE,
0x6, 0x4, 0x7, 0xF, 0x2, 0x0, 0x8, 0xA]
in q t0 t1 t2 t3
q :: ByteVector -> ByteVector -> ByteVector -> ByteVector -> Word8 -> Word8
q t0 t1 t2 t3 x = 16 * b4 + a4
where a0 = x `div` 16
b0 = x `mod` 16
a1 = a0 `xor` b0
b1 = a0 `xor` ror4 b0 1 `xor` (8 * a0) `mod` 16
a2 = t0 ! a1
b2 = t1 ! b1
a3 = a2 `xor` b2
b3 = a2 `xor` ror4 b2 1 `xor` (8 * a2) `mod` 16
a4 = t2 ! a3
b4 = t3 ! b3
ror4 :: Word8 -> Int -> Word8
ror4 x n = ((x .&. 0xf) `shiftR` n) .|. ((x .&. 1) `shiftL` 3)