diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2026, Nikita Volkov + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,89 @@ +# pqi + +[![Hackage](https://img.shields.io/hackage/v/pqi.svg)](https://hackage.haskell.org/package/pqi) +[![Continuous Haddock](https://img.shields.io/badge/haddock-master-blue)](https://nikita-volkov.github.io/pqi/) + +A driver-agnostic interface to the PostgreSQL [libpq][libpq] API. + +## Ecosystem + +| Package | Description | +|---------|-------------| +| **[pqi](https://github.com/nikita-volkov/pqi)** *(this)* | The interface: `IsConnection` class, shared types, and connection-independent helpers | +| [pqi-ffi](https://github.com/nikita-volkov/pqi-ffi) | FFI adapter backed by `postgresql-libpq` and the C `libpq` library. Battle-tested, production-safe | +| [pqi-native](https://github.com/nikita-volkov/pqi-native) | Pure-Haskell adapter speaking the PostgreSQL wire protocol directly. No C dependency. Experimental | +| [pqi-conformance](https://github.com/nikita-volkov/pqi-conformance) | Reusable `hspec` conformance suite that differentially tests any adapter against `postgresql-libpq` | + +## Motivation + +Every major Haskell PostgreSQL driver today depends on +[`postgresql-libpq`][postgresql-libpq], a binding to the C `libpq` library. +This means every user of every driver needs `libpq` installed — on their +development machine, in CI, in production containers, on cross-compilation +targets. There is no way to opt out. + +`pqi` solves this by separating the interface from the implementation. It +defines a driver-agnostic type class (`IsConnection`) that mirrors the `libpq` +API surface, then ships two adapters: + +- [`pqi-ffi`](https://github.com/nikita-volkov/pqi-ffi) — a thin wrapper + around `postgresql-libpq`. Battle-tested, production-safe. The default + choice. +- [`pqi-native`](https://github.com/nikita-volkov/pqi-native) — a pure-Haskell + implementation of the PostgreSQL wire protocol, generated with LLM + assistance. **Experimental.** It produces byte-identical output to `postgresql-libpq` + for all protocol-derived values (verified by differential testing), but it + has not yet been exercised in production at scale. If you adopt it, we want + to hear from you. + +A driver built against `pqi` gives its users transport choice without any +changes to the driver itself. The user picks an adapter at connection time: + +```haskell +-- C-backed (safe, requires libpq) +connection <- connect (Proxy @Pqi.Ffi.Connection) settings + +-- Pure Haskell (experimental, no C dependency) +connection <- connect (Proxy @Pqi.Native.Connection) settings +``` + +## Testing model + +`pqi` comes accompanied by a comprehensive conformance suite isolated into an implementation-agnostic `pqi-conformance` package that covers various edge-cases and error conditions and covers most operations with a precondition that they must behave in exactly the same way that `postgresql-libpq` does. + +## Interface + +`pqi` reproduces the API surface of the [`postgresql-libpq`][postgresql-libpq] +package, but reifies the connection — and the results it produces — as a type +class instead of a single concrete type. Code written against this interface +runs unchanged on any adapter: + +- [`pqi-ffi`](https://github.com/nikita-volkov/pqi-ffi) — a thin + adapter backed by the C `libpq` library via `postgresql-libpq`. +- [`pqi-native`](https://github.com/nikita-volkov/pqi-native) — a + pure-Haskell adapter that speaks the PostgreSQL wire protocol directly. + +The interface mirrors `libpq` in semantics, not just shape: every compliant +adapter must produce byte-identical output to `libpq` for all protocol-derived +values. This contract is enforced by +[`pqi-conformance`](https://github.com/nikita-volkov/pqi-conformance), which +runs every operation differentially against [`postgresql-libpq`][postgresql-libpq] and asserts equality. + +This package ships only the interface: the `IsConnection` class, the associated +`ResultOf` result type family, the shared type vocabulary (statuses, field +codes, formats, OIDs), and the connection-independent helpers. + +## Relationship to `postgresql-libpq` + +The function names, argument order, and semantics mirror +`Database.PostgreSQL.LibPQ`. The deliberate departures are: + +- `Connection` and `Result` become the class parameter `c` and the associated + type family `ResultOf c`. +- OIDs are a plain `Word32` and row/column/parameter indices are a plain + `Int32`, instead of the C-specific newtypes of the original. +- There's no `invalidOid` constant. It's just `0`. +- Ambiguous, rarely-useful helpers (e.g. `resStatus`) are omitted. + +[libpq]: https://www.postgresql.org/docs/current/libpq.html +[postgresql-libpq]: https://hackage.haskell.org/package/postgresql-libpq diff --git a/pqi.cabal b/pqi.cabal new file mode 100644 --- /dev/null +++ b/pqi.cabal @@ -0,0 +1,119 @@ +cabal-version: 3.0 +name: pqi +version: 0.0.1.0 +category: Database, PostgreSQL +synopsis: Driver-agnostic interface to the PostgreSQL libpq API +description: + @pqi@ reproduces the API surface of the @postgresql-libpq@ package, but + reifies the connection (and its results) as a type class instead of a single + concrete type. This lets callers program against one interface and pick an + adapter at the type level: + + * @pqi-ffi@ — a thin adapter backed by the C @libpq@ library via + @postgresql-libpq@. + + * @pqi-native@ — a pure-Haskell adapter that speaks the PostgreSQL wire + protocol directly. + + This package ships only the interface: the typeclasses, types and a couple of connection-independent helpers. + +homepage: https://github.com/nikita-volkov/pqi +bug-reports: https://github.com/nikita-volkov/pqi/issues +author: Nikita Volkov +maintainer: Nikita Volkov +copyright: (c) 2026, Nikita Volkov +license: MIT +license-file: LICENSE +extra-doc-files: + CHANGELOG.md + LICENSE + README.md + +source-repository head + type: git + location: https://github.com/nikita-volkov/pqi + +common base + default-language: Haskell2010 + default-extensions: + ApplicativeDo + BangPatterns + BinaryLiterals + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveTraversable + DerivingStrategies + DerivingVia + DuplicateRecordFields + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + LiberalTypeSynonyms + MagicHash + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoFieldSelectors + NoImplicitPrelude + NoMonomorphismRestriction + NumericUnderscores + OverloadedRecordDot + OverloadedStrings + ParallelListComp + PatternGuards + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + StrictData + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UnboxedTuples + ViewPatterns + +common test + import: base + ghc-options: + -threaded + -with-rtsopts=-N + +library + import: base + hs-source-dirs: src/library + exposed-modules: + Pqi + + other-modules: + Pqi.UnescapeBytea + + build-depends: + base >=4.11 && <5, + bytestring >=0.10 && <0.13, + ptr-peeker >=0.2 && <0.3, + ptr-poker >=0.1 && <0.2, + +test-suite pqi-test + import: test + type: exitcode-stdio-1.0 + hs-source-dirs: src/test + main-is: Spec.hs + build-depends: + base >=4.11 && <5, + bytestring >=0.10 && <0.13, + hspec >=2.11 && <2.12, + postgresql-libpq >=0.11 && <0.12, + pqi, + QuickCheck >=2.14 && <3, diff --git a/src/library/Pqi.hs b/src/library/Pqi.hs new file mode 100644 --- /dev/null +++ b/src/library/Pqi.hs @@ -0,0 +1,569 @@ +-- | A driver-agnostic reproduction of the [@postgresql-libpq@](https://hackage.haskell.org/package/postgresql-libpq) API (version +-- @0.11@, the pipelining-capable release). +-- +-- The connection is reified as a single class @'IsConnection' c@ parameterised +-- over the connection type. Result accessors live in the independent +-- @'IsResult' r@ class, and cancellation handles in @'IsCancel' k@. +-- @'IsResult' ('ResultOf' c)@ and @'IsCancel' ('CancelOf' c)@ are superclass +-- constraints of @'IsConnection' c@, so callers who have access to a connection +-- get result inspection and cancellation automatically. +-- +-- Function names, argument order, and semantics mirror the API of the C library binding +-- @postgresql-libpq@. +-- The only deliberate departures are: +-- +-- * @Connection@, @Result@, and @Cancel@ become the class parameter @c@ and the +-- associated types @'ResultOf' c@ \/ @'CancelOf' c@. +-- +-- * OIDs are a plain 'Word32' and row\/column\/parameter indices and LoFds are a +-- plain 'Int32', rather than the C-specific newtypes of the original. +-- +-- * Ambiguous, rarely-useful helpers (e.g. @resStatus@) are omitted, +-- @libpqVersion@ is omitted too. +-- +-- * There's no @invalidOid@ constant. It's just 0. +-- +-- * The 'unescapeBytea' helper is bundled in this library and implemented natively without IO. +module Pqi + ( -- * Type classes + IsConnection (..), + IsResult (..), + IsCancel (..), + + -- * Shared types + Format (..), + ExecStatus (..), + ConnStatus (..), + TransactionStatus (..), + PollingStatus (..), + PipelineStatus (..), + FieldCode (..), + Verbosity (..), + FlushStatus (..), + CopyInResult (..), + CopyOutResult (..), + Notify (..), + + -- * Connection-independent helpers + unescapeBytea, + ) +where + +import Data.Bool +import Data.ByteString (ByteString) +import Data.Either +import Data.Eq +import Data.Int +import Data.Kind (Type) +import Data.Maybe +import Data.Ord +import Data.Word +import Pqi.UnescapeBytea (unescapeBytea) +import System.IO (FilePath, IO, IOMode, SeekMode) +import System.Posix.Types (Fd) +import Text.Show +import Prelude (Bounded, Enum) + +-- * Shared types + +-- | Format of a parameter or result column: textual or binary. +data Format + = Text + | Binary + deriving stock (Eq, Ord, Show, Enum, Bounded) + +-- | Status of a command result, as reported by @PQresultStatus@. +data ExecStatus + = -- | The string sent to the server was empty. + EmptyQuery + | -- | Successful completion of a command returning no data. + CommandOk + | -- | Successful completion of a command returning data (such as a + -- @SELECT@ or @SHOW@). + TuplesOk + | -- | Copy Out (from server) data transfer started. + CopyOut + | -- | Copy In (to server) data transfer started. + CopyIn + | -- | Copy In\/Out data transfer started. + CopyBoth + | -- | The server's response was not understood. + BadResponse + | -- | A nonfatal error (a notice or warning) occurred. + NonfatalError + | -- | A fatal error occurred. + FatalError + | -- | The @'ResultOf'@ contains a single result tuple from the current command. + -- This status occurs only when single-row mode has been selected for the + -- query. + SingleTuple + | -- | The @'ResultOf'@ represents a synchronization point in pipeline mode, + -- requested by @'pipelineSync'@. This status occurs only in pipeline mode. + PipelineSync + | -- | The @'ResultOf'@ represents a pipeline that has received an error from + -- the server. @'getResult'@ must be called repeatedly, and each time it will + -- return this status code until the end of the current pipeline, at which + -- point it will return @'PipelineSync'@ and normal processing can resume. + PipelineAbort + deriving stock (Eq, Ord, Show, Enum, Bounded) + +-- | Status of a connection, as reported by @PQstatus@. +data ConnStatus + = -- | The connection is ready. + ConnectionOk + | -- | The connection procedure has failed. + ConnectionBad + | -- | Waiting for connection to be made. + ConnectionStarted + | -- | Connection OK; waiting to send. + ConnectionMade + | -- | Waiting for a response from the server. + ConnectionAwaitingResponse + | -- | Received authentication; waiting for backend start-up to finish. + ConnectionAuthOk + | -- | Negotiating environment-driven parameter settings. + ConnectionSetEnv + | -- | Negotiating SSL encryption. + ConnectionSSLStartup + deriving stock (Eq, Ord, Show, Enum, Bounded) + +-- | Current in-transaction status of the server, as reported by +-- @PQtransactionStatus@. +data TransactionStatus + = -- | Currently idle. + TransIdle + | -- | A command is in progress. + TransActive + | -- | Idle, within a transaction block. + TransInTrans + | -- | Idle, within a failed transaction. + TransInError + | -- | Connection is bad. + TransUnknown + deriving stock (Eq, Ord, Show, Enum, Bounded) + +-- | Result of a non-blocking connection-polling step. +data PollingStatus + = PollingFailed + | PollingReading + | PollingWriting + | PollingOk + deriving stock (Eq, Ord, Show, Enum, Bounded) + +-- | Pipeline-mode status of a connection, as reported by @PQpipelineStatus@. +data PipelineStatus + = -- | The connection is in pipeline mode. + PipelineOn + | -- | The connection is /not/ in pipeline mode. + PipelineOff + | -- | The connection is in pipeline mode and an error occurred while + -- processing the current pipeline. + PipelineAborted + deriving stock (Eq, Ord, Show, Enum, Bounded) + +-- | Field identifier for the structured fields of an error report, as accepted +-- by @PQresultErrorField@. +data FieldCode + = DiagSeverity + | DiagSqlstate + | DiagMessagePrimary + | DiagMessageDetail + | DiagMessageHint + | DiagStatementPosition + | DiagInternalPosition + | DiagInternalQuery + | DiagContext + | DiagSourceFile + | DiagSourceLine + | DiagSourceFunction + deriving stock (Eq, Ord, Show, Enum, Bounded) + +-- | Verbosity of error reporting, as set by @PQsetErrorVerbosity@. +data Verbosity + = ErrorsTerse + | ErrorsDefault + | ErrorsVerbose + deriving stock (Eq, Ord, Show, Enum, Bounded) + +-- | Result of attempting to flush the output buffer in non-blocking mode. +data FlushStatus + = FlushOk + | FlushFailed + | FlushWriting + deriving stock (Eq, Ord, Show, Enum, Bounded) + +-- | Result of @PQputCopyData@\/@PQputCopyEnd@. +data CopyInResult + = CopyInOk + | CopyInError + | CopyInWouldBlock + deriving stock (Eq, Ord, Show, Enum, Bounded) + +-- | Result of @PQgetCopyData@. +data CopyOutResult + = CopyOutRow ByteString + | CopyOutWouldBlock + | CopyOutDone + | CopyOutError + deriving stock (Eq, Ord, Show) + +-- | An asynchronous notification, as returned by 'notifies'. +data Notify = Notify + { relname :: ByteString, + bePid :: Int32, + extra :: ByteString + } + deriving stock (Eq, Ord, Show) + +-- * Result inspection + +-- | Result-accessor methods, independent of the connection type that produced +-- the result. This allows row decoders and projection functions (such as +-- 'observeResult' in @pqi-conformance@) to operate on any result type +-- without knowing the originating connection. +class IsResult r where + -- | The status of the result. + resultStatus :: r -> IO ExecStatus + + -- | The flat error message associated with the result, if any. Best-effort; + -- see the note on 'errorMessage'. + resultErrorMessage :: r -> IO (Maybe ByteString) + + -- | A single structured field of the result's error report. + resultErrorField :: r -> FieldCode -> IO (Maybe ByteString) + + -- | Free the result. Adapters that manage results with the garbage collector + -- may implement this as a no-op; for the C-backed adapter it frees the + -- underlying @PGresult@, after which the result must not be used. + unsafeFreeResult :: r -> IO () + + -- | Number of rows (tuples) in the result. + ntuples :: r -> IO Int32 + + -- | Number of columns (fields) in the result. + nfields :: r -> IO Int32 + + -- | Name of the column at the given index. + fname :: r -> Int32 -> IO (Maybe ByteString) + + -- | Index of the column with the given name, if present. + fnumber :: r -> ByteString -> IO (Maybe Int32) + + -- | OID of the table the given column was fetched from, or 0. + ftable :: r -> Int32 -> IO Word32 + + -- | Column number (within its table) that the given result column was + -- fetched from, or 0. + ftablecol :: r -> Int32 -> IO Int32 + + -- | Format (text or binary) of the given column. + fformat :: r -> Int32 -> IO Format + + -- | Data type OID of the given column. + ftype :: r -> Int32 -> IO Word32 + + -- | Type modifier of the given column. + fmod :: r -> Int32 -> IO Int + + -- | Server-side storage size of the given column's type, or a negative value + -- for variable size. + fsize :: r -> Int32 -> IO Int + + -- | Value at @(row, column)@, or @'Nothing'@ for SQL @NULL@. Delegates to + -- @'getvalue''@ by default in case the adapter provides a copying variant. + getvalue :: r -> Int32 -> Int32 -> IO (Maybe ByteString) + getvalue = getvalue' + + -- | Like 'getvalue', but always returns a copy that remains valid after the + -- result is freed. + getvalue' :: r -> Int32 -> Int32 -> IO (Maybe ByteString) + + -- | Whether the value at @(row, column)@ is SQL @NULL@. + getisnull :: r -> Int32 -> Int32 -> IO Bool + + -- | Length in bytes of the value at @(row, column)@. + getlength :: r -> Int32 -> Int32 -> IO Int + + -- | Number of parameters of a prepared statement (for a 'describePrepared' + -- result). + nparams :: r -> IO Int32 + + -- | Data type OID of the given prepared-statement parameter. + paramtype :: r -> Int32 -> IO Word32 + + -- | The command status tag of the result (e.g. @\"INSERT 0 1\"@). + cmdStatus :: r -> IO (Maybe ByteString) + + -- | The number of rows affected by the command, as text. + cmdTuples :: r -> IO (Maybe ByteString) + +-- * Cancellation + +-- | Cancellation of in-progress commands, isolated from the connection type. +class IsCancel k where + -- | Request cancellation of the in-progress command via the handle. + cancel :: k -> IO (Either ByteString ()) + +-- * Connection + +-- | The single flat capability class: establishing, closing, inspecting, +-- querying, escaping, async commands, pipelining, cancellation handle +-- creation, notifications, copy, large objects, and control. +-- +-- See the individual capability-class documentation (now inlined below) for +-- semantics of each method. +class (IsResult (ResultOf c), IsCancel (CancelOf c)) => IsConnection c where + -- | The result type produced by this connection. + type ResultOf c :: Type + + -- | The cancellation-handle type produced by this connection. + type CancelOf c :: Type + + -- | Make a new (blocking) connection from a conninfo string. + connectdb :: ByteString -> IO c + + -- | Begin establishing a connection asynchronously. + connectStart :: ByteString -> IO c + + -- | Drive an asynchronous connection attempt forward. + connectPoll :: c -> IO PollingStatus + + -- | A sentinel \"null\" connection. + newNullConnection :: IO c + + -- | Whether a connection is the null sentinel. + isNullConnection :: c -> Bool + + -- | Close the connection and release its resources. + finish :: c -> IO () + + -- | Reset the communication channel to the server (blocking). + reset :: c -> IO () + + -- | Begin resetting the connection asynchronously. + resetStart :: c -> IO Bool + + -- | Drive an asynchronous reset forward. + resetPoll :: c -> IO PollingStatus + + -- | The database name of the connection. + db :: c -> IO (Maybe ByteString) + + -- | The user name of the connection. + user :: c -> IO (Maybe ByteString) + + -- | The password of the connection. + pass :: c -> IO (Maybe ByteString) + + -- | The server host name of the connection. + host :: c -> IO (Maybe ByteString) + + -- | The port of the connection. + port :: c -> IO (Maybe ByteString) + + -- | The command-line options passed in the connection request. + options :: c -> IO (Maybe ByteString) + + -- | Current connection status. + status :: c -> IO ConnStatus + + -- | Current in-transaction status of the server. + transactionStatus :: c -> IO TransactionStatus + + -- | Look up a current parameter setting reported by the server. + parameterStatus :: c -> ByteString -> IO (Maybe ByteString) + + -- | The frontend\/backend protocol version. + protocolVersion :: c -> IO Int + + -- | The server version, as an integer of the form @MMmmpp@. + serverVersion :: c -> IO Int + + -- | The most recent error message, if any. + -- + -- Note: unlike the structured fields available via @'resultErrorField'@, the + -- flat message text is formatted locally by the driver, so adapters are not + -- expected to produce byte-identical strings. + errorMessage :: c -> IO (Maybe ByteString) + + -- | The file descriptor of the connection socket. + socket :: c -> IO (Maybe Fd) + + -- | The process ID of the backend serving this connection. + backendPID :: c -> IO Int32 + + -- | Whether the connection authentication method required a password but + -- none was available. + connectionNeedsPassword :: c -> IO Bool + + -- | Whether the connection authentication used a password. + connectionUsedPassword :: c -> IO Bool + + -- | Submit a command and wait for the result. + exec :: c -> ByteString -> IO (Maybe (ResultOf c)) + + -- | Submit a parameterized command. Each parameter is given as + -- @(type oid, value, format)@, or @'Nothing'@ for SQL @NULL@. The final + -- @'Format'@ selects the result format. + execParams :: + c -> + ByteString -> + [Maybe (Word32, ByteString, Format)] -> + Format -> + IO (Maybe (ResultOf c)) + + -- | Prepare a named statement. The OID list, when supplied, fixes parameter + -- types; @'Nothing'@ leaves them to be inferred. + prepare :: c -> ByteString -> ByteString -> Maybe [Word32] -> IO (Maybe (ResultOf c)) + + -- | Execute a previously prepared statement. Each parameter is + -- @(value, format)@, or @'Nothing'@ for SQL @NULL@. + execPrepared :: + c -> + ByteString -> + [Maybe (ByteString, Format)] -> + Format -> + IO (Maybe (ResultOf c)) + + -- | Describe a prepared statement. + describePrepared :: c -> ByteString -> IO (Maybe (ResultOf c)) + + -- | Describe a portal. + describePortal :: c -> ByteString -> IO (Maybe (ResultOf c)) + + -- | Escape a string for safe inclusion in an SQL literal. + escapeStringConn :: c -> ByteString -> IO (Maybe ByteString) + + -- | Escape binary data for use within a @bytea@ literal. + escapeByteaConn :: c -> ByteString -> IO (Maybe ByteString) + + -- | Escape a string for use as an SQL identifier (e.g. a table or column + -- name), including the surrounding double quotes. + escapeIdentifier :: c -> ByteString -> IO (Maybe ByteString) + + -- | Submit a command without waiting for the result. + sendQuery :: c -> ByteString -> IO Bool + + -- | Asynchronous @'execParams'@. + sendQueryParams :: c -> ByteString -> [Maybe (Word32, ByteString, Format)] -> Format -> IO Bool + + -- | Asynchronous @'prepare'@. + sendPrepare :: c -> ByteString -> ByteString -> Maybe [Word32] -> IO Bool + + -- | Asynchronous @'execPrepared'@. + sendQueryPrepared :: c -> ByteString -> [Maybe (ByteString, Format)] -> Format -> IO Bool + + -- | Asynchronous @'describePrepared'@. + sendDescribePrepared :: c -> ByteString -> IO Bool + + -- | Asynchronous @'describePortal'@. + sendDescribePortal :: c -> ByteString -> IO Bool + + -- | Collect the next result from an asynchronous command. + getResult :: c -> IO (Maybe (ResultOf c)) + + -- | Read input from the server into the driver's buffer. + consumeInput :: c -> IO Bool + + -- | Whether a command is busy (a @'getResult'@ would block). + isBusy :: c -> IO Bool + + -- | Set the non-blocking flag of the connection. + setnonblocking :: c -> Bool -> IO Bool + + -- | Whether the connection is in non-blocking mode. + isnonblocking :: c -> IO Bool + + -- | Select single-row mode for the currently executing query. + setSingleRowMode :: c -> IO Bool + + -- | Flush queued output data to the server. + flush :: c -> IO FlushStatus + + -- | Current pipeline-mode status. + pipelineStatus :: c -> IO PipelineStatus + + -- | Enter pipeline mode. + enterPipelineMode :: c -> IO Bool + + -- | Leave pipeline mode. + exitPipelineMode :: c -> IO Bool + + -- | Mark a synchronization point in a pipeline. + pipelineSync :: c -> IO Bool + + -- | Request the server to flush its output buffer in pipeline mode. + sendFlushRequest :: c -> IO Bool + + -- | Obtain a cancellation handle for the connection. + getCancel :: c -> IO (Maybe (CancelOf c)) + + -- | Return the next notification from the queue, if any. + notifies :: c -> IO (Maybe Notify) + + -- | Stop accumulating notices for retrieval via @'getNotice'@. + disableNoticeReporting :: c -> IO () + + -- | Start accumulating notices for retrieval via @'getNotice'@. + enableNoticeReporting :: c -> IO () + + -- | Retrieve the next accumulated notice, if any. + getNotice :: c -> IO (Maybe ByteString) + + -- | Send data on a @COPY FROM STDIN@ connection. + putCopyData :: c -> ByteString -> IO CopyInResult + + -- | Signal the end of @COPY FROM STDIN@; @'Just'@ aborts with the given error. + putCopyEnd :: c -> Maybe ByteString -> IO CopyInResult + + -- | Receive data on a @COPY TO STDOUT@ connection. The @'Bool'@ selects + -- non-blocking mode. + getCopyData :: c -> Bool -> IO CopyOutResult + + -- | Create a new large object. + loCreat :: c -> IO (Maybe Word32) + + -- | Create a new large object with the given OID. + loCreate :: c -> Word32 -> IO (Maybe Word32) + + -- | Import a file as a new large object. + loImport :: c -> FilePath -> IO (Maybe Word32) + + -- | Import a file as a new large object with the given OID. + loImportWithOid :: c -> FilePath -> Word32 -> IO (Maybe Word32) + + -- | Export a large object to a file. + loExport :: c -> Word32 -> FilePath -> IO (Maybe ()) + + -- | Open a large object. + loOpen :: c -> Word32 -> IOMode -> IO (Maybe Int32) + + -- | Write to an open large object. + loWrite :: c -> Int32 -> ByteString -> IO (Maybe Int) + + -- | Read from an open large object. + loRead :: c -> Int32 -> Int -> IO (Maybe ByteString) + + -- | Seek within an open large object. + loSeek :: c -> Int32 -> SeekMode -> Int -> IO (Maybe Int) + + -- | Report the current seek position of an open large object. + loTell :: c -> Int32 -> IO (Maybe Int) + + -- | Truncate an open large object. + loTruncate :: c -> Int32 -> Int -> IO (Maybe ()) + + -- | Close an open large object. + loClose :: c -> Int32 -> IO (Maybe ()) + + -- | Remove a large object. + loUnlink :: c -> Word32 -> IO (Maybe ()) + + -- | The current client encoding name. + clientEncoding :: c -> IO ByteString + + -- | Set the client encoding. + setClientEncoding :: c -> ByteString -> IO Bool + + -- | Set error verbosity, returning the previous setting. + setErrorVerbosity :: c -> Verbosity -> IO Verbosity diff --git a/src/library/Pqi/UnescapeBytea.hs b/src/library/Pqi/UnescapeBytea.hs new file mode 100644 --- /dev/null +++ b/src/library/Pqi/UnescapeBytea.hs @@ -0,0 +1,158 @@ +-- | Pure implementation of @bytea@ unescaping. See 'unescapeBytea'. +module Pqi.UnescapeBytea + ( unescapeBytea, + ) +where + +import Data.ByteString (ByteString) +import Data.Either (fromRight) +import Data.Word (Word8) +import PtrPeeker (Variable, fixed, hasMore, runVariableOnByteString, unsignedInt1) +import PtrPoker.Write (Write) +import qualified PtrPoker.Write as Write +import Prelude + +-- | Convert the textual representation of a @bytea@ value, as produced by +-- the server, back into raw bytes. Both the modern @\\x@ hex format (lowercase +-- @x@ only) and the legacy escape format are accepted. +-- +-- Malformed input is tolerated exactly the way @PQunescapeBytea@ tolerates it: +-- in hex format, characters that are not hex digits (including whitespace) are +-- silently skipped, and a hex digit whose pair character is invalid is +-- dropped; in escape format, an invalid escape simply drops the backslash, and +-- an octal escape must start with @0@..@3@. Input is treated as a C string: +-- the first NUL byte terminates processing. +unescapeBytea :: ByteString -> ByteString +unescapeBytea input = + Write.toByteString $ + fromRight mempty $ + runVariableOnByteString decoder input + +-- Inline NUL truncation and \x prefix detection so no intermediate ByteStrings +-- are allocated before dispatching to the format-specific decoder. +decoder :: Variable Write +decoder = do + more <- hasMore + if not more + then return mempty + else do + b0 <- fixed unsignedInt1 + case b0 of + 0x00 -> return mempty -- NUL: C-string terminator + 0x5c -> do + -- backslash: probe for the \x hex-format prefix + more2 <- hasMore + if not more2 + then return mempty -- single trailing backslash + else do + b1 <- fixed unsignedInt1 + if b1 == 0x78 -- lowercase 'x': enter hex mode + then hexDecoder + else afterBackslash b1 -- escape mode; b1 follows the consumed '\' + _ -> (Write.word8 b0 <>) <$> escapeDecoder + +-- | Hex-format decoder. Skips non-hex bytes (matching @PQunescapeBytea@), +-- pairs hex nibbles, and stops at a NUL byte (C-string terminator). +hexDecoder :: Variable Write +hexDecoder = do + more <- hasMore + if not more + then return mempty + else do + a <- fixed unsignedInt1 + if a == 0x00 + then return mempty -- NUL: stop + else case hexValue a of + Nothing -> hexDecoder -- skip non-hex byte + Just hi -> do + more2 <- hasMore + if not more2 + then return mempty -- drop unpaired nibble + else do + b <- fixed unsignedInt1 + if b == 0x00 + then return mempty -- NUL: stop, drop unpaired nibble + else case hexValue b of + Nothing -> hexDecoder -- skip b, look for next pair + Just lo -> (Write.word8 (hi * 16 + lo) <>) <$> hexDecoder + where + hexValue :: Word8 -> Maybe Word8 + hexValue w + | w >= 0x30 && w <= 0x39 = Just (w - 0x30) + | w >= 0x61 && w <= 0x66 = Just (w - 0x57) + | w >= 0x41 && w <= 0x46 = Just (w - 0x37) + | otherwise = Nothing + +-- | Escape-format decoder. Processes bytes as escape sequences and stops at +-- a NUL byte (C-string terminator). +escapeDecoder :: Variable Write +escapeDecoder = do + more <- hasMore + if not more + then return mempty + else do + b <- fixed unsignedInt1 + case b of + 0x00 -> return mempty + 0x5c -> handleEscapeBackslash + _ -> (Write.word8 b <>) <$> escapeDecoder + +-- | Handle the bytes that follow a consumed backslash in escape format. +-- Exported so the top-level dispatcher can reuse it after consuming the +-- @\\x@ prefix check. +afterBackslash :: Word8 -> Variable Write +afterBackslash next = case next of + 0x00 -> return mempty + 0x5c -> (Write.word8 0x5c <>) <$> escapeDecoder + _ -> octalOrLiteralDecoder next + +handleEscapeBackslash :: Variable Write +handleEscapeBackslash = do + more <- hasMore + if not more + then return mempty -- trailing backslash: drop it + else do + next <- fixed unsignedInt1 + afterBackslash next + +-- | Try to decode a 3-digit octal starting with @a@ (already consumed). +-- Falls back to emitting @a@ literally and re-routing the consumed lookahead +-- byte(s) through 'afterEscape', reproducing @PQunescapeBytea@'s backtracking. +octalOrLiteralDecoder :: Word8 -> Variable Write +octalOrLiteralDecoder a + | isFirstOctal a = do + more <- hasMore + if not more + then return (Write.word8 a) + else do + b <- fixed unsignedInt1 + if not (isOctal b) + then (Write.word8 a <>) <$> afterEscape b -- b isn't octal: emit a, re-route b + else do + more2 <- hasMore + if not more2 + then return (Write.word8 a <> Write.word8 b) -- only two digits: both literal + else do + c <- fixed unsignedInt1 + if isOctal c + then (Write.word8 (octal a b c) <>) <$> escapeDecoder + else (\x -> Write.word8 a <> Write.word8 b <> x) <$> afterEscape c + | otherwise = (Write.word8 a <>) <$> escapeDecoder + where + -- \| Route an already-consumed byte back through the escape-format main loop. + -- Used when a consumed lookahead byte must be re-processed after a failed + -- octal-triple attempt. + afterEscape :: Word8 -> Variable Write + afterEscape b = case b of + 0x00 -> return mempty + 0x5c -> handleEscapeBackslash + _ -> (Write.word8 b <>) <$> escapeDecoder + + isFirstOctal :: Word8 -> Bool + isFirstOctal w = w >= 0x30 && w <= 0x33 + + isOctal :: Word8 -> Bool + isOctal w = w >= 0x30 && w <= 0x37 + + octal :: Word8 -> Word8 -> Word8 -> Word8 + octal a b c = (a - 0x30) * 64 + (b - 0x30) * 8 + (c - 0x30) diff --git a/src/test/Spec.hs b/src/test/Spec.hs new file mode 100644 --- /dev/null +++ b/src/test/Spec.hs @@ -0,0 +1,58 @@ +module Main (main) where + +import qualified Data.ByteString as ByteString +import Data.Foldable +import Data.Word +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Pqi +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Prelude + +main :: IO () +main = hspec spec + +spec :: Spec +spec = + describe "unescapeBytea" do + for_ + [ "", + "\\x", + "\\x00", + "\\x00ff", + "\\x48656c6c6f", + "\\X48656C6C6F", + "\\xAbCd", + "Hello, world", + "h\233llo bytes", + "\\\\", + "\\001\\002\\003", + "a\\010b", + "\\x4", + "\\x4g", + "\\xzz", + "\\x61 62", + "\\377", + "\\400", + "\\000", + "\\1", + "\\18", + "\\8", + "a\\b", + "trailing\\", + "mixed\\134text" + ] + \input -> + it (show input) do + theirs <- LibPQ.unescapeBytea input + theirs `shouldBe` Just (Pqi.unescapeBytea input) + + -- PQunescapeBytea treats its input as a null-terminated C string, so + -- embedded NUL bytes would truncate it early. Exclude them. + prop "matches PQunescapeBytea on arbitrary input" $ + \(bytes :: [Word8]) -> + ioProperty do + let input = ByteString.pack bytes + theirs <- LibPQ.unescapeBytea input + return $ theirs === Just (Pqi.unescapeBytea input)