{-# LANGUAGE OverloadedStrings #-}
{-|
    Module: Web.OIDC.Client.Discovery
    Maintainer: krdlab@gmail.com
    Stability: experimental
-}
module Web.OIDC.Client.Discovery
    (
      discover

    -- * OpenID Provider Issuers
    , google

    -- * OpenID Provider Configuration Information
    , Provider(..)
    , Configuration(..)

    -- * For testing
    , generateDiscoveryUrl
    ) where

import           Control.Monad.Catch                (catch, throwM)
import           Data.Aeson                         (eitherDecode)
import           Data.ByteString                    (append, isSuffixOf)
import           Data.Monoid                        ((<>))
import           Data.Text                          (pack)
import qualified Jose.Jwk                           as Jwk
import           Network.HTTP.Client                (Manager, Request, httpLbs,
                                                     path, responseBody)

import           Web.OIDC.Client.Discovery.Issuers  (google)
import           Web.OIDC.Client.Discovery.Provider (Configuration (..),
                                                     Provider (..))
import           Web.OIDC.Client.Internal           (parseUrl, rethrow)
import           Web.OIDC.Client.Types              (IssuerLocation,
                                                     OpenIdException (..))

-- | This function obtains OpenID Provider configuration and JWK set.
discover
    :: IssuerLocation   -- ^ OpenID Provider's Issuer location
    -> Manager
    -> IO Provider
discover :: Text -> Manager -> IO Provider
discover Text
location Manager
manager = do
    Either String Configuration
conf <- IO (Either String Configuration)
getConfiguration forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` forall (m :: * -> *) a. MonadCatch m => HttpException -> m a
rethrow
    case Either String Configuration
conf of
        Right Configuration
c   -> do
            ByteString
json <- Text -> IO ByteString
getJwkSetJson (Configuration -> Text
jwksUri Configuration
c) forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` forall (m :: * -> *) a. MonadCatch m => HttpException -> m a
rethrow
            case ByteString -> Either String [Jwk]
jwks ByteString
json of
                Right [Jwk]
keys -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Configuration -> [Jwk] -> Provider
Provider Configuration
c [Jwk]
keys
                Left  String
err  -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Text -> OpenIdException
DiscoveryException (Text
"Failed to decode JwkSet: " forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
err)
        Left  String
err -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Text -> OpenIdException
DiscoveryException (Text
"Failed to decode configuration: " forall a. Semigroup a => a -> a -> a
<> String -> Text
pack String
err)
  where
    getConfiguration :: IO (Either String Configuration)
getConfiguration = do
        Request
req <- Text -> IO Request
generateDiscoveryUrl Text
location
        Response ByteString
res <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
manager
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either String a
eitherDecode forall a b. (a -> b) -> a -> b
$ forall body. Response body -> body
responseBody Response ByteString
res

    getJwkSetJson :: Text -> IO ByteString
getJwkSetJson Text
url = do
        Request
req <- forall (m :: * -> *). MonadThrow m => Text -> m Request
parseUrl Text
url
        Response ByteString
res <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
manager
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall body. Response body -> body
responseBody Response ByteString
res

    jwks :: ByteString -> Either String [Jwk]
jwks ByteString
j = JwkSet -> [Jwk]
Jwk.keys forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
j

generateDiscoveryUrl :: IssuerLocation -> IO Request
generateDiscoveryUrl :: Text -> IO Request
generateDiscoveryUrl Text
location = do
    Request
req <- forall (m :: * -> *). MonadThrow m => Text -> m Request
parseUrl Text
location
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Request
appendPath ByteString
".well-known/openid-configuration" Request
req
  where
    appendPath :: ByteString -> Request -> Request
appendPath ByteString
suffix Request
req =
        let p :: ByteString
p = Request -> ByteString
path Request
req
            p' :: ByteString
p' = if ByteString
"/" ByteString -> ByteString -> Bool
`isSuffixOf` ByteString
p then ByteString
p else ByteString
p ByteString -> ByteString -> ByteString
`append` ByteString
"/"
        in
            Request
req { path :: ByteString
path = ByteString
p' ByteString -> ByteString -> ByteString
`append` ByteString
suffix }