{-# LANGUAGE ForeignFunctionInterface #-}
module Crypto.Hash.SHA3
{-# WARNING "this implementation is not SHA3 as standardized, but SHA3 as submitted before standardisation (Keccak)" #-}
( Ctx(..)
, init
, 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 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 sizeCtx #-}
sizeCtx :: Int
sizeCtx :: Int
sizeCtx = Int
360
peekHashlen :: Ptr Ctx -> IO Int
peekHashlen :: Ptr Ctx -> IO Int
peekHashlen 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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Word32
v -> Int -> IO Int
forall a. a -> IO a
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 :: forall a. ByteString -> (Ptr Word8 -> IO a) -> IO a
withByteStringPtr ByteString
b 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 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 (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 = (Int -> IO ()) -> [Int] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> IO ()
peekAndPoke [Int
0..(Int
45Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)]
where peekAndPoke :: Int -> IO ()
peekAndPoke 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 a b. IO a -> (a -> IO b) -> IO b
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 ByteString
ctxB) Ptr Ctx -> IO ()
f = ByteString -> Ctx
Ctx (ByteString -> Ctx) -> IO ByteString -> IO Ctx
forall a b. (a -> b) -> IO a -> IO b
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
$ \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
$ \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 :: forall a. Ctx -> (Ptr Ctx -> IO a) -> IO a
withCtxThrow (Ctx ByteString
ctxB) 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
$ \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
$ \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 Ptr Ctx -> IO ()
f = ByteString -> Ctx
Ctx (ByteString -> Ctx) -> IO ByteString -> IO Ctx
forall a b. (a -> b) -> IO a -> IO b
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 :: forall a. (Ptr Ctx -> IO a) -> IO a
withCtxNewThrow 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 "sha3.h cryptohash_sha3_init"
c_sha3_init :: Ptr Ctx -> Word32 -> IO ()
foreign import ccall "sha3.h cryptohash_sha3_update"
c_sha3_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO ()
foreign import ccall unsafe "sha3.h cryptohash_sha3_finalize"
c_sha3_finalize :: Ptr Ctx -> Ptr Word8 -> IO ()
updateInternalIO :: Ptr Ctx -> ByteString -> IO ()
updateInternalIO :: Ptr Ctx -> ByteString -> IO ()
updateInternalIO Ptr Ctx
ptr ByteString
d =
ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
d (\(Ptr CChar
cs, Int
len) -> Ptr Ctx -> Ptr Word8 -> Word32 -> IO ()
c_sha3_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 Ctx
ptr =
Ptr Ctx -> IO Int
peekHashlen Ptr Ctx
ptr IO Int -> (Int -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
digestSize -> Int -> (Ptr Word8 -> IO ()) -> IO ByteString
create Int
digestSize (Ptr Ctx -> Ptr Word8 -> IO ()
c_sha3_finalize Ptr Ctx
ptr)
{-# NOINLINE init #-}
init :: Int -> Ctx
init :: Int -> Ctx
init 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 Ctx
ptr -> Ptr Ctx -> Word32 -> IO ()
c_sha3_init Ptr Ctx
ptr (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hashlen)
{-# NOINLINE update #-}
update :: Ctx -> ByteString -> Ctx
update :: Ctx -> ByteString -> Ctx
update Ctx
ctx 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 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 = 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 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 :: Ctx -> ByteString
finalize :: Ctx -> ByteString
finalize 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 :: Int -> ByteString -> ByteString
hash :: Int -> ByteString -> ByteString
hash Int
hashlen 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 Ctx
ptr -> do
Ptr Ctx -> Word32 -> IO ()
c_sha3_init Ptr Ctx
ptr (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hashlen) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr Ctx -> IO ByteString
finalizeInternalIO Ptr Ctx
ptr
{-# NOINLINE hashlazy #-}
hashlazy :: Int -> L.ByteString -> ByteString
hashlazy :: Int -> ByteString -> ByteString
hashlazy Int
hashlen 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 Ctx
ptr -> do
Ptr Ctx -> Word32 -> IO ()
c_sha3_init Ptr Ctx
ptr (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hashlen) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr Ctx -> IO ByteString
finalizeInternalIO Ptr Ctx
ptr