servant-oauth2-examples-0.1.0.0: src/Servant/OAuth2/Examples/Cookies.hs
{-# language NamedFieldPuns #-}
{-# language QuasiQuotes #-}
{-# language TemplateHaskell #-}
{-# language TypeFamilies #-}
{-|
This example follows the "Servant.OAuth2.Examples.Simple" example very
closely, but this time we use a configuration that let's enables us to
set a cookie, and then redirect to the homepage.
Moreover, we set things up so that we can /read/ that cookie on /any/ page, to
determine if the current visitor is logged in.
We will assume you have read the "Simple" example, and mostly spend our time
explaining what is different.
-}
module Servant.OAuth2.Examples.Cookies where
import "base" Data.Maybe (fromJust, isJust)
import "text" Data.Text (Text)
import "base" GHC.Generics (Generic)
import "wai" Network.Wai (Request)
import "warp" Network.Wai.Handler.Warp (run)
import "wai-middleware-auth" Network.Wai.Middleware.Auth.OAuth2.Github
( Github (..)
, mkGithubProvider
)
import "servant-server" Servant
( AuthProtect
, Context (EmptyContext, (:.))
, Get
, Handler
, NamedRoutes
, WithStatus
, type (:>)
)
import "servant" Servant.API.Generic ((:-))
import "servant-blaze" Servant.HTML.Blaze (HTML)
import Servant.OAuth2
import Servant.OAuth2.Cookies
import Servant.OAuth2.Examples.Config
import Servant.OAuth2.Hacks
import "servant-server" Servant.Server.Experimental.Auth
( AuthHandler
, AuthServerData
, mkAuthHandler
)
import "servant-server" Servant.Server.Generic
( AsServerT
, genericServeTWithContext
)
import "shakespeare" Text.Hamlet (Html, shamlet)
import "tomland" Toml (decodeFileExact)
import "clientsession" Web.ClientSession (Key, getDefaultKey)
-- | This time our result type is a set of headers that both redirects, and
-- sets a particular cookie value. The cookie will, here, contain simply the
-- result of the oauth2 workflow; i.e. the users email.
--
-- @since 0.1.0.0
type OAuth2Result = '[WithStatus 303 RedirectWithCookie]
-- | Our instance here is exactly the same (in fact, it will _always_ be the
-- same!); it just connects the 'Github' type and the 'OAuth2Result' type, so
-- it can be picked out by the right version of 'oauth2AuthHandler'.
--
-- @since 0.1.0.0
type instance AuthServerData (AuthProtect Github) = Tag Github OAuth2Result
-- | Now, we want to be able to check if a user is logged in on any page. We
-- will use this 'AuthProtect' instance to do that.
--
-- The _result_ of this particular check could typically be some kind of
-- @User@ value, but here, we're not concerning ourselves with that detail, so
-- we will just return a 'Maybe Text'; i.e. either 'Nothing', if we couldn't
-- decode a user from the cookie, or the ident of the user if we could.
--
-- @since 0.1.0.0
type instance AuthServerData (AuthProtect "optional-cookie") = Maybe Text
-- | This is the corresponding handler for the above instance. Our
-- implementation is very simple, we just call 'getSessionIdFromCookie', which
-- is provided by the "Servant.OAuth2" library itself; this decodes a
-- previously-encoded value from the cookie, by the corresponding function
-- 'buildSessionCookie', which we will later use through the
-- 'simpleCookieOAuth2Settings' function.
--
-- @since 0.1.0.0
optionalUserAuthHandler :: Key -> AuthHandler Request (Maybe Text)
optionalUserAuthHandler key = mkAuthHandler f
where
f :: Request -> Handler (Maybe Text)
f req = do
let sessionId = getSessionIdFromCookie req key
pure sessionId
-- | As last time, we have our routes; the main change is the inclusion of the
-- 'AuthProtect' tag on the 'home' route, that let's us bring a potential user
-- into scope for that page.
--
-- @since 0.1.0.0
data Routes mode = Routes
{ home :: mode :- AuthProtect "optional-cookie" :> Get '[HTML] Html
, auth ::
mode
:- AuthProtect Github
:> "auth"
:> "github"
:> NamedRoutes (OAuth2Routes OAuth2Result)
}
deriving stock (Generic)
-- | Again, we have settings, but this time, instead of using the
-- 'defaultOAuth2Settings', we use the 'simpleCookieOAuth2Settings' function
-- to get default behaviour that, upon successful completion of the oauth2
-- flow, builds a cookie with a /session id/ — in this case just the
-- ident of the user — and then redirects the browser to the homepage.
--
-- @since 0.1.0.0
mkSettings :: Key -> OAuthConfig -> OAuth2Settings Handler Github OAuth2Result
mkSettings key c = settings
where
toSessionId _ = pure . id
provider = mkGithubProvider (_name c) (_id c) (_secret c) emailAllowList Nothing
settings = simpleCookieOAuth2Settings provider toSessionId key
emailAllowList = [".*"]
-- | Now we can have a simple server implementation, but this time we can
-- check if the user us logged in by looking at the first parameter to the
-- 'home' function; i.e. if it's 'Nothing' then we're not logged in, otherwise
-- we are! Very convenient.
--
-- @since 0.1.0.0
server :: OAuthConfig
-> OAuth2Settings Handler Github OAuth2Result
-> Routes (AsServerT Handler)
server OAuthConfig {_callbackUrl} settings =
Routes
{ home = \user -> do
let githubLoginUrl = getGithubLoginUrl _callbackUrl settings
loggedIn = isJust user
pure $
[shamlet|
<h3> Home - Example with Cookies
<p>
$if not loggedIn
<a href="#{githubLoginUrl}"> Login
$else
Welcome #{fromJust user}!
|]
, auth = authServer
}
-- | Our entrypoint; the only addition here is that we need to obtain a 'Key'
-- to do our cookie encryption/decryption; and we again need to build up our
-- context with our 'Github'-based 'oauth2AuthHandler' and our own custom one,
-- 'optionalUserAuthHandler', to decode the cookie.
--
-- @since 0.1.0.0
main :: IO ()
main = do
eitherConfig <- decodeFileExact configCodec ("./config.toml")
config <-
either
(\errors -> fail $ "unable to parse configuration: " <> show errors)
pure
eitherConfig
key <- getDefaultKey
let ghSettings = mkSettings key (_githubOAuth config)
context = optionalUserAuthHandler key
:. oauth2AuthHandler ghSettings nat
:. EmptyContext
nat = id
putStrLn "Waiting for connections!"
run 8080 $
genericServeTWithContext nat (server (_githubOAuth config) ghSettings) context