> module MD5 (md5,  md5s,  md5i,
>             md5M, md5sM, md5iM,
>             ABCD) where

> import Char
> import Bits
> import Word


Nasty kludge to create a type Zord64 which is really a Word64 but works
how we want in hugs too...

#ifdef __GLASGOW_HASKELL__
#include "ZordGHC.hs"
#else

> import ZordHUGS

#endif


> type ABCD = (Word32, Word32, Word32, Word32)
> type XYZ = (Word32, Word32, Word32)
> type Rotation = Int


The simplest function, gives you the MD5 of a string as 4-tuple of
32bit words.

> md5 :: String -> ABCD
> md5 s = md5_main False 0 magic_numbers s


Returns a hex number ala the md5sum program

> md5s :: String -> String
> md5s = md5_display . md5


Returns an integer equivalent to the above hex number

> md5i :: String -> Integer
> md5i = abcd_to_integer . md5


The first argument is a function that takes an a to a new a (the a is
basically the state of the function) and a bit more of the string. If
the function doesn't return any string when it is called then the string
is assumed to be complete. The next argument is the initial state. Other
than that, and that they clearly need to return values wrapped in a
monad, these functions are equivalent to the above 3.

> md5M :: Monad m => (a -> m (a, String)) -> a -> m ABCD
> md5M f e = do (_, abcd) <- md5M_main False 0 f e ("", magic_numbers)
>               return abcd

> md5sM :: Monad m => (a -> m (a, String)) -> a -> m String
> md5sM f e = do abcd <- md5M f e
>                return $ md5_display abcd

> md5iM :: Monad m => (a -> m (a, String)) -> a -> m Integer
> md5iM f e = do abcd <- md5M f e
>                return $ abcd_to_integer abcd


The magic numbers from the RFC.

> magic_numbers :: ABCD
> magic_numbers = (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476)


Given a string and it's length (mod 2^64), append the padding and
length.

> len_pad :: Zord64 -> String -> String
> len_pad c64 s = s ++ padding ++ len
>  where padding = '\128':replicate (fromIntegral bytes) '\000'
>        bits = (440 - c64) .&. 511
>        bytes = shiftR bits 3
>        len = map chr $ size_split 8 c64


Split the size into character size chunks.

> size_split :: Int -> Zord64 -> [Int]
> size_split 0 _ = []
> size_split p n = fromIntegral d:size_split (p-1) n'
>  where n' = shiftR n 8
>        d = n .&. 255


Decides what to do. The first argument indicates if padding has been
added. The second is the length mod 2^64 so far. Then we have the
starting state, the rest of the string and the final state.

> md5_main :: Bool -> Zord64 -> ABCD -> String -> ABCD
> md5_main True _ abcd "" = abcd
> md5_main padded len (a, b, c, d) s = md5_main padded' (len + 512) abcd s''
>  where (s64, s') = takeDrop 64 s
>        l = length s64
>        len' = len + shiftL (fromIntegral l) 3
>        ((s64', s''), padded') = if not padded && l < 64
>                                 then (takeDrop 64 $ len_pad len' s, True)
>                                 else ((s64, s'), padded)
>        (a', b', c', d') = md5_do_block (a, b, c, d) s64'
>        abcd = (a + a', b + b', c + c', d + d')


Equivalent to md5_main for the monadic functions.

> md5M_main :: Monad m => Bool -> Zord64 -> (a -> m (a, String)) -> a
>                              ->   (String, ABCD)
>                              -> m (String, ABCD)
> md5M_main padded len f e (s, (a, b, c, d))
>  = if length block < 64
>    then if not padded
>         then do (e', s') <- f e
>                 if s' == ""
>                  then md5M_main True 0 f e (len_pad len s, (a, b, c, d))
>                  else let extra_length = fromIntegral $ length s'
>                           len' = (len + shiftL extra_length 3) in
>                       md5M_main False len' f e' (s ++ s', (a, b, c, d))
>         else return ("", (a, b, c, d))
>    else md5M_main padded len f e (rest, (a + a', b + b', c + c', d + d'))
>  where (block, rest) = takeDrop 64 s
>        (a', b', c', d') = md5_do_block (a, b, c, d) block


Process a 64-character (512 bit) block

> md5_do_block :: ABCD -> String -> ABCD
> md5_do_block abcd0 s = abcd4
>  where w = get_word_32s s
>     {- s1 = map (\x -> s0 !! x) [1,6,11,0,5,10,15,4,9,14,3,8,13,2,7,12]
>                              {- [(5 * x + 1) `mod` 16 | x <- [0..15]] -}
>        s2 = map (\x -> s0 !! x) [5,8,11,14,1,4,7,10,13,0,3,6,9,12,15,2]
>                              {- [(3 * x + 5) `mod` 16 | x <- [0..15]] -}
>        s3 = map (\x -> s0 !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9]
>                              {- [(7 * x) `mod` 16 | x <- [0..15]] -} -}
>        (r1, r2, r3, r4) = rounds
>        perm5 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15]
>         = [c1,c6,c11,c0,c5,c10,c15,c4,c9,c14,c3,c8,c13,c2,c7,c12]
>        perm3 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15]
>         = [c5,c8,c11,c14,c1,c4,c7,c10,c13,c0,c3,c6,c9,c12,c15,c2]
>        perm7 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15]
>         = [c0,c7,c14,c5,c12,c3,c10,c1,c8,c15,c6,c13,c4,c11,c2,c9]
>        abcd1 = md5_round md5_f abcd0        w  r1
>        abcd2 = md5_round md5_g abcd1 (perm5 w) r2
>        abcd3 = md5_round md5_h abcd2 (perm3 w) r3
>        abcd4 = md5_round md5_i abcd3 (perm7 w) r4


Convert a 64 byte string to 16 32 bit words

> get_word_32s :: String -> [Word32]
> get_word_32s "" = []
> get_word_32s ss = this:get_word_32s ss'
>  where (s, ss') = takeDrop 4 ss
>        this = foldr (\c i -> shiftL i 8 + (fromIntegral.ord) c) 0 s


Do one of the rounds

> md5_round :: (XYZ -> Word32) -> ABCD -> [Word32]
>                                     -> [(Rotation, Word32)] -> ABCD
> md5_round f (a, b, c, d) s ns = foldl (doit f) (a, b, c, d) ns'
>  where ns' = zipWith (\x (y, z) -> (y, x + z)) s ns


Apply one of the functions md5_[fghi] and put the new ABCD together

> doit :: (XYZ -> Word32) -> ABCD -> (Rotation, Word32) -> ABCD
> doit f (a, b, c, d) (s, ki) = (d, a', b, c)
>  where mid_a = a + f(b,c,d) + ki
>        rot_a = rotL mid_a s
>        a' = b + rot_a

> md5_f :: XYZ -> Word32
> md5_f (x, y, z) = z `xor` (x .&. (y `xor` z))
> {- optimised version of: (x .&. y) .|. ((complement x) .&. z) -}

> md5_g :: XYZ -> Word32
> md5_g (x, y, z) = md5_f (z, x, y)
> {- was: (x .&. z) .|. (y .&. (complement z)) -}

> md5_h :: XYZ -> Word32
> md5_h (x, y, z) = x `xor` y `xor` z

> md5_i :: XYZ -> Word32
> md5_i (x, y, z) = y `xor` (x .|. (complement z))

> rounds :: ([(Rotation, Word32)],
>            [(Rotation, Word32)],
>            [(Rotation, Word32)],
>            [(Rotation, Word32)])
> rounds = (r1, r2, r3, r4)
>  where r1 = [(s11, 0xd76aa478), (s12, 0xe8c7b756), (s13, 0x242070db),
>              (s14, 0xc1bdceee), (s11, 0xf57c0faf), (s12, 0x4787c62a),
>              (s13, 0xa8304613), (s14, 0xfd469501), (s11, 0x698098d8),
>              (s12, 0x8b44f7af), (s13, 0xffff5bb1), (s14, 0x895cd7be),
>              (s11, 0x6b901122), (s12, 0xfd987193), (s13, 0xa679438e),
>              (s14, 0x49b40821)]
>        r2 = [(s21, 0xf61e2562), (s22, 0xc040b340), (s23, 0x265e5a51),
>              (s24, 0xe9b6c7aa), (s21, 0xd62f105d), (s22,  0x2441453),
>              (s23, 0xd8a1e681), (s24, 0xe7d3fbc8), (s21, 0x21e1cde6),
>              (s22, 0xc33707d6), (s23, 0xf4d50d87), (s24, 0x455a14ed),
>              (s21, 0xa9e3e905), (s22, 0xfcefa3f8), (s23, 0x676f02d9),
>              (s24, 0x8d2a4c8a)]
>        r3 = [(s31, 0xfffa3942), (s32, 0x8771f681), (s33, 0x6d9d6122),
>              (s34, 0xfde5380c), (s31, 0xa4beea44), (s32, 0x4bdecfa9),
>              (s33, 0xf6bb4b60), (s34, 0xbebfbc70), (s31, 0x289b7ec6),
>              (s32, 0xeaa127fa), (s33, 0xd4ef3085), (s34,  0x4881d05),
>              (s31, 0xd9d4d039), (s32, 0xe6db99e5), (s33, 0x1fa27cf8),
>              (s34, 0xc4ac5665)]
>        r4 = [(s41, 0xf4292244), (s42, 0x432aff97), (s43, 0xab9423a7),
>              (s44, 0xfc93a039), (s41, 0x655b59c3), (s42, 0x8f0ccc92),
>              (s43, 0xffeff47d), (s44, 0x85845dd1), (s41, 0x6fa87e4f),
>              (s42, 0xfe2ce6e0), (s43, 0xa3014314), (s44, 0x4e0811a1),
>              (s41, 0xf7537e82), (s42, 0xbd3af235), (s43, 0x2ad7d2bb),
>              (s44, 0xeb86d391)]
>        s11 = 7
>        s12 = 12
>        s13 = 17
>        s14 = 22
>        s21 = 5
>        s22 = 9
>        s23 = 14
>        s24 = 20
>        s31 = 4
>        s32 = 11
>        s33 = 16
>        s34 = 23
>        s41 = 6
>        s42 = 10
>        s43 = 15
>        s44 = 21

> takeDrop :: Int -> [a] -> ([a], [a])
> takeDrop _ [] = ([], [])
> takeDrop 0 xs = ([], xs)
> takeDrop n (x:xs) = (x:ys, zs)
>  where (ys, zs) = takeDrop (n-1) xs


Turn the 4 32 bit words into a string representing the hex number they
represent.

> md5_display :: ABCD -> String
> md5_display (a,b,c,d) = concat $ map display_32bits_as_hex [a,b,c,d]


Split the 32 bit word up, swap the chunks over and convert the numbers
to their hex equivalents.

> display_32bits_as_hex :: Word32 -> String
> display_32bits_as_hex w = map getc [y2,y1,y4,y3,y6,y5,y8,y7]
>  where [y1,y2,y3,y4,y5,y6,y7,y8]
>         = map (\x -> (shiftR w (4*x)) .&. 15) [0..7]
>        getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n)


Convert to an integer, performing endianness magic as we go

> abcd_to_integer :: ABCD -> Integer
> abcd_to_integer (a, b, c, d) = toInteger (rev_num a) * 2^(96 :: Int)
>                              + toInteger (rev_num b) * 2^(64 :: Int)
>                              + toInteger (rev_num c) * 2^(32 :: Int)
>                              + toInteger (rev_num d)
>  where rev_num i
>         = foldl (\so_far next -> shiftL so_far 8
>                               + (shiftR i next .&. 255)) 0 [0,8,16,24]


hugs doesn't implement rotateL on Word32s so we write our own

> rotL :: Word32 -> Rotation -> Word32
> rotL a s = shiftL a s .|. shiftL a (s-32)