{-# 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." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
randomStateValue)
          , acScope :: Set Scope
acScope = [Scope] -> Set Scope
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 = Map Text Text
forall k a. Map k a
Map.empty
          , acTokenRequestAuthenticationMethod :: ClientAuthenticationMethod
acTokenRequestAuthenticationMethod = ClientAuthenticationMethod
ClientSecretBasic
          }
  IdpApplication 'Auth0 AuthorizationCodeApplication
-> ExceptT
     Text IO (IdpApplication 'Auth0 AuthorizationCodeApplication)
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IdpApplication {Idp 'Auth0
AuthorizationCodeApplication
idp :: Idp 'Auth0
application :: AuthorizationCodeApplication
idp :: Idp 'Auth0
application :: AuthorizationCodeApplication
..}

mkTestAuth0Idp :: ExceptT Text IO (Idp Auth0)
mkTestAuth0Idp :: ExceptT Text IO (Idp 'Auth0)
mkTestAuth0Idp = Text -> ExceptT Text IO (Idp 'Auth0)
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." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
randomStateValue)
          , acRedirectUri :: URI
acRedirectUri = [uri|http://localhost:9988/oauth2/callback|]
          , acScope :: Set Scope
acScope =
              [Scope] -> Set Scope
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 = Map Text Text
forall k a. Map k a
Map.empty
          , acTokenRequestAuthenticationMethod :: ClientAuthenticationMethod
acTokenRequestAuthenticationMethod = ClientAuthenticationMethod
ClientSecretBasic
          }
      idp :: Idp 'Google
idp = Idp 'Google
Google.defaultGoogleIdp
   in IdpApplication {Idp 'Google
AuthorizationCodeApplication
idp :: Idp 'Google
application :: AuthorizationCodeApplication
application :: AuthorizationCodeApplication
idp :: Idp 'Google
..}

-- | 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
(DemoUser -> DemoUser -> Bool)
-> (DemoUser -> DemoUser -> Bool) -> Eq DemoUser
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DemoUser -> DemoUser -> Bool
== :: DemoUser -> DemoUser -> Bool
$c/= :: DemoUser -> DemoUser -> Bool
/= :: DemoUser -> DemoUser -> Bool
Eq, Int -> DemoUser -> ShowS
[DemoUser] -> ShowS
DemoUser -> [Char]
(Int -> DemoUser -> ShowS)
-> (DemoUser -> [Char]) -> ([DemoUser] -> ShowS) -> Show DemoUser
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DemoUser -> ShowS
showsPrec :: Int -> DemoUser -> ShowS
$cshow :: DemoUser -> [Char]
show :: DemoUser -> [Char]
$cshowList :: [DemoUser] -> ShowS
showList :: [DemoUser] -> ShowS
Show)

-- | The 'scotty' application
app :: IO ()
app :: IO ()
app = do
  Either Text (IdpApplication 'Auth0 AuthorizationCodeApplication)
eAuth0App <- ExceptT
  Text IO (IdpApplication 'Auth0 AuthorizationCodeApplication)
-> IO
     (Either Text (IdpApplication 'Auth0 AuthorizationCodeApplication))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT
  Text IO (IdpApplication 'Auth0 AuthorizationCodeApplication)
mkTestAuth0App
  (Text -> IO ())
-> (IdpApplication 'Auth0 AuthorizationCodeApplication -> IO ())
-> Either Text (IdpApplication 'Auth0 AuthorizationCodeApplication)
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> (Text -> [Char]) -> Text -> IO ()
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 <- Maybe DemoUser -> IO (IORef (Maybe DemoUser))
forall a. a -> IO (IORef a)
newIORef Maybe DemoUser
forall a. Maybe a
Nothing
      let googleApp :: IdpApplication 'Google AuthorizationCodeApplication
googleApp = IdpApplication 'Google AuthorizationCodeApplication
mkTestGoogleApp
      Int -> ScottyM () -> IO ()
scotty Int
9988 (ScottyM () -> IO ()) -> ScottyM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        RoutePattern -> ActionM () -> ScottyM ()
Scotty.get RoutePattern
"/" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
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" (ActionM () -> ScottyM ()) -> ActionM () -> ScottyM ()
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 <- IO (Maybe DemoUser) -> ActionT Text IO (Maybe DemoUser)
forall a. IO a -> ActionT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe DemoUser) -> IO (Maybe DemoUser)
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
name :: DemoUser -> Text
email :: DemoUser -> Maybe Text
name :: Text
email :: Maybe Text
..} ->
          [ Text
"<h2>Hello, "
          , Text
name
          , Text
"</h2>"
          , Text
"<p>"
          , [Char] -> Text
TL.pack (Maybe Text -> [Char]
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 (Text -> ActionM ()) -> ([Text] -> Text) -> [Text] -> ActionM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> ActionM ()) -> [Text] -> ActionM ()
forall a b. (a -> b) -> a -> b
$ Text
"<h1>hoauth2 providers Tutorial</h1>" Text -> [Text] -> [Text]
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 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ URI -> Text
uriToText (URI -> Text) -> URI -> Text
forall a b. (a -> b) -> a -> b
$ IdpApplication 'Auth0 AuthorizationCodeApplication -> URI
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 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ URI -> Text
uriToText (URI -> Text) -> URI -> Text
forall a b. (a -> b) -> a -> b
$ IdpApplication 'Google AuthorizationCodeApplication -> URI
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
  IO () -> ActionM ()
forall a. IO a -> ActionT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe DemoUser) -> Maybe DemoUser -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe DemoUser)
refUser Maybe DemoUser
forall a. Maybe a
Nothing)
  Text -> ActionM ()
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

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

    let code :: ExchangeToken
code = Text -> ExchangeToken
ExchangeToken (Text -> ExchangeToken) -> Text -> 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
'.' Char -> Char -> Bool
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
_ -> Text -> ExceptT Text IO DemoUser
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> ExceptT Text IO DemoUser)
-> Text -> ExceptT Text IO DemoUser
forall a b. (a -> b) -> a -> b
$ Text
"unable to find idp app of: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
idpName

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

  Text -> ActionM ()
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 <- IO Manager -> ExceptT Text IO Manager
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> ExceptT Text IO Manager)
-> IO Manager -> ExceptT Text IO Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
  OAuth2Token
tokenResp <- (TokenResponseError -> Text)
-> ExceptT TokenResponseError IO OAuth2Token
-> ExceptT Text IO OAuth2Token
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT TokenResponseError -> Text
oauth2ErrorToText (IdpApplication 'Auth0 AuthorizationCodeApplication
-> Manager
-> ExchangeTokenInfo AuthorizationCodeApplication
-> ExceptT TokenResponseError IO OAuth2Token
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
ExchangeTokenInfo AuthorizationCodeApplication
code)
  Auth0User {Text
name :: Text
email :: Text
sub :: Text
name :: Auth0User -> Text
email :: Auth0User -> Text
sub :: Auth0User -> Text
..} <- (ByteString -> Text)
-> ExceptT ByteString IO Auth0User -> ExceptT Text IO Auth0User
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ByteString -> Text
bslToText (ExceptT ByteString IO Auth0User -> ExceptT Text IO Auth0User)
-> ExceptT ByteString IO Auth0User -> ExceptT Text IO Auth0User
forall a b. (a -> b) -> a -> b
$ IdpApplication 'Auth0 AuthorizationCodeApplication
-> Manager -> AccessToken -> ExceptT ByteString IO Auth0User
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)
  DemoUser -> ExceptT Text IO DemoUser
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text -> DemoUser
DemoUser Text
name (Text -> Maybe Text
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 <- IO Manager -> ExceptT Text IO Manager
forall a. IO a -> ExceptT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> ExceptT Text IO Manager)
-> IO Manager -> ExceptT Text IO Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
  OAuth2Token
tokenResp <- (TokenResponseError -> Text)
-> ExceptT TokenResponseError IO OAuth2Token
-> ExceptT Text IO OAuth2Token
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT TokenResponseError -> Text
oauth2ErrorToText (IdpApplication 'Google AuthorizationCodeApplication
-> Manager
-> ExchangeTokenInfo AuthorizationCodeApplication
-> ExceptT TokenResponseError IO OAuth2Token
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
ExchangeTokenInfo AuthorizationCodeApplication
code)
  GoogleUser {Text
name :: Text
id :: Text
email :: Text
name :: GoogleUser -> Text
id :: GoogleUser -> Text
email :: GoogleUser -> Text
..} <- (ByteString -> Text)
-> ExceptT ByteString IO GoogleUser -> ExceptT Text IO GoogleUser
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ByteString -> Text
bslToText (ExceptT ByteString IO GoogleUser -> ExceptT Text IO GoogleUser)
-> ExceptT ByteString IO GoogleUser -> ExceptT Text IO GoogleUser
forall a b. (a -> b) -> a -> b
$ IdpApplication 'Google AuthorizationCodeApplication
-> Manager -> AccessToken -> ExceptT ByteString IO GoogleUser
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)
  DemoUser -> ExceptT Text IO DemoUser
forall a. a -> ExceptT Text IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text -> DemoUser
DemoUser Text
name (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
email))

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

-- * Utilities

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

bslToText :: BSL.ByteString -> TL.Text
bslToText :: ByteString -> Text
bslToText = [Char] -> Text
TL.pack ([Char] -> Text) -> (ByteString -> [Char]) -> ByteString -> Text
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 [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
val
    then Text -> Either Text Text
forall a b. a -> Either a b
Left (Text
"No value found for param: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key)
    else Text -> Either Text Text
forall a b. b -> Either a b
Right ([Text] -> Text
forall a. HasCallStack => [a] -> a
head [Text]
val)
  where
    val :: [Text]
val = Param -> Text
forall a b. (a, b) -> b
snd (Param -> Text) -> [Param] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Param -> Bool) -> [Param] -> [Param]
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 = (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t) (Text -> Bool) -> (Param -> Text) -> Param -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> Text
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 <- IO (Either Text a) -> ActionT Text IO (Either Text a)
forall a. IO a -> ActionT Text IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Text a) -> ActionT Text IO (Either Text a))
-> IO (Either Text a) -> ActionT Text IO (Either Text a)
forall a b. (a -> b) -> a -> b
$ ExceptT Text IO a -> IO (Either Text a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT Text IO a
e
  (Text -> ActionM a)
-> (a -> ActionM a) -> Either Text a -> ActionM a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> ActionM a
forall a. Text -> ActionM a
Scotty.raise a -> ActionM a
forall a. a -> ActionT Text IO a
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 ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Unable fetch access token. error detail: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ TokenResponseError -> [Char]
forall a. Show a => a -> [Char]
show TokenResponseError
e