sqlite-simple-effectful (empty) → 0.1.0.0

raw patch · 9 files changed

+1663/−0 lines, 9 filesdep +basedep +effectfuldep +effectful-coresetup-changed

Dependencies added: base, effectful, effectful-core, sqlite-simple, text, unliftio-pool

Files

CHANGELOG.md +11/−0
LICENSE +26/−0
README.md +139/−0
Setup.hs +2/−0
sqlite-simple-effectful.cabal +69/−0
src/Effectful/SQLite/Simple.hs +315/−0
src/Effectful/SQLite/Simple/Labeled.hs +330/−0
src/Effectful/SQLite/Simple/RW.hs +411/−0
src/Effectful/SQLite/Simple/RW/Labeled.hs +360/−0

+ CHANGELOG.md view

@@ -0,0 +1,11 @@+# Changelog for `sqlite-simple-effectful`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD

+ LICENSE view

@@ -0,0 +1,26 @@+Copyright 2026 Diogo Castro++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,139 @@+<!--+    DO NOT EDIT THIS FILE.++    This file was generated from `docs/src/Readme.lhs`.+    Edit that file, and then run `just pandoc`.+-->++# sqlite-simple-effectful++Adaptation of the+[sqlite-simple](https://hackage.haskell.org/package/sqlite-simple)+library for the+[effectful](https://hackage.haskell.org/package/effectful) ecosystem.++## Getting started++This package provides a dynamic `SQLite` effect that can be used to run+SQLite queries in an effectful context.++Use `useConnection` to obtain a connection to the database and run+queries.++``` haskell+import Effectful.SQLite.Simple (SQLite)+import Effectful.SQLite.Simple qualified as SQL++import Effectful+import Effectful.Concurrent (runConcurrent)+import Data.Function ((&))+import Control.Concurrent.MVar qualified as MVar++app :: (SQLite :> es) => Eff es [User]+app = do+  SQL.useConnection \conn -> do+    SQL.query_ conn "SELECT * FROM users"+```++The effect can be interpreted with `runSQLiteUnsync`, suitable for+single-threaded applications, or `runSQLiteSync`, which is safe to use+in multi-threaded applications.++``` haskell+main :: IO [User]+main =+  SQL.withConnection "users.db" \conn -> do+    connVar <- MVar.newMVar conn+    app+      & SQL.runSQLiteSync connVar+      & runConcurrent+      & runEff+```++## Pooled connections++The module+[`Effectful.SQLite.Simple.RW`](https://hackage.haskell.org/package/sqlite-simple-effectful/docs/Effectful-SQLite-Simple-RW.html)+provides an interpreter backed by connection pools.++SQLite allows multiple connections to read/write concurrently, but+concurrent writes will lead to [contention, performance degradation, and+SQLITE_BUSY+errors](https://emschwartz.me/psa-your-sqlite-connection-pool-might-be-ruining-your-write-performance/).+We avoid this by:++- Having separate pools for reading and writing.+- Configuring the write pool to have a maximum of 1 connection, thus+  serializing all writes.++We additionally set the database's journal mode to+[WAL](https://sqlite.org/wal.html), so that readers will not block the+writer and the writer will not block readers.++Note that even in WAL mode, [SQLITE_BUSY errors can still+occur](https://sqlite.org/wal.html#sometimes_queries_return_sqlite_busy_in_wal_mode).++The `useReadConnection` and `useWriteConnection` operations retrieve a+pooled connection from the context that can be used to run "read" or+"write" operations.++``` haskell+import Effectful.SQLite.Simple.RW (SQLite)+import Effectful.SQLite.Simple.RW qualified as SQL++import Effectful+import Effectful.Concurrent.Async (runConcurrent, concurrently)+import Effectful.Fail (Fail, runFail)+import Control.Monad (void)+import Data.Function ((&))++reader :: (SQLite :> es) => Eff es [User]+reader = do+  SQL.useReadConnection \conn -> do+    SQL.query_ conn "SELECT * FROM users"++writer :: (SQLite :> es, Fail :> es) => Eff es ()+writer = do+  SQL.useWriteConnection \conn -> do+    SQL.withImmediateTransaction conn do+      [userId :: SQL.Only UserId] <- SQL.query conn "SELECT id FROM users WHERE username = ?" (SQL.Only @Text "dcastro")+      SQL.execute conn "DELETE FROM articles WHERE author_id = ?" userId+```++``` haskell+main :: IO (Either String ())+main = do+  let dbPath = "users.db"+  pools <-+    SQL.newPools+      =<< SQL.newPoolsConfig+        (SQL.open dbPath) -- Action to create a new read connection.+        60                -- Read connections' idle timeout in seconds.+        32                -- Max number of read connections.+        (SQL.open dbPath) -- Action to create a new write connection.+        60                -- Write connections' idle timeout in seconds.++  let app = void $ concurrently (void reader) writer++  app+    & SQL.runSQLiteWithPools pools+    & runConcurrent+    & runFail+    & runEff+```++## Using multiple connections++The package also provides ["labeled+effects"](https://hackage-content.haskell.org/package/effectful-core/docs/Effectful-Labeled.html)+for handling connections to multiple databases in the same application.++See:++- [`Effectful.SQLite.Simple.Labeled`](https://hackage.haskell.org/package/sqlite-simple-effectful/docs/Effectful-SQLite-Simple-Labeled.html)+- [`Effectful.SQLite.Simple.RW.Labeled`](https://hackage.haskell.org/package/sqlite-simple-effectful/docs/Effectful-SQLite-Simple-RW-Labeled.html)++## Credits++The API was inspired by+[effectful-postgresql](https://hackage.haskell.org/package/effectful-postgresql).

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ sqlite-simple-effectful.cabal view

@@ -0,0 +1,69 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.39.1.+--+-- see: https://github.com/sol/hpack++name:           sqlite-simple-effectful+version:        0.1.0.0+synopsis:       Adaptation of the sqlite-simple library for the effectful ecosystem.+description:    Adaptation of the @<https://hackage.haskell.org/package/sqlite-simple sqlite-simple>@ library for the @<https://hackage.haskell.org/package/effectful effectful>@ ecosystem.+category:       Database+homepage:       https://github.com/dcastro/sqlite-simple-effectful#readme+bug-reports:    https://github.com/dcastro/sqlite-simple-effectful/issues+author:         Diogo Castro+maintainer:     dc@diogocastro.com+copyright:      2026 Diogo Castro+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+tested-with:+    GHC == 9.6.7 , GHC == 9.8.4 , GHC == 9.10.3 , GHC == 9.12.4 , GHC == 9.14.1+extra-source-files:+    README.md+extra-doc-files:+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/dcastro/sqlite-simple-effectful++library+  exposed-modules:+      Effectful.SQLite.Simple+      Effectful.SQLite.Simple.Labeled+      Effectful.SQLite.Simple.RW+      Effectful.SQLite.Simple.RW.Labeled+  other-modules:+      Paths_sqlite_simple_effectful+  autogen-modules:+      Paths_sqlite_simple_effectful+  hs-source-dirs:+      src+  default-extensions:+      BlockArguments+      StrictData+      TypeFamilies+      ImportQualifiedPost+      RankNTypes+      LambdaCase+      TypeOperators+      DataKinds+      NamedFieldPuns+      TypeApplications+      GADTs+      FlexibleContexts+      PolyKinds+      ScopedTypeVariables+      NumericUnderscores+  ghc-options: -Weverything -Wno-name-shadowing -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-export-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-missing-kind-signatures+  build-depends:+      base <5+    , effectful >=2.4.0.0+    , effectful-core >=2.4.0.0+    , sqlite-simple >=0.4.19.0+    , text >=1.2.5.0+    , unliftio-pool >=0.4.2.0+  default-language: Haskell2010+  if impl(ghc >= 9.8.1)+    ghc-options: -Wno-missing-role-annotations

+ src/Effectful/SQLite/Simple.hs view

@@ -0,0 +1,315 @@+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++{- ORMOLU_DISABLE -}+{- | A dynamic effect that lets us use a SQLite `Connection`, without specifying __how__ that connection is supplied.++Supported interpreters:++  * 'runSQLiteUnsync' - Runs a single-threaded action with a single connection.+  * 'runSQLiteSync' - Runs an action with a single connection shared across multiple threads.++To connect to multiple databases, see "Effectful.SQLite.Simple.Labeled".++>>> import Effectful+>>> import Effectful.Concurrent (runConcurrent)+>>> import Effectful.SQLite.Simple (SQLite)+>>> import Effectful.SQLite.Simple qualified as SQL+>>> import Control.Concurrent.MVar qualified as MVar++>>> :{+app :: (SQLite :> es) => Eff es [User]+app = do+  SQL.useConnection \conn -> do+    SQL.query_ conn "SELECT * FROM users"+:}++>>> :{+main :: IO [User]+main =+  SQL.withConnection "users.db" \conn -> do+    connVar <- MVar.newMVar conn+    app+      & SQL.runSQLiteSync connVar+      & runConcurrent+      & runEff+:}++-}+{- ORMOLU_ENABLE -}+module Effectful.SQLite.Simple+  ( -- * Effects+    SQLite (..),+    useConnection,++    -- * Interpreters+    runSQLiteUnsync,+    runSQLiteSync,++    -- * Connections+    S.open,+    S.close,+    S.withConnection,+    S.setTrace,++    -- * Queries that return results+    query,+    query_,+    queryWith,+    queryWith_,+    queryNamed,+    lastInsertRowId,+    changes,+    totalChanges,++    -- * Queries that stream results+    fold,+    fold_,+    foldNamed,++    -- * Statements that do not return results+    execute,+    execute_,+    executeMany,+    executeNamed,+    S.field,++    -- * Transactions+    withTransaction,+    withImmediateTransaction,+    withExclusiveTransaction,+    withSavepoint,++    -- * Low-level statement API for stream access and prepared statements+    openStatement,+    closeStatement,+    withStatement,+    bind,+    bindNamed,+    reset,+    columnName,+    columnCount,+    withBind,+    nextRow,++    -- ** Exceptions+    S.FormatError (..),+    S.ResultError (..),+    S.SQLError (..),+    S.Error (..),++    -- * Types+    S.Query (..),+    S.Connection (..),+    S.ToRow (..),+    S.FromRow (..),+    S.Only (..),+    (S.:.) (..),+    S.SQLData (..),+    S.Statement (..),+    S.ColumnIndex (..),+    S.NamedParam (..),+  )+where++import Data.Int (Int64)+import Data.Text (Text)+import Database.SQLite.Simple (ColumnIndex, Connection, FromRow, NamedParam, Query, Statement, ToRow)+import Database.SQLite.Simple qualified as S+import Database.SQLite.Simple.FromRow (RowParser)+import Effectful+import Effectful.Concurrent (Concurrent)+import Effectful.Concurrent.MVar (MVar)+import Effectful.Concurrent.MVar qualified as MVar+import Effectful.Dispatch.Dynamic (interpret, localSeqUnlift, send)+import Effectful.Dispatch.Static (seqUnliftIO, unsafeEff, unsafeEff_)+import GHC.Stack (HasCallStack)++-- $setup+-- Clear all imports before running doctests+-- >>> :m+-- >>> :set -XOverloadedStrings+-- >>> import Data.Function ((&))+-- >>> import Effectful.SQLite.Simple (FromRow(fromRow))+-- >>> data User+-- >>> instance FromRow User where fromRow = undefined++----------------------------------------------------------------------------+-- Effect+----------------------------------------------------------------------------++data SQLite :: Effect where+  UseConnection :: (Connection -> m a) -> SQLite m a++type instance DispatchOf SQLite = 'Dynamic++-- | Retrieve the connection from the context and run the given action with it.+--+-- __WARNING__:+--+-- * The connection must not escape the scope of `useConnection`.+-- * `useConnection` calls must not be nested.+-- * When used together with other locking primitives, the locks must always be acquired in the same order to avoid deadlocks.+useConnection :: (HasCallStack, SQLite :> es) => (Connection -> Eff es a) -> Eff es a+useConnection = send . UseConnection++----------------------------------------------------------------------------+-- Interpreters+----------------------------------------------------------------------------++-- | Runs a single-threaded action with a single connection.+runSQLiteUnsync ::+  (HasCallStack, IOE :> es) =>+  Connection -> Eff (SQLite ': es) a -> Eff es a+runSQLiteUnsync conn =+  interpret \env -> \case+    UseConnection f ->+      localSeqUnlift env \unlift -> unlift $ f conn++-- | Runs an action with a single connection shared across multiple threads.+--+-- __WARNING__: Since this interpreter is backed by an `MVar`, the usual caveats apply:+--+-- * The connection must not escape the scope of `useConnection`.+-- * `useConnection` calls must not be nested.+-- * When used together with other locking primitives, the locks must always be acquired in the same order to avoid deadlocks.+runSQLiteSync ::+  (HasCallStack, IOE :> es, Concurrent :> es) =>+  MVar Connection -> Eff (SQLite ': es) a -> Eff es a+runSQLiteSync connVar = do+  interpret \env -> \case+    UseConnection f ->+      localSeqUnlift env \unlift -> do+        MVar.withMVar connVar \conn -> do+          unlift $ f conn++----------------------------------------------------------------------------+-- Operations+----------------------------------------------------------------------------++{-+Notes:+  * We're using `unsafeEff_` to avoid having `IOE` show up in every type sig.+    This is fine, _as long as_:+      * we ensure all the `run*` functions require `IOE`.+      * All operations must have the `SQLite :> es` constraint (even if GHC considers it redundant),+        to ensure they cannot be run with `runPureEff` and bypass the `IOE` requirement.++-}++query :: forall q r es. (SQLite :> es) => (ToRow q, FromRow r) => Connection -> Query -> q -> Eff es [r]+query conn q params = unsafeEff_ $ S.query conn q params++query_ :: forall r es. (SQLite :> es) => (FromRow r) => Connection -> Query -> Eff es [r]+query_ conn q = unsafeEff_ $ S.query_ conn q++queryWith :: forall q r es. (SQLite :> es) => (ToRow q) => RowParser r -> Connection -> Query -> q -> Eff es [r]+queryWith parser conn q params = unsafeEff_ $ S.queryWith parser conn q params++queryWith_ :: forall r es. (SQLite :> es) => RowParser r -> Connection -> Query -> Eff es [r]+queryWith_ parser conn q = unsafeEff_ $ S.queryWith_ parser conn q++queryNamed :: forall r es. (SQLite :> es) => (FromRow r) => Connection -> Query -> [NamedParam] -> Eff es [r]+queryNamed conn q params = unsafeEff_ $ S.queryNamed conn q params++lastInsertRowId :: forall es. (SQLite :> es) => Connection -> Eff es Int64+lastInsertRowId = unsafeEff_ . S.lastInsertRowId++changes :: forall es. (SQLite :> es) => Connection -> Eff es Int+changes = unsafeEff_ . S.changes++totalChanges :: forall es. (SQLite :> es) => Connection -> Eff es Int+totalChanges = unsafeEff_ . S.totalChanges++fold :: forall row params a es. (SQLite :> es) => (FromRow row, ToRow params) => Connection -> Query -> params -> a -> (a -> row -> Eff es a) -> Eff es a+fold conn q params initialState action =+  unsafeEffWithUnlift \unlift -> do+    S.fold conn q params initialState \a row ->+      unlift $ action a row++fold_ :: forall row a es. (SQLite :> es) => (FromRow row) => Connection -> Query -> a -> (a -> row -> Eff es a) -> Eff es a+fold_ conn q initialState action =+  unsafeEffWithUnlift \unlift -> do+    S.fold_ conn q initialState \a row ->+      unlift $ action a row++foldNamed :: forall row a es. (SQLite :> es) => (FromRow row) => Connection -> Query -> [NamedParam] -> a -> (a -> row -> Eff es a) -> Eff es a+foldNamed conn q params initialState action =+  unsafeEffWithUnlift \unlift -> do+    S.foldNamed conn q params initialState \a row ->+      unlift $ action a row++execute :: forall q es. (SQLite :> es) => (ToRow q) => Connection -> Query -> q -> Eff es ()+execute conn q params = unsafeEff_ $ S.execute conn q params++execute_ :: forall es. (SQLite :> es) => Connection -> Query -> Eff es ()+execute_ conn q = unsafeEff_ $ S.execute_ conn q++executeMany :: forall q es. (SQLite :> es) => (ToRow q) => Connection -> Query -> [q] -> Eff es ()+executeMany conn q params = unsafeEff_ $ S.executeMany conn q params++executeNamed :: forall es. (SQLite :> es) => Connection -> Query -> [NamedParam] -> Eff es ()+executeNamed conn q params = unsafeEff_ $ S.executeNamed conn q params++withTransaction :: forall a es. (SQLite :> es) => Connection -> Eff es a -> Eff es a+withTransaction conn action =+  unsafeEffWithUnlift \unlift -> do+    S.withTransaction conn $ unlift action++withImmediateTransaction :: forall a es. (SQLite :> es) => Connection -> Eff es a -> Eff es a+withImmediateTransaction conn action =+  unsafeEffWithUnlift \unlift -> do+    S.withImmediateTransaction conn $ unlift action++withExclusiveTransaction :: forall a es. (SQLite :> es) => Connection -> Eff es a -> Eff es a+withExclusiveTransaction conn action =+  unsafeEffWithUnlift \unlift -> do+    S.withExclusiveTransaction conn $ unlift action++withSavepoint :: forall a es. (SQLite :> es) => Connection -> Eff es a -> Eff es a+withSavepoint conn action =+  unsafeEffWithUnlift \unlift -> do+    S.withSavepoint conn $ unlift action++openStatement :: forall es. (SQLite :> es) => Connection -> Query -> Eff es Statement+openStatement conn q = unsafeEff_ $ S.openStatement conn q++closeStatement :: forall es. (SQLite :> es) => Statement -> Eff es ()+closeStatement stmt = unsafeEff_ $ S.closeStatement stmt++withStatement :: forall a es. (SQLite :> es) => Connection -> Query -> (Statement -> Eff es a) -> Eff es a+withStatement conn q action =+  unsafeEffWithUnlift \unlift -> do+    S.withStatement conn q (unlift . action)++bind :: forall params es. (SQLite :> es) => (ToRow params) => Statement -> params -> Eff es ()+bind stmt params = unsafeEff_ $ S.bind stmt params++bindNamed :: forall es. (SQLite :> es) => Statement -> [NamedParam] -> Eff es ()+bindNamed stmt params = unsafeEff_ $ S.bindNamed stmt params++reset :: forall es. (SQLite :> es) => Statement -> Eff es ()+reset stmt = unsafeEff_ $ S.reset stmt++columnName :: forall es. (SQLite :> es) => Statement -> ColumnIndex -> Eff es Text+columnName stmt idx = unsafeEff_ $ S.columnName stmt idx++columnCount :: forall es. (SQLite :> es) => Statement -> Eff es ColumnIndex+columnCount stmt = unsafeEff_ $ S.columnCount stmt++withBind :: forall params a es. (SQLite :> es) => (ToRow params) => Statement -> params -> Eff es a -> Eff es a+withBind stmt params action =+  unsafeEffWithUnlift \unlift -> do+    S.withBind stmt params $ unlift action++nextRow :: forall r es. (SQLite :> es) => (FromRow r) => Statement -> Eff es (Maybe r)+nextRow stmt = unsafeEff_ $ S.nextRow stmt++----------------------------------------------------------------------------+-- Utils+----------------------------------------------------------------------------++unsafeEffWithUnlift :: forall a es. (SQLite :> es) => ((forall x. Eff es x -> IO x) -> IO a) -> Eff es a+unsafeEffWithUnlift action =+  unsafeEff \env -> do+    seqUnliftIO env \unlift -> do+      action unlift

+ src/Effectful/SQLite/Simple/Labeled.hs view

@@ -0,0 +1,330 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++{- ORMOLU_DISABLE -}+{- | A `SQLite` effect with a label attached, allowing multiple SQLite databases to be used in the same program.++Supported interpreters:++  * 'runSQLiteUnsync' - Runs a single-threaded action with a single connection.+  * 'runSQLiteSync' - Runs an action with a single connection shared across multiple threads.++>>> :set -XTypeApplications+>>> import Effectful+>>> import Effectful.Concurrent (runConcurrent)+>>> import Effectful.SQLite.Simple.Labeled (Labeled, SQLite)+>>> import Effectful.SQLite.Simple.Labeled qualified as SQL+>>> import Control.Concurrent.MVar qualified as MVar++>>> :{+app ::+  (Labeled "users" SQLite :> es)  =>+  (Labeled "products" SQLite :> es)  =>+  Eff es ()+app = do+  users <- SQL.useConnection @"users" \usersConn -> do+    SQL.query_ @User usersConn "SELECT * FROM users"+  products <- SQL.useConnection @"products" \productsConn -> do+    SQL.query_ @Product productsConn "SELECT * FROM products"+  pure ()+:}++>>> :{+main :: IO ()+main =+  SQL.withConnection "users.db" \usersConn -> do+    SQL.withConnection "products.db" \productsConn -> do+      usersConnVar <- MVar.newMVar usersConn+      productsConnVar <- MVar.newMVar productsConn+      app+        & SQL.runSQLiteSync @"users" usersConnVar+        & SQL.runSQLiteSync @"products" productsConnVar+        & runConcurrent+        & runEff+:}++-}+{- ORMOLU_ENABLE -}+module Effectful.SQLite.Simple.Labeled+  ( -- * Effects+    Labeled,+    SQLite (..),+    useConnection,+    LConnection (..),++    -- * Interpreters+    runSQLiteUnsync,+    runSQLiteSync,++    -- * Connections+    S.open,+    S.close,+    S.withConnection,+    S.setTrace,++    -- * Queries that return results+    query,+    query_,+    queryWith,+    queryWith_,+    queryNamed,+    lastInsertRowId,+    changes,+    totalChanges,++    -- * Queries that stream results+    fold,+    fold_,+    foldNamed,++    -- * Statements that do not return results+    execute,+    execute_,+    executeMany,+    executeNamed,+    S.field,++    -- * Transactions+    withTransaction,+    withImmediateTransaction,+    withExclusiveTransaction,+    withSavepoint,++    -- * Low-level statement API for stream access and prepared statements+    openStatement,+    closeStatement,+    withStatement,+    bind,+    bindNamed,+    reset,+    columnName,+    columnCount,+    withBind,+    nextRow,++    -- ** Exceptions+    S.FormatError (..),+    S.ResultError (..),+    S.SQLError (..),+    S.Error (..),++    -- * Types+    S.Query (..),+    S.Connection (..),+    S.ToRow (..),+    S.FromRow (..),+    S.Only (..),+    (S.:.) (..),+    S.SQLData (..),+    S.Statement (..),+    S.ColumnIndex (..),+    S.NamedParam (..),+  )+where++import Data.Int (Int64)+import Data.Text (Text)+import Database.SQLite.Simple (ColumnIndex, FromRow, NamedParam, Query, Statement, ToRow)+import Database.SQLite.Simple qualified as S+import Database.SQLite.Simple.FromRow (RowParser)+import Effectful+import Effectful.Concurrent (Concurrent)+import Effectful.Concurrent.MVar (MVar)+import Effectful.Dispatch.Dynamic (send)+import Effectful.Dispatch.Static (seqUnliftIO, unsafeEff, unsafeEff_)+import Effectful.Labeled+import Effectful.SQLite.Simple (SQLite)+import Effectful.SQLite.Simple qualified as SQL+import GHC.Stack (HasCallStack)++-- $setup+-- Clear all imports before running doctests+-- >>> :m+-- >>> :set -XOverloadedStrings+-- >>> import Data.Function ((&))+-- >>> import Effectful.SQLite.Simple (FromRow(fromRow))+-- >>> data User+-- >>> instance FromRow User where fromRow = undefined+-- >>> data Product+-- >>> instance FromRow Product where fromRow = undefined++----------------------------------------------------------------------------+-- Effect+----------------------------------------------------------------------------++-- | A labeled connection.+newtype LConnection (label :: k) = LConnection {getConn :: S.Connection}++-- | Retrieve the connection from the context and run the given action with it.+--+-- __WARNING__:+--+-- * The connection must not escape the scope of `useConnection`.+-- * `useConnection` calls must not be nested.+-- * When used together with other locking primitives, the locks must always be acquired in the same order to avoid deadlocks.+--+-- E.g., in the example below, the connections to the 2 databases are acquired out of order, which could lead to a deadlock.+--+-- >>> :{+-- import Effectful+-- import Effectful.SQLite.Simple.Labeled (Labeled, SQLite)+-- import Effectful.SQLite.Simple.Labeled qualified as SQL+-- f, g :: (Labeled "users" SQLite :> es, Labeled "products" SQLite :> es) => Eff es ()+-- f = do+--   SQL.useConnection @"users" \usersConn -> do+--     SQL.useConnection @"products" \productsConn -> do+--       pure ()+-- g = do+--   SQL.useConnection @"products" \productsConn -> do+--    SQL.useConnection @"users" \usersConn -> do+--       pure ()+-- :}+useConnection :: forall label es a. (Labeled label SQLite :> es) => (LConnection label -> Eff es a) -> Eff es a+useConnection use = send $ Labeled @label $ SQL.UseConnection \conn -> use (LConnection conn)++----------------------------------------------------------------------------+-- Interpreters+----------------------------------------------------------------------------++-- | Runs a single-threaded action with a single connection.+runSQLiteUnsync ::+  forall label es a.+  (HasCallStack, IOE :> es) =>+  S.Connection -> Eff (Labeled label SQLite ': es) a -> Eff es a+runSQLiteUnsync = runLabeled @label . SQL.runSQLiteUnsync++-- | Runs an action with a single connection shared across multiple threads.+--+-- __WARNING__: Since this interpreter is backed by an `MVar`, the usual caveats apply:+--+-- * The connection must not escape the scope of `useConnection`.+-- * `useConnection` calls must not be nested.+-- * When used together with other locking primitives, the locks must always be acquired in the same order to avoid deadlocks.+runSQLiteSync ::+  forall label es a.+  (HasCallStack, IOE :> es, Concurrent :> es) =>+  MVar S.Connection -> Eff (Labeled label SQLite ': es) a -> Eff es a+runSQLiteSync = runLabeled @label . SQL.runSQLiteSync++----------------------------------------------------------------------------+-- Operations+----------------------------------------------------------------------------++query :: forall q r label es. (Labeled label SQLite :> es) => (ToRow q, FromRow r) => LConnection label -> Query -> q -> Eff es [r]+query conn q params = unsafeEff_ $ S.query conn.getConn q params++query_ :: forall r label es. (Labeled label SQLite :> es) => (FromRow r) => LConnection label -> Query -> Eff es [r]+query_ conn q = unsafeEff_ $ S.query_ conn.getConn q++queryWith :: forall q r label es. (Labeled label SQLite :> es) => (ToRow q) => RowParser r -> LConnection label -> Query -> q -> Eff es [r]+queryWith parser conn q params = unsafeEff_ $ S.queryWith parser conn.getConn q params++queryWith_ :: forall r label es. (Labeled label SQLite :> es) => RowParser r -> LConnection label -> Query -> Eff es [r]+queryWith_ parser conn q = unsafeEff_ $ S.queryWith_ parser conn.getConn q++queryNamed :: forall r label es. (Labeled label SQLite :> es) => (FromRow r) => LConnection label -> Query -> [NamedParam] -> Eff es [r]+queryNamed conn q params = unsafeEff_ $ S.queryNamed conn.getConn q params++lastInsertRowId :: forall label es. (Labeled label SQLite :> es) => LConnection label -> Eff es Int64+lastInsertRowId = unsafeEff_ . S.lastInsertRowId . getConn++changes :: forall label es. (Labeled label SQLite :> es) => LConnection label -> Eff es Int+changes = unsafeEff_ . S.changes . getConn++totalChanges :: forall label es. (Labeled label SQLite :> es) => LConnection label -> Eff es Int+totalChanges = unsafeEff_ . S.totalChanges . getConn++fold :: forall row params a label es. (Labeled label SQLite :> es, FromRow row, ToRow params) => LConnection label -> Query -> params -> a -> (a -> row -> Eff es a) -> Eff es a+fold conn q params initialState action =+  unsafeEffWithUnlift @label \unlift -> do+    S.fold conn.getConn q params initialState \a row ->+      unlift $ action a row++fold_ :: forall row a label es. (Labeled label SQLite :> es) => (FromRow row) => LConnection label -> Query -> a -> (a -> row -> Eff es a) -> Eff es a+fold_ conn q initialState action =+  unsafeEffWithUnlift @label \unlift -> do+    S.fold_ conn.getConn q initialState \a row ->+      unlift $ action a row++foldNamed :: forall row a label es. (Labeled label SQLite :> es) => (FromRow row) => LConnection label -> Query -> [NamedParam] -> a -> (a -> row -> Eff es a) -> Eff es a+foldNamed conn q params initialState action =+  unsafeEffWithUnlift @label \unlift -> do+    S.foldNamed conn.getConn q params initialState \a row ->+      unlift $ action a row++execute :: forall q label es. (Labeled label SQLite :> es) => (ToRow q) => LConnection label -> Query -> q -> Eff es ()+execute conn q params = unsafeEff_ $ S.execute conn.getConn q params++execute_ :: forall label es. (Labeled label SQLite :> es) => LConnection label -> Query -> Eff es ()+execute_ conn q = unsafeEff_ $ S.execute_ conn.getConn q++executeMany :: forall q label es. (Labeled label SQLite :> es) => (ToRow q) => LConnection label -> Query -> [q] -> Eff es ()+executeMany conn q params = unsafeEff_ $ S.executeMany conn.getConn q params++executeNamed :: forall label es. (Labeled label SQLite :> es) => LConnection label -> Query -> [NamedParam] -> Eff es ()+executeNamed conn q params = unsafeEff_ $ S.executeNamed conn.getConn q params++withTransaction :: forall a label es. (Labeled label SQLite :> es) => LConnection label -> Eff es a -> Eff es a+withTransaction conn action =+  unsafeEffWithUnlift @label \unlift -> do+    S.withTransaction conn.getConn $ unlift action++withImmediateTransaction :: forall a label es. (Labeled label SQLite :> es) => LConnection label -> Eff es a -> Eff es a+withImmediateTransaction conn action =+  unsafeEffWithUnlift @label \unlift -> do+    S.withImmediateTransaction conn.getConn $ unlift action++withExclusiveTransaction :: forall a label es. (Labeled label SQLite :> es) => LConnection label -> Eff es a -> Eff es a+withExclusiveTransaction conn action =+  unsafeEffWithUnlift @label \unlift -> do+    S.withExclusiveTransaction conn.getConn $ unlift action++withSavepoint :: forall a label es. (Labeled label SQLite :> es) => LConnection label -> Eff es a -> Eff es a+withSavepoint conn action =+  unsafeEffWithUnlift @label \unlift -> do+    S.withSavepoint conn.getConn $ unlift action++openStatement :: forall label es. (Labeled label SQLite :> es) => LConnection label -> Query -> Eff es Statement+openStatement conn q = unsafeEff_ $ S.openStatement conn.getConn q++closeStatement :: forall label es. (Labeled label SQLite :> es) => Statement -> Eff es ()+closeStatement stmt = unsafeEff_ $ S.closeStatement stmt++withStatement :: forall a label es. (Labeled label SQLite :> es) => LConnection label -> Query -> (Statement -> Eff es a) -> Eff es a+withStatement conn q action =+  unsafeEffWithUnlift @label \unlift -> do+    S.withStatement conn.getConn q (unlift . action)++bind :: forall label params es. (Labeled label SQLite :> es) => (ToRow params) => Statement -> params -> Eff es ()+bind stmt params = unsafeEff_ $ S.bind stmt params++bindNamed :: forall label es. (Labeled label SQLite :> es) => Statement -> [NamedParam] -> Eff es ()+bindNamed stmt params = unsafeEff_ $ S.bindNamed stmt params++reset :: forall label es. (Labeled label SQLite :> es) => Statement -> Eff es ()+reset stmt = unsafeEff_ $ S.reset stmt++columnName :: forall label es. (Labeled label SQLite :> es) => Statement -> ColumnIndex -> Eff es Text+columnName stmt idx = unsafeEff_ $ S.columnName stmt idx++columnCount :: forall label es. (Labeled label SQLite :> es) => Statement -> Eff es ColumnIndex+columnCount stmt = unsafeEff_ $ S.columnCount stmt++withBind :: forall label params a es. (Labeled label SQLite :> es) => (ToRow params) => Statement -> params -> Eff es a -> Eff es a+withBind stmt params action =+  unsafeEffWithUnlift @label \unlift -> do+    S.withBind stmt params $ unlift action++nextRow :: forall label r es. (Labeled label SQLite :> es) => (FromRow r) => Statement -> Eff es (Maybe r)+nextRow stmt = unsafeEff_ $ S.nextRow stmt++----------------------------------------------------------------------------+-- Utils+----------------------------------------------------------------------------++unsafeEffWithUnlift :: forall label a es. (Labeled label SQLite :> es) => ((forall x. Eff es x -> IO x) -> IO a) -> Eff es a+unsafeEffWithUnlift action =+  unsafeEff \env -> do+    seqUnliftIO env \unlift -> do+      action unlift

+ src/Effectful/SQLite/Simple/RW.hs view

@@ -0,0 +1,411 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++{- ORMOLU_DISABLE -}+{- | A dynamic effect that lets us use a __pooled__ SQLite `Database.SQLite.Simple.Connection`.++SQLite allows multiple connections to read/write concurrently, but concurrent writes will lead to contention, performance degradation, and @SQLITE_BUSY@ errors.+We avoid this by:++  * Having separate pools for reading and writing.+  * Configuring the write pool to have a maximum of 1 connection, thus serializing all writes.++__WARNING__: This interpreter sets the database's journal mode to [WAL](https://sqlite.org/wal.html),+so that readers will not block the writer and the writer will not block readers.++Note that even in WAL mode, [@SQLITE_BUSY@ errors can still occur](https://sqlite.org/wal.html#sometimes_queries_return_sqlite_busy_in_wal_mode).++To connect to multiple databases, see "Effectful.SQLite.Simple.RW.Labeled".++>>> import Effectful+>>> import Effectful.Concurrent (runConcurrent)+>>> import Effectful.SQLite.Simple.RW (SQLite)+>>> import Effectful.SQLite.Simple.RW qualified as SQL++>>> :{+app :: (SQLite :> es) => Eff es ()+app = do+  SQL.useWriteConnection \conn -> do+    SQL.withImmediateTransaction conn do+      SQL.query_ @User conn "SELECT * FROM users"+      SQL.execute conn "DELETE FROM users WHERE username = ?" (SQL.Only "dcastro")+:}++>>> :{+main :: IO ()+main = do+  let dbPath = "users.db"+  pools <-+    SQL.newPools+      =<< SQL.newPoolsConfig+        (SQL.open dbPath) -- Action to create a new read connection.+        60                -- Read connections' idle timeout in seconds.+        32                -- Max number of read connections.+        (SQL.open dbPath) -- Action to create a new write connection.+        60                -- Write connections' idle timeout in seconds.+  app+    & SQL.runSQLiteWithPools pools+    & runConcurrent+    & runEff+:}++-}+{- ORMOLU_ENABLE -}+module Effectful.SQLite.Simple.RW+  ( -- * Effects+    SQLite (..),++    -- * Use connection+    -- $useConnection+    useReadConnection,+    useWriteConnection,+    RWConnection (..),+    ConnMode (..),++    -- * Interpreters+    runSQLiteWithPools,+    Pools (..),+    newPools,+    PoolsConfig (..),+    newPoolsConfig,++    -- * Connections+    S.open,+    S.close,+    S.withConnection,+    S.setTrace,++    -- * Queries that return results+    query,+    query_,+    queryWith,+    queryWith_,+    queryNamed,+    lastInsertRowId,+    changes,+    totalChanges,++    -- * Queries that stream results+    fold,+    fold_,+    foldNamed,++    -- * Statements that do not return results+    execute,+    execute_,+    executeMany,+    executeNamed,+    S.field,++    -- * Transactions+    withTransaction,+    withImmediateTransaction,+    withExclusiveTransaction,+    withSavepoint,++    -- * Low-level statement API for stream access and prepared statements+    openStatement,+    closeStatement,+    withStatement,+    bind,+    bindNamed,+    reset,+    columnName,+    columnCount,+    withBind,+    nextRow,++    -- ** Exceptions+    S.FormatError (..),+    S.ResultError (..),+    S.SQLError (..),+    S.Error (..),++    -- * Types+    S.Query (..),+    S.Connection (..),+    S.ToRow (..),+    S.FromRow (..),+    S.Only (..),+    (S.:.) (..),+    S.SQLData (..),+    S.Statement (..),+    S.ColumnIndex (..),+    S.NamedParam (..),+  )+where++import Data.Function ((&))+import Data.Int (Int64)+import Data.Text (Text)+import Database.SQLite.Simple (ColumnIndex, FromRow, NamedParam, Query, Statement, ToRow)+import Database.SQLite.Simple qualified as S+import Database.SQLite.Simple.FromRow (RowParser)+import Effectful+import Effectful.Dispatch.Dynamic (interpret, localSeqUnlift, send)+import Effectful.Dispatch.Static (seqUnliftIO, unsafeEff, unsafeEff_)+import GHC.Stack (HasCallStack)+import UnliftIO.Pool qualified as Pool++-- $setup+-- Clear all imports before running doctests+-- >>> :m+-- >>> :set -XOverloadedStrings+-- >>> import Data.Function ((&))+-- >>> import Data.Text (Text)+-- >>> import Effectful.SQLite.Simple (FromRow(fromRow))+-- >>> data User+-- >>> instance FromRow User where fromRow = undefined++----------------------------------------------------------------------------+-- Effect+----------------------------------------------------------------------------++{-+  NOTE: The rationale for having separate "read" and "write" pools has been documented here: @(ref:concurrency)+-}++-- | The mode in which a connection is acquired.+data ConnMode = Read | Write++-- | A connection that can be acquired in "read" or "write" mode.+-- This determines which kind of operations can be performed with the connection.+newtype RWConnection (mode :: ConnMode) = RWConnection {getConn :: S.Connection}++data SQLite :: Effect where+  UseReadConnection :: (RWConnection 'Read -> m a) -> SQLite m a+  UseWriteConnection :: (RWConnection 'Write -> m a) -> SQLite m a++type instance DispatchOf SQLite = 'Dynamic++{- ORMOLU_DISABLE -}+{- $useConnection++The `useReadConnection` and `useWriteConnection` operations retrieve a pooled connection from the context that can be used to run "read" or "write" operations.++If the action throws an exception of any type, the connection is closed and not returned to the pool.++__WARNING__:++* The connection must not be manually closed.+* The connection must not escape the scope of `useReadConnection` or `useWriteConnection`.+* `useWriteConnection` calls must not be nested.+* When `useWriteConnection` is used together with other locking primitives, the locks must always be acquired in the same order to avoid deadlocks.++-}+{- ORMOLU_ENABLE -}++-- | Retrieve the connection from the context and run the given "read" operations with it.+useReadConnection :: (HasCallStack, SQLite :> es) => (RWConnection 'Read -> Eff es a) -> Eff es a+useReadConnection = send . UseReadConnection++-- | Retrieve the connection from the context and run the given "read" or "write" operations with it.+useWriteConnection :: (HasCallStack, SQLite :> es) => (RWConnection 'Write -> Eff es a) -> Eff es a+useWriteConnection = send . UseWriteConnection++----------------------------------------------------------------------------+-- Interpreters+----------------------------------------------------------------------------++-- | Interprets the 'SQLite' effect by using 2 connection pools for reading and writing.+--+-- __WARNING__: This interpreter sets the database's journal mode to [WAL](https://sqlite.org/wal.html),+-- so that readers will not block the writer and the writer will not block readers.+--+-- Note that even in WAL mode, [@SQLITE_BUSY@ errors can still occur](https://sqlite.org/wal.html#sometimes_queries_return_sqlite_busy_in_wal_mode).+runSQLiteWithPools :: (HasCallStack, IOE :> es) => Pools -> Eff (SQLite ': es) a -> Eff es a+runSQLiteWithPools pools action = do+  {-+    NOTE: we set the WAL mode upfront.++    To avoid SQLITE_BUSY errors, all connections must be made in WAL mode.+    We can't set WAL mode lazily (e.g. every time a pool creates a new connection),+    because having the "read pool" execute `PRAGMA journal_mode=WAL` would cause it to acquire+    an exclusive lock on the database, which it must not do.+    Therefore, we must do it eagerly, here.+  -}+  Pool.withResource pools.writePool \conn -> do+    liftIO $ S.execute_ conn.getConn "PRAGMA journal_mode=WAL"++  action & interpret \env -> \case+    UseReadConnection action -> do+      localSeqUnlift env \unlift -> do+        Pool.withResource pools.readPool \conn -> do+          unlift $ action conn+    UseWriteConnection action -> do+      localSeqUnlift env \unlift -> do+        Pool.withResource pools.writePool \conn -> do+          unlift $ action conn++data Pools = Pools+  { readPool :: Pool.Pool (RWConnection 'Read),+    writePool :: Pool.Pool (RWConnection 'Write)+  }++newPools :: (MonadUnliftIO m) => PoolsConfig -> m Pools+newPools (PoolsConfig readPoolConfig writePoolConfig) = do+  readPool <- Pool.newPool readPoolConfig+  writePool <- Pool.newPool writePoolConfig+  pure Pools {readPool, writePool}++data PoolsConfig = PoolsConfig+  { readPoolConfig :: Pool.PoolConfig (RWConnection 'Read),+    writePoolConfig :: Pool.PoolConfig (RWConnection 'Write)+  }++newPoolsConfig ::+  (MonadUnliftIO m) =>+  -- | The action to create a new connection for reading from the database.+  m S.Connection ->+  -- | The number of seconds for which an unused read connection is kept around. The smallest acceptable value is 0.5.+  --+  -- Note: the elapsed time before destroying a connection may be a little longer than requested, as the collector thread wakes at 1-second intervals.+  Double ->+  -- | The maximum number of read connections to keep open at once. The smallest acceptable value is 1.+  Int ->+  -- | The action to create a new connection for writing to the database.+  m S.Connection ->+  -- | The number of seconds for which an unused write connection is kept around. The smallest acceptable value is 0.5.+  --+  -- Note: the elapsed time before destroying a connection may be a little longer than requested, as the collector thread wakes at 1-second intervals.+  Double ->+  m PoolsConfig+newPoolsConfig mkReadConn readTTLSeconds readMaxConns mkWriteConn writeTTLSeconds = do+  readPoolConfig <-+    Pool.mkDefaultPoolConfig+      (RWConnection @'Read <$> mkReadConn)+      (liftIO . S.close . getConn)+      readTTLSeconds+      readMaxConns++  let writeMaxConns = 1+  writePoolConfig <-+    Pool.mkDefaultPoolConfig+      (RWConnection @'Write <$> mkWriteConn)+      (liftIO . S.close . getConn)+      writeTTLSeconds+      writeMaxConns+  pure PoolsConfig {readPoolConfig, writePoolConfig}++----------------------------------------------------------------------------+-- Operations+----------------------------------------------------------------------------++query :: forall q r es mode. (SQLite :> es) => (ToRow q, FromRow r) => RWConnection mode -> Query -> q -> Eff es [r]+query conn q params = unsafeEff_ $ S.query conn.getConn q params++query_ :: forall r es mode. (SQLite :> es) => (FromRow r) => RWConnection mode -> Query -> Eff es [r]+query_ conn q = unsafeEff_ $ S.query_ conn.getConn q++queryWith :: forall q r es mode. (SQLite :> es) => (ToRow q) => RowParser r -> RWConnection mode -> Query -> q -> Eff es [r]+queryWith parser conn q params = unsafeEff_ $ S.queryWith parser conn.getConn q params++queryWith_ :: forall r es mode. (SQLite :> es) => RowParser r -> RWConnection mode -> Query -> Eff es [r]+queryWith_ parser conn q = unsafeEff_ $ S.queryWith_ parser conn.getConn q++queryNamed :: forall r es mode. (SQLite :> es) => (FromRow r) => RWConnection mode -> Query -> [NamedParam] -> Eff es [r]+queryNamed conn q params = unsafeEff_ $ S.queryNamed conn.getConn q params++lastInsertRowId :: forall es mode. (SQLite :> es) => RWConnection mode -> Eff es Int64+lastInsertRowId = unsafeEff_ . S.lastInsertRowId . getConn++changes :: forall es mode. (SQLite :> es) => RWConnection mode -> Eff es Int+changes = unsafeEff_ . S.changes . getConn++totalChanges :: forall es mode. (SQLite :> es) => RWConnection mode -> Eff es Int+totalChanges = unsafeEff_ . S.totalChanges . getConn++fold :: forall row params a es mode. (SQLite :> es) => (FromRow row, ToRow params) => RWConnection mode -> Query -> params -> a -> (a -> row -> Eff es a) -> Eff es a+fold conn q params initialState action =+  unsafeEffWithUnlift \unlift -> do+    S.fold conn.getConn q params initialState \a row ->+      unlift $ action a row++fold_ :: forall row a es mode. (SQLite :> es) => (FromRow row) => RWConnection mode -> Query -> a -> (a -> row -> Eff es a) -> Eff es a+fold_ conn q initialState action =+  unsafeEffWithUnlift \unlift -> do+    S.fold_ conn.getConn q initialState \a row ->+      unlift $ action a row++foldNamed :: forall row a es mode. (SQLite :> es) => (FromRow row) => RWConnection mode -> Query -> [NamedParam] -> a -> (a -> row -> Eff es a) -> Eff es a+foldNamed conn q params initialState action =+  unsafeEffWithUnlift \unlift -> do+    S.foldNamed conn.getConn q params initialState \a row ->+      unlift $ action a row++execute :: forall q es. (SQLite :> es) => (ToRow q) => RWConnection 'Write -> Query -> q -> Eff es ()+execute conn q params = unsafeEff_ $ S.execute conn.getConn q params++execute_ :: forall es. (SQLite :> es) => RWConnection 'Write -> Query -> Eff es ()+execute_ conn q = unsafeEff_ $ S.execute_ conn.getConn q++executeMany :: forall q es. (SQLite :> es) => (ToRow q) => RWConnection 'Write -> Query -> [q] -> Eff es ()+executeMany conn q params = unsafeEff_ $ S.executeMany conn.getConn q params++executeNamed :: forall es. (SQLite :> es) => RWConnection 'Write -> Query -> [NamedParam] -> Eff es ()+executeNamed conn q params = unsafeEff_ $ S.executeNamed conn.getConn q params++withTransaction :: forall a es mode. (SQLite :> es) => RWConnection mode -> Eff es a -> Eff es a+withTransaction conn action =+  unsafeEffWithUnlift \unlift -> do+    S.withTransaction conn.getConn $ unlift action++withImmediateTransaction :: forall a es. (SQLite :> es) => RWConnection 'Write -> Eff es a -> Eff es a+withImmediateTransaction conn action =+  unsafeEffWithUnlift \unlift -> do+    S.withImmediateTransaction conn.getConn $ unlift action++withExclusiveTransaction :: forall a es. (SQLite :> es) => RWConnection 'Write -> Eff es a -> Eff es a+withExclusiveTransaction conn action =+  unsafeEffWithUnlift \unlift -> do+    S.withExclusiveTransaction conn.getConn $ unlift action++withSavepoint :: forall a es. (SQLite :> es) => RWConnection 'Write -> Eff es a -> Eff es a+withSavepoint conn action =+  unsafeEffWithUnlift \unlift -> do+    S.withSavepoint conn.getConn $ unlift action++openStatement :: forall es. (SQLite :> es) => RWConnection 'Write -> Query -> Eff es Statement+openStatement conn q = unsafeEff_ $ S.openStatement conn.getConn q++closeStatement :: forall es. (SQLite :> es) => Statement -> Eff es ()+closeStatement stmt = unsafeEff_ $ S.closeStatement stmt++withStatement :: forall a es. (SQLite :> es) => RWConnection 'Write -> Query -> (Statement -> Eff es a) -> Eff es a+withStatement conn q action =+  unsafeEffWithUnlift \unlift -> do+    S.withStatement conn.getConn q (unlift . action)++bind :: forall params es. (SQLite :> es) => (ToRow params) => Statement -> params -> Eff es ()+bind stmt params = unsafeEff_ $ S.bind stmt params++bindNamed :: forall es. (SQLite :> es) => Statement -> [NamedParam] -> Eff es ()+bindNamed stmt params = unsafeEff_ $ S.bindNamed stmt params++reset :: forall es. (SQLite :> es) => Statement -> Eff es ()+reset stmt = unsafeEff_ $ S.reset stmt++columnName :: forall es. (SQLite :> es) => Statement -> ColumnIndex -> Eff es Text+columnName stmt idx = unsafeEff_ $ S.columnName stmt idx++columnCount :: forall es. (SQLite :> es) => Statement -> Eff es ColumnIndex+columnCount stmt = unsafeEff_ $ S.columnCount stmt++withBind :: forall params a es. (SQLite :> es) => (ToRow params) => Statement -> params -> Eff es a -> Eff es a+withBind stmt params action =+  unsafeEffWithUnlift \unlift -> do+    S.withBind stmt params $ unlift action++nextRow :: forall r es. (SQLite :> es) => (FromRow r) => Statement -> Eff es (Maybe r)+nextRow stmt = unsafeEff_ $ S.nextRow stmt++----------------------------------------------------------------------------+-- Utils+----------------------------------------------------------------------------++unsafeEffWithUnlift :: forall a es. (SQLite :> es) => ((forall x. Eff es x -> IO x) -> IO a) -> Eff es a+unsafeEffWithUnlift action =+  unsafeEff \env -> do+    seqUnliftIO env \unlift -> do+      action unlift

+ src/Effectful/SQLite/Simple/RW/Labeled.hs view

@@ -0,0 +1,360 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++{- ORMOLU_DISABLE -}+{- | A __pooled__ `SQLite` effect with a label attached, allowing multiple SQLite databases to be used in the same program.++SQLite allows multiple connections to read/write concurrently, but concurrent writes will lead to contention, performance degradation, and @SQLITE_BUSY@ errors.+We avoid this by:++  * Having separate pools for reading and writing.+  * Configuring the write pool to have a maximum of 1 connection, thus serializing all writes.++__WARNING__: This interpreter sets the database's journal mode to [WAL](https://sqlite.org/wal.html),+so that readers will not block the writer and the writer will not block readers.++Note that even in WAL mode, [@SQLITE_BUSY@ errors can still occur](https://sqlite.org/wal.html#sometimes_queries_return_sqlite_busy_in_wal_mode).++>>> import Effectful+>>> import Effectful.Concurrent (runConcurrent)+>>> import Effectful.SQLite.Simple.RW.Labeled (Labeled, SQLite)+>>> import Effectful.SQLite.Simple.RW.Labeled qualified as SQL++>>> :{+app ::+  (Labeled "users" SQLite :> es)  =>+  (Labeled "products" SQLite :> es)  =>+  Eff es ()+app = do+  users <- SQL.useWriteConnection @"users" \usersConn -> do+    SQL.execute usersConn "DELETE FROM users WHERE username = ?" (SQL.Only "dcastro")+  products <- SQL.useReadConnection @"products" \productsConn -> do+    SQL.query_ @Product productsConn "SELECT * FROM products"+  pure ()+:}++>>> :{+main :: IO ()+main = do+  let mkPools dbPath =+        SQL.newPools+          =<< SQL.newPoolsConfig+            (SQL.open dbPath) -- Action to create a new read connection.+            60                -- Read connections' idle timeout in seconds.+            32                -- Max number of read connections.+            (SQL.open dbPath) -- Action to create a new write connection.+            60                -- Write connections' idle timeout in seconds.+  userPools <- mkPools "users.db"+  productPools <- mkPools "products.db"+  app+    & SQL.runSQLiteWithPools @"users" userPools+    & SQL.runSQLiteWithPools @"products" productPools+    & runConcurrent+    & runEff+:}++-}+{- ORMOLU_ENABLE -}+module Effectful.SQLite.Simple.RW.Labeled+  ( -- * Effects+    Labeled,+    SQLite (..),++    -- * Use connection+    -- $useConnection+    useReadConnection,+    useWriteConnection,+    LRWConnection (..),+    ConnMode (..),++    -- * Interpreters+    runSQLiteWithPools,+    RW.Pools (..),+    RW.newPools,+    RW.PoolsConfig (..),+    RW.newPoolsConfig,++    -- * Connections+    S.open,+    S.close,+    S.withConnection,+    S.setTrace,++    -- * Queries that return results+    query,+    query_,+    queryWith,+    queryWith_,+    queryNamed,+    lastInsertRowId,+    changes,+    totalChanges,++    -- * Queries that stream results+    fold,+    fold_,+    foldNamed,++    -- * Statements that do not return results+    execute,+    execute_,+    executeMany,+    executeNamed,+    S.field,++    -- * Transactions+    withTransaction,+    withImmediateTransaction,+    withExclusiveTransaction,+    withSavepoint,++    -- * Low-level statement API for stream access and prepared statements+    openStatement,+    closeStatement,+    withStatement,+    bind,+    bindNamed,+    reset,+    columnName,+    columnCount,+    withBind,+    nextRow,++    -- ** Exceptions+    S.FormatError (..),+    S.ResultError (..),+    S.SQLError (..),+    S.Error (..),++    -- * Types+    S.Query (..),+    S.Connection (..),+    S.ToRow (..),+    S.FromRow (..),+    S.Only (..),+    (S.:.) (..),+    S.SQLData (..),+    S.Statement (..),+    S.ColumnIndex (..),+    S.NamedParam (..),+  )+where++import Data.Int (Int64)+import Data.Text (Text)+import Database.SQLite.Simple (ColumnIndex, FromRow, NamedParam, Query, Statement, ToRow)+import Database.SQLite.Simple qualified as S+import Database.SQLite.Simple.FromRow (RowParser)+import Effectful+import Effectful.Dispatch.Dynamic (send)+import Effectful.Dispatch.Static (seqUnliftIO, unsafeEff, unsafeEff_)+import Effectful.Labeled (Labeled (..), runLabeled)+import Effectful.SQLite.Simple.RW (ConnMode (..), SQLite)+import Effectful.SQLite.Simple.RW qualified as RW+import GHC.Stack (HasCallStack)++-- $setup+-- Clear all imports before running doctests+-- >>> :m+-- >>> :set -XOverloadedStrings+-- >>> import Data.Function ((&))+-- >>> import Effectful.SQLite.Simple (FromRow(fromRow))+-- >>> data User+-- >>> instance FromRow User where fromRow = undefined+-- >>> data Product+-- >>> instance FromRow Product where fromRow = undefined++----------------------------------------------------------------------------+-- Effect+----------------------------------------------------------------------------++{-+  The rationale for having separate "read" and "write" pools has been documented here: @(ref:concurrency)+-}++-- | A labelled connection that can be acquired in "read" or "write" mode.+-- This determines which kind of operations can be performed with the connection.+newtype LRWConnection (label :: k) (mode :: RW.ConnMode) = LRWConnection {getConn :: RW.RWConnection mode}++{- ORMOLU_DISABLE -}+{- $useConnection++The `useReadConnection` and `useWriteConnection` operations retrieve a pooled connection from the context that can be used to run "read" or "write" operations.++If the action throws an exception of any type, the connection is closed and not returned to the pool.++__WARNING__:++* The connection must not be manually closed.+* The connection must not escape the scope of `useReadConnection` or `useWriteConnection`.+* `useWriteConnection` calls must not be nested.+* When `useWriteConnection` is used together with other locking primitives, the locks must always be acquired in the same order to avoid deadlocks.++E.g., in the example below, the "write" connections to the 2 databases are acquired out of order, which could lead to a deadlock.++>>> :{+import Effectful+import Effectful.SQLite.Simple.RW.Labeled (Labeled, SQLite)+import Effectful.SQLite.Simple.RW.Labeled qualified as SQL+f, g :: (Labeled "users" SQLite :> es, Labeled "products" SQLite :> es) => Eff es ()+f = do+  SQL.useWriteConnection @"users" \usersConn -> do+    SQL.useWriteConnection @"products" \productsConn -> do+      pure ()+g = do+  SQL.useWriteConnection @"products" \productsConn -> do+   SQL.useWriteConnection @"users" \usersConn -> do+      pure ()+:}++-}+{- ORMOLU_ENABLE -}++-- | Retrieve the connection from the context and run the given "read" operations with it.+useReadConnection :: forall label es a. (HasCallStack, Labeled label SQLite :> es) => (LRWConnection label 'Read -> Eff es a) -> Eff es a+useReadConnection use = send $ Labeled @label $ RW.UseReadConnection \conn -> use (LRWConnection conn)++-- | Retrieve the connection from the context and run the given "read" or "write" operations with it.+useWriteConnection :: forall label es a. (HasCallStack, Labeled label SQLite :> es) => (LRWConnection label 'Write -> Eff es a) -> Eff es a+useWriteConnection use = send $ Labeled @label $ RW.UseWriteConnection \conn -> use (LRWConnection conn)++----------------------------------------------------------------------------+-- Interpreters+----------------------------------------------------------------------------++-- | Interprets the 'SQLite' effect by using 2 connection pools for reading and writing.+--+-- __WARNING__: This interpreter sets the database's journal mode to [WAL](https://sqlite.org/wal.html),+-- so that readers will not block the writer and the writer will not block readers.+--+-- Note that even in WAL mode, [@SQLITE_BUSY@ errors can still occur](https://sqlite.org/wal.html#sometimes_queries_return_sqlite_busy_in_wal_mode).+runSQLiteWithPools ::+  forall label es a.+  (HasCallStack, IOE :> es) =>+  RW.Pools ->+  Eff (Labeled label SQLite ': es) a ->+  Eff es a+runSQLiteWithPools = runLabeled @label . RW.runSQLiteWithPools++----------------------------------------------------------------------------+-- Operations+----------------------------------------------------------------------------++query :: forall q r label mode es. (Labeled label SQLite :> es) => (ToRow q, FromRow r) => LRWConnection label mode -> Query -> q -> Eff es [r]+query conn q params = unsafeEff_ $ S.query conn.getConn.getConn q params++query_ :: forall r label mode es. (Labeled label SQLite :> es) => (FromRow r) => LRWConnection label mode -> Query -> Eff es [r]+query_ conn q = unsafeEff_ $ S.query_ conn.getConn.getConn q++queryWith :: forall q r label mode es. (Labeled label SQLite :> es) => (ToRow q) => RowParser r -> LRWConnection label mode -> Query -> q -> Eff es [r]+queryWith parser conn q params = unsafeEff_ $ S.queryWith parser conn.getConn.getConn q params++queryWith_ :: forall r label mode es. (Labeled label SQLite :> es) => RowParser r -> LRWConnection label mode -> Query -> Eff es [r]+queryWith_ parser conn q = unsafeEff_ $ S.queryWith_ parser conn.getConn.getConn q++queryNamed :: forall r label mode es. (Labeled label SQLite :> es) => (FromRow r) => LRWConnection label mode -> Query -> [NamedParam] -> Eff es [r]+queryNamed conn q params = unsafeEff_ $ S.queryNamed conn.getConn.getConn q params++lastInsertRowId :: forall label mode es. (Labeled label SQLite :> es) => LRWConnection label mode -> Eff es Int64+lastInsertRowId conn = unsafeEff_ $ S.lastInsertRowId conn.getConn.getConn++changes :: forall label mode es. (Labeled label SQLite :> es) => LRWConnection label mode -> Eff es Int+changes conn = unsafeEff_ $ S.changes conn.getConn.getConn++totalChanges :: forall label mode es. (Labeled label SQLite :> es) => LRWConnection label mode -> Eff es Int+totalChanges conn = unsafeEff_ $ S.totalChanges conn.getConn.getConn++fold :: forall row params a label mode es. (Labeled label SQLite :> es) => (FromRow row, ToRow params) => LRWConnection label mode -> Query -> params -> a -> (a -> row -> Eff es a) -> Eff es a+fold conn q params initialState action =+  unsafeEffWithUnlift @label \unlift -> do+    S.fold conn.getConn.getConn q params initialState \a row ->+      unlift $ action a row++fold_ :: forall row a label mode es. (Labeled label SQLite :> es) => (FromRow row) => LRWConnection label mode -> Query -> a -> (a -> row -> Eff es a) -> Eff es a+fold_ conn q initialState action =+  unsafeEffWithUnlift @label \unlift -> do+    S.fold_ conn.getConn.getConn q initialState \a row ->+      unlift $ action a row++foldNamed :: forall row a label mode es. (Labeled label SQLite :> es) => (FromRow row) => LRWConnection label mode -> Query -> [NamedParam] -> a -> (a -> row -> Eff es a) -> Eff es a+foldNamed conn q params initialState action =+  unsafeEffWithUnlift @label \unlift -> do+    S.foldNamed conn.getConn.getConn q params initialState \a row ->+      unlift $ action a row++execute :: forall q label es. (Labeled label SQLite :> es) => (ToRow q) => LRWConnection label 'Write -> Query -> q -> Eff es ()+execute conn q params = unsafeEff_ $ S.execute conn.getConn.getConn q params++execute_ :: forall label es. (Labeled label SQLite :> es) => LRWConnection label 'Write -> Query -> Eff es ()+execute_ conn q = unsafeEff_ $ S.execute_ conn.getConn.getConn q++executeMany :: forall q label es. (Labeled label SQLite :> es) => (ToRow q) => LRWConnection label 'Write -> Query -> [q] -> Eff es ()+executeMany conn q params = unsafeEff_ $ S.executeMany conn.getConn.getConn q params++executeNamed :: forall label es. (Labeled label SQLite :> es) => LRWConnection label 'Write -> Query -> [NamedParam] -> Eff es ()+executeNamed conn q params = unsafeEff_ $ S.executeNamed conn.getConn.getConn q params++withTransaction :: forall a label mode es. (Labeled label SQLite :> es) => LRWConnection label mode -> Eff es a -> Eff es a+withTransaction conn action =+  unsafeEffWithUnlift @label \unlift -> do+    S.withTransaction conn.getConn.getConn $ unlift action++withImmediateTransaction :: forall a label es. (Labeled label SQLite :> es) => LRWConnection label 'Write -> Eff es a -> Eff es a+withImmediateTransaction conn action =+  unsafeEffWithUnlift @label \unlift -> do+    S.withImmediateTransaction conn.getConn.getConn $ unlift action++withExclusiveTransaction :: forall a label es. (Labeled label SQLite :> es) => LRWConnection label 'Write -> Eff es a -> Eff es a+withExclusiveTransaction conn action =+  unsafeEffWithUnlift @label \unlift -> do+    S.withExclusiveTransaction conn.getConn.getConn $ unlift action++withSavepoint :: forall a label es. (Labeled label SQLite :> es) => LRWConnection label 'Write -> Eff es a -> Eff es a+withSavepoint conn action =+  unsafeEffWithUnlift @label \unlift -> do+    S.withSavepoint conn.getConn.getConn $ unlift action++openStatement :: forall label es. (Labeled label SQLite :> es) => LRWConnection label 'Write -> Query -> Eff es Statement+openStatement conn q = unsafeEff_ $ S.openStatement conn.getConn.getConn q++closeStatement :: forall label es. (Labeled label SQLite :> es) => Statement -> Eff es ()+closeStatement stmt = unsafeEff_ $ S.closeStatement stmt++withStatement :: forall a label es. (Labeled label SQLite :> es) => LRWConnection label 'Write -> Query -> (Statement -> Eff es a) -> Eff es a+withStatement conn q action =+  unsafeEffWithUnlift @label \unlift -> do+    S.withStatement conn.getConn.getConn q (unlift . action)++bind :: forall label params es. (Labeled label SQLite :> es) => (ToRow params) => Statement -> params -> Eff es ()+bind stmt params = unsafeEff_ $ S.bind stmt params++bindNamed :: forall label es. (Labeled label SQLite :> es) => Statement -> [NamedParam] -> Eff es ()+bindNamed stmt params = unsafeEff_ $ S.bindNamed stmt params++reset :: forall label es. (Labeled label SQLite :> es) => Statement -> Eff es ()+reset stmt = unsafeEff_ $ S.reset stmt++columnName :: forall label es. (Labeled label SQLite :> es) => Statement -> ColumnIndex -> Eff es Text+columnName stmt idx = unsafeEff_ $ S.columnName stmt idx++columnCount :: forall label es. (Labeled label SQLite :> es) => Statement -> Eff es ColumnIndex+columnCount stmt = unsafeEff_ $ S.columnCount stmt++withBind :: forall label params a es. (Labeled label SQLite :> es) => (ToRow params) => Statement -> params -> Eff es a -> Eff es a+withBind stmt params action =+  unsafeEffWithUnlift @label \unlift -> do+    S.withBind stmt params $ unlift action++nextRow :: forall label r es. (Labeled label SQLite :> es) => (FromRow r) => Statement -> Eff es (Maybe r)+nextRow stmt = unsafeEff_ $ S.nextRow stmt++----------------------------------------------------------------------------+-- Utils+----------------------------------------------------------------------------++unsafeEffWithUnlift :: forall label a es. (Labeled label SQLite :> es) => ((forall x. Eff es x -> IO x) -> IO a) -> Eff es a+unsafeEffWithUnlift action =+  unsafeEff \env -> do+    seqUnliftIO env \unlift -> do+      action unlift