fix: correct implementations of MonadAff, MonadEffect, Fork, Bracket

src/Effect.Postgres.Error.Except.purs

@@ -4,6 +4,7 @@ import Prelude
 
 import Control.Monad.Error.Class (class MonadError, class MonadThrow, liftEither, try)
 import Control.Monad.Except (ExceptT(..), runExceptT)
+import Control.Monad.Morph (hoist)
 import Data.Bifunctor (lmap)
 import Data.Either (Either)
 import Data.Postgres (RepT)
@@ -29,11 +30,15 @@ withEither e m = ExceptT $ map (lmap $ pure <<< e) $ m
 exception :: forall m a. MonadError Effect.Error m => m a -> Except m a
 exception = with Other
 
-parsing :: forall m a. MonadEffect m => Query -> RepT a -> Except m a
-parsing q = withEither (Deserializing q) <<< liftEffect <<< runExceptT
-
-printing :: forall m a. MonadEffect m => RepT a -> Except m a
-printing = withEither Serializing <<< liftEffect <<< runExceptT
-
 executing :: forall m a. MonadError Effect.Error m => Query -> m a -> Except m a
 executing q = with (Executing q)
+
+parsing :: forall m a. MonadEffect m => Query -> RepT a -> Except m a
+parsing q m = do
+  e <- hoist liftEffect $ exception $ runExceptT m
+  withEither (Deserializing q) (pure e)
+
+printing :: forall m a. MonadEffect m => RepT a -> Except m a
+printing m = do
+  e <- hoist liftEffect $ exception $ runExceptT m
+  withEither Serializing (pure e)

src/Effect.Postgres.Error.RE.purs

@@ -5,26 +5,32 @@ import Prelude hiding (join)
 import Control.Alt (class Alt)
 import Control.Alternative (class Alternative, class Plus)
 import Control.Monad.Base (class MonadBase)
-import Control.Monad.Error.Class (class MonadError, class MonadThrow, catchError, liftEither, throwError)
+import Control.Monad.Error.Class (class MonadError, class MonadThrow, catchError, liftEither, liftMaybe, throwError)
 import Control.Monad.Except (ExceptT, runExceptT)
-import Control.Monad.Fork.Class (class MonadBracket, class MonadFork, class MonadKill, BracketCondition, bracket, fork, join, kill, never, suspend, uninterruptible)
+import Control.Monad.Fork.Class (class MonadBracket, class MonadFork, class MonadKill, bracket, fork, join, kill, never, suspend, uninterruptible)
 import Control.Monad.Fork.Class as Bracket
 import Control.Monad.Morph (class MFunctor, class MMonad, embed, hoist)
-import Control.Monad.Reader (class MonadAsk, class MonadReader, ReaderT(..), runReaderT)
+import Control.Monad.Reader (class MonadAsk, class MonadReader, ReaderT(..), ask, runReaderT)
 import Control.Monad.Rec.Class (class MonadRec)
 import Control.Monad.Trans.Class (class MonadTrans, lift)
-import Control.Monad.Unlift (class MonadUnlift, withRunInBase)
+import Control.Monad.Unlift (class MonadUnlift)
 import Control.Parallel (class Parallel, parallel, sequential)
+import Data.Array.NonEmpty as Array.NonEmpty
 import Data.Bifunctor (lmap)
-import Data.Either (Either)
+import Data.Either (Either, blush, hush)
-import Data.Functor.Compose (Compose)
+import Data.Functor.Compose (Compose(..))
+import Data.Maybe (Maybe(..), fromMaybe)
 import Data.Newtype (class Newtype, unwrap, wrap)
-import Effect.Aff.Class (class MonadAff)
+import Data.Traversable (for_, traverse_)
+import Effect.Aff.Class (class MonadAff, liftAff)
 import Effect.Aff.Unlift (class MonadUnliftAff, withRunInAff)
-import Effect.Class (class MonadEffect)
+import Effect.Class (class MonadEffect, liftEffect)
 import Effect.Exception as Effect
+import Effect.Exception as Exception
 import Effect.Postgres.Error.Common (E, Error(..), toException)
 import Effect.Postgres.Error.Except (Except)
+import Effect.Postgres.Error.Except as E
+import Effect.Ref as Ref
 import Effect.Unlift (class MonadUnliftEffect, withRunInEffect)
 
 -- | `ReaderT` with `ExceptT E`
@@ -67,10 +73,14 @@ derive newtype instance Monad m => Bind (RE r m)
 derive newtype instance Monad m => Monad (RE r m)
 derive newtype instance Monad m => MonadError E (RE r m)
 derive newtype instance Monad m => MonadThrow E (RE r m)
-derive newtype instance MonadEffect m => MonadEffect (RE r m)
-derive newtype instance MonadAff m => MonadAff (RE r m)
 derive newtype instance MonadRec m => MonadRec (RE r m)
 
+instance MonadEffect m => MonadEffect (RE r m) where
+  liftEffect m = hoist liftEffect $ liftExcept $ E.exception m
+
+instance MonadAff m => MonadAff (RE r m) where
+  liftAff m = hoist liftAff $ liftExcept $ E.exception m
+
 instance (Monad m, Parallel p m) => Parallel (ParRE r p) (RE r m) where
   parallel = wrap <<< parallel <<< unwrap
   sequential = wrap <<< sequential <<< unwrap
@@ -101,20 +111,47 @@ instance (MonadBase m (RE r m), MonadThrow Effect.Error m) => MonadUnlift m (RE
 instance Monad m => MonadBase m (RE r m) where
   liftBase = lift
 
-instance (MonadThrow Effect.Error m, MonadFork f m) => MonadFork f (RE r m) where
+instance (MonadThrow Effect.Error m, MonadFork f m) => MonadFork (Compose f (Either E)) (RE r m) where
-  fork m = withRunInBase \f -> fork $ f m
+  fork m = RE $ ReaderT \r -> lift $ Compose <$> fork (toEither m r)
-  suspend m = withRunInBase \f -> suspend $ f m
+  suspend m = RE $ ReaderT \r -> lift $ Compose <$> suspend (toEither m r)
-  join f = lift $ join f
+  join f = liftEither =<< lift (join $ unwrap f)
 
-instance (MonadKill Effect.Error f m) => MonadKill E f (RE r m) where
+instance (MonadKill Effect.Error f m) => MonadKill E (Compose f (Either E)) (RE r m) where
-  kill e f = lift $ kill (toException e) f
+  kill e f = lift $ kill (toException e) (unwrap f)
 
-instance (MonadBracket Effect.Error f m) => MonadBracket E f (RE r m) where
+instance (MonadEffect m, MonadBracket Effect.Error f m) => MonadBracket E (Compose f (Either E)) (RE r m) where
-  bracket acq rel m = withRunInBase \f -> bracket (f acq) (\c r -> f $ rel ((bracketCondError (pure <<< Other)) c) r) (f <<< m)
+  bracket acq rel go = do
+    r <- ask
+
+    errs <- liftEffect $ Ref.new []
+
+    let
+      eErrsEmpty = pure $ Other $ Exception.error "no errors"
+      appendErrs = liftEffect <<< flip Ref.modify_ errs <<< (<>) <<< Array.NonEmpty.toArray
+      readErrs = liftEffect $ Array.NonEmpty.fromArray <$> Ref.read errs
+
+      run' :: forall a. RE r m a -> m (Maybe a)
+      run' m = do
+        either <- toEither m r
+        traverse_ appendErrs $ blush either
+        pure $ hush either
+
+      rel' _ Nothing = pure unit
+      rel' (Bracket.Failed e) (Just a) = void $ run' $ rel (Bracket.Failed $ pure $ Other e) a
+      rel' (Bracket.Killed e) (Just a) = void $ run' $ rel (Bracket.Killed $ pure $ Other e) a
+      rel' (Bracket.Completed (Just ret)) (Just a) = void $ run' $ rel (Bracket.Completed ret) a
+      rel' (Bracket.Completed Nothing) (Just a) = void $ run' do
+        errs' <- fromMaybe eErrsEmpty <$> readErrs
+        rel (Bracket.Failed errs') a
+
+      acq' = run' acq
+
+      go' (Just a) = run' $ go a
+      go' Nothing = pure Nothing
+
+    ret <- lift $ bracket acq' rel' go'
+    errs' <- readErrs
+    for_ errs' throwError
+    liftMaybe eErrsEmpty ret
   uninterruptible = hoist uninterruptible
   never = lift never
-
-bracketCondError :: forall ea eb a. (ea -> eb) -> BracketCondition ea a -> BracketCondition eb a
-bracketCondError _ (Bracket.Completed a) = Bracket.Completed a
-bracketCondError f (Bracket.Failed a) = Bracket.Failed $ f a
-bracketCondError f (Bracket.Killed a) = Bracket.Killed $ f a

src/Pipes.Postgres.purs

@@ -4,20 +4,26 @@ import Prelude
 
 import Control.Monad.Cont (lift)
 import Control.Monad.Morph (hoist)
-import Control.Monad.Postgres (class MonadSession, streamIn, streamOut)
+import Control.Monad.Postgres (SessionT)
+import Control.Monad.Reader (ask)
 import Data.Maybe (Maybe)
-import Effect.Aff.Class (liftAff)
+import Effect.Aff.Class (class MonadAff, liftAff)
+import Effect.Aff.Postgres.Client as Client
+import Effect.Class (liftEffect)
+import Effect.Postgres.Error.RE as RE
 import Node.Buffer (Buffer)
-import Node.Stream.Object as O
+import Node.Stream.Object as Node.Stream.Object
 import Pipes.Core (Consumer, Producer)
-import Pipes.Node.Stream (fromReadable, fromWritable)
+import Pipes.Node.Stream as Pipe.Node
 
-stdin :: forall m. MonadSession m => String -> Consumer (Maybe Buffer) m Unit
+stdin :: forall m. MonadAff m => String -> Consumer (Maybe Buffer) (SessionT m) Unit
 stdin q = do
-  stream <- lift $ streamIn q
+  client <- lift ask
-  hoist liftAff $ fromWritable $ O.unsafeFromBufferWritable stream
+  stream <- lift $ RE.liftExcept $ hoist liftEffect $ Client.execWithStdin q client
+  hoist liftAff $ Pipe.Node.fromWritable $ Node.Stream.Object.unsafeFromBufferWritable stream
 
-stdout :: forall m. MonadSession m => String -> Producer (Maybe Buffer) m Unit
+stdout :: forall m. MonadAff m => String -> Producer (Maybe Buffer) (SessionT m) Unit
 stdout q = do
-  stream <- lift $ streamOut q
+  client <- lift ask
-  hoist liftAff $ fromReadable $ O.unsafeFromBufferReadable stream
+  stream <- lift $ RE.liftExcept $ hoist liftEffect $ Client.queryWithStdout q client
+  hoist liftAff $ Pipe.Node.fromReadable $ Node.Stream.Object.unsafeFromBufferReadable stream

test/Test.Effect.Postgres.Error.purs

@@ -0,0 +1,135 @@
+module Test.Effect.Postgres.Error where
+
+import Prelude hiding (join)
+
+import Control.Monad.Cont (lift)
+import Control.Monad.Error.Class (throwError)
+import Control.Monad.Fork.Class (bracket, fork, join)
+import Control.Parallel (parOneOf, parSequence)
+import Data.Either (isLeft)
+import Data.Newtype (wrap)
+import Data.Postgres (deserialize)
+import Data.Postgres.Query (stringQuery)
+import Data.Postgres.Raw (Raw)
+import Effect.Aff (Aff, delay)
+import Effect.Aff.Class (liftAff)
+import Effect.Class (liftEffect)
+import Effect.Exception as Exn
+import Effect.Postgres.Error (Error(..))
+import Effect.Postgres.Error.Except as E
+import Effect.Postgres.Error.RE (RE)
+import Effect.Postgres.Error.RE as RE
+import Test.Common (withPoolClient)
+import Test.Spec (Spec, around, describe, it)
+import Test.Spec.Assertions (shouldEqual)
+import Unsafe.Coerce (unsafeCoerce)
+
+spec :: Spec Unit
+spec =
+  around withPoolClient $ describe "Effect.Postgres.Error" do
+    describe "Except" do
+      it "catches Aff" $ const do
+        either <- E.toEither $ E.exception (throwError $ Exn.error "foo")
+        isLeft either `shouldEqual` true
+      it "catches Effect" $ const do
+        either <- liftEffect $ E.toEither $ E.exception (throwError $ Exn.error "foo")
+        isLeft either `shouldEqual` true
+      it "catches RepT" $ const do
+        let
+          parse = deserialize @Int (unsafeCoerce "foo" :: Raw)
+        either <- liftEffect $ E.toEither $ E.parsing (stringQuery "select 'foo'") parse
+        isLeft either `shouldEqual` true
+      it "catches Effect exception in RepT" $ const do
+        let
+          parse = lift $ throwError $ Exn.error "foo"
+        either <- liftEffect $ E.toEither $ E.parsing (stringQuery "select 'foo'") parse
+        isLeft either `shouldEqual` true
+    describe "RE" do
+      it "liftAff catches exceptions" $ const do
+        either <- RE.toEither (liftAff $ throwError $ Exn.error "foo") unit
+        isLeft either `shouldEqual` true
+      it "liftEffect catches exceptions" $ const do
+        either <- RE.toEither (liftEffect $ throwError $ Exn.error "foo") unit
+        isLeft either `shouldEqual` true
+      it "liftExcept catches exceptions" $ const do
+        either <- RE.toEither (throwError $ pure $ Other $ Exn.error "foo") unit
+        isLeft either `shouldEqual` true
+      it "fork > join catches Fiber exceptions" $ const do
+        either <- flip RE.toEither unit do
+          fiber <- fork (liftAff $ throwError $ Exn.error "foo") :: RE Unit Aff _
+          liftAff $ delay $ wrap 1.0
+          join fiber
+        isLeft either `shouldEqual` true
+      it "bracket catches error in acq" $ const do
+        either <-
+          flip RE.toEither unit
+          $ bracket
+              (liftAff $ throwError $ Exn.error "foo")
+              (const $ const $ pure unit)
+              (const $ pure unit)
+        isLeft either `shouldEqual` true
+      it "bracket catches error in rel" $ const do
+        either <-
+          flip RE.toEither unit
+          $ bracket
+              (pure unit)
+              (const $ const $ liftAff $ throwError $ Exn.error "foo")
+              (const $ pure unit)
+        isLeft either `shouldEqual` true
+      it "bracket catches error in go" $ const do
+        either <-
+          flip RE.toEither unit
+          $ bracket
+              (pure unit)
+              (const $ const $ pure unit)
+              (const $ liftAff $ throwError $ Exn.error "foo")
+        isLeft either `shouldEqual` true
+      it "forked bracket catches error in acq" $ const do
+        either <- flip RE.toEither unit do
+          fiber <-
+            fork
+            $ bracket
+                (liftAff $ throwError $ Exn.error "foo")
+                (const $ const $ pure unit)
+                (const $ pure unit)
+          liftAff $ delay $ wrap 1.0
+          join fiber
+        isLeft either `shouldEqual` true
+      it "forked bracket catches error in rel" $ const do
+        either <- flip RE.toEither unit do
+          fiber <-
+            fork
+            $ bracket
+              (pure unit)
+              (const $ const $ liftAff $ throwError $ Exn.error "foo")
+              (const $ pure unit)
+          liftAff $ delay $ wrap 1.0
+          join fiber
+        isLeft either `shouldEqual` true
+      it "forked bracket catches error in go" $ const do
+        either <- flip RE.toEither unit do
+          fiber <-
+            fork
+            $ bracket
+              (pure unit)
+              (const $ const $ pure unit)
+              (const $ liftAff $ throwError $ Exn.error "foo")
+          liftAff $ delay $ wrap 1.0
+          join fiber
+        isLeft either `shouldEqual` true
+      it "catches errors in `parSequence`" $ const do
+        either <-
+          flip RE.toEither unit
+            $ parSequence
+            $ [ liftAff $ throwError $ Exn.error "a"
+              , pure "a"
+              ]
+        isLeft either `shouldEqual` true
+      it "catches errors in `parOneOf`" $ const do
+        either <-
+          flip RE.toEither unit
+            $ parOneOf
+            $ [ liftAff $ throwError $ Exn.error "a"
+              , liftAff $ throwError $ Exn.error "b"
+              ]
+        isLeft either `shouldEqual` true

test/Test.Main.purs

@@ -25,6 +25,7 @@ import Test.Data.Postgres as Test.Data.Postgres
 import Test.Data.Postgres.Custom as Test.Data.Postgres.Custom
 import Test.Data.Postgres.Interval as Test.Data.Postgres.Interval
 import Test.Effect.Postgres.Client as Test.Effect.Postgres.Client
+import Test.Effect.Postgres.Error as Test.Effect.Postgres.Error
 import Test.Effect.Postgres.Pool as Test.Effect.Postgres.Pool
 import Test.Spec.Reporter (specReporter)
 import Test.Spec.Runner (runSpec)
@@ -64,6 +65,7 @@ main = launchAff_ do
   bracket spawnDb killDb
     $ const
     $ runSpec [ specReporter ] do
+        Test.Effect.Postgres.Error.spec
         Test.Data.Postgres.Custom.spec
         Test.Data.Postgres.spec
         Test.Data.Postgres.Interval.spec