diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,8 @@ +# Changelog + +- 0.1.1 (2024-10-07) + * Add a basic placeholder 'Show' instance for the DRBG type. + +- 0.1.0 (2024-10-05) + * Initial release. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2024 Jared Tobin + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Criterion.Main +import qualified Crypto.DRBG.HMAC as DRBG +import qualified Crypto.Hash.SHA256 as SHA256 + +main :: IO () +main = do + !drbg <- DRBG.new SHA256.hmac mempty mempty mempty -- no NFData + defaultMain [ + suite drbg + ] + +suite drbg = + bgroup "ppad-hmac-drbg" [ + bgroup "HMAC-SHA256" [ + bench "new" $ whnfAppIO (DRBG.new SHA256.hmac mempty mempty) mempty + , bench "reseed" $ whnfAppIO (DRBG.reseed mempty mempty) drbg + , bench "gen (32B)" $ whnfAppIO (DRBG.gen mempty 32) drbg + , bench "gen (256B)" $ whnfAppIO (DRBG.gen mempty 256) drbg + ] + ] + diff --git a/lib/Crypto/DRBG/HMAC.hs b/lib/Crypto/DRBG/HMAC.hs new file mode 100644 --- /dev/null +++ b/lib/Crypto/DRBG/HMAC.hs @@ -0,0 +1,246 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# OPTIONS_GHC -funbox-small-strict-fields #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +-- | +-- Module: Crypto.DRBG.HMAC +-- Copyright: (c) 2024 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- 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 + , _read_v + , _read_k + , HMAC + + -- * 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.Primitive.MutVar as P +import Data.Word (Word64) + +-- keystroke savers and utilities --------------------------------------------- + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral +{-# INLINE fi #-} + +toStrict :: BSB.Builder -> BS.ByteString +toStrict = BS.toStrict . BSB.toLazyByteString +{-# INLINE toStrict #-} + +-- dumb strict pair +data Pair a b = Pair !a !b + deriving Show + +-- types ---------------------------------------------------------------------- + +-- 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. +newtype DRBG s = DRBG (P.MutVar s DRBGState) + +instance Show (DRBG s) where + show _ = "" + +-- DRBG environment data and state +data DRBGState = DRBGState + !HMACEnv -- hmac function & outlen + !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 +-- >>> :t SHA256.hmac +-- SHA256.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 +-- >>> new SHA256.hmac entropy nonce personalization_string +-- "" +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) + +-- | 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 +-- "" +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) + +-- | Generate bytes from a DRBG, optionally injecting additional bytes +-- per SP 800-90A. +-- +-- >>> import qualified Data.ByteString.Base16 as B16 +-- >>> drbg <- new SHA256.hmac entropy nonce personalization_string +-- >>> bytes0 <- gen addl_bytes 16 drbg +-- >>> 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 BS.ByteString +gen addl bytes (DRBG mut) = do + drbg0 <- P.readMutVar mut + let !(Pair bs drbg1) = gen_pure addl bytes drbg0 + P.writeMutVar mut drbg1 + pure bs + +-- 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 = toStrict $ + BSB.byteString bs <> BSB.word8 byte <> BSB.byteString suf + +-- 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 + -> Pair BS.ByteString DRBGState +gen_pure addl bytes drbg0@(DRBGState h@(HMACEnv hmac outlen) _ _ _) + | r > _RESEED_COUNTER = error "ppad-hmac-drbg: reseed required" + | otherwise = + let !(Pair temp drbg1) = loop mempty 0 v1 + returned_bits = BS.take (fi bytes) temp + drbg = update_pure addl drbg1 + in 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 = toStrict acc + in Pair facc (DRBGState h (succ r) vl k1) + diff --git a/ppad-hmac-drbg.cabal b/ppad-hmac-drbg.cabal new file mode 100644 --- /dev/null +++ b/ppad-hmac-drbg.cabal @@ -0,0 +1,68 @@ +cabal-version: 3.0 +name: ppad-hmac-drbg +version: 0.1.1 +synopsis: HMAC-based deterministic random bit generator +license: MIT +license-file: LICENSE +author: Jared Tobin +maintainer: jared@ppad.tech +category: Cryptography +build-type: Simple +tested-with: GHC == { 9.8.1 } +extra-doc-files: CHANGELOG +description: + A pure implementation of the HMAC-DRBG CSPRNG, as specified by NIST-SP + 800-90A. + +source-repository head + type: git + location: git.ppad.tech/hmac-drbg.git + +library + default-language: Haskell2010 + hs-source-dirs: lib + ghc-options: + -Wall + exposed-modules: + Crypto.DRBG.HMAC + build-depends: + base >= 4.9 && < 5 + , bytestring >= 0.9 && < 0.13 + , primitive >= 0.8 && < 0.10 + +test-suite hmac-drbg-tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + + ghc-options: + -rtsopts -Wall -O2 + + build-depends: + attoparsec + , base + , base16-bytestring + , bytestring + , ppad-hmac-drbg + , ppad-sha256 + , ppad-sha512 + , tasty + , tasty-hunit + +benchmark hmac-drbg-bench + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: bench + main-is: Main.hs + + ghc-options: + -rtsopts -O2 -Wall + + build-depends: + base + , bytestring + , criterion + , ppad-hmac-drbg + , ppad-sha256 + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,179 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Main where + +import Control.Applicative ((<|>)) +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Crypto.Hash.SHA512 as SHA512 +import qualified Crypto.DRBG.HMAC as DRBG +import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Base16 as B16 +import Test.Tasty +import Test.Tasty.HUnit + +-- CAVP source: +-- +-- https://raw.githubusercontent.com/coruus/nist-testvectors/refs/heads/master/csrc.nist.gov/groups/STM/cavp/documents/drbg/drbgtestvectors/drbgvectors_pr_true/HMAC_DRBG.txt +-- +-- spec: +-- +-- https://csrc.nist.gov/CSRC/media/Projects/Cryptographic-Algorithm-Validation-Program/documents/drbg/DRBGVS.pdf + +main :: IO () +main = do + sha256_vectors <- BS.readFile "etc/HMAC_DRBG_SHA256.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 + + defaultMain (cavp_14_3 sha256_cases sha512_cases) + +cavp_14_3 :: [Case] -> [Case] -> TestTree +cavp_14_3 cs ds = testGroup "CAVP 14.3" [ + testGroup "SHA-256" (fmap (execute SHA256.hmac) cs) + , testGroup "SHA-512" (fmap (execute SHA512.hmac) ds) + ] + +-- test case spec +data Case = Case { + caseCount :: !Int + -- instantiate + , caseEntropy0 :: !BS.ByteString + , caseNonce :: !BS.ByteString + , casePs :: !BS.ByteString + , caseV0 :: !BS.ByteString + , caseK0 :: !BS.ByteString + -- first generate + , caseAddl1 :: !BS.ByteString + , caseEntropy1 :: !BS.ByteString + , caseV1 :: !BS.ByteString + , caseK1 :: !BS.ByteString + -- second generate + , caseAddl2 :: !BS.ByteString + , caseEntropy2 :: !BS.ByteString + , caseV2 :: !BS.ByteString + , caseK2 :: !BS.ByteString + , caseReturned :: !BS.ByteString + } + deriving Show + +-- execute test case +execute :: DRBG.HMAC -> Case -> TestTree +execute hmac Case {..} = testCase ("count " <> show caseCount) $ do + let bytes = fromIntegral (BS.length caseReturned) + + drbg <- DRBG.new hmac caseEntropy0 caseNonce casePs + v0 <- DRBG._read_v drbg + k0 <- DRBG._read_k drbg + + assertEqual "v0" v0 caseV0 + assertEqual "k0" k0 caseK0 + + DRBG.reseed caseEntropy1 caseAddl1 drbg + _ <- DRBG.gen mempty bytes drbg + v1 <- DRBG._read_v drbg + k1 <- DRBG._read_k drbg + + assertEqual "v1" v1 caseV1 + assertEqual "k1" k1 caseK1 + + DRBG.reseed caseEntropy2 caseAddl2 drbg + returned <- DRBG.gen mempty bytes drbg + v2 <- DRBG._read_v drbg + k2 <- DRBG._read_k drbg + + assertEqual "returned_bytes" returned caseReturned + assertEqual "v2" v2 caseV2 + assertEqual "k2" k2 caseK2 + +-- CAVP vector parsers + +hex_digit :: A.Parser Char +hex_digit = A.satisfy hd where + hd c = + (c >= '0' && c <= '9') + || (c >= 'a' && c <= 'f') + || (c >= 'A' && c <= 'F') + +parse_hex :: A.Parser BS.ByteString +parse_hex = (B16.decodeLenient . B8.pack) <$> A.many1 hex_digit + +parse_kv :: BS.ByteString -> A.Parser BS.ByteString +parse_kv k = + A.string k + *> A.skipSpace + *> A.char '=' + *> parse_v + where + parse_v = + (A.endOfLine *> pure mempty) + <|> (A.skipSpace *> parse_hex <* A.endOfLine) + +parse_case :: A.Parser Case +parse_case = do + caseCount <- A.string "COUNT = " *> A.decimal <* A.endOfLine + caseEntropy0 <- parse_kv "EntropyInput" + caseNonce <- parse_kv "Nonce" + casePs <- parse_kv "PersonalizationString" + A.string "** INSTANTIATE:" *> A.endOfLine + caseV0 <- parse_kv "\tV" + caseK0 <- parse_kv "\tKey" + caseAddl1 <- parse_kv "AdditionalInput" + caseEntropy1 <- parse_kv "EntropyInputPR" + A.string "** GENERATE (FIRST CALL):" *> A.endOfLine + caseV1 <- parse_kv "\tV" + caseK1 <- parse_kv "\tKey" + caseAddl2 <- parse_kv "AdditionalInput" + caseEntropy2 <- parse_kv "EntropyInputPR" + caseReturned <- parse_kv "ReturnedBits" + A.string "** GENERATE (SECOND CALL):" *> A.endOfLine + caseV2 <- parse_kv "\tV" + caseK2 <- parse_kv "\tKey" + return Case {..} + +parse_cases :: A.Parser [Case] +parse_cases = parse_case `A.sepBy` A.endOfLine + +parse_sha256_header :: A.Parser () +parse_sha256_header = + A.string "[SHA-256]" *> A.endOfLine + *> A.skipMany1 boring + *> A.endOfLine + where + boring = A.char '[' *> A.skipWhile (/= ']') *> A.char ']' *> A.endOfLine + +parse_sha256_block :: A.Parser [Case] +parse_sha256_block = + parse_sha256_header + *> parse_cases + <* A.endOfLine + +parse_sha256_blocks :: A.Parser [Case] +parse_sha256_blocks = concat <$> A.many1 parse_sha256_block + +parse_sha512_header :: A.Parser () +parse_sha512_header = + A.string "[SHA-512]" *> A.endOfLine + *> A.skipMany1 boring + *> A.endOfLine + where + boring = A.char '[' *> A.skipWhile (/= ']') *> A.char ']' *> A.endOfLine + +parse_sha512_block :: A.Parser [Case] +parse_sha512_block = + parse_sha512_header + *> parse_cases + <* A.endOfLine + +parse_sha512_blocks :: A.Parser [Case] +parse_sha512_blocks = concat <$> A.many1 parse_sha512_block +