packages feed

hoauth2-demo (empty) → 1.6.0

raw patch · 14 files changed

+1043/−0 lines, 14 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, data-default, directory, hoauth2, hoauth2-providers, http-conduit, http-types, jose-jwt, microlens, mustache, parsec, scotty, text, transformers, unordered-containers, uri-bytestring, wai, wai-middleware-static, warp

Files

+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2022 Haisheng Wu++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.org view
@@ -0,0 +1,4 @@++Sample Application that plays with all those providers and different grant type flow++Integrated IdPs from `hoauth2-providers` module
+ hoauth2-demo.cabal view
@@ -0,0 +1,81 @@+cabal-version:      2.4+name:               hoauth2-demo+version:            1.6.0+synopsis:           hoauth2 demo application+description:+  Demo application to test oauth2 flow with many providers using hoauth2++homepage:           https://github.com/freizl/hoauth2+license:            MIT+license-file:       LICENSE+author:             Haisheng Wu+maintainer:         Haisheng Wu <freizl@gmail.com>+copyright:          Haisheng Wu+category:           Network+build-type:         Simple+stability:          Beta+tested-with:        GHC <=9.2.2+extra-source-files:+  README.org+  sample.env.json++data-files:+  public/assets/main.css+  public/templates/index.mustache++source-repository head+  type:     git+  location: git://github.com/freizl/hoauth2.git++executable hoauth2-demo+  main-is:            Main.hs+  autogen-modules:    Paths_hoauth2_demo+  other-modules:+    App+    Env+    Idp+    Paths_hoauth2_demo+    Session+    Types+    Utils+    Views++  default-extensions:+    DataKinds+    DeriveGeneric+    GeneralizedNewtypeDeriving+    ImportQualifiedPost+    OverloadedStrings+    RecordWildCards+    TypeApplications+    TypeFamilies++  hs-source-dirs:     src+  default-language:   Haskell2010+  build-depends:+    , aeson                  >=2.0    && <2.2+    , base                   >=4.5    && <5+    , bytestring             >=0.9    && <0.12+    , containers             ^>=0.6+    , data-default           ^>=0.7+    , directory              ^>=1.3+    , hoauth2                >=2.7+    , hoauth2-providers      >=0.2+    , 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+    , 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
+ public/assets/main.css view
@@ -0,0 +1,11 @@+body {+    padding: 10px 50px;+}++.login-with {+    margin: 10px 0;+    padding: 10px;+    border: 1px solid grey;+    border-radius: 5px;+    width: 500px;+}
+ public/templates/index.mustache view
@@ -0,0 +1,63 @@+<html>+    <head>+        <link href="/main.css" rel="stylesheet"/>+    </head>+    <body>+        <h1>HOAuth2 Demo Server</h1>++        <h2>Authorization Code flow</h2>+        {{#idps}}+        <section class="login-with">+            {{^isLogin}}+            <a href="{{codeFlowUri}}">Sign in with {{name}}</a>+            {{/isLogin}}+            {{#isLogin}}+            <h2>Welcome to {{name}}</h2>+            {{#user}}+            <div class="result">Hello, {{name}}</div>+            {{/user}}+            <a href="/logout?idp={{name}}">Logout</a>+            <a href="/refresh?idp={{name}}">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>+        <section class="login-with">+            <a href="/login/password-grant?i=okta">Test Password Grant Type flow-okta</a>+        </section>++        <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>+        <section class="login-with">+            <a href="/login/cc-grant?i=okta">Test Client Credentials Grant Type flow (okta)</a>+        </section>+        <ul>+            <li>Check console for login success</li>+        </ul>++        <h2>JWT Bearer flow</h2>+        <section class="login-with">+            <a href="/login/jwt-grant">Test Google service account</a>+        </section>+        <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>+        </ol>+        </p>+    </body>+</html>
+ sample.env.json view
@@ -0,0 +1,7 @@+{+  "your-idp-app-name": {+    "clientId": "",+    "clientSecret": "",+    "scopes": []+  }+}
+ src/App.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module App (app) where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Except+import Data.Aeson+import Data.Maybe+import Data.Text.Lazy (Text)+import Data.Text.Lazy qualified as TL+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.Wai qualified as WAI+import Network.Wai.Handler.Warp (run)+import Network.Wai.Middleware.Static+import Session+import Types+import Utils+import Views+import Web.Scotty+import Prelude++------------------------------+-- App+------------------------------++myServerPort :: Int+myServerPort = 9988++app :: IO ()+app =+  putStrLn ("Starting Server. http://localhost:" ++ show myServerPort)+    >> waiApp+    >>= run myServerPort++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)+  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++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++  get "/login/password-grant" $ testPasswordGrantTypeH idps+  get "/login/cc-grant" (testClientCredentialGrantTypeH idps)++  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++logoutH :: CacheStore -> ActionM ()+logoutH c = do+  idpData <- readIdpParam c+  liftIO (removeKey c (toLabel idpData))+  redirectToHomeM++indexH :: CacheStore -> ActionM ()+indexH c = liftIO (allValues c) >>= overviewTpl++callbackH :: CacheStore -> ActionM ()+callbackH c = do+  -- https://hackage.haskell.org/package/scotty-0.12/docs/Web-Scotty.html#t:Param+  -- (Text, Text)+  pas <- params+  let stateP = paramValue "state" pas+  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")+  exceptToActionM $ do+    idpData <- lookupKey c (TL.takeWhile (/= '.') (head stateP))+    fetchTokenAndUser c (head codeP) idpData+  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++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++testClientCredentialsGrantType ::+  forall a b.+  ( 'ClientCredentials ~ b+  ) =>+  HasTokenRequest b =>+  IdpApplication b a ->+  ActionM ()+testClientCredentialsGrantType testApp = do+  exceptToActionM $ do+    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+  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+    liftIO $ print user+  redirectToHomeM++--------------------------------------------------++-- * Services++--------------------------------------------------++exceptToActionM :: Show a => 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)++fetchTokenAndUser ::+  CacheStore ->+  Text ->+  DemoAppEnv ->+  ExceptT Text IO ()+fetchTokenAndUser c exchangeToken idpData@(DemoAppEnv (DemoAuthorizationApp idpAppConfig) DemoAppPerAppSessionData {..}) = do+  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)+  liftIO $ do+    putStrLn "Found access token"+    print token+  luser <- tryFetchUser mgr token idpAppConfig+  liftIO $ do+    print luser+  updateIdp c idpData luser 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})++oauth2ErrorToText :: TokenRequestError -> Text+oauth2ErrorToText e = TL.pack $ "conduitTokenRequest - cannot fetch access token. error detail: " ++ show e++tryFetchUser ::+  forall a b.+  (HasDemoLoginUser a, HasUserInfoRequest b, FromJSON (IdpUserInfo 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++doRefreshToken :: DemoAppEnv -> ExceptT Text IO OAuth2Token+doRefreshToken (DemoAppEnv (DemoAuthorizationApp idpAppConfig) (DemoAppPerAppSessionData {..})) = 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+    mgr <- liftIO $ newManager tlsManagerSettings+    conduitRefreshTokenRequest idpAppConfig mgr rt
+ src/Env.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Env where++import Data.Aeson+import Data.Aeson.KeyMap+import Data.Default+import Data.Text.Lazy (Text)+import GHC.Generics++data EnvConfigAuthParams = EnvConfigAuthParams+  { clientId :: Text+  , clientSecret :: Text+  , scopes :: Maybe [Text]+  }+  deriving (Generic)++instance Default EnvConfigAuthParams where+  def =+    EnvConfigAuthParams+      { clientId = ""+      , clientSecret = ""+      , scopes = Just []+      }++instance FromJSON EnvConfigAuthParams++type EnvConfig = KeyMap EnvConfigAuthParams
+ src/Idp.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Idp where++import Control.Monad.IO.Class+import Control.Monad.Trans.Except+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.Map.Strict qualified as Map+import Data.Maybe+import Data.Set qualified as Set+import Data.Text.Lazy (Text)+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Encoding qualified as TL+import Env qualified+import Jose.Jwt+import Lens.Micro+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.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.QQ (uri)+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")+              }+  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)+    ]++googleServiceAccountApp ::+  ExceptT+    Text+    IO+    (IdpApplication 'JwtBearer IGoogle.Google)+googleServiceAccountApp = do+  IGoogle.GoogleServiceAccountKey {..} <- withExceptT TL.pack (ExceptT $ Aeson.eitherDecodeFileStrict ".google-sa.json")+  pkey <- withExceptT TL.pack (ExceptT $ IGoogle.readPemRsaKey privateKey)+  jwt <-+    withExceptT+      TL.pack+      ( ExceptT $+          IGoogle.mkJwt+            pkey+            clientEmail+            Nothing+            ( Set.fromList+                [ "https://www.googleapis.com/auth/userinfo.email"+                , "https://www.googleapis.com/auth/userinfo.profile"+                ]+            )+            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"+        ]++-- TODO: use Paths_ module for better to find the file?+envFilePath :: String+envFilePath = ".env.json"++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++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)++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})
+ src/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import App (app)++main :: IO ()+main = app
+ src/Session.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}++{- mimic server side session store -}++module Session where++import Control.Concurrent.MVar+import Control.Monad.IO.Class+import Control.Monad.Trans.Except+import Data.HashMap.Strict qualified as Map+import Data.Text.Lazy qualified as TL+import Types++type CacheStore = MVar (Map.HashMap TL.Text DemoAppEnv)++initCacheStore :: IO CacheStore+initCacheStore = newMVar Map.empty++allValues :: CacheStore -> IO [DemoAppEnv]+allValues store = do+  m1 <- tryReadMVar store+  return $ maybe [] Map.elems m1++removeKey :: CacheStore -> TL.Text -> IO ()+removeKey store idpKey = do+  m1 <- takeMVar store+  let m2 = Map.update updateIdpData idpKey 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)++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
+ src/Types.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE TypeFamilies #-}++module Types where++import Data.Aeson+import Data.Default+import Data.Maybe+import Data.Text.Lazy (Text)+import Data.Text.Lazy qualified as TL+import Network.OAuth.OAuth2 hiding (RefreshToken)+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 Text.Mustache qualified as M+import Prelude hiding (id)++-------------------------------------------------------------------------------++-- * Demo Login User++-------------------------------------------------------------------------------++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}++-------------------------------------------------------------------------------++-- * Authorization Apps++-------------------------------------------------------------------------------++-- | 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)++-------------------------------------------------------------------------------++-- * Env++-------------------------------------------------------------------------------++data DemoAppPerAppSessionData = DemoAppPerAppSessionData+  { loginUser :: Maybe DemoLoginUser+  , oauth2Token :: Maybe OAuth2Token+  , authorizePkceCodeVerifier :: Maybe CodeVerifier+  , authorizeAbsUri :: TL.Text+  }++data DemoAppEnv = DemoAppEnv DemoAuthorizationApp DemoAppPerAppSessionData++instance Default DemoAppPerAppSessionData where+  def =+    DemoAppPerAppSessionData+      { 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 {..}) =+    M.object+      [ "codeFlowUri" ~> authorizeAbsUri+      , "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'+      ]++-------------------------------------------------------------------------------++-- * HasIdpAppName++-------------------------------------------------------------------------------++class HasIdpAppName (a :: GrantTypeFlow) where+  getIdpAppName :: IdpApplication a i -> Text++instance HasIdpAppName 'ClientCredentials where+  getIdpAppName :: IdpApplication 'ClientCredentials i -> Text+  getIdpAppName ClientCredentialsIDPApplication {..} = idpAppName++instance HasIdpAppName 'ResourceOwnerPassword where+  getIdpAppName :: IdpApplication 'ResourceOwnerPassword i -> Text+  getIdpAppName ResourceOwnerPasswordIDPApplication {..} = idpAppName++instance HasIdpAppName 'AuthorizationCode where+  getIdpAppName :: IdpApplication 'AuthorizationCode i -> Text+  getIdpAppName AuthorizationCodeIdpApplication {..} = idpAppName
+ src/Utils.hs view
@@ -0,0 +1,22 @@+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++bslToText :: BSL.ByteString -> Text+bslToText = TL.pack . BSL.unpack++paramValue :: Text -> [Param] -> [Text]+paramValue key = fmap snd . filter (hasParam key)++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
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}++module Views where++import Control.Monad.IO.Class (liftIO)+import Data.List (sort)+import Data.Text.Lazy qualified as TL+import Paths_hoauth2_demo+import Text.Mustache+import Text.Parsec.Error+import Types+import Web.Scotty++type CookieUser = String++tpl :: FilePath -> IO (Either ParseError Template)+tpl f =+  -- TODO: can work with cabal v2-run demo-server but not v2-exec+  getDataFileName ("public/templates/" ++ f ++ ".mustache")+    >>= localAutomaticCompile++tplS ::+  FilePath ->+  [DemoAppEnv] ->+  IO TL.Text+tplS path xs = do+  template <- tpl path+  case template of+    Left e ->+      return $+        TL.unlines $+          map TL.pack ["can not parse template " ++ path ++ ".mustache", show e]+    Right t' -> return $ TL.fromStrict $ substitute t' (TemplateData $ sort xs)++tplH ::+  FilePath ->+  [DemoAppEnv] ->+  ActionM ()+tplH path xs = do+  s <- liftIO (tplS path xs)+  html s++overviewTpl :: [DemoAppEnv] -> ActionM ()+overviewTpl = tplH "index"