commit 41529155f1d85720234136978ab4e5313b472bcc
parent 298a9e4eb8f2149c0e04d1b97ee1f4869be65651
Author: Jared Tobin <jared@jtobin.io>
Date: Sun, 1 Feb 2026 15:34:43 +0400
lib: major refactoring
Diffstat:
7 files changed, 492 insertions(+), 340 deletions(-)
diff --git a/CHANGELOG b/CHANGELOG
@@ -1,5 +1,23 @@
# Changelog
+- 0.3.0 (2026-02-01)
+ * This backwards-incompatible version changes the "bring your own HMAC
+ function" design and simply provides specialized DRBGs for
+ HMAC-SHA256 and HMAC-SHA512, respectively. These HMAC functions are
+ provided by ppad-sha256 and ppad-sha512.
+
+ * The rationale here is to provide better security guarantees around
+ the DRBG state. Now, the DRBG state is restricted to a single, pinned,
+ heap-allocated mutable buffer; components of it are /never/
+ allocated anywhere else on the heap during DRBG operation (not even
+ in temporary, to-be-GC'd bytestrings). A new 'wipe' function is also
+ exposed for explicitly zeroing out state when one is finished
+ generating bytes from the DRBG.
+
+ * Aside from the increased security guarantees, DRBG performance is
+ dramatically improved, and other heap allocation dramatically
+ limited, compared to previous versions.
+
- 0.2.1 (2026-01-10)
* Simply adds bounds to the ppad-sha{256,512} dependencies in the test and
benchmark suites.
diff --git a/bench/Main.hs b/bench/Main.hs
@@ -5,29 +5,30 @@
module Main where
import Criterion.Main
-import qualified Crypto.DRBG.HMAC.SHA256 as DRBG
+import qualified Crypto.DRBG.HMAC.SHA256 as DRBG256
+import qualified Crypto.DRBG.HMAC.SHA512 as DRBG512
main :: IO ()
main = do
- !drbg256 <- DRBG.new mempty mempty mempty
- -- !drbg512 <- DRBG.new mempty mempty mempty
+ !drbg256 <- DRBG256.new mempty mempty mempty
+ !drbg512 <- DRBG512.new mempty mempty mempty
defaultMain [
- suite drbg256
+ suite drbg256 drbg512
]
-suite drbg256 =
+suite drbg256 drbg512 =
bgroup "ppad-hmac-drbg" [
bgroup "HMAC-SHA256" [
- bench "new" $ whnfAppIO (DRBG.new mempty mempty) mempty
- , bench "reseed" $ whnfAppIO (DRBG.reseed drbg256 mempty) mempty
- , bench "gen (32B)" $ whnfAppIO (DRBG.gen drbg256 mempty) 32
- , bench "gen (256B)" $ whnfAppIO (DRBG.gen drbg256 mempty) 256
+ bench "new" $ whnfAppIO (DRBG256.new mempty mempty) mempty
+ , bench "reseed" $ whnfAppIO (DRBG256.reseed drbg256 mempty) mempty
+ , bench "gen (32B)" $ whnfAppIO (DRBG256.gen drbg256 mempty) 32
+ , bench "gen (256B)" $ whnfAppIO (DRBG256.gen drbg256 mempty) 256
+ ]
+ , bgroup "HMAC-SHA512" [
+ bench "new" $ whnfAppIO (DRBG512.new mempty mempty) mempty
+ , bench "reseed" $ whnfAppIO (DRBG512.reseed drbg512 mempty) mempty
+ , bench "gen (32B)" $ whnfAppIO (DRBG512.gen drbg512 mempty) 32
+ , bench "gen (256B)" $ whnfAppIO (DRBG512.gen drbg512 mempty) 256
]
- -- , bgroup "HMAC-SHA512" [
- -- bench "new" $ whnfAppIO (DRBG.new mempty mempty) mempty
- -- , bench "reseed" $ whnfAppIO (DRBG.reseed drbg512 mempty) mempty
- -- , bench "gen (32B)" $ whnfAppIO (DRBG.gen drbg512 mempty) 32
- -- , bench "gen (256B)" $ whnfAppIO (DRBG.gen drbg512 mempty) 256
- -- ]
]
diff --git a/bench/Weight.hs b/bench/Weight.hs
@@ -9,21 +9,34 @@
module Main where
import Control.DeepSeq
-import qualified Crypto.DRBG.HMAC.SHA256 as DRBG
+import qualified Crypto.DRBG.HMAC.SHA256 as DRBG256
+import qualified Crypto.DRBG.HMAC.SHA512 as DRBG512
import Weigh
-instance NFData (DRBG.DRBG s) where
+instance NFData (DRBG256.DRBG s) where
rnf d = d `seq` ()
-instance NFData DRBG.Error where
+instance NFData DRBG256.Error where
+ rnf e = e `seq` ()
+
+instance NFData (DRBG512.DRBG s) where
+ rnf d = d `seq` ()
+
+instance NFData DRBG512.Error where
rnf e = e `seq` ()
main :: IO ()
main = do
- !drbg <- DRBG.new mempty mempty mempty
+ !drbg256 <- DRBG256.new mempty mempty mempty
+ !drbg512 <- DRBG512.new mempty mempty mempty
mainWith $ do
wgroup "HMAC-SHA256" $ do
- io "new" (DRBG.new mempty mempty) mempty
- io "reseed" (DRBG.reseed drbg mempty) mempty
- io "gen (32B)" (DRBG.gen drbg mempty) 32
- io "gen (256B)" (DRBG.gen drbg mempty) 256
+ io "new" (DRBG256.new mempty mempty) mempty
+ io "reseed" (DRBG256.reseed drbg256 mempty) mempty
+ io "gen (32B)" (DRBG256.gen drbg256 mempty) 32
+ io "gen (256B)" (DRBG256.gen drbg256 mempty) 256
+ wgroup "HMAC-SHA512" $ do
+ io "new" (DRBG512.new mempty mempty) mempty
+ io "reseed" (DRBG512.reseed drbg512 mempty) mempty
+ io "gen (32B)" (DRBG512.gen drbg512 mempty) 32
+ io "gen (256B)" (DRBG512.gen drbg512 mempty) 256
diff --git a/lib/Crypto/DRBG/HMAC.hs b/lib/Crypto/DRBG/HMAC.hs
@@ -1,280 +0,0 @@
-{-# OPTIONS_HADDOCK prune #-}
-{-# OPTIONS_GHC -funbox-small-strict-fields #-}
-{-# LANGUAGE BangPatterns #-}
-
--- |
--- Module: Crypto.DRBG.HMAC
--- Copyright: (c) 2024 Jared Tobin
--- License: MIT
--- Maintainer: Jared Tobin <jared@ppad.tech>
---
--- A pure HMAC-DRBG implementation, as specified by
--- [NIST SP-800-90A](https://nvlpubs.nist.gov/nistpubs/SpecialPublications/NIST.SP.800-90Ar1.pdf).
-
-module Crypto.DRBG.HMAC (
- -- * DRBG and HMAC function types
- DRBG
- , HMAC
- , Error(..)
- , _read_v
- , _read_k
-
- -- * DRBG interaction
- , new
- , gen
- , reseed
- ) where
-
-import Control.Monad.Primitive (PrimMonad, PrimState)
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Builder as BSB
-import qualified Data.ByteString.Builder.Extra as BE
-import qualified Data.ByteString.Internal as BI
-import qualified Data.Primitive.MutVar as P
-import Data.Word (Word64)
-
--- keystroke savers and utilities ---------------------------------------------
-
-fi :: (Integral a, Num b) => a -> b
-fi = fromIntegral
-{-# INLINE fi #-}
-
-to_strict :: BSB.Builder -> BS.ByteString
-to_strict = BS.toStrict . BSB.toLazyByteString
-{-# INLINE to_strict #-}
-
-to_strict_small :: BSB.Builder -> BS.ByteString
-to_strict_small = BS.toStrict . BE.toLazyByteStringWith
- (BE.safeStrategy 128 BE.smallChunkSize) mempty
-{-# INLINE to_strict_small #-}
-
--- dumb strict pair
-data Pair a b = Pair !a !b
- deriving Show
-
--- types ----------------------------------------------------------------------
-
--- | A DRBG error.
-data Error =
- MaxBytesExceeded -- ^ More than 65536 bytes have been requested.
- | ReseedRequired -- ^ The DRBG must be reseeded (via 'reseed').
- deriving (Eq, Show)
-
--- see SP 800-90A table 2
-_RESEED_COUNTER :: Word64
-_RESEED_COUNTER = (2 :: Word64) ^ (48 :: Word64)
-
--- | A deterministic random bit generator (DRBG).
---
--- Create a DRBG with 'new', and then use and reuse it to generate
--- bytes as needed.
---
--- >>> drbg <- new hmac entropy nonce personalization_string
--- >>> bytes0 <- gen addl_bytes 16 drbg
--- >>> bytes1 <- gen addl_bytes 16 drbg
--- >>> drbg
--- "<drbg>"
-newtype DRBG s = DRBG (P.MutVar s DRBGState)
-
-instance Show (DRBG s) where
- show _ = "<drbg>"
-
--- DRBG environment data and state
-data DRBGState = DRBGState
- !HMACEnv -- hmac function & outlen
- {-# UNPACK #-} !Word64 -- reseed counter
- {-# UNPACK #-} !BS.ByteString -- v
- {-# UNPACK #-} !BS.ByteString -- key
-
--- NB following synonym really only exists to make haddocks more
--- readable
-
--- | A HMAC function, taking a key as the first argument and the input
--- value as the second, producing a MAC digest.
---
--- >>> import qualified Crypto.Hash.SHA256 as SHA256
--- >>> let hmac k b = let SHA256.MAC m = SHA256.hmac k b in m
--- >>> :t hmac
--- hmac :: BS.ByteString -> BS.ByteString -> BS.ByteString
-type HMAC = BS.ByteString -> BS.ByteString -> BS.ByteString
-
--- HMAC function and its associated outlength
-data HMACEnv = HMACEnv
- !HMAC
- {-# UNPACK #-} !Word64
-
--- the following convenience functions are useful for testing
-
-_read_v
- :: PrimMonad m
- => DRBG (PrimState m)
- -> m BS.ByteString
-_read_v (DRBG mut) = do
- DRBGState _ _ v _ <- P.readMutVar mut
- pure v
-
-_read_k
- :: PrimMonad m
- => DRBG (PrimState m)
- -> m BS.ByteString
-_read_k (DRBG mut) = do
- DRBGState _ _ _ k <- P.readMutVar mut
- pure k
-
--- drbg interaction ------------------------------------------------------
-
--- | Create a DRBG from the supplied HMAC function, entropy, nonce, and
--- personalization string.
---
--- You can instantiate the DRBG using any appropriate HMAC function;
--- it should merely take a key and value as input, as is standard, and
--- return a MAC digest, each being a strict 'ByteString'.
---
--- The DRBG is returned in any 'PrimMonad', e.g. 'ST' or 'IO'.
---
--- >>> import qualified Crypto.Hash.SHA256 as SHA256
--- >>> let hmac k b = let SHA256.MAC m = SHA256.hmac k b in m
--- >>> new hmac entropy nonce personalization_string
--- "<drbg>"
-new
- :: PrimMonad m
- => HMAC -- ^ HMAC function
- -> BS.ByteString -- ^ entropy
- -> BS.ByteString -- ^ nonce
- -> BS.ByteString -- ^ personalization string
- -> m (DRBG (PrimState m))
-new hmac entropy nonce ps = do
- let !drbg = new_pure hmac entropy nonce ps
- mut <- P.newMutVar drbg
- pure (DRBG mut)
-
--- | Generate bytes from a DRBG, optionally injecting additional bytes
--- per SP 800-90A.
---
--- Per SP 800-90A, the maximum number of bytes that can be requested
--- on any invocation is 65536. Larger requests will return
--- 'MaxBytesExceeded'.
---
--- >>> import qualified Data.ByteString.Base16 as B16
--- >>> drbg <- new hmac entropy nonce personalization_string
--- >>> Right bytes0 <- gen addl_bytes 16 drbg
--- >>> Right bytes1 <- gen addl_bytes 16 drbg
--- >>> B16.encode bytes0
--- "938d6ca6d0b797f7b3c653349d6e3135"
--- >>> B16.encode bytes1
--- "5f379d16de6f2c6f8a35c56f13f9e5a5"
-gen
- :: PrimMonad m
- => BS.ByteString -- ^ additional bytes to inject
- -> Word64 -- ^ number of bytes to generate
- -> DRBG (PrimState m)
- -> m (Either Error BS.ByteString)
-gen addl bytes (DRBG mut) = do
- drbg0 <- P.readMutVar mut
- case gen_pure addl bytes drbg0 of
- Left e -> pure (Left e)
- Right !(Pair bs drbg1) -> do
- P.writeMutVar mut drbg1
- pure (Right bs)
-
--- | Reseed a DRBG.
---
--- Each DRBG has an internal /reseed counter/ that tracks the number
--- of requests made to the generator (note /requests made/, not bytes
--- generated). SP 800-90A specifies that a HMAC-DRBG should support
--- 2 ^ 48 requests before requiring a reseed, so in practice you're
--- unlikely to ever need to use this to actually reset the counter.
---
--- Note however that 'reseed' can be used to implement "explicit"
--- prediction resistance, per SP 800-90A, by injecting entropy generated
--- elsewhere into the DRBG.
---
--- >>> import qualified System.Entropy as E
--- >>> entropy <- E.getEntropy 32
--- >>> reseed entropy addl_bytes drbg
--- "<reseeded drbg>"
-reseed
- :: PrimMonad m
- => BS.ByteString -- ^ entropy to inject
- -> BS.ByteString -- ^ additional bytes to inject
- -> DRBG (PrimState m)
- -> m ()
-reseed ent add (DRBG drbg) = P.modifyMutVar' drbg (reseed_pure ent add)
-
--- pure drbg interaction ------------------------------------------------------
-
--- SP 800-90A 10.1.2.2
-update_pure
- :: BS.ByteString
- -> DRBGState
- -> DRBGState
-update_pure provided_data (DRBGState h@(HMACEnv hmac _) r v0 k0) =
- let !k1 = hmac k0 (cat v0 0x00 provided_data)
- !v1 = hmac k1 v0
- in if BS.null provided_data
- then DRBGState h r v1 k1
- else let !k2 = hmac k1 (cat v1 0x01 provided_data)
- !v2 = hmac k2 v1
- in DRBGState h r v2 k2
- where
- cat bs byte suf@(BI.PS _ _ l) =
- let bil = BSB.byteString bs <> BSB.word8 byte <> BSB.byteString suf
- in if l < 64
- then to_strict_small bil
- else to_strict bil
- {-# INLINE cat #-}
-
--- SP 800-90A 10.1.2.3
-new_pure
- :: HMAC -- HMAC function
- -> BS.ByteString -- entropy
- -> BS.ByteString -- nonce
- -> BS.ByteString -- personalization string
- -> DRBGState
-new_pure hmac entropy nonce ps =
- let !drbg = DRBGState (HMACEnv hmac outlen) 1 v0 k0
- in update_pure seed_material drbg
- where
- seed_material = entropy <> nonce <> ps
- outlen = fi (BS.length (hmac mempty mempty))
- k0 = BS.replicate (fi outlen) 0x00
- v0 = BS.replicate (fi outlen) 0x01
-
--- SP 800-90A 10.1.2.4
-reseed_pure :: BS.ByteString -> BS.ByteString -> DRBGState -> DRBGState
-reseed_pure entropy addl drbg =
- let !(DRBGState h _ v k) = update_pure (entropy <> addl) drbg
- in DRBGState h 1 v k
-
--- SP 800-90A 10.1.2.5
-gen_pure
- :: BS.ByteString
- -> Word64
- -> DRBGState
- -> Either Error (Pair BS.ByteString DRBGState)
-gen_pure addl bytes drbg0@(DRBGState h@(HMACEnv hmac outlen) _ _ _)
- | bytes > 0x10000 = Left MaxBytesExceeded
- | r > _RESEED_COUNTER = Left ReseedRequired
- | otherwise =
- let !(Pair temp drbg1) = loop mempty 0 v1
- returned_bits = BS.take (fi bytes) temp
- drbg = update_pure addl drbg1
- in Right (Pair returned_bits drbg)
- where
- !(DRBGState _ r v1 k1)
- | BS.null addl = drbg0
- | otherwise = update_pure addl drbg0
-
- loop !acc !len !vl
- | len < bytes =
- let nv = hmac k1 vl
- nacc = acc <> BSB.byteString nv
- nlen = len + outlen
- in loop nacc nlen nv
-
- | otherwise =
- let facc | bytes < 128 = to_strict_small acc
- | otherwise = to_strict acc
- in Pair facc (DRBGState h (succ r) vl k1)
-{-# INLINE gen_pure #-}
-
diff --git a/lib/Crypto/DRBG/HMAC/SHA512.hs b/lib/Crypto/DRBG/HMAC/SHA512.hs
@@ -0,0 +1,383 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+-- |
+-- Module: Crypto.DRBG.HMAC.SHA512
+-- Copyright: (c) 2024 Jared Tobin
+-- License: MIT
+-- Maintainer: Jared Tobin <jared@ppad.tech>
+--
+-- A pure HMAC-DRBG implementation, as specified by
+-- [NIST SP-800-90A](https://nvlpubs.nist.gov/nistpubs/SpecialPublications/NIST.SP.800-90Ar1.pdf).
+
+module Crypto.DRBG.HMAC.SHA512 (
+ -- * DRBG and HMAC function types
+ DRBG
+ , Error(..)
+
+ -- * DRBG interaction
+ , new
+ , gen
+ , reseed
+ , wipe
+
+ -- for testing
+ , _read_v
+ , _read_k
+ ) where
+
+import qualified Crypto.Hash.SHA512 as SHA512
+import Crypto.Hash.SHA512.Internal (Registers(..))
+import qualified Crypto.Hash.SHA512.Internal as SHA512 (cat)
+import Control.Monad.Primitive (PrimMonad, PrimState)
+import qualified Control.Monad.Primitive as Prim (unsafeIOToPrim)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Builder as BSB
+import qualified Data.ByteString.Internal as BI
+import qualified Data.Primitive.PrimArray as PA
+import Data.Word (Word64)
+import qualified GHC.Word
+import qualified Foreign.Ptr as FP
+
+-- api ------------------------------------------------------------------------
+
+-- | A DRBG error.
+data Error =
+ MaxBytesExceeded -- ^ More than 65536 bytes have been requested.
+ | ReseedRequired -- ^ The DRBG must be reseeded (via 'reseed').
+ deriving (Eq, Show)
+
+-- see SP 800-90A table 2
+_RESEED_COUNTER :: Word64
+_RESEED_COUNTER = (2 :: Word64) ^ (48 :: Word64)
+{-# NOINLINE _RESEED_COUNTER #-}
+
+-- | A deterministic random bit generator (DRBG).
+--
+-- Create a DRBG with 'new', and then use and reuse it to generate
+-- bytes as needed.
+--
+-- >>> drbg <- new entropy nonce personalization_string
+-- >>> bytes0 <- gen drbg mempty 10
+-- >>> bytes1 <- gen drbg mempty 10
+-- >>> drbg
+-- "<drbg>"
+
+-- layout (Word64 array):
+-- index 0: counter
+-- indices 1-8: k (8 Word64s = 64 bytes)
+-- indices 9-16: v (8 Word64s = 64 bytes)
+-- indices 17-32: scratch space (16 Word64s = 128 bytes)
+newtype DRBG s = DRBG (PA.MutablePrimArray s Word64)
+
+instance Show (DRBG s) where
+ show _ = "<drbg>"
+
+-- | Create a HMAC-SHA512 DRBG from the supplied entropy, nonce, and
+-- personalization string.
+--
+-- The DRBG is returned in any 'PrimMonad', e.g. 'ST s' or 'IO'.
+--
+-- >>> new entropy nonce personalization_string
+-- "<drbg>"
+new
+ :: PrimMonad m
+ => BS.ByteString -- ^ entropy
+ -> BS.ByteString -- ^ nonce
+ -> BS.ByteString -- ^ personalization string
+ -> m (DRBG (PrimState m))
+new entropy nonce ps = do
+ drbg <- PA.newPinnedPrimArray 33 -- 1 (ctr) + 16 (k, v) + 16 (scratch)
+ init_counter drbg
+ PA.setPrimArray drbg 01 08 (0x0000000000000000 :: Word64) -- init k
+ PA.setPrimArray drbg 09 08 (0x0101010101010101 :: Word64) -- init v
+ PA.setPrimArray drbg 17 16 (0x0000000000000000 :: Word64) -- scratch
+ update drbg (entropy <> nonce <> ps)
+ pure $! DRBG drbg
+{-# INLINABLE new #-}
+
+-- | Reseed a DRBG.
+--
+-- Each DRBG has an internal /reseed counter/ that tracks the number
+-- of requests made to the generator (note /requests made/, not bytes
+-- generated). SP 800-90A specifies that a HMAC-DRBG should support
+-- 2 ^ 48 requests before requiring a reseed, so in practice you're
+-- unlikely to ever need to use this to actually reset the counter.
+--
+-- Note however that 'reseed' can be used to implement "explicit"
+-- prediction resistance, per SP 800-90A, by injecting entropy generated
+-- elsewhere into the DRBG.
+--
+-- >>> import qualified System.Entropy as E
+-- >>> entropy <- E.getEntropy 32
+-- >>> reseed entropy addl_bytes drbg
+-- "<reseeded drbg>"
+reseed
+ :: PrimMonad m
+ => DRBG (PrimState m)
+ -> BS.ByteString
+ -> BS.ByteString
+ -> m ()
+reseed (DRBG drbg) entr addl = do
+ update drbg (entr <> addl)
+ init_counter drbg
+{-# INLINE reseed #-}
+
+-- | Generate bytes from a DRBG, optionally injecting additional bytes
+-- per SP 800-90A.
+--
+-- Per SP 800-90A, the maximum number of bytes that can be requested
+-- on any invocation is 65536. Larger requests will return
+-- 'MaxBytesExceeded'.
+--
+-- >>> import qualified Data.ByteString.Base16 as B16
+-- >>> drbg <- new entropy nonce personalization_string
+-- >>> Right bytes0 <- gen drbg addl_bytes 16
+-- >>> Right bytes1 <- gen drbg addl_bytes 16
+-- >>> B16.encode bytes0
+-- "938d6ca6d0b797f7b3c653349d6e3135"
+-- >>> B16.encode bytes1
+-- "5f379d16de6f2c6f8a35c56f13f9e5a5"
+gen
+ :: PrimMonad m
+ => DRBG (PrimState m)
+ -> BS.ByteString
+ -> Word64
+ -> m (Either Error BS.ByteString)
+gen (DRBG drbg) addl@(BI.PS _ _ l) bytes
+ | bytes > 0x10000 = pure $! Left MaxBytesExceeded
+ | otherwise = do
+ ctr <- read_counter drbg
+ if ctr > _RESEED_COUNTER
+ then pure $! Left ReseedRequired
+ else do
+ if l == 0 then pure () else update drbg addl
+ !(GHC.Word.W64# k00) <- PA.readPrimArray drbg 01
+ !(GHC.Word.W64# k01) <- PA.readPrimArray drbg 02
+ !(GHC.Word.W64# k02) <- PA.readPrimArray drbg 03
+ !(GHC.Word.W64# k03) <- PA.readPrimArray drbg 04
+ !(GHC.Word.W64# k04) <- PA.readPrimArray drbg 05
+ !(GHC.Word.W64# k05) <- PA.readPrimArray drbg 06
+ !(GHC.Word.W64# k06) <- PA.readPrimArray drbg 07
+ !(GHC.Word.W64# k07) <- PA.readPrimArray drbg 08
+ !(GHC.Word.W64# v00) <- PA.readPrimArray drbg 09
+ !(GHC.Word.W64# v01) <- PA.readPrimArray drbg 10
+ !(GHC.Word.W64# v02) <- PA.readPrimArray drbg 11
+ !(GHC.Word.W64# v03) <- PA.readPrimArray drbg 12
+ !(GHC.Word.W64# v04) <- PA.readPrimArray drbg 13
+ !(GHC.Word.W64# v05) <- PA.readPrimArray drbg 14
+ !(GHC.Word.W64# v06) <- PA.readPrimArray drbg 15
+ !(GHC.Word.W64# v07) <- PA.readPrimArray drbg 16
+ let !k0 = Registers (# k00, k01, k02, k03, k04, k05, k06, k07 #)
+ !v0 = Registers (# v00, v01, v02, v03, v04, v05, v06, v07 #)
+ !res <- gen_loop drbg k0 v0 bytes
+ update drbg addl
+ write_counter drbg (ctr + 1)
+ pure $! Right res
+{-# INLINABLE gen #-}
+
+-- | Wipe the state of a DRBG.
+--
+-- You should call this when you're finished with a DRBG to ensure that its
+-- state is wiped from memory.
+--
+-- >>> drbg <- new mempty mempty mempty
+-- >>> Right bytes <- gen drbg addl_bytes 16
+-- >>> wipe drbg
+-- >>> -- do something with bytes
+wipe
+ :: PrimMonad m
+ => DRBG (PrimState m)
+ -> m ()
+wipe (DRBG drbg) = do
+ init_counter drbg
+ PA.setPrimArray drbg 01 08 (0x0000000000000000 :: Word64) -- init k
+ PA.setPrimArray drbg 09 08 (0x0101010101010101 :: Word64) -- init v
+ PA.setPrimArray drbg 17 16 (0x0000000000000000 :: Word64) -- init scratch
+{-# INLINE wipe #-}
+
+-- drbg utilities -------------------------------------------------------------
+
+gen_loop
+ :: PrimMonad m
+ => PA.MutablePrimArray (PrimState m) Word64
+ -> Registers
+ -> Registers
+ -> Word64
+ -> m BS.ByteString
+gen_loop drbg k0 v0 bytes = loop mempty v0 0 where
+ !vp = PA.mutablePrimArrayContents drbg `FP.plusPtr` 72 -- 9 * 8
+ !sp = PA.mutablePrimArrayContents drbg `FP.plusPtr` 136 -- 17 * 8
+ loop !acc v l
+ | l >= bytes = do
+ write_v drbg v
+ pure acc
+ | otherwise = do
+ Prim.unsafeIOToPrim $ SHA512._hmac_rr vp sp k0 v
+ !(GHC.Word.W64# nv0) <- PA.readPrimArray drbg 09
+ !(GHC.Word.W64# nv1) <- PA.readPrimArray drbg 10
+ !(GHC.Word.W64# nv2) <- PA.readPrimArray drbg 11
+ !(GHC.Word.W64# nv3) <- PA.readPrimArray drbg 12
+ !(GHC.Word.W64# nv4) <- PA.readPrimArray drbg 13
+ !(GHC.Word.W64# nv5) <- PA.readPrimArray drbg 14
+ !(GHC.Word.W64# nv6) <- PA.readPrimArray drbg 15
+ !(GHC.Word.W64# nv7) <- PA.readPrimArray drbg 16
+ let !nv = Registers (# nv0, nv1, nv2, nv3, nv4, nv5, nv6, nv7 #)
+ !na = acc <> SHA512.cat nv
+ !nl = l + 64
+ loop na nv nl
+{-# INLINE gen_loop #-}
+
+update
+ :: PrimMonad m
+ => PA.MutablePrimArray (PrimState m) Word64
+ -> BS.ByteString
+ -> m ()
+update drbg provided_data@(BI.PS _ _ l) = do
+ !(GHC.Word.W64# k00) <- PA.readPrimArray drbg 01
+ !(GHC.Word.W64# k01) <- PA.readPrimArray drbg 02
+ !(GHC.Word.W64# k02) <- PA.readPrimArray drbg 03
+ !(GHC.Word.W64# k03) <- PA.readPrimArray drbg 04
+ !(GHC.Word.W64# k04) <- PA.readPrimArray drbg 05
+ !(GHC.Word.W64# k05) <- PA.readPrimArray drbg 06
+ !(GHC.Word.W64# k06) <- PA.readPrimArray drbg 07
+ !(GHC.Word.W64# k07) <- PA.readPrimArray drbg 08
+ !(GHC.Word.W64# v00) <- PA.readPrimArray drbg 09
+ !(GHC.Word.W64# v01) <- PA.readPrimArray drbg 10
+ !(GHC.Word.W64# v02) <- PA.readPrimArray drbg 11
+ !(GHC.Word.W64# v03) <- PA.readPrimArray drbg 12
+ !(GHC.Word.W64# v04) <- PA.readPrimArray drbg 13
+ !(GHC.Word.W64# v05) <- PA.readPrimArray drbg 14
+ !(GHC.Word.W64# v06) <- PA.readPrimArray drbg 15
+ !(GHC.Word.W64# v07) <- PA.readPrimArray drbg 16
+ let !k0 = Registers (# k00, k01, k02, k03, k04, k05, k06, k07 #)
+ !v0 = Registers (# v00, v01, v02, v03, v04, v05, v06, v07 #)
+ !kp = PA.mutablePrimArrayContents drbg `FP.plusPtr` 08 -- 1 * 8
+ !vp = PA.mutablePrimArrayContents drbg `FP.plusPtr` 72 -- 9 * 8
+ !sp = PA.mutablePrimArrayContents drbg `FP.plusPtr` 136 -- 17 * 8
+ Prim.unsafeIOToPrim $ SHA512._hmac_rsb kp sp k0 v0 0x00 provided_data
+ !(GHC.Word.W64# k10) <- PA.readPrimArray drbg 01
+ !(GHC.Word.W64# k11) <- PA.readPrimArray drbg 02
+ !(GHC.Word.W64# k12) <- PA.readPrimArray drbg 03
+ !(GHC.Word.W64# k13) <- PA.readPrimArray drbg 04
+ !(GHC.Word.W64# k14) <- PA.readPrimArray drbg 05
+ !(GHC.Word.W64# k15) <- PA.readPrimArray drbg 06
+ !(GHC.Word.W64# k16) <- PA.readPrimArray drbg 07
+ !(GHC.Word.W64# k17) <- PA.readPrimArray drbg 08
+ let !k1 = Registers (# k10, k11, k12, k13, k14, k15, k16, k17 #)
+ Prim.unsafeIOToPrim $ SHA512._hmac_rr vp sp k1 v0
+ if l == 0
+ then pure ()
+ else do
+ !(GHC.Word.W64# v10) <- PA.readPrimArray drbg 09
+ !(GHC.Word.W64# v11) <- PA.readPrimArray drbg 10
+ !(GHC.Word.W64# v12) <- PA.readPrimArray drbg 11
+ !(GHC.Word.W64# v13) <- PA.readPrimArray drbg 12
+ !(GHC.Word.W64# v14) <- PA.readPrimArray drbg 13
+ !(GHC.Word.W64# v15) <- PA.readPrimArray drbg 14
+ !(GHC.Word.W64# v16) <- PA.readPrimArray drbg 15
+ !(GHC.Word.W64# v17) <- PA.readPrimArray drbg 16
+ let !v1 = Registers (# v10, v11, v12, v13, v14, v15, v16, v17 #)
+ Prim.unsafeIOToPrim $ SHA512._hmac_rsb kp sp k1 v1 0x01 provided_data
+ !(GHC.Word.W64# k20) <- PA.readPrimArray drbg 01
+ !(GHC.Word.W64# k21) <- PA.readPrimArray drbg 02
+ !(GHC.Word.W64# k22) <- PA.readPrimArray drbg 03
+ !(GHC.Word.W64# k23) <- PA.readPrimArray drbg 04
+ !(GHC.Word.W64# k24) <- PA.readPrimArray drbg 05
+ !(GHC.Word.W64# k25) <- PA.readPrimArray drbg 06
+ !(GHC.Word.W64# k26) <- PA.readPrimArray drbg 07
+ !(GHC.Word.W64# k27) <- PA.readPrimArray drbg 08
+ let !k2 = Registers (# k20, k21, k22, k23, k24, k25, k26, k27 #)
+ Prim.unsafeIOToPrim $ SHA512._hmac_rr vp sp k2 v1
+{-# INLINABLE update #-}
+
+init_counter
+ :: PrimMonad m
+ => PA.MutablePrimArray (PrimState m) Word64
+ -> m ()
+init_counter drbg =
+ PA.writePrimArray drbg 0 (0x01 :: Word64)
+{-# INLINE init_counter #-}
+
+read_counter
+ :: PrimMonad m
+ => PA.MutablePrimArray (PrimState m) Word64
+ -> m Word64
+read_counter drbg = PA.readPrimArray drbg 0
+{-# INLINE read_counter #-}
+
+write_counter
+ :: PrimMonad m
+ => PA.MutablePrimArray (PrimState m) Word64
+ -> Word64
+ -> m ()
+write_counter drbg = PA.writePrimArray drbg 0
+{-# INLINE write_counter #-}
+
+write_v
+ :: PrimMonad m
+ => PA.MutablePrimArray (PrimState m) Word64
+ -> Registers
+ -> m ()
+write_v drbg (R v0 v1 v2 v3 v4 v5 v6 v7) = do
+ PA.writePrimArray drbg 09 (GHC.Word.W64# v0)
+ PA.writePrimArray drbg 10 (GHC.Word.W64# v1)
+ PA.writePrimArray drbg 11 (GHC.Word.W64# v2)
+ PA.writePrimArray drbg 12 (GHC.Word.W64# v3)
+ PA.writePrimArray drbg 13 (GHC.Word.W64# v4)
+ PA.writePrimArray drbg 14 (GHC.Word.W64# v5)
+ PA.writePrimArray drbg 15 (GHC.Word.W64# v6)
+ PA.writePrimArray drbg 16 (GHC.Word.W64# v7)
+{-# INLINE write_v #-}
+
+-- read secret drbg state (for testing)
+_read_v
+ :: PrimMonad m
+ => DRBG (PrimState m)
+ -> m BS.ByteString
+_read_v (DRBG drbg) = do
+ !v00 <- PA.readPrimArray drbg 09
+ !v01 <- PA.readPrimArray drbg 10
+ !v02 <- PA.readPrimArray drbg 11
+ !v03 <- PA.readPrimArray drbg 12
+ !v04 <- PA.readPrimArray drbg 13
+ !v05 <- PA.readPrimArray drbg 14
+ !v06 <- PA.readPrimArray drbg 15
+ !v07 <- PA.readPrimArray drbg 16
+ pure . BS.toStrict . BSB.toLazyByteString $ mconcat [
+ BSB.word64BE v00
+ , BSB.word64BE v01
+ , BSB.word64BE v02
+ , BSB.word64BE v03
+ , BSB.word64BE v04
+ , BSB.word64BE v05
+ , BSB.word64BE v06
+ , BSB.word64BE v07
+ ]
+
+-- read secret drbg state (for testing)
+_read_k
+ :: PrimMonad m
+ => DRBG (PrimState m)
+ -> m BS.ByteString
+_read_k (DRBG drbg) = do
+ !k00 <- PA.readPrimArray drbg 01
+ !k01 <- PA.readPrimArray drbg 02
+ !k02 <- PA.readPrimArray drbg 03
+ !k03 <- PA.readPrimArray drbg 04
+ !k04 <- PA.readPrimArray drbg 05
+ !k05 <- PA.readPrimArray drbg 06
+ !k06 <- PA.readPrimArray drbg 07
+ !k07 <- PA.readPrimArray drbg 08
+ pure . BS.toStrict . BSB.toLazyByteString $ mconcat [
+ BSB.word64BE k00
+ , BSB.word64BE k01
+ , BSB.word64BE k02
+ , BSB.word64BE k03
+ , BSB.word64BE k04
+ , BSB.word64BE k05
+ , BSB.word64BE k06
+ , BSB.word64BE k07
+ ]
diff --git a/ppad-hmac-drbg.cabal b/ppad-hmac-drbg.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: ppad-hmac-drbg
-version: 0.2.1
+version: 0.3.0
synopsis: HMAC-based deterministic random bit generator
license: MIT
license-file: LICENSE
@@ -31,8 +31,8 @@ library
if flag(llvm)
ghc-options: -fllvm -O2
exposed-modules:
- Crypto.DRBG.HMAC
- , Crypto.DRBG.HMAC.SHA256
+ Crypto.DRBG.HMAC.SHA256
+ , Crypto.DRBG.HMAC.SHA512
build-depends:
base >= 4.9 && < 5
, bytestring >= 0.9 && < 0.13
diff --git a/test/Main.hs b/test/Main.hs
@@ -5,9 +5,11 @@
module Main where
import Control.Applicative ((<|>))
-import qualified Crypto.DRBG.HMAC.SHA256 as DRBG
+import qualified Crypto.DRBG.HMAC.SHA256 as DRBG256
+import qualified Crypto.DRBG.HMAC.SHA512 as DRBG512
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString as BS
+import Data.Word (Word64)
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Base16 as B16
import Test.Tasty
@@ -24,21 +26,21 @@ import Test.Tasty.HUnit
main :: IO ()
main = do
sha256_vectors <- BS.readFile "etc/HMAC_DRBG_SHA256.txt"
- -- sha512_vectors <- BS.readFile "etc/HMAC_DRBG_SHA512.txt"
+ sha512_vectors <- BS.readFile "etc/HMAC_DRBG_SHA512.txt"
let sha256_cases = case A.parseOnly parse_sha256_blocks sha256_vectors of
Left _ -> error "ppad-hmac-drbg (test): parse error"
Right cs -> cs
- -- sha512_cases = case A.parseOnly parse_sha512_blocks sha512_vectors of
- -- Left _ -> error "ppad-hmac-drbg (test): parse error"
- -- Right cs -> cs
+ sha512_cases = case A.parseOnly parse_sha512_blocks sha512_vectors of
+ Left _ -> error "ppad-hmac-drbg (test): parse error"
+ Right cs -> cs
- defaultMain (cavp_14_3 sha256_cases)
+ defaultMain (cavp_14_3 sha256_cases sha512_cases)
-cavp_14_3 :: [CaseBlock] -> TestTree
-cavp_14_3 cs = testGroup "CAVP 14.3" [
- testGroup "HMAC-SHA256" (fmap execute_caseblock cs)
- -- , testGroup "HMAC-SHA512" (fmap execute_caseblock ds)
+cavp_14_3 :: [CaseBlock] -> [CaseBlock] -> TestTree
+cavp_14_3 cs ds = testGroup "CAVP 14.3" [
+ testGroup "HMAC-SHA256" (fmap (execute_caseblock DRBG256.new DRBG256.reseed DRBG256.gen DRBG256._read_v DRBG256._read_k) cs)
+ , testGroup "HMAC-SHA512" (fmap (execute_caseblock DRBG512.new DRBG512.reseed DRBG512.gen DRBG512._read_v DRBG512._read_k) ds)
]
data CaseBlock = CaseBlock {
@@ -76,9 +78,16 @@ data Case = Case {
, caseReturned :: !BS.ByteString
} deriving Show
-execute_caseblock :: CaseBlock -> TestTree
-execute_caseblock CaseBlock {..} =
- testGroup msg (fmap execute cb_cases)
+execute_caseblock
+ :: (BS.ByteString -> BS.ByteString -> BS.ByteString -> IO drbg)
+ -> (drbg -> BS.ByteString -> BS.ByteString -> IO ())
+ -> (drbg -> BS.ByteString -> Word64 -> IO (Either e BS.ByteString))
+ -> (drbg -> IO BS.ByteString)
+ -> (drbg -> IO BS.ByteString)
+ -> CaseBlock
+ -> TestTree
+execute_caseblock drbg_new drbg_reseed drbg_gen read_v read_k CaseBlock {..} =
+ testGroup msg (fmap (execute drbg_new drbg_reseed drbg_gen read_v read_k) cb_cases)
where
BlockHeader {..} = cb_blockHeader
msg = "bitlens: " <>
@@ -89,29 +98,37 @@ execute_caseblock CaseBlock {..} =
"ret " <> show bh_ReturnedBitsLen
-- execute test case
-execute :: Case -> TestTree
-execute Case {..} = testCase ("count " <> show caseCount) $ do
+execute
+ :: (BS.ByteString -> BS.ByteString -> BS.ByteString -> IO drbg)
+ -> (drbg -> BS.ByteString -> BS.ByteString -> IO ())
+ -> (drbg -> BS.ByteString -> Word64 -> IO (Either e BS.ByteString))
+ -> (drbg -> IO BS.ByteString)
+ -> (drbg -> IO BS.ByteString)
+ -> Case
+ -> TestTree
+execute drbg_new drbg_reseed drbg_gen read_v read_k Case {..} =
+ testCase ("count " <> show caseCount) $ do
let bytes = fromIntegral (BS.length caseReturned)
- drbg <- DRBG.new caseEntropy0 caseNonce casePs
- v0 <- DRBG._read_v drbg
- k0 <- DRBG._read_k drbg
+ drbg <- drbg_new caseEntropy0 caseNonce casePs
+ v0 <- read_v drbg
+ k0 <- read_k drbg
assertEqual "v0" v0 caseV0
assertEqual "k0" k0 caseK0
- DRBG.reseed drbg caseEntropy1 caseAddl1
- Right _ <- DRBG.gen drbg mempty bytes
- v1 <- DRBG._read_v drbg
- k1 <- DRBG._read_k drbg
+ drbg_reseed drbg caseEntropy1 caseAddl1
+ Right _ <- drbg_gen drbg mempty bytes
+ v1 <- read_v drbg
+ k1 <- read_k drbg
assertEqual "v1" v1 caseV1
assertEqual "k1" k1 caseK1
- DRBG.reseed drbg caseEntropy2 caseAddl2
- Right returned <- DRBG.gen drbg mempty bytes
- v2 <- DRBG._read_v drbg
- k2 <- DRBG._read_k drbg
+ drbg_reseed drbg caseEntropy2 caseAddl2
+ Right returned <- drbg_gen drbg mempty bytes
+ v2 <- read_v drbg
+ k2 <- read_k drbg
assertEqual "returned_bytes" returned caseReturned
assertEqual "v2" v2 caseV2
@@ -198,13 +215,13 @@ parse_sha256_block = do
parse_sha256_blocks :: A.Parser [CaseBlock]
parse_sha256_blocks = A.many1 parse_sha256_block
--- parse_sha512_block :: A.Parser CaseBlock
--- parse_sha512_block = do
--- cb_blockHeader <- parse_header "SHA-512"
--- cb_cases <- parse_cases
--- A.endOfLine
--- pure CaseBlock {..}
+parse_sha512_block :: A.Parser CaseBlock
+parse_sha512_block = do
+ cb_blockHeader <- parse_header "SHA-512"
+ cb_cases <- parse_cases
+ A.endOfLine
+ pure CaseBlock {..}
--- parse_sha512_blocks :: A.Parser [CaseBlock]
--- parse_sha512_blocks = A.many1 parse_sha512_block
+parse_sha512_blocks :: A.Parser [CaseBlock]
+parse_sha512_blocks = A.many1 parse_sha512_block
