{-# LANGUAGE BangPatterns, ForeignFunctionInterface, MultiParamTypeClasses, CPP #-} ----------------------------------------------------------------------------- -- -- 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 -- -- | 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: -- -- @ -- hashFileStrict = liftM hash' B.readFile -- hashFileLazyBS = liftM hash B.readFile -- @ -- ----------------------------------------------------------------------------- module Data.Digest.Pure.MD5 ( -- * Types MD5Context , MD5Digest -- * Static data , md5InitialContext -- * Functions , md5 , md5Update , md5Finalize -- * Crypto-API interface , Hash(..) ) where import Data.ByteString.Unsafe (unsafeUseAsCString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString.Unsafe (unsafeDrop) 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 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 Data.Tagged import Numeric -- | Block size in bits md5BlockSize :: Int md5BlockSize = 512 blockSizeBytes = md5BlockSize `div` 8 blockSizeBytesI64 = (fromIntegral blockSizeBytes) :: Int64 blockSizeBits = (fromIntegral md5BlockSize) :: Word64 -- | The type for intermediate results (from md5Update) data MD5Partial = MD5Par {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 deriving (Ord, Eq) -- | The type for final results. 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. data MD5Digest = MD5Digest MD5Partial deriving (Eq, Ord) -- | The initial context to use when calling md5Update for the first time md5InitialContext :: MD5Context md5InitialContext = MD5Ctx (MD5Par h0 h1 h2 h3) 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 = hash -- | Closes an MD5 context, thus producing the digest. 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 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. -- -- 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 :: 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 -- context across calls to applyMD5Rounds. 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 (PS _ off _) = off `rem` 4 == 0 applyMD5Rounds :: MD5Partial -> ByteString -> MD5Partial applyMD5Rounds par@(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 !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 = {-# 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 (!!) #-} {-# INLINE applyMD5Rounds #-} #ifdef FastWordExtract getNthWord n b = inlinePerformIO (unsafeUseAsCString b (flip peekElemOff n . castPtr)) #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 {-# INLINE getNthWord #-} infix 9 .<. (.<.) :: Word8 -> Int -> Word32 (.<.) w i = (fromIntegral w) `shiftL` i ----- Some quick and dirty instances follow ----- instance Show MD5Digest where show (MD5Digest h) = show h 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 MD5Digest where put (MD5Digest p) = put p get = do p <- get return $ MD5Digest p instance Binary MD5Context where put (MD5Ctx p l) = put p >> putWord64be l get = do p <- get l <- getWord64be return $ MD5Ctx p l instance Binary MD5Partial where put (MD5Par a b c d) = putWord32le a >> putWord32le b >> putWord32le c >> putWord32le d get = do a <- getWord32le b <- getWord32le 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) = 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