{-# language NamedFieldPuns  #-}
{-# language QuasiQuotes     #-}
{-# language TemplateHaskell #-}
{-# language TypeFamilies    #-}

{-|

This is the last example we provide, but also the most interesting, and,
indeed, the main motivation for this libraries existence!

Here we show how to build type-level authorisation into your Servant API,
backed by authentication with OAuth2.

We assume you've read over the previous two examples, as we build directly
on that knowledge:

- "Servant.OAuth2.Examples.Simple"
- "Servant.OAuth2.Examples.Cookies"

-}

module Servant.OAuth2.Examples.Authorisation where

import "mtl" Control.Monad.Reader (ReaderT, ask, runReaderT, withReaderT)
import "base" Data.Coerce (coerce)
import "unordered-containers" Data.HashMap.Strict qualified as H
import "base" Data.Maybe (fromJust, isJust)
import "text" Data.Text (Text)
import "text" Data.Text qualified as Text
import "text" Data.Text.Encoding (decodeUtf8)
import "text" Data.Text.IO qualified as 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 "wai-middleware-auth" Network.Wai.Middleware.Auth.OAuth2.Google
  ( Google (..)
  , mkGoogleProvider
  )
import "servant-server" Servant
  ( AuthProtect
  , Context (EmptyContext, (:.))
  , Get
  , Handler
  , NamedRoutes
  , Proxy (Proxy)
  , ServerT
  , StdMethod (GET)
  , UVerb
  , WithStatus (WithStatus)
  , err404
  , hoistServer
  , respond
  , throwError
  , 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 we're going to have users. We're keeping it light and easy
-- here, so our /database/ is simply a map of emails to users. At this point
-- I'd like to note a slight quirk of oauth2-based authentication.
--
-- Note that the ident that comes back from the provider is up to that
-- provider itself. So, for example, I could make an entirely new oauth2
-- provider that always returns the same email, for example. In particular, it
-- could always return _you_ email. Then, if this website added my (dodgey)
-- provider to it's list, I would be able to log in as you, if all you to do
-- verify accounts is /look up the user by the email/. So, in any real system,
-- you should track the /provider name/ along side the user ident, and only
-- use /that/ combination to find users. We don't do that here, but it's worth
-- remembering.
--
-- @since 0.1.0.0
type Db = H.HashMap Text User


-- | We will use this type to tag particular routes as being only accessible
-- to users with the 'Admin' role, or, alternatively, /everyone/, i.e. those
-- people having the 'Anyone' role ... namely, everyone!
--
-- @since 0.1.0.0
data Role = Anyone | Admin


-- | Our user type that lives in the database. Importantly, this holds the
-- 'role', which we will check when it comes to verifying if a particular
-- person can access the 'Admin' route.
--
-- @since 0.1.0.0
data User = User
  { User -> Text
email :: Text
  , User -> Text
role  :: Text
  }
  deriving stock (Int -> User -> ShowS
[User] -> ShowS
User -> String
(Int -> User -> ShowS)
-> (User -> String) -> ([User] -> ShowS) -> Show User
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [User] -> ShowS
$cshowList :: [User] -> ShowS
show :: User -> String
$cshow :: User -> String
showsPrec :: Int -> User -> ShowS
$cshowsPrec :: Int -> User -> ShowS
Show)


-- | This is a collection of data that we'll want to have available during
-- page processing; so we will wrap the servant 'Handler' type with a
-- 'ReaderT' over this type.
--
-- @since 0.1.0.0
data Env (r :: Role) = Env
  { forall (r :: Role). Env r -> Maybe User
user              :: Maybe User
  , forall (r :: Role).
Env r
-> OAuth2Settings PageM Github '[WithStatus 303 RedirectWithCookie]
githubSettings    :: OAuth2Settings PageM Github OAuth2Result
  , forall (r :: Role). Env r -> OAuthConfig
githubOAuthConfig :: OAuthConfig
  , forall (r :: Role).
Env r
-> OAuth2Settings PageM Google '[WithStatus 303 RedirectWithCookie]
googleSettings    :: OAuth2Settings PageM Google OAuth2Result
  , forall (r :: Role). Env r -> OAuthConfig
googleOAuthConfig :: OAuthConfig
  }


-- | Our type-level authorisation system. We tag two kinds of /page monads/;
-- one that works for 'Anyone'; this one.
--
-- @since 0.1.0.0
type PageM      = ReaderT (Env 'Anyone) Handler


-- | And this one, that is specialised to 'Admin' users. If we make a mistake,
-- we will get a type error along the lines of @Cannot match 'Admin with
-- 'Anyone@.
--
-- @since 0.1.0.0
type AdminPageM = ReaderT (Env 'Admin)  Handler


-- | As in the "Servant.OAuth2.Examples.Cookies" example, our result type is
-- just a redirection with a cookie.
--
-- @since 0.1.0.0
type OAuth2Result = '[WithStatus 303 RedirectWithCookie]


-- | Again, we exactly follow the "Servant.OAuth2.Examples.Cookies" example.
--
-- @since 0.1.0.0
type instance AuthServerData (AuthProtect Github) = Tag Github OAuth2Result


-- | Same here.
--
-- @since 0.1.0.0
type instance AuthServerData (AuthProtect Google) = Tag Google OAuth2Result


-- | The only difference here is the return a 'User' instead of 'Text'.
--
-- @since 0.1.0.0
type instance AuthServerData (AuthProtect "optional-cookie") = Maybe User


-- | This is almost identical to the "Servant.OAuth2.Examples.Cookies"
-- example, except we look up the user in the database, and if we find it, we
-- return it.
--
-- @since 0.1.0.0
optionalUserAuthHandler :: Db -> Key -> AuthHandler Request (Maybe User)
optionalUserAuthHandler :: Db -> Key -> AuthHandler Request (Maybe User)
optionalUserAuthHandler Db
db Key
key = (Request -> Handler (Maybe User))
-> AuthHandler Request (Maybe User)
forall r usr. (r -> Handler usr) -> AuthHandler r usr
mkAuthHandler Request -> Handler (Maybe User)
f
 where
  f :: Request -> Handler (Maybe User)
  f :: Request -> Handler (Maybe User)
f Request
req = do
    let sessionId :: Maybe Ident
sessionId = Request -> Key -> Maybe Ident
forall s. Binary s => Request -> Key -> Maybe s
getSessionIdFromCookie Request
req Key
key
    -- Here, we know the sessionId is, infact, the email address of the user.
    -- So, we can just look it up in the database.
    Maybe User -> Handler (Maybe User)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe User -> Handler (Maybe User))
-> Maybe User -> Handler (Maybe User)
forall a b. (a -> b) -> a -> b
$ Maybe User -> (Ident -> Maybe User) -> Maybe Ident -> Maybe User
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe User
forall a. Maybe a
Nothing ((Text -> Db -> Maybe User) -> Db -> Text -> Maybe User
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Db -> Maybe User
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Db
db (Text -> Maybe User) -> (Ident -> Text) -> Ident -> Maybe User
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
decodeUtf8) Maybe Ident
sessionId


-- | This follows exactly the "Servant.OAuth2.Examples.Cookies" example; we're
-- using two providers because in the hard-coded `db.txt` file I've set
-- different roles for my own account with different providers; you'll be able
-- to edit that file to do the same.
--
-- @since 0.1.0.0
data Routes mode = Routes
  { forall mode.
Routes mode
-> mode
   :- (AuthProtect "optional-cookie" :> NamedRoutes SiteRoutes)
site :: mode :- AuthProtect "optional-cookie" :> NamedRoutes SiteRoutes
  , forall mode.
Routes mode
-> mode
   :- (AuthProtect Github
       :> ("auth"
           :> ("github"
               :> NamedRoutes
                    (OAuth2Routes '[WithStatus 303 RedirectWithCookie]))))
authGithub ::
      mode
        :- AuthProtect Github
          :> "auth"
          :> "github"
          :> NamedRoutes (OAuth2Routes OAuth2Result)
  , forall mode.
Routes mode
-> mode
   :- (AuthProtect Google
       :> ("auth"
           :> ("google"
               :> NamedRoutes
                    (OAuth2Routes '[WithStatus 303 RedirectWithCookie]))))
authGoogle ::
      mode
        :- AuthProtect Google
          :> "auth"
          :> "google"
          :> NamedRoutes (OAuth2Routes OAuth2Result)
  }
  deriving stock ((forall x. Routes mode -> Rep (Routes mode) x)
-> (forall x. Rep (Routes mode) x -> Routes mode)
-> Generic (Routes mode)
forall x. Rep (Routes mode) x -> Routes mode
forall x. Routes mode -> Rep (Routes mode) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall mode x. Rep (Routes mode) x -> Routes mode
forall mode x. Routes mode -> Rep (Routes mode) x
$cto :: forall mode x. Rep (Routes mode) x -> Routes mode
$cfrom :: forall mode x. Routes mode -> Rep (Routes mode) x
Generic)


-- | We now have a slightly more complicated route setup; we need our
-- homepage, and our admin area, which we will aim to protect with our
-- type-level tags; we also need a 'logout' route, because it'll be convenient
-- for testing. This route will simply delete the present cookie.
--
-- @since 0.1.0.0
data SiteRoutes mode = SiteRoutes
  { forall mode. SiteRoutes mode -> mode :- Verb 'GET 200 '[HTML] Html
home   :: mode :- Get '[HTML] Html
  , forall mode.
SiteRoutes mode -> mode :- ("admin" :> NamedRoutes AdminRoutes)
admin  :: mode :- "admin" :> NamedRoutes AdminRoutes
  , forall mode.
SiteRoutes mode
-> mode
   :- ("logout"
       :> UVerb 'GET '[HTML] '[WithStatus 303 RedirectWithCookie])
logout :: mode :- "logout" :> UVerb 'GET '[HTML] '[WithStatus 303 RedirectWithCookie]
  }
  deriving stock ((forall x. SiteRoutes mode -> Rep (SiteRoutes mode) x)
-> (forall x. Rep (SiteRoutes mode) x -> SiteRoutes mode)
-> Generic (SiteRoutes mode)
forall x. Rep (SiteRoutes mode) x -> SiteRoutes mode
forall x. SiteRoutes mode -> Rep (SiteRoutes mode) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall mode x. Rep (SiteRoutes mode) x -> SiteRoutes mode
forall mode x. SiteRoutes mode -> Rep (SiteRoutes mode) x
$cto :: forall mode x. Rep (SiteRoutes mode) x -> SiteRoutes mode
$cfrom :: forall mode x. SiteRoutes mode -> Rep (SiteRoutes mode) x
Generic)


-- | Nothing too innovative; we just pass off to respective handlers and
-- servers; in the 'logout' route we set an empty cookie and redirect home.
--
-- @since 0.1.0.0
siteServer :: SiteRoutes (AsServerT PageM)
siteServer :: SiteRoutes (AsServerT PageM)
siteServer = SiteRoutes :: forall mode.
(mode :- Verb 'GET 200 '[HTML] Html)
-> (mode :- ("admin" :> NamedRoutes AdminRoutes))
-> (mode
    :- ("logout"
        :> UVerb 'GET '[HTML] '[WithStatus 303 RedirectWithCookie]))
-> SiteRoutes mode
SiteRoutes
  { home :: AsServerT PageM :- Verb 'GET 200 '[HTML] Html
home   = PageM Html
AsServerT PageM :- Verb 'GET 200 '[HTML] Html
homeHandler
  , admin :: AsServerT PageM :- ("admin" :> NamedRoutes AdminRoutes)
admin  = ServerT (NamedRoutes AdminRoutes) PageM
AsServerT PageM :- ("admin" :> NamedRoutes AdminRoutes)
adminServer
  , logout :: AsServerT PageM
:- ("logout"
    :> UVerb 'GET '[HTML] '[WithStatus 303 RedirectWithCookie])
logout = WithStatus 303 RedirectWithCookie
-> ReaderT
     (Env 'Anyone) Handler (Union '[WithStatus 303 RedirectWithCookie])
forall x (xs :: [*]) (f :: * -> *).
(Applicative f, HasStatus x, IsMember x xs) =>
x -> f (Union xs)
respond (WithStatus 303 RedirectWithCookie
 -> ReaderT
      (Env 'Anyone) Handler (Union '[WithStatus 303 RedirectWithCookie]))
-> WithStatus 303 RedirectWithCookie
-> ReaderT
     (Env 'Anyone) Handler (Union '[WithStatus 303 RedirectWithCookie])
forall a b. (a -> b) -> a -> b
$ forall (k :: Nat) a. a -> WithStatus k a
WithStatus @303 (Text -> SetCookie -> RedirectWithCookie
redirectWithCookie Text
"/" SetCookie
emptyCookie)
  }


-- | Our admin routes. At this point they look normal.
--
-- @since 0.1.0.0
data AdminRoutes mode = AdminRoutes
  { forall mode. AdminRoutes mode -> mode :- Verb 'GET 200 '[HTML] Html
adminHome :: mode :- Get '[HTML] Html
  }
  deriving stock ((forall x. AdminRoutes mode -> Rep (AdminRoutes mode) x)
-> (forall x. Rep (AdminRoutes mode) x -> AdminRoutes mode)
-> Generic (AdminRoutes mode)
forall x. Rep (AdminRoutes mode) x -> AdminRoutes mode
forall x. AdminRoutes mode -> Rep (AdminRoutes mode) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall mode x. Rep (AdminRoutes mode) x -> AdminRoutes mode
forall mode x. AdminRoutes mode -> Rep (AdminRoutes mode) x
$cto :: forall mode x. Rep (AdminRoutes mode) x -> AdminRoutes mode
$cfrom :: forall mode x. AdminRoutes mode -> Rep (AdminRoutes mode) x
Generic)


-- | Here is where we introduce the 'AdminPageM' type. Typically, a handler
-- like this would have type 'Handler'; but here we're denoting it as having
-- the 'AdminPageM' type. This means we can call specific functions, that we
-- will define below, such as 'getAdmin'. Importantly, we will see that we
-- need to unwrap this type (by verifying the current user!) before we can
-- render this page.
--
-- @since 0.1.0.0
adminHandler :: AdminPageM Html
adminHandler :: AdminPageM Html
adminHandler = do
  let secrets :: [Text]
secrets =
        [ Text
"secret 1" :: Text
        , Text
"mundane secret 2"
        , Text
"you can't know this"
        ]
  User
u <- AdminPageM User
getAdmin
  Html -> AdminPageM Html
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [shamlet|
      <h3> Admin
      <p> Secrets:

      <ul>
        $forall secret <- secrets
          <li> #{secret}

      <p> 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 :: ServerT (NamedRoutes AdminRoutes) (ReaderT (Env 'Admin) Handler)
-> ServerT (NamedRoutes AdminRoutes) PageM
verifyAdmin = Proxy (NamedRoutes AdminRoutes)
-> (forall x.
    ReaderT (Env 'Admin) Handler x -> ReaderT (Env 'Anyone) Handler x)
-> ServerT (NamedRoutes AdminRoutes) (ReaderT (Env 'Admin) Handler)
-> ServerT (NamedRoutes AdminRoutes) PageM
forall api (m :: * -> *) (n :: * -> *).
HasServer api '[] =>
Proxy api
-> (forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServer (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(NamedRoutes AdminRoutes)) forall x.
ReaderT (Env 'Admin) Handler x -> ReaderT (Env 'Anyone) Handler x
transform
  where
    transform :: AdminPageM a -> PageM a
    transform :: forall x.
ReaderT (Env 'Admin) Handler x -> ReaderT (Env 'Anyone) Handler x
transform AdminPageM a
p = do
      Env 'Anyone
env <- ReaderT (Env 'Anyone) Handler (Env 'Anyone)
forall r (m :: * -> *). MonadReader r m => m r
ask
      let currentUser :: Maybe User
currentUser = Env 'Anyone -> Maybe User
forall (r :: Role). Env r -> Maybe User
user Env 'Anyone
env
      if Maybe User -> Bool
isAdmin Maybe User
currentUser
         then AdminPageM a -> ReaderT (Env 'Anyone) Handler a
coerce AdminPageM a
p
         else ServerError -> ReaderT (Env 'Anyone) Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
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 :: ServerT (NamedRoutes AdminRoutes) PageM
adminServer = ServerT (NamedRoutes AdminRoutes) (ReaderT (Env 'Admin) Handler)
-> ServerT (NamedRoutes AdminRoutes) PageM
verifyAdmin (ServerT (NamedRoutes AdminRoutes) (ReaderT (Env 'Admin) Handler)
 -> ServerT (NamedRoutes AdminRoutes) PageM)
-> ServerT (NamedRoutes AdminRoutes) (ReaderT (Env 'Admin) Handler)
-> ServerT (NamedRoutes AdminRoutes) PageM
forall a b. (a -> b) -> a -> b
$ AdminRoutes :: forall mode.
(mode :- Verb 'GET 200 '[HTML] Html) -> AdminRoutes mode
AdminRoutes
  { adminHome :: AsServerT (ReaderT (Env 'Admin) Handler)
:- Verb 'GET 200 '[HTML] Html
adminHome = AdminPageM Html
AsServerT (ReaderT (Env 'Admin) Handler)
:- Verb 'GET 200 '[HTML] Html
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 :: Maybe User -> Bool
isAdmin (Just User {Text
role :: Text
role :: User -> Text
role}) = Text
role Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"admin"
isAdmin Maybe User
_ = Bool
False


-- | Check if a user is present and therefore logged in.
--
-- @since 0.1.0.0
isLoggedIn :: PageM Bool
isLoggedIn :: PageM Bool
isLoggedIn = Maybe User -> Bool
forall a. Maybe a -> Bool
isJust (Maybe User -> Bool)
-> ReaderT (Env 'Anyone) Handler (Maybe User) -> PageM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (Env 'Anyone) Handler (Maybe User)
getUser


-- | 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 :: ReaderT (Env 'Anyone) Handler (Maybe User)
getUser = Env 'Anyone -> Maybe User
forall (r :: Role). Env r -> Maybe User
user (Env 'Anyone -> Maybe User)
-> ReaderT (Env 'Anyone) Handler (Env 'Anyone)
-> ReaderT (Env 'Anyone) Handler (Maybe User)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (Env 'Anyone) Handler (Env 'Anyone)
forall r (m :: * -> *). MonadReader r m => m r
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 :: AdminPageM User
getAdmin = Maybe User -> User
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe User -> User)
-> (Env 'Admin -> Maybe User) -> Env 'Admin -> User
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env 'Admin -> Maybe User
forall (r :: Role). Env r -> Maybe User
user (Env 'Admin -> User)
-> ReaderT (Env 'Admin) Handler (Env 'Admin) -> AdminPageM User
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (Env 'Admin) Handler (Env 'Admin)
forall r (m :: * -> *). MonadReader r m => m r
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 :: PageM Html
homeHandler = do
  Env 'Anyone
env <- ReaderT (Env 'Anyone) Handler (Env 'Anyone)
forall r (m :: * -> *). MonadReader r m => m r
ask

  let githubCallbackUrl :: Text
githubCallbackUrl = OAuthConfig -> Text
_callbackUrl (OAuthConfig -> Text) -> OAuthConfig -> Text
forall a b. (a -> b) -> a -> b
$ Env 'Anyone -> OAuthConfig
forall (r :: Role). Env r -> OAuthConfig
githubOAuthConfig Env 'Anyone
env
      githubLoginUrl :: Text
githubLoginUrl = Text
-> OAuth2Settings PageM Github '[WithStatus 303 RedirectWithCookie]
-> Text
forall (m :: * -> *) (a :: [*]).
Text -> OAuth2Settings m Github a -> Text
getGithubLoginUrl Text
githubCallbackUrl (Env 'Anyone
-> OAuth2Settings PageM Github '[WithStatus 303 RedirectWithCookie]
forall (r :: Role).
Env r
-> OAuth2Settings PageM Github '[WithStatus 303 RedirectWithCookie]
githubSettings Env 'Anyone
env)

  let googleCallbackUrl :: Text
googleCallbackUrl = OAuthConfig -> Text
_callbackUrl (OAuthConfig -> Text) -> OAuthConfig -> Text
forall a b. (a -> b) -> a -> b
$ Env 'Anyone -> OAuthConfig
forall (r :: Role). Env r -> OAuthConfig
googleOAuthConfig Env 'Anyone
env
      googleLoginUrl :: Text
googleLoginUrl = Text
-> OAuth2Settings PageM Google '[WithStatus 303 RedirectWithCookie]
-> Text
forall (m :: * -> *) (a :: [*]).
Text -> OAuth2Settings m Google a -> Text
getGoogleLoginUrl Text
googleCallbackUrl (Env 'Anyone
-> OAuth2Settings PageM Google '[WithStatus 303 RedirectWithCookie]
forall (r :: Role).
Env r
-> OAuth2Settings PageM Google '[WithStatus 303 RedirectWithCookie]
googleSettings Env 'Anyone
env)

  Bool
loggedIn <- PageM Bool
isLoggedIn
  Maybe User
u <- ReaderT (Env 'Anyone) Handler (Maybe User)
getUser
  Html -> PageM Html
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [shamlet|
      <h3> Home - Example with authorisation

      $if not loggedIn
        <p>
          <a href="#{githubLoginUrl}"> Login with Github
          <br>
          <a href="#{googleLoginUrl}"> Login with Google
      $else
        Welcome #{show u}!
        <p>
          <a href="/logout"> Logout

      $if isAdmin u
        <p>
          <a href="/admin"> Access the admin area!
      $else
        <p>
          You're not an admin, but perhaps you may like to
          <a href="/admin"> 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 (AsServerT PageM)
server =
  Routes :: forall mode.
(mode :- (AuthProtect "optional-cookie" :> NamedRoutes SiteRoutes))
-> (mode
    :- (AuthProtect Github
        :> ("auth"
            :> ("github"
                :> NamedRoutes
                     (OAuth2Routes '[WithStatus 303 RedirectWithCookie])))))
-> (mode
    :- (AuthProtect Google
        :> ("auth"
            :> ("google"
                :> NamedRoutes
                     (OAuth2Routes '[WithStatus 303 RedirectWithCookie])))))
-> Routes mode
Routes
    { site :: AsServerT PageM
:- (AuthProtect "optional-cookie" :> NamedRoutes SiteRoutes)
site = \Maybe User
user ->
        let addUser :: Env 'Anyone -> Env 'Anyone
addUser Env 'Anyone
env = Env 'Anyone
env { user :: Maybe User
user = Maybe User
user }
        in Proxy (NamedRoutes SiteRoutes)
-> (forall x.
    ReaderT (Env 'Anyone) Handler x -> ReaderT (Env 'Anyone) Handler x)
-> ServerT (NamedRoutes SiteRoutes) PageM
-> ServerT (NamedRoutes SiteRoutes) PageM
forall api (m :: * -> *) (n :: * -> *).
HasServer api '[] =>
Proxy api
-> (forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServer
            (forall {t}. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(NamedRoutes SiteRoutes))
            ((Env 'Anyone -> Env 'Anyone)
-> ReaderT (Env 'Anyone) Handler x
-> ReaderT (Env 'Anyone) Handler x
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT Env 'Anyone -> Env 'Anyone
addUser)
            ServerT (NamedRoutes SiteRoutes) PageM
SiteRoutes (AsServerT PageM)
siteServer
    , authGithub :: AsServerT PageM
:- (AuthProtect Github
    :> ("auth"
        :> ("github"
            :> NamedRoutes
                 (OAuth2Routes '[WithStatus 303 RedirectWithCookie]))))
authGithub = AsServerT PageM
:- (AuthProtect Github
    :> ("auth"
        :> ("github"
            :> NamedRoutes
                 (OAuth2Routes '[WithStatus 303 RedirectWithCookie]))))
forall (m :: * -> *) a (rs :: [*]).
Monad m =>
Tag a rs -> OAuth2Routes rs (AsServerT m)
authServer
    , authGoogle :: AsServerT PageM
:- (AuthProtect Google
    :> ("auth"
        :> ("google"
            :> NamedRoutes
                 (OAuth2Routes '[WithStatus 303 RedirectWithCookie]))))
authGoogle = AsServerT PageM
:- (AuthProtect Google
    :> ("auth"
        :> ("google"
            :> NamedRoutes
                 (OAuth2Routes '[WithStatus 303 RedirectWithCookie]))))
forall (m :: * -> *) a (rs :: [*]).
Monad m =>
Tag a rs -> OAuth2Routes rs (AsServerT m)
authServer
    }


-- | Our usual approach for 'Github' settings.
--
-- @since 0.1.0.0
mkGithubSettings :: Key -> OAuthConfig -> OAuth2Settings PageM Github OAuth2Result
mkGithubSettings :: Key
-> OAuthConfig
-> OAuth2Settings PageM Github '[WithStatus 303 RedirectWithCookie]
mkGithubSettings Key
key OAuthConfig
c = OAuth2Settings PageM Github '[WithStatus 303 RedirectWithCookie]
settings
 where
  toSessionId :: p -> a -> f a
toSessionId p
_ = a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  provider :: Github
provider = Text -> Text -> Text -> [Ident] -> Maybe ProviderInfo -> Github
mkGithubProvider (OAuthConfig -> Text
_name OAuthConfig
c) (OAuthConfig -> Text
_id OAuthConfig
c) (OAuthConfig -> Text
_secret OAuthConfig
c) [Ident]
emailAllowList Maybe ProviderInfo
forall a. Maybe a
Nothing
  settings :: OAuth2Settings PageM Github '[WithStatus 303 RedirectWithCookie]
settings = Github
-> (Request -> Ident -> PageM Ident)
-> Key
-> OAuth2Settings PageM Github '[WithStatus 303 RedirectWithCookie]
forall s (m :: * -> *) p.
(Binary s, Applicative m, Monad m, MonadIO m) =>
p
-> (Request -> Ident -> m s)
-> Key
-> OAuth2Settings m p '[WithStatus 303 RedirectWithCookie]
simpleCookieOAuth2Settings Github
provider Request -> Ident -> PageM Ident
forall {f :: * -> *} {p} {a}. Applicative f => p -> a -> f a
toSessionId Key
key
  emailAllowList :: [Ident]
emailAllowList = [Ident
".*"]


-- | Our usual approach for 'Google' settings.
--
-- @since 0.1.0.0
mkGoogleSettings :: Key -> OAuthConfig -> OAuth2Settings PageM Google OAuth2Result
mkGoogleSettings :: Key
-> OAuthConfig
-> OAuth2Settings PageM Google '[WithStatus 303 RedirectWithCookie]
mkGoogleSettings Key
key OAuthConfig
c = OAuth2Settings PageM Google '[WithStatus 303 RedirectWithCookie]
settings
 where
  toSessionId :: p -> a -> f a
toSessionId p
_ = a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  provider :: Google
provider = Text -> Text -> [Ident] -> Maybe ProviderInfo -> Google
mkGoogleProvider (OAuthConfig -> Text
_id OAuthConfig
c) (OAuthConfig -> Text
_secret OAuthConfig
c) [Ident]
emailAllowList Maybe ProviderInfo
forall a. Maybe a
Nothing
  settings :: OAuth2Settings PageM Google '[WithStatus 303 RedirectWithCookie]
settings = Google
-> (Request -> Ident -> PageM Ident)
-> Key
-> OAuth2Settings PageM Google '[WithStatus 303 RedirectWithCookie]
forall s (m :: * -> *) p.
(Binary s, Applicative m, Monad m, MonadIO m) =>
p
-> (Request -> Ident -> m s)
-> Key
-> OAuth2Settings m p '[WithStatus 303 RedirectWithCookie]
simpleCookieOAuth2Settings Google
provider Request -> Ident -> PageM Ident
forall {f :: * -> *} {p} {a}. Applicative f => p -> a -> f a
toSessionId Key
key
  emailAllowList :: [Ident]
emailAllowList = [Ident
".*"]


-- | 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 :: IO ()
main = do
  Either [TomlDecodeError] Config
eitherConfig <- TomlCodec Config -> String -> IO (Either [TomlDecodeError] Config)
forall a (m :: * -> *).
MonadIO m =>
TomlCodec a -> String -> m (Either [TomlDecodeError] a)
decodeFileExact TomlCodec Config
configCodec String
"./config.toml"
  Config
config <-
    ([TomlDecodeError] -> IO Config)
-> (Config -> IO Config)
-> Either [TomlDecodeError] Config
-> IO Config
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
      (\[TomlDecodeError]
errors -> String -> IO Config
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Config) -> String -> IO Config
forall a b. (a -> b) -> a -> b
$ String
"unable to parse configuration: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [TomlDecodeError] -> String
forall a. Show a => a -> String
show [TomlDecodeError]
errors)
      Config -> IO Config
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      Either [TomlDecodeError] Config
eitherConfig

  Key
key <- IO Key
getDefaultKey
  Db
db <- IO Db
loadDb

  let nat :: PageM a -> Handler a
      nat :: forall a. PageM a -> Handler a
nat = (ReaderT (Env 'Anyone) Handler a -> Env 'Anyone -> Handler a)
-> Env 'Anyone -> ReaderT (Env 'Anyone) Handler a -> Handler a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (Env 'Anyone) Handler a -> Env 'Anyone -> Handler a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Env 'Anyone
env
      githubSettings :: OAuth2Settings PageM Github '[WithStatus 303 RedirectWithCookie]
githubSettings = Key
-> OAuthConfig
-> OAuth2Settings PageM Github '[WithStatus 303 RedirectWithCookie]
mkGithubSettings Key
key (Config -> OAuthConfig
_githubOAuth Config
config)
      googleSettings :: OAuth2Settings PageM Google '[WithStatus 303 RedirectWithCookie]
googleSettings = Key
-> OAuthConfig
-> OAuth2Settings PageM Google '[WithStatus 303 RedirectWithCookie]
mkGoogleSettings Key
key (Config -> OAuthConfig
_googleOAuth Config
config)
      env :: Env 'Anyone
env = Maybe User
-> OAuth2Settings PageM Github '[WithStatus 303 RedirectWithCookie]
-> OAuthConfig
-> OAuth2Settings PageM Google '[WithStatus 303 RedirectWithCookie]
-> OAuthConfig
-> Env 'Anyone
forall (r :: Role).
Maybe User
-> OAuth2Settings PageM Github '[WithStatus 303 RedirectWithCookie]
-> OAuthConfig
-> OAuth2Settings PageM Google '[WithStatus 303 RedirectWithCookie]
-> OAuthConfig
-> Env r
Env Maybe User
forall a. Maybe a
Nothing
              OAuth2Settings PageM Github '[WithStatus 303 RedirectWithCookie]
githubSettings (Config -> OAuthConfig
_githubOAuth Config
config)
              OAuth2Settings PageM Google '[WithStatus 303 RedirectWithCookie]
googleSettings (Config -> OAuthConfig
_googleOAuth Config
config)
      context :: Context
  '[AuthHandler Request (Maybe User),
    AuthHandler
      Request (Tag Github '[WithStatus 303 RedirectWithCookie]),
    AuthHandler
      Request (Tag Google '[WithStatus 303 RedirectWithCookie])]
context
        =  Db -> Key -> AuthHandler Request (Maybe User)
optionalUserAuthHandler Db
db Key
key
        AuthHandler Request (Maybe User)
-> Context
     '[AuthHandler
         Request (Tag Github '[WithStatus 303 RedirectWithCookie]),
       AuthHandler
         Request (Tag Google '[WithStatus 303 RedirectWithCookie])]
-> Context
     '[AuthHandler Request (Maybe User),
       AuthHandler
         Request (Tag Github '[WithStatus 303 RedirectWithCookie]),
       AuthHandler
         Request (Tag Google '[WithStatus 303 RedirectWithCookie])]
forall x (xs :: [*]). x -> Context xs -> Context (x : xs)
:. OAuth2Settings PageM Github '[WithStatus 303 RedirectWithCookie]
-> (PageM (Tag Github '[WithStatus 303 RedirectWithCookie])
    -> Handler (Tag Github '[WithStatus 303 RedirectWithCookie]))
-> AuthHandler
     Request (Tag Github '[WithStatus 303 RedirectWithCookie])
forall (m :: * -> *) p (rs :: [*]) e.
(AuthProvider p, MonadIO m, MonadThrow m, MonadError e m,
 Monad m) =>
OAuth2Settings m p rs
-> (m (Tag p rs) -> Handler (Tag p rs))
-> AuthHandler Request (Tag p rs)
oauth2AuthHandler OAuth2Settings PageM Github '[WithStatus 303 RedirectWithCookie]
githubSettings PageM (Tag Github '[WithStatus 303 RedirectWithCookie])
-> Handler (Tag Github '[WithStatus 303 RedirectWithCookie])
forall a. PageM a -> Handler a
nat
        AuthHandler
  Request (Tag Github '[WithStatus 303 RedirectWithCookie])
-> Context
     '[AuthHandler
         Request (Tag Google '[WithStatus 303 RedirectWithCookie])]
-> Context
     '[AuthHandler
         Request (Tag Github '[WithStatus 303 RedirectWithCookie]),
       AuthHandler
         Request (Tag Google '[WithStatus 303 RedirectWithCookie])]
forall x (xs :: [*]). x -> Context xs -> Context (x : xs)
:. OAuth2Settings PageM Google '[WithStatus 303 RedirectWithCookie]
-> (PageM (Tag Google '[WithStatus 303 RedirectWithCookie])
    -> Handler (Tag Google '[WithStatus 303 RedirectWithCookie]))
-> AuthHandler
     Request (Tag Google '[WithStatus 303 RedirectWithCookie])
forall (m :: * -> *) p (rs :: [*]) e.
(AuthProvider p, MonadIO m, MonadThrow m, MonadError e m,
 Monad m) =>
OAuth2Settings m p rs
-> (m (Tag p rs) -> Handler (Tag p rs))
-> AuthHandler Request (Tag p rs)
oauth2AuthHandler OAuth2Settings PageM Google '[WithStatus 303 RedirectWithCookie]
googleSettings PageM (Tag Google '[WithStatus 303 RedirectWithCookie])
-> Handler (Tag Google '[WithStatus 303 RedirectWithCookie])
forall a. PageM a -> Handler a
nat
        AuthHandler
  Request (Tag Google '[WithStatus 303 RedirectWithCookie])
-> Context '[]
-> Context
     '[AuthHandler
         Request (Tag Google '[WithStatus 303 RedirectWithCookie])]
forall x (xs :: [*]). x -> Context xs -> Context (x : xs)
:. Context '[]
EmptyContext


  String -> IO ()
putStrLn String
"Waiting for connections!"
  Int -> Application -> IO ()
run Int
8080 (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$
    (forall a. PageM a -> Handler a)
-> Routes (AsServerT PageM)
-> Context
     '[AuthHandler Request (Maybe User),
       AuthHandler
         Request (Tag Github '[WithStatus 303 RedirectWithCookie]),
       AuthHandler
         Request (Tag Google '[WithStatus 303 RedirectWithCookie])]
-> Application
forall (routes :: * -> *) (m :: * -> *) (ctx :: [*]).
(GenericServant routes (AsServerT m), GenericServant routes AsApi,
 HasServer (ToServantApi routes) ctx,
 HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters,
 ServerT (ToServantApi routes) m
 ~ ToServant routes (AsServerT m)) =>
(forall a. m a -> Handler a)
-> routes (AsServerT m) -> Context ctx -> Application
genericServeTWithContext forall a. PageM a -> Handler a
nat Routes (AsServerT PageM)
server Context
  '[AuthHandler Request (Maybe User),
    AuthHandler
      Request (Tag Github '[WithStatus 303 RedirectWithCookie]),
    AuthHandler
      Request (Tag Google '[WithStatus 303 RedirectWithCookie])]
context


-- | Utility function to load the hard-coded database.
--
-- @since 0.1.0.0
loadDb :: IO Db
loadDb :: IO Db
loadDb = do
  [Text]
ls <- Text -> [Text]
Text.lines (Text -> [Text]) -> IO Text -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
Text.readFile String
"./servant-oauth2-examples/example-auth/db.txt"
  let raw :: [[Text]]
raw = (Text -> [Text]) -> [Text] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> Text -> [Text]
Text.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
',')) [Text]
ls
      mkRow :: [Text] -> (Text, User)
mkRow [Text
u,Text
r] = (Text
u, Text -> Text -> User
User Text
u Text
r)
      mkRow [Text]
_ = String -> (Text, User)
forall a. HasCallStack => String -> a
error String
"Inconsistent database state."
  Db -> IO Db
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Db -> IO Db) -> Db -> IO Db
forall a b. (a -> b) -> a -> b
$ [(Text, User)] -> Db
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList ([(Text, User)] -> Db) -> [(Text, User)] -> Db
forall a b. (a -> b) -> a -> b
$ ([Text] -> (Text, User)) -> [[Text]] -> [(Text, User)]
forall a b. (a -> b) -> [a] -> [b]
map [Text] -> (Text, User)
mkRow [[Text]]
raw