hashes 0.1.0.1 → 0.2.0.0

raw patch · 29 files changed

+2874/−471 lines, 29 filesdep +cryptonitedep +sydtestPVP ok

version bump matches the API change (PVP)

Dependencies added: cryptonite, sydtest

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−0
• README.md +38/−5
• bench/Main.hs +266/−31
• cbits/keccak-example.c +49/−0
• cbits/keccak.c +145/−0
• cbits/keccak.h +30/−0
• hashes.cabal +83/−10
• src/Data/Hash/Blake2.hs +31/−0
• src/Data/Hash/Class/Mutable.hs +99/−0
• src/Data/Hash/Class/Mutable/Internal.hs +106/−0
• src/Data/Hash/Class/Mutable/Salted.hs +101/−0
• src/Data/Hash/Class/Pure.hs +94/−0
• src/Data/Hash/Class/Pure/Internal.hs +103/−0
• src/Data/Hash/Class/Pure/Salted.hs +83/−0
• src/Data/Hash/FNV1.hs +318/−32
• src/Data/Hash/FNV1/Salted.hs +90/−0
• src/Data/Hash/Internal/OpenSSL.hs +455/−0
• src/Data/Hash/Internal/Utils.hs +27/−0
• src/Data/Hash/Keccak.hs +39/−0
• src/Data/Hash/SHA2.hs +30/−0
• src/Data/Hash/SHA3.hs +30/−0
• src/Data/Hash/SipHash.hs +239/−124
• src/Data/Hash/Utils.hs +0/−144
• test/Cryptonite.hs +166/−0
• test/Main.hs +20/−6
• test/Test/Data/Hash/Class/Pure.hs +115/−0
• test/Test/Data/Hash/FNV1.hs +89/−32
• test/Test/Data/Hash/SipHash.hs +14/−9
• test/Test/Data/Hash/Utils.hs +0/−78

@@ -1,5 +1,19 @@ # Revision history for the hashes package +## 0.2.0.0 -- 2021-10-20++Breaking changes:++*   Add Class based interfaces for hash functions with pure and mutable+    contexts.+*   Support incremental hashing.+*   Provide type classes for hash functions with salt / key.+*   Add utility functions for hashing `ByteString`s.++Other changes:++*   Provide cryptographic hash functions from OpenSSL.+ ## 0.1.0.1 -- 2021-09-30  *   Support building with GHC-9.2.0-rc1

@@ -1,8 +1,41 @@-Haskell implementation of various non-cryptographic hash functions.+Haskell implementation of various hash functions. -The current version includes+## Available Hash functions -*  SipHash-*  FNV1 (64 bit and 32 bit)-*  FNV1a (64 bit and 32 bit)+### Native Haskell Implementations++*   SipHash+    *   SipHash-2-4+    *   SipHash-1-3+    *   SipHash-4-8+    *   SipHash-c-d (c rounds per block and d finalization rounds)+*   FNV1 (64 bit, 32 bit, and host word size)+*   FNV1a (64 bit, 32 bit, and host word size)++## Linked from OpenSSL++The following hash functions are available with the package is build with+`-f+with-openssl`, which is the default.++A version of OpenSSL of at least version 1.1 must be available on the system at+a location for Cabal/GHC can find it.++*   SHA2+    *   SHA2-224+    *   SHA2-256+    *   SHA2-384+    *   SHA2-512+    *   SHA2-512_224 (SHA512 truncated to 224 bits)+    *   SHA2-512_256 (SHA512 truncated to 256 bits)+*   SHA3+    *   SHA3_224+    *   SHA3_256+    *   SHA3_384+    *   SHA3_512+    *   SHAKE-128+    *   SHAKE-256+*   BLAKE2+    *   BLAKE2s256+    *   BLAKE2b512+*   KECCAK-256 (cf. comment in [Data.Hash.Keccak](https://github.com/larskuhtz/hs-hashes/blob/main/src/Data/Hash/Keccak.hs)) 

@@ -1,5 +1,8 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}  -- | -- Module: Main@@ -12,56 +15,129 @@ ( main ) where +import Control.Monad+ import Criterion import Criterion.Main +#if defined(BENCHMARK_CRYPTONITE) import qualified Data.ByteArray as BA import qualified Data.ByteArray.Hash as BA+import qualified Crypto.Hash as C+#endif import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString.Short as BS import Data.Word  import GHC.Ptr -import Test.QuickCheck+import System.IO.Unsafe  -- internal modules -import qualified Data.Hash.SipHash as H-import qualified Data.Hash.FNV1 as H+import qualified Data.Hash.SipHash as SH+import qualified Data.Hash.FNV1 as FH +#if defined(WITH_OPENSSL)+import qualified Data.Hash.SHA3 as SHA3+import qualified Data.Hash.SHA2 as SHA2+import qualified Data.Hash.Blake2 as BLAKE2+import qualified Data.Hash.Keccak as K+#endif+ -- -------------------------------------------------------------------------- -- -- Main  main :: IO () main = do-    putStrLn "prop_sip"-    quickCheck prop_sip-    putStrLn "prop_fnv1a"-    quickCheck prop_fnv1a-    putStrLn "prop_fnv1aPrimitive"-    quickCheck prop_fnv1aPrimitive     defaultMain-        [ bgroup "sipHash"-            [ sipBench "memory" (memorySipHash 17 17)-            , sipBench "internal" (H.hashByteString $ H.sipHash24 17 17)-            ]-        , bgroup "fnv1aHash"-            [ fnv1aBench "memory" memoryFnv1a-            , fnv1aBench "internal" (H.hashByteString H.fnv1a_64)-            , fnv1aBench "primitive" primitiveFnv1a-            ]+        [ bgroup "sipHash" $ []+            <> [sipBench "internal" (internalSipHash 17 17)]+#if defined(BENCHMARK_CRYPTONITE)+            <> [sipBench "memory" (memorySipHash 17 17)]+#endif++        , bgroup "fnv1aHash" $ []+            <> [fnv1aBench "internal" internalFnv1a]+            <> [fnv1aBench "primitive" primitiveFnv1a]+#if defined(BENCHMARK_CRYPTONITE)+            <> [fnv1aBench "memory" memoryFnv1a]+#endif++        , bgroup "Sha2_256" $ []+#if defined(WITH_OPENSSL)+            <> [sha2_256Bench "openssl" sha2_256Ssl]+#endif+#if defined(BENCHMARK_CRYPTONITE)+            <> [sha2_256Bench "cryptonite" cryptoniteSha2_256]+#endif++        , bgroup "Sha2_512" $ []+#if defined(WITH_OPENSSL)+            <> [sha2_512Bench "openssl" sha2_512Ssl]+#endif+#if defined(BENCHMARK_CRYPTONITE)+            <> [sha2_512Bench "cryptonite" cryptoniteSha2_512]+#endif++        , bgroup "Sha3_256" $ []+#if defined(WITH_OPENSSL)+            <> [sha3_256Bench "openssl" sha3_256Ssl]+#endif+#if defined(BENCHMARK_CRYPTONITE)+            <> [sha3_256Bench "cryptonite" cryptoniteSha3_256]+#endif++        , bgroup "Sha3_512" $ []+#if defined(WITH_OPENSSL)+            <> [sha3_512Bench "openssl" sha3_512Ssl]+#endif+#if defined(BENCHMARK_CRYPTONITE)+            <> [sha3_512Bench "cryptonite" cryptoniteSha3_512]+#endif++        , bgroup "keccak256" $ []+#if defined(WITH_OPENSSL)+            <> [keccakBench "openssl" keccak256Ssl]+#endif+#if defined(BENCHMARK_CRYPTONITE)+            <> [keccakBench "cryptonite" cryptoniteKeccak256]+#endif++        , bgroup "blake2s256" $ []+#if defined(WITH_OPENSSL)+            <> [blake2s256Bench "openssl" blake2s256Ssl]+#endif+#if defined(BENCHMARK_CRYPTONITE)+            <> [blake2s256Bench "cryptonite" cryptoniteBlake2s256]+#endif++        , bgroup "blake2b512" $ []+#if defined(WITH_OPENSSL)+            <> [ blake2b512Bench "openssl" blake2b512Ssl ]+#endif+#if defined(BENCHMARK_CRYPTONITE)+            <> [ blake2b512Bench "cryptonite" cryptoniteBlake2b512 ]+#endif         ]  -- -------------------------------------------------------------------------- -- -- SipHash +#if defined(BENCHMARK_CRYPTONITE) memorySipHash :: BA.ByteArrayAccess p => Word64 -> Word64 -> p -> Word64-memorySipHash w0 w1 x = let BA.SipHash r = BA.sipHash (BA.SipKey w0 w1) x in r+memorySipHash w0 w1 x = r+  where+    BA.SipHash r = BA.sipHash (BA.SipKey w0 w1) x {-# INLINE memorySipHash #-}+#endif -prop_sip :: Word64 -> Word64 -> [Word8] -> Property-prop_sip w0 w1 b =-    memorySipHash w0 w1 (B.pack b) === H.hashByteString (H.sipHash24 w0 w1) (B.pack b)+internalSipHash :: Word64 -> Word64 -> B.ByteString -> Word64+internalSipHash w0 w1 x = r+  where+    SH.SipHash r = SH.hashByteString @(SH.SipHash 2 4) (SH.SipHashKey w0 w1) x+{-# INLINE internalSipHash #-}  sipBench :: String -> (B.ByteString -> Word64) -> Benchmark sipBench l f = bgroup l $ go <$> benchStrings@@ -76,23 +152,182 @@ -- -------------------------------------------------------------------------- -- -- Fvn1Hash +#if defined(BENCHMARK_CRYPTONITE) memoryFnv1a :: B.ByteString -> Word64-memoryFnv1a b = let BA.FnvHash64 h = BA.fnv1a_64Hash b in h+memoryFnv1a b = h+  where+    BA.FnvHash64 h = BA.fnv1a_64Hash b {-# INLINE memoryFnv1a #-}+#endif +internalFnv1a :: B.ByteString -> Word64+internalFnv1a b = r+  where+    FH.Fnv1a64Hash r = FH.hashByteString @FH.Fnv1a64Hash b+{-# INLINE internalFnv1a #-}+ primitiveFnv1a :: B.ByteString -> Word64-primitiveFnv1a = H.hashByteString $ \(Ptr addr) n ->-    fromIntegral <$> H.fnv1a addr n+primitiveFnv1a b = unsafeDupablePerformIO $+    B.unsafeUseAsCStringLen b $ \(addr, n) ->+        fromIntegral <$!> FH.fnv1a_host (castPtr addr) n {-# INLINE primitiveFnv1a #-} -prop_fnv1a :: [Word8] -> Property-prop_fnv1a b = memoryFnv1a (B.pack b) === H.hashByteString H.fnv1a_64 (B.pack b)--prop_fnv1aPrimitive :: [Word8] -> Property-prop_fnv1aPrimitive b = primitiveFnv1a (B.pack b) === H.hashByteString H.fnv1a_64 (B.pack b)- fnv1aBench :: String -> (B.ByteString -> Word64) -> Benchmark fnv1aBench l f = bgroup l $ go <$> benchStrings+  where+    go i = bench (show (B.length i)) $ whnf f i++-- -------------------------------------------------------------------------- --+-- SHA3 256++#if defined(WITH_OPENSSL)+sha3_256Ssl :: B.ByteString -> BS.ShortByteString+sha3_256Ssl b = r+  where+    SHA3.Sha3_256  r = SHA3.hashByteString @SHA3.Sha3_256 b+{-# INLINE sha3_256Ssl #-}+#endif++#if defined(BENCHMARK_CRYPTONITE)+cryptoniteSha3_256 :: B.ByteString -> BS.ShortByteString+cryptoniteSha3_256 b = BS.toShort $ BA.convert $! C.hash @_ @C.SHA3_256 b+{-# INLINE cryptoniteSha3_256 #-}+#endif++sha3_256Bench :: String -> (B.ByteString -> BS.ShortByteString) -> Benchmark+sha3_256Bench l f = bgroup l $ go <$> benchStrings+  where+    go i = bench (show (B.length i)) $ whnf f i++-- -------------------------------------------------------------------------- --+-- SHA3 512++#if defined(WITH_OPENSSL)+sha3_512Ssl :: B.ByteString -> BS.ShortByteString+sha3_512Ssl b = r+  where+    SHA3.Sha3_512  r = SHA3.hashByteString @SHA3.Sha3_512 b+{-# INLINE sha3_512Ssl #-}+#endif++#if defined(BENCHMARK_CRYPTONITE)+cryptoniteSha3_512 :: B.ByteString -> BS.ShortByteString+cryptoniteSha3_512 b = BS.toShort $ BA.convert $! C.hash @_ @C.SHA3_512 b+{-# INLINE cryptoniteSha3_512 #-}+#endif++sha3_512Bench :: String -> (B.ByteString -> BS.ShortByteString) -> Benchmark+sha3_512Bench l f = bgroup l $ go <$> benchStrings+  where+    go i = bench (show (B.length i)) $ whnf f i++-- -------------------------------------------------------------------------- --+-- SHA2_256++#if defined(WITH_OPENSSL)+sha2_256Ssl :: B.ByteString -> BS.ShortByteString+sha2_256Ssl b = r+  where+    SHA2.Sha2_256  r = SHA3.hashByteString @SHA2.Sha2_256 b+{-# INLINE sha2_256Ssl #-}+#endif++#if defined(BENCHMARK_CRYPTONITE)+cryptoniteSha2_256 :: B.ByteString -> BS.ShortByteString+cryptoniteSha2_256 b = BS.toShort $ BA.convert $! C.hash @_ @C.SHA256 b+{-# INLINE cryptoniteSha2_256 #-}+#endif++sha2_256Bench :: String -> (B.ByteString -> BS.ShortByteString) -> Benchmark+sha2_256Bench l f = bgroup l $ go <$> benchStrings+  where+    go i = bench (show (B.length i)) $ whnf f i++-- -------------------------------------------------------------------------- --+-- SHA2_512++#if defined(WITH_OPENSSL)+sha2_512Ssl :: B.ByteString -> BS.ShortByteString+sha2_512Ssl b = r+  where+    SHA2.Sha2_512  r = SHA3.hashByteString @SHA2.Sha2_512 b+{-# INLINE sha2_512Ssl #-}+#endif++#if defined(BENCHMARK_CRYPTONITE)+cryptoniteSha2_512 :: B.ByteString -> BS.ShortByteString+cryptoniteSha2_512 b = BS.toShort $ BA.convert $! C.hash @_ @C.SHA512 b+{-# INLINE cryptoniteSha2_512 #-}+#endif++sha2_512Bench :: String -> (B.ByteString -> BS.ShortByteString) -> Benchmark+sha2_512Bench l f = bgroup l $ go <$> benchStrings+  where+    go i = bench (show (B.length i)) $ whnf f i++-- -------------------------------------------------------------------------- --+-- BLAKE2B512++#if defined(WITH_OPENSSL)+blake2b512Ssl :: B.ByteString -> BS.ShortByteString+blake2b512Ssl b = r+  where+    BLAKE2.Blake2b512  r = BLAKE2.hashByteString @BLAKE2.Blake2b512 b+{-# INLINE blake2b512Ssl #-}+#endif++#if defined(BENCHMARK_CRYPTONITE)+cryptoniteBlake2b512 :: B.ByteString -> BS.ShortByteString+cryptoniteBlake2b512 b = BS.toShort $ BA.convert $! C.hash @_ @C.Blake2b_512 b+{-# INLINE cryptoniteBlake2b512 #-}+#endif++blake2b512Bench :: String -> (B.ByteString -> BS.ShortByteString) -> Benchmark+blake2b512Bench l f = bgroup l $ go <$> benchStrings+  where+    go i = bench (show (B.length i)) $ whnf f i++-- -------------------------------------------------------------------------- --+-- BLAKE2S256++#if defined(WITH_OPENSSL)+blake2s256Ssl :: B.ByteString -> BS.ShortByteString+blake2s256Ssl b = r+  where+    BLAKE2.Blake2s256  r = BLAKE2.hashByteString @BLAKE2.Blake2s256 b+{-# INLINE blake2s256Ssl #-}+#endif++#if defined(BENCHMARK_CRYPTONITE)+cryptoniteBlake2s256 :: B.ByteString -> BS.ShortByteString+cryptoniteBlake2s256 b = BS.toShort $ BA.convert $! C.hash @_ @C.Blake2s_256 b+{-# INLINE cryptoniteBlake2s256 #-}+#endif++blake2s256Bench :: String -> (B.ByteString -> BS.ShortByteString) -> Benchmark+blake2s256Bench l f = bgroup l $ go <$> benchStrings+  where+    go i = bench (show (B.length i)) $ whnf f i++-- -------------------------------------------------------------------------- --+-- Keccak 256++#if defined(WITH_OPENSSL)+keccak256Ssl :: B.ByteString -> BS.ShortByteString+keccak256Ssl b = r+  where+    K.Keccak256  r = K.hashByteString @K.Keccak256 b+{-# INLINE keccak256Ssl #-}+#endif++#if defined(BENCHMARK_CRYPTONITE)+cryptoniteKeccak256 :: B.ByteString -> BS.ShortByteString+cryptoniteKeccak256 b = BS.toShort $ BA.convert $! C.hash @_ @C.Keccak_256 b+{-# INLINE cryptoniteKeccak256 #-}+#endif++keccakBench :: String -> (B.ByteString -> BS.ShortByteString) -> Benchmark+keccakBench l f = bgroup l $ go <$> benchStrings   where     go i = bench (show (B.length i)) $ whnf f i 

@@ -0,0 +1,49 @@+#include <string.h>+#include "keccak.h"++/* *************************************************************************** */+/* Generic Tools */++#define CHECKED(f)             \+    if (! (f)) {               \+        ok = 0; goto finally; \+    }++/* *************************************************************************** */+/* Digests */++typedef unsigned char MD_VALUE[32];+typedef char MD_VALUE_HEX[32*2+1];++void digestToHex(char *result, const unsigned char *md_value) {+    int i;+    for (i = 0; i < 32; i++) {+        sprintf(&result[2*i], "%02x", (uint8_t) (md_value[i]));+    }+}++const char *msg = "testing";+const char *expected = "5f16f4c7f149ac4f9510d9cf8cf384038ad348b3bcdc01915f95de12df9d1b02";++/* *************************************************************************** */+/* Main */++int main()+{+    int ok = 1;+    MD_VALUE md_value;+    MD_VALUE_HEX result;+    KECCAK256_CTX *ctx = NULL;++    CHECKED(ctx = keccak256_newctx());+    CHECKED(keccak256_init(ctx));+    CHECKED(keccak256_update(ctx, msg, strlen(msg)));+    CHECKED(keccak256_final(ctx, md_value));+    digestToHex(result, md_value);+    printf("Keccak-256 digest: %s\n", result);+    printf("expected         : %s\n", expected);++finally:+    if (ctx) keccak256_freectx(ctx);+    return ! ok;+}

@@ -0,0 +1,145 @@+#include <openssl/evp.h>+#include "keccak.h"++/* *************************************************************************** */+/* OpenSSL Master */++/*+int main()+{+    int ok = 1;+    unsigned int md_len = 0;+    MD_VALUE md_value;+    MD_VALUE_HEX result;+    EVP_MD *md;+    EVP_MD_CTX *ctx;++    CHECKED(md = EVP_get_digestbyname("KECCAK-256"));+    CHECKED(ctx = EVP_MD_CTX_new());+    CHECKED(EVP_DigestInit(ctx, md));+    CHECKED(EVP_DigestUpdate(ctx, msg, strlen(msg)));+    CHECKED(EVP_DigestFinal(ctx, md_value, &md_len));++    // Print Digest+    digestToHex(result, md_value);+    printf("Keccak-256 digest: %s\n", result);+    printf("expected         : %s\n", expected);++finally:+    if (ctx) keccak256_freectx(ctx);+    return ! ok;+}+*/++#if OPENSSL_VERSION_NUMBER >= 0x30000000L+/* *************************************************************************** */+/* KECCAK-256 for OpenSSL 3.0 */++typedef struct keccak1600_ctx_st KECCAK1600_CTX;+typedef KECCAK1600_CTX KECCAK256_CTX;++extern const OSSL_DISPATCH ossl_sha3_256_functions[];+extern int ossl_sha3_init(KECCAK1600_CTX *ctx, unsigned char pad, size_t bitlen);++typedef void (*VoidFunPtr) (void);++VoidFunPtr dispatch(int fn_id) {+    const OSSL_DISPATCH *fns = ossl_sha3_256_functions;+    for (; fns->function_id != 0; fns++) {+        if (fns->function_id == fn_id) {+            return fns->function;+        }+    }+    return NULL;+}++KECCAK256_CTX *keccak256_newctx()+{+    KECCAK256_CTX * ctx = ((OSSL_FUNC_digest_newctx_fn *) dispatch(OSSL_FUNC_DIGEST_NEWCTX))(NULL);++    // this has already be called once by the dispatch function. Here we update the pad character+    if (ctx) ossl_sha3_init(ctx, '\x01', 256);+    return ctx;+}++int keccak256_init(KECCAK256_CTX *ctx) {+    return ((OSSL_FUNC_digest_init_fn *) dispatch(OSSL_FUNC_DIGEST_INIT))(ctx, NULL);+}++int keccak256_update(KECCAK256_CTX *ctx, const void *p, size_t l)+{+    return ((OSSL_FUNC_digest_update_fn *) dispatch(OSSL_FUNC_DIGEST_UPDATE))(ctx, p, l);+}++int keccak256_final(KECCAK256_CTX *ctx, unsigned char *md)+{+    size_t l;+    return ((OSSL_FUNC_digest_final_fn *) dispatch(OSSL_FUNC_DIGEST_FINAL))(ctx, md, &l, 32);+}++void keccak256_freectx(KECCAK256_CTX *ctx)+{+    return ((OSSL_FUNC_digest_freectx_fn *) dispatch(OSSL_FUNC_DIGEST_FREECTX))(ctx);+}++#elif OPENSSL_VERSION_NUMBER >= 0x10100000L+/* *************************************************************************** */+/* OpenSSL 1.1 */++/* The computation of the magic offset is base on the keccak_st structure in+ * OpenSSL-1.1.+ *+ * Assuming conventional alignment, the bytes offset is+ *+ * sizeof(uint64_t) * 40 + size_of(size_t) * 3 + (1600 / 8 - 32)+ *+ * On a 64bit platform this number is 392+ */++// struct keccak_st {+//     uint64_t A[5][5];+//     size_t block_size;          /* cached ctx->digest->block_size */+//     size_t md_size;             /* output length, variable in XOF */+//     size_t bufsz;               /* used bytes in below buffer */+//     unsigned char buf[KECCAK1600_WIDTH / 8 - 32];+//     unsigned char pad;+// };++typedef EVP_MD_CTX KECCAK256_CTX;++KECCAK256_CTX *keccak256_newctx()+{+    return EVP_MD_CTX_new();+}++int keccak256_init(KECCAK256_CTX *ctx) {+    int ok = 1;+    const EVP_MD *md = NULL;+    int padByteOffset = 25 * sizeof(uint64_t) + 3 * sizeof(size_t) + 1600/8 - 32;+    CHECKED(md = EVP_sha3_256());+    CHECKED(EVP_DigestInit(ctx, md));++    // MAGIC (set padding char to 0x1)+    ((uint8_t *) EVP_MD_CTX_md_data(ctx))[padByteOffset] = 0x01;+finally:+    return ok;+}++int keccak256_update(KECCAK256_CTX *ctx, const void *p, size_t l)+{+    return EVP_DigestUpdate(ctx, p, l);+}++int keccak256_final(KECCAK256_CTX *ctx, unsigned char *md)+{+    unsigned int l;+    return EVP_DigestFinal(ctx, md, &l);+}++void keccak256_freectx(KECCAK256_CTX *ctx)+{+    return EVP_MD_CTX_free(ctx);+}++#endif+

@@ -0,0 +1,30 @@+#include <openssl/evp.h>++/* *************************************************************************** */+/* Generic Tools */++#define CHECKED(f)            \+    if (! (f)) {              \+        ok = 0; goto finally; \+    }++/* *************************************************************************** */+/* Keccak-256 */++#if OPENSSL_VERSION_NUMBER >= 0x31000000L++#elif OPENSSL_VERSION_NUMBER >= 0x30000000L+typedef struct keccak1600_ctx_st KECCAK1600_CTX;+typedef KECCAK1600_CTX KECCAK256_CTX;++#elif OPENSSL_VERSION_NUMBER >= 0x10100000L+typedef EVP_MD_CTX KECCAK256_CTX;++#endif++KECCAK256_CTX *keccak256_newctx();+int keccak256_init(KECCAK256_CTX *ctx);+int keccak256_update(KECCAK256_CTX *ctx, const void *p, size_t l);+int keccak256_final(KECCAK256_CTX *ctx, unsigned char *md);+void keccak256_freectx(KECCAK256_CTX *ctx);+

@@ -1,8 +1,8 @@ cabal-version: 2.4 name: hashes-version: 0.1.0.1+version: 0.2.0.0 synopsis: Hash functions-Description: Efficient implementation of non-cryptographic hash functions+Description: Efficient implementations of hash functions homepage: https://github.com/larskuhtz/hs-hashes bug-reports: https://github.com/larskuhtz/hs-hashes/issues license: MIT@@ -18,30 +18,90 @@ extra-source-files:     README.md     CHANGELOG.md+    cbits/keccak.h+    cbits/keccak.c+    cbits/keccak-example.c  source-repository head     type: git     location: https://github.com/larskuhtz/hs-hashes.git +flag with-openssl+    description:+        Include cryptograph hash functions from openssl. Requires that openssl+        is installed in the system at a location where cabal can find it.+    default: True+    manual: True++flag benchmark-cryptonite+    description: Include implementations from the cryptonite package in benchmarks+    default: False+    manual: True++flag test-cryptonite+    description: Test compatibility with implementations of hash functions in cryptonite+    default: False+    manual: True++flag openssl-use-pkg-config+    description: Use pkg-config to find OpenSSL (macOS and linux only).+    default: False+    manual: True++common openssl-common+    if flag(with-openssl)+        c-sources:+            cbits/keccak.h+            cbits/keccak.c+        cpp-options: -DWITH_OPENSSL=1+        include-dirs:+            /usr/local/opt/openssl@3/include+            /usr/local/opt/openssl/include+            /opt/local/include+        extra-lib-dirs:+            /usr/local/opt/openssl@3/lib/+            /usr/local/opt/openssl/lib/+            /opt/local/lib+        if flag(openssl-use-pkg-config)+            pkgconfig-depends: libcrypto+        else+            extra-Libraries: crypto+ library+    import: openssl-common     hs-source-dirs: src     default-language: Haskell2010     exposed-modules:-        Data.Hash.SipHash+        Data.Hash.Class.Mutable+        Data.Hash.Class.Mutable.Internal+        Data.Hash.Class.Mutable.Salted+        Data.Hash.Class.Pure+        Data.Hash.Class.Pure.Internal+        Data.Hash.Class.Pure.Salted         Data.Hash.FNV1-        Data.Hash.Utils+        Data.Hash.FNV1.Salted+        Data.Hash.Internal.Utils+        Data.Hash.SipHash+    if flag(with-openssl)+        exposed-modules:+            Data.Hash.Blake2+            Data.Hash.Internal.OpenSSL+            Data.Hash.Keccak+            Data.Hash.SHA2+            Data.Hash.SHA3     ghc-options:-        -Wall+        -mbmi2+        -msse4.2     build-depends:         , base >=4.11 && <5         , bytestring >=0.10  test-suite tests+    import: openssl-common     type: exitcode-stdio-1.0     hs-source-dirs: test     default-language: Haskell2010     ghc-options:-        -Wall         -rtsopts         -threaded         -with-rtsopts=-N@@ -49,7 +109,7 @@     other-modules:         Test.Data.Hash.SipHash         Test.Data.Hash.FNV1-        Test.Data.Hash.Utils+        Test.Data.Hash.Class.Pure     build-depends:         -- internal         , hashes@@ -57,14 +117,23 @@         , QuickCheck >= 2.13         , base >=4.11 && <5         , bytestring >=0.10+        , sydtest >=0.4 +    if flag(test-cryptonite)+        build-depends:+            , memory >=0.14+            , cryptonite >=0.29+        cpp-options: -DTEST_CRYPTONITE=1+        other-modules:+            Cryptonite+ benchmark benchmarks+    import: openssl-common     type: exitcode-stdio-1.0     hs-source-dirs: bench     main-is: Main.hs     default-language: Haskell2010     ghc-options:-        -Wall         -rtsopts         -threaded         -with-rtsopts=-N@@ -75,9 +144,13 @@         , hashes          -- external-        , QuickCheck >= 2.13         , base >=4.10 && <5         , bytestring >=0.10         , criterion >= 1.5-        , memory >=0.14++    if flag(benchmark-cryptonite)+        build-depends:+            , memory >=0.14+            , cryptonite >=0.29+        cpp-options: -DBENCHMARK_CRYPTONITE=1 

@@ -0,0 +1,31 @@+-- |+-- Module: Data.Hash.Blake2+-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>+-- License: MIT+-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>+-- Stability: experimental+--+-- Blake2 Hash Functions+--+module Data.Hash.Blake2+(+-- * Blake2+--+-- | BLAKE2 is an improved version of BLAKE, which was submitted to the NIST SHA-3+-- algorithm competition. The BLAKE2s and BLAKE2b algorithms are described in+-- RFC 7693.+--+-- While the BLAKE2b and BLAKE2s algorithms supports a variable length digest,+-- this implementation outputs a digest of a fixed length (the maximum length+-- supported), which is 512-bits for BLAKE2b and 256-bits for BLAKE2s.++  Blake2b512(..)+, Blake2s256(..)++, module Data.Hash.Class.Mutable+) where++import Data.Hash.Class.Mutable+import Data.Hash.Internal.OpenSSL++

@@ -0,0 +1,99 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module: Data.Hash.Class.Mutable+-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>+-- License: MIT+-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>+-- Stability: experimental+--+-- Class of Salted Pure Hashes+--+module Data.Hash.Class.Mutable+( Hash(..)+, IncrementalHash(..)++, hashPtr+, hashStorable+, hashByteString+, hashByteStringLazy+, hashShortByteString+, hashByteArray++-- * Incremental Hashing+, updateByteString+, updateByteStringLazy+, updateShortByteString+, updateStorable+, updateByteArray+) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Short as BS+import Data.Word++import Foreign.Ptr+import Foreign.Storable++import GHC.Exts+import GHC.IO++-- internal modules++import Data.Hash.Class.Mutable.Internal++-- -------------------------------------------------------------------------- --+-- Class of Salted Pure Hashes++class IncrementalHash a => Hash a where+    initialize :: IO (Context a)++-- -------------------------------------------------------------------------- --+-- Hash Functions++hashPtr :: forall a . Hash a => Ptr Word8 -> Int -> IO a+hashPtr p n = do+    ctx <- initialize @a+    update @a ctx p n+    finalize ctx+{-# INLINE hashPtr #-}++hashByteString :: forall a . Hash a => B.ByteString -> a+hashByteString b = unsafeDupablePerformIO $ do+        ctx <- initialize @a+        updateByteString @a ctx b+        finalize ctx+{-# INLINE hashByteString #-}++hashByteStringLazy :: forall a . Hash a => BL.ByteString -> a+hashByteStringLazy b = unsafeDupablePerformIO $ do+        ctx <- initialize @a+        updateByteStringLazy @a ctx b+        finalize ctx+{-# INLINE hashByteStringLazy #-}++hashShortByteString :: forall a . Hash a => BS.ShortByteString -> IO a+hashShortByteString b = do+        ctx <- initialize @a+        updateShortByteString @a ctx b+        finalize ctx+{-# INLINE hashShortByteString #-}++hashStorable :: forall a b . Hash a => Storable b => b -> IO a+hashStorable b = do+        ctx <- initialize @a+        updateStorable @a ctx b+        finalize ctx+{-# INLINE hashStorable #-}++hashByteArray :: forall a . Hash a => ByteArray# -> IO a+hashByteArray b = do+        ctx <- initialize @a+        updateByteArray @a ctx b+        finalize ctx+{-# INLINE hashByteArray #-}+

@@ -0,0 +1,106 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module: Data.Hash.Class.Mutable.Internal+-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>+-- License: MIT+-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>+-- Stability: experimental+--+-- Incremental Mutable Hashes+--+module Data.Hash.Class.Mutable.Internal+( IncrementalHash(..)+, updateByteString+, updateByteStringLazy+, updateShortByteString+, updateStorable+, updateByteArray+) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Short as BS+import qualified Data.ByteString.Unsafe as B+import Data.Kind+import Data.Word++import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.Storable++import GHC.Exts+import GHC.IO++-- -------------------------------------------------------------------------- --+-- Incremental Mutable Hashes++class IncrementalHash a where+    type Context a :: Type+    update :: Context a -> Ptr Word8 -> Int -> IO ()+    finalize :: Context a -> IO a++updateByteString+    :: forall a+    . IncrementalHash a+    => Context a+    -> B.ByteString+    -> IO ()+updateByteString ctx b = B.unsafeUseAsCStringLen b $ \(!p, !l) ->+    update @a ctx (castPtr p) l+{-# INLINE updateByteString #-}++updateByteStringLazy+    :: forall a+    . IncrementalHash a+    => Context a+    -> BL.ByteString+    -> IO ()+updateByteStringLazy ctx = mapM_ (updateByteString @a ctx) . BL.toChunks+{-# INLINE updateByteStringLazy #-}++updateShortByteString+    :: forall a+    . IncrementalHash a+    => Context a+    -> BS.ShortByteString+    -> IO ()+updateShortByteString ctx b = BS.useAsCStringLen b $ \(!p, !l) ->+    update @a ctx (castPtr p) l+{-# INLINE updateShortByteString #-}++updateStorable+    :: forall a b+    . IncrementalHash a+    => Storable b+    => Context a+    -> b+    -> IO ()+updateStorable ctx b = with b $ \p -> update @a ctx (castPtr p) (sizeOf b)+{-# INLINE updateStorable #-}++updateByteArray+    :: forall a+    . IncrementalHash a+    => Context a+    -> ByteArray#+    -> IO ()+updateByteArray ctx a# = case isByteArrayPinned# a# of+    -- Pinned ByteArray+    1# -> update @a ctx (Ptr (byteArrayContents# a#)) (I# size#)++    -- Unpinned ByteArray, copy content to newly allocated pinned ByteArray+    _ -> allocaBytes (I# size#) $ \ptr@(Ptr addr#) -> IO $ \s0 ->+        case copyByteArrayToAddr# a# 0# addr# size# s0 of+            s1 -> case update @a ctx ptr (I# size#) of+                IO run -> run s1+  where+    size# = sizeofByteArray# a#+{-# INLINE updateByteArray #-}+

@@ -0,0 +1,101 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module: Data.Hash.Class.Mutable.Salted+-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>+-- License: MIT+-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>+-- Stability: experimental+--+-- Class of Salted Mutable Hashes+--+module Data.Hash.Class.Mutable.Salted+( Hash(..)++, hashPtr+, hashStorable+, hashByteString+, hashByteStringLazy+, hashShortByteString+, hashByteArray++-- * Incremental Hashing+, updateByteString+, updateByteStringLazy+, updateShortByteString+, updateStorable+, updateByteArray+) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Short as BS+import Data.Kind+import Data.Word++import Foreign.Ptr+import Foreign.Storable++import GHC.Exts+import GHC.IO++-- internal modules++import Data.Hash.Class.Mutable.Internal++-- -------------------------------------------------------------------------- --+-- Class of Salted Mutable Hashes++class IncrementalHash a => Hash a where+    type Salt a :: Type+    initialize :: Salt a -> IO (Context a)++-- -------------------------------------------------------------------------- --+-- Hash Functions++hashPtr :: forall a . Hash a => Salt a -> Ptr Word8 -> Int -> IO a+hashPtr k p n = do+    ctx <- initialize @a k+    update @a ctx p n+    finalize ctx+{-# INLINE hashPtr #-}++hashByteString :: forall a . Hash a => Salt a -> B.ByteString -> a+hashByteString k b = unsafeDupablePerformIO $ do+        ctx <- initialize @a k+        updateByteString @a ctx b+        finalize ctx+{-# INLINE hashByteString #-}++hashByteStringLazy :: forall a . Hash a => Salt a -> BL.ByteString -> a+hashByteStringLazy k b = unsafeDupablePerformIO $ do+        ctx <- initialize @a k+        updateByteStringLazy @a ctx b+        finalize ctx+{-# INLINE hashByteStringLazy #-}++hashShortByteString :: forall a . Hash a => Salt a -> BS.ShortByteString -> IO a+hashShortByteString k b = do+        ctx <- initialize @a k+        updateShortByteString @a ctx b+        finalize ctx+{-# INLINE hashShortByteString #-}++hashStorable :: forall a b . Hash a => Storable b => Salt a -> b -> IO a+hashStorable k b = do+        ctx <- initialize @a k+        updateStorable @a ctx b+        finalize ctx+{-# INLINE hashStorable #-}++hashByteArray :: forall a . Hash a => Salt a -> ByteArray# -> IO a+hashByteArray k b = do+        ctx <- initialize @a k+        updateByteArray @a ctx b+        finalize ctx+{-# INLINE hashByteArray #-}+

@@ -0,0 +1,94 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module: Data.Hash.Class.Pure+-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>+-- License: MIT+-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>+-- Stability: experimental+--+-- Hashes with pure context+--+module Data.Hash.Class.Pure+( Hash(..)+, IncrementalHash(..)++, hashPtr+, hashStorable+, hashByteString+, hashByteStringLazy+, hashShortByteString+, hashByteArray++-- * Incremental Hashing+, updateByteString+, updateByteStringLazy+, updateShortByteString+, updateStorable+, updateByteArray++-- * Utilities+, initializeWithSalt+) where++import Control.Monad++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Short as BS+import Data.Word++import Foreign.Ptr+import Foreign.Storable++import GHC.Exts++-- internal modules++import Data.Hash.Class.Pure.Internal++-- -------------------------------------------------------------------------- --+-- Class of Pure Hashes++class IncrementalHash a => Hash a where+    initialize :: Context a++-- -------------------------------------------------------------------------- --+-- hash Functions++hashPtr :: forall a. Hash a => Ptr Word8 -> Int -> IO a+hashPtr p n = finalize <$!> update @a (initialize @a) p n+{-# INLINE hashPtr #-}++hashByteString :: forall a . Hash a => B.ByteString -> a+hashByteString b = finalize $! updateByteString @a (initialize @a) b+{-# INLINE hashByteString #-}++hashByteStringLazy :: forall a . Hash a => BL.ByteString -> a+hashByteStringLazy b = finalize $! updateByteStringLazy @a (initialize @a) b+{-# INLINE hashByteStringLazy #-}++hashShortByteString :: forall a . Hash a => BS.ShortByteString -> a+hashShortByteString b = finalize $! updateShortByteString @a (initialize @a) b+{-# INLINE hashShortByteString #-}++hashStorable :: forall a b . Hash a => Storable b => b -> a+hashStorable b = finalize $! updateStorable @a (initialize @a) b+{-# INLINE hashStorable #-}++hashByteArray :: forall a . Hash a => ByteArray# -> a+hashByteArray b = finalize $! updateByteArray @a (initialize @a) b+{-# INLINE hashByteArray #-}++-- -------------------------------------------------------------------------- --+-- Utilities++-- | Utility function to initialize a hash with a salt+--+initializeWithSalt :: forall a s . Hash a => Storable s => s -> Context a+initializeWithSalt = updateStorable @a $ initialize @a+{-# INLINE initializeWithSalt #-}+

@@ -0,0 +1,103 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module: Data.Hash.Class.Pure.Internal+-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>+-- License: MIT+-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>+-- Stability: experimental+--+-- Incremental Pure Hashes+--+module Data.Hash.Class.Pure.Internal+( IncrementalHash(..)+, updateByteString+, updateByteStringLazy+, updateShortByteString+, updateStorable+, updateByteArray+) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Short as BS+import qualified Data.ByteString.Unsafe as B+import Data.Kind+import Data.Word++import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.Storable++import GHC.Exts+import GHC.IO++-- -------------------------------------------------------------------------- --+-- Incremental Pure Hashes++class IncrementalHash a where+    type Context a :: Type+    update :: Context a -> Ptr Word8 -> Int -> IO (Context a)+    finalize :: Context a -> a++updateByteString :: forall a . IncrementalHash a => Context a -> B.ByteString -> Context a+updateByteString !ctx !b = unsafeDupablePerformIO $!+    B.unsafeUseAsCStringLen b $ \(!p, !l) -> update @a ctx (castPtr p) l+{-# INLINE updateByteString #-}++updateByteStringLazy+    :: forall a+    . IncrementalHash a+    => Context a+    -> BL.ByteString+    -> Context a+updateByteStringLazy = BL.foldlChunks (updateByteString @a)+{-# INLINE updateByteStringLazy #-}++updateShortByteString+    :: forall a+    . IncrementalHash a+    => Context a+    -> BS.ShortByteString+    -> Context a+updateShortByteString !ctx b = unsafeDupablePerformIO $!+    BS.useAsCStringLen b $ \(!p, !l) -> update @a ctx (castPtr p) l+{-# INLINE updateShortByteString #-}++updateStorable+    :: forall a b+    . IncrementalHash a+    => Storable b+    => Context a+    -> b+    -> Context a+updateStorable !ctx b = unsafeDupablePerformIO $!+    with b $ \p -> update @a ctx (castPtr p) (sizeOf b)+{-# INLINE updateStorable #-}++updateByteArray+    :: forall a+    . IncrementalHash a+    => Context a+    -> ByteArray#+    -> Context a+updateByteArray ctx a# = unsafeDupablePerformIO $!+    case isByteArrayPinned# a# of+        -- Pinned ByteArray+        1# -> update @a ctx (Ptr (byteArrayContents# a#)) (I# size#)++        -- Unpinned ByteArray, copy content to newly allocated pinned ByteArray+        _ -> allocaBytes (I# size#) $ \ptr@(Ptr addr#) -> IO $ \s0 ->+            case copyByteArrayToAddr# a# 0# addr# size# s0 of+                s1 -> case update @a ctx ptr (I# size#) of+                    IO run -> run s1+  where+    size# = sizeofByteArray# a#+{-# INLINE updateByteArray #-}+

@@ -0,0 +1,83 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module: Data.Hash.Class.Pure.Salted+-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>+-- License: MIT+-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>+-- Stability: experimental+--+module Data.Hash.Class.Pure.Salted+( Hash(..)+, IncrementalHash(..)++, hashPtr+, hashStorable+, hashByteString+, hashByteStringLazy+, hashShortByteString+, hashByteArray++-- * Incremental Hashing+, updateByteString+, updateByteStringLazy+, updateShortByteString+, updateStorable+, updateByteArray+) where++import Control.Monad++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Short as BS+import Data.Kind+import Data.Word++import Foreign.Ptr+import Foreign.Storable++import GHC.Exts++-- internal modules++import Data.Hash.Class.Pure.Internal++-- -------------------------------------------------------------------------- --+-- Class of Pure Salted Hashes++class IncrementalHash a => Hash a where+    type Salt a :: Type+    initialize :: Salt a -> Context a++-- -------------------------------------------------------------------------- --+-- hash Functions++hashPtr :: forall a. Hash a => Salt a -> Ptr Word8 -> Int -> IO a+hashPtr k p n = finalize <$!> update @a (initialize @a k) p n+{-# INLINE hashPtr #-}++hashByteString :: forall a . Hash a => Salt a -> B.ByteString -> a+hashByteString k b = finalize $! updateByteString @a (initialize @a k) b+{-# INLINE hashByteString #-}++hashByteStringLazy :: forall a . Hash a => Salt a -> BL.ByteString -> a+hashByteStringLazy k b = finalize $! updateByteStringLazy @a (initialize @a k) b+{-# INLINE hashByteStringLazy #-}++hashShortByteString :: forall a . Hash a => Salt a -> BS.ShortByteString -> a+hashShortByteString k b = finalize $! updateShortByteString @a (initialize @a k) b+{-# INLINE hashShortByteString #-}++hashStorable :: forall a b . Hash a => Storable b => Salt a -> b -> a+hashStorable k b = finalize $! updateStorable @a (initialize @a k) b+{-# INLINE hashStorable #-}++hashByteArray :: forall a . Hash a => Salt a -> ByteArray# -> a+hashByteArray k b = finalize $! updateByteArray @a (initialize @a k) b+{-# INLINE hashByteArray #-}+

@@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-}  -- |@@ -16,34 +17,84 @@ -- module Data.Hash.FNV1 (--- * IO API (64 bit)+-- * Fnv1 64 bit+  Fnv164Hash(..)+, Fnv164Context+, fnv164Initialize+, fnv164Update+, fnv164Finalize+, fnv164 -  fnv1_64++-- * Fnv1a 64 bit+, Fnv1a64Hash(..)+, Fnv1a64Context+, fnv1a64Initialize+, fnv1a64Update+, fnv1a64Finalize+, fnv1a64++-- * Fnv1 32 bit+, Fnv132Hash(..)+, Fnv132Context+, fnv132Initialize+, fnv132Update+, fnv132Finalize+, fnv132++-- * Fnv1a 32 bit+, Fnv1a32Hash(..)+, Fnv1a32Context+, fnv1a32Initialize+, fnv1a32Update+, fnv1a32Finalize+, fnv1a32++-- * Fnv1 Host Wordsize+, Fnv1Hash(..)+, Fnv1Context+, fnv1Initialize+, fnv1Update+, fnv1Finalize+, fnv1++-- * Fnv1a Host Wordsize+, Fnv1aHash(..)+, Fnv1aContext+, fnv1aInitialize+, fnv1aUpdate+, fnv1aFinalize+, fnv1a++-- * Utils+, module Data.Hash.Class.Pure++-- * Low-Level+-- ** 64 bit++, fnv1_64 , fnv1_64_ , fnv1a_64 , fnv1a_64_ --- * 32 bit versions+-- ** 32 bit , fnv1_32 , fnv1_32_ , fnv1a_32 , fnv1a_32_ --- * Primitive (host word size)-, fnv1-, fnv1_+-- ** Host word size+, fnv1_host+, fnv1_host_ , fnv1Primitive , fnv1Primitive_ -, fnv1a-, fnv1a_+, fnv1a_host+, fnv1a_host_ , fnv1aPrimitive , fnv1aPrimitive_ --- * Utils-, module Data.Hash.Utils---- * Constants+-- ** Internal Constants , fnvPrime , fnvPrime32 , fnvPrime64@@ -54,6 +105,8 @@  ) where +import Control.Monad+ import Data.Bits import Data.Word @@ -61,27 +114,256 @@ import Foreign.Storable  import GHC.Exts- import GHC.IO  -- internal modules -import Data.Hash.Utils+import Data.Hash.Class.Pure  -- -------------------------------------------------------------------------- --+-- Fnv1 64 bit++newtype Fnv164Context = Fnv164Context Word64++newtype Fnv164Hash = Fnv164Hash Word64+    deriving (Show, Eq, Ord)++fnv164Initialize :: Fnv164Context+fnv164Initialize = Fnv164Context fnvOffsetBasis64+{-# INLINE fnv164Initialize #-}++fnv164Update :: Fnv164Context -> Ptr Word8 -> Int -> IO Fnv164Context+fnv164Update (Fnv164Context !ctx) !ptr !n =+    Fnv164Context <$!> fnv1_64_ ptr n ctx+{-# INLINE fnv164Update #-}++fnv164Finalize :: Fnv164Context -> Fnv164Hash+fnv164Finalize (Fnv164Context !ctx) = Fnv164Hash ctx+{-# INLINE fnv164Finalize #-}++fnv164 :: Ptr Word8 -> Int -> IO Fnv164Hash+fnv164 !ptr !n = fnv164Finalize <$!> fnv164Update fnv164Initialize ptr n+{-# INLINE fnv164 #-}++instance IncrementalHash Fnv164Hash where+    type Context Fnv164Hash = Fnv164Context+    update = fnv164Update+    finalize = fnv164Finalize++    {-# INLINE update #-}+    {-# INLINE finalize #-}++instance Hash Fnv164Hash where+    initialize = fnv164Initialize+    {-# INLINE initialize #-}++-- -------------------------------------------------------------------------- --+-- Fnv1a 64 bit++newtype Fnv1a64Context = Fnv1a64Context Word64++newtype Fnv1a64Hash = Fnv1a64Hash Word64+    deriving (Show, Eq, Ord)++fnv1a64Initialize :: Fnv1a64Context+fnv1a64Initialize = Fnv1a64Context fnvOffsetBasis64+{-# INLINE fnv1a64Initialize #-}++fnv1a64Update :: Fnv1a64Context -> Ptr Word8 -> Int -> IO Fnv1a64Context+fnv1a64Update (Fnv1a64Context !ctx) !ptr !n =+    Fnv1a64Context <$!> fnv1a_64_ ptr n ctx+{-# INLINE fnv1a64Update #-}++fnv1a64Finalize :: Fnv1a64Context -> Fnv1a64Hash+fnv1a64Finalize (Fnv1a64Context !ctx) = Fnv1a64Hash ctx+{-# INLINE fnv1a64Finalize #-}++fnv1a64 :: Ptr Word8 -> Int -> IO Fnv1a64Hash+fnv1a64 !ptr !n = fnv1a64Finalize <$!> fnv1a64Update fnv1a64Initialize ptr n+{-# INLINE fnv1a64 #-}++instance IncrementalHash Fnv1a64Hash where+    type Context Fnv1a64Hash = Fnv1a64Context+    update = fnv1a64Update+    finalize = fnv1a64Finalize++    {-# INLINE update #-}+    {-# INLINE finalize #-}++instance Hash Fnv1a64Hash where+    initialize = fnv1a64Initialize+    {-# INLINE initialize #-}++-- -------------------------------------------------------------------------- --+-- Fnv1 32 bit++newtype Fnv132Context = Fnv132Context Word32++newtype Fnv132Hash = Fnv132Hash Word32+    deriving (Show, Eq, Ord)++fnv132Initialize :: Fnv132Context+fnv132Initialize = Fnv132Context fnvOffsetBasis32+{-# INLINE fnv132Initialize #-}++fnv132Update :: Fnv132Context -> Ptr Word8 -> Int -> IO Fnv132Context+fnv132Update (Fnv132Context !ctx) !ptr !n =+    Fnv132Context <$!> fnv1_32_ ptr n ctx+{-# INLINE fnv132Update #-}++fnv132Finalize :: Fnv132Context -> Fnv132Hash+fnv132Finalize (Fnv132Context !ctx) = Fnv132Hash ctx+{-# INLINE fnv132Finalize #-}++fnv132 :: Ptr Word8 -> Int -> IO Fnv132Hash+fnv132 !ptr !n = fnv132Finalize <$!> fnv132Update fnv132Initialize ptr n+{-# INLINE fnv132 #-}++instance IncrementalHash Fnv132Hash where+    type Context Fnv132Hash = Fnv132Context+    update = fnv132Update+    finalize = fnv132Finalize++    {-# INLINE update #-}+    {-# INLINE finalize #-}++instance Hash Fnv132Hash where+    initialize = fnv132Initialize+    {-# INLINE initialize #-}++-- -------------------------------------------------------------------------- --+-- Fnv1a 32 bit++newtype Fnv1a32Context = Fnv1a32Context Word32++newtype Fnv1a32Hash = Fnv1a32Hash Word32+    deriving (Show, Eq, Ord)++fnv1a32Initialize :: Fnv1a32Context+fnv1a32Initialize = Fnv1a32Context fnvOffsetBasis32+{-# INLINE fnv1a32Initialize #-}++fnv1a32Update :: Fnv1a32Context -> Ptr Word8 -> Int -> IO Fnv1a32Context+fnv1a32Update (Fnv1a32Context !ctx) !ptr !n =+    Fnv1a32Context <$!> fnv1a_32_ ptr n ctx+{-# INLINE fnv1a32Update #-}++fnv1a32Finalize :: Fnv1a32Context -> Fnv1a32Hash+fnv1a32Finalize (Fnv1a32Context !ctx) = Fnv1a32Hash ctx+{-# INLINE fnv1a32Finalize #-}++fnv1a32 :: Ptr Word8 -> Int -> IO Fnv1a32Hash+fnv1a32 !ptr !n = fnv1a32Finalize <$!> fnv1a32Update fnv1a32Initialize ptr n+{-# INLINE fnv1a32 #-}++instance IncrementalHash Fnv1a32Hash where+    type Context Fnv1a32Hash = Fnv1a32Context+    update = fnv1a32Update+    finalize = fnv1a32Finalize++    {-# INLINE update #-}+    {-# INLINE finalize #-}++instance Hash Fnv1a32Hash where+    initialize = fnv1a32Initialize+    {-# INLINE initialize #-}++-- -------------------------------------------------------------------------- --+-- Fnv1 Host Wordsize++newtype Fnv1Context = Fnv1Context Word++newtype Fnv1Hash = Fnv1Hash Word+    deriving (Show, Eq, Ord)++fnv1Initialize :: Fnv1Context+fnv1Initialize = Fnv1Context fnvOffsetBasis+{-# INLINE fnv1Initialize #-}++fnv1Update :: Fnv1Context -> Ptr Word8 -> Int -> IO Fnv1Context+fnv1Update (Fnv1Context !ctx) !ptr !n =+    Fnv1Context <$!> fnv1_host_ ptr n ctx+{-# INLINE fnv1Update #-}++fnv1Finalize :: Fnv1Context -> Fnv1Hash+fnv1Finalize (Fnv1Context !ctx) = Fnv1Hash ctx+{-# INLINE fnv1Finalize #-}++fnv1 :: Ptr Word8 -> Int -> IO Fnv1Hash+fnv1 !ptr !n = fnv1Finalize <$!> fnv1Update fnv1Initialize ptr n+{-# INLINE fnv1 #-}++instance IncrementalHash Fnv1Hash where+    type Context Fnv1Hash = Fnv1Context+    update = fnv1Update+    finalize = fnv1Finalize++    {-# INLINE update #-}+    {-# INLINE finalize #-}++instance Hash Fnv1Hash where+    initialize = fnv1Initialize+    {-# INLINE initialize #-}++-- -------------------------------------------------------------------------- --+-- Fnv1a Host Wordsize++newtype Fnv1aContext = Fnv1aContext Word++newtype Fnv1aHash = Fnv1aHash Word+    deriving (Show, Eq, Ord)++fnv1aInitialize :: Fnv1aContext+fnv1aInitialize = Fnv1aContext fnvOffsetBasis+{-# INLINE fnv1aInitialize #-}++fnv1aUpdate :: Fnv1aContext -> Ptr Word8 -> Int -> IO Fnv1aContext+fnv1aUpdate (Fnv1aContext !ctx) !ptr !n =+    Fnv1aContext <$!> fnv1a_host_ ptr n ctx+{-# INLINE fnv1aUpdate #-}++fnv1aFinalize :: Fnv1aContext -> Fnv1aHash+fnv1aFinalize (Fnv1aContext !ctx) = Fnv1aHash ctx+{-# INLINE fnv1aFinalize #-}++fnv1a :: Ptr Word8 -> Int -> IO Fnv1aHash+fnv1a !ptr !n = fnv1aFinalize <$!> fnv1aUpdate fnv1aInitialize ptr n+{-# INLINE fnv1a #-}++instance IncrementalHash Fnv1aHash where+    type Context Fnv1aHash = Fnv1aContext+    update = fnv1aUpdate+    finalize = fnv1aFinalize++    {-# INLINE update #-}+    {-# INLINE finalize #-}++instance Hash Fnv1aHash where+    initialize = fnv1aInitialize+    {-# INLINE initialize #-}++-- -------------------------------------------------------------------------- --+-- Low Level+-- -------------------------------------------------------------------------- --++-- -------------------------------------------------------------------------- -- -- Constants  fnvPrime32 :: Word32 fnvPrime32 = 0x01000193+{-# INLINE fnvPrime32 #-}  fnvPrime64 :: Word64 fnvPrime64 = 0x100000001b3+{-# INLINE fnvPrime64 #-}  fnvOffsetBasis32 :: Word32 fnvOffsetBasis32 = 0x811c9dc5+{-# INLINE fnvOffsetBasis32 #-}  fnvOffsetBasis64 :: Word64 fnvOffsetBasis64 = 0xcbf29ce484222325+{-# INLINE fnvOffsetBasis64 #-}  fnvPrime :: Word #if defined(x86_64_HOST_ARCH)@@ -91,6 +373,7 @@ #else fnvPrime = error "fnvPrime: unsupported hardware platform" #endif+{-# INLINE fnvPrime #-}  fnvOffsetBasis :: Word #if defined(x86_64_HOST_ARCH)@@ -100,6 +383,7 @@ #else fnvOffsetBasis = error "fnvOffsetBasis: unsupported hardware platform" #endif+{-# INLINE fnvOffsetBasis #-}  -- -------------------------------------------------------------------------- -- -- FNV1 64 bit@@ -169,19 +453,19 @@ {-# INLINE fnv1a_32_ #-}  -- -------------------------------------------------------------------------- ----- Primitive (host architecture words)+-- Host architecture words  -- FNV1 -fnv1 :: Addr# -> Int -> IO Word-fnv1 addr (I# n) = IO $ \s -> case fnv1Primitive addr n s of+fnv1_host :: Ptr Word8 -> Int -> IO Word+fnv1_host (Ptr addr) (I# n) = IO $ \s -> case fnv1Primitive addr n s of     (# s1, w #) -> (# s1, W# w #)-{-# INlINE fnv1 #-}+{-# INlINE fnv1_host #-} -fnv1_ :: Addr# -> Int -> Word -> IO Word-fnv1_ addr (I# n) (W# a) = IO $ \s -> case fnv1Primitive_ addr n a s of+fnv1_host_ :: Ptr Word8 -> Int -> Word -> IO Word+fnv1_host_ (Ptr addr) (I# n) (W# a) = IO $ \s -> case fnv1Primitive_ addr n a s of     (# s1, w #) -> (# s1, W# w #)-{-# INlINE fnv1_ #-}+{-# INlINE fnv1_host_ #-}  fnv1Primitive :: Addr# -> Int# -> State# tok -> (# State# tok, Word# #) fnv1Primitive !addr !n !tok = fnv1Primitive_ addr n o tok@@ -204,17 +488,18 @@     !(W# p) = fnvPrime {-# INLINE fnv1Primitive_ #-} --- FNV1a+-- -------------------------------------------------------------------------- --+-- Host Wordsize FNV1a -fnv1a :: Addr# -> Int -> IO Word-fnv1a addr (I# n) = IO $ \s -> case fnv1aPrimitive addr n s of+fnv1a_host :: Ptr Word8 -> Int -> IO Word+fnv1a_host (Ptr addr) (I# n) = IO $ \s -> case fnv1aPrimitive addr n s of     (# s1, w #) -> (# s1, W# w #)-{-# INlINE fnv1a #-}+{-# INlINE fnv1a_host #-} -fnv1a_ :: Addr# -> Int -> Word -> IO Word-fnv1a_ addr (I# n) (W# a) = IO $ \s -> case fnv1aPrimitive_ addr n a s of+fnv1a_host_ :: Ptr Word8 -> Int -> Word -> IO Word+fnv1a_host_ (Ptr addr) (I# n) (W# a) = IO $ \s -> case fnv1aPrimitive_ addr n a s of     (# s1, w #) -> (# s1, W# w #)-{-# INlINE fnv1a_ #-}+{-# INlINE fnv1a_host_ #-}  fnv1aPrimitive :: Addr# -> Int# -> State# tok -> (# State# tok, Word# #) fnv1aPrimitive !addr !n !tok = fnv1aPrimitive_ addr n o tok@@ -229,10 +514,10 @@     loop !acc !i !s = case i ==# n of         1# -> (# s, acc #)         _ -> case readWord8OffAddr# addr i s of-            (# s1, w #) -> loop-                (p `timesWord#` (acc `xor#` word8ToWord# w))-                (i +# 1#)-                s1+            (# s1, w #) ->+                let !acc' = p `timesWord#` (acc `xor#` word8ToWord# w)+                    !n' = i +# 1#+                in loop acc' n' s1      !(W# p) = fnvPrime {-# INLINE fnv1aPrimitive_ #-}@@ -246,4 +531,5 @@ -- word8ToWord# :: Word# -> Word# word8ToWord# a = a+{-# INLINE word8ToWord# #-} #endif

@@ -0,0 +1,90 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Module: Data.Hash.FNV1.Salted+-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>+-- License: MIT+-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>+-- Stability: experimental+--+-- Salted variants for FNV1 Hashes+--+module Data.Hash.FNV1.Salted+(+-- * Fnv1 64 bit+  FH.Fnv164Hash(..)+, FH.Fnv164Context+++-- * Fnv1a 64 bit+, FH.Fnv1a64Hash(..)+, FH.Fnv1a64Context++-- * Fnv1 32 bit+, FH.Fnv132Hash(..)+, FH.Fnv132Context++-- * Fnv1a 32 bit+, FH.Fnv1a32Hash(..)+, FH.Fnv1a32Context++-- * Fnv1 Host Wordsize+, FH.Fnv1Hash(..)+, FH.Fnv1Context++-- * Fnv1a Host Wordsize+, FH.Fnv1aHash(..)+, FH.Fnv1aContext++-- * Utils+, module Data.Hash.Class.Pure.Salted++) where++import Data.Word++-- internal modules++import qualified Data.Hash.FNV1 as FH+import qualified Data.Hash.Class.Pure as PH+import Data.Hash.Class.Pure.Salted++-- -------------------------------------------------------------------------- --+-- Orphans++instance Hash FH.Fnv164Hash where+    type Salt FH.Fnv164Hash = Word64+    initialize = PH.initializeWithSalt @FH.Fnv164Hash+    {-# INLINE initialize #-}++instance Hash FH.Fnv1a64Hash where+    type Salt FH.Fnv1a64Hash = Word64+    initialize = PH.initializeWithSalt @FH.Fnv1a64Hash+    {-# INLINE initialize #-}++instance Hash FH.Fnv132Hash where+    type Salt FH.Fnv132Hash = Word32+    initialize = PH.initializeWithSalt @FH.Fnv132Hash+    {-# INLINE initialize #-}++instance Hash FH.Fnv1a32Hash where+    type Salt FH.Fnv1a32Hash = Word32+    initialize = PH.initializeWithSalt @FH.Fnv1a32Hash+    {-# INLINE initialize #-}++instance Hash FH.Fnv1Hash where+    type Salt FH.Fnv1Hash = Word+    initialize = PH.initializeWithSalt @FH.Fnv1Hash+    {-# INLINE initialize #-}++instance Hash FH.Fnv1aHash where+    type Salt FH.Fnv1aHash = Word+    initialize = PH.initializeWithSalt @FH.Fnv1aHash+    {-# INLINE initialize #-}+

@@ -0,0 +1,455 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++#include <openssl/opensslv.h>++-- |+-- Module: Data.Hash.Internal.OpenSSL+-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>+-- License: MIT+-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>+-- Stability: experimental+--+-- Bindings for OpenSSL EVP Message Digest Routines+--+module Data.Hash.Internal.OpenSSL+(++-- * EVP digest routines++  Algorithm(..)+, Ctx(..)+, Digest(..)+, newCtx+, initCtx+, updateCtx+, finalCtx++-- * Algorithms++, OpenSslDigest(..)+, OpenSslException(..)++-- ** SHA2+--+-- $sha2++, Sha2_224(..)+, Sha2_256(..)+, Sha2_384(..)+, Sha2_512(..)+, Sha2_512_224(..)+, Sha2_512_256(..)++-- ** SHA3+--+-- $sha3++, Sha3_224(..)+, Sha3_256(..)+, Sha3_384(..)+, Sha3_512(..)+, Shake128(..)+, Shake256(..)++-- ** Keccak+--+-- $keccak++, Keccak256(..)++-- ** Blake2+--+-- $blake2++, Blake2b512(..)+, Blake2s256(..)+) where++import Control.Exception+import Control.Monad++import qualified Data.ByteString.Short as BS+import Data.Void+import Data.Word++import Foreign.ForeignPtr+import Foreign.Marshal+import Foreign.Ptr++import GHC.IO++-- internal modules++import Data.Hash.Class.Mutable+import Data.Hash.Internal.Utils+++#if OPENSSL_VERSION_NUMBER < 0x10100000L+#error "Unsupported OpenSSL version. Please install OpenSSL >= 1.1.0"+#endif++-- -------------------------------------------------------------------------- --+-- OpenSSL Message Digests++newtype OpenSslException = OpenSslException String+    deriving (Show)++instance Exception OpenSslException++newtype Algorithm = Algorithm (Ptr Void)+newtype Ctx a = Ctx (ForeignPtr Void)+newtype Digest a = Digest BS.ShortByteString+    deriving (Eq, Ord)+    deriving (Show) via B16ShortByteString++#if OPENSSL_VERSION_NUMBER >= 0x10100000L+foreign import ccall unsafe "openssl/evp.h EVP_MD_CTX_new"+#else+foreign import ccall unsafe "openssl/evp.h EVP_MD_CTX_create"+#endif+    c_evp_ctx_new :: IO (Ptr a)++#if OPENSSL_VERSION_NUMBER >= 0x10100000L+foreign import ccall unsafe "openssl/evp.h &EVP_MD_CTX_free"+#else+foreign import ccall unsafe "openssl/evp.h &EVP_MD_CTX_destroy"+#endif+    c_evp_ctx_free_ptr :: FunPtr (Ptr a -> IO ())++-- obsolete, superseeded by EVP_DigestInit_ex instead, but not deprecated+-- (beware in case this becomes a macro in future versions)+--+foreign import ccall unsafe "opnessl/evp.h EVP_DigestInit"+    c_evp_digest_init :: Ptr ctx -> Ptr alg -> IO Bool++foreign import ccall unsafe "opnessl/evp.h EVP_DigestUpdate"+    c_evp_digest_update :: Ptr ctx -> Ptr d -> Int -> IO Bool++foreign import ccall unsafe "opnessl/evp.h EVP_DigestFinal"+    c_evp_digest_final :: Ptr ctx -> Ptr d -> Int -> IO Bool++#if OPENSSL_VERSION_NUMBER >= 0x30000000L+foreign import ccall unsafe "openssl/evp.h EVP_MD_CTX_get0_md"+#else+foreign import ccall unsafe "openssl/evp.h EVP_MD_CTX_md"+#endif+    c_evp_ctx_get0_md :: Ptr ctx -> IO Algorithm++#if OPENSSL_VERSION_NUMBER >= 0x30000000L+foreign import ccall unsafe "openssl/evp.h EVP_MD_get_size"+#else+foreign import ccall unsafe "openssl/evp.h EVP_MD_size"+#endif+    c_evp_get_size :: Algorithm -> IO Int++newCtx :: IO (Ctx a)+newCtx = fmap Ctx $ mask_ $ do+    ptr <- c_evp_ctx_new+    when (ptr == nullPtr) $ throw $ OpenSslException "failed to initialize context"+    newForeignPtr c_evp_ctx_free_ptr ptr+{-# INLINE newCtx #-}++initCtx :: Algorithm -> IO (Ctx a)+initCtx (Algorithm alg) = do+    Ctx ctx <- newCtx+    r <- withForeignPtr ctx $ \ptr ->+        c_evp_digest_init ptr alg+    unless r $ throw $ OpenSslException "digest initialization failed"+    return $ Ctx ctx+{-# INLINE initCtx #-}++updateCtx :: Ctx a -> Ptr Word8 -> Int -> IO ()+updateCtx (Ctx ctx) d c = withForeignPtr ctx $ \ptr -> do+    r <- c_evp_digest_update ptr d c+    unless r $ throw $ OpenSslException "digest update failed"+{-# INLINE updateCtx #-}++finalCtx :: Ctx a -> IO (Digest a)+finalCtx (Ctx ctx) = withForeignPtr ctx $ \ptr -> do+    s <- c_evp_ctx_get0_md ptr >>= c_evp_get_size+    allocaBytes s $ \dptr -> do+        r <- c_evp_digest_final ptr dptr 0+        unless r $ throw $ OpenSslException "digest finalization failed"+        Digest <$> BS.packCStringLen (dptr, s)+{-# INLINE finalCtx #-}++-- -------------------------------------------------------------------------- --+-- Support for DerivingVia++class OpenSslDigest a where+    algorithm :: Algorithm++instance OpenSslDigest a => IncrementalHash (Digest a) where+    type Context (Digest a) = Ctx a+    update = updateCtx+    finalize = finalCtx+    {-# INLINE update #-}+    {-# INLINE finalize #-}++instance OpenSslDigest a => Hash (Digest a) where+    initialize = initCtx (algorithm @a)+    {-# INLINE initialize #-}++-- -------------------------------------------------------------------------- --+-- Digests+-- -------------------------------------------------------------------------- --++-- -------------------------------------------------------------------------- --+-- SHA-2++-- $sha2+--+-- SHA-2 (Secure Hash Algorithm 2) is a family of cryptographic hash functions+-- standardized in NIST FIPS 180-4, first published in 2001. These functions+-- conform to NIST FIPS 180-4.+--+-- The following hash functions from the SHA-2 family are supported in+-- openssl-3.0 (cf. https://www.openssl.org/docs/man3.0/man3/EVP_sha224.html)+--+-- EVP_sha224, EVP_sha256, EVP_sha512_224, EVP_sha512_256, EVP_sha384,+-- EVP_sha512+--++foreign import ccall unsafe "openssl/evp.h EVP_sha224"+    c_evp_sha2_224 :: Algorithm++foreign import ccall unsafe "openssl/evp.h EVP_sha256"+    c_evp_sha2_256 :: Algorithm++foreign import ccall unsafe "openssl/evp.h EVP_sha384"+    c_evp_sha2_384 :: Algorithm++foreign import ccall unsafe "openssl/evp.h EVP_sha512"+    c_evp_sha2_512 :: Algorithm++foreign import ccall unsafe "openssl/evp.h EVP_sha512_224"+    c_evp_sha2_512_224 :: Algorithm++foreign import ccall unsafe "openssl/evp.h EVP_sha512_256"+    c_evp_sha2_512_256 :: Algorithm++newtype Sha2_224 = Sha2_224 BS.ShortByteString+    deriving (Eq, Ord)+    deriving (Show) via B16ShortByteString+    deriving (IncrementalHash, Hash) via (Digest Sha2_224)+instance OpenSslDigest Sha2_224 where algorithm = c_evp_sha2_224++newtype Sha2_256 = Sha2_256 BS.ShortByteString+    deriving (Eq, Ord)+    deriving (Show) via B16ShortByteString+    deriving (IncrementalHash, Hash) via (Digest Sha2_256)+instance OpenSslDigest Sha2_256 where algorithm = c_evp_sha2_256++newtype Sha2_384 = Sha2_384 BS.ShortByteString+    deriving (Eq, Ord)+    deriving (Show) via B16ShortByteString+    deriving (IncrementalHash, Hash) via (Digest Sha2_384)+instance OpenSslDigest Sha2_384 where algorithm = c_evp_sha2_384++newtype Sha2_512 = Sha2_512 BS.ShortByteString+    deriving (Eq, Ord)+    deriving (Show) via B16ShortByteString+    deriving (IncrementalHash, Hash) via (Digest Sha2_512)+instance OpenSslDigest Sha2_512 where algorithm = c_evp_sha2_512++newtype Sha2_512_224 = Sha2_512_224 BS.ShortByteString+    deriving (Eq, Ord)+    deriving (Show) via B16ShortByteString+    deriving (IncrementalHash, Hash) via (Digest Sha2_512_224)+instance OpenSslDigest Sha2_512_224 where algorithm = c_evp_sha2_512_224++newtype Sha2_512_256 = Sha2_512_256 BS.ShortByteString+    deriving (Eq, Ord)+    deriving (Show) via B16ShortByteString+    deriving (IncrementalHash, Hash) via (Digest Sha2_512_256)+instance OpenSslDigest Sha2_512_256 where algorithm = c_evp_sha2_512_256++-- -------------------------------------------------------------------------- --+-- SHA-3++-- $sha3+--+-- SHA-3 (Secure Hash Algorithm 3) is a family of cryptographic hash functions+-- standardized in NIST FIPS 202, first published in 2015. It is based on the+-- Keccak algorithm. These functions conform to NIST FIPS 202.+--+-- The following hash functions from the SHA-3 family are supported in+-- openssl-3.0 (cf. https://www.openssl.org/docs/man3.0/man3/EVP_sha3_224.html)+--+-- EVP_sha3_224, EVP_sha3_256, EVP_sha3_384, EVP_sha3_512, EVP_shake128,+-- EVP_shake256++foreign import ccall unsafe "openssl/evp.h EVP_sha3_224"+    c_evp_sha3_224 :: Algorithm++foreign import ccall unsafe "openssl/evp.h EVP_sha3_256"+    c_evp_sha3_256 :: Algorithm++foreign import ccall unsafe "openssl/evp.h EVP_sha3_384"+    c_evp_sha3_384 :: Algorithm++foreign import ccall unsafe "openssl/evp.h EVP_sha3_512"+    c_evp_sha3_512 :: Algorithm++foreign import ccall unsafe "openssl/evp.h EVP_shake128"+    c_evp_shake128 :: Algorithm++foreign import ccall unsafe "openssl/evp.h EVP_shake256"+    c_evp_shake256 :: Algorithm++newtype Sha3_224 = Sha3_224 BS.ShortByteString+    deriving (Eq, Ord)+    deriving (Show) via B16ShortByteString+    deriving (IncrementalHash, Hash) via (Digest Sha3_224)+instance OpenSslDigest Sha3_224 where algorithm = c_evp_sha3_224++newtype Sha3_256 = Sha3_256 BS.ShortByteString+    deriving (Eq, Ord)+    deriving (Show) via B16ShortByteString+    deriving (IncrementalHash, Hash) via (Digest Sha3_256)+instance OpenSslDigest Sha3_256 where algorithm = c_evp_sha3_256++newtype Sha3_384 = Sha3_384 BS.ShortByteString+    deriving (Eq, Ord)+    deriving (Show) via B16ShortByteString+    deriving (IncrementalHash, Hash) via (Digest Sha3_384)+instance OpenSslDigest Sha3_384 where algorithm = c_evp_sha3_384++newtype Sha3_512 = Sha3_512 BS.ShortByteString+    deriving (Eq, Ord)+    deriving (Show) via B16ShortByteString+    deriving (IncrementalHash, Hash) via (Digest Sha3_512)+instance OpenSslDigest Sha3_512 where algorithm = c_evp_sha3_512++newtype Shake128 = Shake128 BS.ShortByteString+    deriving (Eq, Ord)+    deriving (Show) via B16ShortByteString+    deriving (IncrementalHash, Hash) via (Digest Shake128)+instance OpenSslDigest Shake128 where algorithm = c_evp_shake128++newtype Shake256 = Shake256 BS.ShortByteString+    deriving (Eq, Ord)+    deriving (Show) via B16ShortByteString+    deriving (IncrementalHash, Hash) via (Digest Shake256)+instance OpenSslDigest Shake256 where algorithm = c_evp_shake256++-- -------------------------------------------------------------------------- --+-- Keccak++-- $keccak+--+-- This is the latest version of Keccak-256 hash function that was submitted to+-- the SHA3 competition. It is different from the final NIST SHA3 hash.+--+-- The difference between NIST SHA3-256 and Keccak-256 is the use of a different+-- padding character for the input message. The former uses '0x06' and the+-- latter uses '0x01'.+--+-- This version of Keccak-256 is used by the Ethereum project.+--+-- This implementation of Keccak-256 uses internal OpenSSL APIs. It may break+-- with new versions of OpenSSL. It may also be broken for existing versions of+-- OpenSSL. Portability of the code is unknown.+--+-- ONLY USE THIS CODE AFTER YOU HAVE VERIFIED THAT IT WORKS WITH OUR VERSION OF+-- OPENSSL.+--+-- For details see the file cbits/keccak.c.++newtype Keccak256 = Keccak256 BS.ShortByteString+    deriving (Eq, Ord)+    deriving (Show) via B16ShortByteString++foreign import ccall unsafe "keccak.h keccak256_newctx"+    c_keccak256_newctx :: IO (Ptr ctx)++foreign import ccall unsafe "keccak.h keccak256_init"+    c_keccak256_init :: Ptr ctx -> IO Bool++foreign import ccall unsafe "keccak.h keccak256_update"+    c_keccak256_update :: Ptr ctx -> Ptr Word8 -> Int -> IO Bool++foreign import ccall unsafe "keccak.h keccak256_final"+    c_keccak256_final :: Ptr ctx -> Ptr Word8 -> IO Bool++foreign import ccall unsafe "keccak.h &keccak256_freectx"+    c_keccak256_freectx_ptr :: FunPtr (Ptr ctx -> IO ())++instance IncrementalHash Keccak256 where+    type Context Keccak256 = Ctx Keccak256+    update (Ctx ctx) ptr n = withForeignPtr ctx $ \cptr -> do+        r <- c_keccak256_update cptr ptr n+        unless r $ throw $ OpenSslException "digest update failed"+    finalize (Ctx ctx) = withForeignPtr ctx $ \cptr -> do+        allocaBytes 32 $ \dptr -> do+            r <- c_keccak256_final cptr dptr+            unless r $ throw $ OpenSslException "digest finalization failed"+            Keccak256 <$> BS.packCStringLen (castPtr dptr, 32)+    {-# INLINE update #-}+    {-# INLINE finalize #-}+++newKeccak256Ctx :: IO (Ctx Keccak256)+newKeccak256Ctx = fmap Ctx $ mask_ $ do+    ptr <- c_keccak256_newctx+    when (ptr == nullPtr) $ throw $ OpenSslException "failed to initialize context"+    newForeignPtr c_keccak256_freectx_ptr ptr+{-# INLINE newKeccak256Ctx #-}++instance Hash Keccak256 where+    initialize = do+        Ctx ctx <- newKeccak256Ctx+        r <- withForeignPtr ctx $ \ptr ->+            c_keccak256_init ptr+        unless r $ throw $ OpenSslException "digest initialization failed"+        return $ Ctx ctx+    {-# INLINE initialize #-}++-- -------------------------------------------------------------------------- --+-- Blake++-- $blake2+--+-- BLAKE2 is an improved version of BLAKE, which was submitted to the NIST SHA-3+-- algorithm competition. The BLAKE2s and BLAKE2b algorithms are described in+-- RFC 7693.+--+-- The following hash functions from the BLAKE2 family are supported in+-- openssl-3.0 (cf.+-- https://www.openssl.org/docs/man3.0/man3/EVP_blake2b512.html)+--+-- EVP_blake2b512, EVP_blake2s256+--+-- While the BLAKE2b and BLAKE2s algorithms supports a variable length digest,+-- this implementation outputs a digest of a fixed length (the maximum length+-- supported), which is 512-bits for BLAKE2b and 256-bits for BLAKE2s.+--+--++foreign import ccall unsafe "openssl/evp.h EVP_blake2b512"+    c_evp_blake2b512 :: Algorithm++foreign import ccall unsafe "openssl/evp.h EVP_blake2s256"+    c_evp_blake2s256 :: Algorithm++newtype Blake2b512 = Blake2b512 BS.ShortByteString+    deriving (Eq, Ord)+    deriving (Show) via B16ShortByteString+    deriving (IncrementalHash, Hash) via (Digest Blake2b512)+instance OpenSslDigest Blake2b512 where algorithm = c_evp_blake2b512++newtype Blake2s256 = Blake2s256 BS.ShortByteString+    deriving (Eq, Ord)+    deriving (Show) via B16ShortByteString+    deriving (IncrementalHash, Hash) via (Digest Blake2s256)+instance OpenSslDigest Blake2s256 where algorithm = c_evp_blake2s256+

@@ -0,0 +1,27 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module: Data.Hash.Internal.Utils+-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>+-- License: MIT+-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>+-- Stability: experimental+--+module Data.Hash.Internal.Utils+( B16ShortByteString(..)+) where++import qualified Data.ByteString.Short as BS++import Text.Printf++-- -------------------------------------------------------------------------- --+-- Utils++newtype B16ShortByteString = B16ShortByteString BS.ShortByteString++instance Show B16ShortByteString where+    show (B16ShortByteString b) = concatMap (printf "%0.2x") $ BS.unpack b+

@@ -0,0 +1,39 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module: Data.Hash.Keccak+-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>+-- License: MIT+-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>+-- Stability: experimental+--+-- | The code in this module uses internal OpenSSL APIs. It may break with new+-- versions of OpenSSL. It may also be broken for existing versions of OpenSSL.+-- Portability of the code is unknown.+--+-- ONLY USE THIS CODE AFTER YOU HAVE VERIFIED THAT IT WORKS WITH OUR VERSION OF+-- OPENSSL.+--+-- For details see the file cbits/keccak.c.+--+module Data.Hash.Keccak+(+-- * Keccak-256+--+-- | This is the latest version of Keccak-256 hash function that was submitted to+-- the SHA3 competition. It is different from the final NIST SHA3 hash.+--+-- The difference between NIST SHA3-256 and Keccak-256 is the use of a different+-- padding character for the input message. The former uses '0x06' and the+-- latter uses '0x01'.+--+-- This version of Keccak-256 is used by the Ethereum project.++  Keccak256(..)+, module Data.Hash.Class.Mutable+) where++import Data.Hash.Class.Mutable+import Data.Hash.Internal.OpenSSL+

@@ -0,0 +1,30 @@+-- |+-- Module: Data.Hash.SHA2+-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>+-- License: MIT+-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>+-- Stability: experimental+--+-- SHA-2 Hash Functions+--+module Data.Hash.SHA2+(+-- * SHA-2+--+-- | SHA-2 (Secure Hash Algorithm 2) is a family of cryptographic hash functions+-- standardized in NIST FIPS 180-4, first published in 2001. These functions+-- conform to NIST FIPS 180-4.++  Sha2_224(..)+, Sha2_256(..)+, Sha2_384(..)+, Sha2_512(..)+, Sha2_512_224(..)+, Sha2_512_256(..)++, module Data.Hash.Class.Mutable+) where++import Data.Hash.Class.Mutable+import Data.Hash.Internal.OpenSSL+

@@ -0,0 +1,30 @@+-- |+-- Module: Data.Hash.SHA3+-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>+-- License: MIT+-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>+-- Stability: experimental+--+-- SHA-3 Hash Functions+--+module Data.Hash.SHA3+(+-- * SHA-3+--+-- | SHA-3 (Secure Hash Algorithm 3) is a family of cryptographic hash functions+-- standardized in NIST FIPS 202, first published in 2015. It is based on the+-- Keccak algorithm. These functions conform to NIST FIPS 202.++  Sha3_224(..)+, Sha3_256(..)+, Sha3_384(..)+, Sha3_512(..)+, Shake128(..)+, Shake256(..)++, module Data.Hash.Class.Mutable+) where++import Data.Hash.Class.Mutable+import Data.Hash.Internal.OpenSSL+

@@ -1,7 +1,15 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UndecidableInstances #-}  -- | -- Module: Data.Hash.SipHash@@ -11,62 +19,82 @@ -- Stability: experimental -- module Data.Hash.SipHash-( sipHash-, sipHash13+( SipHashKey(..)+, SipHash(..)+, sipHash++-- * SipHash-c-d+, sipHashCD , sipHash24+, sipHash13 , sipHash48-, sipHashCD +-- * Incremental SipHash+, SipHashContext+, sipHashInitialize+, sipHashUpdate+, sipHashFinalize+ -- * Utils-, module Data.Hash.Utils+, module Data.Hash.Class.Pure.Salted ) where  import Control.Monad  import Data.Bits-import Data.Function+import Data.Type.Equality import Data.Word -import Foreign.Marshal.Utils+import Foreign.Marshal+import Foreign.Ptr import Foreign.Storable -import GHC.Ptr--import Prelude hiding (drop, length, null, splitAt, take)+import GHC.TypeNats  -- internal modules -import Data.Hash.Utils+import Data.Hash.Class.Pure.Salted  -- -------------------------------------------------------------------------- -- -- SipHash --- | SipHash, with recommended default parameters of c=2 and c=4.+-- | SipHash, with recommended default parameters of c=2 and d=4. -- -- The first and second argument is the 128 bit key, represented as two 64 bit -- words. -- sipHash-    :: Word64-    -> Word64+    :: SipHashKey     -> Ptr Word8     -> Int-    -> IO Word64-sipHash = sipHash24+    -> IO (SipHash 2 4)+sipHash = sipHashCD {-# INLINE sipHash #-} --- | SipHash-2-4+-- | Generic SipHash with c rounds per block and d finalization rounds. -- -- The first and second argument is the 128 bit key, represented as two 64 bit -- words. ---sipHash24-    :: Word64-    -> Word64+sipHashCD+    :: forall c d+    . SipHashParam c+    => SipHashParam d+    => SipHashKey     -> Ptr Word8     -> Int-    -> IO Word64-sipHash24 = sipHashInternal rounds2 rounds4+    -> IO (SipHash c d)+sipHashCD key ptr n = sipHashFinalize+    <$> sipHashUpdate (sipHashInitialize key) ptr n+{-# INLINE sipHashCD #-}++-- | SipHash-2-4+--+-- The first and second argument is the 128 bit key, represented as two 64 bit+-- words.+--+sipHash24 :: SipHashKey -> Ptr Word8 -> Int -> IO (SipHash 2 4)+sipHash24 = sipHashCD {-# INLINE sipHash24 #-}  -- | SipHash-1-3@@ -74,13 +102,8 @@ -- The first and second argument is the 128 bit key, represented as two 64 bit -- words. ---sipHash13-    :: Word64-    -> Word64-    -> Ptr Word8-    -> Int-    -> IO Word64-sipHash13 = sipHashInternal rounds1 rounds3+sipHash13 :: SipHashKey -> Ptr Word8 -> Int -> IO (SipHash 1 3)+sipHash13 = sipHashCD {-# INLINE sipHash13 #-}  -- | SipHash-4-8@@ -88,83 +111,142 @@ -- The first and second argument is the 128 bit key, represented as two 64 bit -- words. ---sipHash48-    :: Word64-    -> Word64-    -> Ptr Word8-    -> Int-    -> IO Word64-sipHash48 = sipHashInternal rounds4 rounds8+sipHash48 :: SipHashKey -> Ptr Word8 -> Int -> IO (SipHash 4 8)+sipHash48 = sipHashCD {-# INLINE sipHash48 #-} --- | Generic SipHash with c rounds per block and d finalization rounds.+-- -------------------------------------------------------------------------- --+-- Class++instance (SipHashParam c, SipHashParam d) => IncrementalHash (SipHash c d) where+    type Context (SipHash c d) = SipHashContext c d+    update = sipHashUpdate+    finalize = sipHashFinalize++    {-# INLINE update #-}+    {-# INLINE finalize #-}++instance (SipHashParam c, SipHashParam d) => Hash (SipHash c d) where+    type Salt (SipHash c d) = SipHashKey+    initialize = sipHashInitialize+    {-# INLINE initialize #-}++-- -------------------------------------------------------------------------- --+-- Incremental Version of SipHash++-- | SipHash with @c@ compression rounds and @d@ finalization rounds. ----- The first and second argument is the 128 bit key, represented as two 64 bit--- words.+-- cf. http://cr.yp.to/siphash/siphash-20120918.pdf ---sipHashCD-    :: Int-    -> Int-    -> Word64-    -> Word64-    -> Ptr Word8-    -> Int-    -> IO Word64-sipHashCD c d = sipHashInternal (rounds c) (rounds d)-{-# INLINE sipHashCD #-}+newtype SipHash (c :: Nat) (d :: Nat) = SipHash Word64+    deriving (Show, Eq, Ord) --- -------------------------------------------------------------------------- ----- Generic SipHash+-- | The 'Word46' constructor parameters represent the 128 bit key in little+-- endian encoding.+--+data SipHashKey = SipHashKey {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64+    deriving (Show, Eq, Ord) -data S = S+-- | Internal mutable SipHashContext.+--+-- The first four arguments are the internal state values \(v_{0..3}\) and the+-- last argument represents the pending bytes from an incomplete word of the+-- last chunk of input.+--+data SipHashContext (c :: Nat) (d :: Nat) = SipHashContext     {-# UNPACK #-} !Word64     {-# UNPACK #-} !Word64     {-# UNPACK #-} !Word64     {-# UNPACK #-} !Word64+    {-# UNPACK #-} !Word64+        -- ^ the most significant byte keeps track of the total number of input+        -- bytes modulo 256. The remaining bytes are the currently pending input+        -- bytes (i.e. the last \(totalInput `mod` 8\) many bytes of the input). -type Round = Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)+-- | Initialize a new SipHashContext+--+sipHashInitialize :: SipHashKey -> SipHashContext c d+sipHashInitialize (SipHashKey k0 k1) = SipHashContext+    (0x736f6d6570736575 `xor` k0)+    (0x646f72616e646f6d `xor` k1)+    (0x6c7967656e657261 `xor` k0)+    (0x7465646279746573 `xor` k1)+    0x0+{-# INLINE sipHashInitialize #-} -sipHashInternal-    :: Round-    -> Round-    -> Word64-    -> Word64+-- | Incrementally add input bytes to an SipHash computation and update+-- the internal context.+--+sipHashUpdate+    :: forall (c :: Nat) (d :: Nat)+    . SipHashParam c+    => SipHashContext c d     -> Ptr Word8     -> Int-    -> IO Word64-sipHashInternal cRound dRound !k0 !k1 !ptr !len = do+    -> IO (SipHashContext c d)+sipHashUpdate (SipHashContext s0 s1 s2 s3 r) ptr8 len+    | 0 <- rlen `rem` 8 = loop s0 s1 s2 s3 ptr64 len64 -    -- loop-    (S !v0 !v1 !v2 !v3) <- loop i0 i1 i2 i3 (castPtr ptr) len+    -- Consume the first input word using any possibly pending input bytes from+    -- previous updates.+    --+    | a <- rlen `rem` 8 = do+        let !missing = 8 - a -    -- end-    let (!off, !r) = quotRem len 8-    w <- ptrToWord64 (plusPtr ptr (off * 8)) r-    let !b = shiftL (fromIntegral len) 56 .|. w-        (# !v0', !v1', !v2', !v3' #) = cRound v0 v1 v2 (v3 `xor` b)-        (# !v0'', !v1'', !v2'', !v3'' #) = dRound (v0' `xor` b) v1' (v2' `xor` 0xff) v3'-    return $! v0'' `xor` v1'' `xor` v2'' `xor` v3''+        -- get enough bytes to fill up next word (if there are less than 8 - a+        -- bytes the most significant bytes are set to 0)+        !m <- ptrToWord64 ptr64 $ fromIntegral missing +        -- add new bytes to get full word64. Input is parsed as little endian,+        -- so new bytes are more significant than pending bytes.+        let !m' = (0x00ffffffffffffff .&. r {- pending bytes -}) .|. m++        if len64 < missing+          then+            -- nothing left to do+            return $ SipHashContext s0 s1 s2 s3 (shiftL (rlen + len64) 56 .|. m')+          else do+            -- compute c round with first word+            let (# v0', v1', v2', v3' #) = rounds @c s0 s1 s2 (s3 `xor` m')+            loop (v0' `xor` m') v1' v2' v3' (plusPtr ptr64 (fromIntegral missing)) (len64 - missing)   where+    len64 = fromIntegral len+    {-# INLINE len64 #-} +    !ptr64 = castPtr ptr8+    {-# INLINE ptr64 #-}++    !rlen = 0xff00000000000000 .&. r+    {-# INLINE rlen #-}+++    -- Assumes that there are no pending bytes.     loop !v0 !v1 !v2 !v3 !p !l-        | l < 8 = return $ S v0 v1 v2 v3+        | l < 8 = do+            !m <- ptrToWord64 p l+            return $ SipHashContext v0 v1 v2 v3 (shiftL (rlen + len64) 56 .|. m)         | otherwise = do+            -- TODO enforce little endian encoding             !m <- peek p-            let (# v0', v1', v2', v3' #) = cRound v0 v1 v2 (v3 `xor` m)+            let (# v0', v1', v2', v3' #) = rounds @c v0 v1 v2 (v3 `xor` m)             loop (v0' `xor` m) v1' v2' v3' (plusPtr p 8) (l - 8)+    {-# INLINE loop #-}+{-# INLINE sipHashUpdate #-} -    !i0 = 0x736f6d6570736575 `xor` k0-    !i1 = 0x646f72616e646f6d `xor` k1-    !i2 = 0x6c7967656e657261 `xor` k0-    !i3 = 0x7465646279746573 `xor` k1-    {-# INLINE i0 #-}-    {-# INLINE i1 #-}-    {-# INLINE i2 #-}-    {-# INLINE i3 #-}-{-# INLINE sipHashInternal #-}+sipHashFinalize+    :: forall (c :: Nat) (d :: Nat)+    . SipHashParam c+    => SipHashParam d+    => SipHashContext c d+    -> SipHash c d+sipHashFinalize (SipHashContext v0 v1 v2 v3 m) =+    SipHash $! v0'' `xor` v1'' `xor` v2'' `xor` v3''+  where+    (# !v0', !v1', !v2', !v3' #) = rounds @c v0 v1 v2 (v3 `xor` m)+    (# !v0'', !v1'', !v2'', !v3'' #) = rounds @d (v0' `xor` m) v1' (v2' `xor` 0xff) v3'+{-# INLINE sipHashFinalize #-} -ptrToWord64 :: Ptr Word64 -> Int -> IO Word64+ptrToWord64 :: Ptr Word64 -> Word64 -> IO Word64 ptrToWord64 _ 0 = pure 0 ptrToWord64 !p 1 = fromIntegral <$!> peek @Word8 (castPtr p) ptrToWord64 !p 2 = fromIntegral <$!> peek @Word16 (castPtr p)@@ -173,60 +255,92 @@         -- using 'with' within unsafeDupablePerformIO is probably safe because         -- with uses 'alloca', which guarantees that the memory is released         -- when computation is abondended before being terminated.-    copyBytes p' p i+    copyBytes p' p (fromIntegral i)     peek p' {-# INLINE ptrToWord64 #-} -rounds1 :: Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)-rounds1 !v0 !v1 !v2 !v3 = sipRound v0 v1 v2 v3-{-# INLINE rounds1 #-}+class SipHashParam (n :: Nat) where+    rounds :: Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #) -rounds2 :: Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)-rounds2 !v0 !v1 !v2 !v3 =-    let (# !v0', !v1', !v2', !v3' #) = sipRound v0 v1 v2 v3-    in sipRound v0' v1' v2' v3'-{-# INLINE rounds2 #-}+instance SipHashRounds n (SlowRounds n) => SipHashParam (n :: Nat) where+    rounds = rounds_ @n @(SlowRounds n)+    {-# INLINE rounds #-} -rounds3 :: Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)-rounds3 !v0 !v1 !v2 !v3 =-    let (# !v0', !v1', !v2', !v3' #) = sipRound v0 v1 v2 v3-        (# !v0'', !v1'', !v2'', !v3'' #) = sipRound v0' v1' v2' v3'-    in sipRound v0'' v1'' v2'' v3''-{-# INLINE rounds3 #-}+-- -------------------------------------------------------------------------- --+-- SipHash Rounds -rounds4 :: Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)-rounds4 !v0 !v1 !v2 !v3 =-    let (# !v0', !v1', !v2', !v3' #) = sipRound v0 v1 v2 v3-        (# !v0'', !v1'', !v2'', !v3'' #) = sipRound v0' v1' v2' v3'-        (# !v0''', !v1''', !v2''', !v3''' #) = sipRound v0'' v1'' v2'' v3''-    in sipRound v0''' v1''' v2''' v3'''-{-# INLINE rounds4 #-}+-- Decide wether to pick an fast specialized routes implementation or a somewhat+-- less efficient generic implementation.+--+type SlowRounds r = CmpNat r 8 == 'GT -rounds8 :: Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)-rounds8 !v0 !v1 !v2 !v3 =-    let (# !v0', !v1', !v2', !v3' #) = sipRound v0 v1 v2 v3-        (# !v0'', !v1'', !v2'', !v3'' #) = sipRound v0' v1' v2' v3'-        (# !v0''', !v1''', !v2''', !v3''' #) = sipRound v0'' v1'' v2'' v3''-        (# !v0'''', !v1'''', !v2'''', !v3'''' #) = sipRound v0''' v1''' v2''' v3'''-        (# !v0''''', !v1''''', !v2''''', !v3''''' #) = sipRound v0'''' v1'''' v2'''' v3''''-        (# !v0'''''', !v1'''''', !v2'''''', !v3'''''' #) = sipRound v0''''' v1''''' v2''''' v3'''''-        (# !v0''''''', !v1''''''', !v2''''''', !v3''''''' #) = sipRound v0'''''' v1'''''' v2'''''' v3''''''-    in sipRound v0''''''' v1''''''' v2''''''' v3'''''''-{-# INLINE rounds8 #-}+-- TODO: create benchmark to check how well inlining works for recursive type class function calls,+-- It's possibly, that we don't need all these specializations but inlining gets the job done all by+-- itself. -rounds :: Int -> Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)-rounds 1 !v0 !v1 !v2 !v3 = rounds1 v0 v1 v2 v3-rounds 2 !v0 !v1 !v2 !v3 = rounds2 v0 v1 v2 v3-rounds 3 !v0 !v1 !v2 !v3 = rounds3 v0 v1 v2 v3-rounds 4 !v0 !v1 !v2 !v3 = rounds4 v0 v1 v2 v3-rounds 8 !v0 !v1 !v2 !v3 = rounds8 v0 v1 v2 v3-rounds !c !v0 !v1 !v2 !v3 = case sipRound v0 v1 v2 v3 of-    (# v0', v1', v2', v3' #) -> rounds (c - 1) v0' v1' v2' v3'-{-# INLINE rounds #-}+class SipHashRounds (n :: Nat) (x :: Bool) where+    rounds_ :: Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #) +instance SipHashRounds 1 'False where+    rounds_ !v0 !v1 !v2 !v3 = sipRound v0 v1 v2 v3+    {-# INLINE rounds_ #-}++instance SipHashRounds 2 'False where+    rounds_ !v0 !v1 !v2 !v3 =+        let (# !v0', !v1', !v2', !v3' #) = sipRound v0 v1 v2 v3+        in sipRound v0' v1' v2' v3'+    {-# INLINE rounds_ #-}++instance SipHashRounds 3 'False where+    rounds_ !v0 !v1 !v2 !v3 =+        let (# !v0', !v1', !v2', !v3' #) = sipRound v0 v1 v2 v3+            (# !v0'', !v1'', !v2'', !v3'' #) = sipRound v0' v1' v2' v3'+        in sipRound v0'' v1'' v2'' v3''+    {-# INLINE rounds_ #-}++instance SipHashRounds 4 'False where+    rounds_ !v0 !v1 !v2 !v3 =+        let (# !v0', !v1', !v2', !v3' #) = sipRound v0 v1 v2 v3+            (# !v0'', !v1'', !v2'', !v3'' #) = sipRound v0' v1' v2' v3'+            (# !v0''', !v1''', !v2''', !v3''' #) = sipRound v0'' v1'' v2'' v3''+        in sipRound v0''' v1''' v2''' v3'''+    {-# INLINE rounds_ #-}++instance SipHashRounds 5 'False where+    rounds_ !v0 !v1 !v2 !v3 = case rounds_ @4 @'False v0 v1 v2 v3 of+        (# v0', v1', v2', v3' #) -> rounds_ @1 @'False v0' v1' v2' v3'+    {-# INLINE rounds_ #-}++instance SipHashRounds 6 'False where+    rounds_ !v0 !v1 !v2 !v3 = case rounds_ @4 @'False v0 v1 v2 v3 of+        (# v0', v1', v2', v3' #) -> rounds_ @2 @'False v0' v1' v2' v3'+    {-# INLINE rounds_ #-}++instance SipHashRounds 7 'False where+    rounds_ !v0 !v1 !v2 !v3 = case rounds_ @4 @'False v0 v1 v2 v3 of+        (# v0', v1', v2', v3' #) -> rounds_ @3 @'False v0' v1' v2' v3'+    {-# INLINE rounds_ #-}++instance SipHashRounds 8 'False where+    rounds_ !v0 !v1 !v2 !v3 =+        let (# !v0', !v1', !v2', !v3' #) = sipRound v0 v1 v2 v3+            (# !v0'', !v1'', !v2'', !v3'' #) = sipRound v0' v1' v2' v3'+            (# !v0''', !v1''', !v2''', !v3''' #) = sipRound v0'' v1'' v2'' v3''+            (# !v0'''', !v1'''', !v2'''', !v3'''' #) = sipRound v0''' v1''' v2''' v3'''+            (# !v0''''', !v1''''', !v2''''', !v3''''' #) = sipRound v0'''' v1'''' v2'''' v3''''+            (# !v0'''''', !v1'''''', !v2'''''', !v3'''''' #) = sipRound v0''''' v1''''' v2''''' v3'''''+            (# !v0''''''', !v1''''''', !v2''''''', !v3''''''' #) = sipRound v0'''''' v1'''''' v2'''''' v3''''''+        in sipRound v0''''''' v1''''''' v2''''''' v3'''''''+    {-# INLINE rounds_ #-}++instance ((CmpNat n 8 == 'GT) ~ 'True, SipHashRounds (n-8) t) => SipHashRounds n 'True where+    rounds_ !v0 !v1 !v2 !v3 = case rounds_ @8 @'False v0 v1 v2 v3 of+        (# v0', v1', v2', v3' #) -> rounds_ @(n - 8) @t v0' v1' v2' v3'+    {-# INLINE rounds_ #-}+ sipRound :: Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #) sipRound !v0 !v1 !v2 !v3 = (# v0''', v1'''', v2''', v3'''' #)-    where+  where     !v0' = v0 + v1     !v2' = v2 + v3     !v1' = v1 `rotateL` 13@@ -242,4 +356,5 @@     !v3'''' = v3''' `xor` v0'''     !v2''' = v2'' `rotateL` 32 {-# INLINE sipRound #-}+ 

@@ -1,144 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UnboxedTuples #-}---- |--- Module: Data.Hash.Utils--- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>--- License: MIT--- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>--- Stability: experimental----module Data.Hash.Utils-(--- * Pure API-  hashStorable-, hashStorable_-, hashByteString-, hashByteString_-, hashByteArray-, hashByteArray_-, hashPtr-, hashPtr_---- * IO API-, hashStorableIO-, hashStorableIO_-, hashByteStringIO-, hashByteStringIO_-, hashByteArrayIO-, hashByteArrayIO_-) where--import qualified Data.ByteString as B-import qualified Data.ByteString.Unsafe as B-import Data.Word--import Foreign.Marshal.Utils-import Foreign.Ptr-import Foreign.Storable--import GHC.Exts-import GHC.IO-import Foreign.Marshal.Alloc---- -------------------------------------------------------------------------- ----- Pure API---- Storable--hashStorable :: Storable a => (Ptr Word8 -> Int -> IO b) -> a -> b-hashStorable f = unsafeDupablePerformIO . hashStorableIO f-{-# INLINE hashStorable #-}--hashStorable_ :: Storable a => (Ptr Word8 -> Int -> b -> IO b) -> a -> b -> b-hashStorable_ f a = unsafeDupablePerformIO . hashStorableIO_ f a-{-# INLINE hashStorable_ #-}---- ByteString--hashByteString :: (Ptr Word8 -> Int -> IO b) -> B.ByteString -> b-hashByteString f = unsafeDupablePerformIO . hashByteStringIO f-{-# INLINE hashByteString #-}--hashByteString_ :: (Ptr Word8 -> Int -> b -> IO b) -> B.ByteString -> b -> b-hashByteString_ f a = unsafeDupablePerformIO . hashByteStringIO_ f a-{-# INLINE hashByteString_ #-}---- ByteArray--hashByteArray :: (Ptr Word8 -> Int -> IO b) -> ByteArray# -> b-hashByteArray f a# = unsafeDupablePerformIO $! hashByteArrayIO f a#-{-# INLINE hashByteArray #-}--hashByteArray_ :: (Ptr Word8 -> Int -> b -> IO b) -> ByteArray# -> b -> b-hashByteArray_ f a# = unsafeDupablePerformIO . hashByteArrayIO_ f a#-{-# INLINE hashByteArray_ #-}---- Ptr--hashPtr :: (Ptr Word8 -> Int -> IO b) -> Ptr Word8 -> Int -> b-hashPtr f ptr = unsafeDupablePerformIO . f ptr-{-# INLINE hashPtr #-}--hashPtr_ :: (Ptr Word8 -> Int -> b -> IO b) -> Ptr Word8 -> Int -> b -> b-hashPtr_ f ptr l = unsafeDupablePerformIO . f ptr l-{-# INLINE hashPtr_ #-}---- -------------------------------------------------------------------------- ----- IO API---- Storable--hashStorableIO :: Storable a => (Ptr Word8 -> Int -> IO b) -> a -> IO b-hashStorableIO f a = with a $ \ptr -> f (castPtr ptr) (sizeOf a)-{-# INLINE hashStorableIO #-}--hashStorableIO_ :: Storable a => (Ptr Word8 -> Int -> b -> IO b) -> a -> b -> IO b-hashStorableIO_ f a b = with a $ \ptr -> f (castPtr ptr) (sizeOf a) b-{-# INLINE hashStorableIO_ #-}---- ByteString--hashByteStringIO :: (Ptr Word8 -> Int -> IO b) -> B.ByteString -> IO b-hashByteStringIO f a = B.unsafeUseAsCStringLen a $ \(!p, !l) -> f (castPtr p) l-{-# INLINE hashByteStringIO #-}--hashByteStringIO_ :: (Ptr Word8 -> Int -> b -> IO b) -> B.ByteString -> b -> IO b-hashByteStringIO_ f a b = B.unsafeUseAsCStringLen a $ \(!p, !l) -> f (castPtr p) l b-{-# INLINE hashByteStringIO_ #-}---- ByteArray--hashByteArrayIO :: (Ptr Word8 -> Int -> IO b) -> ByteArray# -> IO b-hashByteArrayIO f a# = case isByteArrayPinned# a# of-    -- Pinned ByteArray-    1# -> f (Ptr (byteArrayContents# a#)) (I# size#)--    -- Unpinned ByteArray, copy content to newly allocated pinned ByteArray-    _ -> allocaBytes (I# size#) $ \ptr@(Ptr addr#) -> IO $ \s0 ->-        case copyByteArrayToAddr# a# 0# addr# size# s0 of-            s1 -> case f ptr (I# size#) of-                IO run -> run s1-  where-    size# = sizeofByteArray# a#-{-# INLINE hashByteArrayIO #-}---hashByteArrayIO_ :: (Ptr Word8 -> Int -> b -> IO b) -> ByteArray# -> b -> IO b-hashByteArrayIO_ f a# b = case isByteArrayPinned# a# of-    -- Pinned ByteArray-    1# -> f (Ptr (byteArrayContents# a#)) (I# size#) b--    -- Unpinned ByteArray, copy content to newly allocated pinned ByteArray-    _ -> allocaBytes (I# size#) $ \ptr@(Ptr addr#) -> IO $ \s0 ->-        case copyByteArrayToAddr# a# 0# addr# size# s0 of-            s1 -> case f ptr (I# size#) b of-                IO run -> run s1-  where-    size# = sizeofByteArray# a#-{-# INLINE hashByteArrayIO_ #-}-

@@ -0,0 +1,166 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module: Cryptonite+-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>+-- License: MIT+-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>+-- Stability: experimental+--+-- Compatibility with Cryptonite+--+module Cryptonite+( run+, tests+) where++import Control.Monad++#if defined(WITH_OPENSSL)+import qualified Crypto.Hash as C+import qualified Data.ByteArray as BA+import qualified Data.ByteString.Short as BS+import Data.Coerce+#endif++import qualified Data.ByteArray.Hash as BA+import qualified Data.ByteString as B+import Data.Word++import Test.QuickCheck+import Test.Syd++-- internal modules++#if defined(WITH_OPENSSL)+import Data.Hash.SHA2+import Data.Hash.SHA3+import Data.Hash.Blake2+import Data.Hash.Keccak+import qualified Data.Hash.Class.Mutable as M+#endif++import qualified Data.Hash.SipHash as SH+import qualified Data.Hash.FNV1 as FH++-- -------------------------------------------------------------------------- --+-- OpenSSL++run :: IO ()+run = forM_ properties $ \(n, t) -> do+    putStrLn $ "cryptonite compatiblity for " <> n+    quickCheck t++tests :: Spec+tests = mapM_ (uncurry prop) properties++#if defined(WITH_OPENSSL)+prop_eq+    :: forall alg calg+    . Coercible BS.ShortByteString alg+    => C.HashAlgorithm calg+    => M.Hash alg+    => [Word8]+    -> Property+prop_eq b = internal === cryptonite+  where+    bytes = B.pack b+    cryptonite = BS.toShort $ BA.convert $ C.hash @_ @calg bytes+    internal = coerce $ M.hashByteString @alg bytes+#endif++-- -------------------------------------------------------------------------- --+-- SipHash++-- | Compare with SipHash from the memory package+--+prop_eq_sip :: Word64 -> Word64 -> [Word8] -> Property+prop_eq_sip w0 w1 b = internal === memory+  where+    bytes = B.pack b+    SH.SipHash internal = SH.hashByteString @(SH.SipHash 2 4) (SH.SipHashKey w0 w1) bytes+    BA.SipHash memory = BA.sipHash (BA.SipKey w0 w1) bytes++-- -------------------------------------------------------------------------- --+-- Fvn1Hash++prop_eq_fnv132 :: [Word8] -> Property+prop_eq_fnv132 b = internal === memory+  where+    bytes = B.pack b+    FH.Fnv132Hash internal = FH.hashByteString @FH.Fnv132Hash bytes+    BA.FnvHash32 memory = BA.fnv1Hash bytes++prop_eq_fnv164 :: [Word8] -> Property+prop_eq_fnv164 b = internal === memory+  where+    bytes = B.pack b+    FH.Fnv164Hash internal = FH.hashByteString @FH.Fnv164Hash bytes+    BA.FnvHash64 memory = BA.fnv1_64Hash bytes++-- FIXME: assumes x_64+prop_eq_fnv1Host :: [Word8] -> Property+prop_eq_fnv1Host b = fromIntegral internal64 === internalHost+  where+    bytes = B.pack b+    FH.Fnv164Hash internal64 = FH.hashByteString @FH.Fnv164Hash bytes+    FH.Fnv1Hash internalHost = FH.hashByteString @FH.Fnv1Hash bytes++prop_eq_fnv1a32 :: [Word8] -> Property+prop_eq_fnv1a32 b = internal === memory+  where+    bytes = B.pack b+    FH.Fnv1a32Hash internal = FH.hashByteString @FH.Fnv1a32Hash bytes+    BA.FnvHash32 memory = BA.fnv1aHash bytes++prop_eq_fnv1a64 :: [Word8] -> Property+prop_eq_fnv1a64 b = internal === memory+  where+    bytes = B.pack b+    FH.Fnv1a64Hash internal = FH.hashByteString @FH.Fnv1a64Hash bytes+    BA.FnvHash64 memory = BA.fnv1a_64Hash bytes++-- FIXME: assumes x_64+prop_eq_fnv1aHost :: [Word8] -> Property+prop_eq_fnv1aHost b = fromIntegral internal64 === internalHost+  where+    bytes = B.pack b+    FH.Fnv1a64Hash internal64 = FH.hashByteString @FH.Fnv1a64Hash bytes+    FH.Fnv1aHash internalHost = FH.hashByteString @FH.Fnv1aHash bytes++-- -------------------------------------------------------------------------- --+-- Tests++properties :: [(String, Property)]+properties =+    [ ("prop_eq_sip", property prop_eq_sip)+    , ("prop_eq_fnv132", property prop_eq_fnv132)+    , ("prop_eq_fnv164", property prop_eq_fnv164)+    , ("prop_eq_fnv1Host", property prop_eq_fnv1Host)+    , ("prop_eq_fnv1a32", property prop_eq_fnv1a32)+    , ("prop_eq_fnv1a64", property prop_eq_fnv1a64)+    , ("prop_eq_fnv1aHost", property prop_eq_fnv1aHost)+#if defined(WITH_OPENSSL)+    , ("SHA2_224", property $ prop_eq @Sha2_224 @C.SHA224)+    , ("SHA2_256", property $ prop_eq @Sha2_256 @C.SHA256)+    , ("SHA2_384", property $ prop_eq @Sha2_384 @C.SHA384)+    , ("SHA2_512", property $ prop_eq @Sha2_512 @C.SHA512)+    , ("SHA2_512_224", property $ prop_eq @Sha2_512_224 @C.SHA512t_224)+    , ("SHA2_512_256", property $ prop_eq @Sha2_512_256 @C.SHA512t_256)+    , ("SHA3_224", property $ prop_eq @Sha3_224 @C.SHA3_224)+    , ("SHA3_256", property $ prop_eq @Sha3_256 @C.SHA3_256)+    , ("SHA3_384", property $ prop_eq @Sha3_384 @C.SHA3_384)+    , ("SHA3_512", property $ prop_eq @Sha3_512 @C.SHA3_512)+    , ("Blake2s256", property $ prop_eq @Blake2s256 @C.Blake2s_256)+    , ("Blake2b512", property $ prop_eq @Blake2b512 @C.Blake2b_512)+    , ("Keccak256", property $ prop_eq @Keccak256 @C.Keccak_256)+#endif+    ]+

@@ -1,4 +1,4 @@-+{-# LANGUAGE CPP #-} -- | -- Module: Main -- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>@@ -8,15 +8,29 @@ -- module Main ( main+, tests ) where  import qualified Test.Data.Hash.FNV1 import qualified Test.Data.Hash.SipHash-import qualified Test.Data.Hash.Utils+import qualified Test.Data.Hash.Class.Pure +#if defined(TEST_CRYPTONITE)+import qualified Cryptonite+#endif++import Test.Syd+ main :: IO ()-main = do-    putStrLn "Test.Data.Hash.FNV1.tests: " >> Test.Data.Hash.FNV1.tests-    putStrLn "Test.Data.Hash.SipHash.tests: " >> Test.Data.Hash.SipHash.tests-    putStrLn "Test.Data.Hash.Utils:" >> Test.Data.Hash.Utils.tests+main = sydTest tests++tests :: Spec+tests = do+    describe "Test.Data.Hash.FNV1.tests" Test.Data.Hash.FNV1.tests+    describe "Test.Data.Hash.SipHash.tests" Test.Data.Hash.SipHash.tests+    describe "Test.Data.Hash.Class.Pure" Test.Data.Hash.Class.Pure.tests++#if defined(TEST_CRYPTONITE)+    describe "Cryptonite" Cryptonite.tests+#endif 

@@ -0,0 +1,115 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}++-- |+-- Module: Test.Data.Hash.Class.Pure+-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>+-- License: MIT+-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>+-- Stability: experimental+--+module Test.Data.Hash.Class.Pure+( tests+, run+) where++import Data.Bits+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Short as BS+import qualified Data.ByteString.Unsafe as B++import Foreign.Marshal+import Foreign.Ptr++import GHC.Exts+import GHC.IO+import GHC.Word++import Test.QuickCheck+import Test.Syd++-- internal modules++import Data.Hash.Class.Pure.Salted++-- -------------------------------------------------------------------------- --+--++tests :: Spec+tests = do+    prop "prop_hashByteString" prop_hashByteString+    prop "prop_hashByteStringLazy" prop_hashByteStringLazy+    prop "prop_hashShortByteString" prop_hashShortByteString+    prop "prop_hashStorable" prop_hashStorable+    prop "prop_hashPtr" prop_hashPtr+    prop "prop_hashByteArray" prop_hashByteArray++run :: IO ()+run = do+    putStrLn "prop_hashByteString"+    quickCheck prop_hashByteString+    putStrLn "prop_hashByteStringLazy"+    quickCheck prop_hashByteStringLazy+    putStrLn "prop_hashShortByteString"+    quickCheck prop_hashShortByteString+    putStrLn "prop_hashStorable"+    quickCheck prop_hashStorable+    putStrLn "prop_hashPtr"+    quickCheck prop_hashPtr+    putStrLn "prop_hashByteArray"+    quickCheck prop_hashByteArray++word8sToWord64 :: [Word8] -> Word64+word8sToWord64 = foldr (\b c -> fromIntegral b + shiftL c 8) 0++newtype TestHash = TestHash { _getTestHash :: [Word8] }+    deriving (Eq, Ord, Show)++instance IncrementalHash TestHash where+    type Context TestHash = [Word8]+    update ctx p l = (ctx ++) <$> peekArray l p+    finalize = TestHash++instance Hash TestHash where+    type Salt TestHash = ()+    initialize _ = []++prop_hashStorable :: Word64 -> Property+prop_hashStorable b = word8sToWord64 (_getTestHash $ hashStorable @TestHash () b) === b++prop_hashPtr :: [Word8] -> Property+prop_hashPtr b = unsafeDupablePerformIO $+    B.unsafeUseAsCStringLen (B.pack b) $ \(ptr, len) -> do+        return $ unsafeDupablePerformIO (hashPtr @TestHash () (castPtr ptr) len) === TestHash b++prop_hashByteString :: [Word8] -> Property+prop_hashByteString b = hashByteString @TestHash () (B.pack b) === TestHash b++prop_hashByteStringLazy :: [Word8] -> Property+prop_hashByteStringLazy b = hashByteStringLazy @TestHash () (BL.pack b) === TestHash b++prop_hashShortByteString :: [Word8] -> Property+prop_hashShortByteString b = hashShortByteString @TestHash () (BS.pack b) === TestHash b++prop_hashByteArray :: [Word8] -> Property+prop_hashByteArray bytes = unsafeDupablePerformIO $ IO $ \s0 ->+    case newPinnedByteArray# size s0 of+        (# s1, a# #) ->+            case copyToArray 0# bytes a# s1 of+                s2 -> case unsafeFreezeByteArray# a# s2 of+                    (# s3, b# #) ->+                        let r = hashByteArray @TestHash () b# === TestHash bytes+                        in (# s3, r #)+  where+    !(I# size) = length bytes++    copyToArray _ [] _ s = s+    copyToArray i ((W8# h):t) a s = case writeWord8Array# a i h s of+        s' -> copyToArray (i +# 1#) t a s'

@@ -1,7 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}  -- | -- Module: Test.Data.Hash.FNV1@@ -12,16 +14,20 @@ -- module Test.Data.Hash.FNV1 ( tests+, run ) where  import Data.Bifunctor import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B import Data.Word  import GHC.Ptr -import Test.QuickCheck+import System.IO.Unsafe +import Test.Syd+ -- internal modules  import Data.Hash.FNV1@@ -29,26 +35,42 @@ -- -------------------------------------------------------------------------- -- -- All tests -tests :: IO ()-tests = quickCheck $ tests64-    && tests32-    && tests64a-    && tests32a-    && testsPrim-    && testsPrima+run :: Bool+run = run64+    && run32+    && run64a+    && run32a+    && runPrim+    && runPrima +tests :: Spec+tests = do+    describe "FNV1 64 bit" tests64+    describe "FNV1 32 bit" tests32+    describe "FNV1a 64 bit" tests64a+    describe "FNV1a 32 bit" tests32a+    describe "FNV1 host word size" testsPrim+    describe "FNV1a host word size" testsPrima+ -- -------------------------------------------------------------------------- -- -- 64 bit FNV1 -tests64 :: Bool-tests64 = all test64 testVectors64+run64 :: Bool+run64 = all test64 testVectors64     && all testZero64 zeros64 +tests64 :: Spec+tests64 = do+    describe "Test Vectors" $ do+        mapM_ (\x -> it (show x) (test64 x)) testVectors64+    describe "Inputs up to 9 bytes that hash to 0" $ do+        mapM_ (\x -> it (show x) (testZero64 x)) zeros64+ test64 :: (B.ByteString, Word64) -> Bool-test64 (b, r) = hashByteString fnv1_64 b == r+test64 (b, r) = hashByteString @Fnv164Hash b == Fnv164Hash r  testZero64 :: B.ByteString -> Bool-testZero64 b = hashByteString fnv1_64 b == 0+testZero64 b = hashByteString @Fnv164Hash b == Fnv164Hash 0  testVectors64 :: [(B.ByteString, Word64)] testVectors64 = []@@ -303,15 +325,22 @@ -- -------------------------------------------------------------------------- -- -- 64 bit FNV1a -tests64a :: Bool-tests64a = all test64a testVectors64a+run64a :: Bool+run64a = all test64a testVectors64a     && all testZero64a zeros64a +tests64a :: Spec+tests64a = do+    describe "Test Vectors" $ do+        mapM_ (\x -> it (show x) (test64a x)) testVectors64a+    describe "Inputs up to 8 bytes that hash to 0" $ do+        mapM_ (\x -> it (show x) (testZero64a x)) zeros64a+ test64a :: (B.ByteString, Word64) -> Bool-test64a (b, r) = hashByteString fnv1a_64 b == r+test64a (b, r) = hashByteString @Fnv1a64Hash b == Fnv1a64Hash r  testZero64a :: B.ByteString -> Bool-testZero64a b = hashByteString fnv1a_64 b == 0+testZero64a b = hashByteString @Fnv1a64Hash b == Fnv1a64Hash 0  testVectors64a :: [(B.ByteString, Word64)] testVectors64a = []@@ -329,19 +358,26 @@ -- -------------------------------------------------------------------------- -- -- 32 bit FNV1 -tests32 :: Bool-tests32 = all test32 testVectors32+run32 :: Bool+run32 = all test32 testVectors32     && all testZero32 zeros32     && testZero32 zero32ff +tests32 :: Spec+tests32 = do+    describe "Test Vectors" $ do+        mapM_ (\x -> it (show x) (test32 x)) testVectors32+    describe "Two out of 254 inputs of up to 5 bytes that hash to 0" $ do+        mapM_ (\x -> it (show x) (testZero32 x)) zeros32+ test32 :: (B.ByteString, Word32) -> Bool-test32 (b, r) = hashByteString fnv1_32 b == r+test32 (b, r) = hashByteString @Fnv132Hash b == Fnv132Hash r  testVectors32 :: [(B.ByteString, Word32)] testVectors32 = []  testZero32 :: B.ByteString -> Bool-testZero32 b = hashByteString fnv1_32 b == 0+testZero32 b = hashByteString @Fnv132Hash b == Fnv132Hash 0  -- | Two out of 254 inputs of up to 5 bytes length that result in a -- fnv1 32 bit hash of 0.@@ -365,19 +401,26 @@ -- -------------------------------------------------------------------------- -- -- 32 bit FNV1a -tests32a :: Bool-tests32a = all test32a testVectors32a+run32a :: Bool+run32a = all test32a testVectors32a     && all testZero32a zeros32a     && testZero32a zero32ffa +tests32a :: Spec+tests32a = do+    describe "Test Vectors" $ do+        mapM_ (\x -> it (show x) (test32a x)) testVectors32a+    describe "Inputs up to 4 bytes that hash to 0" $ do+        mapM_ (\x -> it (show x) (testZero32a x)) zeros32a+ test32a :: (B.ByteString, Word32) -> Bool-test32a (b, r) = hashByteString fnv1a_32 b == r+test32a (b, r) = hashByteString @Fnv1a32Hash b == Fnv1a32Hash r  testVectors32a :: [(B.ByteString, Word32)] testVectors32a = []  testZero32a :: B.ByteString -> Bool-testZero32a b = hashByteString fnv1a_32 b == 0+testZero32a b = hashByteString @Fnv1a32Hash b == Fnv1a32Hash 0  -- | All FNV1a 32 bit inputs that result in a hash of 0 up to a length of four -- bytes.@@ -397,14 +440,21 @@ -- Primitive FNV1  primitiveFnv1 :: B.ByteString -> Word-primitiveFnv1 = hashByteString $ \(Ptr addr) n ->-    fromIntegral <$> fnv1 addr n+primitiveFnv1 b = unsafeDupablePerformIO $+    B.unsafeUseAsCStringLen b $ \(addr, n) -> fnv1_host (castPtr addr) n {-# INLINE primitiveFnv1 #-} -testsPrim :: Bool-testsPrim = all testPrim testVectorsPrim+runPrim :: Bool+runPrim = all testPrim testVectorsPrim     && all testZeroPrim zerosPrim +testsPrim :: Spec+testsPrim = do+    describe "Test Vectors" $ do+        mapM_ (\x -> it (show x) (testPrim x)) testVectorsPrim+    describe "Inputs up to 9 bytes that hash to 0" $ do+        mapM_ (\x -> it (show x) (testZeroPrim x)) zerosPrim+ testPrim :: (B.ByteString, Word) -> Bool testPrim (b, r) = primitiveFnv1 b == r @@ -433,13 +483,20 @@ -- Primitive FNV1a  primitiveFnv1a :: B.ByteString -> Word-primitiveFnv1a = hashByteString $ \(Ptr addr) n ->-    fromIntegral <$> fnv1a addr n+primitiveFnv1a b = unsafeDupablePerformIO $+    B.unsafeUseAsCStringLen b $ \(addr, n) -> fnv1a_host (castPtr addr) n {-# INLINE primitiveFnv1a #-} -testsPrima :: Bool-testsPrima = all testPrima testVectorsPrima+runPrima :: Bool+runPrima = all testPrima testVectorsPrima     && all testZeroPrima zerosPrima++testsPrima :: Spec+testsPrima = do+    describe "Test Vectors" $ do+        mapM_ (\x -> it (show x) (testPrima x)) testVectorsPrima+    describe "Inputs up to 8 bytes that hash to 0" $ do+        mapM_ (\x -> it (show x) (testZeroPrima x)) zerosPrima  testPrima :: (B.ByteString, Word) -> Bool testPrima (b, r) = primitiveFnv1a b == r

@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -12,6 +13,7 @@ -- module Test.Data.Hash.SipHash ( tests+, run ) where  import qualified Data.ByteString as B@@ -20,7 +22,7 @@  import System.IO.Unsafe -import Test.QuickCheck+import Test.Syd  -- internal modules @@ -36,13 +38,16 @@ -- -------------------------------------------------------------------------- -- -- Tests --- internal sip hash implementation-tests :: IO ()-tests = quickCheck $ all test [0..63]+tests :: Spec+tests = describe "SipHash-2-4 Test Vectors" $ do+    mapM_ (\i -> it (show i) (test i)) [0..length testVectors - 1]  test :: Int -> Bool-test i = hashByteString (uncurry sipHash24 testKey) (testInput i) == (testVectors !! i)+test i = hashByteString @(SipHash 2 4) testKey (testInput i) == (testVectors !! i) +run :: Bool+run = all test [0..length testVectors - 1]+ -- -------------------------------------------------------------------------- -- -- Test Vectors from https://svn.grid.pub.ro/svn/bhyve-save-restore/trunk/sys/crypto/siphash/siphash_test.c @@ -76,14 +81,14 @@  */ -} -testKey :: (Word64, Word64)-testKey = (bytesToWord64 [0..7], bytesToWord64 [8..15])+testKey :: SipHashKey+testKey = SipHashKey (bytesToWord64 [0..7]) (bytesToWord64 [8..15])  testInput :: Int -> B.ByteString testInput i = B.pack $ fromIntegral <$> [0..i-1] -testVectors :: [Word64]-testVectors = bytesToWord64 <$>+testVectors :: [SipHash 2 4]+testVectors = SipHash . bytesToWord64 <$>     [ [ 0x31, 0x0e, 0x0e, 0xdd, 0x47, 0xdb, 0x6f, 0x72 ]     , [ 0xfd, 0x67, 0xdc, 0x93, 0xc5, 0x39, 0xf8, 0x74 ]     , [ 0x5a, 0x4f, 0xa9, 0xd9, 0x09, 0x80, 0x6c, 0x0d ]

@@ -1,78 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UnboxedTuples #-}---- |--- Module: Test.Data.Hash.Utils--- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>--- License: MIT--- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>--- Stability: experimental----module Test.Data.Hash.Utils-( tests-) where--import qualified Data.ByteString as B-import qualified Data.ByteString.Unsafe as B--import Foreign.Marshal-import Foreign.Ptr-import Foreign.Storable--import GHC.Exts-import GHC.IO-import GHC.Word--import Test.QuickCheck---- internal modules--import Data.Hash.Utils---- -------------------------------------------------------------------------- -------tests :: IO ()-tests = do-    putStrLn "prop_hashByteString"-    quickCheck prop_hashByteString-    putStrLn "prop_hashStorable"-    quickCheck prop_hashStorable-    putStrLn "prop_hashPtr"-    quickCheck prop_hashPtr-    putStrLn "prop_hashByteArray"-    quickCheck prop_hashByteArray--ptrToList :: Ptr Word8 -> Int -> IO [Word8]-ptrToList = flip peekArray--prop_hashStorable :: Word64 -> Property-prop_hashStorable b = hashStorable (\ptr _ -> peek (castPtr ptr)) b === b--prop_hashPtr :: [Word8] -> Property-prop_hashPtr b = unsafeDupablePerformIO $-    B.unsafeUseAsCStringLen (B.pack b) $ \(ptr, len) -> do-        return $ hashPtr ptrToList (castPtr ptr) len === b--prop_hashByteString :: [Word8] -> Property-prop_hashByteString b = hashByteString ptrToList (B.pack b) === b--prop_hashByteArray :: [Word8] -> Property-prop_hashByteArray bytes = unsafeDupablePerformIO $ IO $ \s0 ->-    case newPinnedByteArray# size s0 of-        (# s1, a# #) ->-            case copyToArray 0# bytes a# s1 of-                s2 -> case unsafeFreezeByteArray# a# s2 of-                    (# s3, b# #) ->-                        let r = hashByteArray ptrToList b# === bytes-                        in (# s3, r #)-  where-    !(I# size) = length bytes--    copyToArray _ [] _ s = s-    copyToArray i ((W8# h):t) a s = case writeWord8Array# a i h s of-        s' -> copyToArray (i +# 1#) t a s'