A small HTTP server used to test client/backend communication

http_server.hs

#! /usr/bin/env stack
{- stack
    --resolver lts-8.15
    --install-ghc runghc
    --package servant
    --package text
    --package optparse-generic
-}

{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators     #-}

import Prelude           hiding (putStr, putStrLn)
import System.IO                (hPutStrLn, stderr)

import Data.Aeson               (FromJSON, ToJSON)
import Data.Text                (Text)
import Data.Text.IO             (putStr, putStrLn)
import Network.Wai.Handler.Warp (defaultSettings, runSettings,
                                 setBeforeMainLoop, setPort)
import Options.Generic          (Generic, ParseRecord, getRecord)
import Servant
import Control.Monad.IO.Class (liftIO)

-- * Arguments

type HttpCode = Int
data Arguments =
      Success
    | Failure HttpCode
    deriving (Generic, Show, ParseRecord)

-- * Response

data Response = Response
  { status :: Text
  , verb   :: Text
  } deriving (Generic, Show, ToJSON, FromJSON)

-- * Api

type Api =
       Get    '[JSON] Response
  :<|> Post   '[JSON] Response
  :<|> Delete '[JSON] Response
  :<|> Put    '[JSON] Response
  :<|> Patch  '[JSON] Response


api :: Proxy Api
api = Proxy

-- * App

main :: IO ()
main = do
  let port = 8000
      settings =
        setPort port $
        setBeforeMainLoop (hPutStrLn stderr ("listening on port " ++ show port))
        defaultSettings
  args <- getRecord "Simple HTTP server"
  print (args :: Arguments)
  runSettings settings =<< mkApp args
  where
    mkApp :: Arguments -> IO Application
    mkApp args = return $ serve api (server args)

    server :: Arguments -> Server Api
    server args =
           answer args "GET"
      :<|> answer args "POST"
      :<|> answer args "DELETE"
      :<|> answer args "PUT"
      :<|> answer args "PATCH"

    answer :: Arguments -> Text -> Handler Response
    answer args verb = do
      liftIO (putStr verb); liftIO (putStr " => ")
      case args of
        Success -> do
          let response = Response "OK" verb
          liftIO (print response)
          return response
        Failure code -> do
          liftIO (print code)
          throwError ServantErr { errHTTPCode = code
                                , errReasonPhrase = "Error"
                                , errBody = ""
                                , errHeaders = []
                                }