commit aa6378d91b253008baf48b5e3d5499398c3a17f9
parent 5b9548d5d9d51c88920f900cd401a8cae4b88478
Author: Jared Tobin <jared@jtobin.io>
Date: Sat, 10 Oct 2026 15:31:45 +0400
test: compare the dispatching and pure implementations
On hosts where the ARM path is selected, the pure Haskell strict
implementation was never exercised. The public hash, hmac, _hmac_rr
and _hmac_rsb are now checked against Crypto.Hash.SHA512.Pure on
multi-block inputs, and _hmac_rr/_hmac_rsb against hmac itself, with
exhaustive sweeps over message and key lengths to cover every padding
case.
Diffstat:
| M | test/Property.hs | | | 123 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
1 file changed, 123 insertions(+), 0 deletions(-)
diff --git a/test/Property.hs b/test/Property.hs
@@ -1,13 +1,26 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE MagicHash #-}
module Property (
properties
) where
+import Data.Bits ((.|.))
+import qualified Data.Bits as B
import qualified Data.ByteString as BS
+import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Lazy as BL
+import Data.Word (Word8, Word64)
+import Foreign.Marshal.Alloc (allocaBytes)
+import Foreign.Marshal.Array (peekArray)
+import Foreign.Ptr (Ptr)
+import qualified GHC.Exts as Exts
+import qualified GHC.Word
import Crypto.Hash.SHA512
+import Crypto.Hash.SHA512.Internal (Registers(..))
+import qualified Crypto.Hash.SHA512.Pure as Pure
import Test.Tasty
+import qualified Test.Tasty.HUnit as H
import qualified Test.Tasty.QuickCheck as Q
import Test.QuickCheck.Instances.ByteString ()
@@ -41,6 +54,102 @@ hmac_chunking k m chunks =
lazy_chunked = BL.fromChunks (chunk_by (map Q.getPositive chunks) m)
in hmac_lazy k lazy_single == hmac_lazy k lazy_chunked
+-- dispatching vs. pure implementations ------------------------------------
+--
+-- on hosts with the ARM SHA512 extension, the public functions use it, so
+-- these compare it against the pure Haskell implementation.
+
+-- messages spanning several blocks
+newtype Msg = Msg BS.ByteString
+ deriving Show
+
+instance Q.Arbitrary Msg where
+ arbitrary = do
+ l <- Q.chooseInt (0, 8 * 128)
+ Msg . BS.pack <$> Q.vectorOf l Q.arbitrary
+
+-- register-sized strings
+newtype Bytes64 = Bytes64 BS.ByteString
+ deriving Show
+
+instance Q.Arbitrary Bytes64 where
+ arbitrary = Bytes64 . BS.pack <$> Q.vectorOf 64 Q.arbitrary
+
+-- big-endian words of a 64-byte string, as registers
+to_registers :: BS.ByteString -> Registers
+to_registers bs = R (w 0) (w 1) (w 2) (w 3) (w 4) (w 5) (w 6) (w 7) where
+ w :: Int -> Exts.Word64#
+ w i = case word64 (BS.take 8 (BS.drop (8 * i) bs)) of
+ GHC.Word.W64# x -> x
+ word64 :: BS.ByteString -> Word64
+ word64 = BS.foldl' (\acc b -> acc `B.shiftL` 8 .|. fromIntegral b) 0
+
+-- run a destination-pointer HMAC, returning the big-endian digest
+run_ptr :: (Ptr Word64 -> Ptr Word64 -> IO ()) -> IO BS.ByteString
+run_ptr act = allocaBytes 64 $ \rp -> allocaBytes 128 $ \bp -> do
+ act rp bp
+ ws <- peekArray 8 rp
+ pure (BL.toStrict (BSB.toLazyByteString (foldMap BSB.word64BE ws)))
+
+unmac :: MAC -> BS.ByteString
+unmac (MAC m) = m
+
+-- deterministic input of the given length
+msg :: Int -> BS.ByteString
+msg l = BS.pack (fmap fromIntegral (take l [(7 :: Int), 20 ..]))
+
+hash_matches_pure :: Msg -> Bool
+hash_matches_pure (Msg m) = hash m == Pure.hash m
+
+hmac_matches_pure :: Msg -> Msg -> Bool
+hmac_matches_pure (Msg k) (Msg m) = unmac (hmac k m) == Pure.hmac k m
+
+hmac_rr_matches_hmac :: Bytes64 -> Bytes64 -> Q.Property
+hmac_rr_matches_hmac (Bytes64 k) (Bytes64 m) = Q.ioProperty $ do
+ let expected = unmac (hmac k m)
+ a <- run_ptr (\rp bp -> _hmac_rr rp bp (to_registers k) (to_registers m))
+ b <- run_ptr (\rp bp ->
+ Pure._hmac_rr rp bp (to_registers k) (to_registers m))
+ pure (a == expected && b == expected)
+
+hmac_rsb_matches_hmac :: Bytes64 -> Bytes64 -> Word8 -> Msg -> Q.Property
+hmac_rsb_matches_hmac (Bytes64 k) (Bytes64 v) sep (Msg dat) =
+ Q.ioProperty (rsb_matches k v sep dat)
+
+rsb_matches
+ :: BS.ByteString -> BS.ByteString -> Word8 -> BS.ByteString -> IO Bool
+rsb_matches k v sep dat = do
+ let expected = unmac (hmac k (v <> BS.singleton sep <> dat))
+ a <- run_ptr (\rp bp ->
+ _hmac_rsb rp bp (to_registers k) (to_registers v) sep dat)
+ b <- run_ptr (\rp bp ->
+ Pure._hmac_rsb rp bp (to_registers k) (to_registers v) sep dat)
+ pure (a == expected && b == expected)
+
+-- every input length through three blocks, hitting each padding case
+hash_all_lengths :: TestTree
+hash_all_lengths = H.testCase "hash ~ Pure.hash (all lengths)" $
+ H.assertBool mempty $
+ all (\l -> hash (msg l) == Pure.hash (msg l)) [0 .. 3 * 128]
+
+hmac_all_lengths :: TestTree
+hmac_all_lengths = H.testCase "hmac ~ Pure.hmac (all lengths)" $
+ H.assertBool mempty $
+ all (\l -> unmac (hmac (msg 64) (msg l)) == Pure.hmac (msg 64) (msg l))
+ [0 .. 3 * 128]
+
+hmac_all_key_lengths :: TestTree
+hmac_all_key_lengths = H.testCase "hmac ~ Pure.hmac (all key lengths)" $
+ H.assertBool mempty $
+ all (\l -> unmac (hmac (msg l) (msg 3)) == Pure.hmac (msg l) (msg 3))
+ [0 .. 2 * 128 + 1]
+
+hmac_rsb_all_lengths :: TestTree
+hmac_rsb_all_lengths = H.testCase "_hmac_rsb ~ hmac (all lengths)" $ do
+ oks <- traverse (rsb_matches (msg 64) (BS.reverse (msg 64)) 0x01 . msg)
+ [0 .. 3 * 128]
+ H.assertBool mempty (and oks)
+
chunk_by :: [Int] -> BS.ByteString -> [BS.ByteString]
chunk_by _ bs | BS.null bs = []
chunk_by [] bs = [bs]
@@ -62,4 +171,18 @@ properties = testGroup "properties" [
Q.withMaxSuccess 1000 hash_chunking
, Q.testProperty "hmac_lazy chunking-invariant" $
Q.withMaxSuccess 1000 hmac_chunking
+ , testGroup "dispatch ~ pure" [
+ Q.testProperty "hash ~ Pure.hash" $
+ Q.withMaxSuccess 1000 hash_matches_pure
+ , Q.testProperty "hmac ~ Pure.hmac" $
+ Q.withMaxSuccess 1000 hmac_matches_pure
+ , Q.testProperty "_hmac_rr k m ~ hmac (cat k) (cat m)" $
+ Q.withMaxSuccess 1000 hmac_rr_matches_hmac
+ , Q.testProperty "_hmac_rsb k v s d ~ hmac (cat k) (cat v <> s <> d)" $
+ Q.withMaxSuccess 1000 hmac_rsb_matches_hmac
+ , hash_all_lengths
+ , hmac_all_lengths
+ , hmac_all_key_lengths
+ , hmac_rsb_all_lengths
+ ]
]
