packages feed

valiant-mtl (empty) → 0.1.0.0

raw patch · 8 files changed

+768/−0 lines, 8 filesdep +basedep +bytestringdep +hspec

Dependencies added: base, bytestring, hspec, mtl, pg-wire, text, time, transformers, valiant, valiant-mtl, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,14 @@+# Changelog++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/),+and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).++## [0.1.0.0] - 2026-04-25++Initial release. MTL-style adapter for+[`valiant`](https://hackage.haskell.org/package/valiant). Operations+work in any monad with a `HasPool` instance and `MonadIO`. Covers+queries, commands, transactions (including isolation levels), pool+stats, and raw connection access.++[0.1.0.0]: https://github.com/joshburgess/valiant/releases/tag/v0.1.0.0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2026 Josh Burgess++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from this+   software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,54 @@+# valiant-mtl++MTL-style adapter for+[`valiant`](https://hackage.haskell.org/package/valiant).++All operations work in any monad with `HasPool m` (a `MonadReader`-like+class that exposes a `Pool`) and `MonadIO m`. Use this when your+application lives in an `mtl` stack with a richer environment than+just `Pool`.++## Quick start++```haskell+import Control.Monad.Reader+import Valiant (newPool, defaultPoolConfig, poolConnString)+import Valiant.Mtl++data AppEnv = AppEnv+  { appPool   :: Pool+  , appLogger :: Logger+  }++instance HasPool (ReaderT AppEnv IO) where+  getPool = asks appPool++myApp :: (HasPool m, MonadIO m) => m [User]+myApp = do+  users <- fetchAllMtl listUsers ()+  count <- fetchScalarMtl countUsers ()+  pure users++main :: IO ()+main = do+  pool   <- newPool defaultPoolConfig { poolConnString = "postgres://..." }+  logger <- newLogger+  runReaderT myApp (AppEnv pool logger)+```++## What you get++- `class HasPool m where getPool :: m Pool`+- Query operations: `fetchOneMtl`, `fetchAllMtl`, `fetchScalarMtl`,+  `fetchOneOrThrowMtl`, `fetchExistsMtl`, `forEachMtl`+- Command operations: `executeMtl`, `executeReturningMtl`,+  `executeBatchMtl`+- Transactions: `withTransactionMtl`, `withTransactionLevelMtl`+- Pool helpers: `poolStatsMtl`, `withConnectionMtl`++There is also a `Valiant.Monad` module re-exported from this package+that provides the same operations specialised to+`ReaderT Pool IO`.++See the [valiant tutorial](https://github.com/joshburgess/valiant/blob/main/docs/TUTORIAL.md)+for `Statement` definitions and the `valiant prepare` workflow.
+ src/Valiant/Monad.hs view
@@ -0,0 +1,275 @@+-- | Optional convenience monad for valiant.+--+-- Provides a 'ReaderT'-based monad that carries a 'Pool' implicitly,+-- so you don't have to thread it through every function call.+-- Zero-cost at runtime ('ReaderT' is a newtype).+--+-- @+-- import Valiant.Monad+--+-- app :: Valiant ()+-- app = do+--   users <- fetchAllM Q.listUsers ()+--   mUser <- fetchOneM Q.findById 42+--   n     <- executeM Q.deleteOld cutoff+--   withTransactionM $ \\tx -> do+--     liftIO $ execute (txConn tx) Q.insert ("Alice", email)+--+-- main :: IO ()+-- main = do+--   pool <- newPool defaultPoolConfig { poolConnString = "..." }+--   runValiant pool app+-- @+--+-- All @*M@ functions acquire a connection from the pool, run the+-- operation, and return the connection automatically. For operations+-- that need multiple queries on the same connection, use+-- 'withConnectionM'.+module Valiant.Monad+  ( -- * Monad+    Valiant+  , runValiant++    -- * Connection access+  , askPool+  , withConnectionM+  , withResourceTimeoutM++    -- * Queries+  , fetchOneM+  , fetchAllM+  , fetchAllVecM+  , fetchScalarM+  , fetchOneOrThrowM+  , fetchOneOrM+  , fetchExistsM+  , forEachM++    -- * Commands+  , executeM+  , executeReturningM+  , executeReturningManyM+  , executeBatchM+  , executeManyM++    -- * Pipelined batch reads+  , fetchBatchOneM+  , fetchBatchAllM++    -- * Transactions+  , withTransactionM+  , withTransaction_M+  , withTransactionLevelM+  , withTransactionModeM+  , withReadOnlyTransactionM+  , withDeferrableTransactionM+  , withTransactionRetryM++    -- * Pool management+  , poolStatsM+  , resizeM+  ) where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ReaderT (..), ask)+import Data.Int (Int64)+import Data.Vector (Vector)+import Valiant.Execute (execute, executeBatch, executeMany, executeReturning, executeReturningMany, fetchAll, fetchAllVec, fetchBatchAll, fetchBatchOne, fetchExists, fetchOne, fetchOneOr, fetchOneOrThrow, fetchScalar, forEach)+import Valiant.Statement (Statement)+import Valiant.Transaction (IsolationLevel, Transaction, TransactionMode, withDeferrableTransaction, withReadOnlyTransaction, withTransaction, withTransactionLevel, withTransactionMode, withTransactionRetry, withTransaction_)+import PgWire.Connection (Connection)+import Data.Time (NominalDiffTime)+import PgWire.Pool (Pool, PoolStats, poolStats, resize, withResource, withResourceTimeout)++-- | A monad that carries a connection 'Pool' implicitly.+-- @Valiant a = ReaderT Pool IO a@.+type Valiant = ReaderT Pool IO++-- | Run an 'Valiant' action with the given pool.+runValiant :: Pool -> Valiant a -> IO a+runValiant pool action = runReaderT action pool+{-# INLINE runValiant #-}++-- | Get the underlying pool.+askPool :: Valiant Pool+askPool = ask+{-# INLINE askPool #-}++-- | Acquire a connection from the pool for the duration of the callback.+-- Useful when you need multiple operations on the same connection+-- without a transaction.+withConnectionM :: (Connection -> IO a) -> Valiant a+withConnectionM f = do+  pool <- ask+  liftIO $ withResource pool f+{-# INLINE withConnectionM #-}++-- | Like 'withConnectionM' but with a custom acquire timeout.+--+-- Overrides 'poolAcquireTimeout' for this single acquisition. Useful when+-- certain operations can tolerate longer (or shorter) waits than the pool+-- default.+withResourceTimeoutM :: NominalDiffTime -> (Connection -> IO a) -> Valiant a+withResourceTimeoutM timeout f = do+  pool <- ask+  liftIO $ withResourceTimeout pool timeout f+{-# INLINE withResourceTimeoutM #-}++------------------------------------------------------------------------+-- Queries+------------------------------------------------------------------------++-- | Fetch zero or one row.+fetchOneM :: Statement p r -> p -> Valiant (Maybe r)+fetchOneM stmt params = withConnectionM $ \conn -> fetchOne conn stmt params+{-# INLINE fetchOneM #-}++-- | Fetch all result rows.+fetchAllM :: Statement p r -> p -> Valiant [r]+fetchAllM stmt params = withConnectionM $ \conn -> fetchAll conn stmt params+{-# INLINE fetchAllM #-}++-- | Fetch a single scalar value.+fetchScalarM :: Statement p r -> p -> Valiant r+fetchScalarM stmt params = withConnectionM $ \conn -> fetchScalar conn stmt params+{-# INLINE fetchScalarM #-}++-- | Like 'fetchOneM' but throws 'DecodeError' if no rows are returned.+fetchOneOrThrowM :: Statement p r -> p -> Valiant r+fetchOneOrThrowM stmt params = withConnectionM $ \conn -> fetchOneOrThrow conn stmt params+{-# INLINE fetchOneOrThrowM #-}++-- | Fetch all result rows as a 'Vector'.+fetchAllVecM :: Statement p r -> p -> Valiant (Vector r)+fetchAllVecM stmt params = withConnectionM $ \conn -> fetchAllVec conn stmt params+{-# INLINE fetchAllVecM #-}++-- | Like 'fetchOneM' but returns a default value on no rows.+fetchOneOrM :: Statement p r -> p -> r -> Valiant r+fetchOneOrM stmt params def = withConnectionM $ \conn -> fetchOneOr conn stmt params def+{-# INLINE fetchOneOrM #-}++-- | Check whether a query returns any rows.+fetchExistsM :: Statement p r -> p -> Valiant Bool+fetchExistsM stmt params = withConnectionM $ \conn -> fetchExists conn stmt params+{-# INLINE fetchExistsM #-}++-- | Execute a callback for each result row.+forEachM :: Statement p r -> p -> (r -> IO ()) -> Valiant ()+forEachM stmt params action = withConnectionM $ \conn -> forEach conn stmt params action+{-# INLINE forEachM #-}++------------------------------------------------------------------------+-- Commands+------------------------------------------------------------------------++-- | Execute a command. Returns rows affected.+executeM :: Statement p () -> p -> Valiant Int64+executeM stmt params = withConnectionM $ \conn -> execute conn stmt params+{-# INLINE executeM #-}++-- | Execute a command with a RETURNING clause. Returns rows affected and decoded rows.+executeReturningM :: Statement p r -> p -> Valiant (Int64, [r])+executeReturningM stmt params = withConnectionM $ \conn -> executeReturning conn stmt params+{-# INLINE executeReturningM #-}++-- | Execute a batch of commands (pipelined). Returns total rows affected.+executeBatchM :: Statement p () -> [p] -> Valiant Int64+executeBatchM stmt paramsList = withConnectionM $ \conn -> executeBatch conn stmt paramsList+{-# INLINE executeBatchM #-}++-- | Execute a statement once for each parameter set. Returns total rows affected.+-- Alias for 'executeBatchM' with a more common name.+executeManyM :: Statement p () -> [p] -> Valiant Int64+executeManyM stmt paramsList = withConnectionM $ \conn -> executeMany conn stmt paramsList+{-# INLINE executeManyM #-}++-- | Execute a batch with RETURNING. Returns total rows and all decoded rows.+executeReturningManyM :: Statement p r -> [p] -> Valiant (Int64, [r])+executeReturningManyM stmt paramsList = withConnectionM $ \conn -> executeReturningMany conn stmt paramsList+{-# INLINE executeReturningManyM #-}++------------------------------------------------------------------------+-- Pipelined batch reads+------------------------------------------------------------------------++-- | Fetch zero or one row for each parameter set, pipelined.+fetchBatchOneM :: Statement p r -> [p] -> Valiant [Maybe r]+fetchBatchOneM stmt paramsList = withConnectionM $ \conn -> fetchBatchOne conn stmt paramsList+{-# INLINE fetchBatchOneM #-}++-- | Fetch all rows for each parameter set, pipelined.+fetchBatchAllM :: Statement p r -> [p] -> Valiant [[r]]+fetchBatchAllM stmt paramsList = withConnectionM $ \conn -> fetchBatchAll conn stmt paramsList+{-# INLINE fetchBatchAllM #-}++------------------------------------------------------------------------+-- Transactions+------------------------------------------------------------------------++-- | Run an action inside a transaction (READ COMMITTED).+withTransactionM :: (Transaction -> IO a) -> Valiant a+withTransactionM f = do+  pool <- ask+  liftIO $ withTransaction pool f+{-# INLINE withTransactionM #-}++-- | Like 'withTransactionM' but discards the return value.+withTransaction_M :: (Transaction -> IO ()) -> Valiant ()+withTransaction_M f = do+  pool <- ask+  liftIO $ withTransaction_ pool f+{-# INLINE withTransaction_M #-}++-- | Run an action inside a transaction with the given isolation level.+withTransactionLevelM :: IsolationLevel -> (Transaction -> IO a) -> Valiant a+withTransactionLevelM level f = do+  pool <- ask+  liftIO $ withTransactionLevel level pool f+{-# INLINE withTransactionLevelM #-}++-- | Run an action inside a transaction with a full 'TransactionMode'.+withTransactionModeM :: TransactionMode -> (Transaction -> IO a) -> Valiant a+withTransactionModeM mode f = do+  pool <- ask+  liftIO $ withTransactionMode mode pool f+{-# INLINE withTransactionModeM #-}++-- | Run an action inside a READ ONLY transaction.+withReadOnlyTransactionM :: (Transaction -> IO a) -> Valiant a+withReadOnlyTransactionM f = do+  pool <- ask+  liftIO $ withReadOnlyTransaction pool f+{-# INLINE withReadOnlyTransactionM #-}++-- | Run an action inside a SERIALIZABLE READ ONLY DEFERRABLE transaction.+withDeferrableTransactionM :: (Transaction -> IO a) -> Valiant a+withDeferrableTransactionM f = do+  pool <- ask+  liftIO $ withDeferrableTransaction pool f+{-# INLINE withDeferrableTransactionM #-}++-- | Run a SERIALIZABLE transaction with automatic retry on serialization failure.+withTransactionRetryM :: Int -> (Transaction -> IO a) -> Valiant a+withTransactionRetryM maxRetries f = do+  pool <- ask+  liftIO $ withTransactionRetry maxRetries pool f+{-# INLINE withTransactionRetryM #-}++------------------------------------------------------------------------+-- Pool management+------------------------------------------------------------------------++-- | Get a snapshot of the pool's statistics.+poolStatsM :: Valiant PoolStats+poolStatsM = do+  pool <- ask+  liftIO $ poolStats pool+{-# INLINE poolStatsM #-}++-- | Resize the pool at runtime.+resizeM :: Int -> Valiant ()+resizeM newSize = do+  pool <- ask+  liftIO $ resize pool newSize+{-# INLINE resizeM #-}
+ src/Valiant/Mtl.hs view
@@ -0,0 +1,142 @@+-- | MTL-style adapter for valiant.+--+-- All operations work in any monad with @HasPool m@ (which is+-- @MonadReader env m@ where @env@ has a 'Pool') and @MonadIO m@.+-- This allows valiant to compose with arbitrary monad stacks.+--+-- @+-- data AppEnv = AppEnv { appPool :: Pool, appLogger :: Logger }+--+-- instance HasPool (ReaderT AppEnv IO) where+--   getPool = asks appPool+--+-- myApp :: (HasPool m, MonadIO m) => m [User]+-- myApp = do+--   users <- fetchAllMtl listUsers ()+--   count <- fetchScalarMtl countUsers ()+--   pure users+-- @+module Valiant.Mtl+  ( -- * Pool access+    HasPool (..)++    -- * Query operations+  , fetchOneMtl+  , fetchAllMtl+  , fetchScalarMtl+  , fetchOneOrThrowMtl+  , fetchExistsMtl+  , forEachMtl++    -- * Command operations+  , executeMtl+  , executeReturningMtl+  , executeBatchMtl++    -- * Transaction operations+  , withTransactionMtl+  , withTransactionLevelMtl++    -- * Pool management+  , poolStatsMtl+  , withConnectionMtl+  ) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Int (Int64)+import Valiant (Connection, IsolationLevel, Pool, PoolStats, Statement, Transaction)+import Valiant qualified+import PgWire.Pool (poolStats, withResource)++-- | Type class for monads that can provide a 'Pool'.+--+-- Implement this for your application monad:+--+-- @+-- instance HasPool (ReaderT Pool IO) where+--   getPool = ask+--+-- -- Or with a larger environment:+-- instance HasPool (ReaderT AppEnv IO) where+--   getPool = asks appPool+-- @+class Monad m => HasPool m where+  getPool :: m Pool++-- | Fetch zero or one row.+fetchOneMtl :: (HasPool m, MonadIO m) => Statement p r -> p -> m (Maybe r)+fetchOneMtl stmt params = do+  pool <- getPool+  liftIO $ withResource pool $ \conn -> Valiant.fetchOne conn stmt params++-- | Fetch all rows.+fetchAllMtl :: (HasPool m, MonadIO m) => Statement p r -> p -> m [r]+fetchAllMtl stmt params = do+  pool <- getPool+  liftIO $ withResource pool $ \conn -> Valiant.fetchAll conn stmt params++-- | Fetch exactly one scalar value.+fetchScalarMtl :: (HasPool m, MonadIO m) => Statement p r -> p -> m r+fetchScalarMtl stmt params = do+  pool <- getPool+  liftIO $ withResource pool $ \conn -> Valiant.fetchScalar conn stmt params++-- | Fetch one row, throwing if none returned.+fetchOneOrThrowMtl :: (HasPool m, MonadIO m) => Statement p r -> p -> m r+fetchOneOrThrowMtl stmt params = do+  pool <- getPool+  liftIO $ withResource pool $ \conn -> Valiant.fetchOneOrThrow conn stmt params++-- | Check if a query returns any rows.+fetchExistsMtl :: (HasPool m, MonadIO m) => Statement p r -> p -> m Bool+fetchExistsMtl stmt params = do+  pool <- getPool+  liftIO $ withResource pool $ \conn -> Valiant.fetchExists conn stmt params++-- | Execute a callback for each row (streaming, no intermediate list).+forEachMtl :: (HasPool m, MonadIO m) => Statement p r -> p -> (r -> IO ()) -> m ()+forEachMtl stmt params action = do+  pool <- getPool+  liftIO $ withResource pool $ \conn -> Valiant.forEach conn stmt params action++-- | Execute a command. Returns rows affected.+executeMtl :: (HasPool m, MonadIO m) => Statement p () -> p -> m Int64+executeMtl stmt params = do+  pool <- getPool+  liftIO $ withResource pool $ \conn -> Valiant.execute conn stmt params++-- | Execute with RETURNING.+executeReturningMtl :: (HasPool m, MonadIO m) => Statement p r -> p -> m (Int64, [r])+executeReturningMtl stmt params = do+  pool <- getPool+  liftIO $ withResource pool $ \conn -> Valiant.executeReturning conn stmt params++-- | Execute a batch (pipelined). Returns total rows affected.+executeBatchMtl :: (HasPool m, MonadIO m) => Statement p () -> [p] -> m Int64+executeBatchMtl stmt paramsList = do+  pool <- getPool+  liftIO $ withResource pool $ \conn -> Valiant.executeBatch conn stmt paramsList++-- | Run an action in a transaction.+withTransactionMtl :: (HasPool m, MonadIO m) => (Transaction -> IO a) -> m a+withTransactionMtl action = do+  pool <- getPool+  liftIO $ Valiant.withTransaction pool action++-- | Run an action in a transaction with a specific isolation level.+withTransactionLevelMtl :: (HasPool m, MonadIO m) => IsolationLevel -> (Transaction -> IO a) -> m a+withTransactionLevelMtl level action = do+  pool <- getPool+  liftIO $ Valiant.withTransactionLevel level pool action++-- | Get pool statistics.+poolStatsMtl :: (HasPool m, MonadIO m) => m PoolStats+poolStatsMtl = do+  pool <- getPool+  liftIO $ poolStats pool++-- | Run an action with a raw connection.+withConnectionMtl :: (HasPool m, MonadIO m) => (Connection -> IO a) -> m a+withConnectionMtl action = do+  pool <- getPool+  liftIO $ withResource pool action
+ test/Main.hs view
@@ -0,0 +1,101 @@+module Main where++import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BS8+import Data.Int (Int32)+import Data.Text (Text)+import Valiant (defaultPoolConfig, newPool, closePool)+import Valiant qualified+import Valiant.Monad (runValiant, fetchAllM, fetchOneM, executeM, fetchScalarM)+import Valiant.Mtl (HasPool (..), fetchAllMtl, fetchOneMtl, fetchScalarMtl, withTransactionMtl)+import PgWire.Pool.Config (PoolConfig (..))+import System.Environment (lookupEnv)+import Test.Hspec+import TestSupport++-- HasPool instance for ReaderT Pool IO+instance HasPool (ReaderT Valiant.Pool IO) where+  getPool = ask++main :: IO ()+main = hspec $ do+  describe "Valiant.Monad (ReaderT Pool IO)" $ do+    it "fetchAllM returns all rows" $ do+      withTestConnection $ \conn -> withSchema conn $ do+        insertTestUsers conn+        pool <- mkPool+        result <- runValiant pool $ fetchAllM stmtListAll ()+        closePool pool+        length result `shouldBe` 5++    it "fetchOneM returns Just for existing row" $ do+      withTestConnection $ \conn -> withSchema conn $ do+        insertTestUsers conn+        pool <- mkPool+        result <- runValiant pool $ fetchOneM stmtSelectOne 1+        closePool pool+        case result of+          Just (_, name, _) -> name `shouldBe` "Alice"+          Nothing -> expectationFailure "Expected a row"++    it "executeM returns rows affected" $ do+      withTestConnection $ \conn -> withSchema conn $ do+        insertTestUsers conn+        pool <- mkPool+        let stmtDel = Valiant.mkStatement "DELETE FROM users_mtl WHERE id = $1" [23] [] "<test>" :: Valiant.Statement Int32 ()+        n <- runValiant pool $ executeM stmtDel (1 :: Int32)+        closePool pool+        n `shouldBe` 1++    it "composes multiple operations" $ do+      withTestConnection $ \conn -> withSchema conn $ do+        insertTestUsers conn+        pool <- mkPool+        let stmtCount = Valiant.mkStatement "SELECT count(*)::int4 FROM users_mtl" [] ["count"] "<test>" :: Valiant.Statement () Int32+        (users, count) <- runValiant pool $ do+          us <- fetchAllM stmtListAll ()+          c <- fetchScalarM stmtCount ()+          pure (us, c)+        closePool pool+        length users `shouldBe` 5+        count `shouldBe` 5++  describe "Valiant.Mtl (HasPool)" $ do+    it "fetchAllMtl works with ReaderT Pool IO" $ do+      withTestConnection $ \conn -> withSchema conn $ do+        insertTestUsers conn+        pool <- mkPool+        result <- runReaderT (fetchAllMtl stmtListAll ()) pool+        closePool pool+        length result `shouldBe` 5++    it "fetchOneMtl returns Nothing for missing row" $ do+      withTestConnection $ \conn -> withSchema conn $ do+        pool <- mkPool+        result <- runReaderT (fetchOneMtl stmtSelectOne (-1)) pool+        closePool pool+        result `shouldBe` (Nothing :: Maybe (Int32, Text, Maybe Text))++    it "withTransactionMtl commits" $ do+      withTestConnection $ \conn -> withSchema conn $ do+        pool <- mkPool+        let stmtInsert = Valiant.mkStatement "INSERT INTO users_mtl (name, email) VALUES ($1, $2)" [25, 25] [] "<test>"+            stmtCount = Valiant.mkStatement "SELECT count(*)::int4 FROM users_mtl" [] ["count"] "<test>" :: Valiant.Statement () Int32+        _ <- runReaderT (withTransactionMtl $ \tx ->+          Valiant.execute (Valiant.txConn tx) stmtInsert ("MtlUser" :: Text, Just ("mtl@test.com" :: Text))) pool+        count <- runReaderT (fetchScalarMtl stmtCount ()) pool+        closePool pool+        count `shouldBe` 1++mkPool :: IO Valiant.Pool+mkPool = do+  url <- requireDatabaseUrl'+  newPool defaultPoolConfig { poolConnString = url, poolSize = 2, poolAcquireTimeout = 5 }++requireDatabaseUrl' :: IO ByteString+requireDatabaseUrl' = do+  mUrl <- lookupEnv "DATABASE_URL"+  case mUrl of+    Just url -> pure (BS8.pack url)+    Nothing -> error "DATABASE_URL is not set."
+ test/TestSupport.hs view
@@ -0,0 +1,63 @@+module TestSupport+  ( withTestConnection+  , withSchema+  , insertTestUsers+  , stmtListAll+  , stmtSelectOne+  ) where++import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BS8+import Data.Int (Int32)+import Data.Text (Text)+import Valiant+import System.Environment (lookupEnv)++requireDatabaseUrl :: IO ByteString+requireDatabaseUrl = do+  mUrl <- lookupEnv "DATABASE_URL"+  case mUrl of+    Just url -> pure (BS8.pack url)+    Nothing -> error "DATABASE_URL is not set."++withTestConnection :: (Connection -> IO a) -> IO a+withTestConnection action = do+  url <- requireDatabaseUrl+  conn <- connectString url+  result <- action conn+  close conn+  pure result++withSchema :: Connection -> IO a -> IO a+withSchema conn action = do+  _ <- simpleQuery conn "DROP TABLE IF EXISTS users_mtl CASCADE"+  _ <- simpleQuery conn+    "CREATE TABLE users_mtl (\+    \  id SERIAL PRIMARY KEY,\+    \  name TEXT NOT NULL,\+    \  email TEXT\+    \)"+  result <- action+  _ <- simpleQuery conn "DROP TABLE IF EXISTS users_mtl CASCADE"+  pure result++insertTestUsers :: Connection -> IO ()+insertTestUsers conn = do+  _ <- simpleQuery conn+    "INSERT INTO users_mtl (name, email) VALUES \+    \('Alice', 'alice@example.com'),\+    \('Bob', 'bob@example.com'),\+    \('Carol', NULL),\+    \('Dave', 'dave@example.com'),\+    \('Eve', 'eve@example.com')"+  pure ()++stmtListAll :: Statement () (Int32, Text)+stmtListAll = mkStatement+  "SELECT id, name FROM users_mtl ORDER BY id"+  [] ["id", "name"] "<test>"++stmtSelectOne :: Statement Int32 (Int32, Text, Maybe Text)+stmtSelectOne = mkStatement+  "SELECT id, name, email FROM users_mtl WHERE id = $1"+  [23] ["id", "name", "email"] "<test>"
+ valiant-mtl.cabal view
@@ -0,0 +1,92 @@+cabal-version:   3.0+name:            valiant-mtl+version:         0.1.0.0+synopsis:        MTL-style adapter for valiant+description:+  Provides valiant database operations as MTL-style functions that work in+  any monad with @MonadReader pool m@ and @MonadIO m@ constraints. Unlike+  the built-in @Valiant.Monad@ (which is @ReaderT Pool IO@), this adapter+  composes with arbitrary monad stacks.++  @+  import Valiant.Mtl++  myApp :: (HasPool m, MonadIO m) => m [User]+  myApp = do+    users <- fetchAllMtl listUsers ()+    pure users+  @+license:         BSD-3-Clause+license-file:    LICENSE+author:          Josh Burgess+maintainer:      joshburgess.webdev@gmail.com+category:        Database+homepage:        https://github.com/joshburgess/valiant+bug-reports:     https://github.com/joshburgess/valiant/issues+build-type:      Simple+extra-doc-files:+  README.md+  CHANGELOG.md+tested-with:     GHC ==9.10.3++source-repository head+  type:     git+  location: https://github.com/joshburgess/valiant+  subdir:   adapters/valiant-mtl++flag werror+  description: Enable -Werror for development builds.+  default:     False+  manual:      True++common warnings+  ghc-options: -Wall -Wcompat -Wno-unticked-promoted-constructors -funbox-strict-fields -fspecialise-aggressively+  if flag(werror)+    ghc-options: -Werror++library+  import:           warnings+  hs-source-dirs:   src+  default-language: GHC2021+  default-extensions:+    DerivingStrategies+    FlexibleContexts+    OverloadedStrings+    StrictData++  exposed-modules:+    Valiant.Monad+    Valiant.Mtl++  build-depends:+    , base            >=4.17 && <5+    , valiant         >=0.1  && <0.2+    , mtl             >=2.2  && <2.4+    , pg-wire         >=0.1  && <0.2+    , time            >=1.12 && <1.15+    , transformers    >=0.6  && <0.7+    , vector          >=0.12 && <0.14++test-suite valiant-mtl-test+  import:           warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          Main.hs+  default-language: GHC2021+  default-extensions:+    FlexibleInstances+    OverloadedStrings+  ghc-options: -Wno-orphans -rtsopts "-with-rtsopts=-K8K"++  other-modules:+    TestSupport++  build-depends:+    , base            >=4.17 && <5+    , bytestring      >=0.11 && <0.13+    , hspec           >=2.11 && <2.13+    , valiant+    , valiant-mtl+    , pg-wire+    , text            >=2.0  && <2.2+    , transformers    >=0.6  && <0.7