Idiomatic haskell database connectivity

Question

In this post I asked about what would be idiomatic haskell database abstraction. I had been thinking for it a while, and the first answer was similar to what I had in mind, and I wrote a proof-of-concept of it. Discarding the abomination that is the schema, what would you change, and why?

Database.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Database (
    runDB
  , quickQuery
  , prepare
  , execute
  , fetchRowAl
  , DB (..)
  , module Database.HDBC.SqlValue
) where
import qualified Database.HDBC as H
import Database.HDBC.SqlValue
import Database.HDBC.Sqlite3
import Control.Monad.Reader

newtype DB a = D (ReaderT Connection IO a) deriving (Monad, MonadReader Connection, MonadIO)

runDB ::  FilePath -> DB b -> IO b
runDB path (D x) = do
  c <- connectSqlite3 path
  mkSchema c
  r <- runReaderT x c
  H.disconnect c
  return r

mkSchema conn = do
  tables <- H.getTables conn
  unless ("Location" `elem` tables) $ do
    H.handleSqlError $ H.quickQuery' conn "CREATE TABLE Location (location TEXT PRIMARY KEY)" []
    return ()
  unless ("Person" `elem` tables) $ do
    H.handleSqlError $ H.quickQuery' conn (unwords [
        "CREATE TABLE Person"
      , "(id INTEGER PRIMARY KEY AUTOINCREMENT,"
      , "name TEXT NOT NULL,"
      , "age INT NOT NULL,"
      , "location TEXT,"
      , "FOREIGN KEY (location) REFERENCES Location (location))"]) []
    return ()

quickQuery :: String -> [SqlValue] -> DB [[SqlValue]]
quickQuery q v = ask >>= \c -> liftIO $ H.quickQuery c q v

prepare :: String -> DB H.Statement
prepare q = ask >>= \c -> liftIO $ H.prepare c q

execute :: H.Statement -> [SqlValue] -> DB Integer
execute stmt v = liftIO $ H.execute stmt v

fetchRowAl :: H.Statement -> DB (Maybe [(String, SqlValue)])
fetchRowAl = liftIO . H.fetchRowAL

Model.hs

module Model where

import Database

data Person = Person (Maybe Int) String Int Location
newtype Location = Location String deriving (Eq)

instance Eq Person where
  (Person _ a b c) == (Person _ a' b' c') = a == a' && b == b' && c == c'

saveLocation ::  Location -> DB ()
saveLocation (Location x) = quickQuery "INSERT OR IGNORE INTO Location VALUES (?)" [toSql x] >> return ()

retrieveLocation :: String -> DB (Maybe Location)
retrieveLocation x = do
  r <- quickQuery "SELECT location FROM Location WHERE location=?" [toSql x]
  case r of
       [] -> return Nothing
       [[y]] -> return $ Just $ Location $ fromSql y

savePerson :: Person -> DB ()
savePerson (Person _ n a l@(Location loc)) = do
  saveLocation l
  quickQuery "INSERT INTO Person (name, age, location) VALUES (?, ?, ?)" [toSql n, toSql a, toSql loc]
  return ()

retrievePersons name = do
  r <- quickQuery "SELECT id, name, age, location FROM Person WHERE name=?" [toSql name]
  let persons = map makePerson r
  return persons
  where
    makePerson [sid, sname, sage, slocation] =
      Person (fromSql sid) (fromSql sname) (fromSql sage) (Location (fromSql slocation))

tests.hs

import Test.HUnit
import Test.Framework.Providers.HUnit
import Test.Framework (defaultMain, testGroup)
import System.Directory
import Database.HDBC (quickQuery')
import Control.Monad.Reader
import Control.Applicative
import Data.Maybe
import Database
import Model

runTest f = runDB "/tmp/test.db" f <* removeFile "/tmp/test.db"

testConnected = runTest $ do
  c <- ask
  r <- liftIO $ quickQuery' c "SELECT 'foo' AS value" []
  liftIO $ assertBool "Return value should not be empty" (length r > 0)

testQuickQuery = runTest $ do
  [[x]] <- quickQuery "SELECT ? AS value" [toSql "foo"]
  liftIO $ assertBool "quickQuery" (fromSql x == "foo")

testPrepared = runTest $ do
  stmt <- prepare "SELECT ? AS value"
  execute stmt [toSql "foo"]
  (Just r) <- fetchRowAl stmt
  let (Just x) = lookup "value" r
  liftIO $ assertBool "prepared" (fromSql x == "foo")

testRetrieveLocationNothing = runTest $ do
  r <- retrieveLocation "Turku"
  liftIO $ assertBool "Location nothing" (isNothing r)

testSaveLocation = runTest $ do
  let turku = Location "Turku"
  saveLocation turku
  (Just loc) <- retrieveLocation "Turku"
  liftIO $ assertBool "loc == turku" (loc == turku)

testSavePerson = runTest $ do
  let person = Person Nothing "Person" 25 $ Location "Turku"
  savePerson person
  [per] <- retrievePersons "Person"
  liftIO $ assertBool "model == db" $ validate person per
  where
    validate _ (Person Nothing _ _ _) = False
    validate a b = a == b

tests = [
    testGroup "Database" [
        testCase "connected" testConnected
      , testCase "quickQuery" testQuickQuery
      , testCase "testPrepared" testPrepared
    ]
  , testGroup "Model" [
        testCase "saveLocation" testSaveLocation
      , testCase "savePerson" testSavePerson
      , testCase "testRetrieveLocationNothing" testRetrieveLocationNothing
    ]
  ]

main = defaultMain tests

Answer 1

First of all, I spotted a bug: since HDBC implicitly runs queries in a transaction, and since you never commit, none of your changes are actually applied to the database. Add a test that opens the file again, to make sure changes persist.

Now, on to code structure.

I definitely like the use of a reader monad. Not only does it keep the user from having to pass a Connection around, but it confines database operations to a single thread (if I understand correctly, SQLite3 does not support concurrent access to a single connection handle, nor does HDBC-sqlite3 provide mutual exclusion). However, since the MonadReader Connection instance is exposed, a user could still get at the underlying Connection and do something to it in another thread. I wouldn't be too worried about that, through.

You may want to leverage the type system some more. For example, consider defining a type class for records that can be stored and retrieved:

class Record r where
    insert :: r -> DB Int -- returns the ID of the inserted row
    get    :: Int -> DB (Maybe r)

Better yet, use phantom types to keep ID types distinct:

newtype Id record = Id {unId :: Int}
    deriving (Eq, Ord)

class Record r where
    insert :: r -> DB (Id r)
    get    :: Id r -> DB (Maybe r)

However, there's a problem: the Location table's primary key is TEXT, not INT. If it were up to me, I'd give the Location table an integer primary key, so that:

• All records have a consistent ID type

• Locations can be renamed without violating the foreign key constraint.

• The Person table doesn't duplicate location names. You don't want your database blowing up when 200 people take a field trip to Llanfairpwllgwyngyllgogerychwyrndrobwllllantysiliogogogoch.

I recommend reading the Persistent chapter of the Yesod book. Even if you don't use Persistent, look at how it's designed.

For example, I noticed you embedded the ID field in your Person type:

data Person = Person (Maybe Int) String Int Location

Persistent chooses to keep the ID and data separate. The Insert section gives a convincing rationale.

Persistent also runs its database monad in a single transaction (see the PersistBackend section). HDBC implicitly runs everything in a transaction, so you don't have to do much to follow suit. This approach has a semantic benefit. Sometimes, you need to do a group of operations atomically. Rather than calling BEGIN and COMMIT explicitly (and hoping the caller isn't also doing stuff in a transaction), you use the type system to force the code to run inside of a transaction.

STM does something similar: you can't nest transactions without sidestepping the type system (e.g. with unsafePerformIO).