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/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,7 @@ +-- | + +module Main where +import HOAuth2ProvidersTutorial (app) + +main :: IO () +main = app diff --git a/hoauth2-providers-tutorial.cabal b/hoauth2-providers-tutorial.cabal new file mode 100644 --- /dev/null +++ b/hoauth2-providers-tutorial.cabal @@ -0,0 +1,55 @@ +cabal-version: 2.4 +name: hoauth2-providers-tutorial +version: 0.1 +synopsis: tutorial for hoauth2-providers module +description: + A tutorial that demostrates how to use hoauth2-providers package + for OAuth2 Authorization Code flow. + +license: MIT +license-file: LICENSE +author: Haisheng Wu (M) +maintainer: freizl@gmail.com +category: Network + +library + exposed-modules: HOAuth2ProvidersTutorial + build-depends: + , aeson >=2.0 && <2.2 + , base >=4.14 && <5 + , bytestring >=0.9 && <0.12 + , containers + , hoauth2 ^>=2.6 + , hoauth2-providers ^>=0.1 + , http-conduit >=2.1 && <2.4 + , http-types >=0.11 && <0.13 + , scotty >=0.10.0 && <0.13 + , text >=0.11 && <1.3 + , transformers ^>=0.5 + , uri-bytestring >=0.2.3 && <0.4 + , wai ^>=3.2 + , warp >=3.2 && <3.4 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: + -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields + -Wwarnings-deprecations + +executable hoauth2-providers-tutorial + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: + , base >=4.14 && <5 + , hoauth2-providers-tutorial + + hs-source-dirs: app + default-language: Haskell2010 + ghc-options: + -Wall -Wtabs -Wno-unused-do-bind -Wunused-packages -Wpartial-fields + -Wwarnings-deprecations diff --git a/src/HOAuth2ProvidersTutorial.hs b/src/HOAuth2ProvidersTutorial.hs new file mode 100644 --- /dev/null +++ b/src/HOAuth2ProvidersTutorial.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module HOAuth2ProvidersTutorial where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Except +import Data.ByteString.Lazy.Char8 qualified as BSL +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Set qualified as Set +import Data.Text.Encoding qualified as T +import Data.Text.Lazy qualified as TL +import Network.HTTP.Conduit (newManager, tlsManagerSettings) +import Network.HTTP.Types (status302) +import Network.OAuth.OAuth2.Internal + ( ExchangeToken (ExchangeToken), + OAuth2Error, + OAuth2Token (accessToken), + ) +import Network.OAuth.OAuth2.TokenRequest qualified as TR +import Network.OAuth2.Experiment +import Network.OAuth2.Provider.Auth0 + ( Auth0, + Auth0User (Auth0User, email, name, sub), + defaultAuth0App, + defaultAuth0Idp, + ) +import Network.OAuth2.Provider.Google + ( Google, + GoogleUser (GoogleUser, email, id, name), + defaultGoogleApp, + defaultGoogleIdp, + ) +import URI.ByteString (URI, serializeURIRef') +import URI.ByteString.QQ (uri) +import Web.Scotty (ActionM, scotty) +import Web.Scotty qualified as Scotty +import Prelude hiding (id) + +------------------------------ + +-- * Configuration + +------------------------------ + +testAuth0App :: IdpApplication 'AuthorizationCode Auth0 +testAuth0App = + ( defaultAuth0App testAuth0Idp ) + { idpAppClientId = "", + idpAppClientSecret = "", + idpAppAuthorizeState = AuthorizeState ("auth0." <> randomStateValue), + idpAppScope = Set.fromList ["openid", "email", "profile"], + idpAppRedirectUri = [uri|http://localhost:9988/oauth2/callback|], + idpAppName = "foo-auth0-app" + } + +testAuth0Idp :: Idp Auth0 +testAuth0Idp = + defaultAuth0Idp + { idpUserInfoEndpoint = [uri|https://freizl.auth0.com/userinfo|], + idpAuthorizeEndpoint = [uri|https://freizl.auth0.com/authorize|], + idpTokenEndpoint = [uri|https://freizl.auth0.com/oauth/token|] + } + +testGoogleIdp :: Idp Google +testGoogleIdp = defaultGoogleIdp + +testGoogleApp :: IdpApplication 'AuthorizationCode Google +testGoogleApp = + defaultGoogleApp + { idpAppClientId = "", + idpAppClientSecret = "", + idpAppAuthorizeState = AuthorizeState ("google." <> randomStateValue), + idpAppRedirectUri = [uri|http://localhost:9988/oauth2/callback|], + idpAppName = "foo-google-app", + idp = testGoogleIdp + } + +-- | You'll need to find out an better way to create @state@ +-- which is recommended in +randomStateValue :: TL.Text +randomStateValue = "random-state-to-prevent-csrf" + +------------------------------ + +-- * Web server + +------------------------------ +data DemoUser = DemoUser + { name :: TL.Text, + email :: Maybe TL.Text + } + deriving (Eq, Show) + +-- | The 'scotty' application +app :: IO () +app = do + -- Poor man's solution for creating user session. + refUser <- newIORef Nothing + scotty 9988 $ do + Scotty.get "/" $ indexH refUser + Scotty.get "/login/auth0" loginAuth0H + Scotty.get "/login/google" loginGoogleH + Scotty.get "/logout" (logoutH refUser) + Scotty.get "/oauth2/callback" $ callbackH refUser + +-- | @/@ endpoint handler +indexH :: IORef (Maybe DemoUser) -> ActionM () +indexH refUser = do + muser <- liftIO (readIORef refUser) + + let info = case muser of + Just DemoUser {..} -> + [ "

Hello, ", + name, + "

", + "

", + TL.pack (show email), + "

", + "Logout" + ] + Nothing -> + [ "" + ] + + Scotty.html . mconcat $ "

hoauth2 providers Tutorial

" : info + +-- | @/login/auth0@ endpoint handler +loginAuth0H :: ActionM () +loginAuth0H = do + Scotty.setHeader "Location" (mkAuthorizeRequest testAuth0App) + Scotty.status status302 + +-- | @/login/google@ endpoint handler +loginGoogleH :: ActionM () +loginGoogleH = do + Scotty.setHeader "Location" (mkAuthorizeRequest testGoogleApp) + Scotty.status status302 + +-- | @/logout@ endpoint handler +logoutH :: IORef (Maybe DemoUser) -> ActionM () +logoutH refUser = do + liftIO (writeIORef refUser Nothing) + Scotty.redirect "/" + +-- | @/oauth2/callback@ endpoint handler +callbackH :: IORef (Maybe DemoUser) -> ActionM () +callbackH refUser = do + pas <- Scotty.params + + excepttToActionM $ do + state <- ExceptT $ pure $ paramValue "state" pas + codeP <- ExceptT $ pure $ paramValue "code" pas + + let code = ExchangeToken $ TL.toStrict codeP + let idpName = TL.takeWhile ('.' /=) state + + user <- case idpName of + "google" -> handleGoogleCallback code + "auth0" -> handleAuth0Callback code + _ -> throwE $ "unable to find idp app of: " <> idpName + + liftIO $ writeIORef refUser (Just user) + + Scotty.redirect "/" + +handleAuth0Callback :: ExchangeToken -> ExceptT TL.Text IO DemoUser +handleAuth0Callback code = do + let idpApp = testAuth0App + mgr <- liftIO $ newManager tlsManagerSettings + tokenResp <- withExceptT oauth2ErrorToText (conduitTokenRequest idpApp mgr code) + Auth0User {..} <- withExceptT bslToText $ conduitUserInfoRequest idpApp mgr (accessToken tokenResp) + pure (DemoUser name (Just email)) + +handleGoogleCallback :: ExchangeToken -> ExceptT TL.Text IO DemoUser +handleGoogleCallback code = do + let idpApp = testGoogleApp + mgr <- liftIO $ newManager tlsManagerSettings + tokenResp <- withExceptT oauth2ErrorToText (conduitTokenRequest idpApp mgr code) + GoogleUser {..} <- withExceptT bslToText $ conduitUserInfoRequest idpApp mgr (accessToken tokenResp) + pure (DemoUser name (Just email)) + +------------------------------ + +-- * Utilities + +------------------------------ + +uriToText :: URI -> TL.Text +uriToText = TL.fromStrict . T.decodeUtf8 . serializeURIRef' + +bslToText :: BSL.ByteString -> TL.Text +bslToText = TL.pack . BSL.unpack + +paramValue :: + -- | Parameter key + TL.Text -> + -- | All parameters + [Scotty.Param] -> + Either TL.Text TL.Text +paramValue key params = + if null val + then Left ("No value found for param: " <> key) + else Right (head val) + where + val = snd <$> filter (hasParam key) params + hasParam :: TL.Text -> Scotty.Param -> Bool + hasParam t = (== t) . fst + +-- | Lift ExceptT to ActionM which is basically the handler Monad in Scotty. +excepttToActionM :: Show a => ExceptT TL.Text IO a -> ActionM a +excepttToActionM e = do + result <- liftIO $ runExceptT e + either Scotty.raise pure result + +oauth2ErrorToText :: OAuth2Error TR.Errors -> TL.Text +oauth2ErrorToText e = TL.pack $ "Unable fetch access token. error detail: " ++ show e