diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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)) diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.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 diff --git a/cbits/keccak-example.c b/cbits/keccak-example.c new file mode 100644 --- /dev/null +++ b/cbits/keccak-example.c @@ -0,0 +1,49 @@ +#include +#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; +} diff --git a/cbits/keccak.c b/cbits/keccak.c new file mode 100644 --- /dev/null +++ b/cbits/keccak.c @@ -0,0 +1,145 @@ +#include +#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 + diff --git a/cbits/keccak.h b/cbits/keccak.h new file mode 100644 --- /dev/null +++ b/cbits/keccak.h @@ -0,0 +1,30 @@ +#include + +/* *************************************************************************** */ +/* 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); + diff --git a/hashes.cabal b/hashes.cabal --- a/hashes.cabal +++ b/hashes.cabal @@ -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 diff --git a/src/Data/Hash/Blake2.hs b/src/Data/Hash/Blake2.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hash/Blake2.hs @@ -0,0 +1,31 @@ +-- | +-- Module: Data.Hash.Blake2 +-- Copyright: Copyright © 2021 Lars Kuhtz +-- License: MIT +-- Maintainer: Lars Kuhtz +-- 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 + + diff --git a/src/Data/Hash/Class/Mutable.hs b/src/Data/Hash/Class/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hash/Class/Mutable.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module: Data.Hash.Class.Mutable +-- Copyright: Copyright © 2021 Lars Kuhtz +-- License: MIT +-- Maintainer: Lars Kuhtz +-- 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 #-} + diff --git a/src/Data/Hash/Class/Mutable/Internal.hs b/src/Data/Hash/Class/Mutable/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hash/Class/Mutable/Internal.hs @@ -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 +-- License: MIT +-- Maintainer: Lars Kuhtz +-- 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 #-} + diff --git a/src/Data/Hash/Class/Mutable/Salted.hs b/src/Data/Hash/Class/Mutable/Salted.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hash/Class/Mutable/Salted.hs @@ -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 +-- License: MIT +-- Maintainer: Lars Kuhtz +-- 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 #-} + diff --git a/src/Data/Hash/Class/Pure.hs b/src/Data/Hash/Class/Pure.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hash/Class/Pure.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module: Data.Hash.Class.Pure +-- Copyright: Copyright © 2021 Lars Kuhtz +-- License: MIT +-- Maintainer: Lars Kuhtz +-- 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 #-} + diff --git a/src/Data/Hash/Class/Pure/Internal.hs b/src/Data/Hash/Class/Pure/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hash/Class/Pure/Internal.hs @@ -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 +-- License: MIT +-- Maintainer: Lars Kuhtz +-- 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 #-} + diff --git a/src/Data/Hash/Class/Pure/Salted.hs b/src/Data/Hash/Class/Pure/Salted.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hash/Class/Pure/Salted.hs @@ -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 +-- License: MIT +-- Maintainer: Lars Kuhtz +-- 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 #-} + diff --git a/src/Data/Hash/FNV1.hs b/src/Data/Hash/FNV1.hs --- a/src/Data/Hash/FNV1.hs +++ b/src/Data/Hash/FNV1.hs @@ -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 diff --git a/src/Data/Hash/FNV1/Salted.hs b/src/Data/Hash/FNV1/Salted.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hash/FNV1/Salted.hs @@ -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 +-- License: MIT +-- Maintainer: Lars Kuhtz +-- 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 #-} + diff --git a/src/Data/Hash/Internal/OpenSSL.hs b/src/Data/Hash/Internal/OpenSSL.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hash/Internal/OpenSSL.hs @@ -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 + +-- | +-- Module: Data.Hash.Internal.OpenSSL +-- Copyright: Copyright © 2021 Lars Kuhtz +-- License: MIT +-- Maintainer: Lars Kuhtz +-- 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 + diff --git a/src/Data/Hash/Internal/Utils.hs b/src/Data/Hash/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hash/Internal/Utils.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module: Data.Hash.Internal.Utils +-- Copyright: Copyright © 2021 Lars Kuhtz +-- License: MIT +-- Maintainer: Lars Kuhtz +-- 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 + diff --git a/src/Data/Hash/Keccak.hs b/src/Data/Hash/Keccak.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hash/Keccak.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module: Data.Hash.Keccak +-- Copyright: Copyright © 2021 Lars Kuhtz +-- License: MIT +-- Maintainer: Lars Kuhtz +-- 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 + diff --git a/src/Data/Hash/SHA2.hs b/src/Data/Hash/SHA2.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hash/SHA2.hs @@ -0,0 +1,30 @@ +-- | +-- Module: Data.Hash.SHA2 +-- Copyright: Copyright © 2021 Lars Kuhtz +-- License: MIT +-- Maintainer: Lars Kuhtz +-- 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 + diff --git a/src/Data/Hash/SHA3.hs b/src/Data/Hash/SHA3.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hash/SHA3.hs @@ -0,0 +1,30 @@ +-- | +-- Module: Data.Hash.SHA3 +-- Copyright: Copyright © 2021 Lars Kuhtz +-- License: MIT +-- Maintainer: Lars Kuhtz +-- 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 + diff --git a/src/Data/Hash/SipHash.hs b/src/Data/Hash/SipHash.hs --- a/src/Data/Hash/SipHash.hs +++ b/src/Data/Hash/SipHash.hs @@ -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 #-} + diff --git a/src/Data/Hash/Utils.hs b/src/Data/Hash/Utils.hs deleted file mode 100644 --- a/src/Data/Hash/Utils.hs +++ /dev/null @@ -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 --- License: MIT --- Maintainer: Lars Kuhtz --- 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_ #-} - diff --git a/test/Cryptonite.hs b/test/Cryptonite.hs new file mode 100644 --- /dev/null +++ b/test/Cryptonite.hs @@ -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 +-- License: MIT +-- Maintainer: Lars Kuhtz +-- 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 + ] + diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE CPP #-} -- | -- Module: Main -- Copyright: Copyright © 2021 Lars Kuhtz @@ -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 diff --git a/test/Test/Data/Hash/Class/Pure.hs b/test/Test/Data/Hash/Class/Pure.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/Hash/Class/Pure.hs @@ -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 +-- License: MIT +-- Maintainer: Lars Kuhtz +-- 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' diff --git a/test/Test/Data/Hash/FNV1.hs b/test/Test/Data/Hash/FNV1.hs --- a/test/Test/Data/Hash/FNV1.hs +++ b/test/Test/Data/Hash/FNV1.hs @@ -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 diff --git a/test/Test/Data/Hash/SipHash.hs b/test/Test/Data/Hash/SipHash.hs --- a/test/Test/Data/Hash/SipHash.hs +++ b/test/Test/Data/Hash/SipHash.hs @@ -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 ] diff --git a/test/Test/Data/Hash/Utils.hs b/test/Test/Data/Hash/Utils.hs deleted file mode 100644 --- a/test/Test/Data/Hash/Utils.hs +++ /dev/null @@ -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 --- License: MIT --- Maintainer: Lars Kuhtz --- 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'