diff --git a/Bench.hs b/Bench.hs deleted file mode 100644 --- a/Bench.hs +++ /dev/null @@ -1,44 +0,0 @@ -import Criterion.Main -import qualified Data.ByteString as B -import qualified Crypto.Hash.MD2 as MD2 -import qualified Crypto.Hash.MD4 as MD4 -import qualified Crypto.Hash.MD5 as MD5 -import qualified Crypto.Hash.SHA1 as SHA1 -import qualified Crypto.Hash.SHA224 as SHA224 -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Crypto.Hash.SHA384 as SHA384 -import qualified Crypto.Hash.SHA512 as SHA512 -import qualified Crypto.Hash.SHA512t as SHA512t -import qualified Crypto.Hash.RIPEMD160 as RIPEMD160 -import qualified Crypto.Hash.Tiger as Tiger -import qualified Crypto.Hash.Skein256 as Skein256 -import qualified Crypto.Hash.Skein512 as Skein512 -import qualified Crypto.Hash.Whirlpool as Whirlpool - -allHashs = - [ ("MD2",MD2.hash) - , ("MD4",MD4.hash) - , ("MD5",MD5.hash) - , ("SHA1",SHA1.hash) - , ("SHA224",SHA224.hash) - , ("SHA256",SHA256.hash) - , ("SHA384",SHA384.hash) - , ("SHA512",SHA512.hash) - , ("SHA512t-512",(SHA512t.hash 512)) - , ("RIPEMD160",RIPEMD160.hash) - , ("Tiger",Tiger.hash) - , ("Skein256-256",Skein256.hash 256) - , ("Skein512-512",Skein512.hash 512) - , ("Whirlpool",Whirlpool.hash) - ] - -benchHash :: Int -> (B.ByteString -> B.ByteString) -> Pure -benchHash sz f = whnf f (B.replicate sz 0) - -withHashes f = map f allHashs - -main = defaultMain - [ bgroup "hash-256b" (withHashes (\(name, f) -> bench name $ benchHash 256 f)) - , bgroup "hash-4Kb" (withHashes (\(name, f) -> bench name $ benchHash 4096 f)) - , bgroup "hash-1Mb" (withHashes (\(name, f) -> bench name $ benchHash (1*1024*1024) f)) - ] diff --git a/Bench/Bench.hs b/Bench/Bench.hs new file mode 100644 --- /dev/null +++ b/Bench/Bench.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE BangPatterns #-} +import Criterion.Main +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Crypto.Hash.MD2 as MD2 +import qualified Crypto.Hash.MD4 as MD4 +import qualified Crypto.Hash.MD5 as MD5 +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Crypto.Hash.SHA224 as SHA224 +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Crypto.Hash.SHA384 as SHA384 +import qualified Crypto.Hash.SHA512 as SHA512 +import qualified Crypto.Hash.SHA512t as SHA512t +import qualified Crypto.Hash.SHA3 as SHA3 +import qualified Crypto.Hash.RIPEMD160 as RIPEMD160 +import qualified Crypto.Hash.Tiger as Tiger +import qualified Crypto.Hash.Skein256 as Skein256 +import qualified Crypto.Hash.Skein512 as Skein512 +import qualified Crypto.Hash.Whirlpool as Whirlpool + +hashmany (i,u,f) = f . foldl u i + +allHashs = + [ ("MD2",MD2.hash, hashmany (MD2.init,MD2.update,MD2.finalize)) + , ("MD4",MD4.hash, hashmany (MD4.init,MD4.update,MD4.finalize)) + , ("MD5",MD5.hash, hashmany (MD5.init,MD5.update,MD5.finalize)) + , ("SHA1",SHA1.hash, hashmany (SHA1.init,SHA1.update,SHA1.finalize)) + , ("SHA2-224",SHA224.hash, hashmany (SHA224.init,SHA224.update,SHA224.finalize)) + , ("SHA2-256",SHA256.hash, hashmany (SHA256.init,SHA256.update,SHA256.finalize)) + , ("SHA2-384",SHA384.hash, hashmany (SHA384.init,SHA384.update,SHA384.finalize)) + , ("SHA2-512",SHA512.hash, hashmany (SHA512.init,SHA512.update,SHA512.finalize)) + , ("SHA2-512t-512",SHA512t.hash 512, hashmany (SHA512t.init 512,SHA512t.update,SHA512t.finalize)) + , ("SHA3-224",SHA3.hash 224, hashmany (SHA3.init 224,SHA3.update,SHA3.finalize)) + , ("SHA3-256",SHA3.hash 256, hashmany (SHA3.init 256,SHA3.update,SHA3.finalize)) + , ("SHA3-384",SHA3.hash 384, hashmany (SHA3.init 384,SHA3.update,SHA3.finalize)) + , ("SHA3-512",SHA3.hash 512, hashmany (SHA3.init 512,SHA3.update,SHA3.finalize)) + , ("RIPEMD160",RIPEMD160.hash, hashmany (RIPEMD160.init,RIPEMD160.update,RIPEMD160.finalize)) + , ("Tiger",Tiger.hash, hashmany (Tiger.init,Tiger.update,Tiger.finalize)) + , ("Skein256-256",Skein256.hash 256, hashmany (Skein256.init 256,Skein256.update,Skein256.finalize)) + , ("Skein512-512",Skein512.hash 512, hashmany (Skein512.init 512,Skein512.update,Skein512.finalize)) + , ("Whirlpool",Whirlpool.hash, hashmany (Whirlpool.init,Whirlpool.update,Whirlpool.finalize)) + ] + +benchHash :: a -> (a -> B.ByteString) -> Pure +benchHash bs f = whnf f bs + +withHashesFilter out f = map f $ filter (\(n,_,_) -> not (n `elem` out)) allHashs +withHashes f = map f allHashs + +main = do + let !bs32 = B.replicate 32 0 + !bs256 = B.replicate 256 0 + !bs4096 = B.replicate 4096 0 + !bs1M = B.replicate (1*1024*1024) 0 + let !lbs64x256 = (map (const (B.replicate 64 0)) [0..3]) + !lbs64x4096 = (map (const (B.replicate 64 0)) [0..63]) + defaultMain + [ bgroup "hash-32b" (withHashes (\(name, f,_) -> bench name $ benchHash bs32 f)) + , bgroup "hash-256b" (withHashes (\(name, f,_) -> bench name $ benchHash bs256 f)) + , bgroup "hash-4Kb" (withHashes (\(name, f,_) -> bench name $ benchHash bs4096 f)) + , bgroup "hash-1Mb" (withHashesFilter ["MD2"] (\(name, f,_) -> bench name $ benchHash bs1M f)) + , bgroup "iuf-64x256" (withHashes (\(name, _,f) -> bench name $ benchHash lbs64x256 f)) + , bgroup "iuf-64x4096" (withHashes (\(name, _,f) -> bench name $ benchHash lbs64x4096 f)) + ] diff --git a/Crypto/Hash/MD2.hs b/Crypto/Hash/MD2.hs --- a/Crypto/Hash/MD2.hs +++ b/Crypto/Hash/MD2.hs @@ -10,30 +10,28 @@ -- A module containing MD2 bindings -- module Crypto.Hash.MD2 - ( Ctx(..) - , MD2 + ( Ctx(..) + , MD2 - -- * Incremental hashing Functions - , init -- :: Ctx - , update -- :: Ctx -> ByteString -> Ctx - , finalize -- :: Ctx -> ByteString + -- * Incremental hashing Functions + , init -- :: Ctx + , update -- :: Ctx -> ByteString -> Ctx + , finalize -- :: Ctx -> ByteString - -- * Single Pass hashing - , hash -- :: ByteString -> ByteString - , hashlazy -- :: ByteString -> ByteString - ) where + -- * Single Pass hashing + , hash -- :: ByteString -> ByteString + , hashlazy -- :: ByteString -> ByteString + ) where import Prelude hiding (init) -import System.IO.Unsafe (unsafePerformIO) -import Foreign.C.String import Foreign.Ptr +import Foreign.ForeignPtr (withForeignPtr) import Foreign.Storable import Foreign.Marshal.Alloc -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString) -import Data.ByteString.Unsafe (unsafeUseAsCString, unsafeUseAsCStringLen) -import Data.ByteString.Internal (create, memcpy) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.ByteString.Internal (create, toForeignPtr, inlinePerformIO) import Data.Word #ifdef HAVE_CRYPTOAPI @@ -46,79 +44,102 @@ import qualified Crypto.Classes as C (Hash(..)) instance C.Hash Ctx MD2 where - outputLength = Tagged (16 * 8) - blockLength = Tagged (16 * 8) - initialCtx = init - updateCtx = update - finalize ctx bs = Digest . finalize $ update ctx bs + outputLength = Tagged (16 * 8) + blockLength = Tagged (16 * 8) + initialCtx = init + updateCtx = update + finalize ctx bs = Digest . finalize $ update ctx bs instance Serialize MD2 where - get = liftM Digest (getByteString digestSize) - put (Digest d) = putByteString d + get = liftM Digest (getByteString digestSize) + put (Digest d) = putByteString d #endif data Ctx = Ctx !ByteString data MD2 = Digest !ByteString - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show) -digestSize, sizeCtx :: Int + +{-# INLINE digestSize #-} +digestSize :: Int digestSize = 16 + +{-# INLINE sizeCtx #-} +sizeCtx :: Int sizeCtx = 96 -instance Storable Ctx where - sizeOf _ = sizeCtx - alignment _ = 16 - poke ptr (Ctx b) = unsafeUseAsCString b (\cs -> memcpy (castPtr ptr) (castPtr cs) (fromIntegral sizeCtx)) +{-# 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 - peek ptr = create sizeCtx (\bptr -> memcpy bptr (castPtr ptr) (fromIntegral sizeCtx)) >>= return . Ctx +{-# INLINE memcopy64 #-} +memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO () +memcopy64 dst src = mapM_ peekAndPoke [0..(12-1)] + where peekAndPoke i = peekElemOff src i >>= pokeElemOff dst i +withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx +withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx + where createCtx = create sizeCtx $ \dstPtr -> + withByteStringPtr ctxB $ \srcPtr -> do + memcopy64 (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 + memcopy64 (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 "md2.h md2_init" - c_md2_init :: Ptr Ctx -> IO () + c_md2_init :: Ptr Ctx -> IO () foreign import ccall "md2.h md2_update" - c_md2_update :: Ptr Ctx -> CString -> Word32 -> IO () + c_md2_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO () foreign import ccall unsafe "md2.h md2_finalize" - c_md2_finalize :: Ptr Ctx -> CString -> IO () - -allocInternal :: (Ptr Ctx -> IO a) -> IO a -allocInternal = alloca - -allocInternalFrom :: Ctx -> (Ptr Ctx -> IO a) -> IO a -allocInternalFrom ctx f = allocInternal $ \ptr -> (poke ptr ctx >> f ptr) + c_md2_finalize :: Ptr Ctx -> Ptr Word8 -> IO () updateInternalIO :: Ptr Ctx -> ByteString -> IO () updateInternalIO ptr d = - unsafeUseAsCStringLen d (\(cs, len) -> c_md2_update ptr cs (fromIntegral len)) + unsafeUseAsCStringLen d (\(cs, len) -> c_md2_update ptr (castPtr cs) (fromIntegral len)) finalizeInternalIO :: Ptr Ctx -> IO ByteString finalizeInternalIO ptr = - allocaBytes digestSize (\cs -> c_md2_finalize ptr cs >> B.packCStringLen (cs, digestSize)) + create digestSize (c_md2_finalize ptr) {-# NOINLINE init #-} -- | init a context init :: Ctx -init = unsafePerformIO $ allocInternal $ \ptr -> do (c_md2_init ptr >> peek ptr) +init = inlinePerformIO $ withCtxNew $ c_md2_init {-# NOINLINE update #-} -- | update a context with a bytestring update :: Ctx -> ByteString -> Ctx -update ctx d = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do updateInternalIO ptr d >> peek ptr +update ctx d = inlinePerformIO $ withCtxCopy ctx $ \ptr -> updateInternalIO ptr d {-# NOINLINE finalize #-} -- | finalize the context into a digest bytestring finalize :: Ctx -> ByteString -finalize ctx = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do finalizeInternalIO ptr +finalize ctx = inlinePerformIO $ withCtxThrow ctx finalizeInternalIO {-# NOINLINE hash #-} -- | hash a strict bytestring into a digest bytestring hash :: ByteString -> ByteString -hash d = unsafePerformIO $ allocInternal $ \ptr -> do - c_md2_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr +hash d = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_md2_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr {-# NOINLINE hashlazy #-} -- | hash a lazy bytestring into a digest bytestring hashlazy :: L.ByteString -> ByteString -hashlazy l = unsafePerformIO $ allocInternal $ \ptr -> do - c_md2_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr +hashlazy l = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_md2_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr diff --git a/Crypto/Hash/MD4.hs b/Crypto/Hash/MD4.hs --- a/Crypto/Hash/MD4.hs +++ b/Crypto/Hash/MD4.hs @@ -10,30 +10,28 @@ -- A module containing MD4 bindings -- module Crypto.Hash.MD4 - ( Ctx(..) - , MD4 + ( Ctx(..) + , MD4 - -- * Incremental hashing Functions - , init -- :: Ctx - , update -- :: Ctx -> ByteString -> Ctx - , finalize -- :: Ctx -> ByteString + -- * Incremental hashing Functions + , init -- :: Ctx + , update -- :: Ctx -> ByteString -> Ctx + , finalize -- :: Ctx -> ByteString - -- * Single Pass hashing - , hash -- :: ByteString -> ByteString - , hashlazy -- :: ByteString -> ByteString - ) where + -- * Single Pass hashing + , hash -- :: ByteString -> ByteString + , hashlazy -- :: ByteString -> ByteString + ) where import Prelude hiding (init) -import System.IO.Unsafe (unsafePerformIO) -import Foreign.C.String import Foreign.Ptr +import Foreign.ForeignPtr (withForeignPtr) import Foreign.Storable import Foreign.Marshal.Alloc -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString) -import Data.ByteString.Unsafe (unsafeUseAsCString, unsafeUseAsCStringLen) -import Data.ByteString.Internal (create, memcpy) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.ByteString.Internal (create, toForeignPtr, inlinePerformIO) import Data.Word #ifdef HAVE_CRYPTOAPI @@ -46,79 +44,102 @@ import qualified Crypto.Classes as C (Hash(..)) instance C.Hash Ctx MD4 where - outputLength = Tagged (16 * 8) - blockLength = Tagged (64 * 8) - initialCtx = init - updateCtx = update - finalize ctx bs = Digest . finalize $ update ctx bs + outputLength = Tagged (16 * 8) + blockLength = Tagged (64 * 8) + initialCtx = init + updateCtx = update + finalize ctx bs = Digest . finalize $ update ctx bs instance Serialize MD4 where - get = liftM Digest (getByteString digestSize) - put (Digest d) = putByteString d + get = liftM Digest (getByteString digestSize) + put (Digest d) = putByteString d #endif data Ctx = Ctx !ByteString data MD4 = Digest !ByteString - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show) -digestSize, sizeCtx :: Int + +{-# INLINE digestSize #-} +digestSize :: Int digestSize = 16 + +{-# INLINE sizeCtx #-} +sizeCtx :: Int sizeCtx = 96 -instance Storable Ctx where - sizeOf _ = sizeCtx - alignment _ = 16 - poke ptr (Ctx b) = unsafeUseAsCString b (\cs -> memcpy (castPtr ptr) (castPtr cs) (fromIntegral sizeCtx)) +{-# 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 - peek ptr = create sizeCtx (\bptr -> memcpy bptr (castPtr ptr) (fromIntegral sizeCtx)) >>= return . Ctx +{-# INLINE memcopy64 #-} +memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO () +memcopy64 dst src = mapM_ peekAndPoke [0..(12-1)] + where peekAndPoke i = peekElemOff src i >>= pokeElemOff dst i +withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx +withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx + where createCtx = create sizeCtx $ \dstPtr -> + withByteStringPtr ctxB $ \srcPtr -> do + memcopy64 (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 + memcopy64 (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 "md4.h md4_init" - c_md4_init :: Ptr Ctx -> IO () + c_md4_init :: Ptr Ctx -> IO () foreign import ccall "md4.h md4_update" - c_md4_update :: Ptr Ctx -> CString -> Word32 -> IO () + c_md4_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO () foreign import ccall unsafe "md4.h md4_finalize" - c_md4_finalize :: Ptr Ctx -> CString -> IO () - -allocInternal :: (Ptr Ctx -> IO a) -> IO a -allocInternal = alloca - -allocInternalFrom :: Ctx -> (Ptr Ctx -> IO a) -> IO a -allocInternalFrom ctx f = allocInternal $ \ptr -> (poke ptr ctx >> f ptr) + c_md4_finalize :: Ptr Ctx -> Ptr Word8 -> IO () updateInternalIO :: Ptr Ctx -> ByteString -> IO () updateInternalIO ptr d = - unsafeUseAsCStringLen d (\(cs, len) -> c_md4_update ptr cs (fromIntegral len)) + unsafeUseAsCStringLen d (\(cs, len) -> c_md4_update ptr (castPtr cs) (fromIntegral len)) finalizeInternalIO :: Ptr Ctx -> IO ByteString finalizeInternalIO ptr = - allocaBytes digestSize (\cs -> c_md4_finalize ptr cs >> B.packCStringLen (cs, digestSize)) + create digestSize (c_md4_finalize ptr) {-# NOINLINE init #-} -- | init a context init :: Ctx -init = unsafePerformIO $ allocInternal $ \ptr -> do (c_md4_init ptr >> peek ptr) +init = inlinePerformIO $ withCtxNew $ c_md4_init {-# NOINLINE update #-} -- | update a context with a bytestring update :: Ctx -> ByteString -> Ctx -update ctx d = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do updateInternalIO ptr d >> peek ptr +update ctx d = inlinePerformIO $ withCtxCopy ctx $ \ptr -> updateInternalIO ptr d {-# NOINLINE finalize #-} -- | finalize the context into a digest bytestring finalize :: Ctx -> ByteString -finalize ctx = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do finalizeInternalIO ptr +finalize ctx = inlinePerformIO $ withCtxThrow ctx finalizeInternalIO {-# NOINLINE hash #-} -- | hash a strict bytestring into a digest bytestring hash :: ByteString -> ByteString -hash d = unsafePerformIO $ allocInternal $ \ptr -> do - c_md4_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr +hash d = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_md4_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr {-# NOINLINE hashlazy #-} -- | hash a lazy bytestring into a digest bytestring hashlazy :: L.ByteString -> ByteString -hashlazy l = unsafePerformIO $ allocInternal $ \ptr -> do - c_md4_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr +hashlazy l = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_md4_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr diff --git a/Crypto/Hash/MD5.hs b/Crypto/Hash/MD5.hs --- a/Crypto/Hash/MD5.hs +++ b/Crypto/Hash/MD5.hs @@ -10,30 +10,28 @@ -- A module containing MD5 bindings -- module Crypto.Hash.MD5 - ( Ctx(..) - , MD5 + ( Ctx(..) + , MD5 - -- * Incremental hashing Functions - , init -- :: Ctx - , update -- :: Ctx -> ByteString -> Ctx - , finalize -- :: Ctx -> ByteString + -- * Incremental hashing Functions + , init -- :: Ctx + , update -- :: Ctx -> ByteString -> Ctx + , finalize -- :: Ctx -> ByteString - -- * Single Pass hashing - , hash -- :: ByteString -> ByteString - , hashlazy -- :: ByteString -> ByteString - ) where + -- * Single Pass hashing + , hash -- :: ByteString -> ByteString + , hashlazy -- :: ByteString -> ByteString + ) where import Prelude hiding (init) -import System.IO.Unsafe (unsafePerformIO) -import Foreign.C.String import Foreign.Ptr +import Foreign.ForeignPtr (withForeignPtr) import Foreign.Storable import Foreign.Marshal.Alloc -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString) -import Data.ByteString.Unsafe (unsafeUseAsCString, unsafeUseAsCStringLen) -import Data.ByteString.Internal (create, memcpy) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.ByteString.Internal (create, toForeignPtr, inlinePerformIO) import Data.Word #ifdef HAVE_CRYPTOAPI @@ -46,79 +44,102 @@ import qualified Crypto.Classes as C (Hash(..)) instance C.Hash Ctx MD5 where - outputLength = Tagged (16 * 8) - blockLength = Tagged (64 * 8) - initialCtx = init - updateCtx = update - finalize ctx bs = Digest . finalize $ update ctx bs + outputLength = Tagged (16 * 8) + blockLength = Tagged (64 * 8) + initialCtx = init + updateCtx = update + finalize ctx bs = Digest . finalize $ update ctx bs instance Serialize MD5 where - get = liftM Digest (getByteString digestSize) - put (Digest d) = putByteString d + get = liftM Digest (getByteString digestSize) + put (Digest d) = putByteString d #endif data Ctx = Ctx !ByteString data MD5 = Digest !ByteString - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show) -digestSize, sizeCtx :: Int + +{-# INLINE digestSize #-} +digestSize :: Int digestSize = 16 + +{-# INLINE sizeCtx #-} +sizeCtx :: Int sizeCtx = 96 -instance Storable Ctx where - sizeOf _ = sizeCtx - alignment _ = 16 - poke ptr (Ctx b) = unsafeUseAsCString b (\cs -> memcpy (castPtr ptr) (castPtr cs) (fromIntegral sizeCtx)) +{-# 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 - peek ptr = create sizeCtx (\bptr -> memcpy bptr (castPtr ptr) (fromIntegral sizeCtx)) >>= return . Ctx +{-# INLINE memcopy64 #-} +memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO () +memcopy64 dst src = mapM_ peekAndPoke [0..(12-1)] + where peekAndPoke i = peekElemOff src i >>= pokeElemOff dst i +withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx +withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx + where createCtx = create sizeCtx $ \dstPtr -> + withByteStringPtr ctxB $ \srcPtr -> do + memcopy64 (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 + memcopy64 (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 "md5.h md5_init" - c_md5_init :: Ptr Ctx -> IO () + c_md5_init :: Ptr Ctx -> IO () foreign import ccall "md5.h md5_update" - c_md5_update :: Ptr Ctx -> CString -> Word32 -> IO () + c_md5_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO () foreign import ccall unsafe "md5.h md5_finalize" - c_md5_finalize :: Ptr Ctx -> CString -> IO () - -allocInternal :: (Ptr Ctx -> IO a) -> IO a -allocInternal = alloca - -allocInternalFrom :: Ctx -> (Ptr Ctx -> IO a) -> IO a -allocInternalFrom ctx f = allocInternal $ \ptr -> (poke ptr ctx >> f ptr) + c_md5_finalize :: Ptr Ctx -> Ptr Word8 -> IO () updateInternalIO :: Ptr Ctx -> ByteString -> IO () updateInternalIO ptr d = - unsafeUseAsCStringLen d (\(cs, len) -> c_md5_update ptr cs (fromIntegral len)) + unsafeUseAsCStringLen d (\(cs, len) -> c_md5_update ptr (castPtr cs) (fromIntegral len)) finalizeInternalIO :: Ptr Ctx -> IO ByteString finalizeInternalIO ptr = - allocaBytes digestSize (\cs -> c_md5_finalize ptr cs >> B.packCStringLen (cs, digestSize)) + create digestSize (c_md5_finalize ptr) {-# NOINLINE init #-} -- | init a context init :: Ctx -init = unsafePerformIO $ allocInternal $ \ptr -> do (c_md5_init ptr >> peek ptr) +init = inlinePerformIO $ withCtxNew $ c_md5_init {-# NOINLINE update #-} -- | update a context with a bytestring update :: Ctx -> ByteString -> Ctx -update ctx d = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do updateInternalIO ptr d >> peek ptr +update ctx d = inlinePerformIO $ withCtxCopy ctx $ \ptr -> updateInternalIO ptr d {-# NOINLINE finalize #-} -- | finalize the context into a digest bytestring finalize :: Ctx -> ByteString -finalize ctx = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do finalizeInternalIO ptr +finalize ctx = inlinePerformIO $ withCtxThrow ctx finalizeInternalIO {-# NOINLINE hash #-} -- | hash a strict bytestring into a digest bytestring hash :: ByteString -> ByteString -hash d = unsafePerformIO $ allocInternal $ \ptr -> do - c_md5_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr +hash d = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_md5_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr {-# NOINLINE hashlazy #-} -- | hash a lazy bytestring into a digest bytestring hashlazy :: L.ByteString -> ByteString -hashlazy l = unsafePerformIO $ allocInternal $ \ptr -> do - c_md5_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr +hashlazy l = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_md5_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr diff --git a/Crypto/Hash/RIPEMD160.hs b/Crypto/Hash/RIPEMD160.hs --- a/Crypto/Hash/RIPEMD160.hs +++ b/Crypto/Hash/RIPEMD160.hs @@ -10,30 +10,28 @@ -- A module containing RIPEMD160 bindings -- module Crypto.Hash.RIPEMD160 - ( Ctx(..) - , RIPEMD160 + ( Ctx(..) + , RIPEMD160 - -- * Incremental hashing Functions - , init -- :: Ctx - , update -- :: Ctx -> ByteString -> Ctx - , finalize -- :: Ctx -> ByteString + -- * Incremental hashing Functions + , init -- :: Ctx + , update -- :: Ctx -> ByteString -> Ctx + , finalize -- :: Ctx -> ByteString - -- * Single Pass hashing - , hash -- :: ByteString -> ByteString - , hashlazy -- :: ByteString -> ByteString - ) where + -- * Single Pass hashing + , hash -- :: ByteString -> ByteString + , hashlazy -- :: ByteString -> ByteString + ) where import Prelude hiding (init) -import System.IO.Unsafe (unsafePerformIO) -import Foreign.C.String import Foreign.Ptr +import Foreign.ForeignPtr (withForeignPtr) import Foreign.Storable import Foreign.Marshal.Alloc -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString) -import Data.ByteString.Unsafe (unsafeUseAsCString, unsafeUseAsCStringLen) -import Data.ByteString.Internal (create, memcpy) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.ByteString.Internal (create, toForeignPtr, inlinePerformIO) import Data.Word #ifdef HAVE_CRYPTOAPI @@ -46,79 +44,102 @@ import qualified Crypto.Classes as C (Hash(..)) instance C.Hash Ctx RIPEMD160 where - outputLength = Tagged (20 * 8) - blockLength = Tagged (64 * 8) - initialCtx = init - updateCtx = update - finalize ctx bs = Digest . finalize $ update ctx bs + outputLength = Tagged (20 * 8) + blockLength = Tagged (64 * 8) + initialCtx = init + updateCtx = update + finalize ctx bs = Digest . finalize $ update ctx bs instance Serialize RIPEMD160 where - get = liftM Digest (getByteString digestSize) - put (Digest d) = putByteString d + get = liftM Digest (getByteString digestSize) + put (Digest d) = putByteString d #endif data Ctx = Ctx !ByteString data RIPEMD160 = Digest !ByteString - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show) -digestSize, sizeCtx :: Int + +{-# INLINE digestSize #-} +digestSize :: Int digestSize = 20 + +{-# INLINE sizeCtx #-} +sizeCtx :: Int sizeCtx = 128 -instance Storable Ctx where - sizeOf _ = sizeCtx - alignment _ = 16 - poke ptr (Ctx b) = unsafeUseAsCString b (\cs -> memcpy (castPtr ptr) (castPtr cs) (fromIntegral sizeCtx)) +{-# 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 - peek ptr = create sizeCtx (\bptr -> memcpy bptr (castPtr ptr) (fromIntegral sizeCtx)) >>= return . Ctx +{-# INLINE memcopy64 #-} +memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO () +memcopy64 dst src = mapM_ peekAndPoke [0..(16-1)] + where peekAndPoke i = peekElemOff src i >>= pokeElemOff dst i +withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx +withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx + where createCtx = create sizeCtx $ \dstPtr -> + withByteStringPtr ctxB $ \srcPtr -> do + memcopy64 (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 + memcopy64 (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 "ripemd.h ripemd160_init" - c_ripemd160_init :: Ptr Ctx -> IO () + c_ripemd160_init :: Ptr Ctx -> IO () foreign import ccall "ripemd.h ripemd160_update" - c_ripemd160_update :: Ptr Ctx -> CString -> Word32 -> IO () + c_ripemd160_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO () foreign import ccall unsafe "ripemd.h ripemd160_finalize" - c_ripemd160_finalize :: Ptr Ctx -> CString -> IO () - -allocInternal :: (Ptr Ctx -> IO a) -> IO a -allocInternal = alloca - -allocInternalFrom :: Ctx -> (Ptr Ctx -> IO a) -> IO a -allocInternalFrom ctx f = allocInternal $ \ptr -> (poke ptr ctx >> f ptr) + c_ripemd160_finalize :: Ptr Ctx -> Ptr Word8 -> IO () updateInternalIO :: Ptr Ctx -> ByteString -> IO () updateInternalIO ptr d = - unsafeUseAsCStringLen d (\(cs, len) -> c_ripemd160_update ptr cs (fromIntegral len)) + unsafeUseAsCStringLen d (\(cs, len) -> c_ripemd160_update ptr (castPtr cs) (fromIntegral len)) finalizeInternalIO :: Ptr Ctx -> IO ByteString finalizeInternalIO ptr = - allocaBytes digestSize (\cs -> c_ripemd160_finalize ptr cs >> B.packCStringLen (cs, digestSize)) + create digestSize (c_ripemd160_finalize ptr) {-# NOINLINE init #-} -- | init a context init :: Ctx -init = unsafePerformIO $ allocInternal $ \ptr -> do (c_ripemd160_init ptr >> peek ptr) +init = inlinePerformIO $ withCtxNew $ c_ripemd160_init {-# NOINLINE update #-} -- | update a context with a bytestring update :: Ctx -> ByteString -> Ctx -update ctx d = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do updateInternalIO ptr d >> peek ptr +update ctx d = inlinePerformIO $ withCtxCopy ctx $ \ptr -> updateInternalIO ptr d {-# NOINLINE finalize #-} -- | finalize the context into a digest bytestring finalize :: Ctx -> ByteString -finalize ctx = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do finalizeInternalIO ptr +finalize ctx = inlinePerformIO $ withCtxThrow ctx finalizeInternalIO {-# NOINLINE hash #-} -- | hash a strict bytestring into a digest bytestring hash :: ByteString -> ByteString -hash d = unsafePerformIO $ allocInternal $ \ptr -> do - c_ripemd160_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr +hash d = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_ripemd160_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr {-# NOINLINE hashlazy #-} -- | hash a lazy bytestring into a digest bytestring hashlazy :: L.ByteString -> ByteString -hashlazy l = unsafePerformIO $ allocInternal $ \ptr -> do - c_ripemd160_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr +hashlazy l = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_ripemd160_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr diff --git a/Crypto/Hash/SHA1.hs b/Crypto/Hash/SHA1.hs --- a/Crypto/Hash/SHA1.hs +++ b/Crypto/Hash/SHA1.hs @@ -10,30 +10,28 @@ -- A module containing SHA1 bindings -- module Crypto.Hash.SHA1 - ( Ctx(..) - , SHA1 + ( Ctx(..) + , SHA1 - -- * Incremental hashing Functions - , init -- :: Ctx - , update -- :: Ctx -> ByteString -> Ctx - , finalize -- :: Ctx -> ByteString + -- * Incremental hashing Functions + , init -- :: Ctx + , update -- :: Ctx -> ByteString -> Ctx + , finalize -- :: Ctx -> ByteString - -- * Single Pass hashing - , hash -- :: ByteString -> ByteString - , hashlazy -- :: ByteString -> ByteString - ) where + -- * Single Pass hashing + , hash -- :: ByteString -> ByteString + , hashlazy -- :: ByteString -> ByteString + ) where import Prelude hiding (init) -import System.IO.Unsafe (unsafePerformIO) -import Foreign.C.String import Foreign.Ptr +import Foreign.ForeignPtr (withForeignPtr) import Foreign.Storable import Foreign.Marshal.Alloc -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString) -import Data.ByteString.Unsafe (unsafeUseAsCString, unsafeUseAsCStringLen) -import Data.ByteString.Internal (create, memcpy) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.ByteString.Internal (create, toForeignPtr, inlinePerformIO) import Data.Word #ifdef HAVE_CRYPTOAPI @@ -46,79 +44,102 @@ import qualified Crypto.Classes as C (Hash(..)) instance C.Hash Ctx SHA1 where - outputLength = Tagged (20 * 8) - blockLength = Tagged (64 * 8) - initialCtx = init - updateCtx = update - finalize ctx bs = Digest . finalize $ update ctx bs + outputLength = Tagged (20 * 8) + blockLength = Tagged (64 * 8) + initialCtx = init + updateCtx = update + finalize ctx bs = Digest . finalize $ update ctx bs instance Serialize SHA1 where - get = liftM Digest (getByteString digestSize) - put (Digest d) = putByteString d + get = liftM Digest (getByteString digestSize) + put (Digest d) = putByteString d #endif data Ctx = Ctx !ByteString data SHA1 = Digest !ByteString - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show) -digestSize, sizeCtx :: Int + +{-# INLINE digestSize #-} +digestSize :: Int digestSize = 20 + +{-# INLINE sizeCtx #-} +sizeCtx :: Int sizeCtx = 96 -instance Storable Ctx where - sizeOf _ = sizeCtx - alignment _ = 16 - poke ptr (Ctx b) = unsafeUseAsCString b (\cs -> memcpy (castPtr ptr) (castPtr cs) (fromIntegral sizeCtx)) +{-# 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 - peek ptr = create sizeCtx (\bptr -> memcpy bptr (castPtr ptr) (fromIntegral sizeCtx)) >>= return . Ctx +{-# INLINE memcopy64 #-} +memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO () +memcopy64 dst src = mapM_ peekAndPoke [0..(12-1)] + where peekAndPoke i = peekElemOff src i >>= pokeElemOff dst i +withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx +withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx + where createCtx = create sizeCtx $ \dstPtr -> + withByteStringPtr ctxB $ \srcPtr -> do + memcopy64 (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 + memcopy64 (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 sha1_init" - c_sha1_init :: Ptr Ctx -> IO () + c_sha1_init :: Ptr Ctx -> IO () foreign import ccall "sha1.h sha1_update" - c_sha1_update :: Ptr Ctx -> CString -> Word32 -> IO () + c_sha1_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO () foreign import ccall unsafe "sha1.h sha1_finalize" - c_sha1_finalize :: Ptr Ctx -> CString -> IO () - -allocInternal :: (Ptr Ctx -> IO a) -> IO a -allocInternal = alloca - -allocInternalFrom :: Ctx -> (Ptr Ctx -> IO a) -> IO a -allocInternalFrom ctx f = allocInternal $ \ptr -> (poke ptr ctx >> f ptr) + c_sha1_finalize :: Ptr Ctx -> Ptr Word8 -> IO () updateInternalIO :: Ptr Ctx -> ByteString -> IO () updateInternalIO ptr d = - unsafeUseAsCStringLen d (\(cs, len) -> c_sha1_update ptr cs (fromIntegral len)) + unsafeUseAsCStringLen d (\(cs, len) -> c_sha1_update ptr (castPtr cs) (fromIntegral len)) finalizeInternalIO :: Ptr Ctx -> IO ByteString finalizeInternalIO ptr = - allocaBytes digestSize (\cs -> c_sha1_finalize ptr cs >> B.packCStringLen (cs, digestSize)) + create digestSize (c_sha1_finalize ptr) {-# NOINLINE init #-} -- | init a context init :: Ctx -init = unsafePerformIO $ allocInternal $ \ptr -> do (c_sha1_init ptr >> peek ptr) +init = inlinePerformIO $ withCtxNew $ c_sha1_init {-# NOINLINE update #-} -- | update a context with a bytestring update :: Ctx -> ByteString -> Ctx -update ctx d = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do updateInternalIO ptr d >> peek ptr +update ctx d = inlinePerformIO $ withCtxCopy ctx $ \ptr -> updateInternalIO ptr d {-# NOINLINE finalize #-} -- | finalize the context into a digest bytestring finalize :: Ctx -> ByteString -finalize ctx = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do finalizeInternalIO ptr +finalize ctx = inlinePerformIO $ withCtxThrow ctx finalizeInternalIO {-# NOINLINE hash #-} -- | hash a strict bytestring into a digest bytestring hash :: ByteString -> ByteString -hash d = unsafePerformIO $ allocInternal $ \ptr -> do - c_sha1_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr +hash d = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_sha1_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr {-# NOINLINE hashlazy #-} -- | hash a lazy bytestring into a digest bytestring hashlazy :: L.ByteString -> ByteString -hashlazy l = unsafePerformIO $ allocInternal $ \ptr -> do - c_sha1_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr +hashlazy l = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_sha1_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr diff --git a/Crypto/Hash/SHA224.hs b/Crypto/Hash/SHA224.hs --- a/Crypto/Hash/SHA224.hs +++ b/Crypto/Hash/SHA224.hs @@ -10,30 +10,28 @@ -- A module containing SHA224 bindings -- module Crypto.Hash.SHA224 - ( Ctx(..) - , SHA224 + ( Ctx(..) + , SHA224 - -- * Incremental hashing Functions - , init -- :: Ctx - , update -- :: Ctx -> ByteString -> Ctx - , finalize -- :: Ctx -> ByteString + -- * Incremental hashing Functions + , init -- :: Ctx + , update -- :: Ctx -> ByteString -> Ctx + , finalize -- :: Ctx -> ByteString - -- * Single Pass hashing - , hash -- :: ByteString -> ByteString - , hashlazy -- :: ByteString -> ByteString - ) where + -- * Single Pass hashing + , hash -- :: ByteString -> ByteString + , hashlazy -- :: ByteString -> ByteString + ) where import Prelude hiding (init) -import System.IO.Unsafe (unsafePerformIO) -import Foreign.C.String import Foreign.Ptr +import Foreign.ForeignPtr (withForeignPtr) import Foreign.Storable import Foreign.Marshal.Alloc -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString) -import Data.ByteString.Unsafe (unsafeUseAsCString, unsafeUseAsCStringLen) -import Data.ByteString.Internal (create, memcpy) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.ByteString.Internal (create, toForeignPtr, inlinePerformIO) import Data.Word #ifdef HAVE_CRYPTOAPI @@ -46,79 +44,102 @@ import qualified Crypto.Classes as C (Hash(..)) instance C.Hash Ctx SHA224 where - outputLength = Tagged (28 * 8) - blockLength = Tagged (64 * 8) - initialCtx = init - updateCtx = update - finalize ctx bs = Digest . finalize $ update ctx bs + outputLength = Tagged (28 * 8) + blockLength = Tagged (64 * 8) + initialCtx = init + updateCtx = update + finalize ctx bs = Digest . finalize $ update ctx bs instance Serialize SHA224 where - get = liftM Digest (getByteString digestSize) - put (Digest d) = putByteString d + get = liftM Digest (getByteString digestSize) + put (Digest d) = putByteString d #endif data Ctx = Ctx !ByteString data SHA224 = Digest !ByteString - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show) -digestSize, sizeCtx :: Int + +{-# INLINE digestSize #-} +digestSize :: Int digestSize = 28 + +{-# INLINE sizeCtx #-} +sizeCtx :: Int sizeCtx = 192 -instance Storable Ctx where - sizeOf _ = sizeCtx - alignment _ = 16 - poke ptr (Ctx b) = unsafeUseAsCString b (\cs -> memcpy (castPtr ptr) (castPtr cs) (fromIntegral sizeCtx)) +{-# 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 - peek ptr = create sizeCtx (\bptr -> memcpy bptr (castPtr ptr) (fromIntegral sizeCtx)) >>= return . Ctx +{-# INLINE memcopy64 #-} +memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO () +memcopy64 dst src = mapM_ peekAndPoke [0..(24-1)] + where peekAndPoke i = peekElemOff src i >>= pokeElemOff dst i +withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx +withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx + where createCtx = create sizeCtx $ \dstPtr -> + withByteStringPtr ctxB $ \srcPtr -> do + memcopy64 (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 + memcopy64 (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 "sha256.h sha224_init" - c_sha224_init :: Ptr Ctx -> IO () + c_sha224_init :: Ptr Ctx -> IO () foreign import ccall "sha256.h sha224_update" - c_sha224_update :: Ptr Ctx -> CString -> Word32 -> IO () + c_sha224_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO () foreign import ccall unsafe "sha256.h sha224_finalize" - c_sha224_finalize :: Ptr Ctx -> CString -> IO () - -allocInternal :: (Ptr Ctx -> IO a) -> IO a -allocInternal = alloca - -allocInternalFrom :: Ctx -> (Ptr Ctx -> IO a) -> IO a -allocInternalFrom ctx f = allocInternal $ \ptr -> (poke ptr ctx >> f ptr) + c_sha224_finalize :: Ptr Ctx -> Ptr Word8 -> IO () updateInternalIO :: Ptr Ctx -> ByteString -> IO () updateInternalIO ptr d = - unsafeUseAsCStringLen d (\(cs, len) -> c_sha224_update ptr cs (fromIntegral len)) + unsafeUseAsCStringLen d (\(cs, len) -> c_sha224_update ptr (castPtr cs) (fromIntegral len)) finalizeInternalIO :: Ptr Ctx -> IO ByteString finalizeInternalIO ptr = - allocaBytes digestSize (\cs -> c_sha224_finalize ptr cs >> B.packCStringLen (cs, digestSize)) + create digestSize (c_sha224_finalize ptr) {-# NOINLINE init #-} -- | init a context init :: Ctx -init = unsafePerformIO $ allocInternal $ \ptr -> do (c_sha224_init ptr >> peek ptr) +init = inlinePerformIO $ withCtxNew $ c_sha224_init {-# NOINLINE update #-} -- | update a context with a bytestring update :: Ctx -> ByteString -> Ctx -update ctx d = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do updateInternalIO ptr d >> peek ptr +update ctx d = inlinePerformIO $ withCtxCopy ctx $ \ptr -> updateInternalIO ptr d {-# NOINLINE finalize #-} -- | finalize the context into a digest bytestring finalize :: Ctx -> ByteString -finalize ctx = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do finalizeInternalIO ptr +finalize ctx = inlinePerformIO $ withCtxThrow ctx finalizeInternalIO {-# NOINLINE hash #-} -- | hash a strict bytestring into a digest bytestring hash :: ByteString -> ByteString -hash d = unsafePerformIO $ allocInternal $ \ptr -> do - c_sha224_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr +hash d = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_sha224_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr {-# NOINLINE hashlazy #-} -- | hash a lazy bytestring into a digest bytestring hashlazy :: L.ByteString -> ByteString -hashlazy l = unsafePerformIO $ allocInternal $ \ptr -> do - c_sha224_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr +hashlazy l = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_sha224_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr diff --git a/Crypto/Hash/SHA256.hs b/Crypto/Hash/SHA256.hs --- a/Crypto/Hash/SHA256.hs +++ b/Crypto/Hash/SHA256.hs @@ -10,30 +10,28 @@ -- A module containing SHA256 bindings -- module Crypto.Hash.SHA256 - ( Ctx(..) - , SHA256 + ( Ctx(..) + , SHA256 - -- * Incremental hashing Functions - , init -- :: Ctx - , update -- :: Ctx -> ByteString -> Ctx - , finalize -- :: Ctx -> ByteString + -- * Incremental hashing Functions + , init -- :: Ctx + , update -- :: Ctx -> ByteString -> Ctx + , finalize -- :: Ctx -> ByteString - -- * Single Pass hashing - , hash -- :: ByteString -> ByteString - , hashlazy -- :: ByteString -> ByteString - ) where + -- * Single Pass hashing + , hash -- :: ByteString -> ByteString + , hashlazy -- :: ByteString -> ByteString + ) where import Prelude hiding (init) -import System.IO.Unsafe (unsafePerformIO) -import Foreign.C.String import Foreign.Ptr +import Foreign.ForeignPtr (withForeignPtr) import Foreign.Storable import Foreign.Marshal.Alloc -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString) -import Data.ByteString.Unsafe (unsafeUseAsCString, unsafeUseAsCStringLen) -import Data.ByteString.Internal (create, memcpy) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.ByteString.Internal (create, toForeignPtr, inlinePerformIO) import Data.Word #ifdef HAVE_CRYPTOAPI @@ -46,79 +44,102 @@ import qualified Crypto.Classes as C (Hash(..)) instance C.Hash Ctx SHA256 where - outputLength = Tagged (32 * 8) - blockLength = Tagged (64 * 8) - initialCtx = init - updateCtx = update - finalize ctx bs = Digest . finalize $ update ctx bs + outputLength = Tagged (32 * 8) + blockLength = Tagged (64 * 8) + initialCtx = init + updateCtx = update + finalize ctx bs = Digest . finalize $ update ctx bs instance Serialize SHA256 where - get = liftM Digest (getByteString digestSize) - put (Digest d) = putByteString d + get = liftM Digest (getByteString digestSize) + put (Digest d) = putByteString d #endif data Ctx = Ctx !ByteString data SHA256 = Digest !ByteString - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show) -digestSize, sizeCtx :: Int + +{-# INLINE digestSize #-} +digestSize :: Int digestSize = 32 + +{-# INLINE sizeCtx #-} +sizeCtx :: Int sizeCtx = 192 -instance Storable Ctx where - sizeOf _ = sizeCtx - alignment _ = 16 - poke ptr (Ctx b) = unsafeUseAsCString b (\cs -> memcpy (castPtr ptr) (castPtr cs) (fromIntegral sizeCtx)) +{-# 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 - peek ptr = create sizeCtx (\bptr -> memcpy bptr (castPtr ptr) (fromIntegral sizeCtx)) >>= return . Ctx +{-# INLINE memcopy64 #-} +memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO () +memcopy64 dst src = mapM_ peekAndPoke [0..(24-1)] + where peekAndPoke i = peekElemOff src i >>= pokeElemOff dst i +withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx +withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx + where createCtx = create sizeCtx $ \dstPtr -> + withByteStringPtr ctxB $ \srcPtr -> do + memcopy64 (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 + memcopy64 (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 "sha256.h sha256_init" - c_sha256_init :: Ptr Ctx -> IO () + c_sha256_init :: Ptr Ctx -> IO () foreign import ccall "sha256.h sha256_update" - c_sha256_update :: Ptr Ctx -> CString -> Word32 -> IO () + c_sha256_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO () foreign import ccall unsafe "sha256.h sha256_finalize" - c_sha256_finalize :: Ptr Ctx -> CString -> IO () - -allocInternal :: (Ptr Ctx -> IO a) -> IO a -allocInternal = alloca - -allocInternalFrom :: Ctx -> (Ptr Ctx -> IO a) -> IO a -allocInternalFrom ctx f = allocInternal $ \ptr -> (poke ptr ctx >> f ptr) + c_sha256_finalize :: Ptr Ctx -> Ptr Word8 -> IO () updateInternalIO :: Ptr Ctx -> ByteString -> IO () updateInternalIO ptr d = - unsafeUseAsCStringLen d (\(cs, len) -> c_sha256_update ptr cs (fromIntegral len)) + unsafeUseAsCStringLen d (\(cs, len) -> c_sha256_update ptr (castPtr cs) (fromIntegral len)) finalizeInternalIO :: Ptr Ctx -> IO ByteString finalizeInternalIO ptr = - allocaBytes digestSize (\cs -> c_sha256_finalize ptr cs >> B.packCStringLen (cs, digestSize)) + create digestSize (c_sha256_finalize ptr) {-# NOINLINE init #-} -- | init a context init :: Ctx -init = unsafePerformIO $ allocInternal $ \ptr -> do (c_sha256_init ptr >> peek ptr) +init = inlinePerformIO $ withCtxNew $ c_sha256_init {-# NOINLINE update #-} -- | update a context with a bytestring update :: Ctx -> ByteString -> Ctx -update ctx d = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do updateInternalIO ptr d >> peek ptr +update ctx d = inlinePerformIO $ withCtxCopy ctx $ \ptr -> updateInternalIO ptr d {-# NOINLINE finalize #-} -- | finalize the context into a digest bytestring finalize :: Ctx -> ByteString -finalize ctx = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do finalizeInternalIO ptr +finalize ctx = inlinePerformIO $ withCtxThrow ctx finalizeInternalIO {-# NOINLINE hash #-} -- | hash a strict bytestring into a digest bytestring hash :: ByteString -> ByteString -hash d = unsafePerformIO $ allocInternal $ \ptr -> do - c_sha256_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr +hash d = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_sha256_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr {-# NOINLINE hashlazy #-} -- | hash a lazy bytestring into a digest bytestring hashlazy :: L.ByteString -> ByteString -hashlazy l = unsafePerformIO $ allocInternal $ \ptr -> do - c_sha256_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr +hashlazy l = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_sha256_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr diff --git a/Crypto/Hash/SHA3.hs b/Crypto/Hash/SHA3.hs new file mode 100644 --- /dev/null +++ b/Crypto/Hash/SHA3.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | +-- Module : Crypto.Hash.SHA3 +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- A module containing SHA3 bindings +-- +module Crypto.Hash.SHA3 + ( Ctx(..) + + -- * Incremental hashing Functions + , init -- :: Int -> Ctx + , update -- :: Ctx -> ByteString -> Ctx + , finalize -- :: Ctx -> ByteString + + -- * Single Pass hashing + , hash -- :: Int -> ByteString -> ByteString + , hashlazy -- :: Int -> ByteString -> ByteString + ) where + +import Prelude hiding (init) +import Foreign.Ptr +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Storable +import Foreign.Marshal.Alloc +import qualified Data.ByteString.Lazy as L +import Data.ByteString (ByteString) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.ByteString.Internal (create, toForeignPtr, inlinePerformIO) +import Data.Word + +data Ctx = Ctx !ByteString + +{-# INLINE sizeCtx #-} +sizeCtx :: Int +sizeCtx = 360 + +{- return the number of bytes of output for the digest -} +peekHashlen :: Ptr Ctx -> IO Int +peekHashlen ptr = peek iptr >>= \v -> return $! fromIntegral v + where iptr :: Ptr Word32 + iptr = castPtr ptr + +{-# 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 + +{-# INLINE memcopy64 #-} +memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO () +memcopy64 dst src = mapM_ peekAndPoke [0..44] + where peekAndPoke i = peekElemOff src i >>= pokeElemOff dst i + +withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx +withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx + where createCtx = create sizeCtx $ \dstPtr -> + withByteStringPtr ctxB $ \srcPtr -> do + memcopy64 (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 + memcopy64 (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 "sha3.h sha3_init" + c_sha3_init :: Ptr Ctx -> Word32 -> IO () + +foreign import ccall "sha3.h sha3_update" + c_sha3_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO () + +foreign import ccall unsafe "sha3.h sha3_finalize" + c_sha3_finalize :: Ptr Ctx -> Ptr Word8 -> IO () + +updateInternalIO :: Ptr Ctx -> ByteString -> IO () +updateInternalIO ptr d = + unsafeUseAsCStringLen d (\(cs, len) -> c_sha3_update ptr (castPtr cs) (fromIntegral len)) + +finalizeInternalIO :: Ptr Ctx -> IO ByteString +finalizeInternalIO ptr = + peekHashlen ptr >>= \digestSize -> create digestSize (c_sha3_finalize ptr) + +{-# NOINLINE init #-} +-- | init a context +init :: Int -> Ctx +init hashlen = inlinePerformIO $ withCtxNew (\ctx -> c_sha3_init ctx (fromIntegral hashlen)) + +{-# NOINLINE update #-} +-- | update a context with a bytestring +update :: Ctx -> ByteString -> Ctx +update ctx d = inlinePerformIO $ withCtxCopy ctx $ \ptr -> updateInternalIO ptr d + +{-# NOINLINE finalize #-} +-- | finalize the context into a digest bytestring +finalize :: Ctx -> ByteString +finalize ctx = inlinePerformIO $ withCtxThrow ctx finalizeInternalIO + +{-# NOINLINE hash #-} +-- | hash a strict bytestring into a digest bytestring +hash :: Int -> ByteString -> ByteString +hash hashlen d = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_sha3_init ptr (fromIntegral hashlen) >> updateInternalIO ptr d >> finalizeInternalIO ptr + +{-# NOINLINE hashlazy #-} +-- | hash a lazy bytestring into a digest bytestring +hashlazy :: Int -> L.ByteString -> ByteString +hashlazy hashlen l = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_sha3_init ptr (fromIntegral hashlen) >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr diff --git a/Crypto/Hash/SHA384.hs b/Crypto/Hash/SHA384.hs --- a/Crypto/Hash/SHA384.hs +++ b/Crypto/Hash/SHA384.hs @@ -10,30 +10,28 @@ -- A module containing SHA384 bindings -- module Crypto.Hash.SHA384 - ( Ctx(..) - , SHA384 + ( Ctx(..) + , SHA384 - -- * Incremental hashing Functions - , init -- :: Ctx - , update -- :: Ctx -> ByteString -> Ctx - , finalize -- :: Ctx -> ByteString + -- * Incremental hashing Functions + , init -- :: Ctx + , update -- :: Ctx -> ByteString -> Ctx + , finalize -- :: Ctx -> ByteString - -- * Single Pass hashing - , hash -- :: ByteString -> ByteString - , hashlazy -- :: ByteString -> ByteString - ) where + -- * Single Pass hashing + , hash -- :: ByteString -> ByteString + , hashlazy -- :: ByteString -> ByteString + ) where import Prelude hiding (init) -import System.IO.Unsafe (unsafePerformIO) -import Foreign.C.String import Foreign.Ptr +import Foreign.ForeignPtr (withForeignPtr) import Foreign.Storable import Foreign.Marshal.Alloc -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString) -import Data.ByteString.Unsafe (unsafeUseAsCString, unsafeUseAsCStringLen) -import Data.ByteString.Internal (create, memcpy) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.ByteString.Internal (create, toForeignPtr, inlinePerformIO) import Data.Word #ifdef HAVE_CRYPTOAPI @@ -46,79 +44,102 @@ import qualified Crypto.Classes as C (Hash(..)) instance C.Hash Ctx SHA384 where - outputLength = Tagged (48 * 8) - blockLength = Tagged (128 * 8) - initialCtx = init - updateCtx = update - finalize ctx bs = Digest . finalize $ update ctx bs + outputLength = Tagged (48 * 8) + blockLength = Tagged (128 * 8) + initialCtx = init + updateCtx = update + finalize ctx bs = Digest . finalize $ update ctx bs instance Serialize SHA384 where - get = liftM Digest (getByteString digestSize) - put (Digest d) = putByteString d + get = liftM Digest (getByteString digestSize) + put (Digest d) = putByteString d #endif data Ctx = Ctx !ByteString data SHA384 = Digest !ByteString - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show) -digestSize, sizeCtx :: Int + +{-# INLINE digestSize #-} +digestSize :: Int digestSize = 48 + +{-# INLINE sizeCtx #-} +sizeCtx :: Int sizeCtx = 256 -instance Storable Ctx where - sizeOf _ = sizeCtx - alignment _ = 16 - poke ptr (Ctx b) = unsafeUseAsCString b (\cs -> memcpy (castPtr ptr) (castPtr cs) (fromIntegral sizeCtx)) +{-# 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 - peek ptr = create sizeCtx (\bptr -> memcpy bptr (castPtr ptr) (fromIntegral sizeCtx)) >>= return . Ctx +{-# INLINE memcopy64 #-} +memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO () +memcopy64 dst src = mapM_ peekAndPoke [0..(32-1)] + where peekAndPoke i = peekElemOff src i >>= pokeElemOff dst i +withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx +withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx + where createCtx = create sizeCtx $ \dstPtr -> + withByteStringPtr ctxB $ \srcPtr -> do + memcopy64 (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 + memcopy64 (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 "sha512.h sha384_init" - c_sha384_init :: Ptr Ctx -> IO () + c_sha384_init :: Ptr Ctx -> IO () foreign import ccall "sha512.h sha384_update" - c_sha384_update :: Ptr Ctx -> CString -> Word32 -> IO () + c_sha384_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO () foreign import ccall unsafe "sha512.h sha384_finalize" - c_sha384_finalize :: Ptr Ctx -> CString -> IO () - -allocInternal :: (Ptr Ctx -> IO a) -> IO a -allocInternal = alloca - -allocInternalFrom :: Ctx -> (Ptr Ctx -> IO a) -> IO a -allocInternalFrom ctx f = allocInternal $ \ptr -> (poke ptr ctx >> f ptr) + c_sha384_finalize :: Ptr Ctx -> Ptr Word8 -> IO () updateInternalIO :: Ptr Ctx -> ByteString -> IO () updateInternalIO ptr d = - unsafeUseAsCStringLen d (\(cs, len) -> c_sha384_update ptr cs (fromIntegral len)) + unsafeUseAsCStringLen d (\(cs, len) -> c_sha384_update ptr (castPtr cs) (fromIntegral len)) finalizeInternalIO :: Ptr Ctx -> IO ByteString finalizeInternalIO ptr = - allocaBytes digestSize (\cs -> c_sha384_finalize ptr cs >> B.packCStringLen (cs, digestSize)) + create digestSize (c_sha384_finalize ptr) {-# NOINLINE init #-} -- | init a context init :: Ctx -init = unsafePerformIO $ allocInternal $ \ptr -> do (c_sha384_init ptr >> peek ptr) +init = inlinePerformIO $ withCtxNew $ c_sha384_init {-# NOINLINE update #-} -- | update a context with a bytestring update :: Ctx -> ByteString -> Ctx -update ctx d = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do updateInternalIO ptr d >> peek ptr +update ctx d = inlinePerformIO $ withCtxCopy ctx $ \ptr -> updateInternalIO ptr d {-# NOINLINE finalize #-} -- | finalize the context into a digest bytestring finalize :: Ctx -> ByteString -finalize ctx = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do finalizeInternalIO ptr +finalize ctx = inlinePerformIO $ withCtxThrow ctx finalizeInternalIO {-# NOINLINE hash #-} -- | hash a strict bytestring into a digest bytestring hash :: ByteString -> ByteString -hash d = unsafePerformIO $ allocInternal $ \ptr -> do - c_sha384_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr +hash d = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_sha384_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr {-# NOINLINE hashlazy #-} -- | hash a lazy bytestring into a digest bytestring hashlazy :: L.ByteString -> ByteString -hashlazy l = unsafePerformIO $ allocInternal $ \ptr -> do - c_sha384_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr +hashlazy l = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_sha384_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr diff --git a/Crypto/Hash/SHA512.hs b/Crypto/Hash/SHA512.hs --- a/Crypto/Hash/SHA512.hs +++ b/Crypto/Hash/SHA512.hs @@ -10,31 +10,30 @@ -- A module containing SHA512 bindings -- module Crypto.Hash.SHA512 - ( Ctx(..) - , SHA512 + ( Ctx(..) + , SHA512 - -- * Incremental hashing Functions - , init -- :: Ctx - , init_t -- :: Int -> Ctx - , update -- :: Ctx -> ByteString -> Ctx - , finalize -- :: Ctx -> ByteString + -- * Incremental hashing Functions + , init -- :: Ctx + , init_t -- :: Int -> Ctx + , update -- :: Ctx -> ByteString -> Ctx + , finalize -- :: Ctx -> ByteString - -- * Single Pass hashing - , hash -- :: ByteString -> ByteString - , hashlazy -- :: ByteString -> ByteString - ) where + -- * Single Pass hashing + , hash -- :: ByteString -> ByteString + , hashlazy -- :: ByteString -> ByteString + ) where import Prelude hiding (init) import System.IO.Unsafe (unsafePerformIO) -import Foreign.C.String import Foreign.Ptr +import Foreign.ForeignPtr (withForeignPtr) import Foreign.Storable import Foreign.Marshal.Alloc -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString) -import Data.ByteString.Unsafe (unsafeUseAsCString, unsafeUseAsCStringLen) -import Data.ByteString.Internal (create, memcpy) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.ByteString.Internal (create, toForeignPtr) import Data.Word #ifdef HAVE_CRYPTOAPI @@ -47,87 +46,110 @@ import qualified Crypto.Classes as C (Hash(..)) instance C.Hash Ctx SHA512 where - outputLength = Tagged (64 * 8) - blockLength = Tagged (128 * 8) - initialCtx = init - updateCtx = update - finalize ctx bs = Digest . finalize $ update ctx bs + outputLength = Tagged (64 * 8) + blockLength = Tagged (128 * 8) + initialCtx = init + updateCtx = update + finalize ctx bs = Digest . finalize $ update ctx bs instance Serialize SHA512 where - get = liftM Digest (getByteString digestSize) - put (Digest d) = putByteString d + get = liftM Digest (getByteString digestSize) + put (Digest d) = putByteString d #endif data Ctx = Ctx !ByteString data SHA512 = Digest !ByteString - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show) -digestSize, sizeCtx :: Int + +{-# INLINE digestSize #-} +digestSize :: Int digestSize = 64 + +{-# INLINE sizeCtx #-} +sizeCtx :: Int sizeCtx = 256 -instance Storable Ctx where - sizeOf _ = sizeCtx - alignment _ = 16 - poke ptr (Ctx b) = unsafeUseAsCString b (\cs -> memcpy (castPtr ptr) (castPtr cs) (fromIntegral sizeCtx)) +{-# 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 - peek ptr = create sizeCtx (\bptr -> memcpy bptr (castPtr ptr) (fromIntegral sizeCtx)) >>= return . Ctx +{-# INLINE memcopy64 #-} +memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO () +memcopy64 dst src = mapM_ peekAndPoke [0..(32-1)] + where peekAndPoke i = peekElemOff src i >>= pokeElemOff dst i +withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx +withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx + where createCtx = create sizeCtx $ \dstPtr -> + withByteStringPtr ctxB $ \srcPtr -> do + memcopy64 (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 + memcopy64 (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 "sha512.h sha512_init" - c_sha512_init :: Ptr Ctx -> IO () + c_sha512_init :: Ptr Ctx -> IO () foreign import ccall unsafe "sha512.h sha512_init_t" - c_sha512_init_t :: Ptr Ctx -> Int -> IO () + c_sha512_init_t :: Ptr Ctx -> Int -> IO () foreign import ccall "sha512.h sha512_update" - c_sha512_update :: Ptr Ctx -> CString -> Word32 -> IO () + c_sha512_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO () foreign import ccall unsafe "sha512.h sha512_finalize" - c_sha512_finalize :: Ptr Ctx -> CString -> IO () - -allocInternal :: (Ptr Ctx -> IO a) -> IO a -allocInternal = alloca - -allocInternalFrom :: Ctx -> (Ptr Ctx -> IO a) -> IO a -allocInternalFrom ctx f = allocInternal $ \ptr -> (poke ptr ctx >> f ptr) + c_sha512_finalize :: Ptr Ctx -> Ptr Word8 -> IO () updateInternalIO :: Ptr Ctx -> ByteString -> IO () updateInternalIO ptr d = - unsafeUseAsCStringLen d (\(cs, len) -> c_sha512_update ptr cs (fromIntegral len)) + unsafeUseAsCStringLen d (\(cs, len) -> c_sha512_update ptr (castPtr cs) (fromIntegral len)) finalizeInternalIO :: Ptr Ctx -> IO ByteString finalizeInternalIO ptr = - allocaBytes digestSize (\cs -> c_sha512_finalize ptr cs >> B.packCStringLen (cs, digestSize)) + create digestSize (c_sha512_finalize ptr) {-# NOINLINE init #-} -- | init a context init :: Ctx -init = unsafePerformIO $ allocInternal $ \ptr -> do (c_sha512_init ptr >> peek ptr) +init = unsafePerformIO $ withCtxNew $ c_sha512_init {-# NOINLINE init_t #-} -- | init a context using FIPS 180-4 for truncated SHA512 init_t :: Int -> Ctx -init_t t = unsafePerformIO $ allocInternal $ \ptr -> do (c_sha512_init_t ptr t >> peek ptr) +init_t t = unsafePerformIO $ withCtxNew $ \ptr -> c_sha512_init_t ptr t {-# NOINLINE update #-} -- | update a context with a bytestring update :: Ctx -> ByteString -> Ctx -update ctx d = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do updateInternalIO ptr d >> peek ptr +update ctx d = unsafePerformIO $ withCtxCopy ctx $ \ptr -> updateInternalIO ptr d {-# NOINLINE finalize #-} -- | finalize the context into a digest bytestring finalize :: Ctx -> ByteString -finalize ctx = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do finalizeInternalIO ptr +finalize ctx = unsafePerformIO $ withCtxThrow ctx finalizeInternalIO {-# NOINLINE hash #-} -- | hash a strict bytestring into a digest bytestring hash :: ByteString -> ByteString -hash d = unsafePerformIO $ allocInternal $ \ptr -> do - c_sha512_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr +hash d = unsafePerformIO $ withCtxNewThrow $ \ptr -> do + c_sha512_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr {-# NOINLINE hashlazy #-} -- | hash a lazy bytestring into a digest bytestring hashlazy :: L.ByteString -> ByteString -hashlazy l = unsafePerformIO $ allocInternal $ \ptr -> do - c_sha512_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr +hashlazy l = unsafePerformIO $ withCtxNewThrow $ \ptr -> do + c_sha512_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr diff --git a/Crypto/Hash/SHA512t.hs b/Crypto/Hash/SHA512t.hs --- a/Crypto/Hash/SHA512t.hs +++ b/Crypto/Hash/SHA512t.hs @@ -10,18 +10,18 @@ -- A module containing SHA512/t -- module Crypto.Hash.SHA512t - ( Ctx(..) - --, SHA512t + ( Ctx(..) + --, SHA512t - -- * Incremental hashing Functions - , init -- :: Ctx - , update -- :: Ctx -> ByteString -> Ctx - , finalize -- :: Ctx -> ByteString + -- * Incremental hashing Functions + , init -- :: Ctx + , update -- :: Ctx -> ByteString -> Ctx + , finalize -- :: Ctx -> ByteString - -- * Single Pass hashing - , hash -- :: ByteString -> ByteString - , hashlazy -- :: ByteString -> ByteString - ) where + -- * Single Pass hashing + , hash -- :: ByteString -> ByteString + , hashlazy -- :: ByteString -> ByteString + ) where import Prelude hiding (init) import Data.List (foldl') diff --git a/Crypto/Hash/Skein256.hs b/Crypto/Hash/Skein256.hs --- a/Crypto/Hash/Skein256.hs +++ b/Crypto/Hash/Skein256.hs @@ -10,31 +10,29 @@ -- A module containing Skein256 bindings -- module Crypto.Hash.Skein256 - ( Ctx(..) - , Skein256 + ( Ctx(..) + , Skein256 - -- * Incremental hashing Functions - , init -- :: Int -> Ctx - , update -- :: Ctx -> ByteString -> Ctx - , finalize -- :: Ctx -> ByteString + -- * Incremental hashing Functions + , init -- :: Int -> Ctx + , update -- :: Ctx -> ByteString -> Ctx + , finalize -- :: Ctx -> ByteString - -- * Single Pass hashing - , hash -- :: Int -> ByteString -> ByteString - , hashlazy -- :: Int -> ByteString -> ByteString - ) where + -- * Single Pass hashing + , hash -- :: Int -> ByteString -> ByteString + , hashlazy -- :: Int -> ByteString -> ByteString + ) where import Prelude hiding (init) -import System.IO.Unsafe (unsafePerformIO) -import Foreign.C.String import Foreign.C.Types import Foreign.Ptr +import Foreign.ForeignPtr (withForeignPtr) import Foreign.Storable import Foreign.Marshal.Alloc -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString) -import Data.ByteString.Unsafe (unsafeUseAsCString, unsafeUseAsCStringLen) -import Data.ByteString.Internal (create, memcpy) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.ByteString.Internal (create, inlinePerformIO, toForeignPtr) import Data.Word import Data.Bits @@ -48,85 +46,103 @@ import qualified Crypto.Classes as C (Hash(..)) instance C.Hash Ctx Skein256 where - outputLength = Tagged (32 * 8) - blockLength = Tagged (32 * 8) - initialCtx = init (32 * 8) - updateCtx = update - finalize ctx bs = Digest . finalize $ update ctx bs + outputLength = Tagged (32 * 8) + blockLength = Tagged (32 * 8) + initialCtx = init (32 * 8) + updateCtx = update + finalize ctx bs = Digest . finalize $ update ctx bs instance Serialize Skein256 where - get = liftM Digest (getByteString 32) - put (Digest d) = putByteString d + get = liftM Digest (getByteString 32) + put (Digest d) = putByteString d #endif data Ctx = Ctx !ByteString data Skein256 = Digest !ByteString - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show) sizeCtx :: Int -sizeCtx = 100 +sizeCtx = 88 -instance Storable Ctx where - sizeOf _ = sizeCtx - alignment _ = 16 - poke ptr (Ctx b) = unsafeUseAsCString b (\cs -> memcpy (castPtr ptr) (castPtr cs) (fromIntegral sizeCtx)) +peekHashlen :: Ptr Ctx -> IO Int +peekHashlen ptr = do + let iptr = castPtr ptr :: Ptr CUInt + a <- peek iptr + return ((fromIntegral a + 7) `shiftR` 3) - peek ptr = create sizeCtx (\bptr -> memcpy bptr (castPtr ptr) (fromIntegral sizeCtx)) >>= return . Ctx +{-# 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 -poke_hashlen :: Ptr Ctx -> IO Int -poke_hashlen ptr = do - let iptr = castPtr ptr :: Ptr CUInt - a <- peek iptr - return $ fromIntegral a +{-# INLINE memcopy64 #-} +memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO () +memcopy64 dst src = mapM_ peekAndPoke [0..(12-1)] + where peekAndPoke i = peekElemOff src i >>= pokeElemOff dst i +withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx +withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx + where createCtx = create sizeCtx $ \dstPtr -> + withByteStringPtr ctxB $ \srcPtr -> do + memcopy64 (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 + memcopy64 (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 "skein256.h skein256_init" - c_skein256_init :: Ptr Ctx -> CUInt -> IO () + c_skein256_init :: Ptr Ctx -> Word32 -> IO () foreign import ccall "skein256.h skein256_update" - c_skein256_update :: Ptr Ctx -> CString -> Word32 -> IO () + c_skein256_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO () foreign import ccall unsafe "skein256.h skein256_finalize" - c_skein256_finalize :: Ptr Ctx -> CString -> IO () + c_skein256_finalize :: Ptr Ctx -> Ptr Word8 -> IO () -allocInternal :: (Ptr Ctx -> IO a) -> IO a -allocInternal = alloca -allocInternalFrom :: Ctx -> (Ptr Ctx -> IO a) -> IO a -allocInternalFrom ctx f = allocInternal $ \ptr -> (poke ptr ctx >> f ptr) - updateInternalIO :: Ptr Ctx -> ByteString -> IO () updateInternalIO ptr d = - unsafeUseAsCStringLen d (\(cs, len) -> c_skein256_update ptr cs (fromIntegral len)) + unsafeUseAsCStringLen d (\(cs, len) -> c_skein256_update ptr (castPtr cs) (fromIntegral len)) finalizeInternalIO :: Ptr Ctx -> IO ByteString -finalizeInternalIO ptr = do - digestSize <- fmap (\x -> (x + 7) `shiftR` 3) $ poke_hashlen ptr - allocaBytes digestSize (\cs -> c_skein256_finalize ptr cs >> B.packCStringLen (cs, digestSize)) +finalizeInternalIO ptr = + peekHashlen ptr >>= \digestSize -> create digestSize (c_skein256_finalize ptr) {-# NOINLINE init #-} -- | init a context init :: Int -> Ctx -init hashlen = unsafePerformIO $ allocInternal $ \ptr -> do (c_skein256_init ptr (fromIntegral hashlen) >> peek ptr) +init hashlen = inlinePerformIO $ withCtxNew $ \ptr -> c_skein256_init ptr (fromIntegral hashlen) {-# NOINLINE update #-} -- | update a context with a bytestring update :: Ctx -> ByteString -> Ctx -update ctx d = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do updateInternalIO ptr d >> peek ptr +update ctx d = inlinePerformIO $ withCtxCopy ctx $ \ptr -> updateInternalIO ptr d {-# NOINLINE finalize #-} -- | finalize the context into a digest bytestring finalize :: Ctx -> ByteString -finalize ctx = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do finalizeInternalIO ptr +finalize ctx = inlinePerformIO $ withCtxThrow ctx finalizeInternalIO {-# NOINLINE hash #-} -- | hash a strict bytestring into a digest bytestring hash :: Int -> ByteString -> ByteString -hash hashlen d = unsafePerformIO $ allocInternal $ \ptr -> do - c_skein256_init ptr (fromIntegral hashlen) >> updateInternalIO ptr d >> finalizeInternalIO ptr +hash hashlen d = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_skein256_init ptr (fromIntegral hashlen) >> updateInternalIO ptr d >> finalizeInternalIO ptr {-# NOINLINE hashlazy #-} -- | hash a lazy bytestring into a digest bytestring hashlazy :: Int -> L.ByteString -> ByteString -hashlazy hashlen l = unsafePerformIO $ allocInternal $ \ptr -> do - c_skein256_init ptr (fromIntegral hashlen) >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr +hashlazy hashlen l = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_skein256_init ptr (fromIntegral hashlen) >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr diff --git a/Crypto/Hash/Skein512.hs b/Crypto/Hash/Skein512.hs --- a/Crypto/Hash/Skein512.hs +++ b/Crypto/Hash/Skein512.hs @@ -10,31 +10,29 @@ -- A module containing Skein512 bindings -- module Crypto.Hash.Skein512 - ( Ctx(..) - , Skein512 + ( Ctx(..) + , Skein512 - -- * Incremental hashing Functions - , init -- :: Int -> Ctx - , update -- :: Ctx -> ByteString -> Ctx - , finalize -- :: Ctx -> ByteString + -- * Incremental hashing Functions + , init -- :: Int -> Ctx + , update -- :: Ctx -> ByteString -> Ctx + , finalize -- :: Ctx -> ByteString - -- * Single Pass hashing - , hash -- :: Int -> ByteString -> ByteString - , hashlazy -- :: Int -> ByteString -> ByteString - ) where + -- * Single Pass hashing + , hash -- :: Int -> ByteString -> ByteString + , hashlazy -- :: Int -> ByteString -> ByteString + ) where import Prelude hiding (init) -import System.IO.Unsafe (unsafePerformIO) -import Foreign.C.String import Foreign.C.Types import Foreign.Ptr +import Foreign.ForeignPtr (withForeignPtr) import Foreign.Storable import Foreign.Marshal.Alloc -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString) -import Data.ByteString.Unsafe (unsafeUseAsCString, unsafeUseAsCStringLen) -import Data.ByteString.Internal (create, memcpy) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.ByteString.Internal (create, inlinePerformIO, toForeignPtr) import Data.Word import Data.Bits @@ -48,85 +46,103 @@ import qualified Crypto.Classes as C (Hash(..)) instance C.Hash Ctx Skein512 where - outputLength = Tagged (64 * 8) - blockLength = Tagged (64 * 8) - initialCtx = init (64 * 8) - updateCtx = update - finalize ctx bs = Digest . finalize $ update ctx bs + outputLength = Tagged (64 * 8) + blockLength = Tagged (64 * 8) + initialCtx = init (64 * 8) + updateCtx = update + finalize ctx bs = Digest . finalize $ update ctx bs instance Serialize Skein512 where - get = liftM Digest (getByteString 64) - put (Digest d) = putByteString d + get = liftM Digest (getByteString 64) + put (Digest d) = putByteString d #endif data Ctx = Ctx !ByteString data Skein512 = Digest !ByteString - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show) sizeCtx :: Int -sizeCtx = 160 +sizeCtx = 152 -instance Storable Ctx where - sizeOf _ = sizeCtx - alignment _ = 16 - poke ptr (Ctx b) = unsafeUseAsCString b (\cs -> memcpy (castPtr ptr) (castPtr cs) (fromIntegral sizeCtx)) +peekHashlen :: Ptr Ctx -> IO Int +peekHashlen ptr = do + let iptr = castPtr ptr :: Ptr CUInt + a <- peek iptr + return ((fromIntegral a + 7) `shiftR` 3) - peek ptr = create sizeCtx (\bptr -> memcpy bptr (castPtr ptr) (fromIntegral sizeCtx)) >>= return . Ctx +{-# 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 -poke_hashlen :: Ptr Ctx -> IO Int -poke_hashlen ptr = do - let iptr = castPtr ptr :: Ptr CUInt - a <- peek iptr - return $ fromIntegral a +{-# INLINE memcopy64 #-} +memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO () +memcopy64 dst src = mapM_ peekAndPoke [0..(20-1)] + where peekAndPoke i = peekElemOff src i >>= pokeElemOff dst i +withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx +withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx + where createCtx = create sizeCtx $ \dstPtr -> + withByteStringPtr ctxB $ \srcPtr -> do + memcopy64 (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 + memcopy64 (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 "skein512.h skein512_init" - c_skein512_init :: Ptr Ctx -> CUInt -> IO () + c_skein512_init :: Ptr Ctx -> Word32 -> IO () foreign import ccall "skein512.h skein512_update" - c_skein512_update :: Ptr Ctx -> CString -> Word32 -> IO () + c_skein512_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO () foreign import ccall unsafe "skein512.h skein512_finalize" - c_skein512_finalize :: Ptr Ctx -> CString -> IO () + c_skein512_finalize :: Ptr Ctx -> Ptr Word8 -> IO () -allocInternal :: (Ptr Ctx -> IO a) -> IO a -allocInternal = alloca -allocInternalFrom :: Ctx -> (Ptr Ctx -> IO a) -> IO a -allocInternalFrom ctx f = allocInternal $ \ptr -> (poke ptr ctx >> f ptr) - updateInternalIO :: Ptr Ctx -> ByteString -> IO () updateInternalIO ptr d = - unsafeUseAsCStringLen d (\(cs, len) -> c_skein512_update ptr cs (fromIntegral len)) + unsafeUseAsCStringLen d (\(cs, len) -> c_skein512_update ptr (castPtr cs) (fromIntegral len)) finalizeInternalIO :: Ptr Ctx -> IO ByteString -finalizeInternalIO ptr = do - digestSize <- fmap (\x -> (x + 7) `shiftR` 3) $ poke_hashlen ptr - allocaBytes digestSize (\cs -> c_skein512_finalize ptr cs >> B.packCStringLen (cs, digestSize)) +finalizeInternalIO ptr = + peekHashlen ptr >>= \digestSize -> create digestSize (c_skein512_finalize ptr) {-# NOINLINE init #-} -- | init a context init :: Int -> Ctx -init hashlen = unsafePerformIO $ allocInternal $ \ptr -> do (c_skein512_init ptr (fromIntegral hashlen) >> peek ptr) +init hashlen = inlinePerformIO $ withCtxNew $ \ptr -> c_skein512_init ptr (fromIntegral hashlen) {-# NOINLINE update #-} -- | update a context with a bytestring update :: Ctx -> ByteString -> Ctx -update ctx d = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do updateInternalIO ptr d >> peek ptr +update ctx d = inlinePerformIO $ withCtxCopy ctx $ \ptr -> updateInternalIO ptr d {-# NOINLINE finalize #-} -- | finalize the context into a digest bytestring finalize :: Ctx -> ByteString -finalize ctx = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do finalizeInternalIO ptr +finalize ctx = inlinePerformIO $ withCtxThrow ctx finalizeInternalIO {-# NOINLINE hash #-} -- | hash a strict bytestring into a digest bytestring hash :: Int -> ByteString -> ByteString -hash hashlen d = unsafePerformIO $ allocInternal $ \ptr -> do - c_skein512_init ptr (fromIntegral hashlen) >> updateInternalIO ptr d >> finalizeInternalIO ptr +hash hashlen d = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_skein512_init ptr (fromIntegral hashlen) >> updateInternalIO ptr d >> finalizeInternalIO ptr {-# NOINLINE hashlazy #-} -- | hash a lazy bytestring into a digest bytestring hashlazy :: Int -> L.ByteString -> ByteString -hashlazy hashlen l = unsafePerformIO $ allocInternal $ \ptr -> do - c_skein512_init ptr (fromIntegral hashlen) >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr +hashlazy hashlen l = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_skein512_init ptr (fromIntegral hashlen) >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr diff --git a/Crypto/Hash/Tiger.hs b/Crypto/Hash/Tiger.hs --- a/Crypto/Hash/Tiger.hs +++ b/Crypto/Hash/Tiger.hs @@ -10,30 +10,28 @@ -- A module containing Tiger bindings -- module Crypto.Hash.Tiger - ( Ctx(..) - , Tiger + ( Ctx(..) + , Tiger - -- * Incremental hashing Functions - , init -- :: Ctx - , update -- :: Ctx -> ByteString -> Ctx - , finalize -- :: Ctx -> ByteString + -- * Incremental hashing Functions + , init -- :: Ctx + , update -- :: Ctx -> ByteString -> Ctx + , finalize -- :: Ctx -> ByteString - -- * Single Pass hashing - , hash -- :: ByteString -> ByteString - , hashlazy -- :: ByteString -> ByteString - ) where + -- * Single Pass hashing + , hash -- :: ByteString -> ByteString + , hashlazy -- :: ByteString -> ByteString + ) where import Prelude hiding (init) -import System.IO.Unsafe (unsafePerformIO) -import Foreign.C.String import Foreign.Ptr +import Foreign.ForeignPtr (withForeignPtr) import Foreign.Storable import Foreign.Marshal.Alloc -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString) -import Data.ByteString.Unsafe (unsafeUseAsCString, unsafeUseAsCStringLen) -import Data.ByteString.Internal (create, memcpy) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.ByteString.Internal (create, toForeignPtr, inlinePerformIO) import Data.Word #ifdef HAVE_CRYPTOAPI @@ -46,79 +44,102 @@ import qualified Crypto.Classes as C (Hash(..)) instance C.Hash Ctx Tiger where - outputLength = Tagged (24 * 8) - blockLength = Tagged (64 * 8) - initialCtx = init - updateCtx = update - finalize ctx bs = Digest . finalize $ update ctx bs + outputLength = Tagged (24 * 8) + blockLength = Tagged (64 * 8) + initialCtx = init + updateCtx = update + finalize ctx bs = Digest . finalize $ update ctx bs instance Serialize Tiger where - get = liftM Digest (getByteString digestSize) - put (Digest d) = putByteString d + get = liftM Digest (getByteString digestSize) + put (Digest d) = putByteString d #endif data Ctx = Ctx !ByteString data Tiger = Digest !ByteString - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show) -digestSize, sizeCtx :: Int + +{-# INLINE digestSize #-} +digestSize :: Int digestSize = 24 + +{-# INLINE sizeCtx #-} +sizeCtx :: Int sizeCtx = 96 -instance Storable Ctx where - sizeOf _ = sizeCtx - alignment _ = 16 - poke ptr (Ctx b) = unsafeUseAsCString b (\cs -> memcpy (castPtr ptr) (castPtr cs) (fromIntegral sizeCtx)) +{-# 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 - peek ptr = create sizeCtx (\bptr -> memcpy bptr (castPtr ptr) (fromIntegral sizeCtx)) >>= return . Ctx +{-# INLINE memcopy64 #-} +memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO () +memcopy64 dst src = mapM_ peekAndPoke [0..(12-1)] + where peekAndPoke i = peekElemOff src i >>= pokeElemOff dst i +withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx +withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx + where createCtx = create sizeCtx $ \dstPtr -> + withByteStringPtr ctxB $ \srcPtr -> do + memcopy64 (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 + memcopy64 (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 "tiger.h tiger_init" - c_tiger_init :: Ptr Ctx -> IO () + c_tiger_init :: Ptr Ctx -> IO () foreign import ccall "tiger.h tiger_update" - c_tiger_update :: Ptr Ctx -> CString -> Word32 -> IO () + c_tiger_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO () foreign import ccall unsafe "tiger.h tiger_finalize" - c_tiger_finalize :: Ptr Ctx -> CString -> IO () - -allocInternal :: (Ptr Ctx -> IO a) -> IO a -allocInternal = alloca - -allocInternalFrom :: Ctx -> (Ptr Ctx -> IO a) -> IO a -allocInternalFrom ctx f = allocInternal $ \ptr -> (poke ptr ctx >> f ptr) + c_tiger_finalize :: Ptr Ctx -> Ptr Word8 -> IO () updateInternalIO :: Ptr Ctx -> ByteString -> IO () updateInternalIO ptr d = - unsafeUseAsCStringLen d (\(cs, len) -> c_tiger_update ptr cs (fromIntegral len)) + unsafeUseAsCStringLen d (\(cs, len) -> c_tiger_update ptr (castPtr cs) (fromIntegral len)) finalizeInternalIO :: Ptr Ctx -> IO ByteString finalizeInternalIO ptr = - allocaBytes digestSize (\cs -> c_tiger_finalize ptr cs >> B.packCStringLen (cs, digestSize)) + create digestSize (c_tiger_finalize ptr) {-# NOINLINE init #-} -- | init a context init :: Ctx -init = unsafePerformIO $ allocInternal $ \ptr -> do (c_tiger_init ptr >> peek ptr) +init = inlinePerformIO $ withCtxNew $ c_tiger_init {-# NOINLINE update #-} -- | update a context with a bytestring update :: Ctx -> ByteString -> Ctx -update ctx d = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do updateInternalIO ptr d >> peek ptr +update ctx d = inlinePerformIO $ withCtxCopy ctx $ \ptr -> updateInternalIO ptr d {-# NOINLINE finalize #-} -- | finalize the context into a digest bytestring finalize :: Ctx -> ByteString -finalize ctx = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do finalizeInternalIO ptr +finalize ctx = inlinePerformIO $ withCtxThrow ctx finalizeInternalIO {-# NOINLINE hash #-} -- | hash a strict bytestring into a digest bytestring hash :: ByteString -> ByteString -hash d = unsafePerformIO $ allocInternal $ \ptr -> do - c_tiger_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr +hash d = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_tiger_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr {-# NOINLINE hashlazy #-} -- | hash a lazy bytestring into a digest bytestring hashlazy :: L.ByteString -> ByteString -hashlazy l = unsafePerformIO $ allocInternal $ \ptr -> do - c_tiger_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr +hashlazy l = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_tiger_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr diff --git a/Crypto/Hash/Whirlpool.hs b/Crypto/Hash/Whirlpool.hs --- a/Crypto/Hash/Whirlpool.hs +++ b/Crypto/Hash/Whirlpool.hs @@ -10,30 +10,28 @@ -- A module containing Whirlpool bindings -- module Crypto.Hash.Whirlpool - ( Ctx(..) - , Whirlpool + ( Ctx(..) + , Whirlpool - -- * Incremental hashing Functions - , init -- :: Ctx - , update -- :: Ctx -> ByteString -> Ctx - , finalize -- :: Ctx -> ByteString + -- * Incremental hashing Functions + , init -- :: Ctx + , update -- :: Ctx -> ByteString -> Ctx + , finalize -- :: Ctx -> ByteString - -- * Single Pass hashing - , hash -- :: ByteString -> ByteString - , hashlazy -- :: ByteString -> ByteString - ) where + -- * Single Pass hashing + , hash -- :: ByteString -> ByteString + , hashlazy -- :: ByteString -> ByteString + ) where import Prelude hiding (init) -import System.IO.Unsafe (unsafePerformIO) -import Foreign.C.String import Foreign.Ptr +import Foreign.ForeignPtr (withForeignPtr) import Foreign.Storable import Foreign.Marshal.Alloc -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString) -import Data.ByteString.Unsafe (unsafeUseAsCString, unsafeUseAsCStringLen) -import Data.ByteString.Internal (create, memcpy) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.ByteString.Internal (create, toForeignPtr, inlinePerformIO) import Data.Word #ifdef HAVE_CRYPTOAPI @@ -46,79 +44,102 @@ import qualified Crypto.Classes as C (Hash(..)) instance C.Hash Ctx Whirlpool where - outputLength = Tagged 512 - blockLength = Tagged 512 - initialCtx = init - updateCtx = update - finalize ctx bs = Digest . finalize $ update ctx bs + outputLength = Tagged (64 * 8) + blockLength = Tagged (64 * 8) + initialCtx = init + updateCtx = update + finalize ctx bs = Digest . finalize $ update ctx bs instance Serialize Whirlpool where - get = liftM Digest (getByteString digestSize) - put (Digest d) = putByteString d + get = liftM Digest (getByteString digestSize) + put (Digest d) = putByteString d #endif data Ctx = Ctx !ByteString data Whirlpool = Digest !ByteString - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show) -digestSize, sizeCtx :: Int -digestSize = 512 `div` 8 -sizeCtx = 32 + 64 + 4 + 4 + 64 -instance Storable Ctx where - sizeOf _ = sizeCtx - alignment _ = 16 - poke ptr (Ctx b) = unsafeUseAsCString b (\cs -> memcpy (castPtr ptr) (castPtr cs) (fromIntegral sizeCtx)) +{-# INLINE digestSize #-} +digestSize :: Int +digestSize = 64 - peek ptr = create sizeCtx (\bptr -> memcpy bptr (castPtr ptr) (fromIntegral sizeCtx)) >>= return . Ctx +{-# INLINE sizeCtx #-} +sizeCtx :: Int +sizeCtx = 168 +{-# 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 + +{-# INLINE memcopy64 #-} +memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO () +memcopy64 dst src = mapM_ peekAndPoke [0..(21-1)] + where peekAndPoke i = peekElemOff src i >>= pokeElemOff dst i + +withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx +withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx + where createCtx = create sizeCtx $ \dstPtr -> + withByteStringPtr ctxB $ \srcPtr -> do + memcopy64 (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 + memcopy64 (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 "whirlpool.h whirlpool_init" - c_whirlpool_init :: Ptr Ctx -> IO () + c_whirlpool_init :: Ptr Ctx -> IO () foreign import ccall "whirlpool.h whirlpool_update" - c_whirlpool_update :: Ptr Ctx -> CString -> Word32 -> IO () + c_whirlpool_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO () foreign import ccall unsafe "whirlpool.h whirlpool_finalize" - c_whirlpool_finalize :: Ptr Ctx -> CString -> IO () - -allocInternal :: (Ptr Ctx -> IO a) -> IO a -allocInternal = alloca - -allocInternalFrom :: Ctx -> (Ptr Ctx -> IO a) -> IO a -allocInternalFrom ctx f = allocInternal $ \ptr -> (poke ptr ctx >> f ptr) + c_whirlpool_finalize :: Ptr Ctx -> Ptr Word8 -> IO () updateInternalIO :: Ptr Ctx -> ByteString -> IO () updateInternalIO ptr d = - unsafeUseAsCStringLen d (\(cs, len) -> c_whirlpool_update ptr cs (fromIntegral len)) + unsafeUseAsCStringLen d (\(cs, len) -> c_whirlpool_update ptr (castPtr cs) (fromIntegral len)) finalizeInternalIO :: Ptr Ctx -> IO ByteString finalizeInternalIO ptr = - allocaBytes digestSize (\cs -> c_whirlpool_finalize ptr cs >> B.packCStringLen (cs, digestSize)) + create digestSize (c_whirlpool_finalize ptr) {-# NOINLINE init #-} -- | init a context init :: Ctx -init = unsafePerformIO $ allocInternal $ \ptr -> do (c_whirlpool_init ptr >> peek ptr) +init = inlinePerformIO $ withCtxNew $ c_whirlpool_init {-# NOINLINE update #-} -- | update a context with a bytestring update :: Ctx -> ByteString -> Ctx -update ctx d = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do updateInternalIO ptr d >> peek ptr +update ctx d = inlinePerformIO $ withCtxCopy ctx $ \ptr -> updateInternalIO ptr d {-# NOINLINE finalize #-} -- | finalize the context into a digest bytestring finalize :: Ctx -> ByteString -finalize ctx = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do finalizeInternalIO ptr +finalize ctx = inlinePerformIO $ withCtxThrow ctx finalizeInternalIO {-# NOINLINE hash #-} -- | hash a strict bytestring into a digest bytestring hash :: ByteString -> ByteString -hash d = unsafePerformIO $ allocInternal $ \ptr -> do - c_whirlpool_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr +hash d = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_whirlpool_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr {-# NOINLINE hashlazy #-} -- | hash a lazy bytestring into a digest bytestring hashlazy :: L.ByteString -> ByteString -hashlazy l = unsafePerformIO $ allocInternal $ \ptr -> do - c_whirlpool_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr +hashlazy l = inlinePerformIO $ withCtxNewThrow $ \ptr -> do + c_whirlpool_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr diff --git a/Crypto/MAC/HMAC.hs b/Crypto/MAC/HMAC.hs --- a/Crypto/MAC/HMAC.hs +++ b/Crypto/MAC/HMAC.hs @@ -9,8 +9,8 @@ -- http://en.wikipedia.org/wiki/HMAC -- module Crypto.MAC.HMAC - ( hmac - ) where + ( hmac + ) where import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -19,9 +19,9 @@ -- | compute a MAC using the supplied hashing function hmac :: (ByteString -> ByteString) -> Int -> ByteString -> ByteString -> ByteString hmac f blockSize secret msg = f $ B.append opad (f $ B.append ipad msg) where - opad = B.map (xor 0x5c) k' - ipad = B.map (xor 0x36) k' + opad = B.map (xor 0x5c) k' + ipad = B.map (xor 0x36) k' - k' = B.append kt pad - kt = if B.length secret > fromIntegral blockSize then f secret else secret - pad = B.replicate (fromIntegral blockSize - B.length kt) 0 + k' = B.append kt pad + kt = if B.length secret > fromIntegral blockSize then f secret else secret + pad = B.replicate (fromIntegral blockSize - B.length kt) 0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -15,6 +15,7 @@ * RIPEMD160 * SHA1 * SHA-2 family: 224, 256, 384, 512 and the newer 512t +* SHA-3 (aka Keccak) * Skein: 256, 512 * Tiger * Whirlpool diff --git a/Tests.hs b/Tests.hs deleted file mode 100644 --- a/Tests.hs +++ /dev/null @@ -1,181 +0,0 @@ -import Test.HUnit -import Data.Char -import Data.Bits -import Data.Word -import qualified Data.ByteString as B -import qualified Crypto.Hash.MD2 as MD2 -import qualified Crypto.Hash.MD4 as MD4 -import qualified Crypto.Hash.MD5 as MD5 -import qualified Crypto.Hash.SHA1 as SHA1 -import qualified Crypto.Hash.SHA224 as SHA224 -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Crypto.Hash.SHA384 as SHA384 -import qualified Crypto.Hash.SHA512 as SHA512 -import qualified Crypto.Hash.SHA512t as SHA512t -import qualified Crypto.Hash.RIPEMD160 as RIPEMD160 -import qualified Crypto.Hash.Tiger as Tiger -import qualified Crypto.Hash.Skein256 as Skein256 -import qualified Crypto.Hash.Skein512 as Skein512 -import qualified Crypto.Hash.Whirlpool as Whirlpool - -v0 = "" -v1 = "The quick brown fox jumps over the lazy dog" -v2 = "The quick brown fox jumps over the lazy cog" -vectors = [ v0, v1, v2 ] - -data HashFct = HashFct - { fctHash :: (B.ByteString -> B.ByteString) - , fctInc :: ([B.ByteString] -> B.ByteString) } - -hashinc i u f = f . foldl u i - -md2Hash = HashFct { fctHash = MD2.hash, fctInc = hashinc MD2.init MD2.update MD2.finalize } -md4Hash = HashFct { fctHash = MD4.hash, fctInc = hashinc MD4.init MD4.update MD4.finalize } -md5Hash = HashFct { fctHash = MD5.hash, fctInc = hashinc MD5.init MD5.update MD5.finalize } - -sha1Hash = HashFct { fctHash = SHA1.hash, fctInc = hashinc SHA1.init SHA1.update SHA1.finalize } - -sha224Hash = HashFct { fctHash = SHA224.hash, fctInc = hashinc SHA224.init SHA224.update SHA224.finalize } -sha256Hash = HashFct { fctHash = SHA256.hash, fctInc = hashinc SHA256.init SHA256.update SHA256.finalize } - -sha384Hash = HashFct { fctHash = SHA384.hash, fctInc = hashinc SHA384.init SHA384.update SHA384.finalize } -sha512Hash = HashFct { fctHash = SHA512.hash, fctInc = hashinc SHA512.init SHA512.update SHA512.finalize } -sha512_224Hash = HashFct { fctHash = SHA512t.hash 224, fctInc = hashinc (SHA512t.init 224) SHA512t.update SHA512t.finalize } -sha512_256Hash = HashFct { fctHash = SHA512t.hash 256, fctInc = hashinc (SHA512t.init 256) SHA512t.update SHA512t.finalize } - -ripemd160Hash = HashFct { fctHash = RIPEMD160.hash, fctInc = hashinc RIPEMD160.init RIPEMD160.update RIPEMD160.finalize } -tigerHash = HashFct { fctHash = Tiger.hash, fctInc = hashinc Tiger.init Tiger.update Tiger.finalize } - -skein256Hash x = HashFct { fctHash = Skein256.hash x, fctInc = hashinc (Skein256.init x) Skein256.update Skein256.finalize } -skein512Hash x = HashFct { fctHash = Skein512.hash x, fctInc = hashinc (Skein512.init x) Skein512.update Skein512.finalize } - -whirlpoolHash = HashFct { fctHash = Whirlpool.hash, fctInc = hashinc Whirlpool.init Whirlpool.update Whirlpool.finalize } - -results :: [ (String, HashFct, [String]) ] -results = [ - ("MD2", md2Hash, [ - "8350e5a3e24c153df2275c9f80692773", - "03d85a0d629d2c442e987525319fc471", - "6b890c9292668cdbbfda00a4ebf31f05" ]), - ("MD4", md4Hash, [ - "31d6cfe0d16ae931b73c59d7e0c089c0", - "1bee69a46ba811185c194762abaeae90", - "b86e130ce7028da59e672d56ad0113df" ]), - ("MD5", md5Hash, [ - "d41d8cd98f00b204e9800998ecf8427e", - "9e107d9d372bb6826bd81d3542a419d6", - "1055d3e698d289f2af8663725127bd4b" ]), - ("SHA1", sha1Hash, [ - "da39a3ee5e6b4b0d3255bfef95601890afd80709", - "2fd4e1c67a2d28fced849ee1bb76e7391b93eb12", - "de9f2c7fd25e1b3afad3e85a0bd17d9b100db4b3" ]), - ("SHA224", sha224Hash, [ - "d14a028c2a3a2bc9476102bb288234c415a2b01f828ea62ac5b3e42f", - "730e109bd7a8a32b1cb9d9a09aa2325d2430587ddbc0c38bad911525", - "fee755f44a55f20fb3362cdc3c493615b3cb574ed95ce610ee5b1e9b" ]), - ("SHA256", sha256Hash, [ - "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855", - "d7a8fbb307d7809469ca9abcb0082e4f8d5651e46d3cdb762d02d0bf37c9e592", - "e4c4d8f3bf76b692de791a173e05321150f7a345b46484fe427f6acc7ecc81be" ]), - ("SHA384", sha384Hash, [ - "38b060a751ac96384cd9327eb1b1e36a21fdb71114be07434c0cc7bf63f6e1da274edebfe76f65fbd51ad2f14898b95b", - "ca737f1014a48f4c0b6dd43cb177b0afd9e5169367544c494011e3317dbf9a509cb1e5dc1e85a941bbee3d7f2afbc9b1", - "098cea620b0978caa5f0befba6ddcf22764bea977e1c70b3483edfdf1de25f4b40d6cea3cadf00f809d422feb1f0161b" ]), - ("SHA512", sha512Hash, [ - "cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e", - "07e547d9586f6a73f73fbac0435ed76951218fb7d0c8d788a309d785436bbb642e93a252a954f23912547d1e8a3b5ed6e1bfd7097821233fa0538f3db854fee6", - "3eeee1d0e11733ef152a6c29503b3ae20c4f1f3cda4cb26f1bc1a41f91c7fe4ab3bd86494049e201c4bd5155f31ecb7a3c8606843c4cc8dfcab7da11c8ae5045" ]), - - ("SHA512/224", sha512_224Hash, [ - "6ed0dd02806fa89e25de060c19d3ac86cabb87d6a0ddd05c333b84f4", - "944cd2847fb54558d4775db0485a50003111c8e5daa63fe722c6aa37", - "2b9d6565a7e40f780ba8ab7c8dcf41e3ed3b77997f4c55aa987eede5" ]), - ("SHA512/256", sha512_256Hash, [ - "c672b8d1ef56ed28ab87c3622c5114069bdd3ad7b8f9737498d0c01ecef0967a", - "dd9d67b371519c339ed8dbd25af90e976a1eeefd4ad3d889005e532fc5bef04d", - "cc8d255a7f2f38fd50388fd1f65ea7910835c5c1e73da46fba01ea50d5dd76fb" ]), - ("RIPEMD160", ripemd160Hash, [ - "9c1185a5c5e9fc54612808977ee8f548b2258d31", - "37f332f68db77bd9d7edd4969571ad671cf9dd3b", - "132072df690933835eb8b6ad0b77e7b6f14acad7" ]), - ("Tiger", tigerHash, [ - "3293ac630c13f0245f92bbb1766e16167a4e58492dde73f3", - "6d12a41e72e644f017b6f0e2f7b44c6285f06dd5d2c5b075", - "a8f04b0f7201a0d728101c9d26525b31764a3493fcd8458f" ]) - , ("Skein256-160", skein256Hash 160, [ - "ff800bed6d2044ee9d604a674e3fda50d9b24a72", - "3265703c166aa3e0d7da070b9cf1b1a5953f0a77", - "17b29aa1424b3ec022505bd215ff73fd2e6d1e5a" ]) - , ("Skein256-256", skein256Hash 256, [ - "c8877087da56e072870daa843f176e9453115929094c3a40c463a196c29bf7ba", - "c0fbd7d779b20f0a4614a66697f9e41859eaf382f14bf857e8cdb210adb9b3fe", - "fb2f2f2deed0e1dd7ee2b91cee34e2d1c22072e1f5eaee288c35a0723eb653cd" ]) - , ("Skein512-160", skein512Hash 160, [ - "49daf1ccebb3544bc93cb5019ba91b0eea8876ee", - "826325ee55a6dd18c3b2dbbc9c10420f5475975e", - "7544ec7a35712ec953f02b0d0c86641cae4eb6e5" ]) - , ("Skein512-384", skein512Hash 384, [ - "dd5aaf4589dc227bd1eb7bc68771f5baeaa3586ef6c7680167a023ec8ce26980f06c4082c488b4ac9ef313f8cbe70808", - "f814c107f3465e7c54048a5503547deddc377264f05c706b0d19db4847b354855ee52ab6a785c238c9e710d848542041", - "e06520eeadc1d0a44fee1d2492547499c1e58526387c8b9c53905e5edb79f9840575cbf844e21b1ad1ea126dd8a8ca6f" ]) - , ("Skein512-512", skein512Hash 512, [ - "bc5b4c50925519c290cc634277ae3d6257212395cba733bbad37a4af0fa06af41fca7903d06564fea7a2d3730dbdb80c1f85562dfcc070334ea4d1d9e72cba7a", - "94c2ae036dba8783d0b3f7d6cc111ff810702f5c77707999be7e1c9486ff238a7044de734293147359b4ac7e1d09cd247c351d69826b78dcddd951f0ef912713", - "7f81113575e4b4d3441940e87aca331e6d63d103fe5107f29cd877af0d0f5e0ea34164258c60da5190189d0872e63a96596d2ef25e709099842da71d64111e0f" ]) - , ("Skein512-896", skein512Hash 896, [ - "b95175236c83a459ce7ec6c12b761a838b22d750e765b3fdaa892201b2aa714bc3d1d887dd64028bbf177c1dd11baa09c6c4ddb598fd07d6a8c131a09fc5b958e2999a8006754b25abe3bf8492b7eabec70e52e04e5ac867df2393c573f16eee3244554f1d2b724f2c0437c62007f770", - "3265708553e7d146e5c7bcbc97b3e9e9f5b53a5e4af53612bdd6454da4fa7b13d413184fe34ed57b6574be10e389d0ec4b1d2b1dd2c80e0257d5a76b2cd86a19a27b1bcb3cc24d911b5dc5ee74d19ad558fd85b5f024e99f56d1d3199f1f9f88ed85fab9f945f11cf9fc00e94e3ca4c7", - "3d23d3db9be719bbd2119f8402a28f38d8225faa79d5b68b80738c64a82004aafc7a840cd6dd9bced6644fa894a3d8d7d2ee89525fd1956a2db052c4c2f8d2111c91ef46b0997540d42bcf384826af1a5ef6510077f52d0574cf2b46f1b6a5dad07ed40f3d21a13ca2d079fa602ff02d" ]) - , ("Whirlpool", whirlpoolHash, [ - "19fa61d75522a4669b44e39c1d2e1726c530232130d407f89afee0964997f7a73e83be698b288febcf88e3e03c4f0757ea8964e59b63d93708b138cc42a66eb3", - "b97de512e91e3828b40d2b0fdce9ceb3c4a71f9bea8d88e75c4fa854df36725fd2b52eb6544edcacd6f8beddfea403cb55ae31f03ad62a5ef54e42ee82c3fb35", - "dce81fc695cfea3d7e1446509238daf89f24cc61896f2d265927daa70f2108f8902f0dfd68be085d5abb9fcd2e482c1dc24f2fabf81f40b73495cad44d7360d3"]) - ] - -hexalise s = - concatMap (\c -> [ hex $ c `div` 16, hex $ c `mod` 16 ]) s - where hex i - | i >= 0 && i <= 9 = fromIntegral (ord '0') + i - | i >= 10 && i <= 15 = fromIntegral (ord 'a') + i - 10 - | otherwise = 0 - -hexaliseB :: B.ByteString -> B.ByteString -hexaliseB = B.pack . hexalise . B.unpack - -splitB l b = - if B.length b > l - then - let (b1, b2) = B.splitAt l b in - b1 : splitB l b2 - else - [ b ] - -showHash :: B.ByteString -> String -showHash = map (toEnum.fromEnum) . hexalise . B.unpack - -runhash hash v = showHash $ (fctHash hash) $ v -runhashinc hash v = showHash $ (fctInc hash) $ v - -makeTestAlg (name, hash, results) = concatMap maketest $ zip3 [0..] vectors results - where - testname i = name ++ " " ++ show i - runtest v = runhash hash $ B.pack $ map (toEnum.fromEnum) v - - runtestinc i v = runhashinc hash $ splitB i $ B.pack $ map (toEnum.fromEnum) v - - maketest (i, v, r) = - [ testname i ~: testname i ~: r ~=? (runtest v), - testname i ~: testname i ~: r ~=? (runtestinc 1 v), - testname i ~: testname i ~: r ~=? (runtestinc 2 v), - testname i ~: testname i ~: r ~=? (runtestinc 3 v), - testname i ~: testname i ~: r ~=? (runtestinc 4 v), - testname i ~: testname i ~: r ~=? (runtestinc 5 v), - testname i ~: testname i ~: r ~=? (runtestinc 9 v), - testname i ~: testname i ~: r ~=? (runtestinc 16 v) ] - -mapTests :: [Test] -mapTests = concatMap makeTestAlg results - -tests = TestList mapTests - -main = runTestTT tests diff --git a/Tests/KAT.hs b/Tests/KAT.hs new file mode 100644 --- /dev/null +++ b/Tests/KAT.hs @@ -0,0 +1,199 @@ +import Test.HUnit +import Data.Char +import Data.Bits +import Data.Word +import qualified Data.ByteString as B +import qualified Crypto.Hash.MD2 as MD2 +import qualified Crypto.Hash.MD4 as MD4 +import qualified Crypto.Hash.MD5 as MD5 +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Crypto.Hash.SHA224 as SHA224 +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Crypto.Hash.SHA384 as SHA384 +import qualified Crypto.Hash.SHA512 as SHA512 +import qualified Crypto.Hash.SHA512t as SHA512t +import qualified Crypto.Hash.SHA3 as SHA3 +import qualified Crypto.Hash.RIPEMD160 as RIPEMD160 +import qualified Crypto.Hash.Tiger as Tiger +import qualified Crypto.Hash.Skein256 as Skein256 +import qualified Crypto.Hash.Skein512 as Skein512 +import qualified Crypto.Hash.Whirlpool as Whirlpool + +v0 = "" +v1 = "The quick brown fox jumps over the lazy dog" +v2 = "The quick brown fox jumps over the lazy cog" +vectors = [ v0, v1, v2 ] + +data HashFct = HashFct + { fctHash :: (B.ByteString -> B.ByteString) + , fctInc :: ([B.ByteString] -> B.ByteString) } + +hashinc i u f = f . foldl u i + +md2Hash = HashFct { fctHash = MD2.hash, fctInc = hashinc MD2.init MD2.update MD2.finalize } +md4Hash = HashFct { fctHash = MD4.hash, fctInc = hashinc MD4.init MD4.update MD4.finalize } +md5Hash = HashFct { fctHash = MD5.hash, fctInc = hashinc MD5.init MD5.update MD5.finalize } + +sha1Hash = HashFct { fctHash = SHA1.hash, fctInc = hashinc SHA1.init SHA1.update SHA1.finalize } + +sha224Hash = HashFct { fctHash = SHA224.hash, fctInc = hashinc SHA224.init SHA224.update SHA224.finalize } +sha256Hash = HashFct { fctHash = SHA256.hash, fctInc = hashinc SHA256.init SHA256.update SHA256.finalize } + +sha384Hash = HashFct { fctHash = SHA384.hash, fctInc = hashinc SHA384.init SHA384.update SHA384.finalize } +sha512Hash = HashFct { fctHash = SHA512.hash, fctInc = hashinc SHA512.init SHA512.update SHA512.finalize } +sha512_224Hash = HashFct { fctHash = SHA512t.hash 224, fctInc = hashinc (SHA512t.init 224) SHA512t.update SHA512t.finalize } +sha512_256Hash = HashFct { fctHash = SHA512t.hash 256, fctInc = hashinc (SHA512t.init 256) SHA512t.update SHA512t.finalize } + +sha3Hash i = HashFct { fctHash = SHA3.hash i, fctInc = hashinc (SHA3.init i) SHA3.update SHA3.finalize } + +ripemd160Hash = HashFct { fctHash = RIPEMD160.hash, fctInc = hashinc RIPEMD160.init RIPEMD160.update RIPEMD160.finalize } +tigerHash = HashFct { fctHash = Tiger.hash, fctInc = hashinc Tiger.init Tiger.update Tiger.finalize } + +skein256Hash x = HashFct { fctHash = Skein256.hash x, fctInc = hashinc (Skein256.init x) Skein256.update Skein256.finalize } +skein512Hash x = HashFct { fctHash = Skein512.hash x, fctInc = hashinc (Skein512.init x) Skein512.update Skein512.finalize } + +whirlpoolHash = HashFct { fctHash = Whirlpool.hash, fctInc = hashinc Whirlpool.init Whirlpool.update Whirlpool.finalize } + +results :: [ (String, HashFct, [String]) ] +results = [ + ("MD2", md2Hash, [ + "8350e5a3e24c153df2275c9f80692773", + "03d85a0d629d2c442e987525319fc471", + "6b890c9292668cdbbfda00a4ebf31f05" ]), + ("MD4", md4Hash, [ + "31d6cfe0d16ae931b73c59d7e0c089c0", + "1bee69a46ba811185c194762abaeae90", + "b86e130ce7028da59e672d56ad0113df" ]), + ("MD5", md5Hash, [ + "d41d8cd98f00b204e9800998ecf8427e", + "9e107d9d372bb6826bd81d3542a419d6", + "1055d3e698d289f2af8663725127bd4b" ]), + ("SHA1", sha1Hash, [ + "da39a3ee5e6b4b0d3255bfef95601890afd80709", + "2fd4e1c67a2d28fced849ee1bb76e7391b93eb12", + "de9f2c7fd25e1b3afad3e85a0bd17d9b100db4b3" ]), + ("SHA224", sha224Hash, [ + "d14a028c2a3a2bc9476102bb288234c415a2b01f828ea62ac5b3e42f", + "730e109bd7a8a32b1cb9d9a09aa2325d2430587ddbc0c38bad911525", + "fee755f44a55f20fb3362cdc3c493615b3cb574ed95ce610ee5b1e9b" ]), + ("SHA256", sha256Hash, [ + "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855", + "d7a8fbb307d7809469ca9abcb0082e4f8d5651e46d3cdb762d02d0bf37c9e592", + "e4c4d8f3bf76b692de791a173e05321150f7a345b46484fe427f6acc7ecc81be" ]), + ("SHA384", sha384Hash, [ + "38b060a751ac96384cd9327eb1b1e36a21fdb71114be07434c0cc7bf63f6e1da274edebfe76f65fbd51ad2f14898b95b", + "ca737f1014a48f4c0b6dd43cb177b0afd9e5169367544c494011e3317dbf9a509cb1e5dc1e85a941bbee3d7f2afbc9b1", + "098cea620b0978caa5f0befba6ddcf22764bea977e1c70b3483edfdf1de25f4b40d6cea3cadf00f809d422feb1f0161b" ]), + ("SHA512", sha512Hash, [ + "cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e", + "07e547d9586f6a73f73fbac0435ed76951218fb7d0c8d788a309d785436bbb642e93a252a954f23912547d1e8a3b5ed6e1bfd7097821233fa0538f3db854fee6", + "3eeee1d0e11733ef152a6c29503b3ae20c4f1f3cda4cb26f1bc1a41f91c7fe4ab3bd86494049e201c4bd5155f31ecb7a3c8606843c4cc8dfcab7da11c8ae5045" ]), + + ("SHA512/224", sha512_224Hash, [ + "6ed0dd02806fa89e25de060c19d3ac86cabb87d6a0ddd05c333b84f4", + "944cd2847fb54558d4775db0485a50003111c8e5daa63fe722c6aa37", + "2b9d6565a7e40f780ba8ab7c8dcf41e3ed3b77997f4c55aa987eede5" ]), + ("SHA512/256", sha512_256Hash, [ + "c672b8d1ef56ed28ab87c3622c5114069bdd3ad7b8f9737498d0c01ecef0967a", + "dd9d67b371519c339ed8dbd25af90e976a1eeefd4ad3d889005e532fc5bef04d", + "cc8d255a7f2f38fd50388fd1f65ea7910835c5c1e73da46fba01ea50d5dd76fb" ]), + ("RIPEMD160", ripemd160Hash, [ + "9c1185a5c5e9fc54612808977ee8f548b2258d31", + "37f332f68db77bd9d7edd4969571ad671cf9dd3b", + "132072df690933835eb8b6ad0b77e7b6f14acad7" ]), + ("Tiger", tigerHash, [ + "3293ac630c13f0245f92bbb1766e16167a4e58492dde73f3", + "6d12a41e72e644f017b6f0e2f7b44c6285f06dd5d2c5b075", + "a8f04b0f7201a0d728101c9d26525b31764a3493fcd8458f" ]) + , ("Skein256-160", skein256Hash 160, [ + "ff800bed6d2044ee9d604a674e3fda50d9b24a72", + "3265703c166aa3e0d7da070b9cf1b1a5953f0a77", + "17b29aa1424b3ec022505bd215ff73fd2e6d1e5a" ]) + , ("Skein256-256", skein256Hash 256, [ + "c8877087da56e072870daa843f176e9453115929094c3a40c463a196c29bf7ba", + "c0fbd7d779b20f0a4614a66697f9e41859eaf382f14bf857e8cdb210adb9b3fe", + "fb2f2f2deed0e1dd7ee2b91cee34e2d1c22072e1f5eaee288c35a0723eb653cd" ]) + , ("Skein512-160", skein512Hash 160, [ + "49daf1ccebb3544bc93cb5019ba91b0eea8876ee", + "826325ee55a6dd18c3b2dbbc9c10420f5475975e", + "7544ec7a35712ec953f02b0d0c86641cae4eb6e5" ]) + , ("Skein512-384", skein512Hash 384, [ + "dd5aaf4589dc227bd1eb7bc68771f5baeaa3586ef6c7680167a023ec8ce26980f06c4082c488b4ac9ef313f8cbe70808", + "f814c107f3465e7c54048a5503547deddc377264f05c706b0d19db4847b354855ee52ab6a785c238c9e710d848542041", + "e06520eeadc1d0a44fee1d2492547499c1e58526387c8b9c53905e5edb79f9840575cbf844e21b1ad1ea126dd8a8ca6f" ]) + , ("Skein512-512", skein512Hash 512, [ + "bc5b4c50925519c290cc634277ae3d6257212395cba733bbad37a4af0fa06af41fca7903d06564fea7a2d3730dbdb80c1f85562dfcc070334ea4d1d9e72cba7a", + "94c2ae036dba8783d0b3f7d6cc111ff810702f5c77707999be7e1c9486ff238a7044de734293147359b4ac7e1d09cd247c351d69826b78dcddd951f0ef912713", + "7f81113575e4b4d3441940e87aca331e6d63d103fe5107f29cd877af0d0f5e0ea34164258c60da5190189d0872e63a96596d2ef25e709099842da71d64111e0f" ]) + , ("Skein512-896", skein512Hash 896, [ + "b95175236c83a459ce7ec6c12b761a838b22d750e765b3fdaa892201b2aa714bc3d1d887dd64028bbf177c1dd11baa09c6c4ddb598fd07d6a8c131a09fc5b958e2999a8006754b25abe3bf8492b7eabec70e52e04e5ac867df2393c573f16eee3244554f1d2b724f2c0437c62007f770", + "3265708553e7d146e5c7bcbc97b3e9e9f5b53a5e4af53612bdd6454da4fa7b13d413184fe34ed57b6574be10e389d0ec4b1d2b1dd2c80e0257d5a76b2cd86a19a27b1bcb3cc24d911b5dc5ee74d19ad558fd85b5f024e99f56d1d3199f1f9f88ed85fab9f945f11cf9fc00e94e3ca4c7", + "3d23d3db9be719bbd2119f8402a28f38d8225faa79d5b68b80738c64a82004aafc7a840cd6dd9bced6644fa894a3d8d7d2ee89525fd1956a2db052c4c2f8d2111c91ef46b0997540d42bcf384826af1a5ef6510077f52d0574cf2b46f1b6a5dad07ed40f3d21a13ca2d079fa602ff02d" ]) + , ("Whirlpool", whirlpoolHash, [ + "19fa61d75522a4669b44e39c1d2e1726c530232130d407f89afee0964997f7a73e83be698b288febcf88e3e03c4f0757ea8964e59b63d93708b138cc42a66eb3", + "b97de512e91e3828b40d2b0fdce9ceb3c4a71f9bea8d88e75c4fa854df36725fd2b52eb6544edcacd6f8beddfea403cb55ae31f03ad62a5ef54e42ee82c3fb35", + "dce81fc695cfea3d7e1446509238daf89f24cc61896f2d265927daa70f2108f8902f0dfd68be085d5abb9fcd2e482c1dc24f2fabf81f40b73495cad44d7360d3"]) + , ("SHA3-224", sha3Hash 224, [ + "f71837502ba8e10837bdd8d365adb85591895602fc552b48b7390abd", + "310aee6b30c47350576ac2873fa89fd190cdc488442f3ef654cf23fe", + "0b27ff3b732133287f6831e2af47cf342b7ef1f3fcdee248811090cd" ]) + , ("SHA3-256", sha3Hash 256, [ + "c5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470", + "4d741b6f1eb29cb2a9b9911c82f56fa8d73b04959d3d9d222895df6c0b28aa15", + "ed6c07f044d7573cc53bf1276f8cba3dac497919597a45b4599c8f73e22aa334" ]) + , ("SHA3-384", sha3Hash 384, [ + "2c23146a63a29acf99e73b88f8c24eaa7dc60aa771780ccc006afbfa8fe2479b2dd2b21362337441ac12b515911957ff", + "283990fa9d5fb731d786c5bbee94ea4db4910f18c62c03d173fc0a5e494422e8a0b3da7574dae7fa0baf005e504063b3", + "1cc515e1812491058d8b8b226fd85045e746b4937a58b0111b6b7a39dd431b6295bd6b6d05e01e225586b4dab3cbb87a" ]) + , ("SHA3-512", sha3Hash 512, [ + "0eab42de4c3ceb9235fc91acffe746b29c29a8c366b7c60e4e67c466f36a4304c00fa9caf9d87976ba469bcbe06713b435f091ef2769fb160cdab33d3670680e", + "d135bb84d0439dbac432247ee573a23ea7d3c9deb2a968eb31d47c4fb45f1ef4422d6c531b5b9bd6f449ebcc449ea94d0a8f05f62130fda612da53c79659f609", + "10f8caabb5b179861da5e447d34b84d604e3eb81830880e1c2135ffc94580a47cb21f6243ec0053d58b1124d13af2090033659075ee718e0f111bb3f69fb24cf" ]) + ] + +hexalise s = concatMap (\c -> [ hex $ c `div` 16, hex $ c `mod` 16 ]) s + where hex i + | i >= 0 && i <= 9 = fromIntegral (ord '0') + i + | i >= 10 && i <= 15 = fromIntegral (ord 'a') + i - 10 + | otherwise = 0 + +hexaliseB :: B.ByteString -> B.ByteString +hexaliseB = B.pack . hexalise . B.unpack + +splitB l b = + if B.length b > l + then + let (b1, b2) = B.splitAt l b in + b1 : splitB l b2 + else + [ b ] + +showHash :: B.ByteString -> String +showHash = map (toEnum.fromEnum) . hexalise . B.unpack + +runhash hash v = showHash $ (fctHash hash) $ v +runhashinc hash v = showHash $ (fctInc hash) $ v + +makeTestAlg (name, hash, results) = concatMap maketest $ zip3 [0..] vectors results + where + testname i = name ++ " " ++ show i + runtest v = runhash hash $ B.pack $ map (toEnum.fromEnum) v + + runtestinc i v = runhashinc hash $ splitB i $ B.pack $ map (toEnum.fromEnum) v + + maketest (i, v, r) = + [ testname i ~: testname i ~: r ~=? (runtest v), + testname i ~: testname i ~: r ~=? (runtestinc 1 v), + testname i ~: testname i ~: r ~=? (runtestinc 2 v), + testname i ~: testname i ~: r ~=? (runtestinc 3 v), + testname i ~: testname i ~: r ~=? (runtestinc 4 v), + testname i ~: testname i ~: r ~=? (runtestinc 5 v), + testname i ~: testname i ~: r ~=? (runtestinc 9 v), + testname i ~: testname i ~: r ~=? (runtestinc 16 v) ] + +mapTests :: [Test] +mapTests = concatMap makeTestAlg results + +tests = TestList mapTests + +main = runTestTT tests diff --git a/cbits/sha3.c b/cbits/sha3.c new file mode 100644 --- /dev/null +++ b/cbits/sha3.c @@ -0,0 +1,150 @@ +/* + * Copyright (C) 2012 Vincent Hanquez + * + * 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. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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. + */ + +#include +#include +#include "bitfn.h" +#include "sha3.h" + +#define KECCAK_NB_ROUNDS 24 + +/* rounds constants */ +static const uint64_t keccak_rndc[24] = +{ + 0x0000000000000001ULL, 0x0000000000008082ULL, 0x800000000000808aULL, + 0x8000000080008000ULL, 0x000000000000808bULL, 0x0000000080000001ULL, + 0x8000000080008081ULL, 0x8000000000008009ULL, 0x000000000000008aULL, + 0x0000000000000088ULL, 0x0000000080008009ULL, 0x000000008000000aULL, + 0x000000008000808bULL, 0x800000000000008bULL, 0x8000000000008089ULL, + 0x8000000000008003ULL, 0x8000000000008002ULL, 0x8000000000000080ULL, + 0x000000000000800aULL, 0x800000008000000aULL, 0x8000000080008081ULL, + 0x8000000000008080ULL, 0x0000000080000001ULL, 0x8000000080008008ULL, +}; + +/* triangular numbers constants */ +static const int keccak_rotc[24] = + { 1,3,6,10,15,21,28,36,45,55,2,14,27,41,56,8,25,43,62,18,39,61,20,44 }; + +static const int keccak_piln[24] = + { 10,7,11,17,18,3,5,16,8,21,24,4,15,23,19,13,12,2,20,14,22,9,6,1 }; + +static inline void sha3_do_chunk(uint64_t state[25], uint64_t buf[], int bufsz) +{ + int i, j, r; + uint64_t tmp, bc[5]; + + /* merge buf with state */ + for (i = 0; i < bufsz; i++) + state[i] ^= buf[i]; + + /* run keccak rounds */ + for (r = 0; r < KECCAK_NB_ROUNDS; r++) { + /* compute the parity of each columns */ + for (i = 0; i < 5; i++) + bc[i] = state[i] ^ state[i+5] ^ state[i+10] ^ state[i+15] ^ state[i+20]; + + for (i = 0; i < 5; i++) { + tmp = bc[(i + 4) % 5] ^ rol64(bc[(i + 1) % 5], 1); + for (j = 0; j < 25; j += 5) + state[j + i] ^= tmp; + } + + /* rho pi */ + tmp = state[1]; + for (i = 0; i < 24; i++) { + j = keccak_piln[i]; + bc[0] = state[j]; + state[j] = rol64(tmp, keccak_rotc[i]); + tmp = bc[0]; + } + + /* bitwise combine along rows using a = a xor (not b and c) */ + for (j = 0; j < 25; j += 5) { + for (i = 0; i < 5; i++) + bc[i] = state[j + i]; + #define andn(b,c) (~(b) & (c)) + state[j + 0] ^= andn(bc[1], bc[2]); + state[j + 1] ^= andn(bc[2], bc[3]); + state[j + 2] ^= andn(bc[3], bc[4]); + state[j + 3] ^= andn(bc[4], bc[0]); + state[j + 4] ^= andn(bc[0], bc[1]); + #undef andn + } + + /* xor the round constant */ + state[0] ^= keccak_rndc[r]; + } +} + +void sha3_init(struct sha3_ctx *ctx, uint32_t hashlen) +{ + memset(ctx, 0, sizeof(*ctx)); + ctx->hashlen = hashlen / 8; + ctx->bufsz = 200 - 2 * ctx->hashlen; +} + +void sha3_update(struct sha3_ctx *ctx, uint8_t *data, uint32_t len) +{ + uint32_t to_fill; + + to_fill = ctx->bufsz - ctx->bufindex; + + if (ctx->bufindex == ctx->bufsz) { + sha3_do_chunk(ctx->state, (uint64_t *) ctx->buf, ctx->bufsz / 8); + ctx->bufindex = 0; + } + + /* process partial buffer if there's enough data to make a block */ + if (ctx->bufindex && len >= to_fill) { + memcpy(ctx->buf + ctx->bufindex, data, to_fill); + sha3_do_chunk(ctx->state, (uint64_t *) ctx->buf, ctx->bufsz / 8); + len -= to_fill; + data += to_fill; + ctx->bufindex = 0; + } + + /* process as much ctx->bufsz-block as possible except the last one in case we finalize */ + for (; len > ctx->bufsz; len -= ctx->bufsz, data += ctx->bufsz) + sha3_do_chunk(ctx->state, (uint64_t *) data, ctx->bufsz / 8); + + /* append data into buf */ + if (len) { + memcpy(ctx->buf + ctx->bufindex, data, len); + ctx->bufindex += len; + } +} + +void sha3_finalize(struct sha3_ctx *ctx, uint8_t *out) +{ + /* add the 10*1 padding */ + ctx->buf[ctx->bufindex++] = 1; + memset(ctx->buf + ctx->bufindex, 0, ctx->bufsz - ctx->bufindex); + ctx->buf[ctx->bufsz - 1] |= 0x80; + + /* process */ + sha3_do_chunk(ctx->state, (uint64_t *) ctx->buf, ctx->bufsz / 8); + + /* output */ + memcpy(out, ctx->state, ctx->hashlen); +} diff --git a/cbits/sha3.h b/cbits/sha3.h new file mode 100644 --- /dev/null +++ b/cbits/sha3.h @@ -0,0 +1,45 @@ +/* + * Copyright (C) 2012 Vincent Hanquez + * + * 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. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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. + */ +#ifndef CRYPTOHASH_SHA3_H +#define CRYPTOHASH_SHA3_H + +#include + +struct sha3_ctx +{ + uint32_t hashlen; /* in bytes */ + uint32_t bufindex; + uint64_t state[25]; + uint32_t bufsz; + uint32_t _padding; + uint8_t buf[144]; /* minimum SHA3-224, otherwise buffer need increases */ +}; + +#define SHA3_CTX_SIZE sizeof(struct sha3_ctx) + +void sha3_init(struct sha3_ctx *ctx, uint32_t hashlen); +void sha3_update(struct sha3_ctx *ctx, uint8_t *data, uint32_t len); +void sha3_finalize(struct sha3_ctx *ctx, uint8_t *out); + +#endif diff --git a/cryptohash.cabal b/cryptohash.cabal --- a/cryptohash.cabal +++ b/cryptohash.cabal @@ -1,5 +1,5 @@ Name: cryptohash -Version: 0.7.6 +Version: 0.7.7 Description: A collection of crypto hashes, with a practical incremental and one-pass, pure APIs, with performance close to the fastest implementations available in others languages. @@ -14,20 +14,16 @@ Synopsis: collection of crypto hashes, fast, pure and practical Category: Data, Cryptography Build-Type: Simple -Cabal-Version: >=1.6 +Cabal-Version: >=1.8 Homepage: http://github.com/vincenthz/hs-cryptohash data-files: README.md extra-source-files: cbits/bitfn.h cbits/md2.h cbits/md4.h cbits/md5.h - cbits/ripemd.h cbits/sha1.h cbits/sha256.h cbits/sha512.h + cbits/ripemd.h cbits/sha1.h cbits/sha256.h cbits/sha512.h cbits/sha3.h cbits/skein.h cbits/skein256.h cbits/skein512.h cbits/tiger.h cbits/whirlpool.h -Flag test - Description: Build unit test - Default: False - Flag benchmark Description: Build benchmark test Default: False @@ -50,6 +46,7 @@ Crypto.Hash.SHA384 Crypto.Hash.SHA512 Crypto.Hash.SHA512t + Crypto.Hash.SHA3 Crypto.Hash.MD2 Crypto.Hash.MD4 Crypto.Hash.MD5 @@ -59,10 +56,11 @@ Crypto.Hash.Tiger Crypto.Hash.Whirlpool Crypto.MAC.HMAC - ghc-options: -Wall -O2 -optc-O3 -fno-cse + ghc-options: -Wall -O2 -optc-O3 -fno-cse -fwarn-tabs C-sources: cbits/sha1.c cbits/sha256.c cbits/sha512.c + cbits/sha3.c cbits/md2.c cbits/md4.c cbits/md5.c @@ -73,51 +71,27 @@ cbits/whirlpool.c Include-Dirs: cbits -Executable Tests - Main-Is: Tests.hs - Extensions: ForeignFunctionInterface - C-sources: cbits/sha1.c - cbits/sha256.c - cbits/sha512.c - cbits/md2.c - cbits/md4.c - cbits/md5.c - cbits/ripemd.c - cbits/skein256.c - cbits/skein512.c - cbits/tiger.c - cbits/whirlpool.c - if flag(test) - Buildable: True - Build-depends: base >= 4, HUnit, bytestring - else - Buildable: False - if flag(cryptoapi) - Build-depends: crypto-api >= 0.5, tagged >= 0.1, cereal >= 0.2 - cpp-options: -DHAVE_CRYPTOAPI +Test-Suite test-kat + type: exitcode-stdio-1.0 + hs-source-dirs: Tests + Main-Is: KAT.hs + Build-depends: base >= 4 && < 5 + , bytestring + , HUnit + , QuickCheck >= 2 + , test-framework >= 0.3.3 && < 0.7 + , test-framework-quickcheck2 >= 0.2.9 && < 0.3 + , test-framework-hunit + , cryptohash Executable Bench Main-Is: Bench.hs - Extensions: ForeignFunctionInterface - C-sources: cbits/sha1.c - cbits/sha256.c - cbits/sha512.c - cbits/md2.c - cbits/md4.c - cbits/md5.c - cbits/ripemd.c - cbits/skein256.c - cbits/skein512.c - cbits/tiger.c - cbits/whirlpool.c + hs-source-dirs: Bench if flag(benchmark) Buildable: True - Build-depends: base >= 4, bytestring, criterion + Build-depends: base >= 4, bytestring, criterion, cryptohash else Buildable: False - if flag(cryptoapi) - Build-depends: crypto-api >= 0.5, tagged >= 0.1, cereal >= 0.2 - cpp-options: -DHAVE_CRYPTOAPI source-repository head type: git