diff --git a/Data/Digest/Pure/MD5.hs b/Data/Digest/Pure/MD5.hs --- a/Data/Digest/Pure/MD5.hs +++ b/Data/Digest/Pure/MD5.hs @@ -1,69 +1,81 @@ -{-# LANGUAGE BangPatterns, ForeignFunctionInterface #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- -- Module : Data.Digest.Pure.MD5 -- License : BSD3 -- Maintainer : Thomas.DuBuisson@gmail.com -- Stability : experimental --- Portability : portable, requires bang patterns and ByteString --- Tested with : GHC-6.8.1 +-- Portability : portable +-- Tested with : GHC-7.6.3 -- --- |To get an MD5 digest of a lazy ByteString (you probably want this): --- hash = md5 lazyByteString +-- | It is suggested you use the 'crypto-api' class-based interface to access the MD5 algorithm. +-- Either rely on type inference or provide an explicit type: -- --- Alternativly, for a context that can be further updated/finalized: --- partialCtx = md5Update md5InitialContext partOfFile +-- @ +-- hashFileStrict = liftM hash' . B.readFile +-- hashFileLazyBS = liftM hash . B.readFile +-- @ -- --- And you finialize the context with: --- hash = md5Finalize partialCtx ----------------------------------------------------------------------------- module Data.Digest.Pure.MD5 - ( + ( -- * Types MD5Context , MD5Digest -- * Static data , md5InitialContext - , blockSize -- * Functions , md5 , md5Update , md5Finalize + , md5DigestBytes + -- * Crypto-API interface + , Hash(..) ) where import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L +import Data.ByteString.Unsafe (unsafeDrop,unsafeUseAsCString) import Data.ByteString.Internal +#if MIN_VERSION_binary(0,8,3) +import Data.ByteString.Builder.Extra as B +#endif import Data.Bits import Data.List -import Data.Int (Int64) import Data.Word import Foreign.Storable -import Foreign.Ptr -import Foreign.ForeignPtr -import System.IO +import Foreign.Ptr (castPtr) import Data.Binary import Data.Binary.Get import Data.Binary.Put +import qualified Data.Serialize.Get as G +import qualified Data.Serialize.Put as P +import qualified Data.Serialize as S +import Crypto.Classes (Hash(..), hash) +import Control.Monad (replicateM_) +import Data.Tagged import Numeric +#ifdef FastWordExtract +import System.IO.Unsafe (unsafePerformIO) +#endif -- | Block size in bits -blockSize :: Int -blockSize = 512 +md5BlockSize :: Int +md5BlockSize = 512 -blockSizeBytes = blockSize `div` 8 -blockSizeBytesI64 = (fromIntegral blockSizeBytes) :: Int64 -blockSizeBits = (fromIntegral blockSize) :: Word64 +blockSizeBytes :: Int +blockSizeBytes = md5BlockSize `div` 8 -- | The type for intermediate results (from md5Update) -data MD5Partial = MD5Par !Word32 !Word32 !Word32 !Word32 +data MD5Partial = MD5Par {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 deriving (Ord, Eq) -- | The type for final results. -data MD5Context = MD5Ctx { mdPartial :: !MD5Partial, - mdLeftOver :: !ByteString, - mdTotalLen :: !Word64 } +data MD5Context = MD5Ctx { mdPartial :: {-# UNPACK #-} !MD5Partial, + mdTotalLen :: {-# UNPACK #-} !Word64 } -- |After finalizing a context, using md5Finalize, a new type -- is returned to prevent 're-finalizing' the structure. @@ -71,69 +83,76 @@ -- | The initial context to use when calling md5Update for the first time md5InitialContext :: MD5Context -md5InitialContext = MD5Ctx (MD5Par h0 h1 h2 h3) B.empty 0 +md5InitialContext = MD5Ctx (MD5Par h0 h1 h2 h3) 0 + +h0,h1,h2,h3 :: Word32 h0 = 0x67452301 h1 = 0xEFCDAB89 h2 = 0x98BADCFE h3 = 0x10325476 -- | Processes a lazy ByteString and returns the md5 digest. --- This is probably what you want. +-- This is probably what you want. You can use 'show' to produce the standard hex +-- representation. md5 :: L.ByteString -> MD5Digest -md5 bs = md5Finalize $ md5Update md5InitialContext bs +md5 = hash -- | Closes an MD5 context, thus producing the digest. -md5Finalize :: MD5Context -> MD5Digest -md5Finalize !ctx@(MD5Ctx (MD5Par a b c d) rem !totLen) = - let totLen' = (totLen + 8*fromIntegral l) :: Word64 - padBS = L.toChunks $ runPut ( do - putWord8 0x80 - mapM_ putWord8 (replicate lenZeroPad 0) - putWord64le totLen' ) - in MD5Digest $ mdPartial $ md5Update ctx (L.fromChunks padBS) +md5Finalize :: MD5Context -> B.ByteString -> MD5Digest +md5Finalize (MD5Ctx par !totLen) end = + let totLen' = 8*(totLen + fromIntegral l) :: Word64 + padBS = P.runPut $ do P.putByteString end + P.putWord8 0x80 + replicateM_ lenZeroPad (P.putWord8 0) + P.putWord64le totLen' + in MD5Digest $ blockAndDo par padBS where - l = B.length rem + l = B.length end lenZeroPad = if (l + 1) <= blockSizeBytes - 8 then (blockSizeBytes - 8) - (l + 1) else (2 * blockSizeBytes - 8) - (l + 1) -- | Alters the MD5Context with a partial digest of the data. -md5Update :: MD5Context -> L.ByteString -> MD5Context -md5Update !ctx@(MD5Ctx _ !leftover _) bsLazy = - let bs = L.fromChunks (leftover:L.toChunks bsLazy) - in blockAndDo ctx bs --foldl' performMD5Update ctx blks +-- +-- The input bytestring MUST be a multiple of the blockSize +-- or bad things can happen (incorrect digest results)! +md5Update :: MD5Context -> B.ByteString -> MD5Context +md5Update ctx bs + | B.length bs `rem` blockSizeBytes /= 0 = error "Invalid use of hash update routine (see crypto-api Hash class semantics)" + | otherwise = + let bs' = if isAligned bs then bs else B.copy bs -- copying has been measured as a net win on my x86 system + new = blockAndDo (mdPartial ctx) bs' + in ctx { mdPartial = new, mdTotalLen = mdTotalLen ctx + fromIntegral (B.length bs) } -blockAndDo :: MD5Context -> L.ByteString -> MD5Context -blockAndDo !ctx bs = - if B.length blk == blockSizeBytes - then let !newCtx = performMD5Update ctx blk - in blockAndDo newCtx rest - else ctx { mdLeftOver = blk } - where - blk = if isAligned blk' then blk' else B.copy blk' - blk' = B.concat $ L.toChunks top - (top,rest) = L.splitAt blockSizeBytesI64 bs +blockAndDo :: MD5Partial -> B.ByteString -> MD5Partial +blockAndDo !ctx bs + | B.length bs == 0 = ctx + | otherwise = + let !new = performMD5Update ctx bs + in blockAndDo new (unsafeDrop blockSizeBytes bs) {-# INLINE blockAndDo #-} --- Assumes ByteString length == blockSizeBytes, will fold the +-- Assumes ByteString length == blockSizeBytes, will fold the -- context across calls to applyMD5Rounds. -performMD5Update :: MD5Context -> ByteString -> MD5Context -performMD5Update !ctx@(MD5Ctx !par@(MD5Par !a !b !c !d) _ !len) !bs = {-# SCC "performMD5Update" #-} - let MD5Par a' b' c' d' = {- if isAligned bs - then applyMD5Rounds par bs getAlignedNthWord - else applyMD5Rounds par bs getUnalignedNthWord -} - applyMD5Rounds par bs - in MD5Ctx { - mdPartial = MD5Par (a' + a) (b' + b) (c' + c) (d' + d), - mdLeftOver = B.empty, - mdTotalLen = len + blockSizeBits - } +performMD5Update :: MD5Partial -> B.ByteString -> MD5Partial +performMD5Update par@(MD5Par !a !b !c !d) !bs = + let MD5Par a' b' c' d' = applyMD5Rounds par bs + in MD5Par (a' + a) (b' + b) (c' + c) (d' + d) {-# INLINE performMD5Update #-} +isAligned :: ByteString -> Bool +#if !MIN_VERSION_bytestring(0,11,0) isAligned (PS _ off _) = off `rem` 4 == 0 +#else +isAligned = const True +-- This is semantically equivalent to the definition above, because +-- in bytestring-0.11 offset is always 0. Note that neither definition checks +-- that a pointer (the first field of 'PS') is aligned. Anyways 'isAligned' +-- is used for optimization purposes only and does not affect correctness. +#endif applyMD5Rounds :: MD5Partial -> ByteString -> MD5Partial -applyMD5Rounds par@(MD5Par a b c d) w = {-# SCC "applyMD5Rounds" #-} +applyMD5Rounds (MD5Par a b c d) w = {-# SCC "applyMD5Rounds" #-} let -- Round 1 !r0 = ff a b c d (w!!0) 7 3614090360 !r1 = ff d r0 b c (w!!1) 12 3905402710 @@ -236,43 +255,64 @@ {-# INLINE (!!) #-} {-# INLINE applyMD5Rounds #-} -getNthWord n bs@(PS ptr off len) = - inlinePerformIO $ withForeignPtr ptr $ \ptr' -> do - let p = castPtr $ plusPtr ptr' off - peekElemOff p n +#ifdef FastWordExtract +getNthWord n b = unsafePerformIO (unsafeUseAsCString b (flip peekElemOff n . castPtr)) {-# INLINE getNthWord #-} +#else +getNthWord :: Int -> B.ByteString -> Word32 +getNthWord n = right . G.runGet G.getWord32le . B.drop (n * sizeOf (undefined :: Word32)) + where + right x = case x of Right y -> y +#endif -infix 9 .<. -(.<.) :: Word8 -> Int -> Word32 -(.<.) w i = (fromIntegral w) `shiftL` i +-- | The raw bytes of an 'MD5Digest'. It is always 16 bytes long. +-- +-- You can also use the 'Binary' or 'S.Serialize' instances to output the raw +-- bytes. Alternatively you can use 'show' to produce the standard hex +-- representation. +-- +md5DigestBytes :: MD5Digest -> B.ByteString +md5DigestBytes (MD5Digest h) = md5PartialBytes h +md5PartialBytes :: MD5Partial -> B.ByteString +md5PartialBytes = + toBs . (put :: MD5Partial -> Put) + where + toBs :: Put -> B.ByteString +#if MIN_VERSION_binary(0,8,3) + -- with later binary versions we can control the buffer size precisely: + toBs = L.toStrict + . B.toLazyByteStringWith (B.untrimmedStrategy 16 0) L.empty + . execPut +#else + toBs = B.concat . L.toChunks . runPut + -- note L.toStrict is only in newer bytestring versions +#endif + ----- Some quick and dirty instances follow ----- instance Show MD5Digest where show (MD5Digest h) = show h +instance Show MD5Partial where + show md5par = + let bs = md5PartialBytes md5par + in foldl' (\str w -> let cx = showHex w str + in if length cx < length str + 2 + then '0':cx + else cx) "" (B.unpack (B.reverse bs)) + instance Binary MD5Digest where put (MD5Digest p) = put p get = do p <- get return $ MD5Digest p -instance Show MD5Partial where - show (MD5Par a b c d) = - let bs = runPut $ putWord32be d >> putWord32be c >> putWord32be b >> putWord32be a - in foldl' (\str w -> let c = showHex w str - in if length c < length str + 2 - then '0':c - else c) "" (L.unpack bs) - instance Binary MD5Context where - put (MD5Ctx p r l) = put p >> putWord8 (fromIntegral (B.length r)) >> - putByteString r >> putWord64be l + put (MD5Ctx p l) = put p >> putWord64be l get = do p <- get - s <- getWord8 - r <- getByteString (fromIntegral s) l <- getWord64be - return $ MD5Ctx p r l + return $ MD5Ctx p l instance Binary MD5Partial where put (MD5Par a b c d) = putWord32le a >> putWord32le b >> putWord32le c >> putWord32le d @@ -281,3 +321,36 @@ c <- getWord32le d <- getWord32le return $ MD5Par a b c d + +instance S.Serialize MD5Digest where + put (MD5Digest p) = S.put p + get = do + p <- S.get + return $ MD5Digest p + +instance S.Serialize MD5Context where + put (MD5Ctx p l) = S.put p >> + P.putWord64be l + get = do p <- S.get + l <- G.getWord64be + return $ MD5Ctx p l + +instance S.Serialize MD5Partial where + put (MD5Par a b c d) = do + P.putWord32le a + P.putWord32le b + P.putWord32le c + P.putWord32le d + get = do + a <- G.getWord32le + b <- G.getWord32le + c <- G.getWord32le + d <- G.getWord32le + return (MD5Par a b c d) + +instance Hash MD5Context MD5Digest where + outputLength = Tagged 128 + blockLength = Tagged 512 + initialCtx = md5InitialContext + updateCtx = md5Update + finalize = md5Finalize diff --git a/Test/MD5.hs b/Test/MD5.hs deleted file mode 100644 --- a/Test/MD5.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -module Test.MD5 where - -import Test.QuickCheck -import Data.Digest.Pure.MD5 -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString as S -import Control.Monad (forM) -import Data.Word (Word8) -import Data.Binary - -instance Arbitrary Word8 where - arbitrary = (arbitrary :: Gen Int) >>= return . fromIntegral - -instance Arbitrary S.ByteString where - arbitrary = do - len <- choose (0,4096) :: Gen Int - words <- forM [0..len] (\_ -> arbitrary) - return $ S.pack words - -instance Arbitrary L.ByteString where - arbitrary = do - len <- choose (0,10) :: Gen Int - chunks <- vector len - return $ L.fromChunks chunks - -prop_PartsEqWhole lps = - let lpsChunks = map (L.fromChunks . (:[])) (L.toChunks lps) - incremental = foldl md5Update md5InitialContext lpsChunks - final = md5Finalize incremental - in md5 lps == final - -prop_ShowLen bs = 32 == (length $ show (md5 bs)) - -prop_BinaryLen bs = 16 == (L.length $ encode (md5 bs)) - -prop_GetPut bs = - let dg = md5 bs - in decode (encode dg) == dg - -prop_ShowElem bs = - let digest = md5 bs - valids = \c -> (c >= 'a' && c <= 'f') || (c >= '0' && c <= '9') - in [] == filter (not . valids) (show digest) - -prop_KnownAnswers = - let mds = show . md5 . pk - pk = L.pack . (map (fromIntegral . fromEnum)) - in mds ("") == "d41d8cd98f00b204e9800998ecf8427e" && - mds ("a") == "0cc175b9c0f1b6a831c399e269772661" && - mds ("abc") == "900150983cd24fb0d6963f7d28e17f72" && - mds ("message digest") == "f96b697d7cb7938d525a2f31aaf161d0" && - mds ("abcdefghijklmnopqrstuvwxyz") == "c3fcd3d76192e4007dfb496cca67e13b" && - mds ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789") == - "d174ab98d277d9f5a5611c2c9f419d9f" && - mds ("12345678901234567890123456789012345678901234567890123456789012345678901234567890") == "57edf4a22be3c955ac49da2e2107b67a" - -tests = [ T prop_PartsEqWhole "PartsEqWhole" - , T prop_ShowLen "ShowLen" - , T prop_BinaryLen "BinaryLen" - , T prop_GetPut "GetPut" - , T prop_ShowElem "ShowElem" - , T prop_KnownAnswers "KnownAnswers"] - -data Test = forall a. Testable a => T a String -runTest (T a s) = do - putStr ("prop_" ++ s ++ ": ") - quickCheck a - -runTests = mapM_ runTest tests diff --git a/Test/main.hs b/Test/main.hs new file mode 100644 --- /dev/null +++ b/Test/main.hs @@ -0,0 +1,36 @@ +module Main where + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.MD5 +import Data.Digest.Pure.MD5 +import Data.Char (isSpace) +import Data.ByteString.Lazy (toStrict, ByteString) +import qualified Data.Binary as B +import qualified Data.Serialize as S +import Hexdump + +main :: IO () +main = defaultMain + [ testGroup "MD5 functional correctness tests" base_tests + , testGroup "Serialization order correctness tests" serialization_tests + ] + +-- | Use the crypto-api-tests, piddly as they are, to give evidence of +-- functional correctness. +base_tests :: [Test] +base_tests = makeMD5Tests (undefined :: MD5Digest) + +-- | Ensure the output of `show`, `Serialize`, `Binary`, and `md5DigestBytes` +-- are all consistent. +serialization_tests :: [Test] +serialization_tests = + [ testProperty "show == simple_hex . Serialize.encode" + (\bs -> let d = hsh bs in show d == filter (not . isSpace) (simpleHex (S.encode d))) + , testProperty "Serialize.encode == toStrict . Binary.encode" + (\bs -> let d = hsh bs in toStrict (B.encode d) == S.encode d) + , testProperty "Serialize.encode == md5DigestBytes" + (\bs -> let d = hsh bs in S.encode d == md5DigestBytes d) + ] + where + hsh = hash :: ByteString -> MD5Digest diff --git a/Test/md5test.hs b/Test/md5test.hs deleted file mode 100644 --- a/Test/md5test.hs +++ /dev/null @@ -1,14 +0,0 @@ -import Control.Arrow -import Data.ByteString.Lazy.Char8 -import Data.Digest.Pure.MD5 -import Test.QuickCheck - -instance Arbitrary Char where - arbitrary = choose ('A', 'Z') - -md5parts = - (uncurry ((md5Finalize .) . md5Update . md5Update md5InitialContext) .) - . curry (pack *** pack) - -prop_md5 xs ys = show (md5 (pack (xs ++ ys))) == show (md5parts xs ys) - diff --git a/pureMD5.cabal b/pureMD5.cabal --- a/pureMD5.cabal +++ b/pureMD5.cabal @@ -1,23 +1,46 @@ name: pureMD5 -version: 1.0.0.3 +version: 2.1.4 license: BSD3 license-file: LICENSE author: Thomas DuBuisson maintainer: Thomas DuBuisson -description: An unrolled implementation of MD5 purely in Haskell. -synopsis: MD5 implementations that should become part of a ByteString Crypto package. +description: A Haskell-only implementation of the MD5 digest (hash) algorithm. This now supports + the crypto-api class interface. +synopsis: A Haskell-only implementation of the MD5 digest (hash) algorithm. category: Data, Cryptography stability: stable build-type: Simple -cabal-version: >= 1.2 -tested-with: GHC == 6.10.1 -extra-source-files: Test/MD5.hs Test/md5test.hs +cabal-version: >= 1.10 +tested-with: GHC == 7.10.3 -Flag small_base - Description: Choose the split-up base package. +flag test + description: Build a test program + default: False Library - Build-Depends: base >= 3 && < 5, bytestring >= 0.9 && < 0.10, binary >= 0.4.0 && < 0.6.0 + Build-Depends: base == 4.*, bytestring >= 0.9, binary >= 0.4.0, cereal >= 0.2, crypto-api, tagged + ghc-options: -O2 -funfolding-use-threshold66 -funfolding-creation-threshold66 -funbox-strict-fields + default-language: Haskell2010 hs-source-dirs: exposed-modules: Data.Digest.Pure.MD5 - ghc-options: -O2 -funfolding-use-threshold66 -funfolding-creation-threshold66 -fexcess-precision -funbox-strict-fields + if arch(i386) || arch(x86_64) + cpp-options: -DFastWordExtract + +Test-Suite MD5Tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: base >=4.6 && < 5, + pureMD5, + crypto-api-tests, + QuickCheck, + test-framework >= 0.8, + test-framework-quickcheck2, + binary, cereal, pretty-hex, + bytestring + ghc-options: -Wall + hs-source-dirs: Test + main-is: main.hs + +source-repository head + type: git + location: https://github.com/TomMD/pureMD5