tutorial: import code up to prop_tables

This imports the code from the original tutorial, up to and including
the `prop_tables` test.

Note: the bounds of `build-dependencies` in the project Cabal file are
taken from my local build environment and may not match the original
tutorial author's environment.

See: https://jacobstanley.io/how-to-use-hedgehog-to-test-a-real-world-large-scale-stateful-app/

README.md

@@ -0,0 +1,22 @@
+# hedgehog-stateful-demo
+
+This repository contains some code demonstrating testing of a stateful,
+database-backed application using [Hedgehog][hedgehog], a library
+similar in spirit to the well-known [QuickCheck][quickcheck] library.
+Hedgehog comes with
+[built-in functionality to test state machines][hedgehog-fsm] but the
+API may be a slightly daunting, hence this demo.
+
+It's based on a blog-post by [Jacob Stanley][jacob-stanley]:
+"[How to use Hedgehog to test a real world, large scale, stateful app][blog]".
+Make sure to read it first!
+
+This commit imports all code from the original blog-post up to the
+**Generate commands** section.
+
+[hedgehog]: https://hedgehog.qa/
+[quickcheck]: https://hackage.haskell.org/package/QuickCheck
+[hedgehog-fsm]: https://hackage.haskell.org/package/hedgehog-1.2/docs/Hedgehog.html#g:5
+[jacob-stanley]: https://jacobstanley.io
+[blog]: https://jacobstanley.io/how-to-use-hedgehog-to-test-a-real-world-large-scale-stateful-app/
+

hedgehog-stateful-demo.cabal

@@ -28,4 +28,16 @@ test-suite hedgehog-stateful-demo-test
   type:             exitcode-stdio-1.0
   hs-source-dirs:   test
   main-is:          Tutorial.hs
-  build-depends:    base ^>=4.17.0.0
+  build-depends:
+    , base               ^>=4.17.0.0
+    , hedgehog ^>=1.2
+    , lifted-base ^>=0.2.3.12
+    , monad-control ^>=1.0.3.1
+    , mtl ^>=2.2.2
+    , postgresql-simple ^>=0.6.5
+    , resource-pool      ^>=0.2.3.2
+    , text ^>=2.0.1
+    , time ^>=1.12.2
+    , tmp-postgres       ^>=1.34.1.0
+    , transformers ^>=0.5.6.2
+    , transformers-base ^>=0.4.6

test/Tutorial.hs

@@ -1,4 +1,214 @@
-module Main (main) where
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE TemplateHaskell #-}
 
-main :: IO ()
-main = putStrLn "Test suite not yet implemented."
+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))
+
+prop_tables :: Pool Connection -> Property
+prop_tables pool =
+  property $ do
+    withResource pool . abort $ \conn -> do
+      evalIO $ createTables conn
+
+abort :: MonadBaseControl IO m => (Connection -> m a) -> Connection -> m a
+abort f conn =
+  bracket_
+    (liftBase (execute_ conn "BEGIN"))
+    (liftBase (execute_ conn "ROLLBACK"))
+    (f conn)
+
+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)
+    ]