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