atelier-testing (empty) → 0.1.0.0

raw patch · 5 files changed

+392/−0 lines, 5 filesdep +atelier-coredep +atelier-dbdep +atelier-prelude

Dependencies added: atelier-core, atelier-db, atelier-prelude, base, effectful-core, effectful-plugin, hasql, hasql-pool, hspec, postgres-options, string-conversions, text, tmp-postgres, unix, uuid

Files

• CHANGELOG.md +13/−0
• LICENSE +21/−0
• README.md +22/−0
• atelier-testing.cabal +72/−0
• src/Atelier/Testing/Database.hs +264/−0

@@ -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.

@@ -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.

@@ -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).

@@ -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

@@ -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)