-- |
-- Module      : Crypto.Hash.IO
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
-- Generalized impure cryptographic hash interface
--
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables        #-}
module Crypto.Hash.IO
    ( HashAlgorithm(..)
    , MutableContext
    , hashMutableInit
    , hashMutableInitWith
    , hashMutableUpdate
    , hashMutableFinalize
    , hashMutableReset
    ) where

import           Crypto.Hash.Types
import qualified Crypto.Internal.ByteArray as B
import           Foreign.Ptr

-- | A Mutable hash context
--
-- This type is an instance of 'B.ByteArrayAccess' for debugging purpose.
-- Internal layout is architecture dependent, may contain uninitialized data
-- fragments, and change in future versions.  The bytearray should not be used
-- as input to cryptographic algorithms.
newtype MutableContext a = MutableContext B.Bytes
    deriving (MutableContext a -> Int
(MutableContext a -> Int)
-> (forall p a. MutableContext a -> (Ptr p -> IO a) -> IO a)
-> (forall p. MutableContext a -> Ptr p -> IO ())
-> ByteArrayAccess (MutableContext a)
forall a. MutableContext a -> Int
forall p. MutableContext a -> Ptr p -> IO ()
forall ba.
(ba -> Int)
-> (forall p a. ba -> (Ptr p -> IO a) -> IO a)
-> (forall p. ba -> Ptr p -> IO ())
-> ByteArrayAccess ba
forall a p. MutableContext a -> Ptr p -> IO ()
forall p a. MutableContext a -> (Ptr p -> IO a) -> IO a
forall a p a. MutableContext a -> (Ptr p -> IO a) -> IO a
$clength :: forall a. MutableContext a -> Int
length :: MutableContext a -> Int
$cwithByteArray :: forall a p a. MutableContext a -> (Ptr p -> IO a) -> IO a
withByteArray :: forall p a. MutableContext a -> (Ptr p -> IO a) -> IO a
$ccopyByteArrayToPtr :: forall a p. MutableContext a -> Ptr p -> IO ()
copyByteArrayToPtr :: forall p. MutableContext a -> Ptr p -> IO ()
B.ByteArrayAccess)

-- | Create a new mutable hash context.
--
-- the algorithm used is automatically determined from the return constraint.
hashMutableInit :: HashAlgorithm alg => IO (MutableContext alg)
hashMutableInit :: forall alg. HashAlgorithm alg => IO (MutableContext alg)
hashMutableInit = alg
-> (Int -> (Ptr (Context alg) -> IO ()) -> IO Bytes)
-> IO (MutableContext alg)
forall a.
HashAlgorithm a =>
a
-> (Int -> (Ptr (Context a) -> IO ()) -> IO Bytes)
-> IO (MutableContext a)
doInit alg
forall a. HasCallStack => a
undefined Int -> (Ptr (Context alg) -> IO ()) -> IO Bytes
forall ba p. ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba
B.alloc
  where
        doInit :: HashAlgorithm a => a -> (Int -> (Ptr (Context a) -> IO ()) -> IO B.Bytes) -> IO (MutableContext a)
        doInit :: forall a.
HashAlgorithm a =>
a
-> (Int -> (Ptr (Context a) -> IO ()) -> IO Bytes)
-> IO (MutableContext a)
doInit a
alg Int -> (Ptr (Context a) -> IO ()) -> IO Bytes
alloc = Bytes -> MutableContext a
forall a. Bytes -> MutableContext a
MutableContext (Bytes -> MutableContext a) -> IO Bytes -> IO (MutableContext a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> (Ptr (Context a) -> IO ()) -> IO Bytes
alloc (a -> Int
forall a. HashAlgorithm a => a -> Int
hashInternalContextSize a
alg) Ptr (Context a) -> IO ()
forall a. HashAlgorithm a => Ptr (Context a) -> IO ()
hashInternalInit

-- | Create a new mutable hash context.
--
-- The algorithm is explicitely passed as parameter
hashMutableInitWith :: HashAlgorithm alg => alg -> IO (MutableContext alg)
hashMutableInitWith :: forall alg. HashAlgorithm alg => alg -> IO (MutableContext alg)
hashMutableInitWith alg
_ = IO (MutableContext alg)
forall alg. HashAlgorithm alg => IO (MutableContext alg)
hashMutableInit

-- | Update a mutable hash context in place
hashMutableUpdate :: (B.ByteArrayAccess ba, HashAlgorithm a) => MutableContext a -> ba -> IO ()
hashMutableUpdate :: forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
MutableContext a -> ba -> IO ()
hashMutableUpdate MutableContext a
mc ba
dat = MutableContext a -> ((Ptr (Context a) -> IO ()) -> IO ()) -> IO ()
forall a.
HashAlgorithm a =>
MutableContext a -> ((Ptr (Context a) -> IO ()) -> IO ()) -> IO ()
doUpdate MutableContext a
mc (MutableContext a -> (Ptr (Context a) -> IO ()) -> IO ()
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. MutableContext a -> (Ptr p -> IO a) -> IO a
B.withByteArray MutableContext a
mc)
  where doUpdate :: HashAlgorithm a => MutableContext a -> ((Ptr (Context a) -> IO ()) -> IO ()) -> IO ()
        doUpdate :: forall a.
HashAlgorithm a =>
MutableContext a -> ((Ptr (Context a) -> IO ()) -> IO ()) -> IO ()
doUpdate MutableContext a
_ (Ptr (Context a) -> IO ()) -> IO ()
withCtx =
            (Ptr (Context a) -> IO ()) -> IO ()
withCtx             ((Ptr (Context a) -> IO ()) -> IO ())
-> (Ptr (Context a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr (Context a)
ctx ->
            ba -> (Ptr Word8 -> IO ()) -> IO ()
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. ba -> (Ptr p -> IO a) -> IO a
B.withByteArray ba
dat ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
d   ->
                Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
forall a.
HashAlgorithm a =>
Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
hashInternalUpdate Ptr (Context a)
ctx Ptr Word8
d (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ba -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length ba
dat)

-- | Finalize a mutable hash context and compute a digest
hashMutableFinalize :: forall a . HashAlgorithm a => MutableContext a -> IO (Digest a)
hashMutableFinalize :: forall a. HashAlgorithm a => MutableContext a -> IO (Digest a)
hashMutableFinalize MutableContext a
mc = do
    Block Word8
b <- Int -> (Ptr (Digest a) -> IO ()) -> IO (Block Word8)
forall ba p. ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba
B.alloc (a -> Int
forall a. HashAlgorithm a => a -> Int
hashDigestSize (a
forall a. HasCallStack => a
undefined :: a)) ((Ptr (Digest a) -> IO ()) -> IO (Block Word8))
-> (Ptr (Digest a) -> IO ()) -> IO (Block Word8)
forall a b. (a -> b) -> a -> b
$ \Ptr (Digest a)
dig -> MutableContext a -> (Ptr (Context a) -> IO ()) -> IO ()
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. MutableContext a -> (Ptr p -> IO a) -> IO a
B.withByteArray MutableContext a
mc ((Ptr (Context a) -> IO ()) -> IO ())
-> (Ptr (Context a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr (Context a)
ctx :: Ptr (Context a)) -> Ptr (Context a) -> Ptr (Digest a) -> IO ()
forall a.
HashAlgorithm a =>
Ptr (Context a) -> Ptr (Digest a) -> IO ()
hashInternalFinalize Ptr (Context a)
ctx Ptr (Digest a)
dig
    Digest a -> IO (Digest a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Digest a -> IO (Digest a)) -> Digest a -> IO (Digest a)
forall a b. (a -> b) -> a -> b
$ Block Word8 -> Digest a
forall a. Block Word8 -> Digest a
Digest Block Word8
b

-- | Reset the mutable context to the initial state of the hash
hashMutableReset :: HashAlgorithm a => MutableContext a -> IO ()
hashMutableReset :: forall a. HashAlgorithm a => MutableContext a -> IO ()
hashMutableReset MutableContext a
mc = MutableContext a -> ((Ptr (Context a) -> IO ()) -> IO ()) -> IO ()
forall a.
HashAlgorithm a =>
MutableContext a -> ((Ptr (Context a) -> IO ()) -> IO ()) -> IO ()
doReset MutableContext a
mc (MutableContext a -> (Ptr (Context a) -> IO ()) -> IO ()
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. MutableContext a -> (Ptr p -> IO a) -> IO a
B.withByteArray MutableContext a
mc)
  where
    doReset :: HashAlgorithm a => MutableContext a -> ((Ptr (Context a) -> IO ()) -> IO ()) -> IO ()
    doReset :: forall a.
HashAlgorithm a =>
MutableContext a -> ((Ptr (Context a) -> IO ()) -> IO ()) -> IO ()
doReset MutableContext a
_ (Ptr (Context a) -> IO ()) -> IO ()
withCtx = (Ptr (Context a) -> IO ()) -> IO ()
withCtx Ptr (Context a) -> IO ()
forall a. HashAlgorithm a => Ptr (Context a) -> IO ()
hashInternalInit