Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

125 lines (99 sloc) 3.992 kb
{-# 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 whirlpool_init"
c_whirlpool_init :: Ptr Ctx -> IO ()
foreign import ccall "whirlpool.h whirlpool_add"
c_whirlpool_update :: CString -> Word32 -> Ptr Ctx -> 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)
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
Jump to Line
Something went wrong with that request. Please try again.