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

-- | 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 (Context a) -> Int -> Ptr Word8 -> IO ()
forall a.
HashAlgorithm a =>
Ptr (Context a) -> Int -> Ptr Word8 -> IO ()
processBlocks Ptr (Context a)
ctx (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
    -- 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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Bool
otherwise = do
            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
dataPtr (Int -> Word32
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
actuallyProcessed) (Ptr Word8
dataPtr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
actuallyProcessed)
        where
            actuallyProcessed :: Int
actuallyProcessed = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
bytesLeft (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32
forall a. Bounded a => a
maxBound :: Int32))

-- | 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 ()

-- | 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 :: Context a -> ba -> Int -> Digest a
hashFinalizePrefix !Context a
c ba
b Int
len =
    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)) ->
            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 -> Word32 -> Ptr (Digest a) -> IO ()
forall a.
HashAlgorithmPrefix a =>
Ptr (Context a)
-> Ptr Word8 -> Word32 -> Word32 -> Ptr (Digest a) -> IO ()
hashInternalFinalizePrefix 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) (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) 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

-- | Run the 'hashPrefix' function but takes an explicit hash algorithm parameter
hashPrefixWith :: (ByteArrayAccess ba, HashAlgorithmPrefix alg) => alg -> ba -> Int -> Digest alg
hashPrefixWith :: alg -> ba -> Int -> Digest alg
hashPrefixWith alg
_ = ba -> Int -> Digest 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 :: 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)