Internal.hs (17810B)
1 {-# OPTIONS_HADDOCK hide #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE DerivingStrategies #-} 4 {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 {-# LANGUAGE RecordWildCards #-} 6 7 -- | 8 -- Module: Crypto.Hash.SHA512.Internal 9 -- Copyright: (c) 2024 Jared Tobin 10 -- License: MIT 11 -- Maintainer: Jared Tobin <jared@ppad.tech> 12 -- 13 -- SHA-512 internals. 14 15 module Crypto.Hash.SHA512.Internal ( 16 Registers(..) 17 , Block(..) 18 , Schedule(..) 19 20 , MAC(..) 21 22 , iv 23 , block_hash 24 , prepare_schedule 25 , parse_block 26 , cat 27 , unsafe_hash_alg 28 , unsafe_parse 29 , unsafe_padding 30 31 , WSPair(..) 32 , unsafe_word64be 33 , unsafe_parseWsPair 34 ) where 35 36 import qualified Data.Bits as B 37 import Data.Bits ((.|.), (.&.)) 38 import qualified Data.ByteString as BS 39 import qualified Data.ByteString.Builder as BSB 40 import qualified Data.ByteString.Builder.Extra as BE 41 import qualified Data.ByteString.Internal as BI 42 import qualified Data.ByteString.Unsafe as BU 43 import Data.Word (Word8, Word64) 44 import Foreign.ForeignPtr (plusForeignPtr) 45 import Foreign.Marshal.Utils (copyBytes, fillBytes) 46 import Foreign.Ptr (Ptr, plusPtr) 47 import Foreign.Storable (poke) 48 49 -- MAC type ------------------------------------------------------------------ 50 51 -- | A message authentication code. 52 -- 53 -- Note that you should compare MACs for equality using the 'Eq' 54 -- instance, which performs the comparison in constant time, instead 55 -- of unwrapping and comparing the underlying 'ByteStrings'. 56 -- 57 -- >>> let foo@(MAC bs0) = hmac key "hi" 58 -- >>> let bar@(MAC bs1) = hmac key "there" 59 -- >>> foo == bar -- do this 60 -- False 61 -- >>> bs0 == bs1 -- don't do this 62 -- False 63 newtype MAC = MAC BS.ByteString 64 deriving newtype Show 65 66 instance Eq MAC where 67 -- | A constant-time equality check for message authentication codes. 68 -- 69 -- Runs in variable-time only for invalid inputs. 70 (MAC a@(BI.PS _ _ la)) == (MAC b@(BI.PS _ _ lb)) 71 | la /= lb = False 72 | otherwise = BS.foldl' (B..|.) 0 (BS.packZipWith B.xor a b) == 0 73 74 -- preliminary utils --------------------------------------------------------- 75 76 fi :: (Integral a, Num b) => a -> b 77 fi = fromIntegral 78 {-# INLINE fi #-} 79 80 -- parse strict ByteString in BE order to Word64 81 -- 82 -- invariant: 83 -- the input bytestring is at least 64 bits in length 84 unsafe_word64be :: BS.ByteString -> Word64 85 unsafe_word64be s = 86 (fi (s `BU.unsafeIndex` 0) `B.unsafeShiftL` 56) .|. 87 (fi (s `BU.unsafeIndex` 1) `B.unsafeShiftL` 48) .|. 88 (fi (s `BU.unsafeIndex` 2) `B.unsafeShiftL` 40) .|. 89 (fi (s `BU.unsafeIndex` 3) `B.unsafeShiftL` 32) .|. 90 (fi (s `BU.unsafeIndex` 4) `B.unsafeShiftL` 24) .|. 91 (fi (s `BU.unsafeIndex` 5) `B.unsafeShiftL` 16) .|. 92 (fi (s `BU.unsafeIndex` 6) `B.unsafeShiftL` 8) .|. 93 (fi (s `BU.unsafeIndex` 7) ) 94 {-# INLINE unsafe_word64be #-} 95 96 data WSPair = WSPair {-# UNPACK #-} !Word64 {-# UNPACK #-} !BS.ByteString 97 98 -- variant of Data.ByteString.splitAt that behaves like an incremental 99 -- Word64 parser 100 -- 101 -- invariant: 102 -- the input bytestring is at least 64 bits in length 103 unsafe_parseWsPair :: BS.ByteString -> WSPair 104 unsafe_parseWsPair (BI.BS x l) = 105 WSPair (unsafe_word64be (BI.BS x 8)) (BI.BS (plusForeignPtr x 8) (l - 8)) 106 {-# INLINE unsafe_parseWsPair #-} 107 108 -- builder realization strategy 109 110 to_strict_small :: BSB.Builder -> BS.ByteString 111 to_strict_small = BS.toStrict . BE.toLazyByteStringWith 112 (BE.safeStrategy 128 BE.smallChunkSize) mempty 113 114 -- functions and constants --------------------------------------------------- 115 -- https://datatracker.ietf.org/doc/html/rfc6234#section-5.1 116 117 ch :: Word64 -> Word64 -> Word64 -> Word64 118 ch x y z = (x .&. y) `B.xor` (B.complement x .&. z) 119 {-# INLINE ch #-} 120 121 maj :: Word64 -> Word64 -> Word64 -> Word64 122 maj x y z = (x .&. (y .|. z)) .|. (y .&. z) 123 {-# INLINE maj #-} 124 125 bsig0 :: Word64 -> Word64 126 bsig0 x = B.rotateR x 28 `B.xor` B.rotateR x 34 `B.xor` B.rotateR x 39 127 {-# INLINE bsig0 #-} 128 129 bsig1 :: Word64 -> Word64 130 bsig1 x = B.rotateR x 14 `B.xor` B.rotateR x 18 `B.xor` B.rotateR x 41 131 {-# INLINE bsig1 #-} 132 133 ssig0 :: Word64 -> Word64 134 ssig0 x = B.rotateR x 1 `B.xor` B.rotateR x 8 `B.xor` B.unsafeShiftR x 7 135 {-# INLINE ssig0 #-} 136 137 ssig1 :: Word64 -> Word64 138 ssig1 x = B.rotateR x 19 `B.xor` B.rotateR x 61 `B.xor` B.unsafeShiftR x 6 139 {-# INLINE ssig1 #-} 140 141 data Schedule = Schedule { 142 w00 :: !Word64, w01 :: !Word64, w02 :: !Word64, w03 :: !Word64 143 , w04 :: !Word64, w05 :: !Word64, w06 :: !Word64, w07 :: !Word64 144 , w08 :: !Word64, w09 :: !Word64, w10 :: !Word64, w11 :: !Word64 145 , w12 :: !Word64, w13 :: !Word64, w14 :: !Word64, w15 :: !Word64 146 , w16 :: !Word64, w17 :: !Word64, w18 :: !Word64, w19 :: !Word64 147 , w20 :: !Word64, w21 :: !Word64, w22 :: !Word64, w23 :: !Word64 148 , w24 :: !Word64, w25 :: !Word64, w26 :: !Word64, w27 :: !Word64 149 , w28 :: !Word64, w29 :: !Word64, w30 :: !Word64, w31 :: !Word64 150 , w32 :: !Word64, w33 :: !Word64, w34 :: !Word64, w35 :: !Word64 151 , w36 :: !Word64, w37 :: !Word64, w38 :: !Word64, w39 :: !Word64 152 , w40 :: !Word64, w41 :: !Word64, w42 :: !Word64, w43 :: !Word64 153 , w44 :: !Word64, w45 :: !Word64, w46 :: !Word64, w47 :: !Word64 154 , w48 :: !Word64, w49 :: !Word64, w50 :: !Word64, w51 :: !Word64 155 , w52 :: !Word64, w53 :: !Word64, w54 :: !Word64, w55 :: !Word64 156 , w56 :: !Word64, w57 :: !Word64, w58 :: !Word64, w59 :: !Word64 157 , w60 :: !Word64, w61 :: !Word64, w62 :: !Word64, w63 :: !Word64 158 , w64 :: !Word64, w65 :: !Word64, w66 :: !Word64, w67 :: !Word64 159 , w68 :: !Word64, w69 :: !Word64, w70 :: !Word64, w71 :: !Word64 160 , w72 :: !Word64, w73 :: !Word64, w74 :: !Word64, w75 :: !Word64 161 , w76 :: !Word64, w77 :: !Word64, w78 :: !Word64, w79 :: !Word64 162 } 163 164 -- initialization ------------------------------------------------------------ 165 -- https://datatracker.ietf.org/doc/html/rfc6234#section-6.1 166 167 data Registers = Registers { 168 h0 :: !Word64, h1 :: !Word64, h2 :: !Word64, h3 :: !Word64 169 , h4 :: !Word64, h5 :: !Word64, h6 :: !Word64, h7 :: !Word64 170 } 171 172 -- first 64 bits of the fractional parts of the square roots of the 173 -- first eight primes 174 iv :: Registers 175 iv = Registers 176 0x6a09e667f3bcc908 0xbb67ae8584caa73b 0x3c6ef372fe94f82b 0xa54ff53a5f1d36f1 177 0x510e527fade682d1 0x9b05688c2b3e6c1f 0x1f83d9abfb41bd6b 0x5be0cd19137e2179 178 179 -- processing ---------------------------------------------------------------- 180 -- https://datatracker.ietf.org/doc/html/rfc6234#section-6.2 181 182 data Block = Block { 183 m00 :: !Word64, m01 :: !Word64, m02 :: !Word64, m03 :: !Word64 184 , m04 :: !Word64, m05 :: !Word64, m06 :: !Word64, m07 :: !Word64 185 , m08 :: !Word64, m09 :: !Word64, m10 :: !Word64, m11 :: !Word64 186 , m12 :: !Word64, m13 :: !Word64, m14 :: !Word64, m15 :: !Word64 187 } 188 189 -- given a bytestring and offset, parse word64. length not checked. 190 word64be :: BS.ByteString -> Int -> Word64 191 word64be bs off = 192 (fi (bs `BU.unsafeIndex` off) `B.unsafeShiftL` 56) .|. 193 (fi (bs `BU.unsafeIndex` (off + 1)) `B.unsafeShiftL` 48) .|. 194 (fi (bs `BU.unsafeIndex` (off + 2)) `B.unsafeShiftL` 40) .|. 195 (fi (bs `BU.unsafeIndex` (off + 3)) `B.unsafeShiftL` 32) .|. 196 (fi (bs `BU.unsafeIndex` (off + 4)) `B.unsafeShiftL` 24) .|. 197 (fi (bs `BU.unsafeIndex` (off + 5)) `B.unsafeShiftL` 16) .|. 198 (fi (bs `BU.unsafeIndex` (off + 6)) `B.unsafeShiftL` 8) .|. 199 (fi (bs `BU.unsafeIndex` (off + 7))) 200 {-# INLINE word64be #-} 201 202 -- given a bytestring and block offset, parse block. length not checked. 203 parse_block :: BS.ByteString -> Int -> Block 204 parse_block bs m = Block 205 (word64be bs m) 206 (word64be bs (m + 8)) 207 (word64be bs (m + 16)) 208 (word64be bs (m + 24)) 209 (word64be bs (m + 32)) 210 (word64be bs (m + 40)) 211 (word64be bs (m + 48)) 212 (word64be bs (m + 56)) 213 (word64be bs (m + 64)) 214 (word64be bs (m + 72)) 215 (word64be bs (m + 80)) 216 (word64be bs (m + 88)) 217 (word64be bs (m + 96)) 218 (word64be bs (m + 104)) 219 (word64be bs (m + 112)) 220 (word64be bs (m + 120)) 221 {-# INLINE parse_block #-} 222 223 -- parse strict bytestring to block 224 -- 225 -- invariant: 226 -- the input bytestring is exactly 1024 bits long 227 unsafe_parse :: BS.ByteString -> Block 228 unsafe_parse bs = 229 let !(WSPair m00 t00) = unsafe_parseWsPair bs 230 !(WSPair m01 t01) = unsafe_parseWsPair t00 231 !(WSPair m02 t02) = unsafe_parseWsPair t01 232 !(WSPair m03 t03) = unsafe_parseWsPair t02 233 !(WSPair m04 t04) = unsafe_parseWsPair t03 234 !(WSPair m05 t05) = unsafe_parseWsPair t04 235 !(WSPair m06 t06) = unsafe_parseWsPair t05 236 !(WSPair m07 t07) = unsafe_parseWsPair t06 237 !(WSPair m08 t08) = unsafe_parseWsPair t07 238 !(WSPair m09 t09) = unsafe_parseWsPair t08 239 !(WSPair m10 t10) = unsafe_parseWsPair t09 240 !(WSPair m11 t11) = unsafe_parseWsPair t10 241 !(WSPair m12 t12) = unsafe_parseWsPair t11 242 !(WSPair m13 t13) = unsafe_parseWsPair t12 243 !(WSPair m14 t14) = unsafe_parseWsPair t13 244 !(WSPair m15 _) = unsafe_parseWsPair t14 245 in Block {..} 246 247 -- RFC 6234 6.2 step 1 248 prepare_schedule :: Block -> Schedule 249 prepare_schedule Block {..} = Schedule {..} where 250 w00 = m00; w01 = m01; w02 = m02; w03 = m03 251 w04 = m04; w05 = m05; w06 = m06; w07 = m07 252 w08 = m08; w09 = m09; w10 = m10; w11 = m11 253 w12 = m12; w13 = m13; w14 = m14; w15 = m15 254 w16 = ssig1 w14 + w09 + ssig0 w01 + w00 255 w17 = ssig1 w15 + w10 + ssig0 w02 + w01 256 w18 = ssig1 w16 + w11 + ssig0 w03 + w02 257 w19 = ssig1 w17 + w12 + ssig0 w04 + w03 258 w20 = ssig1 w18 + w13 + ssig0 w05 + w04 259 w21 = ssig1 w19 + w14 + ssig0 w06 + w05 260 w22 = ssig1 w20 + w15 + ssig0 w07 + w06 261 w23 = ssig1 w21 + w16 + ssig0 w08 + w07 262 w24 = ssig1 w22 + w17 + ssig0 w09 + w08 263 w25 = ssig1 w23 + w18 + ssig0 w10 + w09 264 w26 = ssig1 w24 + w19 + ssig0 w11 + w10 265 w27 = ssig1 w25 + w20 + ssig0 w12 + w11 266 w28 = ssig1 w26 + w21 + ssig0 w13 + w12 267 w29 = ssig1 w27 + w22 + ssig0 w14 + w13 268 w30 = ssig1 w28 + w23 + ssig0 w15 + w14 269 w31 = ssig1 w29 + w24 + ssig0 w16 + w15 270 w32 = ssig1 w30 + w25 + ssig0 w17 + w16 271 w33 = ssig1 w31 + w26 + ssig0 w18 + w17 272 w34 = ssig1 w32 + w27 + ssig0 w19 + w18 273 w35 = ssig1 w33 + w28 + ssig0 w20 + w19 274 w36 = ssig1 w34 + w29 + ssig0 w21 + w20 275 w37 = ssig1 w35 + w30 + ssig0 w22 + w21 276 w38 = ssig1 w36 + w31 + ssig0 w23 + w22 277 w39 = ssig1 w37 + w32 + ssig0 w24 + w23 278 w40 = ssig1 w38 + w33 + ssig0 w25 + w24 279 w41 = ssig1 w39 + w34 + ssig0 w26 + w25 280 w42 = ssig1 w40 + w35 + ssig0 w27 + w26 281 w43 = ssig1 w41 + w36 + ssig0 w28 + w27 282 w44 = ssig1 w42 + w37 + ssig0 w29 + w28 283 w45 = ssig1 w43 + w38 + ssig0 w30 + w29 284 w46 = ssig1 w44 + w39 + ssig0 w31 + w30 285 w47 = ssig1 w45 + w40 + ssig0 w32 + w31 286 w48 = ssig1 w46 + w41 + ssig0 w33 + w32 287 w49 = ssig1 w47 + w42 + ssig0 w34 + w33 288 w50 = ssig1 w48 + w43 + ssig0 w35 + w34 289 w51 = ssig1 w49 + w44 + ssig0 w36 + w35 290 w52 = ssig1 w50 + w45 + ssig0 w37 + w36 291 w53 = ssig1 w51 + w46 + ssig0 w38 + w37 292 w54 = ssig1 w52 + w47 + ssig0 w39 + w38 293 w55 = ssig1 w53 + w48 + ssig0 w40 + w39 294 w56 = ssig1 w54 + w49 + ssig0 w41 + w40 295 w57 = ssig1 w55 + w50 + ssig0 w42 + w41 296 w58 = ssig1 w56 + w51 + ssig0 w43 + w42 297 w59 = ssig1 w57 + w52 + ssig0 w44 + w43 298 w60 = ssig1 w58 + w53 + ssig0 w45 + w44 299 w61 = ssig1 w59 + w54 + ssig0 w46 + w45 300 w62 = ssig1 w60 + w55 + ssig0 w47 + w46 301 w63 = ssig1 w61 + w56 + ssig0 w48 + w47 302 w64 = ssig1 w62 + w57 + ssig0 w49 + w48 303 w65 = ssig1 w63 + w58 + ssig0 w50 + w49 304 w66 = ssig1 w64 + w59 + ssig0 w51 + w50 305 w67 = ssig1 w65 + w60 + ssig0 w52 + w51 306 w68 = ssig1 w66 + w61 + ssig0 w53 + w52 307 w69 = ssig1 w67 + w62 + ssig0 w54 + w53 308 w70 = ssig1 w68 + w63 + ssig0 w55 + w54 309 w71 = ssig1 w69 + w64 + ssig0 w56 + w55 310 w72 = ssig1 w70 + w65 + ssig0 w57 + w56 311 w73 = ssig1 w71 + w66 + ssig0 w58 + w57 312 w74 = ssig1 w72 + w67 + ssig0 w59 + w58 313 w75 = ssig1 w73 + w68 + ssig0 w60 + w59 314 w76 = ssig1 w74 + w69 + ssig0 w61 + w60 315 w77 = ssig1 w75 + w70 + ssig0 w62 + w61 316 w78 = ssig1 w76 + w71 + ssig0 w63 + w62 317 w79 = ssig1 w77 + w72 + ssig0 w64 + w63 318 319 -- RFC 6234 6.2 steps 2, 3, 4 320 block_hash :: Registers -> Schedule -> Registers 321 block_hash r00@Registers {..} Schedule {..} = 322 -- constants are the first 64 bits of the fractional parts of the 323 -- cube roots of the first eighty prime numbers 324 let r01 = step r00 0x428a2f98d728ae22 w00 325 r02 = step r01 0x7137449123ef65cd w01 326 r03 = step r02 0xb5c0fbcfec4d3b2f w02 327 r04 = step r03 0xe9b5dba58189dbbc w03 328 r05 = step r04 0x3956c25bf348b538 w04 329 r06 = step r05 0x59f111f1b605d019 w05 330 r07 = step r06 0x923f82a4af194f9b w06 331 r08 = step r07 0xab1c5ed5da6d8118 w07 332 r09 = step r08 0xd807aa98a3030242 w08 333 r10 = step r09 0x12835b0145706fbe w09 334 r11 = step r10 0x243185be4ee4b28c w10 335 r12 = step r11 0x550c7dc3d5ffb4e2 w11 336 r13 = step r12 0x72be5d74f27b896f w12 337 r14 = step r13 0x80deb1fe3b1696b1 w13 338 r15 = step r14 0x9bdc06a725c71235 w14 339 r16 = step r15 0xc19bf174cf692694 w15 340 r17 = step r16 0xe49b69c19ef14ad2 w16 341 r18 = step r17 0xefbe4786384f25e3 w17 342 r19 = step r18 0x0fc19dc68b8cd5b5 w18 343 r20 = step r19 0x240ca1cc77ac9c65 w19 344 r21 = step r20 0x2de92c6f592b0275 w20 345 r22 = step r21 0x4a7484aa6ea6e483 w21 346 r23 = step r22 0x5cb0a9dcbd41fbd4 w22 347 r24 = step r23 0x76f988da831153b5 w23 348 r25 = step r24 0x983e5152ee66dfab w24 349 r26 = step r25 0xa831c66d2db43210 w25 350 r27 = step r26 0xb00327c898fb213f w26 351 r28 = step r27 0xbf597fc7beef0ee4 w27 352 r29 = step r28 0xc6e00bf33da88fc2 w28 353 r30 = step r29 0xd5a79147930aa725 w29 354 r31 = step r30 0x06ca6351e003826f w30 355 r32 = step r31 0x142929670a0e6e70 w31 356 r33 = step r32 0x27b70a8546d22ffc w32 357 r34 = step r33 0x2e1b21385c26c926 w33 358 r35 = step r34 0x4d2c6dfc5ac42aed w34 359 r36 = step r35 0x53380d139d95b3df w35 360 r37 = step r36 0x650a73548baf63de w36 361 r38 = step r37 0x766a0abb3c77b2a8 w37 362 r39 = step r38 0x81c2c92e47edaee6 w38 363 r40 = step r39 0x92722c851482353b w39 364 r41 = step r40 0xa2bfe8a14cf10364 w40 365 r42 = step r41 0xa81a664bbc423001 w41 366 r43 = step r42 0xc24b8b70d0f89791 w42 367 r44 = step r43 0xc76c51a30654be30 w43 368 r45 = step r44 0xd192e819d6ef5218 w44 369 r46 = step r45 0xd69906245565a910 w45 370 r47 = step r46 0xf40e35855771202a w46 371 r48 = step r47 0x106aa07032bbd1b8 w47 372 r49 = step r48 0x19a4c116b8d2d0c8 w48 373 r50 = step r49 0x1e376c085141ab53 w49 374 r51 = step r50 0x2748774cdf8eeb99 w50 375 r52 = step r51 0x34b0bcb5e19b48a8 w51 376 r53 = step r52 0x391c0cb3c5c95a63 w52 377 r54 = step r53 0x4ed8aa4ae3418acb w53 378 r55 = step r54 0x5b9cca4f7763e373 w54 379 r56 = step r55 0x682e6ff3d6b2b8a3 w55 380 r57 = step r56 0x748f82ee5defb2fc w56 381 r58 = step r57 0x78a5636f43172f60 w57 382 r59 = step r58 0x84c87814a1f0ab72 w58 383 r60 = step r59 0x8cc702081a6439ec w59 384 r61 = step r60 0x90befffa23631e28 w60 385 r62 = step r61 0xa4506cebde82bde9 w61 386 r63 = step r62 0xbef9a3f7b2c67915 w62 387 r64 = step r63 0xc67178f2e372532b w63 388 r65 = step r64 0xca273eceea26619c w64 389 r66 = step r65 0xd186b8c721c0c207 w65 390 r67 = step r66 0xeada7dd6cde0eb1e w66 391 r68 = step r67 0xf57d4f7fee6ed178 w67 392 r69 = step r68 0x06f067aa72176fba w68 393 r70 = step r69 0x0a637dc5a2c898a6 w69 394 r71 = step r70 0x113f9804bef90dae w70 395 r72 = step r71 0x1b710b35131c471b w71 396 r73 = step r72 0x28db77f523047d84 w72 397 r74 = step r73 0x32caab7b40c72493 w73 398 r75 = step r74 0x3c9ebe0a15c9bebc w74 399 r76 = step r75 0x431d67c49c100d4c w75 400 r77 = step r76 0x4cc5d4becb3e42b6 w76 401 r78 = step r77 0x597f299cfc657e2a w77 402 r79 = step r78 0x5fcb6fab3ad6faec w78 403 r80 = step r79 0x6c44198c4a475817 w79 404 !(Registers a b c d e f g h) = r80 405 in Registers 406 (a + h0) (b + h1) (c + h2) (d + h3) 407 (e + h4) (f + h5) (g + h6) (h + h7) 408 409 step :: Registers -> Word64 -> Word64 -> Registers 410 step (Registers a b c d e f g h) k w = 411 let t1 = h + bsig1 e + ch e f g + k + w 412 t2 = bsig0 a + maj a b c 413 in Registers (t1 + t2) a b c (d + t1) e f g 414 {-# INLINE step #-} 415 416 -- RFC 6234 6.2 block pipeline 417 -- 418 -- invariant: 419 -- the input bytestring is exactly 1024 bits in length 420 unsafe_hash_alg :: Registers -> BS.ByteString -> Registers 421 unsafe_hash_alg rs bs = block_hash rs (prepare_schedule (unsafe_parse bs)) 422 423 -- register concatenation 424 cat :: Registers -> BS.ByteString 425 cat Registers {..} = to_strict_small $ 426 BSB.word64BE h0 <> BSB.word64BE h1 <> BSB.word64BE h2 <> BSB.word64BE h3 427 <> BSB.word64BE h4 <> BSB.word64BE h5 <> BSB.word64BE h6 <> BSB.word64BE h7 428 429 -- RFC 6234 4.1 message padding 430 unsafe_padding :: BS.ByteString -> Word64 -> BS.ByteString 431 unsafe_padding (BI.PS fp off r) len 432 | r < 112 = BI.unsafeCreate 128 $ \p -> do 433 BI.unsafeWithForeignPtr fp $ \src -> 434 copyBytes p (src `plusPtr` off) r 435 poke (p `plusPtr` r) (0x80 :: Word8) 436 fillBytes (p `plusPtr` (r + 1)) 0 (111 - r) 437 poke_word64be (p `plusPtr` 112) 0 438 poke_word64be (p `plusPtr` 120) (len * 8) 439 | otherwise = BI.unsafeCreate 256 $ \p -> do 440 BI.unsafeWithForeignPtr fp $ \src -> 441 copyBytes p (src `plusPtr` off) r 442 poke (p `plusPtr` r) (0x80 :: Word8) 443 fillBytes (p `plusPtr` (r + 1)) 0 (127 - r) 444 fillBytes (p `plusPtr` 128) 0 112 445 poke_word64be (p `plusPtr` 240) 0 446 poke_word64be (p `plusPtr` 248) (len * 8) 447 where 448 poke_word64be :: Ptr Word8 -> Word64 -> IO () 449 poke_word64be p w = do 450 poke p (fi (w `B.unsafeShiftR` 56) :: Word8) 451 poke (p `plusPtr` 1) (fi (w `B.unsafeShiftR` 48) :: Word8) 452 poke (p `plusPtr` 2) (fi (w `B.unsafeShiftR` 40) :: Word8) 453 poke (p `plusPtr` 3) (fi (w `B.unsafeShiftR` 32) :: Word8) 454 poke (p `plusPtr` 4) (fi (w `B.unsafeShiftR` 24) :: Word8) 455 poke (p `plusPtr` 5) (fi (w `B.unsafeShiftR` 16) :: Word8) 456 poke (p `plusPtr` 6) (fi (w `B.unsafeShiftR` 8) :: Word8) 457 poke (p `plusPtr` 7) (fi w :: Word8)