diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.org b/README.org new file mode 100644 --- /dev/null +++ b/README.org @@ -0,0 +1,4 @@ + +Sample Application that plays with all those providers and different grant type flow + +Integrated IdPs from `hoauth2-providers` module diff --git a/hoauth2-demo.cabal b/hoauth2-demo.cabal new file mode 100644 --- /dev/null +++ b/hoauth2-demo.cabal @@ -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 +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 diff --git a/public/assets/main.css b/public/assets/main.css new file mode 100644 --- /dev/null +++ b/public/assets/main.css @@ -0,0 +1,11 @@ +body { + padding: 10px 50px; +} + +.login-with { + margin: 10px 0; + padding: 10px; + border: 1px solid grey; + border-radius: 5px; + width: 500px; +} diff --git a/public/templates/index.mustache b/public/templates/index.mustache new file mode 100644 --- /dev/null +++ b/public/templates/index.mustache @@ -0,0 +1,63 @@ + + + + + +

HOAuth2 Demo Server

+ +

Authorization Code flow

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

Welcome to {{name}}

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

Password flow

+
+ Test Password Grant Type flow-auth0 +
+
+ Test Password Grant Type flow-okta +
+ + + +

Client Credentials flow

+
+ Test Client Credentials Grant Type flow (auth0) +
+
+ Test Client Credentials Grant Type flow (okta) +
+ + +

JWT Bearer flow

+
+ Test Google service account +
+ + +

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. +
+

+ + diff --git a/sample.env.json b/sample.env.json new file mode 100644 --- /dev/null +++ b/sample.env.json @@ -0,0 +1,7 @@ +{ + "your-idp-app-name": { + "clientId": "", + "clientSecret": "", + "scopes": [] + } +} diff --git a/src/App.hs b/src/App.hs new file mode 100644 --- /dev/null +++ b/src/App.hs @@ -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 diff --git a/src/Env.hs b/src/Env.hs new file mode 100644 --- /dev/null +++ b/src/Env.hs @@ -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 diff --git a/src/Idp.hs b/src/Idp.hs new file mode 100644 --- /dev/null +++ b/src/Idp.hs @@ -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}) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import App (app) + +main :: IO () +main = app diff --git a/src/Session.hs b/src/Session.hs new file mode 100644 --- /dev/null +++ b/src/Session.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -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 diff --git a/src/Views.hs b/src/Views.hs new file mode 100644 --- /dev/null +++ b/src/Views.hs @@ -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"