servant/doc/cookbook/hoist-server-with-context/HoistServerWithContext.lhs

# Hoist Server With Context for Custom Monads

In this example we'll combine some of the patterns we've seen in other examples
in order to demonstrate using a custom monad with Servant's `Context` and the function
`hoistServerWithContext`.

`hoistServerWithContext` is a pattern you may encounter if you are trying to use a library such as
[servant-auth-server](https://hackage.haskell.org/package/servant-auth-server) along
with your own custom monad.

In this example, our custom monad will be based on the commonly used `ReaderT env IO a` stack.
We'll create an `AppCtx` to represent our `env` and include some logging utilities as well as
other variables we'd like to have available.

In addition, in order to demonstrate a custom `Context`, we'll also include authentication in
our example. As noted previously (in [jwt-and-basic-auth](../jwt-and-basic-auth/JWTAndBasicAuth.lhs)),
while basic authentication comes with Servant itself,
[servant-auth](https://hackage.haskell.org/package/servant-auth) and
[servant-auth-server](https://hackage.haskell.org/package/servant-auth-server)
packages are needed for JWT-based authentication.

Finally, we're going to use [fast-logger](http://hackage.haskell.org/package/fast-logger)
for our logging example below.

This recipe uses the following ingredients:

```haskell
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

import Prelude ()
import Prelude.Compat

import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader
import Data.Aeson
import Data.Default
import Data.Proxy
import Data.Text
import Data.Time.Clock ( UTCTime, getCurrentTime )
import GHC.Generics
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp as Warp
import Network.Wai.Middleware.RequestLogger
import Network.Wai.Middleware.RequestLogger.JSON
import Servant as S
import Servant.Auth as SA
import Servant.Auth.Server as SAS
import System.Log.FastLogger                      ( ToLogStr(..)
                                                  , LoggerSet
                                                  , defaultBufSize
                                                  , newStdoutLoggerSet
                                                  , flushLogStr
                                                  , pushLogStrLn )


port :: Int
port = 3001
```

## Custom Monad

Let's say we'd like to create a custom monad based on `ReaderT env` in order to hold
access to a config object as well as some logging utilities.

With that, we could define an `AppCtx` and `AppM` like this:

```haskell
type AppM = ReaderT AppCtx Handler

data AppCtx = AppCtx {
  _getConfig   :: SiteConfig
  , _getLogger :: LoggerSet
  }

data SiteConfig = SiteConfig {
  environment     :: !Text
  , version       :: !Text
  , adminUsername :: !Text
  , adminPasswd   :: !Text
} deriving (Generic, Show)
```

This `SiteConfig` is a simple example: it refers to our deployment environment as well as an
application version. For instance, we may do something different based on the environment our app is
deployed into. When emitting log messages, we may want to include information about
the deployed version of our application.

In addition, we're going to identify a single admin user in our config and use
that definition to authenticate requests inside our handlers. This is not too
flexible (and probably not too secure...), but it works as a simple example.

## Logging

A common contemporary pattern is to emit log messages as JSON for later ingestion
into a database like Elasticsearch.

To emit JSON log messages, we'll create a `LogMessage` object and make it so we can turn it
into a JSON-encoded `LogStr` (a type from `fast-logger`).

```haskell
data LogMessage = LogMessage {
  message        :: !Text
  , timestamp    :: !UTCTime
  , level        :: !Text
  , lversion     :: !Text
  , lenvironment :: !Text
} deriving (Eq, Show, Generic)

instance FromJSON LogMessage
instance ToJSON LogMessage where
  toEncoding = genericToEncoding defaultOptions

instance ToLogStr LogMessage where
  toLogStr = toLogStr . encode
```

Eventually, when we'd like to emit a log message inside one of our Handlers, it'll look like this:

```haskell
sampleHandler :: AppM LogMessage
sampleHandler = do
    config <- asks _getConfig
    logset <- asks _getLogger

    tstamp <- liftIO getCurrentTime
    let logMsg = LogMessage { message = "let's do some logging!"
                            , timestamp = tstamp
                            , level = "info"
                            , lversion = version config
                            , lenvironment = environment config
                            }
    -- emit log message
    liftIO $ pushLogStrLn logset $ toLogStr logMsg
    -- return handler result (for simplicity, result is also a LogMessage)
    pure logMsg
```

## Authentication

To demonstrate the other part of this recipe, we are going to use a simple
representation of a user, someone who may have access to an admin section of our site:

```haskell
data AdminUser = AdminUser { name :: Text }
   deriving (Eq, Show, Read, Generic)
```

The following instances are needed for JWT:

```haskell
instance ToJSON AdminUser
instance FromJSON AdminUser
instance SAS.ToJWT AdminUser
instance SAS.FromJWT AdminUser
```

## API

Now we can define our API.

We'll have an `admin` endpoint and a `login` endpoint that takes a `LoginForm`:

```haskell
type AdminApi =
  "admin" :> Get '[JSON] LogMessage

type LoginApi =
  "login"
      :> ReqBody '[JSON] LoginForm
      :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie] LogMessage)

data LoginForm = LoginForm {
  username :: Text
  , password :: Text
} deriving (Eq, Show, Generic)

instance ToJSON LoginForm
instance FromJSON LoginForm
```

We can combine both APIs into one like so:

```haskell
type AdminAndLogin auths = (SAS.Auth auths AdminUser :> AdminApi) :<|> LoginApi
```

## Server

When we define our server, we'll have to define handlers for the `AdminApi` and the `LoginApi` and
we'll have to supply `JWTSettings` and `CookieSettings` so our `login` handler can authenticate users:

```haskell
adminServer :: SAS.CookieSettings -> SAS.JWTSettings -> ServerT (AdminAndLogin auths) AppM
adminServer cs jwts = adminHandler :<|> loginHandler cs jwts
```

The `admin` route should receive an authenticated `AdminUser` as an argument
or it should return a `401`:

```haskell
adminHandler :: AuthResult AdminUser -> AppM LogMessage
adminHandler (SAS.Authenticated adminUser) = do
    config <- asks _getConfig
    logset <- asks _getLogger

    tstamp <- liftIO getCurrentTime
    let logMsg = LogMessage { message = "Admin User accessing admin: " <> name adminUser
                            , timestamp = tstamp
                            , level = "info"
                            , lversion = version config
                            , lenvironment = environment config
                            }
    -- emit log message
    liftIO $ pushLogStrLn logset $ toLogStr logMsg
    -- return handler result (for simplicity, result is a LogMessage)
    pure logMsg
adminHandler _ = throwError err401
```

By contrast, the `login` handler is waiting for a `POST` with a login form.

If login is successful, it will set session cookies and return a value.

Here we're going to include lots of log messages:

```haskell
loginHandler :: CookieSettings
             -> JWTSettings
             -> LoginForm
             -> AppM (Headers '[ Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie] LogMessage)
loginHandler cookieSettings jwtSettings form = do
  config     <- asks _getConfig
  logset     <- asks _getLogger

  tstamp <- liftIO getCurrentTime
  let logMsg = LogMessage { message = "AdminUser login attempt failed!"
                          , timestamp = tstamp
                          , level = "info"
                          , lversion = version config
                          , lenvironment = environment config
                          }
  case validateLogin config form of
    Nothing -> do
      liftIO $ pushLogStrLn logset $ toLogStr logMsg
      throwError err401
    Just usr -> do
      mApplyCookies <- liftIO $ SAS.acceptLogin cookieSettings jwtSettings usr
      case mApplyCookies of
        Nothing           -> do
          liftIO $ pushLogStrLn logset $ toLogStr logMsg
          throwError err401
        Just applyCookies -> do
          let successMsg = logMsg{message = "AdminUser successfully authenticated!"}
          liftIO $ pushLogStrLn logset $ toLogStr successMsg
          pure $ applyCookies successMsg
loginHandler _ _ _ = throwError err401

validateLogin :: SiteConfig -> LoginForm -> Maybe AdminUser
validateLogin config (LoginForm uname passwd ) =
  if (uname == adminUsername config) && (passwd == adminPasswd config)
    then Just $ AdminUser uname
    else Nothing
```

## `serveWithContext` and `hoistServerWithContext`

In order to build a working server, we'll need to `hoist` our custom monad
into Servant's Handler monad. We'll also need to pass in the proper context to ensure
authentication will work.

This will require both `serveWithContext` and `hoistServerWithContext`.

Let's define the function which will create our `Application`:

```haskell
adminLoginApi :: Proxy (AdminAndLogin '[JWT])
adminLoginApi = Proxy

mkApp :: Context '[SAS.CookieSettings, SAS.JWTSettings] -> CookieSettings -> JWTSettings -> AppCtx -> Application
mkApp cfg cs jwts ctx =
  serveWithContext adminLoginApi cfg $
    hoistServerWithContext adminLoginApi (Proxy :: Proxy '[SAS.CookieSettings, SAS.JWTSettings])
      (flip runReaderT ctx) (adminServer cs jwts)
```

One footnote: because we'd like our logs to be in JSON form, we'll also create a `Middleware` object
so that `Warp` *also* will emit logs as JSON. This will ensure *all* logs are emitted as JSON:

```haskell
jsonRequestLogger :: IO Middleware
jsonRequestLogger =
  mkRequestLogger $ def { outputFormat = CustomOutputFormatWithDetails formatAsJSON }
```

We now have all the pieces we need to serve our application inside a `main` function:

```haskell
main :: IO ()
main = do
  -- typically, we'd create our config from environment variables
  -- but we're going to just make one here
  let config = SiteConfig "dev" "1.0.0" "admin" "secretPassword"

  warpLogger <- jsonRequestLogger
  appLogger <- newStdoutLoggerSet defaultBufSize

  tstamp <- getCurrentTime
  myKey <- generateKey

  let lgmsg = LogMessage {
    message = "My app starting up!"
    , timestamp = tstamp
    , level = "info"
    , lversion = version config
    , lenvironment = environment config
  }
  pushLogStrLn appLogger (toLogStr lgmsg) >> flushLogStr appLogger

  let ctx = AppCtx config appLogger

      warpSettings = Warp.defaultSettings
      portSettings = Warp.setPort port warpSettings
      settings = Warp.setTimeout 55 portSettings
      jwtCfg = defaultJWTSettings myKey
      cookieCfg = if environment config == "dev"
                  then defaultCookieSettings{cookieIsSecure=SAS.NotSecure}
                  else defaultCookieSettings
      cfg = cookieCfg :. jwtCfg :. EmptyContext

  Warp.runSettings settings $ warpLogger $ mkApp cfg cookieCfg jwtCfg ctx
```


## Usage

Now we can run it and try it out with `curl`. In one terminal, let's run our application
and see what our log output looks like:

```$ ./cookbook-hoist-server-with-context
{"message":"My app starting up!","timestamp":"2018-10-04T00:33:12.482568Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}
```

In another terminal, let's ensure that it fails with `err401` if
we're not authenticated:

```
$ curl -v 'http://localhost:3001/admin'
…
< HTTP/1.1 401 Unauthorized
```

```
$ curl -v -XPOST 'http://localhost:3001/login' \
  -H "Content-Type:application/json" \
  -d '{"username": "bad", "password": "wrong"}'
…
< HTTP/1.1 401 Unauthorized
```

And in the other terminal with our log messages (from our JSON `Middleware`):

```
{"time":"03/Oct/2018:17:35:56 -0700","response":{"status":401,"size":null,"body":""},"request":{"httpVersion":"1.1","path":"/admin","size":0,"body":"","durationMs":0.22,"remoteHost":{"hostAddress":"127.0.0.1","port":51029},"headers":[["Host","localhost:3001"],["User-Agent","curl/7.60.0"],["Accept","*/*"]],"queryString":[],"method":"GET"}}
```

Now let's see that authentication works, and that we get JWTs:

```
$ curl -v -XPOST 'http://localhost:3001/login' \
  -H "Content-Type:application/json" \
  -d '{"username": "admin", "password": "secretPassword"}'
…
< HTTP/1.1 200 OK
...
< Server: Warp/3.2.25
< Content-Type: application/json;charset=utf-8
< Set-Cookie: JWT-Cookie=eyJhbGciOiJIUzUxMiJ9.eyJkYXQiOnsibmFtZSI6ImFkbWluIn19.SIoRcABKSO4mXnRifzqPWlHJUhVwuy32Qon7s1E_c3vHOsLXdXyX4V4eXOw9tMFoeIqgsXMZucqoFb36vAdKwQ; Path=/; HttpOnly; SameSite=Lax
< Set-Cookie: XSRF-TOKEN=y5PmrYHX3ywFUCwGRQqHh1TDheTLiQpwRQB3FFRd8N4=; Path=/
...
{"message":"AdminUser succesfully authenticated!","timestamp":"2018-10-04T00:37:44.455441Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}
```

And in the other terminal with our log messages (note that logging out passwords is insecure...):

```
{"message":"AdminUser succesfully authenticated!","timestamp":"2018-10-04T00:37:44.455441Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}
{"time":"03/Oct/2018:17:37:44 -0700","response":{"status":200,"size":null,"body":null},"request":{"httpVersion":"1.1","path":"/login","size":51,"body":"{\"username\": \"admin\", \"password\": \"secretPassword\"}","durationMs":0.23,"remoteHost":{"hostAddress":"127.0.0.1","port":51044},"headers":[["Host","localhost:3001"],["User-Agent","curl/7.60.0"],["Accept","*/*"],["Content-Type","application/json"],["Content-Length","51"]],"queryString":[],"method":"POST"}}
```

Finally, let's make sure we can access a protected resource with our tokens:

```
$ export jwt=eyJhbGciOiJIUzUxMiJ9.eyJkYXQiOnsibmFtZSI6ImFkbWluIn19.SIoRcABKSO4mXnRifzqPWlHJUhVwuy32Qon7s1E_c3vHOsLXdXyX4V4eXOw9tMFoeIqgsXMZucqoFb36vAdKwQ
$ curl -v \
  -H "Authorization: Bearer $jwt" \
  'http://localhost:3001/admin'
…
< HTTP/1.1 200 OK
{"message":"Admin User accessing admin: admin","timestamp":"2018-10-04T00:58:07.216605Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}
```

And we should see this message logged-out as well:

```
{"message":"Admin User accessing admin: admin","timestamp":"2018-10-04T00:58:07.216605Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}
```

This program is available as a cabal project
[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/hoist-server-with-context).