postgresql-types 0.1 → 0.1.1
raw patch · 36 files changed
+636/−607 lines, 36 filesdep ~postgresql-types-algebra
Dependency ranges changed: postgresql-types-algebra
Files
- postgresql-types.cabal +13/−35
- src/base-extras/BaseExtras/List.hs +0/−6
- src/integration-tests/IntegrationTests/Scopes.hs +144/−0
- src/integration-tests/IntegrationTests/Scripts.hs +221/−0
- src/integration-tests/Main.hs +2/−2
- src/integration-tests/Main/Scopes.hs +0/−144
- src/integration-tests/Main/Scripts.hs +0/−221
- src/integration-tests/PqProcedures.hs +8/−0
- src/integration-tests/PqProcedures/Algebra.hs +7/−0
- src/integration-tests/PqProcedures/Procedures.hs +10/−0
- src/integration-tests/PqProcedures/Procedures/GetTypeInfoByName.hs +61/−0
- src/integration-tests/PqProcedures/Procedures/RunRoundtripQuery.hs +44/−0
- src/integration-tests/PqProcedures/Procedures/RunStatement.hs +54/−0
- src/library/PostgresqlTypes/Bytea.hs +5/−1
- src/library/PostgresqlTypes/Hstore.hs +31/−3
- src/library/PostgresqlTypes/Multirange.hs +2/−2
- src/library/PostgresqlTypes/Multirange/List.hs +6/−0
- src/library/PostgresqlTypes/Numeric.hs +1/−1
- src/library/PostgresqlTypes/Path.hs +4/−3
- src/library/PostgresqlTypes/Polygon.hs +6/−1
- src/library/PostgresqlTypes/Prelude.hs +0/−1
- src/library/PostgresqlTypes/Uuid.hs +9/−1
- src/pq-procedures/PqProcedures.hs +0/−8
- src/pq-procedures/PqProcedures/Algebra.hs +0/−7
- src/pq-procedures/PqProcedures/Procedures.hs +0/−10
- src/pq-procedures/PqProcedures/Procedures/GetTypeInfoByName.hs +0/−61
- src/pq-procedures/PqProcedures/Procedures/RunRoundtripQuery.hs +0/−44
- src/pq-procedures/PqProcedures/Procedures/RunStatement.hs +0/−56
- src/unit-tests/PostgresqlTypes/BpcharSpec.hs +1/−0
- src/unit-tests/PostgresqlTypes/ByteaSpec.hs +1/−0
- src/unit-tests/PostgresqlTypes/DateSpec.hs +1/−0
- src/unit-tests/PostgresqlTypes/NumericSpec.hs +1/−0
- src/unit-tests/PostgresqlTypes/TextSpec.hs +1/−0
- src/unit-tests/PostgresqlTypes/TimeSpec.hs +1/−0
- src/unit-tests/PostgresqlTypes/UuidSpec.hs +1/−0
- src/unit-tests/PostgresqlTypes/VarcharSpec.hs +1/−0
postgresql-types.cabal view
@@ -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,
− src/base-extras/BaseExtras/List.hs
@@ -1,6 +0,0 @@-module BaseExtras.List where--toPairs :: [a] -> [(a, a)]-toPairs [] = []-toPairs [_] = []-toPairs (x : y : xs) = (x, y) : toPairs xs
+ src/integration-tests/IntegrationTests/Scopes.hs view
@@ -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
+ src/integration-tests/IntegrationTests/Scripts.hs view
@@ -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
src/integration-tests/Main.hs view
@@ -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 ()
− src/integration-tests/Main/Scopes.hs
@@ -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
− src/integration-tests/Main/Scripts.hs
@@ -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
+ src/integration-tests/PqProcedures.hs view
@@ -0,0 +1,8 @@+module PqProcedures+ ( module PqProcedures.Procedures,+ module PqProcedures.Algebra,+ )+where++import PqProcedures.Algebra+import PqProcedures.Procedures
+ src/integration-tests/PqProcedures/Algebra.hs view
@@ -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
+ src/integration-tests/PqProcedures/Procedures.hs view
@@ -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
+ src/integration-tests/PqProcedures/Procedures/GetTypeInfoByName.hs view
@@ -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
+ src/integration-tests/PqProcedures/Procedures/RunRoundtripQuery.hs view
@@ -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
+ src/integration-tests/PqProcedures/Procedures/RunStatement.hs view
@@ -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))
src/library/PostgresqlTypes/Bytea.hs view
@@ -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
src/library/PostgresqlTypes/Hstore.hs view
@@ -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
src/library/PostgresqlTypes/Multirange.hs view
@@ -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]
+ src/library/PostgresqlTypes/Multirange/List.hs view
@@ -0,0 +1,6 @@+module PostgresqlTypes.Multirange.List where++toPairs :: [a] -> [(a, a)]+toPairs [] = []+toPairs [_] = []+toPairs (x : y : xs) = (x, y) : toPairs xs
src/library/PostgresqlTypes/Numeric.hs view
@@ -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
src/library/PostgresqlTypes/Path.hs view
@@ -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
src/library/PostgresqlTypes/Polygon.hs view
@@ -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) =
src/library/PostgresqlTypes/Prelude.hs view
@@ -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)
src/library/PostgresqlTypes/Uuid.hs view
@@ -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
− src/pq-procedures/PqProcedures.hs
@@ -1,8 +0,0 @@-module PqProcedures- ( module PqProcedures.Procedures,- module PqProcedures.Algebra,- )-where--import PqProcedures.Algebra-import PqProcedures.Procedures
− src/pq-procedures/PqProcedures/Algebra.hs
@@ -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
− src/pq-procedures/PqProcedures/Procedures.hs
@@ -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
− src/pq-procedures/PqProcedures/Procedures/GetTypeInfoByName.hs
@@ -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
− src/pq-procedures/PqProcedures/Procedures/RunRoundtripQuery.hs
@@ -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
− src/pq-procedures/PqProcedures/Procedures/RunStatement.hs
@@ -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))
src/unit-tests/PostgresqlTypes/BpcharSpec.hs view
@@ -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
src/unit-tests/PostgresqlTypes/ByteaSpec.hs view
@@ -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
src/unit-tests/PostgresqlTypes/DateSpec.hs view
@@ -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
src/unit-tests/PostgresqlTypes/NumericSpec.hs view
@@ -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
src/unit-tests/PostgresqlTypes/TextSpec.hs view
@@ -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
src/unit-tests/PostgresqlTypes/TimeSpec.hs view
@@ -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
src/unit-tests/PostgresqlTypes/UuidSpec.hs view
@@ -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
src/unit-tests/PostgresqlTypes/VarcharSpec.hs view
@@ -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