-- |
-- 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
    , hashPrefixWith
    -- * Hash methods
    , hashInit
    , hashUpdates
    , hashUpdate
    , hashFinalize
    , hashFinalizePrefix
    , hashBlockSize
    , hashDigestSize
    , hash
    , hashPrefix
    , 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, plusPtr)
import           Crypto.Internal.ByteArray (ByteArrayAccess)
import qualified Crypto.Internal.ByteArray as B
import qualified Data.ByteString.Lazy as L
import           Data.Word (Word8)
import           Data.Int (Int32)

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

-- | Hash the first N bytes of a bytestring, with code path independent from N.
hashPrefix :: (ByteArrayAccess ba, HashAlgorithmPrefix a) => ba -> Int -> Digest a
hashPrefix :: forall ba a.
(ByteArrayAccess ba, HashAlgorithmPrefix a) =>
ba -> Int -> Digest a
hashPrefix = forall a ba.
(HashAlgorithmPrefix a, ByteArrayAccess ba) =>
Context a -> ba -> Int -> Digest a
hashFinalizePrefix forall a. HashAlgorithm a => Context a
hashInit

-- | Hash a lazy bytestring into a digest.
hashlazy :: HashAlgorithm a => L.ByteString -> Digest a
hashlazy :: forall a. HashAlgorithm a => ByteString -> Digest a
hashlazy ByteString
lbs = forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize forall a b. (a -> b) -> a -> b
$ forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
hashUpdates 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 :: forall a. HashAlgorithm a => Context a
hashInit = forall a. Bytes -> Context a
Context forall a b. (a -> b) -> a -> b
$ forall a p. ByteArray a => Int -> (Ptr p -> IO ()) -> a
B.allocAndFreeze (forall a. HashAlgorithm a => a -> Int
hashInternalContextSize (forall a. HasCallStack => a
undefined :: a)) forall a b. (a -> b) -> a -> b
$ \(Ptr (Context a)
ptr :: Ptr (Context a)) ->
    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 :: forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate Context a
ctx ba
b
    | forall a. ByteArrayAccess a => a -> Bool
B.null ba
b  = Context a
ctx
    | Bool
otherwise = 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 :: forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
hashUpdates Context a
c [ba]
l
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ba]
ls   = Context a
c
    | Bool
otherwise = forall a. Bytes -> Context a
Context forall a b. (a -> b) -> a -> b
$ forall bs1 bs2 p.
(ByteArrayAccess bs1, ByteArray bs2) =>
bs1 -> (Ptr p -> IO ()) -> bs2
B.copyAndFreeze Context a
c forall a b. (a -> b) -> a -> b
$ \(Ptr (Context a)
ctx :: Ptr (Context a)) ->
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ba
b -> forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
B.withByteArray ba
b (forall {a}.
HashAlgorithm a =>
Ptr (Context a) -> Int -> Ptr Word8 -> IO ()
processBlocks Ptr (Context a)
ctx (forall ba. ByteArrayAccess ba => ba -> Int
B.length ba
b))) [ba]
ls
  where
    ls :: [ba]
ls = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ByteArrayAccess a => a -> Bool
B.null) [ba]
l
    -- process the data in 2GB chunks to fit in uint32_t and Int on 32 bit systems
    processBlocks :: Ptr (Context a) -> Int -> Ptr Word8 -> IO ()
processBlocks Ptr (Context a)
ctx Int
bytesLeft Ptr Word8
dataPtr
        | Int
bytesLeft forall a. Eq a => a -> a -> Bool
== Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Bool
otherwise = do
            forall a.
HashAlgorithm a =>
Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
hashInternalUpdate Ptr (Context a)
ctx Ptr Word8
dataPtr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
actuallyProcessed)
            Ptr (Context a) -> Int -> Ptr Word8 -> IO ()
processBlocks Ptr (Context a)
ctx (Int
bytesLeft forall a. Num a => a -> a -> a
- Int
actuallyProcessed) (Ptr Word8
dataPtr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
actuallyProcessed)
        where
            actuallyProcessed :: Int
actuallyProcessed = forall a. Ord a => a -> a -> a
min Int
bytesLeft (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int32))

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

-- | Update the context with the first N bytes of a bytestring and return the
-- digest.  The code path is independent from N but much slower than a normal
-- 'hashUpdate'.  The function can be called for the last bytes of a message, in
-- order to exclude a variable padding, without leaking the padding length.  The
-- begining of the message, never impacted by the padding, should preferably go
-- through 'hashUpdate' for better performance.
hashFinalizePrefix :: forall a ba . (HashAlgorithmPrefix a, ByteArrayAccess ba)
                   => Context a
                   -> ba
                   -> Int
                   -> Digest a
hashFinalizePrefix :: forall a ba.
(HashAlgorithmPrefix a, ByteArrayAccess ba) =>
Context a -> ba -> Int -> Digest a
hashFinalizePrefix !Context a
c ba
b Int
len =
    forall a. Block Word8 -> Digest a
Digest forall a b. (a -> b) -> a -> b
$ forall a p. ByteArray a => Int -> (Ptr p -> IO ()) -> a
B.allocAndFreeze (forall a. HashAlgorithm a => a -> Int
hashDigestSize (forall a. HasCallStack => a
undefined :: a)) forall a b. (a -> b) -> a -> b
$ \(Ptr (Digest a)
dig :: Ptr (Digest a)) -> do
        ((!Bytes
_) :: B.Bytes) <- forall bs1 bs2 p.
(ByteArrayAccess bs1, ByteArray bs2) =>
bs1 -> (Ptr p -> IO ()) -> IO bs2
B.copy Context a
c forall a b. (a -> b) -> a -> b
$ \(Ptr (Context a)
ctx :: Ptr (Context a)) ->
            forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
B.withByteArray ba
b forall a b. (a -> b) -> a -> b
$ \Ptr Word8
d ->
                forall a.
HashAlgorithmPrefix a =>
Ptr (Context a)
-> Ptr Word8 -> Word32 -> Word32 -> Ptr (Digest a) -> IO ()
hashInternalFinalizePrefix Ptr (Context a)
ctx Ptr Word8
d (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall ba. ByteArrayAccess ba => ba -> Int
B.length ba
b) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) Ptr (Digest a)
dig
        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 :: forall alg. HashAlgorithm alg => alg -> Context alg
hashInitWith 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 :: forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
hashWith alg
_ = forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash

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

-- | 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 :: forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString = a -> ba -> Maybe (Digest a)
from forall a. HasCallStack => a
undefined
  where
        from :: a -> ba -> Maybe (Digest a)
        from :: a -> ba -> Maybe (Digest a)
from a
alg ba
bs
            | forall ba. ByteArrayAccess ba => ba -> Int
B.length ba
bs forall a. Eq a => a -> a -> Bool
== (forall a. HashAlgorithm a => a -> Int
hashDigestSize a
alg) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Block Word8 -> Digest a
Digest forall a b. (a -> b) -> a -> b
$ forall a. IO a -> a
unsafeDoIO forall a b. (a -> b) -> a -> b
$ ba -> IO (Block Word8)
copyBytes ba
bs
            | Bool
otherwise                           = forall a. Maybe a
Nothing

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