module Crypto.Modes
(
IV
, getIV, getIVIO, zeroIV
, incIV, dblIV
, ecb, unEcb
, cbc, unCbc
, cfb, unCfb
, ofb, unOfb
, ecb', unEcb'
, cbc', unCbc'
, cfb', unCfb'
, ofb', unOfb'
, ctr, unCtr, ctr', unCtr'
, siv, unSiv, siv', unSiv'
, cbcMac', cbcMac, cMac, cMac'
) where
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.Serialize
import qualified Data.Serialize.Put as SP
import qualified Data.Serialize.Get as SG
import Data.Bits (xor, shift, (.&.), (.|.), testBit, setBit, clearBit, Bits, complementBit)
import Data.Tagged
import Crypto.Classes
import Crypto.Random
import Crypto.Util
import Crypto.CPoly
import System.Crypto.Random (getEntropy)
import Control.Monad (liftM, forM_)
import Data.List (genericDrop)
import Data.Word (Word8)
import Data.List (genericDrop,genericReplicate,genericLength)
#if MIN_VERSION_tagged(0,2,0)
import Data.Proxy
#endif
data IV k = IV { initializationVector :: !B.ByteString } deriving (Eq, Ord, Show)
collect :: Int -> [B.ByteString] -> [B.ByteString]
collect 0 _ = []
collect _ [] = []
collect i (b:bs)
| len < i = b : collect (i len) bs
| len >= i = [B.take i b]
where
len = B.length b
chunkFor :: (BlockCipher k) => k -> L.ByteString -> [B.ByteString]
chunkFor k = go
where
blkSz = (blockSize `for` k) `div` 8
blkSzI = fromIntegral blkSz
go bs | L.length bs < blkSzI = []
| otherwise = let (blk,rest) = L.splitAt blkSzI bs in B.concat (L.toChunks blk) : go rest
chunkFor' :: (BlockCipher k) => k -> B.ByteString -> [B.ByteString]
chunkFor' k = go
where
blkSz = (blockSize `for` k) `div` 8
go bs | B.length bs < blkSz = []
| otherwise = let (blk,rest) = B.splitAt blkSz bs in blk : go rest
zwp :: L.ByteString -> L.ByteString -> L.ByteString
zwp a b =
let as = L.toChunks a
bs = L.toChunks b
in L.fromChunks (go as bs)
where
go [] _ = []
go _ [] = []
go (a:as) (b:bs) =
let l = min (B.length a) (B.length b)
(a',ar) = B.splitAt l a
(b',br) = B.splitAt l b
as' = if B.length ar == 0 then as else ar : as
bs' = if B.length br == 0 then bs else br : bs
in (zwp' a' b') : go as' bs'
zwp' :: B.ByteString -> B.ByteString -> B.ByteString
zwp' a = B.pack . B.zipWith xor a
cbc' :: BlockCipher k => k -> IV k -> B.ByteString -> (B.ByteString, IV k)
cbc' k (IV v) plaintext =
let blks = chunkFor' k plaintext
(cts, iv) = go blks v
in (B.concat cts, IV iv)
where
go [] iv = ([], iv)
go (b:bs) iv =
let c = encryptBlock k (zwp' iv b)
(cs, ivFinal) = go bs c
in (c:cs, ivFinal)
cbcMac' :: BlockCipher k => k -> B.ByteString -> B.ByteString
cbcMac' k pt = encode $ snd $ cbc' k zeroIV pt
cbcMac :: BlockCipher k => k -> L.ByteString -> L.ByteString
cbcMac k pt = L.fromChunks [encode $ snd $ cbc k zeroIV pt]
unCbc' :: BlockCipher k => k -> IV k -> B.ByteString -> (B.ByteString, IV k)
unCbc' k (IV v) ciphertext =
let blks = chunkFor' k ciphertext
(pts, iv) = go blks v
in (B.concat pts, IV iv)
where
go [] iv = ([], iv)
go (c:cs) iv =
let p = zwp' (decryptBlock k c) iv
(ps, ivFinal) = go cs c
in (p:ps, ivFinal)
cbc :: BlockCipher k => k -> IV k -> L.ByteString -> (L.ByteString, IV k)
cbc k (IV v) plaintext =
let blks = chunkFor k plaintext
(cts, iv) = go blks v
in (L.fromChunks cts, IV iv)
where
go [] iv = ([], iv)
go (b:bs) iv =
let c = encryptBlock k (zwp' iv b)
(cs, ivFinal) = go bs c
in (c:cs, ivFinal)
unCbc :: BlockCipher k => k -> IV k -> L.ByteString -> (L.ByteString, IV k)
unCbc k (IV v) ciphertext =
let blks = chunkFor k ciphertext
(pts, iv) = go blks v
in (L.fromChunks pts, IV iv)
where
go [] iv = ([], iv)
go (c:cs) iv =
let p = zwp' (decryptBlock k c) iv
(ps, ivFinal) = go cs c
in (p:ps, ivFinal)
ctr :: BlockCipher k => (IV k -> IV k) -> k -> IV k -> L.ByteString -> (L.ByteString, IV k)
ctr = unCtr
unCtr :: BlockCipher k => (IV k -> IV k) -> k -> IV k -> L.ByteString -> (L.ByteString, IV k)
unCtr f k (IV iv) msg =
let ivStr = iterate f $ IV iv
ivLen = fromIntegral $ B.length iv
newIV = head $ genericDrop ((ivLen 1 + L.length msg) `div` ivLen) ivStr
in (zwp (L.fromChunks $ map (encryptBlock k) $ map initializationVector ivStr) msg, newIV)
ctr' :: BlockCipher k => (IV k -> IV k) -> k -> IV k -> B.ByteString -> (B.ByteString, IV k)
ctr' = unCtr'
unCtr' :: BlockCipher k => (IV k -> IV k) -> k -> IV k -> B.ByteString -> (B.ByteString, IV k)
unCtr' f k (IV iv) msg =
let ivStr = iterate f $ IV iv
ivLen = fromIntegral $ B.length iv
newIV = head $ genericDrop ((ivLen 1 + B.length msg) `div` ivLen) ivStr
in (zwp' (B.concat $ collect (B.length msg) (map (encryptBlock k . initializationVector) ivStr)) msg, newIV)
cMacSubk :: BlockCipher k => k -> (IV k, IV k)
cMacSubk k = (k1, k2) `seq` (k1, k2)
where
bSize = blockSizeBytes `for` k
k1 = dblIV $ IV $ encryptBlock k $ B.replicate bSize 0
k2 = dblIV $ k1
cMacPad :: ([Word8], Bool, Int) -> Maybe (Word8,([Word8], Bool, Int))
cMacPad (_, _, 0) = Nothing
cMacPad ([], False, n) = Just (0,([], False, n1))
cMacPad ([], True, n) = Just (128,([], False, n1))
cMacPad (x:xs, b, n) = Just (x,(xs, b, n1))
cMacWithSubK :: BlockCipher k => k -> (IV k, IV k) -> L.ByteString -> L.ByteString
cMacWithSubK k (IV k1, IV k2) l = L.fromChunks $ [go (chunkFor k t) $ B.replicate bSize1 0]
where
bSize1 = fromIntegral $ blockSizeBytes `for` k
bSize2 = fromIntegral $ blockSizeBytes `for` k
(t,e) = L.splitAt (((L.length l1)`div` bSize2)*bSize2) l
pe = fst $ B.unfoldrN (bSize1) cMacPad (L.unpack e,True,bSize1)
fe | bSize2 == L.length e = zwp' k1 pe
| otherwise = zwp' k2 pe
go [] c = encryptBlock k (zwp' c fe)
go (x:xs) c = go xs $ encryptBlock k $ zwp' c x
cMac :: BlockCipher k => k -> L.ByteString -> L.ByteString
cMac k = cMacWithSubK k (cMacSubk k)
cMacWithSubK' :: BlockCipher k => k -> (IV k, IV k) -> B.ByteString -> B.ByteString
cMacWithSubK' k (IV k1, IV k2) b = go (chunkFor' k t) $ B.replicate bSize1 0
where
bSize1 = fromIntegral $ blockSizeBytes `for` k
bSize2 = fromIntegral $ blockSizeBytes `for` k
(t,e) = B.splitAt (((B.length b1)`div` bSize2)*bSize2) b
pe = fst $ B.unfoldrN (bSize1) cMacPad (B.unpack e,True,bSize1)
fe | bSize2 == B.length e = zwp' k1 pe
| otherwise = zwp' k2 pe
go [] c = encryptBlock k (zwp' c fe)
go (x:xs) c = go xs $ encryptBlock k $ zwp' c x
cMac' :: BlockCipher k => k -> B.ByteString -> B.ByteString
cMac' k = cMacWithSubK' k (cMacSubk k)
xorend :: Int -> (Int,[Word8]) -> Maybe (Word8,(Int,[Word8]))
xorend bsize (0, []) = Nothing
xorend bsize (n, x:xs) | n <= bsize = Just (x,((n1),xs))
| otherwise = Just (0,((n1),(x:xs)))
cMacStar :: BlockCipher k => k -> [L.ByteString] -> L.ByteString
cMacStar k l = go (lcmac (L.replicate bSize 0)) l
where
bSize = fromIntegral $ blockSizeBytes `for` k
bSizeb = fromIntegral $ blockSize `for` k
lcmac = cMacWithSubK k (cMacSubk k)
go s [] = s
cMacStar' :: BlockCipher k => k -> [B.ByteString] -> B.ByteString
cMacStar' k s = go (lcmac (B.replicate bSize 0)) s
where
bSize = fromIntegral $ blockSizeBytes `for` k
bSizeb = fromIntegral $ blockSize `for` k
lcmac = cMacWithSubK' k (cMacSubk k)
go s [] = s
go s [x] | (B.length x) >= bSize = lcmac $ zwp' x $ fst $ B.unfoldrN (B.length x) (xorend bSize) (fromIntegral $ B.length x,B.unpack s)
| otherwise = lcmac $ zwp' (dblB s) (fst $ B.unfoldrN bSize cMacPad (B.unpack x,True,bSize))
go s (x:xs) = go (zwp' (dblB s) (lcmac x)) xs
sivMask :: B.ByteString -> B.ByteString
sivMask b = snd $ B.mapAccumR (go) 0 b
where
go :: Int -> Word8 -> (Int,Word8)
go 24 w = (32,clearBit w 7)
go 56 w = (64,clearBit w 7)
go n w = (n+8,w)
siv :: BlockCipher k => k -> k -> [L.ByteString] -> L.ByteString -> Maybe L.ByteString
siv k1 k2 xs m | length xs > bSizeb 1 = Nothing
| otherwise = Just $ L.append iv $ fst $ ctr incIV k2 (IV $ sivMask $ B.concat $ L.toChunks iv) m
where
bSize = fromIntegral $ blockSizeBytes `for` k1
bSizeb = fromIntegral $ blockSize `for` k1
iv = cMacStar k1 $ xs ++ [m]
unSiv :: BlockCipher k => k -> k -> [L.ByteString] -> L.ByteString -> Maybe L.ByteString
unSiv k1 k2 xs c | length xs > bSizeb 1 = Nothing
| L.length c < fromIntegral bSize = Nothing
| iv /= (cMacStar k1 $ xs ++ [dm]) = Nothing
| otherwise = Just dm
where
bSize = fromIntegral $ blockSizeBytes `for` k1
bSizeb = fromIntegral $ blockSize `for` k1
(iv,m) = L.splitAt (fromIntegral bSize) c
dm = fst $ unCtr incIV k2 (IV $ sivMask $ B.concat $ L.toChunks iv) m
siv' :: BlockCipher k => k -> k -> [B.ByteString] -> B.ByteString -> Maybe B.ByteString
siv' k1 k2 xs m | length xs > bSizeb 1 = Nothing
| otherwise = Just $ B.append iv $ fst $ ctr' incIV k2 (IV $ sivMask iv) m
where
bSize = fromIntegral $ blockSizeBytes `for` k1
bSizeb = fromIntegral $ blockSize `for` k1
iv = cMacStar' k1 $ xs ++ [m]
unSiv' :: BlockCipher k => k -> k -> [B.ByteString] -> B.ByteString -> Maybe B.ByteString
unSiv' k1 k2 xs c | length xs > bSizeb 1 = Nothing
| B.length c < bSize = Nothing
| iv /= (cMacStar' k1 $ xs ++ [dm]) = Nothing
| otherwise = Just dm
where
bSize = fromIntegral $ blockSizeBytes `for` k1
bSizeb = fromIntegral $ blockSize `for` k1
(iv,m) = B.splitAt bSize c
dm = fst $ unCtr' incIV k2 (IV $ sivMask iv) m
incIV :: BlockCipher k => IV k -> IV k
incIV (IV b) = IV $ snd $ B.mapAccumR (incw) True b
where
incw :: Bool -> Word8 -> (Bool, Word8)
incw True w = (w == maxBound, w + 1)
incw False w = (False, w)
dblw :: Bool -> (Int,[Int],Bool) -> Word8 -> ((Int,[Int],Bool), Word8)
dblw hb (i,xs,b) w = dblw' hb
where
slw True w = (setBit (shift w 1) 0)
slw False w = (clearBit (shift w 1) 0)
cpolyw i [] w = ((i+8,[]),w)
cpolyw i (x:xs) w
| x < i +8 = (\(a,b) -> (a,complementBit b (xi))) $ cpolyw i xs w
|otherwise = ((i+8,(x:xs)),w)
b' = testBit w 7
w' = slw b w
((i',xs'),w'') = cpolyw i xs w'
dblw' False = i'`seq`xs'`seq`w''`seq`((i,xs,b'),w')
dblw' True = ((i',xs',b'),w'')
dblIV :: BlockCipher k => IV k -> IV k
dblIV (IV b) = IV $ dblB b
dblB :: B.ByteString -> B.ByteString
dblB b | B.null b = b
| otherwise = snd $ B.mapAccumR (dblw (testBit (B.head b) 7)) (0,cpoly2revlist (B.length b * 8),False) b
dblL :: L.ByteString -> L.ByteString
dblL b | L.null b = b
| otherwise = snd $ L.mapAccumR (dblw (testBit (L.head b) 7)) (0,cpoly2revlist (L.length b * 8),False) b
decodeB :: B.ByteString -> Integer
decodeB = B.foldl' (\acc w -> (shift acc 8) + toInteger(w)) 0
encodeB :: (Ord a,Num a) => a -> Integer -> B.ByteString
encodeB k n = B.pack $ if lr > k then takel (lr k) r else pad (k lr) r
where
go 0 xs = xs
go n xs = go (shift n (8)) (fromInteger (n .&. 255) : xs)
pad 0 xs = xs
pad n xs = 0 : pad (n1) xs
takel 0 xs = xs
takel n (_:xs) = takel (n1) xs
r = go n []
lr = genericLength r
decodeL :: L.ByteString -> Integer
decodeL = L.foldl' (\acc w -> (shift acc 8) + toInteger(w)) 0
encodeL :: (Ord a,Num a) => a -> Integer -> L.ByteString
encodeL k n = L.pack $ if lr > k then takel (lr k) r else pad (k lr) r
where go 0 xs = xs
go n xs = go (shift n (8)) (fromInteger (n .&. 255) : xs)
pad 0 xs = xs
pad n xs = 0 : pad (n1) xs
takel 0 xs = xs
takel n (_:xs) = takel (n1) xs
r = go n []
lr = genericLength r
zeroIV :: (BlockCipher k) => IV k
zeroIV = iv
where bytes = ivBlockSizeBytes iv
iv = IV $ B.replicate bytes 0
ecb :: BlockCipher k => k -> L.ByteString -> L.ByteString
ecb k msg =
let chunks = chunkFor k msg
in L.fromChunks $ map (encryptBlock k) chunks
unEcb :: BlockCipher k => k -> L.ByteString -> L.ByteString
unEcb k msg =
let chunks = chunkFor k msg
in L.fromChunks $ map (decryptBlock k) chunks
ecb' :: BlockCipher k => k -> B.ByteString -> B.ByteString
ecb' k msg =
let chunks = chunkFor' k msg
in B.concat $ map (encryptBlock k) chunks
unEcb' :: BlockCipher k => k -> B.ByteString -> B.ByteString
unEcb' k ct =
let chunks = chunkFor' k ct
in B.concat $ map (decryptBlock k) chunks
cfb :: BlockCipher k => k -> IV k -> L.ByteString -> (L.ByteString, IV k)
cfb k (IV v) msg =
let blks = chunkFor k msg
(cs,ivF) = go v blks
in (L.fromChunks cs, IV ivF)
where
go iv [] = ([],iv)
go iv (b:bs) =
let c = zwp' (encryptBlock k iv) b
(cs,ivFinal) = go c bs
in (c:cs, ivFinal)
unCfb :: BlockCipher k => k -> IV k -> L.ByteString -> (L.ByteString, IV k)
unCfb k (IV v) msg =
let blks = chunkFor k msg
(ps, ivF) = go v blks
in (L.fromChunks ps, IV ivF)
where
go iv [] = ([], iv)
go iv (b:bs) =
let p = zwp' (encryptBlock k iv) b
(ps, ivF) = go b bs
in (p:ps, ivF)
cfb' :: BlockCipher k => k -> IV k -> B.ByteString -> (B.ByteString, IV k)
cfb' k (IV v) msg =
let blks = chunkFor' k msg
(cs,ivF) = go v blks
in (B.concat cs, IV ivF)
where
go iv [] = ([],iv)
go iv (b:bs) =
let c = zwp' (encryptBlock k iv) b
(cs,ivFinal) = go c bs
in (c:cs, ivFinal)
unCfb' :: BlockCipher k => k -> IV k -> B.ByteString -> (B.ByteString, IV k)
unCfb' k (IV v) msg =
let blks = chunkFor' k msg
(ps, ivF) = go v blks
in (B.concat ps, IV ivF)
where
go iv [] = ([], iv)
go iv (b:bs) =
let p = zwp' (encryptBlock k iv) b
(ps, ivF) = go b bs
in (p:ps, ivF)
ofb :: BlockCipher k => k -> IV k -> L.ByteString -> (L.ByteString, IV k)
ofb = unOfb
unOfb :: BlockCipher k => k -> IV k -> L.ByteString -> (L.ByteString, IV k)
unOfb k (IV iv) msg =
let ivStr = drop 1 (iterate (encryptBlock k) iv)
ivLen = fromIntegral (B.length iv)
newIV = IV . B.concat . L.toChunks . L.take ivLen . L.drop (L.length msg) . L.fromChunks $ ivStr
in (zwp (L.fromChunks ivStr) msg, newIV)
ofb' :: BlockCipher k => k -> IV k -> B.ByteString -> (B.ByteString, IV k)
ofb' = unOfb'
unOfb' :: BlockCipher k => k -> IV k -> B.ByteString -> (B.ByteString, IV k)
unOfb' k (IV iv) msg =
let ivStr = collect (B.length msg + ivLen) (drop 1 (iterate (encryptBlock k) iv))
ivLen = B.length iv
mLen = fromIntegral (B.length msg)
newIV = IV . B.concat . L.toChunks . L.take (fromIntegral ivLen) . L.drop mLen . L.fromChunks $ ivStr
in (zwp' (B.concat ivStr) msg, newIV)
getIV :: (BlockCipher k, CryptoRandomGen g) => g -> Either GenError (IV k, g)
getIV g =
let bytes = ivBlockSizeBytes iv
gen = genBytes bytes g
fromRight (Right x) = x
iv = IV (fst . fromRight $ gen)
in case gen of
Left err -> Left err
Right (bs,g')
| B.length bs == bytes -> Right (iv, g')
| otherwise -> Left (GenErrorOther "Generator failed to provide requested number of bytes")
getIVIO :: (BlockCipher k) => IO (IV k)
getIVIO = do
let p = Proxy
getTypedIV :: BlockCipher k => Proxy k -> IO (IV k)
getTypedIV pr = liftM IV (getEntropy (proxy blockSize pr `div` 8))
iv <- getTypedIV p
return (iv `asProxyTypeOf` ivProxy p)
ivProxy :: Proxy k -> Proxy (IV k)
ivProxy = reproxy
deIVProxy :: Proxy (IV k) -> Proxy k
deIVProxy = reproxy
proxyOf :: a -> Proxy a
proxyOf = const Proxy
ivBlockSizeBytes :: BlockCipher k => IV k -> Int
ivBlockSizeBytes iv =
let p = deIVProxy (proxyOf iv)
in proxy blockSize p `div` 8
instance (BlockCipher k) => Serialize (IV k) where
get = do
let p = Proxy
doGet :: BlockCipher k => Proxy k -> Get (IV k)
doGet pr = liftM IV (SG.getByteString (proxy blockSizeBytes pr))
iv <- doGet p
return (iv `asProxyTypeOf` ivProxy p)
put (IV iv) = SP.putByteString iv