{-# LANGUAGE Safe #-}

{-# OPTIONS_GHC -fno-warn-missing-methods #-}

{- |
   Module     : Data.Hash.MD5
   Copyright  : Copyright (C) 2001 Ian Lynagh
   SPDX-License-Identifier: BSD-3-Clause OR GPL-2.0-or-later

   Maintainer : Ian Lynagh <igloo@earth.li>
   Stability  : stable
   Portability: portable

Generation of MD5sums

Written by Ian Lynagh, igloo\@earth.li
-}

module Data.Hash.MD5
    ( md5
    , md5s
    , md5i
    , MD5(..)
    , ABCD(..)
    , Zord64
    , Str(..)
    , BoolList(..)
    , WordList(..)
    ) where

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

-- | Synonym for 'Word64' due to historic reasons
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], Zord64)

-- | 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 :: Zord64 -> 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 :: Zord64 -> BoolList -> BoolList
len_pad Zord64
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 (Zord64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Zord64 -> Int) -> Zord64 -> Int
forall a b. (a -> b) -> a -> b
$ (Zord64
447 Zord64 -> Zord64 -> Zord64
forall a. Num a => a -> a -> a
- Zord64
l) Zord64 -> Zord64 -> Zord64
forall a. Bits a => a -> a -> a
.&. Zord64
511) Bool
False
                 [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ [Zord64
l Zord64 -> Zord64 -> Zord64
forall a. Bits a => a -> a -> a
.&. (Zord64 -> Int -> Zord64
forall a. Bits a => a -> Int -> a
shiftL Zord64
1 Int
x) Zord64 -> Zord64 -> Bool
forall a. Ord a => a -> a -> Bool
> Zord64
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 :: Zord64 -> Str -> Str
len_pad Zord64
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 (Zord64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Zord64
zeros) Char
'\000'
        zeros :: Zord64
zeros = Zord64 -> Int -> Zord64
forall a. Bits a => a -> Int -> a
shiftR ((Zord64
440 Zord64 -> Zord64 -> Zord64
forall a. Num a => a -> a -> a
- Zord64
c64) Zord64 -> Zord64 -> Zord64
forall a. Bits a => a -> a -> a
.&. Zord64
511) Int
3
        l :: String
l = Int -> Zord64 -> String
length_to_chars Int
8 Zord64
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, Zord64
l)) = ([Word32]
xs, Zord64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Zord64
taken, ([Word32], Zord64) -> WordList
WordList ([Word32]
ys, Zord64
l Zord64 -> Zord64 -> Zord64
forall a. Num a => a -> a -> a
- Zord64
taken))
  where ([Word32]
xs, [Word32]
ys) = Int -> [Word32] -> ([Word32], [Word32])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
16 [Word32]
ws
        taken :: Zord64
taken = if Zord64
l Zord64 -> Zord64 -> Bool
forall a. Ord a => a -> a -> Bool
> Zord64
511 then Zord64
512 else Zord64
l Zord64 -> Zord64 -> Zord64
forall a. Bits a => a -> a -> a
.&. Zord64
511
 len_pad :: Zord64 -> WordList -> WordList
len_pad Zord64
c64 (WordList ([Word32]
ws, Zord64
l)) = ([Word32], Zord64) -> 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, Zord64
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 :: Zord64
offset = Zord64
c64 Zord64 -> Zord64 -> Zord64
forall a. Bits a => a -> a -> a
.&. Zord64
31
        lastone' :: [Word32]
lastone' = [if Zord64
offset Zord64 -> Zord64 -> Bool
forall a. Ord a => a -> a -> Bool
> Zord64
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 (Zord64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Zord64 -> Int) -> Zord64 -> Int
forall a b. (a -> b) -> a -> b
$ Zord64
offset Zord64 -> Zord64 -> Zord64
forall a. Bits a => a -> a -> a
.&. Zord64
7))
                        (Zord64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Zord64 -> Int) -> Zord64 -> Int
forall a b. (a -> b) -> a -> b
$ Zord64
offset Zord64 -> Zord64 -> Zord64
forall a. Bits a => a -> a -> a
.&. (Zord64
31 Zord64 -> Zord64 -> Zord64
forall a. Num a => a -> a -> a
- Zord64
7))
        nextish :: [Word32]
nextish = if Zord64
offset Zord64 -> Zord64 -> Bool
forall a. Eq a => a -> a -> Bool
== Zord64
0 then [Word32
128] else []
        c64' :: Zord64
c64' = Zord64
c64 Zord64 -> Zord64 -> Zord64
forall a. Num a => a -> a -> a
+ (Zord64
32 Zord64 -> Zord64 -> Zord64
forall a. Num a => a -> a -> a
- Zord64
offset)
        num_blanks :: Int
num_blanks = (Zord64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Zord64 -> Int) -> Zord64 -> Int
forall a b. (a -> b) -> a -> b
$ Zord64 -> Int -> Zord64
forall a. Bits a => a -> Int -> a
shiftR ((Zord64
448 Zord64 -> Zord64 -> Zord64
forall a. Num a => a -> a -> a
- Zord64
c64') Zord64 -> Zord64 -> Zord64
forall a. Bits a => a -> a -> a
.&. Zord64
511) Int
5)
        blanks :: [Word32]
blanks = Int -> Word32 -> [Word32]
forall a. Int -> a -> [a]
replicate Int
num_blanks Word32
0
        lowsize :: Word32
lowsize = Zord64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Zord64 -> Word32) -> Zord64 -> Word32
forall a b. (a -> b) -> a -> b
$ Zord64
c64 Zord64 -> Zord64 -> Zord64
forall a. Bits a => a -> a -> a
.&. (Zord64 -> Int -> Zord64
forall a. Bits a => a -> Int -> a
shiftL Zord64
1 Int
32 Zord64 -> Zord64 -> Zord64
forall a. Num a => a -> a -> a
- Zord64
1)
        topsize :: Word32
topsize = Zord64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Zord64 -> Word32) -> Zord64 -> Word32
forall a b. (a -> b) -> a -> b
$ Zord64 -> Int -> Zord64
forall a. Bits a => a -> Int -> a
shiftR Zord64
c64 Int
32
        size :: [Word32]
size = [Word32
lowsize, Word32
topsize]
        newlen :: Zord64
newlen = Zord64
l Zord64 -> Zord64 -> Zord64
forall a. Bits a => a -> a -> a
.&. (Zord64 -> Zord64
forall a. Bits a => a -> a
complement Zord64
511)
               Zord64 -> Zord64 -> Zord64
forall a. Num a => a -> a -> a
+ if Zord64
c64 Zord64 -> Zord64 -> Zord64
forall a. Bits a => a -> a -> a
.&. Zord64
511 Zord64 -> Zord64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Zord64
448 then Zord64
1024 else Zord64
512
 finished :: WordList -> Bool
finished (WordList ([Word32]
_, Zord64
z)) = Zord64
z Zord64 -> Zord64 -> Bool
forall a. Eq a => a -> a -> Bool
== Zord64
0

-- | __WARNING__: This instance only defines the '+' operation
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)

-- ======================== EXPORTED FUNCTIONS ========================


{- | The simplest function, gives you the MD5 of a string as 4-tuple of
32bit words. -}
md5 :: (MD5 a) => a -> ABCD
md5 :: forall a. MD5 a => a -> ABCD
md5 a
m = Bool -> Zord64 -> ABCD -> a -> ABCD
forall a. MD5 a => Bool -> Zord64 -> ABCD -> a -> ABCD
md5_main Bool
False Zord64
0 ABCD
magic_numbers a
m


{- | Returns a hex number ala the md5sum program. -}
md5s :: (MD5 a) => a -> String
md5s :: forall a. MD5 a => 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 hex number from 'md5s'. -}
md5i :: (MD5 a) => a -> Integer
md5i :: forall a. MD5 a => 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?
         -> Zord64 -- 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 :: forall a. MD5 a => Bool -> Zord64 -> ABCD -> a -> ABCD
md5_main Bool
padded Zord64
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 -> Zord64 -> ABCD -> a -> ABCD
forall a. MD5 a => Bool -> Zord64 -> ABCD -> a -> ABCD
md5_main Bool
padded' (Zord64
ilen Zord64 -> Zord64 -> Zord64
forall a. Num a => a -> a -> a
+ Zord64
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' :: Zord64
len' = Zord64
ilen Zord64 -> Zord64 -> Zord64
forall a. Num a => a -> a -> a
+ Int -> Zord64
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
$ Zord64 -> a -> a
forall a. MD5 a => Zord64 -> a -> a
len_pad Zord64
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
forall a. Bits a => a -> Int -> a
rotateL 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 -> Zord64 -> String
length_to_chars :: Int -> Zord64 -> String
length_to_chars Int
0 Zord64
_ = []
length_to_chars Int
p Zord64
n = Char
thisChar -> ShowS
forall a. a -> [a] -> [a]
:Int -> Zord64 -> String
length_to_chars (Int
pInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Zord64 -> Int -> Zord64
forall a. Bits a => a -> Int -> a
shiftR Zord64
n Int
8)
 where this :: Char
this = Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Zord64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Zord64 -> Int) -> Zord64 -> Int
forall a b. (a -> b) -> a -> b
$ Zord64
n Zord64 -> Zord64 -> Zord64
forall a. Bits a => a -> a -> a
.&. Zord64
255