Chapter 3 - Servant and the Server

By John Lenz. 2016.

The server is built on top of the domain and datastorage libraries and implements the servant routes. As mentioned in the design overview, the server just provides access directly to the domain data. The server does not handle HTML at all, leaving the DOM generation to the client. The design of the server is loosly based on the design of the Yesod scaffold but adapted to servant. For easy testing, the bulk of the code lives in a cabal library.


The Settings.hs module contains all the configuration and runtime data for the server. First, a type Settings which contains all the configuration data:

data SendEmailType = SendEmailViaAws
                   | LogEmailToConsole
                   | WriteEmailToFile
    deriving (Show, Read, Enum, Bounded, Generic)

data Settings = Settings
    { _allowedOrigin :: ByteString -- ^ allowed origin for CORS
    , _allowedHost :: ByteString   -- ^ allowed host for CORS
    , _appPort :: Int
    , _logLevelLimit :: LogLevel -- ^ log level from the monad-logger package
    , _dbServer :: Text
    , _jwtSecret :: Jose.Jwk -- ^ key from the jose-jwt package
    , _sendPasswordResetEmails :: SendEmailType

makeLenses ''Settings

I used to use separate debug and production builds controlled by CPP flags (similar to the Yesod scaffold), but I've transitioned to a scheme where there is no flag for debug or production mode. Instead, everything that differs between debug and production mode is put into the Settings type. You can see that in action with the SendEmailType. During development, I use LogEmailToConsole so that I can just see what email would be sent. Inside the test suite, I use WriteEmailToFile so that the test suite can check the email is correct. Finally, during production I use SendEmailViaAws to send the email using mime-mail-ses. I have several settings of this type.

During development, the server runs in GHCI so the settings are hard-coded into the source. Note I am using jose-jwt imported qualified as Jose.

parseJwk :: Text -> Jose.Jwk
parseJwk secretStr = jwk
        secretBs = either (\e -> error $ "Unable to decode jwt secret " ++ e) id $
            Data.ByteString.Base64.decode $ Data.Text.encodeUtf8 secretStr
        jwk = Jose.SymmetricJwk secretBs Nothing Nothing (Just $ Jose.Signed Jose.HS256)

devSettings :: Settings
devSettings = Settings
    { _allowedOrigin = "http://localhost:8080"
    , _allowedHost = "localhost:3000"
    , _appPort = 3000
    , _logLevelLimit = LevelDebug
    , _dbServer = "localhost"
    -- generate with dd if=/dev/urandom bs=1 count=32 | base64
    -- make sure jwtSecret differs between development and production, because you do not want
    -- your production key inside source control.
    , _jwtSecret = parseJwk "MVg0YAPVSPiYQc/qIs/rV/X32EFR0zOJWfHFgMbszMw="
    , _sendLoginEmails = LogEmailToConsole

Next, I load the production settings from environment variables. This allows the server to be a single executable with no required files which eases deployment. You could also use a config file instead; if you do I suggest yaml. For easy, quick, dirty parsing I reuse the 'FromHttpApiData' class from http-api-data.

reqSetting :: FromHttpApiData a => String -> IO a
reqSetting name = do
    e <- fromMaybe (error $ "Missing " ++ name) <$> lookupEnv name
    pure $ either (error $ "Unable to parse " ++ name) id $ parseUrlPiece $ pack e

optSetting :: FromHttpApiData a => String -> a -> IO a
optSetting name d = do
    me <- lookupEnv name
    case me of
        Nothing -> pure d
        Just e -> pure $ either (error $ "Unable to parse " ++ name) id $ parseUrlPiece $ pack e

settingsFromEnvironment :: IO Settings
settingsFromEnvironment =
    Settings <$> (encodeUtf8 <$> reqSetting "ALLOWED_ORIGIN")
             <*> (encodeUtf8 <$> reqSetting "ALLOWED_HOST")
             <*> optSetting "PORT" 3000
             <*> (parseLogLevel <$> optSetting "LOG_LEVEL" "warn")
             <*> reqSetting "DB_SERVER"
             <*> (parseJwk <$> reqSetting "JWT_SECRET")
             <*> optSetting "SEND_EMAIL" SendEmailViaAws

The Settings.hs module also contains a type Env which stores values created at runtime. This includes the database connection pool, the logging outputter LoggerSet from fast-logger, and other runtime-created values.

data Env = Env
    { _settings :: Settings
    , _logger :: LoggerSet
    , _dbConfig :: ConnectionPool -- from Database.Persist.Postgresql

makeLenses ''Env

createEnv :: Settings -> IO Env
createEnv s = {- implementation here: connect to db, init logger, etc -}


Auth.hs contains the authentication code. As mentioned on the libraries page, authentication happens via JWT tokens. There are several security considerations we must implement.

  1. The server keeps a secret key and when creating tokens uses a cryptographically secure signature on the web token. The server must reject invalid signatures and keep a proper clock and reject outdated tokens. The security relies on the secret key and the inability for an attacker to forge a token. In addition, each route must actually check the token is valid.

  2. The client browser must keep the token secure and only allow access to our GHCJS code. Since the token is stored in local storage and not a cookie, the same origin policy is enough to protect the web token to only allow JavaScript running from our origin to make authenticated requests to the server. But since the static site serving the HTML and JavaScript files is likely at a different origin than the servant server, the server must allow the other origin using CORS. CORS support in the server is described below as part of the Application.hs module.

  3. Cross-site scripting attacks must be prevented. Since the server does not implement any HTML, preventing cross-site scripting attacks is handled as part of the client; for more details, see Chapter 4.

  4. If you are using JavaScript from 3rd party CDNs, they are vulnerable to DNS based attacks where an attacker-controlled file is downloaded and executed as part of your origin. One mitigation is to serve all dependencies along with GHCJS yourself over SSL. Alternatively, you can use the new subresource integrity feature. For now, I include all JavaScript dependencies as part of the metalsmith site. For more details, see Chapter 5.

  5. Support expiring of sessions. You can implement logout by having the javascript delete the token from local storage, but usually you still want a way to expire sessions after some amout of time has passed. One option is to use a short expire time (say 30 minutes) in the token, and then have the client periodically refresh the token by acquiring a new token as long as the page is open. This is the easiest for web-based clients. For mobile apps, users typically expect to stay logged in, so you might instead create a token with a long expiry time (say 30 days) which is called a refresh token, and then in the database store a list of revoked but not-yet-expired refresh tokens. During login, the user presents the refresh token and is granted a short-duration (say 30 minute) token which is used for requests. (Using the short 30-minute token avoids a DB-check for an expired refresh token on every API request.)

The Auth.hs module contains the code to implement the server-half of this security. It uses jose-jwt imported qualified as Jose. Since I am focusing only on web-based clients, I just use a single token and do not use refresh tokens.

First, there are functions to create and decode a token (for the definition of TokenAudience, UserCredentials, and Token, see Chpater 2).

createJwt :: TokenAudience -> UserCredentials -> Env -> Servant.Handler UnverifiedJwtToken
createJwt aud ucreds env = do
    now <- liftIO getPOSIXTime
    expire <- pure $ case aud of
            TokenSentViaEmail -> 15*60 -- 15 minutes
            TokenForLiveUser -> 60*60 -- 1 hour
    let key = env^.settings.jwtSecret

    let token = Token { _tokenCreds = ucreds
                      , _issuedP = now
                      , _expiredP = now + expire
                      , _jwtAudience = aud
    mjwt <- liftIO $ Jose.encode [key] (Jose.JwsEncoding Jose.HS256) (Jose.Claims $ toStrict $ Aeson.encode token)
    case mjwt of
        Left _ -> throwError err500 {errBody = "Unable to authenticate"}
        Right jwt -> pure $ UnverifiedJwtToken $ decodeUtf8 $ Jose.unJwt jwt

verifyJwt :: UnverifiedJwtToken -> Env -> Servant.Handler Token
verifyJwt (UnverifiedJwtToken unverifiedText) env = do
    key <- pure $ env^.settings.jwtSecret
    mjwtContent <- liftIO $ Jose.decode [key] (Just $ Jose.JwsEncoding Jose.HS256) $ encodeUtf8 unverifiedText
    jwt <- case mjwtContent of
            Right (Jose.Jws (_, jwt)) -> pure $ jwt
            _ -> throwError err401 { errBody = "Invalid javascript web token" }

    case Aeson.eitherDecode (fromStrict jwt) of
        Left _ -> throwError err401 { errBody = "Unable to parse jwt claims" }

        Right token -> do
            now <- liftIO getPOSIXTime
            when (token^.expiredP <= now) $
                throwError err401 { errBody = "Expired jwt token" }
            pure token

Finally, there is a helper to verify the token from an Authorization header. The standard for JWT specifies that the Authorization header consists of Bearer followed by the token itself.

-- | Verify and decode a token
verifyWebJwt :: Maybe UnverifiedJwtToken -> Env -> Servant.Handler (Maybe Token)
verifyWebJwt Nothing _ = return Nothing
verifyWebJwt (Just (UnverifiedJwtToken x)) env = do
    let unverifiedToken = if "Bearer " `isPrefixOf` x then drop 7 x else x
    token <- verifyJwt (UnverifiedJwtToken unverifiedToken) env
    case token^.jwtAudience of
        TokenSentViaEmail -> throwError err403 { errBody = "Cannot use email token for authentication" }
        TokenForLiveUser -> pure token

There is a similar helper function for verifying email tokens.


Foundation.hs contains the monad that all handlers run in. The monad has a ResourceT to clean up any resources opened by a handler, a ReaderT to access to the Env, and potentially a Token for the logged in user.

newtype MyServer a = MyServer { myServerM :: ReaderT (Env, Maybe Token) (ResourceT (ExceptT ServantErr IO)) a }
    deriving (Functor, Applicative, Monad, MonadIO)

deriving instance MonadError ServantErr MyServer
instance MonadBase IO MyServer where liftBase = liftIO
instance MonadReader Env MyServer where
  ask = MyServer (fst <$> ask)
  local f (MyServer r) = MyServer (local (\(e,t) -> (f e, t)) r)
instance MonadLogger MyServer where
    monadLoggerLog loc source ll msg = do
        limit <- view (settings.logLevelLimit)
        out <- view logger
        when (ll >= limit) $
            liftIO $ pushLogStr out $ defaultLogStr loc source ll $ toLogStr msg

getToken :: MyServer (Maybe Token)
getToken = MyServer (snd <$> ask)

userRequired :: MyServer UserCredentials
userRequired = do
    mt <- getToken
    case mt of
        Nothing -> throwError $ err401 { errBody = "No Authorization header in request" }
        Just t -> return $ t^.tokenCreds

runDB :: SqlPersist a -> MyServer a
runDB action = {- access pool from env, run action -}

Next, Foundation.hs contains the code to transform the MyServer monad back to the monad that servant expects (ExceptT ServantErr IO).

myServerNat :: Env -> Maybe UnverifiedJwtToken -> (MyServer :~> ExceptT ServantErr IO)
myServerNat env munverifiedToken = Nat $ \s -> do
    mtoken <- case munverifiedToken of
        Nothing -> return Nothing
        Just unverifiedToken -> verifyWebJwt unverifiedToken env
    runResourceT (runReaderT (myServerM s) (env, mtoken))


Handlers for all the routes in the network API are implemented in a variety of files in the Handlers subdirectory. They implement the handlers in the MyServer monad. For example, continuing with the TeamAPI example from the libraries chapter,

module Handlers.Teams (teamServer) where

import Foundation
import Servant.Server
import DataStorage

teamServer :: ServerT TeamAPI MyServer
teamServer = getTeamR :<|> createTeamR :<|> updateTeamR :<|> getAllTeamsR

getTeamR :: TeamKey -> MyServer Team
getTeamR tk = do
    ucreds <- userRequired
    runDB $ loadTeam ucreds tk

createTeamR :: Team -> MyServer ()
createTeamR ....


The Application.hs file pulls together all the handlers and sets up the servant and warp server.

First, the handlers are combined and MyServer is converted to a servant Server via a Nat.

-- | Pull together all servers from the various Handler files
myServer = ServerT MyAPI MyServer
myServer = teamServer :<|> ...

-- Note that @type MyAPIWithAuth = JwtAuthHeader :> MyAPI@ so that
-- @Server MyAPIWithAuth@ expands to @Maybe UnverifiedJwtToken -> Server MyAPI@.
myServerWithAuth :: Env -> Server MyAPIWithAuth
myServerWithAuth env unverifiedJwt = enter (myServerNat env unverifiedJwt) myServer

Next, Application.hs contains the function which creates the WAI application and sets up all the wai middleware. In particular, wai-cors is used for cross-origin resource sharing and RequestLogger is used from wai-extra.

makeApp :: Env -> IO (Warp.Settings, Application)
makeApp env = do
    let serverApp = serve (Proxy :: Proxy MyAPIWithAuth) (myServerWithAuth env)

    logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }

    let checkOriginAndHost app req resp = do
        case (lookup "Origin" (requestHeaders req), lookup "Host" (requestHeaders req))  of
            (Just o, Just h) | o == env^.settings.allowedOrigin && h == env^.settings.allowedHost -> app req resp
            _ -> resp $ responseLBS status401 [] "Invalid Origin or Host header"

    let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
            { corsOrigins = Just ([env^.settings.allowedOrigin], False)
            , corsMethods = [methodGet, methodPost, methodPut, methodDelete]
            , corsRequestHeaders = ["authorization", "content-type"]
            , corsExposedHeaders = Nothing
            , corsMaxAge = Just $ 60*60*24 -- one day
            , corsVaryOrigin = False
            , corsRequireOrigin = True
            , corsIgnoreFailures = False

    let warpS = Warp.setPort (env^.settings.appPort)
              $ Warp.defaultSettings
    return (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)

Finally, Application.hs contains two main functions, one for development from GHCI and one for production.

devMain :: IO ()
devMain = pure devSettings >>= createEnv >>= makeApp >>= uncurry Warp.runSettings

prodMain :: IO ()
prodMain = settingsFromEnvironment >>= createEnv >>= makeApp >>= uncurry Warp.runSettings

The makeApp, devMain and prodMain are exported from the module and library. There is then a small cabal executable project which has a single line of code which calls prodMain.

Development and GHCI

During development, I load the library into GHCI using stack ghci server:lib. Once GHCI loads, I call devMain from the GHCI console. Once I change some code, I use Ctrl-C to kill the server, enter :reload into GHCI, and then call devMain again.

Test Suite

The server has a test suite using hspec-wai. The test suite contains a definiton of Settings containing the test settings and uses a custom hspec Example to provide access to the application under test.

import qualified Test.Hspec as H
import qualified Test.Hspec.Wai as HW

type MyTestSession = ReaderT Env HW.WaiSession
type MySpec = H.SpecWith (Env, Application)

instance H.Example (MyTestSession ()) where
    type Arg (MyTestSession ()) = (Env, Application)
    evaluateExample s p action =
        let run = action $ \(env, app) -> HW.runWaiSession (runReaderT s env) app
         in evaluateExample run p ($ ())

withSession :: MySpec -> H.Spec
withSession = H.beforeAll $ do
   env <- createEnv testSettings
   (_, app) <- makeApp env
   return (env, app)

The tests themselves are some tests to make sure the token decode is working and rejecting correctly, plus an interpreter for the test DSL written as part of the datastorage library. Recall that the datastorage library's test suite defined a DSL with actions such as CreateTeam and ExpectSucceedViewTeam. The interpreter in the datastorage library implemented these actions by making calls to the database, but here in the server test suite these actions are implemented using hspec-wai methods. This gives a large test suite for essentially free.