413 lines
14 KiB
Text
413 lines
14 KiB
Text
# 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 succesfully 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 footenote: 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).
|