diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2024 Jared Tobin + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Criterion.Main +import qualified Crypto.Hash.RIPEMD160 as RIPEMD160 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL + +main :: IO () +main = defaultMain [ + suite + ] + +suite :: Benchmark +suite = env setup $ \ ~(bs, bl) -> + bgroup "ppad-ripemd160" [ + bgroup "RIPEMD160 (32B input)" [ + bench "hash" $ whnf RIPEMD160.hash bs + , bench "hash_lazy" $ whnf RIPEMD160.hash_lazy bl + ] + , bgroup "HMAC-RIPEMD160 (32B input)" [ + bench "hmac" $ whnf (RIPEMD160.hmac "key") bs + , bench "hmac_lazy" $ whnf (RIPEMD160.hmac_lazy "key") bl + ] + ] + where + setup = do + let bs_32B = BS.replicate 32 0 + bl_32B = BL.fromStrict bs_32B + pure (bs_32B, bl_32B) + diff --git a/lib/Crypto/Hash/RIPEMD160.hs b/lib/Crypto/Hash/RIPEMD160.hs new file mode 100644 --- /dev/null +++ b/lib/Crypto/Hash/RIPEMD160.hs @@ -0,0 +1,502 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module: Crypto.Hash.RIPEMD160 +-- Copyright: (c) 2024 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Pure RIPEMD-160 and HMAC-RIPEMD160 implementations for +-- strict and lazy ByteStrings. + +-- for spec, see +-- +-- https://homes.esat.kuleuven.be/~bosselae/ripemd160/pdf/AB-9601/AB-9601.pdf + +module Crypto.Hash.RIPEMD160 ( + -- * RIPEMD-160 message digest functions + hash + , hash_lazy + + -- * RIPEMD160-based MAC functions + , hmac + , hmac_lazy + ) where + +import qualified Data.Bits as B +import Data.Bits ((.|.), (.&.)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Builder.Extra as BE +import qualified Data.ByteString.Internal as BI +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Internal as BLI +import qualified Data.ByteString.Unsafe as BU +import Data.Word (Word32, Word64) +import Foreign.ForeignPtr (plusForeignPtr) + +-- preliminary utils + +-- keystroke saver +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral +{-# INLINE fi #-} + +-- parse strict ByteString in LE order to Word32 (verbatim from +-- Data.Binary) +-- +-- invariant: +-- the input bytestring is at least 32 bits in length +unsafe_word32le :: BS.ByteString -> Word32 +unsafe_word32le s = + (fi (s `BU.unsafeIndex` 3) `B.unsafeShiftL` 24) .|. + (fi (s `BU.unsafeIndex` 2) `B.unsafeShiftL` 16) .|. + (fi (s `BU.unsafeIndex` 1) `B.unsafeShiftL` 8) .|. + (fi (s `BU.unsafeIndex` 0)) +{-# INLINE unsafe_word32le #-} + +-- utility types for more efficient ByteString management + +data SSPair = SSPair + {-# UNPACK #-} !BS.ByteString + {-# UNPACK #-} !BS.ByteString + +data SLPair = SLPair {-# UNPACK #-} !BS.ByteString !BL.ByteString + +data WSPair = WSPair {-# UNPACK #-} !Word32 {-# UNPACK #-} !BS.ByteString + +-- unsafe version of splitAt that does no bounds checking +-- +-- invariant: +-- 0 <= n <= l +unsafe_splitAt :: Int -> BS.ByteString -> SSPair +unsafe_splitAt n (BI.BS x l) = + SSPair (BI.BS x n) (BI.BS (plusForeignPtr x n) (l - n)) + +-- variant of Data.ByteString.Lazy.splitAt that returns the initial +-- component as a strict, unboxed ByteString +splitAt64 :: BL.ByteString -> SLPair +splitAt64 = splitAt' (64 :: Int) where + splitAt' _ BLI.Empty = SLPair mempty BLI.Empty + splitAt' n (BLI.Chunk c cs) = + if n < BS.length c + then + -- n < BS.length c, so unsafe_splitAt is safe + let !(SSPair c0 c1) = unsafe_splitAt n c + in SLPair c0 (BLI.Chunk c1 cs) + else + let SLPair cs' cs'' = splitAt' (n - BS.length c) cs + in SLPair (c <> cs') cs'' + +-- variant of Data.ByteString.splitAt that behaves like an incremental +-- Word32 parser +-- +-- invariant: +-- the input bytestring is at least 32 bits in length +unsafe_parseWsPair :: BS.ByteString -> WSPair +unsafe_parseWsPair (BI.BS x l) = + WSPair (unsafe_word32le (BI.BS x 4)) (BI.BS (plusForeignPtr x 4) (l - 4)) +{-# INLINE unsafe_parseWsPair #-} + +-- message padding and parsing + +-- this is the standard padding for merkle-damgård constructions; see e.g. +-- +-- https://datatracker.ietf.org/doc/html/rfc1320 +-- https://datatracker.ietf.org/doc/html/rfc6234 +-- +-- for equivalent padding specifications for MD4 and SHA2, but note that +-- RIPEMD (and MD4) use little-endian word encodings + +-- k such that (l + 1 + k) mod 64 = 56 +sol :: Word64 -> Word64 +sol l = + let r = 56 - fi l `mod` 64 - 1 :: Integer -- fi prevents underflow + in fi (if r < 0 then r + 64 else r) + +pad :: BS.ByteString -> BS.ByteString +pad m = BL.toStrict . BSB.toLazyByteString $ padded where + l = fi (BS.length m) + padded = BSB.byteString m <> fill (sol l) (BSB.word8 0x80) + + fill j !acc + | j == 0 = acc <> BSB.word64LE (l * 8) + | otherwise = fill (pred j) (acc <> BSB.word8 0x00) + +pad_lazy :: BL.ByteString -> BL.ByteString +pad_lazy (BL.toChunks -> m) = BL.fromChunks (walk 0 m) where + walk !l bs = case bs of + (c:cs) -> c : walk (l + fi (BS.length c)) cs + [] -> padding l (sol l) (BSB.word8 0x80) + + padding l k bs + | k == 0 = + pure + . BL.toStrict + -- more efficient for small builder + . BE.toLazyByteStringWith + (BE.safeStrategy 128 BE.smallChunkSize) mempty + $ bs <> BSB.word64LE (l * 8) + | otherwise = + let nacc = bs <> BSB.word8 0x00 + in padding l (pred k) nacc + +-- initialization + +data Registers = Registers { + h0 :: !Word32 + , h1 :: !Word32 + , h2 :: !Word32 + , h3 :: !Word32 + , h4 :: !Word32 + } deriving Show + +iv :: Registers +iv = Registers 0x67452301 0xEFCDAB89 0x98BADCFE 0x10325476 0xC3D2E1F0 + +-- processing + +data Block = Block { + m00 :: !Word32, m01 :: !Word32, m02 :: !Word32, m03 :: !Word32 + , m04 :: !Word32, m05 :: !Word32, m06 :: !Word32, m07 :: !Word32 + , m08 :: !Word32, m09 :: !Word32, m10 :: !Word32, m11 :: !Word32 + , m12 :: !Word32, m13 :: !Word32, m14 :: !Word32, m15 :: !Word32 + } deriving Show + +-- parse strict bytestring to block +-- +-- invariant: +-- the input bytestring is exactly 512 bits long +unsafe_parse :: BS.ByteString -> Block +unsafe_parse bs = + let !(WSPair m00 t00) = unsafe_parseWsPair bs + !(WSPair m01 t01) = unsafe_parseWsPair t00 + !(WSPair m02 t02) = unsafe_parseWsPair t01 + !(WSPair m03 t03) = unsafe_parseWsPair t02 + !(WSPair m04 t04) = unsafe_parseWsPair t03 + !(WSPair m05 t05) = unsafe_parseWsPair t04 + !(WSPair m06 t06) = unsafe_parseWsPair t05 + !(WSPair m07 t07) = unsafe_parseWsPair t06 + !(WSPair m08 t08) = unsafe_parseWsPair t07 + !(WSPair m09 t09) = unsafe_parseWsPair t08 + !(WSPair m10 t10) = unsafe_parseWsPair t09 + !(WSPair m11 t11) = unsafe_parseWsPair t10 + !(WSPair m12 t12) = unsafe_parseWsPair t11 + !(WSPair m13 t13) = unsafe_parseWsPair t12 + !(WSPair m14 t14) = unsafe_parseWsPair t13 + !(WSPair m15 t15) = unsafe_parseWsPair t14 + in if BS.null t15 + then Block {..} + else error "ppad-ripemd160: internal error (bytes remaining)" + +-- nonlinear functions at bit level +f0, f1, f2, f3, f4 :: Word32 -> Word32 -> Word32 -> Word32 +f0 x y z = x `B.xor` y `B.xor` z +{-# INLINE f0 #-} +f1 x y z = (x .&. y) .|. ((B.complement x) .&. z) +{-# INLINE f1 #-} +f2 x y z = (x .|. B.complement y) `B.xor` z +{-# INLINE f2 #-} +f3 x y z = (x .&. z) .|. (y .&. B.complement z) +{-# INLINE f3 #-} +f4 x y z = x `B.xor` (y .|. B.complement z) +{-# INLINE f4 #-} + +-- constants +k0, k1, k2, k3, k4 :: Word32 +k0 = 0x00000000 -- 00 <= j <= 15 +k1 = 0x5A827999 -- 16 <= j <= 31 +k2 = 0x6ED9EBA1 -- 32 <= j <= 47 +k3 = 0x8F1BBCDC -- 48 <= j <= 63 +k4 = 0xA953FD4E -- 64 <= j <= 79 + +k0', k1', k2', k3', k4' :: Word32 +k0' = 0x50A28BE6 -- 00 <= j <= 15 +k1' = 0x5C4DD124 -- 16 <= j <= 31 +k2' = 0x6D703EF3 -- 32 <= j <= 47 +k3' = 0x7A6D76E9 -- 48 <= j <= 63 +k4' = 0x00000000 -- 64 <= j <= 79 + +-- strict registers pair +data Pair = Pair !Registers !Registers + deriving Show + +round1, round2, round3, round4, round5 :: + Word32 -> Word32 -> Registers -> Registers -> Int -> Int -> Pair + +round1 x x' (Registers a b c d e) (Registers a' b' c' d' e') s s' = + let t = (B.rotateL (a + f0 b c d + x + k0) s) + e + r0 = Registers e t b (B.rotateL c 10) d + t' = (B.rotateL (a' + f4 b' c' d' + x' + k0') s') + e' + r1 = Registers e' t' b' (B.rotateL c' 10) d' + in Pair r0 r1 + +round2 x x' (Registers a b c d e) (Registers a' b' c' d' e') s s' = + let t = (B.rotateL (a + f1 b c d + x + k1) s) + e + r0 = Registers e t b (B.rotateL c 10) d + t' = (B.rotateL (a' + f3 b' c' d' + x' + k1') s') + e' + r1 = Registers e' t' b' (B.rotateL c' 10) d' + in Pair r0 r1 + +round3 x x' (Registers a b c d e) (Registers a' b' c' d' e') s s' = + let t = (B.rotateL (a + f2 b c d + x + k2) s) + e + r0 = Registers e t b (B.rotateL c 10) d + t' = (B.rotateL (a' + f2 b' c' d' + x' + k2') s') + e' + r1 = Registers e' t' b' (B.rotateL c' 10) d' + in Pair r0 r1 + +round4 x x' (Registers a b c d e) (Registers a' b' c' d' e') s s' = + let t = (B.rotateL (a + f3 b c d + x + k3) s) + e + r0 = Registers e t b (B.rotateL c 10) d + t' = (B.rotateL (a' + f1 b' c' d' + x' + k3') s') + e' + r1 = Registers e' t' b' (B.rotateL c' 10) d' + in Pair r0 r1 + +round5 x x' (Registers a b c d e) (Registers a' b' c' d' e') s s' = + let t = (B.rotateL (a + f4 b c d + x + k4) s) + e + r0 = Registers e t b (B.rotateL c 10) d + t' = (B.rotateL (a' + f0 b' c' d' + x' + k4') s') + e' + r1 = Registers e' t' b' (B.rotateL c' 10) d' + in Pair r0 r1 + +block_hash :: Registers -> Block -> Registers +block_hash reg@Registers {..} Block {..} = + -- round 1 + -- + -- r(j) = j (0 ≤ j ≤ 15) + -- r'(0..15) = 5, 14, 7, 0, 9, 2, 11, 4, 13, 6, 15, 8, 1, 10, 3, 12 + -- s(0..15) = 11, 14, 15, 12, 5, 8, 7, 9, 11, 13, 14, 15, 6, 7, 9, 8 + -- s'(0..15) = 8, 9, 9, 11, 13, 15, 15, 5, 7, 7, 8, 11, 14, 14, 12, 6 + let !(Pair l00 r00) = round1 m00 m05 reg reg 11 08 + !(Pair l01 r01) = round1 m01 m14 l00 r00 14 09 + !(Pair l02 r02) = round1 m02 m07 l01 r01 15 09 + !(Pair l03 r03) = round1 m03 m00 l02 r02 12 11 + !(Pair l04 r04) = round1 m04 m09 l03 r03 05 13 + !(Pair l05 r05) = round1 m05 m02 l04 r04 08 15 + !(Pair l06 r06) = round1 m06 m11 l05 r05 07 15 + !(Pair l07 r07) = round1 m07 m04 l06 r06 09 05 + !(Pair l08 r08) = round1 m08 m13 l07 r07 11 07 + !(Pair l09 r09) = round1 m09 m06 l08 r08 13 07 + !(Pair l10 r10) = round1 m10 m15 l09 r09 14 08 + !(Pair l11 r11) = round1 m11 m08 l10 r10 15 11 + !(Pair l12 r12) = round1 m12 m01 l11 r11 06 14 + !(Pair l13 r13) = round1 m13 m10 l12 r12 07 14 + !(Pair l14 r14) = round1 m14 m03 l13 r13 09 12 + !(Pair l15 r15) = round1 m15 m12 l14 r14 08 06 + + -- round 2 + -- + -- r(16..31) = 7, 4, 13, 1, 10, 6, 15, 3, 12, 0, 9, 5, 2, 14, 11, 8 + -- r'(16..31) = 6, 11, 3, 7, 0, 13, 5, 10, 14, 15, 8, 12, 4, 9, 1, 2 + -- s(16..31) = 7, 6, 8, 13, 11, 9, 7, 15, 7, 12, 15, 9, 11, 7, 13, 12 + -- s'(16..31) = 9, 13, 15, 7, 12, 8, 9, 11, 7, 7, 12, 7, 6, 15, 13, 11 + !(Pair l16 r16) = round2 m07 m06 l15 r15 07 09 + !(Pair l17 r17) = round2 m04 m11 l16 r16 06 13 + !(Pair l18 r18) = round2 m13 m03 l17 r17 08 15 + !(Pair l19 r19) = round2 m01 m07 l18 r18 13 07 + !(Pair l20 r20) = round2 m10 m00 l19 r19 11 12 + !(Pair l21 r21) = round2 m06 m13 l20 r20 09 08 + !(Pair l22 r22) = round2 m15 m05 l21 r21 07 09 + !(Pair l23 r23) = round2 m03 m10 l22 r22 15 11 + !(Pair l24 r24) = round2 m12 m14 l23 r23 07 07 + !(Pair l25 r25) = round2 m00 m15 l24 r24 12 07 + !(Pair l26 r26) = round2 m09 m08 l25 r25 15 12 + !(Pair l27 r27) = round2 m05 m12 l26 r26 09 07 + !(Pair l28 r28) = round2 m02 m04 l27 r27 11 06 + !(Pair l29 r29) = round2 m14 m09 l28 r28 07 15 + !(Pair l30 r30) = round2 m11 m01 l29 r29 13 13 + !(Pair l31 r31) = round2 m08 m02 l30 r30 12 11 + + -- round 3 + -- + -- r(32..47) = 3, 10, 14, 4, 9, 15, 8, 1, 2, 7, 0, 6, 13, 11, 5, 12 + -- r'(32..47) = 15, 5, 1, 3, 7, 14, 6, 9, 11, 8, 12, 2, 10, 0, 4, 13 + -- s(32..47) = 11, 13, 6, 7, 14, 9, 13, 15, 14, 8, 13, 6, 5, 12, 7, 5 + -- s'(32..47) = 9, 7, 15, 11, 8, 6, 6, 14, 12, 13, 5, 14, 13, 13, 7, 5 + !(Pair l32 r32) = round3 m03 m15 l31 r31 11 09 + !(Pair l33 r33) = round3 m10 m05 l32 r32 13 07 + !(Pair l34 r34) = round3 m14 m01 l33 r33 06 15 + !(Pair l35 r35) = round3 m04 m03 l34 r34 07 11 + !(Pair l36 r36) = round3 m09 m07 l35 r35 14 08 + !(Pair l37 r37) = round3 m15 m14 l36 r36 09 06 + !(Pair l38 r38) = round3 m08 m06 l37 r37 13 06 + !(Pair l39 r39) = round3 m01 m09 l38 r38 15 14 + !(Pair l40 r40) = round3 m02 m11 l39 r39 14 12 + !(Pair l41 r41) = round3 m07 m08 l40 r40 08 13 + !(Pair l42 r42) = round3 m00 m12 l41 r41 13 05 + !(Pair l43 r43) = round3 m06 m02 l42 r42 06 14 + !(Pair l44 r44) = round3 m13 m10 l43 r43 05 13 + !(Pair l45 r45) = round3 m11 m00 l44 r44 12 13 + !(Pair l46 r46) = round3 m05 m04 l45 r45 07 07 + !(Pair l47 r47) = round3 m12 m13 l46 r46 05 05 + + -- round 4 + -- + -- r(48..63) = 1, 9, 11, 10, 0, 8, 12, 4, 13, 3, 7, 15, 14, 5, 6, 2 + -- r'(48..63) = 8, 6, 4, 1, 3, 11, 15, 0, 5, 12, 2, 13, 9, 7, 10, 14 + -- s(48..63) = 11, 12, 14, 15, 14, 15, 9, 8, 9, 14, 5, 6, 8, 6, 5, 12 + -- s'(48..63) = 15, 5, 8, 11, 14, 14, 6, 14, 6, 9, 12, 9, 12, 5, 15, 8 + !(Pair l48 r48) = round4 m01 m08 l47 r47 11 15 + !(Pair l49 r49) = round4 m09 m06 l48 r48 12 05 + !(Pair l50 r50) = round4 m11 m04 l49 r49 14 08 + !(Pair l51 r51) = round4 m10 m01 l50 r50 15 11 + !(Pair l52 r52) = round4 m00 m03 l51 r51 14 14 + !(Pair l53 r53) = round4 m08 m11 l52 r52 15 14 + !(Pair l54 r54) = round4 m12 m15 l53 r53 09 06 + !(Pair l55 r55) = round4 m04 m00 l54 r54 08 14 + !(Pair l56 r56) = round4 m13 m05 l55 r55 09 06 + !(Pair l57 r57) = round4 m03 m12 l56 r56 14 09 + !(Pair l58 r58) = round4 m07 m02 l57 r57 05 12 + !(Pair l59 r59) = round4 m15 m13 l58 r58 06 09 + !(Pair l60 r60) = round4 m14 m09 l59 r59 08 12 + !(Pair l61 r61) = round4 m05 m07 l60 r60 06 05 + !(Pair l62 r62) = round4 m06 m10 l61 r61 05 15 + !(Pair l63 r63) = round4 m02 m14 l62 r62 12 08 + + -- round 5 + -- + -- r(64..79) = 4, 0, 5, 9, 7, 12, 2, 10, 14, 1, 3, 8, 11, 6, 15, 13 + -- r'(64..79) = 12, 15, 10, 4, 1, 5, 8, 7, 6, 2, 13, 14, 0, 3, 9, 11 + -- s(64..79) = 9, 15, 5, 11, 6, 8, 13, 12, 5, 12, 13, 14, 11, 8, 5, 6 + -- s'(64..79) = 8, 5, 12, 9, 12, 5, 14, 6, 8, 13, 6, 5, 15, 13, 11, 11 + !(Pair l64 r64) = round5 m04 m12 l63 r63 09 08 + !(Pair l65 r65) = round5 m00 m15 l64 r64 15 05 + !(Pair l66 r66) = round5 m05 m10 l65 r65 05 12 + !(Pair l67 r67) = round5 m09 m04 l66 r66 11 09 + !(Pair l68 r68) = round5 m07 m01 l67 r67 06 12 + !(Pair l69 r69) = round5 m12 m05 l68 r68 08 05 + !(Pair l70 r70) = round5 m02 m08 l69 r69 13 14 + !(Pair l71 r71) = round5 m10 m07 l70 r70 12 06 + !(Pair l72 r72) = round5 m14 m06 l71 r71 05 08 + !(Pair l73 r73) = round5 m01 m02 l72 r72 12 13 + !(Pair l74 r74) = round5 m03 m13 l73 r73 13 06 + !(Pair l75 r75) = round5 m08 m14 l74 r74 14 05 + !(Pair l76 r76) = round5 m11 m00 l75 r75 11 15 + !(Pair l77 r77) = round5 m06 m03 l76 r76 08 13 + !(Pair l78 r78) = round5 m15 m09 l77 r77 05 11 + !(Pair l79 r79) = round5 m13 m11 l78 r78 06 11 + + !(Registers a b c d e) = l79 + !(Registers a' b' c' d' e') = r79 + + in Registers + (h1 + c + d') (h2 + d + e') (h3 + e + a') (h4 + a + b') (h0 + b + c') + +-- block pipeline +-- +-- invariant: +-- the input bytestring is exactly 512 bits in length +unsafe_hash_alg :: Registers -> BS.ByteString -> Registers +unsafe_hash_alg rs bs = block_hash rs (unsafe_parse bs) + +-- register concatenation +cat :: Registers -> BS.ByteString +cat Registers {..} = + BL.toStrict + -- more efficient for small builder + . BE.toLazyByteStringWith (BE.safeStrategy 128 BE.smallChunkSize) mempty + $ mconcat [ + BSB.word32LE h0 + , BSB.word32LE h1 + , BSB.word32LE h2 + , BSB.word32LE h3 + , BSB.word32LE h4 + ] + +-- | Compute a condensed representation of a strict bytestring via +-- RIPEMD-160. +-- +-- The 160-bit output digest is returned as a strict bytestring. +-- +-- >>> hash "strict bytestring input" +-- "" +hash :: BS.ByteString -> BS.ByteString +hash bs = cat (go iv (pad bs)) where + go :: Registers -> BS.ByteString -> Registers + go !acc b + | BS.null b = acc + | otherwise = case unsafe_splitAt 64 b of + SSPair c r -> go (unsafe_hash_alg acc c) r + +-- | Compute a condensed representation of a lazy bytestring via +-- RIPEMD-160. +-- +-- The 160-bit output digest is returned as a strict bytestring. +-- +-- >>> hash_lazy "lazy bytestring input" +-- "" +hash_lazy :: BL.ByteString -> BS.ByteString +hash_lazy bl = cat (go iv (pad_lazy bl)) where + go :: Registers -> BL.ByteString -> Registers + go !acc bs + | BL.null bs = acc + | otherwise = case splitAt64 bs of + SLPair c r -> go (unsafe_hash_alg acc c) r + +-- HMAC ----------------------------------------------------------------------- +-- https://datatracker.ietf.org/doc/html/rfc2104#section-2 + +data KeyAndLen = KeyAndLen + {-# UNPACK #-} !BS.ByteString + {-# UNPACK #-} !Int + +-- | Produce a message authentication code for a strict bytestring, +-- based on the provided (strict, bytestring) key, via RIPEMD-160. +-- +-- The 160-bit MAC is returned as a strict bytestring. +-- +-- Per RFC 2104, the key /should/ be a minimum of 20 bytes long. Keys +-- exceeding 64 bytes in length will first be hashed (via RIPEMD-160). +-- +-- >>> hmac "strict bytestring key" "strict bytestring input" +-- "" +hmac + :: BS.ByteString -- ^ key + -> BS.ByteString -- ^ text + -> BS.ByteString +hmac mk text = + let step1 = k <> BS.replicate (64 - lk) 0x00 + step2 = BS.map (B.xor 0x36) step1 + step3 = step2 <> text + step4 = hash step3 + step5 = BS.map (B.xor 0x5C) step1 + step6 = step5 <> step4 + in hash step6 + where + !(KeyAndLen k lk) = + let l = BS.length mk + in if l > 64 + then KeyAndLen (hash mk) 20 + else KeyAndLen mk l + +-- | Produce a message authentication code for a lazy bytestring, based +-- on the provided (strict, bytestring) key, via RIPEMD-160. +-- +-- The 160-bit MAC is returned as a strict bytestring. +-- +-- Per RFC 2104, the key /should/ be a minimum of 20 bytes long. Keys +-- exceeding 64 bytes in length will first be hashed (via RIPEMD-160). +-- +-- >>> hmac_lazy "strict bytestring key" "lazy bytestring input" +-- "" +hmac_lazy + :: BS.ByteString -- ^ key + -> BL.ByteString -- ^ text + -> BS.ByteString +hmac_lazy mk text = + let step1 = k <> BS.replicate (64 - lk) 0x00 + step2 = BS.map (B.xor 0x36) step1 + step3 = BL.fromStrict step2 <> text + step4 = hash_lazy step3 + step5 = BS.map (B.xor 0x5C) step1 + step6 = step5 <> step4 + in hash step6 + where + !(KeyAndLen k lk) = + let l = BS.length mk + in if l > 64 + then KeyAndLen (hash mk) 20 + else KeyAndLen mk l + diff --git a/ppad-ripemd160.cabal b/ppad-ripemd160.cabal new file mode 100644 --- /dev/null +++ b/ppad-ripemd160.cabal @@ -0,0 +1,66 @@ +cabal-version: 3.0 +name: ppad-ripemd160 +version: 0.1.0 +synopsis: The RIPEMD-160 hashing algorithm. +license: MIT +license-file: LICENSE +author: Jared Tobin +maintainer: jared@ppad.tech +category: Cryptography +build-type: Simple +tested-with: GHC == 9.8.1 +extra-doc-files: CHANGELOG +description: + A pure implementation of RIPEMD-160 and HMAC-RIPEMD160 on strict and + lazy ByteStrings. + +source-repository head + type: git + location: git.ppad.tech/ripemd160.git + +library + default-language: Haskell2010 + hs-source-dirs: lib + ghc-options: + -Wall + exposed-modules: + Crypto.Hash.RIPEMD160 + build-depends: + base >= 4.9 && < 5 + , bytestring >= 0.9 && < 0.13 + +test-suite ripemd160-tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + + ghc-options: + -rtsopts -Wall -O2 + + build-depends: + aeson + , base + , base16-bytestring + , bytestring + , ppad-ripemd160 + , tasty + , tasty-hunit + , text + +benchmark ripemd160-bench + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: bench + main-is: Main.hs + + ghc-options: + -rtsopts -O2 -Wall + + build-depends: + base + , bytestring + , criterion + , ppad-ripemd160 + , SHA + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Main where + +import qualified Crypto.Hash.RIPEMD160 as RIPEMD160 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Base16 as B16 +import Test.Tasty +import Test.Tasty.HUnit + +main :: IO () +main = defaultMain $ testGroup "ppad-ripemd160" [ + unit_tests + ] + +unit_tests :: TestTree +unit_tests = testGroup "unit tests" [ + testGroup "hash" [ + cmp_hash "hv0" hv0_put hv0_pec + , cmp_hash "hv1" hv1_put hv1_pec + , cmp_hash "hv2" hv2_put hv2_pec + , cmp_hash "hv3" hv3_put hv3_pec + , cmp_hash "hv4" hv4_put hv4_pec + , cmp_hash "hv5" hv5_put hv5_pec + , cmp_hash "hv6" hv6_put hv6_pec + , cmp_hash "hv7" hv7_put hv7_pec + , cmp_hash "hv8" hv8_put hv8_pec + ] + , testGroup "hash_lazy" [ + cmp_hash_lazy "hv0" hv0_put hv0_pec + , cmp_hash_lazy "hv1" hv1_put hv1_pec + , cmp_hash_lazy "hv2" hv2_put hv2_pec + , cmp_hash_lazy "hv3" hv3_put hv3_pec + , cmp_hash_lazy "hv4" hv4_put hv4_pec + , cmp_hash_lazy "hv5" hv5_put hv5_pec + , cmp_hash_lazy "hv6" hv6_put hv6_pec + , cmp_hash_lazy "hv7" hv7_put hv7_pec + , cmp_hash_lazy "hv8" hv8_put hv8_pec + ] + , testGroup "hmac" [ + cmp_hmac "hmv1" hmv1_key hmv1_put hmv1_pec + , cmp_hmac "hmv2" hmv2_key hmv2_put hmv2_pec + , cmp_hmac "hmv3" hmv3_key hmv3_put hmv3_pec + , cmp_hmac "hmv4" hmv4_key hmv4_put hmv4_pec + , cmp_hmac "hmv5" hmv5_key hmv5_put hmv5_pec + , cmp_hmac "hmv6" hmv6_key hmv6_put hmv6_pec + , cmp_hmac "hmv7" hmv7_key hmv7_put hmv7_pec + ] + , testGroup "hmac_lazy" [ + cmp_hmac_lazy "hmv1" hmv1_key hmv1_put hmv1_pec + , cmp_hmac_lazy "hmv2" hmv2_key hmv2_put hmv2_pec + , cmp_hmac_lazy "hmv3" hmv3_key hmv3_put hmv3_pec + , cmp_hmac_lazy "hmv4" hmv4_key hmv4_put hmv4_pec + , cmp_hmac_lazy "hmv5" hmv5_key hmv5_put hmv5_pec + , cmp_hmac_lazy "hmv6" hmv6_key hmv6_put hmv6_pec + , cmp_hmac_lazy "hmv7" hmv7_key hmv7_put hmv7_pec + ] + ] + +cmp_hash :: String -> BS.ByteString -> BS.ByteString -> TestTree +cmp_hash msg put pec = testCase msg $ do + let out = B16.encode (RIPEMD160.hash put) + assertEqual mempty pec out + +cmp_hash_lazy :: String -> BS.ByteString -> BS.ByteString -> TestTree +cmp_hash_lazy msg (BL.fromStrict -> put) pec = testCase msg $ do + let out = B16.encode (RIPEMD160.hash_lazy put) + assertEqual mempty pec out + +hv0_put, hv0_pec :: BS.ByteString +hv0_put = mempty +hv0_pec = "9c1185a5c5e9fc54612808977ee8f548b2258d31" + +hv1_put, hv1_pec :: BS.ByteString +hv1_put = "a" +hv1_pec = "0bdc9d2d256b3ee9daae347be6f4dc835a467ffe" + +hv2_put, hv2_pec :: BS.ByteString +hv2_put = "abc" +hv2_pec = "8eb208f7e05d987a9b044a8e98c6b087f15a0bfc" + +hv3_put, hv3_pec :: BS.ByteString +hv3_put = "message digest" +hv3_pec = "5d0689ef49d2fae572b881b123a85ffa21595f36" + +hv4_put, hv4_pec :: BS.ByteString +hv4_put = "abcdefghijklmnopqrstuvwxyz" +hv4_pec = "f71c27109c692c1b56bbdceb5b9d2865b3708dbc" + +hv5_put, hv5_pec :: BS.ByteString +hv5_put = "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" +hv5_pec = "12a053384a9c0c88e405a06c27dcf49ada62eb2b" + +hv6_put, hv6_pec :: BS.ByteString +hv6_put = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" +hv6_pec = "b0e20b6e3116640286ed3a87a5713079b21f5189" + +hv7_put, hv7_pec :: BS.ByteString +hv7_put = "12345678901234567890123456789012345678901234567890123456789012345678901234567890" +hv7_pec = "9b752e45573d4b39f4dbd3323cab82bf63326bfb" + +hv8_put, hv8_pec :: BS.ByteString +hv8_put = BS.replicate 1000000 0x61 +hv8_pec = "52783243c1697bdbe16d37f97f68f08325dc1528" + +-- vectors from +-- +-- https://www.rfc-editor.org/rfc/rfc2286.html#section-2 + +cmp_hmac + :: String -> BS.ByteString -> BS.ByteString -> BS.ByteString -> TestTree +cmp_hmac msg key put pec = testCase msg $ do + let out = B16.encode (RIPEMD160.hmac key put) + assertEqual mempty pec out + +cmp_hmac_lazy + :: String -> BS.ByteString -> BS.ByteString -> BS.ByteString -> TestTree +cmp_hmac_lazy msg key (BL.fromStrict -> put) pec = testCase msg $ do + let out = B16.encode (RIPEMD160.hmac_lazy key put) + assertEqual mempty pec out + +hmv1_key :: BS.ByteString +hmv1_key = B16.decodeLenient "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b" + +hmv1_put :: BS.ByteString +hmv1_put = "Hi There" + +hmv1_pec :: BS.ByteString +hmv1_pec = "24cb4bd67d20fc1a5d2ed7732dcc39377f0a5668" + +hmv2_key :: BS.ByteString +hmv2_key = "Jefe" + +hmv2_put :: BS.ByteString +hmv2_put = "what do ya want for nothing?" + +hmv2_pec :: BS.ByteString +hmv2_pec = "dda6c0213a485a9e24f4742064a7f033b43c4069" + +hmv3_key :: BS.ByteString +hmv3_key = B16.decodeLenient "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" + +hmv3_put :: BS.ByteString +hmv3_put = B16.decodeLenient "dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd" + +hmv3_pec :: BS.ByteString +hmv3_pec = "b0b105360de759960ab4f35298e116e295d8e7c1" + +hmv4_key :: BS.ByteString +hmv4_key = B16.decodeLenient "0102030405060708090a0b0c0d0e0f10111213141516171819" + +hmv4_put :: BS.ByteString +hmv4_put = B16.decodeLenient "cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd" + +hmv4_pec :: BS.ByteString +hmv4_pec = "d5ca862f4d21d5e610e18b4cf1beb97a4365ecf4" + +hmv5_key :: BS.ByteString +hmv5_key = B16.decodeLenient "0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c" + +hmv5_put :: BS.ByteString +hmv5_put = "Test With Truncation" + +hmv5_pec :: BS.ByteString +hmv5_pec = "7619693978f91d90539ae786500ff3d8e0518e39" + +hmv6_key :: BS.ByteString +hmv6_key = B16.decodeLenient "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" + +hmv6_put :: BS.ByteString +hmv6_put = "Test Using Larger Than Block-Size Key - Hash Key First" + +hmv6_pec :: BS.ByteString +hmv6_pec = "6466ca07ac5eac29e1bd523e5ada7605b791fd8b" + +hmv7_key :: BS.ByteString +hmv7_key = hmv6_key + +hmv7_put :: BS.ByteString +hmv7_put = "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" + +hmv7_pec :: BS.ByteString +hmv7_pec = "69ea60798d71616cce5fd0871e23754cd75d5a0a" +