{-# 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 (
  ExchangeToken (ExchangeToken),
  OAuth2Token (accessToken),
  TokenRequestError,
 )
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 :: IdpApplication 'AuthorizationCode Auth0
testAuth0App =
  (Idp Auth0 -> IdpApplication 'AuthorizationCode Auth0
defaultAuth0App Idp Auth0
testAuth0Idp)
    { $sel:idpAppClientId:AuthorizationCodeIdpApplication :: ClientId
idpAppClientId = ClientId
""
    , $sel:idpAppClientSecret:AuthorizationCodeIdpApplication :: ClientSecret
idpAppClientSecret = ClientSecret
""
    , $sel:idpAppAuthorizeState:AuthorizationCodeIdpApplication :: AuthorizeState
idpAppAuthorizeState = Text -> AuthorizeState
AuthorizeState (Text
"auth0." forall a. Semigroup a => a -> a -> a
<> Text
randomStateValue)
    , $sel:idpAppScope:AuthorizationCodeIdpApplication :: Set Scope
idpAppScope = forall a. Ord a => [a] -> Set a
Set.fromList [Scope
"openid", Scope
"email", Scope
"profile"]
    , $sel:idpAppRedirectUri:AuthorizationCodeIdpApplication :: URI
idpAppRedirectUri = [uri|http://localhost:9988/oauth2/callback|]
    , $sel:idpAppName:AuthorizationCodeIdpApplication :: Text
idpAppName = Text
"foo-auth0-app"
    }

testAuth0Idp :: Idp Auth0
testAuth0Idp :: Idp Auth0
testAuth0Idp =
  Idp Auth0
defaultAuth0Idp
    { $sel:idpUserInfoEndpoint:Idp :: URI
idpUserInfoEndpoint = [uri|https://freizl.auth0.com/userinfo|]
    , $sel:idpAuthorizeEndpoint:Idp :: URI
idpAuthorizeEndpoint = [uri|https://freizl.auth0.com/authorize|]
    , $sel:idpTokenEndpoint:Idp :: URI
idpTokenEndpoint = [uri|https://freizl.auth0.com/oauth/token|]
    }

testGoogleIdp :: Idp Google
testGoogleIdp :: Idp Google
testGoogleIdp = Idp Google
defaultGoogleIdp

testGoogleApp :: IdpApplication 'AuthorizationCode Google
testGoogleApp :: IdpApplication 'AuthorizationCode Google
testGoogleApp =
  IdpApplication 'AuthorizationCode Google
defaultGoogleApp
    { $sel:idpAppClientId:AuthorizationCodeIdpApplication :: ClientId
idpAppClientId = ClientId
""
    , $sel:idpAppClientSecret:AuthorizationCodeIdpApplication :: ClientSecret
idpAppClientSecret = ClientSecret
""
    , $sel:idpAppAuthorizeState:AuthorizationCodeIdpApplication :: AuthorizeState
idpAppAuthorizeState = Text -> AuthorizeState
AuthorizeState (Text
"google." forall a. Semigroup a => a -> a -> a
<> Text
randomStateValue)
    , $sel:idpAppRedirectUri:AuthorizationCodeIdpApplication :: URI
idpAppRedirectUri = [uri|http://localhost:9988/oauth2/callback|]
    , $sel:idpAppName:AuthorizationCodeIdpApplication :: Text
idpAppName = Text
"foo-google-app"
    , $sel:idp:AuthorizationCodeIdpApplication :: Idp Google
idp = Idp Google
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 :: 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
  -- Poor man's solution for creating user session.
  IORef (Maybe DemoUser)
refUser <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
  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" ActionM ()
loginAuth0H
    RoutePattern -> ActionM () -> ScottyM ()
Scotty.get RoutePattern
"/login/google" ActionM ()
loginGoogleH
    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
$ IORef (Maybe DemoUser) -> ActionM ()
callbackH 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
$sel:email:DemoUser :: DemoUser -> Maybe Text
$sel:name:DemoUser :: 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 :: ActionM ()
loginAuth0H :: ActionM ()
loginAuth0H = do
  Text -> Text -> ActionM ()
Scotty.setHeader Text
"Location" (forall (a :: GrantTypeFlow) i.
HasAuthorizeRequest a =>
IdpApplication a i -> MkAuthorizationRequestResponse a
mkAuthorizeRequest IdpApplication 'AuthorizationCode Auth0
testAuth0App)
  Status -> ActionM ()
Scotty.status Status
status302

-- | @/login/google@ endpoint handler
loginGoogleH :: ActionM ()
loginGoogleH :: ActionM ()
loginGoogleH = do
  Text -> Text -> ActionM ()
Scotty.setHeader Text
"Location" (forall (a :: GrantTypeFlow) i.
HasAuthorizeRequest a =>
IdpApplication a i -> MkAuthorizationRequestResponse a
mkAuthorizeRequest IdpApplication 'AuthorizationCode Google
testGoogleApp)
  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 :: IORef (Maybe DemoUser) -> ActionM ()
callbackH :: IORef (Maybe DemoUser) -> ActionM ()
callbackH 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" -> ExchangeToken -> ExceptT Text IO DemoUser
handleGoogleCallback ExchangeToken
code
      Text
"auth0" -> ExchangeToken -> ExceptT Text IO DemoUser
handleAuth0Callback 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 :: ExchangeToken -> ExceptT TL.Text IO DemoUser
handleAuth0Callback :: ExchangeToken -> ExceptT Text IO DemoUser
handleAuth0Callback ExchangeToken
code = do
  let idpApp :: IdpApplication 'AuthorizationCode Auth0
idpApp = IdpApplication 'AuthorizationCode Auth0
testAuth0App
  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 TokenRequestError -> Text
oauth2ErrorToText (forall (a :: GrantTypeFlow) (m :: * -> *) i.
(HasTokenRequest a, MonadIO m) =>
IdpApplication a i
-> Manager
-> WithExchangeToken a (ExceptT TokenRequestError m OAuth2Token)
conduitTokenRequest IdpApplication 'AuthorizationCode Auth0
idpApp Manager
mgr ExchangeToken
code)
  Auth0User {Text
sub :: Text
email :: Text
name :: Text
sub :: Auth0User -> Text
name :: Auth0User -> Text
email :: Auth0User -> 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 (a :: GrantTypeFlow) i.
(HasUserInfoRequest a, FromJSON (IdpUserInfo i)) =>
IdpApplication a i
-> Manager -> AccessToken -> ExceptT ByteString IO (IdpUserInfo i)
conduitUserInfoRequest IdpApplication 'AuthorizationCode Auth0
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 :: ExchangeToken -> ExceptT TL.Text IO DemoUser
handleGoogleCallback :: ExchangeToken -> ExceptT Text IO DemoUser
handleGoogleCallback ExchangeToken
code = do
  let idpApp :: IdpApplication 'AuthorizationCode Google
idpApp = IdpApplication 'AuthorizationCode Google
testGoogleApp
  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 TokenRequestError -> Text
oauth2ErrorToText (forall (a :: GrantTypeFlow) (m :: * -> *) i.
(HasTokenRequest a, MonadIO m) =>
IdpApplication a i
-> Manager
-> WithExchangeToken a (ExceptT TokenRequestError m OAuth2Token)
conduitTokenRequest IdpApplication 'AuthorizationCode Google
idpApp Manager
mgr ExchangeToken
code)
  GoogleUser {Text
email :: Text
id :: Text
name :: Text
name :: GoogleUser -> Text
id :: GoogleUser -> Text
email :: GoogleUser -> 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 (a :: GrantTypeFlow) i.
(HasUserInfoRequest a, FromJSON (IdpUserInfo i)) =>
IdpApplication a i
-> Manager -> AccessToken -> ExceptT ByteString IO (IdpUserInfo i)
conduitUserInfoRequest IdpApplication 'AuthorizationCode Google
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

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

uriToText :: URI -> TL.Text
uriToText :: URI -> Text
uriToText = Text -> Text
TL.fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. URIRef a -> ByteString
serializeURIRef'

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 :: TokenRequestError -> TL.Text
oauth2ErrorToText :: TokenRequestError -> Text
oauth2ErrorToText TokenRequestError
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 TokenRequestError
e