cryptohash-md5 0.11.7.1 → 0.11.7.2
raw patch · 12 files changed
+628/−735 lines, 12 filesdep +base16-bytestringdep +pureMD5dep ~basedep ~bytestringPVP ok
version bump matches the API change (PVP)
Dependencies added: base16-bytestring, pureMD5
Dependency ranges changed: base, bytestring
API changes (from Hackage documentation)
Files
- Bench/Bench.hs +0/−33
- Bench/BenchAPI.hs +0/−39
- Crypto/Hash/MD5.hs +0/−184
- Tests/KAT.hs +0/−92
- cbits/bitfn.h +0/−240
- cbits/md5.c +189/−123
- cbits/md5.h +3/−2
- changelog.md +12/−0
- cryptohash-md5.cabal +17/−22
- src-bench/bench-md5.hs +38/−0
- src-tests/test-md5.hs +154/−0
- src/Crypto/Hash/MD5.hs +215/−0
− Bench/Bench.hs
@@ -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.MD5 as MD5--hashmany (i,u,f) = f . foldl u i--allHashs =- [ ("MD5",MD5.hash, hashmany (MD5.init,MD5.update,MD5.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))- ]
− Bench/BenchAPI.hs
@@ -1,39 +0,0 @@-{-# LANGUAGE BangPatterns #-}-import Criterion.Main-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Crypto.Hash.MD5 as MD5--md5F = ( "MD5"- , MD5.hash- , MD5.finalize . MD5.update MD5.init- )--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])-- let (fname, fHash, fIncr) = md5F- let benchName ty z = fname ++ "." ++ ty -- ++ " " ++ show z- defaultMain- [ bgroup "hash-0b"- [ bench (benchName "hash" 0) $ whnf fHash B.empty- , bench (benchName "incr" 0) $ whnf fIncr B.empty- ]- , bgroup "hash-32b"- [ bench (benchName "hash" 32) $ whnf fHash bs32- , bench (benchName "incr" 32) $ whnf fIncr bs32- ]- , bgroup "hash-256b"- [ bench (benchName "hash" 256) $ whnf fHash bs256- , bench (benchName "incr" 256) $ whnf fIncr bs256- ]- , bgroup "hash-4Kb"- [ bench (benchName "hash" 4096) $ whnf fHash bs4096- , bench (benchName "incr" 4096) $ whnf fIncr bs4096- ]- ]
− Crypto/Hash/MD5.hs
@@ -1,184 +0,0 @@--- |--- Module : Crypto.Hash.MD5--- License : BSD-style--- Maintainer : Herbert Valerio Riedel <hvr@gnu.org>--- Stability : stable--- Portability : unknown------ A module containing <https://en.wikipedia.org/wiki/MD5 MD5> bindings----module Crypto.Hash.MD5- (-- -- * 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.MD5 as MD5- -- >- -- > main = print digest- -- > where- -- > digest = MD5.finalize ctx- -- > ctx = foldl MD5.update ctx0 (map Data.ByteString.pack [ [1,2,3], [4,5,6] ])- -- > ctx0 = MD5.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.MD5 as MD5- -- >- -- > main = print $ MD5.hash (Data.ByteString.pack [0..255])- --- -- __NOTE__: The returned digest is a binary 'ByteString'. For- -- converting to a base16/hex encoded digest the- -- <https://hackage.haskell.org/package/base16-bytestring base16-bytestring>- -- 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---- | MD5 Context-newtype Ctx = Ctx ByteString--{-# INLINE digestSize #-}-digestSize :: Int-digestSize = 16--{-# 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 "md5.h hs_cryptohash_md5_init"- c_md5_init :: Ptr Ctx -> IO ()--foreign import ccall unsafe "md5.h hs_cryptohash_md5_update"- c_md5_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO ()--foreign import ccall unsafe "md5.h hs_cryptohash_md5_finalize"- c_md5_finalize :: Ptr Ctx -> Ptr Word8 -> IO ()--updateInternalIO :: Ptr Ctx -> ByteString -> IO ()-updateInternalIO ptr d =- unsafeUseAsCStringLen d (\(cs, len) -> c_md5_update ptr (castPtr cs) (fromIntegral len))--finalizeInternalIO :: Ptr Ctx -> IO ByteString-finalizeInternalIO ptr = create digestSize (c_md5_finalize ptr)--{-# NOINLINE init #-}--- | init a context-init :: Ctx-init = unsafeDoIO $ withCtxNew $ c_md5_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_md5_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_md5_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr
− Tests/KAT.hs
@@ -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.MD5 as MD5--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--md5Hash = HashFct { fctHash = MD5.hash, fctInc = hashinc MD5.init MD5.update MD5.finalize }---results :: [ (String, HashFct, [String]) ]-results = [- ("MD5", md5Hash, [- "d41d8cd98f00b204e9800998ecf8427e",- "9e107d9d372bb6826bd81d3542a419d6",- "1055d3e698d289f2af8663725127bd4b" ])- ]--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- ]
− cbits/bitfn.h
@@ -1,240 +0,0 @@-/*- * Copyright (C) 2006-2009 Vincent Hanquez <vincent@snarc.org>- *- * 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 <stdint.h>--#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 <sys/endian.h>-#elif defined(__OpenBSD__) || defined(__SVR4)- # include <sys/types.h>-#elif defined(__APPLE__)- # include <machine/endian.h>-#elif defined( BSD ) && ( BSD >= 199103 )- # include <machine/endian.h>-#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 <sys/machine.h>-#else- # include <endian.h>-#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 */
cbits/md5.c view
@@ -23,161 +23,227 @@ * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ -#include <string.h>-#include <stdio.h>-#include "bitfn.h" #include "md5.h" +#include <assert.h>+#include <string.h>+#include <ghcautoconf.h>++#if defined(static_assert)+static_assert(sizeof(struct md5_ctx) == MD5_CTX_SIZE, "unexpected md5_ctx size");+#else+/* poor man's pre-C11 _Static_assert */+typedef char static_assertion__unexpected_md5_ctx_size[(sizeof(struct md5_ctx) == MD5_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_le32(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_le32_array(uint32_t *dest, const uint32_t *src, unsigned wordcnt)+{+ while (wordcnt--)+ *dest++ = cpu_to_le32(*src++);+}++static inline uint64_t+cpu_to_le64(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_le32(hll & 0xffffffff) << 32LL) | cpu_to_le32(hll >> 32);+#endif+}++ void hs_cryptohash_md5_init(struct md5_ctx *ctx) {- memset(ctx, 0, sizeof(*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;+ 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 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)+md5_do_chunk_aligned(struct md5_ctx *ctx, const uint32_t w[]) {- 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];+ uint32_t a = ctx->h[0];+ uint32_t b = ctx->h[1];+ uint32_t c = ctx->h[2];+ uint32_t 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(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(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(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);+ 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;+ ctx->h[0] += a;+ ctx->h[1] += b;+ ctx->h[2] += c;+ ctx->h[3] += d; } -void-hs_cryptohash_md5_update(struct md5_ctx *ctx, uint8_t *data, uint32_t len)+static void+md5_do_chunk(struct md5_ctx *ctx, const uint8_t buf[]) {- uint32_t index, to_fill;+ if (ptr_uint32_aligned(buf)) { /* aligned buf */+#if WORDS_BIGENDIAN+ uint32_t w[16]; cpu_to_le32_array(w, (const uint32_t *)buf, 16);+#else+ const uint32_t *w = (const uint32_t *)buf;+#endif+ md5_do_chunk_aligned(ctx, w);+ } else { /* unaligned buf */+ uint32_t w[16]; memcpy(w, buf, 64);+#if WORDS_BIGENDIAN+ cpu_to_le32_array(w, w, 16);+#endif+ md5_do_chunk_aligned(ctx, w);+ }+} - index = (uint32_t) (ctx->sz & 0x3f);- to_fill = 64 - index;+void+hs_cryptohash_md5_update(struct md5_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; - 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;- }+ if (index && len >= to_fill) {+ memcpy(ctx->buf + index, data, to_fill);+ md5_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)- md5_do_chunk(ctx, (uint32_t *) data);+ /* process as many 64-blocks as possible */+ while (len >= 64) {+ md5_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_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;+ static const uint8_t padding[64] = { 0x80, }; - /* add padding and update data with it */- bits = cpu_to_le64(ctx->sz << 3);+ /* add padding and update data with it */+ const uint64_t 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);- hs_cryptohash_md5_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_md5_update(ctx, padding, padlen); - /* append length */- hs_cryptohash_md5_update(ctx, (uint8_t *) &bits, sizeof(bits));+ /* append length */+ hs_cryptohash_md5_update(ctx, (const 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]);+ /* output hash */+ cpu_to_le32_array((uint32_t *) out, ctx->h, 4); }
cbits/md5.h view
@@ -27,6 +27,7 @@ #define CRYPTOHASH_MD5_H #include <stdint.h>+#include <stddef.h> struct md5_ctx {@@ -36,10 +37,10 @@ }; #define MD5_DIGEST_SIZE 16-#define MD5_CTX_SIZE sizeof(struct md5_ctx)+#define MD5_CTX_SIZE 88 void hs_cryptohash_md5_init(struct md5_ctx *ctx);-void hs_cryptohash_md5_update(struct md5_ctx *ctx, uint8_t *data, uint32_t len);+void hs_cryptohash_md5_update(struct md5_ctx *ctx, const uint8_t *data, size_t len); void hs_cryptohash_md5_finalize(struct md5_ctx *ctx, uint8_t *out); #endif
+ changelog.md view
@@ -0,0 +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
cryptohash-md5.cabal view
@@ -1,5 +1,5 @@ name: cryptohash-md5-version: 0.11.7.1+version: 0.11.7.2 description: A practical incremental and one-pass, pure API to the <https://en.wikipedia.org/wiki/MD5 MD5 hash algorithm>@@ -31,8 +31,8 @@ , GHC == 7.10.3 , GHC == 8.0.1 -extra-source-files: cbits/bitfn.h- cbits/md5.h+extra-source-files: cbits/md5.h+ changelog.md source-repository head type: git@@ -43,39 +43,34 @@ build-depends: base >= 4.5 && < 4.10 , bytestring >= 0.9.2 && < 0.11 + hs-source-dirs: src exposed-modules: Crypto.Hash.MD5 ghc-options: -Wall -fno-cse -O2- cc-options: -O3+ cc-options: -Wall -O3 c-sources: cbits/md5.c include-dirs: cbits -test-suite test-kat+test-suite test-md5 default-language: Haskell2010 type: exitcode-stdio-1.0- hs-source-dirs: Tests- main-is: KAT.hs+ hs-source-dirs: src-tests+ main-is: test-md5.hs+ ghc-options: -Wall -threaded build-depends: cryptohash-md5 , base , bytestring- , tasty == 0.11.*- , tasty-quickcheck == 0.8.*- , tasty-hunit == 0.9.* -benchmark bench-hashes- default-language: Haskell2010- type: exitcode-stdio-1.0- main-is: Bench.hs- hs-source-dirs: Bench- build-depends: cryptohash-md5- , base- , bytestring- , criterion == 1.1.*+ , base16-bytestring >= 0.1.1 && < 0.2+ , pureMD5 >= 2.1.3 && < 2.2+ , tasty == 0.11.*+ , tasty-quickcheck == 0.8.*+ , tasty-hunit == 0.9.* -benchmark bench-api+benchmark bench-md5 default-language: Haskell2010 type: exitcode-stdio-1.0- main-is: BenchAPI.hs- hs-source-dirs: Bench+ main-is: bench-md5.hs+ hs-source-dirs: src-bench build-depends: cryptohash-md5 , base , bytestring
+ src-bench/bench-md5.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE BangPatterns #-}++import Criterion.Main+import qualified Crypto.Hash.MD5 as MD5+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L++benchSize :: Int -> Benchmark+benchSize sz = bs `seq` bench msg (whnf MD5.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-md5"+ [ 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 MD5.hashlazy lbs64x256)+ , L.length lbs64x4096 `seq` bench "lbs64x4096" (whnf MD5.hashlazy lbs64x4096)+ ]+ ]
+ src-tests/test-md5.hs view
@@ -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.MD5 as REF++-- implementation under test+import qualified Crypto.Hash.MD5 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))+ [ "d41d8cd9 8f00b204 e9800998 ecf8427e"+ , "9e107d9d 372bb682 6bd81d35 42a419d6"+ , "1055d3e6 98d289f2 af866372 5127bd4b"+ , "90015098 3cd24fb0 d6963f7d 28e17f72"+ , "8215ef07 96a20bca aae116d3 876c664a"+ , "03dd8807 a93175fb 062dfb55 dc7d359c"+ , "7707d6ae 4e027c70 eea2a935 c2296f21"+ ]++ansXLTest :: ByteString+ansXLTest = B.filter (/= 0x20)+ "d3381391 69d50f55 526194c7 90ec0448"++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 = REF.md5DigestBytes . REF.md5 . fromStrict++ ref_hashlazy :: BL.ByteString -> ByteString+ ref_hashlazy = REF.md5DigestBytes . REF.md5++ -- toStrict/fromStrict only available with bytestring-0.10 and later+ fromStrict = BL.fromChunks . (:[])++++main :: IO ()+main = defaultMain $ testGroup "cryptohash-md5"+ [ testGroup "KATs" katTests+ , testGroup "REF" refImplTests+ ]
+ src/Crypto/Hash/MD5.hs view
@@ -0,0 +1,215 @@+-- |+-- Module : Crypto.Hash.MD5+-- License : BSD-style+-- Maintainer : Herbert Valerio Riedel <hvr@gnu.org>+-- Stability : stable+-- Portability : unknown+--+-- A module containing <https://en.wikipedia.org/wiki/MD5 MD5> bindings+--+module Crypto.Hash.MD5+ (++ -- * 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.MD5 as MD5+ -- >+ -- > main = print digest+ -- > where+ -- > digest = MD5.finalize ctx+ -- > ctx = foldl MD5.update ctx0 (map Data.ByteString.pack [ [1,2,3], [4,5,6] ])+ -- > ctx0 = MD5.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.MD5 as MD5+ -- >+ -- > main = print $ MD5.hash (Data.ByteString.pack [0..255])+ --+ -- __NOTE__: The returned digest is a binary 'ByteString'. For+ -- converting to a base16/hex encoded digest the+ -- <https://hackage.haskell.org/package/base16-bytestring base16-bytestring>+ -- 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++-- | MD5 Context+--+-- The context data is exactly 88 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 4-element 'Word32' array holding the current work-in-progress digest-value.+--+-- Consequently, a MD5 digest as produced by 'hash', 'hashlazy', or 'finalize' is 16 bytes long.+newtype Ctx = Ctx ByteString++-- keep this synchronised with cbits/md5.h+{-# INLINE digestSize #-}+digestSize :: Int+digestSize = 16++{-# INLINE sizeCtx #-}+sizeCtx :: Int+sizeCtx = 88++{-# 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 "md5.h hs_cryptohash_md5_init"+ c_md5_init :: Ptr Ctx -> IO ()++foreign import ccall unsafe "md5.h hs_cryptohash_md5_update"+ c_md5_update_unsafe :: Ptr Ctx -> Ptr Word8 -> CSize -> IO ()++foreign import ccall safe "md5.h hs_cryptohash_md5_update"+ c_md5_update_safe :: Ptr Ctx -> Ptr Word8 -> CSize -> IO ()++-- 'safe' call overhead neglible for 16KiB and more+c_md5_update :: Ptr Ctx -> Ptr Word8 -> CSize -> IO ()+c_md5_update pctx pbuf sz+ | sz < 16384 = c_md5_update_unsafe pctx pbuf sz+ | otherwise = c_md5_update_safe pctx pbuf sz++foreign import ccall unsafe "md5.h hs_cryptohash_md5_finalize"+ c_md5_finalize :: Ptr Ctx -> Ptr Word8 -> IO ()++updateInternalIO :: Ptr Ctx -> ByteString -> IO ()+updateInternalIO ptr d =+ unsafeUseAsCStringLen d (\(cs, len) -> c_md5_update ptr (castPtr cs) (fromIntegral len))++finalizeInternalIO :: Ptr Ctx -> IO ByteString+finalizeInternalIO ptr = create digestSize (c_md5_finalize ptr)++{-# NOINLINE init #-}+-- | create a new hash context+init :: Ctx+init = unsafeDoIO $ withCtxNew $ c_md5_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 "MD5.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 "MD5.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 "MD5.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_md5_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_md5_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr