From ee73f4e5045d7f0d7b0925d808063b0e188a64b4 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Fri, 19 Apr 2024 07:26:53 +0300 Subject: [PATCH 01/33] Switch to newer libpq --- cabal.project | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/cabal.project b/cabal.project index e6fdbad..38aa2e7 100644 --- a/cabal.project +++ b/cabal.project @@ -1 +1,9 @@ packages: . + +source-repository-package + type: git + location: https://github.com/GulinSS/postgresql-libpq/ + tag: 30b69e55855cabf3356e186c30a1756b4b0c6c95 + +allow-newer: + postgresql-libpq:base From f1fa1f86dd1d366067773501da735475f6662452 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Fri, 19 Apr 2024 08:01:49 +0300 Subject: [PATCH 02/33] Sketch Pipeline No testing has been done yet --- hasql.cabal | 3 ++ library/Hasql/Decoders/Result.hs | 7 +++- library/Hasql/Encoders/Params.hs | 7 ++++ library/Hasql/Pipeline.hs | 7 ++++ library/Hasql/Pipeline/Core.hs | 66 ++++++++++++++++++++++++++++++++ library/Hasql/Session/Core.hs | 18 ++++----- 6 files changed, 98 insertions(+), 10 deletions(-) create mode 100644 library/Hasql/Pipeline.hs create mode 100644 library/Hasql/Pipeline/Core.hs diff --git a/hasql.cabal b/hasql.cabal index c7c2719..0ea4f23 100644 --- a/hasql.cabal +++ b/hasql.cabal @@ -31,6 +31,7 @@ common base NoMonomorphismRestriction Arrows BangPatterns + BlockArguments ConstraintKinds DataKinds DefaultSignatures @@ -82,6 +83,7 @@ library Hasql.Connection Hasql.Decoders Hasql.Encoders + Hasql.Pipeline Hasql.Session Hasql.Statement @@ -101,6 +103,7 @@ library Hasql.Encoders.Value Hasql.Errors Hasql.IO + Hasql.Pipeline.Core Hasql.PostgresTypeInfo Hasql.Prelude Hasql.PreparedStatementRegistry diff --git a/library/Hasql/Decoders/Result.hs b/library/Hasql/Decoders/Result.hs index 8bd3d55..434bbe9 100644 --- a/library/Hasql/Decoders/Result.hs +++ b/library/Hasql/Decoders/Result.hs @@ -25,6 +25,7 @@ noResult = checkExecStatus $ \case LibPQ.CommandOk -> True LibPQ.TuplesOk -> True + LibPQ.PipelineSync -> True _ -> False {-# INLINE rowsAffected #-} @@ -66,7 +67,11 @@ checkExecStatus predicate = LibPQ.NonfatalError -> serverError LibPQ.FatalError -> serverError LibPQ.EmptyQuery -> return () - _ -> Result $ lift $ ExceptT $ pure $ Left $ UnexpectedResult $ "Unexpected result status: " <> (fromString $ show status) + _ -> unexpectedResult $ "Unexpected result status: " <> (fromString $ show status) + +unexpectedResult :: Text -> Result a +unexpectedResult = + Result . lift . ExceptT . pure . Left . UnexpectedResult {-# INLINE serverError #-} serverError :: Result () diff --git a/library/Hasql/Encoders/Params.hs b/library/Hasql/Encoders/Params.hs index de4cd81..43cd779 100644 --- a/library/Hasql/Encoders/Params.hs +++ b/library/Hasql/Encoders/Params.hs @@ -7,6 +7,13 @@ import Hasql.Prelude import PostgreSQL.Binary.Encoding qualified as B import Text.Builder qualified as E +renderReadable :: Params a -> a -> [Text] +renderReadable (Params (Op encoderOp)) params = + foldr step [] (encoderOp params) + where + step (_, _, _, rendering) acc = + rendering : acc + -- | -- Encoder of some representation of a parameters product. newtype Params a diff --git a/library/Hasql/Pipeline.hs b/library/Hasql/Pipeline.hs new file mode 100644 index 0000000..dce834f --- /dev/null +++ b/library/Hasql/Pipeline.hs @@ -0,0 +1,7 @@ +module Hasql.Pipeline + ( Pipeline, + statement, + ) +where + +import Hasql.Pipeline.Core diff --git a/library/Hasql/Pipeline/Core.hs b/library/Hasql/Pipeline/Core.hs new file mode 100644 index 0000000..440fd20 --- /dev/null +++ b/library/Hasql/Pipeline/Core.hs @@ -0,0 +1,66 @@ +module Hasql.Pipeline.Core where + +import Database.PostgreSQL.LibPQ qualified as Pq +import Hasql.Connection.Core qualified as Connection +import Hasql.Decoders.All qualified as Decoders +import Hasql.Encoders.All qualified as Encoders +import Hasql.Encoders.Params qualified as Encoders.Params +import Hasql.Errors +import Hasql.IO qualified as IO +import Hasql.Prelude +import Hasql.PreparedStatementRegistry qualified as PreparedStatementRegistry +import Hasql.Statement qualified as Statement + +run :: Pipeline a -> Connection.Connection -> IO (Either QueryError a) +run (Pipeline send recv) (Connection.Connection pqConnectionRef integerDatetimes registry) = + withMVar pqConnectionRef \pqConnection -> do + Pq.enterPipelineMode pqConnection + sendResult <- send pqConnection integerDatetimes registry + Pq.pipelineSync pqConnection + recvResult <- recv pqConnection integerDatetimes + Pq.exitPipelineMode pqConnection + pure (sendResult *> recvResult) + +data Pipeline a + = Pipeline + -- | Send commands. + (Pq.Connection -> Bool -> PreparedStatementRegistry.PreparedStatementRegistry -> IO (Either QueryError ())) + -- | Receive results. + (Pq.Connection -> Bool -> IO (Either QueryError a)) + deriving (Functor) + +instance Applicative Pipeline where + pure a = + Pipeline send recv + where + send _ _ _ = + pure (Right ()) + recv _ _ = + pure (Right a) + + Pipeline lSend lRecv <*> Pipeline rSend rRecv = + Pipeline send recv + where + send pqConn idt pReg = do + lSendRes <- lSend pqConn idt pReg + rSendRes <- rSend pqConn idt pReg + pure (lSendRes *> rSendRes) + recv pqConn idt = do + lRecvRes <- lRecv pqConn idt + rRecvRes <- rRecv pqConn idt + pure (lRecvRes <*> rRecvRes) + +statement :: params -> Statement.Statement params result -> Pipeline result +statement params (Statement.Statement template (Encoders.Params paramsEncoder) (Decoders.Result decoder) preparable) = + Pipeline send recv + where + send pqConnection integerDatetimes registry = + mapLeft commandToQueryError + <$> IO.sendParametricStatement pqConnection integerDatetimes registry template paramsEncoder preparable params + + recv pqConnection integerDatetimes = + mapLeft commandToQueryError + <$> IO.getResults pqConnection integerDatetimes decoder + + commandToQueryError = + QueryError template (Encoders.Params.renderReadable paramsEncoder params) diff --git a/library/Hasql/Session/Core.hs b/library/Hasql/Session/Core.hs index f57c9d0..1b7176e 100644 --- a/library/Hasql/Session/Core.hs +++ b/library/Hasql/Session/Core.hs @@ -1,12 +1,14 @@ module Hasql.Session.Core where import Hasql.Connection.Core qualified as Connection +import Hasql.Decoders.All qualified as Decoders import Hasql.Decoders.Result qualified as Decoders.Result import Hasql.Decoders.Results qualified as Decoders.Results import Hasql.Encoders.All qualified as Encoders import Hasql.Encoders.Params qualified as Encoders.Params import Hasql.Errors import Hasql.IO qualified as IO +import Hasql.Pipeline.Core qualified as Pipeline import Hasql.Prelude import Hasql.Statement qualified as Statement @@ -46,20 +48,18 @@ sql sql = -- | -- Parameters and a specification of a parametric single-statement query to apply them to. statement :: params -> Statement.Statement params result -> Session result -statement input (Statement.Statement template (Encoders.Params paramsEncoder) decoder preparable) = +statement input (Statement.Statement template (Encoders.Params paramsEncoder) (Decoders.Result decoder) preparable) = Session $ ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) -> ExceptT - $ fmap (mapLeft (QueryError template inputReps)) + $ fmap (mapLeft (QueryError template (Encoders.Params.renderReadable paramsEncoder input))) $ withMVar pqConnectionRef $ \pqConnection -> do r1 <- IO.sendParametricStatement pqConnection integerDatetimes registry template paramsEncoder preparable input - r2 <- IO.getResults pqConnection integerDatetimes (unsafeCoerce decoder) + r2 <- IO.getResults pqConnection integerDatetimes decoder return $ r1 *> r2 - where - inputReps = - let Encoders.Params.Params (Op encoderOp) = paramsEncoder - step (_, _, _, rendering) acc = - rendering : acc - in foldr step [] (encoderOp input) + +pipeline :: Pipeline.Pipeline result -> Session result +pipeline pipeline = + Session $ ReaderT $ ExceptT . Pipeline.run pipeline From b587235bc6387e13ac4f23b0ee5d83abba1ddfa7 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sat, 20 Apr 2024 16:40:11 +0300 Subject: [PATCH 03/33] Add test --- hasql.cabal | 19 +++++++- hspec/Hasql/PipelineSpec.hs | 24 ++++++++++ hspec/Main.hs | 1 + library/Hasql/Session.hs | 1 + .../TestingUtils/Statements/GenerateSeries.hs | 44 +++++++++++++++++++ .../Hasql/TestingUtils/TestingDsl.hs | 13 ++++++ 6 files changed, 101 insertions(+), 1 deletion(-) create mode 100644 hspec/Hasql/PipelineSpec.hs create mode 100644 hspec/Main.hs create mode 100644 testing-utils/Hasql/TestingUtils/Statements/GenerateSeries.hs diff --git a/hasql.cabal b/hasql.cabal index 138ff2a..ea9f460 100644 --- a/hasql.cabal +++ b/hasql.cabal @@ -28,6 +28,7 @@ common base default-language: Haskell2010 default-extensions: Arrows + ApplicativeDo BangPatterns BlockArguments ConstraintKinds @@ -53,6 +54,7 @@ common base NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings + OverloadedRecordDot ParallelListComp PatternGuards QuasiQuotes @@ -145,7 +147,7 @@ library testing-utils exposed-modules: Hasql.TestingUtils.Constants Hasql.TestingUtils.TestingDsl - + Hasql.TestingUtils.Statements.GenerateSeries build-depends: hasql, rerebase <2, @@ -203,3 +205,18 @@ test-suite profiling build-depends: hasql, rerebase >=1 && <2, + +test-suite hspec + import: test + type: exitcode-stdio-1.0 + hs-source-dirs: hspec + main-is: Main.hs + other-modules: + Hasql.PipelineSpec + + + build-tool-depends: hspec-discover:hspec-discover + build-depends: + hasql:testing-utils, + hspec, + rerebase >=1 && <2, diff --git a/hspec/Hasql/PipelineSpec.hs b/hspec/Hasql/PipelineSpec.hs new file mode 100644 index 0000000..214ef7f --- /dev/null +++ b/hspec/Hasql/PipelineSpec.hs @@ -0,0 +1,24 @@ +module Hasql.PipelineSpec (spec) where + +import Hasql.TestingUtils.Statements.GenerateSeries qualified as GenerateSeries +import Hasql.TestingUtils.TestingDsl qualified as Dsl +import Test.Hspec +import Prelude + +spec :: Spec +spec = do + describe "Normally" do + describe "On prepared statements" do + it "Collects results" do + _result <- + Dsl.runPipelineOnLocalDb + $ (,) + <$> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 1000} + <*> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 1000} + pending + describe "On unprepared statements" do + it "Works" do + pending + describe "When some part fails" do + it "Works" do + pending diff --git a/hspec/Main.hs b/hspec/Main.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/hspec/Main.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/library/Hasql/Session.hs b/library/Hasql/Session.hs index 6f3a370..7969023 100644 --- a/library/Hasql/Session.hs +++ b/library/Hasql/Session.hs @@ -2,6 +2,7 @@ module Hasql.Session ( Session, sql, statement, + pipeline, -- * Execution run, diff --git a/testing-utils/Hasql/TestingUtils/Statements/GenerateSeries.hs b/testing-utils/Hasql/TestingUtils/Statements/GenerateSeries.hs new file mode 100644 index 0000000..bb0e4b4 --- /dev/null +++ b/testing-utils/Hasql/TestingUtils/Statements/GenerateSeries.hs @@ -0,0 +1,44 @@ +module Hasql.TestingUtils.Statements.GenerateSeries where + +import Hasql.Decoders qualified as Decoders +import Hasql.Encoders qualified as Encoders +import Hasql.Pipeline qualified as Pipeline +import Hasql.Session qualified as Session +import Hasql.Statement qualified as Statement +import Prelude + +data Params = Params + { start :: Int64, + end :: Int64 + } + +type Result = Vector Int64 + +session :: Bool -> Params -> Session.Session Result +session prepared params = + Session.statement params (statement prepared) + +pipeline :: Bool -> Params -> Pipeline.Pipeline Result +pipeline prepared params = + Pipeline.statement params (statement prepared) + +statement :: Bool -> Statement.Statement Params Result +statement = + Statement.Statement sql encoder decoder + +sql :: ByteString +sql = + "SELECT generate_series($1, $2)" + +encoder :: Encoders.Params Params +encoder = + mconcat + [ (.start) >$< Encoders.param (Encoders.nonNullable Encoders.int8), + (.end) >$< Encoders.param (Encoders.nonNullable Encoders.int8) + ] + +decoder :: Decoders.Result Result +decoder = + Decoders.rowVector + ( Decoders.column (Decoders.nonNullable Decoders.int8) + ) diff --git a/testing-utils/Hasql/TestingUtils/TestingDsl.hs b/testing-utils/Hasql/TestingUtils/TestingDsl.hs index c5cacfb..59144aa 100644 --- a/testing-utils/Hasql/TestingUtils/TestingDsl.hs +++ b/testing-utils/Hasql/TestingUtils/TestingDsl.hs @@ -3,12 +3,17 @@ module Hasql.TestingUtils.TestingDsl SessionError (..), Session.QueryError (..), Session.CommandError (..), + Pipeline.Pipeline, + Statement.Statement (..), runSessionOnLocalDb, + runPipelineOnLocalDb, runStatementInSession, + runPipelineInSession, ) where import Hasql.Connection qualified as Connection +import Hasql.Pipeline qualified as Pipeline import Hasql.Session qualified as Session import Hasql.Statement qualified as Statement import Hasql.TestingUtils.Constants qualified as Constants @@ -32,6 +37,14 @@ runSessionOnLocalDb session = release connection = lift $ Connection.release connection +runPipelineOnLocalDb :: Pipeline.Pipeline a -> IO (Either SessionError a) +runPipelineOnLocalDb = + runSessionOnLocalDb . Session.pipeline + runStatementInSession :: Statement.Statement a b -> a -> Session.Session b runStatementInSession statement params = Session.statement params statement + +runPipelineInSession :: Pipeline.Pipeline a -> Session.Session a +runPipelineInSession = + Session.pipeline From f96af01f082697f6549e774da5dfb4a2160d27d4 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sat, 20 Apr 2024 18:35:32 +0300 Subject: [PATCH 04/33] Progress --- hspec/Hasql/PipelineSpec.hs | 36 ++++++++++++++----- library/Hasql/Decoders/Results.hs | 10 +++--- library/Hasql/IO.hs | 14 ++++---- library/Hasql/Pipeline/Core.hs | 27 +++++++++++--- .../TestingUtils/Statements/GenerateSeries.hs | 4 +-- 5 files changed, 65 insertions(+), 26 deletions(-) diff --git a/hspec/Hasql/PipelineSpec.hs b/hspec/Hasql/PipelineSpec.hs index 214ef7f..291e3d3 100644 --- a/hspec/Hasql/PipelineSpec.hs +++ b/hspec/Hasql/PipelineSpec.hs @@ -7,18 +7,38 @@ import Prelude spec :: Spec spec = do + describe "Single-statement" do + describe "Unprepared" do + it "Collects results and sends params" do + result <- + Dsl.runPipelineOnLocalDb + $ GenerateSeries.pipeline False GenerateSeries.Params {start = 0, end = 2} + shouldBe result (Right [0 .. 2]) + + describe "Prepared and sends params" do + fit "Collects results and sends params" do + result <- + Dsl.runPipelineOnLocalDb + $ GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + shouldBe result (Right [0 .. 2]) + describe "Normally" do describe "On prepared statements" do - it "Collects results" do - _result <- + it "Collects results and sends params" do + result <- Dsl.runPipelineOnLocalDb - $ (,) - <$> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 1000} - <*> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 1000} - pending + $ replicateM 2 + $ GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + shouldBe result (Right [[0 .. 2], [0 .. 2]]) + describe "On unprepared statements" do - it "Works" do - pending + it "Collects results and sends params" do + result <- + Dsl.runPipelineOnLocalDb + $ replicateM 2 + $ GenerateSeries.pipeline False GenerateSeries.Params {start = 0, end = 2} + shouldBe result (Right [[0 .. 2], [0 .. 2]]) + describe "When some part fails" do it "Works" do pending diff --git a/library/Hasql/Decoders/Results.hs b/library/Hasql/Decoders/Results.hs index 26f218a..040ec38 100644 --- a/library/Hasql/Decoders/Results.hs +++ b/library/Hasql/Decoders/Results.hs @@ -21,9 +21,9 @@ newtype Results a deriving (Functor, Applicative, Monad) {-# INLINE run #-} -run :: Results a -> (Bool, LibPQ.Connection) -> IO (Either CommandError a) -run (Results stack) env = - runExceptT (runReaderT stack env) +run :: Results a -> LibPQ.Connection -> Bool -> IO (Either CommandError a) +run (Results stack) conn idt = + runExceptT (runReaderT stack (idt, conn)) {-# INLINE clientError #-} clientError :: Results a @@ -87,8 +87,8 @@ dropRemainders = ExceptT $ fmap (mapLeft ResultError) $ Result.run Result.noResult (integerDatetimes, result) refine :: (a -> Either Text b) -> Results a -> Results b -refine refiner results = Results +refine refiner (Results stack) = Results $ ReaderT $ \env -> ExceptT $ do - resultEither <- run results env + resultEither <- runExceptT $ runReaderT stack env return $ resultEither >>= mapLeft (ResultError . UnexpectedResult) . refiner diff --git a/library/Hasql/IO.hs b/library/Hasql/IO.hs index b434b89..c47840b 100644 --- a/library/Hasql/IO.hs +++ b/library/Hasql/IO.hs @@ -62,9 +62,9 @@ getResults connection integerDatetimes decoder = (<*) <$> get <*> dropRemainders where get = - ResultsDecoders.run decoder (integerDatetimes, connection) + ResultsDecoders.run decoder connection integerDatetimes dropRemainders = - ResultsDecoders.run ResultsDecoders.dropRemainders (integerDatetimes, connection) + ResultsDecoders.run ResultsDecoders.dropRemainders connection integerDatetimes {-# INLINE getPreparedStatementKey #-} getPreparedStatementKey :: @@ -85,12 +85,12 @@ getPreparedStatementKey connection registry template oidList = onNewRemoteKey key = do sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList)) - let resultsDecoder = - if sent - then ResultsDecoders.single ResultDecoders.noResult - else ResultsDecoders.clientError - fmap resultsMapping $ getResults connection undefined resultsDecoder + fmap resultsMapping $ getResults connection undefined (resultsDecoder sent) where + resultsDecoder sent = + if sent + then ResultsDecoders.single ResultDecoders.noResult + else ResultsDecoders.clientError resultsMapping = \case Left x -> (False, Left x) diff --git a/library/Hasql/Pipeline/Core.hs b/library/Hasql/Pipeline/Core.hs index 440fd20..5d2debe 100644 --- a/library/Hasql/Pipeline/Core.hs +++ b/library/Hasql/Pipeline/Core.hs @@ -3,6 +3,7 @@ module Hasql.Pipeline.Core where import Database.PostgreSQL.LibPQ qualified as Pq import Hasql.Connection.Core qualified as Connection import Hasql.Decoders.All qualified as Decoders +import Hasql.Decoders.Results qualified as Decoders.Results import Hasql.Encoders.All qualified as Encoders import Hasql.Encoders.Params qualified as Encoders.Params import Hasql.Errors @@ -10,16 +11,33 @@ import Hasql.IO qualified as IO import Hasql.Prelude import Hasql.PreparedStatementRegistry qualified as PreparedStatementRegistry import Hasql.Statement qualified as Statement +import System.IO (BufferMode (NoBuffering), hSetBuffering, stdout) run :: Pipeline a -> Connection.Connection -> IO (Either QueryError a) -run (Pipeline send recv) (Connection.Connection pqConnectionRef integerDatetimes registry) = +run (Pipeline send recv) (Connection.Connection pqConnectionRef integerDatetimes registry) = do + hSetBuffering stdout NoBuffering withMVar pqConnectionRef \pqConnection -> do - Pq.enterPipelineMode pqConnection + putStrLn "enterPipelineMode" + runCommandFailing pqConnection $ Pq.enterPipelineMode pqConnection + putStrLn "send" sendResult <- send pqConnection integerDatetimes registry - Pq.pipelineSync pqConnection + putStrLn "pipelineSync" + runCommandFailing pqConnection $ Pq.pipelineSync pqConnection + putStrLn "recv" recvResult <- recv pqConnection integerDatetimes - Pq.exitPipelineMode pqConnection + putStrLn "exitPipelineMode" + handleEither =<< Decoders.Results.run Decoders.Results.dropRemainders pqConnection integerDatetimes + putStrLn "exitPipelineMode" + runCommandFailing pqConnection $ Pq.exitPipelineMode pqConnection + putStrLn "return" pure (sendResult *> recvResult) + where + runCommandFailing :: Pq.Connection -> IO Bool -> IO () + runCommandFailing pqConn runCmd = + IO.checkedSend pqConn runCmd >>= handleEither + handleEither = \case + Right a -> pure a + Left err -> fail $ show err data Pipeline a = Pipeline @@ -60,6 +78,7 @@ statement params (Statement.Statement template (Encoders.Params paramsEncoder) ( recv pqConnection integerDatetimes = mapLeft commandToQueryError + -- <$> Decoders.Results.run decoder (integerDatetimes, pqConnection) <$> IO.getResults pqConnection integerDatetimes decoder commandToQueryError = diff --git a/testing-utils/Hasql/TestingUtils/Statements/GenerateSeries.hs b/testing-utils/Hasql/TestingUtils/Statements/GenerateSeries.hs index bb0e4b4..67937e2 100644 --- a/testing-utils/Hasql/TestingUtils/Statements/GenerateSeries.hs +++ b/testing-utils/Hasql/TestingUtils/Statements/GenerateSeries.hs @@ -12,7 +12,7 @@ data Params = Params end :: Int64 } -type Result = Vector Int64 +type Result = [Int64] session :: Bool -> Params -> Session.Session Result session prepared params = @@ -39,6 +39,6 @@ encoder = decoder :: Decoders.Result Result decoder = - Decoders.rowVector + Decoders.rowList ( Decoders.column (Decoders.nonNullable Decoders.int8) ) From e366b3febaf9696e0ac3853111aa680564bb378a Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sun, 21 Apr 2024 07:56:16 +0300 Subject: [PATCH 05/33] Simplify --- library/Hasql/IO.hs | 5 +---- library/Hasql/PreparedStatementRegistry.hs | 3 ++- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/library/Hasql/IO.hs b/library/Hasql/IO.hs index 534b75e..05323d6 100644 --- a/library/Hasql/IO.hs +++ b/library/Hasql/IO.hs @@ -78,10 +78,7 @@ getPreparedStatementKey connection registry template oidList = PreparedStatementRegistry.update localKey onNewRemoteKey onOldRemoteKey registry where localKey = - PreparedStatementRegistry.LocalKey template wordOIDList - where - wordOIDList = - map (\(LibPQ.Oid x) -> fromIntegral x) oidList + PreparedStatementRegistry.LocalKey template oidList onNewRemoteKey key = do sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList)) diff --git a/library/Hasql/PreparedStatementRegistry.hs b/library/Hasql/PreparedStatementRegistry.hs index e5d837c..9ae7503 100644 --- a/library/Hasql/PreparedStatementRegistry.hs +++ b/library/Hasql/PreparedStatementRegistry.hs @@ -9,6 +9,7 @@ where import ByteString.StrictBuilder qualified as B import Data.HashTable.IO qualified as A import Hasql.Prelude hiding (lookup) +import qualified Database.PostgreSQL.LibPQ as Pq data PreparedStatementRegistry = PreparedStatementRegistry !(A.BasicHashTable LocalKey ByteString) !(IORef Word) @@ -44,7 +45,7 @@ update localKey onNewRemoteKey onOldRemoteKey (PreparedStatementRegistry table c -- | -- Local statement key. data LocalKey - = LocalKey !ByteString ![Word32] + = LocalKey !ByteString ![Pq.Oid] deriving (Show, Eq) instance Hashable LocalKey where From 117ebc3d0eef0db4e3053bce70253df3a4cc9929 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sun, 21 Apr 2024 08:14:25 +0300 Subject: [PATCH 06/33] Factor out the reusable pieces --- library/Hasql/Encoders/Params.hs | 20 ++++++++++++++++++++ library/Hasql/IO.hs | 26 ++++++++++---------------- 2 files changed, 30 insertions(+), 16 deletions(-) diff --git a/library/Hasql/Encoders/Params.hs b/library/Hasql/Encoders/Params.hs index 710acc7..8a4640b 100644 --- a/library/Hasql/Encoders/Params.hs +++ b/library/Hasql/Encoders/Params.hs @@ -12,6 +12,26 @@ renderReadable (Params _ _ _ printer) params = printer params & toList +compilePreparedStatementData :: Params a -> Bool -> a -> ([A.Oid], [Maybe (ByteString, A.Format)]) +compilePreparedStatementData (Params _ columnsMetadata serializer _) integerDatetimes input = + (oidList, valueAndFormatList) + where + (oidList, formatList) = + columnsMetadata & toList & unzip + valueAndFormatList = + serializer integerDatetimes input + & toList + & zipWith (\format encoding -> (,format) <$> encoding) formatList + +compileUnpreparedStatementData :: Params a -> Bool -> a -> [Maybe (A.Oid, ByteString, A.Format)] +compileUnpreparedStatementData (Params _ columnsMetadata serializer printer) integerDatetimes input = + zipWith + ( \(oid, format) encoding -> + (,,) <$> pure oid <*> encoding <*> pure format + ) + (toList columnsMetadata) + (toList (serializer integerDatetimes input)) + -- | -- Encoder of some representation of a parameters product. data Params a = Params diff --git a/library/Hasql/IO.hs b/library/Hasql/IO.hs index 05323d6..9facdb1 100644 --- a/library/Hasql/IO.hs +++ b/library/Hasql/IO.hs @@ -111,17 +111,13 @@ sendPreparedParametricStatement :: ParamsEncoders.Params a -> a -> IO (Either CommandError ()) -sendPreparedParametricStatement connection registry integerDatetimes template (ParamsEncoders.Params size columnsMetadata serializer _) input = +sendPreparedParametricStatement connection registry integerDatetimes template encoder input = runExceptT $ do key <- ExceptT $ getPreparedStatementKey connection registry template oidList ExceptT $ checkedSend connection $ LibPQ.sendQueryPrepared connection key valueAndFormatList LibPQ.Binary where - (oidList, formatList) = - columnsMetadata & toList & unzip - valueAndFormatList = - serializer integerDatetimes input - & toList - & zipWith (\format encoding -> (,format) <$> encoding) formatList + (oidList, valueAndFormatList) = + ParamsEncoders.compilePreparedStatementData encoder integerDatetimes input {-# INLINE sendUnpreparedParametricStatement #-} sendUnpreparedParametricStatement :: @@ -131,15 +127,13 @@ sendUnpreparedParametricStatement :: ParamsEncoders.Params a -> a -> IO (Either CommandError ()) -sendUnpreparedParametricStatement connection integerDatetimes template (ParamsEncoders.Params _ columnsMetadata serializer printer) input = - let params = - zipWith - ( \(oid, format) encoding -> - (,,) <$> pure oid <*> encoding <*> pure format - ) - (toList columnsMetadata) - (toList (serializer integerDatetimes input)) - in checkedSend connection $ LibPQ.sendQueryParams connection template params LibPQ.Binary +sendUnpreparedParametricStatement connection integerDatetimes template encoder input = + checkedSend connection + $ LibPQ.sendQueryParams + connection + template + (ParamsEncoders.compileUnpreparedStatementData encoder integerDatetimes input) + LibPQ.Binary {-# INLINE sendParametricStatement #-} sendParametricStatement :: From 851444711bf0401185bfe051f66865d6861fa95a Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sun, 21 Apr 2024 08:54:52 +0300 Subject: [PATCH 07/33] Progress --- library/Hasql/Pipeline/Core.hs | 113 ++++++++++++++++++++------------- 1 file changed, 69 insertions(+), 44 deletions(-) diff --git a/library/Hasql/Pipeline/Core.hs b/library/Hasql/Pipeline/Core.hs index 5d2debe..39328cc 100644 --- a/library/Hasql/Pipeline/Core.hs +++ b/library/Hasql/Pipeline/Core.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-binds #-} + module Hasql.Pipeline.Core where import Database.PostgreSQL.LibPQ qualified as Pq @@ -14,23 +16,30 @@ import Hasql.Statement qualified as Statement import System.IO (BufferMode (NoBuffering), hSetBuffering, stdout) run :: Pipeline a -> Connection.Connection -> IO (Either QueryError a) -run (Pipeline send recv) (Connection.Connection pqConnectionRef integerDatetimes registry) = do +run (Pipeline send) (Connection.Connection pqConnectionRef integerDatetimes registry) = do hSetBuffering stdout NoBuffering withMVar pqConnectionRef \pqConnection -> do putStrLn "enterPipelineMode" runCommandFailing pqConnection $ Pq.enterPipelineMode pqConnection putStrLn "send" - sendResult <- send pqConnection integerDatetimes registry - putStrLn "pipelineSync" - runCommandFailing pqConnection $ Pq.pipelineSync pqConnection - putStrLn "recv" - recvResult <- recv pqConnection integerDatetimes - putStrLn "exitPipelineMode" - handleEither =<< Decoders.Results.run Decoders.Results.dropRemainders pqConnection integerDatetimes - putStrLn "exitPipelineMode" - runCommandFailing pqConnection $ Pq.exitPipelineMode pqConnection - putStrLn "return" - pure (sendResult *> recvResult) + sendResult <- send pqConnection registry integerDatetimes + case sendResult of + Left err -> do + pure (Left err) + Right recv -> do + putStrLn "pipelineSync" + runCommandFailing pqConnection $ Pq.pipelineSync pqConnection + putStrLn "recv" + recvResult <- recv + case recvResult of + Left err -> pure (Left err) + Right res -> do + putStrLn "dropRemainders" + handleEither =<< Decoders.Results.run Decoders.Results.dropRemainders pqConnection integerDatetimes + putStrLn "exitPipelineMode" + runCommandFailing pqConnection $ Pq.exitPipelineMode pqConnection + putStrLn "return" + pure (sendResult *> recvResult) where runCommandFailing :: Pq.Connection -> IO Bool -> IO () runCommandFailing pqConn runCmd = @@ -39,47 +48,63 @@ run (Pipeline send recv) (Connection.Connection pqConnectionRef integerDatetimes Right a -> pure a Left err -> fail $ show err -data Pipeline a +newtype Pipeline a = Pipeline - -- | Send commands. - (Pq.Connection -> Bool -> PreparedStatementRegistry.PreparedStatementRegistry -> IO (Either QueryError ())) - -- | Receive results. - (Pq.Connection -> Bool -> IO (Either QueryError a)) + ( Pq.Connection -> + PreparedStatementRegistry.PreparedStatementRegistry -> + Bool -> + IO (Either QueryError (IO (Either QueryError a))) + ) deriving (Functor) instance Applicative Pipeline where pure a = - Pipeline send recv - where - send _ _ _ = - pure (Right ()) - recv _ _ = - pure (Right a) + Pipeline (\_ _ _ -> pure (Right (pure (Right a)))) - Pipeline lSend lRecv <*> Pipeline rSend rRecv = - Pipeline send recv - where - send pqConn idt pReg = do - lSendRes <- lSend pqConn idt pReg - rSendRes <- rSend pqConn idt pReg - pure (lSendRes *> rSendRes) - recv pqConn idt = do - lRecvRes <- lRecv pqConn idt - rRecvRes <- rRecv pqConn idt - pure (lRecvRes <*> rRecvRes) + Pipeline lSend <*> Pipeline rSend = + Pipeline \conn reg integerDatetimes -> + lSend conn reg integerDatetimes >>= \case + Left sendErr -> + pure (Left sendErr) + Right lRecv -> + rSend conn reg integerDatetimes <&> \case + Left sendErr -> + Left sendErr + Right rRecv -> + Right (liftA2 (<*>) lRecv rRecv) statement :: params -> Statement.Statement params result -> Pipeline result -statement params (Statement.Statement template (Encoders.Params paramsEncoder) (Decoders.Result decoder) preparable) = - Pipeline send recv +statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Result decoder) preparable) = + Pipeline run where - send pqConnection integerDatetimes registry = - mapLeft commandToQueryError - <$> IO.sendParametricStatement pqConnection integerDatetimes registry template paramsEncoder preparable params + run connection registry integerDatetimes = do + error "TODO" + where + (oidList, valueAndFormatList) = + Encoders.Params.compilePreparedStatementData encoder integerDatetimes params - recv pqConnection integerDatetimes = - mapLeft commandToQueryError - -- <$> Decoders.Results.run decoder (integerDatetimes, pqConnection) - <$> IO.getResults pqConnection integerDatetimes decoder + resolvePreparedStatementKey :: IO (Either QueryError (ByteString, IO (Either QueryError ()))) + resolvePreparedStatementKey = + PreparedStatementRegistry.update localKey onNewRemoteKey onOldRemoteKey registry + where + localKey = + PreparedStatementRegistry.LocalKey sql oidList + onNewRemoteKey key = + do + sent <- Pq.sendPrepare connection key sql (mfilter (not . null) (Just oidList)) + if sent + then pure (True, Right (key, recv)) + else (False,) . Left . commandToQueryError . ClientError <$> Pq.errorMessage connection + where + recv :: IO (Either QueryError ()) + recv = do + Pq.getResult connection >>= \case + Nothing -> + Left . commandToQueryError . ClientError <$> Pq.errorMessage connection + Just result -> + error "TODO" + onOldRemoteKey key = + pure (Right (key, pure (Right ()))) commandToQueryError = - QueryError template (Encoders.Params.renderReadable paramsEncoder params) + QueryError sql (Encoders.Params.renderReadable encoder params) From b07dc536feb07278130f4d126c0070c53287c7a3 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sun, 21 Apr 2024 08:59:15 +0300 Subject: [PATCH 08/33] Clean up --- library/Hasql/Decoders/Result.hs | 6 +++--- library/Hasql/Decoders/Results.hs | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/library/Hasql/Decoders/Result.hs b/library/Hasql/Decoders/Result.hs index 434bbe9..61a13a2 100644 --- a/library/Hasql/Decoders/Result.hs +++ b/library/Hasql/Decoders/Result.hs @@ -15,9 +15,9 @@ newtype Result a deriving (Functor, Applicative, Monad) {-# INLINE run #-} -run :: Result a -> (Bool, LibPQ.Result) -> IO (Either ResultError a) -run (Result reader) env = - runExceptT (runReaderT reader env) +run :: Result a -> Bool -> LibPQ.Result -> IO (Either ResultError a) +run (Result reader) idt result = + runExceptT (runReaderT reader (idt, result)) {-# INLINE noResult #-} noResult :: Result () diff --git a/library/Hasql/Decoders/Results.hs b/library/Hasql/Decoders/Results.hs index 040ec38..0add158 100644 --- a/library/Hasql/Decoders/Results.hs +++ b/library/Hasql/Decoders/Results.hs @@ -45,7 +45,7 @@ single resultDec = resultMaybe <- LibPQ.getResult connection case resultMaybe of Just result -> - mapLeft ResultError <$> Result.run resultDec (integerDatetimes, result) + mapLeft ResultError <$> Result.run resultDec integerDatetimes result Nothing -> fmap (Left . ClientError) (LibPQ.errorMessage connection) @@ -84,7 +84,7 @@ dropRemainders = loop integerDatetimes connection <* checkErrors where checkErrors = - ExceptT $ fmap (mapLeft ResultError) $ Result.run Result.noResult (integerDatetimes, result) + ExceptT $ fmap (mapLeft ResultError) $ Result.run Result.noResult integerDatetimes result refine :: (a -> Either Text b) -> Results a -> Results b refine refiner (Results stack) = Results From 3c36ebf3d7d82c82242a578df5b5556af086f7c4 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sun, 21 Apr 2024 09:02:28 +0300 Subject: [PATCH 09/33] Progress --- hspec/Hasql/PipelineSpec.hs | 6 +- library/Hasql/Decoders/Result.hs | 1 - library/Hasql/Pipeline/Core.hs | 95 ++++++++++++++++++++------------ 3 files changed, 64 insertions(+), 38 deletions(-) diff --git a/hspec/Hasql/PipelineSpec.hs b/hspec/Hasql/PipelineSpec.hs index 291e3d3..082dfe4 100644 --- a/hspec/Hasql/PipelineSpec.hs +++ b/hspec/Hasql/PipelineSpec.hs @@ -9,14 +9,14 @@ spec :: Spec spec = do describe "Single-statement" do describe "Unprepared" do - it "Collects results and sends params" do + fit "Collects results and sends params" do result <- Dsl.runPipelineOnLocalDb $ GenerateSeries.pipeline False GenerateSeries.Params {start = 0, end = 2} shouldBe result (Right [0 .. 2]) - describe "Prepared and sends params" do - fit "Collects results and sends params" do + describe "Prepared" do + it "Collects results and sends params" do result <- Dsl.runPipelineOnLocalDb $ GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} diff --git a/library/Hasql/Decoders/Result.hs b/library/Hasql/Decoders/Result.hs index 61a13a2..c47e528 100644 --- a/library/Hasql/Decoders/Result.hs +++ b/library/Hasql/Decoders/Result.hs @@ -25,7 +25,6 @@ noResult = checkExecStatus $ \case LibPQ.CommandOk -> True LibPQ.TuplesOk -> True - LibPQ.PipelineSync -> True _ -> False {-# INLINE rowsAffected #-} diff --git a/library/Hasql/Pipeline/Core.hs b/library/Hasql/Pipeline/Core.hs index 39328cc..ee7f04e 100644 --- a/library/Hasql/Pipeline/Core.hs +++ b/library/Hasql/Pipeline/Core.hs @@ -5,6 +5,7 @@ module Hasql.Pipeline.Core where import Database.PostgreSQL.LibPQ qualified as Pq import Hasql.Connection.Core qualified as Connection import Hasql.Decoders.All qualified as Decoders +import Hasql.Decoders.Result qualified as Decoders.Result import Hasql.Decoders.Results qualified as Decoders.Results import Hasql.Encoders.All qualified as Encoders import Hasql.Encoders.Params qualified as Encoders.Params @@ -31,15 +32,12 @@ run (Pipeline send) (Connection.Connection pqConnectionRef integerDatetimes regi runCommandFailing pqConnection $ Pq.pipelineSync pqConnection putStrLn "recv" recvResult <- recv - case recvResult of - Left err -> pure (Left err) - Right res -> do - putStrLn "dropRemainders" - handleEither =<< Decoders.Results.run Decoders.Results.dropRemainders pqConnection integerDatetimes - putStrLn "exitPipelineMode" - runCommandFailing pqConnection $ Pq.exitPipelineMode pqConnection - putStrLn "return" - pure (sendResult *> recvResult) + putStrLn "dropRemainders" + handleEither =<< Decoders.Results.run Decoders.Results.dropRemainders pqConnection integerDatetimes + putStrLn "exitPipelineMode" + runCommandFailing pqConnection $ Pq.exitPipelineMode pqConnection + putStrLn "return" + pure recvResult where runCommandFailing :: Pq.Connection -> IO Bool -> IO () runCommandFailing pqConn runCmd = @@ -77,34 +75,63 @@ statement :: params -> Statement.Statement params result -> Pipeline result statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Result decoder) preparable) = Pipeline run where - run connection registry integerDatetimes = do - error "TODO" + run connection registry integerDatetimes = + if preparable + then runPrepared + else runUnprepared where - (oidList, valueAndFormatList) = - Encoders.Params.compilePreparedStatementData encoder integerDatetimes params - - resolvePreparedStatementKey :: IO (Either QueryError (ByteString, IO (Either QueryError ()))) - resolvePreparedStatementKey = - PreparedStatementRegistry.update localKey onNewRemoteKey onOldRemoteKey registry + runPrepared = runExceptT do + (key, keyRecv) <- ExceptT resolvePreparedStatementKey + queryRecv <- ExceptT (sendQuery key) + pure (keyRecv *> queryRecv) where - localKey = - PreparedStatementRegistry.LocalKey sql oidList - onNewRemoteKey key = - do - sent <- Pq.sendPrepare connection key sql (mfilter (not . null) (Just oidList)) - if sent - then pure (True, Right (key, recv)) - else (False,) . Left . commandToQueryError . ClientError <$> Pq.errorMessage connection + (oidList, valueAndFormatList) = + Encoders.Params.compilePreparedStatementData encoder integerDatetimes params + + resolvePreparedStatementKey = + PreparedStatementRegistry.update localKey onNewRemoteKey onOldRemoteKey registry where - recv :: IO (Either QueryError ()) - recv = do - Pq.getResult connection >>= \case - Nothing -> - Left . commandToQueryError . ClientError <$> Pq.errorMessage connection - Just result -> - error "TODO" - onOldRemoteKey key = - pure (Right (key, pure (Right ()))) + localKey = + PreparedStatementRegistry.LocalKey sql oidList + onNewRemoteKey key = + do + sent <- Pq.sendPrepare connection key sql (mfilter (not . null) (Just oidList)) + if sent + then pure (True, Right (key, recv)) + else (False,) . Left . commandToQueryError . ClientError <$> Pq.errorMessage connection + where + recv :: IO (Either QueryError ()) + recv = do + Pq.getResult connection >>= \case + Nothing -> + Left . commandToQueryError . ClientError <$> Pq.errorMessage connection + Just result -> + mapLeft (commandToQueryError . ResultError) + <$> Decoders.Result.run Decoders.Result.noResult integerDatetimes result + onOldRemoteKey key = + pure (Right (key, pure (Right ()))) + + sendQuery key = + Pq.sendQueryPrepared connection key valueAndFormatList Pq.Binary >>= \case + False -> Left . commandToQueryError . ClientError <$> Pq.errorMessage connection + True -> pure (Right recv) + where + recv = + fmap (mapLeft commandToQueryError) + $ (<*) + <$> Decoders.Results.run decoder connection integerDatetimes + <*> Decoders.Results.run Decoders.Results.dropRemainders connection integerDatetimes + + runUnprepared = + Pq.sendQueryParams connection sql (Encoders.Params.compileUnpreparedStatementData encoder integerDatetimes params) Pq.Binary >>= \case + False -> Left . commandToQueryError . ClientError <$> Pq.errorMessage connection + True -> pure (Right recv) + where + recv = + fmap (mapLeft commandToQueryError) + $ (<*) + <$> Decoders.Results.run decoder connection integerDatetimes + <*> Decoders.Results.run Decoders.Results.dropRemainders connection integerDatetimes commandToQueryError = QueryError sql (Encoders.Params.renderReadable encoder params) From c2ab043911b0555d46de6c5ebd8ff50eefa0b827 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sun, 21 Apr 2024 12:12:15 +0300 Subject: [PATCH 10/33] Refactor status checking --- library/Hasql/Decoders/Result.hs | 37 ++++++++++---------------------- 1 file changed, 11 insertions(+), 26 deletions(-) diff --git a/library/Hasql/Decoders/Result.hs b/library/Hasql/Decoders/Result.hs index c47e528..85cbe1b 100644 --- a/library/Hasql/Decoders/Result.hs +++ b/library/Hasql/Decoders/Result.hs @@ -22,18 +22,13 @@ run (Result reader) idt result = {-# INLINE noResult #-} noResult :: Result () noResult = - checkExecStatus $ \case - LibPQ.CommandOk -> True - LibPQ.TuplesOk -> True - _ -> False + checkExecStatus [LibPQ.CommandOk, LibPQ.TuplesOk] {-# INLINE rowsAffected #-} rowsAffected :: Result Int64 rowsAffected = do - checkExecStatus $ \case - LibPQ.CommandOk -> True - _ -> False + checkExecStatus [LibPQ.CommandOk] Result $ ReaderT $ \(_, result) -> @@ -55,18 +50,18 @@ rowsAffected = $ Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes {-# INLINE checkExecStatus #-} -checkExecStatus :: (LibPQ.ExecStatus -> Bool) -> Result () -checkExecStatus predicate = +checkExecStatus :: [LibPQ.ExecStatus] -> Result () +checkExecStatus expectedList = {-# SCC "checkExecStatus" #-} do status <- Result $ ReaderT $ \(_, result) -> lift $ LibPQ.resultStatus result - unless (predicate status) $ do + unless (elem status expectedList) $ do case status of LibPQ.BadResponse -> serverError LibPQ.NonfatalError -> serverError LibPQ.FatalError -> serverError LibPQ.EmptyQuery -> return () - _ -> unexpectedResult $ "Unexpected result status: " <> (fromString $ show status) + _ -> unexpectedResult $ "Unexpected result status: " <> fromString (show status) <> ". Expecting one of the following: " <> fromString (show expectedList) unexpectedResult :: Text -> Result a unexpectedResult = @@ -103,9 +98,7 @@ serverError = maybe :: Row.Row a -> Result (Maybe a) maybe rowDec = do - checkExecStatus $ \case - LibPQ.TuplesOk -> True - _ -> False + checkExecStatus [LibPQ.TuplesOk] Result $ ReaderT $ \(integerDatetimes, result) -> ExceptT $ do @@ -125,9 +118,7 @@ maybe rowDec = single :: Row.Row a -> Result a single rowDec = do - checkExecStatus $ \case - LibPQ.TuplesOk -> True - _ -> False + checkExecStatus [LibPQ.TuplesOk] Result $ ReaderT $ \(integerDatetimes, result) -> ExceptT $ do @@ -146,9 +137,7 @@ single rowDec = vector :: Row.Row a -> Result (Vector a) vector rowDec = do - checkExecStatus $ \case - LibPQ.TuplesOk -> True - _ -> False + checkExecStatus [LibPQ.TuplesOk] Result $ ReaderT $ \(integerDatetimes, result) -> ExceptT $ do @@ -175,9 +164,7 @@ foldl :: (a -> b -> a) -> a -> Row.Row b -> Result a foldl step init rowDec = {-# SCC "foldl" #-} do - checkExecStatus $ \case - LibPQ.TuplesOk -> True - _ -> False + checkExecStatus [LibPQ.TuplesOk] Result $ ReaderT $ \(integerDatetimes, result) -> @@ -207,9 +194,7 @@ foldr :: (b -> a -> a) -> a -> Row.Row b -> Result a foldr step init rowDec = {-# SCC "foldr" #-} do - checkExecStatus $ \case - LibPQ.TuplesOk -> True - _ -> False + checkExecStatus [LibPQ.TuplesOk] Result $ ReaderT $ \(integerDatetimes, result) -> ExceptT $ do From eac7e7ccb7ca5bf7ffd1daed61b2b5edebbeb6b6 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sun, 21 Apr 2024 12:12:35 +0300 Subject: [PATCH 11/33] Progress --- hspec/Hasql/PipelineSpec.hs | 18 +++++++++--------- library/Hasql/Decoders/Result.hs | 5 +++++ library/Hasql/Pipeline/Core.hs | 17 +++++++---------- 3 files changed, 21 insertions(+), 19 deletions(-) diff --git a/hspec/Hasql/PipelineSpec.hs b/hspec/Hasql/PipelineSpec.hs index 082dfe4..ea93c39 100644 --- a/hspec/Hasql/PipelineSpec.hs +++ b/hspec/Hasql/PipelineSpec.hs @@ -9,7 +9,7 @@ spec :: Spec spec = do describe "Single-statement" do describe "Unprepared" do - fit "Collects results and sends params" do + it "Collects results and sends params" do result <- Dsl.runPipelineOnLocalDb $ GenerateSeries.pipeline False GenerateSeries.Params {start = 0, end = 2} @@ -23,14 +23,6 @@ spec = do shouldBe result (Right [0 .. 2]) describe "Normally" do - describe "On prepared statements" do - it "Collects results and sends params" do - result <- - Dsl.runPipelineOnLocalDb - $ replicateM 2 - $ GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} - shouldBe result (Right [[0 .. 2], [0 .. 2]]) - describe "On unprepared statements" do it "Collects results and sends params" do result <- @@ -39,6 +31,14 @@ spec = do $ GenerateSeries.pipeline False GenerateSeries.Params {start = 0, end = 2} shouldBe result (Right [[0 .. 2], [0 .. 2]]) + describe "On prepared statements" do + it "Collects results and sends params" do + result <- + Dsl.runPipelineOnLocalDb + $ replicateM 2 + $ GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + shouldBe result (Right [[0 .. 2], [0 .. 2]]) + describe "When some part fails" do it "Works" do pending diff --git a/library/Hasql/Decoders/Result.hs b/library/Hasql/Decoders/Result.hs index 85cbe1b..5c7de42 100644 --- a/library/Hasql/Decoders/Result.hs +++ b/library/Hasql/Decoders/Result.hs @@ -19,6 +19,11 @@ run :: Result a -> Bool -> LibPQ.Result -> IO (Either ResultError a) run (Result reader) idt result = runExceptT (runReaderT reader (idt, result)) +{-# INLINE pipelineSync #-} +pipelineSync :: Result () +pipelineSync = + checkExecStatus [LibPQ.PipelineSync] + {-# INLINE noResult #-} noResult :: Result () noResult = diff --git a/library/Hasql/Pipeline/Core.hs b/library/Hasql/Pipeline/Core.hs index ee7f04e..cf1ba6d 100644 --- a/library/Hasql/Pipeline/Core.hs +++ b/library/Hasql/Pipeline/Core.hs @@ -32,8 +32,8 @@ run (Pipeline send) (Connection.Connection pqConnectionRef integerDatetimes regi runCommandFailing pqConnection $ Pq.pipelineSync pqConnection putStrLn "recv" recvResult <- recv - putStrLn "dropRemainders" - handleEither =<< Decoders.Results.run Decoders.Results.dropRemainders pqConnection integerDatetimes + putStrLn "pipelineSync" + handleEither =<< Decoders.Results.run (Decoders.Results.single Decoders.Result.pipelineSync) pqConnection integerDatetimes putStrLn "exitPipelineMode" runCommandFailing pqConnection $ Pq.exitPipelineMode pqConnection putStrLn "return" @@ -100,14 +100,11 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re then pure (True, Right (key, recv)) else (False,) . Left . commandToQueryError . ClientError <$> Pq.errorMessage connection where - recv :: IO (Either QueryError ()) - recv = do - Pq.getResult connection >>= \case - Nothing -> - Left . commandToQueryError . ClientError <$> Pq.errorMessage connection - Just result -> - mapLeft (commandToQueryError . ResultError) - <$> Decoders.Result.run Decoders.Result.noResult integerDatetimes result + recv = + fmap (mapLeft commandToQueryError) + $ (<*) + <$> Decoders.Results.run (Decoders.Results.single Decoders.Result.noResult) connection integerDatetimes + <*> Decoders.Results.run Decoders.Results.dropRemainders connection integerDatetimes onOldRemoteKey key = pure (Right (key, pure (Right ()))) From e76af7c5593621c35c6b750a1a2f02f1ae4acbac Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sun, 21 Apr 2024 12:26:28 +0300 Subject: [PATCH 12/33] Remove debugging --- library/Hasql/Pipeline/Core.hs | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/library/Hasql/Pipeline/Core.hs b/library/Hasql/Pipeline/Core.hs index cf1ba6d..e551f57 100644 --- a/library/Hasql/Pipeline/Core.hs +++ b/library/Hasql/Pipeline/Core.hs @@ -14,29 +14,20 @@ import Hasql.IO qualified as IO import Hasql.Prelude import Hasql.PreparedStatementRegistry qualified as PreparedStatementRegistry import Hasql.Statement qualified as Statement -import System.IO (BufferMode (NoBuffering), hSetBuffering, stdout) run :: Pipeline a -> Connection.Connection -> IO (Either QueryError a) -run (Pipeline send) (Connection.Connection pqConnectionRef integerDatetimes registry) = do - hSetBuffering stdout NoBuffering +run (Pipeline send) (Connection.Connection pqConnectionRef integerDatetimes registry) = withMVar pqConnectionRef \pqConnection -> do - putStrLn "enterPipelineMode" runCommandFailing pqConnection $ Pq.enterPipelineMode pqConnection - putStrLn "send" sendResult <- send pqConnection registry integerDatetimes case sendResult of Left err -> do pure (Left err) Right recv -> do - putStrLn "pipelineSync" runCommandFailing pqConnection $ Pq.pipelineSync pqConnection - putStrLn "recv" recvResult <- recv - putStrLn "pipelineSync" handleEither =<< Decoders.Results.run (Decoders.Results.single Decoders.Result.pipelineSync) pqConnection integerDatetimes - putStrLn "exitPipelineMode" runCommandFailing pqConnection $ Pq.exitPipelineMode pqConnection - putStrLn "return" pure recvResult where runCommandFailing :: Pq.Connection -> IO Bool -> IO () From 3c831284bdf122c503bb2579913df8072080a5bb Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sun, 21 Apr 2024 12:34:19 +0300 Subject: [PATCH 13/33] Repurpose QueryError as a more general SessionError --- library/Hasql/Errors.hs | 17 ++++++++-------- library/Hasql/Pipeline/Core.hs | 20 +++++++++---------- library/Hasql/Session/Core.hs | 10 +++++----- tasty/Main.hs | 4 ++-- .../Hasql/TestingUtils/TestingDsl.hs | 12 +++++------ 5 files changed, 32 insertions(+), 31 deletions(-) diff --git a/library/Hasql/Errors.hs b/library/Hasql/Errors.hs index 8cc290d..600871d 100644 --- a/library/Hasql/Errors.hs +++ b/library/Hasql/Errors.hs @@ -13,15 +13,16 @@ module Hasql.Errors where import Data.ByteString.Char8 qualified as BC import Hasql.Prelude --- | --- An error during the execution of a query. --- Comes packed with the query template and a textual representation of the provided params. -data QueryError - = QueryError ByteString [Text] CommandError +-- | Error during execution of a session. +data SessionError + = -- | + -- An error during the execution of a query. + -- Comes packed with the query template and a textual representation of the provided params. + QuerySessionError ByteString [Text] CommandError deriving (Show, Eq, Typeable) -instance Exception QueryError where - displayException (QueryError query params commandError) = +instance Exception SessionError where + displayException (QuerySessionError query params commandError) = let queryContext :: Maybe (ByteString, Int) queryContext = case commandError of ClientError _ -> Nothing @@ -59,7 +60,7 @@ instance Exception QueryError where prettyQuery = case queryContext of Nothing -> query Just (message, pos) -> formatErrorContext query message pos - in "QueryError!\n" + in "QuerySessionError!\n" <> "\n Query:\n" <> BC.unpack prettyQuery <> "\n" diff --git a/library/Hasql/Pipeline/Core.hs b/library/Hasql/Pipeline/Core.hs index e551f57..5af7371 100644 --- a/library/Hasql/Pipeline/Core.hs +++ b/library/Hasql/Pipeline/Core.hs @@ -15,7 +15,7 @@ import Hasql.Prelude import Hasql.PreparedStatementRegistry qualified as PreparedStatementRegistry import Hasql.Statement qualified as Statement -run :: Pipeline a -> Connection.Connection -> IO (Either QueryError a) +run :: Pipeline a -> Connection.Connection -> IO (Either SessionError a) run (Pipeline send) (Connection.Connection pqConnectionRef integerDatetimes registry) = withMVar pqConnectionRef \pqConnection -> do runCommandFailing pqConnection $ Pq.enterPipelineMode pqConnection @@ -42,7 +42,7 @@ newtype Pipeline a ( Pq.Connection -> PreparedStatementRegistry.PreparedStatementRegistry -> Bool -> - IO (Either QueryError (IO (Either QueryError a))) + IO (Either SessionError (IO (Either SessionError a))) ) deriving (Functor) @@ -89,10 +89,10 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re sent <- Pq.sendPrepare connection key sql (mfilter (not . null) (Just oidList)) if sent then pure (True, Right (key, recv)) - else (False,) . Left . commandToQueryError . ClientError <$> Pq.errorMessage connection + else (False,) . Left . commandToSessionError . ClientError <$> Pq.errorMessage connection where recv = - fmap (mapLeft commandToQueryError) + fmap (mapLeft commandToSessionError) $ (<*) <$> Decoders.Results.run (Decoders.Results.single Decoders.Result.noResult) connection integerDatetimes <*> Decoders.Results.run Decoders.Results.dropRemainders connection integerDatetimes @@ -101,25 +101,25 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re sendQuery key = Pq.sendQueryPrepared connection key valueAndFormatList Pq.Binary >>= \case - False -> Left . commandToQueryError . ClientError <$> Pq.errorMessage connection + False -> Left . commandToSessionError . ClientError <$> Pq.errorMessage connection True -> pure (Right recv) where recv = - fmap (mapLeft commandToQueryError) + fmap (mapLeft commandToSessionError) $ (<*) <$> Decoders.Results.run decoder connection integerDatetimes <*> Decoders.Results.run Decoders.Results.dropRemainders connection integerDatetimes runUnprepared = Pq.sendQueryParams connection sql (Encoders.Params.compileUnpreparedStatementData encoder integerDatetimes params) Pq.Binary >>= \case - False -> Left . commandToQueryError . ClientError <$> Pq.errorMessage connection + False -> Left . commandToSessionError . ClientError <$> Pq.errorMessage connection True -> pure (Right recv) where recv = - fmap (mapLeft commandToQueryError) + fmap (mapLeft commandToSessionError) $ (<*) <$> Decoders.Results.run decoder connection integerDatetimes <*> Decoders.Results.run Decoders.Results.dropRemainders connection integerDatetimes - commandToQueryError = - QueryError sql (Encoders.Params.renderReadable encoder params) + commandToSessionError = + QuerySessionError sql (Encoders.Params.renderReadable encoder params) diff --git a/library/Hasql/Session/Core.hs b/library/Hasql/Session/Core.hs index 1b7176e..62164d6 100644 --- a/library/Hasql/Session/Core.hs +++ b/library/Hasql/Session/Core.hs @@ -15,12 +15,12 @@ import Hasql.Statement qualified as Statement -- | -- A batch of actions to be executed in the context of a database connection. newtype Session a - = Session (ReaderT Connection.Connection (ExceptT QueryError IO) a) - deriving (Functor, Applicative, Monad, MonadError QueryError, MonadIO, MonadReader Connection.Connection) + = Session (ReaderT Connection.Connection (ExceptT SessionError IO) a) + deriving (Functor, Applicative, Monad, MonadError SessionError, MonadIO, MonadReader Connection.Connection) -- | -- Executes a bunch of commands on the provided connection. -run :: Session a -> Connection.Connection -> IO (Either QueryError a) +run :: Session a -> Connection.Connection -> IO (Either SessionError a) run (Session impl) connection = runExceptT $ runReaderT impl connection @@ -35,7 +35,7 @@ sql sql = $ ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) -> ExceptT - $ fmap (mapLeft (QueryError sql [])) + $ fmap (mapLeft (QuerySessionError sql [])) $ withMVar pqConnectionRef $ \pqConnection -> do r1 <- IO.sendNonparametricStatement pqConnection sql @@ -53,7 +53,7 @@ statement input (Statement.Statement template (Encoders.Params paramsEncoder) (D $ ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) -> ExceptT - $ fmap (mapLeft (QueryError template (Encoders.Params.renderReadable paramsEncoder input))) + $ fmap (mapLeft (QuerySessionError template (Encoders.Params.renderReadable paramsEncoder input))) $ withMVar pqConnectionRef $ \pqConnection -> do r1 <- IO.sendParametricStatement pqConnection integerDatetimes registry template paramsEncoder preparable input diff --git a/tasty/Main.hs b/tasty/Main.hs index a2ffce5..0ec1393 100644 --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -56,7 +56,7 @@ tree = in do x <- Connection.with (Session.run session) assertBool (show x) $ case x of - Right (Left (Session.QueryError "select true where 1 = any ($1) and $2" ["[3, 7]", "\"a\""] _)) -> True + Right (Left (Session.QuerySessionError "select true where 1 = any ($1) and $2" ["[3, 7]", "\"a\""] _)) -> True _ -> False, testCase "IN simulation" $ let statement = @@ -218,7 +218,7 @@ tree = where resultTest = \case - Right (Left (Session.QueryError _ _ (Session.ResultError (Session.ServerError "26000" _ _ _ _)))) -> False + Right (Left (Session.QuerySessionError _ _ (Session.ResultError (Session.ServerError "26000" _ _ _ _)))) -> False _ -> True session = catchError session (const (pure ())) *> session diff --git a/testing-utils/Hasql/TestingUtils/TestingDsl.hs b/testing-utils/Hasql/TestingUtils/TestingDsl.hs index 59144aa..a7a450f 100644 --- a/testing-utils/Hasql/TestingUtils/TestingDsl.hs +++ b/testing-utils/Hasql/TestingUtils/TestingDsl.hs @@ -1,7 +1,7 @@ module Hasql.TestingUtils.TestingDsl ( Session.Session, - SessionError (..), - Session.QueryError (..), + Error (..), + Session.SessionError (..), Session.CommandError (..), Pipeline.Pipeline, Statement.Statement (..), @@ -19,12 +19,12 @@ import Hasql.Statement qualified as Statement import Hasql.TestingUtils.Constants qualified as Constants import Prelude -data SessionError +data Error = ConnectionError (Connection.ConnectionError) - | SessionError (Session.QueryError) + | SessionError (Session.SessionError) deriving (Show, Eq) -runSessionOnLocalDb :: Session.Session a -> IO (Either SessionError a) +runSessionOnLocalDb :: Session.Session a -> IO (Either Error a) runSessionOnLocalDb session = runExceptT $ acquire >>= \connection -> use connection <* release connection where @@ -37,7 +37,7 @@ runSessionOnLocalDb session = release connection = lift $ Connection.release connection -runPipelineOnLocalDb :: Pipeline.Pipeline a -> IO (Either SessionError a) +runPipelineOnLocalDb :: Pipeline.Pipeline a -> IO (Either Error a) runPipelineOnLocalDb = runSessionOnLocalDb . Session.pipeline From d88476e2a951bf6a7fb3a9908d71345eba0581fa Mon Sep 17 00:00:00 2001 From: nikita-volkov Date: Sun, 21 Apr 2024 13:08:03 +0000 Subject: [PATCH 14/33] Format --- library/Hasql/PreparedStatementRegistry.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/Hasql/PreparedStatementRegistry.hs b/library/Hasql/PreparedStatementRegistry.hs index 9ae7503..4aad8b2 100644 --- a/library/Hasql/PreparedStatementRegistry.hs +++ b/library/Hasql/PreparedStatementRegistry.hs @@ -8,8 +8,8 @@ where import ByteString.StrictBuilder qualified as B import Data.HashTable.IO qualified as A +import Database.PostgreSQL.LibPQ qualified as Pq import Hasql.Prelude hiding (lookup) -import qualified Database.PostgreSQL.LibPQ as Pq data PreparedStatementRegistry = PreparedStatementRegistry !(A.BasicHashTable LocalKey ByteString) !(IORef Word) From 5e8147b737e4586110764359b2f7d44584fabd7e Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sun, 21 Apr 2024 16:15:51 +0300 Subject: [PATCH 15/33] Revise errors --- hasql.cabal | 1 + library/Hasql/Decoders/All.hs | 2 +- library/Hasql/Decoders/Result.hs | 26 ++- library/Hasql/Decoders/Results.hs | 16 +- library/Hasql/Decoders/Row.hs | 16 +- library/Hasql/Errors.hs | 187 +++++++++--------- library/Hasql/IO.hs | 16 +- library/Hasql/Pipeline/Core.hs | 6 +- library/Hasql/Statement.hs | 2 +- tasty/Main.hs | 2 +- .../Hasql/TestingUtils/TestingDsl.hs | 2 +- 11 files changed, 143 insertions(+), 133 deletions(-) diff --git a/hasql.cabal b/hasql.cabal index 21a412a..9621fff 100644 --- a/hasql.cabal +++ b/hasql.cabal @@ -63,6 +63,7 @@ common base RoleAnnotations ScopedTypeVariables StandaloneDeriving + StrictData TemplateHaskell TupleSections TypeFamilies diff --git a/library/Hasql/Decoders/All.hs b/library/Hasql/Decoders/All.hs index 0281e1f..64d327d 100644 --- a/library/Hasql/Decoders/All.hs +++ b/library/Hasql/Decoders/All.hs @@ -38,7 +38,7 @@ rowsAffected = Result (Results.single Result.rowsAffected) -- | -- Exactly one row. --- Will raise the 'Errors.UnexpectedAmountOfRows' error if it's any other. +-- Will raise the 'Errors.UnexpectedAmountOfRowsResultError' error if it's any other. {-# INLINEABLE singleRow #-} singleRow :: Row a -> Result a singleRow (Row row) = Result (Results.single (Result.single row)) diff --git a/library/Hasql/Decoders/Result.hs b/library/Hasql/Decoders/Result.hs index 5c7de42..54e395e 100644 --- a/library/Hasql/Decoders/Result.hs +++ b/library/Hasql/Decoders/Result.hs @@ -45,13 +45,13 @@ rowsAffected = notNothing >=> notEmpty >=> decimal where notNothing = - Prelude.maybe (Left (UnexpectedResult "No bytes")) Right + Prelude.maybe (Left (UnexpectedResultError "No bytes")) Right notEmpty bytes = if ByteString.null bytes - then Left (UnexpectedResult "Empty bytes") + then Left (UnexpectedResultError "Empty bytes") else Right bytes decimal bytes = - mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m)) + mapLeft (\m -> UnexpectedResultError ("Decimal parsing failure: " <> fromString m)) $ Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes {-# INLINE checkExecStatus #-} @@ -70,7 +70,7 @@ checkExecStatus expectedList = unexpectedResult :: Text -> Result a unexpectedResult = - Result . lift . ExceptT . pure . Left . UnexpectedResult + Result . lift . ExceptT . pure . Left . UnexpectedResultError {-# INLINE serverError #-} serverError :: Result () @@ -90,7 +90,7 @@ serverError = LibPQ.resultErrorField result LibPQ.DiagMessageHint position <- parsePosition <$> LibPQ.resultErrorField result LibPQ.DiagStatementPosition - pure $ Left $ ServerError code message detail hint position + pure $ Left $ ServerResultError code message detail hint position where parsePosition = \case Nothing -> Nothing @@ -112,9 +112,8 @@ maybe rowDec = 0 -> return (Right Nothing) 1 -> do maxCols <- LibPQ.nfields result - let fromRowError (col, err) = RowError 0 col err - fmap (fmap Just . mapLeft fromRowError) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) - _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows))) + fmap (fmap Just . mapLeft (RowResultError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) + _ -> return (Left (UnexpectedAmountOfRowsResultError (rowToInt maxRows))) where rowToInt (LibPQ.Row n) = fromIntegral n @@ -131,9 +130,8 @@ single rowDec = case maxRows of 1 -> do maxCols <- LibPQ.nfields result - let fromRowError (col, err) = RowError 0 col err - fmap (mapLeft fromRowError) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) - _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows))) + fmap (mapLeft (RowResultError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) + _ -> return (Left (UnexpectedAmountOfRowsResultError (rowToInt maxRows))) where rowToInt (LibPQ.Row n) = fromIntegral n @@ -153,7 +151,7 @@ vector rowDec = forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) case rowResult of - Left !(!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x)) + Left !rowError -> writeIORef failureRef (Just (RowResultError rowIndex rowError)) Right !x -> MutableVector.unsafeWrite mvector rowIndex x readIORef failureRef >>= \case Nothing -> Right <$> Vector.unsafeFreeze mvector @@ -183,7 +181,7 @@ foldl step init rowDec = forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) case rowResult of - Left !(!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x)) + Left !rowError -> writeIORef failureRef (Just (RowResultError rowIndex rowError)) Right !x -> modifyIORef' accRef (\acc -> step acc x) readIORef failureRef >>= \case Nothing -> Right <$> readIORef accRef @@ -210,7 +208,7 @@ foldr step init rowDec = forMToZero_ (rowToInt maxRows) $ \rowIndex -> do rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) case rowResult of - Left !(!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x)) + Left !rowError -> writeIORef failureRef (Just (RowResultError rowIndex rowError)) Right !x -> modifyIORef accRef (\acc -> step x acc) readIORef failureRef >>= \case Nothing -> Right <$> readIORef accRef diff --git a/library/Hasql/Decoders/Results.hs b/library/Hasql/Decoders/Results.hs index 0add158..437c509 100644 --- a/library/Hasql/Decoders/Results.hs +++ b/library/Hasql/Decoders/Results.hs @@ -17,11 +17,11 @@ import Hasql.Prelude hiding (many, maybe) import Hasql.Prelude qualified as Prelude newtype Results a - = Results (ReaderT (Bool, LibPQ.Connection) (ExceptT CommandError IO) a) + = Results (ReaderT (Bool, LibPQ.Connection) (ExceptT QueryError IO) a) deriving (Functor, Applicative, Monad) {-# INLINE run #-} -run :: Results a -> LibPQ.Connection -> Bool -> IO (Either CommandError a) +run :: Results a -> LibPQ.Connection -> Bool -> IO (Either QueryError a) run (Results stack) conn idt = runExceptT (runReaderT stack (idt, conn)) @@ -32,7 +32,7 @@ clientError = $ ReaderT $ \(_, connection) -> ExceptT - $ fmap (Left . ClientError) (LibPQ.errorMessage connection) + $ fmap (Left . ClientQueryError) (LibPQ.errorMessage connection) -- | -- Parse a single result. @@ -45,9 +45,9 @@ single resultDec = resultMaybe <- LibPQ.getResult connection case resultMaybe of Just result -> - mapLeft ResultError <$> Result.run resultDec integerDatetimes result + mapLeft ResultQueryError <$> Result.run resultDec integerDatetimes result Nothing -> - fmap (Left . ClientError) (LibPQ.errorMessage connection) + fmap (Left . ClientQueryError) (LibPQ.errorMessage connection) -- | -- Fetch a single result. @@ -60,7 +60,7 @@ getResult = resultMaybe <- LibPQ.getResult connection case resultMaybe of Just result -> pure (Right result) - Nothing -> fmap (Left . ClientError) (LibPQ.errorMessage connection) + Nothing -> fmap (Left . ClientQueryError) (LibPQ.errorMessage connection) -- | -- Fetch a single result. @@ -84,11 +84,11 @@ dropRemainders = loop integerDatetimes connection <* checkErrors where checkErrors = - ExceptT $ fmap (mapLeft ResultError) $ Result.run Result.noResult integerDatetimes result + ExceptT $ fmap (mapLeft ResultQueryError) $ Result.run Result.noResult integerDatetimes result refine :: (a -> Either Text b) -> Results a -> Results b refine refiner (Results stack) = Results $ ReaderT $ \env -> ExceptT $ do resultEither <- runExceptT $ runReaderT stack env - return $ resultEither >>= mapLeft (ResultError . UnexpectedResult) . refiner + return $ resultEither >>= mapLeft (ResultQueryError . UnexpectedResultError) . refiner diff --git a/library/Hasql/Decoders/Row.hs b/library/Hasql/Decoders/Row.hs index 69f291b..cf8d71d 100644 --- a/library/Hasql/Decoders/Row.hs +++ b/library/Hasql/Decoders/Row.hs @@ -7,11 +7,11 @@ import Hasql.Prelude hiding (error) import PostgreSQL.Binary.Decoding qualified as A newtype Row a - = Row (ReaderT Env (ExceptT RowError IO) a) + = Row (ReaderT Env (ExceptT ColumnError IO) a) deriving (Functor, Applicative, Monad) instance MonadFail Row where - fail = error . ValueError . fromString + fail = error . ValueColumnError . fromString data Env = Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column) @@ -19,7 +19,7 @@ data Env -- * Functions {-# INLINE run #-} -run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either (Int, RowError) a) +run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either RowError a) run (Row impl) (result, row, columnsAmount, integerDatetimes) = do columnRef <- newIORef 0 @@ -27,11 +27,11 @@ run (Row impl) (result, row, columnsAmount, integerDatetimes) = Left e -> do LibPQ.Col col <- readIORef columnRef -- -1 because succ is applied before the error is returned - pure $ Left (fromIntegral col - 1, e) + pure $ Left (ColumnRowError (fromIntegral col - 1) e) Right x -> pure $ Right x {-# INLINE error #-} -error :: RowError -> Row a +error :: ColumnError -> Row a error x = Row (ReaderT (const (ExceptT (pure (Left x))))) @@ -55,9 +55,9 @@ value valueDec = Right Nothing Just value -> fmap Just - $ mapLeft ValueError + $ mapLeft ValueColumnError $ {-# SCC "decode" #-} A.valueParser (Value.run valueDec integerDatetimes) value - else pure (Left EndOfInput) + else pure (Left EndOfInputColumnError) -- | -- Next value, decoded using the provided value decoder. @@ -65,4 +65,4 @@ value valueDec = nonNullValue :: Value.Value a -> Row a nonNullValue valueDec = {-# SCC "nonNullValue" #-} - value valueDec >>= maybe (error UnexpectedNull) pure + value valueDec >>= maybe (error UnexpectedNullColumnError) pure diff --git a/library/Hasql/Errors.hs b/library/Hasql/Errors.hs index 600871d..05c428a 100644 --- a/library/Hasql/Errors.hs +++ b/library/Hasql/Errors.hs @@ -1,13 +1,3 @@ --- | --- An API for retrieval of multiple results. --- Can be used to handle: --- --- * A single result, --- --- * Individual results of a multi-statement query --- with the help of "Applicative" and "Monad", --- --- * Row-by-row fetching. module Hasql.Errors where import Data.ByteString.Char8 qualified as BC @@ -18,90 +8,97 @@ data SessionError = -- | -- An error during the execution of a query. -- Comes packed with the query template and a textual representation of the provided params. - QuerySessionError ByteString [Text] CommandError + QuerySessionError + -- | SQL template. + ByteString + -- | Parameters rendered as human-readable SQL literals. + [Text] + -- | Error details + QueryError deriving (Show, Eq, Typeable) instance Exception SessionError where - displayException (QuerySessionError query params commandError) = - let queryContext :: Maybe (ByteString, Int) - queryContext = case commandError of - ClientError _ -> Nothing - ResultError resultError -> case resultError of - ServerError _ message _ _ (Just position) -> Just (message, position) - _ -> Nothing + displayException = \case + QuerySessionError query params commandError -> + let queryContext :: Maybe (ByteString, Int) + queryContext = case commandError of + ClientQueryError _ -> Nothing + ResultQueryError resultError -> case resultError of + ServerResultError _ message _ _ (Just position) -> Just (message, position) + _ -> Nothing - -- find the line number and position of the error - findLineAndPos :: ByteString -> Int -> (Int, Int) - findLineAndPos byteString errorPos = - let (_, line, pos) = - BC.foldl' - ( \(total, line, pos) c -> - case total + 1 of - 0 -> (total, line, pos) - cursor - | cursor == errorPos -> (-1, line, pos + 1) - | c == '\n' -> (total + 1, line + 1, 0) - | otherwise -> (total + 1, line, pos + 1) - ) - (0, 1, 0) - byteString - in (line, pos) + -- find the line number and position of the error + findLineAndPos :: ByteString -> Int -> (Int, Int) + findLineAndPos byteString errorPos = + let (_, line, pos) = + BC.foldl' + ( \(total, line, pos) c -> + case total + 1 of + 0 -> (total, line, pos) + cursor + | cursor == errorPos -> (-1, line, pos + 1) + | c == '\n' -> (total + 1, line + 1, 0) + | otherwise -> (total + 1, line, pos + 1) + ) + (0, 1, 0) + byteString + in (line, pos) - formatErrorContext :: ByteString -> ByteString -> Int -> ByteString - formatErrorContext query message errorPos = - let lines = BC.lines query - (lineNum, linePos) = findLineAndPos query errorPos - in BC.unlines (take lineNum lines) - <> BC.replicate (linePos - 1) ' ' - <> "^ " - <> message + formatErrorContext :: ByteString -> ByteString -> Int -> ByteString + formatErrorContext query message errorPos = + let lines = BC.lines query + (lineNum, linePos) = findLineAndPos query errorPos + in BC.unlines (take lineNum lines) + <> BC.replicate (linePos - 1) ' ' + <> "^ " + <> message - prettyQuery :: ByteString - prettyQuery = case queryContext of - Nothing -> query - Just (message, pos) -> formatErrorContext query message pos - in "QuerySessionError!\n" - <> "\n Query:\n" - <> BC.unpack prettyQuery - <> "\n" - <> "\n Params: " - <> show params - <> "\n Error: " - <> case commandError of - ClientError (Just message) -> "Client error: " <> show message - ClientError Nothing -> "Unknown client error" - ResultError resultError -> case resultError of - ServerError code message details hint position -> - "Server error " - <> BC.unpack code - <> ": " - <> BC.unpack message - <> maybe "" (\d -> "\n Details: " <> BC.unpack d) details - <> maybe "" (\h -> "\n Hint: " <> BC.unpack h) hint - UnexpectedResult message -> "Unexpected result: " <> show message - RowError row column rowError -> - "Row error: " <> show row <> ":" <> show column <> " " <> show rowError - UnexpectedAmountOfRows amount -> - "Unexpected amount of rows: " <> show amount + prettyQuery :: ByteString + prettyQuery = case queryContext of + Nothing -> query + Just (message, pos) -> formatErrorContext query message pos + in "QuerySessionError!\n" + <> "\n Query:\n" + <> BC.unpack prettyQuery + <> "\n" + <> "\n Params: " + <> show params + <> "\n Error: " + <> case commandError of + ClientQueryError (Just message) -> "Client error: " <> show message + ClientQueryError Nothing -> "Client error without details" + ResultQueryError resultError -> case resultError of + ServerResultError code message details hint position -> + "Server error " + <> BC.unpack code + <> ": " + <> BC.unpack message + <> maybe "" (\d -> "\n Details: " <> BC.unpack d) details + <> maybe "" (\h -> "\n Hint: " <> BC.unpack h) hint + UnexpectedResultError message -> "Unexpected result: " <> show message + RowResultError row (ColumnRowError column rowError) -> + "Row error: " <> show row <> ":" <> show column <> " " <> show rowError + UnexpectedAmountOfRowsResultError amount -> + "Unexpected amount of rows: " <> show amount -- | -- An error of some command in the session. -data CommandError +data QueryError = -- | -- An error on the client-side, - -- with a message generated by the \"libpq\" library. + -- with a message generated by the \"libpq\" driver. -- Usually indicates problems with connection. - ClientError (Maybe ByteString) + ClientQueryError (Maybe ByteString) | -- | -- Some error with a command result. - ResultError ResultError + ResultQueryError ResultError deriving (Show, Eq) -- | -- An error with a command result. data ResultError = -- | An error reported by the DB. - ServerError + ServerResultError -- | __Code__. The SQLSTATE code for the error. It's recommended to use -- to work with those. @@ -120,29 +117,43 @@ data ResultError -- | __Position__. Error cursor position as an index into the original -- statement string. Positions are measured in characters not bytes. (Maybe Int) - | -- | - -- The database returned an unexpected result. + | -- | The database returned an unexpected result. -- Indicates an improper statement or a schema mismatch. - UnexpectedResult Text - | -- | - -- An error of the row reader, preceded by the indexes of the row and column. - RowError Int Int RowError - | -- | - -- An unexpected amount of rows. - UnexpectedAmountOfRows Int + UnexpectedResultError + -- | Details. + Text + | -- | Error decoding a specific row. + RowResultError + -- | Row index. + Int + -- | Details. + RowError + | -- | Unexpected amount of rows. + UnexpectedAmountOfRowsResultError + -- | Actual amount of rows in the result. + Int + deriving (Show, Eq) + +data RowError + = -- | Error at a specific column. + ColumnRowError + -- | Column index. + Int + -- | Error details. + ColumnError deriving (Show, Eq) -- | --- An error during the decoding of a specific row. -data RowError +-- Error during the decoding of a specific column. +data ColumnError = -- | -- Appears on the attempt to parse more columns than there are in the result. - EndOfInput + EndOfInputColumnError | -- | -- Appears on the attempt to parse a @NULL@ as some value. - UnexpectedNull + UnexpectedNullColumnError | -- | -- Appears when a wrong value parser is used. -- Comes with the error details. - ValueError Text + ValueColumnError Text deriving (Show, Eq) diff --git a/library/Hasql/IO.hs b/library/Hasql/IO.hs index 9facdb1..dbd3e88 100644 --- a/library/Hasql/IO.hs +++ b/library/Hasql/IO.hs @@ -56,7 +56,7 @@ initConnection c = void $ LibPQ.exec c (Commands.asBytes (Commands.setEncodersToUTF8 <> Commands.setMinClientMessagesToWarning)) {-# INLINE getResults #-} -getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either CommandError a) +getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either QueryError a) getResults connection integerDatetimes decoder = {-# SCC "getResults" #-} (<*) <$> get <*> dropRemainders @@ -72,7 +72,7 @@ getPreparedStatementKey :: PreparedStatementRegistry.PreparedStatementRegistry -> ByteString -> [LibPQ.Oid] -> - IO (Either CommandError ByteString) + IO (Either QueryError ByteString) getPreparedStatementKey connection registry template oidList = {-# SCC "getPreparedStatementKey" #-} PreparedStatementRegistry.update localKey onNewRemoteKey onOldRemoteKey registry @@ -96,10 +96,10 @@ getPreparedStatementKey connection registry template oidList = pure (pure key) {-# INLINE checkedSend #-} -checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either CommandError ()) +checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either QueryError ()) checkedSend connection send = send >>= \case - False -> fmap (Left . ClientError) $ LibPQ.errorMessage connection + False -> fmap (Left . ClientQueryError) $ LibPQ.errorMessage connection True -> pure (Right ()) {-# INLINE sendPreparedParametricStatement #-} @@ -110,7 +110,7 @@ sendPreparedParametricStatement :: ByteString -> ParamsEncoders.Params a -> a -> - IO (Either CommandError ()) + IO (Either QueryError ()) sendPreparedParametricStatement connection registry integerDatetimes template encoder input = runExceptT $ do key <- ExceptT $ getPreparedStatementKey connection registry template oidList @@ -126,7 +126,7 @@ sendUnpreparedParametricStatement :: ByteString -> ParamsEncoders.Params a -> a -> - IO (Either CommandError ()) + IO (Either QueryError ()) sendUnpreparedParametricStatement connection integerDatetimes template encoder input = checkedSend connection $ LibPQ.sendQueryParams @@ -144,7 +144,7 @@ sendParametricStatement :: ParamsEncoders.Params a -> Bool -> a -> - IO (Either CommandError ()) + IO (Either QueryError ()) sendParametricStatement connection integerDatetimes registry template encoder prepared params = {-# SCC "sendParametricStatement" #-} if prepared @@ -152,6 +152,6 @@ sendParametricStatement connection integerDatetimes registry template encoder pr else sendUnpreparedParametricStatement connection integerDatetimes template encoder params {-# INLINE sendNonparametricStatement #-} -sendNonparametricStatement :: LibPQ.Connection -> ByteString -> IO (Either CommandError ()) +sendNonparametricStatement :: LibPQ.Connection -> ByteString -> IO (Either QueryError ()) sendNonparametricStatement connection sql = checkedSend connection $ LibPQ.sendQuery connection sql diff --git a/library/Hasql/Pipeline/Core.hs b/library/Hasql/Pipeline/Core.hs index 5af7371..9b4a388 100644 --- a/library/Hasql/Pipeline/Core.hs +++ b/library/Hasql/Pipeline/Core.hs @@ -89,7 +89,7 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re sent <- Pq.sendPrepare connection key sql (mfilter (not . null) (Just oidList)) if sent then pure (True, Right (key, recv)) - else (False,) . Left . commandToSessionError . ClientError <$> Pq.errorMessage connection + else (False,) . Left . commandToSessionError . ClientQueryError <$> Pq.errorMessage connection where recv = fmap (mapLeft commandToSessionError) @@ -101,7 +101,7 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re sendQuery key = Pq.sendQueryPrepared connection key valueAndFormatList Pq.Binary >>= \case - False -> Left . commandToSessionError . ClientError <$> Pq.errorMessage connection + False -> Left . commandToSessionError . ClientQueryError <$> Pq.errorMessage connection True -> pure (Right recv) where recv = @@ -112,7 +112,7 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re runUnprepared = Pq.sendQueryParams connection sql (Encoders.Params.compileUnpreparedStatementData encoder integerDatetimes params) Pq.Binary >>= \case - False -> Left . commandToSessionError . ClientError <$> Pq.errorMessage connection + False -> Left . commandToSessionError . ClientQueryError <$> Pq.errorMessage connection True -> pure (Right recv) where recv = diff --git a/library/Hasql/Statement.hs b/library/Hasql/Statement.hs index 5bc0aaf..1b3a7e0 100644 --- a/library/Hasql/Statement.hs +++ b/library/Hasql/Statement.hs @@ -75,7 +75,7 @@ instance Profunctor Statement where -- | -- Refine the result of a statement, --- causing the running session to fail with the `UnexpectedResult` error in case of a refinement failure. +-- causing the running session to fail with the `UnexpectedResultError` error in case of a refinement failure. -- -- This function is especially useful for refining the results of statements produced with -- . diff --git a/tasty/Main.hs b/tasty/Main.hs index 0ec1393..cfb338f 100644 --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -218,7 +218,7 @@ tree = where resultTest = \case - Right (Left (Session.QuerySessionError _ _ (Session.ResultError (Session.ServerError "26000" _ _ _ _)))) -> False + Right (Left (Session.QuerySessionError _ _ (Session.ResultQueryError (Session.ServerResultError "26000" _ _ _ _)))) -> False _ -> True session = catchError session (const (pure ())) *> session diff --git a/testing-utils/Hasql/TestingUtils/TestingDsl.hs b/testing-utils/Hasql/TestingUtils/TestingDsl.hs index a7a450f..82e166c 100644 --- a/testing-utils/Hasql/TestingUtils/TestingDsl.hs +++ b/testing-utils/Hasql/TestingUtils/TestingDsl.hs @@ -2,7 +2,7 @@ module Hasql.TestingUtils.TestingDsl ( Session.Session, Error (..), Session.SessionError (..), - Session.CommandError (..), + Session.QueryError (..), Pipeline.Pipeline, Statement.Statement (..), runSessionOnLocalDb, From 8f5d6f7e819e20040fd1f1436f6c01633e6b1b5a Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 22 Apr 2024 07:02:26 +0300 Subject: [PATCH 16/33] Implement pipeline errors --- hasql.cabal | 2 +- library/Hasql/Decoders/Results.hs | 16 ++--- library/Hasql/Errors.hs | 56 +++++++++------- library/Hasql/IO.hs | 16 ++--- library/Hasql/Pipeline/Core.hs | 67 +++++++++++-------- library/Hasql/Prelude.hs | 2 +- library/Hasql/Session/Core.hs | 4 +- tasty/Main.hs | 2 +- .../Hasql/TestingUtils/TestingDsl.hs | 2 +- 9 files changed, 95 insertions(+), 72 deletions(-) diff --git a/hasql.cabal b/hasql.cabal index 9621fff..f638445 100644 --- a/hasql.cabal +++ b/hasql.cabal @@ -138,7 +138,7 @@ library text >=1 && <3, text-builder >=0.6.7 && <0.7, time >=1.9 && <2, - transformers >=0.3 && <0.7, + transformers >=0.6 && <0.7, uuid >=1.3 && <2, vector >=0.10 && <0.14, diff --git a/library/Hasql/Decoders/Results.hs b/library/Hasql/Decoders/Results.hs index 437c509..87c92d0 100644 --- a/library/Hasql/Decoders/Results.hs +++ b/library/Hasql/Decoders/Results.hs @@ -17,11 +17,11 @@ import Hasql.Prelude hiding (many, maybe) import Hasql.Prelude qualified as Prelude newtype Results a - = Results (ReaderT (Bool, LibPQ.Connection) (ExceptT QueryError IO) a) + = Results (ReaderT (Bool, LibPQ.Connection) (ExceptT CommandError IO) a) deriving (Functor, Applicative, Monad) {-# INLINE run #-} -run :: Results a -> LibPQ.Connection -> Bool -> IO (Either QueryError a) +run :: Results a -> LibPQ.Connection -> Bool -> IO (Either CommandError a) run (Results stack) conn idt = runExceptT (runReaderT stack (idt, conn)) @@ -32,7 +32,7 @@ clientError = $ ReaderT $ \(_, connection) -> ExceptT - $ fmap (Left . ClientQueryError) (LibPQ.errorMessage connection) + $ fmap (Left . ClientCommandError) (LibPQ.errorMessage connection) -- | -- Parse a single result. @@ -45,9 +45,9 @@ single resultDec = resultMaybe <- LibPQ.getResult connection case resultMaybe of Just result -> - mapLeft ResultQueryError <$> Result.run resultDec integerDatetimes result + mapLeft ResultCommandError <$> Result.run resultDec integerDatetimes result Nothing -> - fmap (Left . ClientQueryError) (LibPQ.errorMessage connection) + fmap (Left . ClientCommandError) (LibPQ.errorMessage connection) -- | -- Fetch a single result. @@ -60,7 +60,7 @@ getResult = resultMaybe <- LibPQ.getResult connection case resultMaybe of Just result -> pure (Right result) - Nothing -> fmap (Left . ClientQueryError) (LibPQ.errorMessage connection) + Nothing -> fmap (Left . ClientCommandError) (LibPQ.errorMessage connection) -- | -- Fetch a single result. @@ -84,11 +84,11 @@ dropRemainders = loop integerDatetimes connection <* checkErrors where checkErrors = - ExceptT $ fmap (mapLeft ResultQueryError) $ Result.run Result.noResult integerDatetimes result + ExceptT $ fmap (mapLeft ResultCommandError) $ Result.run Result.noResult integerDatetimes result refine :: (a -> Either Text b) -> Results a -> Results b refine refiner (Results stack) = Results $ ReaderT $ \env -> ExceptT $ do resultEither <- runExceptT $ runReaderT stack env - return $ resultEither >>= mapLeft (ResultQueryError . UnexpectedResultError) . refiner + return $ resultEither >>= mapLeft (ResultCommandError . UnexpectedResultError) . refiner diff --git a/library/Hasql/Errors.hs b/library/Hasql/Errors.hs index 05c428a..e4b72df 100644 --- a/library/Hasql/Errors.hs +++ b/library/Hasql/Errors.hs @@ -13,8 +13,12 @@ data SessionError ByteString -- | Parameters rendered as human-readable SQL literals. [Text] - -- | Error details - QueryError + -- | Error details. + CommandError + | -- | Error during the execution of a pipeline. + PipelineSessionError + -- | Error details. + CommandError deriving (Show, Eq, Typeable) instance Exception SessionError where @@ -22,8 +26,8 @@ instance Exception SessionError where QuerySessionError query params commandError -> let queryContext :: Maybe (ByteString, Int) queryContext = case commandError of - ClientQueryError _ -> Nothing - ResultQueryError resultError -> case resultError of + ClientCommandError _ -> Nothing + ResultCommandError resultError -> case resultError of ServerResultError _ message _ _ (Just position) -> Just (message, position) _ -> Nothing @@ -63,35 +67,39 @@ instance Exception SessionError where <> "\n" <> "\n Params: " <> show params - <> "\n Error: " - <> case commandError of - ClientQueryError (Just message) -> "Client error: " <> show message - ClientQueryError Nothing -> "Client error without details" - ResultQueryError resultError -> case resultError of - ServerResultError code message details hint position -> - "Server error " - <> BC.unpack code - <> ": " - <> BC.unpack message - <> maybe "" (\d -> "\n Details: " <> BC.unpack d) details - <> maybe "" (\h -> "\n Hint: " <> BC.unpack h) hint - UnexpectedResultError message -> "Unexpected result: " <> show message - RowResultError row (ColumnRowError column rowError) -> - "Row error: " <> show row <> ":" <> show column <> " " <> show rowError - UnexpectedAmountOfRowsResultError amount -> - "Unexpected amount of rows: " <> show amount + <> "\n Reason: " + <> renderCommandErrorAsReason commandError + PipelineSessionError commandError -> + "PipelineSessionError!\n Reason: " <> renderCommandErrorAsReason commandError + where + renderCommandErrorAsReason = \case + ClientCommandError (Just message) -> "Client error: " <> show message + ClientCommandError Nothing -> "Client error without details" + ResultCommandError resultError -> case resultError of + ServerResultError code message details hint position -> + "Server error " + <> BC.unpack code + <> ": " + <> BC.unpack message + <> maybe "" (\d -> "\n Details: " <> BC.unpack d) details + <> maybe "" (\h -> "\n Hint: " <> BC.unpack h) hint + UnexpectedResultError message -> "Unexpected result: " <> show message + RowResultError row (ColumnRowError column rowError) -> + "Row error: " <> show row <> ":" <> show column <> " " <> show rowError + UnexpectedAmountOfRowsResultError amount -> + "Unexpected amount of rows: " <> show amount -- | -- An error of some command in the session. -data QueryError +data CommandError = -- | -- An error on the client-side, -- with a message generated by the \"libpq\" driver. -- Usually indicates problems with connection. - ClientQueryError (Maybe ByteString) + ClientCommandError (Maybe ByteString) | -- | -- Some error with a command result. - ResultQueryError ResultError + ResultCommandError ResultError deriving (Show, Eq) -- | diff --git a/library/Hasql/IO.hs b/library/Hasql/IO.hs index dbd3e88..05edf74 100644 --- a/library/Hasql/IO.hs +++ b/library/Hasql/IO.hs @@ -56,7 +56,7 @@ initConnection c = void $ LibPQ.exec c (Commands.asBytes (Commands.setEncodersToUTF8 <> Commands.setMinClientMessagesToWarning)) {-# INLINE getResults #-} -getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either QueryError a) +getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either CommandError a) getResults connection integerDatetimes decoder = {-# SCC "getResults" #-} (<*) <$> get <*> dropRemainders @@ -72,7 +72,7 @@ getPreparedStatementKey :: PreparedStatementRegistry.PreparedStatementRegistry -> ByteString -> [LibPQ.Oid] -> - IO (Either QueryError ByteString) + IO (Either CommandError ByteString) getPreparedStatementKey connection registry template oidList = {-# SCC "getPreparedStatementKey" #-} PreparedStatementRegistry.update localKey onNewRemoteKey onOldRemoteKey registry @@ -96,10 +96,10 @@ getPreparedStatementKey connection registry template oidList = pure (pure key) {-# INLINE checkedSend #-} -checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either QueryError ()) +checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either CommandError ()) checkedSend connection send = send >>= \case - False -> fmap (Left . ClientQueryError) $ LibPQ.errorMessage connection + False -> fmap (Left . ClientCommandError) $ LibPQ.errorMessage connection True -> pure (Right ()) {-# INLINE sendPreparedParametricStatement #-} @@ -110,7 +110,7 @@ sendPreparedParametricStatement :: ByteString -> ParamsEncoders.Params a -> a -> - IO (Either QueryError ()) + IO (Either CommandError ()) sendPreparedParametricStatement connection registry integerDatetimes template encoder input = runExceptT $ do key <- ExceptT $ getPreparedStatementKey connection registry template oidList @@ -126,7 +126,7 @@ sendUnpreparedParametricStatement :: ByteString -> ParamsEncoders.Params a -> a -> - IO (Either QueryError ()) + IO (Either CommandError ()) sendUnpreparedParametricStatement connection integerDatetimes template encoder input = checkedSend connection $ LibPQ.sendQueryParams @@ -144,7 +144,7 @@ sendParametricStatement :: ParamsEncoders.Params a -> Bool -> a -> - IO (Either QueryError ()) + IO (Either CommandError ()) sendParametricStatement connection integerDatetimes registry template encoder prepared params = {-# SCC "sendParametricStatement" #-} if prepared @@ -152,6 +152,6 @@ sendParametricStatement connection integerDatetimes registry template encoder pr else sendUnpreparedParametricStatement connection integerDatetimes template encoder params {-# INLINE sendNonparametricStatement #-} -sendNonparametricStatement :: LibPQ.Connection -> ByteString -> IO (Either QueryError ()) +sendNonparametricStatement :: LibPQ.Connection -> ByteString -> IO (Either CommandError ()) sendNonparametricStatement connection sql = checkedSend connection $ LibPQ.sendQuery connection sql diff --git a/library/Hasql/Pipeline/Core.hs b/library/Hasql/Pipeline/Core.hs index 9b4a388..e73d60a 100644 --- a/library/Hasql/Pipeline/Core.hs +++ b/library/Hasql/Pipeline/Core.hs @@ -1,41 +1,54 @@ -{-# OPTIONS_GHC -Wno-unused-imports -Wno-unused-binds #-} - module Hasql.Pipeline.Core where import Database.PostgreSQL.LibPQ qualified as Pq -import Hasql.Connection.Core qualified as Connection import Hasql.Decoders.All qualified as Decoders import Hasql.Decoders.Result qualified as Decoders.Result import Hasql.Decoders.Results qualified as Decoders.Results import Hasql.Encoders.All qualified as Encoders import Hasql.Encoders.Params qualified as Encoders.Params import Hasql.Errors -import Hasql.IO qualified as IO import Hasql.Prelude import Hasql.PreparedStatementRegistry qualified as PreparedStatementRegistry import Hasql.Statement qualified as Statement -run :: Pipeline a -> Connection.Connection -> IO (Either SessionError a) -run (Pipeline send) (Connection.Connection pqConnectionRef integerDatetimes registry) = - withMVar pqConnectionRef \pqConnection -> do - runCommandFailing pqConnection $ Pq.enterPipelineMode pqConnection - sendResult <- send pqConnection registry integerDatetimes - case sendResult of - Left err -> do - pure (Left err) - Right recv -> do - runCommandFailing pqConnection $ Pq.pipelineSync pqConnection - recvResult <- recv - handleEither =<< Decoders.Results.run (Decoders.Results.single Decoders.Result.pipelineSync) pqConnection integerDatetimes - runCommandFailing pqConnection $ Pq.exitPipelineMode pqConnection - pure recvResult +run :: forall a. Pipeline a -> Pq.Connection -> PreparedStatementRegistry.PreparedStatementRegistry -> Bool -> IO (Either SessionError a) +run (Pipeline sendQueriesInIO) connection registry integerDatetimes = do + runExceptT do + enterPipelineMode + flip finallyE exitPipelineMode do + recvQueries <- sendQueries + pipelineSync + queriesResult <- recvQueries + recvPipelineSync + pure queriesResult where - runCommandFailing :: Pq.Connection -> IO Bool -> IO () - runCommandFailing pqConn runCmd = - IO.checkedSend pqConn runCmd >>= handleEither - handleEither = \case - Right a -> pure a - Left err -> fail $ show err + enterPipelineMode :: ExceptT SessionError IO () + enterPipelineMode = + runCommand $ Pq.enterPipelineMode connection + + exitPipelineMode :: ExceptT SessionError IO () + exitPipelineMode = + runCommand $ Pq.exitPipelineMode connection + + sendQueries :: ExceptT SessionError IO (ExceptT SessionError IO a) + sendQueries = + fmap ExceptT $ ExceptT $ sendQueriesInIO connection registry integerDatetimes + + pipelineSync :: ExceptT SessionError IO () + pipelineSync = + runCommand $ Pq.pipelineSync connection + + recvPipelineSync :: ExceptT SessionError IO () + recvPipelineSync = + ExceptT + $ fmap (mapLeft PipelineSessionError) + $ Decoders.Results.run (Decoders.Results.single Decoders.Result.pipelineSync) connection integerDatetimes + + runCommand :: IO Bool -> ExceptT SessionError IO () + runCommand action = + lift action >>= \case + True -> pure () + False -> ExceptT (Left . PipelineSessionError . ClientCommandError <$> Pq.errorMessage connection) newtype Pipeline a = Pipeline @@ -89,7 +102,7 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re sent <- Pq.sendPrepare connection key sql (mfilter (not . null) (Just oidList)) if sent then pure (True, Right (key, recv)) - else (False,) . Left . commandToSessionError . ClientQueryError <$> Pq.errorMessage connection + else (False,) . Left . commandToSessionError . ClientCommandError <$> Pq.errorMessage connection where recv = fmap (mapLeft commandToSessionError) @@ -101,7 +114,7 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re sendQuery key = Pq.sendQueryPrepared connection key valueAndFormatList Pq.Binary >>= \case - False -> Left . commandToSessionError . ClientQueryError <$> Pq.errorMessage connection + False -> Left . commandToSessionError . ClientCommandError <$> Pq.errorMessage connection True -> pure (Right recv) where recv = @@ -112,7 +125,7 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re runUnprepared = Pq.sendQueryParams connection sql (Encoders.Params.compileUnpreparedStatementData encoder integerDatetimes params) Pq.Binary >>= \case - False -> Left . commandToSessionError . ClientQueryError <$> Pq.errorMessage connection + False -> Left . commandToSessionError . ClientCommandError <$> Pq.errorMessage connection True -> pure (Right recv) where recv = diff --git a/library/Hasql/Prelude.hs b/library/Hasql/Prelude.hs index c6d2403..88e6911 100644 --- a/library/Hasql/Prelude.hs +++ b/library/Hasql/Prelude.hs @@ -25,7 +25,7 @@ import Control.Monad.Reader.Class as Exports (MonadReader (..)) import Control.Monad.ST as Exports import Control.Monad.Trans.Class as Exports import Control.Monad.Trans.Cont as Exports hiding (callCC, shift) -import Control.Monad.Trans.Except as Exports (Except, ExceptT (ExceptT), catchE, except, mapExcept, mapExceptT, runExcept, runExceptT, throwE, withExcept, withExceptT) +import Control.Monad.Trans.Except as Exports (Except, ExceptT (ExceptT), catchE, except, finallyE, mapExcept, mapExceptT, runExcept, runExceptT, throwE, withExcept, withExceptT) import Control.Monad.Trans.Maybe as Exports import Control.Monad.Trans.Reader as Exports (Reader, ReaderT (ReaderT), mapReader, mapReaderT, runReader, runReaderT, withReader, withReaderT) import Control.Monad.Trans.State.Strict as Exports (State, StateT (StateT), evalState, evalStateT, execState, execStateT, mapState, mapStateT, runState, runStateT, withState, withStateT) diff --git a/library/Hasql/Session/Core.hs b/library/Hasql/Session/Core.hs index 62164d6..23c3db0 100644 --- a/library/Hasql/Session/Core.hs +++ b/library/Hasql/Session/Core.hs @@ -62,4 +62,6 @@ statement input (Statement.Statement template (Encoders.Params paramsEncoder) (D pipeline :: Pipeline.Pipeline result -> Session result pipeline pipeline = - Session $ ReaderT $ ExceptT . Pipeline.run pipeline + Session $ ReaderT \(Connection.Connection pqConnectionRef integerDatetimes registry) -> + ExceptT $ withMVar pqConnectionRef \pqConnection -> + Pipeline.run pipeline pqConnection registry integerDatetimes diff --git a/tasty/Main.hs b/tasty/Main.hs index cfb338f..71149e2 100644 --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -218,7 +218,7 @@ tree = where resultTest = \case - Right (Left (Session.QuerySessionError _ _ (Session.ResultQueryError (Session.ServerResultError "26000" _ _ _ _)))) -> False + Right (Left (Session.QuerySessionError _ _ (Session.ResultCommandError (Session.ServerResultError "26000" _ _ _ _)))) -> False _ -> True session = catchError session (const (pure ())) *> session diff --git a/testing-utils/Hasql/TestingUtils/TestingDsl.hs b/testing-utils/Hasql/TestingUtils/TestingDsl.hs index 82e166c..a7a450f 100644 --- a/testing-utils/Hasql/TestingUtils/TestingDsl.hs +++ b/testing-utils/Hasql/TestingUtils/TestingDsl.hs @@ -2,7 +2,7 @@ module Hasql.TestingUtils.TestingDsl ( Session.Session, Error (..), Session.SessionError (..), - Session.QueryError (..), + Session.CommandError (..), Pipeline.Pipeline, Statement.Statement (..), runSessionOnLocalDb, From b4ed0eab56584bb3ed122b40a9ef9ecebcb2d40a Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 22 Apr 2024 07:32:56 +0300 Subject: [PATCH 17/33] Rename testing-utils to testing-kit --- hasql.cabal | 14 +++++++------- hspec/Hasql/PipelineSpec.hs | 4 ++-- tasty/Main.hs | 2 +- .../Hasql/TestingKit}/Constants.hs | 2 +- .../Hasql/TestingKit}/Statements/GenerateSeries.hs | 2 +- .../Hasql/TestingKit}/TestingDsl.hs | 4 ++-- 6 files changed, 14 insertions(+), 14 deletions(-) rename {testing-utils/Hasql/TestingUtils => testing-kit/Hasql/TestingKit}/Constants.hs (87%) rename {testing-utils/Hasql/TestingUtils => testing-kit/Hasql/TestingKit}/Statements/GenerateSeries.hs (94%) rename {testing-utils/Hasql/TestingUtils => testing-kit/Hasql/TestingKit}/TestingDsl.hs (93%) diff --git a/hasql.cabal b/hasql.cabal index f638445..dc0f775 100644 --- a/hasql.cabal +++ b/hasql.cabal @@ -142,13 +142,13 @@ library uuid >=1.3 && <2, vector >=0.10 && <0.14, -library testing-utils +library testing-kit import: base - hs-source-dirs: testing-utils + hs-source-dirs: testing-kit exposed-modules: - Hasql.TestingUtils.Constants - Hasql.TestingUtils.Statements.GenerateSeries - Hasql.TestingUtils.TestingDsl + Hasql.TestingKit.Constants + Hasql.TestingKit.Statements.GenerateSeries + Hasql.TestingKit.TestingDsl build-depends: hasql, @@ -167,7 +167,7 @@ test-suite tasty build-depends: contravariant-extras >=0.3.5.2 && <0.4, hasql, - hasql:testing-utils, + hasql:testing-kit, quickcheck-instances >=0.3.11 && <0.4, rerebase <2, tasty >=0.12 && <2, @@ -218,6 +218,6 @@ test-suite hspec build-tool-depends: hspec-discover:hspec-discover build-depends: - hasql:testing-utils, + hasql:testing-kit, hspec, rerebase >=1 && <2, diff --git a/hspec/Hasql/PipelineSpec.hs b/hspec/Hasql/PipelineSpec.hs index ea93c39..56d172a 100644 --- a/hspec/Hasql/PipelineSpec.hs +++ b/hspec/Hasql/PipelineSpec.hs @@ -1,7 +1,7 @@ module Hasql.PipelineSpec (spec) where -import Hasql.TestingUtils.Statements.GenerateSeries qualified as GenerateSeries -import Hasql.TestingUtils.TestingDsl qualified as Dsl +import Hasql.TestingKit.Statements.GenerateSeries qualified as GenerateSeries +import Hasql.TestingKit.TestingDsl qualified as Dsl import Test.Hspec import Prelude diff --git a/tasty/Main.hs b/tasty/Main.hs index 71149e2..f6eee91 100644 --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -5,7 +5,7 @@ import Hasql.Decoders qualified as Decoders import Hasql.Encoders qualified as Encoders import Hasql.Session qualified as Session import Hasql.Statement qualified as Statement -import Hasql.TestingUtils.TestingDsl qualified as Session +import Hasql.TestingKit.TestingDsl qualified as Session import Main.Connection qualified as Connection import Main.Prelude hiding (assert) import Main.Statements qualified as Statements diff --git a/testing-utils/Hasql/TestingUtils/Constants.hs b/testing-kit/Hasql/TestingKit/Constants.hs similarity index 87% rename from testing-utils/Hasql/TestingUtils/Constants.hs rename to testing-kit/Hasql/TestingKit/Constants.hs index be657f7..584550e 100644 --- a/testing-utils/Hasql/TestingUtils/Constants.hs +++ b/testing-kit/Hasql/TestingKit/Constants.hs @@ -1,4 +1,4 @@ -module Hasql.TestingUtils.Constants where +module Hasql.TestingKit.Constants where import Hasql.Connection qualified as Connection diff --git a/testing-utils/Hasql/TestingUtils/Statements/GenerateSeries.hs b/testing-kit/Hasql/TestingKit/Statements/GenerateSeries.hs similarity index 94% rename from testing-utils/Hasql/TestingUtils/Statements/GenerateSeries.hs rename to testing-kit/Hasql/TestingKit/Statements/GenerateSeries.hs index 67937e2..4cf98b6 100644 --- a/testing-utils/Hasql/TestingUtils/Statements/GenerateSeries.hs +++ b/testing-kit/Hasql/TestingKit/Statements/GenerateSeries.hs @@ -1,4 +1,4 @@ -module Hasql.TestingUtils.Statements.GenerateSeries where +module Hasql.TestingKit.Statements.GenerateSeries where import Hasql.Decoders qualified as Decoders import Hasql.Encoders qualified as Encoders diff --git a/testing-utils/Hasql/TestingUtils/TestingDsl.hs b/testing-kit/Hasql/TestingKit/TestingDsl.hs similarity index 93% rename from testing-utils/Hasql/TestingUtils/TestingDsl.hs rename to testing-kit/Hasql/TestingKit/TestingDsl.hs index a7a450f..ba762d0 100644 --- a/testing-utils/Hasql/TestingUtils/TestingDsl.hs +++ b/testing-kit/Hasql/TestingKit/TestingDsl.hs @@ -1,4 +1,4 @@ -module Hasql.TestingUtils.TestingDsl +module Hasql.TestingKit.TestingDsl ( Session.Session, Error (..), Session.SessionError (..), @@ -16,7 +16,7 @@ import Hasql.Connection qualified as Connection import Hasql.Pipeline qualified as Pipeline import Hasql.Session qualified as Session import Hasql.Statement qualified as Statement -import Hasql.TestingUtils.Constants qualified as Constants +import Hasql.TestingKit.Constants qualified as Constants import Prelude data Error From 30665a331e86edb8cfe7a3007b0dae26eb9f348b Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 22 Apr 2024 07:45:41 +0300 Subject: [PATCH 18/33] Implement more tests and discover bugs --- hasql.cabal | 2 + hspec/Hasql/PipelineSpec.hs | 55 +++++++++++++++++-- library/Hasql/Errors.hs | 3 +- .../TestingKit/Statements/BrokenSyntax.hs | 44 +++++++++++++++ .../TestingKit/Statements/WrongDecoder.hs | 44 +++++++++++++++ testing-kit/Hasql/TestingKit/TestingDsl.hs | 10 +++- 6 files changed, 151 insertions(+), 7 deletions(-) create mode 100644 testing-kit/Hasql/TestingKit/Statements/BrokenSyntax.hs create mode 100644 testing-kit/Hasql/TestingKit/Statements/WrongDecoder.hs diff --git a/hasql.cabal b/hasql.cabal index dc0f775..be7234f 100644 --- a/hasql.cabal +++ b/hasql.cabal @@ -147,7 +147,9 @@ library testing-kit hs-source-dirs: testing-kit exposed-modules: Hasql.TestingKit.Constants + Hasql.TestingKit.Statements.BrokenSyntax Hasql.TestingKit.Statements.GenerateSeries + Hasql.TestingKit.Statements.WrongDecoder Hasql.TestingKit.TestingDsl build-depends: diff --git a/hspec/Hasql/PipelineSpec.hs b/hspec/Hasql/PipelineSpec.hs index 56d172a..25bc179 100644 --- a/hspec/Hasql/PipelineSpec.hs +++ b/hspec/Hasql/PipelineSpec.hs @@ -1,6 +1,8 @@ module Hasql.PipelineSpec (spec) where +import Hasql.TestingKit.Statements.BrokenSyntax qualified as BrokenSyntax import Hasql.TestingKit.Statements.GenerateSeries qualified as GenerateSeries +import Hasql.TestingKit.Statements.WrongDecoder qualified as WrongDecoder import Hasql.TestingKit.TestingDsl qualified as Dsl import Test.Hspec import Prelude @@ -22,7 +24,7 @@ spec = do $ GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} shouldBe result (Right [0 .. 2]) - describe "Normally" do + describe "Multi-statement" do describe "On unprepared statements" do it "Collects results and sends params" do result <- @@ -39,6 +41,51 @@ spec = do $ GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} shouldBe result (Right [[0 .. 2], [0 .. 2]]) - describe "When some part fails" do - it "Works" do - pending + describe "When a part in the middle fails" do + describe "With query error" do + it "Captures the error" do + result <- + Dsl.runPipelineOnLocalDb + $ (,,) + <$> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + <*> BrokenSyntax.pipeline True BrokenSyntax.Params {start = 0, end = 2} + <*> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + case result of + Left (Dsl.SessionError (Dsl.QuerySessionError _ _ _)) -> pure () + _ -> expectationFailure $ "Unexpected result: " <> show result + + it "Leaves the connection usable" do + result <- + Dsl.runSessionOnLocalDb do + tryError + $ Dsl.runPipelineInSession + $ (,,) + <$> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + <*> BrokenSyntax.pipeline True BrokenSyntax.Params {start = 0, end = 2} + <*> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + GenerateSeries.session True GenerateSeries.Params {start = 0, end = 0} + shouldBe result (Right [0]) + + describe "With decoding error" do + it "Captures the error" do + result <- + Dsl.runPipelineOnLocalDb + $ (,,) + <$> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + <*> WrongDecoder.pipeline True WrongDecoder.Params {start = 0, end = 2} + <*> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + case result of + Left (Dsl.SessionError (Dsl.QuerySessionError _ _ _)) -> pure () + _ -> expectationFailure $ "Unexpected result: " <> show result + + it "Leaves the connection usable" do + result <- + Dsl.runSessionOnLocalDb do + tryError + $ Dsl.runPipelineInSession + $ (,,) + <$> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + <*> WrongDecoder.pipeline True WrongDecoder.Params {start = 0, end = 2} + <*> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} + GenerateSeries.session True GenerateSeries.Params {start = 0, end = 0} + shouldBe result (Right [0]) diff --git a/library/Hasql/Errors.hs b/library/Hasql/Errors.hs index e4b72df..85e7eb1 100644 --- a/library/Hasql/Errors.hs +++ b/library/Hasql/Errors.hs @@ -5,8 +5,7 @@ import Hasql.Prelude -- | Error during execution of a session. data SessionError - = -- | - -- An error during the execution of a query. + = -- | Error during the execution of a query. -- Comes packed with the query template and a textual representation of the provided params. QuerySessionError -- | SQL template. diff --git a/testing-kit/Hasql/TestingKit/Statements/BrokenSyntax.hs b/testing-kit/Hasql/TestingKit/Statements/BrokenSyntax.hs new file mode 100644 index 0000000..1d47e70 --- /dev/null +++ b/testing-kit/Hasql/TestingKit/Statements/BrokenSyntax.hs @@ -0,0 +1,44 @@ +module Hasql.TestingKit.Statements.BrokenSyntax where + +import Hasql.Decoders qualified as Decoders +import Hasql.Encoders qualified as Encoders +import Hasql.Pipeline qualified as Pipeline +import Hasql.Session qualified as Session +import Hasql.Statement qualified as Statement +import Prelude + +data Params = Params + { start :: Int64, + end :: Int64 + } + +type Result = [Int64] + +session :: Bool -> Params -> Session.Session Result +session prepared params = + Session.statement params (statement prepared) + +pipeline :: Bool -> Params -> Pipeline.Pipeline Result +pipeline prepared params = + Pipeline.statement params (statement prepared) + +statement :: Bool -> Statement.Statement Params Result +statement = + Statement.Statement sql encoder decoder + +sql :: ByteString +sql = + "S" + +encoder :: Encoders.Params Params +encoder = + mconcat + [ (.start) >$< Encoders.param (Encoders.nonNullable Encoders.int8), + (.end) >$< Encoders.param (Encoders.nonNullable Encoders.int8) + ] + +decoder :: Decoders.Result Result +decoder = + Decoders.rowList + ( Decoders.column (Decoders.nonNullable Decoders.int8) + ) diff --git a/testing-kit/Hasql/TestingKit/Statements/WrongDecoder.hs b/testing-kit/Hasql/TestingKit/Statements/WrongDecoder.hs new file mode 100644 index 0000000..d139327 --- /dev/null +++ b/testing-kit/Hasql/TestingKit/Statements/WrongDecoder.hs @@ -0,0 +1,44 @@ +module Hasql.TestingKit.Statements.WrongDecoder where + +import Hasql.Decoders qualified as Decoders +import Hasql.Encoders qualified as Encoders +import Hasql.Pipeline qualified as Pipeline +import Hasql.Session qualified as Session +import Hasql.Statement qualified as Statement +import Prelude + +data Params = Params + { start :: Int64, + end :: Int64 + } + +type Result = [UUID] + +session :: Bool -> Params -> Session.Session Result +session prepared params = + Session.statement params (statement prepared) + +pipeline :: Bool -> Params -> Pipeline.Pipeline Result +pipeline prepared params = + Pipeline.statement params (statement prepared) + +statement :: Bool -> Statement.Statement Params Result +statement = + Statement.Statement sql encoder decoder + +sql :: ByteString +sql = + "SELECT generate_series($1, $2)" + +encoder :: Encoders.Params Params +encoder = + mconcat + [ (.start) >$< Encoders.param (Encoders.nonNullable Encoders.int8), + (.end) >$< Encoders.param (Encoders.nonNullable Encoders.int8) + ] + +decoder :: Decoders.Result Result +decoder = + Decoders.rowList + ( Decoders.column (Decoders.nonNullable Decoders.uuid) + ) diff --git a/testing-kit/Hasql/TestingKit/TestingDsl.hs b/testing-kit/Hasql/TestingKit/TestingDsl.hs index ba762d0..5183939 100644 --- a/testing-kit/Hasql/TestingKit/TestingDsl.hs +++ b/testing-kit/Hasql/TestingKit/TestingDsl.hs @@ -1,10 +1,18 @@ module Hasql.TestingKit.TestingDsl - ( Session.Session, + ( -- * Errors Error (..), Session.SessionError (..), Session.CommandError (..), + Session.ResultError (..), + Session.RowError (..), + Session.ColumnError (..), + + -- * Abstractions + Session.Session, Pipeline.Pipeline, Statement.Statement (..), + + -- * Execution runSessionOnLocalDb, runPipelineOnLocalDb, runStatementInSession, From cc2c4db3c5cddb4a818a253757f187c40dc42d19 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 22 Apr 2024 08:16:19 +0300 Subject: [PATCH 19/33] Clean up --- library/Hasql/Decoders/Results.hs | 20 -------------------- 1 file changed, 20 deletions(-) diff --git a/library/Hasql/Decoders/Results.hs b/library/Hasql/Decoders/Results.hs index 87c92d0..caef949 100644 --- a/library/Hasql/Decoders/Results.hs +++ b/library/Hasql/Decoders/Results.hs @@ -49,26 +49,6 @@ single resultDec = Nothing -> fmap (Left . ClientCommandError) (LibPQ.errorMessage connection) --- | --- Fetch a single result. -{-# INLINE getResult #-} -getResult :: Results LibPQ.Result -getResult = - Results - $ ReaderT - $ \(_, connection) -> ExceptT $ do - resultMaybe <- LibPQ.getResult connection - case resultMaybe of - Just result -> pure (Right result) - Nothing -> fmap (Left . ClientCommandError) (LibPQ.errorMessage connection) - --- | --- Fetch a single result. -{-# INLINE getResultMaybe #-} -getResultMaybe :: Results (Maybe LibPQ.Result) -getResultMaybe = - Results $ ReaderT $ \(_, connection) -> lift $ LibPQ.getResult connection - {-# INLINE dropRemainders #-} dropRemainders :: Results () dropRemainders = From 1544e3d783ad9514273521965f1b582a20d8edc8 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 22 Apr 2024 09:52:37 +0300 Subject: [PATCH 20/33] Fix --- library/Hasql/Pipeline/Core.hs | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/library/Hasql/Pipeline/Core.hs b/library/Hasql/Pipeline/Core.hs index e73d60a..ba2c37e 100644 --- a/library/Hasql/Pipeline/Core.hs +++ b/library/Hasql/Pipeline/Core.hs @@ -15,12 +15,14 @@ run :: forall a. Pipeline a -> Pq.Connection -> PreparedStatementRegistry.Prepar run (Pipeline sendQueriesInIO) connection registry integerDatetimes = do runExceptT do enterPipelineMode - flip finallyE exitPipelineMode do - recvQueries <- sendQueries - pipelineSync - queriesResult <- recvQueries - recvPipelineSync - pure queriesResult + finallyE + do + recvQueries <- sendQueries + pipelineSync + recvQueries + do + recvPipelineSync + exitPipelineMode where enterPipelineMode :: ExceptT SessionError IO () enterPipelineMode = @@ -40,9 +42,14 @@ run (Pipeline sendQueriesInIO) connection registry integerDatetimes = do recvPipelineSync :: ExceptT SessionError IO () recvPipelineSync = + runResultsDecoder + $ Decoders.Results.single Decoders.Result.pipelineSync + + runResultsDecoder :: forall a. Decoders.Results.Results a -> ExceptT SessionError IO a + runResultsDecoder decoder = ExceptT $ fmap (mapLeft PipelineSessionError) - $ Decoders.Results.run (Decoders.Results.single Decoders.Result.pipelineSync) connection integerDatetimes + $ Decoders.Results.run decoder connection integerDatetimes runCommand :: IO Bool -> ExceptT SessionError IO () runCommand action = From f99f7797a3dfa012251bb4f794fb8f613d921686 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 22 Apr 2024 09:58:30 +0300 Subject: [PATCH 21/33] Ditch OverloadedRecordDot for compatiblity with GHC <9.2 --- hasql.cabal | 1 - testing-kit/Hasql/TestingKit/Statements/BrokenSyntax.hs | 4 ++-- testing-kit/Hasql/TestingKit/Statements/GenerateSeries.hs | 4 ++-- testing-kit/Hasql/TestingKit/Statements/WrongDecoder.hs | 4 ++-- 4 files changed, 6 insertions(+), 7 deletions(-) diff --git a/hasql.cabal b/hasql.cabal index be7234f..303ee27 100644 --- a/hasql.cabal +++ b/hasql.cabal @@ -53,7 +53,6 @@ common base MultiWayIf NoImplicitPrelude NoMonomorphismRestriction - OverloadedRecordDot OverloadedStrings ParallelListComp PatternGuards diff --git a/testing-kit/Hasql/TestingKit/Statements/BrokenSyntax.hs b/testing-kit/Hasql/TestingKit/Statements/BrokenSyntax.hs index 1d47e70..6508bea 100644 --- a/testing-kit/Hasql/TestingKit/Statements/BrokenSyntax.hs +++ b/testing-kit/Hasql/TestingKit/Statements/BrokenSyntax.hs @@ -33,8 +33,8 @@ sql = encoder :: Encoders.Params Params encoder = mconcat - [ (.start) >$< Encoders.param (Encoders.nonNullable Encoders.int8), - (.end) >$< Encoders.param (Encoders.nonNullable Encoders.int8) + [ start >$< Encoders.param (Encoders.nonNullable Encoders.int8), + end >$< Encoders.param (Encoders.nonNullable Encoders.int8) ] decoder :: Decoders.Result Result diff --git a/testing-kit/Hasql/TestingKit/Statements/GenerateSeries.hs b/testing-kit/Hasql/TestingKit/Statements/GenerateSeries.hs index 4cf98b6..20fc044 100644 --- a/testing-kit/Hasql/TestingKit/Statements/GenerateSeries.hs +++ b/testing-kit/Hasql/TestingKit/Statements/GenerateSeries.hs @@ -33,8 +33,8 @@ sql = encoder :: Encoders.Params Params encoder = mconcat - [ (.start) >$< Encoders.param (Encoders.nonNullable Encoders.int8), - (.end) >$< Encoders.param (Encoders.nonNullable Encoders.int8) + [ start >$< Encoders.param (Encoders.nonNullable Encoders.int8), + end >$< Encoders.param (Encoders.nonNullable Encoders.int8) ] decoder :: Decoders.Result Result diff --git a/testing-kit/Hasql/TestingKit/Statements/WrongDecoder.hs b/testing-kit/Hasql/TestingKit/Statements/WrongDecoder.hs index d139327..5a9a302 100644 --- a/testing-kit/Hasql/TestingKit/Statements/WrongDecoder.hs +++ b/testing-kit/Hasql/TestingKit/Statements/WrongDecoder.hs @@ -33,8 +33,8 @@ sql = encoder :: Encoders.Params Params encoder = mconcat - [ (.start) >$< Encoders.param (Encoders.nonNullable Encoders.int8), - (.end) >$< Encoders.param (Encoders.nonNullable Encoders.int8) + [ start >$< Encoders.param (Encoders.nonNullable Encoders.int8), + end >$< Encoders.param (Encoders.nonNullable Encoders.int8) ] decoder :: Decoders.Result Result From 7dd3b2b72a2e2f8adb261647f83107c427bb3c8f Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 22 Apr 2024 20:08:18 +0300 Subject: [PATCH 22/33] Add benchmarks --- benchmarks/Main.hs | 33 ++++++++++++++++++--------------- 1 file changed, 18 insertions(+), 15 deletions(-) diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs index a4cdd2c..32ff52e 100644 --- a/benchmarks/Main.hs +++ b/benchmarks/Main.hs @@ -4,6 +4,7 @@ import Criterion import Criterion.Main import Hasql.Connection qualified as A import Hasql.Decoders qualified as D +import Hasql.Pipeline qualified as E import Hasql.Session qualified as B import Hasql.Statement qualified as C import Prelude @@ -21,41 +22,43 @@ main = [ sessionBench "largeResultInVector" sessionWithSingleLargeResultInVector, sessionBench "largeResultInList" sessionWithSingleLargeResultInList, sessionBench "manyLargeResults" sessionWithManyLargeResults, - sessionBench "manySmallResults" sessionWithManySmallResults + sessionBench "manyLargeResultsViaPipeline" sessionWithManyLargeResultsViaPipeline, + sessionBench "manySmallResults" sessionWithManySmallResults, + sessionBench "manySmallResultsViaPipeline" sessionWithManySmallResultsViaPipeline ] where sessionBench :: (NFData a) => String -> B.Session a -> Benchmark sessionBench name session = - bench name (nfIO (fmap (either (error "") id) (B.run session connection))) + bench name (nfIO (B.run session connection >>= either (fail . show) pure)) -- * Sessions -sessionWithManySmallParameters :: Vector (Int64, Int64) -> B.Session () -sessionWithManySmallParameters = - error "TODO: sessionWithManySmallParameters" - sessionWithSingleLargeResultInVector :: B.Session (Vector (Int64, Int64)) sessionWithSingleLargeResultInVector = B.statement () statementWithManyRowsInVector -sessionWithManyLargeResults :: B.Session [Vector (Int64, Int64)] -sessionWithManyLargeResults = - replicateM 1000 (B.statement () statementWithManyRowsInVector) - sessionWithSingleLargeResultInList :: B.Session [(Int64, Int64)] sessionWithSingleLargeResultInList = B.statement () statementWithManyRowsInList +sessionWithManyLargeResults :: B.Session [Vector (Int64, Int64)] +sessionWithManyLargeResults = + replicateM 100 (B.statement () statementWithManyRowsInVector) + sessionWithManySmallResults :: B.Session [(Int64, Int64)] sessionWithManySmallResults = - replicateM 1000 (B.statement () statementWithSingleRow) + replicateM 100 (B.statement () statementWithSingleRow) + +sessionWithManyLargeResultsViaPipeline :: B.Session [Vector (Int64, Int64)] +sessionWithManyLargeResultsViaPipeline = + B.pipeline (replicateM 100 (E.statement () statementWithManyRowsInVector)) + +sessionWithManySmallResultsViaPipeline :: B.Session [(Int64, Int64)] +sessionWithManySmallResultsViaPipeline = + B.pipeline (replicateM 100 (E.statement () statementWithSingleRow)) -- * Statements -statementWithManyParameters :: C.Statement (Vector (Int64, Int64)) () -statementWithManyParameters = - error "TODO: statementWithManyParameters" - statementWithSingleRow :: C.Statement () (Int64, Int64) statementWithSingleRow = C.Statement template encoder decoder True From c7d76a6f97ee1c4a3eab276c659d6a0a274ba419 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 22 Apr 2024 20:18:35 +0300 Subject: [PATCH 23/33] Add changelog check --- .github/workflows/on-pr.yaml | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 .github/workflows/on-pr.yaml diff --git a/.github/workflows/on-pr.yaml b/.github/workflows/on-pr.yaml new file mode 100644 index 0000000..aae0922 --- /dev/null +++ b/.github/workflows/on-pr.yaml @@ -0,0 +1,17 @@ +on: + pull_request: + types: [assigned, opened, synchronize, reopened, labeled, unlabeled] + branches: + - master + - major + - minor + - patch + +jobs: + check-changelog: + name: Check Changelog Action + runs-on: ubuntu-20.04 + steps: + - uses: tarides/changelog-check-action@v2 + with: + changelog: CHANGELOG.md From e0326c6803e9c842f883c64e6ef6411898fbf6d3 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Mon, 22 Apr 2024 20:23:00 +0300 Subject: [PATCH 24/33] Update the workflows --- .github/workflows/on-pr.yaml | 9 +++++++++ ...-push-to-master-or-pr.yaml => on-push-to-master.yaml} | 1 - 2 files changed, 9 insertions(+), 1 deletion(-) rename .github/workflows/{on-push-to-master-or-pr.yaml => on-push-to-master.yaml} (94%) diff --git a/.github/workflows/on-pr.yaml b/.github/workflows/on-pr.yaml index aae0922..cd0c0b5 100644 --- a/.github/workflows/on-pr.yaml +++ b/.github/workflows/on-pr.yaml @@ -8,6 +8,15 @@ on: - patch jobs: + + format: + uses: nikita-volkov/haskell-hackage-lib-github-actions-workflows/.github/workflows/format.yaml@v3 + secrets: inherit + + check: + uses: ./.github/workflows/check.yaml + secrets: inherit + check-changelog: name: Check Changelog Action runs-on: ubuntu-20.04 diff --git a/.github/workflows/on-push-to-master-or-pr.yaml b/.github/workflows/on-push-to-master.yaml similarity index 94% rename from .github/workflows/on-push-to-master-or-pr.yaml rename to .github/workflows/on-push-to-master.yaml index 4a8dd27..5a6b86a 100644 --- a/.github/workflows/on-push-to-master-or-pr.yaml +++ b/.github/workflows/on-push-to-master.yaml @@ -2,7 +2,6 @@ on: push: branches: - master - pull_request: jobs: From ddd667acb8008b1821bbb323082b1f44c8a43b8c Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Tue, 23 Apr 2024 12:20:47 +0300 Subject: [PATCH 25/33] Correct the use of finally --- library/Hasql/Pipeline/Core.hs | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/library/Hasql/Pipeline/Core.hs b/library/Hasql/Pipeline/Core.hs index ba2c37e..3c420c3 100644 --- a/library/Hasql/Pipeline/Core.hs +++ b/library/Hasql/Pipeline/Core.hs @@ -15,14 +15,11 @@ run :: forall a. Pipeline a -> Pq.Connection -> PreparedStatementRegistry.Prepar run (Pipeline sendQueriesInIO) connection registry integerDatetimes = do runExceptT do enterPipelineMode - finallyE - do - recvQueries <- sendQueries - pipelineSync - recvQueries - do - recvPipelineSync - exitPipelineMode + recvQueries <- sendQueries + pipelineSync + finallyE recvQueries do + recvPipelineSync + exitPipelineMode where enterPipelineMode :: ExceptT SessionError IO () enterPipelineMode = From 14d78fb0787f78c17cad9d9f43d6710a96f868f3 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sat, 27 Apr 2024 07:33:08 +0300 Subject: [PATCH 26/33] Replace mapLeft with first --- library/Hasql/Decoders/Result.hs | 6 +++--- library/Hasql/Decoders/Results.hs | 6 +++--- library/Hasql/Decoders/Row.hs | 2 +- library/Hasql/Pipeline/Core.hs | 8 ++++---- library/Hasql/Prelude.hs | 6 ------ library/Hasql/Session/Core.hs | 4 ++-- testing-kit/Hasql/TestingKit/TestingDsl.hs | 4 ++-- 7 files changed, 15 insertions(+), 21 deletions(-) diff --git a/library/Hasql/Decoders/Result.hs b/library/Hasql/Decoders/Result.hs index 54e395e..38fce65 100644 --- a/library/Hasql/Decoders/Result.hs +++ b/library/Hasql/Decoders/Result.hs @@ -51,7 +51,7 @@ rowsAffected = then Left (UnexpectedResultError "Empty bytes") else Right bytes decimal bytes = - mapLeft (\m -> UnexpectedResultError ("Decimal parsing failure: " <> fromString m)) + first (\m -> UnexpectedResultError ("Decimal parsing failure: " <> fromString m)) $ Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes {-# INLINE checkExecStatus #-} @@ -112,7 +112,7 @@ maybe rowDec = 0 -> return (Right Nothing) 1 -> do maxCols <- LibPQ.nfields result - fmap (fmap Just . mapLeft (RowResultError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) + fmap (fmap Just . first (RowResultError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) _ -> return (Left (UnexpectedAmountOfRowsResultError (rowToInt maxRows))) where rowToInt (LibPQ.Row n) = @@ -130,7 +130,7 @@ single rowDec = case maxRows of 1 -> do maxCols <- LibPQ.nfields result - fmap (mapLeft (RowResultError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) + fmap (first (RowResultError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) _ -> return (Left (UnexpectedAmountOfRowsResultError (rowToInt maxRows))) where rowToInt (LibPQ.Row n) = diff --git a/library/Hasql/Decoders/Results.hs b/library/Hasql/Decoders/Results.hs index caef949..99d7a7f 100644 --- a/library/Hasql/Decoders/Results.hs +++ b/library/Hasql/Decoders/Results.hs @@ -45,7 +45,7 @@ single resultDec = resultMaybe <- LibPQ.getResult connection case resultMaybe of Just result -> - mapLeft ResultCommandError <$> Result.run resultDec integerDatetimes result + first ResultCommandError <$> Result.run resultDec integerDatetimes result Nothing -> fmap (Left . ClientCommandError) (LibPQ.errorMessage connection) @@ -64,11 +64,11 @@ dropRemainders = loop integerDatetimes connection <* checkErrors where checkErrors = - ExceptT $ fmap (mapLeft ResultCommandError) $ Result.run Result.noResult integerDatetimes result + ExceptT $ fmap (first ResultCommandError) $ Result.run Result.noResult integerDatetimes result refine :: (a -> Either Text b) -> Results a -> Results b refine refiner (Results stack) = Results $ ReaderT $ \env -> ExceptT $ do resultEither <- runExceptT $ runReaderT stack env - return $ resultEither >>= mapLeft (ResultCommandError . UnexpectedResultError) . refiner + return $ resultEither >>= first (ResultCommandError . UnexpectedResultError) . refiner diff --git a/library/Hasql/Decoders/Row.hs b/library/Hasql/Decoders/Row.hs index cf8d71d..98c0ec0 100644 --- a/library/Hasql/Decoders/Row.hs +++ b/library/Hasql/Decoders/Row.hs @@ -55,7 +55,7 @@ value valueDec = Right Nothing Just value -> fmap Just - $ mapLeft ValueColumnError + $ first ValueColumnError $ {-# SCC "decode" #-} A.valueParser (Value.run valueDec integerDatetimes) value else pure (Left EndOfInputColumnError) diff --git a/library/Hasql/Pipeline/Core.hs b/library/Hasql/Pipeline/Core.hs index 3c420c3..6c1b685 100644 --- a/library/Hasql/Pipeline/Core.hs +++ b/library/Hasql/Pipeline/Core.hs @@ -45,7 +45,7 @@ run (Pipeline sendQueriesInIO) connection registry integerDatetimes = do runResultsDecoder :: forall a. Decoders.Results.Results a -> ExceptT SessionError IO a runResultsDecoder decoder = ExceptT - $ fmap (mapLeft PipelineSessionError) + $ fmap (first PipelineSessionError) $ Decoders.Results.run decoder connection integerDatetimes runCommand :: IO Bool -> ExceptT SessionError IO () @@ -109,7 +109,7 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re else (False,) . Left . commandToSessionError . ClientCommandError <$> Pq.errorMessage connection where recv = - fmap (mapLeft commandToSessionError) + fmap (first commandToSessionError) $ (<*) <$> Decoders.Results.run (Decoders.Results.single Decoders.Result.noResult) connection integerDatetimes <*> Decoders.Results.run Decoders.Results.dropRemainders connection integerDatetimes @@ -122,7 +122,7 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re True -> pure (Right recv) where recv = - fmap (mapLeft commandToSessionError) + fmap (first commandToSessionError) $ (<*) <$> Decoders.Results.run decoder connection integerDatetimes <*> Decoders.Results.run Decoders.Results.dropRemainders connection integerDatetimes @@ -133,7 +133,7 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re True -> pure (Right recv) where recv = - fmap (mapLeft commandToSessionError) + fmap (first commandToSessionError) $ (<*) <$> Decoders.Results.run decoder connection integerDatetimes <*> Decoders.Results.run Decoders.Results.dropRemainders connection integerDatetimes diff --git a/library/Hasql/Prelude.hs b/library/Hasql/Prelude.hs index 88e6911..cf80c9b 100644 --- a/library/Hasql/Prelude.hs +++ b/library/Hasql/Prelude.hs @@ -7,7 +7,6 @@ module Hasql.Prelude forMToZero_, forMFromZero_, strictCons, - mapLeft, ) where @@ -130,8 +129,3 @@ forMFromZero_ !endN f = strictCons :: a -> [a] -> [a] strictCons !a b = let !c = a : b in c - -{-# INLINE mapLeft #-} -mapLeft :: (a -> c) -> Either a b -> Either c b -mapLeft f = - either (Left . f) Right diff --git a/library/Hasql/Session/Core.hs b/library/Hasql/Session/Core.hs index 23c3db0..c84fcb7 100644 --- a/library/Hasql/Session/Core.hs +++ b/library/Hasql/Session/Core.hs @@ -35,7 +35,7 @@ sql sql = $ ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) -> ExceptT - $ fmap (mapLeft (QuerySessionError sql [])) + $ fmap (first (QuerySessionError sql [])) $ withMVar pqConnectionRef $ \pqConnection -> do r1 <- IO.sendNonparametricStatement pqConnection sql @@ -53,7 +53,7 @@ statement input (Statement.Statement template (Encoders.Params paramsEncoder) (D $ ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) -> ExceptT - $ fmap (mapLeft (QuerySessionError template (Encoders.Params.renderReadable paramsEncoder input))) + $ fmap (first (QuerySessionError template (Encoders.Params.renderReadable paramsEncoder input))) $ withMVar pqConnectionRef $ \pqConnection -> do r1 <- IO.sendParametricStatement pqConnection integerDatetimes registry template paramsEncoder preparable input diff --git a/testing-kit/Hasql/TestingKit/TestingDsl.hs b/testing-kit/Hasql/TestingKit/TestingDsl.hs index 5183939..3d91810 100644 --- a/testing-kit/Hasql/TestingKit/TestingDsl.hs +++ b/testing-kit/Hasql/TestingKit/TestingDsl.hs @@ -37,10 +37,10 @@ runSessionOnLocalDb session = runExceptT $ acquire >>= \connection -> use connection <* release connection where acquire = - ExceptT $ fmap (mapLeft ConnectionError) $ Connection.acquire Constants.localConnectionSettings + ExceptT $ fmap (first ConnectionError) $ Connection.acquire Constants.localConnectionSettings use connection = ExceptT - $ fmap (mapLeft SessionError) + $ fmap (first SessionError) $ Session.run session connection release connection = lift $ Connection.release connection From e40be8555956ca22a33996e04f40768ae1e66d8b Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sat, 27 Apr 2024 07:36:22 +0300 Subject: [PATCH 27/33] Add DerivingVia --- hasql.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/hasql.cabal b/hasql.cabal index 303ee27..4770cd3 100644 --- a/hasql.cabal +++ b/hasql.cabal @@ -39,6 +39,7 @@ common base DeriveFunctor DeriveGeneric DeriveTraversable + DerivingVia EmptyDataDecls FlexibleContexts FlexibleInstances From 01a5dd2ddcde96198e47a8dc959a9390aeefc839 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sat, 27 Apr 2024 19:44:12 +0300 Subject: [PATCH 28/33] Update the changelog --- CHANGELOG.md | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 73f6ac7..9af9957 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,22 @@ # 1.7 +- Error model completely revised: + - All sum-types now follow the convention of having constructors suffixed with the type name. In particular the following transformations occurred: + - `QueryError` type got renamed to `SessionError` + - `QueryError` constructor got renamed to `QuerySessionError` + - New `PipelineSessionError` constructor got added to the `SessionError` type + - `ClientError` constructor got renamed to `ClientCommandError` + - `ResultError` constructor got renamed to `ResultCommandError` + - `ServerError` constructor got renamed to `ServerResultError` + - `UnexpectedResult` constructor got renamed to `UnexpectedResultError` + - `RowResult` constructor got renamed to `RowResultError` + - `RowError` type got renamed to `ColumnError` + - `EndOfInput` constructor got renamed to `EndOfInputColumnError` + - `UnexpectedNull` constructor got renamed to `UnexpectedNullColumnError` + - `ValueError` constructor got renamed to `UnexpectedNull` + - New `RowError` type got created + - `RowResult` constructor's column field go transferred into the new `RowError` type + - Decidable instance on `Encoders.Params` removed. It was useless and limited the design. # 1.6.3.1 From c3a83eb1bf014240a3051cb040df7eb409ce6aae Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sat, 27 Apr 2024 18:43:39 +0300 Subject: [PATCH 29/33] Bundle extensions for libpq14 --- cabal.project | 8 --- hasql.cabal | 9 ++- library/Hasql/Connection/Core.hs | 2 +- library/Hasql/Decoders/Result.hs | 2 +- library/Hasql/Decoders/Results.hs | 2 +- library/Hasql/Decoders/Row.hs | 2 +- library/Hasql/Encoders/Params.hs | 2 +- library/Hasql/IO.hs | 2 +- library/Hasql/LibPq14.hs | 83 ++++++++++++++++++++++ library/Hasql/LibPq14/Ffi.hs | 25 +++++++ library/Hasql/LibPq14/Mappings.hsc | 71 ++++++++++++++++++ library/Hasql/Pipeline/Core.hs | 2 +- library/Hasql/PostgresTypeInfo.hs | 2 +- library/Hasql/PreparedStatementRegistry.hs | 2 +- 14 files changed, 192 insertions(+), 22 deletions(-) create mode 100644 library/Hasql/LibPq14.hs create mode 100644 library/Hasql/LibPq14/Ffi.hs create mode 100644 library/Hasql/LibPq14/Mappings.hsc diff --git a/cabal.project b/cabal.project index 38aa2e7..e6fdbad 100644 --- a/cabal.project +++ b/cabal.project @@ -1,9 +1 @@ packages: . - -source-repository-package - type: git - location: https://github.com/GulinSS/postgresql-libpq/ - tag: 30b69e55855cabf3356e186c30a1756b4b0c6c95 - -allow-newer: - postgresql-libpq:base diff --git a/hasql.cabal b/hasql.cabal index 4770cd3..09001f2 100644 --- a/hasql.cabal +++ b/hasql.cabal @@ -49,13 +49,11 @@ common base ImportQualifiedPost LambdaCase LiberalTypeSynonyms - MagicHash MultiParamTypeClasses MultiWayIf NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings - ParallelListComp PatternGuards QuasiQuotes RankNTypes @@ -64,11 +62,9 @@ common base ScopedTypeVariables StandaloneDeriving StrictData - TemplateHaskell TupleSections TypeFamilies TypeOperators - UnboxedTuples common executable import: base @@ -112,6 +108,9 @@ library Hasql.Encoders.Value Hasql.Errors Hasql.IO + Hasql.LibPq14 + Hasql.LibPq14.Ffi + Hasql.LibPq14.Mappings Hasql.Pipeline.Core Hasql.PostgresTypeInfo Hasql.Prelude @@ -132,7 +131,7 @@ library mtl >=2 && <3, network-ip >=0.3.0.3 && <0.4, postgresql-binary >=0.13.1 && <0.14, - postgresql-libpq >=0.9 && <0.11, + postgresql-libpq ==0.10.1.0, profunctors >=5.1 && <6, scientific >=0.3 && <0.4, text >=1 && <3, diff --git a/library/Hasql/Connection/Core.hs b/library/Hasql/Connection/Core.hs index 77452cc..1dbe9f0 100644 --- a/library/Hasql/Connection/Core.hs +++ b/library/Hasql/Connection/Core.hs @@ -2,8 +2,8 @@ -- This module provides a low-level effectful API dealing with the connections to the database. module Hasql.Connection.Core where -import Database.PostgreSQL.LibPQ qualified as LibPQ import Hasql.IO qualified as IO +import Hasql.LibPq14 qualified as LibPQ import Hasql.Prelude import Hasql.PreparedStatementRegistry qualified as PreparedStatementRegistry import Hasql.Settings qualified as Settings diff --git a/library/Hasql/Decoders/Result.hs b/library/Hasql/Decoders/Result.hs index 38fce65..85666df 100644 --- a/library/Hasql/Decoders/Result.hs +++ b/library/Hasql/Decoders/Result.hs @@ -4,9 +4,9 @@ import Data.Attoparsec.ByteString.Char8 qualified as Attoparsec import Data.ByteString qualified as ByteString import Data.Vector qualified as Vector import Data.Vector.Mutable qualified as MutableVector -import Database.PostgreSQL.LibPQ qualified as LibPQ import Hasql.Decoders.Row qualified as Row import Hasql.Errors +import Hasql.LibPq14 qualified as LibPQ import Hasql.Prelude hiding (many, maybe) import Hasql.Prelude qualified as Prelude diff --git a/library/Hasql/Decoders/Results.hs b/library/Hasql/Decoders/Results.hs index 99d7a7f..a92d5d7 100644 --- a/library/Hasql/Decoders/Results.hs +++ b/library/Hasql/Decoders/Results.hs @@ -10,9 +10,9 @@ -- * Row-by-row fetching. module Hasql.Decoders.Results where -import Database.PostgreSQL.LibPQ qualified as LibPQ import Hasql.Decoders.Result qualified as Result import Hasql.Errors +import Hasql.LibPq14 qualified as LibPQ import Hasql.Prelude hiding (many, maybe) import Hasql.Prelude qualified as Prelude diff --git a/library/Hasql/Decoders/Row.hs b/library/Hasql/Decoders/Row.hs index 98c0ec0..fb50572 100644 --- a/library/Hasql/Decoders/Row.hs +++ b/library/Hasql/Decoders/Row.hs @@ -1,8 +1,8 @@ module Hasql.Decoders.Row where -import Database.PostgreSQL.LibPQ qualified as LibPQ import Hasql.Decoders.Value qualified as Value import Hasql.Errors +import Hasql.LibPq14 qualified as LibPQ import Hasql.Prelude hiding (error) import PostgreSQL.Binary.Decoding qualified as A diff --git a/library/Hasql/Encoders/Params.hs b/library/Hasql/Encoders/Params.hs index 8a4640b..e2c4af2 100644 --- a/library/Hasql/Encoders/Params.hs +++ b/library/Hasql/Encoders/Params.hs @@ -1,7 +1,7 @@ module Hasql.Encoders.Params where -import Database.PostgreSQL.LibPQ qualified as A import Hasql.Encoders.Value qualified as C +import Hasql.LibPq14 qualified as A import Hasql.PostgresTypeInfo qualified as D import Hasql.Prelude import PostgreSQL.Binary.Encoding qualified as B diff --git a/library/Hasql/IO.hs b/library/Hasql/IO.hs index 05edf74..4262f0a 100644 --- a/library/Hasql/IO.hs +++ b/library/Hasql/IO.hs @@ -2,12 +2,12 @@ -- An API of low-level IO operations. module Hasql.IO where -import Database.PostgreSQL.LibPQ qualified as LibPQ import Hasql.Commands qualified as Commands import Hasql.Decoders.Result qualified as ResultDecoders import Hasql.Decoders.Results qualified as ResultsDecoders import Hasql.Encoders.Params qualified as ParamsEncoders import Hasql.Errors +import Hasql.LibPq14 qualified as LibPQ import Hasql.Prelude import Hasql.PreparedStatementRegistry qualified as PreparedStatementRegistry diff --git a/library/Hasql/LibPq14.hs b/library/Hasql/LibPq14.hs new file mode 100644 index 0000000..d762dfb --- /dev/null +++ b/library/Hasql/LibPq14.hs @@ -0,0 +1,83 @@ +module Hasql.LibPq14 + ( module Base, + + -- * Updated and new types + Mappings.ExecStatus (..), + Mappings.PipelineStatus (..), + + -- * Updated and new procedures + resultStatus, + pipelineStatus, + enterPipelineMode, + exitPipelineMode, + pipelineSync, + sendFlushRequest, + ) +where + +import Database.PostgreSQL.LibPQ as Base hiding (ExecStatus (..), resultStatus) +import Database.PostgreSQL.LibPQ.Internal qualified as BaseInternal +import Hasql.LibPq14.Ffi qualified as Ffi +import Hasql.LibPq14.Mappings qualified as Mappings +import Hasql.Prelude + +resultStatus :: Result -> IO Mappings.ExecStatus +resultStatus result = do + -- Unsafe-coercing because the constructor is not exposed by the lib, + -- but it's implemented as a newtype over ForeignPtr. + -- Since internal changes in the \"postgresql-lipbq\" may break this, + -- it requires us to avoid using an open dependency range on it. + ffiStatus <- withForeignPtr (unsafeCoerce result) Ffi.resultStatus + decodeProcedureResult "resultStatus" Mappings.decodeExecStatus ffiStatus + +pipelineStatus :: + Connection -> + IO Mappings.PipelineStatus +pipelineStatus = + parameterlessProcedure "pipelineStatus" Ffi.pipelineStatus Mappings.decodePipelineStatus + +enterPipelineMode :: + Connection -> + IO Bool +enterPipelineMode = + parameterlessProcedure "enterPipelineMode" Ffi.enterPipelineMode Mappings.decodeBool + +exitPipelineMode :: + Connection -> + IO Bool +exitPipelineMode = + parameterlessProcedure "exitPipelineMode" Ffi.exitPipelineMode Mappings.decodeBool + +pipelineSync :: + Connection -> + IO Bool +pipelineSync = + parameterlessProcedure "pipelineSync" Ffi.pipelineSync Mappings.decodeBool + +sendFlushRequest :: + Connection -> + IO Bool +sendFlushRequest = + parameterlessProcedure "sendFlushRequest" Ffi.sendFlushRequest Mappings.decodeBool + +parameterlessProcedure :: + (Show a) => + String -> + (Ptr BaseInternal.PGconn -> IO a) -> + (a -> Maybe b) -> + Connection -> + IO b +parameterlessProcedure label procedure decoder connection = do + ffiResult <- BaseInternal.withConn connection procedure + decodeProcedureResult label decoder ffiResult + +decodeProcedureResult :: + (Show a) => + String -> + (a -> Maybe b) -> + a -> + IO b +decodeProcedureResult label decoder ffiResult = + case decoder ffiResult of + Just res -> pure res + Nothing -> fail ("Failed to decode result of " <> label <> " from: " <> show ffiResult) diff --git a/library/Hasql/LibPq14/Ffi.hs b/library/Hasql/LibPq14/Ffi.hs new file mode 100644 index 0000000..1df9317 --- /dev/null +++ b/library/Hasql/LibPq14/Ffi.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CApiFFI #-} + +module Hasql.LibPq14.Ffi where + +import Database.PostgreSQL.LibPQ.Internal +import Foreign.C.Types (CInt (..)) +import Hasql.Prelude + +foreign import capi "libpq-fe.h PQresultStatus" + resultStatus :: Ptr () -> IO CInt + +foreign import capi "libpq-fe.h PQpipelineStatus" + pipelineStatus :: Ptr PGconn -> IO CInt + +foreign import capi "libpq-fe.h PQenterPipelineMode" + enterPipelineMode :: Ptr PGconn -> IO CInt + +foreign import capi "libpq-fe.h PQexitPipelineMode" + exitPipelineMode :: Ptr PGconn -> IO CInt + +foreign import capi "libpq-fe.h PQpipelineSync" + pipelineSync :: Ptr PGconn -> IO CInt + +foreign import capi "libpq-fe.h PQsendFlushRequest" + sendFlushRequest :: Ptr PGconn -> IO CInt diff --git a/library/Hasql/LibPq14/Mappings.hsc b/library/Hasql/LibPq14/Mappings.hsc new file mode 100644 index 0000000..120e67c --- /dev/null +++ b/library/Hasql/LibPq14/Mappings.hsc @@ -0,0 +1,71 @@ +module Hasql.LibPq14.Mappings where + +#include "libpq-fe.h" + +import Foreign.C.Types (CInt (..)) +import Hasql.Prelude + +data ExecStatus + = EmptyQuery + | CommandOk + | TuplesOk + | CopyOut + | CopyIn + | CopyBoth + | BadResponse + | NonfatalError + | FatalError + | SingleTuple + | PipelineSync + | PipelineAbort + deriving (Eq, Show) + +decodeExecStatus :: CInt -> Maybe ExecStatus +decodeExecStatus = \case + (#const PGRES_EMPTY_QUERY) -> Just EmptyQuery + (#const PGRES_COMMAND_OK) -> Just CommandOk + (#const PGRES_TUPLES_OK) -> Just TuplesOk + (#const PGRES_COPY_OUT) -> Just CopyOut + (#const PGRES_COPY_IN) -> Just CopyIn + (#const PGRES_COPY_BOTH) -> Just CopyBoth + (#const PGRES_BAD_RESPONSE) -> Just BadResponse + (#const PGRES_NONFATAL_ERROR) -> Just NonfatalError + (#const PGRES_FATAL_ERROR) -> Just FatalError + (#const PGRES_SINGLE_TUPLE) -> Just SingleTuple + (#const PGRES_PIPELINE_SYNC) -> Just PipelineSync + (#const PGRES_PIPELINE_ABORTED) -> Just PipelineAbort + _ -> Nothing + +encodeExecStatus :: ExecStatus -> CInt +encodeExecStatus = \case + EmptyQuery -> #const PGRES_EMPTY_QUERY + CommandOk -> #const PGRES_COMMAND_OK + TuplesOk -> #const PGRES_TUPLES_OK + CopyOut -> #const PGRES_COPY_OUT + CopyIn -> #const PGRES_COPY_IN + CopyBoth -> #const PGRES_COPY_BOTH + BadResponse -> #const PGRES_BAD_RESPONSE + NonfatalError -> #const PGRES_NONFATAL_ERROR + FatalError -> #const PGRES_FATAL_ERROR + SingleTuple -> #const PGRES_SINGLE_TUPLE + PipelineSync -> #const PGRES_PIPELINE_SYNC + PipelineAbort -> #const PGRES_PIPELINE_ABORTED + +data PipelineStatus + = PipelineOn + | PipelineOff + | PipelineAborted + deriving (Eq, Show) + +decodePipelineStatus :: CInt -> Maybe PipelineStatus +decodePipelineStatus = \case + (#const PQ_PIPELINE_ON) -> Just PipelineOn + (#const PQ_PIPELINE_OFF) -> Just PipelineOff + (#const PQ_PIPELINE_ABORTED) -> Just PipelineAborted + _ -> Nothing + +decodeBool :: CInt -> Maybe Bool +decodeBool = \case + 0 -> Just False + 1 -> Just True + _ -> Nothing diff --git a/library/Hasql/Pipeline/Core.hs b/library/Hasql/Pipeline/Core.hs index 6c1b685..e60559e 100644 --- a/library/Hasql/Pipeline/Core.hs +++ b/library/Hasql/Pipeline/Core.hs @@ -1,12 +1,12 @@ module Hasql.Pipeline.Core where -import Database.PostgreSQL.LibPQ qualified as Pq import Hasql.Decoders.All qualified as Decoders import Hasql.Decoders.Result qualified as Decoders.Result import Hasql.Decoders.Results qualified as Decoders.Results import Hasql.Encoders.All qualified as Encoders import Hasql.Encoders.Params qualified as Encoders.Params import Hasql.Errors +import Hasql.LibPq14 qualified as Pq import Hasql.Prelude import Hasql.PreparedStatementRegistry qualified as PreparedStatementRegistry import Hasql.Statement qualified as Statement diff --git a/library/Hasql/PostgresTypeInfo.hs b/library/Hasql/PostgresTypeInfo.hs index b7978b1..fb7cc27 100644 --- a/library/Hasql/PostgresTypeInfo.hs +++ b/library/Hasql/PostgresTypeInfo.hs @@ -1,6 +1,6 @@ module Hasql.PostgresTypeInfo where -import Database.PostgreSQL.LibPQ qualified as LibPQ +import Hasql.LibPq14 qualified as LibPQ import Hasql.Prelude hiding (bool) -- | A Postgresql type info diff --git a/library/Hasql/PreparedStatementRegistry.hs b/library/Hasql/PreparedStatementRegistry.hs index 4aad8b2..37fae6a 100644 --- a/library/Hasql/PreparedStatementRegistry.hs +++ b/library/Hasql/PreparedStatementRegistry.hs @@ -8,7 +8,7 @@ where import ByteString.StrictBuilder qualified as B import Data.HashTable.IO qualified as A -import Database.PostgreSQL.LibPQ qualified as Pq +import Hasql.LibPq14 qualified as Pq import Hasql.Prelude hiding (lookup) data PreparedStatementRegistry From 9b151275d013a48ff1e2c7cb4b0890a2dd7a89e4 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sat, 27 Apr 2024 20:59:11 +0300 Subject: [PATCH 30/33] Correct changelog --- CHANGELOG.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 9af9957..46ee884 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,11 +9,11 @@ - `ResultError` constructor got renamed to `ResultCommandError` - `ServerError` constructor got renamed to `ServerResultError` - `UnexpectedResult` constructor got renamed to `UnexpectedResultError` - - `RowResult` constructor got renamed to `RowResultError` + - `RowError` constructor got renamed to `RowResultError` - `RowError` type got renamed to `ColumnError` - `EndOfInput` constructor got renamed to `EndOfInputColumnError` - `UnexpectedNull` constructor got renamed to `UnexpectedNullColumnError` - - `ValueError` constructor got renamed to `UnexpectedNull` + - `ValueError` constructor got renamed to `ValueColumnError` - New `RowError` type got created - `RowResult` constructor's column field go transferred into the new `RowError` type From 7d24e0d9d39fc6128a9e9c1379dbfc8298376642 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sat, 27 Apr 2024 22:00:08 +0300 Subject: [PATCH 31/33] Reduce the amount of changes to the error model for now --- CHANGELOG.md | 19 +---- hspec/Hasql/PipelineSpec.hs | 4 +- library/Hasql/Decoders/All.hs | 2 +- library/Hasql/Decoders/Result.hs | 26 +++---- library/Hasql/Decoders/Results.hs | 10 +-- library/Hasql/Decoders/Row.hs | 16 ++--- library/Hasql/Errors.hs | 84 +++++++++------------- library/Hasql/IO.hs | 2 +- library/Hasql/Pipeline/Core.hs | 12 ++-- library/Hasql/Session/Core.hs | 4 +- library/Hasql/Statement.hs | 2 +- tasty/Main.hs | 4 +- testing-kit/Hasql/TestingKit/TestingDsl.hs | 1 - 13 files changed, 79 insertions(+), 107 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 46ee884..48b3b13 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,23 +1,8 @@ # 1.7 -- Error model completely revised: - - All sum-types now follow the convention of having constructors suffixed with the type name. In particular the following transformations occurred: - - `QueryError` type got renamed to `SessionError` - - `QueryError` constructor got renamed to `QuerySessionError` - - New `PipelineSessionError` constructor got added to the `SessionError` type - - `ClientError` constructor got renamed to `ClientCommandError` - - `ResultError` constructor got renamed to `ResultCommandError` - - `ServerError` constructor got renamed to `ServerResultError` - - `UnexpectedResult` constructor got renamed to `UnexpectedResultError` - - `RowError` constructor got renamed to `RowResultError` - - `RowError` type got renamed to `ColumnError` - - `EndOfInput` constructor got renamed to `EndOfInputColumnError` - - `UnexpectedNull` constructor got renamed to `UnexpectedNullColumnError` - - `ValueError` constructor got renamed to `ValueColumnError` - - New `RowError` type got created - - `RowResult` constructor's column field go transferred into the new `RowError` type - - Decidable instance on `Encoders.Params` removed. It was useless and limited the design. +- `QueryError` type renamed to `SessionError`. +- `PipelineError` constructor added to the `SessionError` type. # 1.6.3.1 diff --git a/hspec/Hasql/PipelineSpec.hs b/hspec/Hasql/PipelineSpec.hs index 25bc179..7b88c23 100644 --- a/hspec/Hasql/PipelineSpec.hs +++ b/hspec/Hasql/PipelineSpec.hs @@ -51,7 +51,7 @@ spec = do <*> BrokenSyntax.pipeline True BrokenSyntax.Params {start = 0, end = 2} <*> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} case result of - Left (Dsl.SessionError (Dsl.QuerySessionError _ _ _)) -> pure () + Left (Dsl.SessionError (Dsl.QueryError _ _ _)) -> pure () _ -> expectationFailure $ "Unexpected result: " <> show result it "Leaves the connection usable" do @@ -75,7 +75,7 @@ spec = do <*> WrongDecoder.pipeline True WrongDecoder.Params {start = 0, end = 2} <*> GenerateSeries.pipeline True GenerateSeries.Params {start = 0, end = 2} case result of - Left (Dsl.SessionError (Dsl.QuerySessionError _ _ _)) -> pure () + Left (Dsl.SessionError (Dsl.QueryError _ _ _)) -> pure () _ -> expectationFailure $ "Unexpected result: " <> show result it "Leaves the connection usable" do diff --git a/library/Hasql/Decoders/All.hs b/library/Hasql/Decoders/All.hs index 64d327d..0281e1f 100644 --- a/library/Hasql/Decoders/All.hs +++ b/library/Hasql/Decoders/All.hs @@ -38,7 +38,7 @@ rowsAffected = Result (Results.single Result.rowsAffected) -- | -- Exactly one row. --- Will raise the 'Errors.UnexpectedAmountOfRowsResultError' error if it's any other. +-- Will raise the 'Errors.UnexpectedAmountOfRows' error if it's any other. {-# INLINEABLE singleRow #-} singleRow :: Row a -> Result a singleRow (Row row) = Result (Results.single (Result.single row)) diff --git a/library/Hasql/Decoders/Result.hs b/library/Hasql/Decoders/Result.hs index 85666df..ed67b3b 100644 --- a/library/Hasql/Decoders/Result.hs +++ b/library/Hasql/Decoders/Result.hs @@ -45,13 +45,13 @@ rowsAffected = notNothing >=> notEmpty >=> decimal where notNothing = - Prelude.maybe (Left (UnexpectedResultError "No bytes")) Right + Prelude.maybe (Left (UnexpectedResult "No bytes")) Right notEmpty bytes = if ByteString.null bytes - then Left (UnexpectedResultError "Empty bytes") + then Left (UnexpectedResult "Empty bytes") else Right bytes decimal bytes = - first (\m -> UnexpectedResultError ("Decimal parsing failure: " <> fromString m)) + first (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m)) $ Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes {-# INLINE checkExecStatus #-} @@ -70,7 +70,7 @@ checkExecStatus expectedList = unexpectedResult :: Text -> Result a unexpectedResult = - Result . lift . ExceptT . pure . Left . UnexpectedResultError + Result . lift . ExceptT . pure . Left . UnexpectedResult {-# INLINE serverError #-} serverError :: Result () @@ -90,7 +90,7 @@ serverError = LibPQ.resultErrorField result LibPQ.DiagMessageHint position <- parsePosition <$> LibPQ.resultErrorField result LibPQ.DiagStatementPosition - pure $ Left $ ServerResultError code message detail hint position + pure $ Left $ ServerError code message detail hint position where parsePosition = \case Nothing -> Nothing @@ -112,8 +112,9 @@ maybe rowDec = 0 -> return (Right Nothing) 1 -> do maxCols <- LibPQ.nfields result - fmap (fmap Just . first (RowResultError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) - _ -> return (Left (UnexpectedAmountOfRowsResultError (rowToInt maxRows))) + let fromRowError (col, err) = RowError 0 col err + fmap (fmap Just . first fromRowError) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) + _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows))) where rowToInt (LibPQ.Row n) = fromIntegral n @@ -130,8 +131,9 @@ single rowDec = case maxRows of 1 -> do maxCols <- LibPQ.nfields result - fmap (first (RowResultError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) - _ -> return (Left (UnexpectedAmountOfRowsResultError (rowToInt maxRows))) + let fromRowError (col, err) = RowError 0 col err + fmap (first fromRowError) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) + _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows))) where rowToInt (LibPQ.Row n) = fromIntegral n @@ -151,7 +153,7 @@ vector rowDec = forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) case rowResult of - Left !rowError -> writeIORef failureRef (Just (RowResultError rowIndex rowError)) + Left !(!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x)) Right !x -> MutableVector.unsafeWrite mvector rowIndex x readIORef failureRef >>= \case Nothing -> Right <$> Vector.unsafeFreeze mvector @@ -181,7 +183,7 @@ foldl step init rowDec = forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) case rowResult of - Left !rowError -> writeIORef failureRef (Just (RowResultError rowIndex rowError)) + Left !(!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x)) Right !x -> modifyIORef' accRef (\acc -> step acc x) readIORef failureRef >>= \case Nothing -> Right <$> readIORef accRef @@ -208,7 +210,7 @@ foldr step init rowDec = forMToZero_ (rowToInt maxRows) $ \rowIndex -> do rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) case rowResult of - Left !rowError -> writeIORef failureRef (Just (RowResultError rowIndex rowError)) + Left !(!colIndex, !x) -> writeIORef failureRef (Just (RowError rowIndex colIndex x)) Right !x -> modifyIORef accRef (\acc -> step x acc) readIORef failureRef >>= \case Nothing -> Right <$> readIORef accRef diff --git a/library/Hasql/Decoders/Results.hs b/library/Hasql/Decoders/Results.hs index a92d5d7..9d5da13 100644 --- a/library/Hasql/Decoders/Results.hs +++ b/library/Hasql/Decoders/Results.hs @@ -32,7 +32,7 @@ clientError = $ ReaderT $ \(_, connection) -> ExceptT - $ fmap (Left . ClientCommandError) (LibPQ.errorMessage connection) + $ fmap (Left . ClientError) (LibPQ.errorMessage connection) -- | -- Parse a single result. @@ -45,9 +45,9 @@ single resultDec = resultMaybe <- LibPQ.getResult connection case resultMaybe of Just result -> - first ResultCommandError <$> Result.run resultDec integerDatetimes result + first ResultError <$> Result.run resultDec integerDatetimes result Nothing -> - fmap (Left . ClientCommandError) (LibPQ.errorMessage connection) + fmap (Left . ClientError) (LibPQ.errorMessage connection) {-# INLINE dropRemainders #-} dropRemainders :: Results () @@ -64,11 +64,11 @@ dropRemainders = loop integerDatetimes connection <* checkErrors where checkErrors = - ExceptT $ fmap (first ResultCommandError) $ Result.run Result.noResult integerDatetimes result + ExceptT $ fmap (first ResultError) $ Result.run Result.noResult integerDatetimes result refine :: (a -> Either Text b) -> Results a -> Results b refine refiner (Results stack) = Results $ ReaderT $ \env -> ExceptT $ do resultEither <- runExceptT $ runReaderT stack env - return $ resultEither >>= first (ResultCommandError . UnexpectedResultError) . refiner + return $ resultEither >>= first (ResultError . UnexpectedResult) . refiner diff --git a/library/Hasql/Decoders/Row.hs b/library/Hasql/Decoders/Row.hs index fb50572..cbbd47a 100644 --- a/library/Hasql/Decoders/Row.hs +++ b/library/Hasql/Decoders/Row.hs @@ -7,11 +7,11 @@ import Hasql.Prelude hiding (error) import PostgreSQL.Binary.Decoding qualified as A newtype Row a - = Row (ReaderT Env (ExceptT ColumnError IO) a) + = Row (ReaderT Env (ExceptT RowError IO) a) deriving (Functor, Applicative, Monad) instance MonadFail Row where - fail = error . ValueColumnError . fromString + fail = error . ValueError . fromString data Env = Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column) @@ -19,7 +19,7 @@ data Env -- * Functions {-# INLINE run #-} -run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either RowError a) +run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either (Int, RowError) a) run (Row impl) (result, row, columnsAmount, integerDatetimes) = do columnRef <- newIORef 0 @@ -27,11 +27,11 @@ run (Row impl) (result, row, columnsAmount, integerDatetimes) = Left e -> do LibPQ.Col col <- readIORef columnRef -- -1 because succ is applied before the error is returned - pure $ Left (ColumnRowError (fromIntegral col - 1) e) + pure $ Left (fromIntegral col - 1, e) Right x -> pure $ Right x {-# INLINE error #-} -error :: ColumnError -> Row a +error :: RowError -> Row a error x = Row (ReaderT (const (ExceptT (pure (Left x))))) @@ -55,9 +55,9 @@ value valueDec = Right Nothing Just value -> fmap Just - $ first ValueColumnError + $ first ValueError $ {-# SCC "decode" #-} A.valueParser (Value.run valueDec integerDatetimes) value - else pure (Left EndOfInputColumnError) + else pure (Left EndOfInput) -- | -- Next value, decoded using the provided value decoder. @@ -65,4 +65,4 @@ value valueDec = nonNullValue :: Value.Value a -> Row a nonNullValue valueDec = {-# SCC "nonNullValue" #-} - value valueDec >>= maybe (error UnexpectedNullColumnError) pure + value valueDec >>= maybe (error UnexpectedNull) pure diff --git a/library/Hasql/Errors.hs b/library/Hasql/Errors.hs index 85e7eb1..c7fe084 100644 --- a/library/Hasql/Errors.hs +++ b/library/Hasql/Errors.hs @@ -7,7 +7,7 @@ import Hasql.Prelude data SessionError = -- | Error during the execution of a query. -- Comes packed with the query template and a textual representation of the provided params. - QuerySessionError + QueryError -- | SQL template. ByteString -- | Parameters rendered as human-readable SQL literals. @@ -15,19 +15,19 @@ data SessionError -- | Error details. CommandError | -- | Error during the execution of a pipeline. - PipelineSessionError + PipelineError -- | Error details. CommandError deriving (Show, Eq, Typeable) instance Exception SessionError where displayException = \case - QuerySessionError query params commandError -> + QueryError query params commandError -> let queryContext :: Maybe (ByteString, Int) queryContext = case commandError of - ClientCommandError _ -> Nothing - ResultCommandError resultError -> case resultError of - ServerResultError _ message _ _ (Just position) -> Just (message, position) + ClientError _ -> Nothing + ResultError resultError -> case resultError of + ServerError _ message _ _ (Just position) -> Just (message, position) _ -> Nothing -- find the line number and position of the error @@ -60,32 +60,32 @@ instance Exception SessionError where prettyQuery = case queryContext of Nothing -> query Just (message, pos) -> formatErrorContext query message pos - in "QuerySessionError!\n" + in "QueryError!\n" <> "\n Query:\n" <> BC.unpack prettyQuery <> "\n" <> "\n Params: " <> show params - <> "\n Reason: " + <> "\n Error: " <> renderCommandErrorAsReason commandError - PipelineSessionError commandError -> - "PipelineSessionError!\n Reason: " <> renderCommandErrorAsReason commandError + PipelineError commandError -> + "PipelineError!\n Reason: " <> renderCommandErrorAsReason commandError where renderCommandErrorAsReason = \case - ClientCommandError (Just message) -> "Client error: " <> show message - ClientCommandError Nothing -> "Client error without details" - ResultCommandError resultError -> case resultError of - ServerResultError code message details hint position -> + ClientError (Just message) -> "Client error: " <> show message + ClientError Nothing -> "Client error without details" + ResultError resultError -> case resultError of + ServerError code message details hint position -> "Server error " <> BC.unpack code <> ": " <> BC.unpack message <> maybe "" (\d -> "\n Details: " <> BC.unpack d) details <> maybe "" (\h -> "\n Hint: " <> BC.unpack h) hint - UnexpectedResultError message -> "Unexpected result: " <> show message - RowResultError row (ColumnRowError column rowError) -> + UnexpectedResult message -> "Unexpected result: " <> show message + RowError row column rowError -> "Row error: " <> show row <> ":" <> show column <> " " <> show rowError - UnexpectedAmountOfRowsResultError amount -> + UnexpectedAmountOfRows amount -> "Unexpected amount of rows: " <> show amount -- | @@ -93,19 +93,19 @@ instance Exception SessionError where data CommandError = -- | -- An error on the client-side, - -- with a message generated by the \"libpq\" driver. + -- with a message generated by the \"libpq\" library. -- Usually indicates problems with connection. - ClientCommandError (Maybe ByteString) + ClientError (Maybe ByteString) | -- | -- Some error with a command result. - ResultCommandError ResultError + ResultError ResultError deriving (Show, Eq) -- | -- An error with a command result. data ResultError = -- | An error reported by the DB. - ServerResultError + ServerError -- | __Code__. The SQLSTATE code for the error. It's recommended to use -- to work with those. @@ -124,43 +124,29 @@ data ResultError -- | __Position__. Error cursor position as an index into the original -- statement string. Positions are measured in characters not bytes. (Maybe Int) - | -- | The database returned an unexpected result. + | -- | + -- The database returned an unexpected result. -- Indicates an improper statement or a schema mismatch. - UnexpectedResultError - -- | Details. - Text - | -- | Error decoding a specific row. - RowResultError - -- | Row index. - Int - -- | Details. - RowError - | -- | Unexpected amount of rows. - UnexpectedAmountOfRowsResultError - -- | Actual amount of rows in the result. - Int - deriving (Show, Eq) - -data RowError - = -- | Error at a specific column. - ColumnRowError - -- | Column index. - Int - -- | Error details. - ColumnError + UnexpectedResult Text + | -- | + -- An error of the row reader, preceded by the indexes of the row and column. + RowError Int Int RowError + | -- | + -- An unexpected amount of rows. + UnexpectedAmountOfRows Int deriving (Show, Eq) -- | --- Error during the decoding of a specific column. -data ColumnError +-- An error during the decoding of a specific row. +data RowError = -- | -- Appears on the attempt to parse more columns than there are in the result. - EndOfInputColumnError + EndOfInput | -- | -- Appears on the attempt to parse a @NULL@ as some value. - UnexpectedNullColumnError + UnexpectedNull | -- | -- Appears when a wrong value parser is used. -- Comes with the error details. - ValueColumnError Text + ValueError Text deriving (Show, Eq) diff --git a/library/Hasql/IO.hs b/library/Hasql/IO.hs index 4262f0a..fdbbbb6 100644 --- a/library/Hasql/IO.hs +++ b/library/Hasql/IO.hs @@ -99,7 +99,7 @@ getPreparedStatementKey connection registry template oidList = checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either CommandError ()) checkedSend connection send = send >>= \case - False -> fmap (Left . ClientCommandError) $ LibPQ.errorMessage connection + False -> fmap (Left . ClientError) $ LibPQ.errorMessage connection True -> pure (Right ()) {-# INLINE sendPreparedParametricStatement #-} diff --git a/library/Hasql/Pipeline/Core.hs b/library/Hasql/Pipeline/Core.hs index e60559e..4c76ae4 100644 --- a/library/Hasql/Pipeline/Core.hs +++ b/library/Hasql/Pipeline/Core.hs @@ -45,14 +45,14 @@ run (Pipeline sendQueriesInIO) connection registry integerDatetimes = do runResultsDecoder :: forall a. Decoders.Results.Results a -> ExceptT SessionError IO a runResultsDecoder decoder = ExceptT - $ fmap (first PipelineSessionError) + $ fmap (first PipelineError) $ Decoders.Results.run decoder connection integerDatetimes runCommand :: IO Bool -> ExceptT SessionError IO () runCommand action = lift action >>= \case True -> pure () - False -> ExceptT (Left . PipelineSessionError . ClientCommandError <$> Pq.errorMessage connection) + False -> ExceptT (Left . PipelineError . ClientError <$> Pq.errorMessage connection) newtype Pipeline a = Pipeline @@ -106,7 +106,7 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re sent <- Pq.sendPrepare connection key sql (mfilter (not . null) (Just oidList)) if sent then pure (True, Right (key, recv)) - else (False,) . Left . commandToSessionError . ClientCommandError <$> Pq.errorMessage connection + else (False,) . Left . commandToSessionError . ClientError <$> Pq.errorMessage connection where recv = fmap (first commandToSessionError) @@ -118,7 +118,7 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re sendQuery key = Pq.sendQueryPrepared connection key valueAndFormatList Pq.Binary >>= \case - False -> Left . commandToSessionError . ClientCommandError <$> Pq.errorMessage connection + False -> Left . commandToSessionError . ClientError <$> Pq.errorMessage connection True -> pure (Right recv) where recv = @@ -129,7 +129,7 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re runUnprepared = Pq.sendQueryParams connection sql (Encoders.Params.compileUnpreparedStatementData encoder integerDatetimes params) Pq.Binary >>= \case - False -> Left . commandToSessionError . ClientCommandError <$> Pq.errorMessage connection + False -> Left . commandToSessionError . ClientError <$> Pq.errorMessage connection True -> pure (Right recv) where recv = @@ -139,4 +139,4 @@ statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Re <*> Decoders.Results.run Decoders.Results.dropRemainders connection integerDatetimes commandToSessionError = - QuerySessionError sql (Encoders.Params.renderReadable encoder params) + QueryError sql (Encoders.Params.renderReadable encoder params) diff --git a/library/Hasql/Session/Core.hs b/library/Hasql/Session/Core.hs index c84fcb7..8a8d381 100644 --- a/library/Hasql/Session/Core.hs +++ b/library/Hasql/Session/Core.hs @@ -35,7 +35,7 @@ sql sql = $ ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) -> ExceptT - $ fmap (first (QuerySessionError sql [])) + $ fmap (first (QueryError sql [])) $ withMVar pqConnectionRef $ \pqConnection -> do r1 <- IO.sendNonparametricStatement pqConnection sql @@ -53,7 +53,7 @@ statement input (Statement.Statement template (Encoders.Params paramsEncoder) (D $ ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) -> ExceptT - $ fmap (first (QuerySessionError template (Encoders.Params.renderReadable paramsEncoder input))) + $ fmap (first (QueryError template (Encoders.Params.renderReadable paramsEncoder input))) $ withMVar pqConnectionRef $ \pqConnection -> do r1 <- IO.sendParametricStatement pqConnection integerDatetimes registry template paramsEncoder preparable input diff --git a/library/Hasql/Statement.hs b/library/Hasql/Statement.hs index 1b3a7e0..5bc0aaf 100644 --- a/library/Hasql/Statement.hs +++ b/library/Hasql/Statement.hs @@ -75,7 +75,7 @@ instance Profunctor Statement where -- | -- Refine the result of a statement, --- causing the running session to fail with the `UnexpectedResultError` error in case of a refinement failure. +-- causing the running session to fail with the `UnexpectedResult` error in case of a refinement failure. -- -- This function is especially useful for refining the results of statements produced with -- . diff --git a/tasty/Main.hs b/tasty/Main.hs index f6eee91..9c4802a 100644 --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -56,7 +56,7 @@ tree = in do x <- Connection.with (Session.run session) assertBool (show x) $ case x of - Right (Left (Session.QuerySessionError "select true where 1 = any ($1) and $2" ["[3, 7]", "\"a\""] _)) -> True + Right (Left (Session.QueryError "select true where 1 = any ($1) and $2" ["[3, 7]", "\"a\""] _)) -> True _ -> False, testCase "IN simulation" $ let statement = @@ -218,7 +218,7 @@ tree = where resultTest = \case - Right (Left (Session.QuerySessionError _ _ (Session.ResultCommandError (Session.ServerResultError "26000" _ _ _ _)))) -> False + Right (Left (Session.QueryError _ _ (Session.ResultError (Session.ServerError "26000" _ _ _ _)))) -> False _ -> True session = catchError session (const (pure ())) *> session diff --git a/testing-kit/Hasql/TestingKit/TestingDsl.hs b/testing-kit/Hasql/TestingKit/TestingDsl.hs index 3d91810..d86de75 100644 --- a/testing-kit/Hasql/TestingKit/TestingDsl.hs +++ b/testing-kit/Hasql/TestingKit/TestingDsl.hs @@ -5,7 +5,6 @@ module Hasql.TestingKit.TestingDsl Session.CommandError (..), Session.ResultError (..), Session.RowError (..), - Session.ColumnError (..), -- * Abstractions Session.Session, From 9150f4f13524e47749fedfd6e2cfeffdb3278323 Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sun, 28 Apr 2024 09:37:53 +0300 Subject: [PATCH 32/33] Add docs --- library/Hasql/Pipeline/Core.hs | 19 +++++++++++++++++++ library/Hasql/Session/Core.hs | 4 +++- 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/library/Hasql/Pipeline/Core.hs b/library/Hasql/Pipeline/Core.hs index 4c76ae4..d12e74d 100644 --- a/library/Hasql/Pipeline/Core.hs +++ b/library/Hasql/Pipeline/Core.hs @@ -54,6 +54,23 @@ run (Pipeline sendQueriesInIO) connection registry integerDatetimes = do True -> pure () False -> ExceptT (Left . PipelineError . ClientError <$> Pq.errorMessage connection) +-- | +-- Abstraction over the pipelining mode of execution of queries. +-- +-- It allows you to issue multiple queries to the server in much fewer network transactions. +-- If the amounts of sent and received data do not surpass the buffer sizes it will be just a single roundtrip. +-- Usually the buffer size is 8KB. +-- +-- This execution mode is much more efficient than running queries directly from 'Hasql.Session.Session', because in session every statement execution involves a dedicated network roundtrip. +-- An obvious question rises then: why not execute all queries like that? +-- +-- In situations where the parameters depend on the result of another query it is impossible to execute them in parallel, because the client needs to receive the results of one query before sending the request to execute the next query. +-- This reasoning is essentially the same as the one for the difference between 'Applicative' and 'Monad'. +-- That\'s why 'Pipeline' does not have the 'Monad' instance. +-- +-- To execute 'Pipeline' lift it into 'Session' via 'Hasql.Session.pipeline'. +-- +-- __Attention__: using this feature requires \"libpq\" of version >14. newtype Pipeline a = Pipeline ( Pq.Connection -> @@ -79,6 +96,8 @@ instance Applicative Pipeline where Right rRecv -> Right (liftA2 (<*>) lRecv rRecv) +-- | +-- Execute a statement in pipelining mode. statement :: params -> Statement.Statement params result -> Pipeline result statement params (Statement.Statement sql (Encoders.Params encoder) (Decoders.Result decoder) preparable) = Pipeline run diff --git a/library/Hasql/Session/Core.hs b/library/Hasql/Session/Core.hs index 8a8d381..0e5d139 100644 --- a/library/Hasql/Session/Core.hs +++ b/library/Hasql/Session/Core.hs @@ -46,7 +46,7 @@ sql sql = Decoders.Results.single Decoders.Result.noResult -- | --- Parameters and a specification of a parametric single-statement query to apply them to. +-- Execute a statement by providing parameters to it. statement :: params -> Statement.Statement params result -> Session result statement input (Statement.Statement template (Encoders.Params paramsEncoder) (Decoders.Result decoder) preparable) = Session @@ -60,6 +60,8 @@ statement input (Statement.Statement template (Encoders.Params paramsEncoder) (D r2 <- IO.getResults pqConnection integerDatetimes decoder return $ r1 *> r2 +-- | +-- Execute a pipeline. pipeline :: Pipeline.Pipeline result -> Session result pipeline pipeline = Session $ ReaderT \(Connection.Connection pqConnectionRef integerDatetimes registry) -> From ed10244e6fc6291f3f4e71ca216fb858e5952e1e Mon Sep 17 00:00:00 2001 From: Nikita Volkov Date: Sun, 28 Apr 2024 12:56:31 +0300 Subject: [PATCH 33/33] Extend the docs --- hasql.cabal | 5 ++++ library/Hasql/Pipeline/Core.hs | 55 ++++++++++++++++++++++++++++++---- 2 files changed, 55 insertions(+), 5 deletions(-) diff --git a/hasql.cabal b/hasql.cabal index 09001f2..3e228fc 100644 --- a/hasql.cabal +++ b/hasql.cabal @@ -9,6 +9,11 @@ description: . The API comes free from all kinds of exceptions. All error-reporting is explicit and is presented using the 'Either' type. + This library requires to have the \"libpq\" library installed on the running system. + It comes distributed with PostgreSQL. + To be able to use the \"Pipeline\" feature you'll need \"libpq\" of version >14. + This feature does not however put any requirements on the version of the PostgreSQL server. + homepage: https://github.com/nikita-volkov/hasql bug-reports: https://github.com/nikita-volkov/hasql/issues author: Nikita Volkov diff --git a/library/Hasql/Pipeline/Core.hs b/library/Hasql/Pipeline/Core.hs index d12e74d..ab70f84 100644 --- a/library/Hasql/Pipeline/Core.hs +++ b/library/Hasql/Pipeline/Core.hs @@ -55,22 +55,67 @@ run (Pipeline sendQueriesInIO) connection registry integerDatetimes = do False -> ExceptT (Left . PipelineError . ClientError <$> Pq.errorMessage connection) -- | --- Abstraction over the pipelining mode of execution of queries. +-- Composable abstraction over the execution of queries in [the pipeline mode](https://www.postgresql.org/docs/current/libpq-pipeline-mode.html). -- -- It allows you to issue multiple queries to the server in much fewer network transactions. --- If the amounts of sent and received data do not surpass the buffer sizes it will be just a single roundtrip. --- Usually the buffer size is 8KB. +-- If the amounts of sent and received data do not surpass the buffer sizes in the driver and on the server it will be just a single roundtrip. +-- Typically the buffer size is 8KB. -- -- This execution mode is much more efficient than running queries directly from 'Hasql.Session.Session', because in session every statement execution involves a dedicated network roundtrip. -- An obvious question rises then: why not execute all queries like that? -- --- In situations where the parameters depend on the result of another query it is impossible to execute them in parallel, because the client needs to receive the results of one query before sending the request to execute the next query. +-- In situations where the parameters depend on the result of another query it is impossible to execute them in parallel, because the client needs to receive the results of one query before sending the request to execute the next. -- This reasoning is essentially the same as the one for the difference between 'Applicative' and 'Monad'. -- That\'s why 'Pipeline' does not have the 'Monad' instance. -- --- To execute 'Pipeline' lift it into 'Session' via 'Hasql.Session.pipeline'. +-- To execute 'Pipeline' lift it into 'Hasql.Session.Session' via 'Hasql.Session.pipeline'. -- -- __Attention__: using this feature requires \"libpq\" of version >14. +-- +-- == __Examples__ +-- +-- === Insert-Many or Batch-Insert +-- +-- You can use pipeline to turn a single-row insert query into an efficient multi-row insertion session. +-- In effect this should be comparable in performance to issuing a single multi-row insert statement. +-- +-- Given the following definition in a Statements module: +-- +-- @ +-- insertOrder :: 'Hasql.Statement.Statement' OrderDetails OrderId +-- @ +-- +-- You can lift it into the following session +-- +-- @ +-- insertOrders :: [OrderDetails] -> 'Hasql.Session.Session' [OrderId] +-- insertOrders songs = +-- 'Hasql.Session.pipeline' $ +-- forM songs $ \song -> +-- 'Hasql.Pipeline.statement' song Statements.insertOrder +-- @ +-- +-- === Combining Queries +-- +-- Given the following definitions in a Statements module: +-- +-- @ +-- selectOrderDetails :: 'Hasql.Statement.Statement' OrderId (Maybe OrderDetails) +-- selectOrderProducts :: 'Hasql.Statement.Statement' OrderId [OrderProduct] +-- selectOrderFinancialTransactions :: 'Hasql.Statement.Statement' OrderId [FinancialTransaction] +-- @ +-- +-- You can combine them into a session using the `ApplicativeDo` extension as follows: +-- +-- @ +-- selectEverythingAboutOrder :: OrderId -> 'Hasql.Session.Session' (Maybe OrderDetails, [OrderProduct], [FinancialTransaction]) +-- selectEverythingAboutOrder orderId = +-- 'Hasql.Session.pipeline' $ do +-- details <- 'Hasql.Pipeline.statement' orderId Statements.selectOrderDetails +-- products <- 'Hasql.Pipeline.statement' orderId Statements.selectOrderProducts +-- transactions <- 'Hasql.Pipeline.statement' orderId Statements.selectOrderFinancialTransactions +-- pure (details, products, transactions) +-- @ newtype Pipeline a = Pipeline ( Pq.Connection ->