{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

-- | If you're hurry, go check source code directly.
--
-- = Configure your OAuth2 provider
--
-- Pick which OAuth2 provider you'd to use, e.g. Google, Github, Auth0 etc.
-- Pretty much all standard OAuth2 provider has developer portal to guide developer to use oauth2 flow.
-- So read it through if you're unfamiliar OAuth2 before.
-- Often time, those documents will guide you how to create an Application which has credentials
-- (e.g. @client_id@ and @client_secret@ for a web application), which will be used to authenticate your
-- service (replying party) with server.
--
-- For some OIDC providers, you may even be able to find out those URLs from a well-known endpoint.
--
-- @
-- https:\/\/BASE_DOMAIN\/.well-known\/openid-configuration
-- @
--
-- In this tutorial, I choose Auth0, which is one of existing OAuth2/OIDC Providers in the market.
-- This is the API Docs <https://auth0.com/docs/api>
--
-- = Generate Authorization URL.
--
-- OAuth2 starts with [authorization](https://www.rfc-editor.org/rfc/rfc6749#section-4).
--
-- To generate an authorization URL, call method 'authorizationUrl', then call 'appendQueryParams' to
-- append additional query parameters, e.g. @state@, @scope@ etc.
--
-- That method will also automatically append following query parameter to the authorization url.
--
-- @
-- client_id = 'xxx'        -- client id of your Application credential you got previously
-- response_type = 'code'   -- must be for authorization request
-- redirect_uri = 'xxx'     -- where does the server (provider) send back the authorization code.
--                        -- You have to config this when creating Application at previous step.
-- @
--
-- The generated URL looks like
--
-- @
-- https://DOMAIN/path/to/authorize?client_id=xxx&response_type=code&redirect_uri=xxx&state=xxx&scope=xxx&..
-- @
--
-- /Notes/: As of today, @hoauth2@ only supports @Code Grant@.
--
-- = Redirect user to the Authorization URL
--
-- Now you need to have your user to navigate to that URL to kick off OAuth flow.
--
-- There are different ways to redirect user to the 'authorizeUrl'.
--
-- e.g.
--
--   1. Display as anchor link directly at UI so that user can click it.
--
--   2. Create your own login endpoint, e.g. @/login@, which then 302 to the 'authorizeUrl'.
--
-- In this tutorial, I choose the second option. For instance this is how 'indexH' is implemented.
--
-- >>> setHeader "Location" (uriToText authorizeUrl)
-- >>> status status302
--
-- = Obtain Access Token
--
-- When user navigates to 'authorizeUrl', user will be prompt for login against the OAuth provider.
--
-- After an successful login there, user will be redirect back to your Application's @redirect_uri@
-- with @code@ in the query parameter.
--
-- With this @code@, we could exchange for an Access Token.
--
-- Also you'd better to validate the @state@ is exactly what you pass in the 'authorizeUrl'.
-- OAuth2 provider expects to send the exact @state@ back in the redirect request.
--
-- To obtain an Access Token, you could call 'fetchAccessToken',
-- which essentially takes the authorization @code@, make request to OAuth2 provider's @/token@ endpoint
-- to get an Access Token, plus some other information (see details at 'OAuth2Token').
--
-- 'fetchAccessToken' returns @ExceptT (OAuth2Error Errors) m OAuth2Token@
-- However Scotty, which is web framework I used to build this tutorial,
-- requires error as Text hence the transform with 'oauth2ErrorToText'
--
-- Once we got the 'OAuth2Token' (which actually deserves an better name like @TokenResponse@),
-- we could get the actual 'accessToken' of out it, use which to make API requests to resource server (often time same as the authorization server)
--
-- "Network.OAuth.OAuth2.HttpClient" provides a few handy method to send such API request.
-- For instance,
--
-- @
-- authGetJSON   -- Makes GET request and decode response as JSON, with access token appended in Authorization http header.
-- authPostJSON  -- Similar but does POST request
-- @
--
-- In this tutorial, it makes request to 'auth0UserInfoUri' to fetch Auth0 user information
-- so application knows who did the authorize.
--
-- = The end
--
-- That's it! Congratulations make thus far!
--
-- If you're interested more of OAuth2, keep reading on <https://www.oauth.com/>,
-- which provides a nice guide regarding what is OAuth2 and various use cases.
module HOAuth2Tutorial where

import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except
import Data.Aeson (FromJSON)
import Data.ByteString.Char8 qualified as BS
import Data.ByteString.Lazy.Char8 qualified as BSL
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Text.Encoding qualified as T
import Data.Text.Lazy qualified as TL
import GHC.Generics (Generic)
import Network.HTTP.Conduit (newManager, tlsManagerSettings)
import Network.HTTP.Types (status302)
import Network.OAuth.OAuth2.AuthorizationRequest
  ( authorizationUrl,
  )
import Network.OAuth.OAuth2.HttpClient (authGetJSON)
import Network.OAuth.OAuth2.Internal
  ( ExchangeToken (ExchangeToken),
    OAuth2 (..),
    OAuth2Error,
    OAuth2Token (accessToken),
    appendQueryParams,
  )
import Network.OAuth.OAuth2.TokenRequest (fetchAccessToken)
import Network.OAuth.OAuth2.TokenRequest qualified as TR
import URI.ByteString (URI, serializeURIRef')
import URI.ByteString.QQ (uri)
import Web.Scotty (ActionM, scotty)
import Web.Scotty qualified as Scotty

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

-- * Configuration

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

auth0 :: OAuth2
auth0 :: OAuth2
auth0 =
  OAuth2
    { oauth2ClientId :: Text
oauth2ClientId = Text
"TZlmNRtLY9duT8M4ztgFBLsFA66aEoGs",
      oauth2ClientSecret :: Text
oauth2ClientSecret = Text
"",
      oauth2AuthorizeEndpoint :: URIRef Absolute
oauth2AuthorizeEndpoint = [uri|https://freizl.auth0.com/authorize|],
      oauth2TokenEndpoint :: URIRef Absolute
oauth2TokenEndpoint = [uri|https://freizl.auth0.com/oauth/token|],
      oauth2RedirectUri :: URIRef Absolute
oauth2RedirectUri = [uri|http://localhost:9988/oauth2/callback|]
    }

authorizeUrl :: URI
authorizeUrl :: URIRef Absolute
authorizeUrl =
  forall a. [(ByteString, ByteString)] -> URIRef a -> URIRef a
appendQueryParams
    [ (ByteString
"scope", ByteString
"openid profile email"),
      (ByteString
"state", ByteString
randomStateValue)
    ]
    forall a b. (a -> b) -> a -> b
$ OAuth2 -> URIRef Absolute
authorizationUrl OAuth2
auth0

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

-- | Endpoint for fetching user profile using access token
auth0UserInfoUri :: URI
auth0UserInfoUri :: URIRef Absolute
auth0UserInfoUri = [uri|https://freizl.auth0.com/userinfo|]

-- | Auth0 user
-- https://auth0.com/docs/api/authentication#get-user-info
data Auth0User = Auth0User
  { Auth0User -> Text
name :: TL.Text,
    Auth0User -> Text
email :: TL.Text,
    Auth0User -> Text
sub :: TL.Text
  }
  deriving (Int -> Auth0User -> ShowS
[Auth0User] -> ShowS
Auth0User -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Auth0User] -> ShowS
$cshowList :: [Auth0User] -> ShowS
show :: Auth0User -> [Char]
$cshow :: Auth0User -> [Char]
showsPrec :: Int -> Auth0User -> ShowS
$cshowsPrec :: Int -> Auth0User -> ShowS
Show, forall x. Rep Auth0User x -> Auth0User
forall x. Auth0User -> Rep Auth0User x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Auth0User x -> Auth0User
$cfrom :: forall x. Auth0User -> Rep Auth0User x
Generic)

instance FromJSON Auth0User

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

-- * Web server

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

-- | The 'scotty' application
app :: IO ()
app :: IO ()
app = do
  -- Poor man's solution for creating user session.
  IORef (Maybe Auth0User)
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 Auth0User) -> ActionM ()
indexH IORef (Maybe Auth0User)
refUser
    RoutePattern -> ActionM () -> ScottyM ()
Scotty.get RoutePattern
"/login" ActionM ()
loginH
    RoutePattern -> ActionM () -> ScottyM ()
Scotty.get RoutePattern
"/logout" (IORef (Maybe Auth0User) -> ActionM ()
logoutH IORef (Maybe Auth0User)
refUser)
    RoutePattern -> ActionM () -> ScottyM ()
Scotty.get RoutePattern
"/oauth2/callback" forall a b. (a -> b) -> a -> b
$ IORef (Maybe Auth0User) -> ActionM ()
callbackH IORef (Maybe Auth0User)
refUser

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

  let info :: [Text]
info = case Maybe Auth0User
muser of
        Just Auth0User
user ->
          [ Text
"<p>Hello, " Text -> Text -> Text
`TL.append` Auth0User -> Text
name Auth0User
user Text -> Text -> Text
`TL.append` Text
"</p>",
            Text
"<a href='/logout'>Logout</a>"
          ]
        Maybe Auth0User
Nothing -> [Text
"<a href='/login'>Login</a>"]

  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 Tutorial</h1>" forall a. a -> [a] -> [a]
: [Text]
info

-- | @/login@ endpoint handler
loginH :: ActionM ()
loginH :: ActionM ()
loginH = do
  Text -> Text -> ActionM ()
Scotty.setHeader Text
"Location" (URIRef Absolute -> Text
uriToText URIRef Absolute
authorizeUrl)
  Status -> ActionM ()
Scotty.status Status
status302

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

-- | @/oauth2/callback@ endpoint handler
callbackH :: IORef (Maybe Auth0User) -> ActionM ()
callbackH :: IORef (Maybe Auth0User) -> ActionM ()
callbackH IORef (Maybe Auth0User)
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
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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

    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

    -- Exchange authorization code for Access Token
    -- 'oauth2ErrorToText' turns (OAuth2 error) to Text which is the default way
    -- Scotty represents error message
    let code :: ExchangeToken
code = Text -> ExchangeToken
ExchangeToken forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict Text
codeP
    OAuth2Token
tokenResp <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT OAuth2Error Errors -> Text
oauth2ErrorToText (Manager
-> OAuth2
-> ExchangeToken
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
fetchAccessToken Manager
mgr OAuth2
auth0 ExchangeToken
code)

    -- Call API to resource server with Access Token being authentication code.
    -- 'bslToText' exists for similar reason as 'oauth2ErrorToText'
    let at :: AccessToken
at = OAuth2Token -> AccessToken
accessToken OAuth2Token
tokenResp
    Auth0User
user <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ByteString -> Text
bslToText (forall b.
FromJSON b =>
Manager
-> AccessToken -> URIRef Absolute -> ExceptT ByteString IO b
authGetJSON Manager
mgr AccessToken
at URIRef Absolute
auth0UserInfoUri)

    -- Now we need to find way to set authentication status for this application
    -- that indicates user has been authenticated successfully.
    -- For simplicity in this tutorial, I choose an 'IORef'.
    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 Auth0User)
refUser (forall a. a -> Maybe a
Just Auth0User
user)

  -- Where to navigate to after login page successfully.
  forall a. Text -> ActionM a
Scotty.redirect Text
"/"

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

-- * Utilities

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

uriToText :: URI -> TL.Text
uriToText :: URIRef Absolute -> 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 :: OAuth2Error TR.Errors -> TL.Text
oauth2ErrorToText :: OAuth2Error Errors -> Text
oauth2ErrorToText OAuth2Error Errors
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 OAuth2Error Errors
e