module Crypto.Hash.SHA1
(
Ctx(..)
, init
, update
, updates
, finalize
, hash
, hashlazy
, hmac
, hmaclazy
) where
import Prelude hiding (init)
import Foreign.C.Types
import Foreign.Ptr
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Marshal.Alloc
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as B
import Data.ByteString (ByteString)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Data.ByteString.Internal (create, toForeignPtr, memcpy)
import Data.Bits (xor)
import Data.Word
import System.IO.Unsafe (unsafeDupablePerformIO)
unsafeDoIO :: IO a -> a
unsafeDoIO = unsafeDupablePerformIO
newtype Ctx = Ctx ByteString
{-# INLINE digestSize #-}
digestSize :: Int
digestSize = 20
{-# INLINE sizeCtx #-}
sizeCtx :: Int
sizeCtx = 92
{-# RULES "digestSize" B.length (finalize init) = digestSize #-}
{-# RULES "hash" forall b. finalize (update init b) = hash b #-}
{-# RULES "hash.list1" forall b. finalize (updates init [b]) = hash b #-}
{-# RULES "hashmany" forall b. finalize (foldl update init b) = hashlazy (L.fromChunks b) #-}
{-# RULES "hashlazy" forall b. finalize (foldl update init $ L.toChunks b) = hashlazy b #-}
{-# INLINE withByteStringPtr #-}
withByteStringPtr :: ByteString -> (Ptr Word8 -> IO a) -> IO a
withByteStringPtr b f =
withForeignPtr fptr $ \ptr -> f (ptr `plusPtr` off)
where (fptr, off, _) = toForeignPtr b
copyCtx :: Ptr Ctx -> Ptr Ctx -> IO ()
copyCtx dst src = memcpy (castPtr dst) (castPtr src) (fromIntegral sizeCtx)
withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx
withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx
where
createCtx = create sizeCtx $ \dstPtr ->
withByteStringPtr ctxB $ \srcPtr -> do
copyCtx (castPtr dstPtr) (castPtr srcPtr)
f (castPtr dstPtr)
withCtxThrow :: Ctx -> (Ptr Ctx -> IO a) -> IO a
withCtxThrow (Ctx ctxB) f =
allocaBytes sizeCtx $ \dstPtr ->
withByteStringPtr ctxB $ \srcPtr -> do
copyCtx (castPtr dstPtr) (castPtr srcPtr)
f (castPtr dstPtr)
withCtxNew :: (Ptr Ctx -> IO ()) -> IO Ctx
withCtxNew f = Ctx `fmap` create sizeCtx (f . castPtr)
withCtxNewThrow :: (Ptr Ctx -> IO a) -> IO a
withCtxNewThrow f = allocaBytes sizeCtx (f . castPtr)
foreign import ccall unsafe "sha1.h hs_cryptohash_sha1_init"
c_sha1_init :: Ptr Ctx -> IO ()
foreign import ccall unsafe "sha1.h hs_cryptohash_sha1_update"
c_sha1_update_unsafe :: Ptr Ctx -> Ptr Word8 -> CSize -> IO ()
foreign import ccall safe "sha1.h hs_cryptohash_sha1_update"
c_sha1_update_safe :: Ptr Ctx -> Ptr Word8 -> CSize -> IO ()
c_sha1_update :: Ptr Ctx -> Ptr Word8 -> CSize -> IO ()
c_sha1_update pctx pbuf sz
| sz < 8192 = c_sha1_update_unsafe pctx pbuf sz
| otherwise = c_sha1_update_safe pctx pbuf sz
foreign import ccall unsafe "sha1.h hs_cryptohash_sha1_finalize"
c_sha1_finalize :: Ptr Ctx -> Ptr Word8 -> IO ()
updateInternalIO :: Ptr Ctx -> ByteString -> IO ()
updateInternalIO ptr d =
unsafeUseAsCStringLen d (\(cs, len) -> c_sha1_update ptr (castPtr cs) (fromIntegral len))
finalizeInternalIO :: Ptr Ctx -> IO ByteString
finalizeInternalIO ptr = create digestSize (c_sha1_finalize ptr)
{-# NOINLINE init #-}
init :: Ctx
init = unsafeDoIO $ withCtxNew $ c_sha1_init
validCtx :: Ctx -> Bool
validCtx (Ctx b) = B.length b == sizeCtx
{-# NOINLINE update #-}
update :: Ctx -> ByteString -> Ctx
update ctx d
| validCtx ctx = unsafeDoIO $ withCtxCopy ctx $ \ptr -> updateInternalIO ptr d
| otherwise = error "SHA1.update: invalid Ctx"
{-# NOINLINE updates #-}
updates :: Ctx -> [ByteString] -> Ctx
updates ctx d
| validCtx ctx = unsafeDoIO $ withCtxCopy ctx $ \ptr -> mapM_ (updateInternalIO ptr) d
| otherwise = error "SHA1.updates: invalid Ctx"
{-# NOINLINE finalize #-}
finalize :: Ctx -> ByteString
finalize ctx
| validCtx ctx = unsafeDoIO $ withCtxThrow ctx finalizeInternalIO
| otherwise = error "SHA1.finalize: invalid Ctx"
{-# NOINLINE hash #-}
hash :: ByteString -> ByteString
hash d = unsafeDoIO $ withCtxNewThrow $ \ptr -> do
c_sha1_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr
{-# NOINLINE hashlazy #-}
hashlazy :: L.ByteString -> ByteString
hashlazy l = unsafeDoIO $ withCtxNewThrow $ \ptr -> do
c_sha1_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr
{-# NOINLINE hmac #-}
hmac :: ByteString
-> ByteString
-> ByteString
hmac secret msg = hash $ B.append opad (hash $ B.append ipad msg)
where
opad = B.map (xor 0x5c) k'
ipad = B.map (xor 0x36) k'
k' = B.append kt pad
kt = if B.length secret > 64 then hash secret else secret
pad = B.replicate (64 - B.length kt) 0
{-# NOINLINE hmaclazy #-}
hmaclazy :: ByteString
-> L.ByteString
-> ByteString
hmaclazy secret msg = hash $ B.append opad (hashlazy $ L.append ipad msg)
where
opad = B.map (xor 0x5c) k'
ipad = L.fromChunks [B.map (xor 0x36) k']
k' = B.append kt pad
kt = if B.length secret > 64 then hash secret else secret
pad = B.replicate (64 - B.length kt) 0