{-|

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
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
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
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 :: forall (m :: * -> *) a.
(Monad m, ToJSON a, FromJSON a) =>
HTTPS m
-> Discovery
-> ClientMetadata a
-> m (Either RegistrationError (ClientMetadataResponse a))
registerClient HTTPS m
https Discovery
disco ClientMetadata a
meta = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
  URI
uri <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError RegistrationError
NoSupportForRegistrationError) forall (f :: * -> *) a. Applicative f => a -> f a
pure
               (Discovery -> Maybe URI
registrationEndpoint Discovery
disco)

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

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