diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,13 @@ +# Changelog + +All notable changes to `atelier-testing` will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), +and this project adheres to the [PVP](https://pvp.haskell.org/). + +## [Unreleased] + +### Added + +- Initial release: database-backed test utilities (tmp-postgres) for the + atelier toolkit. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2025 Christian Georgii + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,22 @@ +# atelier-testing + +Test utilities for database-backed tests using [tmp-postgres](https://github.com/jfischoff/tmp-postgres). Part of the **atelier** toolkit. + +## Overview + +`atelier-testing` spins up a throwaway PostgreSQL instance for integration tests, so suites that exercise [`atelier-db`](https://github.com/atelier-hub/tricorder/tree/main/atelier-db) can run against a real database without external setup. + +| Module | Purpose | +|---|---| +| `Atelier.Testing.Database` | Provision and tear down a temporary PostgreSQL database for tests | + +## Part of atelier + +- [`atelier-prelude`](https://github.com/atelier-hub/tricorder/tree/main/atelier-prelude) — relude-based prelude with Effectful conventions +- [`atelier-core`](https://github.com/atelier-hub/tricorder/tree/main/atelier-core) — foundational effects and utilities +- [`atelier-db`](https://github.com/atelier-hub/tricorder/tree/main/atelier-db) — relational database effect (Hasql/Rel8) +- [`atelier-testing`](https://github.com/atelier-hub/tricorder/tree/main/atelier-testing) — this package + +## License + +MIT — see [LICENSE](LICENSE). diff --git a/atelier-testing.cabal b/atelier-testing.cabal new file mode 100644 --- /dev/null +++ b/atelier-testing.cabal @@ -0,0 +1,72 @@ +cabal-version: 2.0 + +-- This file has been generated from package.yaml by hpack version 0.38.2. +-- +-- see: https://github.com/sol/hpack + +name: atelier-testing +version: 0.1.0.0 +synopsis: Database-backed test utilities for atelier +description: Test utilities for database-backed tests using tmp-postgres — part of the atelier toolkit. +category: Testing +homepage: https://github.com/atelier-hub/tricorder#readme +bug-reports: https://github.com/atelier-hub/tricorder/issues +author: Christian Georgii +maintainer: christian.georgii@tweag.io +license: MIT +license-file: LICENSE +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/atelier-hub/tricorder + +library + exposed-modules: + Atelier.Testing.Database + other-modules: + Paths_atelier_testing + autogen-modules: + Paths_atelier_testing + hs-source-dirs: + src + default-extensions: + BlockArguments + DataKinds + DeriveAnyClass + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + GADTs + LambdaCase + MultiWayIf + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + StrictData + TemplateHaskell + TypeFamilies + ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-poly-kind-signatures -Wno-missing-role-annotations -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded + build-depends: + atelier-core ==0.1.* + , atelier-db ==0.1.* + , atelier-prelude ==0.1.* + , base ==4.20.* + , effectful-core ==2.6.* + , effectful-plugin ==2.0.* + , hasql ==1.9.* + , hasql-pool ==1.3.* + , hspec ==2.11.* + , postgres-options ==0.2.* + , string-conversions ==0.4.* + , text ==2.1.* + , tmp-postgres ==1.35.* + , unix ==2.8.* + , uuid ==1.3.* + mixins: + base hiding (Prelude) + default-language: GHC2021 diff --git a/src/Atelier/Testing/Database.hs b/src/Atelier/Testing/Database.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Testing/Database.hs @@ -0,0 +1,264 @@ +-- | Hspec helpers for running tests against a real, ephemeral PostgreSQL +-- database. +-- +-- 'withCleanTestDatabase' starts a temporary PostgreSQL server once per test +-- process, applies your migrations into a template database, and hands each spec +-- group a fresh database (as 'DBPools') that is truncated between individual +-- tests. Configure it with a 'TmpDbConfig'. +module Atelier.Testing.Database + ( TmpDbConfig (..) + , withCleanTestDatabase + ) +where + +import Atelier.Effects.DB.Config (DBConfig (..), DBPools (..), PoolConfig (..), acquireDatabasePool, acquireDatabasePools) +import Atelier.Exception (trySyncIO) +import Control.Concurrent (MVar, forkIO, modifyMVar, newEmptyMVar, newMVar, putMVar, takeMVar, threadDelay, tryPutMVar, withMVar) +import Data.String.Conversions (cs) +import Database.PostgreSQL.Simple.Options (Options (..)) +import Hasql.Session (Session, statement) +import Hasql.Statement (Statement (..)) +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.User (getEffectiveUserName) +import Test.Hspec (Spec, SpecWith, around, runIO) + +import Data.Text qualified as Text +import Data.UUID qualified as UUID +import Data.UUID.V4 qualified as UUIDv4 +import Database.Postgres.Temp qualified as TmpPostgres +import Hasql.Decoders qualified as Decoders +import Hasql.Pool qualified as Pool + + +-- | Project-specific configuration for the temporary test database. +data TmpDbConfig = TmpDbConfig + { readerUser :: Text + -- ^ Role used for read-only connections + , writerUser :: Text + -- ^ Role used for read-write connections + , schemaName :: Text + -- ^ Application schema name + , excludedTables :: [Text] + -- ^ Tables to exclude from truncation between tests (e.g. migration tracking tables) + , setupTemplate :: DBConfig -> Text -> IO () + -- ^ Called with admin config and template DB name; should apply all migrations + } + + +-- | Shared postgres server and migrated template database, created once for +-- the entire test process. All calls to 'withCleanTestDatabase' share this +-- server, so all callers must use the same 'TmpDbConfig'. +data SharedServer = SharedServer + { socketDir :: String + , portNum :: Word16 + , tmpUser :: String + , templateDbName :: Text + , defaultPool :: PoolConfig + } + + +{-# NOINLINE sharedServerVar #-} +sharedServerVar :: MVar (Maybe SharedServer) +sharedServerVar = unsafePerformIO (newMVar Nothing) + + +acquireSharedServer :: TmpDbConfig -> IO SharedServer +acquireSharedServer cfg = modifyMVar sharedServerVar $ \case + Just server -> pure (Just server, server) + Nothing -> do + server <- startSharedServer cfg + pure (Just server, server) + + +-- | Starts a TmpPostgres server in a background thread, applies migrations +-- once into a template database, then keeps the server alive for the process +-- lifetime. +startSharedServer :: TmpDbConfig -> IO SharedServer +startSharedServer cfg = do + effectiveUser <- getEffectiveUserName + readyVar <- newEmptyMVar + void $ forkIO $ do + TmpPostgres.withDbCache $ \dbCache -> do + let config = TmpPostgres.cacheConfig dbCache + result <- TmpPostgres.withConfig config $ \db -> do + let Options {host = Last mHost, port = Last mPort, user = Last mUser} = + TmpPostgres.toConnectionOptions db + socketDir = fromMaybe "localhost" mHost + portNum = fromIntegral (fromMaybe 5432 mPort) + tmpUser = fromMaybe effectiveUser mUser + pool = + PoolConfig + { size = 10 + , acquisitionTimeoutSeconds = 5 + , agingTimeoutSeconds = 1800 + , idlenessTimeoutSeconds = 600 + } + adminConfig = + DBConfig + { host = cs socketDir + , port = portNum + , user = cs tmpUser + , password = "" + , databaseName = "postgres" + , pool = pool + } + setupResult <- trySyncIO $ do + templateName <- generateUniqueDatabaseName + adminPool <- acquireDatabasePool adminConfig + createDatabase adminPool templateName + cfg.setupTemplate adminConfig templateName + grantTruncatePrivileges adminConfig templateName cfg.schemaName cfg.writerUser + pure $ SharedServer {socketDir, portNum, tmpUser, templateDbName = templateName, defaultPool = pool} + case setupResult of + Left e -> putMVar readyVar (Left (show e)) + Right server -> do + putMVar readyVar (Right server) + forever $ threadDelay 1_000_000_000 + case result of + Left e -> void $ tryPutMVar readyVar (Left (show e)) + Right _ -> pure () + takeMVar readyVar >>= either error pure + + +-- | Sets up a fresh database for the spec group (once, during spec +-- construction) and truncates all tables before each individual test. +-- The postgres server and template are shared across the process. +-- +-- Usage: +-- @ +-- spec :: Spec +-- spec = withCleanTestDatabase myConfig $ do +-- it "can read from the database" $ \pools -> do +-- -- Test code using pools +-- @ +withCleanTestDatabase :: TmpDbConfig -> SpecWith DBPools -> Spec +withCleanTestDatabase cfg spec = do + pools <- runIO $ setupTestDatabase cfg + lock <- runIO $ newMVar () + around (\action -> withMVar lock $ \_ -> cleanDatabase cfg pools >> action pools) spec + + +-- | Create a database from the shared template and acquire connection pools. +-- The database is not explicitly dropped — TmpPostgres cleans up on exit. +setupTestDatabase :: TmpDbConfig -> IO DBPools +setupTestDatabase cfg = do + server <- acquireSharedServer cfg + dbName <- generateUniqueDatabaseName + let adminConfig = + DBConfig + { host = cs server.socketDir + , port = server.portNum + , user = cs server.tmpUser + , password = "" + , databaseName = "postgres" + , pool = server.defaultPool + } + readerConfig = + DBConfig + { host = cs server.socketDir + , port = server.portNum + , user = cfg.readerUser + , password = "" + , databaseName = dbName + , pool = server.defaultPool + } + writerConfig = + DBConfig + { host = cs server.socketDir + , port = server.portNum + , user = cfg.writerUser + , password = "" + , databaseName = dbName + , pool = server.defaultPool + } + createDatabaseFromTemplate adminConfig dbName server.templateDbName + acquireDatabasePools readerConfig writerConfig + + +createDatabaseFromTemplate :: DBConfig -> Text -> Text -> IO () +createDatabaseFromTemplate adminConfig dbName templateName = do + pool <- acquireDatabasePool adminConfig + runOrThrow pool + $ statement () + $ Statement + (cs $ "CREATE DATABASE " <> dbName <> " TEMPLATE " <> templateName) + mempty + Decoders.noResult + False + + +createDatabase :: Pool.Pool -> Text -> IO () +createDatabase pool dbName = + runOrThrow pool + $ statement () + $ Statement (cs $ "CREATE DATABASE " <> dbName) mempty Decoders.noResult False + + +-- | Grant TRUNCATE on all tables in the schema to the writer role. +-- Applied to the template database so all copies inherit the grant. +grantTruncatePrivileges :: DBConfig -> Text -> Text -> Text -> IO () +grantTruncatePrivileges config dbName schema writerRole = do + pool <- acquireDatabasePool (config {databaseName = dbName}) + runOrThrow pool + $ statement () + $ Statement + (cs $ "GRANT TRUNCATE ON ALL TABLES IN SCHEMA " <> schema <> " TO " <> writerRole) + mempty + Decoders.noResult + False + + +-- | Truncate all tables in the schema except excluded ones. +cleanDatabase :: TmpDbConfig -> DBPools -> IO () +cleanDatabase cfg pools = + runOrThrow pools.writerPool $ do + tableNames <- statement () queryTableNames + unless (null tableNames) + $ truncateTables (Text.intercalate "," (map (\t -> cfg.schemaName <> "." <> t) tableNames)) + where + queryTableNames :: Statement () [Text] + queryTableNames = + Statement + ( cs + $ "SELECT tablename FROM pg_tables WHERE schemaname = '" + <> cfg.schemaName + <> "'" + <> exclusions + ) + mempty + (decodeList Decoders.text) + True + + exclusions = + if null cfg.excludedTables then + "" + else + " AND tablename NOT IN (" + <> Text.intercalate "," (map (\t -> "'" <> t <> "'") cfg.excludedTables) + <> ")" + + truncateTables :: Text -> Session () + truncateTables tableNames = + statement () + $ Statement + (cs $ "TRUNCATE TABLE " <> tableNames <> " CASCADE") + mempty + Decoders.noResult + False + + +decodeList :: Decoders.Value a -> Decoders.Result [a] +decodeList val = Decoders.rowList $ Decoders.column $ Decoders.nonNullable val + + +runOrThrow :: Pool.Pool -> Session a -> IO a +runOrThrow pool sess = + Pool.use pool sess >>= \case + Left e -> error $ "Database operation failed: " <> show e + Right a -> pure a + + +generateUniqueDatabaseName :: IO Text +generateUniqueDatabaseName = do + uuid <- UUIDv4.nextRandom + pure $ "testdb_" <> Text.replace "-" "_" (UUID.toText uuid)