atelier-db (empty) → 0.1.0.0

raw patch · 7 files changed

+411/−0 lines, 7 filesdep +aesondep +atelier-coredep +atelier-prelude

Dependencies added: aeson, atelier-core, atelier-prelude, base, bytestring, containers, data-default, effectful, effectful-core, effectful-plugin, effectful-th, hasql, hasql-pool, hasql-transaction, rel8, text, time

Files

• CHANGELOG.md +13/−0
• LICENSE +21/−0
• README.md +24/−0
• atelier-db.cabal +76/−0
• src/Atelier/Effects/DB.hs +116/−0
• src/Atelier/Effects/DB/Config.hs +101/−0
• src/Atelier/Effects/DB/Rel8.hs +60/−0

@@ -0,0 +1,13 @@+# Changelog++All notable changes to `atelier-db` 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: a relational database effect (Hasql/Rel8) 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,24 @@+# atelier-db++Relational database access via [Hasql](https://github.com/nikita-volkov/hasql) and [Rel8](https://github.com/circuithub/rel8), exposed as an [Effectful](https://github.com/haskell-effectful/effectful) effect. Part of the **atelier** toolkit.++## Overview++`atelier-db` exposes database access as a first-class effect so queries can be interpreted, mocked, and composed alongside the rest of your application's effects.++| Module | Purpose |+|---|---|+| `Atelier.Effects.DB` | The `DB` effect and its interpreters |+| `Atelier.Effects.DB.Config` | Connection configuration |+| `Atelier.Effects.DB.Rel8` | Rel8 query helpers over the `DB` effect |++## 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) — this package+- [`atelier-testing`](https://github.com/atelier-hub/tricorder/tree/main/atelier-testing) — database-backed test utilities++## License++MIT — see [LICENSE](LICENSE).

@@ -0,0 +1,76 @@+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-db+version:        0.1.0.0+synopsis:       Relational database effect for atelier (Hasql/Rel8)+description:    Relational database access via Hasql and Rel8, exposed as an Effectful effect — part of the atelier toolkit.+category:       Database+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.Effects.DB+      Atelier.Effects.DB.Config+      Atelier.Effects.DB.Rel8+  other-modules:+      Paths_atelier_db+  autogen-modules:+      Paths_atelier_db+  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:+      aeson ==2.2.*+    , atelier-core ==0.1.*+    , atelier-prelude ==0.1.*+    , base ==4.20.*+    , bytestring ==0.12.*+    , containers ==0.7.*+    , data-default ==0.8.*+    , effectful ==2.6.*+    , effectful-core ==2.6.*+    , effectful-plugin ==2.0.*+    , effectful-th ==1.0.*+    , hasql ==1.9.*+    , hasql-pool ==1.3.*+    , hasql-transaction ==1.2.*+    , rel8 ==1.7.*+    , text ==2.1.*+    , time ==1.12.*+  mixins:+      base hiding (Prelude)+  default-language: GHC2021

@@ -0,0 +1,116 @@+-- | Database access effects for Hasql connection pools.+--+-- 'DBRead' runs read-only statements against a reader pool; 'DBWrite' runs+-- transactions against a writer pool. Both record OpenTelemetry spans, and+-- 'DBRead' additionally emits Prometheus metrics (named via+-- 'DBReadMetricNames'). Failures surface through the @Error Text@ effect.+-- 'runDB' installs both effects over a shared 'DBPools'.+module Atelier.Effects.DB+    ( DBRead+    , DBWrite+    , runQuery+    , runTransaction+    , runDBRead+    , runDBWrite+    , runDB+    , DBReadMetricNames (..)+    )+where++import Atelier.Effects.Monitoring.Metrics (Metrics, counterInc, withHistogramTiming)+import Atelier.Effects.Monitoring.Tracing (SpanStatus (..), Tracing, addAttribute, setStatus, withSpan)+import Effectful (Effect, IOE)+import Effectful.Dispatch.Dynamic (interpretWith_)+import Effectful.Error.Static (Error, throwError)+import Effectful.Reader.Static (Reader, asks)+import Effectful.TH+import Hasql.Statement (Statement)+import Hasql.Transaction.Sessions (IsolationLevel (ReadCommitted), Mode (Write), transaction)++import Hasql.Pool qualified as Pool+import Hasql.Session qualified as Session+import Hasql.Transaction qualified as Transaction++import Atelier.Effects.DB.Config (DBPools)++import Atelier.Effects.DB.Config qualified as DB+++-- | Names of the Prometheus metrics recorded for database read operations.+data DBReadMetricNames = DBReadMetricNames+    { queries :: Text+    -- ^ Counter incremented once per query.+    , errors :: Text+    -- ^ Counter incremented when a query fails.+    , duration :: Text+    -- ^ Histogram recording query duration.+    }+++-- | Effect for read-only database queries.+data DBRead :: Effect where+    -- | Run a named read-only statement and return its result.+    RunQuery :: Text -> Statement () b -> DBRead m b+++-- | Effect for write database transactions.+data DBWrite :: Effect where+    -- | Run a named transaction and return its result.+    RunTransaction :: Text -> Transaction.Transaction a -> DBWrite m a+++makeEffect ''DBRead+makeEffect ''DBWrite+++-- | Interpret 'DBRead' against the reader pool, tracing each query and+-- recording the given metrics.+runDBRead+    :: (Error Text :> es, IOE :> es, Metrics :> es, Reader DBPools :> es, Tracing :> es)+    => DBReadMetricNames+    -> Eff (DBRead : es) a+    -> Eff es a+runDBRead metricNames eff = do+    pool <- asks DB.readerPool+    interpretWith_ eff \case+        RunQuery queryName stmt -> withSpan queryName do+            addAttribute @Text "db.operation" "read"+            counterInc metricNames.queries+            withHistogramTiming metricNames.duration $ do+                result <- liftIO $ Pool.use pool (Session.statement () stmt)+                case result of+                    Left err -> do+                        counterInc metricNames.errors+                        setStatus $ Error $ "Query failed: " <> show err+                        throwError $ "Query failed: " <> queryName <> " - " <> show err+                    Right value -> do+                        setStatus Ok+                        pure value+++-- | Interpret 'DBWrite' against the writer pool, tracing each transaction.+runDBWrite+    :: (Error Text :> es, IOE :> es, Reader DBPools :> es, Tracing :> es)+    => Eff (DBWrite : es) a+    -> Eff es a+runDBWrite eff = do+    pool <- asks DB.writerPool+    interpretWith_ eff \case+        RunTransaction txName tx -> withSpan txName do+            result <- liftIO $ Pool.use pool (transaction ReadCommitted Write tx)+            case result of+                Left err -> do+                    setStatus $ Error $ "Transaction failed: " <> show err+                    throwError $ "Transaction failed: " <> txName <> " - " <> show err+                Right value -> do+                    setStatus Ok+                    pure value+++-- | Run both DBRead and DBWrite effects with a shared connection pool+runDB+    :: (Error Text :> es, IOE :> es, Metrics :> es, Reader DBPools :> es, Tracing :> es)+    => DBReadMetricNames+    -> Eff (DBRead : DBWrite : es) a+    -> Eff es a+runDB metricNames = runDBWrite . runDBRead metricNames

@@ -0,0 +1,101 @@+-- | Database connection configuration and pool acquisition.+--+-- 'DBConfig' describes how to reach a database as one user, and 'PoolConfig'+-- tunes its connection pool. 'acquireDatabasePools' builds separate reader and+-- writer pools ('DBPools'), typically using distinct least-privilege roles.+module Atelier.Effects.DB.Config+    ( DBConfig (..)+    , DBPools (..)+    , PoolConfig (..)+    , acquireDatabasePool+    , acquireDatabasePools+    )+where++import Atelier.Types.QuietSnake (QuietSnake (..))+import Data.Aeson (FromJSON)++import Hasql.Connection.Setting qualified as Setting+import Hasql.Connection.Setting.Connection qualified as Connection+import Hasql.Connection.Setting.Connection.Param qualified as Param+import Hasql.Pool qualified as Pool+import Hasql.Pool.Config qualified as Pool+++-- | Connection pool configuration.+data PoolConfig = PoolConfig+    { size :: Int+    -- ^ Maximum number of connections in the pool.+    , acquisitionTimeoutSeconds :: Int+    -- ^ How long to wait for a free connection before failing.+    , agingTimeoutSeconds :: Int+    -- ^ Maximum lifetime of a connection before it is retired.+    , idlenessTimeoutSeconds :: Int+    -- ^ How long an idle connection is kept before being closed.+    }+    deriving stock (Eq, Generic, Show)+    deriving (FromJSON) via QuietSnake PoolConfig+++-- | Connection details for reaching a database as a single user.+data DBConfig = DBConfig+    { host :: Text+    -- ^ Database server host.+    , port :: Word16+    -- ^ Database server port.+    , user :: Text+    -- ^ Role to connect as.+    , password :: Text+    -- ^ Password for the role.+    , databaseName :: Text+    -- ^ Name of the database to connect to.+    , pool :: PoolConfig+    -- ^ Connection pool settings.+    }+    deriving stock (Eq, Show)+++-- | Separate connection pools for read and write operations.+data DBPools = DBPools+    { readerPool :: Pool.Pool+    -- ^ Pool for read-only queries.+    , writerPool :: Pool.Pool+    -- ^ Pool for write transactions.+    }+++-- | Acquire a single database connection pool+acquireDatabasePool :: DBConfig -> IO Pool.Pool+acquireDatabasePool config = do+    let settings =+            [ Pool.staticConnectionSettings+                [ Setting.connection+                    $ Connection.params+                        [ Param.host config.host+                        , Param.port config.port+                        , Param.user config.user+                        , Param.password config.password+                        , Param.dbname config.databaseName+                        ]+                ]+            , Pool.size config.pool.size+            , Pool.acquisitionTimeout (fromIntegral config.pool.acquisitionTimeoutSeconds)+            , Pool.agingTimeout (fromIntegral config.pool.agingTimeoutSeconds)+            , Pool.idlenessTimeout (fromIntegral config.pool.idlenessTimeoutSeconds)+            ]++    Pool.acquire $ Pool.settings settings+++-- | Acquire both read and write connection pools+-- Uses different database users for read-only and read-write operations+acquireDatabasePools+    :: DBConfig+    -- ^ Read-only user config+    -> DBConfig+    -- ^ Read-write user config+    -> IO DBPools+acquireDatabasePools readerConfig writerConfig = do+    readerPool <- acquireDatabasePool readerConfig+    writerPool <- acquireDatabasePool writerConfig+    pure $ DBPools {readerPool, writerPool}

@@ -0,0 +1,60 @@+-- | Rel8 query helpers layered over the 'DBRead' and 'DBWrite' effects.+--+-- Thin wrappers that build Hasql @Statement@s from Rel8 queries and run them+-- through the database effects: 'select' and 'select1' for reads, and 'transact'+-- with 'insert_', 'update_', 'delete_' and 'selectTx' for writes. The Hasql+-- 'Transaction' type is re-exported for building transaction bodies.+module Atelier.Effects.DB.Rel8+    ( Transaction+    , select+    , select1+    , transact+    , insert_+    , update_+    , delete_+    , selectTx+    )+where++import Hasql.Transaction (Transaction)+import Rel8 (Delete, Insert, Query, Serializable, Update)++import Hasql.Transaction qualified as TX+import Rel8 qualified++import Atelier.Effects.DB (DBRead, DBWrite, runQuery, runTransaction)+++-- | Run a Rel8 SELECT query via 'DBRead'.+select :: (DBRead :> es, Serializable exprs results) => Text -> Query exprs -> Eff es [results]+select name query = runQuery name (Rel8.run $ Rel8.select query)+++-- | Run a Rel8 SELECT expecting exactly one result via 'DBRead'.+select1 :: (DBRead :> es, Serializable exprs results) => Text -> Query exprs -> Eff es results+select1 name query = runQuery name (Rel8.run1 $ Rel8.select query)+++-- | Run a Hasql transaction via 'DBWrite'.+transact :: (DBWrite :> es) => Text -> Transaction a -> Eff es a+transact = runTransaction+++-- | Run a Rel8 INSERT inside a 'Transaction'.+insert_ :: Insert a -> Transaction ()+insert_ = TX.statement () . Rel8.run_ . Rel8.insert+++-- | Run a Rel8 UPDATE inside a 'Transaction'.+update_ :: Update a -> Transaction ()+update_ = TX.statement () . Rel8.run_ . Rel8.update+++-- | Run a Rel8 DELETE inside a 'Transaction'.+delete_ :: Delete a -> Transaction ()+delete_ = TX.statement () . Rel8.run_ . Rel8.delete+++-- | Run a Rel8 SELECT inside a 'Transaction'.+selectTx :: (Serializable exprs results) => Query exprs -> Transaction [results]+selectTx = TX.statement () . Rel8.run . Rel8.select