How to use QuickCheck to test database related functions?

Question

I need to test a lot of functions that access the database (via Persistent). While I can do this using monadicIO and withSqlitePool it will result in inefficient tests. Each test, not property, but test, will create and destroy the DB pool. How do I prevent this?

Important: Forget about efficiency or elegance. I haven't been able to make the QuickCheck and Persistent types to even compose.

instance (Monad a) => MonadThrow (PropertyM a)

instance (MonadThrow a) => MonadCatch (PropertyM a)

type NwApp = SqlPersistT IO

prop_childCreation :: PropertyM NwApp Bool
prop_childCreation = do
  uid <- pick $ UserKey <$> arbitrary
  lid <- pick $ LogKey <$> arbitrary
  gid <- pick $ Aria2Gid <$> arbitrary
  let createDownload_  = createDownload gid lid uid []
  (Entity pid _) <- run $ createDownload_ Nothing
  dstatus <- pick arbitrary
  parent <- run $ updateGet pid [DownloadStatus =. dstatus]

  let test = do 
        (Entity cid child) <- run $ createDownload_ (Just pid)
        case (parent ^. status, child ^. status) of
          (DownloadComplete ChildrenComplete, DownloadComplete ChildrenNone) -> return True
          (DownloadComplete ChildrenIncomplete, DownloadIncomplete) -> return True
          _ -> return False

  test `catches` [
    Handler (\ (e :: SanityException) -> return True),
    Handler (\ (e :: SomeException) -> return False)
    ]

-- How do I write this function?
runTests = monadicIO $ runSqlite ":memory:" $ do 
 -- whatever I do, this function fails to typecheck

Answer 1

To avoid creating and destroying the DB pool and only set up the DB once, you need to use withSqliteConn in your main function on the outside and then transform each property to use that connection, like in this code:

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Person
    name String
    age Int Maybe
    deriving Show Eq
|]

type SqlT m = SqlPersistT (NoLoggingT (ResourceT m))

prop_insert_person :: PropertyM (SqlT IO) ()
prop_insert_person = do
  personName <- pick arbitrary
  personAge  <- pick arbitrary
  let person = Person personName personAge

  -- This assertion will fail right now on the second iteration
  -- since I have not implemented the cleanup code
  numEntries <- run $ count ([] :: [Filter Person])
  assert (numEntries == 0)

  personId <- run $ insert person
  result <- run $ get personId
  assert (result == Just person)

main :: IO ()
main = runNoLoggingT $ withSqliteConn ":memory:" $ \connection -> lift $ do
  let 
    -- Run a SqlT action using our connection
    runSql :: SqlT IO a -> IO a
    runSql =  flip runSqlPersistM connection

    runSqlProperty :: SqlT IO Property -> Property
    runSqlProperty action = ioProperty . runSql $ do
        prop <- action
        liftIO $ putStrLn "\nDB reset code (per test) goes here\n"
        return prop

    quickCheckSql :: PropertyM (SqlT IO) () -> IO ()
    quickCheckSql = quickCheck . monadic runSqlProperty

  -- Initial DB setup code
  runSql $ runMigration migrateAll

  -- Test as many quickcheck properties as you like
  quickCheckSql prop_insert_person

The full code including imports and extensions can be found in this gist.

Note that I did not implement the functionality to clean the database between tests, as I do not know how to do that in general with persistent, you will have to implement that yourself (replace the placeholder cleanup action that just prints a message right now).

---

You should also not need instances for MonadCatch / MonadThrow for PropertyM. Instead, you should catch in the NwApp monad. So instead of this:

let test = do
  run a
  ...
  run b
test `catch` \exc -> ...

you should use the following code instead:

let test = do
  a
  b
  return ...whether or not the test was successfull...
let testCaught = test `catch` \exc -> ..handler code...
ok <- test
assert ok