{-|

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

Provider details needed by clients.

-}
module OpenID.Connect.Client.Provider
  (
    -- * Provider discovery
    ProviderDiscoveryURI
  , discovery

    -- * Provider key sets
  , keysFromDiscovery

    -- * Provider convenience record
  , Provider(..)
  , discoveryAndKeys

    -- * Error handling
  , DiscoveryError(..)

    -- * Discovery document
  , Discovery(..)

    -- * Re-exports:
  , URI(..)
  , uriToText
  ) where

--------------------------------------------------------------------------------
-- Imports:
import Control.Exception (Exception)
import Control.Monad.Except (ExceptT(..), runExceptT)
import Crypto.JOSE.JWK (JWKSet)
import Data.Bifunctor (first)
import Data.Functor ((<&>))
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
import qualified Network.URI as Network
import OpenID.Connect.Client.HTTP
import OpenID.Connect.Discovery
import OpenID.Connect.JSON

--------------------------------------------------------------------------------
-- | Errors that may occur during provider discovery.
--
-- @since 0.1.0.0
data DiscoveryError
  = DiscoveryFailedError ErrorResponse
    -- ^ Failed to decode JSON from the provider.

  | InvalidUriError Text
    -- ^ A provider's URI is invalid.  The URI is provided as 'Text'
    -- for debugging purposes.

  deriving (Int -> DiscoveryError -> ShowS
[DiscoveryError] -> ShowS
DiscoveryError -> String
(Int -> DiscoveryError -> ShowS)
-> (DiscoveryError -> String)
-> ([DiscoveryError] -> ShowS)
-> Show DiscoveryError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DiscoveryError] -> ShowS
$cshowList :: [DiscoveryError] -> ShowS
show :: DiscoveryError -> String
$cshow :: DiscoveryError -> String
showsPrec :: Int -> DiscoveryError -> ShowS
$cshowsPrec :: Int -> DiscoveryError -> ShowS
Show, Show DiscoveryError
Typeable DiscoveryError
Typeable DiscoveryError
-> Show DiscoveryError
-> (DiscoveryError -> SomeException)
-> (SomeException -> Maybe DiscoveryError)
-> (DiscoveryError -> String)
-> Exception DiscoveryError
SomeException -> Maybe DiscoveryError
DiscoveryError -> String
DiscoveryError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: DiscoveryError -> String
$cdisplayException :: DiscoveryError -> String
fromException :: SomeException -> Maybe DiscoveryError
$cfromException :: SomeException -> Maybe DiscoveryError
toException :: DiscoveryError -> SomeException
$ctoException :: DiscoveryError -> SomeException
$cp2Exception :: Show DiscoveryError
$cp1Exception :: Typeable DiscoveryError
Exception)

--------------------------------------------------------------------------------
-- | A provider record is made up of their discovery document and keys.
--
-- @since 0.1.0.0
data Provider = Provider
  { Provider -> Discovery
providerDiscovery :: Discovery  -- ^ Details from the discovery URI.
  , Provider -> JWKSet
providerKeys      :: JWKSet     -- ^ Keys from the @jwksUri@.
  }

--------------------------------------------------------------------------------
-- | Fetch the provider's discovery document.
--
-- Included with the discovery document is a 'UTCTime' value
-- indicating the time at which the content will expire and should be
-- expunged from your cache.  Obviously 'Nothing' indicates that the
-- value cannot be cached.
--
-- If the given 'ProviderDiscoveryURI' is missing its @path@
-- component, or the @path@ component is @/@ it will be rewritten to
-- the /well-known/ discovery path.
--
-- @since 0.1.0.0
discovery
  :: Applicative f
  => HTTPS f                    -- ^ A function that can make HTTPS requests.
  -> ProviderDiscoveryURI       -- ^ The provider's discovery URI.
  -> f (Either DiscoveryError (Discovery, Maybe UTCTime))
discovery :: HTTPS f
-> ProviderDiscoveryURI
-> f (Either DiscoveryError (Discovery, Maybe UTCTime))
discovery HTTPS f
https ProviderDiscoveryURI
uri =
  case Either Text ProviderDiscoveryURI -> Maybe Request
requestFromURI (ProviderDiscoveryURI -> Either Text ProviderDiscoveryURI
forall a b. b -> Either a b
Right (ProviderDiscoveryURI -> ProviderDiscoveryURI
setPath ProviderDiscoveryURI
uri)) of
    Maybe Request
Nothing  -> Either DiscoveryError (Discovery, Maybe UTCTime)
-> f (Either DiscoveryError (Discovery, Maybe UTCTime))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscoveryError -> Either DiscoveryError (Discovery, Maybe UTCTime)
forall a b. a -> Either a b
Left (Text -> DiscoveryError
InvalidUriError (ProviderDiscoveryURI -> Text
uriToText ProviderDiscoveryURI
uri)))
    Just Request
req -> HTTPS f
https Request
req f (Response ByteString)
-> (Response ByteString
    -> Either ErrorResponse (Discovery, Maybe UTCTime))
-> f (Either ErrorResponse (Discovery, Maybe UTCTime))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Response ByteString
-> Either ErrorResponse (Discovery, Maybe UTCTime)
forall a.
FromJSON a =>
Response ByteString -> Either ErrorResponse (a, Maybe UTCTime)
parseResponse f (Either ErrorResponse (Discovery, Maybe UTCTime))
-> (Either ErrorResponse (Discovery, Maybe UTCTime)
    -> Either DiscoveryError (Discovery, Maybe UTCTime))
-> f (Either DiscoveryError (Discovery, Maybe UTCTime))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (ErrorResponse -> DiscoveryError)
-> Either ErrorResponse (Discovery, Maybe UTCTime)
-> Either DiscoveryError (Discovery, Maybe UTCTime)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ErrorResponse -> DiscoveryError
DiscoveryFailedError
  where
    setPath :: Network.URI -> Network.URI
    setPath :: ProviderDiscoveryURI -> ProviderDiscoveryURI
setPath u :: ProviderDiscoveryURI
u@Network.URI{String
uriPath :: ProviderDiscoveryURI -> String
uriPath :: String
uriPath} =
      if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
uriPath Bool -> Bool -> Bool
|| String
uriPath String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"/"
        then ProviderDiscoveryURI
u {uriPath :: String
Network.uriPath = String
"/.well-known/openid-configuration"}
        else ProviderDiscoveryURI
u

--------------------------------------------------------------------------------
-- | Fetch the provider's key set.
--
-- Included with the key set is a 'UTCTime' value indicating the time
-- at which the content will expire and should be expunged from your
-- cache.
--
-- @since 0.1.0.0
keysFromDiscovery
  :: Applicative f
  => HTTPS f                    -- ^ A function that can make HTTPS requests.
  -> Discovery                  -- ^ The provider's discovery document.
  -> f (Either DiscoveryError (JWKSet, Maybe UTCTime))
keysFromDiscovery :: HTTPS f
-> Discovery -> f (Either DiscoveryError (JWKSet, Maybe UTCTime))
keysFromDiscovery HTTPS f
https Discovery{URI
jwksUri :: Discovery -> URI
jwksUri :: URI
jwksUri} =
  case Either Text ProviderDiscoveryURI -> Maybe Request
requestFromURI (ProviderDiscoveryURI -> Either Text ProviderDiscoveryURI
forall a b. b -> Either a b
Right (URI -> ProviderDiscoveryURI
getURI URI
jwksUri)) of
    Maybe Request
Nothing  -> Either DiscoveryError (JWKSet, Maybe UTCTime)
-> f (Either DiscoveryError (JWKSet, Maybe UTCTime))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiscoveryError -> Either DiscoveryError (JWKSet, Maybe UTCTime)
forall a b. a -> Either a b
Left (Text -> DiscoveryError
InvalidUriError (ProviderDiscoveryURI -> Text
uriToText (URI -> ProviderDiscoveryURI
getURI URI
jwksUri))))
    Just Request
req -> HTTPS f
https Request
req f (Response ByteString)
-> (Response ByteString
    -> Either ErrorResponse (JWKSet, Maybe UTCTime))
-> f (Either ErrorResponse (JWKSet, Maybe UTCTime))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Response ByteString -> Either ErrorResponse (JWKSet, Maybe UTCTime)
forall a.
FromJSON a =>
Response ByteString -> Either ErrorResponse (a, Maybe UTCTime)
parseResponse f (Either ErrorResponse (JWKSet, Maybe UTCTime))
-> (Either ErrorResponse (JWKSet, Maybe UTCTime)
    -> Either DiscoveryError (JWKSet, Maybe UTCTime))
-> f (Either DiscoveryError (JWKSet, Maybe UTCTime))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (ErrorResponse -> DiscoveryError)
-> Either ErrorResponse (JWKSet, Maybe UTCTime)
-> Either DiscoveryError (JWKSet, Maybe UTCTime)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ErrorResponse -> DiscoveryError
DiscoveryFailedError

--------------------------------------------------------------------------------
-- | Fetch a provider's discovery document and key set.
--
-- This is a convenience function that simply calls 'discovery' and
-- 'keysFromDiscovery', wrapping them in a 'Provider'.
--
-- If you are caching the results of these functions you probably want
-- to call them individually since they might have very different
-- cache expiration times.
--
-- The expiration time returned from this function is the lesser of
-- the two constituents.
--
-- @since 0.1.0.0
discoveryAndKeys
  :: Monad m
  => HTTPS m                    -- ^ A function that can make HTTPS requests.
  -> ProviderDiscoveryURI       -- ^ The provider's discovery URI.
  -> m (Either DiscoveryError (Provider, Maybe UTCTime))
discoveryAndKeys :: HTTPS m
-> ProviderDiscoveryURI
-> m (Either DiscoveryError (Provider, Maybe UTCTime))
discoveryAndKeys HTTPS m
https ProviderDiscoveryURI
uri = ExceptT DiscoveryError m (Provider, Maybe UTCTime)
-> m (Either DiscoveryError (Provider, Maybe UTCTime))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT DiscoveryError m (Provider, Maybe UTCTime)
 -> m (Either DiscoveryError (Provider, Maybe UTCTime)))
-> ExceptT DiscoveryError m (Provider, Maybe UTCTime)
-> m (Either DiscoveryError (Provider, Maybe UTCTime))
forall a b. (a -> b) -> a -> b
$ do
  (Discovery
d, Maybe UTCTime
t1) <- m (Either DiscoveryError (Discovery, Maybe UTCTime))
-> ExceptT DiscoveryError m (Discovery, Maybe UTCTime)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (HTTPS m
-> ProviderDiscoveryURI
-> m (Either DiscoveryError (Discovery, Maybe UTCTime))
forall (f :: * -> *).
Applicative f =>
HTTPS f
-> ProviderDiscoveryURI
-> f (Either DiscoveryError (Discovery, Maybe UTCTime))
discovery HTTPS m
https ProviderDiscoveryURI
uri )
  (JWKSet
k, Maybe UTCTime
t2) <- m (Either DiscoveryError (JWKSet, Maybe UTCTime))
-> ExceptT DiscoveryError m (JWKSet, Maybe UTCTime)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (HTTPS m
-> Discovery -> m (Either DiscoveryError (JWKSet, Maybe UTCTime))
forall (f :: * -> *).
Applicative f =>
HTTPS f
-> Discovery -> f (Either DiscoveryError (JWKSet, Maybe UTCTime))
keysFromDiscovery HTTPS m
https Discovery
d)
  (Provider, Maybe UTCTime)
-> ExceptT DiscoveryError m (Provider, Maybe UTCTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Discovery -> JWKSet -> Provider
Provider Discovery
d JWKSet
k, UTCTime -> UTCTime -> UTCTime
forall a. Ord a => a -> a -> a
min (UTCTime -> UTCTime -> UTCTime)
-> Maybe UTCTime -> Maybe (UTCTime -> UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UTCTime
t1 Maybe (UTCTime -> UTCTime) -> Maybe UTCTime -> Maybe UTCTime
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe UTCTime
t2)