{-|

Copyright:

  This file is part of the package openid-connect.  It is subject to
  the license terms in the LICENSE file found in the top-level
  directory of this distribution and at:

    https://code.devalot.com/open/openid-connect

  No part of this package, including this file, may be copied,
  modified, propagated, or distributed except according to the terms
  contained in the LICENSE file.

License: BSD-2-Clause

OpenID Connect Dynamic Client Registration 1.0.

-}
module OpenID.Connect.Registration
  ( Registration(..)
  , defaultRegistration
  , ClientMetadata
  , BasicRegistration(..)
  , clientMetadata
  , RegistrationResponse(..)
  , ClientMetadataResponse
  , clientSecretsFromResponse
  , additionalMetadataFromResponse
  , registrationFromResponse
  , (:*:)
  , URI(..)
  ) where

--------------------------------------------------------------------------------
-- Imports:
import Crypto.JOSE (JWKSet)
import qualified Crypto.JOSE.JWA.JWE.Alg as JWE
import qualified Crypto.JOSE.JWA.JWS as JWS
import Crypto.JWT (NumericDate)
import qualified Data.Aeson as Aeson
import Data.List.NonEmpty (NonEmpty(..))
import Data.Text (Text)
import GHC.Generics (Generic)
import qualified Network.URI as Network
import OpenID.Connect.Authentication
import OpenID.Connect.JSON

--------------------------------------------------------------------------------
-- | Client registration metadata.
--
-- OpenID Connect Dynamic Client Registration 1.0 §2.
--
-- Use the 'defaultRegistration' function to easily create a value of
-- this type.
data Registration = Registration
  { Registration -> NonEmpty URI
redirectUris :: NonEmpty URI
    -- ^ Array of Redirection URI values used by the Client.

  , Registration -> Maybe (NonEmpty Text)
responseTypes :: Maybe (NonEmpty Text)
    -- ^ JSON array containing a list of the OAuth 2.0 response_type
    -- values that the Client is declaring that it will restrict
    -- itself to using.

  , Registration -> Maybe (NonEmpty Text)
grantTypes :: Maybe (NonEmpty Text)
    -- ^ JSON array containing a list of the OAuth 2.0 Grant Types
    -- that the Client is declaring that it will restrict itself to
    -- using.

  , Registration -> Maybe Text
applicationType :: Maybe Text
    -- ^ Kind of the application. The default, if omitted, is web. The
    -- defined values are native or web.

  , Registration -> Maybe (NonEmpty Text)
contacts :: Maybe (NonEmpty Text)
    -- ^ Array of e-mail addresses of people responsible for this Client.

  , Registration -> Maybe Text
clientName :: Maybe Text
    -- ^ Name of the Client to be presented to the End-User.

  , Registration -> Maybe URI
logoUri :: Maybe URI
    -- ^ URL that references a logo for the Client application.

  , Registration -> Maybe URI
clientUri :: Maybe URI
    -- ^ URL of the home page of the Client.

  , Registration -> Maybe URI
policyUri :: Maybe URI
    -- ^ URL that the Relying Party Client provides to the End-User to
    -- read about the how the profile data will be used.

  , Registration -> Maybe URI
tosUri :: Maybe URI
    -- ^ URL that the Relying Party Client provides to the End-User to
    -- read about the Relying Party's terms of service.

  , Registration -> Maybe URI
jwksUri :: Maybe URI
    -- ^ URL for the Client's JSON Web Key Set document.

  , Registration -> Maybe JWKSet
jwks :: Maybe JWKSet
    -- ^ Client's JSON Web Key Set [JWK] document, passed by value.

  , Registration -> Maybe URI
sectorIdentifierUri :: Maybe URI
    -- ^ URL using the https scheme to be used in calculating
    -- Pseudonymous Identifiers by the OP.

  , Registration -> Maybe Text
subjectType :: Maybe Text
    -- ^ @subject_type@ requested for responses to this Client.

  , Registration -> Maybe Alg
idTokenSignedResponseAlg :: Maybe JWS.Alg
    -- ^ JWS alg algorithm required for signing the ID Token issued to
    -- this Client.

  , Registration -> Maybe Alg
idTokenEncryptedResponseAlg :: Maybe JWE.Alg
    -- ^ JWE alg algorithm required for encrypting the ID Token issued
    -- to this Client.

  , Registration -> Maybe Alg
idTokenEncryptedResponseEnc :: Maybe JWE.Alg
    -- ^ JWE enc algorithm required for encrypting the ID Token issued
    -- to this Client.

  , Registration -> Maybe Alg
userinfoSignedResponseAlg :: Maybe JWS.Alg
    -- ^ JWS alg algorithm [JWA] REQUIRED for signing UserInfo
    -- Responses.

  , Registration -> Maybe Alg
userinfoEncryptedResponseAlg :: Maybe JWE.Alg
    -- ^ JWE alg algorithm required for encrypting UserInfo Responses.

  , Registration -> Maybe Alg
userinfoEncryptedResponseEnc :: Maybe JWE.Alg
    -- ^ JWE enc algorithm required for encrypting UserInfo Responses.

  , Registration -> Maybe Alg
requestObjectSigningAlg :: Maybe JWS.Alg
    -- ^ JWS alg algorithm that must be used for signing Request
    -- Objects sent to the OP.

  , Registration -> Maybe Alg
requestObjectEncryptionAlg :: Maybe JWE.Alg
    -- ^ JWE alg algorithm the RP is declaring that it may use for
    -- encrypting Request Objects sent to the OP.  This parameter
    -- SHOULD be included when symmetric encryption will be used,
    -- since this signals to the OP that a @client_secret@ value needs
    -- to be returned from which the symmetric key will be derived,
    -- that might not otherwise be returned. The RP MAY still use
    -- other supported encryption algorithms or send unencrypted
    -- Request Objects, even when this parameter is present. If both
    -- signing and encryption are requested, the Request Object will
    -- be signed then encrypted, with the result being a Nested JWT,
    -- as defined in JWT. The default, if omitted, is that the RP is
    -- not declaring whether it might encrypt any Request Objects.

  , Registration -> Maybe Alg
requestObjectEncryptionEnc :: Maybe JWE.Alg
    -- ^ JWE enc algorithm the RP is declaring that it may use for
    -- encrypting Request Objects sent to the OP.  If
    -- @request_object_encryption_alg@ is specified, the default for
    -- this value is @A128CBC-HS256@. When
    -- @request_object_encryption_enc@ is included,
    -- @request_object_encryption_alg@ MUST also be provided.

  , Registration -> ClientAuthentication
tokenEndpointAuthMethod :: ClientAuthentication
    -- ^ Requested Client Authentication method for the Token
    -- Endpoint.

  , Registration -> Maybe Alg
tokenEndpointAuthSigningAlg :: Maybe JWS.Alg
    -- ^ JWS alg algorithm that must be used for signing the JWT used
    -- to authenticate the Client at the Token Endpoint for the
    -- private_key_jwt and client_secret_jwt authentication methods.

  , Registration -> Maybe Int
defaultMaxAge :: Maybe Int
    -- ^ Default Maximum Authentication Age. Specifies that the
    -- End-User MUST be actively authenticated if the End-User was
    -- authenticated longer ago than the specified number of seconds.

  , Registration -> Maybe Bool
requireAuthTime :: Maybe Bool
    -- ^ Boolean value specifying whether the auth_time Claim in the
    -- ID Token is REQUIRED. It is REQUIRED when the value is
    -- true. (If this is false, the auth_time Claim can still be
    -- dynamically requested as an individual Claim for the ID Token
    -- using the claims request parameter described in Section 5.5.1
    -- of OpenID Connect Core 1.0.) If omitted, the default value is
    -- false.

  , Registration -> Maybe (NonEmpty Text)
defaultAcrValues :: Maybe (NonEmpty Text)
    -- ^ Default requested Authentication Context Class Reference
    -- values. Array of strings that specifies the default acr values
    -- that the OP is being requested to use for processing requests
    -- from this Client, with the values appearing in order of
    -- preference.

  , Registration -> Maybe URI
initiateLoginUri :: Maybe URI
    -- ^ URI using the https scheme that a third party can use to
    -- initiate a login by the RP, as specified in Section 4 of OpenID
    -- Connect Core 1.0. The URI MUST accept requests via both GET and
    -- POST. The Client MUST understand the login_hint and iss
    -- parameters and SHOULD support the target_link_uri parameter.

  , Registration -> Maybe (NonEmpty URI)
requestUris :: Maybe (NonEmpty URI)
    -- ^ Array of request_uri values that are pre-registered by the RP
    -- for use at the OP. Servers MAY cache the contents of the files
    -- referenced by these URIs and not retrieve them at the time they
    -- are used in a request. OPs can require that request_uri values
    -- used be pre-registered with the
    -- require_request_uri_registration discovery parameter.
  }
  deriving stock ((forall x. Registration -> Rep Registration x)
-> (forall x. Rep Registration x -> Registration)
-> Generic Registration
forall x. Rep Registration x -> Registration
forall x. Registration -> Rep Registration x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Registration x -> Registration
$cfrom :: forall x. Registration -> Rep Registration x
Generic, Int -> Registration -> ShowS
[Registration] -> ShowS
Registration -> String
(Int -> Registration -> ShowS)
-> (Registration -> String)
-> ([Registration] -> ShowS)
-> Show Registration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Registration] -> ShowS
$cshowList :: [Registration] -> ShowS
show :: Registration -> String
$cshow :: Registration -> String
showsPrec :: Int -> Registration -> ShowS
$cshowsPrec :: Int -> Registration -> ShowS
Show)
  deriving ([Registration] -> Encoding
[Registration] -> Value
Registration -> Encoding
Registration -> Value
(Registration -> Value)
-> (Registration -> Encoding)
-> ([Registration] -> Value)
-> ([Registration] -> Encoding)
-> ToJSON Registration
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Registration] -> Encoding
$ctoEncodingList :: [Registration] -> Encoding
toJSONList :: [Registration] -> Value
$ctoJSONList :: [Registration] -> Value
toEncoding :: Registration -> Encoding
$ctoEncoding :: Registration -> Encoding
toJSON :: Registration -> Value
$ctoJSON :: Registration -> Value
ToJSON, Value -> Parser [Registration]
Value -> Parser Registration
(Value -> Parser Registration)
-> (Value -> Parser [Registration]) -> FromJSON Registration
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Registration]
$cparseJSONList :: Value -> Parser [Registration]
parseJSON :: Value -> Parser Registration
$cparseJSON :: Value -> Parser Registration
FromJSON) via GenericJSON Registration

--------------------------------------------------------------------------------
-- | The default 'Registration' value.
defaultRegistration :: Network.URI -> Registration
defaultRegistration :: URI -> Registration
defaultRegistration URI
redir =
  Registration :: NonEmpty URI
-> Maybe (NonEmpty Text)
-> Maybe (NonEmpty Text)
-> Maybe Text
-> Maybe (NonEmpty Text)
-> Maybe Text
-> Maybe URI
-> Maybe URI
-> Maybe URI
-> Maybe URI
-> Maybe URI
-> Maybe JWKSet
-> Maybe URI
-> Maybe Text
-> Maybe Alg
-> Maybe Alg
-> Maybe Alg
-> Maybe Alg
-> Maybe Alg
-> Maybe Alg
-> Maybe Alg
-> Maybe Alg
-> Maybe Alg
-> ClientAuthentication
-> Maybe Alg
-> Maybe Int
-> Maybe Bool
-> Maybe (NonEmpty Text)
-> Maybe URI
-> Maybe (NonEmpty URI)
-> Registration
Registration
    { redirectUris :: NonEmpty URI
redirectUris                 = URI -> URI
URI URI
redir URI -> [URI] -> NonEmpty URI
forall a. a -> [a] -> NonEmpty a
:| []
    , responseTypes :: Maybe (NonEmpty Text)
responseTypes                = Maybe (NonEmpty Text)
forall a. Maybe a
Nothing
    , grantTypes :: Maybe (NonEmpty Text)
grantTypes                   = Maybe (NonEmpty Text)
forall a. Maybe a
Nothing
    , applicationType :: Maybe Text
applicationType              = Maybe Text
forall a. Maybe a
Nothing
    , contacts :: Maybe (NonEmpty Text)
contacts                     = Maybe (NonEmpty Text)
forall a. Maybe a
Nothing
    , clientName :: Maybe Text
clientName                   = Maybe Text
forall a. Maybe a
Nothing
    , logoUri :: Maybe URI
logoUri                      = Maybe URI
forall a. Maybe a
Nothing
    , clientUri :: Maybe URI
clientUri                    = Maybe URI
forall a. Maybe a
Nothing
    , policyUri :: Maybe URI
policyUri                    = Maybe URI
forall a. Maybe a
Nothing
    , tosUri :: Maybe URI
tosUri                       = Maybe URI
forall a. Maybe a
Nothing
    , jwksUri :: Maybe URI
jwksUri                      = Maybe URI
forall a. Maybe a
Nothing
    , jwks :: Maybe JWKSet
jwks                         = Maybe JWKSet
forall a. Maybe a
Nothing
    , sectorIdentifierUri :: Maybe URI
sectorIdentifierUri          = Maybe URI
forall a. Maybe a
Nothing
    , subjectType :: Maybe Text
subjectType                  = Maybe Text
forall a. Maybe a
Nothing
    , idTokenSignedResponseAlg :: Maybe Alg
idTokenSignedResponseAlg     = Maybe Alg
forall a. Maybe a
Nothing
    , idTokenEncryptedResponseAlg :: Maybe Alg
idTokenEncryptedResponseAlg  = Maybe Alg
forall a. Maybe a
Nothing
    , idTokenEncryptedResponseEnc :: Maybe Alg
idTokenEncryptedResponseEnc  = Maybe Alg
forall a. Maybe a
Nothing
    , userinfoSignedResponseAlg :: Maybe Alg
userinfoSignedResponseAlg    = Maybe Alg
forall a. Maybe a
Nothing
    , userinfoEncryptedResponseAlg :: Maybe Alg
userinfoEncryptedResponseAlg = Maybe Alg
forall a. Maybe a
Nothing
    , userinfoEncryptedResponseEnc :: Maybe Alg
userinfoEncryptedResponseEnc = Maybe Alg
forall a. Maybe a
Nothing
    , requestObjectSigningAlg :: Maybe Alg
requestObjectSigningAlg      = Maybe Alg
forall a. Maybe a
Nothing
    , requestObjectEncryptionAlg :: Maybe Alg
requestObjectEncryptionAlg   = Maybe Alg
forall a. Maybe a
Nothing
    , requestObjectEncryptionEnc :: Maybe Alg
requestObjectEncryptionEnc   = Maybe Alg
forall a. Maybe a
Nothing
    , tokenEndpointAuthMethod :: ClientAuthentication
tokenEndpointAuthMethod      = ClientAuthentication
ClientSecretBasic
    , tokenEndpointAuthSigningAlg :: Maybe Alg
tokenEndpointAuthSigningAlg  = Maybe Alg
forall a. Maybe a
Nothing
    , defaultMaxAge :: Maybe Int
defaultMaxAge                = Maybe Int
forall a. Maybe a
Nothing
    , requireAuthTime :: Maybe Bool
requireAuthTime              = Maybe Bool
forall a. Maybe a
Nothing
    , defaultAcrValues :: Maybe (NonEmpty Text)
defaultAcrValues             = Maybe (NonEmpty Text)
forall a. Maybe a
Nothing
    , initiateLoginUri :: Maybe URI
initiateLoginUri             = Maybe URI
forall a. Maybe a
Nothing
    , requestUris :: Maybe (NonEmpty URI)
requestUris                  = Maybe (NonEmpty URI)
forall a. Maybe a
Nothing
  }

--------------------------------------------------------------------------------
-- | Tag the 'ClientMetadata' and 'ClientMetadataResponse' types as
-- having no additional metadata parameters.
data BasicRegistration = BasicRegistration

instance ToJSON BasicRegistration where
  toJSON :: BasicRegistration -> Value
toJSON BasicRegistration
_ = [Pair] -> Value
Aeson.object [ ]

instance FromJSON BasicRegistration where
  parseJSON :: Value -> Parser BasicRegistration
parseJSON Value
_ = BasicRegistration -> Parser BasicRegistration
forall (f :: * -> *) a. Applicative f => a -> f a
pure BasicRegistration
BasicRegistration

--------------------------------------------------------------------------------
-- | Registration fields with any additional fields that are
-- necessary.  If no additional fields are needed, use
-- 'BasicRegistration' to fill the type variable.
type ClientMetadata a = Registration :*: a

--------------------------------------------------------------------------------
-- | Create a complete 'ClientMetadata' record from an existing
-- 'Registration' value and any additional client metadata parameters
-- that are needed.
--
-- If you don't need to specify additional client metadata parameters
-- you can use 'BasicRegistration' as the @a@ type.  In that case, the
-- type signature would be:
--
-- @
-- clientMetadata
--   :: Registration
--   -> BasicRegistration
--   -> ClientMetadata BasicRegistration
-- @
clientMetadata :: Registration -> a -> ClientMetadata a
clientMetadata :: Registration -> a -> ClientMetadata a
clientMetadata Registration
r a
a = (Registration, a) -> ClientMetadata a
forall a b. (a, b) -> a :*: b
Join (Registration
r, a
a)

--------------------------------------------------------------------------------
-- | Client Registration Response.
--
-- OpenID Connect Dynamic Client Registration 1.0 §3.2.
data RegistrationResponse = RegistrationResponse
  { RegistrationResponse -> Text
clientId :: Text
    -- ^ Unique Client Identifier.

  , RegistrationResponse -> Maybe Text
clientSecret :: Maybe Text
    -- ^ Client Secret.  This value is used by Confidential Clients to
    -- authenticate to the Token Endpoint, as described in Section
    -- 2.3.1 of OAuth 2.0, and for the derivation of symmetric
    -- encryption key values.

  , RegistrationResponse -> Maybe Text
registrationAccessToken :: Maybe Text
    -- ^ Registration Access Token that can be used at the Client
    -- Configuration Endpoint to perform subsequent operations upon
    -- the Client registration.

  , RegistrationResponse -> Maybe URI
registrationClientUri :: Maybe URI
    -- ^ Location of the Client Configuration Endpoint where the
    -- Registration Access Token can be used to perform subsequent
    -- operations upon the resulting Client
    -- registration. Implementations MUST either return both a Client
    -- Configuration Endpoint and a Registration Access Token or
    -- neither of them.

  , RegistrationResponse -> Maybe NumericDate
clientIdIssuedAt :: Maybe NumericDate
    -- ^ Time at which the Client Identifier was issued.

  , RegistrationResponse -> Maybe NumericDate
clientSecretExpiresAt :: Maybe NumericDate
    -- ^ If @client_secret@ is issued. Time at which the client_secret
    -- will expire or 0 if it will not expire.
  }
  deriving stock ((forall x. RegistrationResponse -> Rep RegistrationResponse x)
-> (forall x. Rep RegistrationResponse x -> RegistrationResponse)
-> Generic RegistrationResponse
forall x. Rep RegistrationResponse x -> RegistrationResponse
forall x. RegistrationResponse -> Rep RegistrationResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RegistrationResponse x -> RegistrationResponse
$cfrom :: forall x. RegistrationResponse -> Rep RegistrationResponse x
Generic, Int -> RegistrationResponse -> ShowS
[RegistrationResponse] -> ShowS
RegistrationResponse -> String
(Int -> RegistrationResponse -> ShowS)
-> (RegistrationResponse -> String)
-> ([RegistrationResponse] -> ShowS)
-> Show RegistrationResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RegistrationResponse] -> ShowS
$cshowList :: [RegistrationResponse] -> ShowS
show :: RegistrationResponse -> String
$cshow :: RegistrationResponse -> String
showsPrec :: Int -> RegistrationResponse -> ShowS
$cshowsPrec :: Int -> RegistrationResponse -> ShowS
Show)
  deriving ([RegistrationResponse] -> Encoding
[RegistrationResponse] -> Value
RegistrationResponse -> Encoding
RegistrationResponse -> Value
(RegistrationResponse -> Value)
-> (RegistrationResponse -> Encoding)
-> ([RegistrationResponse] -> Value)
-> ([RegistrationResponse] -> Encoding)
-> ToJSON RegistrationResponse
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RegistrationResponse] -> Encoding
$ctoEncodingList :: [RegistrationResponse] -> Encoding
toJSONList :: [RegistrationResponse] -> Value
$ctoJSONList :: [RegistrationResponse] -> Value
toEncoding :: RegistrationResponse -> Encoding
$ctoEncoding :: RegistrationResponse -> Encoding
toJSON :: RegistrationResponse -> Value
$ctoJSON :: RegistrationResponse -> Value
ToJSON, Value -> Parser [RegistrationResponse]
Value -> Parser RegistrationResponse
(Value -> Parser RegistrationResponse)
-> (Value -> Parser [RegistrationResponse])
-> FromJSON RegistrationResponse
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RegistrationResponse]
$cparseJSONList :: Value -> Parser [RegistrationResponse]
parseJSON :: Value -> Parser RegistrationResponse
$cparseJSON :: Value -> Parser RegistrationResponse
FromJSON) via GenericJSON RegistrationResponse

--------------------------------------------------------------------------------
-- | Like 'ClientMetadata' but includes the registration response.
type ClientMetadataResponse a = Registration :*: RegistrationResponse :*: a

--------------------------------------------------------------------------------
-- | Extract the registration value from a full registration response.
registrationFromResponse :: ClientMetadataResponse a -> Registration
registrationFromResponse :: ClientMetadataResponse a -> Registration
registrationFromResponse (Join (Join (Registration
r, RegistrationResponse
_), a
_)) = Registration
r

--------------------------------------------------------------------------------
-- | Extract the additional metadata fields from a full registration response.
additionalMetadataFromResponse :: ClientMetadataResponse a -> a
additionalMetadataFromResponse :: ClientMetadataResponse a -> a
additionalMetadataFromResponse (Join (Registration :*: RegistrationResponse
_, a
a)) = a
a

--------------------------------------------------------------------------------
-- | Extract the client details from a registration response.
clientSecretsFromResponse :: ClientMetadataResponse a -> RegistrationResponse
clientSecretsFromResponse :: ClientMetadataResponse a -> RegistrationResponse
clientSecretsFromResponse (Join (Join (Registration
_, RegistrationResponse
r), a
_)) = RegistrationResponse
r