module Network.HTTP.MD5Aux 
   (md5,  md5s,  md5i,
    MD5(..), ABCD(..), 
    Zord64, Str(..), BoolList(..), WordList(..)) where

import Data.Char (ord, chr)
import Data.Bits (rotateL, shiftL, shiftR, (.&.), (.|.), xor, complement)
import Data.Word (Word32, Word64)

rotL :: Word32 -> Int -> Word32
rotL :: Word32 -> Int -> Word32
rotL Word32
x = Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
rotateL Word32
x

type Zord64 = Word64

-- ===================== TYPES AND CLASS DEFINTIONS ========================


type XYZ = (Word32, Word32, Word32)
type Rotation = Int
newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (ABCD -> ABCD -> Bool
(ABCD -> ABCD -> Bool) -> (ABCD -> ABCD -> Bool) -> Eq ABCD
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ABCD -> ABCD -> Bool
$c/= :: ABCD -> ABCD -> Bool
== :: ABCD -> ABCD -> Bool
$c== :: ABCD -> ABCD -> Bool
Eq, Int -> ABCD -> ShowS
[ABCD] -> ShowS
ABCD -> String
(Int -> ABCD -> ShowS)
-> (ABCD -> String) -> ([ABCD] -> ShowS) -> Show ABCD
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ABCD] -> ShowS
$cshowList :: [ABCD] -> ShowS
show :: ABCD -> String
$cshow :: ABCD -> String
showsPrec :: Int -> ABCD -> ShowS
$cshowsPrec :: Int -> ABCD -> ShowS
Show)
newtype Str = Str String
newtype BoolList = BoolList [Bool]
newtype WordList = WordList ([Word32], Word64)

-- Anything we want to work out the MD5 of must be an instance of class MD5

class MD5 a where
 get_next :: a -> ([Word32], Int, a) -- get the next blocks worth
 --                     \      \   \------ the rest of the input
 --                      \      \--------- the number of bits returned
 --                       \--------------- the bits returned in 32bit words
 len_pad :: Word64 -> a -> a         -- append the padding and length
 finished :: a -> Bool               -- Have we run out of input yet?


-- Mainly exists because it's fairly easy to do MD5s on input where the
-- length is not a multiple of 8

instance MD5 BoolList where
 get_next :: BoolList -> ([Word32], Int, BoolList)
get_next (BoolList [Bool]
s) = ([Bool] -> [Word32]
bools_to_word32s [Bool]
ys, [Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool]
ys, [Bool] -> BoolList
BoolList [Bool]
zs)
  where ([Bool]
ys, [Bool]
zs) = Int -> [Bool] -> ([Bool], [Bool])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
512 [Bool]
s
 len_pad :: Word64 -> BoolList -> BoolList
len_pad Word64
l (BoolList [Bool]
bs)
  = [Bool] -> BoolList
BoolList ([Bool]
bs [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ [Bool
True]
                 [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Int -> Bool -> [Bool]
forall a. Int -> a -> [a]
replicate (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ (Word64
447 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
l) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
511) Bool
False
                 [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ [Word64
l Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. (Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftL Word64
1 Int
x) Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
0 | Int
x <- ([Int] -> [Int]
forall a. [a] -> [a]
mangle [Int
0..Int
63])]
             )
  where mangle :: [a] -> [a]
mangle [] = []
        mangle [a]
xs = [a] -> [a]
forall a. [a] -> [a]
reverse [a]
ys [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
mangle [a]
zs
         where ([a]
ys, [a]
zs) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
8 [a]
xs
 finished :: BoolList -> Bool
finished (BoolList [Bool]
s) = [Bool]
s [Bool] -> [Bool] -> Bool
forall a. Eq a => a -> a -> Bool
== []


-- The string instance is fairly straightforward

instance MD5 Str where
 get_next :: Str -> ([Word32], Int, Str)
get_next (Str String
s) = (String -> [Word32]
string_to_word32s String
ys, Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ys, String -> Str
Str String
zs)
  where (String
ys, String
zs) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
64 String
s
 len_pad :: Word64 -> Str -> Str
len_pad Word64
c64 (Str String
s) = String -> Str
Str (String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
padding String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l)
  where padding :: String
padding = Char
'\128'Char -> ShowS
forall a. a -> [a] -> [a]
:Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
zeros) Char
'\000'
        zeros :: Word64
zeros = Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftR ((Word64
440 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
c64) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
511) Int
3
        l :: String
l = Int -> Word64 -> String
length_to_chars Int
8 Word64
c64
 finished :: Str -> Bool
finished (Str String
s) = String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
""


-- YA instance that is believed will be useful

instance MD5 WordList where
 get_next :: WordList -> ([Word32], Int, WordList)
get_next (WordList ([Word32]
ws, Word64
l)) = ([Word32]
xs, Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
taken, ([Word32], Word64) -> WordList
WordList ([Word32]
ys, Word64
l Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
taken))
  where ([Word32]
xs, [Word32]
ys) = Int -> [Word32] -> ([Word32], [Word32])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
16 [Word32]
ws
        taken :: Word64
taken = if Word64
l Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
511 then Word64
512 else Word64
l Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
511
 len_pad :: Word64 -> WordList -> WordList
len_pad Word64
c64 (WordList ([Word32]
ws, Word64
l)) = ([Word32], Word64) -> WordList
WordList ([Word32]
beginning [Word32] -> [Word32] -> [Word32]
forall a. [a] -> [a] -> [a]
++ [Word32]
nextish [Word32] -> [Word32] -> [Word32]
forall a. [a] -> [a] -> [a]
++ [Word32]
blanks [Word32] -> [Word32] -> [Word32]
forall a. [a] -> [a] -> [a]
++ [Word32]
size, Word64
newlen)
  where beginning :: [Word32]
beginning = if [Word32] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word32]
ws Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then [Word32]
start [Word32] -> [Word32] -> [Word32]
forall a. [a] -> [a] -> [a]
++ [Word32]
lastone' else []
        start :: [Word32]
start = [Word32] -> [Word32]
forall a. [a] -> [a]
init [Word32]
ws
        lastone :: Word32
lastone = [Word32] -> Word32
forall a. [a] -> a
last [Word32]
ws
        offset :: Word64
offset = Word64
c64 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
31
        lastone' :: [Word32]
lastone' = [if Word64
offset Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
0 then Word32
lastone Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
theone else Word32
lastone]
        theone :: Word32
theone = Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR Word32
128 (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ Word64
offset Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
7))
                        (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ Word64
offset Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. (Word64
31 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
7))
        nextish :: [Word32]
nextish = if Word64
offset Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 then [Word32
128] else []
        c64' :: Word64
c64' = Word64
c64 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ (Word64
32 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
offset)
        num_blanks :: Int
num_blanks = (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftR ((Word64
448 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
c64') Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
511) Int
5)
        blanks :: [Word32]
blanks = Int -> Word32 -> [Word32]
forall a. Int -> a -> [a]
replicate Int
num_blanks Word32
0
        lowsize :: Word32
lowsize = Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word32) -> Word64 -> Word32
forall a b. (a -> b) -> a -> b
$ Word64
c64 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. (Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftL Word64
1 Int
32 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1)
        topsize :: Word32
topsize = Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word32) -> Word64 -> Word32
forall a b. (a -> b) -> a -> b
$ Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftR Word64
c64 Int
32
        size :: [Word32]
size = [Word32
lowsize, Word32
topsize]
        newlen :: Word64
newlen = Word64
l Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. (Word64 -> Word64
forall a. Bits a => a -> a
complement Word64
511)
               Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ if Word64
c64 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
511 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
448 then Word64
1024 else Word64
512
 finished :: WordList -> Bool
finished (WordList ([Word32]
_, Word64
z)) = Word64
z Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0


instance Num ABCD where
 ABCD (Word32
a1, Word32
b1, Word32
c1, Word32
d1) + :: ABCD -> ABCD -> ABCD
+ ABCD (Word32
a2, Word32
b2, Word32
c2, Word32
d2) = (Word32, Word32, Word32, Word32) -> ABCD
ABCD (Word32
a1 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
a2, Word32
b1 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
b2, Word32
c1 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
c2, Word32
d1 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
d2)

 (-)         = String -> ABCD -> ABCD -> ABCD
forall a. HasCallStack => String -> a
error String
"(-){ABCD}: no instance method defined"
 * :: ABCD -> ABCD -> ABCD
(*)         = String -> ABCD -> ABCD -> ABCD
forall a. HasCallStack => String -> a
error String
"(*){ABCD}: no instance method defined"
 signum :: ABCD -> ABCD
signum      = String -> ABCD -> ABCD
forall a. HasCallStack => String -> a
error String
"signum{ABCD}: no instance method defined"
 fromInteger :: Integer -> ABCD
fromInteger = String -> Integer -> ABCD
forall a. HasCallStack => String -> a
error String
"fromInteger{ABCD}: no instance method defined"
 abs :: ABCD -> ABCD
abs         = String -> ABCD -> ABCD
forall a. HasCallStack => String -> a
error String
"abs{ABCD}: no instance method defined"
-- ===================== EXPORTED FUNCTIONS ========================


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

md5 :: (MD5 a) => a -> ABCD
md5 :: a -> ABCD
md5 a
m = Bool -> Word64 -> ABCD -> a -> ABCD
forall a. MD5 a => Bool -> Word64 -> ABCD -> a -> ABCD
md5_main Bool
False Word64
0 ABCD
magic_numbers a
m


-- Returns a hex number ala the md5sum program

md5s :: (MD5 a) => a -> String
md5s :: a -> String
md5s = ABCD -> String
abcd_to_string (ABCD -> String) -> (a -> ABCD) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ABCD
forall a. MD5 a => a -> ABCD
md5


-- Returns an integer equivalent to the above hex number

md5i :: (MD5 a) => a -> Integer
md5i :: a -> Integer
md5i = ABCD -> Integer
abcd_to_integer (ABCD -> Integer) -> (a -> ABCD) -> a -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ABCD
forall a. MD5 a => a -> ABCD
md5


-- ===================== THE CORE ALGORITHM ========================


-- 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 :: (MD5 a) =>
            Bool   -- Have we added padding yet?
         -> Word64 -- The length so far mod 2^64
         -> ABCD   -- The initial state
         -> a      -- The non-processed portion of the message
         -> ABCD   -- The resulting state
md5_main :: Bool -> Word64 -> ABCD -> a -> ABCD
md5_main Bool
padded Word64
ilen ABCD
abcd a
m
 = if a -> Bool
forall a. MD5 a => a -> Bool
finished a
m Bool -> Bool -> Bool
&& Bool
padded
   then ABCD
abcd
   else Bool -> Word64 -> ABCD -> a -> ABCD
forall a. MD5 a => Bool -> Word64 -> ABCD -> a -> ABCD
md5_main Bool
padded' (Word64
ilen Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
512) (ABCD
abcd ABCD -> ABCD -> ABCD
forall a. Num a => a -> a -> a
+ ABCD
abcd') a
m''
 where ([Word32]
m16, Int
l, a
m') = a -> ([Word32], Int, a)
forall a. MD5 a => a -> ([Word32], Int, a)
get_next a
m
       len' :: Word64
len' = Word64
ilen Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l
       (([Word32]
m16', Int
_, a
m''), Bool
padded') = if Bool -> Bool
not Bool
padded Bool -> Bool -> Bool
&& Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
512
                                   then (a -> ([Word32], Int, a)
forall a. MD5 a => a -> ([Word32], Int, a)
get_next (a -> ([Word32], Int, a)) -> a -> ([Word32], Int, a)
forall a b. (a -> b) -> a -> b
$ Word64 -> a -> a
forall a. MD5 a => Word64 -> a -> a
len_pad Word64
len' a
m, Bool
True)
                                   else (([Word32]
m16, Int
l, a
m'), Bool
padded)
       abcd' :: ABCD
abcd' = ABCD -> [Word32] -> ABCD
md5_do_block ABCD
abcd [Word32]
m16'


-- md5_do_block processes a 512 bit block by calling md5_round 4 times to
-- apply each round with the correct constants and permutations of the
-- block

md5_do_block :: ABCD     -- Initial state
             -> [Word32] -- The block to be processed - 16 32bit words
             -> ABCD     -- Resulting state
md5_do_block :: ABCD -> [Word32] -> ABCD
md5_do_block ABCD
abcd0 [Word32]
w = ABCD
abcd4
 where ([(Int, Word32)]
r1, [(Int, Word32)]
r2, [(Int, Word32)]
r3, [(Int, Word32)]
r4) = ([(Int, Word32)], [(Int, Word32)], [(Int, Word32)],
 [(Int, Word32)])
rounds
       {-
       map (\x -> w !! 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]]
       map (\x -> w !! 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]]
       map (\x -> w !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9]
                       -- [(7 * x) `mod` 16 | x <- [0..15]]
       -}
       perm5 :: [a] -> [a]
perm5 [a
c0,a
c1,a
c2,a
c3,a
c4,a
c5,a
c6,a
c7,a
c8,a
c9,a
c10,a
c11,a
c12,a
c13,a
c14,a
c15]
        = [a
c1,a
c6,a
c11,a
c0,a
c5,a
c10,a
c15,a
c4,a
c9,a
c14,a
c3,a
c8,a
c13,a
c2,a
c7,a
c12]
       perm5 [a]
_ = String -> [a]
forall a. HasCallStack => String -> a
error String
"broke at perm5"
       perm3 :: [a] -> [a]
perm3 [a
c0,a
c1,a
c2,a
c3,a
c4,a
c5,a
c6,a
c7,a
c8,a
c9,a
c10,a
c11,a
c12,a
c13,a
c14,a
c15]
        = [a
c5,a
c8,a
c11,a
c14,a
c1,a
c4,a
c7,a
c10,a
c13,a
c0,a
c3,a
c6,a
c9,a
c12,a
c15,a
c2]
       perm3 [a]
_ = String -> [a]
forall a. HasCallStack => String -> a
error String
"broke at perm3"
       perm7 :: [a] -> [a]
perm7 [a
c0,a
c1,a
c2,a
c3,a
c4,a
c5,a
c6,a
c7,a
c8,a
c9,a
c10,a
c11,a
c12,a
c13,a
c14,a
c15]
        = [a
c0,a
c7,a
c14,a
c5,a
c12,a
c3,a
c10,a
c1,a
c8,a
c15,a
c6,a
c13,a
c4,a
c11,a
c2,a
c9]
       perm7 [a]
_ = String -> [a]
forall a. HasCallStack => String -> a
error String
"broke at perm7"
       abcd1 :: ABCD
abcd1 = (XYZ -> Word32) -> ABCD -> [Word32] -> [(Int, Word32)] -> ABCD
md5_round XYZ -> Word32
md5_f ABCD
abcd0        [Word32]
w  [(Int, Word32)]
r1
       abcd2 :: ABCD
abcd2 = (XYZ -> Word32) -> ABCD -> [Word32] -> [(Int, Word32)] -> ABCD
md5_round XYZ -> Word32
md5_g ABCD
abcd1 ([Word32] -> [Word32]
forall a. [a] -> [a]
perm5 [Word32]
w) [(Int, Word32)]
r2
       abcd3 :: ABCD
abcd3 = (XYZ -> Word32) -> ABCD -> [Word32] -> [(Int, Word32)] -> ABCD
md5_round XYZ -> Word32
md5_h ABCD
abcd2 ([Word32] -> [Word32]
forall a. [a] -> [a]
perm3 [Word32]
w) [(Int, Word32)]
r3
       abcd4 :: ABCD
abcd4 = (XYZ -> Word32) -> ABCD -> [Word32] -> [(Int, Word32)] -> ABCD
md5_round XYZ -> Word32
md5_i ABCD
abcd3 ([Word32] -> [Word32]
forall a. [a] -> [a]
perm7 [Word32]
w) [(Int, Word32)]
r4


-- md5_round does one of the rounds. It takes an auxiliary function and foldls
-- (md5_inner_function f) to repeatedly apply it to the initial state with the
-- correct constants

md5_round :: (XYZ -> Word32)      -- Auxiliary function (F, G, H or I
                                  -- for those of you with a copy of
                                  -- the prayer book^W^WRFC)
          -> ABCD                 -- Initial state
          -> [Word32]             -- The 16 32bit words of input
          -> [(Rotation, Word32)] -- The list of 16 rotations and
                                  -- additive constants
          -> ABCD                 -- Resulting state
md5_round :: (XYZ -> Word32) -> ABCD -> [Word32] -> [(Int, Word32)] -> ABCD
md5_round XYZ -> Word32
f ABCD
abcd [Word32]
s [(Int, Word32)]
ns = (ABCD -> (Int, Word32) -> ABCD) -> ABCD -> [(Int, Word32)] -> ABCD
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((XYZ -> Word32) -> ABCD -> (Int, Word32) -> ABCD
md5_inner_function XYZ -> Word32
f) ABCD
abcd [(Int, Word32)]
ns'
 where ns' :: [(Int, Word32)]
ns' = (Word32 -> (Int, Word32) -> (Int, Word32))
-> [Word32] -> [(Int, Word32)] -> [(Int, Word32)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Word32
x (Int
y, Word32
z) -> (Int
y, Word32
x Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
z)) [Word32]
s [(Int, Word32)]
ns


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

md5_inner_function :: (XYZ -> Word32)    -- Auxiliary function
                   -> ABCD               -- Initial state
                   -> (Rotation, Word32) -- The rotation and additive
                                         -- constant (X[i] + T[j])
                   -> ABCD               -- Resulting state
md5_inner_function :: (XYZ -> Word32) -> ABCD -> (Int, Word32) -> ABCD
md5_inner_function XYZ -> Word32
f (ABCD (Word32
a, Word32
b, Word32
c, Word32
d)) (Int
s, Word32
ki) = (Word32, Word32, Word32, Word32) -> ABCD
ABCD (Word32
d, Word32
a', Word32
b, Word32
c)
 where mid_a :: Word32
mid_a = Word32
a Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ XYZ -> Word32
f(Word32
b,Word32
c,Word32
d) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
ki
       rot_a :: Word32
rot_a = Word32 -> Int -> Word32
rotL Word32
mid_a Int
s
       a' :: Word32
a' = Word32
b Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
rot_a


-- The 4 auxiliary functions

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

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

md5_h :: XYZ -> Word32
md5_h :: XYZ -> Word32
md5_h (Word32
x, Word32
y, Word32
z) = Word32
x Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32
y Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32
z

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


-- The magic numbers from the RFC.

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


-- The 4 lists of (rotation, additive constant) tuples, one for each round

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


-- ===================== CONVERSION FUNCTIONS ========================


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

abcd_to_string :: ABCD -> String
abcd_to_string :: ABCD -> String
abcd_to_string (ABCD (Word32
a,Word32
b,Word32
c,Word32
d)) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Word32 -> String) -> [Word32] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Word32 -> String
display_32bits_as_hex [Word32
a,Word32
b,Word32
c,Word32
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 :: Word32 -> String
display_32bits_as_hex Word32
w = ShowS
forall a. [a] -> [a]
swap_pairs String
cs
 where cs :: String
cs = (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> Word32 -> Char
forall a. Integral a => a -> Char
getc (Word32 -> Char) -> Word32 -> Char
forall a b. (a -> b) -> a -> b
$ (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR Word32
w (Int
4Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
x)) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
15) [Int
0..Int
7]
       getc :: a -> Char
getc a
n = ([Char
'0'..Char
'9'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'a'..Char
'f']) String -> Int -> Char
forall a. [a] -> Int -> a
!! (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n)
       swap_pairs :: [a] -> [a]
swap_pairs (a
x1:a
x2:[a]
xs) = a
x2a -> [a] -> [a]
forall a. a -> [a] -> [a]
:a
x1a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a] -> [a]
swap_pairs [a]
xs
       swap_pairs [a]
_ = []

-- Convert to an integer, performing endianness magic as we go

abcd_to_integer :: ABCD -> Integer
abcd_to_integer :: ABCD -> Integer
abcd_to_integer (ABCD (Word32
a,Word32
b,Word32
c,Word32
d)) = Word32 -> Integer
rev_num Word32
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
96 :: Int)
                                 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word32 -> Integer
rev_num Word32
b Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
64 :: Int)
                                 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word32 -> Integer
rev_num Word32
c Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
32 :: Int)
                                 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word32 -> Integer
rev_num Word32
d

rev_num :: Word32 -> Integer
rev_num :: Word32 -> Integer
rev_num Word32
i = Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger Word32
j Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` (Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
32 :: Int))
 --         NHC's fault ~~~~~~~~~~~~~~~~~~~~~
 where j :: Word32
j = (Word32 -> Int -> Word32) -> Word32 -> [Int] -> Word32
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Word32
so_far Int
next -> Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
so_far Int
8 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR Word32
i Int
next Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
255))
                 Word32
0 [Int
0,Int
8,Int
16,Int
24]

-- Used to convert a 64 byte string to 16 32bit words

string_to_word32s :: String -> [Word32]
string_to_word32s :: String -> [Word32]
string_to_word32s String
"" = []
string_to_word32s String
ss = Word32
thisWord32 -> [Word32] -> [Word32]
forall a. a -> [a] -> [a]
:String -> [Word32]
string_to_word32s String
ss'
 where (String
s, String
ss') = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
4 String
ss
       this :: Word32
this = (Char -> Word32 -> Word32) -> Word32 -> String -> Word32
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Char
c Word32
w -> Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
w Int
8 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral(Int -> Word32) -> (Char -> Int) -> Char -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Int
ord) Char
c) Word32
0 String
s


-- Used to convert a list of 512 bools to 16 32bit words

bools_to_word32s :: [Bool] -> [Word32]
bools_to_word32s :: [Bool] -> [Word32]
bools_to_word32s [] = []
bools_to_word32s [Bool]
bs = Word32
thisWord32 -> [Word32] -> [Word32]
forall a. a -> [a] -> [a]
:[Bool] -> [Word32]
bools_to_word32s [Bool]
rest
 where ([Bool]
bs1, [Bool]
bs1') = Int -> [Bool] -> ([Bool], [Bool])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
8 [Bool]
bs
       ([Bool]
bs2, [Bool]
bs2') = Int -> [Bool] -> ([Bool], [Bool])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
8 [Bool]
bs1'
       ([Bool]
bs3, [Bool]
bs3') = Int -> [Bool] -> ([Bool], [Bool])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
8 [Bool]
bs2'
       ([Bool]
bs4, [Bool]
rest) = Int -> [Bool] -> ([Bool], [Bool])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
8 [Bool]
bs3'
       this :: Word32
this = [[Bool]] -> Word32
boolss_to_word32 [[Bool]
bs1, [Bool]
bs2, [Bool]
bs3, [Bool]
bs4]
       bools_to_word8 :: [Bool] -> Word32
bools_to_word8 = (Word32 -> Bool -> Word32) -> Word32 -> [Bool] -> Word32
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Word32
w Bool
b -> Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
w Int
1 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ if Bool
b then Word32
1 else Word32
0) Word32
0
       boolss_to_word32 :: [[Bool]] -> Word32
boolss_to_word32 = ([Bool] -> Word32 -> Word32) -> Word32 -> [[Bool]] -> Word32
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\[Bool]
w8 Word32
w -> Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
w Int
8 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ [Bool] -> Word32
bools_to_word8 [Bool]
w8) Word32
0


-- Convert the size into a list of characters used by the len_pad function
-- for strings

length_to_chars :: Int -> Word64 -> String
length_to_chars :: Int -> Word64 -> String
length_to_chars Int
0 Word64
_ = []
length_to_chars Int
p Word64
n = Char
thisChar -> ShowS
forall a. a -> [a] -> [a]
:Int -> Word64 -> String
length_to_chars (Int
pInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftR Word64
n Int
8)
         where this :: Char
this = Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ Word64
n Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
255