{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE UnboxedTuples #-} module Crypto.Hash.SHA1 ( SHA1 ) where import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString as B import qualified Data.ByteString.Lazy.Char8 as LC import Data.ByteString (ByteString) import Data.ByteString.Builder import Control.Monad.ST import Data.Int import Data.Word import Data.Bits import Data.Monoid import Data.Array.Unboxed import Data.Array.Unsafe import Data.Array.ST import Data.List(foldl') import Crypto.Hash.ADT encodeInt64Helper :: Int64 -> [Word8] encodeInt64Helper :: Int64 -> [Word8] encodeInt64Helper Int64 x_ = [Word8 w7, Word8 w6, Word8 w5, Word8 w4, Word8 w3, Word8 w2, Word8 w1, Word8 w0] where x :: Int64 x = Int64 x_ forall a. Num a => a -> a -> a * Int64 8 w7 :: Word8 w7 = forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ (Int64 x forall a. Bits a => a -> Int -> a `shiftR` Int 56) forall a. Bits a => a -> a -> a .&. Int64 0xff w6 :: Word8 w6 = forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ (Int64 x forall a. Bits a => a -> Int -> a `shiftR` Int 48) forall a. Bits a => a -> a -> a .&. Int64 0xff w5 :: Word8 w5 = forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ (Int64 x forall a. Bits a => a -> Int -> a `shiftR` Int 40) forall a. Bits a => a -> a -> a .&. Int64 0xff w4 :: Word8 w4 = forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ (Int64 x forall a. Bits a => a -> Int -> a `shiftR` Int 32) forall a. Bits a => a -> a -> a .&. Int64 0xff w3 :: Word8 w3 = forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ (Int64 x forall a. Bits a => a -> Int -> a `shiftR` Int 24) forall a. Bits a => a -> a -> a .&. Int64 0xff w2 :: Word8 w2 = forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ (Int64 x forall a. Bits a => a -> Int -> a `shiftR` Int 16) forall a. Bits a => a -> a -> a .&. Int64 0xff w1 :: Word8 w1 = forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ (Int64 x forall a. Bits a => a -> Int -> a `shiftR` Int 8) forall a. Bits a => a -> a -> a .&. Int64 0xff w0 :: Word8 w0 = forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ (Int64 x forall a. Bits a => a -> Int -> a `shiftR` Int 0) forall a. Bits a => a -> a -> a .&. Int64 0xff encodeInt64 :: Int64 -> ByteString encodeInt64 :: Int64 -> ByteString encodeInt64 = [Word8] -> ByteString B.pack forall b c a. (b -> c) -> (a -> b) -> a -> c . Int64 -> [Word8] encodeInt64Helper sha1BlockSize :: Int sha1BlockSize :: Int sha1BlockSize = Int 64 lastChunk :: Int64 -> ByteString -> [ByteString] lastChunk :: Int64 -> ByteString -> [ByteString] lastChunk Int64 msglen ByteString s | Int len forall a. Ord a => a -> a -> Bool < (Int sha1BlockSize forall a. Num a => a -> a -> a - Int 8) = [ByteString s forall a. Semigroup a => a -> a -> a <> Word8 -> ByteString -> ByteString B.cons Word8 0x80 (Int -> Word8 -> ByteString B.replicate (Int sha1BlockSize forall a. Num a => a -> a -> a - Int 9 forall a. Num a => a -> a -> a - Int len) Word8 0x0) forall a. Semigroup a => a -> a -> a <> ByteString encodedLen] | Int len forall a. Ord a => a -> a -> Bool < (Int 2 forall a. Num a => a -> a -> a * Int sha1BlockSize forall a. Num a => a -> a -> a - Int 8) = ByteString -> [ByteString] helper (ByteString s forall a. Semigroup a => a -> a -> a <> Word8 -> ByteString -> ByteString B.cons Word8 0x80 (Int -> Word8 -> ByteString B.replicate (Int 2 forall a. Num a => a -> a -> a * Int sha1BlockSize forall a. Num a => a -> a -> a - Int 9 forall a. Num a => a -> a -> a - Int len) Word8 0x0) forall a. Semigroup a => a -> a -> a <> ByteString encodedLen) where len :: Int len = ByteString -> Int B.length ByteString s encodedLen :: ByteString encodedLen = Int64 -> ByteString encodeInt64 Int64 msglen helper :: ByteString -> [ByteString] helper ByteString bs = [ByteString s1, ByteString s2] where (ByteString s1, ByteString s2) = Int -> ByteString -> (ByteString, ByteString) B.splitAt Int 64 ByteString bs data SHA1 = SHA1 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 deriving SHA1 -> SHA1 -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: SHA1 -> SHA1 -> Bool $c/= :: SHA1 -> SHA1 -> Bool == :: SHA1 -> SHA1 -> Bool $c== :: SHA1 -> SHA1 -> Bool Eq initHash :: SHA1 initHash :: SHA1 initHash = Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> SHA1 SHA1 Word32 0x67452301 Word32 0xEFCDAB89 Word32 0x98BADCFE Word32 0x10325476 Word32 0xC3D2E1F0 instance Show SHA1 where show :: SHA1 -> String show = ByteString -> String LC.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c . Builder -> ByteString toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) m a. (Foldable t, Monoid m) => (a -> m) -> t a -> m foldMap Word32 -> Builder word32HexFixed forall b c a. (b -> c) -> (a -> b) -> a -> c . SHA1 -> [Word32] toList where toList :: SHA1 -> [Word32] toList (SHA1 Word32 a Word32 b Word32 c Word32 d Word32 e) = Word32 aforall a. a -> [a] -> [a] :Word32 bforall a. a -> [a] -> [a] :Word32 cforall a. a -> [a] -> [a] :Word32 dforall a. a -> [a] -> [a] :[Word32 e] sha1BlockUpdate :: SHA1 -> UArray Int Word64 -> SHA1 sha1BlockUpdate :: SHA1 -> UArray Int Word64 -> SHA1 sha1BlockUpdate SHA1 hv = forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' forall {b}. (Integral b, Bits b) => SHA1 -> (Int, b) -> SHA1 acc SHA1 hv forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [(i, e)] assocs where acc :: SHA1 -> (Int, b) -> SHA1 acc (SHA1 Word32 a Word32 b Word32 c Word32 d Word32 e) (!Int i, !b w) = Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> SHA1 SHA1 Word32 temp2 Word32 temp1 (Word32 a forall a. Bits a => a -> Int -> a `rotateL` Int 30) (Word32 b forall a. Bits a => a -> Int -> a `rotateL` Int 30) Word32 c where getK :: Int -> Word32 getK Int i | Int i forall a. Ord a => a -> a -> Bool < Int 10 = Word32 0x5a827999 | Int i forall a. Ord a => a -> a -> Bool < Int 20 = Word32 0x6ed9eba1 | Int i forall a. Ord a => a -> a -> Bool < Int 30 = Word32 0x8f1bbcdc | Int i forall a. Ord a => a -> a -> Bool < Int 40 = Word32 0xca62c1d6 getK :: Int -> Word32 {-# INLINE getK #-} getF1 :: Int -> Word32 getF1 Int i | Int i forall a. Ord a => a -> a -> Bool < Int 10 = Word32 d forall a. Bits a => a -> a -> a `xor` (Word32 b forall a. Bits a => a -> a -> a .&. (Word32 c forall a. Bits a => a -> a -> a `xor` Word32 d)) | Int i forall a. Ord a => a -> a -> Bool < Int 20 = Word32 b forall a. Bits a => a -> a -> a `xor` Word32 c forall a. Bits a => a -> a -> a `xor` Word32 d | Int i forall a. Ord a => a -> a -> Bool < Int 30 = (Word32 b forall a. Bits a => a -> a -> a .&. Word32 c) forall a. Bits a => a -> a -> a .|. (Word32 d forall a. Bits a => a -> a -> a .&. (Word32 b forall a. Bits a => a -> a -> a `xor` Word32 c)) | Int i forall a. Ord a => a -> a -> Bool < Int 40 = Word32 b forall a. Bits a => a -> a -> a `xor` Word32 c forall a. Bits a => a -> a -> a `xor` Word32 d getF1 :: Int -> Word32 {-# INLINE getF1 #-} getF2 :: Int -> Word32 getF2 Int i | Int i forall a. Ord a => a -> a -> Bool < Int 10 = Word32 c forall a. Bits a => a -> a -> a `xor` (Word32 a forall a. Bits a => a -> a -> a .&. ((Word32 b forall a. Bits a => a -> Int -> a `rotateL` Int 30) forall a. Bits a => a -> a -> a `xor` Word32 c)) | Int i forall a. Ord a => a -> a -> Bool < Int 20 = Word32 a forall a. Bits a => a -> a -> a `xor` (Word32 b forall a. Bits a => a -> Int -> a `rotateL` Int 30) forall a. Bits a => a -> a -> a `xor` Word32 c | Int i forall a. Ord a => a -> a -> Bool < Int 30 = (Word32 a forall a. Bits a => a -> a -> a .&. (Word32 b forall a. Bits a => a -> Int -> a `rotateL` Int 30)) forall a. Bits a => a -> a -> a .|. (Word32 c forall a. Bits a => a -> a -> a .&. (Word32 a forall a. Bits a => a -> a -> a `xor` (Word32 b forall a. Bits a => a -> Int -> a `rotateL` Int 30))) | Int i forall a. Ord a => a -> a -> Bool < Int 40 = Word32 a forall a. Bits a => a -> a -> a `xor` (Word32 b forall a. Bits a => a -> Int -> a `rotateL` Int 30) forall a. Bits a => a -> a -> a `xor` Word32 c getF2 :: Int -> Word32 {-# INLINE getF2 #-} !f1 :: Word32 f1 = Int -> Word32 getF1 Int i !f2 :: Word32 f2 = Int -> Word32 getF2 Int i !k :: Word32 k = Int -> Word32 getK Int i !temp1 :: Word32 temp1 = (Word32 a forall a. Bits a => a -> Int -> a `rotateL` Int 5) forall a. Num a => a -> a -> a + Word32 f1 forall a. Num a => a -> a -> a + Word32 e forall a. Num a => a -> a -> a + Word32 k forall a. Num a => a -> a -> a + (forall a b. (Integral a, Num b) => a -> b fromIntegral (b w forall a. Bits a => a -> Int -> a `shiftR` Int 32)) !temp2 :: Word32 temp2 = (Word32 temp1 forall a. Bits a => a -> Int -> a `rotateL` Int 5) forall a. Num a => a -> a -> a + Word32 f2 forall a. Num a => a -> a -> a + Word32 d forall a. Num a => a -> a -> a + Word32 k forall a. Num a => a -> a -> a + (forall a b. (Integral a, Num b) => a -> b fromIntegral (b w forall a. Bits a => a -> a -> a .&. b 0xffffffff)) {-# INLINE acc #-} {-# INLINE readW64 #-} readW64 :: ByteString -> Word64 readW64 :: ByteString -> Word64 readW64 = forall a. (a -> Word8 -> a) -> a -> ByteString -> a B.foldl' Word64 -> Word8 -> Word64 acc Word64 0 forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> ByteString -> ByteString B.take Int 8 where acc :: Word64 -> Word8 -> Word64 acc Word64 x Word8 c = Word64 x forall a. Bits a => a -> Int -> a `shiftL` Int 8 forall a. Num a => a -> a -> a + forall a b. (Integral a, Num b) => a -> b fromIntegral Word8 c acc :: Word64 -> Word8 -> Word64 {-# INLINE acc #-} prepareBlock :: ByteString -> UArray Int Word64 prepareBlock :: ByteString -> UArray Int Word64 prepareBlock ByteString s = forall a. (forall s. ST s a) -> a runST forall a b. (a -> b) -> a -> b $ do STUArray s Int Word64 iou <- forall (a :: * -> * -> *) e (m :: * -> *) i. (MArray a e m, Ix i) => (i, i) -> e -> m (a i e) newArray (Int 0, Int 39) Word64 0 :: ST s (STUArray s Int Word64) let !w1 :: Word64 w1 = ByteString -> Word64 readW64 ByteString s !w2 :: Word64 w2 = ByteString -> Word64 readW64 (Int -> ByteString -> ByteString B.drop Int 8 ByteString s) !w3 :: Word64 w3 = ByteString -> Word64 readW64 (Int -> ByteString -> ByteString B.drop Int 16 ByteString s) !w4 :: Word64 w4 = ByteString -> Word64 readW64 (Int -> ByteString -> ByteString B.drop Int 24 ByteString s) !w5 :: Word64 w5 = ByteString -> Word64 readW64 (Int -> ByteString -> ByteString B.drop Int 32 ByteString s) !w6 :: Word64 w6 = ByteString -> Word64 readW64 (Int -> ByteString -> ByteString B.drop Int 40 ByteString s) !w7 :: Word64 w7 = ByteString -> Word64 readW64 (Int -> ByteString -> ByteString B.drop Int 48 ByteString s) !w8 :: Word64 w8 = ByteString -> Word64 readW64 (Int -> ByteString -> ByteString B.drop Int 56 ByteString s) forall (a :: * -> * -> *) e (m :: * -> *) i. (MArray a e m, Ix i) => a i e -> i -> e -> m () writeArray STUArray s Int Word64 iou Int 0 Word64 w1 forall (a :: * -> * -> *) e (m :: * -> *) i. (MArray a e m, Ix i) => a i e -> i -> e -> m () writeArray STUArray s Int Word64 iou Int 1 Word64 w2 forall (a :: * -> * -> *) e (m :: * -> *) i. (MArray a e m, Ix i) => a i e -> i -> e -> m () writeArray STUArray s Int Word64 iou Int 2 Word64 w3 forall (a :: * -> * -> *) e (m :: * -> *) i. (MArray a e m, Ix i) => a i e -> i -> e -> m () writeArray STUArray s Int Word64 iou Int 3 Word64 w4 forall (a :: * -> * -> *) e (m :: * -> *) i. (MArray a e m, Ix i) => a i e -> i -> e -> m () writeArray STUArray s Int Word64 iou Int 4 Word64 w5 forall (a :: * -> * -> *) e (m :: * -> *) i. (MArray a e m, Ix i) => a i e -> i -> e -> m () writeArray STUArray s Int Word64 iou Int 5 Word64 w6 forall (a :: * -> * -> *) e (m :: * -> *) i. (MArray a e m, Ix i) => a i e -> i -> e -> m () writeArray STUArray s Int Word64 iou Int 6 Word64 w7 forall (a :: * -> * -> *) e (m :: * -> *) i. (MArray a e m, Ix i) => a i e -> i -> e -> m () writeArray STUArray s Int Word64 iou Int 7 Word64 w8 let step1 :: Int -> m () step1 Int i = forall (a :: * -> * -> *) e (m :: * -> *) i. (MArray a e m, Ix i) => a i e -> i -> m e readArray STUArray s Int Word64 iou (Int iforall a. Num a => a -> a -> a -Int 8) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \Word64 x1 -> forall (a :: * -> * -> *) e (m :: * -> *) i. (MArray a e m, Ix i) => a i e -> i -> m e readArray STUArray s Int Word64 iou (Int iforall a. Num a => a -> a -> a -Int 7) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \Word64 x2 -> forall (a :: * -> * -> *) e (m :: * -> *) i. (MArray a e m, Ix i) => a i e -> i -> m e readArray STUArray s Int Word64 iou (Int iforall a. Num a => a -> a -> a -Int 4) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \Word64 x3 -> forall (a :: * -> * -> *) e (m :: * -> *) i. (MArray a e m, Ix i) => a i e -> i -> m e readArray STUArray s Int Word64 iou (Int iforall a. Num a => a -> a -> a -Int 2) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \Word64 x4 -> forall (a :: * -> * -> *) e (m :: * -> *) i. (MArray a e m, Ix i) => a i e -> i -> m e readArray STUArray s Int Word64 iou (Int iforall a. Num a => a -> a -> a -Int 1) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \Word64 x5 -> let !wi :: Word64 wi = (Word64 x1 forall a. Bits a => a -> a -> a `xor` Word64 x2 forall a. Bits a => a -> a -> a `xor` Word64 x3 forall a. Bits a => a -> a -> a `xor` ( ((Word64 x4 forall a. Bits a => a -> a -> a .&. Word64 0xffffffff) forall a. Bits a => a -> Int -> a `shiftL` Int 32) forall a. Bits a => a -> a -> a .|. (Word64 x5 forall a. Bits a => a -> Int -> a `shiftR` Int 32) )) forall a. Bits a => a -> Int -> a `rotateL` Int 1 !i1 :: Word64 i1 = (Word64 wi forall a. Bits a => a -> Int -> a `shiftR` Int 32) forall a. Bits a => a -> a -> a .&. Word64 0x1 !i2 :: Word64 i2 = Word64 wi forall a. Bits a => a -> a -> a .&. Word64 0x1 !wj :: Word64 wj = (Word64 wi forall a. Bits a => a -> a -> a .&. Word64 0xfffffffefffffffe) forall a. Bits a => a -> a -> a .|. Word64 i1 forall a. Bits a => a -> a -> a .|. (Word64 i2 forall a. Bits a => a -> Int -> a `shiftL` Int 32) in forall (a :: * -> * -> *) e (m :: * -> *) i. (MArray a e m, Ix i) => a i e -> i -> e -> m () writeArray STUArray s Int Word64 iou Int i Word64 wj {-# INLINE step1 #-} forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ forall {m :: * -> *}. MArray (STUArray s) Word64 m => Int -> m () step1 [Int 8..Int 39] forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *). (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e) unsafeFreeze STUArray s Int Word64 iou {-# INLINE encodeChunk #-} encodeChunk :: SHA1 -> ByteString -> SHA1 encodeChunk :: SHA1 -> ByteString -> SHA1 encodeChunk hv :: SHA1 hv@(SHA1 Word32 a Word32 b Word32 c Word32 d Word32 e) ByteString bs = Word32 -> Word32 -> Word32 -> Word32 -> Word32 -> SHA1 SHA1 (Word32 aforall a. Num a => a -> a -> a +Word32 a') (Word32 bforall a. Num a => a -> a -> a +Word32 b') (Word32 cforall a. Num a => a -> a -> a +Word32 c') (Word32 dforall a. Num a => a -> a -> a +Word32 d') (Word32 eforall a. Num a => a -> a -> a +Word32 e') where SHA1 Word32 a' Word32 b' Word32 c' Word32 d' Word32 e' = SHA1 -> UArray Int Word64 -> SHA1 sha1BlockUpdate SHA1 hv (ByteString -> UArray Int Word64 prepareBlock ByteString bs) sha1Init :: Context SHA1 sha1Init :: Context SHA1 sha1Init = forall a. Int64 -> Int -> ByteString -> a -> Context a Context Int64 0 Int 0 ByteString B.empty SHA1 initHash {-# NOINLINE sha1Update #-} sha1Update :: Context SHA1 -> ByteString -> Context SHA1 sha1Update :: Context SHA1 -> ByteString -> Context SHA1 sha1Update ctx :: Context SHA1 ctx@(Context Int64 n Int k ByteString w SHA1 hv) ByteString s | ByteString -> Bool B.null ByteString s = Context SHA1 ctx | Int sizeRead forall a. Ord a => a -> a -> Bool < Int sizeToRead = forall a. Int64 -> Int -> ByteString -> a -> Context a Context (Int64 n forall a. Num a => a -> a -> a + forall a b. (Integral a, Num b) => a -> b fromIntegral Int sizeRead) (Int k forall a. Num a => a -> a -> a + Int sizeRead) (ByteString w forall a. Semigroup a => a -> a -> a <> ByteString s1) SHA1 hv | Int sizeRead forall a. Ord a => a -> a -> Bool >= Int sizeToRead = Context SHA1 -> ByteString -> Context SHA1 sha1Update (forall a. Int64 -> Int -> ByteString -> a -> Context a Context (Int64 n forall a. Num a => a -> a -> a + forall a b. (Integral a, Num b) => a -> b fromIntegral Int sizeToRead) Int 0 forall a. Monoid a => a mempty (SHA1 -> ByteString -> SHA1 encodeChunk SHA1 hv (ByteString w forall a. Semigroup a => a -> a -> a <> ByteString s1))) ByteString s' where !sizeToRead :: Int sizeToRead = Int sha1BlockSize forall a. Num a => a -> a -> a - Int k !s1 :: ByteString s1 = Int -> ByteString -> ByteString B.take Int sizeToRead ByteString s !s' :: ByteString s' = Int -> ByteString -> ByteString B.drop Int sizeToRead ByteString s !sizeRead :: Int sizeRead = ByteString -> Int B.length ByteString s1 {-# NOINLINE sha1Final #-} sha1Final :: Context SHA1 -> SHA1 sha1Final :: Context SHA1 -> SHA1 sha1Final (Context Int64 n Int _ ByteString w SHA1 hv) = forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' SHA1 -> ByteString -> SHA1 encodeChunk SHA1 hv (Int64 -> ByteString -> [ByteString] lastChunk Int64 n ByteString w) {-# NOINLINE sha1Hash #-} sha1Hash :: LBS.ByteString -> SHA1 sha1Hash :: ByteString -> SHA1 sha1Hash = Context SHA1 -> SHA1 sha1Final forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. (a -> ByteString -> a) -> a -> ByteString -> a LBS.foldlChunks Context SHA1 -> ByteString -> Context SHA1 sha1Update Context SHA1 sha1Init instance HashAlgorithm SHA1 where hashBlockSize :: SHA1 -> Int hashBlockSize = forall a b. a -> b -> a const Int sha1BlockSize hashDigestSize :: SHA1 -> Int hashDigestSize = forall a b. a -> b -> a const Int 20 hashInit :: Context SHA1 hashInit = Context SHA1 sha1Init hashUpdate :: Context SHA1 -> ByteString -> Context SHA1 hashUpdate = Context SHA1 -> ByteString -> Context SHA1 sha1Update hashFinal :: Context SHA1 -> SHA1 hashFinal = Context SHA1 -> SHA1 sha1Final