-- |
-- Module      : Crypto.Hash
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
-- Generalized cryptographic hash interface, that you can use with cryptographic hash
-- algorithm that belong to the HashAlgorithm type class.
--
-- > import Crypto.Hash
-- >
-- > sha1 :: ByteString -> Digest SHA1
-- > sha1 = hash
-- >
-- > hexSha3_512 :: ByteString -> String
-- > hexSha3_512 bs = show (hash bs :: Digest SHA3_512)
--
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns        #-}
module Crypto.Hash
    (
    -- * Types
      Context
    , Digest
    -- * Functions
    , digestFromByteString
    -- * Hash methods parametrized by algorithm
    , hashInitWith
    , hashWith
    -- * Hash methods
    , hashInit
    , hashUpdates
    , hashUpdate
    , hashFinalize
    , hashBlockSize
    , hashDigestSize
    , hash
    , hashlazy
    -- * Hash algorithms
    , module Crypto.Hash.Algorithms
    ) where

import           Basement.Types.OffsetSize (CountOf (..))
import           Basement.Block (Block, unsafeFreeze)
import           Basement.Block.Mutable (copyFromPtr, new)
import           Crypto.Internal.Compat (unsafeDoIO)
import           Crypto.Hash.Types
import           Crypto.Hash.Algorithms
import           Foreign.Ptr (Ptr)
import           Crypto.Internal.ByteArray (ByteArrayAccess)
import qualified Crypto.Internal.ByteArray as B
import qualified Data.ByteString.Lazy as L
import           Data.Word (Word8)

-- | Hash a strict bytestring into a digest.
hash :: (ByteArrayAccess ba, HashAlgorithm a) => ba -> Digest a
hash :: ba -> Digest a
hash ba
bs = Context a -> Digest a
forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize (Context a -> Digest a) -> Context a -> Digest a
forall a b. (a -> b) -> a -> b
$ Context a -> ba -> Context a
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate Context a
forall a. HashAlgorithm a => Context a
hashInit ba
bs

-- | Hash a lazy bytestring into a digest.
hashlazy :: HashAlgorithm a => L.ByteString -> Digest a
hashlazy :: ByteString -> Digest a
hashlazy ByteString
lbs = Context a -> Digest a
forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize (Context a -> Digest a) -> Context a -> Digest a
forall a b. (a -> b) -> a -> b
$ Context a -> [ByteString] -> Context a
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
hashUpdates Context a
forall a. HashAlgorithm a => Context a
hashInit (ByteString -> [ByteString]
L.toChunks ByteString
lbs)

-- | Initialize a new context for this hash algorithm
hashInit :: forall a . HashAlgorithm a => Context a
hashInit :: Context a
hashInit = Bytes -> Context a
forall a. Bytes -> Context a
Context (Bytes -> Context a) -> Bytes -> Context a
forall a b. (a -> b) -> a -> b
$ Int -> (Ptr (Context a) -> IO ()) -> Bytes
forall a p. ByteArray a => Int -> (Ptr p -> IO ()) -> a
B.allocAndFreeze (a -> Int
forall a. HashAlgorithm a => a -> Int
hashInternalContextSize (a
forall a. HasCallStack => a
undefined :: a)) ((Ptr (Context a) -> IO ()) -> Bytes)
-> (Ptr (Context a) -> IO ()) -> Bytes
forall a b. (a -> b) -> a -> b
$ \(Ptr (Context a)
ptr :: Ptr (Context a)) ->
    Ptr (Context a) -> IO ()
forall a. HashAlgorithm a => Ptr (Context a) -> IO ()
hashInternalInit Ptr (Context a)
ptr

-- | run hashUpdates on one single bytestring and return the updated context.
hashUpdate :: (ByteArrayAccess ba, HashAlgorithm a) => Context a -> ba -> Context a
hashUpdate :: Context a -> ba -> Context a
hashUpdate Context a
ctx ba
b
    | ba -> Bool
forall a. ByteArrayAccess a => a -> Bool
B.null ba
b  = Context a
ctx
    | Bool
otherwise = Context a -> [ba] -> Context a
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
hashUpdates Context a
ctx [ba
b]

-- | Update the context with a list of strict bytestring,
-- and return a new context with the updates.
hashUpdates :: forall a ba . (HashAlgorithm a, ByteArrayAccess ba)
            => Context a
            -> [ba]
            -> Context a
hashUpdates :: Context a -> [ba] -> Context a
hashUpdates Context a
c [ba]
l
    | [ba] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ba]
ls   = Context a
c
    | Bool
otherwise = Bytes -> Context a
forall a. Bytes -> Context a
Context (Bytes -> Context a) -> Bytes -> Context a
forall a b. (a -> b) -> a -> b
$ Context a -> (Ptr (Context a) -> IO ()) -> Bytes
forall bs1 bs2 p.
(ByteArrayAccess bs1, ByteArray bs2) =>
bs1 -> (Ptr p -> IO ()) -> bs2
B.copyAndFreeze Context a
c ((Ptr (Context a) -> IO ()) -> Bytes)
-> (Ptr (Context a) -> IO ()) -> Bytes
forall a b. (a -> b) -> a -> b
$ \(Ptr (Context a)
ctx :: Ptr (Context a)) ->
        (ba -> IO ()) -> [ba] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ba
b -> ba -> (Ptr Word8 -> IO ()) -> IO ()
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
B.withByteArray ba
b ((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
b)) [ba]
ls
  where
    ls :: [ba]
ls = (ba -> Bool) -> [ba] -> [ba]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ba -> Bool) -> ba -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ba -> Bool
forall a. ByteArrayAccess a => a -> Bool
B.null) [ba]
l

-- | Finalize a context and return a digest.
hashFinalize :: forall a . HashAlgorithm a
             => Context a
             -> Digest a
hashFinalize :: Context a -> Digest a
hashFinalize !Context a
c =
    Block Word8 -> Digest a
forall a. Block Word8 -> Digest a
Digest (Block Word8 -> Digest a) -> Block Word8 -> Digest a
forall a b. (a -> b) -> a -> b
$ Int -> (Ptr (Digest a) -> IO ()) -> Block Word8
forall a p. ByteArray a => Int -> (Ptr p -> IO ()) -> a
B.allocAndFreeze (a -> Int
forall a. HashAlgorithm a => a -> Int
hashDigestSize (a
forall a. HasCallStack => a
undefined :: a)) ((Ptr (Digest a) -> IO ()) -> Block Word8)
-> (Ptr (Digest a) -> IO ()) -> Block Word8
forall a b. (a -> b) -> a -> b
$ \(Ptr (Digest a)
dig :: Ptr (Digest a)) -> do
        ((!Bytes
_) :: B.Bytes) <- Context a -> (Ptr (Context a) -> IO ()) -> IO Bytes
forall bs1 bs2 p.
(ByteArrayAccess bs1, ByteArray bs2) =>
bs1 -> (Ptr p -> IO ()) -> IO bs2
B.copy Context a
c ((Ptr (Context a) -> IO ()) -> IO Bytes)
-> (Ptr (Context a) -> IO ()) -> IO Bytes
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
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Initialize a new context for a specified hash algorithm
hashInitWith :: HashAlgorithm alg => alg -> Context alg
hashInitWith :: alg -> Context alg
hashInitWith alg
_ = Context alg
forall a. HashAlgorithm a => Context a
hashInit

-- | Run the 'hash' function but takes an explicit hash algorithm parameter
hashWith :: (ByteArrayAccess ba, HashAlgorithm alg) => alg -> ba -> Digest alg
hashWith :: alg -> ba -> Digest alg
hashWith alg
_ = ba -> Digest alg
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash

-- | Try to transform a bytearray into a Digest of specific algorithm.
--
-- If the digest is not the right size for the algorithm specified, then
-- Nothing is returned.
digestFromByteString :: forall a ba . (HashAlgorithm a, ByteArrayAccess ba) => ba -> Maybe (Digest a)
digestFromByteString :: ba -> Maybe (Digest a)
digestFromByteString = a -> ba -> Maybe (Digest a)
from a
forall a. HasCallStack => a
undefined
  where
        from :: a -> ba -> Maybe (Digest a)
        from :: a -> ba -> Maybe (Digest a)
from a
alg ba
bs
            | ba -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length ba
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (a -> Int
forall a. HashAlgorithm a => a -> Int
hashDigestSize a
alg) = Digest a -> Maybe (Digest a)
forall a. a -> Maybe a
Just (Digest a -> Maybe (Digest a)) -> Digest a -> Maybe (Digest a)
forall a b. (a -> b) -> a -> b
$ Block Word8 -> Digest a
forall a. Block Word8 -> Digest a
Digest (Block Word8 -> Digest a) -> Block Word8 -> Digest a
forall a b. (a -> b) -> a -> b
$ IO (Block Word8) -> Block Word8
forall a. IO a -> a
unsafeDoIO (IO (Block Word8) -> Block Word8)
-> IO (Block Word8) -> Block Word8
forall a b. (a -> b) -> a -> b
$ ba -> IO (Block Word8)
copyBytes ba
bs
            | Bool
otherwise                           = Maybe (Digest a)
forall a. Maybe a
Nothing

        copyBytes :: ba -> IO (Block Word8)
        copyBytes :: ba -> IO (Block Word8)
copyBytes ba
ba = do
            MutableBlock Word8 RealWorld
muArray <- CountOf Word8 -> IO (MutableBlock Word8 (PrimState IO))
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
CountOf ty -> prim (MutableBlock ty (PrimState prim))
new CountOf Word8
forall ty. CountOf ty
count
            ba -> (Ptr Word8 -> IO ()) -> IO ()
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
B.withByteArray ba
ba ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> Ptr Word8
-> MutableBlock Word8 (PrimState IO)
-> Offset Word8
-> CountOf Word8
-> IO ()
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
Ptr ty
-> MutableBlock ty (PrimState prim)
-> Offset ty
-> CountOf ty
-> prim ()
copyFromPtr Ptr Word8
ptr MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
muArray Offset Word8
0 CountOf Word8
forall ty. CountOf ty
count
            MutableBlock Word8 (PrimState IO) -> IO (Block Word8)
forall (prim :: * -> *) ty.
PrimMonad prim =>
MutableBlock ty (PrimState prim) -> prim (Block ty)
unsafeFreeze MutableBlock Word8 RealWorld
MutableBlock Word8 (PrimState IO)
muArray
          where
            count :: CountOf ty
count = Int -> CountOf ty
forall ty. Int -> CountOf ty
CountOf (ba -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length ba
ba)