{-# 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 (parseJSON),
    defaultOptions,
    genericParseJSON,
  )
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 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 where
  parseJSON :: Value -> Parser Auth0User
parseJSON = forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions

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

-- * 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