@@ -0,0 +1,406 @@
1+# Hoist Server With Context for Custom Monads
2+
3+In this example we'll combine some of the patterns we've seen in other examples
4+in order to demonstrate using a custom monad with Servant's `Context` and the function
5+`hoistServerWithContext`.
6+
7+`hoistServerWithContext` is a pattern you may encounter if you are trying to use a library such as
8+[servant-auth-server](https://hackage.haskell.org/package/servant-auth-server) along
9+with your own custom monad.
10+
11+In this example, our custom monad will be based on the commonly used `ReaderT env IO a` stack.
12+We'll create an `AppCtx` to represent our `env` and include some logging utilities as well as
13+other variables we'd like to have available.
14+
15+In addition, in order to demonstrate a custom `Context`, we'll also include authentication in
16+our example. As noted previously (in [jwt-and-basic-auth](../jwt-and-basic-auth/JWTAndBasicAuth.lhs)),
17+while basic authentication comes with Servant itself,
18+[servant-auth](https://hackage.haskell.org/package/servant-auth) and
19+[servant-auth-server](https://hackage.haskell.org/package/servant-auth-server)
20+packages are needed for JWT-based authentication.
21+
22+Finally, we're going to use [fast-logger](http://hackage.haskell.org/package/fast-logger)
23+for our logging example below.
24+
25+This recipe uses the following ingredients:
26+
27+```haskell
28+{-# LANGUAGE OverloadedStrings, TypeFamilies, DataKinds,
29+ DeriveGeneric, TypeOperators #-}
30+import Control.Monad.IO.Class (liftIO)
31+import Control.Monad.Reader
32+import Data.Aeson
33+import Data.Default
34+import Data.Proxy
35+import Data.Text
36+import Data.Time.Clock ( UTCTime, getCurrentTime )
37+import GHC.Generics
38+import Network.Wai (Middleware)
39+import Network.Wai.Handler.Warp as Warp
40+import Network.Wai.Middleware.RequestLogger
41+import Network.Wai.Middleware.RequestLogger.JSON
42+import Servant as S
43+import Servant.Auth as SA
44+import Servant.Auth.Server as SAS
45+import System.Log.FastLogger ( ToLogStr(..)
46+ , LoggerSet
47+ , defaultBufSize
48+ , newStdoutLoggerSet
49+ , flushLogStr
50+ , pushLogStrLn )
51+
52+
53+port :: Int
54+port = 3001
55+```
56+
57+## Custom Monad
58+
59+Let's say we'd like to create a custom monad based on `ReaderT env` in order to hold
60+access to a config object as well as some logging utilities.
61+
62+With that, we could define an `AppCtx` and `AppM` like this:
63+
64+```haskell
65+type AppM = ReaderT AppCtx Handler
66+
67+data AppCtx = AppCtx {
68+ _getConfig :: SiteConfig
69+ , _getLogger :: LoggerSet
70+ }
71+
72+data SiteConfig = SiteConfig {
73+ environment :: !Text
74+ , version :: !Text
75+ , adminUsername :: !Text
76+ , adminPasswd :: !Text
77+} deriving (Generic, Show)
78+```
79+
80+This `SiteConfig` is a simple example: it refers to our deployment environment as well as an
81+application version. For instance, we may do something different based on the environment our app is
82+deployed into. When emitting log messages, we may want to include information about
83+the deployed version of our application.
84+
85+In addition, we're going to identify a single admin user in our config and use
86+that definition to authenticate requests inside our handlers. This is not too
87+flexible (and probably not too secure...), but it works as a simple example.
88+
89+## Logging
90+
91+A common contemporary pattern is to emit log messages as JSON for later ingestion
92+into a database like Elasticsearch.
93+
94+To emit JSON log messages, we'll create a `LogMessage` object and make it so we can turn it
95+into a JSON-encoded `LogStr` (a type from `fast-logger`).
96+
97+```haskell
98+data LogMessage = LogMessage {
99+ message :: !Text
100+ , timestamp :: !UTCTime
101+ , level :: !Text
102+ , lversion :: !Text
103+ , lenvironment :: !Text
104+} deriving (Eq, Show, Generic)
105+
106+instance FromJSON LogMessage
107+instance ToJSON LogMessage where
108+ toEncoding = genericToEncoding defaultOptions
109+
110+instance ToLogStr LogMessage where
111+ toLogStr = toLogStr . encode
112+```
113+
114+Eventually, when we'd like to emit a log message inside one of our Handlers, it'll look like this:
115+
116+```haskell
117+sampleHandler :: AppM LogMessage
118+sampleHandler = do
119+ config <- asks _getConfig
120+ logset <- asks _getLogger
121+
122+ tstamp <- liftIO getCurrentTime
123+ let logMsg = LogMessage { message = "let's do some logging!"
124+ , timestamp = tstamp
125+ , level = "info"
126+ , lversion = version config
127+ , lenvironment = environment config
128+ }
129+ -- emit log message
130+ liftIO $ pushLogStrLn logset $ toLogStr logMsg
131+ -- return handler result (for simplicity, result is also a LogMessage)
132+ pure logMsg
133+```
134+
135+## Authentication
136+
137+To demonstrate the other part of this recipe, we are going to use a simple
138+representation of a user, someone who may have access to an admin section of our site:
139+
140+```haskell
141+data AdminUser = AdminUser { name :: Text }
142+ deriving (Eq, Show, Read, Generic)
143+```
144+
145+The following instances are needed for JWT:
146+
147+```haskell
148+instance ToJSON AdminUser
149+instance FromJSON AdminUser
150+instance SAS.ToJWT AdminUser
151+instance SAS.FromJWT AdminUser
152+```
153+
154+## API
155+
156+Now we can define our API.
157+
158+We'll have an `admin` endpoint and a `login` endpoint that takes a `LoginForm`:
159+
160+```haskell
161+type AdminApi =
162+ "admin" :> Get '[JSON] LogMessage
163+
164+type LoginApi =
165+ "login"
166+ :> ReqBody '[JSON] LoginForm
167+ :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie] LogMessage)
168+
169+data LoginForm = LoginForm {
170+ username :: Text
171+ , password :: Text
172+} deriving (Eq, Show, Generic)
173+
174+instance ToJSON LoginForm
175+instance FromJSON LoginForm
176+```
177+
178+We can combine both APIs into one like so:
179+
180+```haskell
181+type AdminAndLogin auths = (SAS.Auth auths AdminUser :> AdminApi) :<|> LoginApi
182+```
183+
184+## Server
185+
186+When we define our server, we'll have to define handlers for the `AdminApi` and the `LoginApi` and
187+we'll have to supply `JWTSettings` and `CookieSettings` so our `login` handler can authenticate users:
188+
189+```haskell
190+adminServer :: SAS.CookieSettings -> SAS.JWTSettings -> ServerT (AdminAndLogin auths) AppM
191+adminServer cs jwts = adminHandler :<|> loginHandler cs jwts
192+```
193+
194+The `admin` route should receive an authenticated `AdminUser` as an argument
195+or it should return a `401`:
196+
197+```haskell
198+adminHandler :: AuthResult AdminUser -> AppM LogMessage
199+adminHandler (SAS.Authenticated adminUser) = do
200+ config <- asks _getConfig
201+ logset <- asks _getLogger
202+
203+ tstamp <- liftIO getCurrentTime
204+ let logMsg = LogMessage { message = "Admin User accessing admin: " <> name adminUser
205+ , timestamp = tstamp
206+ , level = "info"
207+ , lversion = version config
208+ , lenvironment = environment config
209+ }
210+ -- emit log message
211+ liftIO $ pushLogStrLn logset $ toLogStr logMsg
212+ -- return handler result (for simplicity, result is a LogMessage)
213+ pure logMsg
214+adminHandler _ = throwError err401
215+```
216+
217+By contrast, the `login` handler is waiting for a `POST` with a login form.
218+
219+If login is successful, it will set session cookies and return a value.
220+
221+Here we're going to include lots of log messages:
222+
223+```haskell
224+loginHandler :: CookieSettings
225+ -> JWTSettings
226+ -> LoginForm
227+ -> AppM (Headers '[ Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie] LogMessage)
228+loginHandler cookieSettings jwtSettings form = do
229+ config <- asks _getConfig
230+ logset <- asks _getLogger
231+
232+ tstamp <- liftIO getCurrentTime
233+ let logMsg = LogMessage { message = "AdminUser login attempt failed!"
234+ , timestamp = tstamp
235+ , level = "info"
236+ , lversion = version config
237+ , lenvironment = environment config
238+ }
239+ case validateLogin config form of
240+ Nothing -> do
241+ liftIO $ pushLogStrLn logset $ toLogStr logMsg
242+ throwError err401
243+ Just usr -> do
244+ mApplyCookies <- liftIO $ SAS.acceptLogin cookieSettings jwtSettings usr
245+ case mApplyCookies of
246+ Nothing -> do
247+ liftIO $ pushLogStrLn logset $ toLogStr logMsg
248+ throwError err401
249+ Just applyCookies -> do
250+ let successMsg = logMsg{message = "AdminUser succesfully authenticated!"}
251+ liftIO $ pushLogStrLn logset $ toLogStr successMsg
252+ pure $ applyCookies successMsg
253+loginHandler _ _ _ = throwError err401
254+
255+validateLogin :: SiteConfig -> LoginForm -> Maybe AdminUser
256+validateLogin config (LoginForm uname passwd ) =
257+ if (uname == adminUsername config) && (passwd == adminPasswd config)
258+ then Just $ AdminUser uname
259+ else Nothing
260+```
261+
262+## `serveWithContext` and `hoistServerWithContext`
263+
264+In order to build a working server, we'll need to `hoist` our custom monad
265+into Servant's Handler monad. We'll also need to pass in the proper context to ensure
266+authentication will work.
267+
268+This will require both `serveWithContext` and `hoistServerWithContext`.
269+
270+Let's define the function which will create our `Application`:
271+
272+```haskell
273+adminLoginApi :: Proxy (AdminAndLogin '[JWT])
274+adminLoginApi = Proxy
275+
276+mkApp :: Context '[SAS.CookieSettings, SAS.JWTSettings] -> CookieSettings -> JWTSettings -> AppCtx -> Application
277+mkApp cfg cs jwts ctx =
278+ serveWithContext adminLoginApi cfg $
279+ hoistServerWithContext adminLoginApi (Proxy :: Proxy '[SAS.CookieSettings, SAS.JWTSettings])
280+ (flip runReaderT ctx) (adminServer cs jwts)
281+```
282+
283+One footenote: because we'd like our logs to be in JSON form, we'll also create a `Middleware` object
284+so that `Warp` *also* will emit logs as JSON. This will ensure *all* logs are emitted as JSON:
285+
286+```haskell
287+jsonRequestLogger :: IO Middleware
288+jsonRequestLogger =
289+ mkRequestLogger $ def { outputFormat = CustomOutputFormatWithDetails formatAsJSON }
290+```
291+
292+We now have all the pieces we need to serve our application inside a `main` function:
293+
294+```haskell
295+main :: IO ()
296+main = do
297+ -- typically, we'd create our config from environment variables
298+ -- but we're going to just make one here
299+ let config = SiteConfig "dev" "1.0.0" "admin" "secretPassword"
300+
301+ warpLogger <- jsonRequestLogger
302+ appLogger <- newStdoutLoggerSet defaultBufSize
303+
304+ tstamp <- getCurrentTime
305+ myKey <- generateKey
306+
307+ let lgmsg = LogMessage {
308+ message = "My app starting up!"
309+ , timestamp = tstamp
310+ , level = "info"
311+ , lversion = version config
312+ , lenvironment = environment config
313+ }
314+ pushLogStrLn appLogger (toLogStr lgmsg) >> flushLogStr appLogger
315+
316+ let ctx = AppCtx config appLogger
317+
318+ warpSettings = Warp.defaultSettings
319+ portSettings = Warp.setPort port warpSettings
320+ settings = Warp.setTimeout 55 portSettings
321+ jwtCfg = defaultJWTSettings myKey
322+ cookieCfg = if environment config == "dev"
323+ then defaultCookieSettings{cookieIsSecure=SAS.NotSecure}
324+ else defaultCookieSettings
325+ cfg = cookieCfg :. jwtCfg :. EmptyContext
326+
327+ Warp.runSettings settings $ warpLogger $ mkApp cfg cookieCfg jwtCfg ctx
328+```
329+
330+
331+## Usage
332+
333+Now we can run it and try it out with `curl`. In one terminal, let's run our application
334+and see what our log output looks like:
335+
336+```$ ./cookbook-hoist-server-with-context
337+{"message":"My app starting up!","timestamp":"2018-10-04T00:33:12.482568Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}
338+```
339+
340+In another terminal, let's ensure that it fails with `err401` if
341+we're not authenticated:
342+
343+```
344+$ curl -v 'http://localhost:3001/admin'
345+…
346+< HTTP/1.1 401 Unauthorized
347+```
348+
349+```
350+$ curl -v -XPOST 'http://localhost:3001/login' \
351+ -H "Content-Type:application/json" \
352+ -d '{"username": "bad", "password": "wrong"}'
353+…
354+< HTTP/1.1 401 Unauthorized
355+```
356+
357+And in the other terminal with our log messages (from our JSON `Middleware`):
358+
359+```
360+{"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"}}
361+```
362+
363+Now let's see that authentication works, and that we get JWTs:
364+
365+```
366+$ curl -v -XPOST 'http://localhost:3001/login' \
367+ -H "Content-Type:application/json" \
368+ -d '{"username": "admin", "password": "secretPassword"}'
369+…
370+< HTTP/1.1 200 OK
371+...
372+< Server: Warp/3.2.25
373+< Content-Type: application/json;charset=utf-8
374+< Set-Cookie: JWT-Cookie=eyJhbGciOiJIUzUxMiJ9.eyJkYXQiOnsibmFtZSI6ImFkbWluIn19.SIoRcABKSO4mXnRifzqPWlHJUhVwuy32Qon7s1E_c3vHOsLXdXyX4V4eXOw9tMFoeIqgsXMZucqoFb36vAdKwQ; Path=/; HttpOnly; SameSite=Lax
375+< Set-Cookie: XSRF-TOKEN=y5PmrYHX3ywFUCwGRQqHh1TDheTLiQpwRQB3FFRd8N4=; Path=/
376+...
377+{"message":"AdminUser succesfully authenticated!","timestamp":"2018-10-04T00:37:44.455441Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}
378+```
379+
380+And in the other terminal with our log messages (note that logging out passwords is insecure...):
381+
382+```
383+{"message":"AdminUser succesfully authenticated!","timestamp":"2018-10-04T00:37:44.455441Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}
384+{"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"}}
385+```
386+
387+Finally, let's make sure we can access a protected resource with our tokens:
388+
389+```
390+$ export jwt=eyJhbGciOiJIUzUxMiJ9.eyJkYXQiOnsibmFtZSI6ImFkbWluIn19.SIoRcABKSO4mXnRifzqPWlHJUhVwuy32Qon7s1E_c3vHOsLXdXyX4V4eXOw9tMFoeIqgsXMZucqoFb36vAdKwQ
391+$ curl -v \
392+ -H "Authorization: Bearer $jwt" \
393+ 'http://localhost:3001/admin'
394+…
395+< HTTP/1.1 200 OK
396+{"message":"Admin User accessing admin: admin","timestamp":"2018-10-04T00:58:07.216605Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}
397+```
398+
399+And we should see this message logged-out as well:
400+
401+```
402+{"message":"Admin User accessing admin: admin","timestamp":"2018-10-04T00:58:07.216605Z","level":"info","lversion":"1.0.0","lenvironment":"dev"}
403+```
404+
405+This program is available as a cabal project
406+[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/hoist-server-with-context).