Permalink
Browse files

Added experimental support for Whirlpool.

This patch adds the (public domain) reference implementation of Whirlpool. It is only slightly cleaned up. The bindings are derived from `Crypto.Hash.MD5`.
  • Loading branch information...
1 parent e9b32f7 commit d4c217aae20386ea74a47c41eba46b5949616a82 Stijn van Drongelen committed Aug 9, 2012
Showing with 1,327 additions and 1 deletion.
  1. +124 −0 Crypto/Hash/Whirlpool.hs
  2. +1,058 −0 cbits/whirlpool.c
  3. +13 −0 cbits/whirlpool.h
  4. +129 −0 cbits/whirlpool_nessie.h
  5. +3 −1 cryptohash.cabal
View
@@ -0,0 +1,124 @@
+{-# LANGUAGE ForeignFunctionInterface, CPP, MultiParamTypeClasses #-}
+
+-- |
+-- Module : Crypto.Hash.Whirlpool
+-- License : BSD-style
+-- Maintainer : Vincent Hanquez <vincent@snarc.org>
+-- Stability : experimental
+-- Portability : unknown
+--
+-- A module containing Whirlpool bindings
+--
+module Crypto.Hash.Whirlpool
+ ( Ctx(..)
+ , Whirlpool
+
+ -- * Incremental hashing Functions
+ , init -- :: Ctx
+ , update -- :: Ctx -> ByteString -> Ctx
+ , finalize -- :: Ctx -> ByteString
+
+ -- * 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.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.Word
+
+#ifdef HAVE_CRYPTOAPI
+
+import Control.Monad (liftM)
+import Data.Serialize (Serialize(..))
+import Data.Serialize.Get (getByteString)
+import Data.Serialize.Put (putByteString)
+import Data.Tagged (Tagged(..))
+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
+
+instance Serialize Whirlpool where
+ get = liftM Digest (getByteString digestSize)
+ put (Digest d) = putByteString d
+
+#endif
+
+data Ctx = Ctx !ByteString
+data Whirlpool = Digest !ByteString
+ 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))
+
+ peek ptr = create sizeCtx (\bptr -> memcpy bptr (castPtr ptr) (fromIntegral sizeCtx)) >>= return . Ctx
+
+foreign import ccall unsafe "whirlpool.h NESSIEinit"
+ c_whirlpool_init :: Ptr Ctx -> IO ()
+
+foreign import ccall "whirlpool.h NESSIEadd"
+ c_whirlpool_update :: CString -> Word32 -> Ptr Ctx -> IO ()
+
+foreign import ccall unsafe "whirlpool.h NESSIEfinalize"
+ 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)
+
+updateInternalIO :: Ptr Ctx -> ByteString -> IO ()
+updateInternalIO ptr d =
+ unsafeUseAsCStringLen d (\(cs, len) -> c_whirlpool_update cs (8 * fromIntegral len) ptr)
+
+finalizeInternalIO :: Ptr Ctx -> IO ByteString
+finalizeInternalIO ptr =
+ allocaBytes digestSize (\cs -> c_whirlpool_finalize ptr cs >> B.packCStringLen (cs, digestSize))
+
+{-# NOINLINE init #-}
+-- | init a context
+init :: Ctx
+init = unsafePerformIO $ allocInternal $ \ptr -> do (c_whirlpool_init ptr >> peek ptr)
+
+{-# 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
+
+{-# NOINLINE finalize #-}
+-- | finalize the context into a digest bytestring
+finalize :: Ctx -> ByteString
+finalize ctx = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do finalizeInternalIO ptr
+
+{-# 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
+
+{-# 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
Oops, something went wrong.

0 comments on commit d4c217a

Please sign in to comment.