[Fencommits] fenserve: refactor SHA1.hs to use Data.ByteString; still doesn't fix the speed problem :-/

[Benja Fallenstein]

Sat Mar 31 20:18:16 EEST 2007  Benja Fallenstein <benja.fallenstein at gmail.com>
  * refactor SHA1.hs to use Data.ByteString; still doesn't fix the speed problem :-/
diff -rN -u old-fenserve/SHA1.hs new-fenserve/SHA1.hs
--- old-fenserve/SHA1.hs	2007-03-31 20:18:29.000000000 +0300
+++ new-fenserve/SHA1.hs	2007-03-31 20:18:29.000000000 +0300
@@ -51,52 +51,53 @@
   * Converted to use [Word8] instead of String
 
 Benja Fallenstein, 2007-03-31:
-  * Refactored to use Data.Array.ST
+  * Refactored to use Data.ByteString and Data.Array.ST
   * Changed from .lhs to .hs
 =============================================================================
 -}
 
-module SHA1 (sha1, sha1_size) where
+module SHA1 (sha1) where
 
-import Control.Monad.ST
+import Control.Monad.ST.Strict
 
 import Data.Array.ST
-import Data.Char
 import Data.Bits
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import Data.Char
 import Data.Word
 
 type ABCDE = (Word32, Word32, Word32, Word32, Word32)
 type XYZ = (Word32, Word32, Word32)
 type Rotation = Int
 
-sha1 :: [Word8] -> String
+sha1 :: ByteString -> 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
+sha1_step_1_2_pad_length :: ByteString -> ByteString
+sha1_step_1_2_pad_length bytes = B.append bytes (B.pack (padding ++ lenBytes)) where
+    padding = 128:replicate' (shiftR (fromIntegral $ (440-len) `mod` 512) 3) 0
+    lenBytes = map fromIntegral $ size_split 8 len
+    len = fromInteger ((toInteger $ 8 * B.length bytes) `mod` (2^64))
 
 replicate' :: Word16 -> a -> [a]
 replicate' 0 _ = []
 replicate' n x = x:replicate' (n-1) x
 
-size_split :: Int -> Integer -> [Int]
+size_split :: Int -> Int -> [Int]
 size_split 0 _ = []
 size_split p n = size_split (p-1) n' ++ [fromIntegral d]
  where (n', d) = divMod n 256
@@ -104,16 +105,19 @@
 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 -> ByteString -> ABCDE
 sha1_step_4_main abcde s = runST st where
-    st = newArray (0,79) 0 >>= sha1_step_4_work abcde s
+    st = newArray (0,79) 0 >>= sha1_step_4_work abcde s 0
 
 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
+abcseq :: ABCDE -> a -> a
+abcseq (a,b,c,d,e) x = a `seq` b `seq` c `seq` d `seq` e `seq` x
+
+sha1_step_4_work :: ABCDE -> ByteString -> Int -> Arr s -> ST s ABCDE
+sha1_step_4_work abcde s offs arr | offs >= B.length s = return abcde
+sha1_step_4_work abcde0 s offs arr = abcde0 `abcseq` do
+   sha1_ws 0 s offs 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
@@ -125,16 +129,18 @@
    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
+   sha1_step_4_work abcde5 s (offs+64) 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_ws :: Int -> ByteString -> Int -> Arr s -> ST s ByteString
+sha1_ws 16 s offs arr = return s
+sha1_ws n s offs arr = do 
+    let bs = map (\i -> B.index s (n+offs+i)) [0..3]
+        w = sum $ zipWith shiftL (map fromIntegral bs) [24, 16, 8, 0]
+    writeArray arr n w;  sha1_ws (n+1) s offs arr
 
 sha1_add_ws :: Int -> Arr s -> ST s ()
 sha1_add_ws 80 arr = return ()
@@ -142,10 +148,11 @@
                        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 :: (ABCDE -> Word32 -> ABCDE) -> ABCDE -> Arr s -> (Int,Int) -> 
+            ST s ABCDE
 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)
+                       | otherwise = do
+    val <- readArray arr i;   x `abcseq` 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)