{-# LANGUAGE ForeignFunctionInterface #-}

-- |
-- Module      : Crypto.Hash.Skein512
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
-- A module containing Skein512 bindings
--
module Crypto.Hash.Skein512
    ( Ctx(..)

    -- * Incremental hashing Functions
    , init     -- :: Int -> Ctx
    , update   -- :: Ctx -> ByteString -> Ctx
    , updates  -- :: 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)
import Data.Word
import Crypto.Hash.Internal (unsafeDoIO)

-- | Skein512 Context
newtype Ctx = Ctx ByteString

{-# INLINE sizeCtx #-}
sizeCtx :: Int
sizeCtx :: Int
sizeCtx = 160

{- return the number of bytes of output for the digest -}
peekHashlen :: Ptr Ctx -> IO Int
peekHashlen :: Ptr Ctx -> IO Int
peekHashlen ptr :: Ptr Ctx
ptr = Ptr Word32 -> IO Word32
forall a. Storable a => Ptr a -> IO a
peek Ptr Word32
iptr IO Word32 -> (Word32 -> IO Int) -> IO Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \v :: Word32
v -> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$! Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
v
    where iptr :: Ptr Word32
          iptr :: Ptr Word32
iptr = Ptr Ctx -> Ptr Word32
forall a b. Ptr a -> Ptr b
castPtr Ptr Ctx
ptr

{-# RULES "hash" forall b i. finalize (update (init i) b) = hash i b #-}
{-# RULES "hash.list1" forall b i. finalize (updates (init i) [b]) = hash i b #-}
{-# RULES "hashmany" forall b i. finalize (foldl update (init i) b) = hashlazy i (L.fromChunks b) #-}
{-# RULES "hashlazy" forall b i. finalize (foldl update (init i) $ L.toChunks b) = hashlazy i b #-}

{-# INLINE withByteStringPtr #-}
withByteStringPtr :: ByteString -> (Ptr Word8 -> IO a) -> IO a
withByteStringPtr :: ByteString -> (Ptr Word8 -> IO a) -> IO a
withByteStringPtr b :: ByteString
b f :: Ptr Word8 -> IO a
f =
    ForeignPtr Word8 -> (Ptr Word8 -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr ((Ptr Word8 -> IO a) -> IO a) -> (Ptr Word8 -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr Word8
ptr -> Ptr Word8 -> IO a
f (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off)
    where (fptr :: ForeignPtr Word8
fptr, off :: Int
off, _) = ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr ByteString
b

{-# INLINE memcopy64 #-}
memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO ()
memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO ()
memcopy64 dst :: Ptr Word64
dst src :: Ptr Word64
src = (Int -> IO ()) -> [Int] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> IO ()
peekAndPoke [0..(20Int -> Int -> Int
forall a. Num a => a -> a -> a
-1)]
    where peekAndPoke :: Int -> IO ()
peekAndPoke i :: Int
i = Ptr Word64 -> Int -> IO Word64
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word64
src Int
i IO Word64 -> (Word64 -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr Word64 -> Int -> Word64 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word64
dst Int
i

withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx
withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx
withCtxCopy (Ctx ctxB :: ByteString
ctxB) f :: Ptr Ctx -> IO ()
f = ByteString -> Ctx
Ctx (ByteString -> Ctx) -> IO ByteString -> IO Ctx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO ByteString
createCtx
    where createCtx :: IO ByteString
createCtx = Int -> (Ptr Word8 -> IO ()) -> IO ByteString
create Int
sizeCtx ((Ptr Word8 -> IO ()) -> IO ByteString)
-> (Ptr Word8 -> IO ()) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \dstPtr :: Ptr Word8
dstPtr ->
                      ByteString -> (Ptr Word8 -> IO ()) -> IO ()
forall a. ByteString -> (Ptr Word8 -> IO a) -> IO a
withByteStringPtr ByteString
ctxB ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \srcPtr :: Ptr Word8
srcPtr -> do
                          Ptr Word64 -> Ptr Word64 -> IO ()
memcopy64 (Ptr Word8 -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
dstPtr) (Ptr Word8 -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
srcPtr)
                          Ptr Ctx -> IO ()
f (Ptr Word8 -> Ptr Ctx
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
dstPtr)

withCtxThrow :: Ctx -> (Ptr Ctx -> IO a) -> IO a
withCtxThrow :: Ctx -> (Ptr Ctx -> IO a) -> IO a
withCtxThrow (Ctx ctxB :: ByteString
ctxB) f :: Ptr Ctx -> IO a
f =
    Int -> (Ptr Any -> IO a) -> IO a
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeCtx ((Ptr Any -> IO a) -> IO a) -> (Ptr Any -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \dstPtr :: Ptr Any
dstPtr ->
    ByteString -> (Ptr Word8 -> IO a) -> IO a
forall a. ByteString -> (Ptr Word8 -> IO a) -> IO a
withByteStringPtr ByteString
ctxB ((Ptr Word8 -> IO a) -> IO a) -> (Ptr Word8 -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \srcPtr :: Ptr Word8
srcPtr -> do
        Ptr Word64 -> Ptr Word64 -> IO ()
memcopy64 (Ptr Any -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr Ptr Any
dstPtr) (Ptr Word8 -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
srcPtr)
        Ptr Ctx -> IO a
f (Ptr Any -> Ptr Ctx
forall a b. Ptr a -> Ptr b
castPtr Ptr Any
dstPtr)

withCtxNew :: (Ptr Ctx -> IO ()) -> IO Ctx
withCtxNew :: (Ptr Ctx -> IO ()) -> IO Ctx
withCtxNew f :: Ptr Ctx -> IO ()
f = ByteString -> Ctx
Ctx (ByteString -> Ctx) -> IO ByteString -> IO Ctx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> (Ptr Word8 -> IO ()) -> IO ByteString
create Int
sizeCtx (Ptr Ctx -> IO ()
f (Ptr Ctx -> IO ()) -> (Ptr Word8 -> Ptr Ctx) -> Ptr Word8 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Word8 -> Ptr Ctx
forall a b. Ptr a -> Ptr b
castPtr)

withCtxNewThrow :: (Ptr Ctx -> IO a) -> IO a
withCtxNewThrow :: (Ptr Ctx -> IO a) -> IO a
withCtxNewThrow f :: Ptr Ctx -> IO a
f = Int -> (Ptr Any -> IO a) -> IO a
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeCtx (Ptr Ctx -> IO a
f (Ptr Ctx -> IO a) -> (Ptr Any -> Ptr Ctx) -> Ptr Any -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Any -> Ptr Ctx
forall a b. Ptr a -> Ptr b
castPtr)

foreign import ccall unsafe "skein512.h cryptohash_skein512_init"
    c_skein512_init :: Ptr Ctx -> Word32 -> IO ()

foreign import ccall "skein512.h cryptohash_skein512_update"
    c_skein512_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO ()

foreign import ccall unsafe "skein512.h cryptohash_skein512_finalize"
    c_skein512_finalize :: Ptr Ctx -> Ptr Word8 -> IO ()

updateInternalIO :: Ptr Ctx -> ByteString -> IO ()
updateInternalIO :: Ptr Ctx -> ByteString -> IO ()
updateInternalIO ptr :: Ptr Ctx
ptr d :: ByteString
d =
    ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
d (\(cs :: Ptr CChar
cs, len :: Int
len) -> Ptr Ctx -> Ptr Word8 -> Word32 -> IO ()
c_skein512_update Ptr Ctx
ptr (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
cs) (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len))

finalizeInternalIO :: Ptr Ctx -> IO ByteString
finalizeInternalIO :: Ptr Ctx -> IO ByteString
finalizeInternalIO ptr :: Ptr Ctx
ptr =
    Ptr Ctx -> IO Int
peekHashlen Ptr Ctx
ptr IO Int -> (Int -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \digestSize :: Int
digestSize -> Int -> (Ptr Word8 -> IO ()) -> IO ByteString
create Int
digestSize (Ptr Ctx -> Ptr Word8 -> IO ()
c_skein512_finalize Ptr Ctx
ptr)

{-# NOINLINE init #-}
-- | init a context
init :: Int -> Ctx
init :: Int -> Ctx
init hashlen :: Int
hashlen = IO Ctx -> Ctx
forall a. IO a -> a
unsafeDoIO (IO Ctx -> Ctx) -> IO Ctx -> Ctx
forall a b. (a -> b) -> a -> b
$ (Ptr Ctx -> IO ()) -> IO Ctx
withCtxNew ((Ptr Ctx -> IO ()) -> IO Ctx) -> (Ptr Ctx -> IO ()) -> IO Ctx
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr Ctx
ptr -> Ptr Ctx -> Word32 -> IO ()
c_skein512_init Ptr Ctx
ptr (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hashlen)

{-# NOINLINE update #-}
-- | update a context with a bytestring
update :: Ctx -> ByteString -> Ctx
update :: Ctx -> ByteString -> Ctx
update ctx :: Ctx
ctx d :: ByteString
d = IO Ctx -> Ctx
forall a. IO a -> a
unsafeDoIO (IO Ctx -> Ctx) -> IO Ctx -> Ctx
forall a b. (a -> b) -> a -> b
$ Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx
withCtxCopy Ctx
ctx ((Ptr Ctx -> IO ()) -> IO Ctx) -> (Ptr Ctx -> IO ()) -> IO Ctx
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr Ctx
ptr -> Ptr Ctx -> ByteString -> IO ()
updateInternalIO Ptr Ctx
ptr ByteString
d

{-# NOINLINE updates #-}
-- | updates a context with multiples bytestring
updates :: Ctx -> [ByteString] -> Ctx
updates :: Ctx -> [ByteString] -> Ctx
updates ctx :: Ctx
ctx d :: [ByteString]
d = IO Ctx -> Ctx
forall a. IO a -> a
unsafeDoIO (IO Ctx -> Ctx) -> IO Ctx -> Ctx
forall a b. (a -> b) -> a -> b
$ Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx
withCtxCopy Ctx
ctx ((Ptr Ctx -> IO ()) -> IO Ctx) -> (Ptr Ctx -> IO ()) -> IO Ctx
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr Ctx
ptr -> (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Ptr Ctx -> ByteString -> IO ()
updateInternalIO Ptr Ctx
ptr) [ByteString]
d

{-# NOINLINE finalize #-}
-- | finalize the context into a digest bytestring
finalize :: Ctx -> ByteString
finalize :: Ctx -> ByteString
finalize ctx :: Ctx
ctx = IO ByteString -> ByteString
forall a. IO a -> a
unsafeDoIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Ctx -> (Ptr Ctx -> IO ByteString) -> IO ByteString
forall a. Ctx -> (Ptr Ctx -> IO a) -> IO a
withCtxThrow Ctx
ctx Ptr Ctx -> IO ByteString
finalizeInternalIO

{-# NOINLINE hash #-}
-- | hash a strict bytestring into a digest bytestring
hash :: Int -> ByteString -> ByteString
hash :: Int -> ByteString -> ByteString
hash hashlen :: Int
hashlen d :: ByteString
d = IO ByteString -> ByteString
forall a. IO a -> a
unsafeDoIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Ptr Ctx -> IO ByteString) -> IO ByteString
forall a. (Ptr Ctx -> IO a) -> IO a
withCtxNewThrow ((Ptr Ctx -> IO ByteString) -> IO ByteString)
-> (Ptr Ctx -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr Ctx
ptr -> do
    Ptr Ctx -> Word32 -> IO ()
c_skein512_init Ptr Ctx
ptr (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hashlen) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr Ctx -> ByteString -> IO ()
updateInternalIO Ptr Ctx
ptr ByteString
d IO () -> IO ByteString -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr Ctx -> IO ByteString
finalizeInternalIO Ptr Ctx
ptr

{-# NOINLINE hashlazy #-}
-- | hash a lazy bytestring into a digest bytestring
hashlazy :: Int -> L.ByteString -> ByteString
hashlazy :: Int -> ByteString -> ByteString
hashlazy hashlen :: Int
hashlen l :: ByteString
l = IO ByteString -> ByteString
forall a. IO a -> a
unsafeDoIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Ptr Ctx -> IO ByteString) -> IO ByteString
forall a. (Ptr Ctx -> IO a) -> IO a
withCtxNewThrow ((Ptr Ctx -> IO ByteString) -> IO ByteString)
-> (Ptr Ctx -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr Ctx
ptr -> do
    Ptr Ctx -> Word32 -> IO ()
c_skein512_init Ptr Ctx
ptr (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hashlen) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Ptr Ctx -> ByteString -> IO ()
updateInternalIO Ptr Ctx
ptr) (ByteString -> [ByteString]
L.toChunks ByteString
l) IO () -> IO ByteString -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr Ctx -> IO ByteString
finalizeInternalIO Ptr Ctx
ptr