{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}

-- | Implementation of
-- [PASETO version 4](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version4.md)
-- (modern [Sodium](https://doc.libsodium.org/) cryptography).
--
-- Note that we're not actually using @libsodium@ itself in this module but,
-- instead, the equivalent algorithm implementations that are available in
-- @crypton@.
module Crypto.Paseto.Protocol.V4
  ( -- * Local purpose
    v4LocalTokenHeader
  , encrypt
  , encryptPure
  , DecryptionError (..)
  , renderDecryptionError
  , decrypt

    -- * Public purpose
  , v4PublicTokenHeader
  , sign
  , VerificationError (..)
  , renderVerificationError
  , verify
  ) where

import Control.Monad ( unless, when )
import qualified Crypto.Cipher.ChaCha as Crypto
import qualified Crypto.Error as Crypto
import qualified Crypto.Hash as Crypto
import qualified Crypto.MAC.KeyedBlake2 as Crypto
import Crypto.Paseto.Keys
  ( SigningKey (..), SymmetricKey (..), VerificationKey (..) )
import Crypto.Paseto.Mode ( Purpose (..), Version (..) )
import qualified Crypto.Paseto.PreAuthenticationEncoding as PAE
import Crypto.Paseto.Token
  ( Footer (..), ImplicitAssertion (..), Payload (..), Token (..) )
import Crypto.Paseto.Token.Claims ( Claims )
import qualified Crypto.PubKey.Ed25519 as Crypto
import qualified Crypto.Random as Crypto
import qualified Data.Aeson as Aeson
import Data.Bifunctor ( first )
import qualified Data.ByteArray as BA
import Data.ByteString ( ByteString )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import Data.Text ( Text )
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Prelude

------------------------------------------------------------------------------
-- Local purpose
------------------------------------------------------------------------------

v4LocalTokenHeader :: ByteString
v4LocalTokenHeader :: ByteString
v4LocalTokenHeader = ByteString
"v4.local."

encryptionKeyHkdfInfoPrefix :: ByteString
encryptionKeyHkdfInfoPrefix :: ByteString
encryptionKeyHkdfInfoPrefix = ByteString
"paseto-encryption-key"

authenticationKeyHkdfInfoPrefix :: ByteString
authenticationKeyHkdfInfoPrefix :: ByteString
authenticationKeyHkdfInfoPrefix = ByteString
"paseto-auth-key-for-aead"

-- | Pure variant of 'encrypt'.
--
-- For typical usage, please use 'encrypt'.
encryptPure
  :: ByteString
  -- ^ Random 32-byte nonce.
  --
  -- It is recommended to generate this from the operating system's CSPRNG.
  -> SymmetricKey V4
  -- ^ Symmetric key.
  -> Claims
  -- ^ Claims to be encrypted.
  -> Maybe Footer
  -- ^ Optional footer to authenticate and encode within the resulting token.
  -> Maybe ImplicitAssertion
  -- ^ Optional implicit assertion to authenticate.
  -> Token V4 Local
encryptPure :: ByteString
-> SymmetricKey 'V4
-> Claims
-> Maybe Footer
-> Maybe ImplicitAssertion
-> Token 'V4 'Local
encryptPure ByteString
n (SymmetricKeyV4 ScrubbedBytes32
k) Claims
cs Maybe Footer
f Maybe ImplicitAssertion
i =
  let h :: ByteString
      h :: ByteString
h = ByteString
v4LocalTokenHeader

      m :: ByteString
      m :: ByteString
m = ByteString -> ByteString
BS.toStrict (Claims -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Claims
cs)

      tmp :: Crypto.KeyedBlake2 (Crypto.Blake2b 448)
      tmp :: KeyedBlake2 (Blake2b 448)
tmp = ScrubbedBytes32 -> ByteString -> KeyedBlake2 (Blake2b 448)
forall a key ba.
(HashBlake2 a, ByteArrayAccess key, ByteArrayAccess ba) =>
key -> ba -> KeyedBlake2 a
Crypto.keyedBlake2 ScrubbedBytes32
k (ByteString
encryptionKeyHkdfInfoPrefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
n)

      ek :: ByteString
      n2 :: ByteString
      (ByteString
ek, ByteString
n2) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
32 (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ KeyedBlake2 (Blake2b 448) -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert KeyedBlake2 (Blake2b 448)
tmp

      ak :: Crypto.KeyedBlake2 (Crypto.Blake2b 256)
      ak :: KeyedBlake2 (Blake2b 256)
ak = ScrubbedBytes32 -> ByteString -> KeyedBlake2 (Blake2b 256)
forall a key ba.
(HashBlake2 a, ByteArrayAccess key, ByteArrayAccess ba) =>
key -> ba -> KeyedBlake2 a
Crypto.keyedBlake2 ScrubbedBytes32
k (ByteString
authenticationKeyHkdfInfoPrefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
n)

      xChaCha20St :: Crypto.State
      xChaCha20St :: State
xChaCha20St = Int -> ByteString -> ByteString -> State
forall key nonce.
(ByteArrayAccess key, ByteArrayAccess nonce) =>
Int -> key -> nonce -> State
Crypto.initializeX Int
20 ByteString
ek ByteString
n2

      c :: ByteString
      (ByteString
c, State
_) = State -> ByteString -> (ByteString, State)
forall ba. ByteArray ba => State -> ba -> (ba, State)
Crypto.combine State
xChaCha20St ByteString
m

      preAuth :: ByteString
      preAuth :: ByteString
preAuth = [ByteString] -> ByteString
PAE.encode [ByteString
h, ByteString
n, ByteString
c, ByteString -> (Footer -> ByteString) -> Maybe Footer -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
BS.empty Footer -> ByteString
unFooter Maybe Footer
f, ByteString
-> (ImplicitAssertion -> ByteString)
-> Maybe ImplicitAssertion
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
BS.empty ImplicitAssertion -> ByteString
unImplicitAssertion Maybe ImplicitAssertion
i]

      t :: Crypto.KeyedBlake2 (Crypto.Blake2b 256)
      t :: KeyedBlake2 (Blake2b 256)
t = ByteString -> ByteString -> KeyedBlake2 (Blake2b 256)
forall a key ba.
(HashBlake2 a, ByteArrayAccess key, ByteArrayAccess ba) =>
key -> ba -> KeyedBlake2 a
Crypto.keyedBlake2 (KeyedBlake2 (Blake2b 256) -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert KeyedBlake2 (Blake2b 256)
ak :: ByteString) ByteString
preAuth

      payload :: Payload
      payload :: Payload
payload = ByteString -> Payload
Payload (ByteString
n ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
c ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> KeyedBlake2 (Blake2b 256) -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert KeyedBlake2 (Blake2b 256)
t)

  in Payload -> Maybe Footer -> Token 'V4 'Local
TokenV4Local Payload
payload Maybe Footer
f

-- | [PASETO version 4 encryption](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version4.md#encrypt).
--
-- This is an authenticated encryption with associated data (AEAD)
-- algorithm which combines the @XChaCha20@ stream cipher with the @Blake2b@
-- message authentication code.
--
-- Note that this function essentially just calls 'encryptPure' with a random
-- 32-byte nonce generated from the operating system's CSPRNG.
encrypt
  :: SymmetricKey V4
  -- ^ Symmetric key.
  -> Claims
  -- ^ Claims to be encrypted.
  -> Maybe Footer
  -- ^ Optional footer to authenticate and encode within the resulting token.
  -> Maybe ImplicitAssertion
  -- ^ Optional implicit assertion to authenticate.
  -> IO (Token V4 Local)
encrypt :: SymmetricKey 'V4
-> Claims
-> Maybe Footer
-> Maybe ImplicitAssertion
-> IO (Token 'V4 'Local)
encrypt SymmetricKey 'V4
k Claims
cs Maybe Footer
f Maybe ImplicitAssertion
i = do
  ByteString
n <- Int -> IO ByteString
forall byteArray. ByteArray byteArray => Int -> IO byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
Crypto.getRandomBytes Int
32
  Token 'V4 'Local -> IO (Token 'V4 'Local)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
-> SymmetricKey 'V4
-> Claims
-> Maybe Footer
-> Maybe ImplicitAssertion
-> Token 'V4 'Local
encryptPure ByteString
n SymmetricKey 'V4
k Claims
cs Maybe Footer
f Maybe ImplicitAssertion
i)

-- | PASETO version 4 decryption error.
data DecryptionError
  = -- | Invalid token footer.
    DecryptionInvalidFooterError
      -- | Expected footer.
      !(Maybe Footer)
      -- | Actual footer.
      !(Maybe Footer)
  | -- | Invalid nonce size.
    DecryptionInvalidNonceSizeError !Int
  | -- | Invalid @Blake2b@ message authentication code size.
    DecryptionInvalidMacSizeError !Int
  | -- | Invalid @Blake2b@ message authenticartion code.
    DecryptionInvalidMacError
      -- | Expected MAC.
      !ByteString
      -- | Actual MAC.
      !ByteString
  | -- | Error deserializing a decrypted collection of claims as JSON.
    DecryptionClaimsDeserializationError !String
  deriving stock (Int -> DecryptionError -> ShowS
[DecryptionError] -> ShowS
DecryptionError -> String
(Int -> DecryptionError -> ShowS)
-> (DecryptionError -> String)
-> ([DecryptionError] -> ShowS)
-> Show DecryptionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecryptionError -> ShowS
showsPrec :: Int -> DecryptionError -> ShowS
$cshow :: DecryptionError -> String
show :: DecryptionError -> String
$cshowList :: [DecryptionError] -> ShowS
showList :: [DecryptionError] -> ShowS
Show, DecryptionError -> DecryptionError -> Bool
(DecryptionError -> DecryptionError -> Bool)
-> (DecryptionError -> DecryptionError -> Bool)
-> Eq DecryptionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecryptionError -> DecryptionError -> Bool
== :: DecryptionError -> DecryptionError -> Bool
$c/= :: DecryptionError -> DecryptionError -> Bool
/= :: DecryptionError -> DecryptionError -> Bool
Eq)

-- | Render a 'DecryptionError' as 'Text'.
renderDecryptionError :: DecryptionError -> Text
renderDecryptionError :: DecryptionError -> Text
renderDecryptionError DecryptionError
err =
  case DecryptionError
err of
    DecryptionInvalidFooterError Maybe Footer
_ Maybe Footer
_ ->
      -- Since a footer could potentially be very long or some kind of
      -- illegible structured data, we're not going to attempt to render those
      -- values here.
      Text
"Token has an invalid footer."
    DecryptionInvalidNonceSizeError Int
actual ->
      Text
"Expected nonce with a size of 32, but it was "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
actual)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
    DecryptionInvalidMacSizeError Int
actual ->
      Text
"Expected MAC with a size of 32, but it was "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
actual)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
    DecryptionInvalidMacError ByteString
expected ByteString
actual ->
      Text
"Expected MAC value of "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
TE.decodeUtf8 (ByteString -> ByteString
B16.encode ByteString
expected)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", but encountered "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
TE.decodeUtf8 (ByteString -> ByteString
B16.encode ByteString
actual)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
    DecryptionClaimsDeserializationError String
e ->
      Text
"Error deserializing claims from JSON: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ShowS
forall a. Show a => a -> String
show String
e)

-- | [PASETO version 4 decryption](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version4.md#decrypt).
decrypt
  :: SymmetricKey V4
  -- ^ Symmetric key.
  -> Token V4 Local
  -- ^ Token to decrypt.
  -> Maybe Footer
  -- ^ Optional footer to authenticate.
  -> Maybe ImplicitAssertion
  -- ^ Optional implicit assertion to authenticate.
  -> Either DecryptionError Claims
decrypt :: SymmetricKey 'V4
-> Token 'V4 'Local
-> Maybe Footer
-> Maybe ImplicitAssertion
-> Either DecryptionError Claims
decrypt (SymmetricKeyV4 ScrubbedBytes32
k) (TokenV4Local (Payload ByteString
m) Maybe Footer
actualF) Maybe Footer
expectedF Maybe ImplicitAssertion
i = do
  let h :: ByteString
      h :: ByteString
h = ByteString
v4LocalTokenHeader

  -- Check that the actual footer matches the provided expected footer.
  Bool -> Either DecryptionError () -> Either DecryptionError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Footer
expectedF Maybe Footer -> Maybe Footer -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Footer
actualF) (DecryptionError -> Either DecryptionError ()
forall a b. a -> Either a b
Left (DecryptionError -> Either DecryptionError ())
-> DecryptionError -> Either DecryptionError ()
forall a b. (a -> b) -> a -> b
$ Maybe Footer -> Maybe Footer -> DecryptionError
DecryptionInvalidFooterError Maybe Footer
expectedF Maybe Footer
actualF)

  let n :: ByteString
      n :: ByteString
n = Int -> ByteString -> ByteString
BS.take Int
32 ByteString
m

      nLen :: Int
      nLen :: Int
nLen = ByteString -> Int
BS.length ByteString
n

      tBs :: ByteString
      tBs :: ByteString
tBs = Int -> ByteString -> ByteString
BS.takeEnd Int
32 ByteString
m

      mbT :: Maybe (Crypto.KeyedBlake2 (Crypto.Blake2b 256))
      mbT :: Maybe (KeyedBlake2 (Blake2b 256))
mbT = Digest (Blake2b 256) -> KeyedBlake2 (Blake2b 256)
forall a. Digest a -> KeyedBlake2 a
Crypto.KeyedBlake2 (Digest (Blake2b 256) -> KeyedBlake2 (Blake2b 256))
-> Maybe (Digest (Blake2b 256))
-> Maybe (KeyedBlake2 (Blake2b 256))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe (Digest (Blake2b 256))
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
Crypto.digestFromByteString ByteString
tBs

      c :: ByteString
      c :: ByteString
c = Int -> ByteString -> ByteString
BS.dropEnd Int
32 (Int -> ByteString -> ByteString
BS.drop Int
32 ByteString
m)

  Bool -> Either DecryptionError () -> Either DecryptionError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
nLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
32) (DecryptionError -> Either DecryptionError ()
forall a b. a -> Either a b
Left (DecryptionError -> Either DecryptionError ())
-> DecryptionError -> Either DecryptionError ()
forall a b. (a -> b) -> a -> b
$ Int -> DecryptionError
DecryptionInvalidNonceSizeError Int
nLen)

  KeyedBlake2 (Blake2b 256)
t <-
    case Maybe (KeyedBlake2 (Blake2b 256))
mbT of
      Maybe (KeyedBlake2 (Blake2b 256))
Nothing -> DecryptionError
-> Either DecryptionError (KeyedBlake2 (Blake2b 256))
forall a b. a -> Either a b
Left (Int -> DecryptionError
DecryptionInvalidMacSizeError (Int -> DecryptionError) -> Int -> DecryptionError
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
tBs)
      Just KeyedBlake2 (Blake2b 256)
x -> KeyedBlake2 (Blake2b 256)
-> Either DecryptionError (KeyedBlake2 (Blake2b 256))
forall a b. b -> Either a b
Right KeyedBlake2 (Blake2b 256)
x

  let tmp :: Crypto.KeyedBlake2 (Crypto.Blake2b 448)
      tmp :: KeyedBlake2 (Blake2b 448)
tmp = ScrubbedBytes32 -> ByteString -> KeyedBlake2 (Blake2b 448)
forall a key ba.
(HashBlake2 a, ByteArrayAccess key, ByteArrayAccess ba) =>
key -> ba -> KeyedBlake2 a
Crypto.keyedBlake2 ScrubbedBytes32
k (ByteString
encryptionKeyHkdfInfoPrefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
n)

      ek :: ByteString
      n2 :: ByteString
      (ByteString
ek, ByteString
n2) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
32 (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ KeyedBlake2 (Blake2b 448) -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert KeyedBlake2 (Blake2b 448)
tmp

      ak :: Crypto.KeyedBlake2 (Crypto.Blake2b 256)
      ak :: KeyedBlake2 (Blake2b 256)
ak = ScrubbedBytes32 -> ByteString -> KeyedBlake2 (Blake2b 256)
forall a key ba.
(HashBlake2 a, ByteArrayAccess key, ByteArrayAccess ba) =>
key -> ba -> KeyedBlake2 a
Crypto.keyedBlake2 ScrubbedBytes32
k (ByteString
authenticationKeyHkdfInfoPrefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
n)

      preAuth :: ByteString
      preAuth :: ByteString
preAuth = [ByteString] -> ByteString
PAE.encode [ByteString
h, ByteString
n, ByteString
c, ByteString -> (Footer -> ByteString) -> Maybe Footer -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
BS.empty Footer -> ByteString
unFooter Maybe Footer
actualF, ByteString
-> (ImplicitAssertion -> ByteString)
-> Maybe ImplicitAssertion
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
BS.empty ImplicitAssertion -> ByteString
unImplicitAssertion Maybe ImplicitAssertion
i]

      t2 :: Crypto.KeyedBlake2 (Crypto.Blake2b 256)
      t2 :: KeyedBlake2 (Blake2b 256)
t2 = ByteString -> ByteString -> KeyedBlake2 (Blake2b 256)
forall a key ba.
(HashBlake2 a, ByteArrayAccess key, ByteArrayAccess ba) =>
key -> ba -> KeyedBlake2 a
Crypto.keyedBlake2 (KeyedBlake2 (Blake2b 256) -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert KeyedBlake2 (Blake2b 256)
ak :: ByteString) ByteString
preAuth

  -- The 'Crypto.KeyedBlake2' 'Eq' instance performs a constant-time equality check.
  Bool -> Either DecryptionError () -> Either DecryptionError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeyedBlake2 (Blake2b 256)
t2 KeyedBlake2 (Blake2b 256) -> KeyedBlake2 (Blake2b 256) -> Bool
forall a. Eq a => a -> a -> Bool
/= KeyedBlake2 (Blake2b 256)
t) (DecryptionError -> Either DecryptionError ()
forall a b. a -> Either a b
Left (DecryptionError -> Either DecryptionError ())
-> DecryptionError -> Either DecryptionError ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> DecryptionError
DecryptionInvalidMacError (KeyedBlake2 (Blake2b 256) -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert KeyedBlake2 (Blake2b 256)
t2) (KeyedBlake2 (Blake2b 256) -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert KeyedBlake2 (Blake2b 256)
t))

  let xChaCha20St :: Crypto.State
      xChaCha20St :: State
xChaCha20St = Int -> ByteString -> ByteString -> State
forall key nonce.
(ByteArrayAccess key, ByteArrayAccess nonce) =>
Int -> key -> nonce -> State
Crypto.initializeX Int
20 ByteString
ek ByteString
n2

      decrypted :: ByteString
      (ByteString
decrypted, State
_) = State -> ByteString -> (ByteString, State)
forall ba. ByteArray ba => State -> ba -> (ba, State)
Crypto.combine State
xChaCha20St ByteString
c

  -- Deserialize the raw decrypted bytes as a JSON object of claims.
  (String -> DecryptionError)
-> Either String Claims -> Either DecryptionError Claims
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> DecryptionError
DecryptionClaimsDeserializationError (ByteString -> Either String Claims
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict ByteString
decrypted)

------------------------------------------------------------------------------
-- Public purpose
------------------------------------------------------------------------------

v4PublicTokenHeader :: ByteString
v4PublicTokenHeader :: ByteString
v4PublicTokenHeader = ByteString
"v4.public."

-- | [PASETO version 4 cryptographic signing](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version4.md#sign).
--
-- This implementation produces a token which is signed using @Ed25519@.
sign
  :: SigningKey V4
  -- ^ Signing key.
  -> Claims
  -- ^ Claims to be signed.
  -> Maybe Footer
  -- ^ Optional footer to authenticate and encode within the resulting token.
  -> Maybe ImplicitAssertion
  -- ^ Optional implicit assertion to authenticate.
  -> Token V4 Public
sign :: SigningKey 'V4
-> Claims
-> Maybe Footer
-> Maybe ImplicitAssertion
-> Token 'V4 'Public
sign (SigningKeyV4 SecretKey
sk) Claims
cs Maybe Footer
f Maybe ImplicitAssertion
i =
  let h :: ByteString
      h :: ByteString
h = ByteString
v4PublicTokenHeader

      m :: ByteString
      m :: ByteString
m = ByteString -> ByteString
BS.toStrict (Claims -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Claims
cs)

      m2 :: ByteString
      m2 :: ByteString
m2 = [ByteString] -> ByteString
PAE.encode [ByteString
h, ByteString
m, ByteString -> (Footer -> ByteString) -> Maybe Footer -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
BS.empty Footer -> ByteString
unFooter Maybe Footer
f, ByteString
-> (ImplicitAssertion -> ByteString)
-> Maybe ImplicitAssertion
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
BS.empty ImplicitAssertion -> ByteString
unImplicitAssertion Maybe ImplicitAssertion
i]

      sig :: Crypto.Signature
      sig :: Signature
sig = SecretKey -> PublicKey -> ByteString -> Signature
forall ba.
ByteArrayAccess ba =>
SecretKey -> PublicKey -> ba -> Signature
Crypto.sign SecretKey
sk (SecretKey -> PublicKey
Crypto.toPublic SecretKey
sk) ByteString
m2

      payload :: Payload
      payload :: Payload
payload = ByteString -> Payload
Payload (ByteString
m ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Signature -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert Signature
sig)

  in Payload -> Maybe Footer -> Token 'V4 'Public
TokenV4Public Payload
payload Maybe Footer
f

-- | PASETO version 4 signature verification error.
data VerificationError
  = -- | Invalid token footer.
    VerificationInvalidFooterError
      -- | Expected footer.
      !(Maybe Footer)
      -- | Actual footer.
      !(Maybe Footer)
  | -- | 'Crypto.CryptoError' that occurred during verification.
    VerificationCryptoError !Crypto.CryptoError
  | -- | Signature verification failed.
    VerificationInvalidSignatureError
  | -- | Error deserializing a verified collection of claims as JSON.
    VerificationClaimsDeserializationError !String
  deriving (Int -> VerificationError -> ShowS
[VerificationError] -> ShowS
VerificationError -> String
(Int -> VerificationError -> ShowS)
-> (VerificationError -> String)
-> ([VerificationError] -> ShowS)
-> Show VerificationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VerificationError -> ShowS
showsPrec :: Int -> VerificationError -> ShowS
$cshow :: VerificationError -> String
show :: VerificationError -> String
$cshowList :: [VerificationError] -> ShowS
showList :: [VerificationError] -> ShowS
Show, VerificationError -> VerificationError -> Bool
(VerificationError -> VerificationError -> Bool)
-> (VerificationError -> VerificationError -> Bool)
-> Eq VerificationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VerificationError -> VerificationError -> Bool
== :: VerificationError -> VerificationError -> Bool
$c/= :: VerificationError -> VerificationError -> Bool
/= :: VerificationError -> VerificationError -> Bool
Eq)

-- | Render a 'VerificationError' as 'Text'.
renderVerificationError :: VerificationError -> Text
renderVerificationError :: VerificationError -> Text
renderVerificationError VerificationError
err =
  case VerificationError
err of
    VerificationInvalidFooterError Maybe Footer
_ Maybe Footer
_ ->
      -- Since a footer could potentially be very long or some kind of
      -- illegible structured data, we're not going to attempt to render those
      -- values here.
      Text
"Token has an invalid footer."
    VerificationCryptoError CryptoError
e ->
      Text
"Encountered a cryptographic error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (CryptoError -> String
forall a. Show a => a -> String
show CryptoError
e)
    VerificationError
VerificationInvalidSignatureError -> Text
"Signature is invalid."
    VerificationClaimsDeserializationError String
e ->
      Text
"Error deserializing claims from JSON: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ShowS
forall a. Show a => a -> String
show String
e)

-- | [PASETO version 4 cryptographic signature verification](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version4.md#verify).
verify
  :: VerificationKey V4
  -- ^ Verification key.
  -> Token V4 Public
  -- ^ Token to verify.
  -> Maybe Footer
  -- ^ Optional footer to authenticate.
  -> Maybe ImplicitAssertion
  -- ^ Optional implicit assertion to authenticate.
  -> Either VerificationError Claims
verify :: VerificationKey 'V4
-> Token 'V4 'Public
-> Maybe Footer
-> Maybe ImplicitAssertion
-> Either VerificationError Claims
verify (VerificationKeyV4 PublicKey
vk) (TokenV4Public (Payload ByteString
sm) Maybe Footer
actualF) Maybe Footer
expectedF Maybe ImplicitAssertion
i = do
  let h :: ByteString
      h :: ByteString
h = ByteString
v4PublicTokenHeader

  -- Check that the actual footer matches the provided expected footer.
  Bool -> Either VerificationError () -> Either VerificationError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Footer
expectedF Maybe Footer -> Maybe Footer -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Footer
actualF) (VerificationError -> Either VerificationError ()
forall a b. a -> Either a b
Left (VerificationError -> Either VerificationError ())
-> VerificationError -> Either VerificationError ()
forall a b. (a -> b) -> a -> b
$ Maybe Footer -> Maybe Footer -> VerificationError
VerificationInvalidFooterError Maybe Footer
expectedF Maybe Footer
actualF)

  Signature
s <-
    (CryptoError -> VerificationError)
-> Either CryptoError Signature
-> Either VerificationError Signature
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first CryptoError -> VerificationError
VerificationCryptoError
      (Either CryptoError Signature
 -> Either VerificationError Signature)
-> (CryptoFailable Signature -> Either CryptoError Signature)
-> CryptoFailable Signature
-> Either VerificationError Signature
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoFailable Signature -> Either CryptoError Signature
forall a. CryptoFailable a -> Either CryptoError a
Crypto.eitherCryptoError
      (CryptoFailable Signature -> Either VerificationError Signature)
-> CryptoFailable Signature -> Either VerificationError Signature
forall a b. (a -> b) -> a -> b
$ ByteString -> CryptoFailable Signature
forall ba. ByteArrayAccess ba => ba -> CryptoFailable Signature
Crypto.signature (Int -> ByteString -> ByteString
BS.takeEnd Int
64 ByteString
sm)

  let m :: ByteString
      m :: ByteString
m = Int -> ByteString -> ByteString
BS.dropEnd Int
64 ByteString
sm

      m2 :: ByteString
      m2 :: ByteString
m2 = [ByteString] -> ByteString
PAE.encode [ByteString
h, ByteString
m, ByteString -> (Footer -> ByteString) -> Maybe Footer -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
BS.empty Footer -> ByteString
unFooter Maybe Footer
actualF, ByteString
-> (ImplicitAssertion -> ByteString)
-> Maybe ImplicitAssertion
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
BS.empty ImplicitAssertion -> ByteString
unImplicitAssertion Maybe ImplicitAssertion
i]

  Bool -> Either VerificationError () -> Either VerificationError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
    (PublicKey -> ByteString -> Signature -> Bool
forall ba.
ByteArrayAccess ba =>
PublicKey -> ba -> Signature -> Bool
Crypto.verify PublicKey
vk ByteString
m2 Signature
s)
    (VerificationError -> Either VerificationError ()
forall a b. a -> Either a b
Left VerificationError
VerificationInvalidSignatureError)

  (String -> VerificationError)
-> Either String Claims -> Either VerificationError Claims
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> VerificationError
VerificationClaimsDeserializationError (ByteString -> Either String Claims
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict ByteString
m)