{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | Implementation of the Blake2b hashing algorithm, with various sizes.
module Cardano.Crypto.Hash.Blake2b (
  Blake2b_224,
  Blake2b_256,
  blake2b_libsodium, -- Used for Hash.Short
)
where

import Control.Monad (unless)
import Control.Monad.Class.MonadST (MonadST)
import Data.Proxy (Proxy (..))
import Foreign.C.Error (errnoToIOError, getErrno)
import Foreign.C.Types (CSize, CULLong)
import Foreign.Ptr (castPtr, nullPtr)
import GHC.IO.Exception (ioException)

import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Unsafe as B

import Cardano.Crypto.Hash.Class (
  Hash,
  HashAlgorithm (..),
  HashSize,
  IncrementalHashAlgorithm (..),
  digest,
  hashAlgorithmName,
  hashFromPackedBytes,
  hashSize,
 )
import Cardano.Crypto.Libsodium.C (
  CRYPTO_BLAKE2B_STATE_SIZE,
  c_crypto_generichash_blake2b,
  c_crypto_generichash_blake2b_final,
  c_crypto_generichash_blake2b_init,
  c_crypto_generichash_blake2b_update,
 )
import Cardano.Crypto.Libsodium.Memory.Internal (unsafeIOToMonadST)
import Cardano.Crypto.PinnedSizedBytes (
  PinnedSizedBytes,
  psbCreateLen,
  psbCreateSizedAligned,
  psbToPackedBytes,
  psbUseAsSizedPtr,
 )

data Blake2b_224
data Blake2b_256

instance HashAlgorithm Blake2b_224 where
  type HashSize Blake2b_224 = 28
  hashAlgorithmName :: forall (proxy :: * -> *). proxy Blake2b_224 -> String
hashAlgorithmName proxy Blake2b_224
_ = String
"blake2b_224"
  digest :: forall (proxy :: * -> *).
proxy Blake2b_224 -> ByteString -> ByteString
digest proxy Blake2b_224
_ = Int -> ByteString -> ByteString
blake2b_libsodium Int
28

instance HashAlgorithm Blake2b_256 where
  type HashSize Blake2b_256 = 32
  hashAlgorithmName :: forall (proxy :: * -> *). proxy Blake2b_256 -> String
hashAlgorithmName proxy Blake2b_256
_ = String
"blake2b_256"
  digest :: forall (proxy :: * -> *).
proxy Blake2b_256 -> ByteString -> ByteString
digest proxy Blake2b_256
_ = Int -> ByteString -> ByteString
blake2b_libsodium Int
32

instance IncrementalHashAlgorithm Blake2b_224 where
  data HashContext Blake2b_224 s
    = Blake2b224Context (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE)
  hashInit :: forall (m :: * -> *).
MonadST m =>
m (HashContext Blake2b_224 (PrimState m))
hashInit = PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
-> HashContext Blake2b_224 (PrimState m)
forall s.
PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
-> HashContext Blake2b_224 s
Blake2b224Context (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
 -> HashContext Blake2b_224 (PrimState m))
-> m (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE)
-> m (HashContext Blake2b_224 (PrimState m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h (m :: * -> *).
(HashAlgorithm h, MonadST m) =>
m (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE)
blake2bInitContext @Blake2b_224
  hashUpdate :: forall (m :: * -> *).
MonadST m =>
HashContext Blake2b_224 (PrimState m) -> ByteString -> m ()
hashUpdate (Blake2b224Context PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
psb) = PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE -> ByteString -> m ()
forall (m :: * -> *).
MonadST m =>
PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE -> ByteString -> m ()
blake2bUpdateContext PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
psb
  hashFinalize :: forall (m :: * -> *) a.
MonadST m =>
HashContext Blake2b_224 (PrimState m) -> m (Hash Blake2b_224 a)
hashFinalize (Blake2b224Context PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
psb) = forall h a (m :: * -> *).
(HashAlgorithm h, MonadST m) =>
PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE -> m (Hash h a)
blake2bFinalizeHash @Blake2b_224 PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
psb

instance IncrementalHashAlgorithm Blake2b_256 where
  data HashContext Blake2b_256 s
    = Blake2b256Context (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE)
  hashInit :: forall (m :: * -> *).
MonadST m =>
m (HashContext Blake2b_256 (PrimState m))
hashInit = PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
-> HashContext Blake2b_256 (PrimState m)
forall s.
PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
-> HashContext Blake2b_256 s
Blake2b256Context (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
 -> HashContext Blake2b_256 (PrimState m))
-> m (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE)
-> m (HashContext Blake2b_256 (PrimState m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall h (m :: * -> *).
(HashAlgorithm h, MonadST m) =>
m (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE)
blake2bInitContext @Blake2b_256
  hashUpdate :: forall (m :: * -> *).
MonadST m =>
HashContext Blake2b_256 (PrimState m) -> ByteString -> m ()
hashUpdate (Blake2b256Context PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
psb) = PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE -> ByteString -> m ()
forall (m :: * -> *).
MonadST m =>
PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE -> ByteString -> m ()
blake2bUpdateContext PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
psb
  hashFinalize :: forall (m :: * -> *) a.
MonadST m =>
HashContext Blake2b_256 (PrimState m) -> m (Hash Blake2b_256 a)
hashFinalize (Blake2b256Context PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
psb) = forall h a (m :: * -> *).
(HashAlgorithm h, MonadST m) =>
PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE -> m (Hash h a)
blake2bFinalizeHash @Blake2b_256 PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
psb

-------------------------------------------------------------------------------
-- Shared helpers for incremental Blake2b hashing
-------------------------------------------------------------------------------

{-# INLINE blake2bInitContext #-}
blake2bInitContext ::
  forall h m.
  (HashAlgorithm h, MonadST m) =>
  m (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE)
blake2bInitContext :: forall h (m :: * -> *).
(HashAlgorithm h, MonadST m) =>
m (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE)
blake2bInitContext = do
  let outLen :: CSize
outLen = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @CSize (Proxy h -> Word
forall h (proxy :: * -> *). HashAlgorithm h => proxy h -> Word
hashSize (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @h))
  -- libsodium source notes (in crypto_generichash.h) that "the state address should be 64-bytes aligned"
  IO (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE)
-> m (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE)
forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST (IO (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE)
 -> m (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE))
-> IO (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE)
-> m (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE)
forall a b. (a -> b) -> a -> b
$
    Int
-> (SizedPtr CRYPTO_BLAKE2B_STATE_SIZE -> IO ())
-> IO (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE)
forall (n :: Nat) (m :: * -> *).
(KnownNat n, MonadST m) =>
Int -> (SizedPtr n -> m ()) -> m (PinnedSizedBytes n)
psbCreateSizedAligned Int
64 ((SizedPtr CRYPTO_BLAKE2B_STATE_SIZE -> IO ())
 -> IO (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE))
-> (SizedPtr CRYPTO_BLAKE2B_STATE_SIZE -> IO ())
-> IO (PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE)
forall a b. (a -> b) -> a -> b
$ \SizedPtr CRYPTO_BLAKE2B_STATE_SIZE
sizedPtr -> do
      Int
res <-
        SizedPtr CRYPTO_BLAKE2B_STATE_SIZE
-> Ptr Any -> CSize -> CSize -> IO Int
forall key.
SizedPtr CRYPTO_BLAKE2B_STATE_SIZE
-> Ptr key -> CSize -> CSize -> IO Int
c_crypto_generichash_blake2b_init
          SizedPtr CRYPTO_BLAKE2B_STATE_SIZE
sizedPtr
          Ptr Any
forall a. Ptr a
nullPtr -- no key
          CSize
0 -- key length
          CSize
outLen
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
res Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Errno
errno <- IO Errno
getErrno
        IOException -> IO ()
forall a. IOException -> IO a
ioException (IOException -> IO ()) -> IOException -> IO ()
forall a b. (a -> b) -> a -> b
$
          String -> Errno -> Maybe Handle -> Maybe String -> IOException
errnoToIOError String
"blake2bInitContext: c_crypto_generichash_blake2b_init" Errno
errno Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing

{-# INLINE blake2bUpdateContext #-}
blake2bUpdateContext ::
  MonadST m => PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE -> B.ByteString -> m ()
blake2bUpdateContext :: forall (m :: * -> *).
MonadST m =>
PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE -> ByteString -> m ()
blake2bUpdateContext PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
psb ByteString
chunk =
  IO () -> m ()
forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
-> (SizedPtr CRYPTO_BLAKE2B_STATE_SIZE -> IO ()) -> IO ()
forall (n :: Nat) r (m :: * -> *).
MonadST m =>
PinnedSizedBytes n -> (SizedPtr n -> m r) -> m r
psbUseAsSizedPtr PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
psb ((SizedPtr CRYPTO_BLAKE2B_STATE_SIZE -> IO ()) -> IO ())
-> (SizedPtr CRYPTO_BLAKE2B_STATE_SIZE -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SizedPtr CRYPTO_BLAKE2B_STATE_SIZE
sizedPtr ->
      ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
chunk ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
inPtr, Int
inLen) -> do
        Int
res <-
          SizedPtr CRYPTO_BLAKE2B_STATE_SIZE
-> Ptr CUChar -> CULLong -> IO Int
c_crypto_generichash_blake2b_update
            SizedPtr CRYPTO_BLAKE2B_STATE_SIZE
sizedPtr
            (Ptr CChar -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
inPtr)
            (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @CULLong Int
inLen)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
res Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Errno
errno <- IO Errno
getErrno
          IOException -> IO ()
forall a. IOException -> IO a
ioException (IOException -> IO ()) -> IOException -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> Errno -> Maybe Handle -> Maybe String -> IOException
errnoToIOError String
"blake2bUpdateContext: c_crypto_generichash_blake2b_update" Errno
errno Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing

{-# INLINE blake2bFinalizeHash #-}
blake2bFinalizeHash ::
  forall h a m.
  (HashAlgorithm h, MonadST m) =>
  PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE ->
  m (Hash h a)
blake2bFinalizeHash :: forall h a (m :: * -> *).
(HashAlgorithm h, MonadST m) =>
PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE -> m (Hash h a)
blake2bFinalizeHash PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
psb = do
  PinnedSizedBytes (HashSize h)
psbHash :: PinnedSizedBytes (HashSize h) <-
    IO (PinnedSizedBytes (HashSize h))
-> m (PinnedSizedBytes (HashSize h))
forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST (IO (PinnedSizedBytes (HashSize h))
 -> m (PinnedSizedBytes (HashSize h)))
-> IO (PinnedSizedBytes (HashSize h))
-> m (PinnedSizedBytes (HashSize h))
forall a b. (a -> b) -> a -> b
$
      PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
-> (SizedPtr CRYPTO_BLAKE2B_STATE_SIZE
    -> IO (PinnedSizedBytes (HashSize h)))
-> IO (PinnedSizedBytes (HashSize h))
forall (n :: Nat) r (m :: * -> *).
MonadST m =>
PinnedSizedBytes n -> (SizedPtr n -> m r) -> m r
psbUseAsSizedPtr PinnedSizedBytes CRYPTO_BLAKE2B_STATE_SIZE
psb ((SizedPtr CRYPTO_BLAKE2B_STATE_SIZE
  -> IO (PinnedSizedBytes (HashSize h)))
 -> IO (PinnedSizedBytes (HashSize h)))
-> (SizedPtr CRYPTO_BLAKE2B_STATE_SIZE
    -> IO (PinnedSizedBytes (HashSize h)))
-> IO (PinnedSizedBytes (HashSize h))
forall a b. (a -> b) -> a -> b
$ \SizedPtr CRYPTO_BLAKE2B_STATE_SIZE
sizedPtr ->
        (Ptr Word8 -> CSize -> IO ()) -> IO (PinnedSizedBytes (HashSize h))
forall (n :: Nat) (m :: * -> *).
(KnownNat n, MonadST m) =>
(Ptr Word8 -> CSize -> m ()) -> m (PinnedSizedBytes n)
psbCreateLen ((Ptr Word8 -> CSize -> IO ())
 -> IO (PinnedSizedBytes (HashSize h)))
-> (Ptr Word8 -> CSize -> IO ())
-> IO (PinnedSizedBytes (HashSize h))
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
outPtr CSize
outLen -> do
          Int
res <-
            SizedPtr CRYPTO_BLAKE2B_STATE_SIZE -> Ptr Word8 -> CSize -> IO Int
forall out.
SizedPtr CRYPTO_BLAKE2B_STATE_SIZE -> Ptr out -> CSize -> IO Int
c_crypto_generichash_blake2b_final
              SizedPtr CRYPTO_BLAKE2B_STATE_SIZE
sizedPtr
              Ptr Word8
outPtr
              CSize
outLen
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
res Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Errno
errno <- IO Errno
getErrno
            IOException -> IO ()
forall a. IOException -> IO a
ioException (IOException -> IO ()) -> IOException -> IO ()
forall a b. (a -> b) -> a -> b
$
              String -> Errno -> Maybe Handle -> Maybe String -> IOException
errnoToIOError String
"blake2bFinalizeHash: c_crypto_generichash_blake2b_final" Errno
errno Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
  Hash h a -> m (Hash h a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hash h a -> m (Hash h a)) -> Hash h a -> m (Hash h a)
forall a b. (a -> b) -> a -> b
$ PackedBytes (HashSize h) -> Hash h a
forall h a. PackedBytes (HashSize h) -> Hash h a
hashFromPackedBytes (PackedBytes (HashSize h) -> Hash h a)
-> PackedBytes (HashSize h) -> Hash h a
forall a b. (a -> b) -> a -> b
$ PinnedSizedBytes (HashSize h) -> PackedBytes (HashSize h)
forall (n :: Nat).
KnownNat n =>
PinnedSizedBytes n -> PackedBytes n
psbToPackedBytes PinnedSizedBytes (HashSize h)
psbHash

-------------------------------------------------------------------------------
-- Single-shot Blake2b
-------------------------------------------------------------------------------

blake2b_libsodium :: Int -> B.ByteString -> B.ByteString
blake2b_libsodium :: Int -> ByteString -> ByteString
blake2b_libsodium Int
size ByteString
input =
  Int -> (Ptr Word8 -> IO ()) -> ByteString
BI.unsafeCreate Int
size ((Ptr Word8 -> IO ()) -> ByteString)
-> (Ptr Word8 -> IO ()) -> ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
outptr ->
    ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.useAsCStringLen ByteString
input ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
inptr, Int
inputlen) -> do
      Int
res <-
        Ptr Any
-> CSize -> Ptr CUChar -> CULLong -> Ptr Any -> CSize -> IO Int
forall out key.
Ptr out
-> CSize -> Ptr CUChar -> CULLong -> Ptr key -> CSize -> IO Int
c_crypto_generichash_blake2b
          (Ptr Word8 -> Ptr Any
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
outptr)
          (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @CSize Int
size)
          (Ptr CChar -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
inptr)
          (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @CULLong Int
inputlen)
          Ptr Any
forall a. Ptr a
nullPtr
          CSize
0 -- we used unkeyed hash
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
res Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Errno
errno <- IO Errno
getErrno
        IOException -> IO ()
forall a. IOException -> IO a
ioException (IOException -> IO ()) -> IOException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Errno -> Maybe Handle -> Maybe String -> IOException
errnoToIOError String
"digest @Blake2b: crypto_generichash_blake2b" Errno
errno Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing