{-# LANGUAGE DataKinds #-}

module Crypto.Paseto.Token.Build
  ( BuildTokenParams (..)
  , getDefaultBuildTokenParams
  , V3LocalBuildError (..)
  , renderV3LocalBuildError
  , buildTokenV3Local
  , V3PublicBuildError (..)
  , renderV3PublicBuildError
  , buildTokenV3Public
  , buildTokenV4Local
  , buildTokenV4Public
  ) where

import Control.Monad.Except ( ExceptT )
import Control.Monad.Trans.Except.Extra ( firstExceptT )
import Crypto.Paseto.Keys ( SigningKey (..), SymmetricKey (..) )
import Crypto.Paseto.Mode ( Purpose (..), Version (..) )
import qualified Crypto.Paseto.Protocol.V3 as V3
import qualified Crypto.Paseto.Protocol.V4 as V4
import Crypto.Paseto.Token ( Footer, ImplicitAssertion, Token (..) )
import Crypto.Paseto.Token.Claim
  ( Claim (..), Expiration (..), IssuedAt (..), NotBefore (..) )
import Crypto.Paseto.Token.Claims ( Claims )
import qualified Crypto.Paseto.Token.Claims as Claims
import Data.Text ( Text )
import Data.Time.Clock ( addUTCTime, getCurrentTime, secondsToNominalDiffTime )
import Prelude hiding ( exp )

-- | Parameters for building a PASETO token.
data BuildTokenParams = BuildTokenParams
  { BuildTokenParams -> Claims
btpClaims :: !Claims
  , BuildTokenParams -> Maybe Footer
btpFooter :: !(Maybe Footer)
  , BuildTokenParams -> Maybe ImplicitAssertion
btpImplicitAssertion :: !(Maybe ImplicitAssertion)
  } deriving stock (Int -> BuildTokenParams -> ShowS
[BuildTokenParams] -> ShowS
BuildTokenParams -> String
(Int -> BuildTokenParams -> ShowS)
-> (BuildTokenParams -> String)
-> ([BuildTokenParams] -> ShowS)
-> Show BuildTokenParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BuildTokenParams -> ShowS
showsPrec :: Int -> BuildTokenParams -> ShowS
$cshow :: BuildTokenParams -> String
show :: BuildTokenParams -> String
$cshowList :: [BuildTokenParams] -> ShowS
showList :: [BuildTokenParams] -> ShowS
Show, BuildTokenParams -> BuildTokenParams -> Bool
(BuildTokenParams -> BuildTokenParams -> Bool)
-> (BuildTokenParams -> BuildTokenParams -> Bool)
-> Eq BuildTokenParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BuildTokenParams -> BuildTokenParams -> Bool
== :: BuildTokenParams -> BuildTokenParams -> Bool
$c/= :: BuildTokenParams -> BuildTokenParams -> Bool
/= :: BuildTokenParams -> BuildTokenParams -> Bool
Eq)

-- | Get parameters for building a PASETO token which includes the
-- [recommended default claims](https://github.com/paseto-standard/paseto-spec/blob/af79f25908227555404e7462ccdd8ce106049469/docs/02-Implementation-Guide/05-API-UX.md#secure-defaults).
--
-- This includes the following default claims:
--
-- * An 'ExpirationClaim' of 1 hour from the current system time.
-- * An 'IssuedAtClaim' of the current system time.
-- * A 'NotBeforeClaim' of the current system time.
--
-- The default 'Footer' and 'ImplicitAssertion' is 'Nothing'.
getDefaultBuildTokenParams :: IO BuildTokenParams
getDefaultBuildTokenParams :: IO BuildTokenParams
getDefaultBuildTokenParams = do
  UTCTime
now <- IO UTCTime
getCurrentTime
  let hourInSeconds :: Pico
hourInSeconds = Pico
3600
      exp :: Claim
exp = Expiration -> Claim
ExpirationClaim (Expiration -> Claim)
-> (UTCTime -> Expiration) -> UTCTime -> Claim
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Expiration
Expiration (UTCTime -> Claim) -> UTCTime -> Claim
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Pico -> NominalDiffTime
secondsToNominalDiffTime Pico
hourInSeconds) UTCTime
now
      iat :: Claim
iat = IssuedAt -> Claim
IssuedAtClaim (UTCTime -> IssuedAt
IssuedAt UTCTime
now)
      nbf :: Claim
nbf = NotBefore -> Claim
NotBeforeClaim (UTCTime -> NotBefore
NotBefore UTCTime
now)
  BuildTokenParams -> IO BuildTokenParams
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BuildTokenParams
    { btpClaims :: Claims
btpClaims = [Claim] -> Claims
Claims.fromList [Claim
exp, Claim
iat, Claim
nbf]
    , btpFooter :: Maybe Footer
btpFooter = Maybe Footer
forall a. Maybe a
Nothing
    , btpImplicitAssertion :: Maybe ImplicitAssertion
btpImplicitAssertion = Maybe ImplicitAssertion
forall a. Maybe a
Nothing
    }

-- | Error building a version 3 local PASETO token.
newtype V3LocalBuildError
  = -- | Encryption error.
    V3LocalBuildEncryptionError V3.EncryptionError
  deriving stock (Int -> V3LocalBuildError -> ShowS
[V3LocalBuildError] -> ShowS
V3LocalBuildError -> String
(Int -> V3LocalBuildError -> ShowS)
-> (V3LocalBuildError -> String)
-> ([V3LocalBuildError] -> ShowS)
-> Show V3LocalBuildError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> V3LocalBuildError -> ShowS
showsPrec :: Int -> V3LocalBuildError -> ShowS
$cshow :: V3LocalBuildError -> String
show :: V3LocalBuildError -> String
$cshowList :: [V3LocalBuildError] -> ShowS
showList :: [V3LocalBuildError] -> ShowS
Show, V3LocalBuildError -> V3LocalBuildError -> Bool
(V3LocalBuildError -> V3LocalBuildError -> Bool)
-> (V3LocalBuildError -> V3LocalBuildError -> Bool)
-> Eq V3LocalBuildError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: V3LocalBuildError -> V3LocalBuildError -> Bool
== :: V3LocalBuildError -> V3LocalBuildError -> Bool
$c/= :: V3LocalBuildError -> V3LocalBuildError -> Bool
/= :: V3LocalBuildError -> V3LocalBuildError -> Bool
Eq)

-- | Render a 'V3LocalBuildError' as 'Text'.
renderV3LocalBuildError :: V3LocalBuildError -> Text
renderV3LocalBuildError :: V3LocalBuildError -> Text
renderV3LocalBuildError V3LocalBuildError
err =
  case V3LocalBuildError
err of
    V3LocalBuildEncryptionError EncryptionError
e -> EncryptionError -> Text
V3.renderEncryptionError EncryptionError
e

-- | Build a version 3 local token.
buildTokenV3Local :: BuildTokenParams -> SymmetricKey V3 -> ExceptT V3LocalBuildError IO (Token V3 Local)
buildTokenV3Local :: BuildTokenParams
-> SymmetricKey 'V3
-> ExceptT V3LocalBuildError IO (Token 'V3 'Local)
buildTokenV3Local BuildTokenParams
btp SymmetricKey 'V3
k =
  (EncryptionError -> V3LocalBuildError)
-> ExceptT EncryptionError IO (Token 'V3 'Local)
-> ExceptT V3LocalBuildError IO (Token 'V3 'Local)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT EncryptionError -> V3LocalBuildError
V3LocalBuildEncryptionError (ExceptT EncryptionError IO (Token 'V3 'Local)
 -> ExceptT V3LocalBuildError IO (Token 'V3 'Local))
-> ExceptT EncryptionError IO (Token 'V3 'Local)
-> ExceptT V3LocalBuildError IO (Token 'V3 'Local)
forall a b. (a -> b) -> a -> b
$
    SymmetricKey 'V3
-> Claims
-> Maybe Footer
-> Maybe ImplicitAssertion
-> ExceptT EncryptionError IO (Token 'V3 'Local)
V3.encrypt SymmetricKey 'V3
k Claims
btpClaims Maybe Footer
btpFooter Maybe ImplicitAssertion
btpImplicitAssertion
  where
    BuildTokenParams
      { Claims
btpClaims :: BuildTokenParams -> Claims
btpClaims :: Claims
btpClaims
      , Maybe Footer
btpFooter :: BuildTokenParams -> Maybe Footer
btpFooter :: Maybe Footer
btpFooter
      , Maybe ImplicitAssertion
btpImplicitAssertion :: BuildTokenParams -> Maybe ImplicitAssertion
btpImplicitAssertion :: Maybe ImplicitAssertion
btpImplicitAssertion
      } = BuildTokenParams
btp

-- | Error building a version 3 public PASETO token.
newtype V3PublicBuildError
  = -- | Cryptographic signing error.
    V3PublicBuildSigningError V3.SigningError
  deriving stock (Int -> V3PublicBuildError -> ShowS
[V3PublicBuildError] -> ShowS
V3PublicBuildError -> String
(Int -> V3PublicBuildError -> ShowS)
-> (V3PublicBuildError -> String)
-> ([V3PublicBuildError] -> ShowS)
-> Show V3PublicBuildError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> V3PublicBuildError -> ShowS
showsPrec :: Int -> V3PublicBuildError -> ShowS
$cshow :: V3PublicBuildError -> String
show :: V3PublicBuildError -> String
$cshowList :: [V3PublicBuildError] -> ShowS
showList :: [V3PublicBuildError] -> ShowS
Show, V3PublicBuildError -> V3PublicBuildError -> Bool
(V3PublicBuildError -> V3PublicBuildError -> Bool)
-> (V3PublicBuildError -> V3PublicBuildError -> Bool)
-> Eq V3PublicBuildError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: V3PublicBuildError -> V3PublicBuildError -> Bool
== :: V3PublicBuildError -> V3PublicBuildError -> Bool
$c/= :: V3PublicBuildError -> V3PublicBuildError -> Bool
/= :: V3PublicBuildError -> V3PublicBuildError -> Bool
Eq)

-- | Render a 'V3PublicBuildError' as 'Text'.
renderV3PublicBuildError :: V3PublicBuildError -> Text
renderV3PublicBuildError :: V3PublicBuildError -> Text
renderV3PublicBuildError V3PublicBuildError
err =
  case V3PublicBuildError
err of
    V3PublicBuildSigningError SigningError
e -> SigningError -> Text
V3.renderSigningError SigningError
e

-- | Build a version 3 public token.
buildTokenV3Public :: BuildTokenParams -> SigningKey V3 -> ExceptT V3PublicBuildError IO (Token V3 Public)
buildTokenV3Public :: BuildTokenParams
-> SigningKey 'V3
-> ExceptT V3PublicBuildError IO (Token 'V3 'Public)
buildTokenV3Public BuildTokenParams
btp SigningKey 'V3
sk =
  (SigningError -> V3PublicBuildError)
-> ExceptT SigningError IO (Token 'V3 'Public)
-> ExceptT V3PublicBuildError IO (Token 'V3 'Public)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT SigningError -> V3PublicBuildError
V3PublicBuildSigningError (ExceptT SigningError IO (Token 'V3 'Public)
 -> ExceptT V3PublicBuildError IO (Token 'V3 'Public))
-> ExceptT SigningError IO (Token 'V3 'Public)
-> ExceptT V3PublicBuildError IO (Token 'V3 'Public)
forall a b. (a -> b) -> a -> b
$
    SigningKey 'V3
-> Claims
-> Maybe Footer
-> Maybe ImplicitAssertion
-> ExceptT SigningError IO (Token 'V3 'Public)
V3.sign SigningKey 'V3
sk Claims
btpClaims Maybe Footer
btpFooter Maybe ImplicitAssertion
btpImplicitAssertion
  where
    BuildTokenParams
      { Claims
btpClaims :: BuildTokenParams -> Claims
btpClaims :: Claims
btpClaims
      , Maybe Footer
btpFooter :: BuildTokenParams -> Maybe Footer
btpFooter :: Maybe Footer
btpFooter
      , Maybe ImplicitAssertion
btpImplicitAssertion :: BuildTokenParams -> Maybe ImplicitAssertion
btpImplicitAssertion :: Maybe ImplicitAssertion
btpImplicitAssertion
      } = BuildTokenParams
btp

-- | Build a version 4 local token.
buildTokenV4Local :: BuildTokenParams -> SymmetricKey V4 -> IO (Token V4 Local)
buildTokenV4Local :: BuildTokenParams -> SymmetricKey 'V4 -> IO (Token 'V4 'Local)
buildTokenV4Local BuildTokenParams
btp SymmetricKey 'V4
k = SymmetricKey 'V4
-> Claims
-> Maybe Footer
-> Maybe ImplicitAssertion
-> IO (Token 'V4 'Local)
V4.encrypt SymmetricKey 'V4
k Claims
btpClaims Maybe Footer
btpFooter Maybe ImplicitAssertion
btpImplicitAssertion
  where
    BuildTokenParams
      { Claims
btpClaims :: BuildTokenParams -> Claims
btpClaims :: Claims
btpClaims
      , Maybe Footer
btpFooter :: BuildTokenParams -> Maybe Footer
btpFooter :: Maybe Footer
btpFooter
      , Maybe ImplicitAssertion
btpImplicitAssertion :: BuildTokenParams -> Maybe ImplicitAssertion
btpImplicitAssertion :: Maybe ImplicitAssertion
btpImplicitAssertion
      } = BuildTokenParams
btp

-- | Build a version 4 public token.
buildTokenV4Public :: BuildTokenParams -> SigningKey V4 -> Token V4 Public
buildTokenV4Public :: BuildTokenParams -> SigningKey 'V4 -> Token 'V4 'Public
buildTokenV4Public BuildTokenParams
btp SigningKey 'V4
sk = SigningKey 'V4
-> Claims
-> Maybe Footer
-> Maybe ImplicitAssertion
-> Token 'V4 'Public
V4.sign SigningKey 'V4
sk Claims
btpClaims Maybe Footer
btpFooter Maybe ImplicitAssertion
btpImplicitAssertion
  where
    BuildTokenParams
      { Claims
btpClaims :: BuildTokenParams -> Claims
btpClaims :: Claims
btpClaims
      , Maybe Footer
btpFooter :: BuildTokenParams -> Maybe Footer
btpFooter :: Maybe Footer
btpFooter
      , Maybe ImplicitAssertion
btpImplicitAssertion :: BuildTokenParams -> Maybe ImplicitAssertion
btpImplicitAssertion :: Maybe ImplicitAssertion
btpImplicitAssertion
      } = BuildTokenParams
btp