Improved testing functionality

IHP/QueryBuilder.hs

@@ -289,7 +289,7 @@ buildQuery queryBuilderProvider = buildQueryHelper $ getQueryBuilder queryBuilde
  buildQueryHelper NewQueryBuilder { columns } =
  let tableName = symbolToByteString @table
  in SQLQuery
- { queryIndex = trace (Prelude.show $ getQueryIndex queryBuilderProvider) getQueryIndex queryBuilderProvider 
+ { queryIndex = getQueryIndex queryBuilderProvider 
  , selectFrom = tableName
  , distinctClause = Nothing
  , distinctOnClause = Nothing

IHP/Test/Database.hs

@@ -0,0 +1,64 @@
+module IHP.Test.Database where
+
+import IHP.Prelude
+import qualified Database.PostgreSQL.Simple as PG
+import qualified Database.PostgreSQL.Simple.Types as PG
+import qualified Database.PostgreSQL.Simple.FromRow as PG
+import qualified Database.PostgreSQL.Simple.ToField as PG
+import qualified Data.UUID.V4 as UUID
+import qualified Data.UUID as UUID
+import qualified System.Process as Process
+import qualified Data.Text as Text
+import qualified Data.ByteString as ByteString
+
+
+data TestDatabase = TestDatabase
+ { name :: Text
+ , url :: ByteString
+ }
+
+-- | Given a Postgres Database URL it creates a new randomly named database on the database server. Returns a database url to the freshly created database
+--
+-- >>> createTestDatabase "postgresql:///app?host=/myapp/build/db"
+-- TestDatabase { name = "test-7d3bd463-4cce-413f-a272-ac52e5d93739", url = "postgresql:///test-7d3bd463-4cce-413f-a272-ac52e5d93739?host=/myapp/build/db" }
+--
+createTestDatabase :: ByteString -> IO TestDatabase
+createTestDatabase databaseUrl = do
+ databaseId <- UUID.nextRandom
+ let databaseName = "test-" <> UUID.toText databaseId
+
+ connection <- PG.connectPostgreSQL databaseUrl
+ PG.execute connection "CREATE DATABASE ?" [PG.Identifier databaseName]
+
+ let newUrl :: ByteString = databaseUrl
+ |> cs
+ |> Text.replace "postgresql:///app" ("postgresql:///" <> databaseName)
+ |> cs
+
+ importSql newUrl "Application/Schema.sql"
+
+ pure TestDatabase { name = databaseName, url = newUrl }
+
+-- | Given the master connection url and the open test database, this will clean up the test database
+--
+-- >>> deleteDatabase "postgresql:///app?host=/myapp/build/db" TestDatabase { name = "test-7d3bd463-4cce-413f-a272-ac52e5d93739", url = "postgresql:///test-7d3bd463-4cce-413f-a272-ac52e5d93739?host=/myapp/build/db" }
+--
+-- The master connection url needs to be passed as we cannot drop the database we're currently connected to, and therefore
+-- we cannot use the test database itself.
+--
+deleteDatabase :: ByteString -> TestDatabase -> IO ()
+deleteDatabase masterDatabaseUrl testDatabase = do
+ connection <- PG.connectPostgreSQL masterDatabaseUrl
+
+ -- The WITH FORCE is required to force close open connections
+ -- Otherwise the DROP DATABASE takes a few seconds to execute
+ PG.execute connection "DROP DATABASE ? WITH (FORCE)" [PG.Identifier (get #name testDatabase)]
+ pure ()
+
+importSql url file = do
+ schemaSql <- ByteString.readFile file
+
+ connection <- PG.connectPostgreSQL url
+ PG.execute connection (PG.Query schemaSql) ()
+ PG.close connection
+

IHP/Test/Mocking.hs

@@ -27,23 +27,28 @@ import qualified IHP.FrameworkConfig as FrameworkConfig
 import IHP.ModelSupport (createModelContext)
 import IHP.Prelude
 import IHP.Log.Types
+import qualified IHP.Test.Database as Database
+import Test.Hspec
+import qualified Data.Text as Text
 
 type ContextParameters application = (?applicationContext :: ApplicationContext, ?context :: RequestContext, ?modelContext :: ModelContext, ?application :: application, InitControllerContext application, ?mocking :: MockContext application)
 
-data MockContext application = InitControllerContext application => MockContext {
- modelContext :: ModelContext
- , requestContext :: RequestContext
- , applicationContext :: ApplicationContext
- , application :: application
- }
+data MockContext application = InitControllerContext application => MockContext
+ { modelContext :: ModelContext
+  , requestContext :: RequestContext
+  , applicationContext :: ApplicationContext
+  , application :: application
+  }
 
 -- | Create contexts that can be used for mocking
-mockContext :: (InitControllerContext application) => application -> ConfigBuilder -> IO (MockContext application)
-mockContext application configBuilder = do
+withIHPApp :: (InitControllerContext application) => application -> ConfigBuilder -> (MockContext application -> IO ()) -> IO ()
+withIHPApp application configBuilder hspecAction = do
  frameworkConfig@(FrameworkConfig {dbPoolMaxConnections, dbPoolIdleTime, databaseUrl}) <- FrameworkConfig.buildFrameworkConfig configBuilder
- databaseConnection <- connectPostgreSQL databaseUrl
+
+ testDatabase <- Database.createTestDatabase databaseUrl
+
  logger <- newLogger def { level = Warn } -- don't log queries
- modelContext <- createModelContext dbPoolIdleTime dbPoolMaxConnections databaseUrl logger
+ modelContext <- createModelContext dbPoolIdleTime dbPoolMaxConnections (get #url testDatabase) logger
 
  autoRefreshServer <- newIORef AutoRefresh.newAutoRefreshServer
  session <- Vault.newKey
@@ -53,11 +58,13 @@ mockContext application configBuilder = do
  let requestContext = RequestContext
  { request = defaultRequest {vault = sessionVault}
  , requestBody = FormBody [] []
- , respond = \resp -> pure ResponseReceived
+ , respond = const (pure ResponseReceived)
  , vault = session
  , frameworkConfig = frameworkConfig }
 
- pure MockContext{..}
+ hspecAction MockContext { .. }
+
+ Database.deleteDatabase databaseUrl testDatabase
 
 mockContextNoDatabase :: (InitControllerContext application) => application -> ConfigBuilder -> IO (MockContext application)
 mockContextNoDatabase application configBuilder = do
@@ -95,21 +102,24 @@ setupWithContext :: (ContextParameters application => IO a) -> MockContext appli
 setupWithContext action context = withContext action context >> pure context
 
 -- | Runs a controller action in a mock environment
-mockAction :: forall application controller. (Controller controller, ContextParameters application, Typeable application, Typeable controller) => controller -> IO Response
-mockAction controller = do
+callAction :: forall application controller. (Controller controller, ContextParameters application, Typeable application, Typeable controller) => controller -> IO Response
+callAction controller = do
  responseRef <- newIORef Nothing
- let oldRespond = ?context |> respond
  let customRespond response = do
  writeIORef responseRef (Just response)
- oldRespond response
+ pure ResponseReceived
  let requestContextWithOverridenRespond = ?context { respond = customRespond }
- let ?requestContext = requestContextWithOverridenRespond
+ let ?context = requestContextWithOverridenRespond
  runActionWithNewContext controller
  maybeResponse <- readIORef responseRef
  case maybeResponse of
  Just response -> pure response
  Nothing -> error "mockAction: The action did not render a response"
 
+-- | mockAction has been renamed to callAction
+mockAction :: _ => _
+mockAction = callAction
+
 -- | Get contents of response
 mockActionResponse :: forall application controller. (Controller controller, ContextParameters application, Typeable application, Typeable controller) => controller -> IO LBS.ByteString
 mockActionResponse = (responseBody =<<) . mockAction
@@ -124,13 +134,19 @@ withParams ps action context = withContext action context'
  where
  context' = context{requestContext=(requestContext context){requestBody=FormBody ps []}}
 
-headers :: IO Response -> IO ResponseHeaders
-headers = fmap responseHeaders
-
 responseBody :: Response -> IO LBS.ByteString
 responseBody res =
  let (status,headers,body) = responseToStream res in
  body $ \f -> do
  content <- newIORef mempty
  f (\chunk -> modifyIORef' content (<> chunk)) (return ())
  toLazyByteString <$> readIORef content
+
+
+responseBodyShouldContain :: Response -> Text -> IO ()
+responseBodyShouldContain response includedText = do
+ body :: Text <- cs <$> responseBody response
+ body `shouldSatisfy` (includedText `Text.isInfixOf`)
+
+responseStatusShouldBe :: Response -> HTTP.Status -> IO ()
+responseStatusShouldBe response status = responseStatus response `shouldBe` status

ihp.cabal

@@ -242,6 +242,7 @@ library
  , IHP.LibDir
  , IHP.Telemetry
  , IHP.Test.Mocking
+ , IHP.Test.Database
  , IHP.Version
  , IHP.Postgres.TypeInfo
  , IHP.Postgres.Point