Mig by example

Mig is a lightweight and easy to use library to build servers in Haskell. It is sort of servant for Simple/Boring Haskell. This book is an example driven guide to the library.

The main features are:

• lightweight library

• easy to use. It has simple design on purpose

• it defines no custom server monads. I promise you

• expressive DSL to compose servers

• type-safe route handlers and conversions

• handlers are encoded with generic haskell functions

• built on top of WAI and warp server libraries.

• provides Swagger to your server with one-line of code

• relies on standard classes to compose servers. The server is a monoid

Example of hello world server:

import Mig.Json.IO

-- | Starts server on port 8085.
main :: IO ()
main = runServer 8085 server

-- | The server definition
server :: Server IO
server = "api/v1/hello" /. hello

-- | The handler definition as a function
hello :: Get (Resp Text)
hello = Send $ pure $ ok "Hello World"

How to install library

We can install it from hackage. we need to use the library mig-server

With cabal we can install it from Hackage:

cabal install mig-server --lib

With stack we can link to the repo in extra-deps

TODO: example here

Sturcuture of the library

There are several libraries:

• mig - core library which defines DSL to build servers with API-schemas and functions to render it to low-level representation.
• mig-extra - extra addons to the core library
• mig-server - mig core with batteries and functions to run servers on top of warp.
• mig-client - HTTP-clients from the server code
• mig-wai - connvert mig servers to WAI-applications
• mig-swagger-ui - serve swagger for you app.

Source code for examples

We are going to learn how the mig works by examples. You can run the examples from the tutorial. Here is the code that we are going to study. Look at the Makefile for commands on how to build and run the examples.

Let's dive in to the first example.

Comparing to other libraries

Why to use mig if there are other cool libraries? To me mig lies in the middle ground between servant and scotty. It's as simple as scotty and does not go to fancy type road as servant. But it is akin to servant in usage of type-safe conversions and type-level safety.

servant

The mig uses the same ideas of type-safe handlers which a re based on generic Haskell functions. The main difference is that in servant th whole server is described as type. Which leads to type-safety and ability to derive API sche, from the type.

But downside of it is fancy big types and whery advanced concepts that user needs to know in order to use the library. Also one drawback to me is when things go wrong and you get several pages long error messages. If your server is really big it can be very hard to spot the origin of the error as type mismatch is going to be with the whole type which describes the full server.

The mig borrows idea of type-safe functions to represent route handlers. But types represent only individual handlers. It does not describe the full server. But we have typesafety on the level of the single route. And error messages are going to be localised and dedeicated to a single route.

Using type-level description of the routes provide the same benefits as in serbvant case:

• safe type check of the conversions of low level request and response elements
• usage of generic haskell functions as handlers
• declarative design of the servers

In the mig API is a value that is derived from the server at run-time. It allows us to build clients and OpenApi swagger too.

To me servant is more demanding and complicated solution. I'd like to use something more simple.

scotty

The scotty is also in domain of simple, easy to use solutions. so why did I wrote mig and havn't used the scotty instead? Scotty features more imperative approach where you write handlert as expression for Scotty library monad. But it does not looks so well as in servant's case to me. It is harder to assemble servers from parts. and I really like the idea of type-safe convertions of various parts of request and response.

Hello world

Let's build hello world application. We are going to build simple JSON API server with single route which replies with constant text to request

We have installed the library mig-server. Let's import the main module. It brings into the scope all main functions of the library:

module Main where

import Mig

Let's define a server with single route:

server :: Server IO
server = "api/v1/hello" /. hello

hello :: Get IO (Resp Json Text)
hello = undefined

So we serve single route with path "api/v1/hello". Let's cover the types first.

The server type

The server is a description of both OpenAPI schema for our server and low-level function to run it. In the library it is a newtype wrapper:

newtype Server m = Server (Api (Route m))

The Api type is a value to describe the API schema and Route contains useful info on the type of the route (method, decription of the inputs and outputs). The server is parametrized by some monad type. For this example we use IO-monad. It means that all our hadnlers are going to return IO-values.

How to link paths to handlers

To bind path "api/v1/hello" to handler hello we use function (/.). Let's look at it's type signature:

(/.) :: (ToServer a) => Path -> a -> Server (MonadOf a)

It expects the Path which has instance of class IsString that is why we can use plain strings for it. the second argument is something that is convertible to Server. Here we use trick to be able to use arbitrary haskell functions as handlers. We have special class called ToServer which can convert many different types to Server.

The output type is abit tricky: Server (MonadOf a). The MonadOf is a type function which can extract m from (Server m). Or for example it can extract m from the function request -> m response. So the MonadOf is a way to get underlying server monad from any value.

Let's be more specific and study our example. The type of the handler is Get IO (Resp Text) In our case we get:

(/.) :: Path -> Get IO (Resp Text) -> Server IO

The type-level function MonadOf knows how to extract IO from Get IO (Resp Text).

The type of response

Let's stydy the signature of the hello handler:

hello :: Get IO (Resp Json Text)
          |  |    |     |    |
          |  |    |     |    +-- response body converted to byte string
          |  |    |     |
          |  |    |     +---- codec to convert it 
          |  |    |           (the media-type route uses for response body)
          |  |    |
          |  |    +---- type of response which holds HTTP-response info with result
          |  |
          |  +----- the server monad. Our handler returns values in this monad
          |
          +----- http method encoded as a type

The type Get is a synonym for more generic Send type:

type Get m a = Send GET m a

The type Send is just a wrapper on top of monadic value:

newtype Send method m a = Send (m a)

It encodes HTTP-method on type level. This is useful to aggregate value for API-schema of our server. We have type synonyms for all HTTP-nethods (Get, Post, Put etc).

It's interesting to know that library mig does not use any custom monads for operation. Instead it runs on top of monad provided by the user. Usually it would be IO or Reader over IO.

HTTP-response type

Let's study the Resp type. It is a type for HTTP response. It contains the value and additional HTTP information:

-- | Response with info on the media-type encoded as type.
data Resp media a = Resp
  { status :: Status
  -- ^ response status
  , headers :: ResponseHeaders
  -- ^ response headers
  , body :: Maybe a
  -- ^ response body. Nothing means "no content" in the body
  }
  deriving (Show, Functor)

The type argument media is interesting. It gives a hint to the compiler on how to convert the body to low-level byte string representation. In our example we use type-level tag Json to show that we are going to convert the result to JSON value in the response. So in our case of Resp Json Text we are going to return Text which will be converted to JSON value.

To return successful response there is a handy function:

ok :: a -> Resp media a

It returns response with 200 ok-status and sets Content-Type header to proper media-type.

Define a handler

Let's complete the example and define a handler which returns static text:

hello :: Get IO (Resp Json)
hello = Send $ pure $ ok "Hello World!"

We have several wrappers here:

• ok - converts text value to http-response Resp Json Text
• pure - converts pure value to IO-based value
• Send - send converts monadic value to server. It adds information on HTTP-method of the return type.

Run a server

Let's run the server with warp. For that we define the main function for our application:

main :: IO ()
main = do
  putStrLn $ "Server starts on port: " <> show port
  runServer port server
  where
    port = 8085

That's it! We can compile the code and run it to query our server. We use the function runServer:

runServer :: Int -> Server IO -> IO ()

It renders our server to WAI-application and runs it with warp.

Complete code for the example

module Main (main) where

import Mig

main :: IO ()
main = do
  putStrLn $ "Server starts on port: " <> show port
  runServer port server
  where
    port = 8085

server :: Server IO
server = "api/v1/hello" /. hello

hello :: Get IO (Resp Json)
hello = Send $ pure $ ok "Hello World!"

If we run the code we can test it with curl in command line:

> curl http://localhost:8085/api/v1/hello

"Hello World!"

Add more routes

Let's define another handler to say bye:

bye :: Get IO (Resp Json)
bye = Send $ pure $ ok "Goodbye"

We can add it to the server with monoid method as Server m is a Monoid:

server :: Server IO
server = 
  "api/v1" /.
    mconcat
      [ "hello" /. hello
      , "bye" /. bye
      ]

The meaning of the monoid methods for Server:

• mempty - server that always fails on any request
• a <> b - try to serve the request with server a if it succeeds return the result. If it fails try to serve with server b.

So we have just two functions to build nested trees of servers:

• path /. server - to serve the server on specific path
• mconcat [a, b, c, d] - to combine several servers into one

Note that we can have several handlers on the same path if they have different methods or media-types for output or input:

server = 
  "api/v1" /.
    mconcat
      [ "hello" /. helloGet
      , "hello" /. helloPost
      ]

helloGet :: Get IO (Resp Json Text)
helloPost :: Post IO (Resp Json Text)

Servers on the same path are also distinguished by:

• http-method
• media-type of the result (value of "Accept" header)
• media-type of the request (value of "Content-Type" header)

Subtle nuance on Monoid instance for Server

Yuo may ask: why not to write the previous example like this:

server = 
  "api/v1/hello" /.
    mconcat
      [ helloGet
      , helloPost
      ]

There is a subtle nuance here. The Server m is a Monoid. But the value Send method m a is not. So we use the function (/.) which converts the second argument to Server. If we want to convert we can use the method of the class ToServer:

toServer :: ToServer a => a -> Server (MonadOf a)

So the right way to avoid duplication in path is:

server = 
  "api/v1/hello" /.
    mconcat
      [ toServer helloGet
      , toServer helloPost
      ]

Regarding the previous example we could not use mconcat even if we wnated to. Because handelGet and handlePost have different types. They can not be even put in the same list. But here lies the beauty of the library. We can use arbitrary types as handlers but in the end they all get converted to the value Server m. So we have the flexibility on DSL level but on the level of implementation to build the tree of handlers we use the same type. which makes type very simple.

List instance for Servers

Because of the ToServer a => ToServer [a] instance we can omit the mconcat most of the time. Meaning we can write the previous examples as:

server = 
  "api/v1/hello" /.
      [ toServer helloGet
      , toServer helloPost
      ]

The path type

Let's discuss the Path type. It is a list of atomic path items:

newtype Path = Path [PathItem]
  deriving (Show, Eq, Semigroup, Monoid)

The path item can be of two types:

data PathItem 
  = StaticPath Text
  | CapturePath Text

The static path item is a rigid entity with exact match to string. We used it in all our examples so far. but capture is wild-card that is going to be used as input to the handler.

To construct only rigid paths we can use strings:

"ap1/v1/get/blog/post"
"foo/bar"

To get captures we use *-wildcard:

api/v2/*/get

In the star request captures any text. There might be as many stars in the path as you wish. But they should be supported by the handler. We will touch upon that later.

It's good to know that path is a special type which can be constructed from strings (use OverloadedStrings extension). And we can two types of atomic path elements. Static items and capture parameters. We will deal with captures in the next example.

Anatomy of the request

For the next example we are going to try all sorts of inputs which are possible for the handler.

Useful presets for servers

Before we dive into various parts of the handler I'd like to introduce couple of useful modules that make servers more specific. Often we don't need the most generic types. If we know that all our servers will serve JSON and use only IO monad we can use a special version of the Mig module:

import Mig.Json.IO

It will provide several wrappers to simplify type signatures for handlers:

type Get a = Send GET IO a
type Post a = Send POST IO a

also it provides more specific response type:

newtype Resp a = Resp (Core.Resp Json a)

For the next example we are going to build JSON-application again. So instea of more general Mig we will use Mig.Json.IO.

Also there are similiar modules for:

• IO-based servers
• Html servers with generic monad
• Json servers with generic monad
• Json+IO servers
• Html+IO servers

Servers for HTML take one step further and remove Resp from the equation:

type Get a = Send GET IO (Resp Html a)
type Post a = Send POST IO (Resp Html a)

There is one reason why we do not do that for JSON. But we will study it later.

Http request

In previous example we could query by static path. Let's do something more funcy and provide the input for the handler.

we have several types of inputs in HTTP:

• query parameters. We can see them in the path "api/get/route?queryName=queryValue"

• capture parameters. We can see them also in the path, but they are inlined right into it: api/get/route/someCaptureValueA/someCaptureValueB

• header parameters. They are in HTTP-request headers. For example header that reports media-type of the request body: "Content-Type: application/json"

• request body. It is avalue packed into HTTP-request. It can be JSON or text or raw string or XML. All sorts of things can be used as request bodies.

To use any of HTTP inputs in the handler we use special newtype wrappers as arguments to the handler functions.

Query parameter example

For example let's alter hello handler to greet not the "World" but someone by the name:

hello :: Query "who" Text -> Get (Resp Text)
hello (Query name) = Send $
  pure $ ok $ "Hello " <> name 

Note that we have imported Mig.IO.Json and our types are more specific and have fewer arguments. All types are dedicated to IO and Json. So we can write Get (Resp Text) instead of Get IO (Resp Json Text).

Interesting part of the handler is that qrgument: Query "who" Text. On the API level it creates expectation for a required query parameter in the path. The Query is a simple newtype wrapper:

newtype Query name value = Query value

The cool part of it is that code for the server does not change:

server :: Server IO
server = "api/v1/hello" /. hello

There is no change because function (/.) is overloaded by second argument. and it accepts all sorts of inputs. One of them states:

if value a is convertible to server then Query name value -> a is also convertible to server

and by this magic as all haskell functions are curried we can use any number of queries in the handler. For example if we want to greet two persons we can write:

hello :: Query "personA" Text -> Query "personB" Text -> Get (Resp Text)
hello (Query nameA) (Query nameB) = Send $
  pure $ ok $ "Hello " <> nameA <> " and " <> nameB   

Also we can input any type if it has instance of the classes FromHttpApiData and ToParamSchema. For example let's add two numbers:

add :: Query "a" Int -> Query "b" Int -> Get (Resp Int)
add (Query a) (Query b) = Send $
  pure $ ok (a + b)

The rest of the inputs

All other input parameters work in the same way as a Query. we have a newtype wrapper for the value and type denotes all useful info for API description of the handler.

Let's for example query numbers for addition as capture parameters:

add :: Capture "a" Int -> Capture "b" Int -> Get (Resp Int)
add (Query a) (Query b) = Send $
  pure $ ok (a + b)

It will expect the path to be "api/v1/add/2/4". Other wrappers look very similiar:

• Header name value - for required headers
• OptionalHeader name value - for optional headers
• Capture name value - for path captures
• Optional name value - for optional queries
• QueryFlag - for booleab query that can be missing in the path (and then it is false)
• Body media value - for request body

Using custom types as query parameters

The value of query parameter should have two instances of classes. We need:

• FromHttpApiData from the library http-api-data to convert to value from piece of the URL.

• ToParamSchema from the library openapi3 to describe parameter type in the OpenApi schema.

Let's create a custom type and provide those instances:

newtype AuthToken = AuthToken Text
  deriving newtype (FromHttpApiData, Eq, Ord, ToParamSchema)

We can derive them for newtype wrappers. Aftr that we can use AuthToken as value to get from query parameter. For more info on how to derive those instances see the docs for the libraries. It's easy to do. We can derive Generic for the data type and derive ToParamSchema with it.

The same instances we need for all parameters-like inputs: queries, headers, captures.

Nuances for Capture

The capture is interesting because it can be anywhere in the path. for the example we havn't altered the server and our example:

add :: Query "a" Int -> Query "b" Int -> Get (Resp Int)
add (Query a) (Query b) = Send $
  pure $ ok (a + b)

server = "api/v1/add" /. add

The server expects strings with template:

api/v1/add/{int}/{int}

So for missing captures it inserts them. It is the same as to write:

server = "api/v1/add/*/*" /. add

We denote capture with *-wildcard. If we want the capture to be in another place in the path just put a star there:

server = "api/v1/*/*/add-me" /. add

The server expects strings with template as path:

api/v1/{int}/{int}/add-me

Json request body

I guess that JSON body as request is going to be the most popular case among all inputs. So let's take a closer look at it as it often requires the custom type.

Let's add two numbers and provide input with request body:

data AddInput = AddInput
  { a :: Int
  , b :: Int
  }
  deriving (Generic, FromJSON, ToSchema)

-- | Using JSON as body request
handleAddJson :: Body AddInput -> Post (Resp Int)
handleAddJson (Body (AddInput a b)) = Send $ 
  pure $ ok $ a + b

In the core mig library the type Body has two type arguments. But as we use Json specification the first argument for Mig.Json.IO as for Mig.Json is always Json-tag. So those modules provide special case alternative for type Body. But in the mig library it uses the same idea as we saw in the query parameter. It is just a newtype wrapper for the value.

To be able to use it as input for the handler we have to provide instances for several types:

• FromJSON from aeson library to parse value as JSON from byte string
• ToSchema from openapi3 library to describe it in the API-schema

both of the types can be easily derived with Generic instance (from the module GHC.Generics). First we derive instance of the Generic and then we can derive both FromJSON and ToSchema:

data AddInput = AddInput
  { a :: Int
  , b :: Int
  }
  deriving (Generic, FromJSON, ToSchema)

also there are many libraries on hackage to create custom derivings for those classes: deriving-aeson, aeson-deriving and many others.

So to use JSON request body we can define our own type, derive proper classes and we are done.

Let's build a server

Let's recap on what we have learned and build server with various request inputs:

module Main (main) where

import Mig.Json.IO

main :: IO ()
main = runServer 8085 server

-- | Let's define a server
server :: Server IO
server = 
  "api" /.
    -- no args, constnat output
    [ "hello/world" /. helloWorld
    , -- required query param and custom header
      "succ" /. handleSucc
    , -- optional query param
      "succ-opt" /. handleSuccOpt
    , -- several query params
      "add" /. handleAdd
    , -- query flag
      "add-if" /. handleAddIf
    , -- capture
      "mul" /. handleMul
    , -- json body as input
      "add-json" /. handleAddJson
    ]

-- | Simple getter
helloWorld :: Get (Resp Text)
helloWorld = Send $ do
  pure $ ok "Hello world!"

newtype TraceId = TraceId Text
  deriving newtype (FromHttpApiData, ToHttpApiData, ToText, ToParamSchema)

{-| Using several inputs: header argument and required query
and using conditional output status
-}
handleSucc :: Header "Trace-Id" TraceId -> Query "value" Int -> Get (Resp Int)
handleSucc (Header _traceId) (Query n) = Send $ do
  pure $ ok (succ n)

-- | Using optional query parameters.
handleSuccOpt :: Optional "value" Int -> Get (Resp Int)
handleSuccOpt (Optional n) = Send $ do
  pure $ case n of
    Just val -> ok (succ val)
    Nothing -> ok 0 

{-| Using several query parameters
-}
handleAdd :: Query "a" Int -> Query "b" Int -> Get (Resp Int)
handleAdd (Query a) (Query b) = Send $ do
  pure $ ok $ a + b

-- | Using query flag if flag is false returns 0
handleAddIf :: Query "a" Int -> Query "b" Int -> QueryFlag "perform" -> Get (Resp Int)
handleAddIf (Query a) (Query b) (QueryFlag addFlag) = Send $ do
  pure $
    ok $
      if addFlag
        then (a + b)
        else 0

{-| Using capture as arguments. This route expects two arguments
captured in URL. For example:

> http://localhost:8085/hello/api/mul/3/100
-}
handleMul :: Capture "a" Int -> Capture "b" Int -> Get (Resp Int)
handleMul (Capture a) (Capture b) = Send $ do
  pure $ ok (a * b)

data AddInput = AddInput
  { a :: Int
  , b :: Int
  }
  deriving (Generic, ToJSON, FromJSON, ToSchema)

-- | Using JSON as input
handleAddJson :: Body AddInput -> Post (Resp Int)
handleAddJson (Body (AddInput a b)) = Send $ do
  pure $ ok $ a + b

Curls to test the routes:

curl http://localhost:8085/api/hello/world

curl -X 'GET' \
  'http://localhost:8085/api/succ?value=2' \
  -H 'accept: application/json' \
  -H 'Trace-Id: xyz-trace'

curl -X 'GET' \
  'http://localhost:8085/api/add-if?a=2&b=4&perform=true' \
  -H 'accept: application/json'

curl -X 'GET' \
  'http://localhost:8085/api/mul/100/23' \
  -H 'accept: application/json'

Adding some goodies to the servers

There are some useful addons that make development of the servers much more pleasant. Let's discuss couple of them.

Add swagger

Making curl request can quickly become hard to manage as our servers become more complicated. There is OpenAPI standard that defines how to describe HTTP-server API. Also it provides Swagger. It is a tool to make it easy to check how server behaves. It pprovides an HTTP-client for the server which allows us to query server routes.

Let's add a swagger to our server. Just add this line:

server :: IO
server = 
  withSwagger def $ 
    "api" /. [ {- the rest of the code -} ]

Let's add this line to our example and restart the server. By default it creates a route for the server that serves Swagger UI client at the path: http://localhost:8085/swagger-ui/. It is easy to query the routes with swagger ui.

We can add swagger to any server with function:

withSwagger :: SwaggerConfig m -> Server m -> Server m

We will study the ServerConfig in details in one of the next chapters but for now the default value whcih is set with def from library data-default is fine.

Add simple logs to the server

We can look at the request and trsponse data with tracing functions which come from library mig-extra from the module Mig.Extra.Plugin.Trace:

data Verbosity = V0 | V1  | V2 | V3

-- log http requests and responses
logHttp :: Verbosity -> Plugin m

-- | log requests
logReq :: Verbosity -> Plugin m

-- | Log responses
logResp :: Verbosity -> Plugin m

The Plugin m is a function that can be applied to all routes of the server and modify their behavior. To apply plugin to server we can use functions:

applyPlugin :: Plugin m -> Server m -> Server m

($:) :: Plugin m -> Server m -> Server m

We show simplified signatures here. The real ones are overloaded by the first argument. but we will dicuss plugins in depth in the separate chapter. For now it's ok to assume that those functions are defined in that simplified way.

So let's look at the data that goes through our server:

import Mig.Extra.Plugin.Trace qualified as Trace

...

server = 
  withSwagger def $ 
    withTrace $ {-# the rest of the server code #-}
  where
    withTrace = applyPlugin (Trace.logHttp Trace.V2)

Let's restart the server and see what it logs:

log:
  body: ''
  headers:
    accept: application/json
  method: GET
  path: api/add?a=12&b=45
  time: 2023-10-05T16:29:16.262934Z
  type: http-request

log:
  body: 57
  duration: 9.750000000000001e-4
  headers:
    content-type: application/json
  method: GET
  path: api/add?a=12&b=45
  status: 200
  time: 2023-10-05T16:29:16.263903Z
  type: http-response

This isan easy way to add addhock logs to the application. Note that those logs are not aware of concurrency and will report intermingled messages on concurrent queries.

We can add real loggs with more generic versions of the functions which accept callback and we can pass the logger function defined in terms of one of the standard haskell logging libraries, say katip or fast-logger:

import Data.Aeson as Json

logHttpBy :: (Json.Value -> m ()) -> Verbosity -> Plugin m

Summary

We have learned how various parts of the requests can be queries with newtype wrappers. There are only handful of them. we can query

• Query name value - for required queries
• Body media value - for request body
• Optional name value - for optional queries
• Header name value - for required headers
• OptionalHeader name value - for optional headers
• Capture name value - for path captures
• QueryFlag - for booleab query that can be missing in the path (and then it is false)

We have learned to use specialized versions for servers which operate only in terms of IO or Json. We can import the module Mig.Json.IO and our signatures would bcome more simple and specific.

we have learned how by ony-liners we can add to the server some useful features:

• swagger: (withSwagger def server) For calls to the server in the UI

• trace logs: (applyPlugin (logHttp V2)) To see the data that flows through the server

Both expressions transform servers and have signatures:

Server m -> Server m

Anatomy of the response

For the next example we are going to study which outputs can handler produce. Let's study the HTTP-response.

Http response

We already have seen the Resp data type in the first chapter:

-- | Response with info on the media-type encoded as type.
data Resp media a = Resp
  { status :: Status
  -- ^ response status
  , headers :: ResponseHeaders
  -- ^ response headers
  , body :: Maybe a
  -- ^ response body. Nothing means "no content" in the body
  }
  deriving (Show, Functor)

It is the main type to return values and additional HTTP-information from response.

An HTTP-response contains:

• integer status. It's 200 when everything is allright
• list of headers which provide useful info on response type
• the byte string body which contains result of handler operation. It can hold JSOn, HTML, plain text, raw byte string and other types of outputs.

In the Resp type the media type argument specifies which type the body has. By this type handler knows how to convert value to low-level byte string representation.

When things go bad

Sometimes things go bad and we would like to send errors and state in the status the type of the error. To report errors we have special type RespOr:

-- | Response that can contain an error. The error is represented 
-- with left case of an Either-type.

newtype RespOr ty err a = RespOr {unRespOr :: Either (Resp ty err) (Resp ty a)}

So this value has two possible responses which share the same media type. We need two different responses to be able to report errors with different type than the type of the result.

Response type class IsResp

To unify the output we have special type class called IsResp for all types which can be converted to low-level HTTP-response type Response.

Let's study this type class. It has two associated types for the type of the body (RespBody) and type of the error (RespError):

class IsResp a where
  type RespBody a :: Type
  type RespError a :: Type

We can return successful result with method ok:

  -- | Returns valid repsonse with 200 status
  ok :: RespBody a -> a

When things go bad we can report error with method bad:

  -- | Returns an error with given status
  bad :: Status -> RespError a -> a

Sometimes at rare cases we do not wnat to return any content from response. we can just report error status and leave the body empty:

  -- | response with no content
  noContent :: Status -> a

We can add custom headers to the response by method addHeaders:

  -- | Add some header to the response
  addHeaders :: ResponseHeaders -> a -> a

Note that header Content-Type is set automatically. Although sometimes we would like set it explicitly. For that we have the method:

  -- | Set the media type of the response
  setMedia :: MediaType -> a -> a

also the core of the class is the method to convert value to low-level response:

  -- | Converts value to low-level response
  toResponse :: a -> Response

Both Resp and RespOr are instances of IsResp class and we can Send as HTTP-response anything which has instance of IsResp. For now there are only three types. The third one is the low-level Response.

Examples

So we use Resp if we are sure that handler always produce a value and we use RespOr if handler can produce and error.

How to return error

We already have seen many usages of Resp type. Let's define something that can produce an error. Let's define server that calculates square root of the value. For negative numbers it is not defined in the realm of real numbers. So let's define the handler that use RespOr type:

import Mig.Json.IO

server :: Server IO
server = 
  "square-root" /. squareRoot

squareRoot :: Body Float -> Post (RespOr Text Float)
squareRoot (Body arg) = Send $ pure $
  if arg >= 0 
    then ok (sqrt arg)
    else bad badRequest400 "Argument for square root should be non-negative"

So we return error message and bad request status 400 when negative argument is passed to the handler.

Also note this function looks like pure GET-type function but by the HTTP rules we can not have body request in the GET-method. So we use POST instead.

Also we have special case function for bad requests called badReq. The values for status come from the library http-types. See the module dediicated to HTTP-statuses. It is reexported by the mig library.

How to set headers

For example in the Header we expect trace id with which we can find the request and response in the logs. And we want to pass the trace id from request to the response. Let's do it with addHeaders:

passTrace :: Header "trace-id" Text -> Post (Resp ())
passTrace (Header traceId) = Send $ 
  pure $ addHeaders [("trace-id", toHeader traceId)] $ ok ()

The function toHeader is re-exported from the library http-api-data. It converts various values to header byte string.

also there is a function if we want to add only one header and not a list of them:

setHeader :: (IsResp a, ToHttpApiData h) => HeaderName -> h -> a -> a

It has toHeader built into it.

Just like we set headrs we also can set HTTP-status of the response. we just apply it to Resp-like value. It works both for Resp and RespOr:

setStatus :: IsResp a => Status -> a -> a

Although we rarely need this function as ok sets the right status for successful response and all functions that need the status take it as argument.

How it works with server definition

How we can use both of the types as responses: Resp and RespOr. Recall that /. function is overloaded by the second argument and we have a rule for ToServer class thar:

if a has IsResp instance then Send method m a is convertible to server

As for both Resp and RespOr the inctance for IsResp is defined we can use both types as a result of the HTTP-handler.

Summary

We have learned that there are only tow types to return from server handler:

• Resp for handlers that always produce a value
• RespOr for handlers that can fail

The need for the second type is to have different type of the error and different for the result. If both error and result have the same type then we can use Resp. This is common case for HTML servers when we return HTML-page as result. In case of error we would like to show the page too as in case of success. The difference would be in the HTTP-status of the response.

And this goes well with IsResp class as for Resp media a error type RespError equals to a as the value for RespBody too.

Also we have learned various methods of the IsResp class and how they can be useful in server definitions.

With this chapter we have covered both requests and responses and which types the can have. See the source code RouteArgs for examples on the topic that we have just studied.

Using other monads with Server

So far we have seen only IO monad to be used with Server. But we can use other monads with it. Although so far only three types of monads are supported for Servers:

• IO-monad
• ReaderT env IO and newtype wrappers on top of it
• ReaderT env (EitherT IO) and new type wrappers on top of it

So the library is limited in monad choice but all of the cases can cover everything you need from the server. I personally prefer to just use IO and pass environment around to handlers. This process can be automated with ReaderT monad. Let's study how to use ReaderT with the server.

As example we will build a server that contains mutable state. It has internal counter which we can query and increment. To store the internal state as shared envirnment for all handlers we are going to Reader-pattern or server with ReaderT over IO monad.

Reader-pattern

Our server is Json-based but we want custom monad. So we can import the preset module for Json:

import Mig.Json

also we import ReaderT from mtl library and IORef to store mutable shared state:

import Control.Monad.Reader
import Data.IORef

Let's define a type for our application:

newtype App a = App (ReaderT Env IO a)
  deriving newtype (Functor, Applicative, Monad, MonadReader Env, MonadIO, HasServer)

{-| Common shared state
We can put more shared state if we need. Like logger state or some interfaces.
-}
data Env = Env
  { current :: IORef Int
  }

-- | Init shared state
initEnv :: IO Env
initEnv = Env <$> newIORef 0

HasServer class

We declare it as newtype-wrapper with ReaderT under the hood. We can derive all the classes that we need to use it as Reader. All classes but last are common repertiore of the haskeller. The last class HasServer is special to mig library. It can be also auto-derived as the instance for ReaderT+IO is already defined.

The HasServer class defines how to convert our special monad m server to Server IO. For a reader it defines a method:

  renderServer :: Server (ReaderT env m) -> env -> IO (Server IO)

So if we pass the common shared environment env to server we can use it as Server IO. We need to convert to Server IO becuase for WAI and warp we can run only Server IO based servers. As in library mig-wai:

toApplication :: Server IO -> Wai.Application

How to run Reader based server

So to run the readerT server we need to convert it to IO-based server and we can run it with usual runServer function:

main :: IO ()
main = do
  env <- initEnv 
  putStrLn ("The counter server listens on port: " <> show port)
  runServer port . withSwagger def =<< renderServer server env
  where
    port = 8085

server :: Server App

Here we also add the swagger to the server for easy testing and trying things out with swagger.

Note that we use bind operator:

  runServer port =<< renderServer server env

Server with Reader monad

Our server has two routes:

• get - to querry current state
• put - to add some integer to the state

server :: Server App
server =
  "counter"
    /. [ "get" /. handleGet
       , "put" /. handlePut
       ]

Let's define the get route:

-- | Get handler. It logs the call and returns current state
handleGet :: Get App (Resp Int)
handleGet = Send $ do
  logInfo "Call get"
  ref <- asks (.current)
  liftIO $ ok <$> readIORef ref

-- | Helper to do simple logging
logInfo :: String -> App ()
logInfo message = liftIO $ putStrLn $ "[INFO] " <> message

So we ask for the common mutable state and read it with readIORef function. Also we use liftIO to lift IO result to App monad. We just use App monad inside Send-wrapper to create a handler.

LEt's define the put handler:

-- | Put handler. It logs the call and updates 
-- the state with integer which is read from URL
handlePut :: Capture "arg" Int -> Get App (Resp ())
handlePut (Capture val) = Send $ do
  logInfo $ "Call put with: " <> show val
  ref <- asks (.current)
  liftIO $ ok <$> atomicModifyIORef' ref (\cur -> (cur + val, ()))

We use atomicModifyIORef' to be safe in presence of concurrent requests. So we have completed the definition and we can run the app and try it out. You can find the complete code of the example in the mig repo.

Summary

In this chapter we have learned how to use Reader-monad with mig library. We can define our custom wrapper for ReaderT+IO and derive instance of HasServer and we are ready to go.

Plugins

A plugin is a transformation which is applied to all routes in the server. It is a pair of functions which transform API-description and server function:

data Plugin m = Plugin
  { info :: RouteInfo -> RouteInfo
  -- ^ update api schema
  , run :: PluginFun m
  -- ^ update server function
  }

-- | Low-level plugin function.
type PluginFun m = ServerFun m -> ServerFun m

To apply plugin to server we ca use function applyPlugin:

-- | Applies plugin to all routes of the server.
applyPlugin :: forall f. (ToPlugin f) => 
  f -> Server (MonadOf f) -> Server (MonadOf f)

There is also infix operatore for application ($:).

The class ToPlugin contains all types that can be converted to plugin. Here we use the same trick as with ToServer class to be able to read type-safe parts of the request and update the API-schema. The type-level function MonadOf knows how to find underlying monad m in various types.

We have recursive set of rules for types that can be converted to Plugin:

The identity rule:

PluginFun has instance of ToPlugin with obvious identity instance

Recursive steps for inputs

if f is ToPlugin then (Query name queryType -> f) is ToPlugin too

and so on for other types of request input (query params, headers, captures, request bodies). See the full list of instances in the module Mig.Core.Class.Plugin.

Examples

So the plugin allows us to apply some behavior to all routes in the server. Let's discuss some examples

Add logging

Let's add the logging to all methods which are called. We will log which route was called and we will include the time stamp and the full path in the log:

Let's imagine that we have a function

logInfo :: Text -> IO ()

We can query the path with PathInfo newtype:

newtype PathInfo = PathInfo [Text]

And we have a rule for ToPlugin class:

if f is ToPlugin then (PathInfo -> ToPlugin f) is ToPlugin

so we can create a plugin function:

logRoutes :: Plugin IO
logRoutes = toPlugin $ \(PathInfo pathItems) -> prependServerAction $ do
  now <- getCurrentTime 
  logInfo $ mconcat
    [ "Call route: ", Text.intercalata "/" pathItems 
    , " at ", Text.pack (show now)
    ]

We use function prependServerAction that creates a Plugin from actino which is performed prior to call to server function:

prependServerAction :: MonadIO m => m () -> Plugin m

also there are similar functions in the module: appendServerAction and processResponse.

Allow only secure routes

Another great example of plugin at work is to block routes on some conditions. For example if we want certain routes to be used only under secure SSL connection. We have a standard function for that whenSecure. But let's dive into it's definition to see how plugins can be used:

-- | Execute request only if it is secure (made with SSL connection)
whenSecure :: forall m. (MonadIO m) => Plugin m
whenSecure = toPlugin $ \(IsSecure isSecure) -> 
  processResponse (if isSecure then id else const (pure Nothing))

Here we use standard plugin processResponse which allows us to alter the result of the HTTP-response:

processResponse :: MonadIO m => 
  (m (Maybe Response) -> m (Maybe Response)) -> Plugin m

Also we use query input IsSecure which is true if connection is made over SSL:

newtype IsSecure = IsSecure Bool

So we pass through the response with identity if connection is secure and we block the execution by returning Nothing if connection is secure. The cool part of it is that due to Haskell's laziness there is no performance overhead and underlying route is not going to be performed if connection is insecure.

Authorization with plugin

Let's use this schema for authorization to site. There is a route that provides authorized users with session tokens. User can pass credentials as request body over secure connection and get session token in response which is valid for some time.

With that token user can access the rest of the application. User can pass token as special header. And we check in the application that token is valid.

Imagine that we have a type for a session token:

newtype AuthToken = AuthToken Text
    deriving newtype 
      (ToJSON, FromJSON, FromHttpApiData, Eq, Ord, Show, ToParamSchema, ToSchema)

And we can get it from some route:

getToken :: Body UserCreds -> Post (Resp AuthToken)

We would like to block invalid sessions for all routes of our site. We can create it in similiar way as whenSecure:

isValid :: AuthToken -> IO Bool
isValid = ...

headerAuth :: Header "auth" AuthToken -> Plugin IO
headerAuth (Header token) = processResponse $ \getResp -> do
  isOk <- isValid token
  if isOk
    then getResp
    else pure $ Just $ bad badRequest400 "Auth token is invalid"

whenAuth :: Server IO -> Server IO
whenAuth = applyPlugin headerAuth

In this example we use IsResp instance for low-level http Response to report authorization error. The header with name "auth" is required for all routes which are part of the server to which we apply the plugin.

Summary

In this chapter we have learned on plugins. They provide a tool to apply transformation to all routes in the server. Which can be useful for logging, authrization and adding common behavior to all routes.

How to use Swagger

The Swagger is a powerful tool to try out your servers. It provides easy to use Web UI to call routes in the server. We already saw know how to augment server with swagger. It is just a line of code:

withSwagger def server

The function withSwagger is defined in the package mig-swagger-ui which is re-exported by mig-server.

In this chapter we are going to learn how to tweak and fine-tune the swagger.

Swagger config

We have used default swagger config with constant def. Let's look at what can be configured:

data SwaggerConfig m = SwaggerConfig
  { staticDir :: Path
  -- ^ path to server swagger (default is "/swagger-ui")
  , swaggerFile :: Path
  -- ^ swagger file name (default is "swaggger.json")
  , mapSchema :: OpenApi -> m OpenApi
  -- ^ apply transformation to OpenApi schema on serving OpenApi schema.
  -- it is useful to add additional info or set current date in the examples
  -- or apply any real-time transformation.
  }

instance (Applicative m) => Default (SwaggerConfig m) where
  def =
    SwaggerConfig
      { staticDir = "swagger-ui"
      , swaggerFile = "swagger.json"
      , mapSchema = pure
      }

We can set in staticDir at what path to serve the swagger, how to name the swagger file with swaggerFile and which run-time transformation we apply to the OpenApi schema. We can use this mapping to add useful description to the app or keep examples up to date if they use for example timestamps that should be in the future to be valid.

Add description to application

Often we would like to provide short description of the application, which version it has. We can use the package openapi3 to update OpenApi directly. But also there is a helper type for most often used fields:

-- | Default info that is often added to OpenApi schema
data DefaultInfo = DefaultInfo
  { title :: Text
  , description :: Text
  , version :: Text
  }

addDefaultInfo :: DefaultInfo -> OpenApi -> OpenApi

We can set title, description and version for the application. Here is an example:

setSwagger :: Server IO -> Server IO
setSwagger = withSwagger config
  where
    config =
      (def :: SwaggerConfig IO)
        { mapSchema = pure . addDefaultInfo info
        }

    info =
      def
        { title = "Weather forecast"
        , description =
            "JSON API example for mig library which shows how to forecast weather to authorized users"
        , version = "0.1.0"
        }

Describe the routes

Often we would like to add some useful documentation on the routes. We can do it with the functions:

-- | Sets description of the route
setDescription :: Text -> Server m -> Server m

-- | Sets summary of the route
setSummary :: Text -> Server m -> Server m

-- | Adds OpenApi tag to the route
addTag :: Text -> Server m -> Server m

We can apply thos functions at definition of the route. Also we can describe the inputs for the route:

{-| Appends descriptiton for the inputs. It passes pairs for @(input-name, input-description)@.
special name request-body is dedicated to request body input
nd raw-input is dedicated to raw input
-}
describeInputs :: [(Text, Text)] -> Server m -> Server m

It takes a map from input parameter name to description. There is special name "request-body" for the request body input.

An example:

server = "calculator" /.
  mconcat
    [ describeAdd $ "add" /. add
    , describeMul $ "mul" /. mull
    ]
  where
    describeAdd = setDescription "Performs addition" . describeArgs
    describeMul = setDescription "Performs multiplication" . describeArgs

    describeArgs = describeInputs [("a", "first argument"), ("b", "second argument")]

add, mul :: Capture "a" Int -> Capture "b" Int -> Get (Resp Int)

Summary

In this chapter we have learned how to tweak our swagger servers and make them more user-friendly.

JSON example: weather forecast

We have learned all we need to know about mig to be able to build something cool with it. Let's build a weather forecast application. The app has registered users which can request authroization tokens. With that token users can request for weather in specific city and on specific time and also they can update the weather data. For simplicity we omit user registration and defining roles for the user.

Domain for our application

Let's define main types for our application in the module Types.hs. We will import Mig.Json.IO to bring in scope some classes and types common for HTTP-servers:

module Types where

import Data.Time (Day)
import Mig.Json.IO

Domain of users

There are users in the application that can register and get session tokens:

data User = User
  { name :: Text
  , pass :: Text
  }
  deriving (Generic, ToJSON, FromJSON, ToSchema)

newtype AuthToken = AuthToken Text
  deriving newtype 
    (ToJSON, FromJSON, FromHttpApiData, Eq, Ord, Show, ToParamSchema, ToSchema)

We need instances to pass the dat over HTTP wires.

Domain of weather

We are going to query weather info by location and date:

newtype DayInterval = DayInterval Int
  deriving newtype (ToJSON, FromJSON, FromHttpApiData, ToParamSchema)

data Timed a = Timed
  { from :: Day
  , content :: [a]
  }
  deriving (Generic, ToJSON, FromJSON)

deriving instance (ToSchema a) => ToSchema (Timed a)

newtype Location = Location Text
  deriving newtype 
    (ToJSON, FromJSON, FromHttpApiData, Eq, Ord, Show, ToParamSchema, ToSchema)

The weather has information on temperature, speed of the wind, sun/rain nratio and pressure:

data WeatherData = WeatherData
  { temperature :: Int
  , windSpeed :: Int
  , sunRainRatio :: Int
  , pressure :: Int
  }
  deriving (Generic, ToJSON, FromJSON, ToSchema)

Also some users can update DB of weather:

-- | Update weather data
data UpdateData = UpdateData
  { day :: Day
  , location :: Location
  , content :: WeatherData
  }
  deriving (Generic, ToJSON, FromJSON, ToSchema)

That is our domain for the weather application.

Lets define a server

We are going to build JSON HTTP application. For that we will use module Mig.Json.IO which provides handy types specified to our domain. We expect our application to have shared context Env which we pass to all handlers.

import Mig.Json.IO
import Types

server :: Env -> Server IO
server env =
  withSwagger def $
    "api/v1/weather"
      /. [ auth
         , withAuth env $: app
         ]
  where
    auth = "get/auth-token" /. requestAuthToken env

    app =
      mconcat
        [ "get/weather" /. getWeather env
        , "update" /. updateWeather env
        ]

-- | Site internal shared context
data Env = Env

-- weather

getWeather ::
  Env ->
  Capture "location" Location ->
  Capture "day" Day ->
  Capture "day-interval" DayInterval ->
  Get (RespOr Text (Timed WeatherData))
getWeather = undefined

updateWeather ::
  Env ->
  Body UpdateData ->
  Post (RespOr Text ())
updateWeather = undefined

-- users

requestAuthToken :: Env -> Body User -> Post (RespOr Text AuthToken)
requestAuthToken = undefined

withAuth :: Env -> Header "auth" AuthToken -> Plugin IO
withAuth = undefined

we have one route to query for token:

requestAuthToken :: Env -> Body User -> Post (RespOr Text AuthToken)

and two routes that query info on weather and update it:

getWeather ::
  Env ->
  Capture "location" Location ->
  Capture "day" Day ->
  Capture "day-interval" DayInterval ->
  Get (RespOr Text (Timed WeatherData))

updateWeather ::
  Env ->
  Body UpdateData ->
  Post (RespOr Text ())

also we have a plugin that filters out non aunthorized calls:

withAuth :: Env -> Header "auth" AuthToken -> Plugin IO

From its type-signature we can assume that authroization token is passed in the header of the request.

The structure of the server

We define server as a collection of actions that can be performed. The server is defined in terms of interfaces. We can initialize those interfaces and pass them to handlers.

Our app has several domains:

• users and sessions

• weather DB interface

• process lifecycle: logging, startup, cleanup, etc

So the server enironment has three parts:

data Env = Env
  { auth :: Auth
  , weather :: Weather
  , proc :: Proc
  }

Let's define operations for those domains. We define them in the module Interface.hs.

User domain

For the user we can do

• check that user is valid and can use the app

• allocate new authorization token

• check that token is valid

• expire the token (make it invalid)

-- authorization interface
data Auth = Auth
  { newToken :: User -> IO AuthToken
  , validUser :: User -> IO Bool
  , validToken :: AuthToken -> IO Bool
  , expireToken :: AuthToken -> IO ()
  }

Weather domain

For the weather we can query info and update it:

-- weather forecast interface
data Weather = Weather
  { get :: Location -> Day -> DayInterval -> IO (Maybe (Timed WeatherData))
  , update :: UpdateData -> IO ()
  }

Process domain

For the application process we keep all server lifecycle tools which are not related to business logic domain. It can be logging, metrics, startup and cleanup actions:

-- | Process interface
data Proc = Proc
  { startup :: IO ()
  , cleanup :: IO ()
  , Logger :: Logger
  }

-- logger interface
data Logger = Logger
  { info :: LogFun
  , debug :: LogFun
  , error :: LogFun
  }

type LogFun = Value -> IO ()

We log JSON-values. As a helper functions we create funcitions that can log anything which is convertible to JSON:

logInfo :: (ToJSON a) => Env -> a -> IO ()
logInfo env = env.proc.logger.info . toJSON

logDebug :: (ToJSON a) => Env -> a -> IO ()
logDebug env = env.proc.logger.debug . toJSON

logError :: (ToJSON a) => Env -> a -> IO ()
logError env = env.proc.logger.error . toJSON

Using interfacs

It's interesting to note how all actions on shared state can be expressed as interfaces. We will declare the concrete mutable representation later but for now it is ok to hide them with not implemented yet functions. This also allows us to create mock applications for testing and substitute implementations without changing the code for the server.

Define server in terms of interfaces

As we have defined the main operations of the application we can complete the definition of the server. Let's define the routes for weather domain first as they are more simple.

Weather domain

We can query the weather forecast with function:

getWeather ::
  Env ->
  Capture "location" Location ->
  Capture "day" Day ->
  Capture "day-interval" DayInterval ->
  Get (RespOr Text (Timed WeatherData))
getWeather env (Capture location) (Capture fromDay) (Capture interval) = Send $ do
  logInfo @Text env "get the weather forecast"
  mResult <- env.weather.get location fromDay interval
  pure $ case mResult of
    Just result -> ok result
    Nothing -> bad status400 "No data"

We log that call to get weather is in the progress. Then we try to fetch weather data and if it has the data we return it to the user otherwise we report error.

Let's update the weather data:

updateWeather ::
  Env ->
  Body UpdateData ->
  Post (Resp ())
updateWeather env (Body updateData) = Send $ do
  logInfo @Text env "update the weather data"
  ok <$> env.weather.update updateData

we log the report and update the weather data.

The user domain

Let's give the user access token and check that token is valid. Let's allocate a new token in the hanlder requestAuthToken:

requestAuthToken :: Env -> Body User -> Post (RespOr Text AuthToken)
requestAuthToken env (Body user) = Send $ do
  logInfo env ("get new auth token for: " <> user.name)
  isValid <- env.auth.validUser user
  if isValid
    then do
      token <- env.auth.newToken user
      void $ forkIO $ setExpireTimer token
      pure $ ok token
    else do
      logError env $ Text.unwords ["User", user.name, "does not have access to the service"]
      pure $ bad unauthorized401 "User is not valid"
  where
    setExpireTimer :: AuthToken -> IO ()
    setExpireTimer token = do
      threadDelay (1_000_000 * 60 * 10) -- 10 minutes
      env.auth.expireToken token

We check that user is valid and if the user is valid we give user a token and also set the expiration for it. We will expire it 10 minutes after registration. The expiration is concurrent process that is forked from the thread that hnadles the request. If user has no rights to use our service we report error.

Let's check for authorization tokens. Ideally we would like to add this action to all handlers of our application. We would like to keep the business logic handlers for the weather domain the same. And we can do it with plugin. Let's define such a plugin that expects authorization tokens with required header:

withAuth :: Env -> Header "auth" AuthToken -> Plugin IO
withAuth env (Header token) = processResponse $ \getResp -> do
  isOk <- env.auth.validToken token
  if isOk
    then getResp
    else do
      logError env errMessage
      pure $ Just (bad status500 $ Text.encodeUtf8 errMessage)
  where
    errMessage = "Token is invalid"

we have covered in depth how to implement it in the chapter on Plugins so this code should look familiar to us.

Run application

That completes the definition of the server. Let's run it. We define the main function in the module Main.hs:

main :: IO ()
main = do
  env <- initEnv port
  env.proc.startup
  runServer port (server env)
    `finally` env.proc.cleanup
  where
    port = 8085

initEnv :: Port -> IO Env
initEnv = undefined

The initialization of interfaces is yet to be defined. So this is all we need to start the server.

Implementation of the interfaces

For the purpose of the example we will create a mock application. A bit more detailed implementation is in the source code of the mig library. See example JsonApi.

Mock application

We can create a mock application with one user.

import Data.ByteString.Char8 qualified as B
import Data.Yaml qualified as Yaml
import Data.Aeson qualified as Json

initEnv :: Port -> IO Env
initEnv port = pure $ Env initAuth initWeather (initProc proc)

-- | Application with single user john with token that never expires
initAuth :: Auth
initAuth = 
  Auth
  { newToken = const $ pure AuthToken "john-token"
  , validUser = \(User name pass) = pure $ name == "john" && pass == "123"
  , validToken = (\AuthToken token) -> pure (token == "john-token")
  , expireToken = const $ pure ()
  }

initWeather = Weather
  { get = \location day dayInterval -> pure Nothing
  , update = \updateData -> pure ()
  }

initProc :: Port -> Proc
initProc = 
  pure Proc 
    { logger = logger
    , startup = logger.info $ "App started on port: " <> Text.pack (show port)
    , cleanup = logger.info "App shutdown"
    }
  where
    logger = initLogger

initLogger :: Logger
initLogger = Logger
  { info = logBy "info" 
  , debug = logBy "debug"
  , error = logBy "error"
  }
  where
    logBy :: Text -> Json.Value msg -> IO ()
    logBy level msg = B.putStrLn . Yaml.encode . addLogPrefix $
        Json.object [ "level" .= level, "message" .= msg ]

addLogPrefix :: Json.Value -> Json.Value
addLogPrefix val = Json.object ["log" .= val]

we can start the application and try it out with swagger.

Exercises

You can find the complete code of the example in the mig repo.

• implement routes for user registration. Only registered users can receive the authorization token.

• implement roles for the users:

  • admin: can manage users
  • db-writer: can update weather forecast
  • visitor: can only view forecasts

• implement in-memory storage of the weather DB. Use maps to store weather data and info on valid users and tokens.

• implement real logger with fast-logger library

• implement interface that connects application to some real DB. The code for the server should stay the same and only initialization of interface should change. Use one of the DB libraries for haskell: hasql, postgresql-simple

Summary

In this chapter we have defined a more substantial example of JSON HTTP application and saw how we can apply various concepts in practice.

HTML example: Blog site

We have seen many examples of JSON applications. But we can send data in other formats too. Most common forma t for human-readable information for HTTP applications is HTML. Any site that we visit sends HTML pages to us. Let's create a simple site that shos blog posts and quotes and we can add new blog posts to it. Complete code for example is in the mig repo We will cover the most interesting parts of the application.

As in previous example we are going to use IO-based server. The common actions that change internal state of the site or query useful data are expressed as collection of interfaces. All handlers accept interfaces as first argument.

The structure of the application is similiar to the weather forecast example. The modules with their purpose:

• Types - types that cover fdomain of our application
• Server - defines server API and handlers
• Main - runs the server
• View - renders types as HTML-pages
• Interface - actions that can be performed on shared internal state of the app
• Init - initialization of the interfaces
• Content - some mock data to show on page
• Internal - internal state of the site

Using preset module for HTLM servers

As we define server based on IO and HTML we will use the module Mig.Html.IO. Note that there is a difference in types from JSON brother of that module. We will not see the Resp type in the signatures of the handlers.

Becuase for HTML the type synonyms to Send fix the output of Send-type so that it always has value wrapped in Resp:

type Get a = Send GET IO (Resp a)

The Resp-type is built in the type because for HTML we almost never need the RespOr with different type of erorrs. Our errors are going to be HTML-pages to as the result. So we report errors to user in HTML-pages.

Run a server

Let's define a function that will start an empty server:

module Main (
  main,
) where

import Mig.Html.IO (runServer)

main :: IO ()
main = do
  site <- initSite
  runServer port (server site)
  where
    port = 8085

-- | Placeholder for collection of interfaces
data Site = Site

-- | Initialize site's interfaces
initSite :: IO Site
initSite = pure Site

-- | Create a server that works in terms of interfaces
server :: Site -> Server IO
server _ = mempty

Define server routes

Let's define the server and its routes. For our blogpost site we are going to show the pages:

• main page with list of blog posts and greeting

• show random blog post

• show random quote

• save new blog post

• list all blog posts

Also our site serves static files which contain CSS-style file and images We keep them in separate directory called resources.

Here is the definition of the server:

-- | Server definition. Note how we assemble it from parts with monoid method mconcat.
server :: Site -> Server IO
server site =
  logRoutes $
    mconcat
      [ "blog"
          /. [ readServer
             , writeServer
             ]
      , defaultPage
      , addFavicon $ "static" /. staticFiles resourceFiles
      ]

The site serves several sub-servers:

• readServer - pages that fetch content for us
• writeServer - pages to update the content. to save new blog post
• defaultPage - main page of the app
• staticFiles with addFavicon - serves static files and adds icon for our site that is shown in the tab of the browser

default page server

Let's define the simplest server, the default page:

-- default main page
defaultPage =
  mconcat
    [ "/" /. handleGreeting site
    , "index.html" /. handleGreeting site
    ]

handleGreeting :: Site -> Get (Page Greeting)

It links two routes to the handleGreeting handler. We serve two routs: the route of the site and default route for main page "/index.html".

for now we can think of Page as main template of our site which contains some value that is renderable to HTML. Renderer converts the value to HTML and injects it to the site's template.

Read server

Let's define read-only pages for our site.

-- server to read info.
-- We can read blog posts and quotes.
readServer =
  mconcat
    [ "read"
        /. [ "post" /. handleBlogPost site
           , "quote" /. handleQuote site
           ]
    , "list" /. handleListPosts site
    ]

handleBlogPost :: Site -> Optional "id" BlogPostId -> Get (Page BlogPost)

handleQuote :: Site -> Get (Page Quote)

handleListPosts :: Site -> Get (Page ListPosts)

We have three pages to read in our site:

• handleBlogPost - shows random blog post
• handleQuote - shows random quote
• handleListPosts - shows a list of all posts

Write server

Let's define a route to add new blog posts to the site:

    -- server to write new blog posts
    writeServer =
      "write"
        /. [ toServer $ handleWriteForm site
           , toServer $ handleWriteSubmit site
           ]

handleWriteForm :: Site -> Get (Page WritePost)

handleWriteSubmit :: Site -> Body FormUrlEncoded SubmitBlogPost -> Post (Page BlogPost)

We have two different routes which are served on the same path. The first route shows the page with form to fill the post data. The second route is triggered when we hit the submit button. The data in the form is send to the site as request body with Content-Type set to corresponding FormUrlEncoded type.

We can serve several route handlers on the same path if they differ by HTTP-method, input type or output type. In this example we use toServer function to convert route handler function to Server IO.

As we can see all handlers expect the value Site as first argument. This value contains interfaces for all actions that can be performed with our site.

Static files

We serve static files with the line:

  , addFavicon $ "static" /. staticFiles resourceFiles

Let's explain what happens here. The standard function staticFiles takes a collection of files and turns them into server:

staticFiels :: MonadIO m => [(FilePath, ByteString)] -> Server m

The list of pairs contains pair of (path-to-file, byte-string-content-of-the-file). It is convenient to use it with function embedRecursiveDir which embeds all files from directory to haskell executable. It comes with linrary file-embed-lzma. We use it like this:

server = "static" /. staticFiles resourceFiles

resourceFiles :: [(FilePath, ByteString)]
resourceFiles = $(embedRecursiveDir "Html/resources")

For our site we use milligram.css framework for styling and couple of pictures.

Also let's dicuss addFavicon function:

addFavicon = addPathLink "favicon.ico" "static/lambda-logo.png"

It shows interesting concept of linking to the parts of the server. The standard function addPathLink serves all calls to favicon.ico with handler on path "static/lambda-logo.png". This way we can create additional links to the server.

Also we can reuse the sub-parts of another server in our server with function atPath:

{-| Sub-server for a server on given path
it might be usefule to emulate links from one route to another within the server
or reuse part of the server inside another server.
-}
atPath :: forall m. Api.Path -> Server m -> Server m

It creates sub-server for all routes that match given path-prefix. So it can be not only single route but the whole sub-server. The function addPathLink rides on top of that useful function.

Overview of the site

So for our site we have 5 handlers. Let's recall them:

handleBlogPost :: Site -> Optional "id" BlogPostId -> Get (Page BlogPost)

handleQuote :: Site -> Get (Page Quote)

handleListPosts :: Site -> Get (Page ListPosts)

handleWriteForm :: Site -> Get (Page WritePost)

handleWriteSubmit :: Site -> Body FormUrlEncoded SubmitBlogPost -> Post (Page BlogPost)

We can see from type signatures all the types for our domain. Let's define the types.

Domain model of the blog site

We are going to show Blog posts. and we have a form to input a new content to the site. We can define the types for domain as follows:

-- | Web-page for our site
newtype Page a = Page a

-- | Greeting page
data Greeting = Greeting [BlogPost]

-- | Form to submit new post
data WritePost = WritePost

-- | List all posts
newtype ListPosts = ListPosts [BlogPost]

-- | Blog post id
newtype BlogPostId = BlogPostId {unBlogPostId :: UUID}
  deriving newtype (FromHttpApiData, ToHttpApiData, Eq, Show, FromJSON, ToParamSchema)

data BlogPostView
  = ViewBlogPost BlogPost
    -- | error: post not found by id
  | PostNotFound BlogPostId

-- | Blog post
data BlogPost = BlogPost
  { id :: BlogPostId
  , title :: Text
  , createdAt :: UTCTime
  , content :: Text
  }

-- | A quote
data Quote = Quote
  { content :: Text
  }

-- | Data to submit new blog post
data SubmitBlogPost = SubmitBlogPost
  { title :: Text
  , content :: Text
  }
  deriving (Generic, FromForm, ToSchema)

We need to define certian instances to be able to send the data over HTTP wires. The types come from standard libraries for web development in haskell: openapi3, http-api-data, aeson.

Interfaces for the site

Our web site is going to support the following actions:

{-| Web site actions. It defines interfaces that connect logic of our site
with outside world: DBs, logger.
-}
data Site = Site
  { readBlogPost :: BlogPostId -> IO (Maybe BlogPost)
  , writeBlogPost :: SubmitBlogPost -> IO BlogPostId
  , listBlogPosts :: IO [BlogPost]
  , readQuote :: IO Quote
  , logInfo :: Text -> IO ()
  , cleanup :: IO ()
  }

The actions are natural and follow the design of domain and server.

Implement handlers

Let's implement the handlers in terms of interfaces.

Default page

Let's greet the user:

-- | Greet the user on main page
handleGreeting :: Site -> Get (Page Greeting)
handleGreeting site =
  Send $ ok . Page . Greeting <$> site.listBlogPosts

We get the list of all blog posts and wrap them in Greeting page.

Read site

Let's read the blog post:

-- | Read blog post by id
handleBlogPost :: Site -> Optional "id" BlogPostId -> Get (Page BlogPostView)
handleBlogPost site (Optional mBlogId) = Send $
  case mBlogId of
    Nothing -> ok . Page . ViewBlogPost <$> randomBlogPost site
    Just blogId ->
      maybe
        (bad notFound404 $ Page $ PostNotFound blogId)
        (ok . Page . ViewBlogPost)
      <$> site.readBlogPost blogId

We have an optional query parameter that contains id of the blog post. If id is missing we return some random blog post. If there is no blog post that corresponds to id we return error with page not foud status.

Let's read the random quote:

handleQuote :: Site -> Get (Page Quote)
handleQuote site = Send $ ok . Page <$> site.readQuote

Let's show all blog posts as a menu to the user:

handleListPosts :: Site -> Get (Page ListPosts)
handleListPosts site = Send $ do
  ok . Page . ListPosts <$> site.listBlogPosts

Write site

Let's show the form to the user to fill new post data:

handleWriteForm :: Site -> Get (Page WritePost)
handleWriteForm _site =
  Send $ pure $ ok $ Page WritePost

As we can see we just return the tag of the page that encodes the content with form. We will define the HTML-form in the rendering module View.hs.

Let's define the logic to save the submited data to application:

-- | Submit form with data provided by the user
handleWriteSubmit :: Site -> Body FormUrlEncoded SubmitBlogPost -> Post (Page BlogPostView)
handleWriteSubmit site (Body submitData) = Send $ do
  pid <- site.writeBlogPost submitData
  maybe
    (bad notFound404 $ Page $ PostNotFound pid)
    (ok . Page . ViewBlogPost)
    <$> site.readBlogPost pid

In this example we save the new blog post and read that post after saving to show it to the user.

As we can see the handlers follow the interfaces of the site. We just wrap data in the content.

View HTML pages

To render HTML pages we use blaze-html library. All we need to do is to define instances for all types that show up in the result of handlers.

The type Page is a container for our web site main template:

-- writes the template for main page
instance (ToMarkup a) => ToMarkup (Page a) where
  toMarkup (Page page) = siteTemplate (H.toMarkup page)

siteTemplate :: Html -> Html

Also we define ToMarkup instances for all elements in the site:

instance ToMarkup Greeting where
instance ToMarkup WritePost where
instance ToMarkup BlogPostView where
...

You can find the full code in the sources.

Internal state implementation

Our website server is ready to be launched. We only need to define the interfaces. You can find the implementation in the source code for the example. See the modules:

• Init - initializes the interface
• Content - contains run-time mock data
• Internal.State - mutable state to save blog posts in memory

Summary

We have learned how to build HTML-based servers. It goes almost the same as with JSON applications only we have some twists regarding static files.

Reference

Here is the list of main functions, types and classes

How to build server

-- server on path
(/.) :: ToServer a => Path -> a -> Server (MonadOf m)

-- alternative cases for server:
mconcat, (<>)

-- | take sub-server at path
atPath :: Path -> Server m -> Server m

toServer :: ToServer a => a -> Server (MonadOf m)

How to run server

runServer :: Int -> Server IO -> IO ()

runServer' :: ServerConfig -> Int -> Server IO -> IO ()

Server presets

• Mig - generic types
• Mig.IO - IO-based servers with generic return types
• Mig.Json - JSON-based servers
• Mig.Html - HTML-based servers
• Mig.Json.IO - JSON and IO-based servers
• Mig.Html.IO - HTML and IO-based servers

Media types

* Json
* Text
* Html
* FormUrlEncoded
* AnyMedia
* OctetStream

Request inputs

-- required query parameter
newtype Body media value = Body value

-- required query parameter
newtype Query name value = Query value

-- optional query parameter
newtype Optional name value = Optional (Maybe value)

-- required header parameter
newtype Header name value = Header value

-- optional header parameter
newtype OptionalHeader name value = OptionalHeader (Maybe value)

-- capture in path parameter
newtype Capture name value = Capture value

-- boolean query flag parameter
newtype QueryFlag name = QueryFlag Bool

-- Is connection made over SSL
newtype IsSecure = IsSecure Bool

-- full path with query parameters
newtype PathInfo = Path [Text]

-- | low-level request
newtype RawRequest = RawRequest Request

Request outputs

-- | generic route handler
newtype Send method m a = Send (m a)

-- Sepcific methos
type Get m a = Send GET m a
type Post m a = Send POST m a
...

-- Response where type of the value and error are the same
-- or only succesful result is expected
data Resp media a = Resp ...

-- Response where error and result have different types but media type is the same
data RespOr media err a = RespOr ...

The response type class:

class IsResp a where
  -- | the type of response body value
  type RespBody a :: Type

  -- | the type of an error
  type RespError a :: Type

  -- | Returns valid repsonse with 200 status
  ok :: RespBody a -> a

  -- | Returns an error with given status
  bad :: Status -> RespError a -> a

  -- | response with no content
  noContent :: Status -> a

  -- | Add some header to the response
  addHeaders :: ResponseHeaders -> a -> a

  -- | Sets repsonse status
  setStatus :: Status -> a -> a

  -- | Set the media type of the response
  setMedia :: MediaType -> a -> a

  -- | Reads the media type by response type
  getMedia :: MediaType

  -- | Converts value to low-level response
  toResponse :: a -> Response

setHeader :: (IsResp a, ToHttpApiData h) => HeaderName -> h -> a -> a

-- | Bad request. The @bad@ response with 400 status.
badReq :: (IsResp a) => RespError a -> a

-- | Internal server error. The @bad@ response with 500 status.
internalServerError :: (IsResp a) => RespError a -> a

-- | Not implemented route. The @bad@ response with 501 status.
notImplemented :: (IsResp a) => RespError a -> a

-- | Redirect to url. It is @bad@ response with 302 status 
-- and set header of "Location" to a given URL.
redirect :: (IsResp a) => Text -> a

Plugins

applyPlugin, ($:) :: ToPlugin a => 
  a -> Server (MonadOf a) -> Server (MonadOf a)

-- composition of plugins:
Monoid(..): mconcat, (<>), mempty

specific servers

-- | add wagger to server
withSwagger :: SwaggerConfig m -> Server m -> Server m

-- | add link from one route to another
addPathLink :: Path -> Path -> Server m

-- static files
staticFiles :: [(FilePath, ByteString)] -> Server m

specific plugins

-- prepend or append some acction to all routes
prependServerAction, appendServerAction :: MonadIO m => m () -> Plugin m

-- change the response
processResponse :: (m (Maybe Response) -> m (Maybe Response)) -> Plugin m

-- only secure routes are allowed
whenSecure :: forall m. (MonadIO m) => Plugin m

-- logging with putStrLn for debug traces
logHttp :: Verbosity -> Plugin m

-- logging with custom logger
logHttpBy :: (Json.Value -> m ()) -> Verbosity -> Plugin m

-- | simple authorization
withHeaderAuth :: WithHeaderAuth -> Plugin m

How to use Reader

-- Derive instance of HasServer class for your Reader-IO based application:
newtype App a = App (ReaderT Env IO a)
  deriving newtype (Functor, Applicative, Monad, MonadReader Env, MonadIO, HasServer)

renderServer :: Server App -> Env -> IO (Server IO)

OpenApi and Swagger

-- | Get OpenApi
toOpenApi :: Server m -> OpenApi

-- add swagger to server
withSwagger :: SwaggerConfig m -> Server m -> Server m

-- create swagger server
swagger :: SwaggerConfig m -> m OpenApi -> Server m

-- | Print OpenApi schema
printOpenApi :: Server m -> IO ()

-- | Writes openapi schema to file
writeOpenApi :: FilePath -> Server m -> IO ()

The Swagger config:

-- | Swagger config
data SwaggerConfig m = SwaggerConfig
  { staticDir :: Path
  -- ^ path to server swagger (default is "/swagger-ui")
  , swaggerFile :: Path
  -- ^ swagger file name (default is "swaggger.json")
  , mapSchema :: OpenApi -> m OpenApi
  -- ^ apply transformation to OpenApi schema on serving OpenApi schema.
  -- it is useful to add additional info or set current date in the examples
  -- or apply any real-time transformation.
  }

instance (Applicative m) => Default (SwaggerConfig m) where
  def =
    SwaggerConfig
      { staticDir = "swagger-ui"
      , swaggerFile = "swagger.json"
      , mapSchema = pure
      }

Set swagger title and description:

-- | Default info that is often added to OpenApi schema
data DefaultInfo = DefaultInfo
  { title :: Text
  , description :: Text
  , version :: Text
  }

-- adds default info, use it in the mapSwagger field of SwaggerConfig record
addDefaultInfo :: DefaultInfo -> OpenApi -> OpenApi

Describe routes with swagger:

-- | Sets description of the route
setDescription :: Text -> Server m -> Server m

-- | Sets summary of the route
setSummary :: Text -> Server m -> Server m

-- | Adds OpenApi tag to the route
addTag :: Text -> Server m -> Server m

{-| Appends descriptiton for the inputs. It passes pairs for @(input-name, input-description)@.
special name request-body is dedicated to request body input
nd raw-input is dedicated to raw input
-}
describeInputs :: [(Text, Text)] -> Server m -> Server m