diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015 - 2016 factis research GmbH + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +# LargeHashable + +[![Build Status](https://travis-ci.org/factisresearch/large-hashable.svg?branch=master)](https://travis-ci.org/factisresearch/large-hashable) + +Efficiently hash Haskell values with MD5, SHA256, SHA512 and other +hashing algorithms. + +## Build instructions + +- Install the stack tool (http://haskellstack.org) +- `stack build` builds the code +- `stack test` builds the code and runs the tests +- `run-benchmarks.sh` runs the benchmark suite diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmark/Data/LargeHashable/Benchmarks/CryptoHash.hs b/benchmark/Data/LargeHashable/Benchmarks/CryptoHash.hs new file mode 100644 --- /dev/null +++ b/benchmark/Data/LargeHashable/Benchmarks/CryptoHash.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE MagicHash #-} +module Data.LargeHashable.Benchmarks.CryptoHash where + +-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines") +import Data.Bits +import Data.Byteable +import Data.List (foldl') +import Data.Word +import qualified Crypto.Hash as H +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +data HashAlgorithm + = MD5 + | SHA256 + | SHA512 + deriving (Eq, Show) + +data HashCtx = forall h . H.HashAlgorithm h => HashCtx !(H.Context h) + +newtype Hash = Hash { unHash :: BS.ByteString } + deriving (Eq) + +instance Show Hash where + show (Hash bs) = + BSC.unpack (Base16.encode bs) + +hashMd5 :: LargeHashable h => h -> Hash +hashMd5 h = + let ctx = hashInit MD5 + in hashFinish (hashUpdate ctx h) + +hashInit :: HashAlgorithm -> HashCtx +hashInit alg = + case alg of + MD5 -> HashCtx (H.hashInit :: H.Context H.MD5) + SHA256 -> HashCtx (H.hashInit :: H.Context H.SHA256) + SHA512 -> HashCtx (H.hashInit :: H.Context H.SHA512) + +hashFinish :: HashCtx -> Hash +hashFinish (HashCtx x) = Hash (toBytes $ H.hashFinalize x) + +updateFromBuilder :: HashCtx -> B.Builder -> HashCtx +updateFromBuilder (HashCtx ctx) builder = + HashCtx (H.hashUpdates ctx (BSL.toChunks (B.toLazyByteString builder))) + +class LargeHashable a where + hashUpdate :: HashCtx -> a -> HashCtx + +instance LargeHashable BS.ByteString where + hashUpdate (HashCtx x) bs = HashCtx (H.hashUpdate x bs) + +instance LargeHashable Int where + hashUpdate (HashCtx ctx) i = + -- we can make this faster by accessing the machine represenation of an int + let w = (fromIntegral (toInteger i)) :: Word64 + in HashCtx (H.hashUpdate ctx (BS.pack [(fromIntegral (shiftR w 56) :: Word8) + ,(fromIntegral (shiftR w 48) :: Word8) + ,(fromIntegral (shiftR w 40) :: Word8) + ,(fromIntegral (shiftR w 32) :: Word8) + ,(fromIntegral (shiftR w 24) :: Word8) + ,(fromIntegral (shiftR w 16) :: Word8) + ,(fromIntegral (shiftR w 8) :: Word8) + ,(fromIntegral (w) :: Word8)])) + +instance LargeHashable T.Text where + hashUpdate (HashCtx ctx) t = HashCtx (H.hashUpdate ctx (T.encodeUtf8 t)) + +instance LargeHashable a => LargeHashable [a] where + hashUpdate ctx l = + foldl' hashUpdate ctx l diff --git a/benchmark/Data/LargeHashable/Benchmarks/Main.hs b/benchmark/Data/LargeHashable/Benchmarks/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Data/LargeHashable/Benchmarks/Main.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Data.LargeHashable.Benchmarks.Main (main) where + +import qualified Data.Text as T +import Data.SafeCopy +import Control.DeepSeq +import GHC.Generics +import Data.Serialize.Put +import System.Environment +import qualified Data.LargeHashable.Benchmarks.CryptoHash as CH +import qualified Data.LargeHashable.Benchmarks.Serial as Serial +import qualified Data.LargeHashable as LH +import qualified Data.Bytes.Serial as S + +data Patient + = Patient + { p_firstName :: !T.Text + , p_lastName :: !T.Text + , p_note :: !T.Text + , p_age :: !Int + } + deriving (Eq, Show, NFData, Generic) + +$(deriveSafeCopy 0 'base ''Patient) + +instance S.Serial Patient + +instance CH.LargeHashable Patient where + hashUpdate ctx0 p = + let !ctx1 = CH.hashUpdate ctx0 (p_firstName p) + !ctx2 = CH.hashUpdate ctx1 (p_lastName p) + !ctx3 = CH.hashUpdate ctx2 (p_note p) + !ctx4 = CH.hashUpdate ctx3 (p_age p) + in ctx4 + +instance LH.LargeHashable Patient where + updateHash p = + {-# SCC "updateHash/LargHashable" #-} + do {-# SCC "updateHash/firstName" #-} LH.updateHash (p_firstName p) + {-# SCC "updateHash/lastName" #-} LH.updateHash (p_lastName p) + {-# SCC "updateHash/note" #-} LH.updateHash (p_note p) + {-# SCC "updateHash/age" #-} LH.updateHash (p_age p) + +mkPatList :: Int -> [Patient] +mkPatList n = + let l = map mkPat [1..n] + in l `deepseq` l + where + mkPat i = + Patient + { p_firstName = "Stefan" + , p_lastName = "Wehr" + , p_note = "Dies ist ein bißchen mehr Text, aber auch nicht richtig lang" + , p_age = i + } + +_NUM_ :: Int +_NUM_ = 1000000 + +patList :: [Patient] +patList = mkPatList _NUM_ + +genOnly :: IO () +genOnly = + do let !l = patList + putStrLn ("Generated " ++ show (length l) ++ " patients") + +hashSafeCopy :: IO () +hashSafeCopy = + do let !l = patList + putStrLn ("Generated " ++ show (length l) ++ " patients") + let !bs = runPut (safePut l) + !hash = CH.hashMd5 bs + putStrLn ("Hash: " ++ show hash) + +hashCryptoHash :: IO () +hashCryptoHash = + do let !l = patList + putStrLn ("Generated " ++ show (length l) ++ " patients") + let !hash = CH.hashMd5 l + putStrLn ("Hash: " ++ show hash) + +hashLargeHashable :: IO () +hashLargeHashable = + do let !l = patList + putStrLn ("Generated " ++ show (length l) ++ " patients") + let !hash = LH.largeHash LH.md5HashAlgorithm l + putStrLn ("Hash: " ++ show hash) + +hashSerial :: IO () +hashSerial = + do let !l = patList + putStrLn ("Generated " ++ show (length l) ++ " patients") + let !hash = Serial.serialLargeHash LH.md5HashAlgorithm l + putStrLn ("Hash: " ++ show hash) + +main :: IO () +main = + do args <- getArgs + case args of + ["dry"] -> genOnly + ["safecopy"] -> hashSafeCopy + ["cryptohash"] -> hashCryptoHash + ["large-hashable"] -> hashLargeHashable + ["large-hashable-serial"] -> hashSerial + _ -> hashLargeHashable diff --git a/benchmark/Data/LargeHashable/Benchmarks/Serial.hs b/benchmark/Data/LargeHashable/Benchmarks/Serial.hs new file mode 100644 --- /dev/null +++ b/benchmark/Data/LargeHashable/Benchmarks/Serial.hs @@ -0,0 +1,30 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.LargeHashable.Benchmarks.Serial (serialLargeHash) where + +import Data.LargeHashable.Intern +import Data.LargeHashable.Class +import Data.Bytes.Put +import Data.Bytes.Serial + +serialLargeHash :: Serial a => HashAlgorithm h -> a -> h +serialLargeHash algo a = runLH algo $ serialize a + +instance MonadPut LH where + flush = return () + + putWord8 = updateHash + putWord16host = updateHash + putWord32host = updateHash + putWord64host = updateHash + putWordhost = updateHash + + putWord16le = updateHash + putWord32le = updateHash + putWord64le = updateHash + + putWord16be = updateHash + putWord32be = updateHash + putWord64be = updateHash + + putByteString = updateHash + putLazyByteString = updateHash diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import qualified Data.LargeHashable.Benchmarks.Main as M + +main :: IO () +main = M.main diff --git a/cbits/md5.c b/cbits/md5.c new file mode 100644 --- /dev/null +++ b/cbits/md5.c @@ -0,0 +1,218 @@ +/* + * Copyright (C) 2006-2009 Vincent Hanquez + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +#include +#include +#include "bitfn.h" +#include "md5.h" + +void md5_init(struct md5_ctx *ctx) +{ + memset(ctx, 0, sizeof(*ctx)); + + ctx->sz = 0ULL; + ctx->h[0] = 0x67452301; + ctx->h[1] = 0xefcdab89; + ctx->h[2] = 0x98badcfe; + ctx->h[3] = 0x10325476; +} + +#define f1(x, y, z) (z ^ (x & (y ^ z))) +#define f2(x, y, z) f1(z, x, y) +#define f3(x, y, z) (x ^ y ^ z) +#define f4(x, y, z) (y ^ (x | ~z)) +#define R(f, a, b, c, d, i, k, s) a += f(b, c, d) + w[i] + k; a = rol32(a, s); a += b + +static void md5_do_chunk(struct md5_ctx *ctx, uint32_t *buf) +{ + uint32_t a, b, c, d; +#ifdef ARCH_IS_BIG_ENDIAN + uint32_t w[16]; + cpu_to_le32_array(w, buf, 16); +#else + uint32_t *w = buf; +#endif + a = ctx->h[0]; b = ctx->h[1]; c = ctx->h[2]; d = ctx->h[3]; + + R(f1, a, b, c, d, 0, 0xd76aa478, 7); + R(f1, d, a, b, c, 1, 0xe8c7b756, 12); + R(f1, c, d, a, b, 2, 0x242070db, 17); + R(f1, b, c, d, a, 3, 0xc1bdceee, 22); + R(f1, a, b, c, d, 4, 0xf57c0faf, 7); + R(f1, d, a, b, c, 5, 0x4787c62a, 12); + R(f1, c, d, a, b, 6, 0xa8304613, 17); + R(f1, b, c, d, a, 7, 0xfd469501, 22); + R(f1, a, b, c, d, 8, 0x698098d8, 7); + R(f1, d, a, b, c, 9, 0x8b44f7af, 12); + R(f1, c, d, a, b, 10, 0xffff5bb1, 17); + R(f1, b, c, d, a, 11, 0x895cd7be, 22); + R(f1, a, b, c, d, 12, 0x6b901122, 7); + R(f1, d, a, b, c, 13, 0xfd987193, 12); + R(f1, c, d, a, b, 14, 0xa679438e, 17); + R(f1, b, c, d, a, 15, 0x49b40821, 22); + + R(f2, a, b, c, d, 1, 0xf61e2562, 5); + R(f2, d, a, b, c, 6, 0xc040b340, 9); + R(f2, c, d, a, b, 11, 0x265e5a51, 14); + R(f2, b, c, d, a, 0, 0xe9b6c7aa, 20); + R(f2, a, b, c, d, 5, 0xd62f105d, 5); + R(f2, d, a, b, c, 10, 0x02441453, 9); + R(f2, c, d, a, b, 15, 0xd8a1e681, 14); + R(f2, b, c, d, a, 4, 0xe7d3fbc8, 20); + R(f2, a, b, c, d, 9, 0x21e1cde6, 5); + R(f2, d, a, b, c, 14, 0xc33707d6, 9); + R(f2, c, d, a, b, 3, 0xf4d50d87, 14); + R(f2, b, c, d, a, 8, 0x455a14ed, 20); + R(f2, a, b, c, d, 13, 0xa9e3e905, 5); + R(f2, d, a, b, c, 2, 0xfcefa3f8, 9); + R(f2, c, d, a, b, 7, 0x676f02d9, 14); + R(f2, b, c, d, a, 12, 0x8d2a4c8a, 20); + + R(f3, a, b, c, d, 5, 0xfffa3942, 4); + R(f3, d, a, b, c, 8, 0x8771f681, 11); + R(f3, c, d, a, b, 11, 0x6d9d6122, 16); + R(f3, b, c, d, a, 14, 0xfde5380c, 23); + R(f3, a, b, c, d, 1, 0xa4beea44, 4); + R(f3, d, a, b, c, 4, 0x4bdecfa9, 11); + R(f3, c, d, a, b, 7, 0xf6bb4b60, 16); + R(f3, b, c, d, a, 10, 0xbebfbc70, 23); + R(f3, a, b, c, d, 13, 0x289b7ec6, 4); + R(f3, d, a, b, c, 0, 0xeaa127fa, 11); + R(f3, c, d, a, b, 3, 0xd4ef3085, 16); + R(f3, b, c, d, a, 6, 0x04881d05, 23); + R(f3, a, b, c, d, 9, 0xd9d4d039, 4); + R(f3, d, a, b, c, 12, 0xe6db99e5, 11); + R(f3, c, d, a, b, 15, 0x1fa27cf8, 16); + R(f3, b, c, d, a, 2, 0xc4ac5665, 23); + + R(f4, a, b, c, d, 0, 0xf4292244, 6); + R(f4, d, a, b, c, 7, 0x432aff97, 10); + R(f4, c, d, a, b, 14, 0xab9423a7, 15); + R(f4, b, c, d, a, 5, 0xfc93a039, 21); + R(f4, a, b, c, d, 12, 0x655b59c3, 6); + R(f4, d, a, b, c, 3, 0x8f0ccc92, 10); + R(f4, c, d, a, b, 10, 0xffeff47d, 15); + R(f4, b, c, d, a, 1, 0x85845dd1, 21); + R(f4, a, b, c, d, 8, 0x6fa87e4f, 6); + R(f4, d, a, b, c, 15, 0xfe2ce6e0, 10); + R(f4, c, d, a, b, 6, 0xa3014314, 15); + R(f4, b, c, d, a, 13, 0x4e0811a1, 21); + R(f4, a, b, c, d, 4, 0xf7537e82, 6); + R(f4, d, a, b, c, 11, 0xbd3af235, 10); + R(f4, c, d, a, b, 2, 0x2ad7d2bb, 15); + R(f4, b, c, d, a, 9, 0xeb86d391, 21); + + ctx->h[0] += a; ctx->h[1] += b; ctx->h[2] += c; ctx->h[3] += d; +} + +void md5_update(struct md5_ctx *ctx, uint8_t *data, uint32_t len) +{ + uint32_t index, to_fill; + + index = (uint32_t) (ctx->sz & 0x3f); + to_fill = 64 - index; + + ctx->sz += len; + + if (index && len >= to_fill) { + memcpy(ctx->buf + index, data, to_fill); + md5_do_chunk(ctx, (uint32_t *) ctx->buf); + len -= to_fill; + data += to_fill; + index = 0; + } + + /* process as much 64-block as possible */ + for (; len >= 64; len -= 64, data += 64) + md5_do_chunk(ctx, (uint32_t *) data); + + /* append data into buf */ + if (len) + memcpy(ctx->buf + index, data, len); +} + +void md5_update_char(struct md5_ctx *ctx, char data) +{ + md5_update(ctx, (uint8_t *)&data, sizeof(data)); +} + +void md5_update_uchar(struct md5_ctx *ctx, unsigned char data) +{ + md5_update(ctx, (uint8_t *)&data, sizeof(data)); +} + +void md5_update_short(struct md5_ctx *ctx, short data) +{ + md5_update(ctx, (uint8_t *)&data, sizeof(data)); +} + +void md5_update_ushort(struct md5_ctx *ctx, unsigned short data) +{ + md5_update(ctx, (uint8_t *)&data, sizeof(data)); +} + +void md5_update_int(struct md5_ctx *ctx, int data) +{ + md5_update(ctx, (uint8_t *)&data, sizeof(data)); +} + +void md5_update_uint(struct md5_ctx *ctx, unsigned int data) +{ + md5_update(ctx, (uint8_t *)&data, sizeof(data)); +} + +void md5_update_long(struct md5_ctx *ctx, long data) +{ + md5_update(ctx, (uint8_t *)&data, sizeof(data)); +} + +void md5_update_ulong(struct md5_ctx *ctx, unsigned long data) +{ + md5_update(ctx, (uint8_t *)&data, sizeof(data)); +} + +void md5_finalize(struct md5_ctx *ctx, uint8_t *out) +{ + static uint8_t padding[64] = { 0x80, }; + uint64_t bits; + uint32_t index, padlen; + uint32_t *p = (uint32_t *) out; + + /* add padding and update data with it */ + bits = cpu_to_le64(ctx->sz << 3); + + /* pad out to 56 */ + index = (uint32_t) (ctx->sz & 0x3f); + padlen = (index < 56) ? (56 - index) : ((64 + 56) - index); + md5_update(ctx, padding, padlen); + + /* append length */ + md5_update(ctx, (uint8_t *) &bits, sizeof(bits)); + + /* output hash */ + p[0] = cpu_to_le32(ctx->h[0]); + p[1] = cpu_to_le32(ctx->h[1]); + p[2] = cpu_to_le32(ctx->h[2]); + p[3] = cpu_to_le32(ctx->h[3]); +} diff --git a/cbits/md5.h b/cbits/md5.h new file mode 100644 --- /dev/null +++ b/cbits/md5.h @@ -0,0 +1,51 @@ +/* + * Copyright (C) 2006-2009 Vincent Hanquez + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ +#ifndef CRYPTOHASH_MD5_H +#define CRYPTOHASH_MD5_H + +#include + +struct md5_ctx +{ + uint64_t sz; + uint8_t buf[64]; + uint32_t h[4]; +}; + +#define MD5_DIGEST_SIZE 16 +#define MD5_CTX_SIZE sizeof(struct md5_ctx) + +void md5_init(struct md5_ctx *ctx); +void md5_update(struct md5_ctx *ctx, uint8_t *data, uint32_t len); +void md5_update_char(struct md5_ctx *ctx, char data); +void md5_update_uchar(struct md5_ctx *ctx, unsigned char data); +void md5_update_short(struct md5_ctx *ctx, short data); +void md5_update_ushort(struct md5_ctx *ctx, unsigned short data); +void md5_update_int(struct md5_ctx *ctx, int data); +void md5_update_uint(struct md5_ctx *ctx, unsigned int data); +void md5_update_long(struct md5_ctx *ctx, long data); +void md5_update_ulong(struct md5_ctx *ctx, unsigned long data); +void md5_finalize(struct md5_ctx *ctx, uint8_t *out); + +#endif diff --git a/large-hashable.cabal b/large-hashable.cabal new file mode 100644 --- /dev/null +++ b/large-hashable.cabal @@ -0,0 +1,106 @@ +name: large-hashable +version: 0.1.0.0 +cabal-version: >=1.10 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: 2015 - 2016 factis research GmbH +maintainer: Stefan Wehr +homepage: https://github.com/factisresearch/large-hashable +synopsis: Efficiently hash (large) Haskell values +description: + Please see README.md +category: Web +author: Stefan Wehr, Lukas Epple +extra-source-files: + cbits/md5.h + README.md + shell.nix + stack.yaml + +source-repository head + type: git + location: https://github.com/factisresearch/large-hashable + +library + exposed-modules: + Data.LargeHashable + Data.LargeHashable.Class + Data.LargeHashable.MD5 + Data.LargeHashable.Intern + Data.LargeHashable.LargeWord + Data.LargeHashable.TH + build-depends: + aeson >=0.11.2.0, + base >=4.8 && <5, + text >=1.2.2.1, + bytestring >=0.10.6.0, + transformers >=0.4.2.0, + base16-bytestring >=0.1.1.6, + bytes >=0.15.2, + containers >=0.5.6.2, + unordered-containers >=0.2.7.0, + scientific >=0.3.4.6, + strict >=0.3.2, + time >=1.5.0.1, + template-haskell >=2.10.0.0, + utf8-light >=0.4.2, + vector >=0.11.0.0, + void >=0.7.1 + c-sources: + cbits/md5.c + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -optc -O3 -fno-cse -W -fwarn-unused-imports -fwarn-unused-binds -fwarn-unused-matches -fwarn-unused-do-bind -fwarn-wrong-do-bind -pgmPcpphs -optP--cpp -fno-warn-name-shadowing -fwarn-missing-signatures -O2 + +test-suite large-hashable-test + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: + aeson >=0.11.2.0, + HTF >=0.13.1.0, + QuickCheck >=2.8.2, + base >=4.8 && <5, + bytes >=0.15.2, + bytestring >=0.10.6.0, + containers >=0.5.6.2, + hashable >=1.2.4.0, + large-hashable >=0.1.0.0, + scientific >=0.3.4.6, + strict >=0.3.2, + text >=1.2.2.1, + time >=1.5.0.1, + unordered-containers >=0.2.7.0, + vector >=0.11.0.0 + default-language: Haskell2010 + hs-source-dirs: test + other-modules: + Data.LargeHashable.Tests.Class + Data.LargeHashable.Tests.Helper + Data.LargeHashable.Tests.TH + Data.LargeHashable.Tests.LargeWord + ghc-options: -optc -O3 -fno-cse -threaded -rtsopts -with-rtsopts=-N -W -fwarn-unused-imports -fwarn-unused-binds -fwarn-unused-matches -fwarn-unused-do-bind -fwarn-wrong-do-bind -pgmPcpphs -optP--cpp -rtsopts -threaded -funbox-strict-fields -fwarn-missing-signatures -fno-warn-name-shadowing + +benchmark large-hashable-benchmark + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: + base >=4.8 && <5, + base16-bytestring >=0.1.1.6, + large-hashable >=0.1.0.0, + safecopy >=0.9.0.1, + text >=1.2.2.1, + deepseq >=1.4.1.1, + cryptohash >=0.11.9, + bytestring >=0.10.6.0, + cereal >=0.5.1.0, + byteable >=0.1.1, + transformers >=0.4.2.0, + bytes >=0.15.2 + default-language: Haskell2010 + hs-source-dirs: benchmark + other-modules: + Data.LargeHashable.Benchmarks.CryptoHash + Data.LargeHashable.Benchmarks.Main + Data.LargeHashable.Benchmarks.Serial + ghc-options: -optc -O3 -fno-cse -threaded -rtsopts -with-rtsopts=-N -W -fwarn-unused-imports -fwarn-unused-binds -fwarn-unused-matches -fwarn-unused-do-bind -fwarn-wrong-do-bind -pgmPcpphs -optP--cpp -rtsopts -threaded -funbox-strict-fields -fwarn-missing-signatures -fno-warn-name-shadowing -O2 diff --git a/shell.nix b/shell.nix new file mode 100644 --- /dev/null +++ b/shell.nix @@ -0,0 +1,43 @@ +{ nixpkgs ? import {}, compiler ? "default" }: + +let + + inherit (nixpkgs) pkgs; + + f = { mkDerivation, base, base16-bytestring, byteable, bytes + , bytestring, cereal, containers, cryptohash, deepseq, hashable + , HTF, QuickCheck, safecopy, stdenv, template-haskell, text, time + , transformers, unordered-containers + }: + mkDerivation { + pname = "large-hashable"; + version = "0.1.0.0"; + src = ./.; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ + base base16-bytestring bytes bytestring containers template-haskell + text time transformers unordered-containers + ]; + executableHaskellDepends = [ + base byteable bytes bytestring cereal cryptohash deepseq safecopy + text transformers + ]; + testHaskellDepends = [ + base bytes bytestring containers hashable HTF QuickCheck text + unordered-containers + ]; + homepage = "http://github.com/githubuser/large-hashable#readme"; + description = "Initial project template from stack"; + license = stdenv.lib.licenses.bsd3; + }; + + haskellPackages = if compiler == "default" + then pkgs.haskellPackages + else pkgs.haskell.packages.${compiler}; + + drv = haskellPackages.callPackage f {}; + +in + + if pkgs.lib.inNixShell then drv.env else drv diff --git a/src/Data/LargeHashable.hs b/src/Data/LargeHashable.hs new file mode 100644 --- /dev/null +++ b/src/Data/LargeHashable.hs @@ -0,0 +1,26 @@ +-- | This is the top-level module of LargeHashable, a library +-- for efficiently hashing any Haskell data type using a +-- hash algorithm like MD5, SHA256 etc. +-- +-- Normal users shoud import this module. +module Data.LargeHashable ( + LargeHashable(..) + , LargeHashable'(..) + , LH + , HashAlgorithm + , largeHash + , deriveLargeHashable + , deriveLargeHashableNoCtx + , deriveLargeHashableCtx + , deriveLargeHashableCustomCtx + , MD5Hash(..) + , md5HashAlgorithm + , runMD5 + , module Data.LargeHashable.LargeWord +) where + +import Data.LargeHashable.Class +import Data.LargeHashable.Intern +import Data.LargeHashable.LargeWord +import Data.LargeHashable.MD5 +import Data.LargeHashable.TH diff --git a/src/Data/LargeHashable/Class.hs b/src/Data/LargeHashable/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/LargeHashable/Class.hs @@ -0,0 +1,505 @@ +-- | This module defines the central type class `LargeHashable` of this package. +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +module Data.LargeHashable.Class ( + + LargeHashable(..), largeHash, LargeHashable'(..) + +) where + +-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines") +import Data.Bits +import Data.Fixed +import Data.Foldable +import Data.Int +import Data.LargeHashable.Intern +import Data.Ratio +import Data.Time +import Data.Time.Clock.TAI +import Data.Void (Void) +import Data.Word +import Foreign.C.Types +import Foreign.Ptr +import GHC.Generics +import qualified Codec.Binary.UTF8.Light as Utf8 +import qualified Data.Aeson as J +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Internal as BLI +import qualified Data.ByteString.Short as BS +import qualified Data.Foldable as F +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.HashSet as HashSet +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as M +import qualified Data.Scientific as Sci +import qualified Data.Sequence as Seq +import qualified Data.Set as S +import qualified Data.Strict.Tuple as Tuple +import qualified Data.Text as T +import qualified Data.Text.Foreign as TF +import qualified Data.Text.Internal.Lazy as TLI +import qualified Data.Text.Lazy as TL +import qualified Data.Vector as V + +-- | A type class for computing hashes (i.e. MD5, SHA256, ...) from +-- haskell values. +-- +-- The laws of this typeclass are the following: +-- +-- (1) If two values are equal +-- according to '==', then the finally computed hashes must also be equal +-- according to '=='. However it is not required that the hashes of inequal +-- values have to be inequal. Also note that an instance of 'LargeHashable' +-- does not require a instance of 'Eq'. Using any sane algorithm the chance +-- of a collision should be 1 / n where n is the number of different hashes +-- possible. +-- +-- (2) If two values are inequal +-- according to '==', then the probability of a hash collision is 1/n, +-- where n is the number of possible hashes produced by the +-- underlying hash algorithm. +-- +-- A rule of thumb: hash all information that you would also need for +-- serializing/deserializing values of your datatype. For instance, when +-- hashing lists, you would not only hash the list elements but also the +-- length of the list. Consider the following datatype +-- +-- > data Foo = Foo [Int] [Int] +-- +-- We now write an instance for LargeHashable like this +-- +-- > instance LargeHashable Foo where +-- > updateHash (Foo l1 l2) = updateHash l1 >> updateHash l2 +-- +-- If we did not hash the length of a list, then the following two values +-- of @Foo@ would produce identical hashes: +-- +-- > Foo [1,2,3] [] +-- > Foo [1] [2,3] +-- +class LargeHashable a where + updateHash :: a -> LH () + default updateHash :: (GenericLargeHashable (Rep a), Generic a) => a -> LH () + updateHash = updateHashGeneric . from + +class LargeHashable' t where + updateHash' :: LargeHashable a => t a -> LH () + +-- | 'largeHash' is the central function of this package. +-- For a given value it computes a 'Hash' using the given +-- 'HashAlgorithm'. +largeHash :: LargeHashable a => HashAlgorithm h -> a -> h +largeHash algo x = runLH algo (updateHash x) + +{-# INLINE updateHashTextData #-} +updateHashTextData :: T.Text -> LH () +updateHashTextData !t = do + updates <- hashUpdates + ioInLH $ do + TF.useAsPtr t $ \valPtr units -> + hu_updatePtr updates (castPtr valPtr) (fromIntegral (2 * units)) + return () + +{-# INLINE updateHashText #-} +updateHashText :: T.Text -> LH () +updateHashText !t = do + updateHashTextData t + updates <- hashUpdates + ioInLH $ hu_updateULong updates (fromIntegral (T.length t)) + +instance LargeHashable T.Text where + updateHash = updateHashText + +{-# INLINE updateHashLazyText #-} +updateHashLazyText :: Int -> TL.Text -> LH () +updateHashLazyText !len (TLI.Chunk !t !next) = do + updateHashTextData t + updateHashLazyText (len + T.length t) next +updateHashLazyText !len TLI.Empty = updateHash len + +instance LargeHashable TL.Text where + updateHash = updateHashLazyText 0 + +{-# INLINE updateHashByteStringData #-} +updateHashByteStringData :: B.ByteString -> LH () +updateHashByteStringData !b = do + updates <- hashUpdates + ioInLH $ do + ptr <- B.useAsCString b return + hu_updatePtr updates (castPtr ptr) (B.length b) + +{-# INLINE updateHashByteString #-} +updateHashByteString :: B.ByteString -> LH () +updateHashByteString !b = do + updateHashByteStringData b + updates <- hashUpdates + ioInLH $ hu_updateULong updates (fromIntegral (B.length b)) + +instance LargeHashable B.ByteString where + updateHash = updateHashByteString + +{-# INLINE updateHashLazyByteString #-} +updateHashLazyByteString :: Int -> BL.ByteString -> LH () +updateHashLazyByteString !len (BLI.Chunk !bs !next) = do + updateHashByteStringData bs + updateHashLazyByteString (len + B.length bs) next +updateHashLazyByteString !len BLI.Empty = updateHash len + +instance LargeHashable BL.ByteString where + updateHash = updateHashLazyByteString 0 + +instance LargeHashable BS.ShortByteString where + updateHash = updateHash . BS.fromShort + +{-# INLINE updateHashWithFun #-} +updateHashWithFun :: (HashUpdates -> a -> IO ()) -> a -> LH () +updateHashWithFun f x = + do updates <- hashUpdates + ioInLH $ f updates x + +instance LargeHashable Int where + updateHash i = updateHashWithFun hu_updateLong (fromIntegral i) + +instance LargeHashable Int8 where + updateHash = updateHashWithFun hu_updateChar . CChar + +instance LargeHashable Int16 where + updateHash = updateHashWithFun hu_updateShort . CShort + +instance LargeHashable Int32 where + updateHash = updateHashWithFun hu_updateInt . CInt + +instance LargeHashable Int64 where + updateHash = updateHashWithFun hu_updateLong . CLong + +instance LargeHashable Word where + updateHash i = updateHashWithFun hu_updateLong (fromIntegral i) + +instance LargeHashable Word8 where + updateHash = updateHashWithFun hu_updateUChar . CUChar + +instance LargeHashable Word16 where + updateHash = updateHashWithFun hu_updateUShort . CUShort + +instance LargeHashable Word32 where + updateHash = updateHashWithFun hu_updateUInt . CUInt + +instance LargeHashable Word64 where + updateHash = updateHashWithFun hu_updateULong . CULong + +instance LargeHashable CChar where + updateHash = updateHashWithFun hu_updateChar + +instance LargeHashable CShort where + updateHash = updateHashWithFun hu_updateShort + +instance LargeHashable CInt where + updateHash = updateHashWithFun hu_updateInt + +instance LargeHashable CLong where + updateHash = updateHashWithFun hu_updateLong + +instance LargeHashable CUChar where + updateHash = updateHashWithFun hu_updateUChar + +instance LargeHashable CUShort where + updateHash = updateHashWithFun hu_updateUShort + +instance LargeHashable CUInt where + updateHash = updateHashWithFun hu_updateUInt + +instance LargeHashable CULong where + updateHash = updateHashWithFun hu_updateULong + +instance LargeHashable Char where + updateHash = updateHashWithFun hu_updateUInt . CUInt . Utf8.c2w + +{-# INLINE updateHashInteger #-} +updateHashInteger :: Integer -> LH () +updateHashInteger !i + | i == 0 = updateHash (0 :: CUChar) + | i > 0 = do + updateHash (fromIntegral (i .&. 0xffffffffffffffff) :: CULong) + updateHashInteger (shift i (-64)) + | otherwise = do + updateHash (0 :: CUChar) -- prepend 0 to show it is negative + updateHashInteger (abs i) + +instance LargeHashable Integer where + updateHash = updateHashInteger + +foreign import ccall doubleToWord64 :: Double -> Word64 + +instance LargeHashable Double where + updateHash = updateHash . doubleToWord64 + +foreign import ccall floatToWord32 :: Float -> Word32 + +instance LargeHashable Float where + updateHash = updateHash . floatToWord32 + +{-# INLINE updateHashFixed #-} +updateHashFixed :: HasResolution a => Fixed a -> LH () +updateHashFixed f = updateHash (truncate . (* f) . fromInteger $ resolution f :: Integer) + +instance HasResolution a => LargeHashable (Fixed a) where + updateHash = updateHashFixed + +{-# INLINE updateHashBool #-} +updateHashBool :: Bool -> LH () +updateHashBool True = updateHash (1 :: CUChar) +updateHashBool False = updateHash (0 :: CUChar) + +instance LargeHashable Bool where + updateHash = updateHashBool + +{-# INLINE updateHashList #-} +updateHashList :: LargeHashable a => [a] -> LH () +updateHashList = loop 0 + where + loop :: LargeHashable a => Int -> [a] -> LH () + loop !i [] = + updateHash i + loop !i (x:xs) = do + updateHash x + loop (i + 1) xs + +instance LargeHashable a => LargeHashable [a] where + updateHash = updateHashList + +{-# INLINE setFoldFun #-} +setFoldFun :: LargeHashable a => LH () -> a -> LH () +setFoldFun action value = action >> updateHash value + +{-# INLINE updateHashSet #-} +updateHashSet :: LargeHashable a => S.Set a -> LH () +updateHashSet !set = do + foldl' setFoldFun (return ()) set -- Note: foldl' for sets traverses the elements in asc order + updateHash (S.size set) + +instance LargeHashable a => LargeHashable (S.Set a) where + updateHash = updateHashSet + +{-# INLINE updateHashIntSet #-} +updateHashIntSet :: IntSet.IntSet -> LH () +updateHashIntSet !set = do + IntSet.foldl' setFoldFun (return ()) set + updateHash (IntSet.size set) + +-- Lazy and Strict IntSet share the same definition +instance LargeHashable IntSet.IntSet where + updateHash = updateHashIntSet + +{-# INLINE updateHashHashSet #-} +updateHashHashSet :: LargeHashable a => HashSet.HashSet a -> LH () +updateHashHashSet !set = + -- The ordering of elements in a set does not matter. A HashSet does not + -- offer an efficient way of exctracting its elements in some specific + -- ordering. So we use the auxiliary function 'hashListModuloOrdering'. + hashListModuloOrdering (HashSet.size set) (HashSet.toList set) + +-- | Hashes a list of values such the two permutations of the same list +-- yields the same hash. +hashListModuloOrdering :: LargeHashable a => Int -> [a] -> LH () +hashListModuloOrdering len list = + do updateXorHash (map updateHash list) + updateHash len + +-- Lazy and Strict HashSet share the same definition +instance LargeHashable a => LargeHashable (HashSet.HashSet a) where + updateHash = updateHashHashSet + +{-# INLINE mapFoldFun #-} +mapFoldFun :: (LargeHashable k, LargeHashable a) => LH () -> k -> a -> LH () +mapFoldFun action key value = action >> updateHash key >> updateHash value + +{-# INLINE updateHashMap #-} +updateHashMap :: (LargeHashable k, LargeHashable a) => M.Map k a -> LH () +updateHashMap !m = do + M.foldlWithKey' mapFoldFun (return ()) m + updateHash (M.size m) + +-- Lazy and Strict Map share the same definition +instance (LargeHashable k, LargeHashable a) => LargeHashable (M.Map k a) where + updateHash = updateHashMap + +{-# INLINE updateHashIntMap #-} +updateHashIntMap :: LargeHashable a => IntMap.IntMap a -> LH () +updateHashIntMap !m = do + IntMap.foldlWithKey' mapFoldFun (return ()) m + updateHash (IntMap.size m) + +-- Lazy and Strict IntMap share the same definition +instance LargeHashable a => LargeHashable (IntMap.IntMap a) where + updateHash = updateHashIntMap + +updateHashHashMap :: (LargeHashable k, LargeHashable v) => HashMap.HashMap k v -> LH () +updateHashHashMap !m = + -- The ordering of elements in a map do not matter. A HashMap does not + -- offer an efficient way of exctracting its elements in some specific + -- ordering. So we use the auxiliary function 'hashListModuloOrdering'. + hashListModuloOrdering (HashMap.size m) (HashMap.toList m) + +-- Lazy and Strict HashMap share the same definition +instance (LargeHashable k, LargeHashable v) => LargeHashable (HashMap.HashMap k v) where + updateHash = updateHashHashMap + +{-# INLINE updateHashTuple #-} +updateHashTuple :: (LargeHashable a, LargeHashable b) => (a, b) -> LH () +updateHashTuple (!a, !b) = updateHash a >> updateHash b + +instance (LargeHashable a, LargeHashable b) => LargeHashable (a, b) where + updateHash = updateHashTuple + +{-# INLINE updateHashTriple #-} +updateHashTriple :: (LargeHashable a, LargeHashable b, LargeHashable c) => (a, b, c) -> LH () +updateHashTriple (a, b, c) = updateHash a >> updateHash b >> updateHash c + +instance (LargeHashable a, LargeHashable b, LargeHashable c) => LargeHashable (a, b, c) where + updateHash = updateHashTriple + +{-# INLINE updateHashQuadruple #-} +updateHashQuadruple :: (LargeHashable a, LargeHashable b, LargeHashable c, LargeHashable d) => (a, b, c, d) -> LH () +updateHashQuadruple (a, b, c, d) = updateHash a >> updateHash b >> updateHash c >> updateHash d + +instance (LargeHashable a, LargeHashable b, LargeHashable c, LargeHashable d) => LargeHashable (a, b, c, d) where + updateHash = updateHashQuadruple + +{-# INLINE updateHashQuintuple #-} +updateHashQuintuple :: (LargeHashable a, LargeHashable b, LargeHashable c, LargeHashable d, LargeHashable e) => (a, b, c, d, e) -> LH () +updateHashQuintuple (a, b, c, d, e) = updateHash a >> updateHash b >> updateHash c >> updateHash d >> updateHash e + +instance (LargeHashable a, LargeHashable b, LargeHashable c, LargeHashable d, LargeHashable e) => LargeHashable (a, b, c, d, e) where + updateHash = updateHashQuintuple + +updateHashMaybe :: LargeHashable a => Maybe a -> LH () +updateHashMaybe Nothing = updateHash (0 :: CULong) +updateHashMaybe (Just !x) = updateHash (1 :: CULong) >> updateHash x + +instance LargeHashable a => LargeHashable (Maybe a) where + updateHash = updateHashMaybe + +instance (LargeHashable a, LargeHashable b) => LargeHashable (Either a b) where + updateHash (Left !l) = updateHash (0 :: CULong) >> updateHash l + updateHash (Right !r) = updateHash (1 :: CULong) >> updateHash r + +instance LargeHashable () where + updateHash () = updateHash (0 :: CULong) + +instance LargeHashable Ordering where + updateHash EQ = updateHash (0 :: CULong) + updateHash GT = updateHash (-1 :: CULong) + updateHash LT = updateHash (1 :: CULong) + +instance (Integral a, LargeHashable a) => LargeHashable (Ratio a) where + updateHash !i = do + updateHash $ numerator i + updateHash $ denominator i + +instance LargeHashable AbsoluteTime where + updateHash t = updateHash $ diffAbsoluteTime t taiEpoch + +instance LargeHashable DiffTime where + -- could be replaced by diffTimeToPicoseconds as soon as + -- time 1.6 becomes more common + updateHash = updateHash . (fromRational . toRational :: DiffTime -> Pico) + +instance LargeHashable NominalDiffTime where + updateHash = updateHash . (fromRational . toRational :: NominalDiffTime -> Pico) + +instance LargeHashable LocalTime where + updateHash (LocalTime d tod) = updateHash d >> updateHash tod + +instance LargeHashable ZonedTime where + updateHash (ZonedTime lt tz) = updateHash lt >> updateHash tz + +instance LargeHashable TimeOfDay where + updateHash (TimeOfDay h m s) = updateHash h >> updateHash m >> updateHash s + +instance LargeHashable TimeZone where + updateHash (TimeZone mintz summerOnly name) = + updateHash mintz >> updateHash summerOnly >> updateHash name + +instance LargeHashable UTCTime where + updateHash (UTCTime d dt) = updateHash d >> updateHash dt + +instance LargeHashable Day where + updateHash (ModifiedJulianDay d) = updateHash d + +instance LargeHashable UniversalTime where + updateHash (ModJulianDate d) = updateHash d + +instance LargeHashable a => LargeHashable (V.Vector a) where + updateHash = updateHash . V.toList + +instance (LargeHashable a, LargeHashable b) => LargeHashable (Tuple.Pair a b) where + updateHash (x Tuple.:!: y) = + do updateHash x + updateHash y + +instance LargeHashable Sci.Scientific where + updateHash notNormalized = + do let n = Sci.normalize notNormalized + updateHash (Sci.coefficient n) + updateHash (Sci.base10Exponent n) + +instance LargeHashable J.Value where + updateHash v = + case v of + J.Object obj -> + do updateHash (0::Int) + updateHash obj + J.Array arr -> + do updateHash (1::Int) + updateHash arr + J.String t -> + do updateHash (2::Int) + updateHash t + J.Number n -> + do updateHash (3::Int) + updateHash n + J.Bool b -> + do updateHash (4::Int) + updateHash b + J.Null -> + updateHash (5::Int) + +instance LargeHashable Void where + updateHash _ = error "I'm void" + +instance LargeHashable a => LargeHashable (Seq.Seq a) where + updateHash = updateHash . F.toList + +-- | Support for generically deriving 'LargeHashable' instances. +-- Any instance of the type class 'GHC.Generics.Generic' can be made +-- an instance of 'LargeHashable' by an empty instance declaration. +class GenericLargeHashable f where + updateHashGeneric :: f p -> LH () + +instance GenericLargeHashable V1 where + updateHashGeneric = undefined + +instance GenericLargeHashable U1 where + updateHashGeneric _ = updateHash () + +instance (GenericLargeHashable f, GenericLargeHashable g) => GenericLargeHashable (f :+: g) where + updateHashGeneric (L1 x) = do + updateHash (0 :: CULong) -- is left + updateHashGeneric x + updateHashGeneric (R1 x) = do + updateHash (1 :: CULong) -- is right + updateHashGeneric x + +instance (GenericLargeHashable f, GenericLargeHashable g) => GenericLargeHashable (f :*: g) where + updateHashGeneric (x :*: y) = updateHashGeneric x >> updateHashGeneric y + +instance LargeHashable c => GenericLargeHashable (K1 i c) where + updateHashGeneric (K1 x) = updateHash x + +-- ignore meta-info (for now) +instance (GenericLargeHashable f) => GenericLargeHashable (M1 i t f) where + updateHashGeneric (M1 x) = updateHashGeneric x diff --git a/src/Data/LargeHashable/Intern.hs b/src/Data/LargeHashable/Intern.hs new file mode 100644 --- /dev/null +++ b/src/Data/LargeHashable/Intern.hs @@ -0,0 +1,150 @@ +-- | Generic, low-level data types for hashing. This is an internal module. +-- +-- You should only import this module if you write your own hash algorithm +-- or if you need access to low-level hashing functions when defining +-- instances of 'LargeHash'. +-- +-- Regular users should not import this module. Import 'Data.LargeHashable' +-- instead. +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Data.LargeHashable.Intern ( + + HashUpdates(..), HashAlgorithm(..), LH + , hashUpdates, ioInLH, runLH, updateXorHash + +) where + +-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines") +import Control.Monad +import Data.Word +import Foreign.C.Types +import Foreign.Ptr +import System.IO.Unsafe (unsafePerformIO) + +-- | Functions for updating an intermediate hash value. The functions live +-- in the 'IO' monad because they are typically implemented via FFI. +data HashUpdates + = HashUpdates + { hu_updatePtr :: {-# NOUNPACK #-} !(Ptr Word8 -> Int -> IO ()) -- ^ adds a byte array to the hash + , hu_updateChar :: {-# NOUNPACK #-} !(CChar -> IO ()) -- Int8 + , hu_updateUChar :: {-# NOUNPACK #-} !(CUChar -> IO ()) -- Word8 + , hu_updateShort :: {-# NOUNPACK #-} !(CShort -> IO ()) -- Int16 + , hu_updateUShort :: {-# NOUNPACK #-} !(CUShort -> IO ()) -- Word16 + , hu_updateInt :: {-# NOUNPACK #-} !(CInt -> IO ()) -- Int32 + , hu_updateUInt :: {-# NOUNPACK #-} !(CUInt -> IO ()) -- Word32 + , hu_updateLong :: {-# NOUNPACK #-} !(CLong -> IO ()) -- Int64 + , hu_updateULong :: {-# NOUNPACK #-} !(CULong -> IO ()) -- Word64 + } + +-- | The interface for a hashing algorithm. The interface contains a simple run +-- function, which is used to update the hash with all values needed, and the +-- outputs the resulting hash. +data HashAlgorithm h + = HashAlgorithm + { ha_run :: {-# NOUNPACK #-} !((HashUpdates -> IO ()) -> IO h) + , ha_xor :: {-# NOUNPACK #-} !(h -> h -> h) + , ha_updateHash :: {-# NOUNPACK #-} !(HashUpdates -> h -> IO ()) + } + +data LHEnv + = LHEnv + { lh_updates :: {-# NOUNPACK #-} !HashUpdates + , lh_updateXorHash :: {-# NOUNPACK #-} !([LH ()] -> IO ()) + } + +-- | The 'LH' monad (`LH` stands for "large hash") is used in the definition of +-- hashing functions for arbitrary data types. +newtype LH a = LH (LHEnv -> IO a) + +{-# INLINE lhFmap #-} +lhFmap :: (a -> b) -> LH a -> LH b +lhFmap f (LH x) = + LH $ \env -> + do y <- x env + return (f y) + +{-# INLINE lhReturn #-} +lhReturn :: a -> LH a +lhReturn x = LH $ \_env -> return x + +{-# INLINE lhApp #-} +lhApp :: LH (a -> b) -> LH a -> LH b +lhApp (LH f) (LH x) = + LH $ \env -> f env <*> x env + +{-# INLINE lhBind #-} +lhBind :: LH a -> (a -> LH b) -> LH b +lhBind (LH x) f = + LH $ \env -> + do y <- x env + let (LH g) = f y + g env + +{-# INLINE lhBind' #-} +lhBind' :: LH a -> LH b -> LH b +lhBind' (LH x) (LH y) = + LH $ \env -> + do _ <- x env + y env + +instance Functor LH where + fmap = lhFmap + +instance Applicative LH where + pure = lhReturn + (<*>) = lhApp + +instance Monad LH where + return = lhReturn + (>>=) = lhBind + (>>) = lhBind' + +{-# INLINE hashUpdates #-} +hashUpdates :: LH HashUpdates +hashUpdates = + LH $ \env -> return (lh_updates env) + +{-# INLINE getUpdateXorHash #-} +getUpdateXorHash :: LH ([LH ()] -> IO ()) +getUpdateXorHash = + LH $ \env -> return (lh_updateXorHash env) + +-- | Perform an 'IO' action in the 'LH' monad. Use with care, do not perform +-- arbitrary 'IO' operation with this function! Only use it for calling +-- functions of the 'HashUpdates' datatype. +{-# INLINE ioInLH #-} +ioInLH :: IO a -> LH a +ioInLH io = + LH $ \_env -> io + +-- | Runs a 'LH' computation and returns the resulting hash. +{-# NOINLINE runLH #-} +runLH :: HashAlgorithm h -> LH () -> h +runLH alg lh = + unsafePerformIO (runLH' alg lh) + +runLH' :: HashAlgorithm h -> LH () -> IO h +runLH' alg (LH lh) = + ha_run alg fun + where + fun updates = + lh (LHEnv updates (updateXor updates)) + updateXor updates actions = + do mh <- foldM foldFun Nothing actions + case mh of + Just h -> ha_updateHash alg updates h + Nothing -> return () + foldFun mh action = + do h2 <- runLH' alg action + case mh of + Nothing -> return (Just h2) + Just h1 -> + let !h = ha_xor alg h1 h2 + in return (Just h) + +updateXorHash :: [LH ()] -> LH () +updateXorHash actions = + do f <- getUpdateXorHash + ioInLH (f actions) diff --git a/src/Data/LargeHashable/LargeWord.hs b/src/Data/LargeHashable/LargeWord.hs new file mode 100644 --- /dev/null +++ b/src/Data/LargeHashable/LargeWord.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +-- | Efficient representation for small bytearrays with 128 or 256 bits. +module Data.LargeHashable.LargeWord + ( Word128(..), Word256(..) + , bsToW128, w128ToBs + , bsToW256, w256ToBs + , xorW128, xorW256 + ) +where + +-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines") +import Data.Bits +import Data.Data (Data) +import Data.Typeable +import Data.Word +import GHC.Generics (Generic) +import qualified Data.ByteString as BS + +data Word128 + = Word128 + { w128_first :: !Word64 + , w128_second :: !Word64 + } + deriving (Show, Read, Eq, Ord, Typeable, Generic, Data) + +data Word256 + = Word256 + { w256_first :: !Word128 + , w256_second :: !Word128 + } + deriving (Show, Read, Eq, Ord, Typeable, Generic, Data) + +-- | Converts a 'ByteString' into a 'Word256'. Only the first 32 bytes +-- are taken into account, the rest is ignored. +bsToW256 :: BS.ByteString -> Word256 +bsToW256 bs = Word256 first128 next128 + where + first128 = bsToW128 bs + next128 = bsToW128 (BS.drop 16 bs) + +w256ToBs :: Word256 -> BS.ByteString +w256ToBs (Word256 first128 next128) = + w128ToBs first128 `BS.append` w128ToBs next128 + +-- | Converts a 'ByteString' into a 'Word128'. Only the first 16 bytes +-- are taken into account, the rest is ignored. +bsToW128 :: BS.ByteString -> Word128 +bsToW128 bs = Word128 first64 next64 + where + first64 = bsToW64 bs + next64 = bsToW64 (BS.drop 8 bs) + +w128ToBs :: Word128 -> BS.ByteString +w128ToBs (Word128 first64 next64) = + w64ToBs first64 `BS.append` w64ToBs next64 + +w64ToBs :: Word64 -> BS.ByteString +w64ToBs w64 = + BS.pack + [ fromIntegral (w64 `shiftR` 56 .&. 255) + , fromIntegral (w64 `shiftR` 48 .&. 255) + , fromIntegral (w64 `shiftR` 40 .&. 255) + , fromIntegral (w64 `shiftR` 32 .&. 255) + , fromIntegral (w64 `shiftR` 24 .&. 255) + , fromIntegral (w64 `shiftR` 16 .&. 255) + , fromIntegral (w64 `shiftR` 8 .&. 255) + , fromIntegral (w64 .&. 255) + ] + +bsToW64 :: BS.ByteString -> Word64 +bsToW64 = BS.foldl' (\x w8 -> (x `shiftL` 8) + fromIntegral w8) 0 . BS.take 8 + +xorW128 :: Word128 -> Word128 -> Word128 +xorW128 (Word128 w11 w12) (Word128 w21 w22) = Word128 (w11 `xor` w21) (w12 `xor` w22) + +xorW256 :: Word256 -> Word256 -> Word256 +xorW256 (Word256 w11 w12) (Word256 w21 w22) = Word256 (w11 `xorW128` w21) (w12 `xorW128` w22) diff --git a/src/Data/LargeHashable/MD5.hs b/src/Data/LargeHashable/MD5.hs new file mode 100644 --- /dev/null +++ b/src/Data/LargeHashable/MD5.hs @@ -0,0 +1,116 @@ +-- | An implementation of 'HashAlgorithm' for MD5 (https://www.ietf.org/rfc/rfc1321.txt). +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Data.LargeHashable.MD5 ( + + MD5Hash(..), md5HashAlgorithm, runMD5 + +) where + +-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines") +import Data.LargeHashable.Intern +import Data.LargeHashable.LargeWord +import Data.Word +import Foreign.C.Types +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as BSC + +newtype MD5Hash = MD5Hash { unMD5Hash :: Word128 } + deriving (Eq, Ord) + +instance Show MD5Hash where + show (MD5Hash w) = + BSC.unpack (Base16.encode (w128ToBs w)) + +foreign import ccall unsafe "md5.h md5_init" + c_md5_init :: Ptr RawCtx -> IO () + +foreign import ccall unsafe "md5.h md5_update" + c_md5_update :: Ptr RawCtx -> Ptr Word8 -> Int -> IO () + +foreign import ccall unsafe "md5.h md5_update_char" + c_md5_update_char :: Ptr RawCtx -> CChar -> IO () + +foreign import ccall unsafe "md5.h md5_update_uchar" + c_md5_update_uchar :: Ptr RawCtx -> CUChar -> IO () + +foreign import ccall unsafe "md5.h md5_update_short" + c_md5_update_short :: Ptr RawCtx -> CShort -> IO () + +foreign import ccall unsafe "md5.h md5_update_ushort" + c_md5_update_ushort :: Ptr RawCtx -> CUShort -> IO () + +foreign import ccall unsafe "md5.h md5_update_int" + c_md5_update_int :: Ptr RawCtx -> CInt -> IO () + +foreign import ccall unsafe "md5.h md5_update_uint" + c_md5_update_uint :: Ptr RawCtx -> CUInt -> IO () + +foreign import ccall unsafe "md5.h md5_update_long" + c_md5_update_long :: Ptr RawCtx -> CLong -> IO () + +foreign import ccall unsafe "md5.h md5_update_ulong" + c_md5_update_ulong :: Ptr RawCtx -> CULong -> IO () + +foreign import ccall unsafe "md5.h md5_finalize" + c_md5_finalize :: Ptr RawCtx -> Ptr Word8 -> IO () + +{-# INLINE digestSize #-} +digestSize :: Int +digestSize = 16 + +{-# INLINE sizeCtx #-} +sizeCtx :: Int +sizeCtx = 96 + +data RawCtx -- phantom type argument + +newtype Ctx = Ctx { _unCtx :: Ptr RawCtx } + +withCtx :: (Ctx -> IO ()) -> IO MD5Hash +withCtx f = + allocaBytes sizeCtx $ \(ptr :: Ptr RawCtx) -> + do c_md5_init ptr + f (Ctx ptr) + allocaBytes digestSize $ \(resPtr :: Ptr Word8) -> + do c_md5_finalize ptr resPtr + let first = castPtr resPtr :: Ptr Word64 + w1 <- peek first + let second = castPtr (plusPtr resPtr (sizeOf w1)) :: Ptr Word64 + w2 <- peek second + return (MD5Hash (Word128 w1 w2)) + +md5HashAlgorithm :: HashAlgorithm MD5Hash +md5HashAlgorithm = + HashAlgorithm + { ha_run = run + , ha_xor = xorMD5 + , ha_updateHash = updateHash + } + where + xorMD5 (MD5Hash h1) (MD5Hash h2) = MD5Hash (h1 `xorW128` h2) + updateHash updates (MD5Hash h) = + let f = hu_updateULong updates . CULong + in do f (w128_first h) + f (w128_second h) + run f = + withCtx $ \(Ctx ctxPtr) -> + let !updates = + HashUpdates + { hu_updatePtr = c_md5_update ctxPtr + , hu_updateChar = c_md5_update_char ctxPtr + , hu_updateUChar = c_md5_update_uchar ctxPtr + , hu_updateShort = c_md5_update_short ctxPtr + , hu_updateUShort = c_md5_update_ushort ctxPtr + , hu_updateInt = c_md5_update_int ctxPtr + , hu_updateUInt = c_md5_update_uint ctxPtr + , hu_updateLong = c_md5_update_long ctxPtr + , hu_updateULong = c_md5_update_ulong ctxPtr + } + in f updates + +runMD5 :: LH () -> MD5Hash +runMD5 = runLH md5HashAlgorithm diff --git a/src/Data/LargeHashable/TH.hs b/src/Data/LargeHashable/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/LargeHashable/TH.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +module Data.LargeHashable.TH ( + + deriveLargeHashable, deriveLargeHashableCtx, deriveLargeHashableNoCtx + , deriveLargeHashableCustomCtx + +) where + +import Data.LargeHashable.Class +import Language.Haskell.TH +import Foreign.C.Types (CULong (..)) +import Control.Monad (forM) + +-- | Template Haskell function to automatically derive +-- instances of 'LargeHashable'. The derived instances first +-- calls 'updateHash' with an unique identifier number for +-- every constructor, followed by 'updateHash' calls for every +-- field of the constructor (if existent). It also works for +-- type families. +-- +-- E. g. for the following code +-- +-- @ +-- +-- data BlaFoo a = Foo +-- | Bar Int a +-- | Baz a a +-- +-- $(deriveLargeHashable ''BlaFoo) +-- @ +-- +-- The following instance gets generated: +-- +-- @ +-- instance LargeHashable a_apg8 => +-- LargeHashable (BlaFoo a_apg8) where +-- updateHash Foo = updateHash (0 :: Foreign.C.Types.CULong) +-- updateHash (Bar a b) +-- = (((updateHash (1 :: Foreign.C.Types.CULong)) >> (updateHash a)) +-- >> (updateHash b)) +-- updateHash (XY a b) +-- = (((updateHash (2 :: Foreign.C.Types.CULong)) >> (updateHash a)) +-- >> (updateHash b)) +-- @ +deriveLargeHashable :: Name -> Q [Dec] +deriveLargeHashable n = reify n >>= \info -> + case info of + TyConI dec -> + case dec of + DataD context name tyvars cons _ -> + buildInstance (ConT name) context tyvars cons + NewtypeD context name tyvars con _ -> + buildInstance (ConT name) context tyvars [con] + _ -> fail $ notDeriveAbleErrorMsg n info + FamilyI _ instDecs -> fmap concat $ forM instDecs $ \instDec -> + case instDec of + DataInstD context name types cons _ -> + buildInstance (foldl AppT (ConT name) types) context [] cons + NewtypeInstD context name types con _ -> + buildInstance (foldl AppT (ConT name) types) context [] [con] + _ -> fail $ notDeriveAbleErrorMsg n info + _ -> fail $ notDeriveAbleErrorMsg n info + +-- | Derive a 'LargeHashable' instance with extra constraints in the +-- context of the instance. +deriveLargeHashableCtx :: + Name + -> ([TypeQ] -> [PredQ]) + -- ^ Function mapping the type variables in the instance head to the additional constraints + -> Q [Dec] +deriveLargeHashableCtx tyName extraPreds = + deriveLargeHashableCustomCtx tyName mkCtx + where + mkCtx args oldCtx = + oldCtx ++ extraPreds args + +-- | Derive a 'LargeHashable' instance with no constraints in the context of the instance. +deriveLargeHashableNoCtx :: + Name + -> (Q [Dec]) +deriveLargeHashableNoCtx tyName = + deriveLargeHashableCustomCtx tyName (\_ _ -> []) + +-- | Derive a 'LargeHashable' instance with a completely custom instance context. +deriveLargeHashableCustomCtx :: + Name + -> ([TypeQ] -> [PredQ] -> [PredQ]) + -- ^ Function mapping the type variables in the instance head and the + -- constraints that would normally be generated to the constraints + -- that should be generated. + -> (Q [Dec]) +deriveLargeHashableCustomCtx tyName extraPreds = + do decs <- deriveLargeHashable tyName + case decs of + (InstanceD ctx ty body : _) -> + do let args = reverse (collectArgs ty) + newCtx <- sequence (extraPreds (map return args) (map return ctx)) + -- _ <- fail ("args: " ++ show args ++", ty: " ++ show ty) + return [InstanceD newCtx ty body] + _ -> + error $ + "Unexpected declarations returned by deriveLargeHashable: " ++ show (ppr decs) + where + collectArgs :: Type -> [Type] + collectArgs outerTy = + let loop ty = + case ty of + (AppT l r) -> + case l of + AppT _ _ -> r : loop l + _ -> [r] + _ -> [] + in case outerTy of + AppT _ r -> loop r + _ -> [] + +-- | Generates the error message displayed when somebody tries to let us +-- derive impossible instances! +notDeriveAbleErrorMsg :: Name -> Info -> String +notDeriveAbleErrorMsg name info = "Could not derive LargeHashable instance for " + ++ (show name) ++ "(" ++ (show info) ++ "). If you think this should be possible, file an issue." + +-- | After 'deriveLargeHashable' has matched all the important information +-- this function gets called to build the instance declaration. +buildInstance :: Type -> Cxt -> [TyVarBndr] -> [Con] -> Q [Dec] +buildInstance basicType context vars cons = + let consWithIds = zip [0..] cons + constraints = makeConstraints context vars + typeWithVars = foldl appT (return basicType) $ map (varT . varName) vars + in (:[]) <$> instanceD constraints (conT ''LargeHashable `appT` typeWithVars) + [updateHashDeclaration consWithIds] + +-- | This function generates the declaration for the 'updateHash' function +-- of the 'LargeHashable' typeclass. By taking the constructors with there +-- selected IDs and calling 'updateHashClause' for everyone of them to generate +-- the corresponding clause. +updateHashDeclaration :: [(Integer, Con)] -> Q Dec +updateHashDeclaration consWIds = funD 'updateHash (map (uncurry updateHashClause) consWIds) + +-- | 'updateHashClause' generates a clause of the 'updateHash' function. +-- It makes sure all the fields are matched correctly and updates the hash +-- with the neccessary information about the constructor (its ID) and all +-- of its fields. +updateHashClause :: Integer -> Con -> Q Clause +updateHashClause i con = + clause [return patOfClause] + (normalB $ + foldl sequenceExps + [| updateHash ($(litE . IntegerL $ i) :: CULong) |] + hashUpdatesOfConFields) + [] + where hashUpdatesOfConFields = map (\name -> [| updateHash $(varE name) |]) patVarNames + -- Extract the names of all the + -- pattern variables from usedPat. + patVarNames = case patOfClause of + ConP _ vars -> map (\(VarP v) -> v) vars + InfixP (VarP v1) _ (VarP v2) -> [v1, v2] + _ -> error "Pattern in patVarNames not matched!" + patOfClause = patternForCon con + +-- | Generate a Pattern that matches the supplied constructor +-- and all of its fields. +patternForCon :: Con -> Pat +patternForCon con = case con of + NormalC n types -> ConP n $ uniqueVarPats (length types) + RecC n varTypes -> ConP n $ uniqueVarPats (length varTypes) + InfixC _ n _ -> InfixP (VarP . mkName $ "x") n (VarP . mkName $ "y") + ForallC _ _ c -> patternForCon c + where uniqueVarPats n = take n . map (VarP . mkName) $ names + +-- | Sequences two Expressions using the '(>>)' operator. +sequenceExps :: Q Exp -> Q Exp -> Q Exp +sequenceExps first second = infixE (Just first) (varE '(>>)) (Just second) + +-- | Generates the constraints needed for the declaration of +-- the 'LargeHashable' class. This means that the constraint +-- @LargeHashable $TypeVar$@ is added for every type variable +-- the type has. +makeConstraints :: Cxt -> [TyVarBndr] -> Q Cxt +makeConstraints context vars = return $ context ++ + map (\v -> (ConT (toLargeHashableClass v)) `AppT` (VarT . varName $ v)) vars + where + toLargeHashableClass :: TyVarBndr -> Name + toLargeHashableClass var = + case var of + (PlainTV _) -> ''LargeHashable + (KindedTV _ (AppT (AppT ArrowT StarT) StarT)) -> ''LargeHashable' + (KindedTV _ _) -> ''LargeHashable + +-- | Returns the 'Name' for a type variable. +varName :: TyVarBndr -> Name +varName (PlainTV n) = n +varName (KindedTV n _) = n + +-- | An infinite list of unique names that +-- are used in the generations of patterns. +names :: [String] +names = concat $ map (gen (map (:[]) ['a'..'z'])) [0..] + where gen :: [String] -> Integer -> [String] + gen acc 0 = acc + gen acc n = gen (concat $ map (\q -> map (\c -> c : q) ['a'..'z']) acc) (n - 1) diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,32 @@ +# For more information, see: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md + +# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) +resolver: lts-6.0 +compiler-check: newer-minor +compiler: ghc-7.10.3 +require-stack-version: ">= 1.0.0" + +# Local packages, usually specified by relative directory name +packages: +- '.' + +# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Control whether we use the GHC we find on the path +# system-ghc: true + +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: >= 0.1.4.0 + +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 + +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] diff --git a/test/Data/LargeHashable/Tests/Class.hs b/test/Data/LargeHashable/Tests/Class.hs new file mode 100644 --- /dev/null +++ b/test/Data/LargeHashable/Tests/Class.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} +module Data.LargeHashable.Tests.Class where + +-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines") +import Data.Fixed +import Data.Hashable +import Data.Int +import Data.LargeHashable +import Data.LargeHashable.Tests.Helper +import Data.Map (Map ()) +import Data.Ratio +import Data.Set (Set ()) +import Data.Time.Calendar +import Data.Time.Clock +import Data.Time.Clock.TAI +import Data.Time.LocalTime +import Data.Word +import Test.Framework hiding (Fixed (..)) +import qualified Data.Aeson as J +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Short as BS +import qualified Data.HashMap.Lazy as HML +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Map as Map +import qualified Data.Scientific as Sci +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Strict.Tuple as Tuple +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Vector as V + +-- of course we can't fully prove uniqueness using +-- properties and there is a small chance of collisions +generic_uniquenessProp :: (Eq a, LargeHashable a) => a -> a -> Bool +generic_uniquenessProp a b = (a == b) == (largeHash md5HashAlgorithm a == largeHash md5HashAlgorithm b) + +prop_integerUniqueness :: Integer -> Integer -> Bool +prop_integerUniqueness = generic_uniquenessProp + +test_hashInteger :: IO () +test_hashInteger = + do subAssert $ assertHashes 0 + subAssert $ assertHashes (toInteger (maxBound::Int)) + subAssert $ assertHashes (toInteger (minBound::Int)) + where + assertHashes :: Integer -> IO () + assertHashes n = + do let list = [(n-100)..(n+100)] + hashes = map (largeHash md5HashAlgorithm) list + hashesSet = Set.fromList hashes + assertEqual (length list) (Set.size hashesSet) + +test_hashBool :: IO () +test_hashBool = + assertBool (largeHash md5HashAlgorithm True /= largeHash md5HashAlgorithm False) + +prop_genericUniqueness :: TestA -> TestA -> Bool +prop_genericUniqueness = generic_uniquenessProp + +prop_intUniqueness :: Int -> Int -> Bool +prop_intUniqueness = generic_uniquenessProp + +prop_int8Uniqueness :: Int8 -> Int8 -> Bool +prop_int8Uniqueness = generic_uniquenessProp + +prop_int16Uniqueness :: Int16 -> Int16 -> Bool +prop_int16Uniqueness = generic_uniquenessProp + +prop_int32Uniqueness :: Int32 -> Int32 -> Bool +prop_int32Uniqueness = generic_uniquenessProp + +prop_int64Uniqueness :: Int64 -> Int64 -> Bool +prop_int64Uniqueness = generic_uniquenessProp + +prop_wordUniqueness :: Word -> Word -> Bool +prop_wordUniqueness = generic_uniquenessProp + +prop_word8Uniqueness :: Word8 -> Word8 -> Bool +prop_word8Uniqueness = generic_uniquenessProp + +prop_word16Uniqueness :: Word16 -> Word16 -> Bool +prop_word16Uniqueness = generic_uniquenessProp + +prop_word32Uniqueness :: Word32 -> Word32 -> Bool +prop_word32Uniqueness = generic_uniquenessProp + +prop_word64Uniqueness :: Word64 -> Word64 -> Bool +prop_word64Uniqueness = generic_uniquenessProp + +prop_charUniqueness :: Char -> Char -> Bool +prop_charUniqueness = generic_uniquenessProp + +prop_bytestringUniqueness :: B.ByteString -> B.ByteString -> Bool +prop_bytestringUniqueness = generic_uniquenessProp + +prop_appendByteStringOk :: B.ByteString -> B.ByteString -> Bool +prop_appendByteStringOk b1 b2 = + runMD5 (updateHash (b1 `B.append` b2)) /= + runMD5 (updateHash b1 >> updateHash b2) + +test_irrelevantByteStringChunking :: IO () +test_irrelevantByteStringChunking = do + assertEqual (largeHash md5HashAlgorithm (BL.fromChunks ["foo", "ba", "r"])) + (largeHash md5HashAlgorithm (BL.fromChunks ["foob", "ar"])) + +prop_lazyBytestringUniqueness :: BL.ByteString -> BL.ByteString -> Bool +prop_lazyBytestringUniqueness = generic_uniquenessProp + +prop_appendLazyByteStringOk :: BL.ByteString -> BL.ByteString -> Bool +prop_appendLazyByteStringOk b1 b2 = + runMD5 (updateHash (b1 `BL.append` b2)) /= + runMD5 (updateHash b1 >> updateHash b2) + +prop_shortBytestringUniqueness :: BS.ShortByteString -> BS.ShortByteString -> Bool +prop_shortBytestringUniqueness = generic_uniquenessProp + +prop_textUniqueness :: T.Text -> T.Text -> Bool +prop_textUniqueness = generic_uniquenessProp + +prop_appendTextOk :: T.Text -> T.Text -> Bool +prop_appendTextOk t1 t2 = + runMD5 (updateHash (t1 `T.append` t2)) /= + runMD5 (updateHash t1 >> updateHash t2) + +test_irrelevantTextChunking :: IO () +test_irrelevantTextChunking = do + assertEqual (largeHash md5HashAlgorithm (TL.fromChunks ["don't", " pa", "nic"])) + (largeHash md5HashAlgorithm (TL.fromChunks ["don", "'t p", "an", "ic"])) + +prop_lazyTextUniqueness :: TL.Text -> TL.Text -> Bool +prop_lazyTextUniqueness = generic_uniquenessProp + +prop_appendLazyTextOk :: TL.Text -> TL.Text -> Bool +prop_appendLazyTextOk t1 t2 = + runMD5 (updateHash (t1 `TL.append` t2)) /= + runMD5 (updateHash t1 >> updateHash t2) + +prop_listUniqueness :: [Bool] -> [Bool] -> Bool +prop_listUniqueness = generic_uniquenessProp + +prop_appendListOk :: [Int] -> [Int] -> Bool +prop_appendListOk l1 l2 = + runMD5 (updateHash (l1 ++ l2)) /= + runMD5 (updateHash l1 >> updateHash l2) + +prop_DoubleUniqueness :: Double -> Double -> Bool +prop_DoubleUniqueness = generic_uniquenessProp + +prop_FloatUniqueness :: Float -> Float -> Bool +prop_FloatUniqueness = generic_uniquenessProp + +prop_setUniqueness :: Set Int -> Set Int -> Bool +prop_setUniqueness = generic_uniquenessProp + +test_hashSet :: IO () +test_hashSet = + do let s1 = Set.fromList [1::Int, 2, 3] + s2 = Set.fromList [3::Int, 2, 1] + s3 = Set.fromList [2::Int, 1, 3] + assertEqual (largeHash md5HashAlgorithm s1) (largeHash md5HashAlgorithm s2) + assertEqual (largeHash md5HashAlgorithm s1) (largeHash md5HashAlgorithm s3) + assertEqual (largeHash md5HashAlgorithm s2) (largeHash md5HashAlgorithm s3) + +prop_unionSetOk :: Set Int -> Set Int -> Bool +prop_unionSetOk s1 s2 = + runMD5 (updateHash (s1 `Set.union` s2)) /= runMD5 (updateHash s1 >> updateHash s2) + +prop_intSetUniqueness :: IS.IntSet -> IS.IntSet -> Bool +prop_intSetUniqueness = generic_uniquenessProp + +test_hashIntSet :: IO () +test_hashIntSet = + do let s1 = IS.fromList [1::Int, 2, 3] + s2 = IS.fromList [3::Int, 2, 1] + s3 = IS.fromList [2::Int, 1, 3] + assertEqual (largeHash md5HashAlgorithm s1) (largeHash md5HashAlgorithm s2) + assertEqual (largeHash md5HashAlgorithm s1) (largeHash md5HashAlgorithm s3) + assertEqual (largeHash md5HashAlgorithm s2) (largeHash md5HashAlgorithm s3) + +prop_unionIntSetOk :: IS.IntSet -> IS.IntSet -> Bool +prop_unionIntSetOk s1 s2 = + runMD5 (updateHash (s1 `IS.union` s2)) /= + runMD5 (updateHash s1 >> updateHash s2) + +prop_hashSetUniqueness :: HS.HashSet Int -> HS.HashSet Int -> Bool +prop_hashSetUniqueness = generic_uniquenessProp + +data ConstHash + = ConstHash Int + deriving (Eq) + +instance Hashable ConstHash where + hashWithSalt _ _ = 0 + +instance LargeHashable ConstHash where + updateHash (ConstHash i) = updateHash i + +test_hashHashSet :: IO () +test_hashHashSet = + do let s1 = HS.fromList [ConstHash 1, ConstHash 2, ConstHash 3] + s2 = HS.fromList [ConstHash 3, ConstHash 2, ConstHash 1] + s3 = HS.fromList [ConstHash 2, ConstHash 1, ConstHash 3] + assertEqual (largeHash md5HashAlgorithm s1) (largeHash md5HashAlgorithm s2) + assertEqual (largeHash md5HashAlgorithm s1) (largeHash md5HashAlgorithm s3) + assertEqual (largeHash md5HashAlgorithm s2) (largeHash md5HashAlgorithm s3) + +prop_unionHashSetOk :: HS.HashSet Int -> HS.HashSet Int -> Bool +prop_unionHashSetOk s1 s2 = + runMD5 (updateHash (s1 `HS.union` s2)) /= + runMD5 (updateHash s1 >> updateHash s2) + +prop_mapUniqueness :: Map Int String -> Map Int String -> Bool +prop_mapUniqueness = generic_uniquenessProp + +test_hashMap :: IO () +test_hashMap = + do let m1 = Map.fromList [(1::Int, "1"::String), (2, "2"), (3, "3")] + m2 = Set.fromList [(3::Int, "3"::String), (2, "2"), (1, "1")] + m3 = Set.fromList [(2::Int, "2"::String), (1, "1"), (3, "3")] + assertEqual (largeHash md5HashAlgorithm m1) (largeHash md5HashAlgorithm m2) + assertEqual (largeHash md5HashAlgorithm m1) (largeHash md5HashAlgorithm m3) + assertEqual (largeHash md5HashAlgorithm m2) (largeHash md5HashAlgorithm m3) + +prop_unionMapOk :: Map Int Bool -> Map Int Bool -> Bool +prop_unionMapOk m1 m2 = + runMD5 (updateHash (m1 `Map.union` m2)) /= runMD5 (updateHash m1 >> updateHash m2) + +prop_intMapUniqueness :: IM.IntMap String -> IM.IntMap String -> Bool +prop_intMapUniqueness = generic_uniquenessProp + +test_hashIntMap :: IO () +test_hashIntMap = + do let m1 = IM.fromList [(1::Int, "1"::String), (2, "2"), (3, "3")] + m2 = IM.fromList [(3::Int, "3"::String), (2, "2"), (1, "1")] + m3 = IM.fromList [(2::Int, "2"::String), (1, "1"), (3, "3")] + assertEqual (largeHash md5HashAlgorithm m1) (largeHash md5HashAlgorithm m2) + assertEqual (largeHash md5HashAlgorithm m1) (largeHash md5HashAlgorithm m3) + assertEqual (largeHash md5HashAlgorithm m2) (largeHash md5HashAlgorithm m3) + +prop_unionIntMapOk :: IM.IntMap Bool -> IM.IntMap Bool -> Bool +prop_unionIntMapOk m1 m2 = + runMD5 (updateHash (m1 `IM.union` m2)) /= runMD5 (updateHash m1 >> updateHash m2) + +prop_hashMapUniqueness :: HM.HashMap Int Bool -> HM.HashMap Int Bool -> Bool +prop_hashMapUniqueness = generic_uniquenessProp + +test_hashHashMap :: IO () +test_hashHashMap = + do let val = "foo" :: String + m1 = HM.fromList [(ConstHash 1, val), (ConstHash 2, val), (ConstHash 3, val)] + m2 = HM.fromList [(ConstHash 3, val), (ConstHash 2, val), (ConstHash 1, val)] + m3 = HM.fromList [(ConstHash 2, val), (ConstHash 1, val), (ConstHash 3, val)] + assertEqual (largeHash md5HashAlgorithm m1) (largeHash md5HashAlgorithm m2) + assertEqual (largeHash md5HashAlgorithm m1) (largeHash md5HashAlgorithm m3) + assertEqual (largeHash md5HashAlgorithm m2) (largeHash md5HashAlgorithm m3) + +prop_unionHashMapOk :: HM.HashMap Int Bool -> HM.HashMap Int Bool -> Bool +prop_unionHashMapOk m1 m2 = + runMD5 (updateHash (m1 `HM.union` m2)) /= runMD5 (updateHash m1 >> updateHash m2) + +prop_hashMapLazyUniqueness :: HML.HashMap Int Bool -> HML.HashMap Int Bool -> Bool +prop_hashMapLazyUniqueness = generic_uniquenessProp + +test_hashHashMapLazy :: IO () +test_hashHashMapLazy = + do let val = "foo" :: String + m1 = HML.fromList [(ConstHash 1, val), (ConstHash 2, val), (ConstHash 3, val)] + m2 = HML.fromList [(ConstHash 3, val), (ConstHash 2, val), (ConstHash 1, val)] + m3 = HML.fromList [(ConstHash 2, val), (ConstHash 1, val), (ConstHash 3, val)] + assertEqual (largeHash md5HashAlgorithm m1) (largeHash md5HashAlgorithm m2) + assertEqual (largeHash md5HashAlgorithm m1) (largeHash md5HashAlgorithm m3) + assertEqual (largeHash md5HashAlgorithm m2) (largeHash md5HashAlgorithm m3) + +prop_hashPairUniqueness :: (Int, Int) -> (Int, Int) -> Bool +prop_hashPairUniqueness = generic_uniquenessProp + +prop_hashTripleUniqueness :: (Int, Int, Int) -> (Int, Int, Int) -> Bool +prop_hashTripleUniqueness = generic_uniquenessProp + +prop_hashQuadrupleUniqueness :: (Int, Int, Int, Int) -> (Int, Int, Int, Int) -> Bool +prop_hashQuadrupleUniqueness = generic_uniquenessProp + +prop_hashQuintupleUniqueness :: (Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int) -> Bool +prop_hashQuintupleUniqueness = generic_uniquenessProp + +prop_hashStrictPairUniqueness :: Tuple.Pair Int Int -> Tuple.Pair Int Int -> Bool +prop_hashStrictPairUniqueness = generic_uniquenessProp + +prop_hashMaybeUniqueness :: Maybe Int -> Maybe Int -> Bool +prop_hashMaybeUniqueness = generic_uniquenessProp + +prop_hashEitherUniqueness :: Either Int Bool -> Either Int Bool -> Bool +prop_hashEitherUniqueness = generic_uniquenessProp + +prop_hashOrderingUniqueness :: Ordering -> Ordering -> Bool +prop_hashOrderingUniqueness = generic_uniquenessProp + +prop_ratioUniqueness :: Ratio Int -> Ratio Int -> Bool +prop_ratioUniqueness = generic_uniquenessProp + +test_ratio :: IO () +test_ratio = + do let r1 = (1::Int) % 2 + r2 = (2::Int) % 4 + assertEqual (largeHash md5HashAlgorithm r1) (largeHash md5HashAlgorithm r2) + +prop_dayUniqueness :: Day -> Day -> Bool +prop_dayUniqueness = generic_uniquenessProp + +prop_diffTimeUniqueness :: DiffTime -> DiffTime -> Bool +prop_diffTimeUniqueness = generic_uniquenessProp + +prop_utcTimeUniqueness :: UTCTime -> UTCTime -> Bool +prop_utcTimeUniqueness = generic_uniquenessProp + +prop_absoluteTimeUniqueness :: AbsoluteTime -> AbsoluteTime -> Bool +prop_absoluteTimeUniqueness = generic_uniquenessProp + +prop_nominalDiffTimeUniqueness :: NominalDiffTime -> NominalDiffTime -> Bool +prop_nominalDiffTimeUniqueness = generic_uniquenessProp + +prop_timeZoneUniqueness :: TimeZone -> TimeZone -> Bool +prop_timeZoneUniqueness = generic_uniquenessProp + +prop_timeOfDayUniqueness :: TimeOfDay -> TimeOfDay -> Bool +prop_timeOfDayUniqueness = generic_uniquenessProp + +prop_localTimeUniqueness :: LocalTime -> LocalTime -> Bool +prop_localTimeUniqueness = generic_uniquenessProp + +prop_fixedUniqueness :: Fixed E1 -> Fixed E1 -> Bool +prop_fixedUniqueness = generic_uniquenessProp + +prop_scientificUniqueness :: Sci.Scientific -> Sci.Scientific -> Bool +prop_scientificUniqueness = generic_uniquenessProp + +prop_aesonValueUniqueness :: J.Value -> J.Value -> Bool +prop_aesonValueUniqueness = generic_uniquenessProp + +prop_vectorUniqueness :: V.Vector Int -> V.Vector Int -> Bool +prop_vectorUniqueness = generic_uniquenessProp + +prop_appendVectorOk :: V.Vector Int -> V.Vector Int -> Bool +prop_appendVectorOk v1 v2 = + runMD5 (updateHash (v1 V.++ v2)) /= + runMD5 (updateHash v1 >> updateHash v2) + +prop_seqUniqueness :: Seq.Seq Int -> Seq.Seq Int -> Bool +prop_seqUniqueness = generic_uniquenessProp + +prop_appendSeqOk :: Seq.Seq Int -> Seq.Seq Int -> Bool +prop_appendSeqOk s1 s2 = + runMD5 (updateHash (s1 Seq.>< s2)) /= + runMD5 (updateHash s1 >> updateHash s2) diff --git a/test/Data/LargeHashable/Tests/Helper.hs b/test/Data/LargeHashable/Tests/Helper.hs new file mode 100644 --- /dev/null +++ b/test/Data/LargeHashable/Tests/Helper.hs @@ -0,0 +1,228 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Data.LargeHashable.Tests.Helper where + +-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines") +import Control.Monad +import Data.Bytes.Serial +import Data.Hashable +import Data.LargeHashable +import Data.Time.Calendar +import Data.Time.Clock +import Data.Time.Clock.TAI +import Data.Time.LocalTime +import GHC.Generics +import Test.QuickCheck +import qualified Data.Aeson as J +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Short as BS +import qualified Data.HashMap.Lazy as HML +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.Scientific as Sci +import qualified Data.Strict.Tuple as Tuple +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Vector as V + +#if !MIN_VERSION_QuickCheck(2,8,2) +-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines") +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Map as M +import qualified Data.Set as S +#endif + +instance Arbitrary T.Text where + arbitrary = fmap T.pack arbitrary + shrink = map T.pack . shrink . T.unpack + +instance Arbitrary B.ByteString where + arbitrary = fmap B.pack arbitrary + shrink = map B.pack . shrink . B.unpack + +instance Arbitrary BL.ByteString where + arbitrary = fmap BL.fromChunks arbitrary + shrink = map BL.fromChunks . shrink . BL.toChunks + +instance Arbitrary TL.Text where + arbitrary = fmap TL.fromChunks arbitrary + shrink = map TL.fromChunks . shrink . TL.toChunks + +instance Arbitrary a => Arbitrary (V.Vector a) where + arbitrary = liftM V.fromList arbitrary + shrink = map V.fromList . shrink . V.toList + +instance Arbitrary Sci.Scientific where + arbitrary = + liftM2 Sci.scientific arbitrary arbitrary + shrink = shrinkRealFrac + +instance Arbitrary J.Value where + arbitrary = sized arbitraryJsonValue + where + arbitraryJsonValue n = + if n <= 0 + then oneof simpleGens + else frequency $ + (map (\g -> (1, g)) simpleGens) ++ + [(3, arbitraryObject (n `div` 2)) + ,(3, arbitraryArray (n `div` 2))] + arbitraryObject n = + do l <- arbitraryListOfJsonValues n + elems <- forM l $ \v -> + do k <- + elements + ["key", "foo", "bar", "baz", "spam", "egg", "chicken", "dog" + ,"any", "what", "santa", "mark", "wardrobe", "baseball"] + return (k, v) + return (J.Object (HM.fromList elems)) + arbitraryArray n = + do l <- arbitraryListOfJsonValues n + return (J.Array (V.fromList l)) + arbitraryListOfJsonValues n = + do size <- elements [(0::Int)..10] + forM [1..(size::Int)] $ \_ -> arbitraryJsonValue n + simpleGens = + [liftM J.String arbitrary + ,liftM J.Number arbitrary + ,liftM J.Bool arbitrary + ,return J.Null] + shrink v = + case v of + J.Object obj -> + map J.Object (shrink obj) + J.Array arr -> + map J.Array (shrink arr) + J.String t -> + map J.String (shrink t) + J.Number n -> + map J.Number (shrink n) + J.Bool _ -> [] + J.Null -> [] + +instance (Eq k, Hashable k, Arbitrary k, Arbitrary a) => Arbitrary (HML.HashMap k a) where + arbitrary = fmap HML.fromList arbitrary + shrink = map HML.fromList . shrink . HML.toList + +instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HS.HashSet a) where + arbitrary = fmap HS.fromList arbitrary + shrink = map HS.fromList . shrink . HS.toList + +#if !MIN_VERSION_QuickCheck(2,8,2) +instance (Ord k, Arbitrary k, Arbitrary a) => Arbitrary (M.Map k a) where + arbitrary = fmap M.fromList arbitrary + shrink = map M.fromList . shrink . M.toList + +instance Arbitrary a => Arbitrary (IM.IntMap a) where + arbitrary = fmap IM.fromList arbitrary + shrink = map IM.fromList . shrink . IM.toList + +instance (Ord a, Arbitrary a) => Arbitrary (S.Set a) where + arbitrary = fmap S.fromList arbitrary + shrink = map S.fromList . shrink . S.toList + +instance Arbitrary IS.IntSet where + arbitrary = fmap IS.fromList arbitrary + shrink = map IS.fromList . shrink . IS.toList + +#endif + +data TestA + = TestA + { age :: Int + , wealth :: Integer + , isStudent :: Bool + , name :: T.Text + , initials :: [Char] + , legLength :: (Int, Int) + } deriving (Generic, Eq, Show) + +instance LargeHashable TestA +instance Serial TestA + +instance Arbitrary TestA where + arbitrary = + TestA <$> arbitrary <*> arbitrary <*> arbitrary <*> + arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary BS.ShortByteString where + arbitrary = liftM BS.pack arbitrary + shrink x = + map BS.pack (shrink (BS.unpack x)) + +instance Arbitrary Day where + arbitrary = + do n <- arbitrary + return (ModifiedJulianDay (n `mod` 1000)) + shrink (ModifiedJulianDay n) = + map ModifiedJulianDay (shrink n) + +instance Arbitrary DiffTime where + arbitrary = + liftM picosecondsToDiffTime arbitrary + shrink delta = + let n = toRational delta + in map fromRational (shrink n) + +instance Arbitrary UTCTime where + arbitrary = + do day <- arbitrary + picos <- arbitrary + return (UTCTime day (picosecondsToDiffTime (picos `mod` 86401))) + +instance Arbitrary AbsoluteTime where + arbitrary = + do diff <- arbitrary + return (addAbsoluteTime diff taiEpoch) + +instance Arbitrary NominalDiffTime where + arbitrary = + do r <- arbitrary + return (fromRational r) + +instance Arbitrary TimeZone where + arbitrary = + do n <- arbitrary + s <- arbitrary + b <- arbitrary + return (TimeZone (n `mod` (60*24)) b s) + +instance Arbitrary TimeOfDay where + arbitrary = + do h <- arbitrary + m <- arbitrary + s <- arbitrary + return (TimeOfDay (h `mod` 24) (m `mod` 60) (fromInteger (s `mod` 61))) + +instance Arbitrary LocalTime where + arbitrary = + do d <- arbitrary + t <- arbitrary + return (LocalTime d t) + +instance Arbitrary ZonedTime where + arbitrary = + do t <- arbitrary + z <- arbitrary + return (ZonedTime t z) + +instance Arbitrary UniversalTime where + arbitrary = + do r <- arbitrary + return (ModJulianDate r) + +instance (Arbitrary a, Arbitrary b) => Arbitrary (Tuple.Pair a b) where + arbitrary = + do x <- arbitrary + y <- arbitrary + return (x Tuple.:!: y) + +instance Arbitrary Word128 where + arbitrary = Word128 <$> arbitrary <*> arbitrary + +instance Arbitrary Word256 where + arbitrary = Word256 <$> arbitrary <*> arbitrary diff --git a/test/Data/LargeHashable/Tests/LargeWord.hs b/test/Data/LargeHashable/Tests/LargeWord.hs new file mode 100644 --- /dev/null +++ b/test/Data/LargeHashable/Tests/LargeWord.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +module Data.LargeHashable.Tests.LargeWord where + +-- keep imports in alphabetic order (in Emacs, use "M-x sort-lines") +import Data.LargeHashable.LargeWord +import Data.LargeHashable.Tests.Helper () +import Test.Framework +import qualified Data.ByteString as BS + +prop_w128BsHasLength16 :: Word128 -> Bool +prop_w128BsHasLength16 x = BS.length (w128ToBs x) == 16 + +prop_conversionFromAndToWord128 :: Word128 -> Bool +prop_conversionFromAndToWord128 h128 = h128 == bsToW128 (w128ToBs h128) + +prop_conversionFromAndToWord256 :: Word256 -> Bool +prop_conversionFromAndToWord256 h256 = h256 == bsToW256 (w256ToBs h256) + +test_bsToW128 :: IO () +test_bsToW128 = + do assertEqual (Word128 0 0) (bsToW128 BS.empty) + assertEqual (bsToW128 (BS.pack ([0,0,0,0,0,0,0,1] ++ replicate 8 0))) (bsToW128 (BS.pack [1])) + assertEqual (bsToW128 (BS.pack ([1,2,3,4,5,6,7,8,0,0,0,0,0,0,0,9]))) + (bsToW128 (BS.pack [1,2,3,4,5,6,7,8,9])) diff --git a/test/Data/LargeHashable/Tests/TH.hs b/test/Data/LargeHashable/Tests/TH.hs new file mode 100644 --- /dev/null +++ b/test/Data/LargeHashable/Tests/TH.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} +{-# OPTIONS_GHC -ddump-splices #-} +module Data.LargeHashable.Tests.TH where + +import Test.Framework + +import Data.LargeHashable + +-- | Simple test data structure that embodies most +-- of the diferrent features of a type +-- the TH deriver can encounter. +data BlaFoo a + = Foo + | Bar Int a + | Baz a a a + deriving (Eq, Show) + +$(deriveLargeHashable ''BlaFoo) + +instance Arbitrary a => Arbitrary (BlaFoo a) where + arbitrary = oneof [ pure Foo + , Bar <$> arbitrary <*> arbitrary + , Baz <$> arbitrary <*> arbitrary <*> arbitrary + ] + +-- | Simple property that tries to find hash collisions. +prop_thDerivedHashUnique :: BlaFoo Char -> BlaFoo Char -> Bool +prop_thDerivedHashUnique x y = (x == y) == (largeHash md5HashAlgorithm x == largeHash md5HashAlgorithm y) + +newtype Fool = Fool { unFool :: Bool } + +$(deriveLargeHashable ''Fool) + +-- | Simple sanity check for TH derived instances for newtypes. +test_newtypeTHHashSane :: IO () +test_newtypeTHHashSane = assertNotEqual (largeHash md5HashAlgorithm (Fool True)) + (largeHash md5HashAlgorithm (Fool False)) + +data HigherKinded t = HigherKinded (t String) +data HigherKindedContainer t = HigherKindedContainer (HigherKinded t) + +instance LargeHashable' BlaFoo where + updateHash' = updateHash + +instance LargeHashable' t => LargeHashable (HigherKinded t) where + updateHash (HigherKinded x) = + updateHash' x + +$(deriveLargeHashable ''HigherKindedContainer) + +test_higherKinded :: IO () +test_higherKinded = + assertNotEqual + (largeHash md5HashAlgorithm (HigherKinded (Bar 42 "Stefan"))) + (largeHash md5HashAlgorithm (HigherKinded (Bar 5 "Stefan"))) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +module Main where + +import Test.Framework + +-- In Emacs sort block with M-x sort-lines +import {-@ HTF_TESTS @-} Data.LargeHashable.Tests.Class +import {-@ HTF_TESTS @-} Data.LargeHashable.Tests.LargeWord +import {-@ HTF_TESTS @-} Data.LargeHashable.Tests.TH + +allTests :: [TestSuite] +allTests = htf_importedTests + +main :: IO () +main = htfMain allTests