{-# 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 -> AuthHandler Request (Maybe Text)
optionalUserAuthHandler Key
key = (Request -> Handler (Maybe Text))
-> AuthHandler Request (Maybe Text)
forall r usr. (r -> Handler usr) -> AuthHandler r usr
mkAuthHandler Request -> Handler (Maybe Text)
f
 where
  f :: Request -> Handler (Maybe Text)
  f :: Request -> Handler (Maybe Text)
f Request
req = do
    let sessionId :: Maybe Text
sessionId = Request -> Key -> Maybe Text
forall s. Binary s => Request -> Key -> Maybe s
getSessionIdFromCookie Request
req Key
key
    Maybe Text -> Handler (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
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
  { forall mode.
Routes mode
-> mode
   :- (AuthProtect "optional-cookie" :> Get '[HTML] (MarkupM ()))
home :: mode :- AuthProtect "optional-cookie" :> Get '[HTML] Html
  , forall mode.
Routes mode
-> mode
   :- (AuthProtect Github
       :> ("auth"
           :> ("github" :> NamedRoutes (OAuth2Routes OAuth2Result))))
auth ::
      mode
        :- AuthProtect Github
          :> "auth"
          :> "github"
          :> 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)


-- | 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 -> OAuthConfig -> OAuth2Settings Handler Github OAuth2Result
mkSettings Key
key OAuthConfig
c = OAuth2Settings Handler Github OAuth2Result
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 Handler Github OAuth2Result
settings = Github
-> (Request -> Ident -> Handler Ident)
-> Key
-> OAuth2Settings Handler Github OAuth2Result
forall s (m :: * -> *) p.
(Binary s, Applicative m, Monad m, MonadIO m) =>
p
-> (Request -> Ident -> m s)
-> Key
-> OAuth2Settings m p OAuth2Result
simpleCookieOAuth2Settings Github
provider Request -> Ident -> Handler Ident
forall {f :: * -> *} {p} {a}. Applicative f => p -> a -> f a
toSessionId Key
key
  emailAllowList :: [Ident]
emailAllowList = [Ident
".*"]


-- | 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
-> OAuth2Settings Handler Github OAuth2Result
-> Routes (AsServerT Handler)
server OAuthConfig {Text
_callbackUrl :: OAuthConfig -> Text
_callbackUrl :: Text
_callbackUrl} OAuth2Settings Handler Github OAuth2Result
settings =
  Routes :: forall mode.
(mode
 :- (AuthProtect "optional-cookie" :> Get '[HTML] (MarkupM ())))
-> (mode
    :- (AuthProtect Github
        :> ("auth"
            :> ("github" :> NamedRoutes (OAuth2Routes OAuth2Result)))))
-> Routes mode
Routes
    { home :: AsServerT Handler
:- (AuthProtect "optional-cookie" :> Get '[HTML] (MarkupM ()))
home = \Maybe Text
user -> do
        let githubLoginUrl :: Text
githubLoginUrl = Text -> OAuth2Settings Handler Github OAuth2Result -> Text
forall (m :: * -> *) (a :: [*]).
Text -> OAuth2Settings m Github a -> Text
getGithubLoginUrl Text
_callbackUrl OAuth2Settings Handler Github OAuth2Result
settings
            loggedIn :: Bool
loggedIn = Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
user
        MarkupM () -> Handler (MarkupM ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          [shamlet|
            <h3> Home - Example with Cookies
            <p>
                $if not loggedIn
                  <a href="#{githubLoginUrl}"> Login
                $else
                  Welcome #{fromJust user}!
          |]
    , auth :: AsServerT Handler
:- (AuthProtect Github
    :> ("auth"
        :> ("github" :> NamedRoutes (OAuth2Routes OAuth2Result))))
auth = AsServerT Handler
:- (AuthProtect Github
    :> ("auth"
        :> ("github" :> NamedRoutes (OAuth2Routes OAuth2Result))))
forall (m :: * -> *) a (rs :: [*]).
Monad m =>
Tag a rs -> OAuth2Routes rs (AsServerT m)
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 :: 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 -> String -> String
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

  let ghSettings :: OAuth2Settings Handler Github OAuth2Result
ghSettings = Key -> OAuthConfig -> OAuth2Settings Handler Github OAuth2Result
mkSettings Key
key (Config -> OAuthConfig
_githubOAuth Config
config)
      context :: Context
  '[AuthHandler Request (Maybe Text),
    AuthHandler Request (Tag Github OAuth2Result)]
context =  Key -> AuthHandler Request (Maybe Text)
optionalUserAuthHandler Key
key
              AuthHandler Request (Maybe Text)
-> Context '[AuthHandler Request (Tag Github OAuth2Result)]
-> Context
     '[AuthHandler Request (Maybe Text),
       AuthHandler Request (Tag Github OAuth2Result)]
forall x (xs :: [*]). x -> Context xs -> Context (x : xs)
:. OAuth2Settings Handler Github OAuth2Result
-> (Handler (Tag Github OAuth2Result)
    -> Handler (Tag Github OAuth2Result))
-> AuthHandler Request (Tag Github OAuth2Result)
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 Handler Github OAuth2Result
ghSettings Handler (Tag Github OAuth2Result)
-> Handler (Tag Github OAuth2Result)
forall a. a -> a
nat
              AuthHandler Request (Tag Github OAuth2Result)
-> Context '[]
-> Context '[AuthHandler Request (Tag Github OAuth2Result)]
forall x (xs :: [*]). x -> Context xs -> Context (x : xs)
:. Context '[]
EmptyContext
      nat :: a -> a
nat = a -> a
forall a. a -> a
id

  String -> IO ()
putStrLn String
"Waiting for connections!"
  Port -> Application -> IO ()
run Port
8080 (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$
    (forall a. Handler a -> Handler a)
-> Routes (AsServerT Handler)
-> Context
     '[AuthHandler Request (Maybe Text),
       AuthHandler Request (Tag Github OAuth2Result)]
-> 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. a -> a
forall a. Handler a -> Handler a
nat (OAuthConfig
-> OAuth2Settings Handler Github OAuth2Result
-> Routes (AsServerT Handler)
server (Config -> OAuthConfig
_githubOAuth Config
config) OAuth2Settings Handler Github OAuth2Result
ghSettings) Context
  '[AuthHandler Request (Maybe Text),
    AuthHandler Request (Tag Github OAuth2Result)]
context