RIPEMD160.hs (20083B)
1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE RecordWildCards #-} 3 {-# LANGUAGE ViewPatterns #-} 4 5 -- | 6 -- Module: Crypto.Hash.RIPEMD160 7 -- Copyright: (c) 2024 Jared Tobin 8 -- License: MIT 9 -- Maintainer: Jared Tobin <jared@ppad.tech> 10 -- 11 -- Pure RIPEMD-160 and HMAC-RIPEMD160 implementations for 12 -- strict and lazy ByteStrings. 13 14 -- for spec, see 15 -- 16 -- https://homes.esat.kuleuven.be/~bosselae/ripemd160/pdf/AB-9601/AB-9601.pdf 17 18 module Crypto.Hash.RIPEMD160 ( 19 -- * RIPEMD-160 message digest functions 20 hash 21 , hash_lazy 22 23 -- * RIPEMD160-based MAC functions 24 , hmac 25 , hmac_lazy 26 ) where 27 28 import qualified Data.Bits as B 29 import Data.Bits ((.|.), (.&.)) 30 import qualified Data.ByteString as BS 31 import qualified Data.ByteString.Builder as BSB 32 import qualified Data.ByteString.Builder.Extra as BE 33 import qualified Data.ByteString.Internal as BI 34 import qualified Data.ByteString.Lazy as BL 35 import qualified Data.ByteString.Lazy.Internal as BLI 36 import qualified Data.ByteString.Unsafe as BU 37 import Data.Word (Word32, Word64) 38 import Foreign.ForeignPtr (plusForeignPtr) 39 40 -- preliminary utils 41 42 -- keystroke saver 43 fi :: (Integral a, Num b) => a -> b 44 fi = fromIntegral 45 {-# INLINE fi #-} 46 47 -- parse strict ByteString in LE order to Word32 (verbatim from 48 -- Data.Binary) 49 -- 50 -- invariant: 51 -- the input bytestring is at least 32 bits in length 52 unsafe_word32le :: BS.ByteString -> Word32 53 unsafe_word32le s = 54 (fi (s `BU.unsafeIndex` 3) `B.unsafeShiftL` 24) .|. 55 (fi (s `BU.unsafeIndex` 2) `B.unsafeShiftL` 16) .|. 56 (fi (s `BU.unsafeIndex` 1) `B.unsafeShiftL` 8) .|. 57 (fi (s `BU.unsafeIndex` 0)) 58 {-# INLINE unsafe_word32le #-} 59 60 -- utility types for more efficient ByteString management 61 62 data SSPair = SSPair 63 {-# UNPACK #-} !BS.ByteString 64 {-# UNPACK #-} !BS.ByteString 65 66 data SLPair = SLPair {-# UNPACK #-} !BS.ByteString !BL.ByteString 67 68 data WSPair = WSPair {-# UNPACK #-} !Word32 {-# UNPACK #-} !BS.ByteString 69 70 -- unsafe version of splitAt that does no bounds checking 71 -- 72 -- invariant: 73 -- 0 <= n <= l 74 unsafe_splitAt :: Int -> BS.ByteString -> SSPair 75 unsafe_splitAt n (BI.BS x l) = 76 SSPair (BI.BS x n) (BI.BS (plusForeignPtr x n) (l - n)) 77 78 -- variant of Data.ByteString.Lazy.splitAt that returns the initial 79 -- component as a strict, unboxed ByteString 80 splitAt64 :: BL.ByteString -> SLPair 81 splitAt64 = splitAt' (64 :: Int) where 82 splitAt' _ BLI.Empty = SLPair mempty BLI.Empty 83 splitAt' n (BLI.Chunk c@(BI.PS _ _ l) cs) = 84 if n < l 85 then 86 -- n < BS.length c, so unsafe_splitAt is safe 87 let !(SSPair c0 c1) = unsafe_splitAt n c 88 in SLPair c0 (BLI.Chunk c1 cs) 89 else 90 let SLPair cs' cs'' = splitAt' (n - l) cs 91 in SLPair (c <> cs') cs'' 92 93 -- variant of Data.ByteString.splitAt that behaves like an incremental 94 -- Word32 parser 95 -- 96 -- invariant: 97 -- the input bytestring is at least 32 bits in length 98 unsafe_parseWsPair :: BS.ByteString -> WSPair 99 unsafe_parseWsPair (BI.BS x l) = 100 WSPair (unsafe_word32le (BI.BS x 4)) (BI.BS (plusForeignPtr x 4) (l - 4)) 101 {-# INLINE unsafe_parseWsPair #-} 102 103 -- builder realization strategies 104 105 to_strict :: BSB.Builder -> BS.ByteString 106 to_strict = BL.toStrict . BSB.toLazyByteString 107 108 to_strict_small :: BSB.Builder -> BS.ByteString 109 to_strict_small = BL.toStrict . BE.toLazyByteStringWith 110 (BE.safeStrategy 128 BE.smallChunkSize) mempty 111 112 -- message padding and parsing 113 114 -- this is the standard padding for merkle-damgård constructions; see e.g. 115 -- 116 -- https://datatracker.ietf.org/doc/html/rfc1320 117 -- https://datatracker.ietf.org/doc/html/rfc6234 118 -- 119 -- for equivalent padding specifications for MD4 and SHA2, but note that 120 -- RIPEMD (and MD4) use little-endian word encodings 121 122 -- k such that (l + 1 + k) mod 64 = 56 123 sol :: Word64 -> Word64 124 sol l = 125 let r = 56 - fi l `rem` 64 - 1 :: Integer -- fi prevents underflow 126 in fi (if r < 0 then r + 64 else r) 127 128 pad :: BS.ByteString -> BS.ByteString 129 pad m@(BI.PS _ _ (fi -> l)) 130 | l < 128 = to_strict_small padded 131 | otherwise = to_strict padded 132 where 133 padded = BSB.byteString m 134 <> fill (sol l) (BSB.word8 0x80) 135 <> BSB.word64LE (l * 8) 136 137 fill j !acc 138 | j `rem` 8 == 0 = 139 loop64 j acc 140 | (j - 7) `rem` 8 == 0 = 141 loop64 (j - 7) acc 142 <> BSB.word32LE 0x00 143 <> BSB.word16LE 0x00 144 <> BSB.word8 0x00 145 | (j - 6) `rem` 8 == 0 = 146 loop64 (j - 6) acc 147 <> BSB.word32LE 0x00 148 <> BSB.word16LE 0x00 149 | (j - 5) `rem` 8 == 0 = 150 loop64 (j - 5) acc 151 <> BSB.word32LE 0x00 152 <> BSB.word8 0x00 153 | (j - 4) `rem` 8 == 0 = 154 loop64 (j - 4) acc 155 <> BSB.word32LE 0x00 156 | (j - 3) `rem` 8 == 0 = 157 loop64 (j - 3) acc 158 <> BSB.word16LE 0x00 159 <> BSB.word8 0x00 160 | (j - 2) `rem` 8 == 0 = 161 loop64 (j - 2) acc 162 <> BSB.word16LE 0x00 163 | (j - 1) `rem` 8 == 0 = 164 loop64 (j - 1) acc 165 <> BSB.word8 0x00 166 167 | j `rem` 4 == 0 = 168 loop32 j acc 169 | (j - 3) `rem` 4 == 0 = 170 loop32 (j - 3) acc 171 <> BSB.word16LE 0x00 172 <> BSB.word8 0x00 173 | (j - 2) `rem` 4 == 0 = 174 loop32 (j - 2) acc 175 <> BSB.word16LE 0x00 176 | (j - 1) `rem` 4 == 0 = 177 loop32 (j - 1) acc 178 <> BSB.word8 0x00 179 180 | j `rem` 2 == 0 = 181 loop16 j acc 182 | (j - 1) `rem` 2 == 0 = 183 loop16 (j - 1) acc 184 <> BSB.word8 0x00 185 186 | otherwise = 187 loop8 j acc 188 189 loop64 j !acc 190 | j == 0 = acc 191 | otherwise = loop64 (j - 8) (acc <> BSB.word64LE 0x00) 192 193 loop32 j !acc 194 | j == 0 = acc 195 | otherwise = loop32 (j - 4) (acc <> BSB.word32LE 0x00) 196 197 loop16 j !acc 198 | j == 0 = acc 199 | otherwise = loop16 (j - 2) (acc <> BSB.word16LE 0x00) 200 201 loop8 j !acc 202 | j == 0 = acc 203 | otherwise = loop8 (pred j) (acc <> BSB.word8 0x00) 204 205 pad_lazy :: BL.ByteString -> BL.ByteString 206 pad_lazy (BL.toChunks -> m) = BL.fromChunks (walk 0 m) where 207 walk !l bs = case bs of 208 (c:cs) -> c : walk (l + fi (BS.length c)) cs 209 [] -> padding l (sol l) (BSB.word8 0x80) 210 211 padding l k bs 212 | k == 0 = 213 pure 214 . to_strict 215 $ bs <> BSB.word64LE (l * 8) 216 | otherwise = 217 let nacc = bs <> BSB.word8 0x00 218 in padding l (pred k) nacc 219 220 -- initialization 221 222 data Registers = Registers { 223 h0 :: !Word32 224 , h1 :: !Word32 225 , h2 :: !Word32 226 , h3 :: !Word32 227 , h4 :: !Word32 228 } deriving Show 229 230 iv :: Registers 231 iv = Registers 0x67452301 0xEFCDAB89 0x98BADCFE 0x10325476 0xC3D2E1F0 232 233 -- processing 234 235 data Block = Block { 236 m00 :: !Word32, m01 :: !Word32, m02 :: !Word32, m03 :: !Word32 237 , m04 :: !Word32, m05 :: !Word32, m06 :: !Word32, m07 :: !Word32 238 , m08 :: !Word32, m09 :: !Word32, m10 :: !Word32, m11 :: !Word32 239 , m12 :: !Word32, m13 :: !Word32, m14 :: !Word32, m15 :: !Word32 240 } deriving Show 241 242 -- parse strict bytestring to block 243 -- 244 -- invariant: 245 -- the input bytestring is exactly 512 bits long 246 unsafe_parse :: BS.ByteString -> Block 247 unsafe_parse bs = 248 let !(WSPair m00 t00) = unsafe_parseWsPair bs 249 !(WSPair m01 t01) = unsafe_parseWsPair t00 250 !(WSPair m02 t02) = unsafe_parseWsPair t01 251 !(WSPair m03 t03) = unsafe_parseWsPair t02 252 !(WSPair m04 t04) = unsafe_parseWsPair t03 253 !(WSPair m05 t05) = unsafe_parseWsPair t04 254 !(WSPair m06 t06) = unsafe_parseWsPair t05 255 !(WSPair m07 t07) = unsafe_parseWsPair t06 256 !(WSPair m08 t08) = unsafe_parseWsPair t07 257 !(WSPair m09 t09) = unsafe_parseWsPair t08 258 !(WSPair m10 t10) = unsafe_parseWsPair t09 259 !(WSPair m11 t11) = unsafe_parseWsPair t10 260 !(WSPair m12 t12) = unsafe_parseWsPair t11 261 !(WSPair m13 t13) = unsafe_parseWsPair t12 262 !(WSPair m14 t14) = unsafe_parseWsPair t13 263 !(WSPair m15 t15) = unsafe_parseWsPair t14 264 in if BS.null t15 265 then Block {..} 266 else error "ppad-ripemd160: internal error (bytes remaining)" 267 268 -- nonlinear functions at bit level 269 f0, f1, f2, f3, f4 :: Word32 -> Word32 -> Word32 -> Word32 270 f0 x y z = x `B.xor` y `B.xor` z 271 {-# INLINE f0 #-} 272 f1 x y z = (x .&. y) .|. (B.complement x .&. z) 273 {-# INLINE f1 #-} 274 f2 x y z = (x .|. B.complement y) `B.xor` z 275 {-# INLINE f2 #-} 276 f3 x y z = (x .&. z) .|. (y .&. B.complement z) 277 {-# INLINE f3 #-} 278 f4 x y z = x `B.xor` (y .|. B.complement z) 279 {-# INLINE f4 #-} 280 281 -- constants 282 k0, k1, k2, k3, k4 :: Word32 283 k0 = 0x00000000 -- 00 <= j <= 15 284 k1 = 0x5A827999 -- 16 <= j <= 31 285 k2 = 0x6ED9EBA1 -- 32 <= j <= 47 286 k3 = 0x8F1BBCDC -- 48 <= j <= 63 287 k4 = 0xA953FD4E -- 64 <= j <= 79 288 289 k0', k1', k2', k3', k4' :: Word32 290 k0' = 0x50A28BE6 -- 00 <= j <= 15 291 k1' = 0x5C4DD124 -- 16 <= j <= 31 292 k2' = 0x6D703EF3 -- 32 <= j <= 47 293 k3' = 0x7A6D76E9 -- 48 <= j <= 63 294 k4' = 0x00000000 -- 64 <= j <= 79 295 296 -- strict registers pair 297 data Pair = Pair !Registers !Registers 298 deriving Show 299 300 round1, round2, round3, round4, round5 :: 301 Word32 -> Word32 -> Registers -> Registers -> Int -> Int -> Pair 302 303 round1 x x' (Registers a b c d e) (Registers a' b' c' d' e') s s' = 304 let t = B.rotateL (a + f0 b c d + x + k0) s + e 305 r0 = Registers e t b (B.rotateL c 10) d 306 t' = B.rotateL (a' + f4 b' c' d' + x' + k0') s' + e' 307 r1 = Registers e' t' b' (B.rotateL c' 10) d' 308 in Pair r0 r1 309 310 round2 x x' (Registers a b c d e) (Registers a' b' c' d' e') s s' = 311 let t = B.rotateL (a + f1 b c d + x + k1) s + e 312 r0 = Registers e t b (B.rotateL c 10) d 313 t' = B.rotateL (a' + f3 b' c' d' + x' + k1') s' + e' 314 r1 = Registers e' t' b' (B.rotateL c' 10) d' 315 in Pair r0 r1 316 317 round3 x x' (Registers a b c d e) (Registers a' b' c' d' e') s s' = 318 let t = B.rotateL (a + f2 b c d + x + k2) s + e 319 r0 = Registers e t b (B.rotateL c 10) d 320 t' = B.rotateL (a' + f2 b' c' d' + x' + k2') s' + e' 321 r1 = Registers e' t' b' (B.rotateL c' 10) d' 322 in Pair r0 r1 323 324 round4 x x' (Registers a b c d e) (Registers a' b' c' d' e') s s' = 325 let t = B.rotateL (a + f3 b c d + x + k3) s + e 326 r0 = Registers e t b (B.rotateL c 10) d 327 t' = B.rotateL (a' + f1 b' c' d' + x' + k3') s' + e' 328 r1 = Registers e' t' b' (B.rotateL c' 10) d' 329 in Pair r0 r1 330 331 round5 x x' (Registers a b c d e) (Registers a' b' c' d' e') s s' = 332 let t = B.rotateL (a + f4 b c d + x + k4) s + e 333 r0 = Registers e t b (B.rotateL c 10) d 334 t' = B.rotateL (a' + f0 b' c' d' + x' + k4') s' + e' 335 r1 = Registers e' t' b' (B.rotateL c' 10) d' 336 in Pair r0 r1 337 338 block_hash :: Registers -> Block -> Registers 339 block_hash reg@Registers {..} Block {..} = 340 -- round 1 341 -- 342 -- r(j) = j (0 ≤ j ≤ 15) 343 -- r'(0..15) = 5, 14, 7, 0, 9, 2, 11, 4, 13, 6, 15, 8, 1, 10, 3, 12 344 -- s(0..15) = 11, 14, 15, 12, 5, 8, 7, 9, 11, 13, 14, 15, 6, 7, 9, 8 345 -- s'(0..15) = 8, 9, 9, 11, 13, 15, 15, 5, 7, 7, 8, 11, 14, 14, 12, 6 346 let !(Pair l00 r00) = round1 m00 m05 reg reg 11 08 347 !(Pair l01 r01) = round1 m01 m14 l00 r00 14 09 348 !(Pair l02 r02) = round1 m02 m07 l01 r01 15 09 349 !(Pair l03 r03) = round1 m03 m00 l02 r02 12 11 350 !(Pair l04 r04) = round1 m04 m09 l03 r03 05 13 351 !(Pair l05 r05) = round1 m05 m02 l04 r04 08 15 352 !(Pair l06 r06) = round1 m06 m11 l05 r05 07 15 353 !(Pair l07 r07) = round1 m07 m04 l06 r06 09 05 354 !(Pair l08 r08) = round1 m08 m13 l07 r07 11 07 355 !(Pair l09 r09) = round1 m09 m06 l08 r08 13 07 356 !(Pair l10 r10) = round1 m10 m15 l09 r09 14 08 357 !(Pair l11 r11) = round1 m11 m08 l10 r10 15 11 358 !(Pair l12 r12) = round1 m12 m01 l11 r11 06 14 359 !(Pair l13 r13) = round1 m13 m10 l12 r12 07 14 360 !(Pair l14 r14) = round1 m14 m03 l13 r13 09 12 361 !(Pair l15 r15) = round1 m15 m12 l14 r14 08 06 362 363 -- round 2 364 -- 365 -- r(16..31) = 7, 4, 13, 1, 10, 6, 15, 3, 12, 0, 9, 5, 2, 14, 11, 8 366 -- r'(16..31) = 6, 11, 3, 7, 0, 13, 5, 10, 14, 15, 8, 12, 4, 9, 1, 2 367 -- s(16..31) = 7, 6, 8, 13, 11, 9, 7, 15, 7, 12, 15, 9, 11, 7, 13, 12 368 -- s'(16..31) = 9, 13, 15, 7, 12, 8, 9, 11, 7, 7, 12, 7, 6, 15, 13, 11 369 !(Pair l16 r16) = round2 m07 m06 l15 r15 07 09 370 !(Pair l17 r17) = round2 m04 m11 l16 r16 06 13 371 !(Pair l18 r18) = round2 m13 m03 l17 r17 08 15 372 !(Pair l19 r19) = round2 m01 m07 l18 r18 13 07 373 !(Pair l20 r20) = round2 m10 m00 l19 r19 11 12 374 !(Pair l21 r21) = round2 m06 m13 l20 r20 09 08 375 !(Pair l22 r22) = round2 m15 m05 l21 r21 07 09 376 !(Pair l23 r23) = round2 m03 m10 l22 r22 15 11 377 !(Pair l24 r24) = round2 m12 m14 l23 r23 07 07 378 !(Pair l25 r25) = round2 m00 m15 l24 r24 12 07 379 !(Pair l26 r26) = round2 m09 m08 l25 r25 15 12 380 !(Pair l27 r27) = round2 m05 m12 l26 r26 09 07 381 !(Pair l28 r28) = round2 m02 m04 l27 r27 11 06 382 !(Pair l29 r29) = round2 m14 m09 l28 r28 07 15 383 !(Pair l30 r30) = round2 m11 m01 l29 r29 13 13 384 !(Pair l31 r31) = round2 m08 m02 l30 r30 12 11 385 386 -- round 3 387 -- 388 -- r(32..47) = 3, 10, 14, 4, 9, 15, 8, 1, 2, 7, 0, 6, 13, 11, 5, 12 389 -- r'(32..47) = 15, 5, 1, 3, 7, 14, 6, 9, 11, 8, 12, 2, 10, 0, 4, 13 390 -- s(32..47) = 11, 13, 6, 7, 14, 9, 13, 15, 14, 8, 13, 6, 5, 12, 7, 5 391 -- s'(32..47) = 9, 7, 15, 11, 8, 6, 6, 14, 12, 13, 5, 14, 13, 13, 7, 5 392 !(Pair l32 r32) = round3 m03 m15 l31 r31 11 09 393 !(Pair l33 r33) = round3 m10 m05 l32 r32 13 07 394 !(Pair l34 r34) = round3 m14 m01 l33 r33 06 15 395 !(Pair l35 r35) = round3 m04 m03 l34 r34 07 11 396 !(Pair l36 r36) = round3 m09 m07 l35 r35 14 08 397 !(Pair l37 r37) = round3 m15 m14 l36 r36 09 06 398 !(Pair l38 r38) = round3 m08 m06 l37 r37 13 06 399 !(Pair l39 r39) = round3 m01 m09 l38 r38 15 14 400 !(Pair l40 r40) = round3 m02 m11 l39 r39 14 12 401 !(Pair l41 r41) = round3 m07 m08 l40 r40 08 13 402 !(Pair l42 r42) = round3 m00 m12 l41 r41 13 05 403 !(Pair l43 r43) = round3 m06 m02 l42 r42 06 14 404 !(Pair l44 r44) = round3 m13 m10 l43 r43 05 13 405 !(Pair l45 r45) = round3 m11 m00 l44 r44 12 13 406 !(Pair l46 r46) = round3 m05 m04 l45 r45 07 07 407 !(Pair l47 r47) = round3 m12 m13 l46 r46 05 05 408 409 -- round 4 410 -- 411 -- r(48..63) = 1, 9, 11, 10, 0, 8, 12, 4, 13, 3, 7, 15, 14, 5, 6, 2 412 -- r'(48..63) = 8, 6, 4, 1, 3, 11, 15, 0, 5, 12, 2, 13, 9, 7, 10, 14 413 -- s(48..63) = 11, 12, 14, 15, 14, 15, 9, 8, 9, 14, 5, 6, 8, 6, 5, 12 414 -- s'(48..63) = 15, 5, 8, 11, 14, 14, 6, 14, 6, 9, 12, 9, 12, 5, 15, 8 415 !(Pair l48 r48) = round4 m01 m08 l47 r47 11 15 416 !(Pair l49 r49) = round4 m09 m06 l48 r48 12 05 417 !(Pair l50 r50) = round4 m11 m04 l49 r49 14 08 418 !(Pair l51 r51) = round4 m10 m01 l50 r50 15 11 419 !(Pair l52 r52) = round4 m00 m03 l51 r51 14 14 420 !(Pair l53 r53) = round4 m08 m11 l52 r52 15 14 421 !(Pair l54 r54) = round4 m12 m15 l53 r53 09 06 422 !(Pair l55 r55) = round4 m04 m00 l54 r54 08 14 423 !(Pair l56 r56) = round4 m13 m05 l55 r55 09 06 424 !(Pair l57 r57) = round4 m03 m12 l56 r56 14 09 425 !(Pair l58 r58) = round4 m07 m02 l57 r57 05 12 426 !(Pair l59 r59) = round4 m15 m13 l58 r58 06 09 427 !(Pair l60 r60) = round4 m14 m09 l59 r59 08 12 428 !(Pair l61 r61) = round4 m05 m07 l60 r60 06 05 429 !(Pair l62 r62) = round4 m06 m10 l61 r61 05 15 430 !(Pair l63 r63) = round4 m02 m14 l62 r62 12 08 431 432 -- round 5 433 -- 434 -- r(64..79) = 4, 0, 5, 9, 7, 12, 2, 10, 14, 1, 3, 8, 11, 6, 15, 13 435 -- r'(64..79) = 12, 15, 10, 4, 1, 5, 8, 7, 6, 2, 13, 14, 0, 3, 9, 11 436 -- s(64..79) = 9, 15, 5, 11, 6, 8, 13, 12, 5, 12, 13, 14, 11, 8, 5, 6 437 -- s'(64..79) = 8, 5, 12, 9, 12, 5, 14, 6, 8, 13, 6, 5, 15, 13, 11, 11 438 !(Pair l64 r64) = round5 m04 m12 l63 r63 09 08 439 !(Pair l65 r65) = round5 m00 m15 l64 r64 15 05 440 !(Pair l66 r66) = round5 m05 m10 l65 r65 05 12 441 !(Pair l67 r67) = round5 m09 m04 l66 r66 11 09 442 !(Pair l68 r68) = round5 m07 m01 l67 r67 06 12 443 !(Pair l69 r69) = round5 m12 m05 l68 r68 08 05 444 !(Pair l70 r70) = round5 m02 m08 l69 r69 13 14 445 !(Pair l71 r71) = round5 m10 m07 l70 r70 12 06 446 !(Pair l72 r72) = round5 m14 m06 l71 r71 05 08 447 !(Pair l73 r73) = round5 m01 m02 l72 r72 12 13 448 !(Pair l74 r74) = round5 m03 m13 l73 r73 13 06 449 !(Pair l75 r75) = round5 m08 m14 l74 r74 14 05 450 !(Pair l76 r76) = round5 m11 m00 l75 r75 11 15 451 !(Pair l77 r77) = round5 m06 m03 l76 r76 08 13 452 !(Pair l78 r78) = round5 m15 m09 l77 r77 05 11 453 !(Pair l79 r79) = round5 m13 m11 l78 r78 06 11 454 455 !(Registers a b c d e) = l79 456 !(Registers a' b' c' d' e') = r79 457 458 in Registers 459 (h1 + c + d') (h2 + d + e') (h3 + e + a') (h4 + a + b') (h0 + b + c') 460 461 -- block pipeline 462 -- 463 -- invariant: 464 -- the input bytestring is exactly 512 bits in length 465 unsafe_hash_alg :: Registers -> BS.ByteString -> Registers 466 unsafe_hash_alg rs bs = block_hash rs (unsafe_parse bs) 467 468 -- register concatenation 469 cat :: Registers -> BS.ByteString 470 cat Registers {..} = 471 let w64_0 = fi h1 `B.shiftL` 32 .|. fi h0 472 w64_1 = fi h3 `B.shiftL` 32 .|. fi h2 473 in to_strict_small $ 474 BSB.word64LE w64_0 475 <> BSB.word64LE w64_1 476 <> BSB.word32LE h4 477 478 -- | Compute a condensed representation of a strict bytestring via 479 -- RIPEMD-160. 480 -- 481 -- The 160-bit output digest is returned as a strict bytestring. 482 -- 483 -- >>> hash "strict bytestring input" 484 -- "<strict 160-bit message digest>" 485 hash :: BS.ByteString -> BS.ByteString 486 hash bs = cat (go iv (pad bs)) where 487 go :: Registers -> BS.ByteString -> Registers 488 go !acc b 489 | BS.null b = acc 490 | otherwise = case unsafe_splitAt 64 b of 491 SSPair c r -> go (unsafe_hash_alg acc c) r 492 493 -- | Compute a condensed representation of a lazy bytestring via 494 -- RIPEMD-160. 495 -- 496 -- The 160-bit output digest is returned as a strict bytestring. 497 -- 498 -- >>> hash_lazy "lazy bytestring input" 499 -- "<strict 160-bit message digest>" 500 hash_lazy :: BL.ByteString -> BS.ByteString 501 hash_lazy bl = cat (go iv (pad_lazy bl)) where 502 go :: Registers -> BL.ByteString -> Registers 503 go !acc bs 504 | BL.null bs = acc 505 | otherwise = case splitAt64 bs of 506 SLPair c r -> go (unsafe_hash_alg acc c) r 507 508 -- HMAC ----------------------------------------------------------------------- 509 -- https://datatracker.ietf.org/doc/html/rfc2104#section-2 510 511 data KeyAndLen = KeyAndLen 512 {-# UNPACK #-} !BS.ByteString 513 {-# UNPACK #-} !Int 514 515 -- | Produce a message authentication code for a strict bytestring, 516 -- based on the provided (strict, bytestring) key, via RIPEMD-160. 517 -- 518 -- The 160-bit MAC is returned as a strict bytestring. 519 -- 520 -- Per RFC 2104, the key /should/ be a minimum of 20 bytes long. Keys 521 -- exceeding 64 bytes in length will first be hashed (via RIPEMD-160). 522 -- 523 -- >>> hmac "strict bytestring key" "strict bytestring input" 524 -- "<strict 160-bit MAC>" 525 hmac 526 :: BS.ByteString -- ^ key 527 -> BS.ByteString -- ^ text 528 -> BS.ByteString 529 hmac mk@(BI.PS _ _ l) text = 530 let step1 = k <> BS.replicate (64 - lk) 0x00 531 step2 = BS.map (B.xor 0x36) step1 532 step3 = step2 <> text 533 step4 = hash step3 534 step5 = BS.map (B.xor 0x5C) step1 535 step6 = step5 <> step4 536 in hash step6 537 where 538 !(KeyAndLen k lk) 539 | l > 64 = KeyAndLen (hash mk) 20 540 | otherwise = KeyAndLen mk l 541 542 -- | Produce a message authentication code for a lazy bytestring, based 543 -- on the provided (strict, bytestring) key, via RIPEMD-160. 544 -- 545 -- The 160-bit MAC is returned as a strict bytestring. 546 -- 547 -- Per RFC 2104, the key /should/ be a minimum of 20 bytes long. Keys 548 -- exceeding 64 bytes in length will first be hashed (via RIPEMD-160). 549 -- 550 -- >>> hmac_lazy "strict bytestring key" "lazy bytestring input" 551 -- "<strict 160-bit MAC>" 552 hmac_lazy 553 :: BS.ByteString -- ^ key 554 -> BL.ByteString -- ^ text 555 -> BS.ByteString 556 hmac_lazy mk@(BI.PS _ _ l) text = 557 let step1 = k <> BS.replicate (64 - lk) 0x00 558 step2 = BS.map (B.xor 0x36) step1 559 step3 = BL.fromStrict step2 <> text 560 step4 = hash_lazy step3 561 step5 = BS.map (B.xor 0x5C) step1 562 step6 = step5 <> step4 563 in hash step6 564 where 565 !(KeyAndLen k lk) 566 | l > 64 = KeyAndLen (hash mk) 20 567 | otherwise = KeyAndLen mk l 568