From a7f2e4b32f4fb1ad6ecb46537c5752b734a8156e Mon Sep 17 00:00:00 2001 From: Nicolas Trangez Date: Sat, 14 Jan 2023 10:36:31 +0100 Subject: [PATCH] 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 | 22 ++++ hedgehog-stateful-demo.cabal | 14 ++- test/Tutorial.hs | 216 ++++++++++++++++++++++++++++++++++- 3 files changed, 248 insertions(+), 4 deletions(-) create mode 100644 README.md diff --git a/README.md b/README.md new file mode 100644 index 0000000..4ae674c --- /dev/null +++ b/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/ + diff --git a/hedgehog-stateful-demo.cabal b/hedgehog-stateful-demo.cabal index 2f8d5eb..6f8a67b 100644 --- a/hedgehog-stateful-demo.cabal +++ b/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 diff --git a/test/Tutorial.hs b/test/Tutorial.hs index 3e2059e..824cb7f 100644 --- a/test/Tutorial.hs +++ b/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) + ]