{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# 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.Aeson.KeyMap as HM
import qualified Data.Set 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
import qualified Data.Aeson.Key as Aes

-- 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
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 :: forall site . YesodAuthOIDC site => AuthPlugin site
authOIDC :: forall site. YesodAuthOIDC site => AuthPlugin site
authOIDC = forall master.
Text
-> (Text -> [Text] -> AuthHandler master TypedContent)
-> ((Route Auth -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin Text
oidcPluginName forall site.
YesodAuthOIDC site =>
Text
-> [Text]
-> forall (m :: * -> *). MonadAuthHandler site m => m TypedContent
dispatch 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 :: MonadAuthHandler site m => m TypedContent
  onBadLoginHint = 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 :: MonadAuthHandler site m =>
    LoginHint ->  m (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 :: MonadAuthHandler site m =>
    Provider -> ClientId -> DiffTime ->  m ()
  onProviderConfigDiscovered Provider
_ ClientId
_ DiffTime
_ = 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 :: MonadAuthHandler site m =>
    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.
    ->  m a
  onBadCallbackRequest Maybe OAuthErrorResponse
mError = do
    Markup
errHtml <- forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Markup
authLayout forall a b. (a -> b) -> a -> b
$ forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget WidgetFor site ()
widg
    forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
Status -> c -> m a
sendResponseStatus Status
status400 Markup
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 :: MonadAuthHandler site m => ClientId -> Configuration ->  m 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 :: MonadAuthHandler site m => ClientId -> Configuration ->  m [ScopeValue]
  getScopes ClientId
_ Configuration
_ = 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 :: MonadAuthHandler site m =>
    LoginHint -> ClientId -> Configuration -> m UserInfoPreference
  getUserInfoPreference Text
_ ClientId
_ Configuration
_ = 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 :: MonadAuthHandler site m =>
    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.
    ->  m 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 = 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 ::
    MonadAuthHandler site m => m (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
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
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 = Text
"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 [Text
"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 [Text
"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 [Text
"callback"]

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

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

loginW :: (Route Auth -> Route site) -> WidgetFor site ()
loginW :: forall site. (Route Auth -> Route site) -> WidgetFor site ()
loginW Route Auth -> Route site
toParentRoute = do
  Maybe Text
mToken <- YesodRequest -> Maybe Text
reqToken forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler 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 => MonadAuthHandler site m => m TypedContent
getLoginR :: forall site (m :: * -> *).
(YesodAuthOIDC site, MonadAuthHandler site m) =>
m TypedContent
getLoginR = do
  Route Auth -> Route site
rtp <- forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
  forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Markup
authLayout forall a b. (a -> b) -> a -> b
$ forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget forall a b. (a -> b) -> a -> b
$ forall site. (Route Auth -> Route site) -> WidgetFor site ()
loginW Route Auth -> Route site
rtp

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

-- | Expects 'email' and '_token' post params.
postForwardR :: (YesodAuthOIDC site, MonadAuthHandler site m)
            =>  m TypedContent
postForwardR :: forall site (m :: * -> *).
(YesodAuthOIDC site, MonadAuthHandler site m) =>
m TypedContent
postForwardR = do
  forall (m :: * -> *). MonadHandler m => Text -> m ()
checkCsrfParamNamed Text
defaultCsrfParamName
  Maybe Text
mLoginHint <- forall (m :: * -> *).
(MonadResource m, MonadHandler m) =>
Text -> m (Maybe Text)
lookupPostParam Text
"email"
  case Maybe Text
mLoginHint of
    Maybe Text
Nothing -> forall site (m :: * -> *).
(YesodAuthOIDC site, MonadAuthHandler site m) =>
m TypedContent
onBadLoginHint
    Just Text
loginHint -> do
      (Provider
provider, ClientId
clientId) <- forall site (m :: * -> *).
(MonadAuthHandler site m, YesodAuthOIDC site) =>
Text -> m (Provider, ClientId)
findProvider Text
loginHint
      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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
Crypto.getRandomBytes Int
64

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

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

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

loginHintSessionKey :: Text
loginHintSessionKey :: Text
loginHintSessionKey = Text
sessionPrefix forall a. Semigroup a => a -> a -> a
<> Text
"-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 :: MonadAuthHandler site m => m (SessionStore IO)
makeSessionStore :: forall site (m :: * -> *).
MonadAuthHandler site m =>
m (SessionStore IO)
makeSessionStore = do
  UnliftIO forall a. m a -> IO a
unlift <- forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SessionStore
    { sessionStoreGenerate :: IO ByteString
sessionStoreGenerate = IO ByteString
genNonce
    , sessionStoreSave :: ByteString -> ByteString -> IO ()
sessionStoreSave = \ByteString
state ByteString
nonce -> forall a. m a -> IO a
unlift forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *). MonadHandler m => Text -> ByteString -> m ()
setSessionBS Text
stateSessionKey ByteString
state
        forall (m :: * -> *). MonadHandler m => Text -> ByteString -> m ()
setSessionBS Text
nonceSessionKey ByteString
nonce
#if MIN_VERSION_oidc_client(0,7,0)
    , sessionStoreGet :: ByteString -> IO (Maybe ByteString)
sessionStoreGet = \ByteString
untrustedState -> forall a. m a -> IO a
unlift forall a b. (a -> b) -> a -> b
$ do
        (Maybe ByteString
mState, Maybe ByteString
mNonce) <-
          (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadHandler m =>
Text -> m (Maybe ByteString)
lookupSessionBS Text
stateSessionKey
              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *).
MonadHandler m =>
Text -> m (Maybe ByteString)
lookupSessionBS Text
nonceSessionKey
        if Maybe ByteString
mState forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just ByteString
untrustedState
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          else forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
mNonce
#else
    , sessionStoreGet = unlift $
        (,) <$> lookupSessionBS stateSessionKey
            <*> lookupSessionBS nonceSessionKey
#endif
    , sessionStoreDelete :: IO ()
sessionStoreDelete = forall a. m a -> IO a
unlift forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
stateSessionKey
        forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
nonceSessionKey
    }

newtype ClientId = ClientId { ClientId -> Text
unClientId :: Text } deriving (Int -> ClientId -> ShowS
[ClientId] -> ShowS
ClientId -> String
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
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
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
Ord)

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

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

makeOIDC :: MonadAuthHandler site m =>
  Provider
  -> ClientId
  -> ClientSecret
  ->  m OIDC
makeOIDC :: forall site (m :: * -> *).
MonadAuthHandler site m =>
Provider -> ClientId -> ClientSecret -> m OIDC
makeOIDC Provider
provider (ClientId Text
clientId) (ClientSecret Text
clientSecret) = do
  Route site -> Text
urlRender <- forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
  Route Auth -> Route site
toParent <- forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ OIDC
    { oidcAuthorizationServerUrl :: Text
oidcAuthorizationServerUrl = Configuration -> Text
authorizationEndpoint Configuration
cfg
    , oidcTokenEndpoint :: Text
oidcTokenEndpoint = Configuration -> Text
tokenEndpoint Configuration
cfg
    , oidcClientId :: ByteString
oidcClientId = forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 Text
clientId
    , oidcRedirectUri :: ByteString
oidcRedirectUri = forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 forall a b. (a -> b) -> a -> b
$ Route site -> Text
urlRender forall a b. (a -> b) -> a -> b
$ Route Auth -> Route site
toParent Route Auth
oidcCallbackR
    , oidcProvider :: Provider
oidcProvider = Provider
provider
    , oidcClientSecret :: ByteString
oidcClientSecret = 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 :: forall a.
YesodAuthOIDC a =>
Text -> Provider -> ClientId -> AuthHandler a TypedContent
forward Text
loginHint provider :: Provider
provider@(Provider Configuration
cfg [Jwk]
_keyset) ClientId
clientId = do
  [Text]
scopes <- forall site (m :: * -> *).
(YesodAuthOIDC site, MonadAuthHandler site m) =>
ClientId -> Configuration -> m [Text]
getScopes ClientId
clientId Configuration
cfg
  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 <- forall site (m :: * -> *).
MonadAuthHandler site m =>
Provider -> ClientId -> ClientSecret -> m OIDC
makeOIDC Provider
provider ClientId
clientId (Text -> ClientSecret
ClientSecret Text
"DUMMY") forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \OIDC
oidc' -> OIDC
oidc'
    { oidcClientSecret :: ByteString
oidcClientSecret = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords
        [ String
"client_secret should never be used in the authentication "
        , String
"request as it would undesirably expose the secret to the user"
        ]
    }
  let extraParams :: [(ByteString, Maybe ByteString)]
extraParams =
        [(ByteString
"login_hint", forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bool -> ByteString -> ByteString
urlEncode Bool
False forall a b. (a -> b) -> a -> b
$ forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 Text
loginHint)]
  SessionStore IO
sessionStore <- forall site (m :: * -> *).
MonadAuthHandler site m =>
m (SessionStore IO)
makeSessionStore
  -- This function internally prepends "openid" to the scope list (and
  -- also deduplicates it)
  URI
uri <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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
  forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect forall a b. (a -> b) -> a -> b
$ 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
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, MonadAuthHandler site m)
  => SessionStore IO -> [Text] ->  m Text
asTrustedState :: forall site (m :: * -> *).
(YesodAuthOIDC site, MonadAuthHandler site m) =>
SessionStore IO -> [Text] -> m Text
asTrustedState SessionStore IO
sessionStore = \case
  [Text
untrustedState] -> do
#if MIN_VERSION_oidc_client(0,7,0)
    -- In this case, there's no point in validating the state - we
    -- need to thread this value through to the code later, and when
    -- the code reads the nonce, the state will be validated
    --
    -- We're using 'const' to avoid an unuse warning in the function arg
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Text
untrustedState SessionStore IO
sessionStore
#else
    (mState, _) <- liftIO $ sessionStoreGet sessionStore untrustedState
    if fmap decodeUtf8 mState /= Just untrustedState
      then onBadCallbackRequest Nothing
      else pure untrustedState
#endif
  [Text]
_ -> forall site (m :: * -> *) a.
(YesodAuthOIDC site, MonadAuthHandler site m) =>
Maybe OAuthErrorResponse -> m a
onBadCallbackRequest forall a. Maybe a
Nothing

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

keySet :: J.Object -> Set Text
keySet :: Object -> Set Text
keySet = forall a. Ord a => [a] -> Set a
HashSet.fromList forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Key -> Text
Aes.toText forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall v. KeyMap v -> [Key]
HM.keys

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

sessionExpiryKey :: Text
sessionExpiryKey :: Text
sessionExpiryKey = Text
sessionPrefix forall a. Semigroup a => a -> a -> a
<> Text
"-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 Either MockOidcProvider Manager
eMgr Tokens Object
tokens Text
uri = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
"https:" Text -> Text -> Bool
`T.isPrefixOf` Text
uri
            Bool -> Bool -> Bool
|| Text
"http://localhost" Text -> Text -> Bool
`T.isPrefixOf` Text
uri) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> YesodAuthOIDCException
TLSNotUsedException forall a b. (a -> b) -> a -> b
$ Text
"The URI of the UserInfo Endpoint must start with https"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Text
T.toLower (forall a. Tokens a -> Text
tokenType Tokens Object
tokens) forall a. Eq a => a -> a -> Bool
== Text
"bearer") 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)
    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> YesodAuthOIDCException
UnknownTokenType forall a b. (a -> b) -> a -> b
$ forall a. Tokens a -> Text
tokenType Tokens Object
tokens
  Request
req0 <- forall (m :: * -> *). MonadThrow m => String -> m Request
HTTP.parseRequest 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 = [
            (HeaderName
"Authorization" , forall textual binary. Utf8 textual binary => textual -> binary
encodeUtf8 forall a b. (a -> b) -> a -> b
$ Text
"Bearer " forall a. Semigroup a => a -> a -> a
<> forall a. Tokens a -> Text
accessToken Tokens Object
tokens)]
        }
  case Either MockOidcProvider Manager
eMgr of
    Left MockOidcProvider
mock -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (MockOidcProvider -> Request -> Tokens Object -> Maybe Object
mopRequestUserInfo MockOidcProvider
mock) Request
req Tokens Object
tokens
    Right Manager
mgr -> do
      Response ByteString
resp <- Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
req Manager
mgr
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Maybe a
J.decode forall a b. (a -> b) -> a -> b
$ 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 :: forall site a.
YesodAuthOIDC site =>
HandlerFor site a -> HandlerFor site a
oidcSessionExpiryMiddleware HandlerFor site a
handler = do
  Maybe Text
mExp <- forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
sessionExpiryKey
  case Maybe Text
mExp of
    Just Text
ex -> do
      let Maybe Int64
mExInt :: Maybe Int64 = forall c a.
(Element c ~ Char, MonoFoldable c, Read a) =>
c -> Maybe a
readMay Text
ex
      case Maybe Int64
mExInt of
        Maybe Int64
Nothing -> forall site. YesodAuthOIDC site => HandlerFor site ()
onSessionExpiry forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HandlerFor site a
handler
        Just Int64
exInt -> do
          let expTime :: UTCTime
expTime = POSIXTime -> UTCTime
posixSecondsToUTCTime forall a b. (a -> b) -> a -> b
$ forall a b. (Real a, Fractional b) => a -> b
realToFrac Int64
exInt
          UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO UTCTime
getCurrentTime
          if UTCTime
now forall a. Ord a => a -> a -> Bool
> UTCTime
expTime
            then do
              forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
sessionExpiryKey
              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
    Maybe Text
_ -> HandlerFor site a
handler