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

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

    -- ** Hash
    Hash
  , hashToBinary
  , hashToHexText
  , hashToHexByteString

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

    -- ** Hashing a multi-parts message
  , Multipart
  , withMultipart
  , updateMultipart
  ) where

import Control.Monad (void)
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.Text (Text)
import Data.Text.Display (Display (..))
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Internal.Builder as Builder
import Foreign (ForeignPtr, Ptr, Storable)
import qualified Foreign
import Foreign.C (CChar, CSize, CUChar, CULLong)
import LibSodium.Bindings.SHA2
  ( CryptoHashSHA512State
  , cryptoHashSHA512
  , cryptoHashSHA512Bytes
  , cryptoHashSHA512Final
  , cryptoHashSHA512Init
  , cryptoHashSHA512StateBytes
  , cryptoHashSHA512Update
  )
import System.IO.Unsafe (unsafeDupablePerformIO)

import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Data.Base16.Types as Base16
import Data.Kind (Type)
import Sel.Internal

-- $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.SHA512 as SHA512

-- | A hashed value from the SHA-512 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) =
    IO Bool -> Bool
forall a. IO a -> a
unsafeDupablePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      ForeignPtr CUChar -> ForeignPtr CUChar -> CSize -> IO Bool
forall a. ForeignPtr a -> ForeignPtr a -> CSize -> IO Bool
foreignPtrEq ForeignPtr CUChar
h1 ForeignPtr CUChar
h2 CSize
cryptoHashSHA512Bytes

-- |
--
-- @since 0.0.1.0
instance Ord Hash where
  compare :: Hash -> Hash -> Ordering
compare (Hash ForeignPtr CUChar
h1) (Hash ForeignPtr CUChar
h2) =
    IO Ordering -> Ordering
forall a. IO a -> a
unsafeDupablePerformIO (IO Ordering -> Ordering) -> IO Ordering -> Ordering
forall a b. (a -> b) -> a -> b
$
      ForeignPtr CUChar -> ForeignPtr CUChar -> CSize -> IO Ordering
forall a. ForeignPtr a -> ForeignPtr a -> CSize -> IO Ordering
foreignPtrOrd ForeignPtr CUChar
h1 ForeignPtr CUChar
h2 CSize
cryptoHashSHA512Bytes

-- |
--
-- @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
cryptoHashSHA512Bytes

  --  Aligned on the size of 'cryptoHashSHA512Bytes'
  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
cryptoHashSHA512Bytes)

  peek :: Ptr Hash -> IO Hash
  peek :: Ptr Hash -> IO Hash
peek Ptr Hash
ptr = do
    ForeignPtr CUChar
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
cryptoHashSHA512Bytes)
    ForeignPtr CUChar -> (Ptr CUChar -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
Foreign.withForeignPtr ForeignPtr CUChar
hashfPtr ((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 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
cryptoHashSHA512Bytes)
    Hash -> IO Hash
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hash -> IO Hash) -> Hash -> IO Hash
forall a b. (a -> b) -> a -> b
$ ForeignPtr CUChar -> Hash
Hash ForeignPtr CUChar
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

-- ** Hashing a single message

-- | 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'.
--
-- @since 0.0.1.0
hashToHexByteString :: Hash -> StrictByteString
hashToHexByteString :: Hash -> ByteString
hashToHexByteString = Base16 ByteString -> ByteString
forall a. Base16 a -> a
Base16.extractBase16 (Base16 ByteString -> ByteString)
-> (Hash -> Base16 ByteString) -> Hash -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Base16 ByteString
Base16.encodeBase16' (ByteString -> Base16 ByteString)
-> (Hash -> ByteString) -> Hash -> Base16 ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> ByteString
hashToBinary

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

-- | Hash a 'StrictByteString' with the SHA-512 algorithm.
--
-- @since 0.0.1.0
hashByteString :: StrictByteString -> IO Hash
hashByteString :: ByteString -> IO Hash
hashByteString ByteString
bytestring =
  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
    ForeignPtr CUChar
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
cryptoHashSHA512Bytes)
    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 ->
      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
cryptoHashSHA512
          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)
    Hash -> IO Hash
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hash -> IO Hash) -> Hash -> IO Hash
forall a b. (a -> b) -> a -> b
$ ForeignPtr CUChar -> Hash
Hash ForeignPtr CUChar
hashForeignPtr

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

-- ** Hashing a multi-parts 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 <- SHA512.withMultipart $ \multipartState -> do -- we are in MonadIO
-- ...   message1 <- getMessage
-- ...   SHA512.updateMultipart multipartState message1
-- ...   message2 <- getMessage
-- ...   SHA512.updateMultipart multipartState message2
--
-- @since 0.0.1.0
newtype Multipart s = Multipart (Ptr CryptoHashSHA512State)

type role Multipart nominal

-- | Perform streaming hashing with a 'Multipart' cryptographic context.
--
-- Use 'SHA512.updateMultipart' and 'SHA512.finaliseMultipart' inside of the continuation.
--
-- The context is safely allocated and deallocated inside of the continuation.
--
-- @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
action = do
  CSize -> (Ptr CryptoHashSHA512State -> m Hash) -> m Hash
forall a b (m :: * -> *).
MonadIO m =>
CSize -> (Ptr a -> m b) -> m b
allocateWith CSize
cryptoHashSHA512StateBytes ((Ptr CryptoHashSHA512State -> m Hash) -> m Hash)
-> (Ptr CryptoHashSHA512State -> m Hash) -> m Hash
forall a b. (a -> b) -> a -> b
$ \Ptr CryptoHashSHA512State
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 CryptoHashSHA512State -> IO CInt
cryptoHashSHA512Init Ptr CryptoHashSHA512State
statePtr
    let part :: Multipart s
part = Ptr CryptoHashSHA512State -> Multipart s
forall s. Ptr CryptoHashSHA512State -> Multipart s
Multipart Ptr CryptoHashSHA512State
statePtr
    Multipart Any -> m a
forall s. Multipart s -> m a
action 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 (IO Hash -> m Hash) -> IO Hash -> m Hash
forall a b. (a -> b) -> a -> b
$ 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 CryptoHashSHA512State
statePtr) = do
  ForeignPtr CUChar
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
cryptoHashSHA512Bytes)
  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) ->
    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 CryptoHashSHA512State -> Ptr CUChar -> IO CInt
cryptoHashSHA512Final
        Ptr CryptoHashSHA512State
statePtr
        Ptr CUChar
hashPtr
  Hash -> IO Hash
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hash -> IO Hash) -> Hash -> IO Hash
forall a b. (a -> b) -> a -> b
$ ForeignPtr CUChar -> Hash
Hash ForeignPtr CUChar
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 CryptoHashSHA512State
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 CryptoHashSHA512State -> Ptr CUChar -> CULLong -> IO CInt
cryptoHashSHA512Update
        Ptr CryptoHashSHA512State
statePtr
        Ptr CUChar
messagePtr
        CULLong
messageLen