diff --git a/src/Effect.Postgres.Error.Except.purs b/src/Effect.Postgres.Error.Except.purs index 49a9a00..d506f52 100644 --- a/src/Effect.Postgres.Error.Except.purs +++ b/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) diff --git a/src/Effect.Postgres.Error.RE.purs b/src/Effect.Postgres.Error.RE.purs index 15d67a9..6976a31 100644 --- a/src/Effect.Postgres.Error.RE.purs +++ b/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.Functor.Compose (Compose) +import Data.Either (Either, blush, hush) +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 - fork m = withRunInBase \f -> fork $ f m - suspend m = withRunInBase \f -> suspend $ f m - join f = lift $ join f +instance (MonadThrow Effect.Error m, MonadFork f m) => MonadFork (Compose f (Either E)) (RE r m) where + fork m = RE $ ReaderT \r -> lift $ Compose <$> fork (toEither m r) + suspend m = RE $ ReaderT \r -> lift $ Compose <$> suspend (toEither m r) + join f = liftEither =<< lift (join $ unwrap f) -instance (MonadKill Effect.Error f m) => MonadKill E f (RE r m) where - kill e f = lift $ kill (toException e) f +instance (MonadKill Effect.Error f m) => MonadKill E (Compose f (Either E)) (RE r m) where + kill e f = lift $ kill (toException e) (unwrap f) -instance (MonadBracket Effect.Error f m) => MonadBracket E f (RE r m) where - bracket acq rel m = withRunInBase \f -> bracket (f acq) (\c r -> f $ rel ((bracketCondError (pure <<< Other)) c) r) (f <<< m) +instance (MonadEffect m, MonadBracket Effect.Error f m) => MonadBracket E (Compose f (Either E)) (RE r m) where + 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 diff --git a/src/Pipes.Postgres.purs b/src/Pipes.Postgres.purs index 9d894f8..e3c1ed2 100644 --- a/src/Pipes.Postgres.purs +++ b/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 - hoist liftAff $ fromWritable $ O.unsafeFromBufferWritable stream + client <- lift ask + 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 - hoist liftAff $ fromReadable $ O.unsafeFromBufferReadable stream + client <- lift ask + stream <- lift $ RE.liftExcept $ hoist liftEffect $ Client.queryWithStdout q client + hoist liftAff $ Pipe.Node.fromReadable $ Node.Stream.Object.unsafeFromBufferReadable stream diff --git a/test/Test.Effect.Postgres.Error.purs b/test/Test.Effect.Postgres.Error.purs new file mode 100644 index 0000000..7fe1249 --- /dev/null +++ b/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 diff --git a/test/Test.Main.purs b/test/Test.Main.purs index de0ae64..fdb8ad9 100644 --- a/test/Test.Main.purs +++ b/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