> module Main where

> import MD5
> import Maybe
> import Monad
> import Word
> import Bits
> import Char

> class (MD5 a) => MD5Test a where
>  getDrop_bits :: Int -> a -> (a, a) -- like splitAt

> instance MD5Test [Bool] where
>  getDrop_bits = splitAt

> instance MD5Test String where
>  getDrop_bits n = splitAt $ n `div` 8  -- Only works for n = 8 * m

> instance MD5Test ([Word32], Zord64) where
>  getDrop_bits _ (_, 0) = (([], 0), ([], 0))  -- These two should
>  getDrop_bits _ ([], _) = (([], 0), ([], 0)) -- be identical
>  getDrop_bits 0 (xs, xl) = (([], 0), (xs, xl))
>  getDrop_bits m (x:xs, xl)
>      | fromIntegral m >= xl = ((x:xs, xl), ([], 0))
>      | m >= 32 = ((x:ys, yl + 32), (zs, zl))
>      | otherwise = (([bit_fiddle wanted_x'], wanted_length),
>                     combine ([bit_fiddle unwanted_x'], unwanted_length)
>                             (xs, rest_length)
>                    )
>   where ((ys, yl), (zs, zl)) = getDrop_bits (m - 32) (xs, xl - 32)
>         x' = bit_fiddle x
>         wanted_x' = x' .&. (complement (2^(32 - m) - 1))
>         unwanted_x' = shiftL (x' .&. (2^(32 - m) - 1)) m
>         m' = fromIntegral m
>         wanted_length = if xl > m' then m' else xl
>         unwanted_length = if xl >= 32 then 32 - wanted_length
>                                       else xl - wanted_length
>         rest_length = xl - wanted_length - unwanted_length


> bit_fiddle :: Word32 -> Word32
> bit_fiddle w = shiftL w 24 + (shiftL w 8 .&. shiftL 255 16)
>              + shiftR w 24 + (shiftR w 8 .&. shiftL 255 8)


> count_results :: (Int, Int) -> [IO(Int, Int)] -> IO(Int, Int)
> count_results ii [] = return ii
> count_results (ok1, fail1) (x:xs)
>  = do (ok2, fail2) <- x
>       count_results (ok1 + ok2, fail1 + fail2) xs

> main :: IO()
> main = do putStr "\n"
>           putStr "MD5 test suite\n"
>           putStr "==============\n\n"
>           (ok, failed) <- count_results (0,0) tests
>           putStr "Total OK: "
>           putStr $ show ok
>           putStr "\n"
>           putStr "Total Failed: "
>           putStr $ show failed
>           putStr "\n\n"

> tests :: [IO(Int, Int)]
> tests = [test_0bit
>         ,test_1bit
>         ,test_7bit
>         ,test_8bit
>         ,test_9bit
>         ,test_16bit
>         ,test_17bit
>         ,test_21bit
>         ,test_23bit
>         ,test_24bit
>         ,test_25bit
>         ,test_31bit
>         ,test_32bit
>         ,test_33bit
>         ,test_40bit
>         ,test_440bit
>         ,test_447bit
>         ,test_448bit
>         ,test_449bit
>         ,test_456bit
>         ,test_504bit
>         ,test_511bit
>         ,test_512bit
>         ,test_513bit
>         ,test_520bit
>         ]

> test_0bit :: IO(Int, Int)
> test_0bit = test "0 bit"
>                  (Just "")
>                  []
>                  ([], 0)
>                  ((3649838548,78774415,2550759657,2118318316),
>                   "d41d8cd98f00b204e9800998ecf8427e",
>                   281949768489412648962353822266799178366)

> test_1bit :: IO(Int, Int)
> test_1bit = test "1 bit"
>                  Nothing
>                  [True]
>                  ([128], 1)
>                  ((272066174,3209175982,751495693,2921214329),
>                   "7e663710ae2348bf0deaca2c79311eae",
>                   168013458602541801121410793648038157998)

> test_7bit :: IO(Int, Int)
> test_7bit = test "7 bit"
>                  Nothing
>                  bs
>                  (string_to_word32s $ bools_to_string bs,
>                   fromIntegral $ length bs)
>                  ((3874223782,2323395709,238016611,1952053381),
>                   "a6f6ebe67d347c8a63d82f0e85f85974",
>                   221933936954978917418574952682441169268)
>  where bs = take 7 $ cycle [True, False, True, False, True]

> test_8bit :: IO(Int, Int)
> test_8bit = test "8 bit"
>                  (Just "a")
>                  (char_to_bools 'a')
>                  (string_to_word32s "a", 8)
>                  ((3111502092,2830561728,3801727793,1629910889),
>                   "0cc175b9c0f1b6a831c399e269772661",
>                   16955237001963240173058271559858726497)

> test_9bit :: IO(Int, Int)
> test_9bit = test "9 bit"
>                  Nothing
>                  bs
>                  (string_to_word32s $ bools_to_string bs,
>                   fromIntegral $ length bs)
>                  ((3073956015,1560736200,2585607869,1030470636),
>                   "afd838b7c8f1065dbd3e1d9aecbb6b3d",
>                   233737585759683728280024948142665067325)
>  where bs = take 9 $ cycle [True, False, True, False, True]

> test_16bit :: IO(Int, Int)
> test_16bit = test "16 bit"
>                   (Just "ab")
>                   (concat $ map char_to_bools "ab")
>                   (string_to_word32s "ab", 16)
>                   ((1140096536,3436257889,735854639,2699817106),
>                    "187ef4436122d1cc2f40dc2b92f0eba0",
>                    32560655549305688865853317129809488800)

> test_17bit :: IO(Int, Int)
> test_17bit = test "17 bit"
>                   Nothing
>                   bs
>                   (string_to_word32s $ bools_to_string bs,
>                    fromIntegral $ length bs)
>                   ((3600379153,3154230051,1518575401,1699697739),
>                    "116d99d623bb01bc299f835a4b544f65",
>                    23165956460478055474386295161267441509)
>  where bs = take 17 $ cycle [True, False, True, False, True]

> test_21bit :: IO(Int, Int)
> test_21bit = test "21 bit"
>                   Nothing
>                   bs
>                   (string_to_word32s $ bools_to_string bs,
>                    fromIntegral $ length bs)
>                   ((3016030143,592975423,115126882,2320915544),
>                    "bff7c4b33f16582362b2dc06585c568a",
>                    255169034072625008137368488973981996682)
>  where bs = take 21 $ cycle [True, False, True, False, True]

> test_23bit :: IO(Int, Int)
> test_23bit = test "23 bit"
>                   Nothing
>                   bs
>                   (string_to_word32s $ bools_to_string bs,
>                    fromIntegral $ length bs)
>                   ((2817603430,1893037087,336283538,3113257946),
>                    "6637f1a71f74d57092470b14da8b90b9",
>                    135871733198833733130647634097814081721)
>  where bs = take 23 $ cycle [True, False, True, False, True]

> test_24bit :: IO(Int, Int)
> test_24bit = test "24 bit"
>                   (Just "abc")
>                   (concat $ map char_to_bools "abc")
>                   (string_to_word32s "abc", 24)
>                   ((2555380112,2958021180,2101319382,1920983336),
>                    "900150983cd24fb0d6963f7d28e17f72",
>                    191415658344158766168031473277922803570)

> test_25bit :: IO(Int, Int)
> test_25bit = test "25 bit"
>                   Nothing
>                   bs
>                   (string_to_word32s $ bools_to_string bs,
>                    fromIntegral $ length bs)
>                   ((2146107602,447910356,3861996385,1949814853),
>                    "d200eb7fd491b21a616331e645d03774",
>                    279142655608852788157756064665745504116)
>  where bs = take 25 $ cycle [True, False, True, False, True]

> test_31bit :: IO(Int, Int)
> test_31bit = test "31 bit"
>                    Nothing
>                    bs
>                    (string_to_word32s $ bools_to_string bs,
>                     fromIntegral $ length bs)
>                    ((3148654028,3251176583,3327096227,396272808),
>                     "cca5acbb8704c9c1a3754fc6a8a49e17",
>                     272022743553685567682651335045736078871)
>  where bs = take 31 $ cycle [True, False, True, False, True]

> test_32bit :: IO(Int, Int)
> test_32bit = test "32 bit"
>                   (Just "abcd")
>                   (concat $ map char_to_bools "abcd")
>                   (string_to_word32s "abcd", 32)
>                   ((1282538722,2481858375,3441750933,523468590),
>                    "e2fc714c4727ee9395f324cd2e7f331f",
>                    301716283811389038011477436469853762335)

> test_33bit :: IO(Int, Int)
> test_33bit = test "33 bit"
>                    Nothing
>                    bs
>                    (string_to_word32s $ bools_to_string bs,
>                     fromIntegral $ length bs)
>                    ((1520634312,789137520,774383623,2149163117),
>                     "c809a35a7048092f0728282e6da01980",
>                     265895643026759416663301597970063956352)
>  where bs = take 33 $ cycle [True, False, True, False, True]

> test_40bit :: IO(Int, Int)
> test_40bit = test "40 bit"
>                   (Just "abcde")
>                   (concat $ map char_to_bools "abcde")
>                   (string_to_word32s "abcde", 40)
>                   ((3652474539,980500523,2583190220,2260194437),
>                    "ab56b4d92b40713acc5af89985d4b786",
>                    227748192848680293725464448333830731654)

> test_440bit :: IO(Int, Int)
> test_440bit = test "440 bit"
>                    (Just m_s)
>                    bs
>                    (string_to_word32s m_s,
>                     fromIntegral $ 8 * length m_s)
>                    ((2129780455,1829200469,2963858748,3872126999),
>                     "e7def17e5562076d3ce5a8b017f8cbe6",
>                     308209254998797990860977056692741655526)
>  where m_s = take 55 $ cycle "abcdefg"
>        bs = take 440 $ cycle $ concat $ map char_to_bools "abcdefg"

> test_447bit :: IO(Int, Int)
> test_447bit = test "447 bit"
>                    Nothing
>                    bs
>                    (string_to_word32s $ bools_to_string bs,
>                     fromIntegral $ length bs)
>                    ((146018617,419045834,2338281671,4179882525),
>                     "3911b408ca21fa18c7585f8b1df223f9",
>                     75857916336446301824658930015268905977)
>  where bs = take 447 $ cycle [True, False, True, False, True]

> test_448bit :: IO(Int, Int)
> test_448bit = test "448 bit"
>                    (Just m_s)
>                    bs
>                    (string_to_word32s m_s,
>                     fromIntegral $ 8 * length m_s)
>                    ((272111924,677845269,2833319824,3656850596),
>                     "34193810151967289007e1a8a41cf7d9",
>                     69250800291397296307218994760733489113)
>  where m_s = take 56 $ cycle "abcdefg"
>        bs = take 448 $ cycle $ concat $ map char_to_bools "abcdefg"

> test_449bit :: IO(Int, Int)
> test_449bit = test "449 bit"
>                    Nothing
>                    bs
>                    (string_to_word32s $ bools_to_string bs,
>                     fromIntegral $ length bs)
>                    ((3601628369,1310326814,2751960693,1362514509),
>                     "d17cacd61e001a4e759607a44d523651",
>                     278456001468069016726202533662103320145)
>  where bs = take 449 $ cycle [True, False, True, False, True]


> test_456bit :: IO(Int, Int)
> test_456bit = test "456 bit"
>                    (Just m_s)
>                    bs
>                    (string_to_word32s m_s,
>                     fromIntegral $ 8 * length m_s)
>                    ((279449730,856127161,3308518469,3347659648),
>                     "8210a810b976073345fc33c5803b89c7",
>                     172886124971637048494467684822136097223)
>  where m_s = take 57 $ cycle "abcdefg"
>        bs = take 456 $ cycle $ concat $ map char_to_bools "abcdefg"

> test_504bit :: IO(Int, Int)
> test_504bit = test "504 bit"
>                    (Just m_s)
>                    bs
>                    (string_to_word32s m_s,
>                     fromIntegral $ 8 * length m_s)
>                    ((2956572680,1313635985,3566901056,574489456),
>                     "08b839b0917e4c4e40979ad470033e22",
>                     11590376674781757343337222324479016482)
>  where m_s = take 63 $ cycle "abcdefg"
>        bs = take 504 $ cycle $ concat $ map char_to_bools "abcdefg"

> test_511bit :: IO(Int, Int)
> test_511bit = test "511 bit"
>                    Nothing
>                    bs
>                    (string_to_word32s $ bools_to_string bs,
>                     fromIntegral $ length bs)
>                    ((2264330280,2921290735,2761951796,3504581562),
>                     "28f0f686ef5b1fae340aa0a4baabe3d0",
>                     54420271240858347973075956822623118288)
>  where bs = take 511 $ cycle [True, False, True, False, True]

> test_512bit :: IO(Int, Int)
> test_512bit = test "512 bit"
>                    (Just m_s)
>                    bs
>                    (string_to_word32s m_s,
>                     fromIntegral $ 8 * length m_s)
>                    ((2109724156,489761275,3318408917,910478853),
>                     "fcd5bf7dfb29311dd5e6cac505ce4436",
>                     336075298090151865378817828545312474166)
>  where m_s = take 64 $ cycle "abcdefg"
>        bs = take 512 $ cycle $ concat $ map char_to_bools "abcdefg"

> test_513bit :: IO(Int, Int)
> test_513bit = test "513 bit"
>                    Nothing
>                    bs
>                    (string_to_word32s $ bools_to_string bs,
>                     fromIntegral $ length bs)
>                    ((4120376527,4030448340,1842259211,293161983),
>                     "cff497f5d4c23bf00ba5ce6dff4b7911",
>                     276420197681555687768256992541883988241)
>  where bs = take 513 $ cycle [True, False, True, False, True]

> test_520bit :: IO(Int, Int)
> test_520bit = test "520 bit"
>                    (Just m_s)
>                    bs
>                    (string_to_word32s m_s,
>                     fromIntegral $ 8 * length m_s)
>                    ((2047994787,3293532858,2497755399,2821287797),
>                     "a3eb117aba524fc407b9e094756f29a8",
>                     217884707599159781021720901460062841256)
>  where m_s = take 65 $ cycle "abcdefg"
>        bs = take 520 $ cycle $ concat $ map char_to_bools "abcdefg"

> test :: String                                       -- test name
>      -> Maybe String -> [Bool] -> ([Word32], Zord64) -- inputs
>      -> (ABCD, String, Integer)                      -- expected results
>      -> IO(Int, Int)                                 -- (ok, failed)
> test text m_s bs ws_z answers =
>  do putStr $ "Doing " ++ text                        ++ " test:\n"
>     putStr $ "------" ++ replicate (length text) '-' ++ "------\n"
>     (ok1, failed1) <- case m_s of
>                           Nothing -> return (0, 0)
>                           Just s -> test_all False "String" s answers
>     (ok2, failed2) <- test_all True "[Bool]" bs answers
>     (ok3, failed3) <- test_all True "W32,64" ws_z answers
>     return (ok1 + ok2 + ok3, failed1 + failed2 + failed3)

> test_all :: (MD5Test a) =>
>             Bool                    -- can a represent values with
>                                     -- length not a multiple of 8?
>          -> String                  -- test name
>          -> a                       -- value to be hashed
>          -> (ABCD, String, Integer) -- expected results
>          -> IO(Int, Int)            -- (ok, failed)
> test_all do_non_8 text m answers =
>  do (ok1, failed1) <- test_normal text m answers
>     (ok2, failed2) <- test_monad text "Mall:" monad_all m answers
>     (ok3, failed3) <- if do_non_8
>                       then test_monad text "M1:" (monad_bits 1) m answers
>                       else return (0, 0)
>     (ok4, failed4) <- if do_non_8
>                       then test_monad text "M3:" (monad_bits 3) m answers
>                       else return (0, 0)
>     (ok5, failed5) <- test_monad text "M8:"  (monad_bits 8)  m answers
>     (ok6, failed6) <- test_monad text "M24:" (monad_bits 24) m answers
>     putStr "\n"
>     return (ok1     + ok2     + ok3     + ok4     + ok5     + ok6,
>             failed1 + failed2 + failed3 + failed4 + failed5 + failed6)

> test_normal :: (MD5Test a) =>
>                String                  -- test name
>             -> a                       -- value to be hashed
>             -> (ABCD, String, Integer) -- expected results
>             -> IO(Int, Int)            -- (ok, failed)
> test_normal text m (abcd, s, i) =
>  do putStr $ text ++ ":" ++ replicate (11 - length text) ' '
>     putStr " md5 "
>     let (str1, ok1, failed1) = do_test abcd $ md5 m
>     putStr str1
>     putStr " md5s "
>     let (str2, ok2, failed2) = do_test s $ md5s m
>     putStr str2
>     putStr " md5i "
>     let (str3, ok3, failed3) = do_test i $ md5i m
>     putStr str3
>     putStr "\n"
>     return (ok1 + ok2 + ok3, failed1 + failed2 + failed3)

> test_monad :: (MD5Test a) =>
>               String -> String        -- test name, type
>            -> (a -> IO (a, a)) -> a   -- monadic function and initial state
>            -> (ABCD, String, Integer) -- expected results
>            -> IO(Int, Int)            -- (ok, failed)
> test_monad text_desc text_type f m (abcd, s, i) =
>  do putStr text_desc
>     putStr text_type
>     putStr $ replicate (12 - length text_desc - length text_type) ' '
>     putStr " md5 "
>     (str1, ok1, failed1) <- (liftM (do_test abcd) $ md5M f m)
>     putStr str1
>     putStr " md5s "
>     (str2, ok2, failed2) <- (liftM (do_test s) $ md5sM f m)
>     putStr str2
>     putStr " md5i "
>     (str3, ok3, failed3) <- (liftM (do_test i) $ md5iM f m)
>     putStr str3
>     putStr "\n"
>     return (ok1 + ok2 + ok3, failed1 + failed2 + failed3)

> do_test :: (Eq a) => a -> a -> (String, Int, Int)
> do_test a b = if a == b then ("\027[32mOK\027[0m.    ", 1, 0)
>                         else ("\027[31mFAILED\027[0m.", 0, 1)

> monad_all :: (MD5Test a) => a -> IO (a, a)
> monad_all m = return (zero, m)

> monad_bits :: (MD5Test a) => Int -> a -> IO (a, a)
> monad_bits b m = return (m', c)
>  where (c, m') = getDrop_bits b m

> char_to_bools :: Char -> [Bool]
> char_to_bools 'a' = [False, True, True, False, False, False, False, True]
> char_to_bools 'b' = [False, True, True, False, False, False, True, False]
> char_to_bools 'c' = [False, True, True, False, False, False, True, True]
> char_to_bools 'd' = [False, True, True, False, False, True, False, False]
> char_to_bools 'e' = [False, True, True, False, False, True, False, True]
> char_to_bools 'f' = [False, True, True, False, False, True, True, False]
> char_to_bools 'g' = [False, True, True, False, False, True, True, True]
> char_to_bools _ = undefined

> bools_to_string :: [Bool] -> String
> bools_to_string [] = ""
> bools_to_string bs = this:bools_to_string rest
>  where (these, rest) = splitAt 8 bs
>        these' = these ++ replicate (8 - length these) False
>        this = chr $ foldl (\i b -> 2 * i + if b then 1 else 0) 0 these'

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