{-# OPTIONS_GHC -fglasgow-exts -O2 #-} {- ============================================================================= COPYING Copyright (C) 2001 Ian Lynagh Copyright (C) 2007 Benja Fallenstein 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.ByteString and Data.Array.ST * Changed from .lhs to .hs ============================================================================= -} module SHA1 (sha1) where import Control.Monad.ST.Strict import Data.Array.ST import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.Char import Data.Word data ABCDE = ABCDE !Word32 !Word32 !Word32 !Word32 !Word32 type Rotation = Int type Arr s = STUArray s Int Word32 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_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 ((8 * toInteger (B.length bytes)) `mod` (2^64)) replicate' :: Word16 -> a -> [a] replicate' 0 _ = [] replicate' n x = x:replicate' (n-1) x 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 sha1_step_3_init :: ABCDE sha1_step_3_init = ABCDE 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0 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 0 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 | offs > B.length s = error "SHA1: bug" sha1_step_4_work abcde0 s offs arr = 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 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 ABCDE a b c d e = abcde0 ABCDE a' b' c' d' e' = abcde4 abcde5 = ABCDE (a + a') (b + b') (c + c') (d + d') (e + e') abcde5 `seq` sha1_step_4_work abcde5 s (offs+64) arr doit :: (Word32 -> Word32 -> Word32 -> Word32) -> Word32 -> ABCDE -> Word32 -> ABCDE doit f k (ABCDE a b c d e) w = (ABCDE a' a (rotL b 30) c d) where a' = rotL a 5 + f b c d + e + w + k 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 b1 = fromIntegral $ B.index s (offs) b2 = fromIntegral $ B.index s (offs+1) b3 = fromIntegral $ B.index s (offs+2) b4 = fromIntegral $ B.index s (offs+3) w = shiftL b1 24 + shiftL b2 16 + shiftL b3 8 + b4 writeArray arr n w; sha1_ws (n+1) s (offs+4) arr sha1_add_ws :: Int -> Arr s -> ST s () sha1_add_ws 80 arr = return () sha1_add_ws n arr = do w1 <- readArray arr (n-3); w2 <- readArray arr (n-8) w3 <- readArray arr (n-14); w4 <- readArray arr (n-16) writeArray arr n $ rotL (w1 `xor` w2 `xor` w3 `xor` w4) 1 sha1_add_ws (n+1) arr 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; x `seq` fold_arr f (f x val) arr (i+1) j sha1_step_5_display :: ABCDE -> String sha1_step_5_display (ABCDE 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) {-# INLINE rotL #-} rotL :: Word32 -> Rotation -> Word32 rotL a s = shiftL a s .|. shiftL a (s-32)