> module MD5 (md5) where > import Char > import Bits > import Word #ifdef __GLASGOW_HASKELL__ #include "ZordGHC.hs" #else > import ZordHUGS > import Trace #endif > type ABCD = (Word32, Word32, Word32, Word32) > type XYZ = (Word32, Word32, Word32) > type Rotation = Int MD5 test suite: MD5 ("") = d41d8cd98f00b204e9800998ecf8427e MD5 ("a") = 0cc175b9c0f1b6a831c399e269772661 MD5 ("abc") = 900150983cd24fb0d6963f7d28e17f72 MD5 ("message digest") = f96b697d7cb7938d525a2f31aaf161d0 MD5 ("abcdefghijklmnopqrstuvwxyz") = c3fcd3d76192e4007dfb496cca67e13b MD5 ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789") = d174ab98d277d9f5a5611c2c9f419d9f MD5 ("123456789012345678901234567890123456789012345678901234567890123456 78901234567890") = 57edf4a22be3c955ac49da2e2107b67a md5test :: IO() md5test = foldr (\x y -> putStr (md5 x) >> putStr "\n" >> y) (putStr "") ["", "a", "abc", "message digest", "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789", "12345678901234567890123456789012345678901234567890123456789012345678901234567890"] MD5> md5test d41d8cd98f00b204e9800998ecf8427e 0cc175b9c0f1b6a831c399e269772661 900150983cd24fb0d6963f7d28e17f72 f96b697d7cb7938d525a2f31aaf161d0 c3fcd3d76192e4007dfb496cca67e13b d174ab98d277d9f5a5611c2c9f419d9f 57edf4a22be3c955ac49da2e2107b67a MD5> > md5 :: String -> String > md5 s = md5_display abcd > where magic_numbers = (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476) > abcd = md5_main False 0 magic_numbers s > len_pad :: Zord64 -> String -> (String, String) > len_pad c64 s = takeDrop 64 rest > where rest = s ++ padding ++ len > 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) abcd5 s'' > where (s64, s') = takeDrop 64 s > l = length s64 > ((s64', s''), padded') > = if not padded && l < 64 > then (len_pad (len + shiftL (fromIntegral l) 3) s64, True) > else ((s64, s'), padded) > (r1, r2, r3, r4) = rounds > abcd0 = (a, b, c, d) > abcd1 = md5_round md5_f abcd0 s16_0 r1 > abcd2 = md5_round md5_g abcd1 s16_1 r2 > abcd3 = md5_round md5_h abcd2 s16_2 r3 > abcd4 = md5_round md5_i abcd3 s16_3 r4 > (a', b', c', d') = abcd4 > abcd5 = (a + a', b + b', c + c', d + d') > s16_0 = get_word_32s s64' > s16_1 = map (\x -> s16_0 !! 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]] -} > s16_2 = map (\x -> s16_0 !! 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]] -} > s16_3 = map (\x -> s16_0 !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9] > {- [(7 * x) `mod` 16 | x <- [0..15]] -} > get_word_32s :: String -> [Word32] > get_word_32s "" = [] > get_word_32s ss = this:rest > where (s, ss') = takeDrop 4 ss > this = sum $ zipWith shiftL (map (fromIntegral.ord) s) [0, 8, 16, 24] > rest = get_word_32s ss' > 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) > rotL :: Word32 -> Rotation -> Word32 > rotL a s = shiftL a s .|. shiftL a (s-32)