Servant & Postgres https://twitter.com/taylorfausak/status/838766807414620161

Main.hs

#!/usr/bin/env stack
{-
  stack
  --resolver lts-8.4
  --install-ghc
  runghc
  --package aeson
  --package aeson-casing
  --package base
  --package bytestring
  --package postgresql-simple
  --package servant-server
  --package transformers
  --package wai
  --package wai-extra
  --package warp
  --
  -Wall
-}

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-}

module Main (main) where

import Control.Category ((>>>))
import Prelude hiding ((.))

import qualified Control.Monad.IO.Class as IO
import qualified Control.Monad.Trans.Reader as Reader
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Casing as Casing
import qualified Data.ByteString as ByteString
import qualified Database.PostgreSQL.Simple as Sql
import qualified Database.PostgreSQL.Simple.SqlQQ as Sql
import qualified GHC.Generics as Generics
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Middleware.Gzip as Gzip
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
import qualified Servant

main :: IO ()
main = do
  config <- getConfig
  let application = applicationWith config
  putStrLn ("Listening on port " ++ show port ++ " ...")
  Warp.run port application

getConfig :: IO Config
getConfig = do
  connection <- Sql.connectPostgreSQL ByteString.empty
  pure Config
    { configConnection = connection
    }

data Config = Config
  { configConnection :: Sql.Connection
  }

port :: Warp.Port
port = 8080

applicationWith :: Config -> Wai.Application
applicationWith config =
  let server = serverWith config
      middleware = middlewareWith config
      application = Servant.serve api server
  in middleware application

middlewareWith :: Config -> Wai.Middleware
middlewareWith _config
  = Gzip.gzip Gzip.def
  >>> RequestLogger.logStdoutDev
  -- Add more middleware here. Maybe put a monad-logger in the config and use
  -- that for logging instead.

api :: Servant.Proxy Api
api = Servant.Proxy

type Api
  = GetRoot
  Servant.:<|> GetThings
  -- Add more endpoints here. They don't have to be type aliases, but I think
  -- it makes things easier to understand.

type GetRoot
  = Servant.Get '[Servant.JSON] Servant.NoContent

type GetThings
  = "things"
  Servant.:> Servant.Get '[Servant.JSON] [Thing]

serverWith :: Config -> Servant.Server Api
serverWith config =
  let transformation = Servant.runReaderTNat config
  in Servant.enter transformation rawServer

rawServer :: Servant.ServerT Api Handler
rawServer
  = getRootHandler
  Servant.:<|> getThingsHandler
  -- Add more handlers here. Maybe use servant-named to avoid matching the
  -- order of handlers to the API.

type Handler = Reader.ReaderT Config Servant.Handler

getRootHandler :: Handler Servant.NoContent
getRootHandler = pure Servant.NoContent

getThingsHandler :: Handler [Thing]
getThingsHandler = query_ [Sql.sql| select id, name from things |]

query_
  :: (Sql.FromRow a, IO.MonadIO m)
  => Sql.Query -> Reader.ReaderT Config m [a]
query_ sql = do
  connection <- Reader.asks configConnection
  let action = Sql.query_ connection sql
  IO.liftIO action
  -- This could be expanded to include logging and timing. Also other helper
  -- functions (execute, execute_, query) would need to be wrapped.

data Thing = Thing
  { _thingId :: Int
  , _thingName :: String
  } deriving (Generics.Generic)

instance Sql.FromRow Thing

instance Aeson.ToJSON Thing where
  toJSON = genericToJson "_thing"

genericToJson
  :: (Generics.Generic a, Aeson.GToJSON Aeson.Zero (Generics.Rep a))
  => String -> a -> Aeson.Value
genericToJson prefix =
  let toDrop = length prefix
      options = Casing.aesonDrop toDrop Casing.camelCase
  in Aeson.genericToJSON options