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,4 +1,4 @@ -{-# LANGUAGE BangPatterns, ForeignFunctionInterface #-} +{-# LANGUAGE BangPatterns, ForeignFunctionInterface, MultiParamTypeClasses, CPP #-} ----------------------------------------------------------------------------- -- -- Module : Data.Digest.Pure.MD5 @@ -32,6 +32,7 @@ , md5Finalize ) where +import Data.ByteString.Unsafe (unsafeUseAsCString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString.Internal @@ -49,15 +50,17 @@ import qualified Data.Serialize.Get as G import qualified Data.Serialize.Put as P import qualified Data.Serialize as S +import Crypto.Classes +import Data.Tagged import Numeric -- | Block size in bits -blockSize :: Int -blockSize = 512 +md5BlockSize :: Int +md5BlockSize = 512 -blockSizeBytes = blockSize `div` 8 +blockSizeBytes = md5BlockSize `div` 8 blockSizeBytesI64 = (fromIntegral blockSizeBytes) :: Int64 -blockSizeBits = (fromIntegral blockSize) :: Word64 +blockSizeBits = (fromIntegral md5BlockSize) :: Word64 -- | The type for intermediate results (from md5Update) data MD5Partial = MD5Par !Word32 !Word32 !Word32 !Word32 @@ -65,7 +68,6 @@ -- | The type for final results. data MD5Context = MD5Ctx { mdPartial :: !MD5Partial, - mdLeftOver :: !ByteString, mdTotalLen :: !Word64 } -- |After finalizing a context, using md5Finalize, a new type @@ -74,7 +76,7 @@ -- | 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 = 0x67452301 h1 = 0xEFCDAB89 h2 = 0x98BADCFE @@ -83,51 +85,50 @@ -- | Processes a lazy ByteString and returns the md5 digest. -- This is probably what you want. 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 !ctx@(MD5Ctx par@(MD5Par a b c d) !totLen) end = + let totLen' = 8*(totLen + fromIntegral l) :: Word64 + padBS = P.runPut ( do + P.putByteString end + P.putWord8 0x80 + mapM_ P.putWord8 (replicate lenZeroPad 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 (B.drop blockSizeBytes bs) {-# INLINE blockAndDo #-} -- 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" #-} +performMD5Update :: MD5Partial -> B.ByteString -> MD5Partial +performMD5Update !par@(MD5Par !a !b !c !d) !bs = let MD5Par a' b' c' d' = applyMD5Rounds par bs - in MD5Ctx { - mdPartial = MD5Par (a' + a) (b' + b) (c' + c) (d' + d), - mdLeftOver = B.empty, - mdTotalLen = len + blockSizeBits - } + in MD5Par (a' + a) (b' + b) (c' + c) (d' + d) {-# INLINE performMD5Update #-} isAligned (PS _ off _) = off `rem` 4 == 0 @@ -236,12 +237,14 @@ {-# INLINE (!!) #-} {-# INLINE applyMD5Rounds #-} +#ifdef LittleEndian +getNthWord n b = inlinePerformIO (unsafeUseAsCString b (flip peekElemOff n . castPtr)) +#else getNthWord :: Int -> B.ByteString -> Word32 -getNthWord n = right . G.runGet (do - G.uncheckedSkip (n * sizeOf (undefined :: Word32)) - G.getWord32le) +getNthWord n = right . G.runGet G.getWord32le . B.drop (n * sizeOf (undefined :: Word32)) where right x = case x of Right y -> y +#endif {-# INLINE getNthWord #-} infix 9 .<. @@ -268,13 +271,10 @@ return $ MD5Digest p 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 @@ -291,13 +291,11 @@ return $ MD5Digest p instance S.Serialize MD5Context where - put (MD5Ctx p r l) = S.put p >> P.putWord8 (fromIntegral (B.length r)) >> - P.putByteString r >> P.putWord64be l + put (MD5Ctx p l) = S.put p >> + P.putWord64be l get = do p <- S.get - s <- G.getWord8 - r <- G.getByteString (fromIntegral s) l <- G.getWord64be - return $ MD5Ctx p r l + return $ MD5Ctx p l instance S.Serialize MD5Partial where put (MD5Par a b c d) = P.putWord32le a >> P.putWord32le b >> P.putWord32le c >> P.putWord32le d @@ -306,3 +304,10 @@ 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 --- a/Test/MD5.hs +++ b/Test/MD5.hs @@ -2,69 +2,7 @@ module Test.MD5 where import Test.QuickCheck +import Test.Crypto 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 +test = runTests (makeMD5Tests (undefined :: MD5Digest)) diff --git a/Test/main.hs b/Test/main.hs new file mode 100644 --- /dev/null +++ b/Test/main.hs @@ -0,0 +1,3 @@ +import Test.MD5 + +main = test diff --git a/pureMD5.cabal b/pureMD5.cabal --- a/pureMD5.cabal +++ b/pureMD5.cabal @@ -1,20 +1,37 @@ name: pureMD5 -version: 1.1.0.0 +version: 2.0.0.0 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.6 -tested-with: GHC == 6.10.1 +tested-with: GHC == 6.12.1 extra-source-files: Test/MD5.hs Test/md5test.hs +flag LittleEndian + description: Set to true if the architecture is little endian (uses native Word32 loads instead of bytes + shifts, overall 40% speed-up) + default: False + +flag test + description: Build a test program + default: False + Library - Build-Depends: base == 4.*, bytestring >= 0.9 && < 0.10, binary >= 0.4.0 && < 0.6.0, cereal >= 0.2 + Build-Depends: base == 4.*, bytestring >= 0.9 && < 0.10, binary >= 0.4.0 && < 0.6.0, cereal >= 0.2, crypto-api >= 0.0.0.1, tagged ghc-options: -O2 -funfolding-use-threshold66 -funfolding-creation-threshold66 -fexcess-precision -funbox-strict-fields hs-source-dirs: exposed-modules: Data.Digest.Pure.MD5 + if flag(LittleEndian) + cpp-options: -DLittleEndian + +Executable md5Test + main-is: Test/main.hs + Build-Depends: base, QuickCheck, crypto-api, bytestring, cereal + if !flag(test) + buildable: False