module Crypto.Conduit
(
sinkHash
, hashFile
, sinkHmac
, conduitEncryptEcb
, conduitDecryptEcb
, conduitEncryptCbc
, conduitDecryptCbc
, conduitEncryptCfb
, conduitDecryptCfb
, conduitEncryptOfb
, conduitDecryptOfb
, conduitEncryptCtr
, conduitDecryptCtr
, sourceCtr
, sinkCbcMac
, blocked
, BlockMode(..)
, Block(..)
) where
import Control.Arrow (first)
import Data.Bits (xor)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Serialize as S
import Crypto.Classes ((.::.))
import qualified Crypto.Classes as C
import qualified Crypto.HMAC as C
import qualified Crypto.Modes as C
import qualified Crypto.Types as C
import Data.Conduit hiding (Source, Sink, Conduit, Pipe)
import Data.Conduit.Binary (sourceFile)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
getType :: Monad m => sink input m output -> output
getType = undefined
sinkHash :: (Monad m, C.Hash ctx d) => GLSink B.ByteString m d
sinkHash =
self
where
self = sink C.initialCtx
sink ctx = do
x <- getBlock AnyMultiple blockSize
case x of
Full bs ->
let !ctx' = C.updateCtx ctx bs
in sink ctx'
LastOne bs -> return $! C.finalize ctx bs
blockSize = (C.blockLength .::. getType self) `div` 8
getBlock :: Monad m => BlockMode -> C.ByteLength -> GLSink B.ByteString m Block
getBlock blockMode blockSize =
go id
where
go front = await >>= maybe (close front) (push front)
push front bs' =
case compare (B.length bs) blockSize of
LT -> go $ B.append bs
EQ -> return $ Full bs
GT -> leftover y >> return (Full x)
where
bs = front bs'
(x, y) = B.splitAt splitter bs
splitter =
case blockMode of
StrictBlockSize -> blockSize
AnyMultiple -> B.length bs (B.length bs `mod` blockSize)
close front = return $ LastOne $ front B.empty
hashFile :: (MonadIO m, C.Hash ctx d) => FilePath -> m d
hashFile fp = liftIO $ runResourceT (sourceFile fp $$ sinkHash)
sinkHmac :: (Monad m, C.Hash ctx d) =>
#if OLD_CRYPTO_API
C.MacKey
#else
C.MacKey ctx d
#endif
-> GLSink B.ByteString m d
sinkHmac (C.MacKey key) =
sink
where
key' =
case B.length key `compare` blockSize of
GT -> B.append
(S.encode $ C.hashFunc' d key)
(B.replicate (blockSize outputSize) 0x00)
EQ -> key
LT -> B.append key (B.replicate (blockSize B.length key) 0x00)
ko = B.map (`xor` 0x5c) key'
ki = B.map (`xor` 0x36) key'
sink = go $ C.updateCtx C.initialCtx ki
go ctx = do
x <- getBlock AnyMultiple blockSize
case x of
Full bs ->
let !ctx' = C.updateCtx ctx bs
in go ctx'
LastOne bs ->
let !inner = C.finalize ctx bs `asTypeOf` d
!outer = C.hash $ L.fromChunks [ko, S.encode inner]
in return outer
d = getType sink
blockSize = (C.blockLength .::. d) `div` 8
outputSize = (C.outputLength .::. d) `div` 8
conduitEncryptEcb :: (Monad m, C.BlockCipher k) =>
k
-> GLInfConduit B.ByteString m B.ByteString
conduitEncryptEcb k =
blockCipherConduit k
AnyMultiple
()
(\_ input -> ((), C.encryptBlock k input))
(\_ _ -> fail "conduitEncryptEcb: input has an incomplete final block.")
conduitDecryptEcb :: (Monad m, C.BlockCipher k) =>
k
-> GLInfConduit B.ByteString m B.ByteString
conduitDecryptEcb k =
blockCipherConduit k
AnyMultiple
()
(\_ input -> ((), C.decryptBlock k input))
(\_ _ -> fail "conduitDecryptEcb: input has an incomplete final block.")
conduitEncryptCbc :: (Monad m, C.BlockCipher k) =>
k
-> C.IV k
-> GLInfConduit B.ByteString m B.ByteString
conduitEncryptCbc k iv =
blockCipherConduit k
StrictBlockSize
(S.encode iv)
(\iv' input -> let output = C.encryptBlock k (iv' `zwp` input)
in (output, output))
(\_ _ -> fail "conduitEncryptCbc: input has an incomplete final block.")
conduitDecryptCbc :: (Monad m, C.BlockCipher k) =>
k
-> C.IV k
-> GLInfConduit B.ByteString m B.ByteString
conduitDecryptCbc k iv =
blockCipherConduit k
StrictBlockSize
(S.encode iv)
(\iv' input -> let output = C.decryptBlock k input `zwp` iv'
in (input, output))
(\_ _ -> fail "conduitDecryptCbc: input has an incomplete final block.")
conduitEncryptCfb :: (Monad m, C.BlockCipher k) =>
k
-> C.IV k
-> GLInfConduit B.ByteString m B.ByteString
conduitEncryptCfb k iv =
blockCipherConduit k
StrictBlockSize
(S.encode iv)
(\iv' input -> let output = C.encryptBlock k iv' `zwp` input
in (output, output))
(\_ _ -> fail "conduitEncryptCfb: input has an incomplete final block.")
conduitDecryptCfb :: (Monad m, C.BlockCipher k) =>
k
-> C.IV k
-> GLInfConduit B.ByteString m B.ByteString
conduitDecryptCfb k iv =
blockCipherConduit k
StrictBlockSize
(S.encode iv)
(\iv' input -> let output = C.encryptBlock k iv' `zwp` input
in (input, output))
(\_ _ -> fail "conduitDecryptCfb: input has an incomplete final block.")
conduitEncryptOfb :: (Monad m, C.BlockCipher k) =>
k
-> C.IV k
-> GLInfConduit B.ByteString m B.ByteString
conduitEncryptOfb k iv =
blockCipherConduit k
StrictBlockSize
(S.encode iv)
(\iv' input -> let inter = C.encryptBlock k iv'
in (inter, inter `zwp` input))
(\_ _ -> fail "conduitEncryptOfb: input has an incomplete final block.")
conduitDecryptOfb :: (Monad m, C.BlockCipher k) =>
k
-> C.IV k
-> GLInfConduit B.ByteString m B.ByteString
conduitDecryptOfb = conduitEncryptOfb
conduitEncryptCtr :: (Monad m, C.BlockCipher k) =>
k
-> C.IV k
-> (C.IV k -> C.IV k)
-> GLInfConduit B.ByteString m B.ByteString
conduitEncryptCtr k iv incIV =
blockCipherConduit k
StrictBlockSize
iv
(\iv' input -> let !iv'' = incIV iv'
output = C.encryptBlock k (S.encode iv') `zwp` input
in (iv'', output))
(\iv' input -> let output = C.encryptBlock k (S.encode iv') `zwp` input
in return output)
conduitDecryptCtr :: (Monad m, C.BlockCipher k) =>
k
-> C.IV k
-> (C.IV k -> C.IV k)
-> GLInfConduit B.ByteString m B.ByteString
conduitDecryptCtr = conduitEncryptCtr
sourceCtr :: (Monad m, C.BlockCipher k) =>
k
-> C.IV k
-> GSource m B.ByteString
sourceCtr k =
loop
where
loop iv =
yield block >> loop iv'
where
!iv' = C.incIV iv
block = C.encryptBlock k $ S.encode iv
sinkCbcMac :: (Monad m, C.BlockCipher k) =>
k
-> GLSink B.ByteString m B.ByteString
sinkCbcMac k =
go $ B.replicate blockSize 0
where
go iv = do
x <- getBlock StrictBlockSize blockSize
case x of
Full input ->
let !iv' = C.encryptBlock k (iv `zwp` input)
in go iv'
LastOne input
| B.null input -> return iv
| otherwise -> lift $ fail "sinkCbcMac: input has an incomplete final block."
blockSize = (C.blockSize .::. k) `div` 8
blocked :: Monad m =>
BlockMode
-> C.ByteLength
-> GInfConduit B.ByteString m Block
blocked mode blockSize = go B.empty
where
go x = awaitE >>= either (close x) (push x)
block = case mode of
StrictBlockSize -> blockStrict id
AnyMultiple -> blockAny
where
blockStrict front bs
| B.length bs < blockSize = (front [], bs)
| otherwise = blockStrict (front . (Full this :)) rest
where (this, rest) = B.splitAt blockSize bs
blockAny bs
| n >= 1 = first ((:[]) . Full) $ B.splitAt (n * blockSize) bs
| otherwise = ([], bs)
where n = B.length bs `div` blockSize
append bs1 bs2
| B.null bs1 = bs2
| otherwise = B.append bs1 bs2
push acc x = mapM_ yield blks >> go rest
where
(blks, rest) = block bs
bs = append acc x
close acc r = yield (LastOne acc) >> return r
data BlockMode = StrictBlockSize | AnyMultiple
deriving (Eq, Ord, Show, Enum)
data Block = Full B.ByteString | LastOne B.ByteString
deriving (Eq, Ord, Show)
blockCipherConduit :: (Monad m, C.BlockCipher k) =>
k
-> BlockMode
-> s
-> (s -> B.ByteString -> (s, B.ByteString))
-> (s -> B.ByteString -> m B.ByteString)
-> GLInfConduit B.ByteString m B.ByteString
blockCipherConduit key mode initialState apply final =
go initialState
where
blockSize = (C.blockSize .::. key) `div` 8
go state = do
x <- getBlock mode blockSize
case x of
Full input -> do
let (!state', !output) = apply state input
yield output
go state'
LastOne input
| B.null input -> return () >> finish
| otherwise -> lift (final state input) >>= yield >> finish
finish = awaitE >>= either return (const finish)
zwp :: B.ByteString -> B.ByteString -> B.ByteString
zwp a = B.pack . B.zipWith xor a