Secrets: + +
Hello Admin person whose identity is: #{show u}. + |] + + +-- | Here's the most important function. We aim to convert 'AdminPageM's into +-- 'PageM's. We do this in the context of an 'PageM' function, where we +-- investigate the current user. If that user is an admin (vi a'isAdmin') then +-- we convert the given 'AdminPageM' into a 'PageM' by simply 'coerce'ing it; +-- after all, the 'Role' type was just a phantom type. +-- +-- If we fail to verify that they are an admin, we throw a http 404 error. +-- +-- @since 0.1.0.0 +verifyAdmin :: ServerT (NamedRoutes AdminRoutes) AdminPageM + -> ServerT (NamedRoutes AdminRoutes) PageM +verifyAdmin = hoistServer (Proxy @(NamedRoutes AdminRoutes)) transform + where + transform :: AdminPageM a -> PageM a + transform p = do + env <- ask + let currentUser = user env + if isAdmin currentUser + then coerce p + else throwError err404 + + +-- | Note here that this function returns a server of 'PageM's; that's because +-- we pass the routes through the 'verifyAdmin' function. +-- +-- @since 0.1.0.0 +adminServer :: ServerT (NamedRoutes AdminRoutes) PageM +adminServer = verifyAdmin $ AdminRoutes + { adminHome = adminHandler + } + + +-- | A simple check to see if the user is present and has a 'role' that is +-- equal to `"admin"`. +-- +-- @since 0.1.0.0 +isAdmin :: Maybe User -> Bool +isAdmin (Just (User {role})) = role == "admin" +isAdmin _ = False + + +-- | Check if a user is present and therefore logged in. +-- +-- @since 0.1.0.0 +isLoggedIn :: PageM Bool +isLoggedIn = pure . isJust . user =<< ask + + +-- | In the context of a 'PageM', maybe return the user; this is the best we +-- can do. +-- +-- @since 0.1.0.0 +getUser :: PageM (Maybe User) +getUser = pure . user =<< ask + + +-- | In the present of an 'AdminPageM', /definitely/ return a user. We're +-- happy with an error if this fails, because we know that a user needs to be +-- present. +-- +-- Note that it could be an extension to this code to eliminate the 'fromJust' +-- here, and ensure that whatever context we're referencing has eliminated the +-- 'Maybe' over the user. +-- +-- We leave this as an exercise for the reader :) +-- +-- @since 0.1.0.0 +getAdmin :: AdminPageM User +getAdmin = pure . fromJust . user =<< ask + + +-- | This time our home handler does a bit of busywork to show whether or not +-- you're logged in, and provide the relevant links. It also detects if you're +-- an admin, and if not, provides you a link to the admin page anyway, to see +-- if you can hack into it! :) +-- +-- @since 0.1.0.0 +homeHandler :: PageM Html +homeHandler = do + env <- ask + + let githubCallbackUrl = _callbackUrl $ githubOAuthConfig env + githubLoginUrl = getGithubLoginUrl githubCallbackUrl (githubSettings env) + + let googleCallbackUrl = _callbackUrl $ googleOAuthConfig env + googleLoginUrl = getGoogleLoginUrl googleCallbackUrl (googleSettings env) + + loggedIn <- isLoggedIn + u <- getUser + pure $ + [shamlet| +
+ Login with Github
+
+ Logout
+
+ $if isAdmin u
+
+ Access the admin area!
+ $else
+
+ You're not an admin, but perhaps you may like to
+ try and hack into the admin area!
+ |]
+
+
+-- | The final full server; we need a special 'hoistServer' for the 'site'
+-- route, because we need to add the 'Maybe User' into the 'Env'. Otherwise,
+-- we just do as we've always done - pass off to the 'authServer'.
+--
+-- @since 0.1.0.0
+server :: Routes (AsServerT PageM)
+server =
+ Routes
+ { site = \user ->
+ let addUser env = env { user = user }
+ in hoistServer
+ (Proxy @(NamedRoutes SiteRoutes))
+ (withReaderT addUser)
+ siteServer
+ , authGithub = authServer
+ , authGoogle = authServer
+ }
+
+
+-- | Our usual approach for 'Github' settings.
+--
+-- @since 0.1.0.0
+mkGithubSettings :: Key -> OAuthConfig -> OAuth2Settings PageM Github OAuth2Result
+mkGithubSettings key c = settings
+ where
+ toSessionId _ = pure . id
+ provider = mkGithubProvider (_name c) (_id c) (_secret c) emailAllowList Nothing
+ settings = simpleCookieOAuth2Settings provider toSessionId key
+ emailAllowList = [".*"]
+
+
+-- | Our usual approach for 'Google' settings.
+--
+-- @since 0.1.0.0
+mkGoogleSettings :: Key -> OAuthConfig -> OAuth2Settings PageM Google OAuth2Result
+mkGoogleSettings key c = settings
+ where
+ toSessionId _ = pure . id
+ provider = mkGoogleProvider (_id c) (_secret c) emailAllowList Nothing
+ settings = simpleCookieOAuth2Settings provider toSessionId key
+ emailAllowList = [".*"]
+
+
+-- | Our usual approach to the 'main' function; setting up the settings,
+-- setting up the contexts for the relevant auth handler functions.
+--
+-- @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
+ db <- loadDb
+
+ let nat :: PageM a -> Handler a
+ nat = flip runReaderT env
+ githubSettings = mkGithubSettings key (_githubOAuth config)
+ googleSettings = mkGoogleSettings key (_googleOAuth config)
+ env = Env Nothing
+ githubSettings (_githubOAuth config)
+ googleSettings (_googleOAuth config)
+ context
+ = optionalUserAuthHandler db key
+ :. oauth2AuthHandler githubSettings nat
+ :. oauth2AuthHandler googleSettings nat
+ :. EmptyContext
+
+
+ putStrLn "Waiting for connections!"
+ run 8080 $
+ genericServeTWithContext nat server context
+
+
+-- | Utility function to load the hard-coded database.
+--
+-- @since 0.1.0.0
+loadDb :: IO Db
+loadDb = do
+ ls <- Text.lines <$> Text.readFile "./servant-oauth2-examples/example-auth/db.txt"
+ let raw = map (Text.split (==',')) ls
+ mkRow [u,r] = (u, User u r)
+ mkRow _ = error "Inconsistent database state."
+ pure $ H.fromList $ map mkRow raw
diff --git a/src/Servant/OAuth2/Examples/Config.hs b/src/Servant/OAuth2/Examples/Config.hs
new file mode 100644
--- /dev/null
+++ b/src/Servant/OAuth2/Examples/Config.hs
@@ -0,0 +1,34 @@
+module Servant.OAuth2.Examples.Config where
+
+import "text" Data.Text (Text)
+import "tomland" Toml (TomlCodec, diwrap, table, text, (.=))
+
+
+data OAuthConfig = OAuthConfig
+ { _name :: Text
+ , _id :: Text
+ , _secret :: Text
+ , _callbackUrl :: Text
+ }
+
+
+oauthConfigCodec :: TomlCodec OAuthConfig
+oauthConfigCodec =
+ OAuthConfig
+ <$> diwrap (text "name") .= _name
+ <*> diwrap (text "id") .= _id
+ <*> diwrap (text "secret") .= _secret
+ <*> diwrap (text "callback_url") .= _callbackUrl
+
+
+data Config = Config
+ { _githubOAuth :: OAuthConfig
+ , _googleOAuth :: OAuthConfig
+ }
+
+
+configCodec :: TomlCodec Config
+configCodec =
+ Config
+ <$> table oauthConfigCodec "oauth-github" .= _githubOAuth
+ <*> table oauthConfigCodec "oauth-google" .= _googleOAuth
diff --git a/src/Servant/OAuth2/Examples/Cookies.hs b/src/Servant/OAuth2/Examples/Cookies.hs
new file mode 100644
--- /dev/null
+++ b/src/Servant/OAuth2/Examples/Cookies.hs
@@ -0,0 +1,190 @@
+{-# 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|
+
+ $if not loggedIn
+ 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
diff --git a/src/Servant/OAuth2/Examples/Simple.hs b/src/Servant/OAuth2/Examples/Simple.hs
new file mode 100644
--- /dev/null
+++ b/src/Servant/OAuth2/Examples/Simple.hs
@@ -0,0 +1,198 @@
+{-# language NamedFieldPuns #-}
+{-# language QuasiQuotes #-}
+{-# language TemplateHaskell #-}
+{-# language TypeFamilies #-}
+{-|
+
+This is the simplest example of a full application that makes use of this
+library.
+
+We don't do anything with the result of successful authentication other than
+return the ident that was provided to us. In an "real" example, you'll want to
+set a cookie. For that, you can take a look at
+"Servant.OAuth2.Examples.Cookies".
+
+This file serves as a complete example; and you can read through this
+documentation from top to bottom, in order to work out what each component is.
+-}
+
+module Servant.OAuth2.Examples.Simple where
+
+import "text" Data.Text (Text)
+import "base" GHC.Generics (Generic)
+import "warp" Network.Wai.Handler.Warp (run)
+import "wai-middleware-auth" Network.Wai.Middleware.Auth.OAuth2.Github
+ ( Github (..)
+ , mkGithubProvider
+ )
+import "wai-middleware-auth" Network.Wai.Middleware.Auth.OAuth2.Google
+ ( Google (..)
+ , mkGoogleProvider
+ )
+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.Examples.Config
+import Servant.OAuth2.Hacks
+import "servant-server" Servant.Server.Experimental.Auth
+ ( AuthServerData
+ )
+import "servant-server" Servant.Server.Generic
+ ( AsServerT
+ , genericServeTWithContext
+ )
+import "shakespeare" Text.Hamlet (Html, shamlet)
+import "tomland" Toml (decodeFileExact)
+
+
+-- | First, we need to define an instance that corresponds to the result we
+-- want to return. We're going with the 'basic' option; so we'll just take the
+-- Text value of the ident that comes back. Note that this is a _list_ of
+-- potential return kinds; the reason it's set up this way is only so we can
+-- explicitly say we'd like to return a 303 Redirect, when using cookies.
+--
+-- @since 0.1.0.0
+type OAuth2Result = '[WithStatus 200 Text]
+
+
+-- | Next up, we follow the approach of the generalised servant authentication
+-- to connect up our (future usage of) the 'oauth2AuthHandler' to the
+-- respective tagged routes by by this particular 'AuthProtect' instance,
+-- namely, the 'authGithub' and 'authGoogle' routes we will define in a
+-- moment.
+--
+-- @since 0.1.0.0
+type instance AuthServerData (AuthProtect Github) = Tag Github OAuth2Result
+
+
+-- | Same as above, but for google.
+--
+-- @since 0.1.0.0
+type instance AuthServerData (AuthProtect Google) = Tag Google OAuth2Result
+
+
+-- | Here we just define a very simple website, something like:
+--
+-- @
+-- \/
+-- \/auth\/github\/...
+-- \/auth\/google\/...
+-- @
+--
+-- The 'authGoogle' and 'authGithub' routes will not be implemented by us;
+-- they are both provided by a 'NamedRoutes (OAuth2Routes OAuth2Result)'
+-- value; i.e. the routes themselves come from 'Servant.OAuth2'.
+--
+-- @since 0.1.0.0
+data Routes mode = Routes
+ { home :: mode :- Get '[HTML] Html
+ , authGithub ::
+ mode
+ :- AuthProtect Github
+ :> "auth"
+ :> "github"
+ :> NamedRoutes (OAuth2Routes OAuth2Result)
+ , authGoogle ::
+ mode
+ :- AuthProtect Google
+ :> "auth"
+ :> "google"
+ :> NamedRoutes (OAuth2Routes OAuth2Result)
+ }
+ deriving stock (Generic)
+
+
+-- | We need to build an 'OAuth2Settings' to pass to 'oauth2AuthHandler', so
+-- that it knows which provider it is working with. We also need to tag it
+-- with a 'Handler'-like monad that can interpret errors; in the simple case
+-- this is just the 'Handler' type itself, but in later examples (in
+-- particular the "Servant.OAuth2.Examples.Authorisation" example) it will be
+-- a custom monad.
+--
+-- @since 0.1.0.0
+mkGithubSettings :: OAuthConfig -> OAuth2Settings Handler Github OAuth2Result
+mkGithubSettings c =
+ defaultOAuth2Settings $
+ mkGithubProvider (_name c) (_id c) (_secret c) emailAllowList Nothing
+ where
+ emailAllowList = [".*"]
+
+
+-- | Exactly the same as 'mkGithubSettings' but for the 'Google' provider.
+--
+-- @since 0.1.0.0
+mkGoogleSettings :: OAuthConfig -> OAuth2Settings Handler Google OAuth2Result
+mkGoogleSettings c =
+ defaultOAuth2Settings $
+ mkGoogleProvider (_id c) (_secret c) emailAllowList Nothing
+ where
+ emailAllowList = [".*"]
+
+
+-- | Here we pull implement a very simple homepage, basically just showing the
+-- links to login, and connecting the two 'authGithub' and 'authGoogle' routes
+-- together. There's a bit of noise in passing all the relevant configs in,
+-- but this would go away in a "real" application, by passing that around in
+-- an env, or otherwise.
+--
+-- @since 0.1.0.0
+server ::
+ Text ->
+ OAuth2Settings Handler Github OAuth2Result ->
+ Text ->
+ OAuth2Settings Handler Google OAuth2Result ->
+ Routes (AsServerT Handler)
+server githubCallbackUrl githubSettings googleCallbackUrl googleSettings =
+ Routes
+ { home = do
+ let githubLoginUrl = getGithubLoginUrl githubCallbackUrl githubSettings
+ googleLoginUrl = getGoogleLoginUrl googleCallbackUrl googleSettings
+
+ pure $
+ [shamlet|
+
+ Login with Google
+ $else
+ Welcome #{show u}!
+ Home - Example with Cookies
+
Home - Basic Example
+