SHA256.hs (14217B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE MagicHash #-} 4 {-# LANGUAGE PatternSynonyms #-} 5 {-# LANGUAGE UnboxedTuples #-} 6 7 -- | 8 -- Module: Crypto.DRBG.HMAC.SHA256 9 -- Copyright: (c) 2024 Jared Tobin 10 -- License: MIT 11 -- Maintainer: Jared Tobin <jared@ppad.tech> 12 -- 13 -- A pure HMAC-DRBG implementation, as specified by 14 -- [NIST SP-800-90A](https://nvlpubs.nist.gov/nistpubs/SpecialPublications/NIST.SP.800-90Ar1.pdf). 15 16 module Crypto.DRBG.HMAC.SHA256 ( 17 -- * DRBG and HMAC function types 18 DRBG 19 , Error(..) 20 21 -- * DRBG interaction 22 , new 23 , gen 24 , reseed 25 , wipe 26 27 -- for testing 28 , _read_v 29 , _read_k 30 ) where 31 32 import Crypto.DRBG.HMAC.Internal (Error(..), _RESEED_COUNTER, _MAX_BYTES) 33 import qualified Crypto.Hash.SHA256 as SHA256 34 import Crypto.Hash.SHA256.Internal (Registers(..)) 35 import qualified Crypto.Hash.SHA256.Internal as SHA256 (cat) 36 import Control.Monad.Primitive (PrimMonad, PrimState) 37 import Control.Monad.ST (ST) 38 import GHC.Exts (RealWorld) 39 import qualified Control.Monad.Primitive as Prim (unsafeIOToPrim) 40 import Data.Bits ((.<<.), (.>>.), (.|.)) 41 import qualified Data.ByteString as BS 42 import qualified Data.ByteString.Builder as BSB 43 import qualified Data.ByteString.Internal as BI 44 import qualified Data.Primitive.PrimArray as PA 45 import Data.Word (Word32, Word64) 46 import qualified GHC.Word 47 import qualified Foreign.Ptr as FP 48 49 -- api ------------------------------------------------------------------------ 50 51 -- | A deterministic random bit generator (DRBG). 52 -- 53 -- Create a DRBG with 'new', and then use and reuse it to generate 54 -- bytes as needed. 55 -- 56 -- >>> drbg <- new entropy nonce personalization_string 57 -- >>> bytes0 <- gen drbg mempty 10 58 -- >>> bytes1 <- gen drbg mempty 10 59 -- >>> drbg 60 -- "<drbg>" 61 62 -- first two elements are hi/lo bits of word64 counter 63 -- next eight elements are k 64 -- next eight elements are v 65 -- next sixteen elements are scratch space 66 newtype DRBG s = DRBG (PA.MutablePrimArray s Word32) 67 68 instance Show (DRBG s) where 69 show _ = "<drbg>" 70 71 -- | Create a HMAC-SHA256 DRBG from the supplied entropy, nonce, and 72 -- personalization string. 73 -- 74 -- The DRBG is returned in any 'PrimMonad', e.g. 'ST s' or 'IO'. 75 -- 76 -- >>> new entropy nonce personalization_string 77 -- "<drbg>" 78 new 79 :: PrimMonad m 80 => BS.ByteString -- ^ entropy 81 -> BS.ByteString -- ^ nonce 82 -> BS.ByteString -- ^ personalization string 83 -> m (DRBG (PrimState m)) 84 new entropy nonce ps = do 85 drbg <- PA.newPinnedPrimArray 34 -- 2 (ctr) + 16 (k, v) + 16 (scratch) 86 init_counter drbg 87 PA.setPrimArray drbg 02 08 (0x00000000 :: Word32) -- init k 88 PA.setPrimArray drbg 10 08 (0x01010101 :: Word32) -- init v 89 PA.setPrimArray drbg 18 16 (0x00000000 :: Word32) -- scratch 90 update drbg (entropy <> nonce <> ps) 91 pure $! DRBG drbg 92 {-# INLINABLE new #-} 93 {-# SPECIALIZE new 94 :: BS.ByteString -> BS.ByteString -> BS.ByteString -> IO (DRBG RealWorld) #-} 95 {-# SPECIALIZE new 96 :: BS.ByteString -> BS.ByteString -> BS.ByteString -> ST s (DRBG s) #-} 97 98 -- | Reseed a DRBG. 99 -- 100 -- Each DRBG has an internal /reseed counter/ that tracks the number 101 -- of requests made to the generator (note /requests made/, not bytes 102 -- generated). SP 800-90A specifies that a HMAC-DRBG should support 103 -- 2 ^ 48 requests before requiring a reseed, so in practice you're 104 -- unlikely to ever need to use this to actually reset the counter. 105 -- 106 -- Note however that 'reseed' can be used to implement "explicit" 107 -- prediction resistance, per SP 800-90A, by injecting entropy generated 108 -- elsewhere into the DRBG. 109 -- 110 -- >>> import qualified System.Entropy as E 111 -- >>> entropy <- E.getEntropy 32 112 -- >>> reseed entropy addl_bytes drbg 113 -- "<reseeded drbg>" 114 reseed 115 :: PrimMonad m 116 => DRBG (PrimState m) 117 -> BS.ByteString 118 -> BS.ByteString 119 -> m () 120 reseed (DRBG drbg) entr addl = do 121 update drbg (entr <> addl) 122 init_counter drbg 123 {-# INLINE reseed #-} 124 125 -- | Generate bytes from a DRBG, optionally injecting additional bytes 126 -- per SP 800-90A. 127 -- 128 -- Per SP 800-90A, the maximum number of bytes that can be requested 129 -- on any invocation is 65536. Larger requests will return 130 -- 'MaxBytesExceeded'. 131 -- 132 -- >>> import qualified Data.ByteString.Base16 as B16 133 -- >>> drbg <- new entropy nonce personalization_string 134 -- >>> Right bytes0 <- gen drbg addl_bytes 16 135 -- >>> Right bytes1 <- gen drbg addl_bytes 16 136 -- >>> B16.encode bytes0 137 -- "938d6ca6d0b797f7b3c653349d6e3135" 138 -- >>> B16.encode bytes1 139 -- "5f379d16de6f2c6f8a35c56f13f9e5a5" 140 gen 141 :: PrimMonad m 142 => DRBG (PrimState m) 143 -> BS.ByteString 144 -> Word64 145 -> m (Either Error BS.ByteString) 146 gen (DRBG drbg) addl@(BI.PS _ _ l) bytes 147 | bytes > _MAX_BYTES = pure $! Left MaxBytesExceeded 148 | otherwise = do 149 ctr <- read_counter drbg 150 if ctr > _RESEED_COUNTER 151 then pure $! Left ReseedRequired 152 else do 153 if l == 0 then pure () else update drbg addl 154 !(GHC.Word.W32# k00) <- PA.readPrimArray drbg 02 155 !(GHC.Word.W32# k01) <- PA.readPrimArray drbg 03 156 !(GHC.Word.W32# k02) <- PA.readPrimArray drbg 04 157 !(GHC.Word.W32# k03) <- PA.readPrimArray drbg 05 158 !(GHC.Word.W32# k04) <- PA.readPrimArray drbg 06 159 !(GHC.Word.W32# k05) <- PA.readPrimArray drbg 07 160 !(GHC.Word.W32# k06) <- PA.readPrimArray drbg 08 161 !(GHC.Word.W32# k07) <- PA.readPrimArray drbg 09 162 !(GHC.Word.W32# v00) <- PA.readPrimArray drbg 10 163 !(GHC.Word.W32# v01) <- PA.readPrimArray drbg 11 164 !(GHC.Word.W32# v02) <- PA.readPrimArray drbg 12 165 !(GHC.Word.W32# v03) <- PA.readPrimArray drbg 13 166 !(GHC.Word.W32# v04) <- PA.readPrimArray drbg 14 167 !(GHC.Word.W32# v05) <- PA.readPrimArray drbg 15 168 !(GHC.Word.W32# v06) <- PA.readPrimArray drbg 16 169 !(GHC.Word.W32# v07) <- PA.readPrimArray drbg 17 170 let !k0 = Registers (# k00, k01, k02, k03, k04, k05, k06, k07 #) 171 !v0 = Registers (# v00, v01, v02, v03, v04, v05, v06, v07 #) 172 !res <- gen_loop drbg k0 v0 bytes 173 update drbg addl 174 write_counter drbg (ctr + 1) 175 pure $! Right res 176 {-# INLINABLE gen #-} 177 {-# SPECIALIZE gen 178 :: DRBG RealWorld -> BS.ByteString -> Word64 179 -> IO (Either Error BS.ByteString) #-} 180 {-# SPECIALIZE gen 181 :: DRBG s -> BS.ByteString -> Word64 182 -> ST s (Either Error BS.ByteString) #-} 183 184 -- | Wipe the state of a DRBG. 185 -- 186 -- You should call this when you're finished with a DRBG to ensure that its 187 -- state is wiped from memory. 188 -- 189 -- >>> drbg <- new mempty mempty mempty 190 -- >>> Right bytes <- gen drbg addl_bytes 16 191 -- >>> wipe drbg 192 -- >>> -- do something with bytes 193 wipe 194 :: PrimMonad m 195 => DRBG (PrimState m) 196 -> m () 197 wipe (DRBG drbg) = do 198 init_counter drbg 199 PA.setPrimArray drbg 02 08 (0x00000000 :: Word32) -- init k 200 PA.setPrimArray drbg 10 08 (0x01010101 :: Word32) -- init v 201 PA.setPrimArray drbg 18 16 (0x00000000 :: Word32) -- init scratch 202 {-# INLINE wipe #-} 203 -- utilities ------------------------------------------------------------------ 204 205 fi :: (Integral a, Num b) => a -> b 206 fi = fromIntegral 207 {-# INLINE fi #-} 208 209 -- drbg utilities ------------------------------------------------------------- 210 211 gen_loop 212 :: PrimMonad m 213 => PA.MutablePrimArray (PrimState m) Word32 214 -> Registers 215 -> Registers 216 -> Word64 217 -> m BS.ByteString 218 gen_loop drbg k0 v0 bytes = loop mempty v0 0 where 219 !vp = PA.mutablePrimArrayContents drbg `FP.plusPtr` 40 -- 10 * 4 220 !sp = PA.mutablePrimArrayContents drbg `FP.plusPtr` 72 -- 18 * 4 221 loop !acc v l 222 | l >= bytes = do 223 write_v drbg v 224 pure acc 225 | otherwise = do 226 Prim.unsafeIOToPrim $ SHA256._hmac_rr vp sp k0 v 227 !(GHC.Word.W32# nv0) <- PA.readPrimArray drbg 10 228 !(GHC.Word.W32# nv1) <- PA.readPrimArray drbg 11 229 !(GHC.Word.W32# nv2) <- PA.readPrimArray drbg 12 230 !(GHC.Word.W32# nv3) <- PA.readPrimArray drbg 13 231 !(GHC.Word.W32# nv4) <- PA.readPrimArray drbg 14 232 !(GHC.Word.W32# nv5) <- PA.readPrimArray drbg 15 233 !(GHC.Word.W32# nv6) <- PA.readPrimArray drbg 16 234 !(GHC.Word.W32# nv7) <- PA.readPrimArray drbg 17 235 let !nv = Registers (# nv0, nv1, nv2, nv3, nv4, nv5, nv6, nv7 #) 236 !na = acc <> SHA256.cat nv 237 !nl = l + 32 238 loop na nv nl 239 {-# INLINE gen_loop #-} 240 241 update 242 :: PrimMonad m 243 => PA.MutablePrimArray (PrimState m) Word32 244 -> BS.ByteString 245 -> m () 246 update drbg provided_data@(BI.PS _ _ l) = do 247 !(GHC.Word.W32# k00) <- PA.readPrimArray drbg 02 248 !(GHC.Word.W32# k01) <- PA.readPrimArray drbg 03 249 !(GHC.Word.W32# k02) <- PA.readPrimArray drbg 04 250 !(GHC.Word.W32# k03) <- PA.readPrimArray drbg 05 251 !(GHC.Word.W32# k04) <- PA.readPrimArray drbg 06 252 !(GHC.Word.W32# k05) <- PA.readPrimArray drbg 07 253 !(GHC.Word.W32# k06) <- PA.readPrimArray drbg 08 254 !(GHC.Word.W32# k07) <- PA.readPrimArray drbg 09 255 !(GHC.Word.W32# v00) <- PA.readPrimArray drbg 10 256 !(GHC.Word.W32# v01) <- PA.readPrimArray drbg 11 257 !(GHC.Word.W32# v02) <- PA.readPrimArray drbg 12 258 !(GHC.Word.W32# v03) <- PA.readPrimArray drbg 13 259 !(GHC.Word.W32# v04) <- PA.readPrimArray drbg 14 260 !(GHC.Word.W32# v05) <- PA.readPrimArray drbg 15 261 !(GHC.Word.W32# v06) <- PA.readPrimArray drbg 16 262 !(GHC.Word.W32# v07) <- PA.readPrimArray drbg 17 263 let !k0 = Registers (# k00, k01, k02, k03, k04, k05, k06, k07 #) 264 !v0 = Registers (# v00, v01, v02, v03, v04, v05, v06, v07 #) 265 !kp = PA.mutablePrimArrayContents drbg `FP.plusPtr` 08 -- 2 * 4 266 !vp = PA.mutablePrimArrayContents drbg `FP.plusPtr` 40 -- 10 * 4 267 !sp = PA.mutablePrimArrayContents drbg `FP.plusPtr` 72 -- 18 * 4 268 Prim.unsafeIOToPrim $ SHA256._hmac_rsb kp sp k0 v0 0x00 provided_data 269 !(GHC.Word.W32# k10) <- PA.readPrimArray drbg 02 270 !(GHC.Word.W32# k11) <- PA.readPrimArray drbg 03 271 !(GHC.Word.W32# k12) <- PA.readPrimArray drbg 04 272 !(GHC.Word.W32# k13) <- PA.readPrimArray drbg 05 273 !(GHC.Word.W32# k14) <- PA.readPrimArray drbg 06 274 !(GHC.Word.W32# k15) <- PA.readPrimArray drbg 07 275 !(GHC.Word.W32# k16) <- PA.readPrimArray drbg 08 276 !(GHC.Word.W32# k17) <- PA.readPrimArray drbg 09 277 let !k1 = Registers (# k10, k11, k12, k13, k14, k15, k16, k17 #) 278 Prim.unsafeIOToPrim $ SHA256._hmac_rr vp sp k1 v0 279 if l == 0 280 then pure () 281 else do 282 !(GHC.Word.W32# v10) <- PA.readPrimArray drbg 10 283 !(GHC.Word.W32# v11) <- PA.readPrimArray drbg 11 284 !(GHC.Word.W32# v12) <- PA.readPrimArray drbg 12 285 !(GHC.Word.W32# v13) <- PA.readPrimArray drbg 13 286 !(GHC.Word.W32# v14) <- PA.readPrimArray drbg 14 287 !(GHC.Word.W32# v15) <- PA.readPrimArray drbg 15 288 !(GHC.Word.W32# v16) <- PA.readPrimArray drbg 16 289 !(GHC.Word.W32# v17) <- PA.readPrimArray drbg 17 290 let !v1 = Registers (# v10, v11, v12, v13, v14, v15, v16, v17 #) 291 Prim.unsafeIOToPrim $ SHA256._hmac_rsb kp sp k1 v1 0x01 provided_data 292 !(GHC.Word.W32# k20) <- PA.readPrimArray drbg 02 293 !(GHC.Word.W32# k21) <- PA.readPrimArray drbg 03 294 !(GHC.Word.W32# k22) <- PA.readPrimArray drbg 04 295 !(GHC.Word.W32# k23) <- PA.readPrimArray drbg 05 296 !(GHC.Word.W32# k24) <- PA.readPrimArray drbg 06 297 !(GHC.Word.W32# k25) <- PA.readPrimArray drbg 07 298 !(GHC.Word.W32# k26) <- PA.readPrimArray drbg 08 299 !(GHC.Word.W32# k27) <- PA.readPrimArray drbg 09 300 let !k2 = Registers (# k20, k21, k22, k23, k24, k25, k26, k27 #) 301 Prim.unsafeIOToPrim $ SHA256._hmac_rr vp sp k2 v1 302 {-# INLINABLE update #-} 303 {-# SPECIALIZE update 304 :: PA.MutablePrimArray RealWorld Word32 -> BS.ByteString -> IO () #-} 305 {-# SPECIALIZE update 306 :: PA.MutablePrimArray s Word32 -> BS.ByteString -> ST s () #-} 307 308 init_counter 309 :: PrimMonad m 310 => PA.MutablePrimArray (PrimState m) Word32 311 -> m () 312 init_counter drbg = do 313 PA.writePrimArray drbg 0 (0x00 :: Word32) -- init high word, counter 314 PA.writePrimArray drbg 1 (0x01 :: Word32) -- init low word, counter 315 {-# INLINE init_counter #-} 316 317 read_counter 318 :: PrimMonad m 319 => PA.MutablePrimArray (PrimState m) Word32 320 -> m Word64 321 read_counter drbg = do 322 !hi <- PA.readPrimArray drbg 0 323 !lo <- PA.readPrimArray drbg 1 324 let !ctr = fi hi .<<. 32 .|. fi lo 325 pure $! ctr 326 {-# INLINE read_counter #-} 327 328 write_counter 329 :: PrimMonad m 330 => PA.MutablePrimArray (PrimState m) Word32 331 -> Word64 332 -> m () 333 write_counter drbg ctr = do 334 let !hi = fi (ctr .>>. 32) 335 !lo = fi ctr 336 PA.writePrimArray drbg 0 hi 337 PA.writePrimArray drbg 1 lo 338 {-# INLINE write_counter #-} 339 340 write_v 341 :: PrimMonad m 342 => PA.MutablePrimArray (PrimState m) Word32 343 -> Registers 344 -> m () 345 write_v drbg (R v0 v1 v2 v3 v4 v5 v6 v7) = do 346 PA.writePrimArray drbg 10 (GHC.Word.W32# v0) 347 PA.writePrimArray drbg 11 (GHC.Word.W32# v1) 348 PA.writePrimArray drbg 12 (GHC.Word.W32# v2) 349 PA.writePrimArray drbg 13 (GHC.Word.W32# v3) 350 PA.writePrimArray drbg 14 (GHC.Word.W32# v4) 351 PA.writePrimArray drbg 15 (GHC.Word.W32# v5) 352 PA.writePrimArray drbg 16 (GHC.Word.W32# v6) 353 PA.writePrimArray drbg 17 (GHC.Word.W32# v7) 354 {-# INLINE write_v #-} 355 356 -- read secret drbg state (for testing) 357 _read_v 358 :: PrimMonad m 359 => DRBG (PrimState m) 360 -> m BS.ByteString 361 _read_v (DRBG drbg) = do 362 !v00 <- PA.readPrimArray drbg 10 363 !v01 <- PA.readPrimArray drbg 11 364 !v02 <- PA.readPrimArray drbg 12 365 !v03 <- PA.readPrimArray drbg 13 366 !v04 <- PA.readPrimArray drbg 14 367 !v05 <- PA.readPrimArray drbg 15 368 !v06 <- PA.readPrimArray drbg 16 369 !v07 <- PA.readPrimArray drbg 17 370 pure . BS.toStrict . BSB.toLazyByteString $ mconcat [ 371 BSB.word32BE v00 372 , BSB.word32BE v01 373 , BSB.word32BE v02 374 , BSB.word32BE v03 375 , BSB.word32BE v04 376 , BSB.word32BE v05 377 , BSB.word32BE v06 378 , BSB.word32BE v07 379 ] 380 381 -- read secret drbg state (for testing) 382 _read_k 383 :: PrimMonad m 384 => DRBG (PrimState m) 385 -> m BS.ByteString 386 _read_k (DRBG drbg) = do 387 !k00 <- PA.readPrimArray drbg 02 388 !k01 <- PA.readPrimArray drbg 03 389 !k02 <- PA.readPrimArray drbg 04 390 !k03 <- PA.readPrimArray drbg 05 391 !k04 <- PA.readPrimArray drbg 06 392 !k05 <- PA.readPrimArray drbg 07 393 !k06 <- PA.readPrimArray drbg 08 394 !k07 <- PA.readPrimArray drbg 09 395 pure . BS.toStrict . BSB.toLazyByteString $ mconcat [ 396 BSB.word32BE k00 397 , BSB.word32BE k01 398 , BSB.word32BE k02 399 , BSB.word32BE k03 400 , BSB.word32BE k04 401 , BSB.word32BE k05 402 , BSB.word32BE k06 403 , BSB.word32BE k07 404 ] 405