{-# 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 #-}
module Yesod.Auth.OIDC
( oidcPluginName
, authOIDC
, ClientId(..)
, ClientSecret(..)
, UserInfo
, UserInfoPreference(..)
, YesodAuthOIDC(..)
, OAuthErrorResponse(..)
, oidcSessionExpiryMiddleware
, oidcLoginR
, oidcForwardR
, oidcCallbackR
, Configuration(..)
, Provider(..)
, IssuerLocation
, Tokens(..)
, IdTokenClaims(..)
, 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
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
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
type LoginHint = Text
type UserInfo = J.Object
class (YesodAuth site) => YesodAuthOIDC site where
enableLoginPage :: Bool
enableLoginPage = Bool
True
onBadLoginHint :: AuthHandler site TypedContent
onBadLoginHint = YesodAuthOIDCException -> m TypedContent
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO YesodAuthOIDCException
BadLoginHint
getProviderConfig ::
LoginHint -> AuthHandler site (Either Provider IssuerLocation, ClientId)
onProviderConfigDiscovered ::
Provider -> ClientId -> DiffTime -> AuthHandler site ()
onProviderConfigDiscovered _ _ _ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
onBadCallbackRequest ::
Maybe OAuthErrorResponse
-> 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}
|]
getClientSecret :: ClientId -> Configuration -> AuthHandler site ClientSecret
getScopes :: ClientId -> Configuration -> AuthHandler site [ScopeValue]
getScopes _ _ = [Text] -> m [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text
email]
getUserInfoPreference ::
LoginHint -> ClientId -> Configuration -> AuthHandler site UserInfoPreference
getUserInfoPreference _ _ _ = UserInfoPreference -> m UserInfoPreference
forall (f :: * -> *) a. Applicative f => a -> f a
pure UserInfoPreference
GetUserInfoOnlyToSatisfyRequestedScopes
onSuccessfulAuthentication ::
LoginHint
-> ClientId
-> Provider
-> Tokens J.Object
-> Maybe UserInfo
-> AuthHandler site Text
onSessionExpiry :: HandlerFor site ()
onSessionExpiry = Bool -> HandlerFor site ()
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Bool -> m ()
clearCreds Bool
True
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
| GetUserInfoOnlyToSatisfyRequestedScopes
| 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)
oidcPluginName :: Text
oidcPluginName :: Text
oidcPluginName = "oidc"
oidcLoginR :: AuthRoute
oidcLoginR :: Route Auth
oidcLoginR = Text -> [Text] -> Route Auth
PluginR Text
oidcPluginName ["login"]
oidcForwardR :: AuthRoute
oidcForwardR :: Route Auth
oidcForwardR = Text -> [Text] -> Route Auth
PluginR Text
oidcPluginName ["forward"]
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
("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)
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
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"
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
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
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
}
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
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
-> 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
$
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
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
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
HandlerFor site a
handler
else HandlerFor site a
handler
_ -> HandlerFor site a
handler