valiant-effectful (empty) → 0.1.0.0

raw patch · 7 files changed

+534/−0 lines, 7 filesdep +basedep +bytestringdep +effectful-core

Dependencies added: base, bytestring, effectful-core, hspec, pg-wire, text, valiant, valiant-effectful, vector

Files

CHANGELOG.md +15/−0
LICENSE +27/−0
README.md +43/−0
src/Valiant/Effectful.hs +198/−0
test/Main.hs +88/−0
test/TestSupport.hs +63/−0
valiant-effectful.cabal +100/−0

+ CHANGELOG.md view

@@ -0,0 +1,15 @@+# 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.+[Effectful](https://hackage.haskell.org/package/effectful) adapter for+[`valiant`](https://hackage.haskell.org/package/valiant). Provides a+dynamic `Valiant` effect with pool-based (`runValiant`) and custom+(`runValiantWith`) handlers, plus smart constructors covering query,+command, and transaction operations.++[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,43 @@+# valiant-effectful++[Effectful](https://hackage.haskell.org/package/effectful) adapter for+[`valiant`](https://hackage.haskell.org/package/valiant).++Provides a dynamic `Valiant` effect that any `Eff` action can request+via `Valiant :> es`, plus a pool-based handler.++## Quick start++```haskell+import Effectful+import Valiant (newPool, defaultPoolConfig, poolConnString)+import Valiant.Effectful++myApp :: (Valiant :> es, IOE :> es) => Eff es [User]+myApp = do+  users <- fetchAllEff listUsers ()+  count <- fetchScalarEff countUsers ()+  liftIO $ putStrLn $ "got " <> show count <> " users"+  pure users++main :: IO ()+main = do+  pool <- newPool defaultPoolConfig { poolConnString = "postgres://..." }+  users <- runEff . runValiant pool $ myApp+  print users+```++## What you get++- Effect: `data Valiant :: Effect`+- Handlers: `runValiant pool` and `runValiantWith` (custom handler,+  useful for tests)+- Query operations: `fetchOneEff`, `fetchAllEff`, `fetchScalarEff`,+  `fetchOneOrThrowEff`, `fetchExistsEff`+- Command operations: `executeEff`, `executeReturningEff`,+  `executeBatchEff`+- Transactions: `withTransactionEff`, `withTransactionLevelEff`+- Raw access: `withConnectionEff`++See the [valiant tutorial](https://github.com/joshburgess/valiant/blob/main/docs/TUTORIAL.md)+for the underlying `Statement` and `valiant prepare` workflow.

+ src/Valiant/Effectful.hs view

@@ -0,0 +1,198 @@+-- | Effectful adapter for valiant.+--+-- Provides an @Valiant@ effect for database operations, with a pool-based+-- handler that manages connection acquisition and release automatically.+--+-- @+-- import Effectful+-- import Valiant.Effectful+--+-- myApp :: (Valiant :> es, IOE :> es) => Eff es [User]+-- myApp = do+--   users <- fetchAllEff listUsers ()+--   count <- fetchScalarEff countUsers ()+--   pure users+--+-- main :: IO ()+-- main = do+--   pool <- newPool defaultPoolConfig { poolConnString = "..." }+--   result <- runEff . runValiant pool $ myApp+--   print result+-- @+module Valiant.Effectful+  ( -- * Effect+    Valiant (..)++    -- * Handler+  , runValiant+  , runValiantWith++    -- * Query operations+  , fetchOneEff+  , fetchAllEff+  , fetchScalarEff+  , fetchOneOrThrowEff+  , fetchExistsEff++    -- * Command operations+  , executeEff+  , executeReturningEff+  , executeBatchEff++    -- * Transaction operations+  , withTransactionEff+  , withTransactionLevelEff++    -- * Raw access+  , withConnectionEff+  ) where++import Data.Int (Int64)+import Effectful+import Effectful.Dispatch.Dynamic+import Valiant (Connection, IsolationLevel, Pool, Statement, Transaction (..))+import Valiant qualified+import PgWire.Pool (withResource)++------------------------------------------------------------------------+-- Effect definition+------------------------------------------------------------------------++-- | The Valiant database effect.+--+-- All operations acquire a connection from the pool, execute, and release.+-- Transactions hold a connection for the duration of the callback.+data Valiant :: Effect where+  FetchOneEff :: Statement p r -> p -> Valiant m (Maybe r)+  FetchAllEff :: Statement p r -> p -> Valiant m [r]+  FetchScalarEff :: Statement p r -> p -> Valiant m r+  FetchOneOrThrowEff :: Statement p r -> p -> Valiant m r+  FetchExistsEff :: Statement p r -> p -> Valiant m Bool+  ExecuteEff :: Statement p () -> p -> Valiant m Int64+  ExecuteReturningEff :: Statement p r -> p -> Valiant m (Int64, [r])+  ExecuteBatchEff :: Statement p () -> [p] -> Valiant m Int64+  WithTransactionEff :: (Transaction -> IO a) -> Valiant m a+  WithTransactionLevelEff :: IsolationLevel -> (Transaction -> IO a) -> Valiant m a+  WithConnectionEff :: (Connection -> IO a) -> Valiant m a++type instance DispatchOf Valiant = 'Dynamic++------------------------------------------------------------------------+-- Handler+------------------------------------------------------------------------++-- | Run the Valiant effect with a connection pool.+--+-- @+-- main = do+--   pool <- newPool defaultPoolConfig { poolConnString = "..." }+--   runEff . runValiant pool $ do+--     users <- fetchAllEff listUsers ()+--     liftIO $ print users+-- @+runValiant :: (IOE :> es) => Pool -> Eff (Valiant : es) a -> Eff es a+runValiant pool = interpret $ \_ -> \case+  FetchOneEff stmt params ->+    liftIO $ withResource pool $ \conn -> Valiant.fetchOne conn stmt params+  FetchAllEff stmt params ->+    liftIO $ withResource pool $ \conn -> Valiant.fetchAll conn stmt params+  FetchScalarEff stmt params ->+    liftIO $ withResource pool $ \conn -> Valiant.fetchScalar conn stmt params+  FetchOneOrThrowEff stmt params ->+    liftIO $ withResource pool $ \conn -> Valiant.fetchOneOrThrow conn stmt params+  FetchExistsEff stmt params ->+    liftIO $ withResource pool $ \conn -> Valiant.fetchExists conn stmt params+  ExecuteEff stmt params ->+    liftIO $ withResource pool $ \conn -> Valiant.execute conn stmt params+  ExecuteReturningEff stmt params ->+    liftIO $ withResource pool $ \conn -> Valiant.executeReturning conn stmt params+  ExecuteBatchEff stmt paramsList ->+    liftIO $ withResource pool $ \conn -> Valiant.executeBatch conn stmt paramsList+  WithTransactionEff action ->+    liftIO $ Valiant.withTransaction pool action+  WithTransactionLevelEff level action ->+    liftIO $ Valiant.withTransactionLevel level pool action+  WithConnectionEff action ->+    liftIO $ withResource pool action++-- | Run the Valiant effect with a custom handler function.+-- Useful for testing with mock connections.+runValiantWith+  :: (IOE :> es)+  => (forall x. (Connection -> IO x) -> IO x)+  -- ^ Connection provider (e.g., 'withResource pool' or a mock)+  -> (forall x. (Transaction -> IO x) -> IO x)+  -- ^ Transaction provider+  -> Eff (Valiant : es) a+  -> Eff es a+runValiantWith withConn withTxn = interpret $ \_ -> \case+  FetchOneEff stmt params ->+    liftIO $ withConn $ \conn -> Valiant.fetchOne conn stmt params+  FetchAllEff stmt params ->+    liftIO $ withConn $ \conn -> Valiant.fetchAll conn stmt params+  FetchScalarEff stmt params ->+    liftIO $ withConn $ \conn -> Valiant.fetchScalar conn stmt params+  FetchOneOrThrowEff stmt params ->+    liftIO $ withConn $ \conn -> Valiant.fetchOneOrThrow conn stmt params+  FetchExistsEff stmt params ->+    liftIO $ withConn $ \conn -> Valiant.fetchExists conn stmt params+  ExecuteEff stmt params ->+    liftIO $ withConn $ \conn -> Valiant.execute conn stmt params+  ExecuteReturningEff stmt params ->+    liftIO $ withConn $ \conn -> Valiant.executeReturning conn stmt params+  ExecuteBatchEff stmt paramsList ->+    liftIO $ withConn $ \conn -> Valiant.executeBatch conn stmt paramsList+  WithTransactionEff action ->+    liftIO $ withTxn action+  WithTransactionLevelEff _level action ->+    liftIO $ withTxn action  -- level ignored in custom handler+  WithConnectionEff action ->+    liftIO $ withConn action++------------------------------------------------------------------------+-- Smart constructors+------------------------------------------------------------------------++-- | Fetch zero or one row.+fetchOneEff :: (Valiant :> es) => Statement p r -> p -> Eff es (Maybe r)+fetchOneEff stmt params = send (FetchOneEff stmt params)++-- | Fetch all rows.+fetchAllEff :: (Valiant :> es) => Statement p r -> p -> Eff es [r]+fetchAllEff stmt params = send (FetchAllEff stmt params)++-- | Fetch exactly one scalar value. Throws on zero or multiple rows.+fetchScalarEff :: (Valiant :> es) => Statement p r -> p -> Eff es r+fetchScalarEff stmt params = send (FetchScalarEff stmt params)++-- | Fetch one row, throwing if none returned.+fetchOneOrThrowEff :: (Valiant :> es) => Statement p r -> p -> Eff es r+fetchOneOrThrowEff stmt params = send (FetchOneOrThrowEff stmt params)++-- | Check if a query returns any rows.+fetchExistsEff :: (Valiant :> es) => Statement p r -> p -> Eff es Bool+fetchExistsEff stmt params = send (FetchExistsEff stmt params)++-- | Execute a command. Returns rows affected.+executeEff :: (Valiant :> es) => Statement p () -> p -> Eff es Int64+executeEff stmt params = send (ExecuteEff stmt params)++-- | Execute with RETURNING. Returns rows affected and decoded rows.+executeReturningEff :: (Valiant :> es) => Statement p r -> p -> Eff es (Int64, [r])+executeReturningEff stmt params = send (ExecuteReturningEff stmt params)++-- | Execute a batch of commands (pipelined). Returns total rows affected.+executeBatchEff :: (Valiant :> es) => Statement p () -> [p] -> Eff es Int64+executeBatchEff stmt paramsList = send (ExecuteBatchEff stmt paramsList)++-- | Run an action in a transaction.+withTransactionEff :: (Valiant :> es) => (Transaction -> IO a) -> Eff es a+withTransactionEff action = send (WithTransactionEff action)++-- | Run an action in a transaction with a specific isolation level.+withTransactionLevelEff :: (Valiant :> es) => IsolationLevel -> (Transaction -> IO a) -> Eff es a+withTransactionLevelEff level action = send (WithTransactionLevelEff level action)++-- | Run an action with a raw connection from the pool.+withConnectionEff :: (Valiant :> es) => (Connection -> IO a) -> Eff es a+withConnectionEff action = send (WithConnectionEff action)

+ test/Main.hs view

@@ -0,0 +1,88 @@+module Main where++import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BS8+import Data.Int (Int32)+import Data.Text (Text)+import Effectful+import Valiant (defaultPoolConfig, newPool, closePool, txConn)+import Valiant qualified+import Valiant.Effectful+import PgWire.Pool.Config (PoolConfig (..))+import System.Environment (lookupEnv)+import Test.Hspec+import TestSupport++main :: IO ()+main = hspec $ do+  describe "Valiant.Effectful" $ do+    describe "runValiant" $ do+      it "fetchAllEff returns all rows" $ do+        withTestConnection $ \conn -> withSchema conn $ do+          insertTestUsers conn+          pool <- mkPool+          result <- runEff . runValiant pool $ fetchAllEff stmtListAll ()+          closePool pool+          length result `shouldBe` 5++      it "fetchOneEff returns Just for existing row" $ do+        withTestConnection $ \conn -> withSchema conn $ do+          insertTestUsers conn+          pool <- mkPool+          result <- runEff . runValiant pool $ fetchOneEff stmtSelectOne 1+          closePool pool+          case result of+            Just (_, name, _) -> name `shouldBe` "Alice"+            Nothing -> expectationFailure "Expected a row"++      it "fetchOneEff returns Nothing for missing row" $ do+        withTestConnection $ \conn -> withSchema conn $ do+          pool <- mkPool+          result <- runEff . runValiant pool $ fetchOneEff stmtSelectOne (-1)+          closePool pool+          result `shouldBe` (Nothing :: Maybe (Int32, Text, Maybe Text))++      it "executeEff returns rows affected" $ do+        withTestConnection $ \conn -> withSchema conn $ do+          insertTestUsers conn+          pool <- mkPool+          let stmtDelete = Valiant.mkStatement "DELETE FROM users_effectful WHERE id = $1" [23] [] "<test>" :: Valiant.Statement Int32 ()+          n <- runEff . runValiant pool $ executeEff stmtDelete (1 :: Int32)+          closePool pool+          n `shouldBe` 1++      it "withTransactionEff commits" $ do+        withTestConnection $ \conn -> withSchema conn $ do+          pool <- mkPool+          let stmtInsert = Valiant.mkStatement "INSERT INTO users_effectful (name, email) VALUES ($1, $2)" [25, 25] [] "<test>"+              stmtCount = Valiant.mkStatement "SELECT count(*)::int4 FROM users_effectful" [] ["count"] "<test>" :: Valiant.Statement () Int32+          _ <- runEff . runValiant pool $+            withTransactionEff $ \tx ->+              Valiant.execute (txConn tx) stmtInsert ("EffUser" :: Text, Just ("eff@test.com" :: Text))+          count <- runEff . runValiant pool $ fetchScalarEff stmtCount ()+          closePool pool+          count `shouldBe` 1++      it "composes multiple operations" $ do+        withTestConnection $ \conn -> withSchema conn $ do+          insertTestUsers conn+          pool <- mkPool+          (users, exists) <- runEff . runValiant pool $ do+            us <- fetchAllEff stmtListAll ()+            ex <- fetchExistsEff stmtSelectOne 1+            pure (us, ex)+          closePool pool+          length users `shouldBe` 5+          exists `shouldBe` True++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_effectful CASCADE"+  _ <- simpleQuery conn+    "CREATE TABLE users_effectful (\+    \  id SERIAL PRIMARY KEY,\+    \  name TEXT NOT NULL,\+    \  email TEXT\+    \)"+  result <- action+  _ <- simpleQuery conn "DROP TABLE IF EXISTS users_effectful CASCADE"+  pure result++insertTestUsers :: Connection -> IO ()+insertTestUsers conn = do+  _ <- simpleQuery conn+    "INSERT INTO users_effectful (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_effectful ORDER BY id"+  [] ["id", "name"] "<test>"++stmtSelectOne :: Statement Int32 (Int32, Text, Maybe Text)+stmtSelectOne = mkStatement+  "SELECT id, name, email FROM users_effectful WHERE id = $1"+  [23] ["id", "name", "email"] "<test>"

+ valiant-effectful.cabal view

@@ -0,0 +1,100 @@+cabal-version:   3.0+name:            valiant-effectful+version:         0.1.0.0+synopsis:        Effectful adapter for valiant+description:+  Provides an @Valiant@ effect for the @effectful@ effect system, enabling+  compile-time checked SQL queries as an effect with pool-based handlers.++  @+  import Valiant.Effectful++  myApp :: (Valiant :> es, IOE :> es) => Eff es [User]+  myApp = do+    users <- fetchAllEff listUsers ()+    forM_ users $ \\u -> executeEff updateLastSeen (userId u)+    pure users++  main :: IO ()+  main = do+    pool <- newPool defaultPoolConfig { poolConnString = "..." }+    runEff . runValiant pool $ myApp+  @+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-effectful++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:+    DataKinds+    DerivingStrategies+    GADTs+    LambdaCase+    OverloadedStrings+    StrictData+    TypeFamilies+    TypeOperators++  exposed-modules:+    Valiant.Effectful++  build-depends:+    , base            >=4.17 && <5+    , effectful-core  >=2.3  && <2.6+    , valiant         >=0.1  && <0.2+    , pg-wire         >=0.1  && <0.2+    , vector          >=0.12 && <0.14++test-suite valiant-effectful-test+  import:           warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          Main.hs+  default-language: GHC2021+  default-extensions:+    DataKinds+    GADTs+    OverloadedStrings+    TypeOperators++  ghc-options: -rtsopts "-with-rtsopts=-K8K"++  build-depends:+    , base            >=4.17 && <5+    , bytestring      >=0.11 && <0.13+    , effectful-core   >=2.3  && <2.6+    , hspec           >=2.11 && <2.13+    , valiant+    , valiant-effectful+    , pg-wire+    , text            >=2.0  && <2.2++  other-modules:+    TestSupport