{-# 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
  { forall mode.
Routes mode -> mode :- Verb 'GET 200 '[HTML] (MarkupM ())
home :: mode :- Get '[HTML] Html
  , forall mode.
Routes mode
-> mode
   :- (AuthProtect Github
       :> ("auth"
           :> ("github" :> NamedRoutes (OAuth2Routes OAuth2Result))))
authGithub ::
      mode
        :- AuthProtect Github
          :> "auth"
          :> "github"
          :> NamedRoutes (OAuth2Routes OAuth2Result)
  , forall mode.
Routes mode
-> mode
   :- (AuthProtect Google
       :> ("auth"
           :> ("google" :> NamedRoutes (OAuth2Routes OAuth2Result))))
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 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 :: OAuthConfig -> OAuth2Settings Handler Github OAuth2Result
mkGithubSettings OAuthConfig
c =
  Github -> OAuth2Settings Handler Github OAuth2Result
forall (m :: * -> *) p.
Applicative m =>
p -> OAuth2Settings m p OAuth2Result
defaultOAuth2Settings (Github -> OAuth2Settings Handler Github OAuth2Result)
-> Github -> OAuth2Settings Handler Github OAuth2Result
forall a b. (a -> b) -> a -> b
$
    Text
-> Text -> Text -> [ByteString] -> Maybe ProviderInfo -> Github
mkGithubProvider (OAuthConfig -> Text
_name OAuthConfig
c) (OAuthConfig -> Text
_id OAuthConfig
c) (OAuthConfig -> Text
_secret OAuthConfig
c) [ByteString]
emailAllowList Maybe ProviderInfo
forall a. Maybe a
Nothing
 where
  emailAllowList :: [ByteString]
emailAllowList = [ByteString
".*"]


-- | Exactly the same as 'mkGithubSettings' but for the 'Google' provider.
--
-- @since 0.1.0.0
mkGoogleSettings :: OAuthConfig -> OAuth2Settings Handler Google OAuth2Result
mkGoogleSettings :: OAuthConfig -> OAuth2Settings Handler Google OAuth2Result
mkGoogleSettings OAuthConfig
c =
  Google -> OAuth2Settings Handler Google OAuth2Result
forall (m :: * -> *) p.
Applicative m =>
p -> OAuth2Settings m p OAuth2Result
defaultOAuth2Settings (Google -> OAuth2Settings Handler Google OAuth2Result)
-> Google -> OAuth2Settings Handler Google OAuth2Result
forall a b. (a -> b) -> a -> b
$
    Text -> Text -> [ByteString] -> Maybe ProviderInfo -> Google
mkGoogleProvider (OAuthConfig -> Text
_id OAuthConfig
c) (OAuthConfig -> Text
_secret OAuthConfig
c) [ByteString]
emailAllowList Maybe ProviderInfo
forall a. Maybe a
Nothing
 where
  emailAllowList :: [ByteString]
emailAllowList = [ByteString
".*"]


-- | 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 :: Text
-> OAuth2Settings Handler Github OAuth2Result
-> Text
-> OAuth2Settings Handler Google OAuth2Result
-> Routes (AsServerT Handler)
server Text
githubCallbackUrl OAuth2Settings Handler Github OAuth2Result
githubSettings Text
googleCallbackUrl OAuth2Settings Handler Google OAuth2Result
googleSettings =
  Routes :: forall mode.
(mode :- Verb 'GET 200 '[HTML] (MarkupM ()))
-> (mode
    :- (AuthProtect Github
        :> ("auth"
            :> ("github" :> NamedRoutes (OAuth2Routes OAuth2Result)))))
-> (mode
    :- (AuthProtect Google
        :> ("auth"
            :> ("google" :> NamedRoutes (OAuth2Routes OAuth2Result)))))
-> Routes mode
Routes
    { home :: AsServerT Handler :- Verb 'GET 200 '[HTML] (MarkupM ())
home = do
        let githubLoginUrl :: Text
githubLoginUrl = Text -> OAuth2Settings Handler Github OAuth2Result -> Text
forall (m :: * -> *) (a :: [*]).
Text -> OAuth2Settings m Github a -> Text
getGithubLoginUrl Text
githubCallbackUrl OAuth2Settings Handler Github OAuth2Result
githubSettings
            googleLoginUrl :: Text
googleLoginUrl = Text -> OAuth2Settings Handler Google OAuth2Result -> Text
forall (m :: * -> *) (a :: [*]).
Text -> OAuth2Settings m Google a -> Text
getGoogleLoginUrl Text
googleCallbackUrl OAuth2Settings Handler Google OAuth2Result
googleSettings

        MarkupM () -> Handler (MarkupM ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          [shamlet|
            <h3> Home - Basic Example
            <p>
              <a href="#{githubLoginUrl}"> Github Login
            <p>
              <a href="#{googleLoginUrl}"> Google Login
          |]
    , authGithub :: AsServerT Handler
:- (AuthProtect Github
    :> ("auth"
        :> ("github" :> NamedRoutes (OAuth2Routes OAuth2Result))))
authGithub = AsServerT Handler
:- (AuthProtect Github
    :> ("auth"
        :> ("github" :> NamedRoutes (OAuth2Routes OAuth2Result))))
forall (m :: * -> *) a (rs :: [*]).
Monad m =>
Tag a rs -> OAuth2Routes rs (AsServerT m)
authServer
    , authGoogle :: AsServerT Handler
:- (AuthProtect Google
    :> ("auth"
        :> ("google" :> NamedRoutes (OAuth2Routes OAuth2Result))))
authGoogle = AsServerT Handler
:- (AuthProtect Google
    :> ("auth"
        :> ("google" :> NamedRoutes (OAuth2Routes OAuth2Result))))
forall (m :: * -> *) a (rs :: [*]).
Monad m =>
Tag a rs -> OAuth2Routes rs (AsServerT m)
authServer
    }


-- | Entrypoint. The most important thing we do here is build our list of
-- contexts by calling 'oauth2AuthHandler' with the respective settings.
--
-- @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

  let githubSettings :: OAuth2Settings Handler Github OAuth2Result
githubSettings = OAuthConfig -> OAuth2Settings Handler Github OAuth2Result
mkGithubSettings (Config -> OAuthConfig
_githubOAuth Config
config)
      googleSettings :: OAuth2Settings Handler Google OAuth2Result
googleSettings = OAuthConfig -> OAuth2Settings Handler Google OAuth2Result
mkGoogleSettings (Config -> OAuthConfig
_googleOAuth Config
config)
      context :: Context
  '[AuthHandler Request (Tag Github OAuth2Result),
    AuthHandler Request (Tag Google OAuth2Result)]
context =  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
githubSettings Handler (Tag Github OAuth2Result)
-> Handler (Tag Github OAuth2Result)
forall a. a -> a
nat
              AuthHandler Request (Tag Github OAuth2Result)
-> Context '[AuthHandler Request (Tag Google OAuth2Result)]
-> Context
     '[AuthHandler Request (Tag Github OAuth2Result),
       AuthHandler Request (Tag Google OAuth2Result)]
forall x (xs :: [*]). x -> Context xs -> Context (x : xs)
:. OAuth2Settings Handler Google OAuth2Result
-> (Handler (Tag Google OAuth2Result)
    -> Handler (Tag Google OAuth2Result))
-> AuthHandler Request (Tag Google 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 Google OAuth2Result
googleSettings Handler (Tag Google OAuth2Result)
-> Handler (Tag Google OAuth2Result)
forall a. a -> a
nat
              AuthHandler Request (Tag Google OAuth2Result)
-> Context '[]
-> Context '[AuthHandler Request (Tag Google OAuth2Result)]
forall x (xs :: [*]). x -> Context xs -> Context (x : xs)
:. Context '[]
EmptyContext
      nat :: a -> a
nat = a -> a
forall a. a -> a
id
      server' :: Routes (AsServerT Handler)
server' = Text
-> OAuth2Settings Handler Github OAuth2Result
-> Text
-> OAuth2Settings Handler Google OAuth2Result
-> Routes (AsServerT Handler)
server (OAuthConfig -> Text
_callbackUrl (Config -> OAuthConfig
_githubOAuth Config
config))
                       OAuth2Settings Handler Github OAuth2Result
githubSettings
                       (OAuthConfig -> Text
_callbackUrl (Config -> OAuthConfig
_googleOAuth Config
config))
                       OAuth2Settings Handler Google OAuth2Result
googleSettings

  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 (Tag Github OAuth2Result),
       AuthHandler Request (Tag Google 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 Routes (AsServerT Handler)
server' Context
  '[AuthHandler Request (Tag Github OAuth2Result),
    AuthHandler Request (Tag Google OAuth2Result)]
context