diff --git a/Data/Digest/Pure/MD5.hs b/Data/Digest/Pure/MD5.hs new file mode 100644 --- /dev/null +++ b/Data/Digest/Pure/MD5.hs @@ -0,0 +1,277 @@ +{-# OPTIONS_GHC -XBangPatterns #-} +----------------------------------------------------------------------------- +-- +-- Module : Data.Digest.MD5 +-- License : BSD3 +-- Maintainer : Thomas.DuBuisson@mail.google.com +-- Stability : experimental +-- Portability : portable, requires bang patterns and ByteString +-- Tested with : GHC-6.8.1 +-- +-- To get an MD5 digest of a lazy ByteString (you probably want this): +-- hash = md5 lazyByteString +-- +-- Alternativly, for a context that can be further updated/finalized: +-- partialCtx = md5Update md5InitialContext partOfFile +-- +-- 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 + ) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Internal +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 Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Numeric + +-- | Block size in bits +blockSize :: Int +blockSize = 512 + +blockSizeBytes = blockSize `div` 8 +blockSizeBytesI64 = (fromIntegral blockSizeBytes) :: Int64 +blockSizeBits = (fromIntegral blockSize) :: Word64 + +data MD5Partial = MD5Par !Word32 !Word32 !Word32 !Word32 + deriving (Ord, Eq) + +-- | The type for intermediate and final results. +data MD5Context = MD5Ctx { mdPartial :: !MD5Partial, + mdLeftOver :: ByteString, + mdTotalLen :: !Word64 } + +-- |After finalizing a context, using md5Finalize, a new type +-- is returned to prevent 're-finalizing' the structure. +newtype MD5Digest = MD5Digest MD5Context + +-- | The initial context to use when calling md5Update for the first time +md5InitialContext :: MD5Context +md5InitialContext = MD5Ctx (MD5Par h0 h1 h2 h3) B.empty 0 +h0 = 0x67452301 +h1 = 0xEFCDAB89 +h2 = 0x98BADCFE +h3 = 0x10325476 + +-- | 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 + +-- | 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 $ md5Update ctx (L.fromChunks padBS) + where + l = B.length rem + 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) + blks = block bs + in foldl' performMD5Update ctx blks + +block :: L.ByteString -> [ByteString] +block bs = + if rest /= L.empty + then (conv top) : (block rest) + else [conv top] + where + conv = B.concat . L.toChunks + (top,rest) = L.splitAt blockSizeBytesI64 bs +{-# INLINE block #-} + +-- 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 = + let MD5Par a' b' c' d' = applyMD5Rounds par bs + in if B.length bs == blockSizeBytes + then MD5Ctx { + mdPartial = MD5Par (a' + a) (b' + b) (c' + c) (d' + d), + mdLeftOver = B.empty, + mdTotalLen = len + blockSizeBits + } + else ctx { mdLeftOver = bs } + +applyMD5Rounds :: MD5Partial -> ByteString -> MD5Partial +applyMD5Rounds par@(MD5Par a b c d) w = + let -- Round 1 + !r0 = ff a b c d (w!!0) 7 3614090360 + !r1 = ff d r0 b c (w!!1) 12 3905402710 + !r2 = ff c r1 r0 b (w!!2) 17 606105819 + !r3 = ff b r2 r1 r0 (w!!3) 22 3250441966 + !r4 = ff r0 r3 r2 r1 (w!!4) 7 4118548399 + !r5 = ff r1 r4 r3 r2 (w!!5) 12 1200080426 + !r6 = ff r2 r5 r4 r3 (w!!6) 17 2821735955 + !r7 = ff r3 r6 r5 r4 (w!!7) 22 4249261313 + !r8 = ff r4 r7 r6 r5 (w!!8) 7 1770035416 + !r9 = ff r5 r8 r7 r6 (w!!9) 12 2336552879 + !r10 = ff r6 r9 r8 r7 (w!!10) 17 4294925233 + !r11 = ff r7 r10 r9 r8 (w!!11) 22 2304563134 + !r12 = ff r8 r11 r10 r9 (w!!12) 7 1804603682 + !r13 = ff r9 r12 r11 r10 (w!!13) 12 4254626195 + !r14 = ff r10 r13 r12 r11 (w!!14) 17 2792965006 + !r15 = ff r11 r14 r13 r12 (w!!15) 22 1236535329 + -- Round 2 + !r16 = gg r12 r15 r14 r13 (w!!1) 5 4129170786 + !r17 = gg r13 r16 r15 r14 (w!!6) 9 3225465664 + !r18 = gg r14 r17 r16 r15 (w!!11) 14 643717713 + !r19 = gg r15 r18 r17 r16 (w!!0) 20 3921069994 + !r20 = gg r16 r19 r18 r17 (w!!5) 5 3593408605 + !r21 = gg r17 r20 r19 r18 (w!!10) 9 38016083 + !r22 = gg r18 r21 r20 r19 (w!!15) 14 3634488961 + !r23 = gg r19 r22 r21 r20 (w!!4) 20 3889429448 + !r24 = gg r20 r23 r22 r21 (w!!9) 5 568446438 + !r25 = gg r21 r24 r23 r22 (w!!14) 9 3275163606 + !r26 = gg r22 r25 r24 r23 (w!!3) 14 4107603335 + !r27 = gg r23 r26 r25 r24 (w!!8) 20 1163531501 + !r28 = gg r24 r27 r26 r25 (w!!13) 5 2850285829 + !r29 = gg r25 r28 r27 r26 (w!!2) 9 4243563512 + !r30 = gg r26 r29 r28 r27 (w!!7) 14 1735328473 + !r31 = gg r27 r30 r29 r28 (w!!12) 20 2368359562 + -- Round 3 + !r32 = hh r28 r31 r30 r29 (w!!5) 4 4294588738 + !r33 = hh r29 r32 r31 r30 (w!!8) 11 2272392833 + !r34 = hh r30 r33 r32 r31 (w!!11) 16 1839030562 + !r35 = hh r31 r34 r33 r32 (w!!14) 23 4259657740 + !r36 = hh r32 r35 r34 r33 (w!!1) 4 2763975236 + !r37 = hh r33 r36 r35 r34 (w!!4) 11 1272893353 + !r38 = hh r34 r37 r36 r35 (w!!7) 16 4139469664 + !r39 = hh r35 r38 r37 r36 (w!!10) 23 3200236656 + !r40 = hh r36 r39 r38 r37 (w!!13) 4 681279174 + !r41 = hh r37 r40 r39 r38 (w!!0) 11 3936430074 + !r42 = hh r38 r41 r40 r39 (w!!3) 16 3572445317 + !r43 = hh r39 r42 r41 r40 (w!!6) 23 76029189 + !r44 = hh r40 r43 r42 r41 (w!!9) 4 3654602809 + !r45 = hh r41 r44 r43 r42 (w!!12) 11 3873151461 + !r46 = hh r42 r45 r44 r43 (w!!15) 16 530742520 + !r47 = hh r43 r46 r45 r44 (w!!2) 23 3299628645 + -- Round 4 + !r48 = ii r44 r47 r46 r45 (w!!0) 6 4096336452 + !r49 = ii r45 r48 r47 r46 (w!!7) 10 1126891415 + !r50 = ii r46 r49 r48 r47 (w!!14) 15 2878612391 + !r51 = ii r47 r50 r49 r48 (w!!5) 21 4237533241 + !r52 = ii r48 r51 r50 r49 (w!!12) 6 1700485571 + !r53 = ii r49 r52 r51 r50 (w!!3) 10 2399980690 + !r54 = ii r50 r53 r52 r51 (w!!10) 15 4293915773 + !r55 = ii r51 r54 r53 r52 (w!!1) 21 2240044497 + !r56 = ii r52 r55 r54 r53 (w!!8) 6 1873313359 + !r57 = ii r53 r56 r55 r54 (w!!15) 10 4264355552 + !r58 = ii r54 r57 r56 r55 (w!!6) 15 2734768916 + !r59 = ii r55 r58 r57 r56 (w!!13) 21 1309151649 + !r60 = ii r56 r59 r58 r57 (w!!4) 6 4149444226 + !r61 = ii r57 r60 r59 r58 (w!!11) 10 3174756917 + !r62 = ii r58 r61 r60 r59 (w!!2) 15 718787259 + !r63 = ii r59 r62 r61 r60 (w!!9) 21 3951481745 + in MD5Par r60 r63 r62 r61 + where + f !x !y !z = (x .&. y) .|. ((complement x) .&. z) + {-# INLINE f #-} + g !x !y !z = (x .&. z) .|. (y .&. (complement z)) + {-# INLINE g #-} + h !x !y !z = (x `xor` y `xor` z) + {-# INLINE h #-} + i !x !y !z = y `xor` (x .|. (complement z)) + {-# INLINE i #-} + ff a b c d x s ac = + let !a' = f b c d + x + ac + a + !a'' = rotateL a' s + in a'' + b + {-# INLINE ff #-} + gg a b c d x s ac = + let !a' = g b c d + x + ac + a + !a'' = rotateL a' s + in a'' + b + {-# INLINE gg #-} + hh a b c d x s ac = + let !a' = h b c d + x + ac + a + !a'' = rotateL a' s + in a'' + b + {-# INLINE hh #-} + ii a b c d x s ac = + let !a' = i b c d + x + ac + a + !a'' = rotateL a' s + in a'' + b + {-# INLINE ii #-} + (!!) word32s pos = getNthWord pos word32s + {-# INLINE (!!) #-} + getNthWord n bs@(PS ptr off len) = + inlinePerformIO $ withForeignPtr ptr $ \ptr' -> do + let p = castPtr $ plusPtr ptr' off + peekElemOff p n + {-# INLINE getNthWord #-} +{-# INLINE applyMD5Rounds #-} + +----- Some quick and dirty instances follow ----- + +instance Show MD5Digest where + show (MD5Digest h) = show h + +instance Binary MD5Digest where + put (MD5Digest (MD5Ctx p _ _)) = put p + get = do + p <- get + return $ MD5Digest $ MD5Ctx p B.empty 0 + +instance Ord MD5Digest where + compare (MD5Digest (MD5Ctx a _ _)) (MD5Digest (MD5Ctx b _ _)) = compare a b + +instance Eq MD5Digest where + (MD5Digest (MD5Ctx a _ _)) == (MD5Digest (MD5Ctx b _ _)) = a == b + +instance Show MD5Context where + show (MD5Ctx (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 + get = do p <- get + s <- getWord8 + r <- getByteString (fromIntegral s) + l <- getWord64be + return $ MD5Ctx p r l + +instance Binary MD5Partial where + put (MD5Par a b c d) = putWord32be a >> putWord32be b >> putWord32be c >> putWord32be d + get = do a <- getWord32be + b <- getWord32be + c <- getWord32be + d <- getWord32be + return $ MD5Par a b c d diff --git a/NOTES b/NOTES deleted file mode 100644 --- a/NOTES +++ /dev/null @@ -1,3 +0,0 @@ -pureMD5 rolled version (MD5.Rolled) is around just for historical purposes, -but if you want a real challange then try to make a compiler that will compile -the rolled version to run as fast as the unrolled version. diff --git a/Test/MD5.hs b/Test/MD5.hs new file mode 100644 --- /dev/null +++ b/Test/MD5.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Test.MD5 where + +import Test.QuickCheck +import Data.Digest.Pure.MD5 +import qualified Data.ByteString.Lazy as L +import Control.Monad (forM) +import Data.Word (Word8) +import Data.Binary + +instance Arbitrary Word8 where + arbitrary = (arbitrary :: Gen Int) >>= return . fromIntegral + +instance Arbitrary L.ByteString where + arbitrary = do + len <- choose (0,10000) :: Gen Int + words <- forM [0..len] (\_ -> arbitrary) + return $ L.pack words + +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/md5test.hs b/Test/md5test.hs new file mode 100644 --- /dev/null +++ b/Test/md5test.hs @@ -0,0 +1,14 @@ +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,17 +1,17 @@ name: pureMD5 -version: 0.1.2 +version: 0.2.0 license: BSD3 license-file: LICENSE author: Thomas DuBuisson maintainer: Thomas DuBuisson -description: A rolled (concise yet inefficient) and unrolled (more efficient, much less concise) - version of MD5 purely in Haskell. Only the unrolled is exported. +description: An unrolled implementation of MD5 purely in Haskell. synopsis: MD5 implementations that should become part of a ByteString Crypto package. category: Data, Cryptography stability: stable build-type: Simple cabal-version: >= 1.2 tested-with: GHC == 6.8.2 +extra-source-files: Test/MD5.hs Test/md5test.hs Flag small_base Description: Choose the split-up base package. @@ -21,6 +21,6 @@ Build-Depends: base >= 3, bytestring >= 0.9, binary >= 0.4.0 else Build-Depends: base >= 3, bytestring, binary >= 0.4.0 - hs-source-dirs: src - exposed-modules: Data.Digest.MD5 + hs-source-dirs: Data, Test + exposed-modules: Data.Digest.Pure.MD5 ghc-options: -O2 -funfolding-use-threshold66 -funfolding-creation-threshold66 -fvia-C -optc-funroll-all-loops -optc-ffast-math -fexcess-precision -funbox-strict-fields diff --git a/src/Data/Digest/MD5.hs b/src/Data/Digest/MD5.hs deleted file mode 100644 --- a/src/Data/Digest/MD5.hs +++ /dev/null @@ -1,256 +0,0 @@ -{-# OPTIONS_GHC -XBangPatterns #-} ------------------------------------------------------------------------------ --- --- Module : Data.Digest.MD5 --- License : BSD3 --- Maintainer : Thomas.DuBuisson@mail.google.com --- Stability : experimental --- Portability : portable, requires bang patterns and ByteString --- Tested with : GHC-6.8.1 --- --- To get an MD5 digest of a lazy ByteString (you probably want this): --- hash = md5 lazyByteString --- --- Alternativly, for a context that can be further updated/finalized: --- partialCtx = md5Update md5InitialContext partOfFile --- --- And you finialize the context with: --- hash = md5Finalize partialCtx ------------------------------------------------------------------------------ - -module Data.Digest.MD5 ( - -- * Types - MD5Context - -- * Static data - ,md5InitialContext - ,blockSize - -- * Functions - ,md5 - ,md5Update - ,md5Finalize - ) where - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Internal -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 Data.Binary -import Data.Binary.Get -import Data.Binary.Put -import Numeric - --- | Block size in bits -blockSize :: Int -blockSize = 512 - -blockSizeBytes = blockSize `div` 8 -blockSizeBytesI64 = (fromIntegral blockSizeBytes) :: Int64 -blockSizeBits = (fromIntegral blockSize) :: Word64 - -data MD5Partial = MD5Par !Word32 !Word32 !Word32 !Word32 - --- | The type for intermediate and final results. -data MD5Context = MD5Ctx { mdPartial :: !MD5Partial, - mdLeftOver :: ByteString, - mdTotalLen :: !Word64 } - --- | The initial context to use when calling md5Update for the first time -md5InitialContext :: MD5Context -md5InitialContext = MD5Ctx (MD5Par h0 h1 h2 h3) B.empty 0 -h0 = 0x67452301 -h1 = 0xEFCDAB89 -h2 = 0x98BADCFE -h3 = 0x10325476 - --- | Processes a lazy ByteString and returns the md5 digest -md5 :: L.ByteString -> MD5Context -md5 bs = md5Finalize $ md5Update md5InitialContext bs - --- | Closes an MD5 context. While it is typesafe to reupdate a finalized --- context the result would not be a valid MD5 hash of your data. -md5Finalize :: MD5Context -> MD5Context -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 md5Update ctx (L.fromChunks (rem:padBS)) - where - l = B.length rem - 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 bsLazy = - let blks = block bsLazy - in foldl' performMD5Update ctx blks - -block :: L.ByteString -> [ByteString] -block bs = - if rest /= L.empty - then (conv top) : (block rest) - else [conv top] - where - conv = B.concat . L.toChunks - (top,rest) = L.splitAt blockSizeBytesI64 bs -{-# INLINE block #-} - --- 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 = - let MD5Par a' b' c' d' = applyMD5Rounds par bs - in if B.length bs == blockSizeBytes - then MD5Ctx { - mdPartial = MD5Par (a' + a) (b' + b) (c' + c) (d' + d), - mdLeftOver = B.empty, - mdTotalLen = len + blockSizeBits - } - else ctx { mdLeftOver = bs } - -applyMD5Rounds :: MD5Partial -> ByteString -> MD5Partial -applyMD5Rounds par@(MD5Par a b c d) w = - let -- Round 1 - !r0 = ff a b c d (w!!0) 7 3614090360 - !r1 = ff d r0 b c (w!!1) 12 3905402710 - !r2 = ff c r1 r0 b (w!!2) 17 606105819 - !r3 = ff b r2 r1 r0 (w!!3) 22 3250441966 - !r4 = ff r0 r3 r2 r1 (w!!4) 7 4118548399 - !r5 = ff r1 r4 r3 r2 (w!!5) 12 1200080426 - !r6 = ff r2 r5 r4 r3 (w!!6) 17 2821735955 - !r7 = ff r3 r6 r5 r4 (w!!7) 22 4249261313 - !r8 = ff r4 r7 r6 r5 (w!!8) 7 1770035416 - !r9 = ff r5 r8 r7 r6 (w!!9) 12 2336552879 - !r10 = ff r6 r9 r8 r7 (w!!10) 17 4294925233 - !r11 = ff r7 r10 r9 r8 (w!!11) 22 2304563134 - !r12 = ff r8 r11 r10 r9 (w!!12) 7 1804603682 - !r13 = ff r9 r12 r11 r10 (w!!13) 12 4254626195 - !r14 = ff r10 r13 r12 r11 (w!!14) 17 2792965006 - !r15 = ff r11 r14 r13 r12 (w!!15) 22 1236535329 - -- Round 2 - !r16 = gg r12 r15 r14 r13 (w!!1) 5 4129170786 - !r17 = gg r13 r16 r15 r14 (w!!6) 9 3225465664 - !r18 = gg r14 r17 r16 r15 (w!!11) 14 643717713 - !r19 = gg r15 r18 r17 r16 (w!!0) 20 3921069994 - !r20 = gg r16 r19 r18 r17 (w!!5) 5 3593408605 - !r21 = gg r17 r20 r19 r18 (w!!10) 9 38016083 - !r22 = gg r18 r21 r20 r19 (w!!15) 14 3634488961 - !r23 = gg r19 r22 r21 r20 (w!!4) 20 3889429448 - !r24 = gg r20 r23 r22 r21 (w!!9) 5 568446438 - !r25 = gg r21 r24 r23 r22 (w!!14) 9 3275163606 - !r26 = gg r22 r25 r24 r23 (w!!3) 14 4107603335 - !r27 = gg r23 r26 r25 r24 (w!!8) 20 1163531501 - !r28 = gg r24 r27 r26 r25 (w!!13) 5 2850285829 - !r29 = gg r25 r28 r27 r26 (w!!2) 9 4243563512 - !r30 = gg r26 r29 r28 r27 (w!!7) 14 1735328473 - !r31 = gg r27 r30 r29 r28 (w!!12) 20 2368359562 - -- Round 3 - !r32 = hh r28 r31 r30 r29 (w!!5) 4 4294588738 - !r33 = hh r29 r32 r31 r30 (w!!8) 11 2272392833 - !r34 = hh r30 r33 r32 r31 (w!!11) 16 1839030562 - !r35 = hh r31 r34 r33 r32 (w!!14) 23 4259657740 - !r36 = hh r32 r35 r34 r33 (w!!1) 4 2763975236 - !r37 = hh r33 r36 r35 r34 (w!!4) 11 1272893353 - !r38 = hh r34 r37 r36 r35 (w!!7) 16 4139469664 - !r39 = hh r35 r38 r37 r36 (w!!10) 23 3200236656 - !r40 = hh r36 r39 r38 r37 (w!!13) 4 681279174 - !r41 = hh r37 r40 r39 r38 (w!!0) 11 3936430074 - !r42 = hh r38 r41 r40 r39 (w!!3) 16 3572445317 - !r43 = hh r39 r42 r41 r40 (w!!6) 23 76029189 - !r44 = hh r40 r43 r42 r41 (w!!9) 4 3654602809 - !r45 = hh r41 r44 r43 r42 (w!!12) 11 3873151461 - !r46 = hh r42 r45 r44 r43 (w!!15) 16 530742520 - !r47 = hh r43 r46 r45 r44 (w!!2) 23 3299628645 - -- Round 4 - !r48 = ii r44 r47 r46 r45 (w!!0) 6 4096336452 - !r49 = ii r45 r48 r47 r46 (w!!7) 10 1126891415 - !r50 = ii r46 r49 r48 r47 (w!!14) 15 2878612391 - !r51 = ii r47 r50 r49 r48 (w!!5) 21 4237533241 - !r52 = ii r48 r51 r50 r49 (w!!12) 6 1700485571 - !r53 = ii r49 r52 r51 r50 (w!!3) 10 2399980690 - !r54 = ii r50 r53 r52 r51 (w!!10) 15 4293915773 - !r55 = ii r51 r54 r53 r52 (w!!1) 21 2240044497 - !r56 = ii r52 r55 r54 r53 (w!!8) 6 1873313359 - !r57 = ii r53 r56 r55 r54 (w!!15) 10 4264355552 - !r58 = ii r54 r57 r56 r55 (w!!6) 15 2734768916 - !r59 = ii r55 r58 r57 r56 (w!!13) 21 1309151649 - !r60 = ii r56 r59 r58 r57 (w!!4) 6 4149444226 - !r61 = ii r57 r60 r59 r58 (w!!11) 10 3174756917 - !r62 = ii r58 r61 r60 r59 (w!!2) 15 718787259 - !r63 = ii r59 r62 r61 r60 (w!!9) 21 3951481745 - in MD5Par r60 r63 r62 r61 - where - f !x !y !z = (x .&. y) .|. ((complement x) .&. z) - {-# INLINE f #-} - g !x !y !z = (x .&. z) .|. (y .&. (complement z)) - {-# INLINE g #-} - h !x !y !z = (x `xor` y `xor` z) - {-# INLINE h #-} - i !x !y !z = y `xor` (x .|. (complement z)) - {-# INLINE i #-} - ff a b c d x s ac = - let !a' = f b c d + x + ac + a - !a'' = rotateL a' s - in a'' + b - {-# INLINE ff #-} - gg a b c d x s ac = - let !a' = g b c d + x + ac + a - !a'' = rotateL a' s - in a'' + b - {-# INLINE gg #-} - hh a b c d x s ac = - let !a' = h b c d + x + ac + a - !a'' = rotateL a' s - in a'' + b - {-# INLINE hh #-} - ii a b c d x s ac = - let !a' = i b c d + x + ac + a - !a'' = rotateL a' s - in a'' + b - {-# INLINE ii #-} - (!!) word32s pos = getNthWord pos word32s - {-# INLINE (!!) #-} - getNthWord n bs@(PS ptr off len) = - inlinePerformIO $ withForeignPtr ptr $ \ptr' -> do - let p = castPtr $ plusPtr ptr' off - peekElemOff p n - {-# INLINE getNthWord #-} -{-# INLINE applyMD5Rounds #-} - ------ Some quick and dirty instances follow ----- - -instance Show MD5Context where - show (MD5Ctx (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 - get = do p <- get - s <- getWord8 - r <- getByteString (fromIntegral s) - l <- getWord64be - return $ MD5Ctx p r l - -instance Binary MD5Partial where - put (MD5Par a b c d) = putWord32be a >> putWord32be b >> putWord32be c >> putWord32be d - get = do a <- getWord32be - b <- getWord32be - c <- getWord32be - d <- getWord32be - return $ MD5Par a b c d - diff --git a/src/Data/Digest/MD5/Rolled.hs b/src/Data/Digest/MD5/Rolled.hs deleted file mode 100644 --- a/src/Data/Digest/MD5/Rolled.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# OPTIONS_GHC -fbang-patterns -funbox-strict-fields -fvia-c -optc-funroll-all-loops -optc-O3 #-} --- --- Module : Crypto.MD5 --- License : BSD3 --- Maintainer : Thomas.DuBuisson@gmail.com --- Stability : experimental --- Portability : portable, requires bang patterns and ByteString --- Tested with : GHC-6.8.0 --- - -module Data.Digest.MD5.Rolled - (md5 - ,md5InitialContext - ,md5Update - ,md5Finalize - ,MD5Context - ,applyMD5Rounds - ) where - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Internal -import Data.Bits -import Data.List as T -import Data.Int (Int64) -import Data.Word -import Foreign.Storable -import Foreign.Ptr -import Foreign.ForeignPtr -import Numeric -import System.Environment -import System.IO -import Data.Binary -import Data.Binary.Get -import Data.Binary.Put - -blockSize = 512 -- Block size in bits -blockSizeBytes = blockSize `div` 8 -blockSizeBytesW64 = fromIntegral blockSizeBytes -blockSizeBits = (fromIntegral blockSize) :: Word64 - -sinConst :: [Word32] -sinConst = [floor(abs(sin(i + 1)) * (2 ^ 32)) | i <- [0..63]] - -roundShift :: [Int] -roundShift = [7, 12, 17, 22, 7, 12, 17, 22, 7, 12, 17, 22, 7, 12, 17, 22, - 5, 9, 14, 20, 5, 9, 14, 20, 5, 9, 14, 20, 5, 9, 14, 20, - 4, 11, 16, 23, 4, 11, 16, 23, 4, 11, 16, 23, 4, 11, 16, 23, - 6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21 ] - -data MD5Partial = MD5Par !Word32 !Word32 !Word32 !Word32 -data MD5Context = MD5Ctx { mdPartial :: MD5Partial, - mdLeftOver :: ByteString, - mdTotalLen :: Word64 - } - -md5InitialContext = MD5Ctx (MD5Par h0 h1 h2 h3) B.empty 0 -h0 = 0x67452301 -h1 = 0xEFCDAB89 -h2 = 0x98BADCFE -h3 = 0x10325476 - --- | Will read the lazy ByteString and return the md5 digest. --- Some application might want to wrap this function for type safty. -md5 :: L.ByteString -> L.ByteString -md5 bs = md5Finalize $ md5Update md5InitialContext bs - -md5Finalize :: MD5Context -> L.ByteString -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' ) - (MD5Ctx (MD5Par a' b' c' d') _ _) = md5Update ctx (L.fromChunks (rem:padBS)) - in runPut ( do - putWord32le a' - putWord32le b' - putWord32le c' - putWord32le d' ) - - where - l = B.length rem - lenZeroPad = if (l+1) <= blockSizeBytes - 8 - then (blockSizeBytes - 8) - (l+1) - else (2*blockSizeBytes - 8) - (l+1) - -md5Update :: MD5Context -> L.ByteString -> MD5Context -md5Update ctx bsLazy = - let blks = block bsLazy - in foldl' performMD5Update ctx blks - -block :: L.ByteString -> [ByteString] -block bs = - case L.toChunks bs of - [] -> [] - otherwise -> (B.concat . L.toChunks) top : block rest - where - (top,rest) = L.splitAt blockSizeBytesW64 bs -{-# INLINE block #-} - --- 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 = - let MD5Par a' b' c' d' = applyMD5Rounds par bs - in if B.length bs == blockSizeBytes - then MD5Ctx { - mdPartial = MD5Par (a' + a) (b' + b) (c' + c) (d' + d), - mdLeftOver = B.empty, - mdTotalLen = len + blockSizeBits - } - else ctx { mdLeftOver = bs } - -applyMD5Rounds :: MD5Partial -> ByteString -> MD5Partial -applyMD5Rounds par@(MD5Par a b c d) w = - foldl' (md5Round w) par [0..63] - -md5Round :: ByteString -> MD5Partial -> Int -> MD5Partial -md5Round w par@(MD5Par a b c d) !r - | r <= 15 = let j = r - b' = ff a b c d (w!!j) rs sc - in MD5Par d b' b c - | r <= 31 = let j = (5*r + 1) `mod` 16 - b' = gg a b c d (w!!j) rs sc - in MD5Par d b' b c - | r <= 47 = let j = (3*r + 5) `mod` 16 - b' = hh a b c d (w!!j) rs sc - in MD5Par d b' b c - | otherwise = let j = (7*r) `mod` 16 - b' = ii a b c d (w!!j) rs sc - in MD5Par d b' b c - where - rs = roundShift T.!! r - sc = sinConst T.!! r - f !x !y !z = (x .&. y) .|. ((complement x) .&. z) - {-# INLINE f #-} - g !x !y !z = (x .&. z) .|. (y .&. (complement z)) - {-# INLINE g #-} - h !x !y !z = (x `xor` y `xor` z) - {-# INLINE h #-} - i !x !y !z = y `xor` (x .|. (complement z)) - {-# INLINE i #-} - ff a b c d x s ac = {-# SCC "ff" #-} - let !a' = f b c d + x + ac + a - !a'' = rotateL a' s - in a'' + b - {-# INLINE ff #-} - gg a b c d x s ac = {-# SCC "gg" #-} - let !a' = g b c d + x + ac + a - !a'' = rotateL a' s - in a'' + b - {-# INLINE gg #-} - hh a b c d x s ac = {-# SCC "hh" #-} - let !a' = h b c d + x + ac + a - !a'' = rotateL a' s - in a'' + b - {-# INLINE hh #-} - ii a b c d x s ac = {-# SCC "ii" #-} - let !a' = i b c d + x + ac + a - !a'' = rotateL a' s - in a'' + b - {-# INLINE ii #-} - (!!) word32s pos = getNthWord pos word32s - {-# INLINE (!!) #-} --- getNthWord n bs = runGet (skip (n*4) >> getWord32le) (L.fromChunks [bs]) - getNthWord n bs@(PS ptr off len) = - inlinePerformIO $ withForeignPtr ptr $ \ptr' -> do - let p = castPtr $ plusPtr ptr' off - peekElemOff p n - {-# INLINE getNthWord #-} -{-# INLINE applyMD5Rounds #-}