HMAC.hs (8187B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# OPTIONS_GHC -funbox-small-strict-fields #-} 3 {-# LANGUAGE BangPatterns #-} 4 5 -- | 6 -- Module: Crypto.DRBG.HMAC 7 -- Copyright: (c) 2024 Jared Tobin 8 -- License: MIT 9 -- Maintainer: Jared Tobin <jared@ppad.tech> 10 -- 11 -- A pure HMAC-DRBG implementation, as specified by 12 -- [NIST SP-800-90A](https://nvlpubs.nist.gov/nistpubs/SpecialPublications/NIST.SP.800-90Ar1.pdf). 13 14 module Crypto.DRBG.HMAC ( 15 -- * DRBG and HMAC function types 16 DRBG 17 , _read_v 18 , _read_k 19 , HMAC 20 21 -- * DRBG interaction 22 , new 23 , gen 24 , reseed 25 ) where 26 27 import Control.Monad.Primitive (PrimMonad, PrimState) 28 import qualified Data.ByteString as BS 29 import qualified Data.ByteString.Builder as BSB 30 import qualified Data.ByteString.Builder.Extra as BE 31 import qualified Data.ByteString.Internal as BI 32 import qualified Data.Primitive.MutVar as P 33 import Data.Word (Word64) 34 35 -- keystroke savers and utilities --------------------------------------------- 36 37 fi :: (Integral a, Num b) => a -> b 38 fi = fromIntegral 39 {-# INLINE fi #-} 40 41 to_strict :: BSB.Builder -> BS.ByteString 42 to_strict = BS.toStrict . BSB.toLazyByteString 43 {-# INLINE to_strict #-} 44 45 to_strict_small :: BSB.Builder -> BS.ByteString 46 to_strict_small = BS.toStrict . BE.toLazyByteStringWith 47 (BE.safeStrategy 128 BE.smallChunkSize) mempty 48 {-# INLINE to_strict_small #-} 49 50 -- dumb strict pair 51 data Pair a b = Pair !a !b 52 deriving Show 53 54 -- types ---------------------------------------------------------------------- 55 56 -- see SP 800-90A table 2 57 _RESEED_COUNTER :: Word64 58 _RESEED_COUNTER = (2 :: Word64) ^ (48 :: Word64) 59 60 -- | A deterministic random bit generator (DRBG). 61 -- 62 -- Create a DRBG with 'new', and then use and reuse it to generate 63 -- bytes as needed. 64 -- 65 -- >>> import qualified Crypto.Hash.SHA256 as SHA256 66 -- >>> drbg <- new SHA256.hmac entropy nonce personalization_string 67 -- >>> bytes0 <- gen addl_bytes 16 drbg 68 -- >>> bytes1 <- gen addl_bytes 16 drbg 69 -- >>> drbg 70 -- "<drbg>" 71 newtype DRBG s = DRBG (P.MutVar s DRBGState) 72 73 instance Show (DRBG s) where 74 show _ = "<drbg>" 75 76 -- DRBG environment data and state 77 data DRBGState = DRBGState 78 !HMACEnv -- hmac function & outlen 79 {-# UNPACK #-} !Word64 -- reseed counter 80 {-# UNPACK #-} !BS.ByteString -- v 81 {-# UNPACK #-} !BS.ByteString -- key 82 83 -- NB following synonym really only exists to make haddocks more 84 -- readable 85 86 -- | A HMAC function, taking a key as the first argument and the input 87 -- value as the second, producing a MAC digest. 88 -- 89 -- >>> import qualified Crypto.Hash.SHA256 as SHA256 90 -- >>> :t SHA256.hmac 91 -- SHA256.hmac :: BS.ByteString -> BS.ByteString -> BS.ByteString 92 type HMAC = BS.ByteString -> BS.ByteString -> BS.ByteString 93 94 -- HMAC function and its associated outlength 95 data HMACEnv = HMACEnv 96 !HMAC 97 {-# UNPACK #-} !Word64 98 99 -- the following convenience functions are useful for testing 100 101 _read_v 102 :: PrimMonad m 103 => DRBG (PrimState m) 104 -> m BS.ByteString 105 _read_v (DRBG mut) = do 106 DRBGState _ _ v _ <- P.readMutVar mut 107 pure v 108 109 _read_k 110 :: PrimMonad m 111 => DRBG (PrimState m) 112 -> m BS.ByteString 113 _read_k (DRBG mut) = do 114 DRBGState _ _ _ k <- P.readMutVar mut 115 pure k 116 117 -- drbg interaction ------------------------------------------------------ 118 119 -- | Create a DRBG from the supplied HMAC function, entropy, nonce, and 120 -- personalization string. 121 -- 122 -- You can instantiate the DRBG using any appropriate HMAC function; 123 -- it should merely take a key and value as input, as is standard, and 124 -- return a MAC digest, each being a strict 'ByteString'. 125 -- 126 -- The DRBG is returned in any 'PrimMonad', e.g. 'ST' or 'IO'. 127 -- 128 -- >>> import qualified Crypto.Hash.SHA256 as SHA256 129 -- >>> new SHA256.hmac entropy nonce personalization_string 130 -- "<drbg>" 131 new 132 :: PrimMonad m 133 => HMAC -- ^ HMAC function 134 -> BS.ByteString -- ^ entropy 135 -> BS.ByteString -- ^ nonce 136 -> BS.ByteString -- ^ personalization string 137 -> m (DRBG (PrimState m)) 138 new hmac entropy nonce ps = do 139 let !drbg = new_pure hmac entropy nonce ps 140 mut <- P.newMutVar drbg 141 pure (DRBG mut) 142 143 -- | Generate bytes from a DRBG, optionally injecting additional bytes 144 -- per SP 800-90A. 145 -- 146 -- >>> import qualified Data.ByteString.Base16 as B16 147 -- >>> drbg <- new SHA256.hmac entropy nonce personalization_string 148 -- >>> bytes0 <- gen addl_bytes 16 drbg 149 -- >>> bytes1 <- gen addl_bytes 16 drbg 150 -- >>> B16.encode bytes0 151 -- "938d6ca6d0b797f7b3c653349d6e3135" 152 -- >>> B16.encode bytes1 153 -- "5f379d16de6f2c6f8a35c56f13f9e5a5" 154 gen 155 :: PrimMonad m 156 => BS.ByteString -- ^ additional bytes to inject 157 -> Word64 -- ^ number of bytes to generate 158 -> DRBG (PrimState m) 159 -> m BS.ByteString 160 gen addl bytes (DRBG mut) = do 161 drbg0 <- P.readMutVar mut 162 let !(Pair bs drbg1) = gen_pure addl bytes drbg0 163 P.writeMutVar mut drbg1 164 pure bs 165 166 -- | Reseed a DRBG. 167 -- 168 -- Each DRBG has an internal /reseed counter/ that tracks the number 169 -- of requests made to the generator (note /requests made/, not bytes 170 -- generated). SP 800-90A specifies that a HMAC-DRBG should support 171 -- 2 ^ 48 requests before requiring a reseed, so in practice you're 172 -- unlikely to ever need to use this to actually reset the counter. 173 -- 174 -- Note however that 'reseed' can be used to implement "explicit" 175 -- prediction resistance, per SP 800-90A, by injecting entropy generated 176 -- elsewhere into the DRBG. 177 -- 178 -- >>> import qualified System.Entropy as E 179 -- >>> entropy <- E.getEntropy 32 180 -- >>> reseed entropy addl_bytes drbg 181 -- "<reseeded drbg>" 182 reseed 183 :: PrimMonad m 184 => BS.ByteString -- ^ entropy to inject 185 -> BS.ByteString -- ^ additional bytes to inject 186 -> DRBG (PrimState m) 187 -> m () 188 reseed ent add (DRBG drbg) = P.modifyMutVar' drbg (reseed_pure ent add) 189 190 -- pure drbg interaction ------------------------------------------------------ 191 192 -- SP 800-90A 10.1.2.2 193 update_pure 194 :: BS.ByteString 195 -> DRBGState 196 -> DRBGState 197 update_pure provided_data (DRBGState h@(HMACEnv hmac _) r v0 k0) = 198 let !k1 = hmac k0 (cat v0 0x00 provided_data) 199 !v1 = hmac k1 v0 200 in if BS.null provided_data 201 then DRBGState h r v1 k1 202 else let !k2 = hmac k1 (cat v1 0x01 provided_data) 203 !v2 = hmac k2 v1 204 in DRBGState h r v2 k2 205 where 206 cat bs byte suf@(BI.PS _ _ l) = 207 let bil = BSB.byteString bs <> BSB.word8 byte <> BSB.byteString suf 208 in if l < 64 209 then to_strict_small bil 210 else to_strict bil 211 {-# INLINE cat #-} 212 213 -- SP 800-90A 10.1.2.3 214 new_pure 215 :: HMAC -- HMAC function 216 -> BS.ByteString -- entropy 217 -> BS.ByteString -- nonce 218 -> BS.ByteString -- personalization string 219 -> DRBGState 220 new_pure hmac entropy nonce ps = 221 let !drbg = DRBGState (HMACEnv hmac outlen) 1 v0 k0 222 in update_pure seed_material drbg 223 where 224 seed_material = entropy <> nonce <> ps 225 outlen = fi (BS.length (hmac mempty mempty)) 226 k0 = BS.replicate (fi outlen) 0x00 227 v0 = BS.replicate (fi outlen) 0x01 228 229 -- SP 800-90A 10.1.2.4 230 reseed_pure :: BS.ByteString -> BS.ByteString -> DRBGState -> DRBGState 231 reseed_pure entropy addl drbg = 232 let !(DRBGState h _ v k) = update_pure (entropy <> addl) drbg 233 in DRBGState h 1 v k 234 235 -- SP 800-90A 10.1.2.5 236 gen_pure 237 :: BS.ByteString 238 -> Word64 239 -> DRBGState 240 -> Pair BS.ByteString DRBGState 241 gen_pure addl bytes drbg0@(DRBGState h@(HMACEnv hmac outlen) _ _ _) 242 | r > _RESEED_COUNTER = error "ppad-hmac-drbg: reseed required" 243 | otherwise = 244 let !(Pair temp drbg1) = loop mempty 0 v1 245 returned_bits = BS.take (fi bytes) temp 246 drbg = update_pure addl drbg1 247 in Pair returned_bits drbg 248 where 249 !(DRBGState _ r v1 k1) 250 | BS.null addl = drbg0 251 | otherwise = update_pure addl drbg0 252 253 loop !acc !len !vl 254 | len < bytes = 255 let nv = hmac k1 vl 256 nacc = acc <> BSB.byteString nv 257 nlen = len + outlen 258 in loop nacc nlen nv 259 260 | otherwise = 261 let facc | bytes < 128 = to_strict_small acc 262 | otherwise = to_strict acc 263 in Pair facc (DRBGState h (succ r) vl k1) 264 {-# INLINE gen_pure #-} 265