packages feed

ppad-sha256 0.3.4 → 0.3.5

raw patch · 10 files changed

+418/−185 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

CHANGELOG view
@@ -1,5 +1,17 @@ # Changelog +- 0.3.5 (2026-10-10)+  * Further defends MAC comparison timing against "helpful" LLVM+    optimizations.+  * Detects support for the ARM SHA2 extensions at runtime, rather than+    assuming it on all aarch64 builds, which crashed on aarch64 CPUs+    lacking them.+  * The portable implementation now lives in an internal+    'Crypto.Hash.SHA256.Pure' module, and+    'Crypto.Hash.SHA256.Arm' is no longer exposed. Both are hidden+    internal modules; the public API is unchanged.+  * Improves 'hash_lazy' and 'hmac_lazy' performance.+ - 0.3.4 (2026-07-06)   * Reverts the unrolled MAC comparison introduced in 0.3.3, which was     found to introduce timing variation on both aarch64 and x86-64 when
cbits/sha256_arm.c view
@@ -1,10 +1,17 @@ #include <stdint.h> #include <string.h> -#if defined(__aarch64__) && defined(__ARM_FEATURE_SHA2)+#if defined(__aarch64__)  #include <arm_neon.h> +#if defined(__linux__)+#include <sys/auxv.h>+#ifndef HWCAP_SHA2+#define HWCAP_SHA2 (1UL << 6)+#endif+#endif+ static const uint32_t K[64] = {     0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5,     0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5,@@ -31,7 +38,11 @@  * block: pointer to 16 uint32_t words (already native endian)  *  * The state is updated in place.+ *+ * Compiled for the SHA2 extension only; callers must first check+ * 'sha256_arm_available'.  */+__attribute__((target("+sha2"))) void sha256_block_arm(uint32_t *state, const uint32_t *block) {     /* Load current hash state */     uint32x4_t abcd = vld1q_u32(&state[0]);@@ -166,14 +177,25 @@     vst1q_u32(&state[4], efgh); } -/* Return 1 if ARM SHA2 is available, 0 otherwise */+/*+ * Return 1 if the CPU implements the ARM SHA2 extension, 0 otherwise.+ * Every Apple arm64 core implements it.  Elsewhere we only know how to+ * ask Linux, and report 0 (selecting the pure Haskell fallback) on+ * any other OS.+ */ int sha256_arm_available(void) {+#if defined(__APPLE__)     return 1;+#elif defined(__linux__)+    return (getauxval(AT_HWCAP) & HWCAP_SHA2) != 0;+#else+    return 0;+#endif }  #else -/* Stub implementations when ARM SHA2 is not available */+/* Stub implementations for non-aarch64 builds */ void sha256_block_arm(uint32_t *state, const uint32_t *block) {     (void)state;     (void)block;
lib/Crypto/Hash/SHA256.hs view
@@ -1,9 +1,4 @@ {-# OPTIONS_HADDOCK prune #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE UnliftedNewtypes #-}  -- | -- Module: Crypto.Hash.SHA256@@ -36,20 +31,12 @@   ) where  import qualified Data.ByteString as BS-import qualified Data.ByteString.Internal as BI-import qualified Data.ByteString.Unsafe as BU-import Data.Word (Word8, Word32, Word64)+import Data.Word (Word8, Word32) import Foreign.Ptr (Ptr)-import qualified GHC.Exts as Exts import qualified Crypto.Hash.SHA256.Arm as Arm-import Crypto.Hash.SHA256.Internal+import Crypto.Hash.SHA256.Internal (MAC(..), Registers) import qualified Crypto.Hash.SHA256.Lazy as Lazy---- utilities --------------------------------------------------------------------fi :: (Integral a, Num b) => a -> b-fi = fromIntegral-{-# INLINE fi #-}+import qualified Crypto.Hash.SHA256.Pure as Pure  -- hash ----------------------------------------------------------------------- @@ -63,71 +50,27 @@ hash :: BS.ByteString -> BS.ByteString hash m   | Arm.sha256_arm_available = Arm.hash m-  | otherwise = cat (_hash 0 (iv ()) m)+  | otherwise = Pure.hash m {-# INLINABLE hash #-} -_hash-  :: Word64        -- ^ extra prefix length for padding calculations-  -> Registers     -- ^ register state-  -> BS.ByteString -- ^ input-  -> Registers-_hash el rs m@(BI.PS _ _ l) = do-  let !state = _hash_blocks rs m-      !fin@(BI.PS _ _ ll) = BU.unsafeDrop (l - l `rem` 64) m-      !total = el + fi l-  if   ll < 56-  then-    let !ult = parse_pad1 fin total-    in  update state ult-  else-    let !(# pen, ult #) = parse_pad2 fin total-    in  update (update state pen) ult-{-# INLINABLE _hash #-}--_hash_blocks-  :: Registers     -- ^ state-  -> BS.ByteString -- ^ input-  -> Registers-_hash_blocks rs m@(BI.PS _ _ l) = loop rs 0 where-  loop !acc !j-    | j + 64 > l = acc-    | otherwise  =-        let !nacc = update acc (parse m j)-        in  loop nacc (j + 64)-{-# INLINABLE _hash_blocks #-}- -- hmac ---------------------------------------------------------------------- --- | Compute a condensed representation of a strict bytestring via---   SHA-256.+-- | Produce a message authentication code for a strict bytestring,+--   based on the provided (strict, bytestring) key, via SHA-256. -----   The 256-bit output digest is returned as a strict bytestring.+--   The 256-bit MAC is returned as a strict bytestring. -----   >>> hash "strict bytestring input"---   "<strict 256-bit message digest>"+--   Per RFC 2104, the key /should/ be a minimum of 32 bytes long. Keys+--   exceeding 64 bytes in length will first be hashed (via SHA-256).+--+--   >>> hmac "strict bytestring key" "strict bytestring input"+--   "<strict 256-bit MAC>" hmac :: BS.ByteString -> BS.ByteString -> MAC hmac k m   | Arm.sha256_arm_available = MAC (Arm.hmac k m)-  | otherwise = MAC (cat (_hmac (prep_key k) m))+  | otherwise = MAC (Pure.hmac k m) {-# INLINABLE hmac #-} -prep_key :: BS.ByteString -> Block-prep_key k@(BI.PS _ _ l)-    | l > 64    = parse_key (hash k)-    | otherwise = parse_key k-{-# INLINABLE prep_key #-}--_hmac-  :: Block          -- ^ padded key-  -> BS.ByteString  -- ^ message-  -> Registers-_hmac k m =-  let !rs0   = update (iv ()) (xor k (Exts.wordToWord32# 0x36363636##))-      !block = pad_registers_with_length (_hash 64 rs0 m)-      !rs1   = update (iv ()) (xor k (Exts.wordToWord32# 0x5C5C5C5C##))-  in  update rs1 block-{-# INLINABLE _hmac #-}- -- the following functions are useful when we want to avoid allocating certain -- components of the HMAC key and message on the heap. @@ -142,25 +85,9 @@   -> IO () _hmac_rr rp bp k m   | Arm.sha256_arm_available = Arm._hmac_rr rp bp k m-  | otherwise = do-      let !key   = pad_registers k-          !block = pad_registers_with_length m-          !rs    = _hmac_bb key block-      poke_registers rp rs+  | otherwise = Pure._hmac_rr rp bp k m {-# INLINABLE _hmac_rr #-} -_hmac_bb-  :: Block     -- ^ key-  -> Block     -- ^ message-  -> Registers-_hmac_bb k m =-  let !rs0   = update (iv ()) (xor k (Exts.wordToWord32# 0x36363636##))-      !rs1   = update rs0 m-      !inner = pad_registers_with_length rs1-      !rs2   = update (iv ()) (xor k (Exts.wordToWord32# 0x5C5C5C5C##))-  in  update rs2 inner-{-# INLINABLE _hmac_bb #-}- -- Calculate hmac(k, m) where m is the concatenation of v (registers), a -- separator byte, and a ByteString. This avoids allocating 'v' on the -- heap.@@ -176,46 +103,5 @@   -> IO () _hmac_rsb rp bp k v sep dat   | Arm.sha256_arm_available = Arm._hmac_rsb rp bp k v sep dat-  | otherwise = do-      let !key   = pad_registers k-          !rs0   = update (iv ()) (xor key (Exts.wordToWord32# 0x36363636##))-          !inner = _hash_vsb 64 rs0 v sep dat-          !block = pad_registers_with_length inner-          !rs1   = update (iv ()) (xor key (Exts.wordToWord32# 0x5C5C5C5C##))-          !rs    = update rs1 block-      poke_registers rp rs+  | otherwise = Pure._hmac_rsb rp bp k v sep dat {-# INLINABLE _hmac_rsb #-}---- hash(v || sep || dat) with a custom initial state and extra--- prefix length. used for producing a more specialized hmac.-_hash_vsb-  :: Word64        -- ^ extra prefix length-  -> Registers     -- ^ initial state-  -> Registers     -- ^ v-  -> Word8         -- ^ sep-  -> BS.ByteString -- ^ dat-  -> Registers-_hash_vsb el rs0 v sep dat@(BI.PS _ _ l)-  | l >= 31 =-      -- first block is complete-      let !b0    = parse_vsb v sep dat-          !rs1   = update rs0 b0-          !rest  = BU.unsafeDrop 31 dat-          !rlen  = l - 31-          !rs2   = _hash_blocks rs1 rest-          !flen  = rlen `rem` 64-          !fin   = BU.unsafeDrop (rlen - flen) rest-          !total = el + 33 + fi l-      in  if   flen < 56-          then update rs2 (parse_pad1 fin total)-          else let !(# pen, ult #) = parse_pad2 fin total-               in  update (update rs2 pen) ult-  | otherwise =-      -- message < 64 bytes, goes straight to padding-      let !total = el + 33 + fi l-      in  if   33 + l < 56-          then update rs0 (parse_pad1_vsb v sep dat total)-          else let !(# pen, ult #) = parse_pad2_vsb v sep dat total-               in  update (update rs0 pen) ult-{-# INLINABLE _hash_vsb #-}-
lib/Crypto/Hash/SHA256/Arm.hs view
@@ -24,6 +24,7 @@ import qualified Data.ByteString.Internal as BI import qualified Data.ByteString.Unsafe as BU import Data.Word (Word8, Word32, Word64)+import Foreign.C.Types (CInt(..)) import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Ptr (Ptr) import qualified GHC.Exts as Exts@@ -38,7 +39,7 @@   c_sha256_block :: Ptr Word32 -> Ptr Word32 -> IO ()  foreign import ccall unsafe "sha256_arm_available"-  c_sha256_arm_available :: IO Int+  c_sha256_arm_available :: IO CInt  -- utilities ------------------------------------------------------------------
lib/Crypto/Hash/SHA256/Internal.hs view
@@ -50,6 +50,7 @@   , poke_registers   ) where +import Data.Barrier (barrier) import qualified Data.Bits as B import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BI@@ -89,10 +90,13 @@       -- fused fold: OR the bytewise XORs into an accumulator       -- directly, rather than via packZipWith, so no intermediate       -- ByteString holding the (secret-derived) difference bytes-      -- is ever materialised on the heap.+      -- is ever materialised on the heap. The accumulator is routed+      -- through 'barrier' before the zero-test so the LLVM backend+      -- cannot recover the array-equality idiom and short-circuit on+      -- the first mismatch (see "Data.Barrier").       go :: Word8 -> Int -> Bool       go !acc !i-        | i == la   = acc == 0+        | i == la   = barrier acc == 0         | otherwise =             let !x = BU.unsafeIndex a i                 !y = BU.unsafeIndex b i
lib/Crypto/Hash/SHA256/Lazy.hs view
@@ -24,13 +24,13 @@ import qualified Data.Bits as B 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 Data.Word (Word64) import Foreign.ForeignPtr (plusForeignPtr) import Crypto.Hash.SHA256.Internal+import qualified Crypto.Hash.SHA256.Pure as Pure  fi :: (Integral a, Num b) => a -> b fi = fromIntegral@@ -77,26 +77,19 @@  -- k such that (l + 1 + k) mod 64 = 56 sol :: Word64 -> Word64-sol l =-  let r = 56 - fi l `rem` 64 - 1 :: Integer -- fi prevents underflow-  in  fi (if r < 0 then r + 64 else r)+sol l = (55 - l) B..&. 63 -- wraps mod 2^64, a multiple of 64  -- RFC 6234 4.1 (lazy) 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] -  padding l k bs-    | k == 0 =-          pure-        . to_strict-          -- more efficient for small builder-        $ bs <> BSB.word64BE (l * 8)-    | otherwise =-        let nacc = bs <> BSB.word8 0x00-        in  padding l (pred k) nacc+  padding l = to_strict $+       BSB.word8 0x80+    <> BSB.byteString (BS.replicate (fi (sol l)) 0x00)+    <> BSB.word64BE (l * 8)  -- | Compute a condensed representation of a lazy bytestring via --   SHA-256.@@ -137,36 +130,6 @@         step4 = hash_lazy step3         step5 = BS.map (B.xor 0x5C) step1         step6 = step5 <> step4-    in  MAC (hash step6)+    in  MAC (Pure.hash step6)   where-    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 (update acc (parse c 0)) r--      pad m@(BI.PS _ _ (fi -> len))-          | len < 128 = to_strict_small padded-          | otherwise = to_strict padded-        where-          padded = BSB.byteString m-                <> fill (sol len) (BSB.word8 0x80)-                <> BSB.word64BE (len * 8)--          to_strict_small = BL.toStrict . BE.toLazyByteStringWith-            (BE.safeStrategy 128 BE.smallChunkSize) mempty--          fill j !acc-            | j `rem` 8 == 0 = loop64 j acc-            | otherwise = loop8 j acc--          loop64 j !acc-            | j == 0 = acc-            | otherwise = loop64 (j - 8) (acc <> BSB.word64BE 0x00)--          loop8 j !acc-            | j == 0 = acc-            | otherwise = loop8 (pred j) (acc <> BSB.word8 0x00)--    !(k, lk) = if l > 64 then (hash mk, 32) else (mk, l)+    !(k, lk) = if l > 64 then (Pure.hash mk, 32) else (mk, l)
+ lib/Crypto/Hash/SHA256/Pure.hs view
@@ -0,0 +1,187 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++-- |+-- Module: Crypto.Hash.SHA256.Pure+-- Copyright: (c) 2024 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- Pure Haskell SHA-256 and HMAC-SHA256 implementations for strict+-- ByteStrings, used when the ARM cryptographic extensions are+-- unavailable.++module Crypto.Hash.SHA256.Pure (+    hash+  , hmac+  , _hmac_rr+  , _hmac_rsb+  ) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BI+import qualified Data.ByteString.Unsafe as BU+import Data.Word (Word8, Word32, Word64)+import Foreign.Ptr (Ptr)+import qualified GHC.Exts as Exts+import Crypto.Hash.SHA256.Internal++-- utilities ------------------------------------------------------------------++fi :: (Integral a, Num b) => a -> b+fi = fromIntegral+{-# INLINE fi #-}++-- hash -----------------------------------------------------------------------++-- | Compute a condensed representation of a strict bytestring via+--   SHA-256, using the pure Haskell implementation.+hash :: BS.ByteString -> BS.ByteString+hash m = cat (_hash 0 (iv ()) m)+{-# INLINABLE hash #-}++_hash+  :: Word64        -- ^ extra prefix length for padding calculations+  -> Registers     -- ^ register state+  -> BS.ByteString -- ^ input+  -> Registers+_hash el rs m@(BI.PS _ _ l) = do+  let !state = _hash_blocks rs m+      !fin@(BI.PS _ _ ll) = BU.unsafeDrop (l - l `rem` 64) m+      !total = el + fi l+  if   ll < 56+  then+    let !ult = parse_pad1 fin total+    in  update state ult+  else+    let !(# pen, ult #) = parse_pad2 fin total+    in  update (update state pen) ult+{-# INLINABLE _hash #-}++_hash_blocks+  :: Registers     -- ^ state+  -> BS.ByteString -- ^ input+  -> Registers+_hash_blocks rs m@(BI.PS _ _ l) = loop rs 0 where+  loop !acc !j+    | j + 64 > l = acc+    | otherwise  =+        let !nacc = update acc (parse m j)+        in  loop nacc (j + 64)+{-# INLINABLE _hash_blocks #-}++-- hmac ----------------------------------------------------------------------++-- | Produce a message authentication code for a strict bytestring,+--   based on the provided (strict, bytestring) key, via HMAC-SHA256,+--   using the pure Haskell implementation.+hmac :: BS.ByteString -> BS.ByteString -> BS.ByteString+hmac k m = cat (_hmac (prep_key k) m)+{-# INLINABLE hmac #-}++prep_key :: BS.ByteString -> Block+prep_key k@(BI.PS _ _ l)+    | l > 64    = parse_key (hash k)+    | otherwise = parse_key k+{-# INLINABLE prep_key #-}++_hmac+  :: Block          -- ^ padded key+  -> BS.ByteString  -- ^ message+  -> Registers+_hmac k m =+  let !rs0   = update (iv ()) (xor k (Exts.wordToWord32# 0x36363636##))+      !block = pad_registers_with_length (_hash 64 rs0 m)+      !rs1   = update (iv ()) (xor k (Exts.wordToWord32# 0x5C5C5C5C##))+  in  update rs1 block+{-# INLINABLE _hmac #-}++-- the following functions are useful when we want to avoid allocating certain+-- components of the HMAC key and message on the heap.++-- Computes hmac(k, v) when k and v are Registers.+--+-- The 32-byte result is written to the destination pointer.+_hmac_rr+  :: Ptr Word32    -- ^ destination (8 Word32s)+  -> Ptr Word32    -- ^ scratch block buffer (unused)+  -> Registers     -- ^ key+  -> Registers     -- ^ message+  -> IO ()+_hmac_rr rp _ k m = do+  let !key   = pad_registers k+      !block = pad_registers_with_length m+      !rs    = _hmac_bb key block+  poke_registers rp rs+{-# INLINABLE _hmac_rr #-}++_hmac_bb+  :: Block     -- ^ key+  -> Block     -- ^ message+  -> Registers+_hmac_bb k m =+  let !rs0   = update (iv ()) (xor k (Exts.wordToWord32# 0x36363636##))+      !rs1   = update rs0 m+      !inner = pad_registers_with_length rs1+      !rs2   = update (iv ()) (xor k (Exts.wordToWord32# 0x5C5C5C5C##))+  in  update rs2 inner+{-# INLINABLE _hmac_bb #-}++-- Calculate hmac(k, m) where m is the concatenation of v (registers), a+-- separator byte, and a ByteString. This avoids allocating 'v' on the+-- heap.+--+-- The 32-byte result is written to the destination pointer.+_hmac_rsb+  :: Ptr Word32    -- ^ destination pointer (8 x Word32)+  -> Ptr Word32    -- ^ scratch block pointer (unused)+  -> Registers     -- ^ k+  -> Registers     -- ^ v+  -> Word8         -- ^ separator byte+  -> BS.ByteString -- ^ data+  -> IO ()+_hmac_rsb rp _ k v sep dat = do+  let !key   = pad_registers k+      !rs0   = update (iv ()) (xor key (Exts.wordToWord32# 0x36363636##))+      !inner = _hash_vsb 64 rs0 v sep dat+      !block = pad_registers_with_length inner+      !rs1   = update (iv ()) (xor key (Exts.wordToWord32# 0x5C5C5C5C##))+      !rs    = update rs1 block+  poke_registers rp rs+{-# INLINABLE _hmac_rsb #-}++-- hash(v || sep || dat) with a custom initial state and extra+-- prefix length. used for producing a more specialized hmac.+_hash_vsb+  :: Word64        -- ^ extra prefix length+  -> Registers     -- ^ initial state+  -> Registers     -- ^ v+  -> Word8         -- ^ sep+  -> BS.ByteString -- ^ dat+  -> Registers+_hash_vsb el rs0 v sep dat@(BI.PS _ _ l)+  | l >= 31 =+      -- first block is complete+      let !b0    = parse_vsb v sep dat+          !rs1   = update rs0 b0+          !rest  = BU.unsafeDrop 31 dat+          !rlen  = l - 31+          !rs2   = _hash_blocks rs1 rest+          !flen  = rlen `rem` 64+          !fin   = BU.unsafeDrop (rlen - flen) rest+          !total = el + 33 + fi l+      in  if   flen < 56+          then update rs2 (parse_pad1 fin total)+          else let !(# pen, ult #) = parse_pad2 fin total+               in  update (update rs2 pen) ult+  | otherwise =+      -- message < 64 bytes, goes straight to padding+      let !total = el + 33 + fi l+      in  if   33 + l < 56+          then update rs0 (parse_pad1_vsb v sep dat total)+          else let !(# pen, ult #) = parse_pad2_vsb v sep dat total+               in  update (update rs0 pen) ult+{-# INLINABLE _hash_vsb #-}+
+ lib/Data/Barrier.hs view
@@ -0,0 +1,34 @@+{-# OPTIONS_HADDOCK hide #-}++-- |+-- Module: Data.Barrier+-- Copyright: (c) 2026 Jared Tobin+-- License: MIT+-- Maintainer: Jared Tobin <jared@ppad.tech>+--+-- An optimisation barrier for constant-time code.++module Data.Barrier (+    barrier+  ) where++import Data.Word (Word8)++-- | Identity on 'Word8', but opaque to the optimiser. A constant-time+--   accumulate-then-compare (e.g. an OR-fold of bytewise XORs, tested+--   against zero) routes its accumulator through this before the+--   zero-test, so the compiler cannot recognise it as an array-equality+--   test and lower it to a short-circuiting byte comparison (which would+--   leak the mismatch position).+--+--   Both properties are required and must not be \"tidied\" away:+--+--     * @NOINLINE@ -- if GHC inlines it, the LLVM backend regains the+--       accumulator's definition and short-circuits again.+--     * a /separate/ module -- a caller then compiles @barrier@ to an+--       external call it cannot see through. Inline it into the caller+--       and the barrier is gone.+--+barrier :: Word8 -> Word8+barrier x = x+{-# NOINLINE barrier #-}
ppad-sha256.cabal view
@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               ppad-sha256-version:            0.3.4+version:            0.3.5 synopsis:           The SHA-256 and HMAC-SHA256 algorithms license:            MIT license-file:       LICENSE@@ -37,16 +37,17 @@     ghc-options: -fllvm -O2   exposed-modules:       Crypto.Hash.SHA256-      Crypto.Hash.SHA256.Arm       Crypto.Hash.SHA256.Internal       Crypto.Hash.SHA256.Lazy+      Crypto.Hash.SHA256.Pure+  other-modules:+      Crypto.Hash.SHA256.Arm+      Data.Barrier   build-depends:       base >= 4.9 && < 5     , bytestring >= 0.9 && < 0.13   c-sources:       cbits/sha256_arm.c-  if arch(aarch64)-    cc-options: -march=armv8-a+sha2   if flag(sanitize)     cc-options: -fsanitize=address,undefined -fno-omit-frame-pointer     ghc-options: -optl=-fsanitize=address,undefined
test/Property.hs view
@@ -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, Word32)+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.SHA256+import Crypto.Hash.SHA256.Internal (Registers(..))+import qualified Crypto.Hash.SHA256.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 @@       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 SHA2 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 * 64)+    Msg . BS.pack <$> Q.vectorOf l Q.arbitrary++-- register-sized strings+newtype Bytes32 = Bytes32 BS.ByteString+  deriving Show++instance Q.Arbitrary Bytes32 where+  arbitrary = Bytes32 . BS.pack <$> Q.vectorOf 32 Q.arbitrary++-- big-endian words of a 32-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.Word32#+  w i = case word32 (BS.take 4 (BS.drop (4 * i) bs)) of+    GHC.Word.W32# x -> x+  word32 :: BS.ByteString -> Word32+  word32 = BS.foldl' (\acc b -> acc `B.shiftL` 8 .|. fromIntegral b) 0++-- run a destination-pointer HMAC, returning the big-endian digest+run_ptr :: (Ptr Word32 -> Ptr Word32 -> IO ()) -> IO BS.ByteString+run_ptr act = allocaBytes 32 $ \rp -> allocaBytes 64 $ \bp -> do+  act rp bp+  ws <- peekArray 8 rp+  pure (BL.toStrict (BSB.toLazyByteString (foldMap BSB.word32BE 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 :: Bytes32 -> Bytes32 -> Q.Property+hmac_rr_matches_hmac (Bytes32 k) (Bytes32 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 :: Bytes32 -> Bytes32 -> Word8 -> Msg -> Q.Property+hmac_rsb_matches_hmac (Bytes32 k) (Bytes32 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 * 64]++hmac_all_lengths :: TestTree+hmac_all_lengths = H.testCase "hmac ~ Pure.hmac (all lengths)" $+  H.assertBool mempty $+    all (\l -> unmac (hmac (msg 32) (msg l)) == Pure.hmac (msg 32) (msg l))+      [0 .. 3 * 64]++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 * 64 + 1]++hmac_rsb_all_lengths :: TestTree+hmac_rsb_all_lengths = H.testCase "_hmac_rsb ~ hmac (all lengths)" $ do+  oks <- traverse (rsb_matches (msg 32) (BS.reverse (msg 32)) 0x01 . msg)+           [0 .. 3 * 64]+  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 @@       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+    ]   ]