packages feed

hoauth2-providers-tutorial (empty) → 0.1

raw patch · 4 files changed

+313/−0 lines, 4 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, hoauth2, hoauth2-providers, hoauth2-providers-tutorial, http-conduit, http-types, scotty, text, transformers, uri-bytestring, wai, 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.
+ app/Main.hs view
@@ -0,0 +1,7 @@+-- |++module Main where+import HOAuth2ProvidersTutorial (app)++main :: IO ()+main = app
+ hoauth2-providers-tutorial.cabal view
@@ -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
+ src/HOAuth2ProvidersTutorial.hs view
@@ -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 <https://www.rfc-editor.org/rfc/rfc6749#section-10.12>+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 {..} ->+          [ "<h2>Hello, ",+            name,+            "</h2>",+            "<p>",+            TL.pack (show email),+            "</p>",+            "<a href='/logout'>Logout</a>"+          ]+        Nothing ->+          [ "<ul>",+            "<li>",+            "<a href='/login/auth0'>Login with Auth0</a>",+            "</li>",+            "<li>",+            "<a href='/login/google'>Login with Google</a>",+            "</li>",+            "</ul>"+          ]++  Scotty.html . mconcat $ "<h1>hoauth2 providers Tutorial</h1>" : 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