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,20 @@ +# pqi-ffi + +[![Hackage](https://img.shields.io/hackage/v/pqi-ffi.svg)](https://hackage.haskell.org/package/pqi-ffi) +[![Continuous Haddock](https://img.shields.io/badge/haddock-master-blue)](https://nikita-volkov.github.io/pqi-ffi/) + +The FFI adapter for [`pqi`](https://github.com/nikita-volkov/pqi), +backed by [`postgresql-libpq`](https://hackage.haskell.org/package/postgresql-libpq) +(a binding to the C `libpq` library). + +`Pqi.Ffi.Connection` wraps a C-backed `PGconn` and provides an +`IsConnection` instance whose every method is a near-mechanical delegation to +the matching `Database.PostgreSQL.LibPQ` function. The only work is converting +between this family's portable types (OIDs as `Word32`, indices as `Int32`, +the shared enums) and `postgresql-libpq`'s C-specific newtypes. + +This adapter is the **fidelity reference** for the `pqi` family: it is the +oracle against which all other adapters are tested. The +[`pqi-conformance`](https://github.com/nikita-volkov/pqi-conformance) suite +runs every operation on both the candidate adapter and this one, asserts +byte-identical output, and thereby defines what "correct" means for the family. diff --git a/pqi-ffi.cabal b/pqi-ffi.cabal new file mode 100644 --- /dev/null +++ b/pqi-ffi.cabal @@ -0,0 +1,109 @@ +cabal-version: 3.0 +name: pqi-ffi +version: 0.0.1.0 +category: Database, PostgreSQL +synopsis: FFI adapter for pqi, backed by postgresql-libpq +description: + A @pqi@ adapter implemented as a thin pass-through over the + @postgresql-libpq@ package, which binds the C @libpq@ library. Use this + adapter when you want the fidelity of the reference C implementation; it is + also the oracle that the @pqi-native@ adapter is tested against. + +homepage: https://github.com/nikita-volkov/pqi-ffi +bug-reports: https://github.com/nikita-volkov/pqi-ffi/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-ffi + +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.Ffi + + other-modules: + Pqi.Ffi.Prelude + + build-depends: + base >=4.11 && <5, + bytestring >=0.10 && <0.13, + postgresql-libpq >=0.11 && <0.12, + pqi ^>=0, + +test-suite ffi-test + import: test + type: exitcode-stdio-1.0 + hs-source-dirs: src/test + main-is: Spec.hs + build-depends: + base >=4.11 && <5, + hspec >=2.11 && <2.12, + pqi-conformance, + pqi-ffi, diff --git a/src/library/Pqi/Ffi.hs b/src/library/Pqi/Ffi.hs new file mode 100644 --- /dev/null +++ b/src/library/Pqi/Ffi.hs @@ -0,0 +1,295 @@ +-- | The FFI adapter, backed by @postgresql-libpq@. +-- +-- 'Connection' wraps the C-backed @PGconn@. +-- +-- Each method is a near-mechanical delegation to the matching +-- @Database.PostgreSQL.LibPQ@ function, with the only work being the +-- conversion between this family's portable types (OIDs as 'Word32', indices +-- as 'Int32', the shared enums) and @postgresql-libpq@'s C-specific newtypes. +module Pqi.Ffi + ( Connection, + ) +where + +import qualified Database.PostgreSQL.LibPQ as Pq +import qualified Pqi +import Pqi.Ffi.Prelude + +-- | A handle to a PostgreSQL connection backed by the C @libpq@ library. +newtype Connection = Connection Pq.Connection + +-- | A result handle backed by a C @PGresult@. +newtype Result = Result Pq.Result + +-- | A cancellation handle backed by a C @PGcancel@. +newtype Cancel = Cancel Pq.Cancel + +instance Pqi.IsResult Result where + resultStatus (Result r) = fromExecStatus <$> Pq.resultStatus r + resultErrorMessage (Result r) = Pq.resultErrorMessage r + resultErrorField (Result r) field = Pq.resultErrorField r (toFieldCode field) + unsafeFreeResult (Result r) = Pq.unsafeFreeResult r + ntuples (Result r) = fromRow <$> Pq.ntuples r + nfields (Result r) = fromColumn <$> Pq.nfields r + fname (Result r) column = Pq.fname r (toColumn column) + fnumber (Result r) name = fmap fromColumn <$> Pq.fnumber r name + ftable (Result r) column = fromOid <$> Pq.ftable r (toColumn column) + ftablecol (Result r) column = fromColumn <$> Pq.ftablecol r (toColumn column) + fformat (Result r) column = fromFormat <$> Pq.fformat r (toColumn column) + ftype (Result r) column = fromOid <$> Pq.ftype r (toColumn column) + fmod (Result r) column = Pq.fmod r (toColumn column) + fsize (Result r) column = Pq.fsize r (toColumn column) + getvalue (Result r) row column = Pq.getvalue r (toRow row) (toColumn column) + getvalue' (Result r) row column = Pq.getvalue' r (toRow row) (toColumn column) + getisnull (Result r) row column = Pq.getisnull r (toRow row) (toColumn column) + getlength (Result r) row column = Pq.getlength r (toRow row) (toColumn column) + nparams (Result r) = fromIntegral <$> Pq.nparams r + paramtype (Result r) index = fromOid <$> Pq.paramtype r (fromIntegral index) + cmdStatus (Result r) = Pq.cmdStatus r + cmdTuples (Result r) = Pq.cmdTuples r + +instance Pqi.IsCancel Cancel where + cancel (Cancel handle) = Pq.cancel handle + +instance Pqi.IsConnection Connection where + type ResultOf Connection = Result + type CancelOf Connection = Cancel + + connectdb conninfo = Connection <$> Pq.connectdb conninfo + connectStart conninfo = Connection <$> Pq.connectStart conninfo + connectPoll (Connection c) = fromPollingStatus <$> Pq.connectPoll c + newNullConnection = Connection <$> Pq.newNullConnection + isNullConnection (Connection c) = Pq.isNullConnection c + finish (Connection c) = Pq.finish c + reset (Connection c) = Pq.reset c + resetStart (Connection c) = Pq.resetStart c + resetPoll (Connection c) = fromPollingStatus <$> Pq.resetPoll c + db (Connection c) = Pq.db c + user (Connection c) = Pq.user c + pass (Connection c) = Pq.pass c + host (Connection c) = Pq.host c + port (Connection c) = Pq.port c + options (Connection c) = Pq.options c + status (Connection c) = fromConnStatus <$> Pq.status c + transactionStatus (Connection c) = fromTransactionStatus <$> Pq.transactionStatus c + parameterStatus (Connection c) name = Pq.parameterStatus c name + protocolVersion (Connection c) = Pq.protocolVersion c + serverVersion (Connection c) = Pq.serverVersion c + errorMessage (Connection c) = Pq.errorMessage c + socket (Connection c) = Pq.socket c + backendPID (Connection c) = fromIntegral <$> Pq.backendPID c + connectionNeedsPassword (Connection c) = Pq.connectionNeedsPassword c + connectionUsedPassword (Connection c) = Pq.connectionUsedPassword c + + exec (Connection c) sql = + fmap Result <$> Pq.exec c sql + execParams (Connection c) sql params resultFormat = + fmap Result <$> Pq.execParams c sql (fmap (fmap toParam) params) (toFormat resultFormat) + prepare (Connection c) name sql paramTypes = + fmap Result <$> Pq.prepare c name sql (fmap (fmap toOid) paramTypes) + execPrepared (Connection c) name params resultFormat = + fmap Result <$> Pq.execPrepared c name (fmap (fmap toBoundParam) params) (toFormat resultFormat) + describePrepared (Connection c) name = + fmap Result <$> Pq.describePrepared c name + describePortal (Connection c) name = + fmap Result <$> Pq.describePortal c name + + escapeStringConn (Connection c) = Pq.escapeStringConn c + escapeByteaConn (Connection c) = Pq.escapeByteaConn c + escapeIdentifier (Connection c) = Pq.escapeIdentifier c + + sendQuery (Connection c) sql = Pq.sendQuery c sql + sendQueryParams (Connection c) sql params resultFormat = + Pq.sendQueryParams c sql (fmap (fmap toParam) params) (toFormat resultFormat) + sendPrepare (Connection c) name sql paramTypes = + Pq.sendPrepare c name sql (fmap (fmap toOid) paramTypes) + sendQueryPrepared (Connection c) name params resultFormat = + Pq.sendQueryPrepared c name (fmap (fmap toBoundParam) params) (toFormat resultFormat) + sendDescribePrepared (Connection c) name = Pq.sendDescribePrepared c name + sendDescribePortal (Connection c) name = Pq.sendDescribePortal c name + getResult (Connection c) = fmap Result <$> Pq.getResult c + consumeInput (Connection c) = Pq.consumeInput c + isBusy (Connection c) = Pq.isBusy c + setnonblocking (Connection c) nonBlocking = Pq.setnonblocking c nonBlocking + isnonblocking (Connection c) = Pq.isnonblocking c + setSingleRowMode (Connection c) = Pq.setSingleRowMode c + flush (Connection c) = fromFlushStatus <$> Pq.flush c + + pipelineStatus (Connection c) = fromPipelineStatus <$> Pq.pipelineStatus c + enterPipelineMode (Connection c) = Pq.enterPipelineMode c + exitPipelineMode (Connection c) = Pq.exitPipelineMode c + pipelineSync (Connection c) = Pq.pipelineSync c + sendFlushRequest (Connection c) = Pq.sendFlushRequest c + + getCancel (Connection c) = fmap Cancel <$> Pq.getCancel c + + notifies (Connection c) = fmap fromNotify <$> Pq.notifies c + disableNoticeReporting (Connection c) = Pq.disableNoticeReporting c + enableNoticeReporting (Connection c) = Pq.enableNoticeReporting c + getNotice (Connection c) = Pq.getNotice c + + putCopyData (Connection c) value = fromCopyInResult <$> Pq.putCopyData c value + putCopyEnd (Connection c) reason = fromCopyInResult <$> Pq.putCopyEnd c reason + getCopyData (Connection c) nonBlocking = fromCopyOutResult <$> Pq.getCopyData c nonBlocking + + loCreat (Connection c) = fmap fromOid <$> Pq.loCreat c + loCreate (Connection c) oid = fmap fromOid <$> Pq.loCreate c (toOid oid) + loImport (Connection c) path = fmap fromOid <$> Pq.loImport c path + loImportWithOid (Connection c) path oid = fmap fromOid <$> Pq.loImportWithOid c path (toOid oid) + loExport (Connection c) oid path = Pq.loExport c (toOid oid) path + loOpen (Connection c) oid mode = fmap fromLibPQLoFd <$> Pq.loOpen c (toOid oid) mode + loWrite (Connection c) fd value = Pq.loWrite c (toLibPQLoFd fd) value + loRead (Connection c) fd len = Pq.loRead c (toLibPQLoFd fd) len + loSeek (Connection c) fd mode offset = Pq.loSeek c (toLibPQLoFd fd) mode offset + loTell (Connection c) fd = Pq.loTell c (toLibPQLoFd fd) + loTruncate (Connection c) fd len = Pq.loTruncate c (toLibPQLoFd fd) len + loClose (Connection c) fd = Pq.loClose c (toLibPQLoFd fd) + loUnlink (Connection c) oid = Pq.loUnlink c (toOid oid) + + clientEncoding (Connection c) = Pq.clientEncoding c + setClientEncoding (Connection c) encoding = Pq.setClientEncoding c encoding + setErrorVerbosity (Connection c) verbosity = + fromVerbosity <$> Pq.setErrorVerbosity c (toVerbosity verbosity) + +-- * Type conversions + +toParam :: (Word32, ByteString, Pqi.Format) -> (Pq.Oid, ByteString, Pq.Format) +toParam (oid, value, format) = (toOid oid, value, toFormat format) + +toBoundParam :: (ByteString, Pqi.Format) -> (ByteString, Pq.Format) +toBoundParam (value, format) = (value, toFormat format) + +toOid :: Word32 -> Pq.Oid +toOid = Pq.Oid . fromIntegral + +fromOid :: Pq.Oid -> Word32 +fromOid (Pq.Oid value) = fromIntegral value + +toRow :: Int32 -> Pq.Row +toRow = Pq.toRow + +fromRow :: Pq.Row -> Int32 +fromRow = fromIntegral . fromEnum + +toColumn :: Int32 -> Pq.Column +toColumn = Pq.toColumn + +fromColumn :: Pq.Column -> Int32 +fromColumn = fromIntegral . fromEnum + +toLibPQLoFd :: Int32 -> Pq.LoFd +toLibPQLoFd = Pq.LoFd . fromIntegral + +fromLibPQLoFd :: Pq.LoFd -> Int32 +fromLibPQLoFd (Pq.LoFd fd) = fromIntegral fd + +fromNotify :: Pq.Notify -> Pqi.Notify +fromNotify notification = + Pqi.Notify + { Pqi.relname = Pq.notifyRelname notification, + Pqi.bePid = fromIntegral (Pq.notifyBePid notification), + Pqi.extra = Pq.notifyExtra notification + } + +toFormat :: Pqi.Format -> Pq.Format +toFormat = \case + Pqi.Text -> Pq.Text + Pqi.Binary -> Pq.Binary + +fromFormat :: Pq.Format -> Pqi.Format +fromFormat = \case + Pq.Text -> Pqi.Text + Pq.Binary -> Pqi.Binary + +fromExecStatus :: Pq.ExecStatus -> Pqi.ExecStatus +fromExecStatus = \case + Pq.EmptyQuery -> Pqi.EmptyQuery + Pq.CommandOk -> Pqi.CommandOk + Pq.TuplesOk -> Pqi.TuplesOk + Pq.CopyOut -> Pqi.CopyOut + Pq.CopyIn -> Pqi.CopyIn + Pq.CopyBoth -> Pqi.CopyBoth + Pq.BadResponse -> Pqi.BadResponse + Pq.NonfatalError -> Pqi.NonfatalError + Pq.FatalError -> Pqi.FatalError + Pq.SingleTuple -> Pqi.SingleTuple + Pq.PipelineSync -> Pqi.PipelineSync + Pq.PipelineAbort -> Pqi.PipelineAbort + +fromConnStatus :: Pq.ConnStatus -> Pqi.ConnStatus +fromConnStatus = \case + Pq.ConnectionOk -> Pqi.ConnectionOk + Pq.ConnectionBad -> Pqi.ConnectionBad + Pq.ConnectionStarted -> Pqi.ConnectionStarted + Pq.ConnectionMade -> Pqi.ConnectionMade + Pq.ConnectionAwaitingResponse -> Pqi.ConnectionAwaitingResponse + Pq.ConnectionAuthOk -> Pqi.ConnectionAuthOk + Pq.ConnectionSetEnv -> Pqi.ConnectionSetEnv + Pq.ConnectionSSLStartup -> Pqi.ConnectionSSLStartup + +fromTransactionStatus :: Pq.TransactionStatus -> Pqi.TransactionStatus +fromTransactionStatus = \case + Pq.TransIdle -> Pqi.TransIdle + Pq.TransActive -> Pqi.TransActive + Pq.TransInTrans -> Pqi.TransInTrans + Pq.TransInError -> Pqi.TransInError + Pq.TransUnknown -> Pqi.TransUnknown + +fromPollingStatus :: Pq.PollingStatus -> Pqi.PollingStatus +fromPollingStatus = \case + Pq.PollingFailed -> Pqi.PollingFailed + Pq.PollingReading -> Pqi.PollingReading + Pq.PollingWriting -> Pqi.PollingWriting + Pq.PollingOk -> Pqi.PollingOk + +fromPipelineStatus :: Pq.PipelineStatus -> Pqi.PipelineStatus +fromPipelineStatus = \case + Pq.PipelineOn -> Pqi.PipelineOn + Pq.PipelineOff -> Pqi.PipelineOff + Pq.PipelineAborted -> Pqi.PipelineAborted + +fromFlushStatus :: Pq.FlushStatus -> Pqi.FlushStatus +fromFlushStatus = \case + Pq.FlushOk -> Pqi.FlushOk + Pq.FlushFailed -> Pqi.FlushFailed + Pq.FlushWriting -> Pqi.FlushWriting + +fromCopyInResult :: Pq.CopyInResult -> Pqi.CopyInResult +fromCopyInResult = \case + Pq.CopyInOk -> Pqi.CopyInOk + Pq.CopyInError -> Pqi.CopyInError + Pq.CopyInWouldBlock -> Pqi.CopyInWouldBlock + +fromCopyOutResult :: Pq.CopyOutResult -> Pqi.CopyOutResult +fromCopyOutResult = \case + Pq.CopyOutRow value -> Pqi.CopyOutRow value + Pq.CopyOutWouldBlock -> Pqi.CopyOutWouldBlock + Pq.CopyOutDone -> Pqi.CopyOutDone + Pq.CopyOutError -> Pqi.CopyOutError + +toVerbosity :: Pqi.Verbosity -> Pq.Verbosity +toVerbosity = \case + Pqi.ErrorsTerse -> Pq.ErrorsTerse + Pqi.ErrorsDefault -> Pq.ErrorsDefault + Pqi.ErrorsVerbose -> Pq.ErrorsVerbose + +fromVerbosity :: Pq.Verbosity -> Pqi.Verbosity +fromVerbosity = \case + Pq.ErrorsTerse -> Pqi.ErrorsTerse + Pq.ErrorsDefault -> Pqi.ErrorsDefault + Pq.ErrorsVerbose -> Pqi.ErrorsVerbose + +toFieldCode :: Pqi.FieldCode -> Pq.FieldCode +toFieldCode = \case + Pqi.DiagSeverity -> Pq.DiagSeverity + Pqi.DiagSqlstate -> Pq.DiagSqlstate + Pqi.DiagMessagePrimary -> Pq.DiagMessagePrimary + Pqi.DiagMessageDetail -> Pq.DiagMessageDetail + Pqi.DiagMessageHint -> Pq.DiagMessageHint + Pqi.DiagStatementPosition -> Pq.DiagStatementPosition + Pqi.DiagInternalPosition -> Pq.DiagInternalPosition + Pqi.DiagInternalQuery -> Pq.DiagInternalQuery + Pqi.DiagContext -> Pq.DiagContext + Pqi.DiagSourceFile -> Pq.DiagSourceFile + Pqi.DiagSourceLine -> Pq.DiagSourceLine + Pqi.DiagSourceFunction -> Pq.DiagSourceFunction diff --git a/src/library/Pqi/Ffi/Prelude.hs b/src/library/Pqi/Ffi/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/library/Pqi/Ffi/Prelude.hs @@ -0,0 +1,27 @@ +module Pqi.Ffi.Prelude + ( module Exports, + ) +where + +import Control.Applicative as Exports +import Control.Monad as Exports +import Data.Bool as Exports +import Data.ByteString as Exports (ByteString) +import Data.Either as Exports +import Data.Eq as Exports +import Data.Foldable as Exports +import Data.Function as Exports +import Data.Functor as Exports +import Data.Int as Exports +import Data.Maybe as Exports +import Data.Ord as Exports +import Data.Traversable as Exports +import Data.Word as Exports +import System.IO as Exports (IO) +import Text.Show as Exports +import Prelude as Exports + ( Enum (..), + Integral (..), + Num (..), + fromIntegral, + ) 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,14 @@ +-- | The FFI adapter's conformance test suite: a single delegate to +-- 'Pqi.Conformance.specs', which brings up a throwaway PostgreSQL +-- container, runs the full differential battery against the FFI reference, +-- and tears the container down again. +module Main (main) where + +import Data.Proxy (Proxy (..)) +import Pqi.Conformance (specs) +import Pqi.Ffi (Connection) +import Test.Hspec +import Prelude + +main :: IO () +main = hspec (specs (Proxy @Connection))