diff --git a/Bench/Bench.hs b/Bench/Bench.hs deleted file mode 100644 --- a/Bench/Bench.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -import Criterion.Main -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import qualified Crypto.Hash.SHA1 as SHA1 - -hashmany (i,u,f) = f . foldl u i - -allHashs = - [ ("SHA-1",SHA1.hash, hashmany (SHA1.init,SHA1.update,SHA1.finalize)) - ] - -benchHash :: a -> (a -> B.ByteString) -> Benchmarkable -benchHash bs f = whnf f bs - -withHashesFilter out f = map f $ filter (\(n,_,_) -> not (n `elem` out)) allHashs -withHashes f = map f allHashs - -main = do - let !bs32 = B.replicate 32 0 - !bs256 = B.replicate 256 0 - !bs4096 = B.replicate 4096 0 - !bs1M = B.replicate (1*1024*1024) 0 - let !lbs64x256 = (map (const (B.replicate 64 0)) [0..3]) - !lbs64x4096 = (map (const (B.replicate 64 0)) [0..63]) - defaultMain - [ bgroup "hash-32b" (withHashes (\(name, f,_) -> bench name $ benchHash bs32 f)) - , bgroup "hash-256b" (withHashes (\(name, f,_) -> bench name $ benchHash bs256 f)) - , bgroup "hash-4Kb" (withHashes (\(name, f,_) -> bench name $ benchHash bs4096 f)) - , bgroup "hash-1Mb" (withHashesFilter ["MD2"] (\(name, f,_) -> bench name $ benchHash bs1M f)) - , bgroup "iuf-64x256" (withHashes (\(name, _,f) -> bench name $ benchHash lbs64x256 f)) - , bgroup "iuf-64x4096" (withHashes (\(name, _,f) -> bench name $ benchHash lbs64x4096 f)) - ] diff --git a/Crypto/Hash/SHA1.hs b/Crypto/Hash/SHA1.hs deleted file mode 100644 --- a/Crypto/Hash/SHA1.hs +++ /dev/null @@ -1,184 +0,0 @@ --- | --- Module : Crypto.Hash.SHA1 --- License : BSD-style --- Maintainer : Herbert Valerio Riedel --- Stability : stable --- Portability : unknown --- --- A module containing bindings --- -module Crypto.Hash.SHA1 - ( - - -- * Incremental API - -- - -- | This API is based on 4 different functions, similar to the - -- lowlevel operations of a typical hash: - -- - -- - 'init': create a new hash context - -- - 'update': update non-destructively a new hash context with a strict bytestring - -- - 'updates': same as update, except that it takes a list of strict bytestring - -- - 'finalize': finalize the context and returns a digest bytestring. - -- - -- all those operations are completely pure, and instead of - -- changing the context as usual in others language, it - -- re-allocates a new context each time. - -- - -- Example: - -- - -- > import qualified Data.ByteString - -- > import qualified Crypto.Hash.SHA1 as SHA1 - -- > - -- > main = print digest - -- > where - -- > digest = SHA1.finalize ctx - -- > ctx = foldl SHA1.update ctx0 (map Data.ByteString.pack [ [1,2,3], [4,5,6] ]) - -- > ctx0 = SHA1.init - - Ctx(..) - , init -- :: Ctx - , update -- :: Ctx -> ByteString -> Ctx - , updates -- :: Ctx -> [ByteString] -> Ctx - , finalize -- :: Ctx -> ByteString - - -- * Single Pass API - -- - -- | This API use the incremental API under the hood to provide - -- the common all-in-one operations to create digests out of a - -- 'ByteString' and lazy 'L.ByteString'. - -- - -- - 'hash': create a digest ('init' + 'update' + 'finalize') from a strict 'ByteString' - -- - 'hashlazy': create a digest ('init' + 'update' + 'finalize') from a lazy 'L.ByteString' - -- - -- Example: - -- - -- > import qualified Data.ByteString - -- > import qualified Crypto.Hash.SHA1 as SHA1 - -- > - -- > main = print $ SHA1.hash (Data.ByteString.pack [0..255]) - -- - -- __NOTE__: The returned digest is a binary 'ByteString'. For - -- converting to a base16/hex encoded digest the - -- - -- package is recommended. - - , hash -- :: ByteString -> ByteString - , hashlazy -- :: ByteString -> ByteString - ) where - -import Prelude hiding (init) -import Foreign.Ptr -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Storable -import Foreign.Marshal.Alloc -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString as B -import Data.ByteString (ByteString) -import Data.ByteString.Unsafe (unsafeUseAsCStringLen) -import Data.ByteString.Internal (create, toForeignPtr) -import Data.Word -import System.IO.Unsafe (unsafeDupablePerformIO) - --- | perform IO for hashes that do allocation and ffi. --- unsafeDupablePerformIO is used when possible as the --- computation is pure and the output is directly linked --- to the input. we also do not modify anything after it has --- been returned to the user. -unsafeDoIO :: IO a -> a -unsafeDoIO = unsafeDupablePerformIO - --- | SHA-1 Context -newtype Ctx = Ctx ByteString - -{-# INLINE digestSize #-} -digestSize :: Int -digestSize = 20 - -{-# INLINE sizeCtx #-} -sizeCtx :: Int -sizeCtx = 96 - -{-# RULES "digestSize" B.length (finalize init) = digestSize #-} -{-# RULES "hash" forall b. finalize (update init b) = hash b #-} -{-# RULES "hash.list1" forall b. finalize (updates init [b]) = hash b #-} -{-# RULES "hashmany" forall b. finalize (foldl update init b) = hashlazy (L.fromChunks b) #-} -{-# RULES "hashlazy" forall b. finalize (foldl update init $ L.toChunks b) = hashlazy b #-} - -{-# INLINE withByteStringPtr #-} -withByteStringPtr :: ByteString -> (Ptr Word8 -> IO a) -> IO a -withByteStringPtr b f = - withForeignPtr fptr $ \ptr -> f (ptr `plusPtr` off) - where (fptr, off, _) = toForeignPtr b - -{-# INLINE memcopy64 #-} -memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO () -memcopy64 dst src = mapM_ peekAndPoke [0..(12-1)] - where peekAndPoke i = peekElemOff src i >>= pokeElemOff dst i - -withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx -withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx - where createCtx = create sizeCtx $ \dstPtr -> - withByteStringPtr ctxB $ \srcPtr -> do - memcopy64 (castPtr dstPtr) (castPtr srcPtr) - f (castPtr dstPtr) - -withCtxThrow :: Ctx -> (Ptr Ctx -> IO a) -> IO a -withCtxThrow (Ctx ctxB) f = - allocaBytes sizeCtx $ \dstPtr -> - withByteStringPtr ctxB $ \srcPtr -> do - memcopy64 (castPtr dstPtr) (castPtr srcPtr) - f (castPtr dstPtr) - -withCtxNew :: (Ptr Ctx -> IO ()) -> IO Ctx -withCtxNew f = Ctx `fmap` create sizeCtx (f . castPtr) - -withCtxNewThrow :: (Ptr Ctx -> IO a) -> IO a -withCtxNewThrow f = allocaBytes sizeCtx (f . castPtr) - -foreign import ccall unsafe "sha1.h hs_cryptohash_sha1_init" - c_sha1_init :: Ptr Ctx -> IO () - -foreign import ccall unsafe "sha1.h hs_cryptohash_sha1_update" - c_sha1_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO () - -foreign import ccall unsafe "sha1.h hs_cryptohash_sha1_finalize" - c_sha1_finalize :: Ptr Ctx -> Ptr Word8 -> IO () - -updateInternalIO :: Ptr Ctx -> ByteString -> IO () -updateInternalIO ptr d = - unsafeUseAsCStringLen d (\(cs, len) -> c_sha1_update ptr (castPtr cs) (fromIntegral len)) - -finalizeInternalIO :: Ptr Ctx -> IO ByteString -finalizeInternalIO ptr = create digestSize (c_sha1_finalize ptr) - -{-# NOINLINE init #-} --- | init a context -init :: Ctx -init = unsafeDoIO $ withCtxNew $ c_sha1_init - -{-# NOINLINE update #-} --- | update a context with a bytestring -update :: Ctx -> ByteString -> Ctx -update ctx d = unsafeDoIO $ withCtxCopy ctx $ \ptr -> updateInternalIO ptr d - -{-# NOINLINE updates #-} --- | updates a context with multiples bytestring -updates :: Ctx -> [ByteString] -> Ctx -updates ctx d = unsafeDoIO $ withCtxCopy ctx $ \ptr -> mapM_ (updateInternalIO ptr) d - -{-# NOINLINE finalize #-} --- | finalize the context into a digest bytestring -finalize :: Ctx -> ByteString -finalize ctx = unsafeDoIO $ withCtxThrow ctx finalizeInternalIO - -{-# NOINLINE hash #-} --- | hash a strict bytestring into a digest bytestring -hash :: ByteString -> ByteString -hash d = unsafeDoIO $ withCtxNewThrow $ \ptr -> do - c_sha1_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr - -{-# NOINLINE hashlazy #-} --- | hash a lazy bytestring into a digest bytestring -hashlazy :: L.ByteString -> ByteString -hashlazy l = unsafeDoIO $ withCtxNewThrow $ \ptr -> do - c_sha1_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr diff --git a/Tests/KAT.hs b/Tests/KAT.hs deleted file mode 100644 --- a/Tests/KAT.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -import Data.Char -import Data.Bits -import Data.Word -import Data.ByteString (ByteString) -import Data.Foldable (foldl') -import Data.Monoid (mconcat) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Crypto.Hash.SHA1 as SHA1 - -import Test.Tasty -import Test.Tasty.QuickCheck -import Test.Tasty.HUnit - -v0,v1,v2 :: ByteString -v0 = "" -v1 = "The quick brown fox jumps over the lazy dog" -v2 = "The quick brown fox jumps over the lazy cog" -vectors = [ v0, v1, v2 ] - -instance Arbitrary ByteString where - arbitrary = B.pack `fmap` arbitrary - -data HashFct = HashFct - { fctHash :: (B.ByteString -> B.ByteString) - , fctInc :: ([B.ByteString] -> B.ByteString) } - -hashinc i u f = f . foldl u i - -sha1Hash = HashFct { fctHash = SHA1.hash, fctInc = hashinc SHA1.init SHA1.update SHA1.finalize } - - -results :: [ (String, HashFct, [String]) ] -results = [ - ("SHA1", sha1Hash, [ - "da39a3ee5e6b4b0d3255bfef95601890afd80709", - "2fd4e1c67a2d28fced849ee1bb76e7391b93eb12", - "de9f2c7fd25e1b3afad3e85a0bd17d9b100db4b3" ]) - ] - -hexalise s = concatMap (\c -> [ hex $ c `div` 16, hex $ c `mod` 16 ]) s - where hex i - | i >= 0 && i <= 9 = fromIntegral (ord '0') + i - | i >= 10 && i <= 15 = fromIntegral (ord 'a') + i - 10 - | otherwise = 0 - -hexaliseB :: B.ByteString -> B.ByteString -hexaliseB = B.pack . hexalise . B.unpack - -splitB :: Int -> ByteString -> [ByteString] -splitB l b = - if B.length b > l - then - let (b1, b2) = B.splitAt l b in - b1 : splitB l b2 - else - [ b ] - -showHash :: B.ByteString -> String -showHash = map (toEnum.fromEnum) . hexalise . B.unpack - -runhash hash v = showHash $ (fctHash hash) $ v -runhashinc hash v = showHash $ (fctInc hash) $ v - -makeTestAlg (name, hash, results) = testGroup name $ concatMap maketest (zip3 [0..] vectors results) - where - runtest :: ByteString -> String - runtest v = runhash hash v - - runtestinc :: Int -> ByteString -> String - runtestinc i v = runhashinc hash $ splitB i v - - maketest (i, v, r) = - [ testCase (show i ++ " one-pass") (r @=? runtest v) - , testCase (show i ++ " inc 1") (r @=? runtestinc 1 v) - , testCase (show i ++ " inc 2") (r @=? runtestinc 2 v) - , testCase (show i ++ " inc 3") (r @=? runtestinc 3 v) - , testCase (show i ++ " inc 4") (r @=? runtestinc 4 v) - , testCase (show i ++ " inc 5") (r @=? runtestinc 5 v) - , testCase (show i ++ " inc 9") (r @=? runtestinc 9 v) - , testCase (show i ++ " inc 16") (r @=? runtestinc 16 v) - ] - -katTests :: [TestTree] -katTests = map makeTestAlg results - - -main = defaultMain $ testGroup "cryptohash" - [ testGroup "KATs" katTests - ] diff --git a/cbits/bitfn.h b/cbits/bitfn.h deleted file mode 100644 --- a/cbits/bitfn.h +++ /dev/null @@ -1,240 +0,0 @@ -/* - * 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 BITFN_H -#define BITFN_H -#include - -#ifndef NO_INLINE_ASM -/**********************************************************/ -# if (defined(__i386__)) -# define ARCH_HAS_SWAP32 -static inline uint32_t bitfn_swap32(uint32_t a) -{ - asm ("bswap %0" : "=r" (a) : "0" (a)); - return a; -} -/**********************************************************/ -# elif (defined(__arm__)) -# define ARCH_HAS_SWAP32 -static inline uint32_t bitfn_swap32(uint32_t a) -{ - uint32_t tmp = a; - asm volatile ("eor %1, %0, %0, ror #16\n" - "bic %1, %1, #0xff0000\n" - "mov %0, %0, ror #8\n" - "eor %0, %0, %1, lsr #8\n" - : "=r" (a), "=r" (tmp) : "0" (a), "1" (tmp)); - return a; -} -/**********************************************************/ -# elif defined(__x86_64__) -# define ARCH_HAS_SWAP32 -# define ARCH_HAS_SWAP64 -static inline uint32_t bitfn_swap32(uint32_t a) -{ - asm ("bswap %0" : "=r" (a) : "0" (a)); - return a; -} - -static inline uint64_t bitfn_swap64(uint64_t a) -{ - asm ("bswap %0" : "=r" (a) : "0" (a)); - return a; -} - -# endif -#endif /* NO_INLINE_ASM */ -/**********************************************************/ - -#ifndef ARCH_HAS_ROL32 -static inline uint32_t rol32(uint32_t word, uint32_t shift) -{ - return (word << shift) | (word >> (32 - shift)); -} -#endif - -#ifndef ARCH_HAS_ROR32 -static inline uint32_t ror32(uint32_t word, uint32_t shift) -{ - return (word >> shift) | (word << (32 - shift)); -} -#endif - -#ifndef ARCH_HAS_ROL64 -static inline uint64_t rol64(uint64_t word, uint32_t shift) -{ - return (word << shift) | (word >> (64 - shift)); -} -#endif - -#ifndef ARCH_HAS_ROR64 -static inline uint64_t ror64(uint64_t word, uint32_t shift) -{ - return (word >> shift) | (word << (64 - shift)); -} -#endif - -#ifndef ARCH_HAS_SWAP32 -static inline uint32_t bitfn_swap32(uint32_t a) -{ - return (a << 24) | ((a & 0xff00) << 8) | ((a >> 8) & 0xff00) | (a >> 24); -} -#endif - -#ifndef ARCH_HAS_ARRAY_SWAP32 -static inline void array_swap32(uint32_t *d, uint32_t *s, uint32_t nb) -{ - while (nb--) - *d++ = bitfn_swap32(*s++); -} -#endif - -#ifndef ARCH_HAS_SWAP64 -static inline uint64_t bitfn_swap64(uint64_t a) -{ - return ((uint64_t) bitfn_swap32((uint32_t) (a >> 32))) | - (((uint64_t) bitfn_swap32((uint32_t) a)) << 32); -} -#endif - -#ifndef ARCH_HAS_ARRAY_SWAP64 -static inline void array_swap64(uint64_t *d, uint64_t *s, uint32_t nb) -{ - while (nb--) - *d++ = bitfn_swap64(*s++); -} -#endif - -#ifndef ARCH_HAS_MEMORY_ZERO -static inline void memory_zero(void *ptr, uint32_t len) -{ - uint32_t *ptr32 = ptr; - uint8_t *ptr8; - int i; - - for (i = 0; i < len / 4; i++) - *ptr32++ = 0; - if (len % 4) { - ptr8 = (uint8_t *) ptr32; - for (i = len % 4; i >= 0; i--) - ptr8[i] = 0; - } -} -#endif - -#ifndef ARCH_HAS_ARRAY_COPY32 -static inline void array_copy32(uint32_t *d, uint32_t *s, uint32_t nb) -{ - while (nb--) *d++ = *s++; -} -#endif - -#ifndef ARCH_HAS_ARRAY_COPY64 -static inline void array_copy64(uint64_t *d, uint64_t *s, uint32_t nb) -{ - while (nb--) *d++ = *s++; -} -#endif - -#ifdef __MINGW32__ - # define LITTLE_ENDIAN 1234 - # define BYTE_ORDER LITTLE_ENDIAN -#elif defined(__FreeBSD__) || defined(__DragonFly__) || defined(__NetBSD__) - # include -#elif defined(__OpenBSD__) || defined(__SVR4) - # include -#elif defined(__APPLE__) - # include -#elif defined( BSD ) && ( BSD >= 199103 ) - # include -#elif defined( __QNXNTO__ ) && defined( __LITTLEENDIAN__ ) - # define LITTLE_ENDIAN 1234 - # define BYTE_ORDER LITTLE_ENDIAN -#elif defined( __QNXNTO__ ) && defined( __BIGENDIAN__ ) - # define BIG_ENDIAN 1234 - # define BYTE_ORDER BIG_ENDIAN -#elif defined( _AIX ) - # include -#else - # include -#endif -/* big endian to cpu */ -#if LITTLE_ENDIAN == BYTE_ORDER - -# define be32_to_cpu(a) bitfn_swap32(a) -# define cpu_to_be32(a) bitfn_swap32(a) -# define le32_to_cpu(a) (a) -# define cpu_to_le32(a) (a) -# define be64_to_cpu(a) bitfn_swap64(a) -# define cpu_to_be64(a) bitfn_swap64(a) -# define le64_to_cpu(a) (a) -# define cpu_to_le64(a) (a) - -# define cpu_to_le32_array(d, s, l) array_copy32(d, s, l) -# define le32_to_cpu_array(d, s, l) array_copy32(d, s, l) -# define cpu_to_be32_array(d, s, l) array_swap32(d, s, l) -# define be32_to_cpu_array(d, s, l) array_swap32(d, s, l) - -# define cpu_to_le64_array(d, s, l) array_copy64(d, s, l) -# define le64_to_cpu_array(d, s, l) array_copy64(d, s, l) -# define cpu_to_be64_array(d, s, l) array_swap64(d, s, l) -# define be64_to_cpu_array(d, s, l) array_swap64(d, s, l) - -# define ror32_be(a, s) rol32(a, s) -# define rol32_be(a, s) ror32(a, s) - -# define ARCH_IS_LITTLE_ENDIAN - -#elif BIG_ENDIAN == BYTE_ORDER - -# define be32_to_cpu(a) (a) -# define cpu_to_be32(a) (a) -# define be64_to_cpu(a) (a) -# define cpu_to_be64(a) (a) -# define le64_to_cpu(a) bitfn_swap64(a) -# define cpu_to_le64(a) bitfn_swap64(a) -# define le32_to_cpu(a) bitfn_swap32(a) -# define cpu_to_le32(a) bitfn_swap32(a) - -# define cpu_to_le32_array(d, s, l) array_swap32(d, s, l) -# define le32_to_cpu_array(d, s, l) array_swap32(d, s, l) -# define cpu_to_be32_array(d, s, l) array_copy32(d, s, l) -# define be32_to_cpu_array(d, s, l) array_copy32(d, s, l) - -# define cpu_to_le64_array(d, s, l) array_swap64(d, s, l) -# define le64_to_cpu_array(d, s, l) array_swap64(d, s, l) -# define cpu_to_be64_array(d, s, l) array_copy64(d, s, l) -# define be64_to_cpu_array(d, s, l) array_copy64(d, s, l) - -# define ror32_be(a, s) ror32(a, s) -# define rol32_be(a, s) rol32(a, s) - -# define ARCH_IS_BIG_ENDIAN - -#else -# error "endian not supported" -#endif - -#endif /* !BITFN_H */ diff --git a/cbits/sha1.c b/cbits/sha1.c --- a/cbits/sha1.c +++ b/cbits/sha1.c @@ -23,20 +23,74 @@ * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ -#include #include "sha1.h" -#include "bitfn.h" -void +#include +#include +#include + +#if defined(static_assert) +static_assert(offsetof(struct sha1_ctx, h[5]) == SHA1_CTX_SIZE, "unexpected sha1_ctx size"); +#else +/* poor man's pre-C11 _Static_assert */ +typedef char static_assertion__unexpected_sha1_ctx_size[(offsetof(struct sha1_ctx, h[5]) == SHA1_CTX_SIZE)?1:-1]; +#endif + +#define ptr_uint32_aligned(ptr) (!((uintptr_t)(ptr) & 0x3)) + +static inline uint32_t +rol32(const uint32_t word, const unsigned shift) +{ + /* GCC usually transforms this into a 'rol'-insn */ + return (word << shift) | (word >> (32 - shift)); +} + +static inline uint32_t +cpu_to_be32(const uint32_t hl) +{ +#if WORDS_BIGENDIAN + return hl; +#elif __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 2) + return __builtin_bswap32(hl); +#else + /* GCC usually transforms this into a bswap insn */ + return ((hl & 0xff000000) >> 24) | + ((hl & 0x00ff0000) >> 8) | + ((hl & 0x0000ff00) << 8) | + ( hl << 24); +#endif +} + +static inline void +cpu_to_be32_array(uint32_t *dest, const uint32_t *src, unsigned wordcnt) +{ + while (wordcnt--) + *dest++ = cpu_to_be32(*src++); +} + +static inline uint64_t +cpu_to_be64(const uint64_t hll) +{ +#if WORDS_BIGENDIAN + return hll; +#elif __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 2) + return __builtin_bswap64(hll); +#else + return ((uint64_t)cpu_to_be32(hll & 0xffffffff) << 32LL) | cpu_to_be32(hll >> 32); +#endif +} + + +void hs_cryptohash_sha1_init(struct sha1_ctx *ctx) { - memset(ctx, 0, sizeof(*ctx)); + memset(ctx, 0, SHA1_CTX_SIZE); - ctx->h[0] = 0x67452301; - ctx->h[1] = 0xefcdab89; - ctx->h[2] = 0x98badcfe; - ctx->h[3] = 0x10325476; - ctx->h[4] = 0xc3d2e1f0; + ctx->h[0] = 0x67452301; + ctx->h[1] = 0xefcdab89; + ctx->h[2] = 0x98badcfe; + ctx->h[3] = 0x10325476; + ctx->h[4] = 0xc3d2e1f0; } #define f1(x, y, z) (z ^ (x & (y ^ z))) @@ -50,165 +104,172 @@ #define K4 0xca62c1d6 #define R(a, b, c, d, e, f, k, w) \ - e += rol32(a, 5) + f(b, c, d) + k + w; b = rol32(b, 30) + e += rol32(a, 5) + f(b, c, d) + k + w; b = rol32(b, 30) #define M(i) (w[i & 0x0f] = rol32(w[i & 0x0f] ^ w[(i - 14) & 0x0f] \ ^ w[(i - 8) & 0x0f] ^ w[(i - 3) & 0x0f], 1)) -static inline void -sha1_do_chunk(struct sha1_ctx *ctx, uint32_t *buf) +static void +sha1_do_chunk_aligned(struct sha1_ctx *ctx, uint32_t w[]) { - uint32_t a, b, c, d, e; - uint32_t w[16]; -#define CPY(i) w[i] = be32_to_cpu(buf[i]) - CPY(0); CPY(1); CPY(2); CPY(3); CPY(4); CPY(5); CPY(6); CPY(7); - CPY(8); CPY(9); CPY(10); CPY(11); CPY(12); CPY(13); CPY(14); CPY(15); -#undef CPY - - a = ctx->h[0]; b = ctx->h[1]; c = ctx->h[2]; d = ctx->h[3]; e = ctx->h[4]; + uint32_t a = ctx->h[0]; + uint32_t b = ctx->h[1]; + uint32_t c = ctx->h[2]; + uint32_t d = ctx->h[3]; + uint32_t e = ctx->h[4]; - R(a, b, c, d, e, f1, K1, w[0]); - R(e, a, b, c, d, f1, K1, w[1]); - R(d, e, a, b, c, f1, K1, w[2]); - R(c, d, e, a, b, f1, K1, w[3]); - R(b, c, d, e, a, f1, K1, w[4]); - R(a, b, c, d, e, f1, K1, w[5]); - R(e, a, b, c, d, f1, K1, w[6]); - R(d, e, a, b, c, f1, K1, w[7]); - R(c, d, e, a, b, f1, K1, w[8]); - R(b, c, d, e, a, f1, K1, w[9]); - R(a, b, c, d, e, f1, K1, w[10]); - R(e, a, b, c, d, f1, K1, w[11]); - R(d, e, a, b, c, f1, K1, w[12]); - R(c, d, e, a, b, f1, K1, w[13]); - R(b, c, d, e, a, f1, K1, w[14]); - R(a, b, c, d, e, f1, K1, w[15]); - R(e, a, b, c, d, f1, K1, M(16)); - R(d, e, a, b, c, f1, K1, M(17)); - R(c, d, e, a, b, f1, K1, M(18)); - R(b, c, d, e, a, f1, K1, M(19)); + R(a, b, c, d, e, f1, K1, w[0]); + R(e, a, b, c, d, f1, K1, w[1]); + R(d, e, a, b, c, f1, K1, w[2]); + R(c, d, e, a, b, f1, K1, w[3]); + R(b, c, d, e, a, f1, K1, w[4]); + R(a, b, c, d, e, f1, K1, w[5]); + R(e, a, b, c, d, f1, K1, w[6]); + R(d, e, a, b, c, f1, K1, w[7]); + R(c, d, e, a, b, f1, K1, w[8]); + R(b, c, d, e, a, f1, K1, w[9]); + R(a, b, c, d, e, f1, K1, w[10]); + R(e, a, b, c, d, f1, K1, w[11]); + R(d, e, a, b, c, f1, K1, w[12]); + R(c, d, e, a, b, f1, K1, w[13]); + R(b, c, d, e, a, f1, K1, w[14]); + R(a, b, c, d, e, f1, K1, w[15]); + R(e, a, b, c, d, f1, K1, M(16)); + R(d, e, a, b, c, f1, K1, M(17)); + R(c, d, e, a, b, f1, K1, M(18)); + R(b, c, d, e, a, f1, K1, M(19)); - R(a, b, c, d, e, f2, K2, M(20)); - R(e, a, b, c, d, f2, K2, M(21)); - R(d, e, a, b, c, f2, K2, M(22)); - R(c, d, e, a, b, f2, K2, M(23)); - R(b, c, d, e, a, f2, K2, M(24)); - R(a, b, c, d, e, f2, K2, M(25)); - R(e, a, b, c, d, f2, K2, M(26)); - R(d, e, a, b, c, f2, K2, M(27)); - R(c, d, e, a, b, f2, K2, M(28)); - R(b, c, d, e, a, f2, K2, M(29)); - R(a, b, c, d, e, f2, K2, M(30)); - R(e, a, b, c, d, f2, K2, M(31)); - R(d, e, a, b, c, f2, K2, M(32)); - R(c, d, e, a, b, f2, K2, M(33)); - R(b, c, d, e, a, f2, K2, M(34)); - R(a, b, c, d, e, f2, K2, M(35)); - R(e, a, b, c, d, f2, K2, M(36)); - R(d, e, a, b, c, f2, K2, M(37)); - R(c, d, e, a, b, f2, K2, M(38)); - R(b, c, d, e, a, f2, K2, M(39)); + R(a, b, c, d, e, f2, K2, M(20)); + R(e, a, b, c, d, f2, K2, M(21)); + R(d, e, a, b, c, f2, K2, M(22)); + R(c, d, e, a, b, f2, K2, M(23)); + R(b, c, d, e, a, f2, K2, M(24)); + R(a, b, c, d, e, f2, K2, M(25)); + R(e, a, b, c, d, f2, K2, M(26)); + R(d, e, a, b, c, f2, K2, M(27)); + R(c, d, e, a, b, f2, K2, M(28)); + R(b, c, d, e, a, f2, K2, M(29)); + R(a, b, c, d, e, f2, K2, M(30)); + R(e, a, b, c, d, f2, K2, M(31)); + R(d, e, a, b, c, f2, K2, M(32)); + R(c, d, e, a, b, f2, K2, M(33)); + R(b, c, d, e, a, f2, K2, M(34)); + R(a, b, c, d, e, f2, K2, M(35)); + R(e, a, b, c, d, f2, K2, M(36)); + R(d, e, a, b, c, f2, K2, M(37)); + R(c, d, e, a, b, f2, K2, M(38)); + R(b, c, d, e, a, f2, K2, M(39)); - R(a, b, c, d, e, f3, K3, M(40)); - R(e, a, b, c, d, f3, K3, M(41)); - R(d, e, a, b, c, f3, K3, M(42)); - R(c, d, e, a, b, f3, K3, M(43)); - R(b, c, d, e, a, f3, K3, M(44)); - R(a, b, c, d, e, f3, K3, M(45)); - R(e, a, b, c, d, f3, K3, M(46)); - R(d, e, a, b, c, f3, K3, M(47)); - R(c, d, e, a, b, f3, K3, M(48)); - R(b, c, d, e, a, f3, K3, M(49)); - R(a, b, c, d, e, f3, K3, M(50)); - R(e, a, b, c, d, f3, K3, M(51)); - R(d, e, a, b, c, f3, K3, M(52)); - R(c, d, e, a, b, f3, K3, M(53)); - R(b, c, d, e, a, f3, K3, M(54)); - R(a, b, c, d, e, f3, K3, M(55)); - R(e, a, b, c, d, f3, K3, M(56)); - R(d, e, a, b, c, f3, K3, M(57)); - R(c, d, e, a, b, f3, K3, M(58)); - R(b, c, d, e, a, f3, K3, M(59)); + R(a, b, c, d, e, f3, K3, M(40)); + R(e, a, b, c, d, f3, K3, M(41)); + R(d, e, a, b, c, f3, K3, M(42)); + R(c, d, e, a, b, f3, K3, M(43)); + R(b, c, d, e, a, f3, K3, M(44)); + R(a, b, c, d, e, f3, K3, M(45)); + R(e, a, b, c, d, f3, K3, M(46)); + R(d, e, a, b, c, f3, K3, M(47)); + R(c, d, e, a, b, f3, K3, M(48)); + R(b, c, d, e, a, f3, K3, M(49)); + R(a, b, c, d, e, f3, K3, M(50)); + R(e, a, b, c, d, f3, K3, M(51)); + R(d, e, a, b, c, f3, K3, M(52)); + R(c, d, e, a, b, f3, K3, M(53)); + R(b, c, d, e, a, f3, K3, M(54)); + R(a, b, c, d, e, f3, K3, M(55)); + R(e, a, b, c, d, f3, K3, M(56)); + R(d, e, a, b, c, f3, K3, M(57)); + R(c, d, e, a, b, f3, K3, M(58)); + R(b, c, d, e, a, f3, K3, M(59)); - R(a, b, c, d, e, f4, K4, M(60)); - R(e, a, b, c, d, f4, K4, M(61)); - R(d, e, a, b, c, f4, K4, M(62)); - R(c, d, e, a, b, f4, K4, M(63)); - R(b, c, d, e, a, f4, K4, M(64)); - R(a, b, c, d, e, f4, K4, M(65)); - R(e, a, b, c, d, f4, K4, M(66)); - R(d, e, a, b, c, f4, K4, M(67)); - R(c, d, e, a, b, f4, K4, M(68)); - R(b, c, d, e, a, f4, K4, M(69)); - R(a, b, c, d, e, f4, K4, M(70)); - R(e, a, b, c, d, f4, K4, M(71)); - R(d, e, a, b, c, f4, K4, M(72)); - R(c, d, e, a, b, f4, K4, M(73)); - R(b, c, d, e, a, f4, K4, M(74)); - R(a, b, c, d, e, f4, K4, M(75)); - R(e, a, b, c, d, f4, K4, M(76)); - R(d, e, a, b, c, f4, K4, M(77)); - R(c, d, e, a, b, f4, K4, M(78)); - R(b, c, d, e, a, f4, K4, M(79)); + R(a, b, c, d, e, f4, K4, M(60)); + R(e, a, b, c, d, f4, K4, M(61)); + R(d, e, a, b, c, f4, K4, M(62)); + R(c, d, e, a, b, f4, K4, M(63)); + R(b, c, d, e, a, f4, K4, M(64)); + R(a, b, c, d, e, f4, K4, M(65)); + R(e, a, b, c, d, f4, K4, M(66)); + R(d, e, a, b, c, f4, K4, M(67)); + R(c, d, e, a, b, f4, K4, M(68)); + R(b, c, d, e, a, f4, K4, M(69)); + R(a, b, c, d, e, f4, K4, M(70)); + R(e, a, b, c, d, f4, K4, M(71)); + R(d, e, a, b, c, f4, K4, M(72)); + R(c, d, e, a, b, f4, K4, M(73)); + R(b, c, d, e, a, f4, K4, M(74)); + R(a, b, c, d, e, f4, K4, M(75)); + R(e, a, b, c, d, f4, K4, M(76)); + R(d, e, a, b, c, f4, K4, M(77)); + R(c, d, e, a, b, f4, K4, M(78)); + R(b, c, d, e, a, f4, K4, M(79)); - ctx->h[0] += a; - ctx->h[1] += b; - ctx->h[2] += c; - ctx->h[3] += d; - ctx->h[4] += e; + ctx->h[0] += a; + ctx->h[1] += b; + ctx->h[2] += c; + ctx->h[3] += d; + ctx->h[4] += e; } -void -hs_cryptohash_sha1_update(struct sha1_ctx *ctx, uint8_t *data, uint32_t len) +static void +sha1_do_chunk(struct sha1_ctx *ctx, const uint8_t buf[]) { - uint32_t index, to_fill; + uint32_t w[16]; + if (ptr_uint32_aligned(buf)) { /* aligned buf */ + cpu_to_be32_array(w, (const uint32_t *)buf, 16); + } else { /* unaligned buf */ + memcpy(w, buf, 64); +#if !WORDS_BIGENDIAN + cpu_to_be32_array(w, w, 16); +#endif + } + sha1_do_chunk_aligned(ctx, w); +} - index = (uint32_t) (ctx->sz & 0x3f); - to_fill = 64 - index; +void +hs_cryptohash_sha1_update(struct sha1_ctx *ctx, const uint8_t *data, size_t len) +{ + size_t index = ctx->sz & 0x3f; + const size_t to_fill = 64 - index; - ctx->sz += len; + ctx->sz += len; - /* process partial buffer if there's enough data to make a block */ - if (index && len >= to_fill) { - memcpy(ctx->buf + index, data, to_fill); - sha1_do_chunk(ctx, (uint32_t *) ctx->buf); - len -= to_fill; - data += to_fill; - index = 0; - } + /* process partial buffer if there's enough data to make a block */ + if (index && len >= to_fill) { + memcpy(ctx->buf + index, data, to_fill); + sha1_do_chunk(ctx, ctx->buf); + /* memset(ctx->buf, 0, 64); */ + len -= to_fill; + data += to_fill; + index = 0; + } - /* process as much 64-block as possible */ - for (; len >= 64; len -= 64, data += 64) - sha1_do_chunk(ctx, (uint32_t *) data); + /* process as many 64-blocks as possible */ + while (len >= 64) { + sha1_do_chunk(ctx, data); + len -= 64; + data += 64; + } - /* append data into buf */ - if (len) - memcpy(ctx->buf + index, data, len); + /* append data into buf */ + if (len) + memcpy(ctx->buf + index, data, len); } void hs_cryptohash_sha1_finalize(struct sha1_ctx *ctx, uint8_t *out) { - static uint8_t padding[64] = { 0x80, }; - uint64_t bits; - uint32_t index, padlen; - uint32_t *p = (uint32_t *) out; + static uint8_t padding[64] = { 0x80, }; - /* add padding and update data with it */ - bits = cpu_to_be64(ctx->sz << 3); + /* add padding and update data with it */ + uint64_t bits = cpu_to_be64(ctx->sz << 3); - /* pad out to 56 */ - index = (uint32_t) (ctx->sz & 0x3f); - padlen = (index < 56) ? (56 - index) : ((64 + 56) - index); - hs_cryptohash_sha1_update(ctx, padding, padlen); + /* pad out to 56 */ + const size_t index = ctx->sz & 0x3f; + const size_t padlen = (index < 56) ? (56 - index) : ((64 + 56) - index); + hs_cryptohash_sha1_update(ctx, padding, padlen); - /* append length */ - hs_cryptohash_sha1_update(ctx, (uint8_t *) &bits, sizeof(bits)); + /* append length */ + hs_cryptohash_sha1_update(ctx, (uint8_t *) &bits, sizeof(bits)); - /* output hash */ - p[0] = cpu_to_be32(ctx->h[0]); - p[1] = cpu_to_be32(ctx->h[1]); - p[2] = cpu_to_be32(ctx->h[2]); - p[3] = cpu_to_be32(ctx->h[3]); - p[4] = cpu_to_be32(ctx->h[4]); + /* output hash */ + cpu_to_be32_array((uint32_t *) out, ctx->h, 5); } diff --git a/cbits/sha1.h b/cbits/sha1.h --- a/cbits/sha1.h +++ b/cbits/sha1.h @@ -27,19 +27,20 @@ #define CRYPTOHASH_SHA1_H #include +#include struct sha1_ctx { - uint64_t sz; - uint8_t buf[64]; - uint32_t h[5]; + uint64_t sz; + uint8_t buf[64]; + uint32_t h[5]; }; #define SHA1_DIGEST_SIZE 20 -#define SHA1_CTX_SIZE (sizeof(struct sha1_ctx)) +#define SHA1_CTX_SIZE 92 /* NB: no 64-bit padding */ void hs_cryptohash_sha1_init(struct sha1_ctx *ctx); -void hs_cryptohash_sha1_update(struct sha1_ctx *ctx, uint8_t *data, uint32_t len); +void hs_cryptohash_sha1_update(struct sha1_ctx *ctx, const uint8_t *data, size_t len); void hs_cryptohash_sha1_finalize(struct sha1_ctx *ctx, uint8_t *out); #endif diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,12 @@ +## 0.11.7.2 + + - switch to 'safe' FFI for calls where overhead becomes neglible + - removed inline assembly in favour of portable C constructs + - fix 32bit length overflow bug in `hash` function + - fix inaccurate context-size + - add context-size verification to incremental API operations + - fix unaligned memory-accesses + ## 0.11.7.1 - first version forked off `cryptohash-0.11.7` release diff --git a/cryptohash-sha1.cabal b/cryptohash-sha1.cabal --- a/cryptohash-sha1.cabal +++ b/cryptohash-sha1.cabal @@ -1,5 +1,5 @@ name: cryptohash-sha1 -version: 0.11.7.1 +version: 0.11.7.2 description: A practical incremental and one-pass, pure API to the @@ -31,8 +31,7 @@ , GHC == 7.10.3 , GHC == 8.0.1 -extra-source-files: cbits/bitfn.h - cbits/sha1.h +extra-source-files: cbits/sha1.h changelog.md source-repository head @@ -44,30 +43,34 @@ build-depends: base >= 4.5 && < 4.10 , bytestring >= 0.9.2 && < 0.11 + hs-source-dirs: src exposed-modules: Crypto.Hash.SHA1 ghc-options: -Wall -fno-cse -O2 - cc-options: -O3 + cc-options: -Wall -O3 c-sources: cbits/sha1.c include-dirs: cbits test-suite test-sha1 default-language: Haskell2010 + other-extensions: OverloadedStrings type: exitcode-stdio-1.0 - hs-source-dirs: Tests - main-is: KAT.hs + hs-source-dirs: src-tests + main-is: test-sha1.hs build-depends: cryptohash-sha1 , base , bytestring - , tasty == 0.11.* - , tasty-quickcheck == 0.8.* - , tasty-hunit == 0.9.* + , base16-bytestring >= 0.1.1 && < 0.2 + , SHA >= 1.6.4 && < 1.7 + , tasty == 0.11.* + , tasty-quickcheck == 0.8.* + , tasty-hunit == 0.9.* benchmark bench-sha1 default-language: Haskell2010 type: exitcode-stdio-1.0 - main-is: Bench.hs - hs-source-dirs: Bench + main-is: bench-sha1.hs + hs-source-dirs: src-bench build-depends: cryptohash-sha1 , base , bytestring diff --git a/src-bench/bench-sha1.hs b/src-bench/bench-sha1.hs new file mode 100644 --- /dev/null +++ b/src-bench/bench-sha1.hs @@ -0,0 +1,36 @@ +import Criterion.Main +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +benchSize :: Int -> Benchmark +benchSize sz = bs `seq` bench msg (whnf SHA1.hash bs) + where + bs = B.replicate sz 0 + msg = "bs-" ++ show sz + +main :: IO () +main = do + let lbs64x256 = L.fromChunks $ replicate 4 (B.replicate 64 0) + lbs64x4096 = L.fromChunks $ replicate 64 (B.replicate 64 0) + defaultMain + [ bgroup "cryptohash-sha1" + [ benchSize 0 + , benchSize 8 + , benchSize 32 + , benchSize 64 + , benchSize 128 + , benchSize 256 + , benchSize 1024 + , benchSize 4096 + , benchSize 8192 + , benchSize 16384 + , benchSize (128*1024) + , benchSize (1024*1024) + , benchSize (2*1024*1024) + , benchSize (4*1024*1024) + + , L.length lbs64x256 `seq` bench "lbs64x256" (whnf SHA1.hashlazy lbs64x256) + , L.length lbs64x4096 `seq` bench "lbs64x4096" (whnf SHA1.hashlazy lbs64x4096) + ] + ] diff --git a/src-tests/test-sha1.hs b/src-tests/test-sha1.hs new file mode 100644 --- /dev/null +++ b/src-tests/test-sha1.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Base16 as B16 + +-- reference implementation +import qualified Data.Digest.Pure.SHA as REF + +-- implementation under test +import qualified Crypto.Hash.SHA1 as IUT + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck as QC + +vectors :: [ByteString] +vectors = + [ "" + , "The quick brown fox jumps over the lazy dog" + , "The quick brown fox jumps over the lazy cog" + , "abc" + , "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" + , "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" + , B.replicate 1000000 0x61 + ] + +answers :: [ByteString] +answers = map (B.filter (/= 0x20)) + [ "da39a3ee 5e6b4b0d 3255bfef 95601890 afd80709" + , "2fd4e1c6 7a2d28fc ed849ee1 bb76e739 1b93eb12" + , "de9f2c7f d25e1b3a fad3e85a 0bd17d9b 100db4b3" + , "a9993e36 4706816a ba3e2571 7850c26c 9cd0d89d" + , "84983e44 1c3bd26e baae4aa1 f95129e5 e54670f1" + , "a49b2446 a02c645b f419f995 b6709125 3a04a259" + , "34aa973c d4c4daa4 f61eeb2b dbad2731 6534016f" + ] + +ansXLTest :: ByteString +ansXLTest = B.filter (/= 0x20) + "7789f0c9 ef7bfc40 d9331114 3dfbe69e 2017f592" + +katTests :: [TestTree] +katTests + | length vectors == length answers = map makeTest (zip3 [1::Int ..] vectors answers) ++ [xltest] + | otherwise = error "vectors/answers length mismatch" + where + makeTest (i, v, r) = testGroup ("vec"++show i) $ + [ testCase "one-pass" (r @=? runTest v) + , testCase "inc-1" (r @=? runTestInc 1 v) + , testCase "inc-2" (r @=? runTestInc 2 v) + , testCase "inc-3" (r @=? runTestInc 3 v) + , testCase "inc-4" (r @=? runTestInc 4 v) + , testCase "inc-5" (r @=? runTestInc 5 v) + , testCase "inc-7" (r @=? runTestInc 7 v) + , testCase "inc-8" (r @=? runTestInc 8 v) + , testCase "inc-9" (r @=? runTestInc 9 v) + , testCase "inc-16" (r @=? runTestInc 16 v) + , testCase "lazy-1" (r @=? runTestLazy 1 v) + , testCase "lazy-2" (r @=? runTestLazy 2 v) + , testCase "lazy-7" (r @=? runTestLazy 7 v) + , testCase "lazy-8" (r @=? runTestLazy 8 v) + , testCase "lazy-16" (r @=? runTestLazy 16 v) + ] ++ + [ testCase "lazy-63u" (r @=? runTestLazyU 63 v) | B.length v > 63 ] ++ + [ testCase "lazy-65u" (r @=? runTestLazyU 65 v) | B.length v > 65 ] ++ + [ testCase "lazy-97u" (r @=? runTestLazyU 97 v) | B.length v > 97 ] ++ + [ testCase "lazy-131u" (r @=? runTestLazyU 131 v) | B.length v > 131 ] + + runTest :: ByteString -> ByteString + runTest = B16.encode . IUT.hash + + runTestInc :: Int -> ByteString -> ByteString + runTestInc i = B16.encode . IUT.finalize . myfoldl' IUT.update IUT.init . splitB i + + runTestLazy :: Int -> ByteString -> ByteString + runTestLazy i = B16.encode . IUT.hashlazy . BL.fromChunks . splitB i + + -- force unaligned md5-blocks + runTestLazyU :: Int -> ByteString -> ByteString + runTestLazyU i = B16.encode . IUT.hashlazy . BL.fromChunks . map B.copy . splitB i + + ---- + + xltest = testGroup "XL-vec" + [ testCase "inc" (ansXLTest @=? (B16.encode . IUT.hashlazy) vecXL) ] + where + vecXL = BL.fromChunks (replicate 16777216 "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmno") + + splitB :: Int -> ByteString -> [ByteString] + splitB l b + | B.length b > l = b1 : splitB l b2 + | otherwise = [b] + where + (b1, b2) = B.splitAt l b + + +-- define own 'foldl' here to avoid RULE rewriting to 'hashlazy' +myfoldl' :: (b -> a -> b) -> b -> [a] -> b +myfoldl' f z0 xs0 = lgo z0 xs0 + where + lgo z [] = z + lgo z (x:xs) = let z' = f z x + in z' `seq` lgo z' xs + +newtype RandBS = RandBS { unRandBS :: ByteString } +newtype RandLBS = RandLBS BL.ByteString + +instance Arbitrary RandBS where + arbitrary = fmap (RandBS . B.pack) arbitrary + shrink (RandBS x) = fmap RandBS (go x) + where + go bs = zipWith B.append (B.inits bs) (tail $ B.tails bs) + +instance Show RandBS where + show (RandBS x) = "RandBS {len=" ++ show (B.length x)++"}" + +instance Arbitrary RandLBS where + arbitrary = fmap (RandLBS . BL.fromChunks . map unRandBS) arbitrary + +instance Show RandLBS where + show (RandLBS x) = "RandLBS {len=" ++ show (BL.length x) ++ ", chunks=" ++ show (length $ BL.toChunks x)++"}" + + +refImplTests :: [TestTree] +refImplTests = + [ testProperty "hash" prop_hash + , testProperty "hashlazy" prop_hashlazy + ] + where + prop_hash (RandBS bs) + = ref_hash bs == IUT.hash bs + + prop_hashlazy (RandLBS bs) + = ref_hashlazy bs == IUT.hashlazy bs + + ref_hash :: ByteString -> ByteString + ref_hash = toStrict . REF.bytestringDigest . REF.sha1 . fromStrict + + ref_hashlazy :: BL.ByteString -> ByteString + ref_hashlazy = toStrict . REF.bytestringDigest . REF.sha1 + + -- toStrict/fromStrict only available with bytestring-0.10 and later + toStrict = B.concat . BL.toChunks + fromStrict = BL.fromChunks . (:[]) + +main :: IO () +main = defaultMain $ testGroup "cryptohash-sha1" + [ testGroup "KATs" katTests + , testGroup "REF" refImplTests + ] diff --git a/src/Crypto/Hash/SHA1.hs b/src/Crypto/Hash/SHA1.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Hash/SHA1.hs @@ -0,0 +1,214 @@ +-- | +-- Module : Crypto.Hash.SHA1 +-- License : BSD-style +-- Maintainer : Herbert Valerio Riedel +-- Stability : stable +-- Portability : unknown +-- +-- A module containing bindings +-- +module Crypto.Hash.SHA1 + ( + + -- * Incremental API + -- + -- | This API is based on 4 different functions, similar to the + -- lowlevel operations of a typical hash: + -- + -- - 'init': create a new hash context + -- - 'update': update non-destructively a new hash context with a strict bytestring + -- - 'updates': same as update, except that it takes a list of strict bytestrings + -- - 'finalize': finalize the context and returns a digest bytestring. + -- + -- all those operations are completely pure, and instead of + -- changing the context as usual in others language, it + -- re-allocates a new context each time. + -- + -- Example: + -- + -- > import qualified Data.ByteString + -- > import qualified Crypto.Hash.SHA1 as SHA1 + -- > + -- > main = print digest + -- > where + -- > digest = SHA1.finalize ctx + -- > ctx = foldl SHA1.update ctx0 (map Data.ByteString.pack [ [1,2,3], [4,5,6] ]) + -- > ctx0 = SHA1.init + + Ctx(..) + , init -- :: Ctx + , update -- :: Ctx -> ByteString -> Ctx + , updates -- :: Ctx -> [ByteString] -> Ctx + , finalize -- :: Ctx -> ByteString + + -- * Single Pass API + -- + -- | This API use the incremental API under the hood to provide + -- the common all-in-one operations to create digests out of a + -- 'ByteString' and lazy 'L.ByteString'. + -- + -- - 'hash': create a digest ('init' + 'update' + 'finalize') from a strict 'ByteString' + -- - 'hashlazy': create a digest ('init' + 'update' + 'finalize') from a lazy 'L.ByteString' + -- + -- Example: + -- + -- > import qualified Data.ByteString + -- > import qualified Crypto.Hash.SHA1 as SHA1 + -- > + -- > main = print $ SHA1.hash (Data.ByteString.pack [0..255]) + -- + -- __NOTE__: The returned digest is a binary 'ByteString'. For + -- converting to a base16/hex encoded digest the + -- + -- package is recommended. + + , hash -- :: ByteString -> ByteString + , hashlazy -- :: ByteString -> ByteString + ) where + +import Prelude hiding (init) +import Foreign.C.Types +import Foreign.Ptr +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Marshal.Alloc +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as B +import Data.ByteString (ByteString) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.ByteString.Internal (create, toForeignPtr, memcpy) +import Data.Word +import System.IO.Unsafe (unsafeDupablePerformIO) + +-- | perform IO for hashes that do allocation and ffi. +-- unsafeDupablePerformIO is used when possible as the +-- computation is pure and the output is directly linked +-- to the input. we also do not modify anything after it has +-- been returned to the user. +unsafeDoIO :: IO a -> a +unsafeDoIO = unsafeDupablePerformIO + +-- | SHA-1 Context +-- +-- The context data is exactly 92 bytes long, however +-- the data in the context is stored in host-endianness. +-- +-- The context data is made up of +-- +-- * a 'Word64' representing the number of bytes already feed to hash algorithm so far, +-- +-- * a 64-element 'Word8' buffer holding partial input-chunks, and finally +-- +-- * a 5-element 'Word32' array holding the current work-in-progress digest-value. +-- +-- Consequently, a SHA-1 digest as produced by 'hash', 'hashlazy', or 'finalize' is 20 bytes long. +newtype Ctx = Ctx ByteString + +{-# INLINE digestSize #-} +digestSize :: Int +digestSize = 20 + +{-# INLINE sizeCtx #-} +sizeCtx :: Int +sizeCtx = 92 + +{-# RULES "digestSize" B.length (finalize init) = digestSize #-} +{-# RULES "hash" forall b. finalize (update init b) = hash b #-} +{-# RULES "hash.list1" forall b. finalize (updates init [b]) = hash b #-} +{-# RULES "hashmany" forall b. finalize (foldl update init b) = hashlazy (L.fromChunks b) #-} +{-# RULES "hashlazy" forall b. finalize (foldl update init $ L.toChunks b) = hashlazy b #-} + +{-# INLINE withByteStringPtr #-} +withByteStringPtr :: ByteString -> (Ptr Word8 -> IO a) -> IO a +withByteStringPtr b f = + withForeignPtr fptr $ \ptr -> f (ptr `plusPtr` off) + where (fptr, off, _) = toForeignPtr b + +copyCtx :: Ptr Ctx -> Ptr Ctx -> IO () +copyCtx dst src = memcpy (castPtr dst) (castPtr src) (fromIntegral sizeCtx) + +withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx +withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx + where + createCtx = create sizeCtx $ \dstPtr -> + withByteStringPtr ctxB $ \srcPtr -> do + copyCtx (castPtr dstPtr) (castPtr srcPtr) + f (castPtr dstPtr) + +withCtxThrow :: Ctx -> (Ptr Ctx -> IO a) -> IO a +withCtxThrow (Ctx ctxB) f = + allocaBytes sizeCtx $ \dstPtr -> + withByteStringPtr ctxB $ \srcPtr -> do + copyCtx (castPtr dstPtr) (castPtr srcPtr) + f (castPtr dstPtr) + +withCtxNew :: (Ptr Ctx -> IO ()) -> IO Ctx +withCtxNew f = Ctx `fmap` create sizeCtx (f . castPtr) + +withCtxNewThrow :: (Ptr Ctx -> IO a) -> IO a +withCtxNewThrow f = allocaBytes sizeCtx (f . castPtr) + +foreign import ccall unsafe "sha1.h hs_cryptohash_sha1_init" + c_sha1_init :: Ptr Ctx -> IO () + +foreign import ccall unsafe "sha1.h hs_cryptohash_sha1_update" + c_sha1_update_unsafe :: Ptr Ctx -> Ptr Word8 -> CSize -> IO () + +foreign import ccall safe "sha1.h hs_cryptohash_sha1_update" + c_sha1_update_safe :: Ptr Ctx -> Ptr Word8 -> CSize -> IO () + +-- 'safe' call overhead neglible for 8KiB and more +c_sha1_update :: Ptr Ctx -> Ptr Word8 -> CSize -> IO () +c_sha1_update pctx pbuf sz + | sz < 8192 = c_sha1_update_unsafe pctx pbuf sz + | otherwise = c_sha1_update_safe pctx pbuf sz + +foreign import ccall unsafe "sha1.h hs_cryptohash_sha1_finalize" + c_sha1_finalize :: Ptr Ctx -> Ptr Word8 -> IO () + +updateInternalIO :: Ptr Ctx -> ByteString -> IO () +updateInternalIO ptr d = + unsafeUseAsCStringLen d (\(cs, len) -> c_sha1_update ptr (castPtr cs) (fromIntegral len)) + +finalizeInternalIO :: Ptr Ctx -> IO ByteString +finalizeInternalIO ptr = create digestSize (c_sha1_finalize ptr) + +{-# NOINLINE init #-} +-- | create a new hash context +init :: Ctx +init = unsafeDoIO $ withCtxNew $ c_sha1_init + +validCtx :: Ctx -> Bool +validCtx (Ctx b) = B.length b == sizeCtx + +{-# NOINLINE update #-} +-- | update a context with a bytestring +update :: Ctx -> ByteString -> Ctx +update ctx d + | validCtx ctx = unsafeDoIO $ withCtxCopy ctx $ \ptr -> updateInternalIO ptr d + | otherwise = error "SHA1.update: invalid Ctx" + +{-# NOINLINE updates #-} +-- | updates a context with multiple bytestrings +updates :: Ctx -> [ByteString] -> Ctx +updates ctx d + | validCtx ctx = unsafeDoIO $ withCtxCopy ctx $ \ptr -> mapM_ (updateInternalIO ptr) d + | otherwise = error "SHA1.updates: invalid Ctx" + +{-# NOINLINE finalize #-} +-- | finalize the context into a digest bytestring (16 bytes) +finalize :: Ctx -> ByteString +finalize ctx + | validCtx ctx = unsafeDoIO $ withCtxThrow ctx finalizeInternalIO + | otherwise = error "SHA1.finalize: invalid Ctx" + +{-# NOINLINE hash #-} +-- | hash a strict bytestring into a digest bytestring (16 bytes) +hash :: ByteString -> ByteString +hash d = unsafeDoIO $ withCtxNewThrow $ \ptr -> do + c_sha1_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr + +{-# NOINLINE hashlazy #-} +-- | hash a lazy bytestring into a digest bytestring (16 bytes) +hashlazy :: L.ByteString -> ByteString +hashlazy l = unsafeDoIO $ withCtxNewThrow $ \ptr -> do + c_sha1_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr