[Fencommits] fenserve: refactor SHA1 to use Data.Array.ST
Benja Fallenstein
benja.fallenstein at gmail.com
Sat Mar 31 19:33:36 EEST 2007
Sat Mar 31 19:33:12 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* refactor SHA1 to use Data.Array.ST
diff -rN -u old-fenserve/SHA1.hs new-fenserve/SHA1.hs
--- old-fenserve/SHA1.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/SHA1.hs 2007-03-31 19:33:36.000000000 +0300
@@ -0,0 +1,167 @@
+{-
+=============================================================================
+COPYING
+
+Copyright (C) 2001 Ian Lynagh <igloo at earth.li>
+Copyright (C) 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
+
+SHA.lhs can be used under either the BSD or GPL.
+=============================================================================
+BSD license:
+
+Copyright (c) The Regents of the University of California.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+3. Neither the name of the University nor the names of its contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.
+=============================================================================
+GPL license: See file LICENSE
+=============================================================================
+ChangeLog
+
+0.1.0 Fri, 2 Feb 2001 00:00:43 +0000
+ First release
+
+Benja Fallenstein, 2007-03-14:
+ * File copied to fenserve repository & headers added
+
+Benja Fallenstein, 2007-03-16:
+ * Changed Word/Char/Bits imports to Data.Word/Data.Char/Data.Bits
+ * Converted to use [Word8] instead of String
+
+Benja Fallenstein, 2007-03-31:
+ * Refactored to use Data.Array.ST
+ * Changed from .lhs to .hs
+=============================================================================
+-}
+
+module SHA1 (sha1, sha1_size) where
+
+import Control.Monad.ST
+
+import Data.Array.ST
+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 :: [Word8] -> 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'
+
+sha1_size :: (Integral a) => a -> [Word8] -> String
+sha1_size l s = s5
+ where s1_2 = s ++ sha1_step_1_2_work (fromIntegral ((toInteger l) `mod` (2^64))) []
+ 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 :: [Word8] -> [Word8]
+sha1_step_1_2_pad_length s = sha1_step_1_2_work 0 s
+
+sha1_step_1_2_work :: Integer -> [Word8] -> [Word8]
+sha1_step_1_2_work c64 [] = padding ++ len
+ where padding = 128:replicate' (shiftR (fromIntegral $ (440 - c64) `mod` 512) 3) 0
+ len = map fromIntegral $ size_split 8 c64
+sha1_step_1_2_work c64 (c:cs) = c:sha1_step_1_2_work ((c64 + 8) `mod` (2^64)) cs
+
+replicate' :: Word16 -> a -> [a]
+replicate' 0 _ = []
+replicate' n x = x:replicate' (n-1) x
+
+size_split :: Int -> Integer -> [Int]
+size_split 0 _ = []
+size_split p n = size_split (p-1) n' ++ [fromIntegral d]
+ where (n', d) = divMod n 256
+
+sha1_step_3_init :: ABCDE
+sha1_step_3_init = (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476, 0xc3d2e1f0)
+
+sha1_step_4_main :: ABCDE -> [Word8] -> ABCDE
+sha1_step_4_main abcde s = runST st where
+ st = newArray (0,79) 0 >>= sha1_step_4_work abcde s
+
+type Arr s = STUArray s Int Word32
+
+sha1_step_4_work :: ABCDE -> [Word8] -> Arr s -> ST s ABCDE
+sha1_step_4_work abcde [] arr = return abcde
+sha1_step_4_work abcde0 s arr = do
+ s' <- sha1_ws 0 s arr
+ sha1_add_ws 16 arr
+ let 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)
+ abcde1 <- fold_arr (doit f1 0x5a827999) abcde0 arr (0,19)
+ abcde2 <- fold_arr (doit f2 0x6ed9eba1) abcde1 arr (20,39)
+ abcde3 <- fold_arr (doit f3 0x8f1bbcdc) abcde2 arr (40,59)
+ abcde4 <- fold_arr (doit f2 0xca62c1d6) abcde3 arr (60,79)
+ let (a, b, c, d, e ) = abcde0
+ (a', b', c', d', e') = abcde4
+ abcde5 = (a + a', b + b', c + c', d + d', e + e')
+ sha1_step_4_work abcde5 s' arr
+
+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_ws :: Int -> [Word8] -> Arr s -> ST s [Word8]
+sha1_ws 16 s arr = return s
+sha1_ws n (b1:b2:b3:b4:s) arr = do writeArray arr n w; sha1_ws (n+1) s arr
+ where w = f b1 24 + f b2 16 + f b3 8 + f b4 0; f x = shiftL (fromIntegral x)
+
+sha1_add_ws :: Int -> Arr s -> ST s ()
+sha1_add_ws 80 arr = return ()
+sha1_add_ws n arr = do w1234 <- mapM (\i -> readArray arr (n-i)) [3,8,14,16]
+ writeArray arr n $ rotL (foldr1 xor w1234) 1
+ sha1_add_ws (n+1) arr
+
+fold_arr :: (a -> Word32 -> a) -> a -> Arr s -> (Int,Int) -> ST s a
+fold_arr f x arr (i,j) | i > j = return x
+ | otherwise = do val <- readArray arr i
+ fold_arr f (f x val) arr (i+1,j)
+
+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]
+
+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)
+
+rotL :: Word32 -> Rotation -> Word32
+rotL a s = shiftL a s .|. shiftL a (s-32)
+
diff -rN -u old-fenserve/SHA1.lhs new-fenserve/SHA1.lhs
--- old-fenserve/SHA1.lhs 2007-03-31 19:33:35.000000000 +0300
+++ new-fenserve/SHA1.lhs 1970-01-01 02:00:00.000000000 +0200
@@ -1,166 +0,0 @@
-
-=============================================================================
-COPYING
-
-Copyright (C) 2001 Ian Lynagh <igloo at earth.li>
-
-SHA.lhs can be used under either the BSD or GPL.
-=============================================================================
-BSD license:
-
-Copyright (c) The Regents of the University of California.
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions
-are met:
-1. Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-2. Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer in the
- documentation and/or other materials provided with the distribution.
-3. Neither the name of the University nor the names of its contributors
- may be used to endorse or promote products derived from this software
- without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
-SUCH DAMAGE.
-=============================================================================
-GPL license: See file LICENSE
-=============================================================================
-ChangeLog
-
-0.1.0 Fri, 2 Feb 2001 00:00:43 +0000
- First release
-
-File copied to fenserve repository & headers added
-by Benja Fallenstein on 2007-03-14
-
-Changed Word/Char/Bits imports to Data.Word/Data.Char/Data.Bits
-Benja Fallenstein on 2007-03-16
-
-Converted to use [Word8] instead of String by Benja Fallenstein on 2007-03-16
-=============================================================================
-
-> module SHA1 (sha1, 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 :: [Word8] -> 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'
-
-> sha1_size :: (Integral a) => a -> [Word8] -> String
-> sha1_size l s = s5
-> where s1_2 = s ++ sha1_step_1_2_work (fromIntegral ((toInteger l) `mod` (2^64))) []
-> 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 :: [Word8] -> [Word8]
-> sha1_step_1_2_pad_length s = sha1_step_1_2_work 0 s
-
-> sha1_step_1_2_work :: Integer -> [Word8] -> [Word8]
-> sha1_step_1_2_work c64 [] = padding ++ len
-> where padding = 128:replicate' (shiftR (fromIntegral $ (440 - c64) `mod` 512) 3) 0
-> len = map fromIntegral $ size_split 8 c64
-> sha1_step_1_2_work c64 (c:cs) = c:sha1_step_1_2_work ((c64 + 8) `mod` (2^64)) cs
-
-> replicate' :: Word16 -> a -> [a]
-> replicate' 0 _ = []
-> replicate' n x = x:replicate' (n-1) x
-
-> size_split :: Int -> Integer -> [Int]
-> size_split 0 _ = []
-> size_split p n = size_split (p-1) 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 -> [Word8] -> ABCDE
-> sha1_step_4_main abcde [] = {- 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
-
-> get_word_32s :: [Word8] -> [Word32]
-> get_word_32s [] = []
-> get_word_32s ss = this:rest
-> where (s, ss') = takeDrop 4 ss
-> this = sum $ zipWith shiftL (map fromIntegral 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 (n-1) 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]
-
-> 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)
-
-> rotL :: Word32 -> Rotation -> Word32
-> rotL a s = shiftL a s .|. shiftL a (s-32)
-
More information about the Fencommits
mailing list