PostgreSQL connection pool

Let’s see how we can write a simple web application that uses a PostgreSQL database to store simple textual messages, just like in the SQLite cookbook recipe. The main difference, besides the database technology, is that in this example we will be using a pool of connections to talk to the database server. The pool abstraction will be provided by the resource-pool library.

As usual, we start with a little bit of throat clearing.

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
import Data.ByteString (ByteString)
import Control.Concurrent
import Control.Exception (bracket)
import Control.Monad.IO.Class
import Data.Pool
import Database.PostgreSQL.Simple
import Network.HTTP.Client (newManager, defaultManagerSettings)
import Network.Wai.Handler.Warp
import Servant
import Servant.Client

type DBConnectionString = ByteString

We will only care about a single type here, the messages. We want to be able to add a new one and retrieve them all, using two different endpoints.

type Message = String

type API = ReqBody '[PlainText] Message :> Post '[JSON] NoContent
      :<|> Get '[JSON] [Message]

api :: Proxy API
api = Proxy

We proceed with a simple function for creating a table for holding our messages if it doesn’t already exist, given a PostgreSQL connection string.

initDB :: DBConnectionString -> IO ()
initDB connstr = bracket (connectPostgreSQL connstr) close $ \conn -> do
  execute_ conn
    "CREATE TABLE IF NOT EXISTS messages (msg text not null)"
  return ()

Next, our server implementation. It will be parametrised (take as argument) by the pool of database connections that handlers can use to talk to the PostgreSQL database. The resource pool abstraction allows us to flexibly set up a whole bunch of PostgreSQL connections tailored to our needs and then to forget about it all by simply asking for a connection using withResource.

The handlers are straighforward. One takes care of inserting a new value in the database while the other fetches all messages and returns them. We also provide a function for serving our web app given a PostgreSQL connection pool, which simply calls servant-server’s serve function.

server :: Pool Connection -> Server API
server conns = postMessage :<|> getMessages

  where postMessage :: Message -> Handler NoContent
        postMessage msg = do
          liftIO . withResource conns $ \conn ->
            execute conn
                    "INSERT INTO messages VALUES (?)"
                    (Only msg)
          return NoContent

        getMessages :: Handler [Message]
        getMessages = fmap (map fromOnly) . liftIO $
         withResource conns $ \conn ->
            query_ conn "SELECT msg FROM messages"

runApp :: Pool Connection -> IO ()
runApp conns = run 8080 (serve api $ server conns)

We will also need a function for initialising our connection pool. resource-pool is quite configurable, feel free to wander in its documentation to gain a better understanding of how it works and what the configuration knobs are. I will be using some dummy values in this example.

initConnectionPool :: DBConnectionString -> IO (Pool Connection)
initConnectionPool connStr =
  createPool (connectPostgreSQL connStr)
             close
             2 -- stripes
             60 -- unused connections are kept open for a minute
             10 -- max. 10 connections open per stripe

Let’s finally derive some clients for our API and use them to insert two messages and retrieve them in main, after setting up our pool of database connections.

postMsg :: Message -> ClientM NoContent
getMsgs :: ClientM [Message]
postMsg :<|> getMsgs = client api

main :: IO ()
main = do
  -- you could read this from some configuration file,
  -- environment variable or somewhere else instead.
  -- you will need to either change this connection string OR
  -- set some environment variables (see
  -- https://www.postgresql.org/docs/9.5/static/libpq-envars.html)
  -- to point to a running PostgreSQL server for this example to work.
  let connStr = ""
  pool <- initConnectionPool connStr
  initDB connStr
  mgr <- newManager defaultManagerSettings
  bracket (forkIO $ runApp pool) killThread $ \_ -> do
    ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
      postMsg "hello"
      postMsg "world"
      getMsgs
    print ms

This program prints Right ["hello","world"] the first time it is executed, Right ["hello","world","hello","world"] the second time and so on.

You could alternatively have the handlers live in ReaderT (Pool Connection) and access the pool using e.g ask, but this would be more complicated than simply taking the pool as argument.

The entire source for this example is available as a cabal project here.