diff --git a/Crypto/Random/DRBG.hs b/Crypto/Random/DRBG.hs --- a/Crypto/Random/DRBG.hs +++ b/Crypto/Random/DRBG.hs @@ -75,15 +75,11 @@ import qualified Crypto.Random.DRBG.HMAC as M import qualified Crypto.Random.DRBG.Hash as H -import Crypto.Random.DRBG.Util +import Crypto.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.Modes (zeroIV) +import Crypto.Hash.CryptoAPI import Crypto.Cipher.AES128 (AESKey) import Crypto.Types import System.Entropy @@ -142,14 +138,14 @@ -- -- Will last for @2^48 * 2^41@ bytes of randomly generated data. That's -- 2^49 terabytes of random values (128 byte reseeds every 2^48 bytes generated). -newGenAutoReseed :: (CryptoRandomGen a, CryptoRandomGen b) => B.ByteString -> Int -> Either GenError (GenAutoReseed a b) +newGenAutoReseed :: (CryptoRandomGen a, CryptoRandomGen b) => B.ByteString -> Word64 -> 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 + (Right a, Right b) -> Right $ GenAutoReseed rsInterval 0 a b (Left e, _) -> Left e (_, Left e) -> Left e @@ -157,11 +153,11 @@ -- interval of @i@ bytes, using the system random number generator as a seed. -- -- See 'newGenAutoReseed'. -newGenAutoReseedIO :: (CryptoRandomGen a, CryptoRandomGen b) => Int -> IO (GenAutoReseed a b) +newGenAutoReseedIO :: (CryptoRandomGen a, CryptoRandomGen b) => Word64 -> IO (GenAutoReseed a b) newGenAutoReseedIO i = do g1 <- newGenIO g2 <- newGenIO - return $ GenAutoReseed g1 g2 i 0 + return $ GenAutoReseed i 0 g1 g2 seed :: CryptoRandomGen g => Proxy g -> Int seed x = proxy genSeedLength x @@ -192,6 +188,9 @@ then Left NotEnoughEntropy else Right res + reseedInfo s = InXCalls (M.counter s) + reseedPeriod _ = InXCalls M.reseedInterval + instance CryptoRandomGen HashDRBG where newGen bs = let res = H.instantiate bs B.empty B.empty @@ -214,6 +213,8 @@ in if B.length ent < genSeedLength `for` res then Left NotEnoughEntropy else Right res + reseedInfo s = InXCalls (H.counter s) + reseedPeriod _ = InXCalls H.reseedInterval helper1 :: Tagged (GenAutoReseed a b) Int -> a helper1 = const undefined @@ -240,7 +241,7 @@ -- @2^15 * (2^b / a')@ bytes. For the common values of @a' = 128@ and @2^b = 2^48@ this -- means reseeding every 2^56 byte. For the example numbers this translates to -- about 200 years of continually generating random values at a rate of 10MB/s. -data GenAutoReseed a b = GenAutoReseed !a !b !Int !Int +data GenAutoReseed a b = GenAutoReseed {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 !a !b instance (CryptoRandomGen a, CryptoRandomGen b) => CryptoRandomGen (GenAutoReseed a b) where {-# SPECIALIZE instance CryptoRandomGen (GenAutoReseed HmacDRBG HmacDRBG) #-} @@ -254,39 +255,39 @@ b = helper2 res res = Tagged $ genSeedLength `for` a + genSeedLength `for` b in res - genBytes req (GenAutoReseed a b rs cnt) = + genBytes req (GenAutoReseed rs cnt a b) = 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) + return (res,GenAutoReseed rs 0 aNew b') Left err -> Left err Right (res,aNew) -> do - gNew <- if (cnt + req) > rs + gNew <- if (cnt + fromIntegral 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 (GenAutoReseed rs 0 a' b') + else return $ GenAutoReseed rs (cnt + fromIntegral req) aNew b return (res, gNew) - genBytesWithEntropy req entropy (GenAutoReseed a b rs cnt) = do + genBytesWithEntropy req entropy (GenAutoReseed rs cnt a b) = 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) + return (res, GenAutoReseed rs 0 aNew b') Left err -> Left err Right (res,aNew) -> do - gNew <- if (cnt + req) > rs + gNew <- if (cnt + fromIntegral 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 (GenAutoReseed rs 0 a' b') + else return $ GenAutoReseed rs (cnt + fromIntegral req) aNew b return (res, gNew) - reseed ent gen@(GenAutoReseed a b rs _) + reseed ent gen@(GenAutoReseed rs _ a b) | genSeedLength `for` gen > B.length ent = Left NotEnoughEntropy | otherwise = do let (e1,e2) = B.splitAt (genSeedLength `for` a) ent @@ -294,7 +295,36 @@ b' <- if B.length e2 /= 0 then reseed e2 b else return b - return $ GenAutoReseed a' b' rs 0 + return $ GenAutoReseed rs 0 a' b' + reseedPeriod ~(GenAutoReseed rs _ ag bg) = + case (reseedPeriod ag, reseedPeriod bg) of + (Never, _) -> Never + (_, Never) -> Never + (NotSoon, _) -> NotSoon + (_, NotSoon) -> NotSoon + (_, InXCalls b) -> + if fromIntegral rs * fromIntegral b > fromIntegral (maxBound `asTypeOf` b) + then NotSoon + else InXBytes (rs * b) + (_, InXBytes b) -> + let s = genSeedLength `for` ag + nr = if s <= 0 then 1 else ((b `div` fromIntegral s) - 1) + in InXBytes $ rs * nr + reseedInfo (GenAutoReseed rs x ag bg) = + -- Attempt to provide a lower bound on the next reseed + case (reseedInfo ag, reseedInfo bg) of + (NotSoon, _) -> NotSoon + (_, NotSoon) -> NotSoon + (Never, _) -> Never + (_, Never) -> Never + (_, InXBytes b) -> + let s = genSeedLength `for` ag + nr = if s <= 0 then 1 else ((b `div` fromIntegral s) - 1) + in InXBytes $ rs - x + rs * nr + (_, InXCalls b) -> + if fromIntegral rs * fromIntegral b > fromIntegral (maxBound `asTypeOf` b) + then NotSoon + else InXBytes (rs - x + rs * b) -- |@g :: GenXor a b@ generates bytes with sub-generators a and b -- and exclusive-or's the outputs to produce the resulting bytes. @@ -340,6 +370,8 @@ a' <- reseed b1 a b' <- reseed b2 b return (GenXor a' b') + reseedPeriod ~(GenXor a b) = min (reseedPeriod a) (reseedPeriod b) + reseedInfo ~(GenXor a b) = min (reseedInfo a) (reseedInfo b) -- |@g :: GenBuffered a@ is a generator of type @a@ that attempts to -- maintain a buffer of random values size >= 1MB and <= 5MB at any time. @@ -407,6 +439,8 @@ let new = wrapErr (genBytes (min-B.length bs') g'') g'' bs' = B.take max (B.append bs rs) return (GenBuffered min max new bs') + reseedPeriod ~(GenBuffered _ _ g _) = reseedPeriod . either snd snd $ g + reseedInfo ~(GenBuffered _ _ g _) = reseedInfo . either snd snd $ g wrapErr :: Either x y -> g -> Either (x,g) y wrapErr (Left x) g = Left (x,g) @@ -422,6 +456,10 @@ -- |@GenCounter k@ is a cryptographic BlockCipher with key @k@ -- being used in 'ctr' mode to generate random bytes. +-- +-- Notice this is the only generator in the package that does not follow +-- SP800-90. It is a rather hap-hazard construction. Use at your own risk +-- and patch at your own leisure. data GenCounter a = GenCounter {-# UNPACK #-} !Word64 a (IV a) instance BlockCipher x => CryptoRandomGen (GenCounter x) where @@ -445,13 +483,15 @@ genBytes req (GenCounter rs k counter) = let bs = B.replicate (req' * blkSz) 0 blkSz = blockSizeBytes `for` k - (rnd,iv) = ctr' incIV k counter bs + (rnd,iv) = ctr 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) + reseedPeriod (GenCounter cnt _ _) = InXCalls (2^48) + reseedInfo (GenCounter nr _ _) = InXCalls (2^48 - nr) xorExtendBS a b = res where @@ -462,9 +502,3 @@ bl = B.length b rem | bl > al = B.drop al b | otherwise = B.drop bl a - - --- |zipWith xor + Pack --- As a result of rewrite rules, this should automatically be optimized (at compile time) --- to use the bytestring libraries 'zipWith'' function. -zwp' a = B.pack . B.zipWith xor a diff --git a/Crypto/Random/DRBG/HMAC.hs b/Crypto/Random/DRBG/HMAC.hs --- a/Crypto/Random/DRBG/HMAC.hs +++ b/Crypto/Random/DRBG/HMAC.hs @@ -1,16 +1,17 @@ {-# LANGUAGE BangPatterns #-} module Crypto.Random.DRBG.HMAC - ( State - , reseedInterval - , instantiate - , reseed - , generate) where + ( State, counter + , reseedInterval + , instantiate + , reseed + , generate) where import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.Serialize (encode, Serialize(..)) import Data.Serialize.Put import Data.Serialize.Builder (toByteString) +import Data.Word (Word64) import Crypto.Classes import Crypto.HMAC import Crypto.Types @@ -20,13 +21,14 @@ type Value = B.ByteString data State d = St - { value :: !Value - , key :: !Key - , counter :: !Integer - -- Start admin info - , hashAlg :: L.ByteString -> d - } + { counter :: {-# UNPACK #-} !Word64 + -- Start admin info + , value :: !Value + , key :: !Key + , hashAlg :: L.ByteString -> d + } +reseedInterval :: Word64 reseedInterval = 2^48 fc = L.fromChunks . \s -> [s] @@ -52,7 +54,7 @@ seedMaterial = L.fromChunks [ent, nonce, perStr] k = B.replicate olen 0 v = B.replicate olen 1 - st = update (St v k 1 hash) seedMaterial + st = update (St 1 v k hash) seedMaterial d = hashAlg st undefined olen = (outputLength .::. d) `div` 8 @@ -61,14 +63,14 @@ generate :: (Hash c d) => State d -> BitLength -> AdditionalInput -> Maybe (RandomBits, State d) generate st req additionalInput = - if(counter st > reseedInterval) - then Nothing - else Just (randBitsFinal, stFinal { counter = 1 + counter st}) + if(counter st > reseedInterval) + then Nothing + else Just (randBitsFinal, stFinal { counter = 1 + counter st}) where d = hashAlg st undefined st' = if B.length additionalInput == 0 - then st - else update st (fc additionalInput) + then st + else update st (fc additionalInput) reqBytes = (req+7) `div` 8 iterations = (reqBytes + (outlen - 1)) `div` outlen @@ -79,10 +81,10 @@ getV :: Value -> Int -> (Value, [B.ByteString]) getV !u 0 = (u, []) getV !u i = - let !vNew = hmac' (MacKey kFinal) u `asTypeOf` d - !encV = encode vNew - (uFinal, rest) = getV encV (i - 1) - in (uFinal, encV:rest) + let !vNew = hmac' (MacKey kFinal) u `asTypeOf` d + !encV = encode vNew + (uFinal, rest) = getV encV (i - 1) + in (uFinal, encV:rest) (vFinal, randBitsList) = getV (value st') iterations randBitsFinal = B.take reqBytes $ B.concat randBitsList kFinal = key st' diff --git a/Crypto/Random/DRBG/Hash.hs b/Crypto/Random/DRBG/Hash.hs --- a/Crypto/Random/DRBG/Hash.hs +++ b/Crypto/Random/DRBG/Hash.hs @@ -1,12 +1,12 @@ {-# LANGUAGE BangPatterns, MonomorphismRestriction #-} module Crypto.Random.DRBG.Hash - ( State - , reseedInterval - , SeedLength (..) - , instantiate - , reseed - , generate - ) where + ( State, counter + , reseedInterval + , SeedLength (..) + , instantiate + , reseed + , generate + ) where -- NIST SP 800-90 import qualified Data.ByteString as B @@ -17,58 +17,60 @@ import Data.Serialize (encode) import Data.Bits (shiftR, shiftL) import Data.Tagged -import Crypto.Random.DRBG.Util +import Data.Word (Word64) class SeedLength h where seedlen :: Tagged h Int +reseedInterval :: Word64 reseedInterval = 2^48 -- Section 10.1.1.1, pg 35 data State d = St - { value :: B.ByteString -- seedlen bits - , constant :: B.ByteString -- seedlen bits - , counter :: Integer -- Number of RBG requests since last reseed - -- start admin info - , hsh :: L.ByteString -> d - } + { counter :: {-# UNPACK #-} !Word64 -- Number of RBG requests since last reseed + -- start admin info + , value :: B.ByteString -- seedlen bits + , constant :: B.ByteString -- seedlen bits + , hsh :: L.ByteString -> d + } -- section 10.1.1.2 pg 36 instantiate :: (Hash c d, SeedLength d) => Entropy -> Nonce -> PersonalizationString -> State d instantiate entropyInput nonce perStr = - let seedMaterial = B.concat [entropyInput, nonce, perStr] - slen = seedlen .::. d - seed = hash_df f seedMaterial slen - v = seed - c = hash_df f (B.cons 0 v) slen - f = hash - d = f undefined - in St v c 1 f + let seedMaterial = B.concat [entropyInput, nonce, perStr] + slen = seedlen .::. d + seed = hash_df f seedMaterial slen + v = seed + c = hash_df f (B.cons 0 v) slen + f = hash + d = f undefined + in St 1 v c f -- section 10.1.1.3 pg 37 reseed :: (SeedLength d, Hash c d) => State d -> Entropy -> AdditionalInput -> State d reseed st ent additionalInput = - let seedMaterial = B.concat [B.pack [1], value st, ent, additionalInput] - seed = hash_df f seedMaterial (seedlen `for` d) - v = seed - c = hash_df f (B.cons 0 v) (seedlen `for` d) - f = hash - d = f undefined - in St v c 1 f + let seedMaterial = B.concat [B.pack [1], value st, ent, additionalInput] + seed = hash_df f seedMaterial (seedlen `for` d) + v = seed + c = hash_df f (B.cons 0 v) (seedlen `for` d) + f = hash + d = f undefined + in St 1 v c f -- section 10.1.1.4 pg 38 -- Nothing indicates a need to reseed generate :: (Hash c d, SeedLength d) => State d -> BitLen -> AdditionalInput -> Maybe (RandomBits, State d) generate st req additionalInput = - if (counter st > reseedInterval) - then Nothing - else Just (retBits, st { value = v2, counter = cnt}) + if (counter st > reseedInterval) + then Nothing + else Just (retBits, st { value = v2, counter = cnt}) where w = hash [B.singleton 2, value st, additionalInput] v1 = if B.length additionalInput == 0 then value st else i2bs slen (bs2i (value st) + bs2i w) retBits = hashGen d req v1 h = hash [B.cons 3 v1] - v2 = i2bs slen (sum $ counter st : map bs2i [v1, h, constant st]) + -- TODO determine if Integer is needed here and move to Word64 if possible + v2 = i2bs slen (sum $ fromIntegral (counter st) : map bs2i [v1, h, constant st]) cnt = counter st + 1 slen = seedlen `for` d hash = encode . hashF . L.fromChunks @@ -84,10 +86,10 @@ getW :: B.ByteString -> Int -> [B.ByteString] getW _ 0 = [] getW dat i = - let wi = encode (h dat) - dat' = incBS dat - rest = getW dat' (i-1) - in wi : rest + let wi = encode (h dat) + dat' = incBS dat + rest = getW dat' (i-1) + in wi : rest slen = seedlen `for` d outlen = outputLength `for` d h = hashFunc' d diff --git a/Crypto/Random/DRBG/HashDF.hs b/Crypto/Random/DRBG/HashDF.hs --- a/Crypto/Random/DRBG/HashDF.hs +++ b/Crypto/Random/DRBG/HashDF.hs @@ -16,7 +16,7 @@ outlen = outputLength .::. (hashF undefined) hash = encode . hashF . L.fromChunks . \x -> [x] getT tmp cnt - | B.length tmp >= reqBytes = tmp + | B.length tmp >= reqBytes = tmp | otherwise = let new = hash (B.concat [B.singleton cnt, reqBitsBS, str]) in getT (B.append tmp new) (cnt + 1) len = (if reqBits `rem` outlen == 0 then reqBits `div` outlen else (reqBits + outlen) `div` outlen) reqBitsBS = runPut $ putWord32be (fromIntegral reqBits :: Word32) diff --git a/Crypto/Random/DRBG/Util.hs b/Crypto/Random/DRBG/Util.hs deleted file mode 100644 --- a/Crypto/Random/DRBG/Util.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Crypto.Random.DRBG.Util where - -import qualified Data.ByteString as B -import Crypto.Random.DRBG.Types -import Data.Bits (shiftL, shiftR) - -{-# INLINE incBS #-} -incBS :: B.ByteString -> B.ByteString -incBS bs = B.concat (go bs (B.length bs - 1)) - where - go bs i - | B.length bs == 0 = [] - | B.index bs i == 0xFF = (go (B.init bs) (i-1)) ++ [B.singleton 0] - | otherwise = [B.init bs] ++ [B.singleton $ (B.index bs i) + 1] - --- Appendix B -i2bs :: BitLen -> Integer -> B.ByteString -i2bs l i = B.unfoldr (\l' -> if l' < 0 then Nothing else Just (fromIntegral (i `shiftR` l'), l' - 8)) (l-8) -{-# INLINE i2bs #-} - -bs2i :: B.ByteString -> Integer -bs2i bs = B.foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 bs -{-# INLINE bs2i #-} diff --git a/DRBG.cabal b/DRBG.cabal --- a/DRBG.cabal +++ b/DRBG.cabal @@ -1,5 +1,5 @@ name: DRBG -version: 0.3 +version: 0.3.2 license: BSD3 license-file: LICENSE author: Thomas DuBuisson @@ -23,7 +23,7 @@ Library Build-Depends: base >= 4.0 && < 5, cereal >= 0.2, bytestring, prettyclass, tagged >= 0.2, - crypto-api >= 0.6, cryptohash >= 0.6.1, parallel, mtl >= 2.0, + crypto-api >= 0.12, cryptohash-cryptoapi >= 0.1, parallel, mtl >= 2.0, cipher-aes128, entropy ghc-options: -O2 hs-source-dirs: @@ -31,12 +31,16 @@ Crypto.Random.DRBG.HMAC, Crypto.Random.DRBG, Crypto.Random.DRBG.Types - other-modules: Crypto.Random.DRBG.HashDF Crypto.Random.DRBG.Util + other-modules: Crypto.Random.DRBG.HashDF Executable drbg_test if !flag(test) buildable: False main-is: Test/KAT.hs if flag(test) - build-depends: base, QuickCheck, crypto-api, bytestring, binary, cereal, cryptohash, crypto-api-tests, HUnit, test-framework, test-framework-hunit + build-depends: base, QuickCheck, crypto-api, bytestring, binary, cereal, cryptohash-cryptoapi, crypto-api-tests, HUnit, test-framework, test-framework-hunit other-modules: Paths_DRBG + +source-repository head + type: git + location: https://github.com/TomMD/cipher-aes128