> module MD5 (md5, md5s, md5i, > md5M, md5sM, md5iM, > ABCD) where > import Char > import Bits > import Word #ifdef __GLASGOW_HASKELL__ #include "ZordGHC.hs" #else > import ZordHUGS #endif > type ABCD = (Word32, Word32, Word32, Word32) > type XYZ = (Word32, Word32, Word32) > type Rotation = Int > md5 :: String -> ABCD > md5 s = md5_main False 0 magic_numbers s > md5s :: String -> String > md5s = md5_display . md5 > md5i :: String -> Integer > md5i = abcd_to_integer . md5 > 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 > magic_numbers :: ABCD > magic_numbers = (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476) > 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 > 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 > 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') > 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 > 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 > 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 > 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 > 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 > md5_display :: ABCD -> String > md5_display (a,b,c,d) = concat $ map display_32bits_as_hex [a,b,c,d] > display_32bits_as_hex :: Word32 -> String > display_32bits_as_hex x0 = map getc [y2,y1,y4,y3,y6,y5,y8,y7] > where (x1, y1) = divMod x0 16 > (x2, y2) = divMod x1 16 > (x3, y3) = divMod x2 16 > (x4, y4) = divMod x3 16 > (x5, y5) = divMod x4 16 > (x6, y6) = divMod x5 16 > (y8, y7) = divMod x6 16 > getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n) abcd_to_integer :: ABCD -> Integer abcd_to_integer (a, b, c, d) = 2^96 * toInteger a + 2^64 * toInteger b + 2^32 * toInteger c + toInteger d > abcd_to_integer :: ABCD -> Integer > abcd_to_integer (a, b, c, d) = toInteger a * 2^(96 :: Int) > + toInteger b * 2^(64 :: Int) > + toInteger c * 2^(32 :: Int) > + toInteger d > rotL :: Word32 -> Rotation -> Word32 > rotL a s = shiftL a s .|. shiftL a (s-32)