RosettaCodeData/Task/MD5-Implementation/Haskell/md5-implementation.hs

import Control.Monad (replicateM)

import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import Data.Binary.Get
import Data.Binary.Put
import Data.Bits

import Data.Array (Array, listArray, (!))
import Data.List (foldl)
import Data.Word (Word32)

import Numeric (showHex)


-- functions
type Fun = Word32 -> Word32 -> Word32 -> Word32

funF, funG, funH, funI :: Fun
funF x y z = (x .&. y) .|. (complement x .&. z)
funG x y z = (x .&. z) .|. (complement z .&. y)
funH x y z = x `xor` y `xor` z
funI x y z = y `xor` (complement z .|. x)

idxF, idxG, idxH, idxI :: Int -> Int
idxF i = i
idxG i = (5 * i + 1) `mod` 16
idxH i = (3 * i + 5) `mod` 16
idxI i = 7 * i `mod` 16


-- arrays
funA :: Array Int Fun
funA = listArray (1,64) $ replicate 16 =<< [funF, funG, funH, funI]

idxA :: Array Int Int
idxA = listArray (1,64) $ zipWith ($) (replicate 16 =<< [idxF, idxG, idxH, idxI]) [0..63]

rotA :: Array Int Int
rotA = listArray (1,64) $ concat . replicate 4 =<<
       [[7, 12, 17, 22], [5, 9, 14, 20], [4, 11, 16, 23], [6, 10, 15, 21]]

sinA :: Array Int Word32
sinA = listArray (1,64) $ map (floor . (*mult) . abs . sin) [1..64]
    where mult = 2 ** 32 :: Double


-- to lazily calculate MD5 sum for standart input:
-- main = putStrLn . md5sum =<< BL.getContents

main :: IO ()
main = mapM_ (putStrLn . md5sum . BLC.pack)
        [ ""
        , "a"
        , "abc"
        , "message digest"
        , "abcdefghijklmnopqrstuvwxyz"
        , "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
        , "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
        ]


md5sum :: BL.ByteString -> String
md5sum input =
    let MD5 a b c d = getMD5 initial `runGet` input
    in  foldr hex [] . BL.unpack . runPut $ mapM_ putWord32le [a,b,c,d]
    where
      initial = MD5 0x67452301 0xEFCDAB89 0x98BADCFE 0x10325476

      hex x s | x < 16    = '0' : showHex x s -- quick hack: like "%02x"
              | otherwise =       showHex x s


data MD5 = MD5
    { a :: {-# UNPACK #-} !Word32
    , b :: {-# UNPACK #-} !Word32
    , c :: {-# UNPACK #-} !Word32
    , d :: {-# UNPACK #-} !Word32
    }


getMD5 :: MD5 -> Get MD5
getMD5 md5 = do
  chunk <- getLazyByteString 64
  let len = BL.length chunk

  if len == 64
  then getMD5 $! md5 <+> chunk  -- apply and process next chunk

  else do                       -- input is totally eaten, finalize
    bytes <- bytesRead
    let fin   = runPut . putWord64le $ fromIntegral (bytes - 64 + len) * 8
        pad n = chunk `BL.append` (0x80 `BL.cons` BL.replicate (n - 1) 0x00)

    return $ if len >= 56
        then md5 <+> pad (64 - len) <+> BL.replicate 56 0x00 `BL.append` fin
        else md5 <+> pad (56 - len) `BL.append` fin


(<+>) :: MD5 -> BL.ByteString -> MD5
infixl 5  <+>
md5@(MD5 a b c d) <+> bs =
    let datA = listArray (0,15) $ replicateM 16 getWord32le `runGet` bs
        MD5 a' b' c' d' = foldl' (md5round datA) md5 [1..64]
    in MD5 (a + a') (b + b') (c + c') (d + d')


md5round :: Array Int Word32 -> MD5 -> Int -> MD5
md5round datA (MD5 a b c d) i =
    let f  =  funA ! i
        w  =  datA ! (idxA ! i)
        a' =  b + (a + f b c d + w + sinA ! i) `rotateL` rotA ! i
    in MD5 d a' b c