feat: generalize PostgresT to MonadPostgres to allow mocking

src/Control.Monad.Postgres.Base.purs

@@ -7,19 +7,23 @@ import Control.Alternative (class Plus)
 import Control.Monad.Error.Class (class MonadError, class MonadThrow, catchError, throwError)
 import Control.Monad.Fork.Class (class MonadBracket, class MonadFork, class MonadKill, bracket, kill, never, uninterruptible)
 import Control.Monad.Morph (class MFunctor, class MMonad)
+import Control.Monad.Postgres.Cursor (class MonadCursor, CursorT)
 import Control.Monad.Postgres.Session (class MonadSession, SessionT, exec, exec_, query)
 import Control.Monad.Reader (class MonadAsk, class MonadReader, ReaderT, ask, local, runReaderT)
 import Control.Monad.Rec.Class (class MonadRec)
 import Control.Monad.Trans.Class (class MonadTrans, lift)
 import Control.Parallel (class Parallel, parallel, sequential)
 import Data.Newtype (class Newtype, unwrap, wrap)
-import Effect.Aff (Fiber)
+import Data.Postgres (RepT)
+import Data.Postgres.Query (class AsQuery, asQuery)
+import Data.Postgres.Raw (Raw)
+import Data.Postgres.Result (class FromRow, fromRow)
+import Data.Tuple.Nested ((/\))
 import Effect.Aff.Class (class MonadAff, liftAff)
 import Effect.Aff.Postgres.Pool (Pool)
 import Effect.Aff.Postgres.Pool as Pool
 import Effect.Aff.Unlift (class MonadUnliftAff)
 import Effect.Class (class MonadEffect, liftEffect)
-import Effect.Exception (Error)
 import Effect.Unlift (class MonadUnliftEffect)
 import Prim.Row (class Union)
 
@@ -92,29 +96,48 @@ instance (MonadBracket e f m, MonadAff m) => MonadSession (PostgresT m) where
   exec = session <<< exec
   exec_ = session <<< exec_
 
--- | Lifts a session to `PostgresT`, releasing the client to the pool
--- | after execution.
-session :: forall e f m a. MonadBracket e f m => MonadAff m => MonadSession (SessionT m) => SessionT m a -> PostgresT m a
-session m = do
-  pool <- ask
-  let
-    acq = liftAff $ Pool.connect pool
-    rel _ c = liftEffect $ Pool.release pool c
-  lift $ bracket acq rel (runReaderT m)
-
--- | Lifts a session to `PostgresT`, running the session
--- | in a transaction.
+-- | Typeclass generalizing `PostgresT`. Allows for dependency-injecting different
+-- | implementations of the idea of a postgres connection.
 -- |
--- | If the session throws an error, the transaction will be
--- | rolled back and the error rethrown.
-transaction :: forall m a. MonadBracket Error Fiber m => MonadAff m => MonadSession (SessionT m) => SessionT m a -> PostgresT m a
-transaction m =
-  let
-    begin = void $ exec "begin;"
-    commit = m <* exec "commit;"
-    rollback e = exec "rollback;" *> throwError e
-  in
-    session $ begin *> catchError commit rollback
+-- | - `session` - Session monad (for `PostgresT` this is `SessionT`)
+-- | - `cursor` - Cursor session monad (for `PostgresT` this is `CursorT`)
+-- | - `ct` - Open type parameter for cursor type. Don't pin this to a concrete type.
+class (MonadSession session, MonadCursor cursor ct) <= MonadPostgres m session cursor ct | m -> ct cursor session where
+  -- | Run a session in `m`.
+  session :: session ~> m
+  -- | Run a session in `m`, wrapped in a transaction.
+  -- |
+  -- | If any errors are raised, the transaction is rolled back and
+  -- | the error rethrown.
+  transaction :: session ~> m
+  -- | `cursor`, but using a custom deserialize function for the data
+  -- | yielded by the cursor
+  cursorWith :: forall q. AsQuery q => (Array Raw -> RepT ct) -> String -> q -> cursor ~> m
+
+instance (MonadBracket e f m, MonadAff m, MonadSession (SessionT m), MonadCursor (CursorT t (SessionT m)) t) => MonadPostgres (PostgresT m) (SessionT m) (CursorT ct (SessionT m)) ct where
+  session m = do
+    pool <- ask
+    let
+      acq = liftAff $ Pool.connect pool
+      rel _ c = liftEffect $ Pool.release pool c
+    lift $ bracket acq rel (runReaderT m)
+  transaction m =
+    let
+      begin = void $ exec "begin;"
+      commit = m <* exec "commit;"
+      rollback e = exec "rollback;" *> throwError e
+    in
+      session $ begin *> catchError commit rollback
+  cursorWith f cur q m =
+    transaction do
+      q' <- liftEffect $ asQuery q
+      exec_ $ "declare " <> cur <> " cursor for (" <> (unwrap q').text <> ");"
+      runReaderT (unwrap m) (cur /\ f)
+
+-- | Create a server-side cursor for a query in a transaction,
+-- | and execute a `CursorT` with a view to the new cursor.
+cursor :: forall @cursort t session cursor q a. MonadPostgres t session cursor cursort => AsQuery q => FromRow cursort => String -> q -> cursor a -> t a
+cursor = cursorWith fromRow
 
 -- | Execute a `PostgresT` using an existing connection pool.
 -- |

src/Control.Monad.Postgres.Cursor.purs

@@ -6,9 +6,8 @@ import Control.Alt (class Alt)
 import Control.Alternative (class Plus)
 import Control.Monad.Error.Class (class MonadError, class MonadThrow)
 import Control.Monad.Fork.Class (class MonadBracket, class MonadFork, class MonadKill, bracket, kill, never, uninterruptible)
-import Control.Monad.Postgres.Base (PostgresT, transaction)
-import Control.Monad.Postgres.Session (class MonadSession, SessionT, exec, exec_, query)
-import Control.Monad.Reader (class MonadAsk, class MonadReader, ReaderT, ask, local, runReaderT)
+import Control.Monad.Postgres.Session (class MonadSession, exec, exec_, query)
+import Control.Monad.Reader (class MonadAsk, class MonadReader, ReaderT, ask, local)
 import Control.Monad.Rec.Class (class MonadRec)
 import Control.Monad.Trans.Class (class MonadTrans, lift)
 import Control.Parallel (class Parallel, parallel, sequential)
@@ -16,16 +15,12 @@ import Data.Array as Array
 import Data.Maybe (Maybe)
 import Data.Newtype (class Newtype, unwrap, wrap)
 import Data.Postgres (RepT, smash)
-import Data.Postgres.Query (class AsQuery, asQuery)
 import Data.Postgres.Raw (Raw)
-import Data.Postgres.Result (class FromRow, fromRow)
 import Data.Traversable (traverse)
 import Data.Tuple.Nested (type (/\), (/\))
-import Effect.Aff (Fiber)
 import Effect.Aff.Class (class MonadAff)
 import Effect.Aff.Unlift (class MonadUnliftAff)
 import Effect.Class (class MonadEffect, liftEffect)
-import Effect.Exception (Error)
 import Effect.Unlift (class MonadUnliftEffect)
 
 newtype CursorT :: forall k. Type -> (k -> Type) -> k -> Type
@@ -112,17 +107,3 @@ instance (MonadSession m) => MonadSession (CursorT t m) where
 -- | Fetch the next row from the cursor
 fetchOne :: forall m t. MonadCursor m t => m (Maybe t)
 fetchOne = Array.head <$> fetch 1
-
--- | Create a server-side cursor for a query in a transaction,
--- | and execute a `CursorT` with a view to the new cursor.
-cursor :: forall m @t a q. FromRow t => AsQuery q => MonadAff m => MonadBracket Error Fiber m => MonadSession (SessionT m) => String -> q -> CursorT t (SessionT m) a -> PostgresT m a
-cursor cur q m = cursorWith cur q fromRow m
-
--- | `cursor`, but using a custom deserialize function for the data
--- | yielded by the cursor
-cursorWith :: forall m @t a q. AsQuery q => MonadAff m => MonadBracket Error Fiber m => MonadSession (SessionT m) => String -> q -> (Array Raw -> RepT t) -> CursorT t (SessionT m) a -> PostgresT m a
-cursorWith cur q f m =
-  transaction do
-    q' <- liftEffect $ asQuery q
-    exec_ $ "declare " <> cur <> " cursor for (" <> (unwrap q').text <> ");"
-    runReaderT (unwrap m) (cur /\ f)