{-# LANGUAGE ForeignFunctionInterface #-}
module Crypto.Hash.SHA512
( Ctx(..)
, init
, init_t
, update
, updates
, finalize
, hash
, hashlazy
) 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 qualified Data.ByteString as B
import Data.ByteString (ByteString)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Data.ByteString.Internal (create, toForeignPtr)
import Data.Word
import Crypto.Hash.Internal (unsafeDoIO)
newtype Ctx = Ctx ByteString
{-# INLINE digestSize #-}
digestSize :: Int
digestSize :: Int
digestSize = Int
64
{-# INLINE sizeCtx #-}
sizeCtx :: Int
sizeCtx :: Int
sizeCtx = Int
256
{-# RULES "digestSize" B.length (finalize init) = digestSize #-}
{-# RULES "hash" forall b. finalize (update init b) = hash b #-}
{-# RULES "hash.list1" forall b. finalize (updates init [b]) = hash b #-}
{-# RULES "hashmany" forall b. finalize (foldl update init b) = hashlazy (L.fromChunks b) #-}
{-# RULES "hashlazy" forall b. finalize (foldl update init $ L.toChunks b) = hashlazy b #-}
{-# INLINE withByteStringPtr #-}
withByteStringPtr :: ByteString -> (Ptr Word8 -> IO a) -> IO a
withByteStringPtr :: forall a. ByteString -> (Ptr Word8 -> IO a) -> IO a
withByteStringPtr ByteString
b Ptr Word8 -> IO a
f =
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> Ptr Word8 -> IO a
f (Ptr Word8
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off)
where (ForeignPtr Word8
fptr, Int
off, Int
_) = ByteString -> (ForeignPtr Word8, Int, Int)
toForeignPtr ByteString
b
{-# INLINE memcopy64 #-}
memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO ()
memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO ()
memcopy64 Ptr Word64
dst Ptr Word64
src = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> IO ()
peekAndPoke [Int
0..(Int
32forall a. Num a => a -> a -> a
-Int
1)]
where peekAndPoke :: Int -> IO ()
peekAndPoke Int
i = forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word64
src Int
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 ByteString
ctxB) Ptr Ctx -> IO ()
f = ByteString -> Ctx
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 forall a b. (a -> b) -> a -> b
$ \Ptr Word8
dstPtr ->
forall a. ByteString -> (Ptr Word8 -> IO a) -> IO a
withByteStringPtr ByteString
ctxB forall a b. (a -> b) -> a -> b
$ \Ptr Word8
srcPtr -> do
Ptr Word64 -> Ptr Word64 -> IO ()
memcopy64 (forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
dstPtr) (forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
srcPtr)
Ptr Ctx -> IO ()
f (forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
dstPtr)
withCtxThrow :: Ctx -> (Ptr Ctx -> IO a) -> IO a
withCtxThrow :: forall a. Ctx -> (Ptr Ctx -> IO a) -> IO a
withCtxThrow (Ctx ByteString
ctxB) Ptr Ctx -> IO a
f =
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeCtx forall a b. (a -> b) -> a -> b
$ \Ptr Any
dstPtr ->
forall a. ByteString -> (Ptr Word8 -> IO a) -> IO a
withByteStringPtr ByteString
ctxB forall a b. (a -> b) -> a -> b
$ \Ptr Word8
srcPtr -> do
Ptr Word64 -> Ptr Word64 -> IO ()
memcopy64 (forall a b. Ptr a -> Ptr b
castPtr Ptr Any
dstPtr) (forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
srcPtr)
Ptr Ctx -> IO a
f (forall a b. Ptr a -> Ptr b
castPtr Ptr Any
dstPtr)
withCtxNew :: (Ptr Ctx -> IO ()) -> IO Ctx
withCtxNew :: (Ptr Ctx -> IO ()) -> IO Ctx
withCtxNew Ptr Ctx -> IO ()
f = ByteString -> Ctx
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Ptr a -> Ptr b
castPtr)
withCtxNewThrow :: (Ptr Ctx -> IO a) -> IO a
withCtxNewThrow :: forall a. (Ptr Ctx -> IO a) -> IO a
withCtxNewThrow Ptr Ctx -> IO a
f = forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
sizeCtx (Ptr Ctx -> IO a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Ptr a -> Ptr b
castPtr)
foreign import ccall unsafe "sha512.h cryptohash_sha512_init"
c_sha512_init :: Ptr Ctx -> IO ()
foreign import ccall "sha512.h cryptohash_sha512_update"
c_sha512_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO ()
foreign import ccall unsafe "sha512.h cryptohash_sha512_finalize"
c_sha512_finalize :: Ptr Ctx -> Ptr Word8 -> IO ()
foreign import ccall unsafe "sha512.h cryptohash_sha512_init_t"
c_sha512_init_t :: Ptr Ctx -> Int -> IO ()
{-# NOINLINE init_t #-}
init_t :: Int -> Ctx
init_t :: Int -> Ctx
init_t Int
t = forall a. IO a -> a
unsafeDoIO forall a b. (a -> b) -> a -> b
$ (Ptr Ctx -> IO ()) -> IO Ctx
withCtxNew forall a b. (a -> b) -> a -> b
$ \Ptr Ctx
ptr -> Ptr Ctx -> Int -> IO ()
c_sha512_init_t Ptr Ctx
ptr Int
t
updateInternalIO :: Ptr Ctx -> ByteString -> IO ()
updateInternalIO :: Ptr Ctx -> ByteString -> IO ()
updateInternalIO Ptr Ctx
ptr ByteString
d =
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
d (\(Ptr CChar
cs, Int
len) -> Ptr Ctx -> Ptr Word8 -> Word32 -> IO ()
c_sha512_update Ptr Ctx
ptr (forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
cs) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len))
finalizeInternalIO :: Ptr Ctx -> IO ByteString
finalizeInternalIO :: Ptr Ctx -> IO ByteString
finalizeInternalIO Ptr Ctx
ptr = Int -> (Ptr Word8 -> IO ()) -> IO ByteString
create Int
digestSize (Ptr Ctx -> Ptr Word8 -> IO ()
c_sha512_finalize Ptr Ctx
ptr)
{-# NOINLINE init #-}
init :: Ctx
init :: Ctx
init = forall a. IO a -> a
unsafeDoIO forall a b. (a -> b) -> a -> b
$ (Ptr Ctx -> IO ()) -> IO Ctx
withCtxNew forall a b. (a -> b) -> a -> b
$ Ptr Ctx -> IO ()
c_sha512_init
{-# NOINLINE update #-}
update :: Ctx -> ByteString -> Ctx
update :: Ctx -> ByteString -> Ctx
update Ctx
ctx ByteString
d = forall a. IO a -> a
unsafeDoIO forall a b. (a -> b) -> a -> b
$ Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx
withCtxCopy Ctx
ctx forall a b. (a -> b) -> a -> b
$ \Ptr Ctx
ptr -> Ptr Ctx -> ByteString -> IO ()
updateInternalIO Ptr Ctx
ptr ByteString
d
{-# NOINLINE updates #-}
updates :: Ctx -> [ByteString] -> Ctx
updates :: Ctx -> [ByteString] -> Ctx
updates Ctx
ctx [ByteString]
d = forall a. IO a -> a
unsafeDoIO forall a b. (a -> b) -> a -> b
$ Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx
withCtxCopy Ctx
ctx forall a b. (a -> b) -> a -> b
$ \Ptr Ctx
ptr -> 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 :: Ctx -> ByteString
finalize :: Ctx -> ByteString
finalize Ctx
ctx = forall a. IO a -> a
unsafeDoIO forall a b. (a -> b) -> a -> b
$ forall a. Ctx -> (Ptr Ctx -> IO a) -> IO a
withCtxThrow Ctx
ctx Ptr Ctx -> IO ByteString
finalizeInternalIO
{-# NOINLINE hash #-}
hash :: ByteString -> ByteString
hash :: ByteString -> ByteString
hash ByteString
d = forall a. IO a -> a
unsafeDoIO forall a b. (a -> b) -> a -> b
$ forall a. (Ptr Ctx -> IO a) -> IO a
withCtxNewThrow forall a b. (a -> b) -> a -> b
$ \Ptr Ctx
ptr -> do
Ptr Ctx -> IO ()
c_sha512_init Ptr Ctx
ptr forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr Ctx -> ByteString -> IO ()
updateInternalIO Ptr Ctx
ptr ByteString
d forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr Ctx -> IO ByteString
finalizeInternalIO Ptr Ctx
ptr
{-# NOINLINE hashlazy #-}
hashlazy :: L.ByteString -> ByteString
hashlazy :: ByteString -> ByteString
hashlazy ByteString
l = forall a. IO a -> a
unsafeDoIO forall a b. (a -> b) -> a -> b
$ forall a. (Ptr Ctx -> IO a) -> IO a
withCtxNewThrow forall a b. (a -> b) -> a -> b
$ \Ptr Ctx
ptr -> do
Ptr Ctx -> IO ()
c_sha512_init Ptr Ctx
ptr forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr Ctx -> IO ByteString
finalizeInternalIO Ptr Ctx
ptr