{-|

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.Client.DynamicRegistration
  (
    -- * Registration
    registerClient

    -- * Errors that can occur
  , RegistrationError(..)

    -- * Re-exports
  , HTTPS
  , ErrorResponse(..)
  , module OpenID.Connect.Registration
  ) where

--------------------------------------------------------------------------------
-- Imports:
import Control.Exception (Exception)
import Control.Monad.Except
import Data.Bifunctor (bimap)
import Data.Functor ((<&>))
import OpenID.Connect.Client.HTTP
import OpenID.Connect.Discovery
import OpenID.Connect.JSON
import OpenID.Connect.Registration

--------------------------------------------------------------------------------
-- | Errors that can occur during dynamic client registration.
data RegistrationError
  = NoSupportForRegistrationError
  | RegistrationFailedError ErrorResponse
  deriving (Int -> RegistrationError -> ShowS
[RegistrationError] -> ShowS
RegistrationError -> String
(Int -> RegistrationError -> ShowS)
-> (RegistrationError -> String)
-> ([RegistrationError] -> ShowS)
-> Show RegistrationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RegistrationError] -> ShowS
$cshowList :: [RegistrationError] -> ShowS
show :: RegistrationError -> String
$cshow :: RegistrationError -> String
showsPrec :: Int -> RegistrationError -> ShowS
$cshowsPrec :: Int -> RegistrationError -> ShowS
Show, Show RegistrationError
Typeable RegistrationError
Typeable RegistrationError
-> Show RegistrationError
-> (RegistrationError -> SomeException)
-> (SomeException -> Maybe RegistrationError)
-> (RegistrationError -> String)
-> Exception RegistrationError
SomeException -> Maybe RegistrationError
RegistrationError -> String
RegistrationError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: RegistrationError -> String
$cdisplayException :: RegistrationError -> String
fromException :: SomeException -> Maybe RegistrationError
$cfromException :: SomeException -> Maybe RegistrationError
toException :: RegistrationError -> SomeException
$ctoException :: RegistrationError -> SomeException
$cp2Exception :: Show RegistrationError
$cp1Exception :: Typeable RegistrationError
Exception)

--------------------------------------------------------------------------------
-- | Register a client with the provider described by the 'Discovery' document.
--
-- Example:
--
-- @
-- let reg = 'defaultRegistration' yourClientRedirURI
--     metadata = 'clientMetadata' reg 'BasicRegistration'
-- in registerClient http discoveryDoc metadata
-- @
registerClient
  :: (Monad m, ToJSON a, FromJSON a)
  => HTTPS m
  -> Discovery
  -> ClientMetadata a
  -> m (Either RegistrationError (ClientMetadataResponse a))
registerClient :: HTTPS m
-> Discovery
-> ClientMetadata a
-> m (Either RegistrationError (ClientMetadataResponse a))
registerClient HTTPS m
https Discovery
disco ClientMetadata a
meta = ExceptT RegistrationError m (ClientMetadataResponse a)
-> m (Either RegistrationError (ClientMetadataResponse a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT RegistrationError m (ClientMetadataResponse a)
 -> m (Either RegistrationError (ClientMetadataResponse a)))
-> ExceptT RegistrationError m (ClientMetadataResponse a)
-> m (Either RegistrationError (ClientMetadataResponse a))
forall a b. (a -> b) -> a -> b
$ do
  URI
uri <- ExceptT RegistrationError m URI
-> (URI -> ExceptT RegistrationError m URI)
-> Maybe URI
-> ExceptT RegistrationError m URI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (RegistrationError -> ExceptT RegistrationError m URI
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RegistrationError
NoSupportForRegistrationError) URI -> ExceptT RegistrationError m URI
forall (f :: * -> *) a. Applicative f => a -> f a
pure
               (Discovery -> Maybe URI
registrationEndpoint Discovery
disco)

  Request
req <- ExceptT RegistrationError m Request
-> (Request -> ExceptT RegistrationError m Request)
-> Maybe Request
-> ExceptT RegistrationError m Request
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (RegistrationError -> ExceptT RegistrationError m Request
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RegistrationError
NoSupportForRegistrationError) Request -> ExceptT RegistrationError m Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure
               (Either Text URI -> Maybe Request
requestFromURI (URI -> Either Text URI
forall a b. b -> Either a b
Right (URI -> URI
getURI URI
uri)))

  m (Either RegistrationError (ClientMetadataResponse a))
-> ExceptT RegistrationError m (ClientMetadataResponse a)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (HTTPS m
https (ClientMetadata a -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
jsonPostRequest ClientMetadata a
meta Request
req)
            m (Response ByteString)
-> (Response ByteString
    -> Either ErrorResponse (ClientMetadataResponse a, Maybe UTCTime))
-> m (Either
        ErrorResponse (ClientMetadataResponse a, Maybe UTCTime))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Response ByteString
-> Either ErrorResponse (ClientMetadataResponse a, Maybe UTCTime)
forall a.
FromJSON a =>
Response ByteString -> Either ErrorResponse (a, Maybe UTCTime)
parseResponse
            m (Either ErrorResponse (ClientMetadataResponse a, Maybe UTCTime))
-> (Either ErrorResponse (ClientMetadataResponse a, Maybe UTCTime)
    -> Either RegistrationError (ClientMetadataResponse a))
-> m (Either RegistrationError (ClientMetadataResponse a))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (ErrorResponse -> RegistrationError)
-> ((ClientMetadataResponse a, Maybe UTCTime)
    -> ClientMetadataResponse a)
-> Either ErrorResponse (ClientMetadataResponse a, Maybe UTCTime)
-> Either RegistrationError (ClientMetadataResponse a)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ErrorResponse -> RegistrationError
RegistrationFailedError (ClientMetadataResponse a, Maybe UTCTime)
-> ClientMetadataResponse a
forall a b. (a, b) -> a
fst)