Merge pull request #1044 from erewok/hoistWithContextCookbook

Add new cookbook recipe for hoistServerWithContext

.travis.yml

@@ -118,6 +118,9 @@ install:
   - if [ -f "doc/cookbook/jwt-and-basic-auth/configure.ac" ]; then
       (cd "doc/cookbook/jwt-and-basic-auth" && autoreconf -i);
     fi
+  - if [ -f "doc/cookbook/hoist-server-with-context/configure.ac" ]; then
+      (cd "doc/cookbook/hoist-server-with-context" && autoreconf -i);
+    fi
   - if [ -f "doc/cookbook/pagination/configure.ac" ]; then
       (cd "doc/cookbook/pagination" && autoreconf -i);
     fi
@@ -157,6 +160,7 @@ script:
   - (cd "doc/cookbook/generic" && cabal sdist)
   - (cd "doc/cookbook/https" && cabal sdist)
   - (cd "doc/cookbook/jwt-and-basic-auth" && cabal sdist)
+  - (cd "doc/cookbook/hoist-server-with-context" && cabal sdist)
   - (cd "doc/cookbook/pagination" && cabal sdist)
   - (cd "doc/cookbook/structuring-apis" && cabal sdist)
   - (cd "doc/cookbook/using-custom-monad" && cabal sdist)

doc/cookbook/cabal.project

@@ -5,6 +5,7 @@ packages:
   db-postgres-pool/
   using-custom-monad/
   jwt-and-basic-auth/
+  hoist-server-with-context/
   file-upload/
   structuring-apis/
   https/

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

@@ -0,0 +1,406 @@
+# 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 OverloadedStrings, TypeFamilies, DataKinds,
+  DeriveGeneric, TypeOperators #-}
+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).

doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal

@@ -0,0 +1,36 @@
+name:                cookbook-hoist-server-with-context
+version:             0.0.1
+synopsis:            JWT and basic access authentication with a Custom Monad cookbook example
+description:         Using servant-auth to support both JWT-based and basic
+                     authentication.
+homepage:            http://haskell-servant.readthedocs.org/
+license:             BSD3
+license-file:        ../../../servant/LICENSE
+author:              Servant Contributors
+maintainer:          haskell-servant-maintainers@googlegroups.com
+category:            Servant
+build-type:          Simple
+cabal-version:       >=1.10
+tested-with:         GHC==8.0.2, GHC==8.2.2, GHC==8.4.3
+
+executable cookbook-hoist-server-with-context
+  main-is:             HoistServerWithContext.lhs
+  build-depends:       base == 4.*
+                     , text >= 1.2
+                     , aeson >= 1.2
+                     , data-default
+                     , fast-logger
+                     , servant
+                     , servant-server
+                     , servant-auth >= 0.3.2
+                     , servant-auth-server
+                     , time
+                     , warp >= 3.2
+                     , wai >= 3.2
+                     , wai-extra
+                     , http-types >= 0.12
+                     , bytestring >= 0.10.4
+                     , mtl
+  default-language:    Haskell2010
+  ghc-options:         -Wall -pgmL markdown-unlit
+  build-tool-depends:  markdown-unlit:markdown-unlit

doc/cookbook/index.rst

@@ -26,6 +26,7 @@ you name it!
   using-free-client/UsingFreeClient.lhs
   basic-auth/BasicAuth.lhs
   jwt-and-basic-auth/JWTAndBasicAuth.lhs
+  hoist-server-with-context/HoistServerWithContext.lhs
   file-upload/FileUpload.lhs
   pagination/Pagination.lhs
   curl-mock/CurlMock.lhs