Discovery.hs

{-# 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(..)
    ) where

import           Control.Monad.Catch                (catch, throwM)
import           Data.Aeson                         (eitherDecode)
import           Data.ByteString                    (append)
import           Data.Text                          (pack)
import qualified Jose.Jwk                           as Jwk
import           Network.HTTP.Client                (Manager, 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 location manager = do
    conf <- getConfiguration `catch` rethrow
    case conf of
        Right c   -> do
            json <- getJwkSetJson (jwksUri c) `catch` rethrow
            case jwks json of
                Right keys -> return $ Provider c keys
                Left  err  -> throwM $ DiscoveryException ("Failed to decode JwkSet: " <> pack err)
        Left  err -> throwM $ DiscoveryException ("Failed to decode configuration: " <> pack err)
  where
    appendPath suffix req = req { path = path req `append` suffix }

    getConfiguration = do
        req <- parseUrl location
        let req' = appendPath "/.well-known/openid-configuration" req
        res <- httpLbs req' manager
        return $ eitherDecode $ responseBody res

    getJwkSetJson url = do
        req <- parseUrl url
        res <- httpLbs req manager
        return $ responseBody res

    jwks j = Jwk.keys <$> eitherDecode j