From 0c4dc8859228770706a22d8592c5d1f1e582eaa8 Mon Sep 17 00:00:00 2001 From: Erik Aker Date: Wed, 3 Oct 2018 18:00:06 -0700 Subject: [PATCH] Add new cookbook recipe for hoistServerWithContext --- .travis.yml | 4 + doc/cookbook/cabal.project | 1 + .../HoistServerWithContext.lhs | 406 ++++++++++++++++++ .../hoist-server-with-context.cabal | 36 ++ doc/cookbook/index.rst | 1 + 5 files changed, 448 insertions(+) create mode 100644 doc/cookbook/hoist-server-with-context/HoistServerWithContext.lhs create mode 100644 doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal diff --git a/.travis.yml b/.travis.yml index 74a5ffa8..fa19b260 100644 --- a/.travis.yml +++ b/.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) diff --git a/doc/cookbook/cabal.project b/doc/cookbook/cabal.project index 71b97b89..190e1c66 100644 --- a/doc/cookbook/cabal.project +++ b/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/ diff --git a/doc/cookbook/hoist-server-with-context/HoistServerWithContext.lhs b/doc/cookbook/hoist-server-with-context/HoistServerWithContext.lhs new file mode 100644 index 00000000..50792a53 --- /dev/null +++ b/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). diff --git a/doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal b/doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal new file mode 100644 index 00000000..70f432b1 --- /dev/null +++ b/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 diff --git a/doc/cookbook/index.rst b/doc/cookbook/index.rst index 99d905c7..b7e9bd1c 100644 --- a/doc/cookbook/index.rst +++ b/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