> module Happstack.Crypto.SHA1 (sha1, sha1Raw, sha1_size) where
> import Data.Char
> import Data.Bits
> import Data.Word
> type ABCDE = (Word32, Word32, Word32, Word32, Word32)
> type XYZ = (Word32, Word32, Word32)
> type Rotation = Int
> sha1 :: String -> String
> sha1 s = s5
> where s1_2 = sha1_step_1_2_pad_length s
> abcde = sha1_step_3_init
> abcde' = sha1_step_4_main abcde s1_2
> s5 = sha1_step_5_display abcde'
> sha1Raw :: String -> String
> sha1Raw s = s5
> where s1_2 = sha1_step_1_2_pad_length s
> abcde = sha1_step_3_init
> abcde' = sha1_step_4_main abcde s1_2
> s5 = sha1_step_5_concat abcde'
> sha1_size :: (Integral a) => a -> String -> String
> sha1_size l s = s5
> where s1_2 = s ++ sha1_step_1_2_work (fromIntegral ((toInteger l) `mod` (2^64::Integer))) ""
> abcde = sha1_step_3_init
> abcde' = sha1_step_4_main abcde s1_2
> s5 = sha1_step_5_display abcde'
> sha1_step_1_2_pad_length :: String -> String
> sha1_step_1_2_pad_length = sha1_step_1_2_work 0
> sha1_step_1_2_work :: Integer -> String -> String
> sha1_step_1_2_work c64 "" = padding ++ len
> where padding = '\128':replicate' (shiftR (fromIntegral $ (440 c64) `mod` 512) 3) '\000'
> len = map chr $ size_split 8 c64
> sha1_step_1_2_work c64 (c:cs) = c:sha1_step_1_2_work (((c64 + 8) `mod` (2^64))::Integer) cs
> replicate' :: Word16 -> a -> [a]
> replicate' 0 _ = []
> replicate' n x = x:replicate' (n1) x
> size_split :: Int -> Integer -> [Int]
> size_split 0 _ = []
> size_split p n = size_split (p1) n' ++ [fromIntegral d]
> where (n', d) = divMod n 256
> sha1_step_3_init :: ABCDE
> sha1_step_3_init = (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476, 0xc3d2e1f0)
[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15]
wm3 = [13,14,15]
wm8 = [8,9,10,11,12,13,14,15]
wm14 = [2,3,4,5,6,7,8,9,10,11,12,13,14,15]
wm16 = [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15]
> sha1_step_4_main :: ABCDE -> String -> ABCDE
> sha1_step_4_main abcde "" = abcde
> sha1_step_4_main abcde0 s = sha1_step_4_main abcde5 s'
> where (s64, s') = takeDrop 64 s
> s16 = get_word_32s s64
> s80 = s16 ++ sha1_add_ws 16 (drop 13 s16, drop 8 s16, drop 2 s16, s16)
> (s20_0, s60) = takeDrop 20 s80
> (s20_1, s40) = takeDrop 20 s60
> (s20_2, s20_3) = takeDrop 20 s40
> abcde1 = foldl (doit f1 0x5a827999) abcde0 s20_0
> abcde2 = foldl (doit f2 0x6ed9eba1) abcde1 s20_1
> abcde3 = foldl (doit f3 0x8f1bbcdc) abcde2 s20_2
> abcde4 = foldl (doit f2 0xca62c1d6) abcde3 s20_3
> f1 (x, y, z) = (x .&. y) .|. ((complement x) .&. z)
> f2 (x, y, z) = x `xor` y `xor` z
> f3 (x, y, z) = (x .&. y) .|. (x .&. z) .|. (y .&. z)
> (a, b, c, d, e ) = abcde0
> (a', b', c', d', e') = abcde4
> abcde5 = (a + a', b + b', c + c', d + d', e + e')
> doit :: (XYZ -> Word32) -> Word32 -> ABCDE -> Word32 -> ABCDE
> doit f k (a, b, c, d, e) w = (a', a, rotL b 30, c, d)
> where a' = rotL a 5 + f(b, c, d) + e + w + k
> sha1_add_ws :: Int -> ([Word32], [Word32], [Word32], [Word32]) -> [Word32]
> sha1_add_ws 80 _ = []
> sha1_add_ws n (w1:w1s, w2:w2s, w3:w3s, w4:w4s)
> = w:sha1_add_ws (n + 1) (w1s ++ [w], w2s ++ [w], w3s ++ [w], w4s ++ [w])
> where w = rotL (foldr1 xor [w1, w2, w3, w4]) 1
> sha1_add_ws _ _ = error "Case not defined in sha1_add_ws"
>
> 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) [24, 16, 8, 0]
> rest = get_word_32s ss'
> takeDrop :: Int -> [a] -> ([a], [a])
> takeDrop _ [] = ([], [])
> takeDrop 0 xs = ([], xs)
> takeDrop n (x:xs) = (x:ys, zs)
> where (ys, zs) = takeDrop (n1) xs
> sha1_step_5_display :: ABCDE -> String
> sha1_step_5_display (a, b, c, d, e)
> = foldr (\x y -> display_32bits_as_hex x ++ y) "" [a, b, c, d, e]
> sha1_step_5_concat :: ABCDE -> String
> sha1_step_5_concat (a, b, c, d, e)
> = foldr (\x y -> display_32bits_as_8bits x y) "" [a, b, c, d, e]
> display_32bits_as_hex :: Word32 -> String
> display_32bits_as_hex x0 = map getc [y8,y7,y6,y5,y4,y3,y2,y1]
> 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)
> display_32bits_as_8bits :: Word32 -> ShowS
> display_32bits_as_8bits x0 l
> = getn 3 : getn 2 : getn 1 : getn 0 : l
> where getn n = chr (fromIntegral (x0 `shiftR` (n*8) .&. 0xFF))
> rotL :: Word32 -> Rotation -> Word32
> rotL a s = shiftL a s .|. shiftL a (s32)