{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# 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.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text.Lazy (Text)
import Data.Text.Lazy qualified as TL
import Network.HTTP.Conduit (newManager, tlsManagerSettings)
import Network.HTTP.Types (status302)
import Network.OAuth.OAuth2 (
  ExchangeToken (ExchangeToken),
  OAuth2Token (accessToken),
  TokenResponseError,
 )
import Network.OAuth2.Experiment
import Network.OAuth2.Provider
import Network.OAuth2.Provider.Auth0 (Auth0User (..), mkAuth0Idp)
import Network.OAuth2.Provider.Auth0 qualified as Auth0
import Network.OAuth2.Provider.Google (GoogleUser (..))
import Network.OAuth2.Provider.Google qualified as Google
import URI.ByteString.QQ (uri)
import Web.Scotty (ActionM, scotty)
import Web.Scotty qualified as Scotty
import Prelude hiding (id)

------------------------------

-- * Configuration

------------------------------

mkTestAuth0App :: ExceptT Text IO (IdpApplication Auth0 AuthorizationCodeApplication)
mkTestAuth0App :: ExceptT
  Text IO (IdpApplication 'Auth0 AuthorizationCodeApplication)
mkTestAuth0App = do
  Idp 'Auth0
idp <- ExceptT Text IO (Idp 'Auth0)
mkTestAuth0Idp
  let application :: AuthorizationCodeApplication
application =
        AuthorizationCodeApplication
          { acClientId :: ClientId
acClientId = ClientId
""
          , acClientSecret :: ClientSecret
acClientSecret = ClientSecret
""
          , acAuthorizeState :: AuthorizeState
acAuthorizeState = Text -> AuthorizeState
AuthorizeState (Text
"auth0." forall a. Semigroup a => a -> a -> a
<> Text
randomStateValue)
          , acScope :: Set Scope
acScope = forall a. Ord a => [a] -> Set a
Set.fromList [Scope
"openid", Scope
"email", Scope
"profile"]
          , acRedirectUri :: URI
acRedirectUri = [uri|http://localhost:9988/oauth2/callback|]
          , acName :: Text
acName = Text
"foo-auth0-app"
          , acAuthorizeRequestExtraParams :: Map Text Text
acAuthorizeRequestExtraParams = forall k a. Map k a
Map.empty
          , acTokenRequestAuthenticationMethod :: ClientAuthenticationMethod
acTokenRequestAuthenticationMethod = ClientAuthenticationMethod
ClientSecretBasic
          }
  forall (f :: * -> *) a. Applicative f => a -> f a
pure IdpApplication {AuthorizationCodeApplication
Idp 'Auth0
idp :: Idp 'Auth0
application :: AuthorizationCodeApplication
application :: AuthorizationCodeApplication
idp :: Idp 'Auth0
..}

mkTestAuth0Idp :: ExceptT Text IO (Idp Auth0)
mkTestAuth0Idp :: ExceptT Text IO (Idp 'Auth0)
mkTestAuth0Idp = forall (m :: * -> *).
MonadIO m =>
Text -> ExceptT Text m (Idp 'Auth0)
mkAuth0Idp Text
"freizl.auth0.com"

mkTestGoogleApp :: IdpApplication Google AuthorizationCodeApplication
mkTestGoogleApp :: IdpApplication 'Google AuthorizationCodeApplication
mkTestGoogleApp =
  let application :: AuthorizationCodeApplication
application =
        AuthorizationCodeApplication
          { acClientId :: ClientId
acClientId = ClientId
""
          , acClientSecret :: ClientSecret
acClientSecret = ClientSecret
""
          , acAuthorizeState :: AuthorizeState
acAuthorizeState = Text -> AuthorizeState
AuthorizeState (Text
"google." forall a. Semigroup a => a -> a -> a
<> Text
randomStateValue)
          , acRedirectUri :: URI
acRedirectUri = [uri|http://localhost:9988/oauth2/callback|]
          , acScope :: Set Scope
acScope =
              forall a. Ord a => [a] -> Set a
Set.fromList
                [ Scope
"https://www.googleapis.com/auth/userinfo.email"
                , Scope
"https://www.googleapis.com/auth/userinfo.profile"
                ]
          , acName :: Text
acName = Text
"foo-google-app"
          , acAuthorizeRequestExtraParams :: Map Text Text
acAuthorizeRequestExtraParams = forall k a. Map k a
Map.empty
          , acTokenRequestAuthenticationMethod :: ClientAuthenticationMethod
acTokenRequestAuthenticationMethod = ClientAuthenticationMethod
ClientSecretBasic
          }
      idp :: Idp 'Google
idp = Idp 'Google
Google.defaultGoogleIdp
   in IdpApplication {AuthorizationCodeApplication
Idp 'Google
idp :: Idp 'Google
application :: AuthorizationCodeApplication
idp :: Idp 'Google
application :: AuthorizationCodeApplication
..}

-- | 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 :: Text
randomStateValue = Text
"random-state-to-prevent-csrf"

------------------------------

-- * Web server

------------------------------
data DemoUser = DemoUser
  { DemoUser -> Text
name :: TL.Text
  , DemoUser -> Maybe Text
email :: Maybe TL.Text
  }
  deriving (DemoUser -> DemoUser -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DemoUser -> DemoUser -> Bool
$c/= :: DemoUser -> DemoUser -> Bool
== :: DemoUser -> DemoUser -> Bool
$c== :: DemoUser -> DemoUser -> Bool
Eq, Int -> DemoUser -> ShowS
[DemoUser] -> ShowS
DemoUser -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [DemoUser] -> ShowS
$cshowList :: [DemoUser] -> ShowS
show :: DemoUser -> [Char]
$cshow :: DemoUser -> [Char]
showsPrec :: Int -> DemoUser -> ShowS
$cshowsPrec :: Int -> DemoUser -> ShowS
Show)

-- | The 'scotty' application
app :: IO ()
app :: IO ()
app = do
  Either Text (IdpApplication 'Auth0 AuthorizationCodeApplication)
eAuth0App <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT
  Text IO (IdpApplication 'Auth0 AuthorizationCodeApplication)
mkTestAuth0App
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => [Char] -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
TL.unpack) IdpApplication 'Auth0 AuthorizationCodeApplication -> IO ()
runApp Either Text (IdpApplication 'Auth0 AuthorizationCodeApplication)
eAuth0App
  where
    runApp :: IdpApplication Auth0 AuthorizationCodeApplication -> IO ()
    runApp :: IdpApplication 'Auth0 AuthorizationCodeApplication -> IO ()
runApp IdpApplication 'Auth0 AuthorizationCodeApplication
auth0App = do
      -- Poor man's solution for creating user session.
      IORef (Maybe DemoUser)
refUser <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
      let googleApp :: IdpApplication 'Google AuthorizationCodeApplication
googleApp = IdpApplication 'Google AuthorizationCodeApplication
mkTestGoogleApp
      Int -> ScottyM () -> IO ()
scotty Int
9988 forall a b. (a -> b) -> a -> b
$ do
        RoutePattern -> ActionM () -> ScottyM ()
Scotty.get RoutePattern
"/" forall a b. (a -> b) -> a -> b
$ IORef (Maybe DemoUser) -> ActionM ()
indexH IORef (Maybe DemoUser)
refUser
        RoutePattern -> ActionM () -> ScottyM ()
Scotty.get RoutePattern
"/login/auth0" (IdpApplication 'Auth0 AuthorizationCodeApplication -> ActionM ()
loginAuth0H IdpApplication 'Auth0 AuthorizationCodeApplication
auth0App)
        RoutePattern -> ActionM () -> ScottyM ()
Scotty.get RoutePattern
"/login/google" (IdpApplication 'Google AuthorizationCodeApplication -> ActionM ()
loginGoogleH IdpApplication 'Google AuthorizationCodeApplication
googleApp)
        RoutePattern -> ActionM () -> ScottyM ()
Scotty.get RoutePattern
"/logout" (IORef (Maybe DemoUser) -> ActionM ()
logoutH IORef (Maybe DemoUser)
refUser)
        RoutePattern -> ActionM () -> ScottyM ()
Scotty.get RoutePattern
"/oauth2/callback" forall a b. (a -> b) -> a -> b
$ IdpApplication 'Auth0 AuthorizationCodeApplication
-> IdpApplication 'Google AuthorizationCodeApplication
-> IORef (Maybe DemoUser)
-> ActionM ()
callbackH IdpApplication 'Auth0 AuthorizationCodeApplication
auth0App IdpApplication 'Google AuthorizationCodeApplication
googleApp IORef (Maybe DemoUser)
refUser

-- | @/@ endpoint handler
indexH :: IORef (Maybe DemoUser) -> ActionM ()
indexH :: IORef (Maybe DemoUser) -> ActionM ()
indexH IORef (Maybe DemoUser)
refUser = do
  Maybe DemoUser
muser <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef (Maybe DemoUser)
refUser)

  let info :: [Text]
info = case Maybe DemoUser
muser of
        Just DemoUser {Maybe Text
Text
email :: Maybe Text
name :: Text
email :: DemoUser -> Maybe Text
name :: DemoUser -> Text
..} ->
          [ Text
"<h2>Hello, "
          , Text
name
          , Text
"</h2>"
          , Text
"<p>"
          , [Char] -> Text
TL.pack (forall a. Show a => a -> [Char]
show Maybe Text
email)
          , Text
"</p>"
          , Text
"<a href='/logout'>Logout</a>"
          ]
        Maybe DemoUser
Nothing ->
          [ Text
"<ul>"
          , Text
"<li>"
          , Text
"<a href='/login/auth0'>Login with Auth0</a>"
          , Text
"</li>"
          , Text
"<li>"
          , Text
"<a href='/login/google'>Login with Google</a>"
          , Text
"</li>"
          , Text
"</ul>"
          ]

  Text -> ActionM ()
Scotty.html forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ Text
"<h1>hoauth2 providers Tutorial</h1>" forall a. a -> [a] -> [a]
: [Text]
info

-- | @/login/auth0@ endpoint handler
loginAuth0H :: IdpApplication Auth0 AuthorizationCodeApplication -> ActionM ()
loginAuth0H :: IdpApplication 'Auth0 AuthorizationCodeApplication -> ActionM ()
loginAuth0H IdpApplication 'Auth0 AuthorizationCodeApplication
auth0App = do
  Text -> Text -> ActionM ()
Scotty.setHeader Text
"Location" (Text -> Text
TL.fromStrict forall a b. (a -> b) -> a -> b
$ URI -> Text
uriToText forall a b. (a -> b) -> a -> b
$ forall {k} a (i :: k).
HasAuthorizeRequest a =>
IdpApplication i a -> URI
mkAuthorizationRequest IdpApplication 'Auth0 AuthorizationCodeApplication
auth0App)
  Status -> ActionM ()
Scotty.status Status
status302

-- | @/login/google@ endpoint handler
loginGoogleH :: IdpApplication Google AuthorizationCodeApplication -> ActionM ()
loginGoogleH :: IdpApplication 'Google AuthorizationCodeApplication -> ActionM ()
loginGoogleH IdpApplication 'Google AuthorizationCodeApplication
googleApp = do
  Text -> Text -> ActionM ()
Scotty.setHeader Text
"Location" (Text -> Text
TL.fromStrict forall a b. (a -> b) -> a -> b
$ URI -> Text
uriToText forall a b. (a -> b) -> a -> b
$ forall {k} a (i :: k).
HasAuthorizeRequest a =>
IdpApplication i a -> URI
mkAuthorizationRequest IdpApplication 'Google AuthorizationCodeApplication
googleApp)
  Status -> ActionM ()
Scotty.status Status
status302

-- | @/logout@ endpoint handler
logoutH :: IORef (Maybe DemoUser) -> ActionM ()
logoutH :: IORef (Maybe DemoUser) -> ActionM ()
logoutH IORef (Maybe DemoUser)
refUser = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe DemoUser)
refUser forall a. Maybe a
Nothing)
  forall a. Text -> ActionM a
Scotty.redirect Text
"/"

-- | @/oauth2/callback@ endpoint handler
callbackH ::
  IdpApplication Auth0 AuthorizationCodeApplication ->
  IdpApplication Google AuthorizationCodeApplication ->
  IORef (Maybe DemoUser) ->
  ActionM ()
callbackH :: IdpApplication 'Auth0 AuthorizationCodeApplication
-> IdpApplication 'Google AuthorizationCodeApplication
-> IORef (Maybe DemoUser)
-> ActionM ()
callbackH IdpApplication 'Auth0 AuthorizationCodeApplication
auth0App IdpApplication 'Google AuthorizationCodeApplication
googleApp IORef (Maybe DemoUser)
refUser = do
  [Param]
pas <- ActionM [Param]
Scotty.params

  forall a. Show a => ExceptT Text IO a -> ActionM a
excepttToActionM forall a b. (a -> b) -> a -> b
$ do
    Text
state <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [Param] -> Either Text Text
paramValue Text
"state" [Param]
pas
    Text
codeP <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> [Param] -> Either Text Text
paramValue Text
"code" [Param]
pas

    let code :: ExchangeToken
code = Text -> ExchangeToken
ExchangeToken forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict Text
codeP
    let idpName :: Text
idpName = (Char -> Bool) -> Text -> Text
TL.takeWhile (Char
'.' forall a. Eq a => a -> a -> Bool
/=) Text
state

    DemoUser
user <- case Text
idpName of
      Text
"google" -> IdpApplication 'Google AuthorizationCodeApplication
-> ExchangeToken -> ExceptT Text IO DemoUser
handleGoogleCallback IdpApplication 'Google AuthorizationCodeApplication
googleApp ExchangeToken
code
      Text
"auth0" -> IdpApplication 'Auth0 AuthorizationCodeApplication
-> ExchangeToken -> ExceptT Text IO DemoUser
handleAuth0Callback IdpApplication 'Auth0 AuthorizationCodeApplication
auth0App ExchangeToken
code
      Text
_ -> forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a b. (a -> b) -> a -> b
$ Text
"unable to find idp app of: " forall a. Semigroup a => a -> a -> a
<> Text
idpName

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe DemoUser)
refUser (forall a. a -> Maybe a
Just DemoUser
user)

  forall a. Text -> ActionM a
Scotty.redirect Text
"/"

handleAuth0Callback ::
  IdpApplication Auth0 AuthorizationCodeApplication ->
  ExchangeToken ->
  ExceptT TL.Text IO DemoUser
handleAuth0Callback :: IdpApplication 'Auth0 AuthorizationCodeApplication
-> ExchangeToken -> ExceptT Text IO DemoUser
handleAuth0Callback IdpApplication 'Auth0 AuthorizationCodeApplication
idpApp ExchangeToken
code = do
  Manager
mgr <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
  OAuth2Token
tokenResp <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT TokenResponseError -> Text
oauth2ErrorToText (forall {k} a (m :: * -> *) (i :: k).
(HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) =>
IdpApplication i a
-> Manager
-> ExchangeTokenInfo a
-> ExceptT TokenResponseError m OAuth2Token
conduitTokenRequest IdpApplication 'Auth0 AuthorizationCodeApplication
idpApp Manager
mgr ExchangeToken
code)
  Auth0User {Text
name :: Auth0User -> Text
email :: Auth0User -> Text
sub :: Auth0User -> Text
sub :: Text
email :: Text
name :: Text
..} <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ByteString -> Text
bslToText forall a b. (a -> b) -> a -> b
$ forall {k} (m :: * -> *) a b (i :: k).
(MonadIO m, HasUserInfoRequest a, FromJSON b) =>
IdpApplication i a
-> Manager -> AccessToken -> ExceptT ByteString m b
Auth0.fetchUserInfo IdpApplication 'Auth0 AuthorizationCodeApplication
idpApp Manager
mgr (OAuth2Token -> AccessToken
accessToken OAuth2Token
tokenResp)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text -> DemoUser
DemoUser Text
name (forall a. a -> Maybe a
Just Text
email))

handleGoogleCallback ::
  IdpApplication Google AuthorizationCodeApplication ->
  ExchangeToken ->
  ExceptT TL.Text IO DemoUser
handleGoogleCallback :: IdpApplication 'Google AuthorizationCodeApplication
-> ExchangeToken -> ExceptT Text IO DemoUser
handleGoogleCallback IdpApplication 'Google AuthorizationCodeApplication
idpApp ExchangeToken
code = do
  Manager
mgr <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
  OAuth2Token
tokenResp <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT TokenResponseError -> Text
oauth2ErrorToText (forall {k} a (m :: * -> *) (i :: k).
(HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) =>
IdpApplication i a
-> Manager
-> ExchangeTokenInfo a
-> ExceptT TokenResponseError m OAuth2Token
conduitTokenRequest IdpApplication 'Google AuthorizationCodeApplication
idpApp Manager
mgr ExchangeToken
code)
  GoogleUser {Text
name :: GoogleUser -> Text
id :: GoogleUser -> Text
email :: GoogleUser -> Text
email :: Text
id :: Text
name :: Text
..} <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ByteString -> Text
bslToText forall a b. (a -> b) -> a -> b
$ forall {k} (m :: * -> *) a b (i :: k).
(MonadIO m, HasUserInfoRequest a, FromJSON b) =>
IdpApplication i a
-> Manager -> AccessToken -> ExceptT ByteString m b
Google.fetchUserInfo IdpApplication 'Google AuthorizationCodeApplication
idpApp Manager
mgr (OAuth2Token -> AccessToken
accessToken OAuth2Token
tokenResp)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text -> DemoUser
DemoUser Text
name (forall a. a -> Maybe a
Just Text
email))

------------------------------

-- * Utilities

------------------------------

bslToText :: BSL.ByteString -> TL.Text
bslToText :: ByteString -> Text
bslToText = [Char] -> Text
TL.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
BSL.unpack

paramValue ::
  -- | Parameter key
  TL.Text ->
  -- | All parameters
  [Scotty.Param] ->
  Either TL.Text TL.Text
paramValue :: Text -> [Param] -> Either Text Text
paramValue Text
key [Param]
params =
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
val
    then forall a b. a -> Either a b
Left (Text
"No value found for param: " forall a. Semigroup a => a -> a -> a
<> Text
key)
    else forall a b. b -> Either a b
Right (forall a. [a] -> a
head [Text]
val)
  where
    val :: [Text]
val = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Param -> Bool
hasParam Text
key) [Param]
params
    hasParam :: TL.Text -> Scotty.Param -> Bool
    hasParam :: Text -> Param -> Bool
hasParam Text
t = (forall a. Eq a => a -> a -> Bool
== Text
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst

-- | Lift ExceptT to ActionM which is basically the handler Monad in Scotty.
excepttToActionM :: Show a => ExceptT TL.Text IO a -> ActionM a
excepttToActionM :: forall a. Show a => ExceptT Text IO a -> ActionM a
excepttToActionM ExceptT Text IO a
e = do
  Either Text a
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT Text IO a
e
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Text -> ActionM a
Scotty.raise forall (f :: * -> *) a. Applicative f => a -> f a
pure Either Text a
result

oauth2ErrorToText :: TokenResponseError -> TL.Text
oauth2ErrorToText :: TokenResponseError -> Text
oauth2ErrorToText TokenResponseError
e = [Char] -> Text
TL.pack forall a b. (a -> b) -> a -> b
$ [Char]
"Unable fetch access token. error detail: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show TokenResponseError
e