{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
--
-- Module: Sel.PublicKey.Signature
-- Description: Public-key signatures with the Ed25519 algorithm
-- Copyright: (C) Hécate Moonlight 2022
-- License: BSD-3-Clause
-- Maintainer: The Haskell Cryptography Group
-- Portability: GHC only
module Sel.PublicKey.Signature
  ( -- ** Introduction
    -- $introduction
    PublicKey
  , SecretKey
  , SignedMessage

    -- ** Key Pair generation
  , generateKeyPair

    -- ** Message Signing
  , signMessage
  , openMessage

    -- ** Constructing and Deconstructing
  , getSignature
  , unsafeGetMessage
  , mkSignature
  )
where

import Control.Monad (void)
import Data.ByteString (StrictByteString)
import Data.ByteString.Unsafe (unsafePackMallocCStringLen)
import qualified Data.ByteString.Unsafe as ByteString
import Foreign
  ( ForeignPtr
  , Ptr
  , castPtr
  , mallocBytes
  , mallocForeignPtrBytes
  , withForeignPtr
  )
import Foreign.C (CChar, CSize, CUChar, CULLong)
import qualified Foreign.Marshal.Array as Foreign
import qualified Foreign.Ptr as Foreign
import GHC.IO.Handle.Text (memcpy)
import LibSodium.Bindings.CryptoSign
  ( cryptoSignBytes
  , cryptoSignDetached
  , cryptoSignKeyPair
  , cryptoSignPublicKeyBytes
  , cryptoSignSecretKeyBytes
  , cryptoSignVerifyDetached
  )
import System.IO.Unsafe (unsafeDupablePerformIO)

import Sel.Internal

-- $introduction
--
-- Public-key Signatures work with a 'SecretKey' and 'PublicKey'
--
-- * The 'SecretKey' is used to append a signature to any number of messages. It must stay private;
-- * The 'PublicKey' is used by third-parties to to verify that the signature appended to a message was
-- issued by the creator of the public key. It must be distributed to third-parties.
--
-- Verifiers need to already know and ultimately trust a public key before messages signed
-- using it can be verified.

-- |
--
-- @since 0.0.1.0
newtype PublicKey = PublicKey (ForeignPtr CUChar)

-- |
--
-- @since 0.0.1.0
instance Eq PublicKey where
  (PublicKey ForeignPtr CUChar
pk1) == :: PublicKey -> PublicKey -> Bool
== (PublicKey ForeignPtr CUChar
pk2) =
    ForeignPtr CUChar -> ForeignPtr CUChar -> CSize -> Bool
foreignPtrEq ForeignPtr CUChar
pk1 ForeignPtr CUChar
pk2 CSize
cryptoSignPublicKeyBytes

-- |
--
-- @since 0.0.1.0
instance Ord PublicKey where
  compare :: PublicKey -> PublicKey -> Ordering
compare (PublicKey ForeignPtr CUChar
pk1) (PublicKey ForeignPtr CUChar
pk2) =
    ForeignPtr CUChar -> ForeignPtr CUChar -> CSize -> Ordering
foreignPtrOrd ForeignPtr CUChar
pk1 ForeignPtr CUChar
pk2 CSize
cryptoSignPublicKeyBytes

-- |
--
-- @since 0.0.1.0
newtype SecretKey = SecretKey (ForeignPtr CUChar)

-- |
--
-- @since 0.0.1.0
instance Eq SecretKey where
  (SecretKey ForeignPtr CUChar
sk1) == :: SecretKey -> SecretKey -> Bool
== (SecretKey ForeignPtr CUChar
sk2) =
    ForeignPtr CUChar -> ForeignPtr CUChar -> CSize -> Bool
foreignPtrEqConstantTime ForeignPtr CUChar
sk1 ForeignPtr CUChar
sk2 CSize
cryptoSignSecretKeyBytes

-- |
--
-- @since 0.0.1.0
instance Ord SecretKey where
  compare :: SecretKey -> SecretKey -> Ordering
compare (SecretKey ForeignPtr CUChar
sk1) (SecretKey ForeignPtr CUChar
sk2) =
    ForeignPtr CUChar -> ForeignPtr CUChar -> CSize -> Ordering
foreignPtrOrd ForeignPtr CUChar
sk1 ForeignPtr CUChar
sk2 CSize
cryptoSignSecretKeyBytes

-- |
--
-- @since 0.0.1.0
data SignedMessage = SignedMessage
  { SignedMessage -> CSize
messageLength :: CSize
  , SignedMessage -> ForeignPtr CUChar
messageForeignPtr :: ForeignPtr CUChar
  , SignedMessage -> ForeignPtr CUChar
signatureForeignPtr :: ForeignPtr CUChar
  }

-- |
--
-- @since 0.0.1.0
instance Eq SignedMessage where
  (SignedMessage CSize
len1 ForeignPtr CUChar
msg1 ForeignPtr CUChar
sig1) == :: SignedMessage -> SignedMessage -> Bool
== (SignedMessage CSize
len2 ForeignPtr CUChar
msg2 ForeignPtr CUChar
sig2) =
    let
      messageLength :: Bool
messageLength = CSize
len1 CSize -> CSize -> Bool
forall a. Eq a => a -> a -> Bool
== CSize
len2
      msg1Eq :: Bool
msg1Eq = ForeignPtr CUChar -> ForeignPtr CUChar -> CSize -> Bool
foreignPtrEq ForeignPtr CUChar
msg1 ForeignPtr CUChar
msg2 CSize
len1
      msg2Eq :: Bool
msg2Eq = ForeignPtr CUChar -> ForeignPtr CUChar -> CSize -> Bool
foreignPtrEq ForeignPtr CUChar
sig1 ForeignPtr CUChar
sig2 CSize
cryptoSignBytes
     in
      Bool
messageLength Bool -> Bool -> Bool
&& Bool
msg1Eq Bool -> Bool -> Bool
&& Bool
msg2Eq

-- |
--
-- @since 0.0.1.0
instance Ord SignedMessage where
  compare :: SignedMessage -> SignedMessage -> Ordering
compare (SignedMessage CSize
len1 ForeignPtr CUChar
msg1 ForeignPtr CUChar
sig1) (SignedMessage CSize
len2 ForeignPtr CUChar
msg2 ForeignPtr CUChar
sig2) =
    let
      messageLength :: Ordering
messageLength = CSize -> CSize -> Ordering
forall a. Ord a => a -> a -> Ordering
compare CSize
len1 CSize
len2
      msg1Ord :: Ordering
msg1Ord = ForeignPtr CUChar -> ForeignPtr CUChar -> CSize -> Ordering
foreignPtrOrd ForeignPtr CUChar
msg1 ForeignPtr CUChar
msg2 CSize
len1
      msg2Ord :: Ordering
msg2Ord = ForeignPtr CUChar -> ForeignPtr CUChar -> CSize -> Ordering
foreignPtrOrd ForeignPtr CUChar
sig1 ForeignPtr CUChar
sig2 CSize
cryptoSignBytes
     in
      Ordering
messageLength Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Ordering
msg1Ord Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Ordering
msg2Ord

-- | Generate a pair of public and secret key.
--
-- The length parameters used are 'cryptoSignPublicKeyBytes'
-- and 'cryptoSignSecretKeyBytes'.
--
-- @since 0.0.1.0
generateKeyPair :: IO (PublicKey, SecretKey)
generateKeyPair :: IO (PublicKey, SecretKey)
generateKeyPair = do
  publicKeyForeignPtr <- Int -> IO (ForeignPtr CUChar)
forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes (forall a b. (Integral a, Num b) => a -> b
fromIntegral @CSize @Int CSize
cryptoSignPublicKeyBytes)
  secretKeyForeignPtr <- mallocForeignPtrBytes (fromIntegral @CSize @Int cryptoSignSecretKeyBytes)
  withForeignPtr publicKeyForeignPtr $ \Ptr CUChar
pkPtr ->
    ForeignPtr CUChar -> (Ptr CUChar -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CUChar
secretKeyForeignPtr ((Ptr CUChar -> IO ()) -> IO ()) -> (Ptr CUChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
skPtr ->
      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 -> IO CInt
cryptoSignKeyPair
          Ptr CUChar
pkPtr
          Ptr CUChar
skPtr
  pure (PublicKey publicKeyForeignPtr, SecretKey secretKeyForeignPtr)

-- | Sign a message.
--
-- Note that, if @libsodium@ is compiled with the @ED25519_NONDETERMINISTIC@
-- macro defined, this function will produce non-deterministic (but also
-- non-standard) Ed25519 signatures. If @libsodium@ hasn't been compiled with
-- the @ED25519_NONDETERMINISTIC@ macro defined, it's safe to call this
-- function in a pure context with 'unsafeDupablePerformIO'.
--
-- For more information, see the
-- [@libsodium@ docs](https://doc.libsodium.org/public-key_cryptography/public-key_signatures#notes).
--
-- @since 0.0.1.0
signMessage :: StrictByteString -> SecretKey -> IO SignedMessage
signMessage :: StrictByteString -> SecretKey -> IO SignedMessage
signMessage StrictByteString
message (SecretKey ForeignPtr CUChar
skFPtr) =
  StrictByteString
-> (CStringLen -> IO SignedMessage) -> IO SignedMessage
forall a. StrictByteString -> (CStringLen -> IO a) -> IO a
ByteString.unsafeUseAsCStringLen StrictByteString
message ((CStringLen -> IO SignedMessage) -> IO SignedMessage)
-> (CStringLen -> IO SignedMessage) -> IO SignedMessage
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
cString, Int
messageLength) -> do
    let sigLength :: Int
sigLength = forall a b. (Integral a, Num b) => a -> b
fromIntegral @CSize @Int CSize
cryptoSignBytes
    (messageForeignPtr :: ForeignPtr CUChar) <- Int -> IO (ForeignPtr CUChar)
forall a. Int -> IO (ForeignPtr a)
Foreign.mallocForeignPtrBytes Int
messageLength
    signatureForeignPtr <- Foreign.mallocForeignPtrBytes sigLength
    withForeignPtr messageForeignPtr $ \Ptr CUChar
messagePtr ->
      ForeignPtr CUChar -> (Ptr CUChar -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CUChar
signatureForeignPtr ((Ptr CUChar -> IO ()) -> IO ()) -> (Ptr CUChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
signaturePtr ->
        ForeignPtr CUChar -> (Ptr CUChar -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CUChar
skFPtr ((Ptr CUChar -> IO ()) -> IO ()) -> (Ptr CUChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
skPtr -> do
          Ptr CUChar -> Ptr CUChar -> Int -> IO ()
forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
Foreign.copyArray Ptr CUChar
messagePtr (forall a b. Ptr a -> Ptr b
Foreign.castPtr @CChar @CUChar Ptr CChar
cString) Int
messageLength
          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 CULLong -> Ptr CUChar -> CULLong -> Ptr CUChar -> IO CInt
cryptoSignDetached
              Ptr CUChar
signaturePtr
              Ptr CULLong
forall a. Ptr a
Foreign.nullPtr -- Always of size 'cryptoSignBytes'
              (forall a b. Ptr a -> Ptr b
castPtr @CChar @CUChar Ptr CChar
cString)
              (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @CULLong Int
messageLength)
              Ptr CUChar
skPtr
    pure $ SignedMessage (fromIntegral @Int @CSize messageLength) messageForeignPtr signatureForeignPtr

-- | Open a signed message with the signatory's public key.
-- The function returns 'Nothing' if there is a key mismatch.
--
-- @since 0.0.1.0
openMessage :: SignedMessage -> PublicKey -> Maybe StrictByteString
openMessage :: SignedMessage -> PublicKey -> Maybe StrictByteString
openMessage SignedMessage{CSize
messageLength :: SignedMessage -> CSize
messageLength :: CSize
messageLength, ForeignPtr CUChar
messageForeignPtr :: SignedMessage -> ForeignPtr CUChar
messageForeignPtr :: ForeignPtr CUChar
messageForeignPtr, ForeignPtr CUChar
signatureForeignPtr :: SignedMessage -> ForeignPtr CUChar
signatureForeignPtr :: ForeignPtr CUChar
signatureForeignPtr} (PublicKey ForeignPtr CUChar
pkForeignPtr) = 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
$
  ForeignPtr CUChar
-> (Ptr CUChar -> IO (Maybe StrictByteString))
-> IO (Maybe StrictByteString)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CUChar
pkForeignPtr ((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
withForeignPtr ForeignPtr CUChar
signatureForeignPtr ((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
signaturePtr -> do
      ForeignPtr CUChar
-> (Ptr CUChar -> IO (Maybe StrictByteString))
-> IO (Maybe StrictByteString)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CUChar
messageForeignPtr ((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
messagePtr -> do
        result <-
          Ptr CUChar -> Ptr CUChar -> CULLong -> Ptr CUChar -> IO CInt
cryptoSignVerifyDetached
            Ptr CUChar
signaturePtr
            Ptr CUChar
messagePtr
            (forall a b. (Integral a, Num b) => a -> b
fromIntegral @CSize @CULLong CSize
messageLength)
            Ptr CUChar
publicKeyPtr
        case 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
            bsPtr <- Int -> IO (Ptr Any)
forall a. Int -> IO (Ptr a)
mallocBytes (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
messageLength)
            memcpy bsPtr (castPtr messagePtr) messageLength
            Just <$> unsafePackMallocCStringLen (castPtr bsPtr :: Ptr CChar, fromIntegral messageLength)

-- | Get the signature part of a 'SignedMessage'.
--
-- @since 0.0.1.0
getSignature :: SignedMessage -> StrictByteString
getSignature :: SignedMessage -> StrictByteString
getSignature SignedMessage{ForeignPtr CUChar
signatureForeignPtr :: SignedMessage -> ForeignPtr CUChar
signatureForeignPtr :: ForeignPtr CUChar
signatureForeignPtr} = IO StrictByteString -> StrictByteString
forall a. IO a -> a
unsafeDupablePerformIO (IO StrictByteString -> StrictByteString)
-> IO StrictByteString -> StrictByteString
forall a b. (a -> b) -> a -> b
$
  ForeignPtr CUChar
-> (Ptr CUChar -> IO StrictByteString) -> IO StrictByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CUChar
signatureForeignPtr ((Ptr CUChar -> IO StrictByteString) -> IO StrictByteString)
-> (Ptr CUChar -> IO StrictByteString) -> IO StrictByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
signaturePtr -> do
    bsPtr <- Int -> IO (Ptr CUChar)
forall a. Int -> IO (Ptr a)
Foreign.mallocBytes (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
cryptoSignBytes)
    memcpy bsPtr signaturePtr cryptoSignBytes
    unsafePackMallocCStringLen (Foreign.castPtr bsPtr :: Ptr CChar, fromIntegral cryptoSignBytes)

-- | Get the message part of a 'SignedMessage' __without verifying the signature__.
--
-- @since 0.0.1.0
unsafeGetMessage :: SignedMessage -> StrictByteString
unsafeGetMessage :: SignedMessage -> StrictByteString
unsafeGetMessage SignedMessage{CSize
messageLength :: SignedMessage -> CSize
messageLength :: CSize
messageLength, ForeignPtr CUChar
messageForeignPtr :: SignedMessage -> ForeignPtr CUChar
messageForeignPtr :: ForeignPtr CUChar
messageForeignPtr} = IO StrictByteString -> StrictByteString
forall a. IO a -> a
unsafeDupablePerformIO (IO StrictByteString -> StrictByteString)
-> IO StrictByteString -> StrictByteString
forall a b. (a -> b) -> a -> b
$
  ForeignPtr CUChar
-> (Ptr CUChar -> IO StrictByteString) -> IO StrictByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CUChar
messageForeignPtr ((Ptr CUChar -> IO StrictByteString) -> IO StrictByteString)
-> (Ptr CUChar -> IO StrictByteString) -> IO StrictByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
messagePtr -> do
    bsPtr <- Int -> IO (Ptr CUChar)
forall a. Int -> IO (Ptr a)
Foreign.mallocBytes (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
messageLength)
    memcpy bsPtr messagePtr messageLength
    unsafePackMallocCStringLen (Foreign.castPtr bsPtr :: Ptr CChar, fromIntegral messageLength)

-- | Combine a message and a signature into a 'SignedMessage'.
--
-- @since 0.0.1.0
mkSignature :: StrictByteString -> StrictByteString -> SignedMessage
mkSignature :: StrictByteString -> StrictByteString -> SignedMessage
mkSignature StrictByteString
message StrictByteString
signature = IO SignedMessage -> SignedMessage
forall a. IO a -> a
unsafeDupablePerformIO (IO SignedMessage -> SignedMessage)
-> IO SignedMessage -> SignedMessage
forall a b. (a -> b) -> a -> b
$
  StrictByteString
-> (CStringLen -> IO SignedMessage) -> IO SignedMessage
forall a. StrictByteString -> (CStringLen -> IO a) -> IO a
ByteString.unsafeUseAsCStringLen StrictByteString
message ((CStringLen -> IO SignedMessage) -> IO SignedMessage)
-> (CStringLen -> IO SignedMessage) -> IO SignedMessage
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
messageStringPtr, Int
messageLength) ->
    StrictByteString
-> (CStringLen -> IO SignedMessage) -> IO SignedMessage
forall a. StrictByteString -> (CStringLen -> IO a) -> IO a
ByteString.unsafeUseAsCStringLen StrictByteString
signature ((CStringLen -> IO SignedMessage) -> IO SignedMessage)
-> (CStringLen -> IO SignedMessage) -> IO SignedMessage
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
signatureStringPtr, Int
_) -> do
      (messageForeignPtr :: ForeignPtr CUChar) <- Int -> IO (ForeignPtr CUChar)
forall a. Int -> IO (ForeignPtr a)
Foreign.mallocForeignPtrBytes Int
messageLength
      signatureForeignPtr <- Foreign.mallocForeignPtrBytes (fromIntegral cryptoSignBytes)
      withForeignPtr messageForeignPtr $ \Ptr CUChar
messagePtr ->
        ForeignPtr CUChar -> (Ptr CUChar -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CUChar
signatureForeignPtr ((Ptr CUChar -> IO ()) -> IO ()) -> (Ptr CUChar -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CUChar
signaturePtr -> do
          Ptr CUChar -> Ptr CUChar -> Int -> IO ()
forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
Foreign.copyArray Ptr CUChar
messagePtr (Ptr CChar -> Ptr CUChar
forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr CChar
messageStringPtr) Int
messageLength
          Ptr CUChar -> Ptr CUChar -> Int -> IO ()
forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
Foreign.copyArray Ptr CUChar
signaturePtr (Ptr CChar -> Ptr CUChar
forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr CChar
signatureStringPtr) (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
cryptoSignBytes)
      pure $ SignedMessage (fromIntegral @Int @CSize messageLength) messageForeignPtr signatureForeignPtr