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

-- | Implementation of
-- [PASETO version 3](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version3.md)
-- (modern NIST cryptography).
module Crypto.Paseto.Protocol.V3
  ( -- * Local purpose
    v3LocalTokenHeader
  , EncryptionError (..)
  , renderEncryptionError
  , encrypt
  , encryptPure
  , DecryptionError (..)
  , renderDecryptionError
  , decrypt

    -- * Public purpose
  , v3PublicTokenHeader
  , SigningError (..)
  , renderSigningError
  , sign
  , signPure
  , VerificationError (..)
  , renderVerificationError
  , verify
  ) where

import Control.Monad ( unless, when )
import Control.Monad.Except ( ExceptT )
import Control.Monad.IO.Class ( liftIO )
import Control.Monad.Trans.Except.Extra ( hoistEither )
import qualified Crypto.Cipher.AES as Crypto
import qualified Crypto.Cipher.Types as Crypto
import qualified Crypto.Error as Crypto
import qualified Crypto.Hash as Crypto
import qualified Crypto.KDF.HKDF as Crypto
import qualified Crypto.MAC.HMAC as Crypto
import Crypto.Paseto.Keys
  ( SigningKey (..)
  , SymmetricKey (..)
  , VerificationKey (..)
  , fromSigningKey
  , verificationKeyToBytes
  )
import Crypto.Paseto.Keys.V3
  ( PrivateKeyP384 (..)
  , PublicKeyP384 (..)
  , generateScalarP384
  , isScalarValidP384
  )
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.ECC.ECDSA as Crypto
import qualified Crypto.Random as Crypto
import qualified Data.Aeson as Aeson
import Data.Bifunctor ( first )
import Data.Binary.Put ( runPut )
import Data.Binary.Put.Integer ( putIntegerbe )
import Data.Bits ( shiftL, (.|.) )
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

maybeToEither :: a -> Maybe b -> Either a b
maybeToEither :: forall a b. a -> Maybe b -> Either a b
maybeToEither a
_ (Just b
b) = b -> Either a b
forall a b. b -> Either a b
Right b
b
maybeToEither a
a Maybe b
Nothing = a -> Either a b
forall a b. a -> Either a b
Left a
a

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

v3LocalTokenHeader :: ByteString
v3LocalTokenHeader :: ByteString
v3LocalTokenHeader = ByteString
"v3.local."

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

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

mkAes256Cipher :: ByteString -> Either Crypto.CryptoError Crypto.AES256
mkAes256Cipher :: ByteString -> Either CryptoError AES256
mkAes256Cipher ByteString
ek = CryptoFailable AES256 -> Either CryptoError AES256
forall a. CryptoFailable a -> Either CryptoError a
Crypto.eitherCryptoError (ByteString -> CryptoFailable AES256
forall cipher key.
(Cipher cipher, ByteArray key) =>
key -> CryptoFailable cipher
forall key. ByteArray key => key -> CryptoFailable AES256
Crypto.cipherInit ByteString
ek)

-- | PASETO version 3 encryption error.
data EncryptionError
  = -- | 'Crypto.CryptoError' that occurred during encryption.
    EncryptionCryptoError !Crypto.CryptoError
  | -- | Initialization vector is of an invalid size.
    EncryptionInvalidInitializationVectorSizeError
      -- | Expected size.
      !Int
      -- | Actual size.
      !Int
  deriving stock (Int -> EncryptionError -> ShowS
[EncryptionError] -> ShowS
EncryptionError -> String
(Int -> EncryptionError -> ShowS)
-> (EncryptionError -> String)
-> ([EncryptionError] -> ShowS)
-> Show EncryptionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EncryptionError -> ShowS
showsPrec :: Int -> EncryptionError -> ShowS
$cshow :: EncryptionError -> String
show :: EncryptionError -> String
$cshowList :: [EncryptionError] -> ShowS
showList :: [EncryptionError] -> ShowS
Show, EncryptionError -> EncryptionError -> Bool
(EncryptionError -> EncryptionError -> Bool)
-> (EncryptionError -> EncryptionError -> Bool)
-> Eq EncryptionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EncryptionError -> EncryptionError -> Bool
== :: EncryptionError -> EncryptionError -> Bool
$c/= :: EncryptionError -> EncryptionError -> Bool
/= :: EncryptionError -> EncryptionError -> Bool
Eq)

-- | Render an 'EncryptionError' as 'Text'.
renderEncryptionError :: EncryptionError -> Text
renderEncryptionError :: EncryptionError -> Text
renderEncryptionError EncryptionError
err =
  case EncryptionError
err of
    EncryptionCryptoError 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)
    EncryptionInvalidInitializationVectorSizeError Int
expected Int
actual ->
      Text
"Initialization vector length is expected to be "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
expected)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 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
"."

-- | 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 V3
  -- ^ 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.
  -> Either EncryptionError (Token V3 Local)
encryptPure :: ByteString
-> SymmetricKey 'V3
-> Claims
-> Maybe Footer
-> Maybe ImplicitAssertion
-> Either EncryptionError (Token 'V3 'Local)
encryptPure ByteString
n (SymmetricKeyV3 ScrubbedBytes32
k) Claims
cs Maybe Footer
f Maybe ImplicitAssertion
i = do
  let h :: ByteString
      h :: ByteString
h = ByteString
v3LocalTokenHeader

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

      prk :: Crypto.PRK Crypto.SHA384
      prk :: PRK SHA384
prk = ByteString -> ScrubbedBytes32 -> PRK SHA384
forall a salt ikm.
(HashAlgorithm a, ByteArrayAccess salt, ByteArrayAccess ikm) =>
salt -> ikm -> PRK a
Crypto.extract ByteString
BS.empty ScrubbedBytes32
k

      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
$ PRK SHA384 -> ByteString -> Int -> ByteString
forall a info out.
(HashAlgorithm a, ByteArrayAccess info, ByteArray out) =>
PRK a -> info -> Int -> out
Crypto.expand PRK SHA384
prk (ByteString
encryptionKeyHkdfInfoPrefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
n) Int
48

      ak :: ByteString
      ak :: ByteString
ak = PRK SHA384 -> ByteString -> Int -> ByteString
forall a info out.
(HashAlgorithm a, ByteArrayAccess info, ByteArray out) =>
PRK a -> info -> Int -> out
Crypto.expand PRK SHA384
prk (ByteString
authenticationKeyHkdfInfoPrefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
n) Int
48

  AES256
aes256 <- (CryptoError -> EncryptionError)
-> Either CryptoError AES256 -> Either EncryptionError AES256
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 -> EncryptionError
EncryptionCryptoError (ByteString -> Either CryptoError AES256
mkAes256Cipher ByteString
ek)
  IV AES256
iv <-
    EncryptionError
-> Maybe (IV AES256) -> Either EncryptionError (IV AES256)
forall a b. a -> Maybe b -> Either a b
maybeToEither
      (Int -> Int -> EncryptionError
EncryptionInvalidInitializationVectorSizeError (AES256 -> Int
forall cipher. BlockCipher cipher => cipher -> Int
Crypto.blockSize AES256
aes256) (ByteString -> Int
BS.length ByteString
n2))
      (ByteString -> Maybe (IV AES256)
forall b c. (ByteArrayAccess b, BlockCipher c) => b -> Maybe (IV c)
Crypto.makeIV ByteString
n2)
  let c :: ByteString
      c :: ByteString
c = AES256 -> IV AES256 -> ByteString -> ByteString
forall cipher ba.
(BlockCipher cipher, ByteArray ba) =>
cipher -> IV cipher -> ba -> ba
forall ba. ByteArray ba => AES256 -> IV AES256 -> ba -> ba
Crypto.ctrCombine AES256
aes256 IV AES256
iv 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.HMAC Crypto.SHA384
      t :: HMAC SHA384
t = ByteString -> ByteString -> HMAC SHA384
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
Crypto.hmac ByteString
ak 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
<> HMAC SHA384 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert HMAC SHA384
t)

  Token 'V3 'Local -> Either EncryptionError (Token 'V3 'Local)
forall a. a -> Either EncryptionError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token 'V3 'Local -> Either EncryptionError (Token 'V3 'Local))
-> Token 'V3 'Local -> Either EncryptionError (Token 'V3 'Local)
forall a b. (a -> b) -> a -> b
$ Payload -> Maybe Footer -> Token 'V3 'Local
TokenV3Local Payload
payload Maybe Footer
f

-- | [PASETO version 3 encryption](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version3.md#encrypt).
--
-- This is an authenticated encryption with associated data (AEAD)
-- algorithm which combines the @AES-256-CTR@ block cipher with the
-- @HMAC-SHA384@ 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 V3
  -- ^ 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.
  -> ExceptT EncryptionError IO (Token V3 Local)
encrypt :: SymmetricKey 'V3
-> Claims
-> Maybe Footer
-> Maybe ImplicitAssertion
-> ExceptT EncryptionError IO (Token 'V3 'Local)
encrypt SymmetricKey 'V3
k Claims
cs Maybe Footer
f Maybe ImplicitAssertion
i = do
  ByteString
n <- IO ByteString -> ExceptT EncryptionError IO ByteString
forall a. IO a -> ExceptT EncryptionError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ByteString
forall byteArray. ByteArray byteArray => Int -> IO byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
Crypto.getRandomBytes Int
32 :: IO ByteString)
  Either EncryptionError (Token 'V3 'Local)
-> ExceptT EncryptionError IO (Token 'V3 'Local)
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither (ByteString
-> SymmetricKey 'V3
-> Claims
-> Maybe Footer
-> Maybe ImplicitAssertion
-> Either EncryptionError (Token 'V3 'Local)
encryptPure ByteString
n SymmetricKey 'V3
k Claims
cs Maybe Footer
f Maybe ImplicitAssertion
i)

-- | PASETO version 3 decryption error.
data DecryptionError
  = -- | Invalid token footer.
    DecryptionInvalidFooterError
      -- | Expected footer.
      !(Maybe Footer)
      -- | Actual footer.
      !(Maybe Footer)
  | -- | Invalid @HKDF-HMAC-SHA384@ nonce size.
    DecryptionInvalidHkdfNonceSizeError !Int
  | -- | Invalid @HMAC-SHA384@ message authentication code size.
    DecryptionInvalidHmacSizeError !Int
  | -- | Invalid @HMAC-SHA384@ message authentication code.
    DecryptionInvalidHmacError
      -- | Expected HMAC.
      !ByteString
      -- | Actual HMAC.
      !ByteString
  | -- | 'Crypto.CryptoError' that occurred during decryption.
    DecryptionCryptoError !Crypto.CryptoError
  | -- | Initialization vector is of an invalid size.
    DecryptionInvalidInitializationVectorSizeError
      -- | Expected size.
      !Int
      -- | Actual size.
      !Int
  | -- | 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."
    DecryptionInvalidHkdfNonceSizeError 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
"."
    DecryptionInvalidHmacSizeError Int
actual ->
      Text
"Expected HMAC with a size of 48, 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
"."
    DecryptionInvalidHmacError ByteString
expected ByteString
actual ->
      Text
"Expected HMAC 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
"."
    DecryptionCryptoError 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)
    DecryptionInvalidInitializationVectorSizeError Int
expected Int
actual ->
      Text
"Initialization vector length is expected to be "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
expected)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", 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
"."
    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 3 decryption](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version3.md#decrypt).
decrypt
  :: SymmetricKey V3
  -- ^ Symmetric key.
  -> Token V3 Local
  -- ^ Token to decrypt.
  -> Maybe Footer
  -- ^ Optional footer to authenticate.
  -> Maybe ImplicitAssertion
  -- ^ Optional implicit assertion to authenticate.
  -> Either DecryptionError Claims
decrypt :: SymmetricKey 'V3
-> Token 'V3 'Local
-> Maybe Footer
-> Maybe ImplicitAssertion
-> Either DecryptionError Claims
decrypt (SymmetricKeyV3 ScrubbedBytes32
k) (TokenV3Local (Payload ByteString
m) Maybe Footer
actualF) Maybe Footer
expectedF Maybe ImplicitAssertion
i = do
  let h :: ByteString
      h :: ByteString
h = ByteString
v3LocalTokenHeader

  -- 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
48 ByteString
m

      mbT :: Maybe (Crypto.HMAC Crypto.SHA384)
      mbT :: Maybe (HMAC SHA384)
mbT = Digest SHA384 -> HMAC SHA384
forall a. Digest a -> HMAC a
Crypto.HMAC (Digest SHA384 -> HMAC SHA384)
-> Maybe (Digest SHA384) -> Maybe (HMAC SHA384)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe (Digest SHA384)
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
48 (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
DecryptionInvalidHkdfNonceSizeError Int
nLen)

  HMAC SHA384
t <-
    case Maybe (HMAC SHA384)
mbT of
      Maybe (HMAC SHA384)
Nothing -> DecryptionError -> Either DecryptionError (HMAC SHA384)
forall a b. a -> Either a b
Left (Int -> DecryptionError
DecryptionInvalidHmacSizeError (Int -> DecryptionError) -> Int -> DecryptionError
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
tBs)
      Just HMAC SHA384
x -> HMAC SHA384 -> Either DecryptionError (HMAC SHA384)
forall a b. b -> Either a b
Right HMAC SHA384
x

  let prk :: Crypto.PRK Crypto.SHA384
      prk :: PRK SHA384
prk = ByteString -> ScrubbedBytes32 -> PRK SHA384
forall a salt ikm.
(HashAlgorithm a, ByteArrayAccess salt, ByteArrayAccess ikm) =>
salt -> ikm -> PRK a
Crypto.extract ByteString
BS.empty ScrubbedBytes32
k

      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
$ PRK SHA384 -> ByteString -> Int -> ByteString
forall a info out.
(HashAlgorithm a, ByteArrayAccess info, ByteArray out) =>
PRK a -> info -> Int -> out
Crypto.expand PRK SHA384
prk (ByteString
encryptionKeyHkdfInfoPrefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
n) Int
48

      ak :: ByteString
      ak :: ByteString
ak = PRK SHA384 -> ByteString -> Int -> ByteString
forall a info out.
(HashAlgorithm a, ByteArrayAccess info, ByteArray out) =>
PRK a -> info -> Int -> out
Crypto.expand PRK SHA384
prk (ByteString
authenticationKeyHkdfInfoPrefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
n) Int
48

      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.HMAC Crypto.SHA384
      t2 :: HMAC SHA384
t2 = ByteString -> ByteString -> HMAC SHA384
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
Crypto.hmac ByteString
ak ByteString
preAuth

  -- The 'Crypto.HMAC' 'Eq' instance performs a constant-time equality check.
  Bool -> Either DecryptionError () -> Either DecryptionError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HMAC SHA384
t2 HMAC SHA384 -> HMAC SHA384 -> Bool
forall a. Eq a => a -> a -> Bool
/= HMAC SHA384
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
DecryptionInvalidHmacError (HMAC SHA384 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert HMAC SHA384
t2) (HMAC SHA384 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert HMAC SHA384
t))

  AES256
aes256 <- (CryptoError -> DecryptionError)
-> Either CryptoError AES256 -> Either DecryptionError AES256
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 -> DecryptionError
DecryptionCryptoError (ByteString -> Either CryptoError AES256
mkAes256Cipher ByteString
ek)
  IV AES256
iv <-
    DecryptionError
-> Maybe (IV AES256) -> Either DecryptionError (IV AES256)
forall a b. a -> Maybe b -> Either a b
maybeToEither
      (Int -> Int -> DecryptionError
DecryptionInvalidInitializationVectorSizeError (AES256 -> Int
forall cipher. BlockCipher cipher => cipher -> Int
Crypto.blockSize AES256
aes256) (ByteString -> Int
BS.length ByteString
n2))
      (ByteString -> Maybe (IV AES256)
forall b c. (ByteArrayAccess b, BlockCipher c) => b -> Maybe (IV c)
Crypto.makeIV ByteString
n2)
  let decrypted :: ByteString
      decrypted :: ByteString
decrypted = AES256 -> IV AES256 -> ByteString -> ByteString
forall cipher ba.
(BlockCipher cipher, ByteArray ba) =>
cipher -> IV cipher -> ba -> ba
forall ba. ByteArray ba => AES256 -> IV AES256 -> ba -> ba
Crypto.ctrCombine AES256
aes256 IV AES256
iv 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
------------------------------------------------------------------------------

v3PublicTokenHeader :: ByteString
v3PublicTokenHeader :: ByteString
v3PublicTokenHeader = ByteString
"v3.public."

-- | PASETO version 3 cryptographic signing error.
data SigningError
  = -- | Random number, @k@, is zero.
    SigningKIsZeroError
  deriving (Int -> SigningError -> ShowS
[SigningError] -> ShowS
SigningError -> String
(Int -> SigningError -> ShowS)
-> (SigningError -> String)
-> ([SigningError] -> ShowS)
-> Show SigningError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SigningError -> ShowS
showsPrec :: Int -> SigningError -> ShowS
$cshow :: SigningError -> String
show :: SigningError -> String
$cshowList :: [SigningError] -> ShowS
showList :: [SigningError] -> ShowS
Show, SigningError -> SigningError -> Bool
(SigningError -> SigningError -> Bool)
-> (SigningError -> SigningError -> Bool) -> Eq SigningError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SigningError -> SigningError -> Bool
== :: SigningError -> SigningError -> Bool
$c/= :: SigningError -> SigningError -> Bool
/= :: SigningError -> SigningError -> Bool
Eq)

-- | Render a 'SigningError' as 'Text'.
renderSigningError :: SigningError -> Text
renderSigningError :: SigningError -> Text
renderSigningError SigningError
err =
  case SigningError
err of
    SigningError
SigningKIsZeroError -> Text
"Parameter k is 0."

-- | Pure variant of 'sign'.
--
-- For typical usage, please use 'sign'.
signPure
  :: Integer
  -- ^ Explicit @k@ scalar.
  -> SigningKey V3
  -- ^ 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.
  -> Either SigningError (Token V3 Public)
signPure :: Integer
-> SigningKey 'V3
-> Claims
-> Maybe Footer
-> Maybe ImplicitAssertion
-> Either SigningError (Token 'V3 'Public)
signPure Integer
k signingKey :: SigningKey 'V3
signingKey@(SigningKeyV3 (PrivateKeyP384 PrivateKey
sk)) Claims
cs Maybe Footer
f Maybe ImplicitAssertion
i = do
  let h :: ByteString
      h :: ByteString
h = ByteString
v3PublicTokenHeader

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

      vk :: VerificationKey V3
      vk :: VerificationKey 'V3
vk = SigningKey 'V3 -> VerificationKey 'V3
forall (v :: Version). SigningKey v -> VerificationKey v
fromSigningKey SigningKey 'V3
signingKey

      m2 :: ByteString
      m2 :: ByteString
m2 = [ByteString] -> ByteString
PAE.encode [VerificationKey 'V3 -> ByteString
forall (v :: Version). VerificationKey v -> ByteString
verificationKeyToBytes VerificationKey 'V3
vk, 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]

  Signature
sig <-
    SigningError -> Maybe Signature -> Either SigningError Signature
forall a b. a -> Maybe b -> Either a b
maybeToEither
      SigningError
SigningKIsZeroError
      (Integer -> PrivateKey -> SHA384 -> ByteString -> Maybe Signature
forall msg hash.
(ByteArrayAccess msg, HashAlgorithm hash) =>
Integer -> PrivateKey -> hash -> msg -> Maybe Signature
Crypto.signWith Integer
k PrivateKey
sk SHA384
Crypto.SHA384 ByteString
m2)
  let r :: Integer
      r :: Integer
r = Signature -> Integer
Crypto.sign_r Signature
sig

      s :: Integer
      s :: Integer
s = Signature -> Integer
Crypto.sign_s Signature
sig

      sigBs :: ByteString
      sigBs :: ByteString
sigBs =
        Int -> ByteString -> ByteString
padTo Int
48 (ByteString -> ByteString
BS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPut (Integer -> Put
putIntegerbe Integer
r))
          ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString -> ByteString
padTo Int
48 (ByteString -> ByteString
BS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPut (Integer -> Put
putIntegerbe Integer
s))

      payload :: Payload
      payload :: Payload
payload = ByteString -> Payload
Payload (ByteString
m ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
sigBs)

  Token 'V3 'Public -> Either SigningError (Token 'V3 'Public)
forall a b. b -> Either a b
Right (Token 'V3 'Public -> Either SigningError (Token 'V3 'Public))
-> Token 'V3 'Public -> Either SigningError (Token 'V3 'Public)
forall a b. (a -> b) -> a -> b
$ Payload -> Maybe Footer -> Token 'V3 'Public
TokenV3Public Payload
payload Maybe Footer
f
    where
      padTo :: Int -> ByteString -> ByteString
      padTo :: Int -> ByteString -> ByteString
padTo Int
n ByteString
bs
        | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = ByteString
bs
        | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = ByteString
bs
        | Bool
otherwise = Int -> Word8 -> ByteString
BS.replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
bs) Word8
0 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
bs

-- | [PASETO version 3 cryptographic signing](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version3.md#sign).
--
-- This implementation produces a token which is signed using @ECDSA@ over
-- @P-384@ and @SHA-384@.
--
-- Note that this function essentially just calls 'signPure' with a
-- randomly-generated scalar multiple, @k@.
sign
  :: SigningKey V3
  -- ^ 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.
  -> ExceptT SigningError IO (Token V3 Public)
sign :: SigningKey 'V3
-> Claims
-> Maybe Footer
-> Maybe ImplicitAssertion
-> ExceptT SigningError IO (Token 'V3 'Public)
sign SigningKey 'V3
sk Claims
cs Maybe Footer
f Maybe ImplicitAssertion
i = do
  Integer
k <- IO Integer -> ExceptT SigningError IO Integer
forall a. IO a -> ExceptT SigningError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Integer
generateScalarP384
  Either SigningError (Token 'V3 'Public)
-> ExceptT SigningError IO (Token 'V3 'Public)
forall (m :: * -> *) x a. Monad m => Either x a -> ExceptT x m a
hoistEither (Integer
-> SigningKey 'V3
-> Claims
-> Maybe Footer
-> Maybe ImplicitAssertion
-> Either SigningError (Token 'V3 'Public)
signPure Integer
k SigningKey 'V3
sk Claims
cs Maybe Footer
f Maybe ImplicitAssertion
i)

-- | PASETO version 3 signature verification error.
data VerificationError
  = -- | Invalid token footer.
    VerificationInvalidFooterError
      -- | Expected footer.
      !(Maybe Footer)
      -- | Actual footer.
      !(Maybe Footer)
  | -- | Signature size is invalid.
    VerificationInvalidSignatureSizeError
  | -- | 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."
    VerificationError
VerificationInvalidSignatureSizeError -> Text
"Signature size is invalid."
    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 3 cryptographic signature verification](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/01-Protocol-Versions/Version3.md#verify).
verify
  :: VerificationKey V3
  -- ^ Verification key.
  -> Token V3 Public
  -- ^ Token to verify.
  -> Maybe Footer
  -- ^ Optional footer to authenticate.
  -> Maybe ImplicitAssertion
  -- ^ Optional implicit assertion to authenticate.
  -> Either VerificationError Claims
verify :: VerificationKey 'V3
-> Token 'V3 'Public
-> Maybe Footer
-> Maybe ImplicitAssertion
-> Either VerificationError Claims
verify verKey :: VerificationKey 'V3
verKey@(VerificationKeyV3 (PublicKeyP384 PublicKey
vk)) (TokenV3Public (Payload ByteString
sm) Maybe Footer
actualF) Maybe Footer
expectedF Maybe ImplicitAssertion
i = do
  let h :: ByteString
      h :: ByteString
h = ByteString
v3PublicTokenHeader

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

  let sigBs :: ByteString
      sigBs :: ByteString
sigBs = Int -> ByteString -> ByteString
BS.takeEnd Int
96 ByteString
sm

      rBs :: ByteString
      sBs :: ByteString
      (ByteString
rBs, ByteString
sBs) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
48 ByteString
sigBs

      r :: Integer
      r :: Integer
r = ByteString -> Integer
bsToInteger ByteString
rBs

      s :: Integer
      s :: Integer
s = ByteString -> Integer
bsToInteger ByteString
sBs

  Signature
sig <- (Integer, Integer) -> Either VerificationError Signature
sigFromIntegers (Integer
r, Integer
s)

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

      m2 :: ByteString
      m2 :: ByteString
m2 = [ByteString] -> ByteString
PAE.encode [VerificationKey 'V3 -> ByteString
forall (v :: Version). VerificationKey v -> ByteString
verificationKeyToBytes VerificationKey 'V3
verKey, 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
    (SHA384 -> PublicKey -> Signature -> ByteString -> Bool
forall msg hash.
(ByteArrayAccess msg, HashAlgorithm hash) =>
hash -> PublicKey -> Signature -> msg -> Bool
Crypto.verify SHA384
Crypto.SHA384 PublicKey
vk Signature
sig ByteString
m2)
    (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)
  where
    -- Decode a big endian 'Integer' from a 'ByteString'.
    --
    -- Ripped from @haskoin-core-1.1.0@.
    bsToInteger :: ByteString -> Integer
    bsToInteger :: ByteString -> Integer
bsToInteger = (Word8 -> Integer -> Integer) -> Integer -> ByteString -> Integer
forall a. (Word8 -> a -> a) -> a -> ByteString -> a
BS.foldr Word8 -> Integer -> Integer
forall {a}. Integral a => a -> Integer -> Integer
f Integer
0 (ByteString -> Integer)
-> (ByteString -> ByteString) -> ByteString -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.reverse
      where
        f :: a -> Integer -> Integer
f a
w Integer
n = a -> Integer
forall a. Integral a => a -> Integer
toInteger a
w Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL Integer
n Int
8

    mkValidScalar :: Integer -> Either VerificationError Integer
    mkValidScalar :: Integer -> Either VerificationError Integer
mkValidScalar Integer
s
      | Integer -> Bool
isScalarValidP384 Integer
s = Integer -> Either VerificationError Integer
forall a b. b -> Either a b
Right Integer
s
      | Bool
otherwise = VerificationError -> Either VerificationError Integer
forall a b. a -> Either a b
Left VerificationError
VerificationInvalidSignatureSizeError

    sigFromIntegers :: (Integer, Integer) -> Either VerificationError Crypto.Signature
    sigFromIntegers :: (Integer, Integer) -> Either VerificationError Signature
sigFromIntegers (Integer
r, Integer
s) =
      Integer -> Integer -> Signature
Crypto.Signature (Integer -> Integer -> Signature)
-> Either VerificationError Integer
-> Either VerificationError (Integer -> Signature)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Either VerificationError Integer
mkValidScalar Integer
r Either VerificationError (Integer -> Signature)
-> Either VerificationError Integer
-> Either VerificationError Signature
forall a b.
Either VerificationError (a -> b)
-> Either VerificationError a -> Either VerificationError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Integer -> Either VerificationError Integer
mkValidScalar Integer
s