{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module: Sel.Hashing.SHA256
-- Description: Legacy SHA-256 hashing
-- Copyright: (C) Hécate Moonlight 2022
-- License: BSD-3-Clause
-- Maintainer: The Haskell Cryptography Group
-- Portability: GHC only
module Sel.Hashing.SHA256
  ( -- ** Usage
    -- $usage
    Hash

    -- ** Hashing a single message
  , hashByteString
  , hashText

    -- ** Hashing a multi-part message
  , Multipart
  , withMultipart
  , updateMultipart

    -- ** Displaying
  , hashToBinary
  , hashToHexText
  , hashToHexByteString
  ) where

import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO (liftIO))
import qualified Data.Base16.Types as Base16
import Data.ByteString (StrictByteString)
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Unsafe as BS
import Data.Kind (Type)
import Data.Text (Text)
import qualified Data.Text.Builder.Linear as Builder
import Data.Text.Display (Display (..))
import qualified Data.Text.Encoding as Text
import Foreign (ForeignPtr, Ptr, Storable)
import qualified Foreign
import Foreign.C (CChar, CSize, CUChar, CULLong)
import LibSodium.Bindings.SHA2
  ( CryptoHashSHA256State
  , cryptoHashSHA256
  , cryptoHashSHA256Bytes
  , cryptoHashSHA256Final
  , cryptoHashSHA256Init
  , cryptoHashSHA256StateBytes
  , cryptoHashSHA256Update
  )
import System.IO.Unsafe (unsafeDupablePerformIO)

import Sel.Internal
import Sel.Internal.Sodium (binaryToHex)

-- $usage
--
-- The SHA-2 family of hashing functions is only provided for interoperability with other applications.
--
-- If you are looking for a generic hash function, do use 'Sel.Hashing'.
--
-- If you are looking to hash passwords or deriving keys from passwords, do use 'Sel.Hashing.Password',
-- as the functions of the SHA-2 family are not suitable for this task.
--
-- Only import this module qualified like this:
--
-- >>> import qualified Sel.Hashing.SHA256 as SHA256

-- | A hashed value from the SHA-256 algorithm.
--
-- @since 0.0.1.0
newtype Hash = Hash (ForeignPtr CUChar)

-- |
--
-- @since 0.0.1.0
instance Eq Hash where
  (Hash ForeignPtr CUChar
h1) == :: Hash -> Hash -> Bool
== (Hash ForeignPtr CUChar
h2) =
    ForeignPtr CUChar -> ForeignPtr CUChar -> CSize -> Bool
foreignPtrEq ForeignPtr CUChar
h1 ForeignPtr CUChar
h2 CSize
cryptoHashSHA256Bytes

-- |
--
-- @since 0.0.1.0
instance Ord Hash where
  compare :: Hash -> Hash -> Ordering
compare (Hash ForeignPtr CUChar
h1) (Hash ForeignPtr CUChar
h2) =
    ForeignPtr CUChar -> ForeignPtr CUChar -> CSize -> Ordering
foreignPtrOrd ForeignPtr CUChar
h1 ForeignPtr CUChar
h2 CSize
cryptoHashSHA256Bytes

-- |
--
-- @since 0.0.1.0
instance Storable Hash where
  sizeOf :: Hash -> Int
  sizeOf :: Hash -> Int
sizeOf Hash
_ = CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
cryptoHashSHA256Bytes

  --  Aligned on the size of 'cryptoHashSHA256Bytes'
  alignment :: Hash -> Int
  alignment :: Hash -> Int
alignment Hash
_ = Int
32

  poke :: Ptr Hash -> Hash -> IO ()
  poke :: Ptr Hash -> Hash -> IO ()
poke Ptr Hash
ptr (Hash ForeignPtr CUChar
hashForeignPtr) =
    ForeignPtr CUChar -> (Ptr CUChar -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
Foreign.withForeignPtr ForeignPtr CUChar
hashForeignPtr ((Ptr CUChar -> IO ()) -> IO ()) -> (Ptr CUChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
hashPtr ->
      Ptr CUChar -> Ptr CUChar -> Int -> IO ()
forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
Foreign.copyArray (Ptr Hash -> Ptr CUChar
forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr Hash
ptr) Ptr CUChar
hashPtr (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
cryptoHashSHA256Bytes)

  peek :: Ptr Hash -> IO Hash
  peek :: Ptr Hash -> IO Hash
peek Ptr Hash
ptr = do
    hashfPtr <- Int -> IO (ForeignPtr CUChar)
forall a. Int -> IO (ForeignPtr a)
Foreign.mallocForeignPtrBytes (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
cryptoHashSHA256Bytes)
    Foreign.withForeignPtr hashfPtr $ \Ptr CUChar
hashPtr ->
      Ptr CUChar -> Ptr CUChar -> Int -> IO ()
forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
Foreign.copyArray Ptr CUChar
hashPtr (Ptr Hash -> Ptr CUChar
forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr Hash
ptr) (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
cryptoHashSHA256Bytes)
    pure $ Hash hashfPtr

-- |
--
-- @since 0.0.1.0
instance Display Hash where
  displayBuilder :: Hash -> Builder
displayBuilder = Text -> Builder
Builder.fromText (Text -> Builder) -> (Hash -> Text) -> Hash -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> Text
hashToHexText

-- |
--
-- @since 0.0.1.0
instance Show Hash where
  show :: Hash -> String
show = ByteString -> String
BS.unpackChars (ByteString -> String) -> (Hash -> ByteString) -> Hash -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> ByteString
hashToHexByteString

-- | Hash a 'StrictByteString' with the SHA-256 algorithm.
--
-- @since 0.0.1.0
hashByteString :: StrictByteString -> Hash
hashByteString :: ByteString -> Hash
hashByteString ByteString
bytestring = IO Hash -> Hash
forall a. IO a -> a
unsafeDupablePerformIO (IO Hash -> Hash) -> IO Hash -> Hash
forall a b. (a -> b) -> a -> b
$
  ByteString -> (CStringLen -> IO Hash) -> IO Hash
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
bytestring ((CStringLen -> IO Hash) -> IO Hash)
-> (CStringLen -> IO Hash) -> IO Hash
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cString, Int
cStringLen) -> do
    hashForeignPtr <- Int -> IO (ForeignPtr CUChar)
forall a. Int -> IO (ForeignPtr a)
Foreign.mallocForeignPtrBytes (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
cryptoHashSHA256Bytes)
    Foreign.withForeignPtr hashForeignPtr $ \Ptr CUChar
hashPtr ->
      IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$
        Ptr CUChar -> Ptr CUChar -> CULLong -> IO CInt
cryptoHashSHA256
          Ptr CUChar
hashPtr
          (Ptr CChar -> Ptr CUChar
forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr CChar
cString :: Ptr CUChar)
          (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @CULLong Int
cStringLen)
    pure $ Hash hashForeignPtr

-- | Hash a UTF8-encoded strict 'Text' with the SHA-256 algorithm.
--
-- @since 0.0.1.0
hashText :: Text -> Hash
hashText :: Text -> Hash
hashText Text
text = ByteString -> Hash
hashByteString (Text -> ByteString
Text.encodeUtf8 Text
text)

-- == Displaying

-- | Convert a 'Hash' to a strict hexadecimal 'Text'.
--
-- @since 0.0.1.0
hashToHexText :: Hash -> Text
hashToHexText :: Hash -> Text
hashToHexText = Base16 Text -> Text
forall a. Base16 a -> a
Base16.extractBase16 (Base16 Text -> Text) -> (Hash -> Base16 Text) -> Hash -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Base16 Text
Base16.encodeBase16 (ByteString -> Base16 Text)
-> (Hash -> ByteString) -> Hash -> Base16 Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> ByteString
hashToBinary

-- | Convert a 'Hash' to a strict, hexadecimal-encoded 'StrictByteString' in constant time.
--
-- @since 0.0.1.0
hashToHexByteString :: Hash -> StrictByteString
hashToHexByteString :: Hash -> ByteString
hashToHexByteString (Hash ForeignPtr CUChar
hashForeignPtr) =
  ForeignPtr CUChar -> CSize -> ByteString
binaryToHex ForeignPtr CUChar
hashForeignPtr CSize
cryptoHashSHA256Bytes

-- | Convert a 'Hash' to a binary 'StrictByteString'.
--
-- @since 0.0.1.0
hashToBinary :: Hash -> StrictByteString
hashToBinary :: Hash -> ByteString
hashToBinary (Hash ForeignPtr CUChar
fPtr) =
  ForeignPtr Word8 -> Int -> Int -> ByteString
BS.fromForeignPtr
    (ForeignPtr CUChar -> ForeignPtr Word8
forall a b. ForeignPtr a -> ForeignPtr b
Foreign.castForeignPtr ForeignPtr CUChar
fPtr)
    Int
0
    (forall a b. (Integral a, Num b) => a -> b
fromIntegral @CSize @Int CSize
cryptoHashSHA256Bytes)

-- ** Hashing a multi-part message

-- | 'Multipart' is a cryptographic context for streaming hashing.
-- This API can be used when a message is too big to fit in memory or when the message is received in portions.
--
-- Use it like this:
--
-- >>> hash <- SHA256.withMultipart $ \multipartState -> do -- we are in MonadIO
-- ...   message1 <- getMessage
-- ...   SHA256.updateMultipart multipartState message1
-- ...   message2 <- getMessage
-- ...   SHA256.updateMultipart multipartState message2
--
-- @since 0.0.1.0
newtype Multipart s = Multipart (Ptr CryptoHashSHA256State)

type role Multipart nominal

-- | Perform streaming hashing with a 'Multipart' cryptographic context.
--
-- Use 'SHA256.updateMultipart' within the continuation.
--
-- The context is safely allocated first, then the continuation is run
-- and then it is deallocated after that.
--
-- @since 0.0.1.0
withMultipart
  :: forall (a :: Type) (m :: Type -> Type)
   . MonadIO m
  => (forall s. Multipart s -> m a)
  -- ^ Continuation that gives you access to a 'Multipart' cryptographic context
  -> m Hash
withMultipart :: forall a (m :: * -> *).
MonadIO m =>
(forall s. Multipart s -> m a) -> m Hash
withMultipart forall s. Multipart s -> m a
actions = do
  CSize -> (Ptr CryptoHashSHA256State -> m Hash) -> m Hash
forall a b (m :: * -> *).
MonadIO m =>
CSize -> (Ptr a -> m b) -> m b
allocateWith CSize
cryptoHashSHA256StateBytes ((Ptr CryptoHashSHA256State -> m Hash) -> m Hash)
-> (Ptr CryptoHashSHA256State -> m Hash) -> m Hash
forall a b. (a -> b) -> a -> b
$ \Ptr CryptoHashSHA256State
statePtr -> do
    m CInt -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m CInt -> m ()) -> m CInt -> m ()
forall a b. (a -> b) -> a -> b
$ IO CInt -> m CInt
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CInt -> m CInt) -> IO CInt -> m CInt
forall a b. (a -> b) -> a -> b
$ Ptr CryptoHashSHA256State -> IO CInt
cryptoHashSHA256Init Ptr CryptoHashSHA256State
statePtr
    let part :: Multipart s
part = Ptr CryptoHashSHA256State -> Multipart s
forall s. Ptr CryptoHashSHA256State -> Multipart s
Multipart Ptr CryptoHashSHA256State
statePtr
    Multipart Any -> m a
forall s. Multipart s -> m a
actions Multipart Any
forall {s}. Multipart s
part
    IO Hash -> m Hash
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Multipart Any -> IO Hash
forall s. Multipart s -> IO Hash
finaliseMultipart Multipart Any
forall {s}. Multipart s
part)

-- | Compute the 'Hash' of all the portions that were fed to the cryptographic context.
--
--  this function is only used within 'withMultipart'
--
--  @since 0.0.1.0
finaliseMultipart :: Multipart s -> IO Hash
finaliseMultipart :: forall s. Multipart s -> IO Hash
finaliseMultipart (Multipart Ptr CryptoHashSHA256State
statePtr) = do
  hashForeignPtr <- Int -> IO (ForeignPtr CUChar)
forall a. Int -> IO (ForeignPtr a)
Foreign.mallocForeignPtrBytes (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
cryptoHashSHA256Bytes)
  Foreign.withForeignPtr hashForeignPtr $ \(Ptr CUChar
hashPtr :: Ptr CUChar) ->
    IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$
      Ptr CryptoHashSHA256State -> Ptr CUChar -> IO CInt
cryptoHashSHA256Final
        Ptr CryptoHashSHA256State
statePtr
        Ptr CUChar
hashPtr
  pure $ Hash hashForeignPtr

-- | Add a message portion to be hashed.
--
-- This function should be used within 'withMultipart'.
--
-- @since 0.0.1.0
updateMultipart :: Multipart s -> StrictByteString -> IO ()
updateMultipart :: forall s. Multipart s -> ByteString -> IO ()
updateMultipart (Multipart Ptr CryptoHashSHA256State
statePtr) ByteString
message = do
  ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
message ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cString, Int
cStringLen) -> do
    let messagePtr :: Ptr CUChar
messagePtr = forall a b. Ptr a -> Ptr b
Foreign.castPtr @CChar @CUChar Ptr CChar
cString
    let messageLen :: CULLong
messageLen = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @CULLong Int
cStringLen
    IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$
      Ptr CryptoHashSHA256State -> Ptr CUChar -> CULLong -> IO CInt
cryptoHashSHA256Update
        Ptr CryptoHashSHA256State
statePtr
        Ptr CUChar
messagePtr
        CULLong
messageLen