How to use Hedgehog to test a real world, large scale, stateful app

QuickCheck is awesome

So you’ve heard all the hype about QuickCheck and property-based testing.

You’re super pumped to random test the s*#t out of your code!

You spend months trying to figure this stuff out, it sounded so awesome!

Unfortunately all the examples seem to be about testing pure code or trivial data structures.

 You know how to test reversing a list.

 You know how to test a circular buffer.

 But how do you use QuickCheck with a database?

There is no documentation

You find there is absolutely no documentation about how to use QuickCheck or property-based testing for a real world, large scale, stateful app.

How are you supposed to generate a complex object graph?

What do you do when you have users, you have bookings, you have comments, you have votes? All of those things are stored in a database which wants to be in control of creating identifiers and timestamps. How are you supposed to deal with those kinds of values?

There are only two people in the world that know how to use QuickCheck. John Hughes… and God

Saurabh Nanda (Functional Conf 2017)

Assuming you can even generate realistic data, what are you supposed to test?

You can’t even imagine what it would look like to write random tests for a real world application. How do you random test a business rule like “only allow overbooking if it’s the admin making the request” ?

If you’ve ever tried to actually use QuickCheck, Hedgehog or some other property testing library to test a stateful app you’ll know it can be seriously difficult!

The state-machine testing libraries aimed at solving this problem use complicated types that are overwhelming and hard to use, especially for newbies.

-- Hedgehog.Callback ??
data Callback i o s =
    Require (s Symbolic -> s Symbolic -> Bool)
  | Update (forall v. Ord1 v => s v -> i v -> Var o v -> s v)
  | Ensure (s Concrete -> s Concrete -> i Concrete -> o -> Test ())

What if there was an alternative?

What if you didn’t need all those complicated types?

What if you could just write basic looking Haskell code?

What if you could use the property testing features that you already know?

Good news: there’s a simple design pattern for writing these kinds of tests and you’re about to learn it.

I’m not promising that this will be easy or without some boilerplate, but if you can understand MonadState, then you can understand this technique!

System Under Test

To start with you’re going to need some code to test.

You can skip this section if you just want to read about how to do the testing and don’t want to follow along in your own file.

Typically the database code that follows would be part of your own application, but I’m just going to give you something for demonstration purposes. I’m not going to go in to detail explaining it as this isn’t a postgresql-simple tutorial.

Hopefully you already have a stateful application that you want to test and that’s why you’re here!

I have chosen the schema for this tutorial from on a question on Hedgehog’s GitHub. It’s the evergreen contrived CMS example of storing users and their posts. It may not be the users/bookings/comments/votes that I mentioned in the intro, but this will certainly fill in the blanks necessary to be able to generate a structure like that. The important thing about this schema is that it requires a relation between tables and therefore makes generating test data tricky.

If you want to follow along you can start by copying the starter code into a Tutorial.hs file and loading it up in GHCi. It includes all the imports you’ll need for the whole tutorial as well as the types and functions for the simple database app which you’ll be testing.

Here are the dependencies you’ll need in your package.yaml or tutorial.cabal file.

dependencies:
- base
- hedgehog
- lifted-base
- monad-control
- mtl
- postgresql-simple
- resource-pool
- text
- time
- tmp-postgres >= 1.34.1.0
- transformers
- transformers-base

# As of 2020-02-02 I had to add these to my stack.yaml to use with lts-14.22
extra-deps:
- [email protected]:7d6fd2e6f737890857aa60be1ba2828093c057db272e16180e99cd51566fead7,4753
- [email protected]:372875d12742b97befaacbd08a35c2e73cc3821a3b7a09ec1b17a079d0b24ff7,856
- [email protected]:5e2d6408ed3943f9a056b58106186397b9aa1424c56f1f26668305ce8ea2838f,1604

There’s a couple of notable things about the starter code, the User and Post types also have NewUser and NewPost variations. This is because it can’t be known ahead of time which values the database will allocate for things like identifiers and timestamps.

This serves the same purpose as the Entity type from persistent but is deliberately as low tech as possible for demonstration purposes.

{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}

module Tutorial where

import           Control.Exception (Exception, throwIO, try, catch)
import           Control.Exception.Lifted (bracket_)
import           Control.Monad (when)
import           Control.Monad.Base (liftBase)
import           Control.Monad.IO.Class (MonadIO)
import           Control.Monad.State.Class (MonadState(..), modify, gets)
import           Control.Monad.Trans.Control (MonadBaseControl)
import           Control.Monad.Trans.State (execStateT)

import           Data.Foldable (for_)
import           Data.Function (on)
import qualified Data.List as List
import           Data.Maybe (listToMaybe, fromJust)
import           Data.Pool (Pool, createPool, withResource)
import           Data.String (fromString)
import           Data.Text (Text)
import           Data.Time.Calendar (Day(..))
import           Data.Time.Clock (UTCTime(..))

import           Database.PostgreSQL.Simple (Connection, Only(..))
import           Database.PostgreSQL.Simple (connectPostgreSQL)
import           Database.PostgreSQL.Simple (execute, execute_)
import           Database.PostgreSQL.Simple (query, close)
import           Database.PostgreSQL.Simple.SqlQQ (sql)
import           Database.Postgres.Temp (with, toConnectionString)

import           GHC.Stack (HasCallStack, withFrozenCallStack)

import           Hedgehog hiding (Command)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

import           Text.Printf (printf)


data DbError = DbError Text
  deriving (Eq, Ord, Show)
instance Exception DbError where

newtype UserId =
  UserId {
      unUserId :: Int
    } deriving (Eq, Ord, Show)

data NewUser =
  NewUser {
      newuserName :: Text
    , newuserEmail :: Text
    } deriving (Eq, Ord, Show)

data User =
  User {
      userId :: UserId
    , userName :: Text
    , userEmail :: Text
    , userCreatedAt :: UTCTime
    } deriving (Eq, Ord, Show)

packUser :: UserId -> UTCTime -> NewUser -> User
packUser uid ctime x =
  User uid
    (newuserName x)
    (newuserEmail x)
    ctime

newtype PostId =
  PostId {
      unPostId :: Int
    } deriving (Eq, Ord, Show)

data NewPost =
  NewPost {
      newpostUserId :: UserId
    , newpostTitle :: Text
    , newpostBody :: Text
    } deriving (Eq, Ord, Show)

data Post =
  Post {
      postId :: PostId
    , postUserId :: UserId
    , postTitle :: Text
    , postBody :: Text
    , postCreatedAt :: UTCTime
    } deriving (Eq, Ord, Show)

packPost :: PostId -> UTCTime -> NewPost -> Post
packPost pid ctime x =
  Post pid
    (newpostUserId x)
    (newpostTitle x)
    (newpostBody x)
    ctime

createTables :: Connection -> IO ()
createTables conn = do
  _ <- execute_ conn [sql|
    CREATE TABLE users (
      id SERIAL PRIMARY KEY,
      name TEXT NOT NULL,
      email TEXT NOT NULL,
      created_at TIMESTAMP WITH TIME ZONE DEFAULT CURRENT_TIMESTAMP
    );
    CREATE TABLE posts (
      id SERIAL PRIMARY KEY,
      user_id INTEGER NOT NULL REFERENCES users(id),
      title TEXT NOT NULL,
      body TEXT NOT NULL,
      created_at TIMESTAMP WITH TIME ZONE DEFAULT CURRENT_TIMESTAMP
    );
    |]
  pure ()

createUser :: Connection -> NewUser -> IO UserId
createUser conn user  = do
  rows <- query conn [sql|
    INSERT INTO users (name, email)
    VALUES (?, ?)
    RETURNING id
    |] (newuserName user, newuserEmail user)
  case rows of
    [] ->
      throwIO $ DbError "failed to create user"
    Only uid : _ ->
      pure (UserId uid)

deleteUser :: Connection -> UserId -> IO ()
deleteUser conn uid  = do
  n <- execute conn [sql|
    DELETE FROM users
    WHERE id = ?
    |] (Only (unUserId uid))
  if n == 0 then
    throwIO $ DbError "user did not exist"
  else
    pure ()

readUser :: Connection -> UserId -> IO (Maybe User)
readUser conn uid = do
  rows <- query conn [sql|
    SELECT name, email, created_at
    FROM users
    WHERE id = ?
    |] (Only (unUserId uid))
  case rows of
    [] ->
      pure Nothing
    (name, email, ctime) : _ ->
      pure (Just (User uid name email ctime))

createPost :: Connection -> NewPost -> IO PostId
createPost conn post  = do
  rows <- query conn [sql|
    INSERT INTO posts (user_id, title, body)
    VALUES (?, ?, ?)
    RETURNING id
    |] (unUserId (newpostUserId post), newpostTitle post, newpostBody post)
  case rows of
    [] ->
      throwIO $ DbError "failed to create user"
    Only pid : _ ->
      pure (PostId pid)

readPost :: Connection -> PostId -> IO (Maybe Post)
readPost conn pid = do
  rows <- query conn [sql|
    SELECT user_id, title, body, created_at
    FROM posts
    WHERE id = ?
    |] (Only (unPostId pid))
  case rows of
    [] ->
      pure Nothing
    (uid, title, body, ctime) : _ ->
      pure (Just (Post pid (UserId uid) title body ctime))

Load that up in GHCi and make sure everything type checks and that you’ve got the dependencies you need.

Make a temporary database

To start testing a database, you’re going to need a connection to one.

Jonathan Fischoff recently posted about how tmp-postgres is an easy and fast way to make a temporary PostgreSQL database. I tried it and it works really well with Hedgehog, so that’s what you’ll be using.

I was amused to see Jonathan note:

A major pain of database testing I have not addressed is how to build test data that has foreign key references. I’ll have to come back to this after showing off tmp-postgres.

This is exactly the issue I’ll be addressing in this tutorial.

Install PostgreSQL

You need to have PostgreSQL installed on your system for any of this to work, so go find a guide for doing that on your operating system, install it, then come back here. I’m not sure if this will work on Windows but Jonathan notes that he has tested on macOS and Ubuntu.

Ubuntu’s PostgreSQL installation does not put initdb on the PATH. You will need to add it manually. The necessary binaries are in the /usr/lib/postgresql/VERSION/bin/ directory, and should be added to the PATH.

# add this to your .bashrc, .zshrc or whatever rc
# replace 11 with the version that you actually have
export PATH=$PATH:/usr/lib/postgresql/11/bin/

Read more about tmp-postgres requirements on Hackage.

Set up and tear down

To start, you should get tmp-postgres setting up and tearing down a temporary database for you.

You’re going to create a basic property prop_tables which will check that it’s possible to initialize the required database tables. It looks a bit different to a vanilla Hedgehog property because it needs an argument, the connection pool. Passing in an existing pool will speed things up by avoid the need to create new connections for every test run.

prop_tables :: Pool Connection -> Property
prop_tables pool =
  property $ do
    withResource pool . abort $ \conn -> do
      evalIO $ createTables conn

You need to write this abort function which wraps the statements executed in a transaction so they can be rolled back after each test. I have taken this idea from one of Jonathan’s blog posts. For the purposes of this tutorial the code below should be fine, but you may want to read his post to understand more about its limitations.

abort :: MonadBaseControl IO m => (Connection -> m a) -> Connection -> m a
abort f conn =
  bracket_
    (liftBase (execute_ conn "BEGIN"))
    (liftBase (execute_ conn "ROLLBACK"))
    (f conn)

Finally you need a way to run to run your property. This will look a bit different to what you might be used to when running Hedgehog tests as you need to do some setup which is shared across all of your properties.

I have used with which is the simplest way to create (and clean up) a test database using tmp-postgres. I have also created a connection pool which you need to pass to your properties manually.

withPool :: (Pool Connection -> IO a) -> IO a
withPool io =
  (either throwIO pure =<<) .
  with $ \db -> do
    let connect = connectPostgreSQL (toConnectionString db)
    pool <- createPool connect close 2 60 10
    io pool

tests :: IO Bool
tests =
  withPool $ \pool ->
  checkParallel $ Group "Tutorial" [
      ("prop_tables", prop_tables pool)
    ]

You’ll notice that you can’t use $$(discover) because it doesn’t (yet) allow for passing arguments. Hopefully Hedgehog will grow a way to do that elegantly one day.

Reload and try running tests in GHCi to make sure it works.

ghci> :r
ghci> tests
━━━ Tutorial ━━━
  ✓ prop_tables passed 100 tests.
  ✓ 1 succeeded.
True

Generate commands

Now you have Hedgehog set up to provide a database connection for your properties, the fun begins!

You’re going to have Hedgehog construct a random database structure by executing generated commands. These commands are conceptually the same as in the object-oriented command pattern.

In object-oriented programming, the command pattern is a behavioral design pattern in which an object is used to encapsulate all information needed to perform an action or trigger an event at a later time.

Command Pattern (Wikipedia)

Unlike in the object-oriented pattern, a sum type will be used to represent the commands. You’re going to start with the two commands which are necessary to get a post into the system. Obviously a User must be created before a Post can be, because a Post has a foreign key reference to a User.

-- Make sure your Hedgehog import is `hiding (Command)`
-- You're building something much simpler that serves the same purpose.
data Command =
    CreateUser Text Text     -- name / email
  | CreatePost Int Text Text -- user-index / title / body
    deriving (Eq, Ord, Show)

One interesting point to note is that to generate CreatePost you will need something that ties it to a user, but it can’t be a UserId because only the database can generate those. So instead you are going to generate an index which you can resolve later to find the real UserId.

The generated index has a lot in common with a de Bruijn index, which is a technique used to avoid naming variables in compilers. Here you’ll use it to avoid naming users!

genCreateUser :: Gen Command
genCreateUser = do
  name <- Gen.element ["stephanie", "lennart", "simon"]
  pure $
    CreateUser name (name <> "@haskell.land")

-- You can generate just about anything
-- here, you'll see why later.
genUserIx :: Gen Int
genUserIx =
  Gen.int (Range.constant 0 50)

genCreatePost :: Gen Command
genCreatePost =
  CreatePost
    <$> genUserIx
    <*> Gen.element ["C", "C++", "Haskell", "Rust", "JavaScript"]
    <*> Gen.element ["fast", "slow", "best", "worst"]

genCommand :: Gen Command
genCommand =
  Gen.choice [
      genCreateUser
    , genCreatePost
    ]

Execute commands

To be able to resolve an index to a UserId you need a model to keep track of the current state of the system under test. More importantly, a model will allow you to make assertions about how you expect the system to behave when various commands are executed.

data Model =
  Model {
      modelUsers :: [User]
    } deriving (Eq, Ord, Show)

modelAddUser :: User -> Model -> Model
modelAddUser user x =
  x { modelUsers = modelUsers x <> [user] }

Finally you need some functions to execute the commands and verify their effects. You’ll be keeping track of the current state of the model using MonadState.

First for creating users, and then for creating posts after that.

execCreateUser :: (
    MonadState Model m
  , MonadIO m
  , MonadTest m
  )
  => Connection
  -> Text
  -> Text
  -> m ()
execCreateUser conn name email = do
  let new = NewUser name email
  uid <- evalIO $ createUser conn new
  mgot <- evalIO $ readUser conn uid
  got <- eval $ fromJust mgot

  let want = packUser uid (userCreatedAt got) new
  want === got

  -- Track in the model that a user was created.
  -- Importantly, this means their UserId is known.
  modify (modelAddUser want)

When execCreateUser runs it writes the user it created to the model so that execCreatePost can use that information.

With execCreatePost below, note how userIx is used to lookup a previously created user from then model state. You need to use the lookupIx function to do the lookup so that it will wrap around if the index is too large. Remember that the index was randomly generated anyway so it really doesn’t matter which user is picked as long as it’s predictable.

lookupIx starts from the back of the list. So ix = 0 means the most recently created user. Having the index be relative like this, rather than absolute, should improve shrinking as removing commands from the start of the sequence will not change the meaning of commands at the end of the sequence.

-- Lookup an element at the specified index
-- or a modulo thereof if past the end.
lookupIx :: Int -> [a] -> Maybe a
lookupIx ix = \case
  [] ->
    Nothing
  xs ->
    listToMaybe (drop (ix `mod` length xs) (reverse xs))

execCreatePost :: (
    MonadState Model m
  , MonadIO m
  , MonadTest m
  )
  => Connection
  -> Int
  -> Text
  -> Text
  -> m ()
execCreatePost conn userIx title body = do
  muser <- gets (lookupIx userIx . modelUsers)
  case muser of
    Nothing ->
      -- failed precondition, skip
      pure ()
    Just user -> do
      let new = NewPost (userId user) title body
      pid <- evalIO $ createPost conn new
      mgot <- evalIO $ readPost conn pid
      got <- eval $ fromJust mgot

      let want = packPost pid (postCreatedAt got) new
      want === got

Finally you need to write a function which can execute a Command by dispatching to its execXXX function.

execCommands :: (
    MonadIO m
  , MonadTest m
  )
  => Connection
  -> [Command]
  -> m Model
execCommands conn xs =
  flip execStateT (Model []) . for_ xs $ \case
    CreateUser name email ->
      execCreateUser conn name email
    CreatePost userIx title body ->
      execCreatePost conn userIx title body

Then you can tie it all together with a property that generates and executes your random commands.

prop_commands :: Pool Connection -> Property
prop_commands pool =
  property $ do
    commands <- forAll $ Gen.list (Range.constant 0 100) genCommand
    withResource pool . abort $ \conn -> do
      evalIO $ createTables conn
      _model <- execCommands conn commands
      pure ()

-- don't forget to add prop_commands to your tests function
tests :: IO Bool
tests =
  withPool $ \pool ->
  checkParallel $ Group "Tutorial" [
      ("prop_tables", prop_tables pool)
    , ("prop_commands", prop_commands pool)
    ]

Try running tests in GHCi to make sure it all works.

ghci> :r
ghci> tests
━━━ Tutorial ━━━
  ✓ prop_tables passed 100 tests.
  ✓ prop_commands passed 100 tests.
  ✓ 2 succeeded.

Delete some users

Currently your commands aren’t doing anything interesting enough to cause a failure.

Let’s change that by introducing a command to delete users.

-- add the DeleteUser user constructor to Command
data Command =
    CreateUser Text Text     -- name / email
  | DeleteUser Int           -- user-index
  | CreatePost Int Text Text -- user-index / title / body
    deriving (Eq, Ord, Show)

genDeleteUser :: Gen Command
genDeleteUser = do
  DeleteUser
    <$> Gen.int (Range.constant 0 50)

-- add genDeleteUser to genCommand
genCommand :: Gen Command
genCommand =
  Gen.choice [
      genCreateUser
    , genDeleteUser
    , genCreatePost
    ]

Because of the foreign key constraint between posts and users, it shouldn’t be possible to delete a user without first deleting their posts.

However, you’re going to implement execDeleteUser without checking that, so you can see if Hedgehog is able to find the bug.

modelRemoveUser :: UserId -> Model -> Model
modelRemoveUser uid x =
  x { modelUsers = List.filter ((/= uid) . userId) (modelUsers x) }

execDeleteUser :: (
    MonadState Model m
  , MonadIO m
  , MonadTest m
  )
  => Connection
  -> Int
  -> m ()
execDeleteUser conn userN = do
  muser <- gets (lookupIx userN . modelUsers)
  case muser of
    Nothing ->
      -- no users created yet, failed precondition, skip
      pure ()
    Just user -> do
      evalIO $ deleteUser conn (userId user)
      modify (modelRemoveUser (userId user))

-- don't forget to add DeleteUser to execCommands
execCommands conn xs =
  flip execStateT (Model []) . for_ xs $ \case
    CreateUser name email ->
      execCreateUser conn name email
    DeleteUser userIx ->
      execDeleteUser conn userIx
    CreatePost userIx title body ->
      execCreatePost conn userIx title body

Try running tests in GHCi and you should see that Hedgehog finds the minimal sequence of commands which breaks the foreign key constraint!

[ CreateUser "stephanie" "st[email protected]"
, CreatePost 0 "C" "fast"
, DeleteUser 0
]

    ┏━━ test/Tutorial.hs ━━━
291 ┃ execDeleteUser :: (
292 ┃     MonadState Model m
293 ┃   , MonadIO m
294 ┃   , MonadTest m
295 ┃   )
296 ┃   => Connection
297 ┃   -> Int
298 ┃   -> m ()
299 ┃ execDeleteUser conn userIx = do
300 ┃   muser <- gets (lookupIx userIx . modelUsers)
301 ┃   case muser of
302 ┃     Nothing ->
303 ┃       -- failed precondition
304 ┃       pure ()
305 ┃     Just user -> do
306 ┃       evalIO $ deleteUser conn (userId user)
    ┃       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
    ┃       │ ━━━ Exception (SqlError) ━━━
    ┃       │ SqlError {sqlState = "23503", sqlExecStatus = FatalError, sqlErrorMsg = "update or delete on table \"users\" violates foreign key constraint \"posts_user_id_fkey\" on table \"posts\"", sqlErrorDetail = "Key (id)=(1) is still referenced from table \"posts\".", sqlErrorHint = ""}
307 ┃       modify (modelRemoveUser (userId user))

    ┏━━ test/Tutorial.hs ━━━
375 ┃ prop_commands :: Pool Connection -> Property
376 ┃ prop_commands pool =
377 ┃   property $ do
378 ┃     commands <- forAll $ Gen.list (Range.constant 0 100) genCommand
    ┃     │ [ CreateUser "stephanie" "[email protected]"
    ┃     │ , CreatePost 0 "C" "fast"
    ┃     │ , DeleteUser 0
    ┃     │ ]
379 ┃     withResource pool . abort $ \conn -> do
380 ┃       evalIO $ createTables conn
381 ┃       _model <- execCommands conn commands
382 ┃       pure ()

Fix the model

There are two directions you can go from here, you can say either the model is correct and fix the app, or you can say the app is correct and fix the model.

For this tutorial you’re going to fix the model because it’ll be more interesting.

To fix the model you need to start tracking posts in the same way you’ve been tracking users. So add a modelPosts field to the Model data type.

data Model =
  Model {
      modelUsers :: [User]
    , modelPosts :: [Post]
    } deriving (Eq, Ord, Show)

Now change execCreatePost so that it updates the model.

modelAddPost :: Post -> Model -> Model
modelAddPost post x =
  x { modelPosts = modelPosts x <> [post] }

execCreatePost :: (
    MonadState Model m
  , MonadIO m
  , MonadTest m
  )
  => Connection
  -> Int
  -> Text
  -> Text
  -> m ()
execCreatePost conn userIx title body = do
  muser <- gets (lookupIx userIx . modelUsers)
  case muser of
    Nothing ->
      -- failed precondition, skip
      pure ()
    Just user -> do
      let new = NewPost (userId user) title body
      pid <- evalIO $ createPost conn new
      mgot <- evalIO $ readPost conn pid
      got <- eval $ fromJust mgot

      let want = packPost pid (postCreatedAt got) new
      want === got

      modify (modelAddPost want)
   -- ^^^^^^^^^^^^^^^^^^^^^^^^^^
   -- You need to add this line.

-- and add another empty list when constructing Model
execCommands conn xs =
  flip execStateT (Model [] []) . for_ xs $ \case
    -- .. snip

Finally you need to change execDeleteUser so that it doesn’t try to delete users which have posts.

modelUserHasPosts :: UserId -> Model -> Bool
modelUserHasPosts uid x =
  any ((uid ==) . postUserId) (modelPosts x)

execDeleteUser :: (
    MonadState Model m
  , MonadIO m
  , MonadTest m
  )
  => Connection
  -> Int
  -> m ()
execDeleteUser conn userIx = do
  muser <- gets (lookupIx userIx . modelUsers)
  case muser of
    Nothing ->
      -- failed precondition
      pure ()
    Just user -> do
   -- You need to add this check.
   -- vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
      active <- gets (modelUserHasPosts (userId user))
      if active then
        -- failed precondition
        -- possible improvement: make sure deleteUser throws
        pure ()
      else do
        evalIO $ deleteUser conn (userId user)
        modify (modelRemoveUser (userId user))

Try running tests in GHCi and you should see that everything now works!

Check commands get used

You might be thinking, “that’s great but I bet deleteUser just never gets called now”.

Hedgehog’s coverage functions are a great way to check this.

Add a label to each of the execXXX functions, but only only in the branches that satisfy preconditions and hence perform IO.

execCreateUser conn name email = do
  -- ...snip... --
  modify (modelAddUser want)
  label "CreateUser"

execDeleteUser conn userN = do
  -- ...snip... --
        modify (modelRemoveUser (userId user))
        label "DeleteUser"

execCreatePost conn userN title body = do
  -- ...snip... --
      modify (modelAddPost want)
      label "CreatePost"

Try running tests in GHCi and now you should get some proof that the tests are in fact executing every command for real.

━━━ Tutorial ━━━
  ✓ prop_tables passed 100 tests.
  ✓ prop_commands passed 100 tests.
    CreateUser 99% ███████████████████▊
    DeleteUser 95% ███████████████████·
    CreatePost 96% ███████████████████▏
  ✓ 2 succeeded.

Finally, you might want to analyze the resulting model to see other details about what kind of database you ended up generating.

prop_commands :: Pool Connection -> Property
prop_commands pool =
  property $ do
    commands <- forAll $ Gen.list (Range.constant 0 100) genCommand
    withResource pool . abort $ \conn -> do
      _ <- evalIO $ createTables conn
      model <- execCommands conn commands

      -- add some labels for how many posts were generated
      let n = length (modelPosts model)
      when (n >= 10) $ label "Posts 10+"
      when (n >= 20) $ label "Posts 20+"
      when (n >= 30) $ label "Posts 30+"

So when you run tests again, you should see something even more interesting.

━━━ Tutorial ━━━
  ✓ prop_tables passed 100 tests.
  ✓ prop_commands passed 100 tests.
    CreateUser 99% ███████████████████▊
    DeleteUser 96% ███████████████████▏
    CreatePost 95% ███████████████████·
    Posts 10+  70% ██████████████······
    Posts 20+  37% ███████▍············
    Posts 30+  13% ██▌·················
  ✓ 2 succeeded.

Assert business rules

Earlier I mentioned the hypothetical “How can you check that a reservation system only allows overbooking if it’s the admin which is making the request?”

In this example there isn’t anything about reservations, but enforcing any kind of business rule will come down to checking something about the model.

Try adding a check to make sure that every email address registered is unique.

assertNoDuplicateEmails :: MonadTest m => Model -> m ()
assertNoDuplicateEmails model = do
  -- check for email duplicates
  let want = List.nubBy ((==) `on` userEmail) (modelUsers model)
  let got = modelUsers model
  want === got

prop_commands :: Pool Connection -> Property
prop_commands pool =
  property $ do
    commands <- forAll $ Gen.list (Range.constant 0 100) genCommand
    withResource pool . abort $ \conn -> do
      evalIO $ createTables conn
      model <- execCommands conn commands

      assertNoDuplicateEmails model

      let n = length (modelPosts model)
      when (n >= 10) $ label "Posts 10+"
      when (n >= 20) $ label "Posts 20+"
      when (n >= 30) $ label "Posts 30+"

Running the tests again, you should see a failure as that’s not something the test code prevents!

    ┏━━ test/Tutorial.hs ━━━
358 ┃ assertNoDuplicateEmails :: MonadTest m => Model -> m ()
359 ┃ assertNoDuplicateEmails model = do
360 ┃   -- check for email duplicates
361 ┃   let want = List.nubBy ((==) `on` userEmail) (modelUsers model)
362 ┃   let got = modelUsers model
363 ┃   want === got
    ┃   ^^^^^^^^^^^^
    ┃   │ ━━━ Failed (- lhs) (+ rhs) ━━━
    ┃   │ - [ User
    ┃   │ -     { userId = UserId { unUserId = 1 }
    ┃   │ -     , userName = "stephanie"
    ┃   │ -     , userEmail = "[email protected]"
    ┃   │ -     , userCreatedAt = (2020 - 02 - 02) (09 : 38 : 30.952121) UTC
    ┃   │ -     }
    ┃   │ - ]
    ┃   │ + [ User
    ┃   │ +     { userId = UserId { unUserId = 1 }
    ┃   │ +     , userName = "stephanie"
    ┃   │ +     , userEmail = "[email protected]"
    ┃   │ +     , userCreatedAt = (2020 - 02 - 02) (09 : 38 : 30.952121) UTC
    ┃   │ +     }
    ┃   │ + , User
    ┃   │ +     { userId = UserId { unUserId = 2 }
    ┃   │ +     , userName = "stephanie"
    ┃   │ +     , userEmail = "[email protected]"
    ┃   │ +     , userCreatedAt = (2020 - 02 - 02) (09 : 38 : 30.952121) UTC
    ┃   │ +     }
    ┃   │ + ]

    ┏━━ test/Tutorial.hs ━━━
365 ┃ prop_commands :: Pool Connection -> Property
366 ┃ prop_commands pool =
367 ┃   property $ do
368 ┃     commands <- forAll $ Gen.list (Range.constant 0 100) genCommand
    ┃     │ [ CreateUser "stephanie" "[email protected]"
    ┃     │ , CreateUser "stephanie" "[email protected]"
    ┃     │ ]
369 ┃     withResource pool . abort $ \conn -> do
370 ┃       evalIO $ createTables conn
371 ┃       model <- execCommands conn commands
372 ┃
373 ┃       assertNoDuplicateEmails model
374 ┃
375 ┃       let n = length (modelPosts model)
376 ┃       when (n >= 10) $ label "Posts 10+"
377 ┃       when (n >= 20) $ label "Posts 20+"
378 ┃       when (n >= 30) $ label "Posts 30+"

You should consider that you can put these kind of checks after running certain commands or even after every command, by modifying the execCommands function.

Try it for real

You’ve learned a new skill!

I promised you real world large scale stateful apps and I’ve only shown you that this works for a toy CMS example, but you’ve got to start somewhere.

Hopefully this tutorial has sparked your imagination and you can see how it’s possible to apply the same technique to testing a real application.

Try it on your own stateful apps and let me know on Twitter how you go, or ask for help on the Hedgehog GitHub.

Credits

Photo by Ricardo Viana on Unsplash