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