-- | Collection of PASETO token claims.
--
-- It is recommended to import this module qualified since it contains
-- functions which may conflict with those in "Prelude" and other container
-- implementations such as "Data.Map".
--
-- For example:
--
-- @
-- import Crypto.Paseto.Token.Claims (Claims)
-- import qualified Crypto.Paseto.Token.Claims as Claims
-- @
module Crypto.Paseto.Token.Claims
  ( -- * Claims type
    Claims

    -- * Construction
  , empty
  , singleton
    -- ** Insertion
  , insert
    -- ** Deletion
  , delete

    -- * Query
  , lookupIssuer
  , lookupSubject
  , lookupAudience
  , lookupExpiration
  , lookupNotBefore
  , lookupIssuedAt
  , lookupTokenIdentifier
  , lookupCustom
  , null
  , size

    -- * Conversion
  , toList
  , fromList
  ) where

import Control.Monad ( foldM )
import Crypto.Paseto.Token.Claim
  ( Audience
  , Claim (..)
  , ClaimKey (..)
  , Expiration
  , IssuedAt
  , Issuer
  , NotBefore
  , Subject
  , TokenIdentifier
  , UnregisteredClaimKey
  , claimFromJson
  , claimKey
  , claimToPair
  , parseClaimKey
  )
import Data.Aeson ( FromJSON (..), ToJSON (..) )
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Key as Aeson
import qualified Data.Aeson.KeyMap as Aeson
import Data.Map.Strict ( Map )
import qualified Data.Map.Strict as Map
import Prelude hiding ( lookup, null )

------------------------------------------------------------------------------
-- Claims type
------------------------------------------------------------------------------

-- | Collection of 'Claim's.
newtype Claims = Claims
  { Claims -> Map ClaimKey Claim
unClaims :: Map ClaimKey Claim }
  deriving newtype (Int -> Claims -> ShowS
[Claims] -> ShowS
Claims -> String
(Int -> Claims -> ShowS)
-> (Claims -> String) -> ([Claims] -> ShowS) -> Show Claims
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Claims -> ShowS
showsPrec :: Int -> Claims -> ShowS
$cshow :: Claims -> String
show :: Claims -> String
$cshowList :: [Claims] -> ShowS
showList :: [Claims] -> ShowS
Show, Claims -> Claims -> Bool
(Claims -> Claims -> Bool)
-> (Claims -> Claims -> Bool) -> Eq Claims
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Claims -> Claims -> Bool
== :: Claims -> Claims -> Bool
$c/= :: Claims -> Claims -> Bool
/= :: Claims -> Claims -> Bool
Eq, NonEmpty Claims -> Claims
Claims -> Claims -> Claims
(Claims -> Claims -> Claims)
-> (NonEmpty Claims -> Claims)
-> (forall b. Integral b => b -> Claims -> Claims)
-> Semigroup Claims
forall b. Integral b => b -> Claims -> Claims
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Claims -> Claims -> Claims
<> :: Claims -> Claims -> Claims
$csconcat :: NonEmpty Claims -> Claims
sconcat :: NonEmpty Claims -> Claims
$cstimes :: forall b. Integral b => b -> Claims -> Claims
stimes :: forall b. Integral b => b -> Claims -> Claims
Semigroup, Semigroup Claims
Claims
Semigroup Claims
-> Claims
-> (Claims -> Claims -> Claims)
-> ([Claims] -> Claims)
-> Monoid Claims
[Claims] -> Claims
Claims -> Claims -> Claims
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Claims
mempty :: Claims
$cmappend :: Claims -> Claims -> Claims
mappend :: Claims -> Claims -> Claims
$cmconcat :: [Claims] -> Claims
mconcat :: [Claims] -> Claims
Monoid)

instance ToJSON Claims where
  toJSON :: Claims -> Value
toJSON = [Pair] -> Value
Aeson.object ([Pair] -> Value) -> (Claims -> [Pair]) -> Claims -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ClaimKey, Claim) -> Pair) -> [(ClaimKey, Claim)] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map (Claim -> Pair
claimToPair (Claim -> Pair)
-> ((ClaimKey, Claim) -> Claim) -> (ClaimKey, Claim) -> Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClaimKey, Claim) -> Claim
forall a b. (a, b) -> b
snd) ([(ClaimKey, Claim)] -> [Pair])
-> (Claims -> [(ClaimKey, Claim)]) -> Claims -> [Pair]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ClaimKey Claim -> [(ClaimKey, Claim)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map ClaimKey Claim -> [(ClaimKey, Claim)])
-> (Claims -> Map ClaimKey Claim) -> Claims -> [(ClaimKey, Claim)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Claims -> Map ClaimKey Claim
unClaims

instance FromJSON Claims where
  parseJSON :: Value -> Parser Claims
parseJSON = String -> (Object -> Parser Claims) -> Value -> Parser Claims
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Claims" ((Object -> Parser Claims) -> Value -> Parser Claims)
-> (Object -> Parser Claims) -> Value -> Parser Claims
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    let kvs :: [Pair]
kvs = Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
Aeson.toList Object
o
    (Claims -> Pair -> Parser Claims)
-> Claims -> [Pair] -> Parser Claims
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Claims -> Pair -> Parser Claims
parseAndAccumClaims Claims
empty [Pair]
kvs
    where
      parseAndAccumClaims :: Claims -> Pair -> Parser Claims
parseAndAccumClaims (Claims Map ClaimKey Claim
acc) (Key
k, Value
v) = do
        Claim
c <- Key -> Value -> Parser Claim
claimFromJson Key
k Value
v
        Claims -> Parser Claims
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Claims -> Parser Claims)
-> (Map ClaimKey Claim -> Claims)
-> Map ClaimKey Claim
-> Parser Claims
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ClaimKey Claim -> Claims
Claims (Map ClaimKey Claim -> Parser Claims)
-> Map ClaimKey Claim -> Parser Claims
forall a b. (a -> b) -> a -> b
$ ClaimKey -> Claim -> Map ClaimKey Claim -> Map ClaimKey Claim
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Text -> ClaimKey
parseClaimKey (Text -> ClaimKey) -> Text -> ClaimKey
forall a b. (a -> b) -> a -> b
$ Key -> Text
Aeson.toText Key
k) Claim
c Map ClaimKey Claim
acc

------------------------------------------------------------------------------
-- Construction
------------------------------------------------------------------------------

-- | Empty collection of claims.
empty :: Claims
empty :: Claims
empty = Map ClaimKey Claim -> Claims
Claims Map ClaimKey Claim
forall k a. Map k a
Map.empty

-- | Construct a collection of claims with a single element.
singleton :: Claim -> Claims
singleton :: Claim -> Claims
singleton Claim
c = Map ClaimKey Claim -> Claims
Claims (Map ClaimKey Claim -> Claims) -> Map ClaimKey Claim -> Claims
forall a b. (a -> b) -> a -> b
$ ClaimKey -> Claim -> Map ClaimKey Claim
forall k a. k -> a -> Map k a
Map.singleton (Claim -> ClaimKey
claimKey Claim
c) Claim
c

-- | Insert a 'Claim' into a collection of 'Claims'.
--
-- Note that if a claim with the same key is already present, it is replaced
-- with the provided claim.
insert :: Claim -> Claims -> Claims
insert :: Claim -> Claims -> Claims
insert Claim
c = Map ClaimKey Claim -> Claims
Claims (Map ClaimKey Claim -> Claims)
-> (Claims -> Map ClaimKey Claim) -> Claims -> Claims
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClaimKey -> Claim -> Map ClaimKey Claim -> Map ClaimKey Claim
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Claim -> ClaimKey
claimKey Claim
c) Claim
c (Map ClaimKey Claim -> Map ClaimKey Claim)
-> (Claims -> Map ClaimKey Claim) -> Claims -> Map ClaimKey Claim
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Claims -> Map ClaimKey Claim
unClaims

-- | Delete a claim from the collection.
delete :: ClaimKey -> Claims -> Claims
delete :: ClaimKey -> Claims -> Claims
delete ClaimKey
k = Map ClaimKey Claim -> Claims
Claims (Map ClaimKey Claim -> Claims)
-> (Claims -> Map ClaimKey Claim) -> Claims -> Claims
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClaimKey -> Map ClaimKey Claim -> Map ClaimKey Claim
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ClaimKey
k (Map ClaimKey Claim -> Map ClaimKey Claim)
-> (Claims -> Map ClaimKey Claim) -> Claims -> Map ClaimKey Claim
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Claims -> Map ClaimKey Claim
unClaims

------------------------------------------------------------------------------
-- Query
------------------------------------------------------------------------------

-- | Lookup a 'Claim' by its key.
--
-- Note that this function is not intended to be exported as it can be a bit
-- error prone.
lookup :: ClaimKey -> Claims -> Maybe Claim
lookup :: ClaimKey -> Claims -> Maybe Claim
lookup ClaimKey
k = ClaimKey -> Map ClaimKey Claim -> Maybe Claim
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ClaimKey
k (Map ClaimKey Claim -> Maybe Claim)
-> (Claims -> Map ClaimKey Claim) -> Claims -> Maybe Claim
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Claims -> Map ClaimKey Claim
unClaims

-- | Lookup the issuer claim.
lookupIssuer :: Claims -> Maybe Issuer
lookupIssuer :: Claims -> Maybe Issuer
lookupIssuer Claims
cs =
  case ClaimKey -> Claims -> Maybe Claim
lookup ClaimKey
IssuerClaimKey Claims
cs of
    Maybe Claim
Nothing -> Maybe Issuer
forall a. Maybe a
Nothing
    Just (IssuerClaim Issuer
i) -> Issuer -> Maybe Issuer
forall a. a -> Maybe a
Just Issuer
i
    Just Claim
_ -> String -> Maybe Issuer
forall a. HasCallStack => String -> a
error String
"impossible: invalid claim for key"

-- | Lookup the subject claim.
lookupSubject :: Claims -> Maybe Subject
lookupSubject :: Claims -> Maybe Subject
lookupSubject Claims
cs =
  case ClaimKey -> Claims -> Maybe Claim
lookup ClaimKey
SubjectClaimKey Claims
cs of
    Maybe Claim
Nothing -> Maybe Subject
forall a. Maybe a
Nothing
    Just (SubjectClaim Subject
s) -> Subject -> Maybe Subject
forall a. a -> Maybe a
Just Subject
s
    Just Claim
_ -> String -> Maybe Subject
forall a. HasCallStack => String -> a
error String
"impossible: invalid claim for key"

-- | Lookup the audience claim.
lookupAudience :: Claims -> Maybe Audience
lookupAudience :: Claims -> Maybe Audience
lookupAudience Claims
cs =
  case ClaimKey -> Claims -> Maybe Claim
lookup ClaimKey
AudienceClaimKey Claims
cs of
    Maybe Claim
Nothing -> Maybe Audience
forall a. Maybe a
Nothing
    Just (AudienceClaim Audience
a) -> Audience -> Maybe Audience
forall a. a -> Maybe a
Just Audience
a
    Just Claim
_ -> String -> Maybe Audience
forall a. HasCallStack => String -> a
error String
"impossible: invalid claim for key"

-- | Lookup the expiration claim.
lookupExpiration :: Claims -> Maybe Expiration
lookupExpiration :: Claims -> Maybe Expiration
lookupExpiration Claims
cs =
  case ClaimKey -> Claims -> Maybe Claim
lookup ClaimKey
ExpirationClaimKey Claims
cs of
    Maybe Claim
Nothing -> Maybe Expiration
forall a. Maybe a
Nothing
    Just (ExpirationClaim Expiration
e) -> Expiration -> Maybe Expiration
forall a. a -> Maybe a
Just Expiration
e
    Just Claim
_ -> String -> Maybe Expiration
forall a. HasCallStack => String -> a
error String
"impossible: invalid claim for key"

-- | Lookup the \"not before\" claim.
lookupNotBefore :: Claims -> Maybe NotBefore
lookupNotBefore :: Claims -> Maybe NotBefore
lookupNotBefore Claims
cs =
  case ClaimKey -> Claims -> Maybe Claim
lookup ClaimKey
NotBeforeClaimKey Claims
cs of
    Maybe Claim
Nothing -> Maybe NotBefore
forall a. Maybe a
Nothing
    Just (NotBeforeClaim NotBefore
nb) -> NotBefore -> Maybe NotBefore
forall a. a -> Maybe a
Just NotBefore
nb
    Just Claim
_ -> String -> Maybe NotBefore
forall a. HasCallStack => String -> a
error String
"impossible: invalid claim for key"

-- | Lookup the \"issued at\" claim.
lookupIssuedAt :: Claims -> Maybe IssuedAt
lookupIssuedAt :: Claims -> Maybe IssuedAt
lookupIssuedAt Claims
cs =
  case ClaimKey -> Claims -> Maybe Claim
lookup ClaimKey
IssuedAtClaimKey Claims
cs of
    Maybe Claim
Nothing -> Maybe IssuedAt
forall a. Maybe a
Nothing
    Just (IssuedAtClaim IssuedAt
ia) -> IssuedAt -> Maybe IssuedAt
forall a. a -> Maybe a
Just IssuedAt
ia
    Just Claim
_ -> String -> Maybe IssuedAt
forall a. HasCallStack => String -> a
error String
"impossible: invalid claim for key"

-- | Lookup the token identifier claim.
lookupTokenIdentifier :: Claims -> Maybe TokenIdentifier
lookupTokenIdentifier :: Claims -> Maybe TokenIdentifier
lookupTokenIdentifier Claims
cs =
  case ClaimKey -> Claims -> Maybe Claim
lookup ClaimKey
TokenIdentifierClaimKey Claims
cs of
    Maybe Claim
Nothing -> Maybe TokenIdentifier
forall a. Maybe a
Nothing
    Just (TokenIdentifierClaim TokenIdentifier
ti) -> TokenIdentifier -> Maybe TokenIdentifier
forall a. a -> Maybe a
Just TokenIdentifier
ti
    Just Claim
_ -> String -> Maybe TokenIdentifier
forall a. HasCallStack => String -> a
error String
"impossible: invalid claim for key"

-- | Lookup a custom unregistered claim.
lookupCustom :: UnregisteredClaimKey -> Claims -> Maybe Aeson.Value
lookupCustom :: UnregisteredClaimKey -> Claims -> Maybe Value
lookupCustom UnregisteredClaimKey
k Claims
cs =
  case ClaimKey -> Claims -> Maybe Claim
lookup (UnregisteredClaimKey -> ClaimKey
CustomClaimKey UnregisteredClaimKey
k) Claims
cs of
    Maybe Claim
Nothing -> Maybe Value
forall a. Maybe a
Nothing
    Just (CustomClaim UnregisteredClaimKey
_ Value
v) -> Value -> Maybe Value
forall a. a -> Maybe a
Just Value
v
    Just Claim
_ -> String -> Maybe Value
forall a. HasCallStack => String -> a
error String
"impossible: invalid claim for key"

-- | Whether a collection of claims is empty.
null :: Claims -> Bool
null :: Claims -> Bool
null = Map ClaimKey Claim -> Bool
forall k a. Map k a -> Bool
Map.null (Map ClaimKey Claim -> Bool)
-> (Claims -> Map ClaimKey Claim) -> Claims -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Claims -> Map ClaimKey Claim
unClaims

-- | Size of a collection of claims.
size :: Claims -> Int
size :: Claims -> Int
size = Map ClaimKey Claim -> Int
forall k a. Map k a -> Int
Map.size (Map ClaimKey Claim -> Int)
-> (Claims -> Map ClaimKey Claim) -> Claims -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Claims -> Map ClaimKey Claim
unClaims

------------------------------------------------------------------------------
-- Conversion
------------------------------------------------------------------------------

-- | Convert a collection of 'Claims' to a list of 'Claim's.
toList :: Claims -> [Claim]
toList :: Claims -> [Claim]
toList = Map ClaimKey Claim -> [Claim]
forall k a. Map k a -> [a]
Map.elems (Map ClaimKey Claim -> [Claim])
-> (Claims -> Map ClaimKey Claim) -> Claims -> [Claim]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Claims -> Map ClaimKey Claim
unClaims

-- | Convert a list of 'Claim's to a collection of 'Claims'.
--
-- Note that if the provided list contains more than one value for the same
-- claim, the last value for that claim is retained.
fromList :: [Claim] -> Claims
fromList :: [Claim] -> Claims
fromList = Map ClaimKey Claim -> Claims
Claims (Map ClaimKey Claim -> Claims)
-> ([Claim] -> Map ClaimKey Claim) -> [Claim] -> Claims
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ClaimKey, Claim)] -> Map ClaimKey Claim
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ClaimKey, Claim)] -> Map ClaimKey Claim)
-> ([Claim] -> [(ClaimKey, Claim)])
-> [Claim]
-> Map ClaimKey Claim
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Claim -> (ClaimKey, Claim)) -> [Claim] -> [(ClaimKey, Claim)]
forall a b. (a -> b) -> [a] -> [b]
map (\Claim
c -> (Claim -> ClaimKey
claimKey Claim
c, Claim
c))