diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## 0.0.1.0 (April 24th, 2017) + +- Initial release diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +-- This script is used to build and install your package. Typically you don't +-- need to change it. The Cabal documentation has more information about this +-- file: . +import qualified Distribution.Simple + +main :: IO () +main = Distribution.Simple.defaultMain diff --git a/genesis-test.cabal b/genesis-test.cabal new file mode 100644 --- /dev/null +++ b/genesis-test.cabal @@ -0,0 +1,69 @@ +-- This file has been generated from package.yaml by hpack version 0.15.0. +-- +-- see: https://github.com/sol/hpack + +name: genesis-test +version: 0.0.1.0 +synopsis: Opinionated bootstrapping for Haskell web services. +description: Opinionated bootstrapping for Haskell web services. +category: Other +homepage: https://github.com/cjdev/genesis#readme +bug-reports: https://github.com/cjdev/genesis/issues +maintainer: Alexis King +copyright: 2017 CJ Affiliate by Conversant +license: ISC +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + CHANGELOG.md + package.yaml + stack.yaml + +source-repository head + type: git + location: https://github.com/cjdev/genesis + +library + hs-source-dirs: + library + default-extensions: ConstraintKinds DeriveGeneric DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.9.0.0 && < 5 + , genesis == 0.0.1.0 + , hspec + , hspec-expectations >= 0.7.0 + , lifted-base + , monad-control >= 1.0.0.0 && < 2 + , monad-logger >= 0.3.10 + , monad-persist >= 0.0.1.0 && < 1 + , persistent-postgresql >= 2.5 && < 3 + , transformers-base + exposed-modules: + Genesis.Test + Genesis.Test.Hspec + Genesis.Test.Persist + default-language: Haskell2010 + +test-suite genesis-test-test-suite + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + test-suite + default-extensions: ConstraintKinds DeriveGeneric DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables TypeApplications TypeOperators + ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N + build-depends: + base + , envparse + , genesis + , genesis-test + , hspec + , monad-logger + , monad-persist + , persistent-template + , text + other-modules: + Genesis.Test.PersistSpec + Spec + default-language: Haskell2010 diff --git a/library/Genesis/Test.hs b/library/Genesis/Test.hs new file mode 100644 --- /dev/null +++ b/library/Genesis/Test.hs @@ -0,0 +1,18 @@ +module Genesis.Test + ( -- * Managing the global database connection + -- | The bindings in this section are re-exported from + -- "Genesis.Test.Persist". For more information, see the module + -- documentation for "Genesis.Test.Persist". + runDB + , runDBCommit + , withGlobalPostgresqlConn + -- * HSpec helpers + , module Genesis.Test.Hspec + , dbExample + -- * Other re-exports + , module Genesis.Persist + ) where + +import Genesis.Persist +import Genesis.Test.Hspec +import Genesis.Test.Persist diff --git a/library/Genesis/Test/Hspec.hs b/library/Genesis/Test/Hspec.hs new file mode 100644 --- /dev/null +++ b/library/Genesis/Test/Hspec.hs @@ -0,0 +1,101 @@ +{-| + This module re-exports everything from "Test.Hspec", except with modified + versions of the runner and expectations that operate over an arbitrary monad + transformer stack with 'IO' at the base. This is especially useful in + conjunction with 'Genesis.Test.Persist.dbExample' from "Genesis.Test.Persist", + which runs an @hspec@ example in a monad that can interact with a database. +-} +module Genesis.Test.Hspec + ( module Test.Hspec + , hspec + , expectationFailure + , shouldBe + , shouldSatisfy + , shouldStartWith + , shouldEndWith + , shouldContain + , shouldMatchList + , shouldReturn + , shouldNotBe + , shouldNotSatisfy + , shouldNotContain + , shouldNotReturn + , shouldThrow + ) where + +import qualified Test.Hspec as Hspec + +import Control.Exception.Lifted (Exception, try) +import Control.Monad (unless) +import Control.Monad.Base (MonadBase, liftBase) +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Proxy (Proxy(..)) +import Data.Typeable (typeRep) +import GHC.Stack (HasCallStack) +import Test.Hspec hiding + ( hspec + , expectationFailure + , shouldBe + , shouldSatisfy + , shouldStartWith + , shouldEndWith + , shouldContain + , shouldMatchList + , shouldReturn + , shouldNotBe + , shouldNotSatisfy + , shouldNotContain + , shouldNotReturn + , shouldThrow + ) + +hspec :: MonadBase IO m => Spec -> m () +hspec x = liftBase $ Hspec.hspec x + +expectationFailure :: (HasCallStack, MonadBase IO m) => String -> m () +expectationFailure x = liftBase $ Hspec.expectationFailure x + +expectTrue :: (HasCallStack, MonadBase IO m) => String -> Bool -> m () +expectTrue msg b = unless b (expectationFailure msg) + +shouldBe :: (HasCallStack, Show a, Eq a, MonadBase IO m) => a -> a -> m () +shouldBe x y = liftBase $ Hspec.shouldBe x y + +shouldSatisfy :: (HasCallStack, Show a, MonadBase IO m) => a -> (a -> Bool) -> m () +shouldSatisfy x y = liftBase $ Hspec.shouldSatisfy x y + +shouldStartWith :: (HasCallStack, Show a, Eq a, MonadBase IO m) => [a] -> [a] -> m () +shouldStartWith x y = liftBase $ Hspec.shouldStartWith x y + +shouldEndWith :: (HasCallStack, Show a, Eq a, MonadBase IO m) => [a] -> [a] -> m () +shouldEndWith x y = liftBase $ Hspec.shouldEndWith x y + +shouldContain :: (HasCallStack, Show a, Eq a, MonadBase IO m) => [a] -> [a] -> m () +shouldContain x y = liftBase $ Hspec.shouldContain x y + +shouldMatchList :: (HasCallStack, Show a, Eq a, MonadBase IO m) => [a] -> [a] -> m () +shouldMatchList x y = liftBase $ Hspec.shouldMatchList x y + +shouldNotBe :: (HasCallStack, Show a, Eq a, MonadBase IO m) => a -> a -> m () +shouldNotBe x y = liftBase $ Hspec.shouldNotBe x y + +shouldNotSatisfy :: (HasCallStack, Show a, MonadBase IO m) => a -> (a -> Bool) -> m () +shouldNotSatisfy x y = liftBase $ Hspec.shouldNotSatisfy x y + +shouldNotContain :: (HasCallStack, Show a, Eq a, MonadBase IO m) => [a] -> [a] -> m () +shouldNotContain x y = liftBase $ Hspec.shouldNotContain x y + +shouldReturn :: (HasCallStack, Show a, Eq a, MonadBase IO m) => m a -> a -> m () +shouldReturn action x = action >>= (`shouldBe` x) + +shouldNotReturn :: (HasCallStack, Show a, Eq a, MonadBase IO m) => m a -> a -> m () +shouldNotReturn action x = action >>= (`shouldNotBe` x) + +-- impl modified from Test.Hspec.Expectations.shouldThrow +shouldThrow :: forall e a m. (HasCallStack, Exception e, MonadBaseControl IO m) => m a -> Selector e -> m () +shouldThrow action p = try action >>= \case + Right _ -> expectationFailure $ + "did not get expected exception: " ++ exceptionType + Left e -> flip expectTrue (p e) $ + "predicate failed on expected exception: " ++ exceptionType ++ " (" ++ show e ++ ")" + where exceptionType = show $ typeRep (Proxy @e) -- a string repsentation of the expected exception's type diff --git a/library/Genesis/Test/Persist.hs b/library/Genesis/Test/Persist.hs new file mode 100644 --- /dev/null +++ b/library/Genesis/Test/Persist.hs @@ -0,0 +1,118 @@ +{-# OPTIONS_HADDOCK not-home #-} + +{-| + This module provides 'withGlobalPostgresqlConn', a function that parameterizes + a global reference to a PostgreSQL database, 'dbConn'. This is intended for + use in test code that does not need a connection pool and simply needs to + execute functions against a database. It also provides 'postgresOptions', an + @envparse@ 'Env.Parser' for 'PostgresOptions', which makes it easy to + configure the PostgreSQL connection via the environment. + + If you use @hspec@, you should wrap your top-level test execution with + 'withGlobalPostgresqlConn' to properly set the global connection during the + dynamic scope of your tests and ensure the database is rolled back after each + test, then use 'runDB' in your tests to utilize the global connection. + + Example: + + @ + main :: 'IO' () + main = do + opts <- 'Env.parse' ('Env.header' "test suite") 'postgresOptions' + 'withGlobalPostgresqlConn' opts $ + 'Hspec.hspec' spec + + spec :: 'Spec' + spec = 'Hspec.describe' "GET /foo" $ do + 'Hspec.it' "should produce a Foo" $ 'dbExample' $ do + let foo = Foo { fooBar = "baz" } + fooId <- 'Persist.insert' foo + result <- getFoo (FooId 1) + result `​'Hspec.shouldBe'​` foo + @ +-} +module Genesis.Test.Persist + ( runDB + , runDBCommit + , dbExample + , dbConn + , withGlobalPostgresqlConn + ) where + +import qualified Control.Monad.Persist as Persist +import qualified Database.Persist.Postgresql as PG +import qualified Genesis.Test.Hspec as Hspec + +import Control.Exception (bracket_) +import Control.Monad.Base (liftBase) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Logger (runNoLoggingT) +import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Maybe (fromMaybe) +import Genesis.Persist (PostgresOptions, withPostgresqlConn) +import GHC.Stack (HasCallStack) +import System.IO.Unsafe (unsafePerformIO) + +dbConnRef :: IORef (Maybe Persist.SqlBackend) +dbConnRef = unsafePerformIO (newIORef Nothing) +{-# NOINLINE dbConnRef #-} + +{-| + Low-level access to the global database connection. If the global connection + does not exist (that is, you are not in the dynamic extent of a call to + 'withGlobalPostgresqlConn'), this will raise an exception. +-} +dbConn :: HasCallStack => MonadBaseControl IO m => m Persist.SqlBackend +dbConn = fromMaybe (error "dbConn: connection does not exist") <$> liftBase (readIORef dbConnRef) + +{-| + Runs a computation that may interact with a database using the global database + context, then rolls back the transaction once the computation has completed. + This is intended to be wrapped around a single test case to create a + self-contained test that interacts with the database. + + If you are using @hspec@, the 'dbExample' helper may be more useful and + concise, but this function is provided for uses that fall outside of simple + @hspec@ examples. +-} +runDB :: (MonadIO m, MonadBaseControl IO m) => Persist.SqlPersistT m a -> m a +runDB x = Persist.runPersistT (x <* Persist.transactionUndo) =<< dbConn + +{-| + Like 'runDB', except that the transaction is commited after running instead of + rolled back. You should avoid this in test code to avoid creating tests that + dependent on the database state, but it can be useful to run migrations, for + example. +-} +runDBCommit :: (MonadIO m, MonadBaseControl IO m) => Persist.SqlPersistT m a -> m a +runDBCommit x = Persist.runPersistT (x <* Persist.transactionSave) =<< dbConn + +{-| + A helper function that combines 'Hspec.example' with 'runDB'. This can be used + with 'Hspec.it' to create a test case which has access to the database within + its body: + + @ + spec = 'Hspec.describe' "the database" $ + 'Hspec.it' "holds records" $ 'dbExample' $ do + ... + @ + + When using this function, you should most likely also use "Genesis.Test.Hspec" + instead of "Test.Hspec" to avoid unnecessarily lifting of assertions. +-} +dbExample :: Persist.SqlPersistT IO () -> Hspec.Expectation +dbExample = Hspec.example . runDB + +{-| + Parameterizes the global database connection, 'dbConn', within the dynamic + extent of its execution. The connection is started within a transaction. +-} +withGlobalPostgresqlConn :: MonadBaseControl IO m => PostgresOptions -> m a -> m a +withGlobalPostgresqlConn opts = liftBaseOp_ $ \action -> + runNoLoggingT $ withPostgresqlConn opts $ \conn -> do + oldConn <- liftBase $ readIORef dbConnRef + liftBase $ bracket_ (writeIORef dbConnRef (Just conn)) (writeIORef dbConnRef oldConn) $ do + PG.connBegin conn (PG.getStmtConn conn) -- start a new transaction + action diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,66 @@ +name: genesis-test +version: 0.0.1.0 +category: Other +synopsis: Opinionated bootstrapping for Haskell web services. +description: Opinionated bootstrapping for Haskell web services. +maintainer: Alexis King +copyright: 2017 CJ Affiliate by Conversant +license: ISC +github: cjdev/genesis + +extra-source-files: +- CHANGELOG.md +- package.yaml +- stack.yaml + +ghc-options: -Wall +default-extensions: +- ConstraintKinds +- DeriveGeneric +- DuplicateRecordFields +- FlexibleContexts +- FlexibleInstances +- GADTs +- GeneralizedNewtypeDeriving +- KindSignatures +- LambdaCase +- MultiParamTypeClasses +- NamedFieldPuns +- OverloadedStrings +- RankNTypes +- ScopedTypeVariables +- TypeApplications +- TypeOperators + +library: + dependencies: + - base >= 4.9.0.0 && < 5 + - genesis == 0.0.1.0 + - hspec + - hspec-expectations >= 0.7.0 + - lifted-base + - monad-control >= 1.0.0.0 && < 2 + - monad-logger >= 0.3.10 + - monad-persist >= 0.0.1.0 && < 1 + - persistent-postgresql >= 2.5 && < 3 + - transformers-base + source-dirs: library + +tests: + genesis-test-test-suite: + dependencies: + - base + - envparse + - genesis + - genesis-test + - hspec + - monad-logger + - monad-persist + - persistent-template + - text + ghc-options: + - -rtsopts + - -threaded + - -with-rtsopts=-N + main: Main.hs + source-dirs: test-suite diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,12 @@ +resolver: lts-8.11 + +packages: +- '.' +- location: '../genesis' + extra-dep: true + +extra-deps: [monad-persist-0.0.1.0] + +flags: {} + +extra-package-dbs: [] diff --git a/test-suite/Genesis/Test/PersistSpec.hs b/test-suite/Genesis/Test/PersistSpec.hs new file mode 100644 --- /dev/null +++ b/test-suite/Genesis/Test/PersistSpec.hs @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Genesis.Test.PersistSpec (spec) where + +import Control.Monad.Persist (Entity(..), insert, selectList) +import Data.Text (Text) +import Database.Persist.TH (mkPersist, persistLowerCase, sqlSettings) +import Genesis.Test + +mkPersist sqlSettings [persistLowerCase| +Blog + name Text + deriving Eq Show + +Post + title Text + body Text + blogId BlogId + deriving Eq Show +|] + +spec :: Spec +spec = describe "dbExample" $ + it "runs an Hspec example with access to the database" $ dbExample $ do + blogId <- insert $ Blog "Alyssa’s Blog" + let post = Post { postTitle = "First Post", postBody = "world changing post", postBlogId = blogId } + postId <- insert post + posts <- selectList [] [] + posts `shouldBe` [Entity postId post] diff --git a/test-suite/Main.hs b/test-suite/Main.hs new file mode 100644 --- /dev/null +++ b/test-suite/Main.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} + +import qualified Env +import qualified Spec + +import Control.Monad.Logger (runNoLoggingT) +import Genesis.Persist.Migrate (runMigrations) +import Genesis.Test + +main :: IO () +main = do + opts <- Env.parse (Env.header "genesis-test test suite") postgresOptions + runNoLoggingT $ withGlobalPostgresqlConn opts $ do + runDBCommit $(runMigrations "test-suite/migrations") + hspec Spec.spec diff --git a/test-suite/Spec.hs b/test-suite/Spec.hs new file mode 100644 --- /dev/null +++ b/test-suite/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}