hoauth2-demo 1.6.0 → 1.7.0
raw patch · 12 files changed
+947/−591 lines, 12 filesdep +breakpointdep −microlensdep −unordered-containersdep ~hoauth2dep ~hoauth2-providersdep ~text
Dependencies added: breakpoint
Dependencies removed: microlens, unordered-containers
Dependency ranges changed: hoauth2, hoauth2-providers, text, transformers
Files
- README.org +16/−2
- hoauth2-demo.cabal +24/−12
- public/templates/index.mustache +30/−17
- sample.env.json +93/−4
- src/App.hs +227/−150
- src/Env.hs +61/−18
- src/Idp.hs +233/−158
- src/Session.hs +64/−33
- src/Types.hs +55/−180
- src/User.hs +122/−0
- src/Utils.hs +6/−8
- src/Views.hs +16/−9
README.org view
@@ -1,4 +1,18 @@+* Introduction -Sample Application that plays with all those providers and different grant type flow+Sample Application that demonstrates the usage of [[../hoauth2-providers][hoauth2-providers]] to implement social login flow. -Integrated IdPs from `hoauth2-providers` module+* Run the App+1. Copy ~sample.env.json~ to ~.env.json~ for modify it properly.+ a. The structure is like this. The key is App name that each IdP in ~hoauth2-providers~ has defined a name.++ #+begin_example+ "the-app-name": {+ "clientId": "xxx",+ "clientSecret": "xxx",+ "scopes": ""+ }+ #+end_example+ b. ~scopes~ are optional. When omit, use default scopes defined in each IdP from ~hoauth2-providers~. Otherwise, combine with default scopes.++2. run ~make start~
hoauth2-demo.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: hoauth2-demo-version: 1.6.0+version: 1.7.0 synopsis: hoauth2 demo application description: Demo application to test oauth2 flow with many providers using hoauth2@@ -14,7 +14,7 @@ category: Network build-type: Simple stability: Beta-tested-with: GHC <=9.2.2+tested-with: GHC <=9.6.1 extra-source-files: README.org sample.env.json@@ -27,6 +27,11 @@ type: git location: git://github.com/freizl/hoauth2.git +flag breakpoint+ description: Turn on breakpoint plugin+ manual: True+ default: False+ executable hoauth2-demo main-is: Main.hs autogen-modules: Paths_hoauth2_demo@@ -37,18 +42,21 @@ Paths_hoauth2_demo Session Types+ User Utils Views default-extensions: DataKinds DeriveGeneric- GeneralizedNewtypeDeriving+ DerivingStrategies ImportQualifiedPost+ InstanceSigs+ LambdaCase OverloadedStrings+ PolyKinds RecordWildCards TypeApplications- TypeFamilies hs-source-dirs: src default-language: Haskell2010@@ -59,23 +67,27 @@ , containers ^>=0.6 , data-default ^>=0.7 , directory ^>=1.3- , hoauth2 >=2.7- , hoauth2-providers >=0.2+ , hoauth2 ^>=2.9+ , hoauth2-providers ^>=0.3 , http-conduit >=2.1 && <2.4 , http-types >=0.11 && <0.13 , jose-jwt >=0.9.4 && <0.10- , microlens ^>=0.4.0 , mustache >=2.2.3 && <2.5.0 , parsec >=3.1.11 && <3.2.0 , scotty >=0.10.0 && <0.13- , text >=0.11 && <1.3- , transformers ^>=0.5- , unordered-containers >=0.2.5+ , text >=0.11 && <2.1+ , transformers >=0.4 && <0.7 , uri-bytestring >=0.2.3 && <0.4 , wai ^>=3.2 , wai-middleware-static >=0.8.1 && <0.10.0 , warp >=3.2 && <3.4 ghc-options:- -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields- -Wwarnings-deprecations+ -Wall -Wextra -Wtabs -Wno-unused-do-bind -Wpartial-fields+ -Wunused-packages -Wwarnings-deprecations -Wwarn++ if flag(breakpoint)+ build-depends: breakpoint ^>= 0.1.2+ ghc-options: -fplugin=Debug.Breakpoint -plugin-package breakpoint+ if impl(ghc <9.4)+ ghc-options: -Wno-unticked-promoted-constructors
public/templates/index.mustache view
@@ -3,44 +3,45 @@ <link href="/main.css" rel="stylesheet"/> </head> <body>- <h1>HOAuth2 Demo Server</h1>+ <h1>HOAuth2 Demo</h1> <h2>Authorization Code flow</h2> {{#idps}} <section class="login-with"> {{^isLogin}}- <a href="{{codeFlowUri}}">Sign in with {{name}}</a>+ <a href="/login?idp={{idpName}}">Sign in with {{idpName}}</a> {{/isLogin}} {{#isLogin}}- <h2>Welcome to {{name}}</h2>+ <h2>Welcome to {{idpName}}</h2> {{#user}}- <div class="result">Hello, {{name}}</div>+ <div class="result">Hello, {{idpName}}</div> {{/user}}- <a href="/logout?idp={{name}}">Logout</a>- <a href="/refresh?idp={{name}}">Refresh</a>+ <a href="/logout?idp={{idpName}}">Logout</a>+ <a href="/refresh-token?idp={{idpName}}">Refresh</a> {{/isLogin}} </section> {{/idps}} <h2>Password flow</h2>- <section class="login-with">- <a href="/login/password-grant?i=auth0">Test Password Grant Type flow-auth0</a>- </section>+ {{#idps}}+ {{#hasPasswordGrant}} <section class="login-with">- <a href="/login/password-grant?i=okta">Test Password Grant Type flow-okta</a>+ <a href="/login/password-grant?idp={{idpName}}">Sign-in with {{idpName}}</a> </section>-+ {{/hasPasswordGrant}}+ {{/idps}} <ul> <li>Check console for login success</li> </ul> <h2>Client Credentials flow</h2>- <section class="login-with">- <a href="/login/cc-grant?i=auth0">Test Client Credentials Grant Type flow (auth0)</a>- </section>+ {{#idps}}+ {{#hasClientCredentialsGrant}} <section class="login-with">- <a href="/login/cc-grant?i=okta">Test Client Credentials Grant Type flow (okta)</a>+ <a href="/login/cc-grant?idp={{idpName}}">Sign-in with {{idpName}}</a> </section>+ {{/hasClientCredentialsGrant}}+ {{/idps}} <ul> <li>Check console for login success</li> </ul>@@ -53,10 +54,22 @@ <li>Check console for login success</li> </ul> + <h2>Device Auth flow</h2>+ {{#idps}}+ {{#hasDeviceGrant}}+ <section class="login-with">+ <a href="/login/device-auth-grant?idp={{idpName}}">Sign-in with {{idpName}}</a>+ </section>+ {{/hasDeviceGrant}}+ {{/idps}}+ <ul>+ <li>Check console for login success</li>+ </ul>+ <h2>Notes</h2> <ol>- <li>for StackExchange, the callback domain is localhost, have manually add port 9988.</li>- <li>for Slack, the callback url has to be https and without any port hence need manual intervention. (TODO: add tls to the server)</li>+ <li>For StackExchange, the callback URI cannot have port, hence have manually add port 9988 in browser when Stack Exchange redirects back.</li>+ <li>For Slack, the callback url has to be https and without any port hence also need manual intervention. (TODO: add tls to the server)</li> </ol> </p> </body>
sample.env.json view
@@ -1,7 +1,96 @@ {- "your-idp-app-name": {- "clientId": "",- "clientSecret": "",- "scopes": []+ "sample-okta-authorization-code-app": {+ "client_id": "",+ "client_secret": ""+ },+ "sample-okta-device-authorization-app": {+ "client_id": "",+ "client_secret": "",+ "scopes": [+ "openid",+ "profile",+ "email"+ ]+ },+ "sample-okta-client-credentials-app-jwt": {+ "client_id": "",+ "client_secret": "",+ "scopes": [+ "okta.users.read"+ ]+ },+ "sample-okta-client-credentials-app": {+ "client_id": "",+ "client_secret": "",+ "scopes": [+ "hw-test"+ ]+ },+ "sample-okta-resource-owner-app": {+ "client_id": "",+ "client_secret": "",+ "scopes": [],+ "user": {+ "username": "",+ "password": ""+ }+ },+ "sample-twitter-authorization-code-app": {+ "client_id": "",+ "client_secret": ""+ },+ "sample-azure-device-authorization-app": {+ "client_id": "",+ "client_secret": ""+ },+ "sample-google-authorization-code-app": {+ "client_id": "",+ "client_secret": ""+ },+ "sample-google-device-authorization-app": {+ "client_id": "",+ "client_secret": "",+ "scopes": [+ "https://www.googleapis.com/auth/userinfo.email",+ "https://www.googleapis.com/auth/userinfo.profile"+ ]+ },+ "sample-auth0-authorization-code-app": {+ "client_id": "",+ "client_secret": ""+ },+ "sample-auth0-device-authorization-app": {+ "client_id": "",+ "client_secret": "",+ "scopes": [+ "openid",+ "profile",+ "email",+ "offline_access"+ ]+ },+ "sample-auth0-client-credentials-app": {+ "client_id": "",+ "client_secret": "",+ "scopes": [+ "read:users"+ ]+ },+ "sample-auth0-resource-owner-app": {+ "client_id": "",+ "client_secret": "",+ "scopes": [],+ "user": {+ "username": "",+ "password": ""+ }+ },+ "sample-github-authorization-code-app": {+ "client_id": "",+ "client_secret": ""+ },+ "sample-github-device-authorization-app": {+ "client_id": "",+ "client_secret": "" } }
src/App.hs view
@@ -1,12 +1,5 @@-{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ImportQualifiedPost #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-} module App (app) where @@ -14,30 +7,37 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Except import Data.Aeson+import Data.Bifunctor import Data.Maybe import Data.Text.Lazy (Text) import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.IO qualified as TL+import Env import Idp import Network.HTTP.Conduit import Network.HTTP.Types import Network.OAuth.OAuth2 import Network.OAuth.OAuth2 qualified as OAuth2 import Network.OAuth2.Experiment-import Network.OAuth2.Provider.Auth0 qualified as IAuth0-import Network.OAuth2.Provider.Okta qualified as IOkta+import Network.OAuth2.Provider+import Network.OAuth2.Provider.Auth0 qualified as Auth0+import Network.OAuth2.Provider.Okta qualified as Okta import Network.Wai qualified as WAI import Network.Wai.Handler.Warp (run) import Network.Wai.Middleware.Static import Session import Types+import URI.ByteString qualified as URI+import User import Utils import Views import Web.Scotty+import Web.Scotty qualified as Scotty import Prelude ---------------------------------- App-------------------------------+-------------------------------------------------------------------------------+-- App --+------------------------------------------------------------------------------- myServerPort :: Int myServerPort = 9988@@ -50,69 +50,117 @@ waiApp :: IO WAI.Application waiApp = do- cache <- initCacheStore re <- runExceptT $ do- myAuth0Idp <- IAuth0.mkAuth0Idp "freizl.auth0.com"- myOktaIdp <- IOkta.mkOktaIdp "dev-494096.okta.com"- -- For the sake of simplicity for this demo App,- -- I store user data in MVar in server side.- -- It means user session shared across browsers.- -- which simplify my testing cross browsers.- -- I am sure you don't want to this for your production services.- initIdps cache (myAuth0Idp, myOktaIdp)- pure (myAuth0Idp, myOktaIdp)+ myAuth0Idp <- Auth0.mkAuth0Idp "freizl.auth0.com"+ myOktaIdp <- Okta.mkOktaIdp "dev-494096.okta.com"+ -- myOktaIdp <- Okta.mkOktaIdp "dev-494096.okta.com/oauth2/default"+ let oidcIdps = (myAuth0Idp, myOktaIdp)+ oauthAppSettings <- readEnvFile+ sessionStore <- liftIO (initUserStore allIdpNames)+ let findIdpByName = findIdp oidcIdps+ pure AppEnv {..} case re of- Left e -> Prelude.error $ TL.unpack $ "unable to init cache: " <> e- Right r -> do- putStrLn "global cache has been initialized."- initApp cache r+ Left e -> Prelude.error $ TL.unpack $ "unable to init demo server: \n" <> e+ Right r -> initApp r -initApp :: CacheStore -> (Idp IAuth0.Auth0, Idp IOkta.Okta) -> IO WAI.Application-initApp cache idps = scottyApp $ do- middleware $ staticPolicy (addBase "public/assets")- defaultHandler globalErrorHandler- get "/" $ indexH cache- get "/oauth2/callback" $ callbackH cache- get "/logout" $ logoutH cache- get "/refresh" $ refreshH cache+initApp ::+ AppEnv ->+ IO WAI.Application+initApp appEnv = do+ scottyApp $ do+ middleware $ staticPolicy (addBase "public/assets")+ defaultHandler globalErrorHandler - get "/login/password-grant" $ testPasswordGrantTypeH idps- get "/login/cc-grant" (testClientCredentialGrantTypeH idps)+ get "/" $ indexH appEnv - get "/login/jwt-grant" testJwtBearerGrantTypeH+ get "/oauth2/sso-login" $ ssoLoginH appEnv ---------------------------------------------------+ -- Authorization Code Grant+ get "/login" $ loginH appEnv+ get "/logout" $ logoutH appEnv+ get "/oauth2/callback" $ callbackH appEnv+ get "/refresh-token" $ refreshTokenH appEnv --- * Handlers+ -- Resource Owner Password Grant+ get "/login/password-grant" $ testPasswordGrantTypeH appEnv ---------------------------------------------------+ -- Client Credentials Grant+ get "/login/cc-grant" $ testClientCredentialGrantTypeH appEnv + -- Device Authorization Grant+ get "/login/device-auth-grant" $ testDeviceCodeGrantTypeH appEnv++ -- JWT Grant+ get "/login/jwt-grant" testJwtBearerGrantTypeH++-------------------------------------------------------------------------------+-- Handlers --+-------------------------------------------------------------------------------+ redirectToHomeM :: ActionM () redirectToHomeM = redirect "/" globalErrorHandler :: Text -> ActionM () globalErrorHandler t = status status500 >> html t -refreshH :: CacheStore -> ActionM ()-refreshH c = do- idpData@(DemoAppEnv idp sData) <- readIdpParam c- exceptToActionM $ do- newToken <- doRefreshToken idpData- liftIO $ putStrLn ">>>>>> got new token"- upsertDemoAppEnv c (DemoAppEnv idp (sData {oauth2Token = Just newToken}))- redirectToHomeM+indexH ::+ AppEnv ->+ ActionM ()+indexH AppEnv {..} = do+ liftIO (allAppSessionData sessionStore) >>= overviewTpl -logoutH :: CacheStore -> ActionM ()-logoutH c = do- idpData <- readIdpParam c- liftIO (removeKey c (toLabel idpData))- redirectToHomeM+-- | IdP-init sso login+ssoLoginH :: AppEnv -> ActionM ()+ssoLoginH appEnv = do+ pas <- params+ let issP = paramValue "iss" pas+ case issP of+ [] -> raise "sso-login: no 'iss' from sso-login request"+ (iss : _) -> do+ -- FIXME+ -- Assume it's Okta for now but shall parse iss and figure out the right IdP.+ -- let issUri = URI.parseURI URI.strictURIParserOptions (T.encodeUtf8 $ TL.toStrict iss)+ --+ authRequestUri <- exceptToActionM (createAuthorizationUri appEnv Okta)+ let authRequestUriText = TL.fromStrict (uriToText authRequestUri)+ if iss `TL.isPrefixOf` authRequestUriText+ then Scotty.setHeader "Location" authRequestUriText >> Scotty.status status302+ else raise ("Unsupported issue: " <> iss) -indexH :: CacheStore -> ActionM ()-indexH c = liftIO (allValues c) >>= overviewTpl+loginH ::+ AppEnv ->+ ActionM ()+loginH appEnv = do+ authRequestUri <- runActionWithIdp "loginH" (createAuthorizationUri appEnv)+ Scotty.setHeader "Location" (TL.fromStrict $ uriToText authRequestUri)+ Scotty.status status302 -callbackH :: CacheStore -> ActionM ()-callbackH c = do+createAuthorizationUri :: AppEnv -> IdpName -> ExceptT Text IO URI.URI+createAuthorizationUri AppEnv {..} idpName = do+ -- TODO: I dont understand why can use let here+ -- let (DemoIdp idp) = findIdpByName idpName+ (DemoIdp idp) <- pure (findIdpByName idpName)+ authCodeApp <- createAuthorizationCodeApp idp idpName+ (authorizationUri, codeVerifier) <-+ liftIO $+ if isSupportPkce idpName+ then fmap (second Just) (mkPkceAuthorizeRequest authCodeApp)+ else pure (mkAuthorizationRequest authCodeApp, Nothing)+ insertCodeVerifier sessionStore idpName codeVerifier+ pure authorizationUri++logoutH ::+ AppEnv ->+ ActionM ()+logoutH AppEnv {..} = do+ runActionWithIdp "logoutH" $ \idpName -> do+ liftIO (removeAppSessionData sessionStore idpName)+ redirectToHomeM++callbackH ::+ AppEnv ->+ ActionM ()+callbackH appEnv@AppEnv {..} = do -- https://hackage.haskell.org/package/scotty-0.12/docs/Web-Scotty.html#t:Param -- (Text, Text) pas <- params@@ -120,140 +168,169 @@ when (null stateP) (raise "callbackH: no state from callback request") let codeP = paramValue "code" pas when (null codeP) (raise "callbackH: no code from callback request")+ let idpName = fromText $ TL.takeWhile (/= '.') (head stateP) exceptToActionM $ do- idpData <- lookupKey c (TL.takeWhile (/= '.') (head stateP))- fetchTokenAndUser c (head codeP) idpData+ idpData <- lookupAppSessionData sessionStore idpName+ fetchTokenAndUser appEnv idpData (ExchangeToken $ TL.toStrict $ head codeP) redirectToHomeM -testPasswordGrantTypeH :: (Idp IAuth0.Auth0, Idp IOkta.Okta) -> ActionM ()-testPasswordGrantTypeH (auth0, okta) = do- idpP <- paramValue "i" <$> params- when (null idpP) (raise "testPasswordGrantTypeH: no idp parameter in the password grant type login request")- let i = head idpP- case i of- "auth0" -> testPasswordGrantType (auth0PasswordGrantApp auth0)- "okta" -> testPasswordGrantType (oktaPasswordGrantApp okta)- _ -> raise $ "unable to find password grant type flow for idp " <> i- where- testPasswordGrantType ::- ( HasTokenRequest a- , 'ResourceOwnerPassword ~ a- , HasDemoLoginUser b- , HasUserInfoRequest a- , FromJSON (IdpUserInfo b)- ) =>- IdpApplication a b ->- ActionM ()- testPasswordGrantType idpApp = do- exceptToActionM $ do- mgr <- liftIO $ newManager tlsManagerSettings- token <- withExceptT oauth2ErrorToText $ conduitTokenRequest idpApp mgr- user <- tryFetchUser mgr token idpApp- liftIO $ print user- redirectToHomeM+refreshTokenH ::+ AppEnv ->+ ActionM ()+refreshTokenH AppEnv {..} = do+ runActionWithIdp "testPasswordGrantTypeH" $ \idpName -> do+ (DemoIdp idp) <- pure (findIdpByName idpName)+ authCodeApp <- createAuthorizationCodeApp idp idpName+ idpData <- lookupAppSessionData sessionStore idpName+ newToken <- doRefreshToken authCodeApp idpData+ liftIO $ do+ putStrLn "=== refreshTokenH === got new token"+ print newToken+ upsertAppSessionData sessionStore idpName (idpData {oauth2Token = Just newToken})+ redirectToHomeM -testClientCredentialGrantTypeH :: (Idp IAuth0.Auth0, Idp IOkta.Okta) -> ActionM ()-testClientCredentialGrantTypeH (auth0, okta) = do- idpP <- paramValue "i" <$> params- when (null idpP) (raise "testClientCredentialsGrantTypeH: no idp parameter in the password grant type login request")- let i = head idpP- case i of- "auth0" -> testClientCredentialsGrantType (auth0ClientCredentialsGrantApp auth0)- "okta" -> liftIO (oktaClientCredentialsGrantApp okta) >>= testClientCredentialsGrantType- _ -> raise $ "unable to find password grant type flow for idp " <> i+testPasswordGrantTypeH ::+ AppEnv ->+ ActionM ()+testPasswordGrantTypeH AppEnv {..} = do+ runActionWithIdp "testPasswordGrantTypeH" $ \idpName -> do+ (DemoIdp idp) <- pure (findIdpByName idpName)+ idpApp <- createResourceOwnerPasswordApp idp idpName+ mgr <- liftIO $ newManager tlsManagerSettings+ token <- withExceptT tokenRequestErrorErrorToText $ conduitTokenRequest idpApp mgr NoNeedExchangeToken+ user <- tryFetchUser idpName idpApp mgr token+ liftIO $ do+ putStrLn "=== testPasswordGrantTypeH find token ==="+ print user+ redirectToHomeM -testClientCredentialsGrantType ::- forall a b.- ( 'ClientCredentials ~ b- ) =>- HasTokenRequest b =>- IdpApplication b a ->+testClientCredentialGrantTypeH ::+ AppEnv -> ActionM ()-testClientCredentialsGrantType testApp = do- exceptToActionM $ do+testClientCredentialGrantTypeH AppEnv {..} = do+ runActionWithIdp "testClientCredentialsGrantTypeH" $ \idpName -> do+ (DemoIdp idp) <- pure (findIdpByName idpName)+ idpApp <- createClientCredentialsApp idp idpName mgr <- liftIO $ newManager tlsManagerSettings -- client credentials flow is meant for machine to machine -- hence wont be able to hit /userinfo endpoint- tokenResp <- withExceptT oauth2ErrorToText $ conduitTokenRequest testApp mgr- liftIO $ print tokenResp+ tokenResp <- withExceptT tokenRequestErrorErrorToText $ conduitTokenRequest idpApp mgr NoNeedExchangeToken+ liftIO $ do+ putStrLn "=== testClientCredentialGrantTypeH find token ==="+ print tokenResp redirectToHomeM +testDeviceCodeGrantTypeH ::+ AppEnv ->+ ActionM ()+testDeviceCodeGrantTypeH AppEnv {..} = do+ runActionWithIdp "testDeviceCodeGrantTypeH" $ \idpName -> do+ (DemoIdp idp) <- pure (findIdpByName idpName)+ deviceAuthApp <- createDeviceAuthApp idp idpName+ mgr <- liftIO $ newManager tlsManagerSettings+ deviceAuthResp <- withExceptT bslToText $ conduitDeviceAuthorizationRequest deviceAuthApp mgr+ liftIO $ do+ putStr "Please visit this URL to redeem the code: "+ TL.putStr $ userCode deviceAuthResp <> "\n"+ TL.putStrLn $ TL.fromStrict $ uriToText (verificationUri deviceAuthResp)+ atoken <- withExceptT tokenRequestErrorErrorToText (pollDeviceTokenRequest deviceAuthApp mgr deviceAuthResp)+ liftIO $ do+ putStrLn "=== testDeviceCodeGrantTypeH found token ==="+ print atoken+ luser <- tryFetchUser idpName deviceAuthApp mgr atoken+ liftIO $ print luser+ redirectToHomeM+ -- Only testing google for now testJwtBearerGrantTypeH :: ActionM () testJwtBearerGrantTypeH = do exceptToActionM $ do testApp <- googleServiceAccountApp mgr <- liftIO $ newManager tlsManagerSettings- tokenResp <- withExceptT oauth2ErrorToText $ conduitTokenRequest testApp mgr- user <- tryFetchUser mgr tokenResp testApp+ tokenResp <- withExceptT tokenRequestErrorErrorToText $ conduitTokenRequest testApp mgr NoNeedExchangeToken+ user <- tryFetchUser Google testApp mgr tokenResp liftIO $ print user redirectToHomeM ------------------------------------------------------- * Services----------------------------------------------------+-------------------------------------------------------------------------------+-- Services --+------------------------------------------------------------------------------- -exceptToActionM :: Show a => ExceptT Text IO a -> ActionM a+exceptToActionM :: ExceptT Text IO a -> ActionM a exceptToActionM e = do result <- liftIO $ runExceptT e either raise return result -readIdpParam :: CacheStore -> ActionM DemoAppEnv-readIdpParam c = do- pas <- params- let idpP = paramValue "idp" pas- when (null idpP) redirectToHomeM- exceptToActionM $ lookupKey c (head idpP)+runActionWithIdp ::+ Text ->+ (IdpName -> ExceptT Text IO a) ->+ ActionM a+runActionWithIdp funcName action = do+ midp <- paramValueMaybe "idp" <$> params+ case midp of+ Just idpName -> exceptToActionM (action $ fromText idpName)+ Nothing -> raise $ "[" <> funcName <> "] Expects 'idp' parameter but found nothing" fetchTokenAndUser ::- CacheStore ->- Text ->- DemoAppEnv ->+ AppEnv ->+ IdpAuthorizationCodeAppSessionData ->+ -- | Session Data+ ExchangeToken -> ExceptT Text IO ()-fetchTokenAndUser c exchangeToken idpData@(DemoAppEnv (DemoAuthorizationApp idpAppConfig) DemoAppPerAppSessionData {..}) = do+fetchTokenAndUser AppEnv {..} idpData@(IdpAuthorizationCodeAppSessionData {..}) exchangeToken = do+ (DemoIdp idp) <- pure (findIdpByName idpName)+ authCodeIdpApp <- createAuthorizationCodeApp idp idpName mgr <- liftIO $ newManager tlsManagerSettings- token <-- if isSupportPkce idpAppConfig- then do- when (isNothing authorizePkceCodeVerifier) (throwE "Unable to find code verifier")- withExceptT oauth2ErrorToText $- conduitPkceTokenRequest- idpAppConfig- mgr- (ExchangeToken $ TL.toStrict exchangeToken, fromJust authorizePkceCodeVerifier)- else withExceptT oauth2ErrorToText $ conduitTokenRequest idpAppConfig mgr (ExchangeToken $ TL.toStrict exchangeToken)+ token <- tryFetchAccessToken authCodeIdpApp mgr exchangeToken liftIO $ do- putStrLn "Found access token"+ putStrLn "[Authorization Code Flow] Found access token" print token- luser <- tryFetchUser mgr token idpAppConfig+ luser <- tryFetchUser idpName authCodeIdpApp mgr token liftIO $ do print luser- updateIdp c idpData luser token+ upsertAppSessionData+ sessionStore+ idpName+ (idpData {loginUser = Just luser, oauth2Token = Just token}) where- updateIdp :: MonadIO m => CacheStore -> DemoAppEnv -> DemoLoginUser -> OAuth2Token -> ExceptT Text m ()- updateIdp c1 (DemoAppEnv iApp sData) luser token =- upsertDemoAppEnv- c1- (DemoAppEnv iApp $ sData {loginUser = Just luser, oauth2Token = Just token})+ tryFetchAccessToken ::+ IdpApplication i AuthorizationCodeApplication ->+ Manager ->+ ExchangeToken ->+ ExceptT Text IO OAuth2Token+ tryFetchAccessToken idpApp mgr exchangeTokenText = do+ if isSupportPkce idpName+ then do+ when (isNothing authorizePkceCodeVerifier) (throwE "Unable to find code verifier")+ withExceptT tokenRequestErrorErrorToText $+ conduitPkceTokenRequest+ idpApp+ mgr+ (exchangeTokenText, fromJust authorizePkceCodeVerifier)+ else withExceptT tokenRequestErrorErrorToText $ conduitTokenRequest idpApp mgr exchangeTokenText -oauth2ErrorToText :: TokenRequestError -> Text-oauth2ErrorToText e = TL.pack $ "conduitTokenRequest - cannot fetch access token. error detail: " ++ show e+tokenRequestErrorErrorToText :: TokenResponseError -> Text+tokenRequestErrorErrorToText e = TL.pack $ "conduitTokenRequest - cannot fetch access token. error detail: " ++ show e tryFetchUser ::- forall a b.- (HasDemoLoginUser a, HasUserInfoRequest b, FromJSON (IdpUserInfo a)) =>+ forall i a.+ (HasUserInfoRequest a, HasDemoLoginUser i, FromJSON (IdpUser i)) =>+ IdpName ->+ IdpApplication i a -> Manager -> OAuth2Token ->- IdpApplication b a -> ExceptT Text IO DemoLoginUser-tryFetchUser mgr at idpAppConfig = do- user <- withExceptT bslToText $ conduitUserInfoRequest idpAppConfig mgr (accessToken at)- pure $ toLoginUser @a user+tryFetchUser idpName idpAppConfig mgr at = do+ let fetchMethod = findFetchUserInfoMethod idpName+ user <- withExceptT bslToText $ do+ fetchMethod idpAppConfig mgr (accessToken at)+ pure $ toLoginUser @i user -doRefreshToken :: DemoAppEnv -> ExceptT Text IO OAuth2Token-doRefreshToken (DemoAppEnv (DemoAuthorizationApp idpAppConfig) (DemoAppPerAppSessionData {..})) = do+doRefreshToken ::+ IdpApplication i AuthorizationCodeApplication ->+ IdpAuthorizationCodeAppSessionData ->+ ExceptT Text IO OAuth2Token+doRefreshToken idpAppConfig (IdpAuthorizationCodeAppSessionData {..}) = do at <- maybe (throwE "no token response found for idp") pure oauth2Token rt <- maybe (throwE "no refresh token found for idp") pure (OAuth2.refreshToken at) withExceptT (TL.pack . show) $ do
src/Env.hs view
@@ -1,29 +1,72 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}- module Env where +import Control.Monad.IO.Class+import Control.Monad.Trans.Except import Data.Aeson-import Data.Aeson.KeyMap-import Data.Default+import Data.Aeson.Key qualified as Aeson+import Data.Aeson.KeyMap qualified as Aeson+import Data.Maybe+import Data.Set qualified as Set import Data.Text.Lazy (Text)+import Data.Text.Lazy qualified as TL import GHC.Generics+import Network.OAuth2.Experiment+import System.Directory -data EnvConfigAuthParams = EnvConfigAuthParams- { clientId :: Text- , clientSecret :: Text- , scopes :: Maybe [Text]+newtype OAuthAppSettings = OAuthAppSettings (Aeson.KeyMap OAuthAppSetting)+ deriving (Generic)++instance FromJSON OAuthAppSettings++data OAuthAppSetting = OAuthAppSetting+ { clientId :: ClientId+ , clientSecret :: ClientSecret+ , scopes :: Set.Set Scope+ , user :: Maybe UserConfig }++instance FromJSON OAuthAppSetting where+ parseJSON = withObject "parseJSON OAuthAppSetting" $ \t -> do+ clientId <- ClientId <$> t .: "client_id"+ clientSecret <- ClientSecret <$> t .: "client_secret"+ scopeTexts <- t .:? "scopes"+ user <- t .:? "user"+ let scopes = Set.map Scope (Set.fromList (fromMaybe [] scopeTexts))+ pure OAuthAppSetting {..}++data UserConfig = UserConfig+ { username :: Text+ , password :: Text+ } deriving (Generic) -instance Default EnvConfigAuthParams where- def =- EnvConfigAuthParams- { clientId = ""- , clientSecret = ""- , scopes = Just []- }+instance FromJSON UserConfig -instance FromJSON EnvConfigAuthParams+envFilePath :: String+envFilePath = ".env.json" -type EnvConfig = KeyMap EnvConfigAuthParams+readEnvFile :: MonadIO m => ExceptT Text m OAuthAppSettings+readEnvFile = do+ withExceptT wrapError $+ ExceptT $+ liftIO $ do+ pwd <- liftIO getCurrentDirectory+ eitherDecodeFileStrict (pwd <> "/" <> envFilePath)+ where+ wrapError :: String -> Text+ wrapError = TL.pack . ("Error when try to load .env.json\n" <>)++lookup :: MonadIO m => Text -> ExceptT Text m OAuthAppSetting+lookup idpAppName = do+ envs <- readEnvFile+ lookupWith envs idpAppName++lookupWith :: MonadIO m => OAuthAppSettings -> Text -> ExceptT Text m OAuthAppSetting+lookupWith (OAuthAppSettings val) idpAppName = do+ let key = TL.toLower idpAppName+ resp = Aeson.lookup (Aeson.fromString $ TL.unpack key) val+ except $+ maybe+ (Left $ "[ Env.lookupWith ] Unable to load config for " <> key)+ Right+ resp
src/Idp.hs view
@@ -1,22 +1,17 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE RankNTypes #-} module Idp where import Control.Monad.IO.Class import Control.Monad.Trans.Except+import Data.Aeson (FromJSON) import Data.Aeson qualified as Aeson-import Data.Aeson.Key qualified as Aeson-import Data.Aeson.KeyMap qualified as Aeson import Data.Bifunctor import Data.ByteString qualified as BS-import Data.Default+import Data.ByteString.Contrib+import Data.ByteString.Lazy.Char8 qualified as BSL import Data.Map.Strict qualified as Map import Data.Maybe import Data.Set qualified as Set@@ -25,71 +20,186 @@ import Data.Text.Lazy.Encoding qualified as TL import Env qualified import Jose.Jwt-import Lens.Micro+import Network.HTTP.Conduit import Network.OAuth.OAuth2 import Network.OAuth2.Experiment+import Network.OAuth2.Provider import Network.OAuth2.Provider.Auth0 qualified as IAuth0 import Network.OAuth2.Provider.AzureAD qualified as IAzureAD-import Network.OAuth2.Provider.Dropbox qualified as IDropbox+import Network.OAuth2.Provider.DropBox qualified as IDropBox import Network.OAuth2.Provider.Facebook qualified as IFacebook import Network.OAuth2.Provider.Fitbit qualified as IFitbit-import Network.OAuth2.Provider.Github qualified as IGithub+import Network.OAuth2.Provider.GitHub qualified as IGitHub import Network.OAuth2.Provider.Google qualified as IGoogle-import Network.OAuth2.Provider.Linkedin qualified as ILinkedin+import Network.OAuth2.Provider.LinkedIn qualified as ILinkedIn import Network.OAuth2.Provider.Okta qualified as IOkta import Network.OAuth2.Provider.Slack qualified as ISlack import Network.OAuth2.Provider.StackExchange qualified as IStackExchange import Network.OAuth2.Provider.Twitter qualified as ITwitter-import Network.OAuth2.Provider.Utils import Network.OAuth2.Provider.Weibo qualified as IWeibo import Network.OAuth2.Provider.ZOHO qualified as IZOHO-import Session-import System.Directory import Types-import URI.ByteString+import URI.ByteString (URI) import URI.ByteString.QQ (uri)+import User import Prelude hiding (id) defaultOAuth2RedirectUri :: URI defaultOAuth2RedirectUri = [uri|http://localhost:9988/oauth2/callback|] -createAuthorizationApps :: MonadIO m => (Idp IAuth0.Auth0, Idp IOkta.Okta) -> ExceptT Text m [DemoAuthorizationApp]-createAuthorizationApps (myAuth0Idp, myOktaIdp) = do- configParams <- readEnvFile- let initIdpAppConfig :: IdpApplication 'AuthorizationCode i -> IdpApplication 'AuthorizationCode i- initIdpAppConfig idpAppConfig@AuthorizationCodeIdpApplication {..} =- case Aeson.lookup (Aeson.fromString $ TL.unpack $ TL.toLower $ getIdpAppName idpAppConfig) configParams of- Nothing -> idpAppConfig- Just config ->- idpAppConfig- { idpAppClientId = ClientId $ Env.clientId config- , idpAppClientSecret = ClientSecret $ Env.clientSecret config- , idpAppRedirectUri = defaultOAuth2RedirectUri- , idpAppScope = Set.unions [idpAppScope, Set.map Scope (Set.fromList (fromMaybe [] (Env.scopes config)))]- , idpAppAuthorizeState = AuthorizeState (idpAppName <> ".hoauth2-demo-app-123")- }+createAuthorizationCodeApp ::+ Idp i ->+ IdpName ->+ ExceptT Text IO (IdpApplication i AuthorizationCodeApplication)+createAuthorizationCodeApp idp idpName = do+ let newAppName = "sample-" <> toText idpName <> "-authorization-code-app"+ let sampleApp = findAuthorizationCodeSampleApp idpName+ Env.OAuthAppSetting {..} <- Env.lookup newAppName+ let newApp' =+ sampleApp+ { acClientId = clientId+ , acClientSecret = clientSecret+ , acScope = if Set.null scopes then acScope sampleApp else scopes+ , acRedirectUri = defaultOAuth2RedirectUri+ , acAuthorizeState = AuthorizeState (toText idpName <> ".hoauth2-demo-app-123")+ }+ pure IdpApplication {idp = idp, application = newApp'}++-- | https://auth0.com/docs/api/authentication#resource-owner-password+createResourceOwnerPasswordApp ::+ Idp i ->+ IdpName ->+ ExceptT Text IO (IdpApplication i ResourceOwnerPasswordApplication)+createResourceOwnerPasswordApp i idpName = do+ let newAppName = "sample-" <> toText idpName <> "-resource-owner-app"+ let defaultApp =+ ResourceOwnerPasswordApplication+ { ropClientId = ""+ , ropClientSecret = ""+ , ropName = newAppName+ , ropScope = Set.fromList ["openid", "profile", "email"]+ , ropUserName = ""+ , ropPassword = ""+ , ropTokenRequestExtraParams = Map.empty+ }+ Env.OAuthAppSetting {..} <- Env.lookup newAppName+ newApp' <- case user of+ Nothing -> throwE ("[createResourceOwnerPasswordApp] unable to load user config for " <> toText idpName)+ Just userConfig ->+ pure+ defaultApp+ { ropClientId = clientId+ , ropClientSecret = clientSecret+ , ropUserName = Username (Env.username userConfig)+ , ropPassword = Password (Env.password userConfig)+ }+ pure $+ IdpApplication+ { idp = i+ , application = newApp'+ }++-- | https://auth0.com/docs/api/authentication#client-credentials-flow+createClientCredentialsApp ::+ Idp i ->+ IdpName ->+ ExceptT Text IO (IdpApplication i ClientCredentialsApplication)+createClientCredentialsApp i idpName = do+ let newAppName = "sample-" <> toText idpName <> "-client-credentials-app"+ let defaultApp =+ ClientCredentialsApplication+ { ccClientId = ""+ , ccClientSecret = ""+ , ccTokenRequestAuthenticationMethod = ClientSecretPost+ , ccName = ""+ , ccScope = Set.empty+ , ccTokenRequestExtraParams = Map.empty+ }++ Env.OAuthAppSetting {..} <- Env.lookup newAppName+ newApp <- case idpName of+ Auth0 ->+ pure+ defaultApp+ { ccTokenRequestExtraParams = Map.fromList [("audience ", "https://freizl.auth0.com/api/v2/")]+ }+ -- Okta -> createOktaClientCredentialsGrantAppJwt i appSetting+ _ -> pure defaultApp+ let newApp' =+ newApp+ { ccClientId = clientId+ , ccClientSecret = clientSecret+ , ccScope = scopes+ , ccName = newAppName+ }+ pure $+ IdpApplication+ { idp = i+ , application = newApp'+ }++-- Base on the document, it works well with both custom Athourization Server and Org As.+-- https://developer.okta.com/docs/guides/implement-grant-type/clientcreds/main/#client-credentials-flow+--+-- But with Org AS, has to use jwt athentication method otherwise got error+-- Client Credentials requests to the Org Authorization Server must use the private_key_jwt token_endpoint_auth_method+--+-- FIXME: Get error from Okta about parsing assertion error+createOktaClientCredentialsGrantAppJwt ::+ Idp i ->+ Env.OAuthAppSetting ->+ ExceptT Text IO ClientCredentialsApplication+createOktaClientCredentialsGrantAppJwt i Env.OAuthAppSetting {..} = do+ keyJsonStr <- liftIO $ BS.readFile ".okta-key.json"+ jwk <- except (first TL.pack $ Aeson.eitherDecodeStrict keyJsonStr)+ jwt <- ExceptT $ IOkta.mkOktaClientCredentialAppJwt jwk clientId i pure- [ DemoAuthorizationApp (initIdpAppConfig IAzureAD.defaultAzureADApp)- , DemoAuthorizationApp (initIdpAppConfig (IAuth0.defaultAuth0App myAuth0Idp))- , DemoAuthorizationApp (initIdpAppConfig IFacebook.defaultFacebookApp)- , DemoAuthorizationApp (initIdpAppConfig IFitbit.defaultFitbitApp)- , DemoAuthorizationApp (initIdpAppConfig IGithub.defaultGithubApp)- , DemoAuthorizationApp (initIdpAppConfig IDropbox.defaultDropboxApp)- , DemoAuthorizationApp (initIdpAppConfig IGoogle.defaultGoogleApp)- , DemoAuthorizationApp (initIdpAppConfig ILinkedin.defaultLinkedinApp)- , DemoAuthorizationApp (initIdpAppConfig (IOkta.defaultOktaApp myOktaIdp))- , DemoAuthorizationApp (initIdpAppConfig ITwitter.defaultTwitterApp)- , DemoAuthorizationApp (initIdpAppConfig ISlack.defaultSlackApp)- , DemoAuthorizationApp (initIdpAppConfig IWeibo.defaultWeiboApp)- , DemoAuthorizationApp (initIdpAppConfig IZOHO.defaultZohoApp)- , DemoAuthorizationApp (initIdpAppConfig IStackExchange.defaultStackExchangeApp)- ]+ ClientCredentialsApplication+ { ccClientId = clientId+ , ccClientSecret = ClientSecret (TL.decodeUtf8 $ bsFromStrict $ unJwt jwt)+ , ccTokenRequestAuthenticationMethod = ClientAssertionJwt+ , ccName = ""+ , ccScope = Set.empty+ , ccTokenRequestExtraParams = Map.empty+ } -googleServiceAccountApp ::- ExceptT- Text- IO- (IdpApplication 'JwtBearer IGoogle.Google)+createDeviceAuthApp ::+ Idp i ->+ IdpName ->+ ExceptT Text IO (IdpApplication i DeviceAuthorizationApplication)+createDeviceAuthApp i idpName = do+ let authMethod =+ if Okta == idpName+ then Just ClientSecretBasic+ else Nothing+ extraParams =+ if AzureAD == idpName+ then Map.singleton "tenant" "/common"+ else Map.empty+ let newAppName = "sample-" <> toText idpName <> "-device-authorization-app"+ newApp =+ DeviceAuthorizationApplication+ { daClientId = ""+ , daClientSecret = ""+ , daName = newAppName+ , daScope = Set.empty+ , daAuthorizationRequestExtraParam = extraParams+ , daAuthorizationRequestAuthenticationMethod = authMethod+ }+ Env.OAuthAppSetting {..} <- Env.lookup newAppName+ let newApp' =+ newApp+ { daClientId = clientId+ , daClientSecret = clientSecret+ , daScope = scopes+ }+ pure $+ IdpApplication+ { idp = i+ , application = newApp'+ }++googleServiceAccountApp :: ExceptT Text IO (IdpApplication Google JwtBearerApplication) googleServiceAccountApp = do IGoogle.GoogleServiceAccountKey {..} <- withExceptT TL.pack (ExceptT $ Aeson.eitherDecodeFileStrict ".google-sa.json") pkey <- withExceptT TL.pack (ExceptT $ IGoogle.readPemRsaKey privateKey)@@ -108,113 +218,78 @@ ) IGoogle.defaultGoogleIdp )- pure $ IGoogle.defaultServiceAccountApp jwt--oktaPasswordGrantApp :: Idp IOkta.Okta -> IdpApplication 'ResourceOwnerPassword IOkta.Okta-oktaPasswordGrantApp i =- ResourceOwnerPasswordIDPApplication- { idpAppClientId = ""- , idpAppClientSecret = ""- , idpAppName = "okta-demo-password-grant-app"- , idpAppScope = Set.fromList ["openid", "profile"]- , idpAppUserName = ""- , idpAppPassword = ""- , idpAppTokenRequestExtraParams = Map.empty- , idp = i- }---- Base on the document, it works well with custom Athourization Server--- https://developer.okta.com/docs/guides/implement-grant-type/clientcreds/main/#client-credentials-flow------ With Org AS, got this error--- Client Credentials requests to the Org Authorization Server must use the private_key_jwt token_endpoint_auth_method----oktaClientCredentialsGrantApp :: Idp IOkta.Okta -> IO (IdpApplication 'ClientCredentials IOkta.Okta)-oktaClientCredentialsGrantApp i = do- let clientId = "0oa9mbklxn2Ac0oJ24x7"- keyJsonStr <- BS.readFile ".okta-key.json"- case Aeson.eitherDecodeStrict keyJsonStr of- Right jwk -> do- ejwt <- IOkta.mkOktaClientCredentialAppJwt jwk clientId i- case ejwt of- Right jwt ->- pure- ClientCredentialsIDPApplication- { idpAppClientId = clientId- , idpAppClientSecret = ClientSecret (TL.decodeUtf8 $ bsFromStrict $ unJwt jwt)- , idpAppTokenRequestAuthenticationMethod = ClientAssertionJwt- , idpAppName = "okta-demo-cc-grant-jwt-app"- , -- , idpAppScope = Set.fromList ["hw-test"]- idpAppScope = Set.fromList ["okta.users.read"]- , idpAppTokenRequestExtraParams = Map.empty- , idp = i- }- Left e -> Prelude.error e- Left e -> Prelude.error e---- | https://auth0.com/docs/api/authentication#resource-owner-password-auth0PasswordGrantApp :: Idp IAuth0.Auth0 -> IdpApplication 'ResourceOwnerPassword IAuth0.Auth0-auth0PasswordGrantApp i =- ResourceOwnerPasswordIDPApplication- { idpAppClientId = ""- , idpAppClientSecret = ""- , idpAppName = "auth0-demo-password-grant-app"- , idpAppScope = Set.fromList ["openid", "profile", "email"]- , idpAppUserName = "test"- , idpAppPassword = ""- , idpAppTokenRequestExtraParams = Map.empty- , idp = i- }---- | https://auth0.com/docs/api/authentication#client-credentials-flow-auth0ClientCredentialsGrantApp :: Idp IAuth0.Auth0 -> IdpApplication 'ClientCredentials IAuth0.Auth0-auth0ClientCredentialsGrantApp i =- ClientCredentialsIDPApplication- { idpAppClientId = ""- , idpAppClientSecret = ""- , idpAppTokenRequestAuthenticationMethod = ClientSecretPost- , idpAppName = "auth0-demo-cc-grant-app"- , idpAppScope = Set.fromList ["read:users"]- , idpAppTokenRequestExtraParams = Map.fromList [("audience ", "https://freizl.auth0.com/api/v2/")]- , idp = i- }--isSupportPkce :: forall a i. ( 'AuthorizationCode ~ a) => IdpApplication a i -> Bool-isSupportPkce AuthorizationCodeIdpApplication {..} =- let hostStr = idpAuthorizeEndpoint idp ^. (authorityL . _Just . authorityHostL . hostBSL)- in any- (`BS.isInfixOf` hostStr)- [ "auth0.com"- , "okta.com"- , "google.com"- , "twitter.com"- ]+ pure $+ IdpApplication+ { idp = IGoogle.defaultGoogleIdp+ , application = IGoogle.sampleServiceAccountApp jwt+ } --- TODO: use Paths_ module for better to find the file?-envFilePath :: String-envFilePath = ".env.json"+findIdp ::+ TenantBasedIdps ->+ IdpName ->+ DemoIdp+findIdp (myAuth0Idp, myOktaIdp) = \case+ AzureAD -> DemoIdp IAzureAD.defaultAzureADIdp+ Auth0 -> DemoIdp myAuth0Idp+ Okta -> DemoIdp myOktaIdp+ Facebook -> DemoIdp IFacebook.defaultFacebookIdp+ Fitbit -> DemoIdp IFitbit.defaultFitbitIdp+ GitHub -> DemoIdp IGitHub.defaultGithubIdp+ DropBox -> DemoIdp IDropBox.defaultDropBoxIdp+ Google -> DemoIdp IGoogle.defaultGoogleIdp+ LinkedIn -> DemoIdp ILinkedIn.defaultLinkedInIdp+ Twitter -> DemoIdp ITwitter.defaultTwitterIdp+ Slack -> DemoIdp ISlack.defaultSlackIdp+ Weibo -> DemoIdp IWeibo.defaultWeiboIdp+ ZOHO -> DemoIdp IZOHO.defaultZohoIdp+ StackExchange -> DemoIdp IStackExchange.defaultStackExchangeIdp -readEnvFile :: MonadIO m => ExceptT Text m Env.EnvConfig-readEnvFile = liftIO $ do- envFileE <- doesFileExist envFilePath- if envFileE- then do- putStrLn "Found .env.json"- fileContent <- BS.readFile envFilePath- case Aeson.eitherDecodeStrict fileContent of- Left err -> print err >> return Aeson.empty- Right ec -> return ec- else return Aeson.empty+findAuthorizationCodeSampleApp :: IdpName -> AuthorizationCodeApplication+findAuthorizationCodeSampleApp = \case+ Auth0 -> IAuth0.sampleAuth0AuthorizationCodeApp+ Okta -> IOkta.sampleOktaAuthorizationCodeApp+ AzureAD -> IAzureAD.sampleAzureADAuthorizationCodeApp+ Facebook -> IFacebook.sampleFacebookAuthorizationCodeApp+ Fitbit -> IFitbit.sampleFitbitAuthorizationCodeApp+ GitHub -> IGitHub.sampleGithubAuthorizationCodeApp+ DropBox -> IDropBox.sampleDropBoxAuthorizationCodeApp+ Google -> IGoogle.sampleGoogleAuthorizationCodeApp+ LinkedIn -> ILinkedIn.sampleLinkedInAuthorizationCodeApp+ Twitter -> ITwitter.sampleTwitterAuthorizationCodeApp+ Slack -> ISlack.sampleSlackAuthorizationCodeApp+ Weibo -> IWeibo.sampleWeiboAuthorizationCodeApp+ ZOHO -> IZOHO.sampleZohoAuthorizationCodeApp+ StackExchange -> IStackExchange.sampleStackExchangeAuthorizationCodeApp -initIdps :: MonadIO m => CacheStore -> (Idp IAuth0.Auth0, Idp IOkta.Okta) -> ExceptT Text m ()-initIdps c is = do- idps <- createAuthorizationApps is- mapM mkDemoAppEnv idps >>= mapM_ (upsertDemoAppEnv c)+findFetchUserInfoMethod ::+ (MonadIO m, HasDemoLoginUser i, HasUserInfoRequest a, FromJSON (IdpUser i)) =>+ IdpName ->+ ( IdpApplication i a ->+ Manager ->+ AccessToken ->+ ExceptT BSL.ByteString m (IdpUser i)+ )+findFetchUserInfoMethod = \case+ Auth0 -> IAuth0.fetchUserInfo+ Okta -> IOkta.fetchUserInfo+ AzureAD -> IAzureAD.fetchUserInfo+ Facebook -> IFacebook.fetchUserInfo+ Fitbit -> IFitbit.fetchUserInfo+ GitHub -> IGitHub.fetchUserInfo+ DropBox -> IDropBox.fetchUserInfo+ Google -> IGoogle.fetchUserInfo+ LinkedIn -> ILinkedIn.fetchUserInfo+ Twitter -> ITwitter.fetchUserInfo+ Slack -> ISlack.fetchUserInfo+ Weibo -> IWeibo.fetchUserInfo+ ZOHO -> IZOHO.fetchUserInfo+ StackExchange -> IStackExchange.fetchUserInfo -mkDemoAppEnv :: MonadIO m => DemoAuthorizationApp -> ExceptT Text m DemoAppEnv-mkDemoAppEnv ia@(DemoAuthorizationApp idpAppConfig) = do- re <-- if isSupportPkce idpAppConfig- then fmap (second Just) (mkPkceAuthorizeRequest idpAppConfig)- else pure (mkAuthorizeRequest idpAppConfig, Nothing)- pure $ DemoAppEnv ia (def {authorizeAbsUri = fst re, authorizePkceCodeVerifier = snd re})+isSupportPkce :: IdpName -> Bool+isSupportPkce idpName =+ idpName+ `elem` [ Auth0+ , Okta+ , Google+ , Twitter+ ]
src/Session.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE ImportQualifiedPost #-}-{-# LANGUAGE OverloadedStrings #-}- {- mimic server side session store -} module Session where@@ -8,42 +5,76 @@ import Control.Concurrent.MVar import Control.Monad.IO.Class import Control.Monad.Trans.Except-import Data.HashMap.Strict qualified as Map+import Data.Default+import Data.Map.Strict qualified as Map import Data.Text.Lazy qualified as TL+import Network.OAuth2.Experiment+import Network.OAuth2.Provider import Types -type CacheStore = MVar (Map.HashMap TL.Text DemoAppEnv)--initCacheStore :: IO CacheStore-initCacheStore = newMVar Map.empty+-- For the sake of simplicity for this demo App,+-- I store user data in MVar in server side.+-- It means user session shared across browsers.+-- which simplify my testing cross browsers.+-- I am sure you don't want to this for your production services.+initUserStore ::+ [IdpName] ->+ IO AuthorizationGrantUserStore+initUserStore = do+ fmap AuthorizationGrantUserStore+ . newMVar+ . Map.fromList+ . fmap (\idpName -> (idpName, def {idpName = idpName})) -allValues :: CacheStore -> IO [DemoAppEnv]-allValues store = do- m1 <- tryReadMVar store- return $ maybe [] Map.elems m1+insertCodeVerifier ::+ AuthorizationGrantUserStore ->+ IdpName ->+ Maybe CodeVerifier ->+ ExceptT TL.Text IO ()+insertCodeVerifier store idpName val = do+ sdata <- lookupAppSessionData store idpName+ let newData = sdata {authorizePkceCodeVerifier = val}+ liftIO $ upsertAppSessionData store idpName newData -removeKey :: CacheStore -> TL.Text -> IO ()-removeKey store idpKey = do+upsertAppSessionData ::+ AuthorizationGrantUserStore ->+ IdpName ->+ IdpAuthorizationCodeAppSessionData ->+ IO ()+upsertAppSessionData (AuthorizationGrantUserStore store) idpName val = do m1 <- takeMVar store- let m2 = Map.update updateIdpData idpKey m1+ let m2 =+ if Map.member idpName m1+ then Map.adjust (const val) idpName m1+ else Map.insert idpName val m1 putMVar store m2- where- updateIdpData (DemoAppEnv app sessionD) = Just (DemoAppEnv app sessionD {loginUser = Nothing}) -lookupKey ::- MonadIO m =>- CacheStore ->- TL.Text ->- ExceptT TL.Text m DemoAppEnv-lookupKey store idpKey = ExceptT $ do- m1 <- liftIO $ tryReadMVar store- return $ maybe (Left ("unknown Idp " <> idpKey)) Right (Map.lookup idpKey =<< m1)+allAppSessionData :: AuthorizationGrantUserStore -> IO [IdpAuthorizationCodeAppSessionData]+allAppSessionData (AuthorizationGrantUserStore store) = do+ m1 <- tryReadMVar store+ return $ maybe [] Map.elems m1 -upsertDemoAppEnv :: MonadIO m => CacheStore -> DemoAppEnv -> ExceptT TL.Text m ()-upsertDemoAppEnv store val = liftIO $ do- m1 <- takeMVar store- let m2 =- if Map.member (toLabel val) m1- then Map.adjust (const val) (toLabel val) m1- else Map.insert (toLabel val) val m1- putMVar store m2+removeAppSessionData ::+ AuthorizationGrantUserStore ->+ IdpName ->+ IO ()+removeAppSessionData store idpName = do+ upsertAppSessionData store idpName (def {idpName = idpName})++lookupAppSessionData ::+ AuthorizationGrantUserStore ->+ IdpName ->+ ExceptT TL.Text IO IdpAuthorizationCodeAppSessionData+lookupAppSessionData (AuthorizationGrantUserStore store) idpName = do+ mm <- liftIO $ tryReadMVar store+ m1 <-+ except $+ maybe+ (Left "[lookupAppSessionData] store (mvar) is empty")+ Right+ mm+ except $+ maybe+ (Left $ "[lookupAppSessionData] unable to find cache data for idp " <> toText idpName)+ Right+ (Map.lookup idpName m1)
src/Types.hs view
@@ -1,225 +1,100 @@-{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Types where +import Control.Concurrent.MVar import Data.Aeson import Data.Default+import Data.Map.Strict qualified as Map import Data.Maybe import Data.Text.Lazy (Text) import Data.Text.Lazy qualified as TL-import Network.OAuth.OAuth2 hiding (RefreshToken)+import Env+import Network.OAuth.OAuth2 import Network.OAuth2.Experiment-import Network.OAuth2.Provider.Auth0 qualified as IAuth0-import Network.OAuth2.Provider.AzureAD qualified as IAzureAD-import Network.OAuth2.Provider.Dropbox qualified as IDropbox-import Network.OAuth2.Provider.Facebook qualified as IFacebook-import Network.OAuth2.Provider.Fitbit qualified as IFitbit-import Network.OAuth2.Provider.Github qualified as IGithub-import Network.OAuth2.Provider.Google qualified as IGoogle-import Network.OAuth2.Provider.Linkedin qualified as ILinkedin-import Network.OAuth2.Provider.Okta qualified as IOkta-import Network.OAuth2.Provider.Slack qualified as ISlack-import Network.OAuth2.Provider.StackExchange qualified as IStackExchange-import Network.OAuth2.Provider.Twitter qualified as ITwitter-import Network.OAuth2.Provider.Weibo qualified as IWeibo-import Network.OAuth2.Provider.ZOHO qualified as IZOHO-import Text.Mustache+import Network.OAuth2.Provider+import Text.Mustache ((~>)) import Text.Mustache qualified as M-import Prelude hiding (id)+import User ----------------------------------------------------------------------------------- * Demo Login User-+-- DemoIdp -- ------------------------------------------------------------------------------- -newtype DemoLoginUser = DemoLoginUser- { loginUserName :: TL.Text- -- TODO: maybe email- }- deriving (Eq, Show)--class HasDemoLoginUser a where- toLoginUser :: IdpUserInfo a -> DemoLoginUser--instance HasDemoLoginUser IAuth0.Auth0 where- toLoginUser :: IAuth0.Auth0User -> DemoLoginUser- toLoginUser IAuth0.Auth0User {..} = DemoLoginUser {loginUserName = name}--instance HasDemoLoginUser IGoogle.Google where- toLoginUser :: IGoogle.GoogleUser -> DemoLoginUser- toLoginUser IGoogle.GoogleUser {..} = DemoLoginUser {loginUserName = name}--instance HasDemoLoginUser IZOHO.ZOHO where- toLoginUser resp =- let us = IZOHO.users resp- in case us of- [] -> DemoLoginUser {loginUserName = "ZOHO: no user found"}- (a : _) -> DemoLoginUser {loginUserName = IZOHO.fullName a}--instance HasDemoLoginUser IAzureAD.AzureAD where- toLoginUser :: IAzureAD.AzureADUser -> DemoLoginUser- toLoginUser ouser =- DemoLoginUser- { loginUserName = IAzureAD.email ouser <> " " <> IAzureAD.name ouser- }--instance HasDemoLoginUser IWeibo.Weibo where- toLoginUser :: IWeibo.WeiboUID -> DemoLoginUser- toLoginUser ouser = DemoLoginUser {loginUserName = TL.pack $ show $ IWeibo.uid ouser}--instance HasDemoLoginUser IDropbox.Dropbox where- toLoginUser :: IDropbox.DropboxUser -> DemoLoginUser- toLoginUser ouser = DemoLoginUser {loginUserName = IDropbox.displayName $ IDropbox.name ouser}--instance HasDemoLoginUser IFacebook.Facebook where- toLoginUser :: IFacebook.FacebookUser -> DemoLoginUser- toLoginUser ouser = DemoLoginUser {loginUserName = IFacebook.name ouser}--instance HasDemoLoginUser IFitbit.Fitbit where- toLoginUser :: IFitbit.FitbitUser -> DemoLoginUser- toLoginUser ouser = DemoLoginUser {loginUserName = IFitbit.userName ouser}--instance HasDemoLoginUser IGithub.Github where- toLoginUser :: IGithub.GithubUser -> DemoLoginUser- toLoginUser guser = DemoLoginUser {loginUserName = IGithub.name guser}--instance HasDemoLoginUser ILinkedin.Linkedin where- toLoginUser :: ILinkedin.LinkedinUser -> DemoLoginUser- toLoginUser ILinkedin.LinkedinUser {..} =- DemoLoginUser- { loginUserName = localizedFirstName <> " " <> localizedLastName- }--instance HasDemoLoginUser ITwitter.Twitter where- toLoginUser :: ITwitter.TwitterUserResp -> DemoLoginUser- toLoginUser ITwitter.TwitterUserResp {..} = DemoLoginUser {loginUserName = ITwitter.name twitterUserRespData}--instance HasDemoLoginUser IOkta.Okta where- toLoginUser :: IOkta.OktaUser -> DemoLoginUser- toLoginUser ouser = DemoLoginUser {loginUserName = IOkta.name ouser}--instance HasDemoLoginUser ISlack.Slack where- toLoginUser :: ISlack.SlackUser -> DemoLoginUser- toLoginUser ouser = DemoLoginUser {loginUserName = ISlack.name ouser}--instance HasDemoLoginUser IStackExchange.StackExchange where- toLoginUser :: IStackExchange.StackExchangeResp -> DemoLoginUser- toLoginUser IStackExchange.StackExchangeResp {..} =- case items of- [] -> DemoLoginUser {loginUserName = TL.pack "Cannot find stackexchange user"}- (user : _) -> DemoLoginUser {loginUserName = IStackExchange.displayName user}+data DemoIdp+ = forall i.+ ( HasDemoLoginUser i+ , FromJSON (IdpUser i)+ ) =>+ DemoIdp (Idp i) ----------------------------------------------------------------------------------- * Authorization Apps-+-- AppEnv -- -------------------------------------------------------------------------------+type TenantBasedIdps = (Idp Auth0, Idp Okta) --- | Use for creating list of IDPs--- Heterogenous collections--- https://wiki.haskell.org/Heterogenous_collections-data DemoAuthorizationApp- = forall a b.- ( HasDemoLoginUser b- , FromJSON (IdpUserInfo b)- , 'AuthorizationCode ~ a- , HasPkceAuthorizeRequest a- , HasPkceTokenRequest a- , HasUserInfoRequest a- , HasIdpAppName a- , HasAuthorizeRequest a- , HasTokenRequest a- , HasRefreshTokenRequest a- ) =>- DemoAuthorizationApp (IdpApplication a b)+data AppEnv = AppEnv+ { oauthAppSettings :: OAuthAppSettings+ , oidcIdps :: TenantBasedIdps+ , findIdpByName :: IdpName -> DemoIdp+ , sessionStore :: AuthorizationGrantUserStore+ } ----------------------------------------------------------------------------------- * Env-+-- Session -- -------------------------------------------------------------------------------+newtype AuthorizationGrantUserStore = AuthorizationGrantUserStore (MVar (Map.Map IdpName IdpAuthorizationCodeAppSessionData)) -data DemoAppPerAppSessionData = DemoAppPerAppSessionData- { loginUser :: Maybe DemoLoginUser+data IdpAuthorizationCodeAppSessionData = IdpAuthorizationCodeAppSessionData+ { idpName :: IdpName+ , loginUser :: Maybe DemoLoginUser , oauth2Token :: Maybe OAuth2Token , authorizePkceCodeVerifier :: Maybe CodeVerifier , authorizeAbsUri :: TL.Text } -data DemoAppEnv = DemoAppEnv DemoAuthorizationApp DemoAppPerAppSessionData--instance Default DemoAppPerAppSessionData where+instance Default IdpAuthorizationCodeAppSessionData where def =- DemoAppPerAppSessionData- { loginUser = Nothing+ IdpAuthorizationCodeAppSessionData+ { idpName = Okta+ , loginUser = Nothing , oauth2Token = Nothing , authorizePkceCodeVerifier = Nothing , authorizeAbsUri = "" } -instance Show DemoAppEnv where- show :: DemoAppEnv -> String- show = TL.unpack . toLabel--toLabel :: DemoAppEnv -> TL.Text-toLabel (DemoAppEnv (DemoAuthorizationApp idpAppConfig) _) = getIdpAppName idpAppConfig---- simplify use case to only allow one idp instance for now.-instance Eq DemoAppEnv where- a == b = toLabel a == toLabel b--instance Ord DemoAppEnv where- a `compare` b = toLabel a `compare` toLabel b--newtype TemplateData = TemplateData- { idpTemplateData :: [DemoAppEnv]- }- deriving (Eq)---- * Mustache instances--instance ToMustache DemoAppEnv where- toMustache (DemoAppEnv (DemoAuthorizationApp idpAppConfig) DemoAppPerAppSessionData {..}) =+instance M.ToMustache IdpAuthorizationCodeAppSessionData where+ toMustache (IdpAuthorizationCodeAppSessionData {..}) = do+ let hasDeviceGrant = idpName `elem` [Okta, GitHub, Auth0, AzureAD, Google]+ hasClientCredentialsGrant = idpName `elem` [Okta, Auth0]+ hasPasswordGrant = idpName `elem` [Okta, Auth0] M.object- [ "codeFlowUri" ~> authorizeAbsUri- , "isLogin" ~> isJust loginUser+ [ "isLogin" ~> isJust loginUser , "user" ~> loginUser- , "name" ~> TL.unpack (getIdpAppName idpAppConfig)- ]--instance ToMustache DemoLoginUser where- toMustache t' =- M.object- ["name" ~> loginUserName t']--instance ToMustache TemplateData where- toMustache td' =- M.object- [ "idps" ~> idpTemplateData td'+ , "idpName" ~> idpName+ , "hasDeviceGrant" ~> hasDeviceGrant+ , "hasClientCredentialsGrant" ~> hasClientCredentialsGrant+ , "hasPasswordGrant" ~> hasPasswordGrant ] ----------------------------------------------------------------------------------- * HasIdpAppName-+-- IdpName extension -- ------------------------------------------------------------------------------- -class HasIdpAppName (a :: GrantTypeFlow) where- getIdpAppName :: IdpApplication a i -> Text+allIdpNames :: [IdpName]+allIdpNames = [minBound .. maxBound] -instance HasIdpAppName 'ClientCredentials where- getIdpAppName :: IdpApplication 'ClientCredentials i -> Text- getIdpAppName ClientCredentialsIDPApplication {..} = idpAppName+deriving instance Read IdpName -instance HasIdpAppName 'ResourceOwnerPassword where- getIdpAppName :: IdpApplication 'ResourceOwnerPassword i -> Text- getIdpAppName ResourceOwnerPasswordIDPApplication {..} = idpAppName+fromText :: Text -> IdpName+fromText = read . TL.unpack -instance HasIdpAppName 'AuthorizationCode where- getIdpAppName :: IdpApplication 'AuthorizationCode i -> Text- getIdpAppName AuthorizationCodeIdpApplication {..} = idpAppName+toText :: IdpName -> Text+toText = TL.pack . show++instance M.ToMustache IdpName where+ toMustache idpName = M.toMustache (show idpName)
+ src/User.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module User where++import Data.Text.Lazy qualified as TL+import Network.OAuth2.Provider+import Network.OAuth2.Provider.Auth0 qualified as IAuth0+import Network.OAuth2.Provider.AzureAD qualified as IAzureAD+import Network.OAuth2.Provider.DropBox qualified as IDropBox+import Network.OAuth2.Provider.Facebook qualified as IFacebook+import Network.OAuth2.Provider.Fitbit qualified as IFitbit+import Network.OAuth2.Provider.GitHub qualified as IGitHub+import Network.OAuth2.Provider.Google qualified as IGoogle+import Network.OAuth2.Provider.LinkedIn qualified as ILinkedIn+import Network.OAuth2.Provider.Okta qualified as IOkta+import Network.OAuth2.Provider.Slack qualified as ISlack+import Network.OAuth2.Provider.StackExchange qualified as IStackExchange+import Network.OAuth2.Provider.Twitter qualified as ITwitter+import Network.OAuth2.Provider.Weibo qualified as IWeibo+import Network.OAuth2.Provider.ZOHO qualified as IZOHO+import Text.Mustache ((~>))+import Text.Mustache qualified as M+import Prelude hiding (id)++newtype DemoLoginUser = DemoLoginUser+ { loginUserName :: TL.Text+ }+ deriving (Eq, Show)++instance M.ToMustache DemoLoginUser where+ toMustache t' =+ M.object+ ["name" ~> loginUserName t']++class HasDemoLoginUser a where+ type IdpUser a+ toLoginUser :: IdpUser a -> DemoLoginUser++instance HasDemoLoginUser Auth0 where+ type IdpUser Auth0 = IAuth0.Auth0User+ toLoginUser :: IAuth0.Auth0User -> DemoLoginUser+ toLoginUser IAuth0.Auth0User {..} = DemoLoginUser {loginUserName = name}++instance HasDemoLoginUser Google where+ type IdpUser Google = IGoogle.GoogleUser+ toLoginUser :: IGoogle.GoogleUser -> DemoLoginUser+ toLoginUser IGoogle.GoogleUser {..} = DemoLoginUser {loginUserName = name}++instance HasDemoLoginUser ZOHO where+ type IdpUser ZOHO = IZOHO.ZOHOUserResp+ toLoginUser :: IdpUser ZOHO -> DemoLoginUser+ toLoginUser resp =+ let us = IZOHO.users resp+ in case us of+ [] -> DemoLoginUser {loginUserName = "ZOHO: no user found"}+ (a : _) -> DemoLoginUser {loginUserName = IZOHO.fullName a}++instance HasDemoLoginUser AzureAD where+ type IdpUser AzureAD = IAzureAD.AzureADUser+ toLoginUser :: IAzureAD.AzureADUser -> DemoLoginUser+ toLoginUser ouser =+ DemoLoginUser+ { loginUserName = IAzureAD.email ouser <> " " <> IAzureAD.name ouser+ }++instance HasDemoLoginUser Weibo where+ type IdpUser Weibo = IWeibo.WeiboUID+ toLoginUser :: IWeibo.WeiboUID -> DemoLoginUser+ toLoginUser ouser = DemoLoginUser {loginUserName = TL.pack $ show $ IWeibo.uid ouser}++instance HasDemoLoginUser DropBox where+ type IdpUser DropBox = IDropBox.DropBoxUser+ toLoginUser :: IDropBox.DropBoxUser -> DemoLoginUser+ toLoginUser ouser = DemoLoginUser {loginUserName = IDropBox.displayName $ IDropBox.name ouser}++instance HasDemoLoginUser Facebook where+ type IdpUser Facebook = IFacebook.FacebookUser+ toLoginUser :: IFacebook.FacebookUser -> DemoLoginUser+ toLoginUser ouser = DemoLoginUser {loginUserName = IFacebook.name ouser}++instance HasDemoLoginUser Fitbit where+ type IdpUser Fitbit = IFitbit.FitbitUser+ toLoginUser :: IFitbit.FitbitUser -> DemoLoginUser+ toLoginUser ouser = DemoLoginUser {loginUserName = IFitbit.userName ouser}++instance HasDemoLoginUser GitHub where+ type IdpUser GitHub = IGitHub.GitHubUser+ toLoginUser :: IGitHub.GitHubUser -> DemoLoginUser+ toLoginUser guser = DemoLoginUser {loginUserName = IGitHub.name guser}++instance HasDemoLoginUser LinkedIn where+ type IdpUser LinkedIn = ILinkedIn.LinkedInUser+ toLoginUser :: ILinkedIn.LinkedInUser -> DemoLoginUser+ toLoginUser ILinkedIn.LinkedInUser {..} =+ DemoLoginUser+ { loginUserName = localizedFirstName <> " " <> localizedLastName+ }++instance HasDemoLoginUser Twitter where+ type IdpUser Twitter = ITwitter.TwitterUserResp+ toLoginUser :: ITwitter.TwitterUserResp -> DemoLoginUser+ toLoginUser ITwitter.TwitterUserResp {..} = DemoLoginUser {loginUserName = ITwitter.name twitterUserRespData}++instance HasDemoLoginUser Okta where+ type IdpUser Okta = IOkta.OktaUser+ toLoginUser :: IOkta.OktaUser -> DemoLoginUser+ toLoginUser ouser = DemoLoginUser {loginUserName = IOkta.name ouser}++instance HasDemoLoginUser Slack where+ type IdpUser Slack = ISlack.SlackUser+ toLoginUser :: ISlack.SlackUser -> DemoLoginUser+ toLoginUser ouser = DemoLoginUser {loginUserName = ISlack.name ouser}++instance HasDemoLoginUser StackExchange where+ type IdpUser StackExchange = IStackExchange.StackExchangeResp+ toLoginUser :: IStackExchange.StackExchangeResp -> DemoLoginUser+ toLoginUser IStackExchange.StackExchangeResp {..} =+ case items of+ [] -> DemoLoginUser {loginUserName = TL.pack "Cannot find stackexchange user"}+ (user : _) -> DemoLoginUser {loginUserName = IStackExchange.displayName user}
src/Utils.hs view
@@ -1,10 +1,9 @@ module Utils where -import Data.Aeson qualified as Aeson import Data.ByteString.Lazy.Char8 qualified as BSL import Data.Text.Lazy (Text) import Data.Text.Lazy qualified as TL-import Web.Scotty.Internal.Types+import Web.Scotty (Param) bslToText :: BSL.ByteString -> Text bslToText = TL.pack . BSL.unpack@@ -12,11 +11,10 @@ paramValue :: Text -> [Param] -> [Text] paramValue key = fmap snd . filter (hasParam key) +paramValueMaybe :: Text -> [Param] -> Maybe Text+paramValueMaybe key xs = case filter (hasParam key) xs of+ [a] -> Just (snd a)+ _ -> Nothing+ hasParam :: Text -> Param -> Bool hasParam t = (== t) . fst--parseValue :: Aeson.FromJSON a => Maybe Aeson.Value -> Maybe a-parseValue Nothing = Nothing-parseValue (Just a) = case Aeson.fromJSON a of- Aeson.Error _ -> Nothing- Aeson.Success b -> Just b
src/Views.hs view
@@ -1,27 +1,34 @@-{-# LANGUAGE OverloadedStrings #-}- module Views where import Control.Monad.IO.Class (liftIO)-import Data.List (sort)+import Data.List import Data.Text.Lazy qualified as TL import Paths_hoauth2_demo import Text.Mustache+import Text.Mustache qualified as M import Text.Parsec.Error import Types import Web.Scotty -type CookieUser = String+newtype TemplateData = TemplateData+ { idpSessionData :: [IdpAuthorizationCodeAppSessionData]+ } +instance ToMustache TemplateData where+ toMustache td' =+ M.object+ [ "idps" ~> idpSessionData td'+ ]+ tpl :: FilePath -> IO (Either ParseError Template) tpl f =- -- TODO: can work with cabal v2-run demo-server but not v2-exec+ -- NOTE: can work with cabal v2-run demo-server but not v2-exec getDataFileName ("public/templates/" ++ f ++ ".mustache") >>= localAutomaticCompile tplS :: FilePath ->- [DemoAppEnv] ->+ [IdpAuthorizationCodeAppSessionData] -> IO TL.Text tplS path xs = do template <- tpl path@@ -30,15 +37,15 @@ return $ TL.unlines $ map TL.pack ["can not parse template " ++ path ++ ".mustache", show e]- Right t' -> return $ TL.fromStrict $ substitute t' (TemplateData $ sort xs)+ Right t' -> return $ TL.fromStrict $ substitute t' (TemplateData $ sortOn idpName xs) tplH :: FilePath ->- [DemoAppEnv] ->+ [IdpAuthorizationCodeAppSessionData] -> ActionM () tplH path xs = do s <- liftIO (tplS path xs) html s -overviewTpl :: [DemoAppEnv] -> ActionM ()+overviewTpl :: [IdpAuthorizationCodeAppSessionData] -> ActionM () overviewTpl = tplH "index"