SHA512.hs (13810B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE MagicHash #-} 4 {-# LANGUAGE PatternSynonyms #-} 5 {-# LANGUAGE UnboxedTuples #-} 6 7 -- | 8 -- Module: Crypto.DRBG.HMAC.SHA512 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.SHA512 ( 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.SHA512 as SHA512 34 import Crypto.Hash.SHA512.Internal (Registers(..)) 35 import qualified Crypto.Hash.SHA512.Internal as SHA512 (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 qualified Data.ByteString as BS 41 import qualified Data.ByteString.Builder as BSB 42 import qualified Data.ByteString.Internal as BI 43 import qualified Data.Primitive.PrimArray as PA 44 import Data.Word (Word64) 45 import qualified GHC.Word 46 import qualified Foreign.Ptr as FP 47 48 -- api ------------------------------------------------------------------------ 49 50 -- | A deterministic random bit generator (DRBG). 51 -- 52 -- Create a DRBG with 'new', and then use and reuse it to generate 53 -- bytes as needed. 54 -- 55 -- >>> drbg <- new entropy nonce personalization_string 56 -- >>> bytes0 <- gen drbg mempty 10 57 -- >>> bytes1 <- gen drbg mempty 10 58 -- >>> drbg 59 -- "<drbg>" 60 61 -- layout (Word64 array): 62 -- index 0: counter 63 -- indices 1-8: k (8 Word64s = 64 bytes) 64 -- indices 9-16: v (8 Word64s = 64 bytes) 65 -- indices 17-32: scratch space (16 Word64s = 128 bytes) 66 newtype DRBG s = DRBG (PA.MutablePrimArray s Word64) 67 68 instance Show (DRBG s) where 69 show _ = "<drbg>" 70 71 -- | Create a HMAC-SHA512 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 33 -- 1 (ctr) + 16 (k, v) + 16 (scratch) 86 init_counter drbg 87 PA.setPrimArray drbg 01 08 (0x0000000000000000 :: Word64) -- init k 88 PA.setPrimArray drbg 09 08 (0x0101010101010101 :: Word64) -- init v 89 PA.setPrimArray drbg 17 16 (0x0000000000000000 :: Word64) -- 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.W64# k00) <- PA.readPrimArray drbg 01 155 !(GHC.Word.W64# k01) <- PA.readPrimArray drbg 02 156 !(GHC.Word.W64# k02) <- PA.readPrimArray drbg 03 157 !(GHC.Word.W64# k03) <- PA.readPrimArray drbg 04 158 !(GHC.Word.W64# k04) <- PA.readPrimArray drbg 05 159 !(GHC.Word.W64# k05) <- PA.readPrimArray drbg 06 160 !(GHC.Word.W64# k06) <- PA.readPrimArray drbg 07 161 !(GHC.Word.W64# k07) <- PA.readPrimArray drbg 08 162 !(GHC.Word.W64# v00) <- PA.readPrimArray drbg 09 163 !(GHC.Word.W64# v01) <- PA.readPrimArray drbg 10 164 !(GHC.Word.W64# v02) <- PA.readPrimArray drbg 11 165 !(GHC.Word.W64# v03) <- PA.readPrimArray drbg 12 166 !(GHC.Word.W64# v04) <- PA.readPrimArray drbg 13 167 !(GHC.Word.W64# v05) <- PA.readPrimArray drbg 14 168 !(GHC.Word.W64# v06) <- PA.readPrimArray drbg 15 169 !(GHC.Word.W64# v07) <- PA.readPrimArray drbg 16 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 01 08 (0x0000000000000000 :: Word64) -- init k 200 PA.setPrimArray drbg 09 08 (0x0101010101010101 :: Word64) -- init v 201 PA.setPrimArray drbg 17 16 (0x0000000000000000 :: Word64) -- init scratch 202 {-# INLINE wipe #-} 203 204 -- drbg utilities ------------------------------------------------------------- 205 206 gen_loop 207 :: PrimMonad m 208 => PA.MutablePrimArray (PrimState m) Word64 209 -> Registers 210 -> Registers 211 -> Word64 212 -> m BS.ByteString 213 gen_loop drbg k0 v0 bytes = loop mempty v0 0 where 214 !vp = PA.mutablePrimArrayContents drbg `FP.plusPtr` 72 -- 9 * 8 215 !sp = PA.mutablePrimArrayContents drbg `FP.plusPtr` 136 -- 17 * 8 216 loop !acc v l 217 | l >= bytes = do 218 write_v drbg v 219 pure acc 220 | otherwise = do 221 Prim.unsafeIOToPrim $ SHA512._hmac_rr vp sp k0 v 222 !(GHC.Word.W64# nv0) <- PA.readPrimArray drbg 09 223 !(GHC.Word.W64# nv1) <- PA.readPrimArray drbg 10 224 !(GHC.Word.W64# nv2) <- PA.readPrimArray drbg 11 225 !(GHC.Word.W64# nv3) <- PA.readPrimArray drbg 12 226 !(GHC.Word.W64# nv4) <- PA.readPrimArray drbg 13 227 !(GHC.Word.W64# nv5) <- PA.readPrimArray drbg 14 228 !(GHC.Word.W64# nv6) <- PA.readPrimArray drbg 15 229 !(GHC.Word.W64# nv7) <- PA.readPrimArray drbg 16 230 let !nv = Registers (# nv0, nv1, nv2, nv3, nv4, nv5, nv6, nv7 #) 231 !na = acc <> SHA512.cat nv 232 !nl = l + 64 233 loop na nv nl 234 {-# INLINE gen_loop #-} 235 236 update 237 :: PrimMonad m 238 => PA.MutablePrimArray (PrimState m) Word64 239 -> BS.ByteString 240 -> m () 241 update drbg provided_data@(BI.PS _ _ l) = do 242 !(GHC.Word.W64# k00) <- PA.readPrimArray drbg 01 243 !(GHC.Word.W64# k01) <- PA.readPrimArray drbg 02 244 !(GHC.Word.W64# k02) <- PA.readPrimArray drbg 03 245 !(GHC.Word.W64# k03) <- PA.readPrimArray drbg 04 246 !(GHC.Word.W64# k04) <- PA.readPrimArray drbg 05 247 !(GHC.Word.W64# k05) <- PA.readPrimArray drbg 06 248 !(GHC.Word.W64# k06) <- PA.readPrimArray drbg 07 249 !(GHC.Word.W64# k07) <- PA.readPrimArray drbg 08 250 !(GHC.Word.W64# v00) <- PA.readPrimArray drbg 09 251 !(GHC.Word.W64# v01) <- PA.readPrimArray drbg 10 252 !(GHC.Word.W64# v02) <- PA.readPrimArray drbg 11 253 !(GHC.Word.W64# v03) <- PA.readPrimArray drbg 12 254 !(GHC.Word.W64# v04) <- PA.readPrimArray drbg 13 255 !(GHC.Word.W64# v05) <- PA.readPrimArray drbg 14 256 !(GHC.Word.W64# v06) <- PA.readPrimArray drbg 15 257 !(GHC.Word.W64# v07) <- PA.readPrimArray drbg 16 258 let !k0 = Registers (# k00, k01, k02, k03, k04, k05, k06, k07 #) 259 !v0 = Registers (# v00, v01, v02, v03, v04, v05, v06, v07 #) 260 !kp = PA.mutablePrimArrayContents drbg `FP.plusPtr` 08 -- 1 * 8 261 !vp = PA.mutablePrimArrayContents drbg `FP.plusPtr` 72 -- 9 * 8 262 !sp = PA.mutablePrimArrayContents drbg `FP.plusPtr` 136 -- 17 * 8 263 Prim.unsafeIOToPrim $ SHA512._hmac_rsb kp sp k0 v0 0x00 provided_data 264 !(GHC.Word.W64# k10) <- PA.readPrimArray drbg 01 265 !(GHC.Word.W64# k11) <- PA.readPrimArray drbg 02 266 !(GHC.Word.W64# k12) <- PA.readPrimArray drbg 03 267 !(GHC.Word.W64# k13) <- PA.readPrimArray drbg 04 268 !(GHC.Word.W64# k14) <- PA.readPrimArray drbg 05 269 !(GHC.Word.W64# k15) <- PA.readPrimArray drbg 06 270 !(GHC.Word.W64# k16) <- PA.readPrimArray drbg 07 271 !(GHC.Word.W64# k17) <- PA.readPrimArray drbg 08 272 let !k1 = Registers (# k10, k11, k12, k13, k14, k15, k16, k17 #) 273 Prim.unsafeIOToPrim $ SHA512._hmac_rr vp sp k1 v0 274 if l == 0 275 then pure () 276 else do 277 !(GHC.Word.W64# v10) <- PA.readPrimArray drbg 09 278 !(GHC.Word.W64# v11) <- PA.readPrimArray drbg 10 279 !(GHC.Word.W64# v12) <- PA.readPrimArray drbg 11 280 !(GHC.Word.W64# v13) <- PA.readPrimArray drbg 12 281 !(GHC.Word.W64# v14) <- PA.readPrimArray drbg 13 282 !(GHC.Word.W64# v15) <- PA.readPrimArray drbg 14 283 !(GHC.Word.W64# v16) <- PA.readPrimArray drbg 15 284 !(GHC.Word.W64# v17) <- PA.readPrimArray drbg 16 285 let !v1 = Registers (# v10, v11, v12, v13, v14, v15, v16, v17 #) 286 Prim.unsafeIOToPrim $ SHA512._hmac_rsb kp sp k1 v1 0x01 provided_data 287 !(GHC.Word.W64# k20) <- PA.readPrimArray drbg 01 288 !(GHC.Word.W64# k21) <- PA.readPrimArray drbg 02 289 !(GHC.Word.W64# k22) <- PA.readPrimArray drbg 03 290 !(GHC.Word.W64# k23) <- PA.readPrimArray drbg 04 291 !(GHC.Word.W64# k24) <- PA.readPrimArray drbg 05 292 !(GHC.Word.W64# k25) <- PA.readPrimArray drbg 06 293 !(GHC.Word.W64# k26) <- PA.readPrimArray drbg 07 294 !(GHC.Word.W64# k27) <- PA.readPrimArray drbg 08 295 let !k2 = Registers (# k20, k21, k22, k23, k24, k25, k26, k27 #) 296 Prim.unsafeIOToPrim $ SHA512._hmac_rr vp sp k2 v1 297 {-# INLINABLE update #-} 298 {-# SPECIALIZE update 299 :: PA.MutablePrimArray RealWorld Word64 -> BS.ByteString -> IO () #-} 300 {-# SPECIALIZE update 301 :: PA.MutablePrimArray s Word64 -> BS.ByteString -> ST s () #-} 302 303 init_counter 304 :: PrimMonad m 305 => PA.MutablePrimArray (PrimState m) Word64 306 -> m () 307 init_counter drbg = 308 PA.writePrimArray drbg 0 (0x01 :: Word64) 309 {-# INLINE init_counter #-} 310 311 read_counter 312 :: PrimMonad m 313 => PA.MutablePrimArray (PrimState m) Word64 314 -> m Word64 315 read_counter drbg = PA.readPrimArray drbg 0 316 {-# INLINE read_counter #-} 317 318 write_counter 319 :: PrimMonad m 320 => PA.MutablePrimArray (PrimState m) Word64 321 -> Word64 322 -> m () 323 write_counter drbg = PA.writePrimArray drbg 0 324 {-# INLINE write_counter #-} 325 326 write_v 327 :: PrimMonad m 328 => PA.MutablePrimArray (PrimState m) Word64 329 -> Registers 330 -> m () 331 write_v drbg (R v0 v1 v2 v3 v4 v5 v6 v7) = do 332 PA.writePrimArray drbg 09 (GHC.Word.W64# v0) 333 PA.writePrimArray drbg 10 (GHC.Word.W64# v1) 334 PA.writePrimArray drbg 11 (GHC.Word.W64# v2) 335 PA.writePrimArray drbg 12 (GHC.Word.W64# v3) 336 PA.writePrimArray drbg 13 (GHC.Word.W64# v4) 337 PA.writePrimArray drbg 14 (GHC.Word.W64# v5) 338 PA.writePrimArray drbg 15 (GHC.Word.W64# v6) 339 PA.writePrimArray drbg 16 (GHC.Word.W64# v7) 340 {-# INLINE write_v #-} 341 342 -- read secret drbg state (for testing) 343 _read_v 344 :: PrimMonad m 345 => DRBG (PrimState m) 346 -> m BS.ByteString 347 _read_v (DRBG drbg) = do 348 !v00 <- PA.readPrimArray drbg 09 349 !v01 <- PA.readPrimArray drbg 10 350 !v02 <- PA.readPrimArray drbg 11 351 !v03 <- PA.readPrimArray drbg 12 352 !v04 <- PA.readPrimArray drbg 13 353 !v05 <- PA.readPrimArray drbg 14 354 !v06 <- PA.readPrimArray drbg 15 355 !v07 <- PA.readPrimArray drbg 16 356 pure . BS.toStrict . BSB.toLazyByteString $ mconcat [ 357 BSB.word64BE v00 358 , BSB.word64BE v01 359 , BSB.word64BE v02 360 , BSB.word64BE v03 361 , BSB.word64BE v04 362 , BSB.word64BE v05 363 , BSB.word64BE v06 364 , BSB.word64BE v07 365 ] 366 367 -- read secret drbg state (for testing) 368 _read_k 369 :: PrimMonad m 370 => DRBG (PrimState m) 371 -> m BS.ByteString 372 _read_k (DRBG drbg) = do 373 !k00 <- PA.readPrimArray drbg 01 374 !k01 <- PA.readPrimArray drbg 02 375 !k02 <- PA.readPrimArray drbg 03 376 !k03 <- PA.readPrimArray drbg 04 377 !k04 <- PA.readPrimArray drbg 05 378 !k05 <- PA.readPrimArray drbg 06 379 !k06 <- PA.readPrimArray drbg 07 380 !k07 <- PA.readPrimArray drbg 08 381 pure . BS.toStrict . BSB.toLazyByteString $ mconcat [ 382 BSB.word64BE k00 383 , BSB.word64BE k01 384 , BSB.word64BE k02 385 , BSB.word64BE k03 386 , BSB.word64BE k04 387 , BSB.word64BE k05 388 , BSB.word64BE k06 389 , BSB.word64BE k07 390 ]