SQLite databaseΒΆ

Let’s see how we can write a simple web application that uses an SQLite database to store simple textual messages. As usual, we start with a little bit of throat clearing.

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

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.

initDB :: FilePath -> IO ()
initDB dbfile = withConnection dbfile $ \conn ->
  execute_ conn
    "CREATE TABLE IF NOT EXISTS messages (msg text not null)"

Next, our server implementation. It will be parametrised (take as argument) by the name of the file that contains our SQLite database. 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 an SQLite database file, which simply calls servant-server’s serve function.

server :: FilePath -> Server API
server dbfile = postMessage :<|> getMessages

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

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

runApp :: FilePath -> IO ()
runApp dbfile = run 8080 (serve api $ server dbfile)

Let’s also derive some clients for our API and use them to insert two messages and retrieve them in main.

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.
  let dbfile = "test.db"
  initDB dbfile
  mgr <- newManager defaultManagerSettings
  bracket (forkIO $ runApp dbfile) killThread $ \_ -> do
    ms <- flip runClientM (mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
      postMsg "hello"
      postMsg "world"
    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.

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