Internal.hs (30758B)
1 {-# OPTIONS_HADDOCK hide #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE DerivingStrategies #-} 4 {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 {-# LANGUAGE MagicHash #-} 6 {-# LANGUAGE PatternSynonyms #-} 7 {-# LANGUAGE UnboxedTuples #-} 8 {-# LANGUAGE UnliftedNewtypes #-} 9 {-# LANGUAGE ViewPatterns #-} 10 11 -- | 12 -- Module: Crypto.Hash.SHA256.Internal 13 -- Copyright: (c) 2024 Jared Tobin 14 -- License: MIT 15 -- Maintainer: Jared Tobin <jared@ppad.tech> 16 -- 17 -- SHA-256 internals. 18 19 module Crypto.Hash.SHA256.Internal ( 20 -- * Types 21 Block(B, ..) 22 , Registers(R, ..) 23 , MAC(..) 24 25 -- * Parsing 26 , parse 27 , parse_pad1 28 , parse_pad2 29 30 -- * Serializing 31 , cat 32 , cat_into 33 34 -- * Hash function internals 35 , update 36 , iv 37 38 -- * HMAC utilities 39 , pad_registers 40 , pad_registers_with_length 41 , xor 42 , parse_key 43 44 -- * HMAC-DRBG utilities 45 , parse_vsb 46 , parse_pad1_vsb 47 , parse_pad2_vsb 48 49 -- * Pointer-based IO utilities 50 , poke_registers 51 ) where 52 53 import Data.Barrier (barrier) 54 import qualified Data.Bits as B 55 import qualified Data.ByteString as BS 56 import qualified Data.ByteString.Internal as BI 57 import qualified Data.ByteString.Unsafe as BU 58 import Data.Word (Word8, Word32, Word64) 59 import qualified GHC.IO (IO(..)) 60 import GHC.Ptr (Ptr(..)) 61 import GHC.Exts (Int#) 62 import qualified GHC.Exts as Exts 63 import qualified GHC.Word (Word32(..), Word8(..)) 64 65 -- types ---------------------------------------------------------------------- 66 67 -- | A message authentication code. 68 -- 69 -- Note that you should compare MACs for equality using the 'Eq' 70 -- instance, which performs the comparison in constant time, instead 71 -- of unwrapping and comparing the underlying 'ByteStrings'. 72 -- 73 -- >>> let foo@(MAC bs0) = hmac key "hi" 74 -- >>> let bar@(MAC bs1) = hmac key "there" 75 -- >>> foo == bar -- do this 76 -- False 77 -- >>> bs0 == bs1 -- don't do this 78 -- False 79 newtype MAC = MAC BS.ByteString 80 deriving newtype Show 81 82 instance Eq MAC where 83 -- | A constant-time equality check for message authentication codes. 84 -- 85 -- Runs in variable-time only for invalid inputs. 86 (MAC a@(BI.PS _ _ la)) == (MAC b@(BI.PS _ _ lb)) 87 | la /= lb = False 88 | otherwise = go 0 0 89 where 90 -- fused fold: OR the bytewise XORs into an accumulator 91 -- directly, rather than via packZipWith, so no intermediate 92 -- ByteString holding the (secret-derived) difference bytes 93 -- is ever materialised on the heap. The accumulator is routed 94 -- through 'barrier' before the zero-test so the LLVM backend 95 -- cannot recover the array-equality idiom and short-circuit on 96 -- the first mismatch (see "Data.Barrier"). 97 go :: Word8 -> Int -> Bool 98 go !acc !i 99 | i == la = barrier acc == 0 100 | otherwise = 101 let !x = BU.unsafeIndex a i 102 !y = BU.unsafeIndex b i 103 in go (acc B..|. B.xor x y) (i + 1) 104 105 -- | SHA256 block. 106 newtype Block = Block 107 (# Exts.Word32#, Exts.Word32#, Exts.Word32#, Exts.Word32# 108 , Exts.Word32#, Exts.Word32#, Exts.Word32#, Exts.Word32# 109 , Exts.Word32#, Exts.Word32#, Exts.Word32#, Exts.Word32# 110 , Exts.Word32#, Exts.Word32#, Exts.Word32#, Exts.Word32# 111 #) 112 113 pattern B 114 :: Exts.Word32# -> Exts.Word32# -> Exts.Word32# -> Exts.Word32# 115 -> Exts.Word32# -> Exts.Word32# -> Exts.Word32# -> Exts.Word32# 116 -> Exts.Word32# -> Exts.Word32# -> Exts.Word32# -> Exts.Word32# 117 -> Exts.Word32# -> Exts.Word32# -> Exts.Word32# -> Exts.Word32# 118 -> Block 119 pattern B w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 w10 w11 w12 w13 w14 w15 = 120 Block 121 (# w00, w01, w02, w03, w04, w05, w06, w07 122 , w08, w09, w10, w11, w12, w13, w14, w15 123 #) 124 {-# COMPLETE B #-} 125 126 -- | SHA256 state. 127 newtype Registers = Registers 128 (# Exts.Word32#, Exts.Word32#, Exts.Word32#, Exts.Word32# 129 , Exts.Word32#, Exts.Word32#, Exts.Word32#, Exts.Word32# 130 #) 131 132 pattern R 133 :: Exts.Word32# -> Exts.Word32# -> Exts.Word32# -> Exts.Word32# 134 -> Exts.Word32# -> Exts.Word32# -> Exts.Word32# -> Exts.Word32# 135 -> Registers 136 pattern R w00 w01 w02 w03 w04 w05 w06 w07 = Registers 137 (# w00, w01, w02, w03 138 , w04, w05, w06, w07 139 #) 140 {-# COMPLETE R #-} 141 142 -- utilities ------------------------------------------------------------------ 143 144 fi :: (Integral a, Num b) => a -> b 145 fi = fromIntegral 146 {-# INLINE fi #-} 147 148 -- parsing (nonfinal input) --------------------------------------------------- 149 150 -- | Given a bytestring and offset, parse a full block. 151 -- 152 -- The length of the input is not checked. 153 parse :: BS.ByteString -> Int -> Block 154 parse bs m = B 155 (word32be bs m) 156 (word32be bs (m + 04)) 157 (word32be bs (m + 08)) 158 (word32be bs (m + 12)) 159 (word32be bs (m + 16)) 160 (word32be bs (m + 20)) 161 (word32be bs (m + 24)) 162 (word32be bs (m + 28)) 163 (word32be bs (m + 32)) 164 (word32be bs (m + 36)) 165 (word32be bs (m + 40)) 166 (word32be bs (m + 44)) 167 (word32be bs (m + 48)) 168 (word32be bs (m + 52)) 169 (word32be bs (m + 56)) 170 (word32be bs (m + 60)) 171 {-# INLINE parse #-} 172 173 -- | Parse the 32-bit word encoded at the given ofset. 174 -- 175 -- The length of the input is not checked. 176 word32be :: BS.ByteString -> Int -> Exts.Word32# 177 word32be bs m = 178 let !(GHC.Word.W8# ra) = BU.unsafeIndex bs m 179 !(GHC.Word.W8# rb) = BU.unsafeIndex bs (m + 1) 180 !(GHC.Word.W8# rc) = BU.unsafeIndex bs (m + 2) 181 !(GHC.Word.W8# rd) = BU.unsafeIndex bs (m + 3) 182 !a = Exts.wordToWord32# (Exts.word8ToWord# ra) 183 !b = Exts.wordToWord32# (Exts.word8ToWord# rb) 184 !c = Exts.wordToWord32# (Exts.word8ToWord# rc) 185 !d = Exts.wordToWord32# (Exts.word8ToWord# rd) 186 !sa = Exts.uncheckedShiftLWord32# a 24# 187 !sb = Exts.uncheckedShiftLWord32# b 16# 188 !sc = Exts.uncheckedShiftLWord32# c 08# 189 in sa `Exts.orWord32#` sb `Exts.orWord32#` sc `Exts.orWord32#` d 190 {-# INLINE word32be #-} 191 192 -- parsing (final input) ------------------------------------------------------ 193 194 -- | Parse the final chunk of an input message, assuming it is less than 195 -- 56 bytes in length (unchecked!). 196 -- 197 -- Returns one block consisting of the chunk and padding. 198 parse_pad1 199 :: BS.ByteString -- ^ final input chunk (< 56 bytes) 200 -> Word64 -- ^ length of all input 201 -> Block -- ^ resulting block 202 parse_pad1 bs l = 203 let !bits = l * 8 204 !(GHC.Word.W32# lhi) = fi (bits `B.unsafeShiftR` 32) 205 !(GHC.Word.W32# llo) = fi bits 206 in B (w32_at bs 00) (w32_at bs 04) (w32_at bs 08) (w32_at bs 12) 207 (w32_at bs 16) (w32_at bs 20) (w32_at bs 24) (w32_at bs 28) 208 (w32_at bs 32) (w32_at bs 36) (w32_at bs 40) (w32_at bs 44) 209 (w32_at bs 48) (w32_at bs 52) lhi llo 210 {-# INLINABLE parse_pad1 #-} 211 212 -- | Parse the final chunk of an input message, assuming it is at least 56 213 -- bytes in length (unchecked!). 214 -- 215 -- Returns two blocks consisting of the chunk and padding. 216 parse_pad2 217 :: BS.ByteString -- ^ final input chunk (>= 56 bytes) 218 -> Word64 -- ^ length of all input 219 -> (# Block, Block #) -- ^ resulting blocks 220 parse_pad2 bs l = 221 let !bits = l * 8 222 !z = Exts.wordToWord32# 0## 223 !(GHC.Word.W32# lhi) = fi (bits `B.unsafeShiftR` 32) 224 !(GHC.Word.W32# llo) = fi bits 225 !block0 = B 226 (w32_at bs 00) (w32_at bs 04) (w32_at bs 08) (w32_at bs 12) 227 (w32_at bs 16) (w32_at bs 20) (w32_at bs 24) (w32_at bs 28) 228 (w32_at bs 32) (w32_at bs 36) (w32_at bs 40) (w32_at bs 44) 229 (w32_at bs 48) (w32_at bs 52) (w32_at bs 56) (w32_at bs 60) 230 !block1 = B z z z z z z z z z z z z z z lhi llo 231 in (# block0, block1 #) 232 {-# INLINABLE parse_pad2 #-} 233 234 -- | Return the byte at offset 'i', or a padding separator or zero byte 235 -- beyond the input bounds, as an unboxed 32-bit word. 236 w8_as_w32_at 237 :: BS.ByteString -- ^ input chunk 238 -> Int -- ^ offset 239 -> Exts.Word32# 240 w8_as_w32_at bs@(BI.PS _ _ l) i = Exts.wordToWord32# $ case compare i l of 241 LT -> let !(GHC.Word.W8# w) = BU.unsafeIndex bs i 242 in Exts.word8ToWord# w 243 EQ -> 0x80## 244 _ -> 0x00## 245 {-# INLINE w8_as_w32_at #-} 246 247 -- | Return the 32-bit word encoded by four consecutive bytes at the 248 -- provided offset. 249 w32_at 250 :: BS.ByteString 251 -> Int 252 -> Exts.Word32# 253 w32_at bs i = 254 let !wa = w8_as_w32_at bs i `Exts.uncheckedShiftLWord32#` 24# 255 !wb = w8_as_w32_at bs (i + 1) `Exts.uncheckedShiftLWord32#` 16# 256 !wc = w8_as_w32_at bs (i + 2) `Exts.uncheckedShiftLWord32#` 08# 257 !wd = w8_as_w32_at bs (i + 3) 258 in wa `Exts.orWord32#` wb `Exts.orWord32#` wc `Exts.orWord32#` wd 259 {-# INLINE w32_at #-} 260 261 -- update --------------------------------------------------------------------- 262 263 -- | Update register state, given new input block. 264 update :: Registers -> Block -> Registers 265 update 266 (R h0 h1 h2 h3 h4 h5 h6 h7) 267 (B b00 b01 b02 b03 b04 b05 b06 b07 b08 b09 b10 b11 b12 b13 b14 b15) 268 = 269 let -- message schedule 270 !w00 = b00; !w01 = b01; !w02 = b02; !w03 = b03 271 !w04 = b04; !w05 = b05; !w06 = b06; !w07 = b07 272 !w08 = b08; !w09 = b09; !w10 = b10; !w11 = b11 273 !w12 = b12; !w13 = b13; !w14 = b14; !w15 = b15 274 !w16 = ssig1# w14 `p` w09 `p` ssig0# w01 `p` w00 275 !w17 = ssig1# w15 `p` w10 `p` ssig0# w02 `p` w01 276 !w18 = ssig1# w16 `p` w11 `p` ssig0# w03 `p` w02 277 !w19 = ssig1# w17 `p` w12 `p` ssig0# w04 `p` w03 278 !w20 = ssig1# w18 `p` w13 `p` ssig0# w05 `p` w04 279 !w21 = ssig1# w19 `p` w14 `p` ssig0# w06 `p` w05 280 !w22 = ssig1# w20 `p` w15 `p` ssig0# w07 `p` w06 281 !w23 = ssig1# w21 `p` w16 `p` ssig0# w08 `p` w07 282 !w24 = ssig1# w22 `p` w17 `p` ssig0# w09 `p` w08 283 !w25 = ssig1# w23 `p` w18 `p` ssig0# w10 `p` w09 284 !w26 = ssig1# w24 `p` w19 `p` ssig0# w11 `p` w10 285 !w27 = ssig1# w25 `p` w20 `p` ssig0# w12 `p` w11 286 !w28 = ssig1# w26 `p` w21 `p` ssig0# w13 `p` w12 287 !w29 = ssig1# w27 `p` w22 `p` ssig0# w14 `p` w13 288 !w30 = ssig1# w28 `p` w23 `p` ssig0# w15 `p` w14 289 !w31 = ssig1# w29 `p` w24 `p` ssig0# w16 `p` w15 290 !w32 = ssig1# w30 `p` w25 `p` ssig0# w17 `p` w16 291 !w33 = ssig1# w31 `p` w26 `p` ssig0# w18 `p` w17 292 !w34 = ssig1# w32 `p` w27 `p` ssig0# w19 `p` w18 293 !w35 = ssig1# w33 `p` w28 `p` ssig0# w20 `p` w19 294 !w36 = ssig1# w34 `p` w29 `p` ssig0# w21 `p` w20 295 !w37 = ssig1# w35 `p` w30 `p` ssig0# w22 `p` w21 296 !w38 = ssig1# w36 `p` w31 `p` ssig0# w23 `p` w22 297 !w39 = ssig1# w37 `p` w32 `p` ssig0# w24 `p` w23 298 !w40 = ssig1# w38 `p` w33 `p` ssig0# w25 `p` w24 299 !w41 = ssig1# w39 `p` w34 `p` ssig0# w26 `p` w25 300 !w42 = ssig1# w40 `p` w35 `p` ssig0# w27 `p` w26 301 !w43 = ssig1# w41 `p` w36 `p` ssig0# w28 `p` w27 302 !w44 = ssig1# w42 `p` w37 `p` ssig0# w29 `p` w28 303 !w45 = ssig1# w43 `p` w38 `p` ssig0# w30 `p` w29 304 !w46 = ssig1# w44 `p` w39 `p` ssig0# w31 `p` w30 305 !w47 = ssig1# w45 `p` w40 `p` ssig0# w32 `p` w31 306 !w48 = ssig1# w46 `p` w41 `p` ssig0# w33 `p` w32 307 !w49 = ssig1# w47 `p` w42 `p` ssig0# w34 `p` w33 308 !w50 = ssig1# w48 `p` w43 `p` ssig0# w35 `p` w34 309 !w51 = ssig1# w49 `p` w44 `p` ssig0# w36 `p` w35 310 !w52 = ssig1# w50 `p` w45 `p` ssig0# w37 `p` w36 311 !w53 = ssig1# w51 `p` w46 `p` ssig0# w38 `p` w37 312 !w54 = ssig1# w52 `p` w47 `p` ssig0# w39 `p` w38 313 !w55 = ssig1# w53 `p` w48 `p` ssig0# w40 `p` w39 314 !w56 = ssig1# w54 `p` w49 `p` ssig0# w41 `p` w40 315 !w57 = ssig1# w55 `p` w50 `p` ssig0# w42 `p` w41 316 !w58 = ssig1# w56 `p` w51 `p` ssig0# w43 `p` w42 317 !w59 = ssig1# w57 `p` w52 `p` ssig0# w44 `p` w43 318 !w60 = ssig1# w58 `p` w53 `p` ssig0# w45 `p` w44 319 !w61 = ssig1# w59 `p` w54 `p` ssig0# w46 `p` w45 320 !w62 = ssig1# w60 `p` w55 `p` ssig0# w47 `p` w46 321 !w63 = ssig1# w61 `p` w56 `p` ssig0# w48 `p` w47 322 323 -- rounds (constants are cube roots of first 64 primes) 324 !(R s00a s00b s00c s00d s00e s00f s00g s00h) = 325 step# h0 h1 h2 h3 h4 h5 h6 h7 (k 0x428a2f98##) w00 326 !(R s01a s01b s01c s01d s01e s01f s01g s01h) = 327 step# s00a s00b s00c s00d s00e s00f s00g s00h (k 0x71374491##) w01 328 !(R s02a s02b s02c s02d s02e s02f s02g s02h) = 329 step# s01a s01b s01c s01d s01e s01f s01g s01h (k 0xb5c0fbcf##) w02 330 !(R s03a s03b s03c s03d s03e s03f s03g s03h) = 331 step# s02a s02b s02c s02d s02e s02f s02g s02h (k 0xe9b5dba5##) w03 332 !(R s04a s04b s04c s04d s04e s04f s04g s04h) = 333 step# s03a s03b s03c s03d s03e s03f s03g s03h (k 0x3956c25b##) w04 334 !(R s05a s05b s05c s05d s05e s05f s05g s05h) = 335 step# s04a s04b s04c s04d s04e s04f s04g s04h (k 0x59f111f1##) w05 336 !(R s06a s06b s06c s06d s06e s06f s06g s06h) = 337 step# s05a s05b s05c s05d s05e s05f s05g s05h (k 0x923f82a4##) w06 338 !(R s07a s07b s07c s07d s07e s07f s07g s07h) = 339 step# s06a s06b s06c s06d s06e s06f s06g s06h (k 0xab1c5ed5##) w07 340 !(R s08a s08b s08c s08d s08e s08f s08g s08h) = 341 step# s07a s07b s07c s07d s07e s07f s07g s07h (k 0xd807aa98##) w08 342 !(R s09a s09b s09c s09d s09e s09f s09g s09h) = 343 step# s08a s08b s08c s08d s08e s08f s08g s08h (k 0x12835b01##) w09 344 !(R s10a s10b s10c s10d s10e s10f s10g s10h) = 345 step# s09a s09b s09c s09d s09e s09f s09g s09h (k 0x243185be##) w10 346 !(R s11a s11b s11c s11d s11e s11f s11g s11h) = 347 step# s10a s10b s10c s10d s10e s10f s10g s10h (k 0x550c7dc3##) w11 348 !(R s12a s12b s12c s12d s12e s12f s12g s12h) = 349 step# s11a s11b s11c s11d s11e s11f s11g s11h (k 0x72be5d74##) w12 350 !(R s13a s13b s13c s13d s13e s13f s13g s13h) = 351 step# s12a s12b s12c s12d s12e s12f s12g s12h (k 0x80deb1fe##) w13 352 !(R s14a s14b s14c s14d s14e s14f s14g s14h) = 353 step# s13a s13b s13c s13d s13e s13f s13g s13h (k 0x9bdc06a7##) w14 354 !(R s15a s15b s15c s15d s15e s15f s15g s15h) = 355 step# s14a s14b s14c s14d s14e s14f s14g s14h (k 0xc19bf174##) w15 356 !(R s16a s16b s16c s16d s16e s16f s16g s16h) = 357 step# s15a s15b s15c s15d s15e s15f s15g s15h (k 0xe49b69c1##) w16 358 !(R s17a s17b s17c s17d s17e s17f s17g s17h) = 359 step# s16a s16b s16c s16d s16e s16f s16g s16h (k 0xefbe4786##) w17 360 !(R s18a s18b s18c s18d s18e s18f s18g s18h) = 361 step# s17a s17b s17c s17d s17e s17f s17g s17h (k 0x0fc19dc6##) w18 362 !(R s19a s19b s19c s19d s19e s19f s19g s19h) = 363 step# s18a s18b s18c s18d s18e s18f s18g s18h (k 0x240ca1cc##) w19 364 !(R s20a s20b s20c s20d s20e s20f s20g s20h) = 365 step# s19a s19b s19c s19d s19e s19f s19g s19h (k 0x2de92c6f##) w20 366 !(R s21a s21b s21c s21d s21e s21f s21g s21h) = 367 step# s20a s20b s20c s20d s20e s20f s20g s20h (k 0x4a7484aa##) w21 368 !(R s22a s22b s22c s22d s22e s22f s22g s22h) = 369 step# s21a s21b s21c s21d s21e s21f s21g s21h (k 0x5cb0a9dc##) w22 370 !(R s23a s23b s23c s23d s23e s23f s23g s23h) = 371 step# s22a s22b s22c s22d s22e s22f s22g s22h (k 0x76f988da##) w23 372 !(R s24a s24b s24c s24d s24e s24f s24g s24h) = 373 step# s23a s23b s23c s23d s23e s23f s23g s23h (k 0x983e5152##) w24 374 !(R s25a s25b s25c s25d s25e s25f s25g s25h) = 375 step# s24a s24b s24c s24d s24e s24f s24g s24h (k 0xa831c66d##) w25 376 !(R s26a s26b s26c s26d s26e s26f s26g s26h) = 377 step# s25a s25b s25c s25d s25e s25f s25g s25h (k 0xb00327c8##) w26 378 !(R s27a s27b s27c s27d s27e s27f s27g s27h) = 379 step# s26a s26b s26c s26d s26e s26f s26g s26h (k 0xbf597fc7##) w27 380 !(R s28a s28b s28c s28d s28e s28f s28g s28h) = 381 step# s27a s27b s27c s27d s27e s27f s27g s27h (k 0xc6e00bf3##) w28 382 !(R s29a s29b s29c s29d s29e s29f s29g s29h) = 383 step# s28a s28b s28c s28d s28e s28f s28g s28h (k 0xd5a79147##) w29 384 !(R s30a s30b s30c s30d s30e s30f s30g s30h) = 385 step# s29a s29b s29c s29d s29e s29f s29g s29h (k 0x06ca6351##) w30 386 !(R s31a s31b s31c s31d s31e s31f s31g s31h) = 387 step# s30a s30b s30c s30d s30e s30f s30g s30h (k 0x14292967##) w31 388 !(R s32a s32b s32c s32d s32e s32f s32g s32h) = 389 step# s31a s31b s31c s31d s31e s31f s31g s31h (k 0x27b70a85##) w32 390 !(R s33a s33b s33c s33d s33e s33f s33g s33h) = 391 step# s32a s32b s32c s32d s32e s32f s32g s32h (k 0x2e1b2138##) w33 392 !(R s34a s34b s34c s34d s34e s34f s34g s34h) = 393 step# s33a s33b s33c s33d s33e s33f s33g s33h (k 0x4d2c6dfc##) w34 394 !(R s35a s35b s35c s35d s35e s35f s35g s35h) = 395 step# s34a s34b s34c s34d s34e s34f s34g s34h (k 0x53380d13##) w35 396 !(R s36a s36b s36c s36d s36e s36f s36g s36h) = 397 step# s35a s35b s35c s35d s35e s35f s35g s35h (k 0x650a7354##) w36 398 !(R s37a s37b s37c s37d s37e s37f s37g s37h) = 399 step# s36a s36b s36c s36d s36e s36f s36g s36h (k 0x766a0abb##) w37 400 !(R s38a s38b s38c s38d s38e s38f s38g s38h) = 401 step# s37a s37b s37c s37d s37e s37f s37g s37h (k 0x81c2c92e##) w38 402 !(R s39a s39b s39c s39d s39e s39f s39g s39h) = 403 step# s38a s38b s38c s38d s38e s38f s38g s38h (k 0x92722c85##) w39 404 !(R s40a s40b s40c s40d s40e s40f s40g s40h) = 405 step# s39a s39b s39c s39d s39e s39f s39g s39h (k 0xa2bfe8a1##) w40 406 !(R s41a s41b s41c s41d s41e s41f s41g s41h) = 407 step# s40a s40b s40c s40d s40e s40f s40g s40h (k 0xa81a664b##) w41 408 !(R s42a s42b s42c s42d s42e s42f s42g s42h) = 409 step# s41a s41b s41c s41d s41e s41f s41g s41h (k 0xc24b8b70##) w42 410 !(R s43a s43b s43c s43d s43e s43f s43g s43h) = 411 step# s42a s42b s42c s42d s42e s42f s42g s42h (k 0xc76c51a3##) w43 412 !(R s44a s44b s44c s44d s44e s44f s44g s44h) = 413 step# s43a s43b s43c s43d s43e s43f s43g s43h (k 0xd192e819##) w44 414 !(R s45a s45b s45c s45d s45e s45f s45g s45h) = 415 step# s44a s44b s44c s44d s44e s44f s44g s44h (k 0xd6990624##) w45 416 !(R s46a s46b s46c s46d s46e s46f s46g s46h) = 417 step# s45a s45b s45c s45d s45e s45f s45g s45h (k 0xf40e3585##) w46 418 !(R s47a s47b s47c s47d s47e s47f s47g s47h) = 419 step# s46a s46b s46c s46d s46e s46f s46g s46h (k 0x106aa070##) w47 420 !(R s48a s48b s48c s48d s48e s48f s48g s48h) = 421 step# s47a s47b s47c s47d s47e s47f s47g s47h (k 0x19a4c116##) w48 422 !(R s49a s49b s49c s49d s49e s49f s49g s49h) = 423 step# s48a s48b s48c s48d s48e s48f s48g s48h (k 0x1e376c08##) w49 424 !(R s50a s50b s50c s50d s50e s50f s50g s50h) = 425 step# s49a s49b s49c s49d s49e s49f s49g s49h (k 0x2748774c##) w50 426 !(R s51a s51b s51c s51d s51e s51f s51g s51h) = 427 step# s50a s50b s50c s50d s50e s50f s50g s50h (k 0x34b0bcb5##) w51 428 !(R s52a s52b s52c s52d s52e s52f s52g s52h) = 429 step# s51a s51b s51c s51d s51e s51f s51g s51h (k 0x391c0cb3##) w52 430 !(R s53a s53b s53c s53d s53e s53f s53g s53h) = 431 step# s52a s52b s52c s52d s52e s52f s52g s52h (k 0x4ed8aa4a##) w53 432 !(R s54a s54b s54c s54d s54e s54f s54g s54h) = 433 step# s53a s53b s53c s53d s53e s53f s53g s53h (k 0x5b9cca4f##) w54 434 !(R s55a s55b s55c s55d s55e s55f s55g s55h) = 435 step# s54a s54b s54c s54d s54e s54f s54g s54h (k 0x682e6ff3##) w55 436 !(R s56a s56b s56c s56d s56e s56f s56g s56h) = 437 step# s55a s55b s55c s55d s55e s55f s55g s55h (k 0x748f82ee##) w56 438 !(R s57a s57b s57c s57d s57e s57f s57g s57h) = 439 step# s56a s56b s56c s56d s56e s56f s56g s56h (k 0x78a5636f##) w57 440 !(R s58a s58b s58c s58d s58e s58f s58g s58h) = 441 step# s57a s57b s57c s57d s57e s57f s57g s57h (k 0x84c87814##) w58 442 !(R s59a s59b s59c s59d s59e s59f s59g s59h) = 443 step# s58a s58b s58c s58d s58e s58f s58g s58h (k 0x8cc70208##) w59 444 !(R s60a s60b s60c s60d s60e s60f s60g s60h) = 445 step# s59a s59b s59c s59d s59e s59f s59g s59h (k 0x90befffa##) w60 446 !(R s61a s61b s61c s61d s61e s61f s61g s61h) = 447 step# s60a s60b s60c s60d s60e s60f s60g s60h (k 0xa4506ceb##) w61 448 !(R s62a s62b s62c s62d s62e s62f s62g s62h) = 449 step# s61a s61b s61c s61d s61e s61f s61g s61h (k 0xbef9a3f7##) w62 450 !(R s63a s63b s63c s63d s63e s63f s63g s63h) = 451 step# s62a s62b s62c s62d s62e s62f s62g s62h (k 0xc67178f2##) w63 452 in R (h0 `p` s63a) (h1 `p` s63b) (h2 `p` s63c) (h3 `p` s63d) 453 (h4 `p` s63e) (h5 `p` s63f) (h6 `p` s63g) (h7 `p` s63h) 454 where 455 p = Exts.plusWord32# 456 {-# INLINE p #-} 457 k :: Exts.Word# -> Exts.Word32# 458 k = Exts.wordToWord32# 459 {-# INLINE k #-} 460 461 -- rotate right 462 rotr# :: Exts.Word32# -> Int# -> Exts.Word32# 463 rotr# x n = 464 Exts.uncheckedShiftRLWord32# x n `Exts.orWord32#` 465 Exts.uncheckedShiftLWord32# x (32# Exts.-# n) 466 {-# INLINE rotr# #-} 467 468 -- logical right shift 469 shr# :: Exts.Word32# -> Int# -> Exts.Word32# 470 shr# = Exts.uncheckedShiftRLWord32# 471 {-# INLINE shr# #-} 472 473 -- ch(x, y, z) = (x & y) ^ (~x & z) 474 ch# :: Exts.Word32# -> Exts.Word32# -> Exts.Word32# -> Exts.Word32# 475 ch# x y z = 476 (x `Exts.andWord32#` y) `Exts.xorWord32#` 477 (Exts.notWord32# x `Exts.andWord32#` z) 478 {-# INLINE ch# #-} 479 480 -- maj(x, y, z) = (x & (y | z)) | (y & z) 481 maj# :: Exts.Word32# -> Exts.Word32# -> Exts.Word32# -> Exts.Word32# 482 maj# x y z = 483 (x `Exts.andWord32#` (y `Exts.orWord32#` z)) `Exts.orWord32#` 484 (y `Exts.andWord32#` z) 485 {-# INLINE maj# #-} 486 487 -- big sigma 0: rotr2 ^ rotr13 ^ rotr22 488 bsig0# :: Exts.Word32# -> Exts.Word32# 489 bsig0# x = 490 rotr# x 2# `Exts.xorWord32#` rotr# x 13# `Exts.xorWord32#` rotr# x 22# 491 {-# INLINE bsig0# #-} 492 493 -- big sigma 1: rotr6 ^ rotr11 ^ rotr25 494 bsig1# :: Exts.Word32# -> Exts.Word32# 495 bsig1# x = 496 rotr# x 6# `Exts.xorWord32#` rotr# x 11# `Exts.xorWord32#` rotr# x 25# 497 {-# INLINE bsig1# #-} 498 499 -- small sigma 0: rotr7 ^ rotr18 ^ shr3 500 ssig0# :: Exts.Word32# -> Exts.Word32# 501 ssig0# x = 502 rotr# x 7# `Exts.xorWord32#` rotr# x 18# `Exts.xorWord32#` shr# x 3# 503 {-# INLINE ssig0# #-} 504 505 -- small sigma 1: rotr17 ^ rotr19 ^ shr10 506 ssig1# :: Exts.Word32# -> Exts.Word32# 507 ssig1# x = 508 rotr# x 17# `Exts.xorWord32#` rotr# x 19# `Exts.xorWord32#` shr# x 10# 509 {-# INLINE ssig1# #-} 510 511 -- round step 512 step# 513 :: Exts.Word32# -> Exts.Word32# -> Exts.Word32# -> Exts.Word32# 514 -> Exts.Word32# -> Exts.Word32# -> Exts.Word32# -> Exts.Word32# 515 -> Exts.Word32# -> Exts.Word32# 516 -> Registers 517 step# a b c d e f g h k w = 518 let !t1 = h 519 `Exts.plusWord32#` bsig1# e 520 `Exts.plusWord32#` ch# e f g 521 `Exts.plusWord32#` k 522 `Exts.plusWord32#` w 523 !t2 = bsig0# a `Exts.plusWord32#` maj# a b c 524 in R (t1 `Exts.plusWord32#` t2) a b c (d `Exts.plusWord32#` t1) e f g 525 {-# INLINE step# #-} 526 527 -- initial register state; first 32 bits of the fractional parts of the 528 -- square roots of the first eight primes 529 iv :: () -> Registers 530 iv _ = R 531 (Exts.wordToWord32# 0x6a09e667##) 532 (Exts.wordToWord32# 0xbb67ae85##) 533 (Exts.wordToWord32# 0x3c6ef372##) 534 (Exts.wordToWord32# 0xa54ff53a##) 535 (Exts.wordToWord32# 0x510e527f##) 536 (Exts.wordToWord32# 0x9b05688c##) 537 (Exts.wordToWord32# 0x1f83d9ab##) 538 (Exts.wordToWord32# 0x5be0cd19##) 539 540 -- serializing ---------------------------------------------------------------- 541 542 -- | Concat SHA256 state into a ByteString. 543 cat :: Registers -> BS.ByteString 544 cat rs = BI.unsafeCreate 32 (cat_into rs) 545 {-# INLINABLE cat #-} 546 547 -- | Serialize SHA256 state to a pointer (big-endian). 548 cat_into :: Registers -> Ptr Word8 -> IO () 549 cat_into (R h0 h1 h2 h3 h4 h5 h6 h7) (Ptr addr) = GHC.IO.IO $ \s0 -> 550 case poke32be addr 00# h0 s0 of { s1 -> 551 case poke32be addr 04# h1 s1 of { s2 -> 552 case poke32be addr 08# h2 s2 of { s3 -> 553 case poke32be addr 12# h3 s3 of { s4 -> 554 case poke32be addr 16# h4 s4 of { s5 -> 555 case poke32be addr 20# h5 s5 of { s6 -> 556 case poke32be addr 24# h6 s6 of { s7 -> 557 case poke32be addr 28# h7 s7 of { s8 -> 558 (# s8, () #) 559 }}}}}}}} 560 {-# INLINE cat_into #-} 561 562 poke32be 563 :: Exts.Addr# 564 -> Int# 565 -> Exts.Word32# 566 -> Exts.State# Exts.RealWorld 567 -> Exts.State# Exts.RealWorld 568 poke32be a off w s0 = 569 case Exts.writeWord8OffAddr# a off (byte# w 24#) s0 of { s1 -> 570 case Exts.writeWord8OffAddr# a (off Exts.+# 1#) (byte# w 16#) s1 of { s2 -> 571 case Exts.writeWord8OffAddr# a (off Exts.+# 2#) (byte# w 8#) s2 of { s3 -> 572 Exts.writeWord8OffAddr# a (off Exts.+# 3#) (byte# w 0#) s3 573 }}} 574 {-# INLINE poke32be #-} 575 576 byte# :: Exts.Word32# -> Int# -> Exts.Word8# 577 byte# w n = Exts.wordToWord8# 578 (Exts.word32ToWord# (Exts.uncheckedShiftRLWord32# w n)) 579 {-# INLINE byte# #-} 580 581 -- | Write register state to a pointer (native endian Word32s). 582 poke_registers :: Ptr Word32 -> Registers -> IO () 583 poke_registers (Ptr addr) (R w0 w1 w2 w3 w4 w5 w6 w7) = GHC.IO.IO $ \s0 -> 584 case Exts.writeWord32OffAddr# addr 0# w0 s0 of { s1 -> 585 case Exts.writeWord32OffAddr# addr 1# w1 s1 of { s2 -> 586 case Exts.writeWord32OffAddr# addr 2# w2 s2 of { s3 -> 587 case Exts.writeWord32OffAddr# addr 3# w3 s3 of { s4 -> 588 case Exts.writeWord32OffAddr# addr 4# w4 s4 of { s5 -> 589 case Exts.writeWord32OffAddr# addr 5# w5 s5 of { s6 -> 590 case Exts.writeWord32OffAddr# addr 6# w6 s6 of { s7 -> 591 case Exts.writeWord32OffAddr# addr 7# w7 s7 of { s8 -> 592 (# s8, () #) }}}}}}}} 593 {-# INLINE poke_registers #-} 594 595 -- hmac utilities ------------------------------------------------------------- 596 597 -- pad registers to block 598 pad_registers :: Registers -> Block 599 pad_registers (R w0 w1 w2 w3 w4 w5 w6 w7) = B 600 w0 w1 w2 w3 w4 w5 w6 w7 601 (Exts.wordToWord32# 0##) (Exts.wordToWord32# 0##) (Exts.wordToWord32# 0##) 602 (Exts.wordToWord32# 0##) (Exts.wordToWord32# 0##) (Exts.wordToWord32# 0##) 603 (Exts.wordToWord32# 0##) (Exts.wordToWord32# 0##) 604 {-# INLINE pad_registers #-} 605 606 -- pad registers to block, using padding separator and augmented length 607 -- (assumes existence of a leading block) 608 pad_registers_with_length :: Registers -> Block 609 pad_registers_with_length (R h0 h1 h2 h3 h4 h5 h6 h7) = B 610 h0 h1 h2 h3 h4 h5 h6 h7 -- inner hash 611 (Exts.wordToWord32# 0x80000000##) -- padding separator 612 (Exts.wordToWord32# 0x00000000##) 613 (Exts.wordToWord32# 0x00000000##) 614 (Exts.wordToWord32# 0x00000000##) 615 (Exts.wordToWord32# 0x00000000##) 616 (Exts.wordToWord32# 0x00000000##) 617 (Exts.wordToWord32# 0x00000000##) -- high 32 bits of length 618 (Exts.wordToWord32# 0x00000300##) -- low 32 bits of length 619 {-# INLINABLE pad_registers_with_length #-} 620 621 xor :: Block -> Exts.Word32# -> Block 622 xor (B w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 w10 w11 w12 w13 w14 w15) b = B 623 (Exts.xorWord32# w00 b) 624 (Exts.xorWord32# w01 b) 625 (Exts.xorWord32# w02 b) 626 (Exts.xorWord32# w03 b) 627 (Exts.xorWord32# w04 b) 628 (Exts.xorWord32# w05 b) 629 (Exts.xorWord32# w06 b) 630 (Exts.xorWord32# w07 b) 631 (Exts.xorWord32# w08 b) 632 (Exts.xorWord32# w09 b) 633 (Exts.xorWord32# w10 b) 634 (Exts.xorWord32# w11 b) 635 (Exts.xorWord32# w12 b) 636 (Exts.xorWord32# w13 b) 637 (Exts.xorWord32# w14 b) 638 (Exts.xorWord32# w15 b) 639 {-# INLINE xor #-} 640 641 parse_key :: BS.ByteString -> Block 642 parse_key bs = B 643 (w32_zero bs 0) (w32_zero bs 4) (w32_zero bs 8) (w32_zero bs 12) 644 (w32_zero bs 16) (w32_zero bs 20) (w32_zero bs 24) (w32_zero bs 28) 645 (w32_zero bs 32) (w32_zero bs 36) (w32_zero bs 40) (w32_zero bs 44) 646 (w32_zero bs 48) (w32_zero bs 52) (w32_zero bs 56) (w32_zero bs 60) 647 {-# INLINE parse_key #-} 648 649 -- read big-endian Word32#, zero-padding beyond input length 650 w32_zero :: BS.ByteString -> Int -> Exts.Word32# 651 w32_zero bs i = 652 let !wa = w8_zero bs i `Exts.uncheckedShiftLWord32#` 24# 653 !wb = w8_zero bs (i + 1) `Exts.uncheckedShiftLWord32#` 16# 654 !wc = w8_zero bs (i + 2) `Exts.uncheckedShiftLWord32#` 08# 655 !wd = w8_zero bs (i + 3) 656 in wa `Exts.orWord32#` wb `Exts.orWord32#` wc `Exts.orWord32#` wd 657 {-# INLINE w32_zero #-} 658 659 -- read byte as Word32#, returning zero beyond input length 660 w8_zero :: BS.ByteString -> Int -> Exts.Word32# 661 w8_zero bs@(BI.PS _ _ l) i 662 | i < l = let !(GHC.Word.W8# w) = BU.unsafeIndex bs i 663 in Exts.wordToWord32# (Exts.word8ToWord# w) 664 | otherwise = Exts.wordToWord32# 0## 665 {-# INLINE w8_zero #-} 666 667 -- hmac-drbg utilities -------------------------------------------------------- 668 669 -- | Parse first complete block from v || sep || dat[0:31]. 670 -- 671 -- Requires len(dat) >= 31. 672 parse_vsb :: Registers -> Word8 -> BS.ByteString -> Block 673 parse_vsb (R v0 v1 v2 v3 v4 v5 v6 v7) (GHC.Word.W8# sep) dat = 674 let !(GHC.Word.W8# b0) = BU.unsafeIndex dat 0 675 !(GHC.Word.W8# b1) = BU.unsafeIndex dat 1 676 !(GHC.Word.W8# b2) = BU.unsafeIndex dat 2 677 !w08 = 678 Exts.uncheckedShiftLWord32# (w8_w32 sep) 24# 679 `Exts.orWord32#` 680 Exts.uncheckedShiftLWord32# (w8_w32 b0) 16# 681 `Exts.orWord32#` 682 Exts.uncheckedShiftLWord32# (w8_w32 b1) 8# 683 `Exts.orWord32#` 684 w8_w32 b2 685 in B v0 v1 v2 v3 v4 v5 v6 v7 686 w08 687 (word32be dat 3) (word32be dat 7) (word32be dat 11) 688 (word32be dat 15) (word32be dat 19) (word32be dat 23) (word32be dat 27) 689 {-# INLINE parse_vsb #-} 690 691 -- | Parse single padding block from v || sep || dat. 692 -- 693 -- Requires (33 + len(dat)) < 56. 694 parse_pad1_vsb :: Registers -> Word8 -> BS.ByteString -> Word64 -> Block 695 parse_pad1_vsb (R v0 v1 v2 v3 v4 v5 v6 v7) sep dat total = 696 let !bits = total * 8 697 !(GHC.Word.W32# lhi) = fi (bits `B.unsafeShiftR` 32) 698 !(GHC.Word.W32# llo) = fi bits 699 in B v0 v1 v2 v3 v4 v5 v6 v7 700 (w32_sdp sep dat 32) (w32_sdp sep dat 36) 701 (w32_sdp sep dat 40) (w32_sdp sep dat 44) 702 (w32_sdp sep dat 48) (w32_sdp sep dat 52) 703 lhi llo 704 {-# INLINABLE parse_pad1_vsb #-} 705 706 -- | Parse two padding blocks from v || sep || dat. 707 -- 708 -- Requires 56 <= (33 + len(dat)) < 64. 709 parse_pad2_vsb 710 :: Registers -> Word8 -> BS.ByteString -> Word64 -> (# Block, Block #) 711 parse_pad2_vsb (R v0 v1 v2 v3 v4 v5 v6 v7) sep dat total = 712 let !bits = total * 8 713 !z = Exts.wordToWord32# 0## 714 !(GHC.Word.W32# lhi) = fi (bits `B.unsafeShiftR` 32) 715 !(GHC.Word.W32# llo) = fi bits 716 !b0 = B v0 v1 v2 v3 v4 v5 v6 v7 717 (w32_sdp sep dat 32) (w32_sdp sep dat 36) 718 (w32_sdp sep dat 40) (w32_sdp sep dat 44) 719 (w32_sdp sep dat 48) (w32_sdp sep dat 52) 720 (w32_sdp sep dat 56) (w32_sdp sep dat 60) 721 !b1 = B z z z z z z z z z z z z z z lhi llo 722 in (# b0, b1 #) 723 {-# INLINABLE parse_pad2_vsb #-} 724 725 -- Read Word32 at offset i (>= 32) from (sep || dat || 0x80 || zeros). 726 w32_sdp :: Word8 -> BS.ByteString -> Int -> Exts.Word32# 727 w32_sdp sep dat i = 728 let !(GHC.Word.W8# a) = byte_sdp sep dat i 729 !(GHC.Word.W8# b) = byte_sdp sep dat (i + 1) 730 !(GHC.Word.W8# c) = byte_sdp sep dat (i + 2) 731 !(GHC.Word.W8# d) = byte_sdp sep dat (i + 3) 732 in Exts.uncheckedShiftLWord32# (w8_w32 a) 24# 733 `Exts.orWord32#` 734 Exts.uncheckedShiftLWord32# (w8_w32 b) 16# 735 `Exts.orWord32#` 736 Exts.uncheckedShiftLWord32# (w8_w32 c) 8# 737 `Exts.orWord32#` 738 w8_w32 d 739 {-# INLINE w32_sdp #-} 740 741 -- Read byte at offset i (>= 32) from (sep || dat || 0x80 || zeros). 742 byte_sdp :: Word8 -> BS.ByteString -> Int -> Word8 743 byte_sdp sep dat@(BI.PS _ _ l) i 744 | i == 32 = sep 745 | i < 33 + l = BU.unsafeIndex dat (i - 33) 746 | i == 33 + l = 0x80 747 | otherwise = 0x00 748 {-# INLINE byte_sdp #-} 749 750 w8_w32 :: Exts.Word8# -> Exts.Word32# 751 w8_w32 w = Exts.wordToWord32# (Exts.word8ToWord# w) 752 {-# INLINE w8_w32 #-} 753