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

-- |
--
-- Module: Sel.PublicKey.Seal
-- Description: Anonymous ephemeral authenticated encryption with public and secret keys
-- Copyright: (C) Hécate Moonlight 2022
-- License: BSD-3-Clause
-- Maintainer: The Haskell Cryptography Group
-- Portability: GHC only
module Sel.PublicKey.Seal
  ( -- ** Introduction
    -- $introduction

    -- ** Usage
    -- $usage

    -- ** Keys
    PublicKey (..)
  , SecretKey (..)
  , newKeyPair

    -- ** Operations
  , seal
  , open

    -- ** Errors
  , KeyPairGenerationException
  , EncryptionError
  ) where

import Control.Exception (throw)
import Control.Monad (when)
import Data.ByteString (StrictByteString)
import qualified Data.ByteString.Unsafe as BS
import qualified Foreign
import Foreign.C (CChar, CSize, CUChar, CULLong)
import GHC.IO.Handle.Text (memcpy)
import System.IO.Unsafe (unsafeDupablePerformIO)

import LibSodium.Bindings.SealedBoxes (cryptoBoxSeal, cryptoBoxSealOpen, cryptoBoxSealbytes)
import Sel.PublicKey.Cipher (CipherText (CipherText), EncryptionError (..), KeyPairGenerationException, PublicKey (PublicKey), SecretKey (..), newKeyPair)

-- $introduction
-- Ephemeral authenticated encryption allows to anonymously send message to
-- a recipient given their public key.
--
-- Only the recipient can decrypt these messages using their own secret key.
-- While the recipient can verify the integrity of the message, they cannot
-- verify the identity of the sender.
--
-- A message is encrypted using an ephemeral key pair, with the secret key being erased
-- right after the encryption process.
--
-- Without knowing the secret key used for a given message, the sender cannot decrypt
-- their own message later. Furthermore, without additional data, a message cannot
-- be correlated with the identity of its sender.

-- $usage
--
-- > import qualified Sel.PublicKey.Seal as Seal
-- >
-- > main = do
-- >   -- We get the recipient their pair of keys:
-- > (recipientPublicKey, recipientSecretKey) <- newKeyPair
-- >   encryptedMessage <- Seal.encrypt "hello hello" recipientPublicKey
-- >   let result = Seal.open encryptedMessage recipientPublicKey recipientSecretKey
-- >   print result
-- >   -- "Just \"hello hello\""

-- | Encrypt a message with the recipient's public key. A key pair for the sender
-- is generated, and the public key of that pair is attached to the cipher text.
-- The secret key of the sender's pair is automatically destroyed.
--
-- @since 0.0.1.0
seal
  :: StrictByteString
  -- ^ Message to encrypt
  -> PublicKey
  -- ^ Public key of the recipient
  -> IO CipherText
seal :: StrictByteString -> PublicKey -> IO CipherText
seal StrictByteString
messageByteString (PublicKey ForeignPtr CUChar
publicKeyFptr) = do
  StrictByteString -> (CStringLen -> IO CipherText) -> IO CipherText
forall a. StrictByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen StrictByteString
messageByteString ((CStringLen -> IO CipherText) -> IO CipherText)
-> (CStringLen -> IO CipherText) -> IO CipherText
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
messagePtr, Int
messageLen) -> do
    ForeignPtr CUChar
cipherTextForeignPtr <-
      Int -> IO (ForeignPtr CUChar)
forall a. Int -> IO (ForeignPtr a)
Foreign.mallocForeignPtrBytes
        (Int
messageLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
cryptoBoxSealbytes)
    ForeignPtr CUChar -> (Ptr CUChar -> IO CipherText) -> IO CipherText
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
Foreign.withForeignPtr ForeignPtr CUChar
publicKeyFptr ((Ptr CUChar -> IO CipherText) -> IO CipherText)
-> (Ptr CUChar -> IO CipherText) -> IO CipherText
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
publicKeyPtr ->
      ForeignPtr CUChar -> (Ptr CUChar -> IO CipherText) -> IO CipherText
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
Foreign.withForeignPtr ForeignPtr CUChar
cipherTextForeignPtr ((Ptr CUChar -> IO CipherText) -> IO CipherText)
-> (Ptr CUChar -> IO CipherText) -> IO CipherText
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
cipherTextPtr -> do
        CInt
result <-
          Ptr CUChar -> Ptr CUChar -> CULLong -> Ptr CUChar -> IO CInt
cryptoBoxSeal
            Ptr CUChar
cipherTextPtr
            (forall a b. Ptr a -> Ptr b
Foreign.castPtr @CChar @CUChar Ptr CChar
messagePtr)
            (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @CULLong Int
messageLen)
            Ptr CUChar
publicKeyPtr
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
result CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ EncryptionError -> IO ()
forall a e. Exception e => e -> a
throw EncryptionError
EncryptionError
        CipherText -> IO CipherText
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CipherText -> IO CipherText) -> CipherText -> IO CipherText
forall a b. (a -> b) -> a -> b
$
          CULLong -> ForeignPtr CUChar -> CipherText
CipherText
            (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @CULLong Int
messageLen)
            ForeignPtr CUChar
cipherTextForeignPtr

-- | Open a sealed message from an unknown sender.
-- You need your public and secret keys.
--
-- @since 0.0.1.0
open
  :: CipherText
  -- ^ Cipher to decrypt
  -> PublicKey
  -- ^ Public key of the recipient
  -> SecretKey
  -- ^ Secret key of the recipient
  -> Maybe StrictByteString
open :: CipherText -> PublicKey -> SecretKey -> Maybe StrictByteString
open
  (CipherText CULLong
messageLen ForeignPtr CUChar
cipherForeignPtr)
  (PublicKey ForeignPtr CUChar
publicKeyFPtr)
  (SecretKey ForeignPtr CUChar
secretKeyFPtr) = IO (Maybe StrictByteString) -> Maybe StrictByteString
forall a. IO a -> a
unsafeDupablePerformIO (IO (Maybe StrictByteString) -> Maybe StrictByteString)
-> IO (Maybe StrictByteString) -> Maybe StrictByteString
forall a b. (a -> b) -> a -> b
$ do
    Ptr CUChar
messagePtr <- Int -> IO (Ptr CUChar)
forall a. Int -> IO (Ptr a)
Foreign.mallocBytes (forall a b. (Integral a, Num b) => a -> b
fromIntegral @CULLong @Int CULLong
messageLen)
    ForeignPtr CUChar
-> (Ptr CUChar -> IO (Maybe StrictByteString))
-> IO (Maybe StrictByteString)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
Foreign.withForeignPtr ForeignPtr CUChar
cipherForeignPtr ((Ptr CUChar -> IO (Maybe StrictByteString))
 -> IO (Maybe StrictByteString))
-> (Ptr CUChar -> IO (Maybe StrictByteString))
-> IO (Maybe StrictByteString)
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
cipherTextPtr ->
      ForeignPtr CUChar
-> (Ptr CUChar -> IO (Maybe StrictByteString))
-> IO (Maybe StrictByteString)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
Foreign.withForeignPtr ForeignPtr CUChar
publicKeyFPtr ((Ptr CUChar -> IO (Maybe StrictByteString))
 -> IO (Maybe StrictByteString))
-> (Ptr CUChar -> IO (Maybe StrictByteString))
-> IO (Maybe StrictByteString)
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
publicKeyPtr ->
        ForeignPtr CUChar
-> (Ptr CUChar -> IO (Maybe StrictByteString))
-> IO (Maybe StrictByteString)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
Foreign.withForeignPtr ForeignPtr CUChar
secretKeyFPtr ((Ptr CUChar -> IO (Maybe StrictByteString))
 -> IO (Maybe StrictByteString))
-> (Ptr CUChar -> IO (Maybe StrictByteString))
-> IO (Maybe StrictByteString)
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
secretKeyPtr -> do
          CInt
result <-
            Ptr CUChar
-> Ptr CUChar -> CULLong -> Ptr CUChar -> Ptr CUChar -> IO CInt
cryptoBoxSealOpen
              Ptr CUChar
messagePtr
              Ptr CUChar
cipherTextPtr
              (CULLong
messageLen CULLong -> CULLong -> CULLong
forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral @CSize @CULLong CSize
cryptoBoxSealbytes)
              Ptr CUChar
publicKeyPtr
              Ptr CUChar
secretKeyPtr
          case CInt
result of
            (-1) -> Maybe StrictByteString -> IO (Maybe StrictByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe StrictByteString
forall a. Maybe a
Nothing
            CInt
_ -> do
              Ptr CChar
bsPtr <- Int -> IO (Ptr CChar)
forall a. Int -> IO (Ptr a)
Foreign.mallocBytes (CULLong -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CULLong
messageLen)
              Ptr CChar -> Ptr CChar -> CSize -> IO (Ptr ())
forall a. Ptr a -> Ptr a -> CSize -> IO (Ptr ())
memcpy Ptr CChar
bsPtr (Ptr CUChar -> Ptr CChar
forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr CUChar
messagePtr) (CULLong -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral CULLong
messageLen)
              StrictByteString -> Maybe StrictByteString
forall a. a -> Maybe a
Just
                (StrictByteString -> Maybe StrictByteString)
-> IO StrictByteString -> IO (Maybe StrictByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CStringLen -> IO StrictByteString
BS.unsafePackMallocCStringLen
                  (forall a b. Ptr a -> Ptr b
Foreign.castPtr @CChar Ptr CChar
bsPtr, CULLong -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CULLong
messageLen)