yesod-auth-oidc (empty) → 0.1.0
raw patch · 10 files changed
+1296/−0 lines, 10 filesdep +aesondep +basedep +base64-bytestring
Dependencies added: aeson, base, base64-bytestring, blaze-html, broch, bytestring, classy-prelude, classy-prelude-yesod, containers, cryptonite, directory, email-validate, fast-logger, hspec, http-client, http-conduit, http-types, jose-jwt, lens, lens-regex-pcre, memory, monad-logger, oidc-client, persistent, persistent-sqlite, postgresql-simple, reroute, resource-pool, shakespeare, sqlite-simple, text, time, unordered-containers, wai-app-static, wai-extra, warp, yesod, yesod-auth, yesod-core, yesod-form, yesod-persistent, yesod-test
Files
- LICENSE +29/−0
- README.md +44/−0
- src/Yesod/Auth/OIDC.hs +587/−0
- test/ExampleApp.hs +162/−0
- test/ExampleProvider.hs +131/−0
- test/ExampleProviderOpts.hs +29/−0
- test/Spec.hs +1/−0
- test/TestImport.hs +82/−0
- test/Yesod/Auth/OIDCSpec.hs +105/−0
- yesod-auth-oidc.cabal +126/−0
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2021, Supercede+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,44 @@+# yesod-auth-oidc++A Yesod authentication plugin for multi-tenant Single Sign-on (SSO) via [OpenID Connect](https://openid.net/specs/openid-connect-core-1_0.html) (OIDC Core 1.0), using Authorization Code flow (defined in §3.1, AKA server flow).++* Supports multiple Identity Providers with callbacks based on the login_hint (typically an email).+* Each provider can be configured either through OIDC Discovery or manually. (The Dynamic Registration OIDC extension is not supported).+* Uses with your Yesod app's session library plus a small middleware. That means there's no need to rely on encrypted JWTs in the browser if you use server-side sessions.+* Works well with [yesod-auth-simple](https://github.com/riskbook/yesod-auth-simple).++# Using the library++This library abstracts many details of OIDC for you, but you may need to understand the basics of OIDC to integrate this with your app. The steps are:++1. Implement the `YesodAuthOIDC` class for your Yesod `App`. See the Haddocks for documentation.++2. Add `Yesod.Auth.OIDC.authOIDC` to your list of authPlugins.++3. Add the `Yesod.Auth.OIDC.oidcSessionExpiryMiddleware` to your WAI middleware. This ensures the user is logged out upon the token's expiry. You should be able to implement something more fancy than a hard logout without modifying this libary.++4. Add some extra UI logic for choosing between login methods if you have more than one auth plugin. Yesod provides some defaults here for getting started.++Also see this library's test suite, especially `test/ExampleApp.hs` and `test/Yesod/Auth/OIDCSpec.hs`.++# Relation to other Haskell libraries++* [Broch](https://github.com/tekul/broch): a Haskell implementation of an OpenID _Provider_. `yesod-auth-oidc` implements an OpenID _Relying Party_ (AKA client).++* [oidc-client](https://hackage.haskell.org/package/oidc-client): `yesod-auth-oidc` uses this utility library. It handles important parts such as token validation, and is not tied to Yesod.++* [yesod-auth](https://hackage.haskell.org/package/yesod-auth), its `Yesod.Auth.OpenID` module, and the the [authenticate](https://hackage.haskell.org/package/authenticate) library: this appears to be an implementation of [OpenID Authentication 2.0](https://openid.net/specs/openid-authentication-2_0.html), which is the previous "generation" of the OpenID Foundation's efforts. OpenID 2 doesn't seem to be supported by many off-the-shelf SSO Providers (e.g. Azure AD, Auth0), unlike OIDC.++* [yesod-auth-oauth2](https://hackage.haskell.org/package/yesod-auth-oauth2): Offers authentication using the authorisation protocol [OAuth 2.0](https://tools.ietf.org/html/rfc6749). OIDC defines some extras on top of OAuth 2.0 to securely implement authentication.++# Limitations++* Only Authorization Code flow is supported. This is the most widely compatible version of OIDC, which all compliant providers must support.++* Extras such as dynamic registration, single log-out, and automatic session extension via the "prompt" parameter are not implemented.++* The algorithm for determining the HTTP cache period of the discovery document and JWK Set is not yet implemented. For now, you could implement most of this yourself in the appropriate callback however (or send.++# Development++The maintainers typically run `nix-shell` and then use GHCi or cabal from there.
+ src/Yesod/Auth/OIDC.hs view
@@ -0,0 +1,587 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+-- | A yesod-auth plugin for per-tenant SSO via OpenID Connect, using+-- Authorization Code flow (AKA server flow) with client_secret_post+-- client authentication.+--+-- Reserves "ya-oidc-*" as session keys.+--+-- Referenced standards:+-- * OIDC Core: https://openid.net/specs/openid-connect-core-1_0.html+-- * RFC 6749, OAuth 2.0: https://tools.ietf.org/html/rfc6749+-- * RFC 6750, OAuth 2.0 Bearer Token Usage: https://tools.ietf.org/html/rfc6750+module Yesod.Auth.OIDC+ ( oidcPluginName+ , authOIDC+ , ClientId(..)+ , ClientSecret(..)+ , UserInfo+ , UserInfoPreference(..)+ , YesodAuthOIDC(..)+ , OAuthErrorResponse(..)+ , oidcSessionExpiryMiddleware++ -- * Routes+ , oidcLoginR+ , oidcForwardR+ , oidcCallbackR++ -- * Re-exported from oidc-client+ , Configuration(..)+ , Provider(..)+ , IssuerLocation+ , Tokens(..)+ , IdTokenClaims(..)++ -- * Exposed or re-exported for testing and mocking+ , MockOidcProvider(..)+ , SessionStore(..)+ , OIDC(..)+ , JwsAlgJson(..)+ , JwsAlg(..)+ , Jwt(..)+ , IntDate(..)+ , CallbackInput(..)+ ) where++import ClassyPrelude.Yesod+import qualified "cryptonite" Crypto.Random as Crypto+import qualified Data.Aeson as J+import qualified Data.ByteString.Base64.URL as Base64Url+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HashSet+import qualified Data.Text as T+import Data.Time.Clock+import Data.Time.Clock.POSIX+import qualified Network.HTTP.Client as HTTP+import Web.OIDC.Client as Client+import Web.OIDC.Client.Discovery.Provider (JwsAlgJson(..))+import Web.OIDC.Client.Settings+import qualified Web.OIDC.Client.Types as Scopes+import Yesod.Auth++-- For re-export for mocking:+import Jose.Jwa (JwsAlg(..))+import Jose.Jwt (IntDate(..), Jwt(..))++data YesodAuthOIDCException+ = InvalidQueryParamsException Text+ | BadLoginHint+ | NoProviderConfigException+ | InvalidSecurityTokenException+ | TLSNotUsedException Text+ | UnknownTokenType Text+ deriving Show++instance Exception YesodAuthOIDCException++-- | Add this value to your YesodAuth instance's 'authPlugins' list+authOIDC :: YesodAuthOIDC site => AuthPlugin site+authOIDC = AuthPlugin oidcPluginName dispatch 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 = True++ -- | (Optional) A callback to your app in case oidcForwardR is+ -- called without the login_hint query parameter. Default+ -- implementation throws a 'BadLoginHint' exception.+ onBadLoginHint :: AuthHandler site TypedContent+ onBadLoginHint = throwIO BadLoginHint++ -- | Looks up configuration. If none can be found, you should handle+ -- the fallback / error call yourself. Returns the ClientID for the+ -- given identity provider, and either the provider configuration+ -- itself, or otherwise just the Issuer URI. If the latter, this+ -- library will use OIDC discovery to retrieve the configuration.+ --+ -- The Issuer URI should only consist of the scheme (which must be+ -- "https:") and fully qualified host name (e.g. example.com), with+ -- no path etc.+ --+ -- The full configuration could be hard-coded or the cached result+ -- of a previous discovery. Cf 'onProviderConfigDiscovered'.+ --+ -- Note that the 'Provider' is both the configuration and the result of+ -- retrieving the keyset from jwks_uri.+ getProviderConfig ::+ LoginHint -> AuthHandler site (Either Provider IssuerLocation, ClientId)++ -- | (Optional). If the tenant is configured via a discovery URL,+ -- this function will be called with the discovered result and that+ -- result's retrieved keyset. This can be used to cache the+ -- configuration for the given duration. Since the oidc-client+ -- library combines discovery with key retrieval, the given time is+ -- the minimum of the two remaining cache lifetimes returned by both+ -- http requests.+ onProviderConfigDiscovered ::+ Provider -> ClientId -> DiffTime -> AuthHandler site ()+ onProviderConfigDiscovered _ _ _ = pure ()++ -- | (Optional). Do something if the 'oidcCallbackR' was called with+ -- incorrect parameters or the Identity Provider returned an+ -- error. This could happen if the request is not legitimate or if+ -- the identity provider doesn't provide the required `state` or+ -- `code` query or post parameters.+ --+ -- Defaults to a simple page showing the error (sans the error_uri).+ onBadCallbackRequest ::+ Maybe OAuthErrorResponse+ -- ^ The OAuth Error Response if present (See RFC6749 §5.2 and+ -- OIDC §3.1.2.6). This will only be 'Just' if the "state" param+ -- (anti-CSRF token) is valid.+ -> AuthHandler site a+ onBadCallbackRequest mError = do+ errHtml <- authLayout $ toWidget widg+ sendResponseStatus status400 errHtml+ where+ widg =+ [whamlet|+ <h1>Error+ <p>There has been some miscommunication between your Identity Provider and our application.+ <p>Please try logging in again and contact support if the problem persists.+ $maybe OAuthErrorResponse err mErrDesc _ <- mError+ <p><i>Error code:</i> #{err}+ $maybe errDesc <- mErrDesc+ <p><i>Error description: </i>#{errDesc}+ $maybe errUri <- mErrDesc+ <p><i>More information: </i>#{errUri}+ |]++ -- | The printable-ASCII client_secret which you've set up with the+ -- provider ahead of time (this library does not support the dynamic+ -- registration spec).+ getClientSecret :: ClientId -> Configuration -> AuthHandler site ClientSecret++ -- | (Optional). The scopes that you are requesting. The "openid"+ -- scope will always be included in the eventual request whether or+ -- not you specify it here. Defaults to ["email"].+ getScopes :: ClientId -> Configuration -> AuthHandler site [ScopeValue]+ getScopes _ _ = pure [email]++ -- | (Optional). Configure the behaviour of when to request user+ -- information. The default behaviour is to only make this request+ -- if it's necessary satisfy the scopes in 'getScopes'.+ getUserInfoPreference ::+ LoginHint -> ClientId -> Configuration -> AuthHandler site UserInfoPreference+ getUserInfoPreference _ _ _ = pure GetUserInfoOnlyToSatisfyRequestedScopes++ -- | (Required). Should return a unique identifier for this user to+ -- use as the key in the yesod app's session backend. Sent after the+ -- user has successfully authenticated and right before telling+ -- Yesod that the user is authenticated. This function can still+ -- cancel authentication if it throws an error or short-circuits.+ --+ -- If you are using the underlying OAuth spec for non-OIDC reasons,+ -- you can do extra work here, such as storing the access and+ -- refresh tokens.+ onSuccessfulAuthentication ::+ LoginHint+ -- ^ *Warning*: This is original login hint (typically an email),+ -- does *not* assert anything about the user's identity. The user+ -- could have logged in with an email different to this one, or+ -- their email at the Identity Provider could just be different to+ -- this hint. Use the information in the ID Token and UserInfo+ -- Response for authentic identity information.+ -> ClientId+ -> Provider+ -> Tokens J.Object+ -- ^ The OIDC 'Token Response', including a fully validated ID+ -- Token. The 'otherClaims' value is purposefully an unparsed JSON+ -- object to provide maximum flexibility.+ -> Maybe UserInfo+ -- ^ The response of the userinfo endpoint is given depending on+ -- the 'getUserInfoPreference' and whether the request was+ -- actually successful. For flexibility, any exceptions in the+ -- course of getting the UserInfo are caught by this library;+ -- such errors only manifest as an unexpected 'Nothing' here.+ -> AuthHandler site Text++ -- | Defaults to clearing the credentials from the session and+ -- redirecting to the site's logoutDest (if not currently there+ -- already or out loginDest)+ onSessionExpiry :: HandlerFor site ()+ onSessionExpiry = clearCreds True++ -- | Should return your app's 'HttpManager' or a mock for+ -- testing. Allows high-level mocking of the 3 functions that use+ -- the HttpManager (as opposed to a lower-level mock of the 3 HTTP+ -- responses themselves).+ getHttpManagerForOidc ::+ AuthHandler site (Either MockOidcProvider HTTP.Manager)++data MockOidcProvider = MockOidcProvider+ { mopDiscover :: Text -> Provider+ , mopGetValidTokens ::+ LoginHint -> CallbackInput -> SessionStore IO -> OIDC -> Tokens J.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 (Show, Eq)++-- | The name used to render this plugin's routes, "oidc".+oidcPluginName :: Text+oidcPluginName = "oidc"++-- | Optional route that reads in the "login hint" (commonly an email+-- address). Your app can use this for its main login screen, or it+-- could have a separate login screen not managed by this plugin but+-- which redirects to 'oidcForwardR' with the login_hint when+-- appropriate.+--+-- /auth/page/oidc/login+oidcLoginR :: AuthRoute+oidcLoginR = PluginR oidcPluginName ["login"]++-- | This accepts an `email` post param. Looks up or discovers+-- the OIDC provider associated with this login_hint, and redirects+-- the user to the provider's Authorization Endpoint.+--+-- /auth/page/oidc/forward+oidcForwardR :: AuthRoute+oidcForwardR = PluginR oidcPluginName ["forward"]++-- | This route is given to the provider so that the provider can+-- redirect the user here with the appropriate Authorisation Code, at+-- which point the library continues the authentication process.+--+-- /auth/page/oidc/callback+oidcCallbackR :: AuthRoute+oidcCallbackR = PluginR oidcPluginName ["callback"]++dispatch :: forall site. YesodAuthOIDC site+ => Text -> [Text] -> AuthHandler site TypedContent+dispatch httpMethod uriPath = case (httpMethod, uriPath) of+ ("GET", ["login"]) -> if enableLoginPage @site then getLoginR else notFound+ ("POST", ["forward"]) -> postForwardR++ -- These two handlers are ultimately the same handler. Identity+ -- Providers may use GET or POST for the callback.+ ("GET", ["callback"]) -> handleCallback GET+ ("POST", ["callback"]) -> handleCallback POST+ _ -> notFound++loginW :: (Route Auth -> Route site) -> WidgetFor site ()+loginW toParentRoute = do+ mToken <- reqToken <$> liftHandler 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 = do+ rtp <- getRouteToParent+ selectRep . provideRep . authLayout $ toWidget $ loginW rtp++findProvider :: YesodAuthOIDC site+ => LoginHint -> AuthHandler site (Provider, ClientId)+findProvider loginHint = getProviderConfig loginHint >>= \case+ (Left provider, clientId) ->+ pure (provider, clientId)+ (Right issuerLoc, clientId) -> do+ unless ("https:" `T.isPrefixOf` issuerLoc+ || "http://localhost" `T.isPrefixOf` issuerLoc) $+ throwIO $ TLSNotUsedException+ $ "The issuer location doesn't start with 'https:'. \+ \OIDC requires all communication with the IdP to use TLS."+ provider <- getHttpManagerForOidc >>= \case+ Left mock -> pure $ (mopDiscover mock) issuerLoc+ Right mgr -> liftIO $ discover issuerLoc mgr+ onProviderConfigDiscovered provider clientId 60+ pure (provider, clientId)++-- | Expects 'email' and '_token' post params.+postForwardR :: YesodAuthOIDC site+ => AuthHandler site TypedContent+postForwardR = do+ checkCsrfParamNamed defaultCsrfParamName+ mLoginHint <- lookupPostParam "email"+ case mLoginHint of+ Nothing -> onBadLoginHint+ Just loginHint -> do+ (provider, clientId) <- findProvider loginHint+ forward loginHint provider clientId++-- Generates a 64-bit nonce encoded as uri-safe base64+genNonce :: IO ByteString+genNonce = Base64Url.encode <$> Crypto.getRandomBytes 64++sessionPrefix :: Text+sessionPrefix = "ya"++nonceSessionKey :: Text+nonceSessionKey = sessionPrefix <> "-oidc-nonce"++stateSessionKey :: Text+stateSessionKey = sessionPrefix <> "-oidc-state"++loginHintSessionKey :: Text+loginHintSessionKey = sessionPrefix <> "-oidc-login-hint"++-- oidc-client's CodeFlow functions have a `MonadCatch m` constraint,+-- and take a `SessionStore m` argument. Handlers in Yesod do not+-- implement MonadCatch, so we use m ~ IO, and then unliftIO to still+-- use Handler calls in the 'SessionStore IO'+makeSessionStore :: AuthHandler site (SessionStore IO)+makeSessionStore = do+ UnliftIO unlift <- askUnliftIO+ pure $ SessionStore+ { sessionStoreGenerate = genNonce+ , sessionStoreSave = \state nonce -> unlift $ do+ setSessionBS stateSessionKey state+ setSessionBS nonceSessionKey nonce+ , sessionStoreGet = unlift $+ (,) <$> lookupSessionBS stateSessionKey+ <*> lookupSessionBS nonceSessionKey+ , sessionStoreDelete = unlift $ do+ deleteSession stateSessionKey+ deleteSession nonceSessionKey+ }++newtype ClientId = ClientId { unClientId :: Text } deriving (Show, Eq, Ord)++newtype ClientSecret = ClientSecret { unClientSecret :: Text }++instance Show ClientSecret where+ show _ = "<redacted-client-secret>"++makeOIDC ::+ Provider+ -> ClientId+ -> ClientSecret+ -> AuthHandler site OIDC+makeOIDC provider (ClientId clientId) (ClientSecret clientSecret) = do+ urlRender <- getUrlRender+ toParent <- getRouteToParent+ pure $ OIDC+ { oidcAuthorizationServerUrl = authorizationEndpoint cfg+ , oidcTokenEndpoint = tokenEndpoint cfg+ , oidcClientId = encodeUtf8 clientId+ , oidcRedirectUri = encodeUtf8 $ urlRender $ toParent oidcCallbackR+ , oidcProvider = provider+ , oidcClientSecret = encodeUtf8 clientSecret+ }+ where cfg = configuration provider++forward :: (YesodAuthOIDC a)+ => LoginHint+ -> Provider+ -> ClientId+ -> AuthHandler a TypedContent+forward loginHint provider@(Provider cfg _keyset) clientId = do+ scopes <- getScopes clientId cfg+ setSession loginHintSessionKey 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 <- makeOIDC provider clientId (ClientSecret "DUMMY") <&> \oidc' -> oidc'+ { oidcClientSecret =+ error "client_secret should never be used in the authentication \+ \request as it would undesirably expose the secret to the user"+ }+ let extraParams =+ [("login_hint", Just $ urlEncode False $ encodeUtf8 loginHint)]+ sessionStore <- makeSessionStore+ -- This function internally prepends "openid" to the scope list (and+ -- also deduplicates it)+ uri <- liftIO $ prepareAuthenticationRequestUrl+ sessionStore oidc scopes extraParams+ redirect $ show uri++data CallbackInput = CallbackInput+ { ciState :: Text+ , ciCode :: Text+ }++-- | As defined in RFC6749 §5.2+data OAuthErrorResponse = OAuthErrorResponse+ { oaeError :: Text+ , oaeErrorDescription :: Maybe Text+ , oaeErrorUri :: Maybe Text+ } deriving Show++asTrustedState :: YesodAuthOIDC site+ => SessionStore IO -> [Text] -> AuthHandler site Text+asTrustedState sessionStore = \case+ [untrustedState] -> do+ (mState, _) <- liftIO $ sessionStoreGet sessionStore+ if fmap decodeUtf8 mState /= Just untrustedState+ then onBadCallbackRequest Nothing+ else pure untrustedState+ _ -> onBadCallbackRequest Nothing++processCallbackInput :: YesodAuthOIDC site+ => StdMethod -> SessionStore IO -> AuthHandler site CallbackInput+processCallbackInput reqMethod sessionStore = do+ validState <- params "state" >>= asTrustedState sessionStore+ codes <- params "code"+ errs <- params "error"+ case (codes, errs) of+ ([code], []) ->+ pure CallbackInput+ { ciState = validState+ , ciCode = code }+ ([], [err]) -> do+ mErrDesc <- listToMaybe <$> params "error_description"+ mErrUri <- listToMaybe <$> params "error_uri"+ onBadCallbackRequest $ Just $ OAuthErrorResponse err mErrDesc mErrUri+ _ -> onBadCallbackRequest Nothing+ where+ params = if reqMethod == GET+ then lookupGetParams+ else lookupPostParams++-- Providers may use GET or POST for the callback, so we+-- handle both cases in this function+handleCallback ::+ YesodAuthOIDC site+ => StdMethod -> AuthHandler site TypedContent+handleCallback reqMethod = do+ loginHint <- lookupSession loginHintSessionKey+ >>= maybe (onBadCallbackRequest Nothing) pure+ deleteSession loginHintSessionKey+ sessionStore <- makeSessionStore+ cbInput@CallbackInput{..} <- processCallbackInput reqMethod sessionStore+ (provider, clientId) <- findProvider loginHint+ clientSecret <- getClientSecret clientId $ configuration provider+ oidc <- makeOIDC provider clientId clientSecret+ eMgr <- getHttpManagerForOidc+ tokens <- case eMgr of+ Left mock -> pure $ (mopGetValidTokens mock) loginHint cbInput sessionStore oidc+ Right mgr -> liftIO $ getValidTokens sessionStore oidc mgr+ (encodeUtf8 ciState) (encodeUtf8 ciCode)+ let posixExpiryTime = case Client.exp $ idToken tokens of+ IntDate posixTime -> floor @POSIXTime @Int posixTime+ userInfoPref <- getUserInfoPreference loginHint clientId (configuration provider)+ requestedClaims <- HashSet.delete Scopes.openId . HashSet.fromList+ <$> getScopes clientId (configuration provider)+ let missingClaims = requestedClaims+ `HashSet.difference` HM.keysSet (otherClaims $ idToken tokens)+ mUserInfo <- case (userInfoPref, userinfoEndpoint $ configuration provider) of+ (GetUserInfoIfAvailable, Just uri) -> liftIO $+ handleAny (const (pure Nothing)) $ requestUserInfo eMgr tokens uri+ (GetUserInfoOnlyToSatisfyRequestedScopes, Just uri)+ | not (HashSet.null missingClaims) -> liftIO $+ handleAny (const (pure Nothing)) $ requestUserInfo eMgr tokens uri+ _ -> pure Nothing+ userId <- onSuccessfulAuthentication loginHint clientId provider tokens mUserInfo+ setSession sessionExpiryKey $ tshow posixExpiryTime+ setCredsRedirect Creds+ { credsPlugin = oidcPluginName+ , credsIdent = userId+ , credsExtra = [("iss", iss $ idToken tokens), ("exp", tshow posixExpiryTime)]+ }++sessionExpiryKey :: Text+sessionExpiryKey = sessionPrefix <> "-exp"++requestUserInfo ::+ Either MockOidcProvider HTTP.Manager+ -> Tokens J.Object+ -> Text -- UserInfo Endpoint URI+ -> IO (Maybe J.Object)+requestUserInfo eMgr tokens uri = do+ unless ("https:" `T.isPrefixOf` uri+ || "http://localhost" `T.isPrefixOf` uri) $+ throwIO $ TLSNotUsedException $ "The URI of the UserInfo Endpoint must start with https"+ unless (T.toLower (tokenType tokens) == "bearer") $+ -- "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)+ throwIO $ UnknownTokenType $ tokenType tokens+ req0 <- HTTP.parseRequest $ T.unpack uri+ -- Use Bearer auth as defined in RFC6750 2.1+ let req = req0 {+ HTTP.requestHeaders = [+ ("Authorization" , encodeUtf8 $ "Bearer " <> accessToken tokens)]+ }+ case eMgr of+ Left mock -> pure $ (mopRequestUserInfo mock) req tokens+ Right mgr -> do+ resp <- HTTP.httpLbs req mgr+ pure $ J.decode $ responseBody 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 handler = do+ mExp <- lookupSession sessionExpiryKey+ case mExp of+ Just ex -> do+ let mExInt :: Maybe Int64 = readMay ex+ case mExInt of+ Nothing -> onSessionExpiry >> handler+ Just exInt -> do+ let expTime = posixSecondsToUTCTime $ realToFrac exInt+ now <- liftIO $ getCurrentTime+ if now > expTime+ then do+ deleteSession sessionExpiryKey+ onSessionExpiry+ -- The handler almost certainly will be+ -- short-circuited by now but for flexbility and+ -- easier typing, we include it here:+ handler+ else handler+ _ -> handler
+ test/ExampleApp.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module ExampleApp where++import ClassyPrelude.Yesod+import qualified Data.Aeson as J+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import Database.Persist.Sql+import ExampleProviderOpts+import Yesod.Auth+import Yesod.Auth.OIDC+import Yesod.Core.Types (Logger)++data App = App+ { appLogger :: Logger+ , appHost :: Text+ , appConnPool :: ConnectionPool+ , appHttpManager :: Manager+ , appBrochClientId :: ClientId+ }++mkYesod "App" [parseRoutes|+/ HomeR GET+/auth AuthR Auth getAuth+/convenient-test-token CsrfTokenR GET+/protected/resource ProtectedResourceR GET+|]++getHomeR :: Handler ()+getHomeR = pure ()++getCsrfTokenR :: Handler Text+getCsrfTokenR = do+ setCsrfCookie+ reqToken <$> getRequest >>= \case+ Nothing -> error "app unexpectedly started without session storage"+ Just t -> pure t++getProtectedResourceR :: Handler J.Value+getProtectedResourceR = do+ uid <- requireAuthId+ pure $ J.String $ tshow uid++share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|+OidcConfig+ clientId Text+ issuer Text+ Primary clientId issuer+ deriving Show++OidcDomain+ domain Text+ clientId Text+ issuer Text+ Primary domain+ Foreign OidcConfig oidc_domain_oidc_config_fk clientId issuer+ deriving Show++-- | Users in this example app come exclusively from OIDC+-- Providers. Users are created automatically on successful+-- authentication+User+ -- | We specifically do not make the email unique per-user, in+ -- accordance with the OIDC spec+ email Email++ -- | The unique issuer + subject pair could be made null-able in an+ -- app that also allows non-OIDC registrations+ issuer Text+ subject Text++ UniqueUser issuer subject+ deriving Show+|]++instance Yesod App where++instance YesodPersist App where+ type YesodPersistBackend App = SqlBackend++ runDB :: SqlPersistT Handler a -> Handler a+ runDB db = getsYesod appConnPool >>= runSqlPool db++instance YesodAuth App where+ type AuthId App = Key User+ loginDest _ = HomeR+ logoutDest _ = HomeR+ authPlugins _ = [ authOIDC ]+ getAuthId = return . fromPathPiece . credsIdent+ maybeAuthId = defaultMaybeAuthId++addProvider ::+ ( PersistStoreWrite (YesodPersistBackend (HandlerSite f))+ , YesodPersist (HandlerSite f)+ , MonadHandler f+ , BaseBackend (YesodPersistBackend (HandlerSite f)) ~ SqlBackend)+ => OidcConfig -> [Text] -> f ()+addProvider cfg domains = liftHandler . runDB $ do+ insert_ cfg+ insertMany_ $ flip map domains $ \domain ->+ OidcDomain { oidcDomainDomain = domain+ , oidcDomainClientId = oidcConfigClientId cfg+ , oidcDomainIssuer = oidcConfigIssuer cfg+ }++instance HasHttpManager App where+ getHttpManager = appHttpManager++instance YesodAuthOIDC App where+ getHttpManagerForOidc = Right <$> getsYesod appHttpManager+ getProviderConfig loginHint = do+ let domain = snd $ T.breakOnEnd "@" loginHint+ mConfig <- liftHandler . runDB $ get $ OidcDomainKey domain+ case mConfig of+ Just cfg -> pure ( Right $ oidcDomainIssuer cfg+ , ClientId $ oidcDomainClientId cfg)+ Nothing -> error "No config for this domain"+ getClientSecret clientId _ = pure $ fakeClientSecret clientId+ onSuccessfulAuthentication _originalLoginHint _clientId _provider tokens mUserInfo = do+ let idTok = idToken tokens+ -- The 'email' is sometimes in the ID Token, and sometimes in the+ -- UserInfo Response. Both are JSON objects.+ let emailVal =+ HM.lookup "email" (otherClaims idTok)+ <|> (mUserInfo >>= HM.lookup "email")+ emailAddr = case emailVal of+ Just (J.String em) -> em+ _ -> error "Spec-conforming email missing from ID token and/or User Info Response"+ mUser <- liftHandler . runDB $ getBy $ UniqueUser (iss idTok) (sub idTok)+ case mUser of+ Just (Entity uid u) -> do+ when (userEmail u /= emailAddr) $+ liftHandler . runDB $ update uid [ UserEmail =. emailAddr ]+ pure $ toPathPiece uid+ Nothing -> do+ fmap toPathPiece $ liftHandler . runDB $ insert $ User+ { userEmail = emailAddr+ , userIssuer = iss idTok+ , userSubject = sub idTok+ }++instance YesodAuthPersist App++instance RenderMessage App FormMessage where+ renderMessage _ _ = defaultFormMessage
+ test/ExampleProvider.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-+The code in this module is modified from that found in the+broch-server/broch.hs file in the 'broch' library, which is under the+following copyright and license:++----------------------++Copyright (c) 2014, Luke Taylor++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;+OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++-}+module ExampleProvider where++import ClassyPrelude+import ExampleProviderOpts++import Broch.Model+import Broch.Server+import Broch.Server.Config+import Broch.Server.Internal+import Broch.Server.Session (defaultKey, defaultLoadSession)+import qualified Broch.SQLite as BS+import Broch.URI+import Crypto.KDF.BCrypt (hashPassword)+import Data.Aeson+import qualified Data.Map as M+import Data.Pool (createPool, withResource)+import qualified Database.SQLite.Simple as SQLite+import Network.Wai.Application.Static (defaultWebAppSettings, staticApp)+import Network.Wai.Handler.Warp (run)+import Network.Wai.Middleware.RequestLogger (logStdoutDev)+import System.Directory+import qualified Web.Routing.Combinators as R+import qualified Web.Routing.SafeRouting as R+import Yesod.Auth.OIDC (ClientId(..), ClientSecret(..))++-- Adapted from Broch.SQLite+toJSONField :: ToJSON a => Maybe a -> SQLite.SQLData+toJSONField = maybe SQLite.SQLNull (SQLite.SQLText . decodeUtf8 . toStrict . encode)++-- Adapted from Broch.SQLite+insertClient :: SQLite.Connection -> Client -> IO ()+insertClient conn Client{..} =+ void $ SQLite.execute conn "INSERT INTO oauth2_client (id, secret, redirect_uri, allowed_scope, authorized_grant_types, access_token_validity, refresh_token_validity, auth_method, auth_alg, keys_uri, keys, id_token_algs, user_info_algs, request_obj_algs, sector_identifier, auto_approve) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" ((clientId, clientSecret, redirectURIs, allowedScope, authorizedGrantTypes, accessTokenValidity, refreshTokenValidity, clientAuthMethodName tokenEndpointAuthMethod, fmap tshow tokenEndpointAuthAlg, clientKeysUri) SQLite.:. (toJSONField clientKeys, toJSONField idTokenAlgs, toJSONField userInfoAlgs, toJSONField requestObjAlgs, sectorIdentifier, autoapprove))++initDB :: BrochOptions -> SQLite.Connection -> IO ()+initDB BrochOptions{..} c = do+ void $ flip M.traverseWithKey boClients $ \(ClientId clientId) (ClientSecret secret, host, callback) ->+ insertClient c $ Client+ { clientId = clientId+ , clientSecret = Just secret+ , authorizedGrantTypes = [AuthorizationCode]+ , redirectURIs = case parseURI callback of+ Right url -> [url]+ Left e -> error $ "Can't initialise tests due to bad callback URL: " <> show e+ , accessTokenValidity = 3600+ , refreshTokenValidity = 7200+ , allowedScope = [OpenID, Profile, Email]+ , autoapprove = False+ , tokenEndpointAuthMethod = ClientSecretPost+ , tokenEndpointAuthAlg = Nothing -- :: Maybe JwsAlg+ , clientKeysUri = Nothing -- :: Maybe Text+ , clientKeys = Just [] -- :: Maybe [Jwk]+ , idTokenAlgs = Nothing -- :: Maybe AlgPrefs+ , userInfoAlgs = Nothing -- :: Maybe AlgPrefs+ , requestObjAlgs = Nothing -- :: Maybe AlgPrefs+ , sectorIdentifier = host+ }+ void $ flip M.traverseWithKey boUsers $ \userId (emailAddr, pw) -> do+ pwHash :: ByteString <- hashPassword 6 (encodeUtf8 pw)+ void $ SQLite.execute c "INSERT OR REPLACE INTO op_user VALUES (?, ?, ?, 'key')" ((userId, userId, pwHash))+ void $ SQLite.execute c "INSERT OR REPLACE INTO user_info VALUES (?, 'name', 'first', 'last', 'middle', 'nick', 'name', 'http://placeholder', 'http://placeholder', 'http://placeholder', ?, 0, null, '2000-01-01', 'Europe/Paris', 'en-US', '+33 12 34 56 78', 0, '25 My Street, Village, 1234567, France', '25 My Street', 'Vilage', 'Shire', '1234567', 'EN', datetime('now'))" ((userId, emailAddr))+++runBroch :: BrochOptions -> IO ()+runBroch opts@BrochOptions{..} = do+ sessionKey <- defaultKey+ kr <- defaultKeyRing+ rotateKeys kr True+ let dbFile = "broch.sqlite3"+ dbExists <- doesFileExist dbFile+ when dbExists $ removeFile dbFile+ pool <- createPool (SQLite.open dbFile) SQLite.close 1 60 20+ withResource pool BS.createSchema+ config <- BS.sqliteBackend pool <$> inMemoryConfig boIssuerUri kr Nothing+ let app = staticApp (defaultWebAppSettings "webroot")+ baseRouter = brochServer config defaultApprovalPage authenticatedSubject authenticateSubject+ authenticate username password = pure $ M.lookup username boUsers >>= \case+ (_, pw) | pw == password -> Just username+ _ -> Nothing+ extraRoutes =+ [ ("/home", text "Hello, I'm the home page")+ , ("/login", passwordLoginHandler defaultLoginPage authenticate)+ , ("/logout", invalidateSession >> text "You have been logged out")+ ]+ router = foldl' (\pathMap (r, h) -> R.insertPathMap' (R.toInternalPath (R.static r)) (const h) pathMap) baseRouter extraRoutes+ broch = routerToMiddleware (defaultLoadSession 3600 sessionKey) boIssuerUri router++ withResource pool $ initDB opts++ run boPort (logStdoutDev (broch app))
+ test/ExampleProviderOpts.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+module ExampleProviderOpts where++import ClassyPrelude+import Yesod.Auth.OIDC++-- Quick-and-dirty type synonyms just for testing+type Domain = Text+type Email = Text+type SubjectId = Text+type ClientHost = Text+type CallbackUri = Text+type Password = Text++-- | You should store your client secrets as you would for other+-- credentials in your app.+fakeClientSecret :: ClientId -> ClientSecret+fakeClientSecret (ClientId cid) =+ -- You should not hardcode it like this:+ ClientSecret $ cid <> "_secret"++-- | We use the 'broch' library as a local OIDC Provider. You do not+-- need something like this in your client app.+data BrochOptions = BrochOptions+ { boIssuerUri :: Text+ , boPort :: Int+ , boUsers :: Map SubjectId (Email, Password)+ , boClients :: Map ClientId (ClientSecret, ClientHost, CallbackUri)+ }
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/TestImport.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++module TestImport+ ( module TestImport+ , module X+ ) where++import ClassyPrelude as X hiding (Handler, delete, deleteBy)+import Control.Monad.Logger (runLoggingT)+import qualified Data.Map as M+import Database.Persist as X hiding (get)+import Database.Persist.Sql (runMigration, runSqlPool)+import Database.Persist.Sqlite (createSqlitePool)+import ExampleApp as X+import ExampleProvider as Broch+import ExampleProviderOpts as X+import Network.HTTP.Client+import Network.Wai.Handler.Warp+import Network.Wai.Middleware.RequestLogger (logStdoutDev)+import System.Directory+import System.Log.FastLogger (newStdoutLoggerSet)+import Test.Hspec as X+import Yesod hiding (get)+import Yesod.Auth.OIDC as X hiding (exp)+import Yesod.Core as X+import qualified Yesod.Core.Unsafe as Unsafe+import Yesod.Default.Config2 (makeYesodLogger)+import Yesod.Persist.Core as X++type TestArgs = (Async (), Async (), App, BrochOptions)++user1 :: (SubjectId, (Email, Password))+user1 = ("user1", ("user1@example.local", "password1"))++brochUsers :: Map SubjectId (Email, Password)+brochUsers = M.fromList+ [ user1+ , ("user2", ("user2@sub.example.local", "password2"))+ ]++withServers :: SpecWith TestArgs -> Spec+withServers = beforeAll runServers . afterAll stopServers+ where+ appPort = 4049+ appHost = "http://localhost:" <> tshow appPort+ boPort = 4050+ boIssuerUri = "http://localhost:" <> tshow boPort+ boUsers = brochUsers+ appBrochClientId = ClientId "client1"+ boClients = M.fromList+ [ (appBrochClientId, ( fakeClientSecret appBrochClientId+ , appHost+ , appHost <> "/auth/page/oidc/callback"))+ ]+ brochOptions = BrochOptions{..}+ runServers = do+ brochA <- async $ Broch.runBroch brochOptions+ appLogger <- newStdoutLoggerSet 1 >>= makeYesodLogger+ appHttpManager <- newManager defaultManagerSettings+ let mkFoundation appConnPool = App {..}+ tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"+ logFunc = messageLoggerSource tempFoundation appLogger+ removeIfExists "auth.sqlite3"+ pool <- flip runLoggingT logFunc $ createSqlitePool "auth.sqlite3" 10+ runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc+ let app = mkFoundation pool+ waiApp <- toWaiAppPlain app+ appA <- async $ run appPort $ logStdoutDev waiApp+ pure (brochA, appA, app, brochOptions)+ stopServers (brochA, appA, _, _) = do+ cancel brochA+ cancel appA++unsafeHandler :: App -> Handler a -> IO a+unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger++removeIfExists :: FilePath -> IO ()+removeIfExists f = do+ fileExists <- doesFileExist f+ when fileExists (removeFile f)
+ test/Yesod/Auth/OIDCSpec.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}++module Yesod.Auth.OIDCSpec (spec) where++import Control.Lens ((^.))+import qualified Control.Lens.Regex.Text as Regex+import qualified Data.Map as M+import qualified Data.Set as Set+import qualified Data.Text as T+import Network.HTTP.Client+import Network.HTTP.Types.Status+import TestImport++spec :: Spec+spec = withServers $ do+ describe "login with OpenID Connect" $ do+ it "can login with OIDC" $ \(_, _, app@App{..}, BrochOptions{..}) -> do+ -- In this test, the ExampleProvider has already been populated+ -- with the user, and the ExampleApp is configured to insert new+ -- users into its local database upon successful+ -- authentication. We first configure our client app for this+ -- provider:+ unsafeHandler app $ runDB $ do+ insert_ $ OidcConfig+ { oidcConfigClientId = unClientId appBrochClientId+ , oidcConfigIssuer = boIssuerUri+ }+ let domains = Set.toList . Set.fromList+ $ map (snd . T.breakOnEnd "@" . fst) $ M.elems brochUsers+ insertMany_ $ flip map domains $ \domain -> OidcDomain+ { oidcDomainDomain = domain+ , oidcDomainClientId = unClientId appBrochClientId+ , oidcDomainIssuer = boIssuerUri+ }++ ur <- unsafeHandler app getUrlRender+ let+ mgr = appHttpManager+ mkReq = parseRequest_ . unpack . (appHost <>) . ur+ protectedReq = mkReq ProtectedResourceR+ tokenReq = mkReq CsrfTokenR+ forwardReq = mkReq $ AuthR oidcForwardR++ -- Assert that we can't get the ProtectedResource yet+ protectedRes0 <- httpNoBody protectedReq mgr+ liftIO $ responseStatus protectedRes0 `shouldBe` status403++ -- Get the csrf token (Yesod's default csrf handling is+ -- session-specific rather than request-specific).+ tokenResp <- httpLbs tokenReq mgr+ let token = toStrict $ responseBody tokenResp++ -- POST to the oidcForwardR with correct params.+ let (user1_id, (user1_email, user1_pw)) = user1+ respForwardR <- httpLbs+ (urlEncodedBody+ [ (encodeUtf8 defaultCsrfParamName, token)+ , ("email", encodeUtf8 user1_email)+ ] $ forwardReq { method = "POST"+ , cookieJar = Just $ responseCookieJar tokenResp })+ mgr+ let+ respForwardR_body = toStrict $ decodeUtf8 (responseBody respForwardR)+ brochCsrfToken = respForwardR_body+ ^. [Regex.regex|name="_rid" value="([^"]*)">|]+ . Regex.group 0++ -- POST the provider's login URL with username and password.+ let loginReq = urlEncodedBody+ [ ("username", encodeUtf8 user1_id)+ , ("password", encodeUtf8 user1_pw)+ , ("_rid", encodeUtf8 brochCsrfToken)+ ] $ (parseRequest_ (unpack $ boIssuerUri <> "/login"))+ { method = "POST"+ , cookieJar = Just $ responseCookieJar respForwardR+ }+ respProviderLogin <- httpLbs loginReq mgr++ -- POST the provider's scope approval form+ let+ expiryParam =+ (toStrict $ decodeUtf8 $ responseBody respProviderLogin)+ ^. [Regex.regex|"expiry"><option value="([^"]*)"|]+ . Regex.group 0+ approvalReq = urlEncodedBody+ [ ("client_id", encodeUtf8 $ unClientId appBrochClientId)+ , ("expiry", encodeUtf8 expiryParam)+ , ("requested_scope", "openid")+ , ("scope", "openid")+ , ("scope", "email")+ ] $ (parseRequest_ (unpack $ boIssuerUri <> "/approval"))+ { method = "POST"+ , cookieJar = Just $ responseCookieJar respProviderLogin+ }+ respApproval <- httpLbs approvalReq mgr++ -- Assert that we can access previously unaccessible protected+ -- resource.+ protectedRes1 <- httpNoBody+ (protectedReq { cookieJar = Just $ responseCookieJar respApproval }) mgr++ liftIO $ responseStatus protectedRes1 `shouldBe` status200
+ yesod-auth-oidc.cabal view
@@ -0,0 +1,126 @@+cabal-version: 2.2+name: yesod-auth-oidc+version: 0.1.0+build-type: Simple+category: Web, Yesod+extra-source-files: README.md+license: BSD-3-Clause+license-file: LICENSE+author: Supercede Technology Ltd+maintainer: Supercede Technology Ltd <support@supercede.com>+homepage: https://github.com/SupercedeTech/yesod-auth-oidc+synopsis: A yesod-auth plugin for multi-tenant SSO via OpenID Connect+description:+ A yesod-auth plugin for multi-tenant SSO via OpenID Connect, using+ Authorization Code flow (AKA server flow).++ Please see the README.md file for more documentation.++tested-with: GHC == 8.10.4++source-repository head+ type: git+ location: git@github.com:SupercedeTech/yesod-auth-oidc.git++common common-options+ default-language: Haskell2010+ default-extensions: NoImplicitPrelude+ hs-source-dirs: src+ ghc-options:+ -Wall -Wincomplete-uni-patterns+ -Wincomplete-record-updates -Widentities -Wredundant-constraints+ -Wcpp-undef -Wimplicit-prelude -fwarn-tabs+ build-depends:+ base >=4.9.1.0 && <5,+ aeson >= 1.5.6 && < 1.6,+ text >= 1.2.4 && < 1.3,+ time >= 1.9.3 && < 1.10,+ unordered-containers >= 0.2.13 && < 0.3,+ base64-bytestring >= 1.1.0 && < 1.2,+ classy-prelude-yesod >= 1.5.0 && < 1.6,++ cryptonite >= 0.28 && < 0.29,++ http-client >= 0.6.4 && < 0.7,+ jose-jwt >= 0.9.2 && < 0.10,++ oidc-client >= 0.6.0 && < 0.7,++ shakespeare >= 2.0.25 && < 2.1,++ yesod-core >= 1.6.19 && < 1.7,+ yesod-form >= 1.6.7 && < 1.7,+ yesod-auth >= 1.6.10 && < 1.7++library+ import: common-options+ hs-source-dirs: src+ exposed-modules:+ Yesod.Auth.OIDC++Common test-properties+ Default-Language: Haskell2010+ Hs-Source-Dirs: src, test+ Ghc-Options: -Wall+ Default-Extensions: NoImplicitPrelude+ Build-Depends:+ base,+ aeson,+ bytestring >= 0.10.10 && < 0.11,+ containers >= 0.6.2 && < 0.7,+ text,+ time,+ unordered-containers,+ base64-bytestring,+ classy-prelude-yesod,+ classy-prelude >= 1.5.0 && < 1.6,+ directory >= 1.3.6 && < 1.4,+ http-conduit >= 2.3.8 && < 2.4,+ http-client,+ http-types >= 0.12.3 && < 0.13,+ memory >= 0.15.0 && < 0.16,+ cryptonite,+ persistent >= 2.11.0 && <= 2.13.2,+ blaze-html >= 0.9.1 && < 0.10,+ fast-logger >= 3.0.5 && < 3.1,+ monad-logger >= 0.3.36 && < 0.4,+ resource-pool >= 0.2.3 && < 0.3,+ yesod >= 1.6.1 && < 1.7,+ shakespeare,+ wai-extra >= 3.1.6 && < 3.2,+ warp >= 3.3.15 && < 3.4,+ yesod-core,+ yesod-form,+ email-validate >= 2.3.2 && < 2.4,+ yesod-persistent >= 1.6.0 && < 1.7,+ wai-app-static >= 3.1.7 && < 3.2,+ jose-jwt,+ oidc-client,+ yesod-auth,+ broch >= 0.1 && < 0.2,+ postgresql-simple >= 0.6.4 && < 0.7,+ reroute >= 0.6.0 && < 0.7,+ sqlite-simple >= 0.4.18 && < 0.5,+ hspec >= 2.7.10 && < 2.8,+ lens >= 4.19.2 && < 4.20,+ lens-regex-pcre >= 1.1.0 && < 1.2,+ persistent-sqlite >= 2.11.1 && <= 2.13,+ yesod-test >= 1.6.12 && < 1.7++ Other-Modules:+ ExampleApp+ ExampleProvider+ ExampleProviderOpts+ TestImport+ Yesod.Auth.OIDC+ Yesod.Auth.OIDCSpec++Test-Suite spec+ Import: test-properties+ Type: exitcode-stdio-1.0+ Main-Is: Spec.hs+ Build-Tool-Depends: hspec-discover:hspec-discover++Executable yesod-auth-oidc-test+ Import: test-properties+ Main-Is: Spec.hs