{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
--
-- Module: Sel.SecretKey.Authentication
-- Description: Authentication with HMAC-SHA512-256
-- Maintainer: The Haskell Cryptography Group
-- Portability: GHC only
module Sel.SecretKey.Authentication
  ( -- ** Introduction
    -- $introduction

    -- ** Usage
    -- $usage

    -- ** Operations
    authenticate
  , verify

    -- ** Authentication key
  , AuthenticationKey
  , newAuthenticationKey
  , authenticationKeyFromHexByteString
  , unsafeAuthenticationKeyToHexByteString

    -- ** Authentication tag
  , AuthenticationTag
  , authenticationTagToHexByteString
  , authenticationTagFromHexByteString
  ) where

import Control.Monad (void, when)
import qualified Data.Base16.Types as Base16
import Data.ByteString (StrictByteString)
import qualified Data.ByteString as BS
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 qualified Data.Text as Text
import Data.Text.Display (Display, OpaqueInstance (..), ShowInstance (..))
import Data.Word (Word8)
import Foreign (ForeignPtr)
import qualified Foreign
import Foreign.C (CChar, CSize, CUChar, CULLong, throwErrno)
import System.IO.Unsafe (unsafeDupablePerformIO)

import LibSodium.Bindings.CryptoAuth
  ( cryptoAuth
  , cryptoAuthBytes
  , cryptoAuthKeyBytes
  , cryptoAuthKeygen
  , cryptoAuthVerify
  )
import LibSodium.Bindings.SecureMemory
import Sel.Internal

-- $introduction
-- The 'authenticate' function computes an authentication tag for a message and a secret key,
-- and provides a way to verify that a given tag is valid for a given message and a key.
--
-- The function computing the tag deterministic: the same @(message, key)@ tuple will always
-- produce the same output. However, even if the message is public, knowing the key is required
-- in order to be able to compute a valid tag.
-- Therefore, the key should remain confidential. The tag, however, can be public.

-- $usage
--
-- > import Sel.SecretKey.Authentication qualified as Auth
-- >
-- > main = do
-- >   -- The parties agree on a shared secret key
-- >   authKey <- Auth.newAuthenticationKey
-- >   -- An authentication tag is computed for the message by the server
-- >   let message = "Hello, world!"
-- >   tag <- Auth.authenticate message
-- >   -- The server sends the message and its authentication tag
-- >   -- […]
-- >   -- The recipient of the message uses the shared secret to validate the message's tag
-- >   Auth.verify tag authKey message
-- >   -- => True

-- | Compute an authentication tag for a message with a secret key shared by all parties.
--
-- @since 0.0.1.0
authenticate
  :: StrictByteString
  -- ^ Message to authenticate
  -> AuthenticationKey
  -- ^ Secret key for authentication
  -> IO AuthenticationTag
  -- ^ Cryptographic tag for authentication
authenticate :: StrictByteString -> AuthenticationKey -> IO AuthenticationTag
authenticate StrictByteString
message (AuthenticationKey ForeignPtr CUChar
authenticationKeyForeignPtr) =
  StrictByteString
-> (CStringLen -> IO AuthenticationTag) -> IO AuthenticationTag
forall a. StrictByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen StrictByteString
message ((CStringLen -> IO AuthenticationTag) -> IO AuthenticationTag)
-> (CStringLen -> IO AuthenticationTag) -> IO AuthenticationTag
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cString, Int
cStringLen) -> do
    ForeignPtr CUChar
authenticationTagForeignPtr <-
      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
cryptoAuthBytes)
    ForeignPtr CUChar -> (Ptr CUChar -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
Foreign.withForeignPtr ForeignPtr CUChar
authenticationTagForeignPtr ((Ptr CUChar -> IO ()) -> IO ()) -> (Ptr CUChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
authTagPtr ->
      ForeignPtr CUChar -> (Ptr CUChar -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
Foreign.withForeignPtr ForeignPtr CUChar
authenticationKeyForeignPtr ((Ptr CUChar -> IO ()) -> IO ()) -> (Ptr CUChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
authKeyPtr ->
        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 -> Ptr CUChar -> IO CInt
cryptoAuth
            Ptr CUChar
authTagPtr
            (forall a b. Ptr a -> Ptr b
Foreign.castPtr @CChar @CUChar Ptr CChar
cString)
            (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @CULLong Int
cStringLen)
            Ptr CUChar
authKeyPtr
    AuthenticationTag -> IO AuthenticationTag
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthenticationTag -> IO AuthenticationTag)
-> AuthenticationTag -> IO AuthenticationTag
forall a b. (a -> b) -> a -> b
$ ForeignPtr CUChar -> AuthenticationTag
AuthenticationTag ForeignPtr CUChar
authenticationTagForeignPtr

-- | Verify that the tag is valid for the provided message and secret key.
--
-- @since 0.0.1.0
verify
  :: AuthenticationTag
  -> AuthenticationKey
  -> StrictByteString
  -> Bool
verify :: AuthenticationTag -> AuthenticationKey -> StrictByteString -> Bool
verify (AuthenticationTag ForeignPtr CUChar
tagForeignPtr) (AuthenticationKey ForeignPtr CUChar
keyForeignPtr) StrictByteString
message = IO Bool -> Bool
forall a. IO a -> a
unsafeDupablePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$
  StrictByteString -> (CStringLen -> IO Bool) -> IO Bool
forall a. StrictByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen StrictByteString
message ((CStringLen -> IO Bool) -> IO Bool)
-> (CStringLen -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cString, Int
cStringLen) ->
    ForeignPtr CUChar -> (Ptr CUChar -> IO Bool) -> IO Bool
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
Foreign.withForeignPtr ForeignPtr CUChar
tagForeignPtr ((Ptr CUChar -> IO Bool) -> IO Bool)
-> (Ptr CUChar -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
authTagPtr ->
      ForeignPtr CUChar -> (Ptr CUChar -> IO Bool) -> IO Bool
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
Foreign.withForeignPtr ForeignPtr CUChar
keyForeignPtr ((Ptr CUChar -> IO Bool) -> IO Bool)
-> (Ptr CUChar -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
authKeyPtr -> do
        CInt
result <-
          Ptr CUChar -> Ptr CUChar -> CULLong -> Ptr CUChar -> IO CInt
cryptoAuthVerify
            Ptr CUChar
authTagPtr
            (forall a b. Ptr a -> Ptr b
Foreign.castPtr @CChar @CUChar Ptr CChar
cString)
            (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @CULLong Int
cStringLen)
            Ptr CUChar
authKeyPtr
        Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ CInt
result CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0

-- | A secret authentication key of size 'cryptoAuthKeyBytes'.
--
-- @since 0.0.1.0
newtype AuthenticationKey = AuthenticationKey (ForeignPtr CUChar)
  deriving
    ( Int -> AuthenticationKey -> Builder
[AuthenticationKey] -> Builder
AuthenticationKey -> Builder
(AuthenticationKey -> Builder)
-> ([AuthenticationKey] -> Builder)
-> (Int -> AuthenticationKey -> Builder)
-> Display AuthenticationKey
forall a.
(a -> Builder)
-> ([a] -> Builder) -> (Int -> a -> Builder) -> Display a
$cdisplayBuilder :: AuthenticationKey -> Builder
displayBuilder :: AuthenticationKey -> Builder
$cdisplayList :: [AuthenticationKey] -> Builder
displayList :: [AuthenticationKey] -> Builder
$cdisplayPrec :: Int -> AuthenticationKey -> Builder
displayPrec :: Int -> AuthenticationKey -> Builder
Display
      -- ^ @since 0.0.1.0
      -- > display authenticatonKey == "[REDACTED]"
    )
    via (OpaqueInstance "[REDACTED]" AuthenticationKey)

-- |
--
-- @since 0.0.1.0
instance Eq AuthenticationKey where
  (AuthenticationKey ForeignPtr CUChar
hk1) == :: AuthenticationKey -> AuthenticationKey -> Bool
== (AuthenticationKey ForeignPtr CUChar
hk2) =
    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
hk1 ForeignPtr CUChar
hk2 CSize
cryptoAuthKeyBytes

-- |
--
-- @since 0.0.1.0
instance Ord AuthenticationKey where
  compare :: AuthenticationKey -> AuthenticationKey -> Ordering
compare (AuthenticationKey ForeignPtr CUChar
hk1) (AuthenticationKey ForeignPtr CUChar
hk2) =
    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
hk1 ForeignPtr CUChar
hk2 CSize
cryptoAuthKeyBytes

-- | > show authenticationKey == "[REDACTED]"
--
-- @since 0.0.1.0
instance Show AuthenticationKey where
  show :: AuthenticationKey -> String
show AuthenticationKey
_ = String
"[REDACTED]"

-- | Generate a new random secret key.
--
-- @since 0.0.1.0
newAuthenticationKey :: IO AuthenticationKey
newAuthenticationKey :: IO AuthenticationKey
newAuthenticationKey = (Ptr CUChar -> IO ()) -> IO AuthenticationKey
newAuthenticationKeyWith Ptr CUChar -> IO ()
cryptoAuthKeygen

-- | Prepare memory for a 'AuthenticationKey' and use the provided action to fill it.
--
-- Memory is allocated with 'LibSodium.Bindings.SecureMemory.sodiumMalloc'
-- (see the note attached there).
-- A finalizer is run when the key is goes out of scope.
newAuthenticationKeyWith :: (Foreign.Ptr CUChar -> IO ()) -> IO AuthenticationKey
newAuthenticationKeyWith :: (Ptr CUChar -> IO ()) -> IO AuthenticationKey
newAuthenticationKeyWith Ptr CUChar -> IO ()
action = do
  Ptr CUChar
ptr <- CSize -> IO (Ptr CUChar)
forall a. CSize -> IO (Ptr a)
sodiumMalloc CSize
cryptoAuthKeyBytes
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr CUChar
ptr Ptr CUChar -> Ptr CUChar -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CUChar
forall a. Ptr a
Foreign.nullPtr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
forall a. String -> IO a
throwErrno String
"sodium_malloc"

  ForeignPtr CUChar
fPtr <- Ptr CUChar -> IO (ForeignPtr CUChar)
forall a. Ptr a -> IO (ForeignPtr a)
Foreign.newForeignPtr_ Ptr CUChar
ptr
  FinalizerPtr CUChar -> ForeignPtr CUChar -> IO ()
forall a. FinalizerPtr a -> ForeignPtr a -> IO ()
Foreign.addForeignPtrFinalizer FinalizerPtr CUChar
forall a. FinalizerPtr a
finalizerSodiumFree ForeignPtr CUChar
fPtr
  Ptr CUChar -> IO ()
action Ptr CUChar
ptr
  AuthenticationKey -> IO AuthenticationKey
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthenticationKey -> IO AuthenticationKey)
-> AuthenticationKey -> IO AuthenticationKey
forall a b. (a -> b) -> a -> b
$ ForeignPtr CUChar -> AuthenticationKey
AuthenticationKey ForeignPtr CUChar
fPtr

-- | Create an 'AuthenticationKey' from a binary 'StrictByteString' that you have obtained on your own,
-- usually from the network or disk.
--
-- The input secret key, once decoded from base16, must be of length
-- 'cryptoAuthKeyBytes'.
--
-- @since 0.0.1.0
authenticationKeyFromHexByteString :: StrictByteString -> Either Text AuthenticationKey
authenticationKeyFromHexByteString :: StrictByteString -> Either Text AuthenticationKey
authenticationKeyFromHexByteString StrictByteString
hexKey = IO (Either Text AuthenticationKey) -> Either Text AuthenticationKey
forall a. IO a -> a
unsafeDupablePerformIO (IO (Either Text AuthenticationKey)
 -> Either Text AuthenticationKey)
-> IO (Either Text AuthenticationKey)
-> Either Text AuthenticationKey
forall a b. (a -> b) -> a -> b
$
  case StrictByteString -> Either Text StrictByteString
Base16.decodeBase16Untyped StrictByteString
hexKey of
    Right StrictByteString
bytestring ->
      if StrictByteString -> Int
BS.length StrictByteString
bytestring Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
cryptoAuthKeyBytes
        then StrictByteString
-> (CStringLen -> IO (Either Text AuthenticationKey))
-> IO (Either Text AuthenticationKey)
forall a. StrictByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen StrictByteString
bytestring ((CStringLen -> IO (Either Text AuthenticationKey))
 -> IO (Either Text AuthenticationKey))
-> (CStringLen -> IO (Either Text AuthenticationKey))
-> IO (Either Text AuthenticationKey)
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
outsideAuthenticationKeyPtr, Int
_) ->
          (AuthenticationKey -> Either Text AuthenticationKey)
-> IO AuthenticationKey -> IO (Either Text AuthenticationKey)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AuthenticationKey -> Either Text AuthenticationKey
forall a b. b -> Either a b
Right (IO AuthenticationKey -> IO (Either Text AuthenticationKey))
-> IO AuthenticationKey -> IO (Either Text AuthenticationKey)
forall a b. (a -> b) -> a -> b
$
            (Ptr CUChar -> IO ()) -> IO AuthenticationKey
newAuthenticationKeyWith ((Ptr CUChar -> IO ()) -> IO AuthenticationKey)
-> (Ptr CUChar -> IO ()) -> IO AuthenticationKey
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
authenticationKeyPtr ->
              Ptr CChar -> Ptr CChar -> Int -> IO ()
forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
Foreign.copyArray
                (forall a b. Ptr a -> Ptr b
Foreign.castPtr @CUChar @CChar Ptr CUChar
authenticationKeyPtr)
                Ptr CChar
outsideAuthenticationKeyPtr
                (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
cryptoAuthKeyBytes)
        else Either Text AuthenticationKey -> IO (Either Text AuthenticationKey)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text AuthenticationKey
 -> IO (Either Text AuthenticationKey))
-> Either Text AuthenticationKey
-> IO (Either Text AuthenticationKey)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text AuthenticationKey
forall a b. a -> Either a b
Left (Text -> Either Text AuthenticationKey)
-> Text -> Either Text AuthenticationKey
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
"Authentication Key is too short"
    Left Text
msg -> Either Text AuthenticationKey -> IO (Either Text AuthenticationKey)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text AuthenticationKey
 -> IO (Either Text AuthenticationKey))
-> Either Text AuthenticationKey
-> IO (Either Text AuthenticationKey)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text AuthenticationKey
forall a b. a -> Either a b
Left Text
msg

-- | Convert a 'AuthenticationKey to a hexadecimal-encoded 'StrictByteString'.
--
-- ⚠️  Be prudent as to where you store it!
--
-- @since 0.0.1.0
unsafeAuthenticationKeyToHexByteString :: AuthenticationKey -> StrictByteString
unsafeAuthenticationKeyToHexByteString :: AuthenticationKey -> StrictByteString
unsafeAuthenticationKeyToHexByteString (AuthenticationKey ForeignPtr CUChar
authenticationKeyForeignPtr) =
  Base16 StrictByteString -> StrictByteString
forall a. Base16 a -> a
Base16.extractBase16 (Base16 StrictByteString -> StrictByteString)
-> (StrictByteString -> Base16 StrictByteString)
-> StrictByteString
-> StrictByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictByteString -> Base16 StrictByteString
Base16.encodeBase16' (StrictByteString -> StrictByteString)
-> StrictByteString -> StrictByteString
forall a b. (a -> b) -> a -> b
$
    ForeignPtr Word8 -> Int -> StrictByteString
BS.fromForeignPtr0
      (forall a b. ForeignPtr a -> ForeignPtr b
Foreign.castForeignPtr @CUChar @Word8 ForeignPtr CUChar
authenticationKeyForeignPtr)
      (forall a b. (Integral a, Num b) => a -> b
fromIntegral @CSize @Int CSize
cryptoAuthKeyBytes)

-- | A secret authentication key of size 'cryptoAuthBytes'.
--
-- @since 0.0.1.0
newtype AuthenticationTag = AuthenticationTag (ForeignPtr CUChar)
  deriving
    ( Int -> AuthenticationTag -> Builder
[AuthenticationTag] -> Builder
AuthenticationTag -> Builder
(AuthenticationTag -> Builder)
-> ([AuthenticationTag] -> Builder)
-> (Int -> AuthenticationTag -> Builder)
-> Display AuthenticationTag
forall a.
(a -> Builder)
-> ([a] -> Builder) -> (Int -> a -> Builder) -> Display a
$cdisplayBuilder :: AuthenticationTag -> Builder
displayBuilder :: AuthenticationTag -> Builder
$cdisplayList :: [AuthenticationTag] -> Builder
displayList :: [AuthenticationTag] -> Builder
$cdisplayPrec :: Int -> AuthenticationTag -> Builder
displayPrec :: Int -> AuthenticationTag -> Builder
Display
      -- ^ @since 0.0.1.0
    )
    via (ShowInstance AuthenticationTag)

-- |
--
-- @since 0.0.1.0
instance Eq AuthenticationTag where
  (AuthenticationTag ForeignPtr CUChar
hk1) == :: AuthenticationTag -> AuthenticationTag -> Bool
== (AuthenticationTag ForeignPtr CUChar
hk2) =
    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
hk1 ForeignPtr CUChar
hk2 CSize
cryptoAuthBytes

-- |
--
-- @since 0.0.1.0
instance Ord AuthenticationTag where
  compare :: AuthenticationTag -> AuthenticationTag -> Ordering
compare (AuthenticationTag ForeignPtr CUChar
hk1) (AuthenticationTag ForeignPtr CUChar
hk2) =
    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
hk1 ForeignPtr CUChar
hk2 CSize
cryptoAuthBytes

-- |
--
-- @since 0.0.1.0
instance Show AuthenticationTag where
  show :: AuthenticationTag -> String
show = StrictByteString -> String
BS.unpackChars (StrictByteString -> String)
-> (AuthenticationTag -> StrictByteString)
-> AuthenticationTag
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthenticationTag -> StrictByteString
authenticationTagToHexByteString

-- | Convert an 'AuthenticationTag' to a hexadecimal-encoded 'StrictByteString'.
--
-- @since 0.0.1.0
authenticationTagToHexByteString :: AuthenticationTag -> StrictByteString
authenticationTagToHexByteString :: AuthenticationTag -> StrictByteString
authenticationTagToHexByteString (AuthenticationTag ForeignPtr CUChar
fPtr) =
  Base16 StrictByteString -> StrictByteString
forall a. Base16 a -> a
Base16.extractBase16 (Base16 StrictByteString -> StrictByteString)
-> Base16 StrictByteString -> StrictByteString
forall a b. (a -> b) -> a -> b
$
    StrictByteString -> Base16 StrictByteString
Base16.encodeBase16' (StrictByteString -> Base16 StrictByteString)
-> StrictByteString -> Base16 StrictByteString
forall a b. (a -> b) -> a -> b
$
      ForeignPtr Word8 -> Int -> StrictByteString
BS.fromForeignPtr0
        (ForeignPtr CUChar -> ForeignPtr Word8
forall a b. ForeignPtr a -> ForeignPtr b
Foreign.castForeignPtr ForeignPtr CUChar
fPtr)
        (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
cryptoAuthBytes)

-- | Create an 'AuthenticationTag' from a binary 'StrictByteString' that you have obtained on your own,
-- usually from the network or disk.
--
-- The input secret key, once decoded from base16, must be of length
-- 'cryptoAuthBytes'.
--
-- @since 0.0.1.0
authenticationTagFromHexByteString :: StrictByteString -> Either Text AuthenticationTag
authenticationTagFromHexByteString :: StrictByteString -> Either Text AuthenticationTag
authenticationTagFromHexByteString StrictByteString
hexTag = IO (Either Text AuthenticationTag) -> Either Text AuthenticationTag
forall a. IO a -> a
unsafeDupablePerformIO (IO (Either Text AuthenticationTag)
 -> Either Text AuthenticationTag)
-> IO (Either Text AuthenticationTag)
-> Either Text AuthenticationTag
forall a b. (a -> b) -> a -> b
$
  case StrictByteString -> Either Text StrictByteString
Base16.decodeBase16Untyped StrictByteString
hexTag of
    Right StrictByteString
bytestring ->
      if StrictByteString -> Int
BS.length StrictByteString
bytestring Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
cryptoAuthBytes
        then StrictByteString
-> (CStringLen -> IO (Either Text AuthenticationTag))
-> IO (Either Text AuthenticationTag)
forall a. StrictByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen StrictByteString
bytestring ((CStringLen -> IO (Either Text AuthenticationTag))
 -> IO (Either Text AuthenticationTag))
-> (CStringLen -> IO (Either Text AuthenticationTag))
-> IO (Either Text AuthenticationTag)
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
outsideTagPtr, Int
outsideTagLength) -> do
          ForeignPtr CChar
hashForeignPtr <- forall a. Int -> IO (ForeignPtr a)
BS.mallocByteString @CChar Int
outsideTagLength -- The foreign pointer that will receive the hash data.
          ForeignPtr CChar -> (Ptr CChar -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
Foreign.withForeignPtr ForeignPtr CChar
hashForeignPtr ((Ptr CChar -> IO ()) -> IO ()) -> (Ptr CChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
hashPtr ->
            -- We copy bytes from 'outsideTagPtr' to 'hashPtr'.
            Ptr CChar -> Ptr CChar -> Int -> IO ()
forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
Foreign.copyArray Ptr CChar
hashPtr Ptr CChar
outsideTagPtr Int
outsideTagLength
          Either Text AuthenticationTag -> IO (Either Text AuthenticationTag)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text AuthenticationTag
 -> IO (Either Text AuthenticationTag))
-> Either Text AuthenticationTag
-> IO (Either Text AuthenticationTag)
forall a b. (a -> b) -> a -> b
$
            AuthenticationTag -> Either Text AuthenticationTag
forall a b. b -> Either a b
Right (AuthenticationTag -> Either Text AuthenticationTag)
-> AuthenticationTag -> Either Text AuthenticationTag
forall a b. (a -> b) -> a -> b
$
              ForeignPtr CUChar -> AuthenticationTag
AuthenticationTag
                (forall a b. ForeignPtr a -> ForeignPtr b
Foreign.castForeignPtr @CChar @CUChar ForeignPtr CChar
hashForeignPtr)
        else Either Text AuthenticationTag -> IO (Either Text AuthenticationTag)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text AuthenticationTag
 -> IO (Either Text AuthenticationTag))
-> Either Text AuthenticationTag
-> IO (Either Text AuthenticationTag)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text AuthenticationTag
forall a b. a -> Either a b
Left (Text -> Either Text AuthenticationTag)
-> Text -> Either Text AuthenticationTag
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
"Hash is too short"
    Left Text
msg -> Either Text AuthenticationTag -> IO (Either Text AuthenticationTag)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text AuthenticationTag
 -> IO (Either Text AuthenticationTag))
-> Either Text AuthenticationTag
-> IO (Either Text AuthenticationTag)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text AuthenticationTag
forall a b. a -> Either a b
Left Text
msg