diff --git a/README.org b/README.org --- a/README.org +++ b/README.org @@ -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~ diff --git a/hoauth2-demo.cabal b/hoauth2-demo.cabal --- a/hoauth2-demo.cabal +++ b/hoauth2-demo.cabal @@ -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 diff --git a/public/templates/index.mustache b/public/templates/index.mustache --- a/public/templates/index.mustache +++ b/public/templates/index.mustache @@ -3,44 +3,45 @@ -

HOAuth2 Demo Server

+

HOAuth2 Demo

Authorization Code flow

{{#idps}}
{{^isLogin}} - Sign in with {{name}} + Sign in with {{idpName}} {{/isLogin}} {{#isLogin}} -

Welcome to {{name}}

+

Welcome to {{idpName}}

{{#user}} -
Hello, {{name}}
+
Hello, {{idpName}}
{{/user}} - Logout - Refresh + Logout + Refresh {{/isLogin}}
{{/idps}}

Password flow

-
- Test Password Grant Type flow-auth0 -
+ {{#idps}} + {{#hasPasswordGrant}}
- Test Password Grant Type flow-okta + Sign-in with {{idpName}}
- + {{/hasPasswordGrant}} + {{/idps}}

Client Credentials flow

-
- Test Client Credentials Grant Type flow (auth0) -
+ {{#idps}} + {{#hasClientCredentialsGrant}}
- Test Client Credentials Grant Type flow (okta) + Sign-in with {{idpName}}
+ {{/hasClientCredentialsGrant}} + {{/idps}} @@ -53,10 +54,22 @@
  • Check console for login success
    • +

    Device Auth flow

    + {{#idps}} + {{#hasDeviceGrant}} +
    + Sign-in with {{idpName}} +
    + {{/hasDeviceGrant}} + {{/idps}} + +

    Notes

      -
    1. for StackExchange, the callback domain is localhost, have manually add port 9988.
      2. -
    2. for Slack, the callback url has to be https and without any port hence need manual intervention. (TODO: add tls to the server)
      3. +
    3. For StackExchange, the callback URI cannot have port, hence have manually add port 9988 in browser when Stack Exchange redirects back.
      4. +
    4. For Slack, the callback url has to be https and without any port hence also need manual intervention. (TODO: add tls to the server)

    diff --git a/sample.env.json b/sample.env.json --- a/sample.env.json +++ b/sample.env.json @@ -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": "" } } diff --git a/src/App.hs b/src/App.hs --- a/src/App.hs +++ b/src/App.hs @@ -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 diff --git a/src/Env.hs b/src/Env.hs --- a/src/Env.hs +++ b/src/Env.hs @@ -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 diff --git a/src/Idp.hs b/src/Idp.hs --- a/src/Idp.hs +++ b/src/Idp.hs @@ -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 + ] diff --git a/src/Session.hs b/src/Session.hs --- a/src/Session.hs +++ b/src/Session.hs @@ -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) diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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) diff --git a/src/User.hs b/src/User.hs new file mode 100644 --- /dev/null +++ b/src/User.hs @@ -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} diff --git a/src/Utils.hs b/src/Utils.hs --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 diff --git a/src/Views.hs b/src/Views.hs --- a/src/Views.hs +++ b/src/Views.hs @@ -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"