{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
-- | A yesod-auth plugin for per-tenant SSO via OpenID Connect, using
-- Authorization Code flow (AKA server flow) with client_secret_post
-- client authentication.
--
-- Reserves "ya-oidc-*" as session keys.
--
-- Referenced standards:
-- * OIDC Core: https://openid.net/specs/openid-connect-core-1_0.html
-- * RFC 6749, OAuth 2.0: https://tools.ietf.org/html/rfc6749
-- * RFC 6750, OAuth 2.0 Bearer Token Usage: https://tools.ietf.org/html/rfc6750
module Yesod.Auth.OIDC
  ( oidcPluginName
  , authOIDC
  , ClientId(..)
  , ClientSecret(..)
  , UserInfo
  , UserInfoPreference(..)
  , YesodAuthOIDC(..)
  , OAuthErrorResponse(..)
  , oidcSessionExpiryMiddleware

  -- * Routes
  , oidcLoginR
  , oidcForwardR
  , oidcCallbackR

  -- * Re-exported from oidc-client
  , Configuration(..)
  , Provider(..)
  , IssuerLocation
  , Tokens(..)
  , IdTokenClaims(..)

  -- * Exposed or re-exported for testing and mocking
  , MockOidcProvider(..)
  , SessionStore(..)
  , OIDC(..)
  , JwsAlgJson(..)
  , JwsAlg(..)
  , Jwt(..)
  , IntDate(..)
  , CallbackInput(..)
  ) where

import ClassyPrelude.Yesod
import qualified "cryptonite" Crypto.Random as Crypto
import qualified Data.Aeson as J
import qualified Data.ByteString.Base64.URL as Base64Url
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HashSet
import qualified Data.Text as T
import Data.Time.Clock
import Data.Time.Clock.POSIX
import qualified Network.HTTP.Client as HTTP
import Web.OIDC.Client as Client
import Web.OIDC.Client.Discovery.Provider (JwsAlgJson(..))
import Web.OIDC.Client.Settings
import qualified Web.OIDC.Client.Types as Scopes
import Yesod.Auth

-- For re-export for mocking:
import Jose.Jwa (JwsAlg(..))
import Jose.Jwt (IntDate(..), Jwt(..))

data YesodAuthOIDCException
  = InvalidQueryParamsException Text
  | BadLoginHint
  | NoProviderConfigException
  | InvalidSecurityTokenException
  | TLSNotUsedException Text
  | UnknownTokenType Text
  deriving Int -> YesodAuthOIDCException -> ShowS
[YesodAuthOIDCException] -> ShowS
YesodAuthOIDCException -> String
(Int -> YesodAuthOIDCException -> ShowS)
-> (YesodAuthOIDCException -> String)
-> ([YesodAuthOIDCException] -> ShowS)
-> Show YesodAuthOIDCException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [YesodAuthOIDCException] -> ShowS
$cshowList :: [YesodAuthOIDCException] -> ShowS
show :: YesodAuthOIDCException -> String
$cshow :: YesodAuthOIDCException -> String
showsPrec :: Int -> YesodAuthOIDCException -> ShowS
$cshowsPrec :: Int -> YesodAuthOIDCException -> ShowS
Show

instance Exception YesodAuthOIDCException

-- | Add this value to your YesodAuth instance's 'authPlugins' list
authOIDC :: YesodAuthOIDC site => AuthPlugin site
authOIDC :: AuthPlugin site
authOIDC = Text
-> (Text -> [Text] -> AuthHandler site TypedContent)
-> ((Route Auth -> Route site) -> WidgetFor site ())
-> AuthPlugin site
forall master.
Text
-> (Text -> [Text] -> AuthHandler master TypedContent)
-> ((Route Auth -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin Text
oidcPluginName Text -> [Text] -> AuthHandler site TypedContent
forall site.
YesodAuthOIDC site =>
Text -> [Text] -> AuthHandler site TypedContent
dispatch (Route Auth -> Route site) -> WidgetFor site ()
forall site. (Route Auth -> Route site) -> WidgetFor site ()
loginW

-- | The login hint is sent as the `login_hint` query parameter to the
-- service provider's authentication URL. It is commonly an email
-- address and hence why oidcForwardR takes an "email" post
-- parameter. It can be used not only for this purpose but also as a
-- hint to your own app about which tenant configuration to use (based
-- on the email domain perhaps).
type LoginHint = Text

-- | Response of call to the UserInfo Endpoint. This library does not
-- currently support signed or encrypted responses to this particular
-- request (unlike the ID Token response which must be signed). C.f.
-- OIDC Core 5.3.2
type UserInfo = J.Object

-- | Write an instance of this class for your Yesod App
class (YesodAuth site) => YesodAuthOIDC site where
  -- | (Optional). If this is False, there will be no '/auth/page/oidc/login' with
  -- its default form asking for an email. This can be used if you
  -- consolidate your various yesod auth plugins into one login page
  -- outside of this plugin. In that case, you would initialise OIDC
  -- login by POSTing to 'oidcForwardR' with "email" and Yesod's
  -- 'defaultCsrfParamName' from your own page. Defaut is True.
  enableLoginPage :: Bool
  enableLoginPage = Bool
True

  -- | (Optional) A callback to your app in case oidcForwardR is
  -- called without the login_hint query parameter. Default
  -- implementation throws a 'BadLoginHint' exception.
  onBadLoginHint :: AuthHandler site TypedContent
  onBadLoginHint = YesodAuthOIDCException -> m TypedContent
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO YesodAuthOIDCException
BadLoginHint

  -- | Looks up configuration. If none can be found, you should handle
  -- the fallback / error call yourself. Returns the ClientID for the
  -- given identity provider, and either the provider configuration
  -- itself, or otherwise just the Issuer URI. If the latter, this
  -- library will use OIDC discovery to retrieve the configuration.
  --
  -- The Issuer URI should only consist of the scheme (which must be
  -- "https:") and fully qualified host name (e.g. example.com), with
  -- no path etc.
  --
  -- The full configuration could be hard-coded or the cached result
  -- of a previous discovery. Cf 'onProviderConfigDiscovered'.
  --
  -- Note that the 'Provider' is both the configuration and the result of
  -- retrieving the keyset from jwks_uri.
  getProviderConfig ::
    LoginHint -> AuthHandler site (Either Provider IssuerLocation, ClientId)

  -- | (Optional). If the tenant is configured via a discovery URL,
  -- this function will be called with the discovered result and that
  -- result's retrieved keyset. This can be used to cache the
  -- configuration for the given duration. Since the oidc-client
  -- library combines discovery with key retrieval, the given time is
  -- the minimum of the two remaining cache lifetimes returned by both
  -- http requests.
  onProviderConfigDiscovered ::
    Provider -> ClientId -> DiffTime -> AuthHandler site ()
  onProviderConfigDiscovered _ _ _ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  -- | (Optional). Do something if the 'oidcCallbackR' was called with
  -- incorrect parameters or the Identity Provider returned an
  -- error. This could happen if the request is not legitimate or if
  -- the identity provider doesn't provide the required `state` or
  -- `code` query or post parameters.
  --
  -- Defaults to a simple page showing the error (sans the error_uri).
  onBadCallbackRequest ::
    Maybe OAuthErrorResponse
    -- ^ The OAuth Error Response if present (See RFC6749 §5.2 and
    -- OIDC §3.1.2.6). This will only be 'Just' if the "state" param
    -- (anti-CSRF token) is valid.
    -> AuthHandler site a
  onBadCallbackRequest mError :: Maybe OAuthErrorResponse
mError = do
    Html
errHtml <- WidgetFor site () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor site () -> m Html) -> WidgetFor site () -> m Html
forall a b. (a -> b) -> a -> b
$ WidgetFor site () -> WidgetFor site ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget WidgetFor site ()
widg
    Status -> Html -> m a
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
Status -> c -> m a
sendResponseStatus Status
status400 Html
errHtml
    where
      widg :: WidgetFor site ()
widg =
        [whamlet|
          <h1>Error
          <p>There has been some miscommunication between your Identity Provider and our application.
          <p>Please try logging in again and contact support if the problem persists.
          $maybe OAuthErrorResponse err mErrDesc _ <- mError
            <p><i>Error code:</i> #{err}
            $maybe errDesc <- mErrDesc
              <p><i>Error description: </i>#{errDesc}
            $maybe errUri <- mErrDesc
              <p><i>More information: </i>#{errUri}
        |]

  -- | The printable-ASCII client_secret which you've set up with the
  -- provider ahead of time (this library does not support the dynamic
  -- registration spec).
  getClientSecret :: ClientId -> Configuration -> AuthHandler site ClientSecret

  -- | (Optional). The scopes that you are requesting. The "openid"
  -- scope will always be included in the eventual request whether or
  -- not you specify it here. Defaults to ["email"].
  getScopes :: ClientId -> Configuration -> AuthHandler site [ScopeValue]
  getScopes _ _ = [Text] -> m [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text
email]

  -- | (Optional). Configure the behaviour of when to request user
  -- information. The default behaviour is to only make this request
  -- if it's necessary satisfy the scopes in 'getScopes'.
  getUserInfoPreference ::
    LoginHint -> ClientId -> Configuration -> AuthHandler site UserInfoPreference
  getUserInfoPreference _ _ _ = UserInfoPreference -> m UserInfoPreference
forall (f :: * -> *) a. Applicative f => a -> f a
pure UserInfoPreference
GetUserInfoOnlyToSatisfyRequestedScopes

  -- | (Required). Should return a unique identifier for this user to
  -- use as the key in the yesod app's session backend. Sent after the
  -- user has successfully authenticated and right before telling
  -- Yesod that the user is authenticated. This function can still
  -- cancel authentication if it throws an error or short-circuits.
  --
  -- If you are using the underlying OAuth spec for non-OIDC reasons,
  -- you can do extra work here, such as storing the access and
  -- refresh tokens.
  onSuccessfulAuthentication ::
    LoginHint
    -- ^ *Warning*: This is original login hint (typically an email),
    -- does *not* assert anything about the user's identity. The user
    -- could have logged in with an email different to this one, or
    -- their email at the Identity Provider could just be different to
    -- this hint. Use the information in the ID Token and UserInfo
    -- Response for authentic identity information.
    -> ClientId
    -> Provider
    -> Tokens J.Object
    -- ^ The OIDC 'Token Response', including a fully validated ID
    -- Token. The 'otherClaims' value is purposefully an unparsed JSON
    -- object to provide maximum flexibility.
    -> Maybe UserInfo
    -- ^ The response of the userinfo endpoint is given depending on
    -- the 'getUserInfoPreference' and whether the request was
    -- actually successful. For flexibility, any exceptions in the
    -- course of getting the UserInfo are caught by this library;
    -- such errors only manifest as an unexpected 'Nothing' here.
    -> AuthHandler site Text

  -- | Defaults to clearing the credentials from the session and
  -- redirecting to the site's logoutDest (if not currently there
  -- already or out loginDest)
  onSessionExpiry :: HandlerFor site ()
  onSessionExpiry = Bool -> HandlerFor site ()
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Bool -> m ()
clearCreds Bool
True

  -- | Should return your app's 'HttpManager' or a mock for
  -- testing. Allows high-level mocking of the 3 functions that use
  -- the HttpManager (as opposed to a lower-level mock of the 3 HTTP
  -- responses themselves).
  getHttpManagerForOidc ::
    AuthHandler site (Either MockOidcProvider HTTP.Manager)

data MockOidcProvider = MockOidcProvider
  { MockOidcProvider -> Text -> Provider
mopDiscover :: Text -> Provider
  , MockOidcProvider
-> Text
-> CallbackInput
-> SessionStore IO
-> OIDC
-> Tokens Object
mopGetValidTokens ::
      LoginHint -> CallbackInput -> SessionStore IO -> OIDC -> Tokens J.Object
  , MockOidcProvider -> Request -> Tokens Object -> Maybe Object
mopRequestUserInfo :: HTTP.Request -> Tokens (J.Object) -> Maybe J.Object
  }

data UserInfoPreference
  = GetUserInfoIfAvailable
    -- ^ Always requests the userinfo, as long as the 'Provider'
    -- configuration has a userinfo endpoint.
  | GetUserInfoOnlyToSatisfyRequestedScopes
    -- ^ (Default). Only requests the user info if a) it's available
    -- and b) the token endpoint did not return all the scoped claims
    -- requested (cf 'getScopes'). For example, many Identity
    -- Providers will return "email" in the token response, and thus
    -- there is no need to request the user info if that's all your
    -- app wants.
  | NeverGetUserInfo
  deriving (Int -> UserInfoPreference -> ShowS
[UserInfoPreference] -> ShowS
UserInfoPreference -> String
(Int -> UserInfoPreference -> ShowS)
-> (UserInfoPreference -> String)
-> ([UserInfoPreference] -> ShowS)
-> Show UserInfoPreference
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserInfoPreference] -> ShowS
$cshowList :: [UserInfoPreference] -> ShowS
show :: UserInfoPreference -> String
$cshow :: UserInfoPreference -> String
showsPrec :: Int -> UserInfoPreference -> ShowS
$cshowsPrec :: Int -> UserInfoPreference -> ShowS
Show, UserInfoPreference -> UserInfoPreference -> Bool
(UserInfoPreference -> UserInfoPreference -> Bool)
-> (UserInfoPreference -> UserInfoPreference -> Bool)
-> Eq UserInfoPreference
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserInfoPreference -> UserInfoPreference -> Bool
$c/= :: UserInfoPreference -> UserInfoPreference -> Bool
== :: UserInfoPreference -> UserInfoPreference -> Bool
$c== :: UserInfoPreference -> UserInfoPreference -> Bool
Eq)

-- | The name used to render this plugin's routes, "oidc".
oidcPluginName :: Text
oidcPluginName :: Text
oidcPluginName = "oidc"

-- | Optional route that reads in the "login hint" (commonly an email
-- address). Your app can use this for its main login screen, or it
-- could have a separate login screen not managed by this plugin but
-- which redirects to 'oidcForwardR' with the login_hint when
-- appropriate.
--
-- /auth/page/oidc/login
oidcLoginR :: AuthRoute
oidcLoginR :: Route Auth
oidcLoginR = Text -> [Text] -> Route Auth
PluginR Text
oidcPluginName ["login"]

-- | This accepts an `email` post param. Looks up or discovers
-- the OIDC provider associated with this login_hint, and redirects
-- the user to the provider's Authorization Endpoint.
--
-- /auth/page/oidc/forward
oidcForwardR :: AuthRoute
oidcForwardR :: Route Auth
oidcForwardR = Text -> [Text] -> Route Auth
PluginR Text
oidcPluginName ["forward"]

-- | This route is given to the provider so that the provider can
-- redirect the user here with the appropriate Authorisation Code, at
-- which point the library continues the authentication process.
--
-- /auth/page/oidc/callback
oidcCallbackR :: AuthRoute
oidcCallbackR :: Route Auth
oidcCallbackR = Text -> [Text] -> Route Auth
PluginR Text
oidcPluginName ["callback"]

dispatch :: forall site. YesodAuthOIDC site
         => Text -> [Text] -> AuthHandler site TypedContent
dispatch :: Text -> [Text] -> AuthHandler site TypedContent
dispatch httpMethod :: Text
httpMethod uriPath :: [Text]
uriPath = case (Text
httpMethod, [Text]
uriPath) of
  ("GET", ["login"]) -> if YesodAuthOIDC site => Bool
forall site. YesodAuthOIDC site => Bool
enableLoginPage @site then m TypedContent
forall site. YesodAuthOIDC site => AuthHandler site TypedContent
getLoginR else m TypedContent
forall (m :: * -> *) a. MonadHandler m => m a
notFound
  ("POST", ["forward"]) -> m TypedContent
forall site. YesodAuthOIDC site => AuthHandler site TypedContent
postForwardR

  -- These two handlers are ultimately the same handler. Identity
  -- Providers may use GET or POST for the callback.
  ("GET", ["callback"]) -> StdMethod -> AuthHandler site TypedContent
forall site.
YesodAuthOIDC site =>
StdMethod -> AuthHandler site TypedContent
handleCallback StdMethod
GET
  ("POST", ["callback"]) -> StdMethod -> AuthHandler site TypedContent
forall site.
YesodAuthOIDC site =>
StdMethod -> AuthHandler site TypedContent
handleCallback StdMethod
POST
  _ -> m TypedContent
forall (m :: * -> *) a. MonadHandler m => m a
notFound

loginW :: (Route Auth -> Route site) -> WidgetFor site ()
loginW :: (Route Auth -> Route site) -> WidgetFor site ()
loginW toParentRoute :: Route Auth -> Route site
toParentRoute = do
  Maybe Text
mToken <- YesodRequest -> Maybe Text
reqToken (YesodRequest -> Maybe Text)
-> WidgetFor site YesodRequest -> WidgetFor site (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor (HandlerSite (WidgetFor site)) YesodRequest
-> WidgetFor site YesodRequest
forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler HandlerFor (HandlerSite (WidgetFor site)) YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
  [whamlet|
    <h1>Sign in
    <p>
      Sign in with OpenID Connect (single sign on). Enter your email,
      and we'll redirect you to your company's login page.
    <form action="@{toParentRoute oidcForwardR}">
      $maybe token <- mToken
        <input type=hidden name=#{defaultCsrfParamName} value=#{token}>
      <input type=email name=email placeholder="Enter your corporate email">
      <button type=submit aria-label="Sign in">
  |]

getLoginR :: YesodAuthOIDC site => AuthHandler site TypedContent
getLoginR :: AuthHandler site TypedContent
getLoginR = do
  Route Auth -> Route site
rtp <- m (Route Auth -> Route site)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
  Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> (WidgetFor site () -> Writer (Endo [ProvidedRep m]) ())
-> WidgetFor site ()
-> m TypedContent
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> (WidgetFor site () -> m Html)
-> WidgetFor site ()
-> Writer (Endo [ProvidedRep m]) ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WidgetFor site () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor site () -> m TypedContent)
-> WidgetFor site () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ WidgetFor site () -> WidgetFor site ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget (WidgetFor site () -> WidgetFor site ())
-> WidgetFor site () -> WidgetFor site ()
forall a b. (a -> b) -> a -> b
$ (Route Auth -> Route site) -> WidgetFor site ()
forall site. (Route Auth -> Route site) -> WidgetFor site ()
loginW Route Auth -> Route site
rtp

findProvider :: YesodAuthOIDC site
             => LoginHint -> AuthHandler site (Provider, ClientId)
findProvider :: Text -> AuthHandler site (Provider, ClientId)
findProvider loginHint :: Text
loginHint = Text -> AuthHandler site (Either Provider Text, ClientId)
forall site.
YesodAuthOIDC site =>
Text -> AuthHandler site (Either Provider Text, ClientId)
getProviderConfig Text
loginHint m (Either Provider Text, ClientId)
-> ((Either Provider Text, ClientId) -> m (Provider, ClientId))
-> m (Provider, ClientId)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  (Left provider :: Provider
provider, clientId :: ClientId
clientId) ->
    (Provider, ClientId) -> m (Provider, ClientId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Provider
provider, ClientId
clientId)
  (Right issuerLoc :: Text
issuerLoc, clientId :: ClientId
clientId) -> do
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ("https:" Text -> Text -> Bool
`T.isPrefixOf` Text
issuerLoc
            Bool -> Bool -> Bool
|| "http://localhost" Text -> Text -> Bool
`T.isPrefixOf` Text
issuerLoc) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      YesodAuthOIDCException -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (YesodAuthOIDCException -> m ()) -> YesodAuthOIDCException -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> YesodAuthOIDCException
TLSNotUsedException
        (Text -> YesodAuthOIDCException) -> Text -> YesodAuthOIDCException
forall a b. (a -> b) -> a -> b
$ "The issuer location doesn't start with 'https:'. \
          \OIDC requires all communication with the IdP to use TLS."
    Provider
provider <- m (Either MockOidcProvider Manager)
forall site.
YesodAuthOIDC site =>
AuthHandler site (Either MockOidcProvider Manager)
getHttpManagerForOidc m (Either MockOidcProvider Manager)
-> (Either MockOidcProvider Manager -> m Provider) -> m Provider
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left mock :: MockOidcProvider
mock -> Provider -> m Provider
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Provider -> m Provider) -> Provider -> m Provider
forall a b. (a -> b) -> a -> b
$ (MockOidcProvider -> Text -> Provider
mopDiscover MockOidcProvider
mock) Text
issuerLoc
      Right mgr :: Manager
mgr -> IO Provider -> m Provider
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Provider -> m Provider) -> IO Provider -> m Provider
forall a b. (a -> b) -> a -> b
$ Text -> Manager -> IO Provider
discover Text
issuerLoc Manager
mgr
    Provider -> ClientId -> DiffTime -> AuthHandler site ()
forall site.
YesodAuthOIDC site =>
Provider -> ClientId -> DiffTime -> AuthHandler site ()
onProviderConfigDiscovered Provider
provider ClientId
clientId 60
    (Provider, ClientId) -> m (Provider, ClientId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Provider
provider, ClientId
clientId)

-- | Expects 'email' and '_token' post params.
postForwardR :: YesodAuthOIDC site
            => AuthHandler site TypedContent
postForwardR :: AuthHandler site TypedContent
postForwardR = do
  Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
checkCsrfParamNamed Text
defaultCsrfParamName
  Maybe Text
mLoginHint <- Text -> m (Maybe Text)
forall (m :: * -> *).
(MonadResource m, MonadHandler m) =>
Text -> m (Maybe Text)
lookupPostParam "email"
  case Maybe Text
mLoginHint of
    Nothing -> m TypedContent
forall site. YesodAuthOIDC site => AuthHandler site TypedContent
onBadLoginHint
    Just loginHint :: Text
loginHint -> do
      (provider :: Provider
provider, clientId :: ClientId
clientId) <- Text -> AuthHandler site (Provider, ClientId)
forall site.
YesodAuthOIDC site =>
Text -> AuthHandler site (Provider, ClientId)
findProvider Text
loginHint
      Text -> Provider -> ClientId -> AuthHandler site TypedContent
forall a.
YesodAuthOIDC a =>
Text -> Provider -> ClientId -> AuthHandler a TypedContent
forward Text
loginHint Provider
provider ClientId
clientId

-- Generates a 64-bit nonce encoded as uri-safe base64
genNonce :: IO ByteString
genNonce :: IO ByteString
genNonce = ByteString -> ByteString
Base64Url.encode (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO ByteString
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
Crypto.getRandomBytes 64

sessionPrefix :: Text
sessionPrefix :: Text
sessionPrefix = "ya"

nonceSessionKey :: Text
nonceSessionKey :: Text
nonceSessionKey = Text
sessionPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "-oidc-nonce"

stateSessionKey :: Text
stateSessionKey :: Text
stateSessionKey = Text
sessionPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "-oidc-state"

loginHintSessionKey :: Text
loginHintSessionKey :: Text
loginHintSessionKey = Text
sessionPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "-oidc-login-hint"

-- oidc-client's CodeFlow functions have a `MonadCatch m` constraint,
-- and take a `SessionStore m` argument. Handlers in Yesod do not
-- implement MonadCatch, so we use m ~ IO, and then unliftIO to still
-- use Handler calls in the 'SessionStore IO'
makeSessionStore :: AuthHandler site (SessionStore IO)
makeSessionStore :: m (SessionStore IO)
makeSessionStore = do
  UnliftIO unlift :: forall a. m a -> IO a
unlift <- m (UnliftIO m)
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
  SessionStore IO -> m (SessionStore IO)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SessionStore IO -> m (SessionStore IO))
-> SessionStore IO -> m (SessionStore IO)
forall a b. (a -> b) -> a -> b
$ SessionStore :: forall (m :: * -> *).
m ByteString
-> (ByteString -> ByteString -> m ())
-> m (Maybe ByteString, Maybe ByteString)
-> m ()
-> SessionStore m
SessionStore
    { sessionStoreGenerate :: IO ByteString
sessionStoreGenerate = IO ByteString
genNonce
    , sessionStoreSave :: ByteString -> ByteString -> IO ()
sessionStoreSave = \state :: ByteString
state nonce :: ByteString
nonce -> m () -> IO ()
forall a. m a -> IO a
unlift (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> ByteString -> m ()
forall (m :: * -> *). MonadHandler m => Text -> ByteString -> m ()
setSessionBS Text
stateSessionKey ByteString
state
        Text -> ByteString -> m ()
forall (m :: * -> *). MonadHandler m => Text -> ByteString -> m ()
setSessionBS Text
nonceSessionKey ByteString
nonce
    , sessionStoreGet :: IO (Maybe ByteString, Maybe ByteString)
sessionStoreGet = m (Maybe ByteString, Maybe ByteString)
-> IO (Maybe ByteString, Maybe ByteString)
forall a. m a -> IO a
unlift (m (Maybe ByteString, Maybe ByteString)
 -> IO (Maybe ByteString, Maybe ByteString))
-> m (Maybe ByteString, Maybe ByteString)
-> IO (Maybe ByteString, Maybe ByteString)
forall a b. (a -> b) -> a -> b
$
        (,) (Maybe ByteString
 -> Maybe ByteString -> (Maybe ByteString, Maybe ByteString))
-> m (Maybe ByteString)
-> m (Maybe ByteString -> (Maybe ByteString, Maybe ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
Text -> m (Maybe ByteString)
lookupSessionBS Text
stateSessionKey
            m (Maybe ByteString -> (Maybe ByteString, Maybe ByteString))
-> m (Maybe ByteString) -> m (Maybe ByteString, Maybe ByteString)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
Text -> m (Maybe ByteString)
lookupSessionBS Text
nonceSessionKey
    , sessionStoreDelete :: IO ()
sessionStoreDelete = m () -> IO ()
forall a. m a -> IO a
unlift (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
stateSessionKey
        Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
nonceSessionKey
    }

newtype ClientId = ClientId { ClientId -> Text
unClientId :: Text } deriving (Int -> ClientId -> ShowS
[ClientId] -> ShowS
ClientId -> String
(Int -> ClientId -> ShowS)
-> (ClientId -> String) -> ([ClientId] -> ShowS) -> Show ClientId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClientId] -> ShowS
$cshowList :: [ClientId] -> ShowS
show :: ClientId -> String
$cshow :: ClientId -> String
showsPrec :: Int -> ClientId -> ShowS
$cshowsPrec :: Int -> ClientId -> ShowS
Show, ClientId -> ClientId -> Bool
(ClientId -> ClientId -> Bool)
-> (ClientId -> ClientId -> Bool) -> Eq ClientId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClientId -> ClientId -> Bool
$c/= :: ClientId -> ClientId -> Bool
== :: ClientId -> ClientId -> Bool
$c== :: ClientId -> ClientId -> Bool
Eq, Eq ClientId
Eq ClientId =>
(ClientId -> ClientId -> Ordering)
-> (ClientId -> ClientId -> Bool)
-> (ClientId -> ClientId -> Bool)
-> (ClientId -> ClientId -> Bool)
-> (ClientId -> ClientId -> Bool)
-> (ClientId -> ClientId -> ClientId)
-> (ClientId -> ClientId -> ClientId)
-> Ord ClientId
ClientId -> ClientId -> Bool
ClientId -> ClientId -> Ordering
ClientId -> ClientId -> ClientId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ClientId -> ClientId -> ClientId
$cmin :: ClientId -> ClientId -> ClientId
max :: ClientId -> ClientId -> ClientId
$cmax :: ClientId -> ClientId -> ClientId
>= :: ClientId -> ClientId -> Bool
$c>= :: ClientId -> ClientId -> Bool
> :: ClientId -> ClientId -> Bool
$c> :: ClientId -> ClientId -> Bool
<= :: ClientId -> ClientId -> Bool
$c<= :: ClientId -> ClientId -> Bool
< :: ClientId -> ClientId -> Bool
$c< :: ClientId -> ClientId -> Bool
compare :: ClientId -> ClientId -> Ordering
$ccompare :: ClientId -> ClientId -> Ordering
$cp1Ord :: Eq ClientId
Ord)

newtype ClientSecret = ClientSecret { ClientSecret -> Text
unClientSecret :: Text }

instance Show ClientSecret where
  show :: ClientSecret -> String
show _ = "<redacted-client-secret>"

makeOIDC ::
  Provider
  -> ClientId
  -> ClientSecret
  -> AuthHandler site OIDC
makeOIDC :: Provider -> ClientId -> ClientSecret -> AuthHandler site OIDC
makeOIDC provider :: Provider
provider (ClientId clientId :: Text
clientId) (ClientSecret clientSecret :: Text
clientSecret) = do
  Route site -> Text
urlRender <- m (Route site -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
  Route Auth -> Route site
toParent <- m (Route Auth -> Route site)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
  OIDC -> m OIDC
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OIDC -> m OIDC) -> OIDC -> m OIDC
forall a b. (a -> b) -> a -> b
$ OIDC :: Text
-> Text
-> ByteString
-> ByteString
-> ByteString
-> Provider
-> OIDC
OIDC
    { oidcAuthorizationServerUrl :: Text
oidcAuthorizationServerUrl = Configuration -> Text
authorizationEndpoint Configuration
cfg
    , oidcTokenEndpoint :: Text
oidcTokenEndpoint = Configuration -> Text
tokenEndpoint Configuration
cfg
    , oidcClientId :: ByteString
oidcClientId = Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 Text
clientId
    , oidcRedirectUri :: ByteString
oidcRedirectUri = Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Route site -> Text
urlRender (Route site -> Text) -> Route site -> Text
forall a b. (a -> b) -> a -> b
$ Route Auth -> Route site
toParent Route Auth
oidcCallbackR
    , oidcProvider :: Provider
oidcProvider = Provider
provider
    , oidcClientSecret :: ByteString
oidcClientSecret = Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 Text
clientSecret
    }
  where cfg :: Configuration
cfg = Provider -> Configuration
configuration Provider
provider

forward :: (YesodAuthOIDC a)
        => LoginHint
        -> Provider
        -> ClientId
        -> AuthHandler a TypedContent
forward :: Text -> Provider -> ClientId -> AuthHandler a TypedContent
forward loginHint :: Text
loginHint provider :: Provider
provider@(Provider cfg :: Configuration
cfg _keyset :: [Jwk]
_keyset) clientId :: ClientId
clientId = do
  [Text]
scopes <- ClientId -> Configuration -> AuthHandler a [Text]
forall site.
YesodAuthOIDC site =>
ClientId -> Configuration -> AuthHandler site [Text]
getScopes ClientId
clientId Configuration
cfg
  Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
loginHintSessionKey Text
loginHint
  -- The OIDC protocol must never use the Client Secret at this stage,
  -- but the oidc-client haskell library still asks for it inside the
  -- 'OIDC' type. We purposefully throw a 500 error if the value is used.
  OIDC
oidc <- Provider -> ClientId -> ClientSecret -> AuthHandler a OIDC
forall site.
Provider -> ClientId -> ClientSecret -> AuthHandler site OIDC
makeOIDC Provider
provider ClientId
clientId (Text -> ClientSecret
ClientSecret "DUMMY") m OIDC -> (OIDC -> OIDC) -> m OIDC
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \oidc' :: OIDC
oidc' -> OIDC
oidc'
    { oidcClientSecret :: ByteString
oidcClientSecret =
        String -> ByteString
forall a. HasCallStack => String -> a
error "client_secret should never be used in the authentication \
              \request as it would undesirably expose the secret to the user"
    }
  let extraParams :: [(ByteString, Maybe ByteString)]
extraParams =
        [("login_hint", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Bool -> ByteString -> ByteString
urlEncode Bool
False (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 Text
loginHint)]
  SessionStore IO
sessionStore <- m (SessionStore IO)
forall site. AuthHandler site (SessionStore IO)
makeSessionStore
  -- This function internally prepends "openid" to the scope list (and
  -- also deduplicates it)
  URI
uri <- IO URI -> m URI
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO URI -> m URI) -> IO URI -> m URI
forall a b. (a -> b) -> a -> b
$ SessionStore IO
-> OIDC -> [Text] -> [(ByteString, Maybe ByteString)] -> IO URI
forall (m :: * -> *).
(MonadThrow m, MonadCatch m) =>
SessionStore m
-> OIDC -> [Text] -> [(ByteString, Maybe ByteString)] -> m URI
prepareAuthenticationRequestUrl
         SessionStore IO
sessionStore OIDC
oidc [Text]
scopes [(ByteString, Maybe ByteString)]
extraParams
  String -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect (String -> m TypedContent) -> String -> m TypedContent
forall a b. (a -> b) -> a -> b
$ URI -> String
forall a. Show a => a -> String
show URI
uri

data CallbackInput = CallbackInput
  { CallbackInput -> Text
ciState :: Text
  , CallbackInput -> Text
ciCode :: Text
  }

-- | As defined in RFC6749 §5.2
data OAuthErrorResponse = OAuthErrorResponse
  { OAuthErrorResponse -> Text
oaeError :: Text
  , OAuthErrorResponse -> Maybe Text
oaeErrorDescription :: Maybe Text
  , OAuthErrorResponse -> Maybe Text
oaeErrorUri :: Maybe Text
  } deriving Int -> OAuthErrorResponse -> ShowS
[OAuthErrorResponse] -> ShowS
OAuthErrorResponse -> String
(Int -> OAuthErrorResponse -> ShowS)
-> (OAuthErrorResponse -> String)
-> ([OAuthErrorResponse] -> ShowS)
-> Show OAuthErrorResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OAuthErrorResponse] -> ShowS
$cshowList :: [OAuthErrorResponse] -> ShowS
show :: OAuthErrorResponse -> String
$cshow :: OAuthErrorResponse -> String
showsPrec :: Int -> OAuthErrorResponse -> ShowS
$cshowsPrec :: Int -> OAuthErrorResponse -> ShowS
Show

asTrustedState :: YesodAuthOIDC site
  => SessionStore IO -> [Text] -> AuthHandler site Text
asTrustedState :: SessionStore IO -> [Text] -> AuthHandler site Text
asTrustedState sessionStore :: SessionStore IO
sessionStore = \case
  [untrustedState :: Text
untrustedState] -> do
    (mState :: Maybe ByteString
mState, _) <- IO (Maybe ByteString, Maybe ByteString)
-> m (Maybe ByteString, Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString, Maybe ByteString)
 -> m (Maybe ByteString, Maybe ByteString))
-> IO (Maybe ByteString, Maybe ByteString)
-> m (Maybe ByteString, Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ SessionStore IO -> IO (Maybe ByteString, Maybe ByteString)
forall (m :: * -> *).
SessionStore m -> m (Maybe ByteString, Maybe ByteString)
sessionStoreGet SessionStore IO
sessionStore
    if (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
forall textual binary. Utf8 textual binary => binary -> textual
decodeUtf8 Maybe ByteString
mState Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just Text
untrustedState
      then Maybe OAuthErrorResponse -> AuthHandler site Text
forall site a.
YesodAuthOIDC site =>
Maybe OAuthErrorResponse -> AuthHandler site a
onBadCallbackRequest Maybe OAuthErrorResponse
forall a. Maybe a
Nothing
      else Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
untrustedState
  _ -> Maybe OAuthErrorResponse -> AuthHandler site Text
forall site a.
YesodAuthOIDC site =>
Maybe OAuthErrorResponse -> AuthHandler site a
onBadCallbackRequest Maybe OAuthErrorResponse
forall a. Maybe a
Nothing

processCallbackInput :: YesodAuthOIDC site
  => StdMethod -> SessionStore IO -> AuthHandler site CallbackInput
processCallbackInput :: StdMethod -> SessionStore IO -> AuthHandler site CallbackInput
processCallbackInput reqMethod :: StdMethod
reqMethod sessionStore :: SessionStore IO
sessionStore = do
  Text
validState <- Text -> m [Text]
params "state" m [Text] -> ([Text] -> m Text) -> m Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SessionStore IO -> [Text] -> AuthHandler site Text
forall site.
YesodAuthOIDC site =>
SessionStore IO -> [Text] -> AuthHandler site Text
asTrustedState SessionStore IO
sessionStore
  [Text]
codes <- Text -> m [Text]
params "code"
  [Text]
errs <- Text -> m [Text]
params "error"
  case ([Text]
codes, [Text]
errs) of
    ([code :: Text
code], []) ->
      CallbackInput -> m CallbackInput
forall (f :: * -> *) a. Applicative f => a -> f a
pure CallbackInput :: Text -> Text -> CallbackInput
CallbackInput
        { ciState :: Text
ciState = Text
validState
        , ciCode :: Text
ciCode = Text
code }
    ([], [err :: Text
err]) -> do
      Maybe Text
mErrDesc <- [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text) -> m [Text] -> m (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m [Text]
params "error_description"
      Maybe Text
mErrUri <- [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text) -> m [Text] -> m (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m [Text]
params "error_uri"
      Maybe OAuthErrorResponse -> m CallbackInput
forall site a.
YesodAuthOIDC site =>
Maybe OAuthErrorResponse -> AuthHandler site a
onBadCallbackRequest (Maybe OAuthErrorResponse -> m CallbackInput)
-> Maybe OAuthErrorResponse -> m CallbackInput
forall a b. (a -> b) -> a -> b
$ OAuthErrorResponse -> Maybe OAuthErrorResponse
forall a. a -> Maybe a
Just (OAuthErrorResponse -> Maybe OAuthErrorResponse)
-> OAuthErrorResponse -> Maybe OAuthErrorResponse
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Maybe Text -> OAuthErrorResponse
OAuthErrorResponse Text
err Maybe Text
mErrDesc Maybe Text
mErrUri
    _ -> Maybe OAuthErrorResponse -> AuthHandler site CallbackInput
forall site a.
YesodAuthOIDC site =>
Maybe OAuthErrorResponse -> AuthHandler site a
onBadCallbackRequest Maybe OAuthErrorResponse
forall a. Maybe a
Nothing
  where
    params :: Text -> m [Text]
params = if StdMethod
reqMethod StdMethod -> StdMethod -> Bool
forall a. Eq a => a -> a -> Bool
== StdMethod
GET
      then Text -> m [Text]
forall (m :: * -> *). MonadHandler m => Text -> m [Text]
lookupGetParams
      else Text -> m [Text]
forall (m :: * -> *).
(MonadResource m, MonadHandler m) =>
Text -> m [Text]
lookupPostParams

-- Providers may use GET or POST for the callback, so we
-- handle both cases in this function
handleCallback ::
  YesodAuthOIDC site
  => StdMethod -> AuthHandler site TypedContent
handleCallback :: StdMethod -> AuthHandler site TypedContent
handleCallback reqMethod :: StdMethod
reqMethod = do
  Text
loginHint <- Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
loginHintSessionKey
    m (Maybe Text) -> (Maybe Text -> m Text) -> m Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m Text -> (Text -> m Text) -> Maybe Text -> m Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe OAuthErrorResponse -> AuthHandler site Text
forall site a.
YesodAuthOIDC site =>
Maybe OAuthErrorResponse -> AuthHandler site a
onBadCallbackRequest Maybe OAuthErrorResponse
forall a. Maybe a
Nothing) Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
loginHintSessionKey
  SessionStore IO
sessionStore <- m (SessionStore IO)
forall site. AuthHandler site (SessionStore IO)
makeSessionStore
  cbInput :: CallbackInput
cbInput@CallbackInput{..} <- StdMethod -> SessionStore IO -> AuthHandler site CallbackInput
forall site.
YesodAuthOIDC site =>
StdMethod -> SessionStore IO -> AuthHandler site CallbackInput
processCallbackInput StdMethod
reqMethod SessionStore IO
sessionStore
  (provider :: Provider
provider, clientId :: ClientId
clientId) <- Text -> AuthHandler site (Provider, ClientId)
forall site.
YesodAuthOIDC site =>
Text -> AuthHandler site (Provider, ClientId)
findProvider Text
loginHint
  ClientSecret
clientSecret <- ClientId -> Configuration -> AuthHandler site ClientSecret
forall site.
YesodAuthOIDC site =>
ClientId -> Configuration -> AuthHandler site ClientSecret
getClientSecret ClientId
clientId (Configuration -> m ClientSecret)
-> Configuration -> m ClientSecret
forall a b. (a -> b) -> a -> b
$ Provider -> Configuration
configuration Provider
provider
  OIDC
oidc <- Provider -> ClientId -> ClientSecret -> AuthHandler site OIDC
forall site.
Provider -> ClientId -> ClientSecret -> AuthHandler site OIDC
makeOIDC Provider
provider ClientId
clientId ClientSecret
clientSecret
  Either MockOidcProvider Manager
eMgr <- m (Either MockOidcProvider Manager)
forall site.
YesodAuthOIDC site =>
AuthHandler site (Either MockOidcProvider Manager)
getHttpManagerForOidc
  Tokens Object
tokens <- case Either MockOidcProvider Manager
eMgr of
    Left mock :: MockOidcProvider
mock -> Tokens Object -> m (Tokens Object)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tokens Object -> m (Tokens Object))
-> Tokens Object -> m (Tokens Object)
forall a b. (a -> b) -> a -> b
$ (MockOidcProvider
-> Text
-> CallbackInput
-> SessionStore IO
-> OIDC
-> Tokens Object
mopGetValidTokens MockOidcProvider
mock) Text
loginHint CallbackInput
cbInput SessionStore IO
sessionStore OIDC
oidc
    Right mgr :: Manager
mgr -> IO (Tokens Object) -> m (Tokens Object)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Tokens Object) -> m (Tokens Object))
-> IO (Tokens Object) -> m (Tokens Object)
forall a b. (a -> b) -> a -> b
$ SessionStore IO
-> OIDC
-> Manager
-> ByteString
-> ByteString
-> IO (Tokens Object)
forall (m :: * -> *) a.
(MonadThrow m, MonadCatch m, MonadIO m, FromJSON a) =>
SessionStore m
-> OIDC -> Manager -> ByteString -> ByteString -> m (Tokens a)
getValidTokens SessionStore IO
sessionStore OIDC
oidc Manager
mgr
                 (Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 Text
ciState) (Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 Text
ciCode)
  let posixExpiryTime :: Int
posixExpiryTime = case IdTokenClaims Object -> IntDate
forall a. IdTokenClaims a -> IntDate
Client.exp (IdTokenClaims Object -> IntDate)
-> IdTokenClaims Object -> IntDate
forall a b. (a -> b) -> a -> b
$ Tokens Object -> IdTokenClaims Object
forall a. Tokens a -> IdTokenClaims a
idToken Tokens Object
tokens of
        IntDate posixTime :: POSIXTime
posixTime -> POSIXTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor @POSIXTime @Int POSIXTime
posixTime
  UserInfoPreference
userInfoPref <- Text
-> ClientId -> Configuration -> AuthHandler site UserInfoPreference
forall site.
YesodAuthOIDC site =>
Text
-> ClientId -> Configuration -> AuthHandler site UserInfoPreference
getUserInfoPreference Text
loginHint ClientId
clientId (Provider -> Configuration
configuration Provider
provider)
  HashSet Text
requestedClaims <- Text -> HashSet Text -> HashSet Text
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.delete Text
Scopes.openId (HashSet Text -> HashSet Text)
-> ([Text] -> HashSet Text) -> [Text] -> HashSet Text
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Text] -> HashSet Text
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList
                     ([Text] -> HashSet Text) -> m [Text] -> m (HashSet Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClientId -> Configuration -> AuthHandler site [Text]
forall site.
YesodAuthOIDC site =>
ClientId -> Configuration -> AuthHandler site [Text]
getScopes ClientId
clientId (Provider -> Configuration
configuration Provider
provider)
  let missingClaims :: HashSet Text
missingClaims = HashSet Text
requestedClaims
        HashSet Text -> HashSet Text -> HashSet Text
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HashSet.difference` Object -> HashSet Text
forall k a. HashMap k a -> HashSet k
HM.keysSet (IdTokenClaims Object -> Object
forall a. IdTokenClaims a -> a
otherClaims (IdTokenClaims Object -> Object) -> IdTokenClaims Object -> Object
forall a b. (a -> b) -> a -> b
$ Tokens Object -> IdTokenClaims Object
forall a. Tokens a -> IdTokenClaims a
idToken Tokens Object
tokens)
  Maybe Object
mUserInfo <- case (UserInfoPreference
userInfoPref, Configuration -> Maybe Text
userinfoEndpoint (Configuration -> Maybe Text) -> Configuration -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Provider -> Configuration
configuration Provider
provider) of
    (GetUserInfoIfAvailable, Just uri :: Text
uri) -> IO (Maybe Object) -> m (Maybe Object)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Object) -> m (Maybe Object))
-> IO (Maybe Object) -> m (Maybe Object)
forall a b. (a -> b) -> a -> b
$
      (SomeException -> IO (Maybe Object))
-> IO (Maybe Object) -> IO (Maybe Object)
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (IO (Maybe Object) -> SomeException -> IO (Maybe Object)
forall a b. a -> b -> a
const (Maybe Object -> IO (Maybe Object)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Object
forall a. Maybe a
Nothing)) (IO (Maybe Object) -> IO (Maybe Object))
-> IO (Maybe Object) -> IO (Maybe Object)
forall a b. (a -> b) -> a -> b
$ Either MockOidcProvider Manager
-> Tokens Object -> Text -> IO (Maybe Object)
requestUserInfo Either MockOidcProvider Manager
eMgr Tokens Object
tokens Text
uri
    (GetUserInfoOnlyToSatisfyRequestedScopes, Just uri :: Text
uri)
      | Bool -> Bool
not (HashSet Text -> Bool
forall a. HashSet a -> Bool
HashSet.null HashSet Text
missingClaims) -> IO (Maybe Object) -> m (Maybe Object)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Object) -> m (Maybe Object))
-> IO (Maybe Object) -> m (Maybe Object)
forall a b. (a -> b) -> a -> b
$
        (SomeException -> IO (Maybe Object))
-> IO (Maybe Object) -> IO (Maybe Object)
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (IO (Maybe Object) -> SomeException -> IO (Maybe Object)
forall a b. a -> b -> a
const (Maybe Object -> IO (Maybe Object)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Object
forall a. Maybe a
Nothing)) (IO (Maybe Object) -> IO (Maybe Object))
-> IO (Maybe Object) -> IO (Maybe Object)
forall a b. (a -> b) -> a -> b
$ Either MockOidcProvider Manager
-> Tokens Object -> Text -> IO (Maybe Object)
requestUserInfo Either MockOidcProvider Manager
eMgr Tokens Object
tokens Text
uri
    _ -> Maybe Object -> m (Maybe Object)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Object
forall a. Maybe a
Nothing
  Text
userId <- Text
-> ClientId
-> Provider
-> Tokens Object
-> Maybe Object
-> AuthHandler site Text
forall site.
YesodAuthOIDC site =>
Text
-> ClientId
-> Provider
-> Tokens Object
-> Maybe Object
-> AuthHandler site Text
onSuccessfulAuthentication Text
loginHint ClientId
clientId Provider
provider Tokens Object
tokens Maybe Object
mUserInfo
  Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
sessionExpiryKey (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> Text
forall a. Show a => a -> Text
tshow Int
posixExpiryTime
  Creds (HandlerSite m) -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect Creds :: forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds
    { credsPlugin :: Text
credsPlugin = Text
oidcPluginName
    , credsIdent :: Text
credsIdent = Text
userId
    , credsExtra :: [(Text, Text)]
credsExtra = [("iss", IdTokenClaims Object -> Text
forall a. IdTokenClaims a -> Text
iss (IdTokenClaims Object -> Text) -> IdTokenClaims Object -> Text
forall a b. (a -> b) -> a -> b
$ Tokens Object -> IdTokenClaims Object
forall a. Tokens a -> IdTokenClaims a
idToken Tokens Object
tokens), ("exp", Int -> Text
forall a. Show a => a -> Text
tshow Int
posixExpiryTime)]
    }

sessionExpiryKey :: Text
sessionExpiryKey :: Text
sessionExpiryKey = Text
sessionPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "-exp"

requestUserInfo ::
  Either MockOidcProvider HTTP.Manager
  -> Tokens J.Object
  -> Text -- UserInfo Endpoint URI
  -> IO (Maybe J.Object)
requestUserInfo :: Either MockOidcProvider Manager
-> Tokens Object -> Text -> IO (Maybe Object)
requestUserInfo eMgr :: Either MockOidcProvider Manager
eMgr tokens :: Tokens Object
tokens uri :: Text
uri = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ("https:" Text -> Text -> Bool
`T.isPrefixOf` Text
uri
            Bool -> Bool -> Bool
|| "http://localhost" Text -> Text -> Bool
`T.isPrefixOf` Text
uri) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    YesodAuthOIDCException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (YesodAuthOIDCException -> IO ())
-> YesodAuthOIDCException -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> YesodAuthOIDCException
TLSNotUsedException (Text -> YesodAuthOIDCException) -> Text -> YesodAuthOIDCException
forall a b. (a -> b) -> a -> b
$ "The URI of the UserInfo Endpoint must start with https"
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Text
T.toLower (Tokens Object -> Text
forall a. Tokens a -> Text
tokenType Tokens Object
tokens) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "bearer") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    -- "The client MUST NOT use an access token if it does not
    -- understand the token type." (RFC6749 7.1). "The OAuth 2.0
    -- token_type response parameter value MUST be Bearer" (OIDC Core
    -- 3.1.3.3)
    YesodAuthOIDCException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (YesodAuthOIDCException -> IO ())
-> YesodAuthOIDCException -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> YesodAuthOIDCException
UnknownTokenType (Text -> YesodAuthOIDCException) -> Text -> YesodAuthOIDCException
forall a b. (a -> b) -> a -> b
$ Tokens Object -> Text
forall a. Tokens a -> Text
tokenType Tokens Object
tokens
  Request
req0 <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
HTTP.parseRequest (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
uri
  -- Use Bearer auth as defined in RFC6750 2.1
  let req :: Request
req = Request
req0 {
        requestHeaders :: RequestHeaders
HTTP.requestHeaders = [
            ("Authorization" , Text -> ByteString
forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ "Bearer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Tokens Object -> Text
forall a. Tokens a -> Text
accessToken Tokens Object
tokens)]
        }
  case Either MockOidcProvider Manager
eMgr of
    Left mock :: MockOidcProvider
mock -> Maybe Object -> IO (Maybe Object)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Object -> IO (Maybe Object))
-> Maybe Object -> IO (Maybe Object)
forall a b. (a -> b) -> a -> b
$ (MockOidcProvider -> Request -> Tokens Object -> Maybe Object
mopRequestUserInfo MockOidcProvider
mock) Request
req Tokens Object
tokens
    Right mgr :: Manager
mgr -> do
      Response ByteString
resp <- Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
req Manager
mgr
      Maybe Object -> IO (Maybe Object)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Object -> IO (Maybe Object))
-> Maybe Object -> IO (Maybe Object)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Object
forall a. FromJSON a => ByteString -> Maybe a
J.decode (ByteString -> Maybe Object) -> ByteString -> Maybe Object
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
resp

-- | Checks if the user has authenticated via `yesod-auth-oidc`. If
-- so, checks for the session expiry time as returned by the original
-- ID Token. If expired, it removes the 'sessionExpiryKey' from the
-- session, then calls 'onSessionExpired'. We can greatly improve this
-- by following the specs that can request re-authentication via the
-- OIDC-defined "prompt" parameter, but this is not implemented yet.
--
-- You should add this to your app's middleware. This library cannot
-- include it automatically.
oidcSessionExpiryMiddleware :: YesodAuthOIDC site => HandlerFor site a -> HandlerFor site a
oidcSessionExpiryMiddleware :: HandlerFor site a -> HandlerFor site a
oidcSessionExpiryMiddleware handler :: HandlerFor site a
handler = do
  Maybe Text
mExp <- Text -> HandlerFor site (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
sessionExpiryKey
  case Maybe Text
mExp of
    Just ex :: Text
ex -> do
      let Maybe Int64
mExInt :: Maybe Int64 = Text -> Maybe Int64
forall c a.
(Element c ~ Char, MonoFoldable c, Read a) =>
c -> Maybe a
readMay Text
ex
      case Maybe Int64
mExInt of
        Nothing -> HandlerFor site ()
forall site. YesodAuthOIDC site => HandlerFor site ()
onSessionExpiry HandlerFor site () -> HandlerFor site a -> HandlerFor site a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HandlerFor site a
handler
        Just exInt :: Int64
exInt -> do
          let expTime :: UTCTime
expTime = POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime) -> POSIXTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Int64 -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Int64
exInt
          UTCTime
now <- IO UTCTime -> HandlerFor site UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> HandlerFor site UTCTime)
-> IO UTCTime -> HandlerFor site UTCTime
forall a b. (a -> b) -> a -> b
$ IO UTCTime
getCurrentTime
          if UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
expTime
            then do
              Text -> HandlerFor site ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
sessionExpiryKey
              HandlerFor site ()
forall site. YesodAuthOIDC site => HandlerFor site ()
onSessionExpiry
              -- The handler almost certainly will be
              -- short-circuited by now but for flexbility and
              -- easier typing, we include it here:
              HandlerFor site a
handler
            else HandlerFor site a
handler
    _ -> HandlerFor site a
handler