Property.hs (6850B)
1 {-# OPTIONS_GHC -fno-warn-orphans #-} 2 {-# LANGUAGE MagicHash #-} 3 4 module Property ( 5 properties 6 ) where 7 8 import Data.Bits ((.|.)) 9 import qualified Data.Bits as B 10 import qualified Data.ByteString as BS 11 import qualified Data.ByteString.Builder as BSB 12 import qualified Data.ByteString.Lazy as BL 13 import Data.Word (Word8, Word32) 14 import Foreign.Marshal.Alloc (allocaBytes) 15 import Foreign.Marshal.Array (peekArray) 16 import Foreign.Ptr (Ptr) 17 import qualified GHC.Exts as Exts 18 import qualified GHC.Word 19 import Crypto.Hash.SHA256 20 import Crypto.Hash.SHA256.Internal (Registers(..)) 21 import qualified Crypto.Hash.SHA256.Pure as Pure 22 import Test.Tasty 23 import qualified Test.Tasty.HUnit as H 24 import qualified Test.Tasty.QuickCheck as Q 25 import Test.QuickCheck.Instances.ByteString () 26 27 -- strict/lazy hash equivalence 28 hash_equiv :: BS.ByteString -> Bool 29 hash_equiv bs = hash bs == hash_lazy (BL.fromStrict bs) 30 31 -- strict/lazy hmac equivalence 32 hmac_equiv :: BS.ByteString -> BS.ByteString -> Bool 33 hmac_equiv k m = hmac k m == hmac_lazy k (BL.fromStrict m) 34 35 -- hash output is always 32 bytes 36 hash_length :: BS.ByteString -> Bool 37 hash_length bs = BS.length (hash bs) == 32 38 39 -- hmac output is always 32 bytes 40 hmac_length :: BS.ByteString -> BS.ByteString -> Bool 41 hmac_length k m = let MAC h = hmac k m in BS.length h == 32 42 43 -- hash_lazy produces same result regardless of chunking 44 hash_chunking :: BS.ByteString -> [Q.Positive Int] -> Bool 45 hash_chunking bs chunks = 46 let lazy_single = BL.fromStrict bs 47 lazy_chunked = BL.fromChunks (chunk_by (map Q.getPositive chunks) bs) 48 in hash_lazy lazy_single == hash_lazy lazy_chunked 49 50 -- hmac_lazy produces same result regardless of chunking 51 hmac_chunking :: BS.ByteString -> BS.ByteString -> [Q.Positive Int] -> Bool 52 hmac_chunking k m chunks = 53 let lazy_single = BL.fromStrict m 54 lazy_chunked = BL.fromChunks (chunk_by (map Q.getPositive chunks) m) 55 in hmac_lazy k lazy_single == hmac_lazy k lazy_chunked 56 57 -- dispatching vs. pure implementations ------------------------------------ 58 -- 59 -- on hosts with the ARM SHA2 extension, the public functions use it, so 60 -- these compare it against the pure Haskell implementation. 61 62 -- messages spanning several blocks 63 newtype Msg = Msg BS.ByteString 64 deriving Show 65 66 instance Q.Arbitrary Msg where 67 arbitrary = do 68 l <- Q.chooseInt (0, 8 * 64) 69 Msg . BS.pack <$> Q.vectorOf l Q.arbitrary 70 71 -- register-sized strings 72 newtype Bytes32 = Bytes32 BS.ByteString 73 deriving Show 74 75 instance Q.Arbitrary Bytes32 where 76 arbitrary = Bytes32 . BS.pack <$> Q.vectorOf 32 Q.arbitrary 77 78 -- big-endian words of a 32-byte string, as registers 79 to_registers :: BS.ByteString -> Registers 80 to_registers bs = R (w 0) (w 1) (w 2) (w 3) (w 4) (w 5) (w 6) (w 7) where 81 w :: Int -> Exts.Word32# 82 w i = case word32 (BS.take 4 (BS.drop (4 * i) bs)) of 83 GHC.Word.W32# x -> x 84 word32 :: BS.ByteString -> Word32 85 word32 = BS.foldl' (\acc b -> acc `B.shiftL` 8 .|. fromIntegral b) 0 86 87 -- run a destination-pointer HMAC, returning the big-endian digest 88 run_ptr :: (Ptr Word32 -> Ptr Word32 -> IO ()) -> IO BS.ByteString 89 run_ptr act = allocaBytes 32 $ \rp -> allocaBytes 64 $ \bp -> do 90 act rp bp 91 ws <- peekArray 8 rp 92 pure (BL.toStrict (BSB.toLazyByteString (foldMap BSB.word32BE ws))) 93 94 unmac :: MAC -> BS.ByteString 95 unmac (MAC m) = m 96 97 -- deterministic input of the given length 98 msg :: Int -> BS.ByteString 99 msg l = BS.pack (fmap fromIntegral (take l [(7 :: Int), 20 ..])) 100 101 hash_matches_pure :: Msg -> Bool 102 hash_matches_pure (Msg m) = hash m == Pure.hash m 103 104 hmac_matches_pure :: Msg -> Msg -> Bool 105 hmac_matches_pure (Msg k) (Msg m) = unmac (hmac k m) == Pure.hmac k m 106 107 hmac_rr_matches_hmac :: Bytes32 -> Bytes32 -> Q.Property 108 hmac_rr_matches_hmac (Bytes32 k) (Bytes32 m) = Q.ioProperty $ do 109 let expected = unmac (hmac k m) 110 a <- run_ptr (\rp bp -> _hmac_rr rp bp (to_registers k) (to_registers m)) 111 b <- run_ptr (\rp bp -> 112 Pure._hmac_rr rp bp (to_registers k) (to_registers m)) 113 pure (a == expected && b == expected) 114 115 hmac_rsb_matches_hmac :: Bytes32 -> Bytes32 -> Word8 -> Msg -> Q.Property 116 hmac_rsb_matches_hmac (Bytes32 k) (Bytes32 v) sep (Msg dat) = 117 Q.ioProperty (rsb_matches k v sep dat) 118 119 rsb_matches 120 :: BS.ByteString -> BS.ByteString -> Word8 -> BS.ByteString -> IO Bool 121 rsb_matches k v sep dat = do 122 let expected = unmac (hmac k (v <> BS.singleton sep <> dat)) 123 a <- run_ptr (\rp bp -> 124 _hmac_rsb rp bp (to_registers k) (to_registers v) sep dat) 125 b <- run_ptr (\rp bp -> 126 Pure._hmac_rsb rp bp (to_registers k) (to_registers v) sep dat) 127 pure (a == expected && b == expected) 128 129 -- every input length through three blocks, hitting each padding case 130 hash_all_lengths :: TestTree 131 hash_all_lengths = H.testCase "hash ~ Pure.hash (all lengths)" $ 132 H.assertBool mempty $ 133 all (\l -> hash (msg l) == Pure.hash (msg l)) [0 .. 3 * 64] 134 135 hmac_all_lengths :: TestTree 136 hmac_all_lengths = H.testCase "hmac ~ Pure.hmac (all lengths)" $ 137 H.assertBool mempty $ 138 all (\l -> unmac (hmac (msg 32) (msg l)) == Pure.hmac (msg 32) (msg l)) 139 [0 .. 3 * 64] 140 141 hmac_all_key_lengths :: TestTree 142 hmac_all_key_lengths = H.testCase "hmac ~ Pure.hmac (all key lengths)" $ 143 H.assertBool mempty $ 144 all (\l -> unmac (hmac (msg l) (msg 3)) == Pure.hmac (msg l) (msg 3)) 145 [0 .. 2 * 64 + 1] 146 147 hmac_rsb_all_lengths :: TestTree 148 hmac_rsb_all_lengths = H.testCase "_hmac_rsb ~ hmac (all lengths)" $ do 149 oks <- traverse (rsb_matches (msg 32) (BS.reverse (msg 32)) 0x01 . msg) 150 [0 .. 3 * 64] 151 H.assertBool mempty (and oks) 152 153 chunk_by :: [Int] -> BS.ByteString -> [BS.ByteString] 154 chunk_by _ bs | BS.null bs = [] 155 chunk_by [] bs = [bs] 156 chunk_by (n:ns) bs = 157 let (h, t) = BS.splitAt n bs 158 in h : chunk_by ns t 159 160 properties :: TestTree 161 properties = testGroup "properties" [ 162 Q.testProperty "hash == hash_lazy" $ 163 Q.withMaxSuccess 1000 hash_equiv 164 , Q.testProperty "hmac == hmac_lazy" $ 165 Q.withMaxSuccess 1000 hmac_equiv 166 , Q.testProperty "hash output is 32 bytes" $ 167 Q.withMaxSuccess 1000 hash_length 168 , Q.testProperty "hmac output is 32 bytes" $ 169 Q.withMaxSuccess 1000 hmac_length 170 , Q.testProperty "hash_lazy chunking-invariant" $ 171 Q.withMaxSuccess 1000 hash_chunking 172 , Q.testProperty "hmac_lazy chunking-invariant" $ 173 Q.withMaxSuccess 1000 hmac_chunking 174 , testGroup "dispatch ~ pure" [ 175 Q.testProperty "hash ~ Pure.hash" $ 176 Q.withMaxSuccess 1000 hash_matches_pure 177 , Q.testProperty "hmac ~ Pure.hmac" $ 178 Q.withMaxSuccess 1000 hmac_matches_pure 179 , Q.testProperty "_hmac_rr k m ~ hmac (cat k) (cat m)" $ 180 Q.withMaxSuccess 1000 hmac_rr_matches_hmac 181 , Q.testProperty "_hmac_rsb k v s d ~ hmac (cat k) (cat v <> s <> d)" $ 182 Q.withMaxSuccess 1000 hmac_rsb_matches_hmac 183 , hash_all_lengths 184 , hmac_all_lengths 185 , hmac_all_key_lengths 186 , hmac_rsb_all_lengths 187 ] 188 ]