MD4.hs (3885B)
1 -- copied/modified from 2 -- 3 -- https://github.com/mfeyg/md4/blob/master/Data/Digest/Pure/MD4.hs 4 module Cryptopals.Digest.Pure.MD4 ( 5 md4 6 , md4' 7 ) where 8 9 import Control.Applicative 10 import Control.Monad 11 import Control.Monad.Trans.State 12 import Data.Bits 13 import Data.Binary.Put 14 import Data.Binary.Get 15 import qualified Data.ByteString.Lazy as L 16 import Data.Word 17 import GHC.Word (Word64) 18 19 f x y z = x .&. y .|. complement x .&. z 20 g x y z = x .&. y .|. x .&. z .|. y .&. z 21 h x y z = x `xor` y `xor` z 22 23 abcd f a b c d = f a b c d 24 dabc f a b c d = f d a b c 25 cdab f a b c d = f c d a b 26 bcda f a b c d = f b c d a 27 28 data State = Vals !Word32 !Word32 !Word32 !Word32 29 30 store1 x (Vals a b c d) = Vals x b c d 31 store2 x (Vals a b c d) = Vals a x c d 32 store3 x (Vals a b c d) = Vals a b x d 33 store4 x (Vals a b c d) = Vals a b c x 34 35 get1 (Vals x _ _ _) = x 36 get2 (Vals _ x _ _) = x 37 get3 (Vals _ _ x _) = x 38 get4 (Vals _ _ _ x) = x 39 40 op f n k s x a b c d = 41 rotateL (a + f b c d + (x!!k) + n) s 42 43 op1 = op f 0 44 op2 = op g 0x5a827999 45 op3 = op h 0x6ed9eba1 46 47 params1 = [ 0, 3, 1, 7, 2, 11, 3, 19 48 , 4, 3, 5, 7, 6, 11, 7, 19 49 , 8, 3, 9, 7, 10, 11, 11, 19 50 ,12, 3, 13, 7, 14, 11, 15, 19] 51 52 params2 = [0, 3, 4, 5, 8, 9, 12, 13 53 ,1, 3, 5, 5, 9, 9, 13, 13 54 ,2, 3, 6, 5, 10, 9, 14, 13 55 ,3, 3, 7, 5, 11, 9, 15, 13] 56 57 params3 = [0, 3, 8, 9, 4, 11, 12, 15 58 ,2, 3, 10, 9, 6, 11, 14, 15 59 ,1, 3, 9, 9, 5, 11, 13, 15 60 ,3, 3, 11, 9, 7, 11, 15, 15] 61 62 apply x op p k s = p go (gets get1, modify . store1) 63 (gets get2, modify . store2) 64 (gets get3, modify . store3) 65 (gets get4, modify . store4) 66 where go (a, store) (b,_) (c,_) (d,_) = 67 store =<< (op k s x <$> a <*> b <*> c <*> d) 68 69 on app = go 70 where go [] = pure () 71 go (k1:s1:k2:s2:k3:s3:k4:s4:r) 72 = app abcd k1 s1 73 *> app dabc k2 s2 74 *> app cdab k3 s3 75 *> app bcda k4 s4 76 *> go r 77 78 proc !x = (modify . add) =<< 79 (get <* go op1 params1 80 <* go op2 params2 81 <* go op3 params3) 82 where add (Vals a b c d) (Vals a' b' c' d') = 83 Vals (a+a') (b+b') (c+c') (d+d') 84 go op params = apply x op `on` params 85 86 md4' 87 :: Word32 88 -> Word32 89 -> Word32 90 -> Word32 91 -> Word64 92 -> L.ByteString 93 -> L.ByteString 94 md4' a b c d n s = output $ execState (go (prep' n s) (pure ())) $ 95 Vals a b c d 96 where 97 go [] m = m 98 go !s m = go (drop 16 s) $ m >> proc (take 16 s) 99 100 pad' n bs = bs <> evilpadding n bs 101 102 prep' n = getWords . pad' n 103 104 md4 :: L.ByteString -> L.ByteString 105 md4 s = output $ execState (go (prep s) (return ())) $ 106 Vals 0x67452301 0xefcdab89 0x98badcfe 0x10325476 107 where go [] m = m 108 go !s m = go (drop 16 s) $ m >> proc (take 16 s) 109 110 prep = getWords . pad 111 112 pad bs = runPut $ putAndCountBytes bs >>= \len -> 113 putWord8 0x80 114 *> replicateM_ (mod (55 - fromIntegral len) 64) (putWord8 0) 115 *> putWord64le (len * 8) 116 117 putAndCountBytes = go 0 118 where go !n s = case L.uncons s of 119 Just (w, s') -> putWord8 w >> go (n+1) s' 120 Nothing -> return $! n 121 122 getWords = runGet words where 123 words = isEmpty >>= \e -> 124 if e 125 then pure [] 126 else (:) <$> getWord32le <*> words 127 128 output (Vals a b c d) = runPut $ mapM_ putWord32le [a,b,c,d] 129 130 -- required padding bytes 131 pbytes :: Integral a => a -> a 132 pbytes ((\k -> 64 - k `mod` 64) -> l) 133 | l == 0 = l + 56 134 | otherwise = l - 8 135 136 -- padding for a supplied message, using arbitrary bytelength n 137 evilpadding :: Word64 -> L.ByteString -> L.ByteString 138 evilpadding n bs = runPut $ do 139 putWord8 128 140 loop (pred (pbytes (L.length bs))) 141 where 142 loop l 143 | l == 0 = putWord64le (n * 8) 144 | otherwise = do 145 putWord8 0 146 loop (pred l) 147