pureMD5 1.0.0.3 → 2.1.4
raw patch · 5 files changed
Files
- Data/Digest/Pure/MD5.hs +156/−83
- Test/MD5.hs +0/−70
- Test/main.hs +36/−0
- Test/md5test.hs +0/−14
- pureMD5.cabal +33/−10
Data/Digest/Pure/MD5.hs view
@@ -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
− Test/MD5.hs
@@ -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
+ Test/main.hs view
@@ -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
− Test/md5test.hs
@@ -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)-
pureMD5.cabal view
@@ -1,23 +1,46 @@ name: pureMD5-version: 1.0.0.3+version: 2.1.4 license: BSD3 license-file: LICENSE author: Thomas DuBuisson <thomas.dubuisson@gmail.com> 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