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

414 lines
14 KiB
Text
Raw Permalink Normal View History

# 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)
```
2020-07-21 01:02:05 +02:00
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).