module Crypto.Random.DRBG
(
HmacDRBG, HashDRBG
, HmacDRBGWith, HashDRBGWith
, GenAES, GenCounter
, GenXor
, GenBuffered
, GenAutoReseed
, newGenAutoReseed, newGenAutoReseedIO
, module Crypto.Random
) where
import qualified Crypto.Random.DRBG.HMAC as M
import qualified Crypto.Random.DRBG.Hash as H
import Crypto.Random.DRBG.Util
import Crypto.Classes
import Crypto.Modes
import Crypto.Random
import Crypto.Hash.SHA512 (SHA512)
import Crypto.Hash.SHA384 (SHA384)
import Crypto.Hash.SHA256 (SHA256)
import Crypto.Hash.SHA224 (SHA224)
import Crypto.Hash.SHA1 (SHA1)
import Crypto.Cipher.AES (AES128)
import System.Entropy
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as BI
import Data.Tagged
import Data.Proxy
import Data.Bits (xor)
import Control.Parallel
import Control.Monad (liftM)
import Control.Monad.Error ()
import Data.Serialize (encode)
import Data.Word
instance H.SeedLength SHA512 where
seedlen = Tagged 888
instance H.SeedLength SHA384 where
seedlen = Tagged 888
instance H.SeedLength SHA256 where
seedlen = Tagged 440
instance H.SeedLength SHA224 where
seedlen = Tagged 440
instance H.SeedLength SHA1 where
seedlen = Tagged 440
type HmacDRBGWith = M.State
type HashDRBGWith = H.State
type HmacDRBG = M.State SHA512
type HashDRBG = H.State SHA512
newGenAutoReseed :: (CryptoRandomGen a, CryptoRandomGen b) => B.ByteString -> Int -> Either GenError (GenAutoReseed a b)
newGenAutoReseed bs rsInterval=
let (b1,b2) = B.splitAt (genSeedLength `for` fromRight g1) bs
g1 = newGen b1
g2 = newGen b2
fromRight (Right x) = x
in case (g1, g2) of
(Right a, Right b) -> Right $ GenAutoReseed a b rsInterval 0
(Left e, _) -> Left e
(_, Left e) -> Left e
newGenAutoReseedIO :: (CryptoRandomGen a, CryptoRandomGen b) => Int -> IO (GenAutoReseed a b)
newGenAutoReseedIO i = do
g1 <- newGenIO
g2 <- newGenIO
return $ GenAutoReseed g1 g2 i 0
seed :: CryptoRandomGen g => Proxy g -> Int
seed x = proxy genSeedLength x
rightProxy :: Proxy p -> Proxy (Either x p)
rightProxy = reproxy
instance CryptoRandomGen HmacDRBG where
newGen bs =
let res = M.instantiate bs B.empty B.empty
in if B.length bs < genSeedLength `for` res
then Left NotEnoughEntropy
else Right res
genSeedLength = Tagged (512 `div` 8)
genBytes req g =
let res = M.generate g (req * 8) B.empty
in case res of
Nothing -> Left NeedReseed
Just (r,s) -> Right (r, s)
genBytesWithEntropy req ai g =
let res = M.generate g (req * 8) ai
in case res of
Nothing -> Left NeedReseed
Just (r,s) -> Right (r, s)
reseed ent g =
let res = M.reseed g ent B.empty
in if B.length ent < genSeedLength `for` res
then Left NotEnoughEntropy
else Right res
instance CryptoRandomGen HashDRBG where
newGen bs =
let res = H.instantiate bs B.empty B.empty
in if B.length bs < genSeedLength `for` res
then Left NotEnoughEntropy
else Right res
genSeedLength = Tagged $ 512 `div` 8
genBytes req g =
let res = H.generate g (req * 8) B.empty
in case res of
Nothing -> Left NeedReseed
Just (r,s) -> Right (r, s)
genBytesWithEntropy req ai g =
let res = H.generate g (req * 8) ai
in case res of
Nothing -> Left NeedReseed
Just (r,s) -> Right (r, s)
reseed ent g =
let res = H.reseed g ent B.empty
in if B.length ent < genSeedLength `for` res
then Left NotEnoughEntropy
else Right res
helper1 :: Tagged (GenAutoReseed a b) Int -> a
helper1 = const undefined
helper2 :: Tagged (GenAutoReseed a b) Int -> b
helper2 = const undefined
data GenAutoReseed a b = GenAutoReseed !a !b !Int !Int
instance (CryptoRandomGen a, CryptoRandomGen b) => CryptoRandomGen (GenAutoReseed a b) where
newGen bs = newGenAutoReseed bs (2^15)
newGenIO = newGenAutoReseedIO (2^15)
genSeedLength =
let a = helper1 res
b = helper2 res
res = Tagged $ genSeedLength `for` a + genSeedLength `for` b
in res
genBytes req (GenAutoReseed a b rs cnt) =
case genBytes req a of
Left NeedReseed -> do
(ent,b') <- genBytes (genSeedLength `for` a) b
a' <- reseed ent a
(res, aNew) <- genBytes req a'
return (res,GenAutoReseed aNew b' rs 0)
Left err -> Left err
Right (res,aNew) -> do
gNew <- if (cnt + req) > rs
then do
(ent,b') <- genBytes (genSeedLength `for` a) b
a' <- reseed ent aNew
return (GenAutoReseed a' b' rs 0)
else return $ GenAutoReseed aNew b rs (cnt + req)
return (res, gNew)
genBytesWithEntropy req entropy (GenAutoReseed a b rs cnt) = do
case genBytesWithEntropy req entropy a of
Left NeedReseed -> do
(ent,b') <- genBytes (genSeedLength `for` a) b
a' <- reseed ent a
(res, aNew) <- genBytesWithEntropy req entropy a'
return (res,GenAutoReseed aNew b' rs 0)
Left err -> Left err
Right (res,aNew) -> do
gNew <- if (cnt + req) > rs
then do
(ent,b') <- genBytes (genSeedLength `for` a) b
a' <- reseed ent aNew
return (GenAutoReseed a' b' rs 0)
else return $ GenAutoReseed aNew b rs (cnt + req)
return (res, gNew)
reseed ent gen@(GenAutoReseed a b rs _)
| genSeedLength `for` gen > B.length ent = Left NotEnoughEntropy
| otherwise = do
let (e1,e2) = B.splitAt (genSeedLength `for` a) ent
a' <- reseed e1 a
b' <- if B.length e2 /= 0
then reseed e2 b
else return b
return $ GenAutoReseed a' b' rs 0
data GenXor a b = GenXor !a !b
helperXor1 :: Tagged (GenXor a b) c -> a
helperXor1 = const undefined
helperXor2 :: Tagged (GenXor a b) c -> b
helperXor2 = const undefined
instance (CryptoRandomGen a, CryptoRandomGen b) => CryptoRandomGen (GenXor a b) where
newGen bs = do
let g1 = newGen b1
g2 = newGen b2
(b1,b2) = B.splitAt (genSeedLength `for` fromRight g1) bs
fromRight (Right x) = x
a <- g1
b <- g2
return (GenXor a b)
newGenIO = do
a <- newGenIO
b <- newGenIO
return (GenXor a b)
genSeedLength =
let a = helperXor1 res
b = helperXor2 res
res = Tagged $ (genSeedLength `for` a) + (genSeedLength `for` b)
in res
genBytes req (GenXor a b) = do
(r1, a') <- genBytes req a
(r2, b') <- genBytes req b
return (zwp' r1 r2, GenXor a' b')
genBytesWithEntropy req ent (GenXor a b) = do
(r1, a') <- genBytesWithEntropy req ent a
(r2, b') <- genBytesWithEntropy req ent b
return (zwp' r1 r2, GenXor a' b')
reseed ent (GenXor a b) = do
let (b1, b2) = B.splitAt (genSeedLength `for` a) ent
a' <- reseed b1 a
b' <- reseed b2 b
return (GenXor a' b')
data GenBuffered g = GenBuffered Int Int (Either (GenError, g) (B.ByteString, g)) !B.ByteString
proxyToGenBuffered :: Proxy g -> Proxy (Either GenError (GenBuffered g))
proxyToGenBuffered = const Proxy
bufferMinDef = 2^20
bufferMaxDef = 2^22
newGenBuffered :: (CryptoRandomGen g) => Int -> Int -> B.ByteString -> Either GenError (GenBuffered g)
newGenBuffered min max bs = do
g <- newGen bs
(rs,g') <- genBytes min g
let new = wrapErr (genBytes min g') g'
(let !_ = rs in ()) `par` return (GenBuffered min max new rs)
newGenBufferedIO :: CryptoRandomGen g => Int -> Int -> IO (GenBuffered g)
newGenBufferedIO min max = do
g <- newGenIO
let !(Right !gBuf) = do
(rs,g') <- genBytes min g
let new = wrapErr (genBytes min g') g'
(let !_ = rs in ()) `par` return (GenBuffered min max new rs)
return gBuf
instance (CryptoRandomGen g) => CryptoRandomGen (GenBuffered g) where
newGen = newGenBuffered bufferMinDef bufferMaxDef
newGenIO = newGenBufferedIO bufferMinDef bufferMaxDef
genSeedLength =
let a = help res
res = Tagged $ genSeedLength `for` a
in res
where
help :: Tagged (GenBuffered g) c -> g
help = const undefined
genBytes req gb@(GenBuffered min max g bs)
| remSize >= min = Right (B.take req bs, GenBuffered min max g (B.drop req bs))
| B.length bs < min =
case g of
Left (err,_) -> Left err
Right g -> Left (GenErrorOther "Buffering generator failed to buffer properly - unknown reason")
| req > B.length bs = Left RequestedTooManyBytes
| remSize < min =
case g of
Left (err,_) -> Left err
Right (rnd, gen) ->
let new | B.length rnd > 0 = wrapErr (genBytes (max (remSize + B.length rnd)) gen) gen
| otherwise = Right (B.empty,gen)
(rs,rem) = B.splitAt req bs
in (eval new) `par` Right (rs, GenBuffered min max new (B.append rem rnd))
| otherwise = Left $ GenErrorOther "Buffering generator hit an impossible case. Please inform the Haskell crypto-api maintainer"
where
remSize = B.length bs req
genBytesWithEntropy req ent g = reseed ent g >>= \gen -> genBytes req gen
reseed ent (GenBuffered min max g bs) = do
let (rs, g') =
case g of
Left (_,g') -> (B.empty, g')
Right (rs, g') -> (rs, g')
g'' <- reseed ent g'
let new = wrapErr (genBytes (minB.length bs') g'') g''
bs' = B.take max (B.append bs rs)
return (GenBuffered min max new bs')
wrapErr :: Either x y -> g -> Either (x,g) y
wrapErr (Left x) g = Left (x,g)
wrapErr (Right r) _ = Right r
eval :: Either x (B.ByteString, g) -> Either x (B.ByteString, g)
eval (Left x) = Left x
eval (Right (g,bs)) = bs `seq` (g `seq` (Right (g, bs)))
type GenAES = GenCounter AES128
data GenCounter a = GenCounter !Word64 a (IV a)
instance BlockCipher x => CryptoRandomGen (GenCounter x) where
newGen bytes =
let kl = keyLength
in case buildKey (B.take (untag kl `div` 8) bytes) of
Nothing -> Left NotEnoughEntropy
Just x -> Right (GenCounter 0 (x `asTaggedTypeOf` kl) zeroIV)
newGenIO = do
let b = keyLength
kd <- getEntropy ((untag b + 7) `div` 8)
case buildKey kd of
Nothing -> error "Failed to generate key for GenCounter"
Just k -> return $ GenCounter 0 (k `asTaggedTypeOf` b) zeroIV
genSeedLength =
let rt :: Tagged x Int -> Tagged (GenCounter x) Int
rt = Tagged . (`div` 8) . unTagged
in rt keyLength
genBytes req (GenCounter rs k counter) =
let bs = B.replicate (req' * blkSz) 0
blkSz = blockSizeBytes `for` k
(rnd,iv) = ctr' incIV k counter bs
req' = (req + blkSz 1) `div` blkSz
in if rs >= 2^48
then Left NeedReseed
else Right (B.take req rnd, GenCounter (rs+1) k iv)
reseed bs (GenCounter _ k _) = newGen (xorExtendBS (encode k) bs)
xorExtendBS a b = res
where
x = B.pack $ B.zipWith Data.Bits.xor a b
res | al /= bl = x
| otherwise = B.append x rem
al = B.length a
bl = B.length b
rem | bl > al = B.drop al b
| otherwise = B.drop bl a
zwp' a = B.pack . B.zipWith xor a