diff --git a/postgresql-types.cabal b/postgresql-types.cabal --- a/postgresql-types.cabal +++ b/postgresql-types.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: postgresql-types -version: 0.1 +version: 0.1.1 category: PostgreSQL, Codecs synopsis: Precise PostgreSQL types representation and driver-agnostic codecs description: @@ -143,6 +143,7 @@ PostgresqlTypes.Varchar other-modules: + PostgresqlTypes.Multirange.List PostgresqlTypes.Numeric.Integer PostgresqlTypes.Numeric.Scientific PostgresqlTypes.Prelude @@ -162,7 +163,6 @@ invariant ^>=0.6.4, jsonifier ^>=0.2.1.3, mtl >=2.2 && <3, - postgresql-types:base-extras, postgresql-types:jsonifier-aeson, postgresql-types:time-extras, postgresql-types-algebra ^>=0.1, @@ -170,7 +170,6 @@ ptr-peeker ^>=0.1, ptr-poker ^>=0.1.3, quickcheck-extras ^>=0.1, - quickcheck-instances ^>=0.3.33, scientific >=0.3 && <1, tagged ^>=0.8.9, text >=1.2 && <3, @@ -204,33 +203,6 @@ base >=4.11 && <5, time >=1.12 && <2, -library base-extras - import: base - hs-source-dirs: src/base-extras - exposed-modules: - BaseExtras.List - -library pq-procedures - import: base - hs-source-dirs: src/pq-procedures - exposed-modules: - PqProcedures - PqProcedures.Algebra - PqProcedures.Procedures - - other-modules: - PqProcedures.Procedures.GetTypeInfoByName - PqProcedures.Procedures.RunRoundtripQuery - PqProcedures.Procedures.RunStatement - - build-depends: - base >=4.11 && <5, - bytestring >=0.10 && <0.13, - postgresql-libpq >=0.10 && <0.12, - ptr-peeker ^>=0.1, - text >=1.2 && <3, - text-builder ^>=1.0.0.4, - test-suite unit-tests import: test type: exitcode-stdio-1.0 @@ -291,10 +263,11 @@ containers >=0.6 && <0.9, hspec >=2.11 && <3, postgresql-types, - postgresql-types-algebra, + postgresql-types-algebra ^>=0.1, ptr-peeker ^>=0.1, ptr-poker ^>=0.1.2.16, quickcheck-classes ^>=0.6.5, + quickcheck-instances ^>=0.3.33, scientific >=0.3 && <1, tagged ^>=0.8.9, text >=1.2 && <3, @@ -309,8 +282,14 @@ hs-source-dirs: src/integration-tests main-is: Main.hs other-modules: - Main.Scopes - Main.Scripts + IntegrationTests.Scopes + IntegrationTests.Scripts + PqProcedures + PqProcedures.Algebra + PqProcedures.Procedures + PqProcedures.Procedures.GetTypeInfoByName + PqProcedures.Procedures.RunRoundtripQuery + PqProcedures.Procedures.RunStatement build-depends: QuickCheck >=2.14 && <3, @@ -321,8 +300,7 @@ hspec >=2.11 && <3, postgresql-libpq >=0.10 && <0.12, postgresql-types, - postgresql-types:pq-procedures, - postgresql-types-algebra, + postgresql-types-algebra ^>=0.1, ptr-peeker ^>=0.1, ptr-poker ^>=0.1.2.16, quickcheck-instances ^>=0.3.33, diff --git a/src/base-extras/BaseExtras/List.hs b/src/base-extras/BaseExtras/List.hs deleted file mode 100644 --- a/src/base-extras/BaseExtras/List.hs +++ /dev/null @@ -1,6 +0,0 @@ -module BaseExtras.List where - -toPairs :: [a] -> [(a, a)] -toPairs [] = [] -toPairs [_] = [] -toPairs (x : y : xs) = (x, y) : toPairs xs diff --git a/src/integration-tests/IntegrationTests/Scopes.hs b/src/integration-tests/IntegrationTests/Scopes.hs new file mode 100644 --- /dev/null +++ b/src/integration-tests/IntegrationTests/Scopes.hs @@ -0,0 +1,144 @@ +module IntegrationTests.Scopes where + +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import qualified Data.ByteString as ByteString +import Data.Function +import Data.Maybe +import Data.Proxy +import Data.String +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import Data.Typeable +import Data.Word +import qualified Database.PostgreSQL.LibPQ as Pq +import Test.Hspec +import qualified TestcontainersPostgresql +import qualified TextBuilder +import Prelude + +withContainer :: Text -> SpecWith (Text, Word16) -> Spec +withContainer tagName = + describe (Text.unpack tagName) . aroundAll (TestcontainersPostgresql.run config) + where + config = + TestcontainersPostgresql.Config + { forwardLogs = False, + auth = TestcontainersPostgresql.TrustAuth, + tagName + } + +withConnection :: Maybe Int -> SpecWith Pq.Connection -> SpecWith (Text, Word16) +withConnection extraFloatDigits = + withConnectionPool 100 extraFloatDigits . withTQueueElement clean + where + clean connection = pure connection + +withConnectionPool :: Int -> Maybe Int -> SpecWith (TQueue Pq.Connection) -> SpecWith (Text, Word16) +withConnectionPool poolSize extraFloatDigits = + describe name . mapSubject connectionStringByContainerInfo . withPool poolSize acquire release + where + name = + mconcat + [ "extraFloatDigits: ", + case extraFloatDigits of + Just digits -> show digits + Nothing -> "default" + ] + + connectionStringByContainerInfo (host, port) = + ByteString.intercalate " " components + where + components = + [ "host=" <> (Text.Encoding.encodeUtf8 host), + "port=" <> (fromString . show) port, + "user=" <> user, + "password=" <> password, + "dbname=" <> db + ] + where + user = "postgres" + password = "postgres" + db = "postgres" + + acquire connectionString = do + connection <- Pq.connectdb connectionString + status <- Pq.status connection + case status of + Pq.ConnectionOk -> pure () + _ -> do + message <- Pq.errorMessage connection + fail ("Failed to connect to database: " <> show message) + result <- + Pq.exec + connection + ( [ Just "SET client_min_messages TO WARNING", + Just "SET client_encoding = 'UTF8'", + Just "SET intervalstyle = 'iso_8601'", + fmap + (\digits -> "SET extra_float_digits = " <> TextBuilder.decimal digits) + extraFloatDigits + ] + & catMaybes + & fmap (<> ";") + & TextBuilder.intercalate "\n" + & TextBuilder.toText + & Text.Encoding.encodeUtf8 + ) + case result of + Just _ -> pure () + Nothing -> do + message <- Pq.errorMessage connection + fail ("Failed to set connection parameters: " <> show message) + pure connection + + release = Pq.finish + +withPool :: + -- | Pool size. + Int -> + -- | Acquire. + (b -> IO a) -> + -- | Release. + (a -> IO ()) -> + SpecWith (TQueue a) -> + SpecWith b +withPool poolSize acquire release = + describe ("poolSize: " <> show poolSize) . aroundAllWith \actionWithQueue b -> + bracket + ( do + queue <- newTQueueIO + replicateConcurrently_ poolSize do + element <- acquire b + atomically $ writeTQueue queue element + pure queue + ) + ( \queue -> do + replicateConcurrently_ poolSize do + element <- atomically $ readTQueue queue + release element + ) + actionWithQueue + +withTQueueElement :: + -- | Clean. Called upon returning to the pool. + (a -> IO a) -> + SpecWith a -> + SpecWith (TQueue a) +withTQueueElement clean = + aroundWith \actionWithElement queue -> + bracket + (atomically $ readTQueue queue) + ( \element -> do + element <- clean element + atomically $ writeTQueue queue element + ) + actionWithElement + +withType :: forall a b. (Typeable a) => [Proxy a -> SpecWith b] -> SpecWith b +withType specs = do + describe (show (typeOf (undefined :: a))) do + mapM_ (\spec -> spec Proxy) specs diff --git a/src/integration-tests/IntegrationTests/Scripts.hs b/src/integration-tests/IntegrationTests/Scripts.hs new file mode 100644 --- /dev/null +++ b/src/integration-tests/IntegrationTests/Scripts.hs @@ -0,0 +1,221 @@ +module IntegrationTests.Scripts where + +import Control.Monad +import qualified Data.Attoparsec.Text +import Data.Function +import Data.Maybe +import Data.Proxy +import Data.Tagged +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Database.PostgreSQL.LibPQ as Pq +import qualified PostgresqlTypes.Algebra +import qualified PqProcedures as Procedures +import qualified PtrPeeker +import qualified PtrPoker.Write +import Test.Hspec +import Test.QuickCheck ((.&&.), (===)) +import qualified Test.QuickCheck as QuickCheck +import qualified TextBuilder +import Prelude + +mappingSpec :: + forall a. + (HasCallStack, QuickCheck.Arbitrary a, Show a, Eq a, PostgresqlTypes.Algebra.IsScalar a) => + Proxy a -> + SpecWith Pq.Connection +mappingSpec _ = + let typeName = untag (PostgresqlTypes.Algebra.typeName @a) + maybeBaseOid = untag (PostgresqlTypes.Algebra.baseOid @a) + maybeArrayOid = untag (PostgresqlTypes.Algebra.arrayOid @a) + binEnc = PostgresqlTypes.Algebra.binaryEncoder @a + binDec = PostgresqlTypes.Algebra.binaryDecoder @a + txtEnc = PostgresqlTypes.Algebra.textualEncoder @a + txtDec = PostgresqlTypes.Algebra.textualDecoder @a + + getOids connection = do + case (maybeBaseOid, maybeArrayOid) of + (Just baseOid, Just arrayOid) -> + pure (baseOid, arrayOid) + _ -> do + Procedures.GetTypeInfoByNameResult {..} <- Procedures.run connection Procedures.GetTypeInfoByNameParams {name = typeName} + baseOid <- case maybeBaseOid of + Just oid -> pure oid + Nothing -> case baseOid of + Just oid -> pure oid + Nothing -> fail $ "Base OID not found for type: " <> Text.unpack typeName + arrayOid <- case maybeArrayOid of + Just oid -> pure oid + Nothing -> case arrayOid of + Just oid -> pure oid + Nothing -> fail $ "Array OID not found for type: " <> Text.unpack typeName + pure (baseOid, arrayOid) + in describe "IsScalar" do + describe (Text.unpack typeName) do + describe "Encoding via textualEncoder" do + describe "And decoding via textualDecoder" do + it "Should produce the original value" \(connection :: Pq.Connection) -> + QuickCheck.property \(value :: a) -> do + let valueText = TextBuilder.toText (txtEnc value) + QuickCheck.idempotentIOProperty do + (baseOid, _) <- getOids connection + bytes <- + Procedures.run + connection + Procedures.RunRoundtripQueryParams + { paramOid = baseOid, + paramEncoding = Text.Encoding.encodeUtf8 valueText, + paramFormat = Pq.Text, + resultFormat = Pq.Text, + typeSignature = Nothing + } + let serverProducedText = Text.Encoding.decodeUtf8 bytes + decoding = Data.Attoparsec.Text.parseOnly txtDec serverProducedText + pure + ( QuickCheck.counterexample + ( Text.unpack + ( Text.intercalate + "\n" + [ "serverProducedText: " <> serverProducedText, + "encoded: " <> valueText + ] + ) + ) + (decoding === Right value) + ) + + describe "And decoding via binaryDecoder" do + it "Should produce the original value" \(connection :: Pq.Connection) -> + QuickCheck.property \(value :: a) -> do + let valueText = TextBuilder.toText (txtEnc value) + QuickCheck.idempotentIOProperty do + (baseOid, _) <- getOids connection + bytes <- + Procedures.run + connection + Procedures.RunRoundtripQueryParams + { paramOid = baseOid, + paramEncoding = Text.Encoding.encodeUtf8 valueText, + paramFormat = Pq.Text, + resultFormat = Pq.Binary, + typeSignature = Nothing + } + let decoding = PtrPeeker.runVariableOnByteString binDec bytes + pure + ( QuickCheck.counterexample + ( Text.unpack + ( Text.intercalate + "\n" + [ "encoded: " <> valueText + ] + ) + ) + (decoding === Right (Right value)) + ) + + describe "Encoding via binaryEncoder" do + describe "And decoding via textualDecoder" do + it "Should produce the original value" \(connection :: Pq.Connection) -> + QuickCheck.property \(value :: a) -> do + QuickCheck.idempotentIOProperty do + (baseOid, _) <- getOids connection + bytes <- + Procedures.run + connection + Procedures.RunRoundtripQueryParams + { paramOid = baseOid, + paramEncoding = PtrPoker.Write.toByteString (binEnc value), + paramFormat = Pq.Binary, + resultFormat = Pq.Text, + typeSignature = Nothing + } + let serverProducedText = Text.Encoding.decodeUtf8 bytes + decoding = Data.Attoparsec.Text.parseOnly txtDec serverProducedText + pure + ( QuickCheck.counterexample + ("serverProducedText: " <> show serverProducedText) + (decoding === Right value) + ) + + describe "And decoding via binaryDecoder" do + it "Should produce the original value" \(connection :: Pq.Connection) -> + QuickCheck.property \(value :: a) -> do + QuickCheck.idempotentIOProperty do + (baseOid, _) <- getOids connection + bytes <- + Procedures.run + connection + Procedures.RunRoundtripQueryParams + { paramOid = baseOid, + paramEncoding = PtrPoker.Write.toByteString (binEnc value), + paramFormat = Pq.Binary, + resultFormat = Pq.Binary, + typeSignature = Nothing + } + let decoding = PtrPeeker.runVariableOnByteString binDec bytes + pure (decoding === Right (Right value)) + + describe "As array" do + it "Should produce the original value" \(connection :: Pq.Connection) -> + QuickCheck.property \(value :: [a]) -> do + QuickCheck.idempotentIOProperty do + (baseOid, arrayOid) <- getOids connection + let arrayElementBinEnc value' = + let write = binEnc value' + in PtrPoker.Write.bInt32 (fromIntegral (PtrPoker.Write.writeSize write)) <> write + arrayBinEnc value' = + mconcat + [ PtrPoker.Write.bWord32 1, + PtrPoker.Write.bWord32 0, + PtrPoker.Write.bWord32 baseOid, + PtrPoker.Write.bInt32 (fromIntegral (length value')), + PtrPoker.Write.bWord32 1, + foldMap arrayElementBinEnc value' + ] + arrayElementBinDec = do + size <- PtrPeeker.fixed PtrPeeker.beSignedInt4 + case size of + -1 -> error "TODO" + _ -> PtrPeeker.forceSize (fromIntegral size) binDec + arrayBinDec = do + dims <- PtrPeeker.fixed PtrPeeker.beUnsignedInt4 + _ <- PtrPeeker.fixed PtrPeeker.beUnsignedInt4 + decodedBaseOid <- PtrPeeker.fixed PtrPeeker.beUnsignedInt4 + case dims of + 0 -> pure (decodedBaseOid, Right []) + 1 -> do + length <- PtrPeeker.fixed PtrPeeker.beUnsignedInt4 + _ <- PtrPeeker.fixed PtrPeeker.beUnsignedInt4 + values <- replicateM (fromIntegral length) arrayElementBinDec + pure (decodedBaseOid, sequence values) + _ -> error "Bug" + bytes <- + Procedures.run + connection + Procedures.RunRoundtripQueryParams + { paramOid = arrayOid, + paramEncoding = PtrPoker.Write.toByteString (arrayBinEnc value), + paramFormat = Pq.Binary, + resultFormat = Pq.Binary, + typeSignature = Nothing + } + let decoding = PtrPeeker.runVariableOnByteString arrayBinDec bytes + (decodedBaseOid, decoding) <- case decoding of + Left bytesNeeded -> fail $ "More input bytes needed: " <> show bytesNeeded + Right decoding -> pure decoding + decodedValue <- case decoding of + Right value' -> pure value' + _ -> fail "Decoding failed 2" + pure (decodedBaseOid === baseOid .&&. decodedValue === value) + + describe "Metadata" do + it "Should match the DB catalogue" \(connection :: Pq.Connection) -> do + Procedures.GetTypeInfoByNameResult {..} <- Procedures.run connection Procedures.GetTypeInfoByNameParams {name = typeName} + case (maybeBaseOid, maybeArrayOid) of + (Just expectedBaseOid, Just expectedArrayOid) -> do + shouldBe baseOid (Just expectedBaseOid) + shouldBe arrayOid (Just expectedArrayOid) + _ -> do + -- For types without stable OIDs, just verify the OIDs exist + shouldSatisfy baseOid isJust + shouldSatisfy arrayOid isJust diff --git a/src/integration-tests/Main.hs b/src/integration-tests/Main.hs --- a/src/integration-tests/Main.hs +++ b/src/integration-tests/Main.hs @@ -1,7 +1,7 @@ module Main (main) where -import Main.Scopes -import Main.Scripts +import IntegrationTests.Scopes +import IntegrationTests.Scripts import qualified PostgresqlTypes as PostgresqlTypes import Test.Hspec import Test.QuickCheck.Instances () diff --git a/src/integration-tests/Main/Scopes.hs b/src/integration-tests/Main/Scopes.hs deleted file mode 100644 --- a/src/integration-tests/Main/Scopes.hs +++ /dev/null @@ -1,144 +0,0 @@ -module Main.Scopes where - -import Control.Concurrent.Async -import Control.Concurrent.STM -import Control.Exception -import Control.Monad -import qualified Data.ByteString as ByteString -import Data.Function -import Data.Maybe -import Data.Proxy -import Data.String -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import Data.Typeable -import Data.Word -import qualified Database.PostgreSQL.LibPQ as Pq -import Test.Hspec -import qualified TestcontainersPostgresql -import qualified TextBuilder -import Prelude - -withContainer :: Text -> SpecWith (Text, Word16) -> Spec -withContainer tagName = - describe (Text.unpack tagName) . aroundAll (TestcontainersPostgresql.run config) - where - config = - TestcontainersPostgresql.Config - { forwardLogs = False, - auth = TestcontainersPostgresql.TrustAuth, - tagName - } - -withConnection :: Maybe Int -> SpecWith Pq.Connection -> SpecWith (Text, Word16) -withConnection extraFloatDigits = - withConnectionPool 100 extraFloatDigits . withTQueueElement clean - where - clean connection = pure connection - -withConnectionPool :: Int -> Maybe Int -> SpecWith (TQueue Pq.Connection) -> SpecWith (Text, Word16) -withConnectionPool poolSize extraFloatDigits = - describe name . mapSubject connectionStringByContainerInfo . withPool poolSize acquire release - where - name = - mconcat - [ "extraFloatDigits: ", - case extraFloatDigits of - Just digits -> show digits - Nothing -> "default" - ] - - connectionStringByContainerInfo (host, port) = - ByteString.intercalate " " components - where - components = - [ "host=" <> (Text.Encoding.encodeUtf8 host), - "port=" <> (fromString . show) port, - "user=" <> user, - "password=" <> password, - "dbname=" <> db - ] - where - user = "postgres" - password = "postgres" - db = "postgres" - - acquire connectionString = do - connection <- Pq.connectdb connectionString - status <- Pq.status connection - case status of - Pq.ConnectionOk -> pure () - _ -> do - message <- Pq.errorMessage connection - fail ("Failed to connect to database: " <> show message) - result <- - Pq.exec - connection - ( [ Just "SET client_min_messages TO WARNING", - Just "SET client_encoding = 'UTF8'", - Just "SET intervalstyle = 'iso_8601'", - fmap - (\digits -> "SET extra_float_digits = " <> TextBuilder.decimal digits) - extraFloatDigits - ] - & catMaybes - & fmap (<> ";") - & TextBuilder.intercalate "\n" - & TextBuilder.toText - & Text.Encoding.encodeUtf8 - ) - case result of - Just _ -> pure () - Nothing -> do - message <- Pq.errorMessage connection - fail ("Failed to set connection parameters: " <> show message) - pure connection - - release = Pq.finish - -withPool :: - -- | Pool size. - Int -> - -- | Acquire. - (b -> IO a) -> - -- | Release. - (a -> IO ()) -> - SpecWith (TQueue a) -> - SpecWith b -withPool poolSize acquire release = - describe ("poolSize: " <> show poolSize) . aroundAllWith \actionWithQueue b -> - bracket - ( do - queue <- newTQueueIO - replicateConcurrently_ poolSize do - element <- acquire b - atomically $ writeTQueue queue element - pure queue - ) - ( \queue -> do - replicateConcurrently_ poolSize do - element <- atomically $ readTQueue queue - release element - ) - actionWithQueue - -withTQueueElement :: - -- | Clean. Called upon returning to the pool. - (a -> IO a) -> - SpecWith a -> - SpecWith (TQueue a) -withTQueueElement clean = - aroundWith \actionWithElement queue -> - bracket - (atomically $ readTQueue queue) - ( \element -> do - element <- clean element - atomically $ writeTQueue queue element - ) - actionWithElement - -withType :: forall a b. (Typeable a) => [Proxy a -> SpecWith b] -> SpecWith b -withType specs = do - describe (show (typeOf (undefined :: a))) do - mapM_ (\spec -> spec Proxy) specs diff --git a/src/integration-tests/Main/Scripts.hs b/src/integration-tests/Main/Scripts.hs deleted file mode 100644 --- a/src/integration-tests/Main/Scripts.hs +++ /dev/null @@ -1,221 +0,0 @@ -module Main.Scripts where - -import Control.Monad -import qualified Data.Attoparsec.Text -import Data.Function -import Data.Maybe -import Data.Proxy -import Data.Tagged -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Database.PostgreSQL.LibPQ as Pq -import qualified PostgresqlTypes.Algebra -import qualified PqProcedures as Procedures -import qualified PtrPeeker -import qualified PtrPoker.Write -import Test.Hspec -import Test.QuickCheck ((.&&.), (===)) -import qualified Test.QuickCheck as QuickCheck -import qualified TextBuilder -import Prelude - -mappingSpec :: - forall a. - (HasCallStack, QuickCheck.Arbitrary a, Show a, Eq a, PostgresqlTypes.Algebra.IsScalar a) => - Proxy a -> - SpecWith Pq.Connection -mappingSpec _ = - let typeName = untag (PostgresqlTypes.Algebra.typeName @a) - maybeBaseOid = untag (PostgresqlTypes.Algebra.baseOid @a) - maybeArrayOid = untag (PostgresqlTypes.Algebra.arrayOid @a) - binEnc = PostgresqlTypes.Algebra.binaryEncoder @a - binDec = PostgresqlTypes.Algebra.binaryDecoder @a - txtEnc = PostgresqlTypes.Algebra.textualEncoder @a - txtDec = PostgresqlTypes.Algebra.textualDecoder @a - - getOids connection = do - case (maybeBaseOid, maybeArrayOid) of - (Just baseOid, Just arrayOid) -> - pure (baseOid, arrayOid) - _ -> do - Procedures.GetTypeInfoByNameResult {..} <- Procedures.run connection Procedures.GetTypeInfoByNameParams {name = typeName} - baseOid <- case maybeBaseOid of - Just oid -> pure oid - Nothing -> case baseOid of - Just oid -> pure oid - Nothing -> fail $ "Base OID not found for type: " <> Text.unpack typeName - arrayOid <- case maybeArrayOid of - Just oid -> pure oid - Nothing -> case arrayOid of - Just oid -> pure oid - Nothing -> fail $ "Array OID not found for type: " <> Text.unpack typeName - pure (baseOid, arrayOid) - in describe "IsScalar" do - describe (Text.unpack typeName) do - describe "Encoding via textualEncoder" do - describe "And decoding via textualDecoder" do - it "Should produce the original value" \(connection :: Pq.Connection) -> - QuickCheck.property \(value :: a) -> do - let valueText = TextBuilder.toText (txtEnc value) - QuickCheck.idempotentIOProperty do - (baseOid, _) <- getOids connection - bytes <- - Procedures.run - connection - Procedures.RunRoundtripQueryParams - { paramOid = baseOid, - paramEncoding = Text.Encoding.encodeUtf8 valueText, - paramFormat = Pq.Text, - resultFormat = Pq.Text, - typeSignature = Nothing - } - let serverProducedText = Text.Encoding.decodeUtf8 bytes - decoding = Data.Attoparsec.Text.parseOnly txtDec serverProducedText - pure - ( QuickCheck.counterexample - ( Text.unpack - ( Text.intercalate - "\n" - [ "serverProducedText: " <> serverProducedText, - "encoded: " <> valueText - ] - ) - ) - (decoding === Right value) - ) - - describe "And decoding via binaryDecoder" do - it "Should produce the original value" \(connection :: Pq.Connection) -> - QuickCheck.property \(value :: a) -> do - let valueText = TextBuilder.toText (txtEnc value) - QuickCheck.idempotentIOProperty do - (baseOid, _) <- getOids connection - bytes <- - Procedures.run - connection - Procedures.RunRoundtripQueryParams - { paramOid = baseOid, - paramEncoding = Text.Encoding.encodeUtf8 valueText, - paramFormat = Pq.Text, - resultFormat = Pq.Binary, - typeSignature = Nothing - } - let decoding = PtrPeeker.runVariableOnByteString binDec bytes - pure - ( QuickCheck.counterexample - ( Text.unpack - ( Text.intercalate - "\n" - [ "encoded: " <> valueText - ] - ) - ) - (decoding === Right (Right value)) - ) - - describe "Encoding via binaryEncoder" do - describe "And decoding via textualDecoder" do - it "Should produce the original value" \(connection :: Pq.Connection) -> - QuickCheck.property \(value :: a) -> do - QuickCheck.idempotentIOProperty do - (baseOid, _) <- getOids connection - bytes <- - Procedures.run - connection - Procedures.RunRoundtripQueryParams - { paramOid = baseOid, - paramEncoding = PtrPoker.Write.toByteString (binEnc value), - paramFormat = Pq.Binary, - resultFormat = Pq.Text, - typeSignature = Nothing - } - let serverProducedText = Text.Encoding.decodeUtf8 bytes - decoding = Data.Attoparsec.Text.parseOnly txtDec serverProducedText - pure - ( QuickCheck.counterexample - ("serverProducedText: " <> show serverProducedText) - (decoding === Right value) - ) - - describe "And decoding via binaryDecoder" do - it "Should produce the original value" \(connection :: Pq.Connection) -> - QuickCheck.property \(value :: a) -> do - QuickCheck.idempotentIOProperty do - (baseOid, _) <- getOids connection - bytes <- - Procedures.run - connection - Procedures.RunRoundtripQueryParams - { paramOid = baseOid, - paramEncoding = PtrPoker.Write.toByteString (binEnc value), - paramFormat = Pq.Binary, - resultFormat = Pq.Binary, - typeSignature = Nothing - } - let decoding = PtrPeeker.runVariableOnByteString binDec bytes - pure (decoding === Right (Right value)) - - describe "As array" do - it "Should produce the original value" \(connection :: Pq.Connection) -> - QuickCheck.property \(value :: [a]) -> do - QuickCheck.idempotentIOProperty do - (baseOid, arrayOid) <- getOids connection - let arrayElementBinEnc value' = - let write = binEnc value' - in PtrPoker.Write.bInt32 (fromIntegral (PtrPoker.Write.writeSize write)) <> write - arrayBinEnc value' = - mconcat - [ PtrPoker.Write.bWord32 1, - PtrPoker.Write.bWord32 0, - PtrPoker.Write.bWord32 baseOid, - PtrPoker.Write.bInt32 (fromIntegral (length value')), - PtrPoker.Write.bWord32 1, - foldMap arrayElementBinEnc value' - ] - arrayElementBinDec = do - size <- PtrPeeker.fixed PtrPeeker.beSignedInt4 - case size of - -1 -> error "TODO" - _ -> PtrPeeker.forceSize (fromIntegral size) binDec - arrayBinDec = do - dims <- PtrPeeker.fixed PtrPeeker.beUnsignedInt4 - _ <- PtrPeeker.fixed PtrPeeker.beUnsignedInt4 - decodedBaseOid <- PtrPeeker.fixed PtrPeeker.beUnsignedInt4 - case dims of - 0 -> pure (decodedBaseOid, Right []) - 1 -> do - length <- PtrPeeker.fixed PtrPeeker.beUnsignedInt4 - _ <- PtrPeeker.fixed PtrPeeker.beUnsignedInt4 - values <- replicateM (fromIntegral length) arrayElementBinDec - pure (decodedBaseOid, sequence values) - _ -> error "Bug" - bytes <- - Procedures.run - connection - Procedures.RunRoundtripQueryParams - { paramOid = arrayOid, - paramEncoding = PtrPoker.Write.toByteString (arrayBinEnc value), - paramFormat = Pq.Binary, - resultFormat = Pq.Binary, - typeSignature = Nothing - } - let decoding = PtrPeeker.runVariableOnByteString arrayBinDec bytes - (decodedBaseOid, decoding) <- case decoding of - Left bytesNeeded -> fail $ "More input bytes needed: " <> show bytesNeeded - Right decoding -> pure decoding - decodedValue <- case decoding of - Right value' -> pure value' - _ -> fail "Decoding failed 2" - pure (decodedBaseOid === baseOid .&&. decodedValue === value) - - describe "Metadata" do - it "Should match the DB catalogue" \(connection :: Pq.Connection) -> do - Procedures.GetTypeInfoByNameResult {..} <- Procedures.run connection Procedures.GetTypeInfoByNameParams {name = typeName} - case (maybeBaseOid, maybeArrayOid) of - (Just expectedBaseOid, Just expectedArrayOid) -> do - shouldBe baseOid (Just expectedBaseOid) - shouldBe arrayOid (Just expectedArrayOid) - _ -> do - -- For types without stable OIDs, just verify the OIDs exist - shouldSatisfy baseOid isJust - shouldSatisfy arrayOid isJust diff --git a/src/integration-tests/PqProcedures.hs b/src/integration-tests/PqProcedures.hs new file mode 100644 --- /dev/null +++ b/src/integration-tests/PqProcedures.hs @@ -0,0 +1,8 @@ +module PqProcedures + ( module PqProcedures.Procedures, + module PqProcedures.Algebra, + ) +where + +import PqProcedures.Algebra +import PqProcedures.Procedures diff --git a/src/integration-tests/PqProcedures/Algebra.hs b/src/integration-tests/PqProcedures/Algebra.hs new file mode 100644 --- /dev/null +++ b/src/integration-tests/PqProcedures/Algebra.hs @@ -0,0 +1,7 @@ +module PqProcedures.Algebra where + +import qualified Database.PostgreSQL.LibPQ as Pq +import Prelude + +class Procedure params result | params -> result where + run :: Pq.Connection -> params -> IO result diff --git a/src/integration-tests/PqProcedures/Procedures.hs b/src/integration-tests/PqProcedures/Procedures.hs new file mode 100644 --- /dev/null +++ b/src/integration-tests/PqProcedures/Procedures.hs @@ -0,0 +1,10 @@ +module PqProcedures.Procedures + ( module PqProcedures.Procedures.GetTypeInfoByName, + module PqProcedures.Procedures.RunRoundtripQuery, + module PqProcedures.Procedures.RunStatement, + ) +where + +import PqProcedures.Procedures.GetTypeInfoByName +import PqProcedures.Procedures.RunRoundtripQuery +import PqProcedures.Procedures.RunStatement diff --git a/src/integration-tests/PqProcedures/Procedures/GetTypeInfoByName.hs b/src/integration-tests/PqProcedures/Procedures/GetTypeInfoByName.hs new file mode 100644 --- /dev/null +++ b/src/integration-tests/PqProcedures/Procedures/GetTypeInfoByName.hs @@ -0,0 +1,61 @@ +module PqProcedures.Procedures.GetTypeInfoByName + ( GetTypeInfoByNameParams (..), + GetTypeInfoByNameResult (..), + ) +where + +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text.Encoding as Text.Encoding +import Data.Word +import qualified Database.PostgreSQL.LibPQ as Pq +import PqProcedures.Algebra +import PqProcedures.Procedures.RunStatement +import qualified PtrPeeker +import Prelude + +newtype GetTypeInfoByNameParams = GetTypeInfoByNameParams + { name :: Text + } + +data GetTypeInfoByNameResult = GetTypeInfoByNameResult + { baseOid :: Maybe Word32, + arrayOid :: Maybe Word32 + } + +instance Procedure GetTypeInfoByNameParams GetTypeInfoByNameResult where + run connection GetTypeInfoByNameParams {name} = do + run + connection + RunStatementParams + { sql = + "SELECT t.oid AS base_oid, t.typarray AS array_oid\n\ + \FROM pg_type t\n\ + \WHERE t.typname = $1\n\ + \LIMIT 1", + params = + [ Just + ( 25, -- OID of TEXT + Text.Encoding.encodeUtf8 name, + Pq.Binary + ) + ], + resultFormat = Pq.Binary + } + >>= processPqResult + +processPqResult :: Pq.Result -> IO GetTypeInfoByNameResult +processPqResult result = do + baseOid <- readOid 0 0 + arrayOid <- readOid 0 1 + pure GetTypeInfoByNameResult {baseOid, arrayOid} + where + readOid x y = + Pq.getvalue result x y >>= \case + Nothing -> pure Nothing + Just bs -> + case PtrPeeker.runVariableOnByteString decoder bs of + Left _err -> fail ("Failed to read OID from database, data: " <> show bs) + Right value -> pure (Just value) + where + decoder = PtrPeeker.fixed PtrPeeker.beUnsignedInt4 diff --git a/src/integration-tests/PqProcedures/Procedures/RunRoundtripQuery.hs b/src/integration-tests/PqProcedures/Procedures/RunRoundtripQuery.hs new file mode 100644 --- /dev/null +++ b/src/integration-tests/PqProcedures/Procedures/RunRoundtripQuery.hs @@ -0,0 +1,44 @@ +module PqProcedures.Procedures.RunRoundtripQuery + ( RunRoundtripQueryParams (..), + RunRoundtripQueryResult, + ) +where + +import qualified Data.ByteString as ByteString +import Data.Maybe +import qualified Data.Text as Text +import Data.Word +import qualified Database.PostgreSQL.LibPQ as Pq +import PqProcedures.Algebra +import PqProcedures.Procedures.RunStatement +import Prelude + +data RunRoundtripQueryParams = RunRoundtripQueryParams + { paramOid :: Word32, + paramEncoding :: ByteString.ByteString, + paramFormat :: Pq.Format, + resultFormat :: Pq.Format, + typeSignature :: Maybe Text.Text + } + +type RunRoundtripQueryResult = ByteString.ByteString + +instance Procedure RunRoundtripQueryParams RunRoundtripQueryResult where + run connection (RunRoundtripQueryParams {..}) = do + let sql = case typeSignature of + Nothing -> "SELECT $1" + Just sig -> "SELECT $1::" <> sig + pqResult <- + run + connection + RunStatementParams + { sql = sql, + params = + [ Just (paramOid, paramEncoding, paramFormat) + ], + resultFormat = resultFormat + } + bytes <- Pq.getvalue pqResult 0 0 + case bytes of + Nothing -> fail "getvalue produced no bytes" + Just bytes -> pure bytes diff --git a/src/integration-tests/PqProcedures/Procedures/RunStatement.hs b/src/integration-tests/PqProcedures/Procedures/RunStatement.hs new file mode 100644 --- /dev/null +++ b/src/integration-tests/PqProcedures/Procedures/RunStatement.hs @@ -0,0 +1,54 @@ +module PqProcedures.Procedures.RunStatement + ( RunStatementParams (..), + RunStatementResult, + ) +where + +import qualified Data.ByteString as ByteString +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import Data.Word +import qualified Database.PostgreSQL.LibPQ as Pq +import PqProcedures.Algebra +import Prelude + +data RunStatementParams = RunStatementParams + { sql :: Text.Text, + -- | Params + params :: + [ Maybe + ( Word32, + ByteString.ByteString, + Pq.Format + ) + ], + -- | Result format. + resultFormat :: Pq.Format + } + +type RunStatementResult = Pq.Result + +instance Procedure RunStatementParams RunStatementResult where + run connection (RunStatementParams sql params resultFormat) = do + result <- + Pq.execParams + connection + (Text.Encoding.encodeUtf8 sql) + (fmap (fmap (\(oid, encoding, format) -> (Pq.Oid (fromIntegral oid), encoding, format))) params) + resultFormat + result <- case result of + Nothing -> do + m <- Pq.errorMessage connection + failWithSql "No result" (maybe "" Text.Encoding.decodeUtf8 m) + Just result -> pure result + resultErrorField <- Pq.resultErrorField result Pq.DiagMessagePrimary + case resultErrorField of + Nothing -> pure () + Just err -> failWithSql "Error field present" (Text.Encoding.decodeUtf8 err) + pure result + where + failWithSql :: Text -> Text -> IO a + failWithSql msg reason = + fail (Text.unpack (msg <> "\nDue to:\n\t\t" <> reason <> "\nQuery:\n\t\t" <> sql)) diff --git a/src/library/PostgresqlTypes/Bytea.hs b/src/library/PostgresqlTypes/Bytea.hs --- a/src/library/PostgresqlTypes/Bytea.hs +++ b/src/library/PostgresqlTypes/Bytea.hs @@ -23,8 +23,12 @@ -- -- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-binary.html). newtype Bytea = Bytea ByteString - deriving newtype (Eq, Ord, Hashable, Arbitrary) + deriving newtype (Eq, Ord, Hashable) deriving (Show, Read, IsString) via (ViaIsScalar Bytea) + +instance Arbitrary Bytea where + arbitrary = Bytea . ByteString.pack <$> arbitrary + shrink (Bytea bytes) = Bytea . ByteString.pack <$> shrink (ByteString.unpack bytes) instance IsScalar Bytea where schemaName = Tagged Nothing diff --git a/src/library/PostgresqlTypes/Hstore.hs b/src/library/PostgresqlTypes/Hstore.hs --- a/src/library/PostgresqlTypes/Hstore.hs +++ b/src/library/PostgresqlTypes/Hstore.hs @@ -38,7 +38,24 @@ arbitrary = do -- Generate a list of key-value pairs pairs <- QuickCheck.listOf do - key <- Text.pack <$> QuickCheck.listOf1 (QuickCheck.suchThat arbitrary (\c -> c /= '\NUL' && c /= '=' && c /= '>' && c /= '"' && c /= '\\' && c /= ' ' && c /= ',' && c /= '\n' && c /= '\r' && c /= '\t')) + key <- + Text.pack + <$> QuickCheck.listOf1 + ( QuickCheck.suchThat + arbitrary + ( \c -> + c /= '\NUL' + && c /= '=' + && c /= '>' + && c /= '"' + && c /= '\\' + && c /= ' ' + && c /= ',' + && c /= '\n' + && c /= '\r' + && c /= '\t' + ) + ) value <- QuickCheck.oneof [ pure Nothing, @@ -46,8 +63,19 @@ ] pure (key, value) pure (Hstore (Map.fromList pairs)) - shrink (Hstore base) = - Hstore . Map.fromList <$> shrink (Map.toList base) + shrink = + QuickCheck.shrinkMapBy + (Hstore . Map.fromList) + (Map.toList . coerce) + ( QuickCheck.shrinkList + ( \(key, value) -> do + shrunkenKey <- QuickCheck.shrinkMap Text.pack Text.unpack key + shrunkenValue <- case value of + Nothing -> [Nothing] + Just v -> Just <$> QuickCheck.shrinkMap Text.pack Text.unpack v + pure (shrunkenKey, shrunkenValue) + ) + ) instance IsScalar Hstore where schemaName = Tagged Nothing diff --git a/src/library/PostgresqlTypes/Multirange.hs b/src/library/PostgresqlTypes/Multirange.hs --- a/src/library/PostgresqlTypes/Multirange.hs +++ b/src/library/PostgresqlTypes/Multirange.hs @@ -11,11 +11,11 @@ ) where -import qualified BaseExtras.List import qualified Data.Attoparsec.Text as Attoparsec import qualified Data.Set as Set import qualified Data.Vector as Vector import PostgresqlTypes.Algebra +import qualified PostgresqlTypes.Multirange.List import PostgresqlTypes.Prelude import PostgresqlTypes.Range (Range) import qualified PostgresqlTypes.Range as Range @@ -116,7 +116,7 @@ if upperInfinity then [Nothing] else [] ] pairs = - BaseExtras.List.toPairs preparedBounds + PostgresqlTypes.Multirange.List.toPairs preparedBounds ranges = fmap (uncurry Range.normalizeBounded) pairs :: [Range a] diff --git a/src/library/PostgresqlTypes/Multirange/List.hs b/src/library/PostgresqlTypes/Multirange/List.hs new file mode 100644 --- /dev/null +++ b/src/library/PostgresqlTypes/Multirange/List.hs @@ -0,0 +1,6 @@ +module PostgresqlTypes.Multirange.List where + +toPairs :: [a] -> [(a, a)] +toPairs [] = [] +toPairs [_] = [] +toPairs (x : y : xs) = (x, y) : toPairs xs diff --git a/src/library/PostgresqlTypes/Numeric.hs b/src/library/PostgresqlTypes/Numeric.hs --- a/src/library/PostgresqlTypes/Numeric.hs +++ b/src/library/PostgresqlTypes/Numeric.hs @@ -67,7 +67,7 @@ [ (1, pure NanNumeric), (1, pure NegInfinityNumeric), (1, pure PosInfinityNumeric), - (47, ScientificNumeric . Scientific.normalize <$> arbitrary) + (47, ScientificNumeric <$> (Scientific.scientific <$> arbitrary <*> arbitrary)) ] else if sc > prec diff --git a/src/library/PostgresqlTypes/Path.hs b/src/library/PostgresqlTypes/Path.hs --- a/src/library/PostgresqlTypes/Path.hs +++ b/src/library/PostgresqlTypes/Path.hs @@ -46,9 +46,10 @@ points <- UnboxedVector.replicateM numPoints arbitrary pure (Path closed points) shrink (Path closed points) = - [ Path closed' points' - | (closed', points') <- shrink (closed, points), - UnboxedVector.length points' >= 1 + [ Path closed' points'' + | (closed', points') <- shrink (closed, UnboxedVector.toList points), + let points'' = UnboxedVector.fromList points', + UnboxedVector.length points'' >= 1 ] instance Hashable Path where diff --git a/src/library/PostgresqlTypes/Polygon.hs b/src/library/PostgresqlTypes/Polygon.hs --- a/src/library/PostgresqlTypes/Polygon.hs +++ b/src/library/PostgresqlTypes/Polygon.hs @@ -42,7 +42,12 @@ points <- UnboxedVector.fromList <$> QuickCheck.vectorOf numPoints arbitrary pure (Polygon points) - shrink (Polygon points) = [Polygon points' | points' <- shrink points, UnboxedVector.length points' >= 3] + shrink (Polygon points) = + [ Polygon points'' + | points' <- shrink (UnboxedVector.toList points), + let points'' = UnboxedVector.fromList points', + UnboxedVector.length points'' >= 3 + ] instance Hashable Polygon where hashWithSalt salt (Polygon points) = diff --git a/src/library/PostgresqlTypes/Prelude.hs b/src/library/PostgresqlTypes/Prelude.hs --- a/src/library/PostgresqlTypes/Prelude.hs +++ b/src/library/PostgresqlTypes/Prelude.hs @@ -77,7 +77,6 @@ import System.Mem.StableName as Exports import System.Timeout as Exports import Test.QuickCheck as Exports (Arbitrary (..), Property, Testable (..)) -import Test.QuickCheck.Instances () import Text.Printf as Exports (hPrintf, printf) import Text.Read as Exports (Read (..), readEither, readMaybe) import TextBuilder as Exports (TextBuilder) diff --git a/src/library/PostgresqlTypes/Uuid.hs b/src/library/PostgresqlTypes/Uuid.hs --- a/src/library/PostgresqlTypes/Uuid.hs +++ b/src/library/PostgresqlTypes/Uuid.hs @@ -24,8 +24,16 @@ -- -- [PostgreSQL docs](https://www.postgresql.org/docs/18/datatype-uuid.html). newtype Uuid = Uuid Data.UUID.UUID - deriving newtype (Eq, Ord, Hashable, Arbitrary) + deriving newtype (Eq, Ord, Hashable) deriving (Show, Read, IsString) via (ViaIsScalar Uuid) + +instance Arbitrary Uuid where + arbitrary = Uuid <$> (Data.UUID.fromWords64 <$> arbitrary <*> arbitrary) + shrink (Uuid uuid) = + [ Uuid (Data.UUID.fromWords64 w1 w2) + | let (w1, w2) = Data.UUID.toWords64 uuid, + (w1, w2) <- shrink (w1, w2) + ] instance IsScalar Uuid where schemaName = Tagged Nothing diff --git a/src/pq-procedures/PqProcedures.hs b/src/pq-procedures/PqProcedures.hs deleted file mode 100644 --- a/src/pq-procedures/PqProcedures.hs +++ /dev/null @@ -1,8 +0,0 @@ -module PqProcedures - ( module PqProcedures.Procedures, - module PqProcedures.Algebra, - ) -where - -import PqProcedures.Algebra -import PqProcedures.Procedures diff --git a/src/pq-procedures/PqProcedures/Algebra.hs b/src/pq-procedures/PqProcedures/Algebra.hs deleted file mode 100644 --- a/src/pq-procedures/PqProcedures/Algebra.hs +++ /dev/null @@ -1,7 +0,0 @@ -module PqProcedures.Algebra where - -import qualified Database.PostgreSQL.LibPQ as Pq -import Prelude - -class Procedure params result | params -> result where - run :: Pq.Connection -> params -> IO result diff --git a/src/pq-procedures/PqProcedures/Procedures.hs b/src/pq-procedures/PqProcedures/Procedures.hs deleted file mode 100644 --- a/src/pq-procedures/PqProcedures/Procedures.hs +++ /dev/null @@ -1,10 +0,0 @@ -module PqProcedures.Procedures - ( module PqProcedures.Procedures.GetTypeInfoByName, - module PqProcedures.Procedures.RunRoundtripQuery, - module PqProcedures.Procedures.RunStatement, - ) -where - -import PqProcedures.Procedures.GetTypeInfoByName -import PqProcedures.Procedures.RunRoundtripQuery -import PqProcedures.Procedures.RunStatement diff --git a/src/pq-procedures/PqProcedures/Procedures/GetTypeInfoByName.hs b/src/pq-procedures/PqProcedures/Procedures/GetTypeInfoByName.hs deleted file mode 100644 --- a/src/pq-procedures/PqProcedures/Procedures/GetTypeInfoByName.hs +++ /dev/null @@ -1,61 +0,0 @@ -module PqProcedures.Procedures.GetTypeInfoByName - ( GetTypeInfoByNameParams (..), - GetTypeInfoByNameResult (..), - ) -where - -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text.Encoding as Text.Encoding -import Data.Word -import qualified Database.PostgreSQL.LibPQ as Pq -import PqProcedures.Algebra -import PqProcedures.Procedures.RunStatement -import qualified PtrPeeker -import Prelude - -newtype GetTypeInfoByNameParams = GetTypeInfoByNameParams - { name :: Text - } - -data GetTypeInfoByNameResult = GetTypeInfoByNameResult - { baseOid :: Maybe Word32, - arrayOid :: Maybe Word32 - } - -instance Procedure GetTypeInfoByNameParams GetTypeInfoByNameResult where - run connection GetTypeInfoByNameParams {name} = do - run - connection - RunStatementParams - { sql = - "SELECT t.oid AS base_oid, t.typarray AS array_oid\n\ - \FROM pg_type t\n\ - \WHERE t.typname = $1\n\ - \LIMIT 1", - params = - [ Just - ( 25, -- OID of TEXT - Text.Encoding.encodeUtf8 name, - Pq.Binary - ) - ], - resultFormat = Pq.Binary - } - >>= processPqResult - -processPqResult :: Pq.Result -> IO GetTypeInfoByNameResult -processPqResult result = do - baseOid <- readOid 0 0 - arrayOid <- readOid 0 1 - pure GetTypeInfoByNameResult {baseOid, arrayOid} - where - readOid x y = - Pq.getvalue result x y >>= \case - Nothing -> pure Nothing - Just bs -> - case PtrPeeker.runVariableOnByteString decoder bs of - Left _err -> fail ("Failed to read OID from database, data: " <> show bs) - Right value -> pure (Just value) - where - decoder = PtrPeeker.fixed PtrPeeker.beUnsignedInt4 diff --git a/src/pq-procedures/PqProcedures/Procedures/RunRoundtripQuery.hs b/src/pq-procedures/PqProcedures/Procedures/RunRoundtripQuery.hs deleted file mode 100644 --- a/src/pq-procedures/PqProcedures/Procedures/RunRoundtripQuery.hs +++ /dev/null @@ -1,44 +0,0 @@ -module PqProcedures.Procedures.RunRoundtripQuery - ( RunRoundtripQueryParams (..), - RunRoundtripQueryResult, - ) -where - -import qualified Data.ByteString as ByteString -import Data.Maybe -import qualified Data.Text as Text -import Data.Word -import qualified Database.PostgreSQL.LibPQ as Pq -import PqProcedures.Algebra -import PqProcedures.Procedures.RunStatement -import Prelude - -data RunRoundtripQueryParams = RunRoundtripQueryParams - { paramOid :: Word32, - paramEncoding :: ByteString.ByteString, - paramFormat :: Pq.Format, - resultFormat :: Pq.Format, - typeSignature :: Maybe Text.Text - } - -type RunRoundtripQueryResult = ByteString.ByteString - -instance Procedure RunRoundtripQueryParams RunRoundtripQueryResult where - run connection (RunRoundtripQueryParams {..}) = do - let sql = case typeSignature of - Nothing -> "SELECT $1" - Just sig -> "SELECT $1::" <> sig - pqResult <- - run - connection - RunStatementParams - { sql = sql, - params = - [ Just (paramOid, paramEncoding, paramFormat) - ], - resultFormat = resultFormat - } - bytes <- Pq.getvalue pqResult 0 0 - case bytes of - Nothing -> fail "getvalue produced no bytes" - Just bytes -> pure bytes diff --git a/src/pq-procedures/PqProcedures/Procedures/RunStatement.hs b/src/pq-procedures/PqProcedures/Procedures/RunStatement.hs deleted file mode 100644 --- a/src/pq-procedures/PqProcedures/Procedures/RunStatement.hs +++ /dev/null @@ -1,56 +0,0 @@ -module PqProcedures.Procedures.RunStatement - ( RunStatementParams (..), - RunStatementResult, - ) -where - -import qualified Data.ByteString as ByteString -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import Data.Word -import qualified Database.PostgreSQL.LibPQ as Pq -import PqProcedures.Algebra -import TextBuilder (TextBuilder) -import qualified TextBuilder -import Prelude - -data RunStatementParams = RunStatementParams - { sql :: Text.Text, - -- | Params - params :: - [ Maybe - ( Word32, - ByteString.ByteString, - Pq.Format - ) - ], - -- | Result format. - resultFormat :: Pq.Format - } - -type RunStatementResult = Pq.Result - -instance Procedure RunStatementParams RunStatementResult where - run connection (RunStatementParams sql params resultFormat) = do - result <- - Pq.execParams - connection - (Text.Encoding.encodeUtf8 sql) - (fmap (fmap (\(oid, encoding, format) -> (Pq.Oid (fromIntegral oid), encoding, format))) params) - resultFormat - result <- case result of - Nothing -> do - m <- Pq.errorMessage connection - failWithSql "No result" (maybe "" Text.Encoding.decodeUtf8 m) - Just result -> pure result - resultErrorField <- Pq.resultErrorField result Pq.DiagMessagePrimary - case resultErrorField of - Nothing -> pure () - Just err -> failWithSql "Error field present" (Text.Encoding.decodeUtf8 err) - pure result - where - failWithSql :: Text -> Text -> IO a - failWithSql msg reason = - fail (Text.unpack (msg <> "\nDue to:\n\t\t" <> reason <> "\nQuery:\n\t\t" <> sql)) diff --git a/src/unit-tests/PostgresqlTypes/BpcharSpec.hs b/src/unit-tests/PostgresqlTypes/BpcharSpec.hs --- a/src/unit-tests/PostgresqlTypes/BpcharSpec.hs +++ b/src/unit-tests/PostgresqlTypes/BpcharSpec.hs @@ -6,6 +6,7 @@ import qualified PostgresqlTypes.Bpchar as Bpchar import Test.Hspec import Test.QuickCheck +import Test.QuickCheck.Instances () import qualified UnitTests.Scripts as Scripts import Prelude diff --git a/src/unit-tests/PostgresqlTypes/ByteaSpec.hs b/src/unit-tests/PostgresqlTypes/ByteaSpec.hs --- a/src/unit-tests/PostgresqlTypes/ByteaSpec.hs +++ b/src/unit-tests/PostgresqlTypes/ByteaSpec.hs @@ -5,6 +5,7 @@ import qualified PostgresqlTypes.Bytea as Bytea import Test.Hspec import Test.QuickCheck +import Test.QuickCheck.Instances () import qualified UnitTests.Scripts as Scripts spec :: Spec diff --git a/src/unit-tests/PostgresqlTypes/DateSpec.hs b/src/unit-tests/PostgresqlTypes/DateSpec.hs --- a/src/unit-tests/PostgresqlTypes/DateSpec.hs +++ b/src/unit-tests/PostgresqlTypes/DateSpec.hs @@ -6,6 +6,7 @@ import qualified PostgresqlTypes.Date as Date import Test.Hspec import Test.QuickCheck +import Test.QuickCheck.Instances () import qualified UnitTests.Scripts as Scripts import Prelude diff --git a/src/unit-tests/PostgresqlTypes/NumericSpec.hs b/src/unit-tests/PostgresqlTypes/NumericSpec.hs --- a/src/unit-tests/PostgresqlTypes/NumericSpec.hs +++ b/src/unit-tests/PostgresqlTypes/NumericSpec.hs @@ -9,6 +9,7 @@ import Test.Hspec import Test.QuickCheck import qualified Test.QuickCheck as QuickCheck +import Test.QuickCheck.Instances () import qualified UnitTests.Scripts as Scripts import Prelude diff --git a/src/unit-tests/PostgresqlTypes/TextSpec.hs b/src/unit-tests/PostgresqlTypes/TextSpec.hs --- a/src/unit-tests/PostgresqlTypes/TextSpec.hs +++ b/src/unit-tests/PostgresqlTypes/TextSpec.hs @@ -6,6 +6,7 @@ import qualified PostgresqlTypes.Text as PgText import Test.Hspec import Test.QuickCheck +import Test.QuickCheck.Instances () import qualified UnitTests.Scripts as Scripts import Prelude diff --git a/src/unit-tests/PostgresqlTypes/TimeSpec.hs b/src/unit-tests/PostgresqlTypes/TimeSpec.hs --- a/src/unit-tests/PostgresqlTypes/TimeSpec.hs +++ b/src/unit-tests/PostgresqlTypes/TimeSpec.hs @@ -6,6 +6,7 @@ import qualified PostgresqlTypes.Time as PgTime import Test.Hspec import Test.QuickCheck +import Test.QuickCheck.Instances () import qualified UnitTests.Scripts as Scripts import Prelude diff --git a/src/unit-tests/PostgresqlTypes/UuidSpec.hs b/src/unit-tests/PostgresqlTypes/UuidSpec.hs --- a/src/unit-tests/PostgresqlTypes/UuidSpec.hs +++ b/src/unit-tests/PostgresqlTypes/UuidSpec.hs @@ -5,6 +5,7 @@ import qualified PostgresqlTypes.Uuid as Uuid import Test.Hspec import Test.QuickCheck +import Test.QuickCheck.Instances () import qualified UnitTests.Scripts as Scripts spec :: Spec diff --git a/src/unit-tests/PostgresqlTypes/VarcharSpec.hs b/src/unit-tests/PostgresqlTypes/VarcharSpec.hs --- a/src/unit-tests/PostgresqlTypes/VarcharSpec.hs +++ b/src/unit-tests/PostgresqlTypes/VarcharSpec.hs @@ -6,6 +6,7 @@ import qualified PostgresqlTypes.Varchar as Varchar import Test.Hspec import Test.QuickCheck +import Test.QuickCheck.Instances () import qualified UnitTests.Scripts as Scripts import Prelude