Ffi.hs

-- | The FFI adapter, backed by @postgresql-libpq@.
--
-- 'adapter' bundles the three functions that produce a 'Pqi.Connection'
-- whose fields are closures over the underlying C-backed @PGconn@.
-- 'Pqi.Result' and 'Pqi.Cancel' values are constructed the same way, closing
-- over the underlying @PGresult@\/@PGcancel@.
--
-- Each closure 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
  ( adapter,
  )
where

import qualified Database.PostgreSQL.LibPQ as Pq
import qualified Pqi
import Pqi.Ffi.Prelude

-- | The FFI adapter.
adapter :: Pqi.Adapter
adapter =
  Pqi.Adapter
    { Pqi.name = "pqi-ffi",
      Pqi.connectdb = \conninfo -> mkConnection <$> Pq.connectdb conninfo,
      Pqi.connectStart = \conninfo -> mkConnection <$> Pq.connectStart conninfo,
      Pqi.newNullConnection = mkConnection <$> Pq.newNullConnection,
      Pqi.unescapeBytea = \input -> Pq.unescapeBytea input
    }

-- | Build a 'Pqi.Connection' whose fields close over the given
-- @postgresql-libpq@ connection handle.
mkConnection :: Pq.Connection -> Pqi.Connection
mkConnection c =
  Pqi.Connection
    { Pqi.connectPoll = fromPollingStatus <$> Pq.connectPoll c,
      Pqi.isNullConnection = Pq.isNullConnection c,
      Pqi.finish = Pq.finish c,
      Pqi.reset = Pq.reset c,
      Pqi.resetStart = Pq.resetStart c,
      Pqi.resetPoll = fromPollingStatus <$> Pq.resetPoll c,
      Pqi.db = Pq.db c,
      Pqi.user = Pq.user c,
      Pqi.pass = Pq.pass c,
      Pqi.host = Pq.host c,
      Pqi.port = Pq.port c,
      Pqi.options = Pq.options c,
      Pqi.status = fromConnStatus <$> Pq.status c,
      Pqi.transactionStatus = fromTransactionStatus <$> Pq.transactionStatus c,
      Pqi.parameterStatus = \name -> Pq.parameterStatus c name,
      Pqi.protocolVersion = Pq.protocolVersion c,
      Pqi.serverVersion = Pq.serverVersion c,
      Pqi.errorMessage = Pq.errorMessage c,
      Pqi.socket = Pq.socket c,
      Pqi.backendPID = fromIntegral <$> Pq.backendPID c,
      Pqi.connectionNeedsPassword = Pq.connectionNeedsPassword c,
      Pqi.connectionUsedPassword = Pq.connectionUsedPassword c,
      Pqi.exec = \sql -> fmap mkResult <$> Pq.exec c sql,
      Pqi.execParams = \sql params resultFormat ->
        fmap mkResult <$> Pq.execParams c sql (fmap (fmap toParam) params) (toFormat resultFormat),
      Pqi.prepare = \name sql paramTypes ->
        fmap mkResult <$> Pq.prepare c name sql (fmap (fmap toOid) paramTypes),
      Pqi.execPrepared = \name params resultFormat ->
        fmap mkResult <$> Pq.execPrepared c name (fmap (fmap toBoundParam) params) (toFormat resultFormat),
      Pqi.describePrepared = \name -> fmap mkResult <$> Pq.describePrepared c name,
      Pqi.describePortal = \name -> fmap mkResult <$> Pq.describePortal c name,
      Pqi.escapeStringConn = \s -> Pq.escapeStringConn c s,
      Pqi.escapeByteaConn = \s -> Pq.escapeByteaConn c s,
      Pqi.escapeIdentifier = \s -> Pq.escapeIdentifier c s,
      Pqi.sendQuery = \sql -> Pq.sendQuery c sql,
      Pqi.sendQueryParams = \sql params resultFormat ->
        Pq.sendQueryParams c sql (fmap (fmap toParam) params) (toFormat resultFormat),
      Pqi.sendPrepare = \name sql paramTypes ->
        Pq.sendPrepare c name sql (fmap (fmap toOid) paramTypes),
      Pqi.sendQueryPrepared = \name params resultFormat ->
        Pq.sendQueryPrepared c name (fmap (fmap toBoundParam) params) (toFormat resultFormat),
      Pqi.sendDescribePrepared = \name -> Pq.sendDescribePrepared c name,
      Pqi.sendDescribePortal = \name -> Pq.sendDescribePortal c name,
      Pqi.getResult = fmap mkResult <$> Pq.getResult c,
      Pqi.consumeInput = Pq.consumeInput c,
      Pqi.isBusy = Pq.isBusy c,
      Pqi.setnonblocking = \nonBlocking -> Pq.setnonblocking c nonBlocking,
      Pqi.isnonblocking = Pq.isnonblocking c,
      Pqi.setSingleRowMode = Pq.setSingleRowMode c,
      Pqi.flush = fromFlushStatus <$> Pq.flush c,
      Pqi.pipelineStatus = fromPipelineStatus <$> Pq.pipelineStatus c,
      Pqi.enterPipelineMode = Pq.enterPipelineMode c,
      Pqi.exitPipelineMode = Pq.exitPipelineMode c,
      Pqi.pipelineSync = Pq.pipelineSync c,
      Pqi.sendFlushRequest = Pq.sendFlushRequest c,
      Pqi.getCancel = fmap mkCancel <$> Pq.getCancel c,
      Pqi.notifies = fmap fromNotify <$> Pq.notifies c,
      Pqi.disableNoticeReporting = Pq.disableNoticeReporting c,
      Pqi.enableNoticeReporting = Pq.enableNoticeReporting c,
      Pqi.getNotice = Pq.getNotice c,
      Pqi.putCopyData = \value -> fromCopyInResult <$> Pq.putCopyData c value,
      Pqi.putCopyEnd = \reason -> fromCopyInResult <$> Pq.putCopyEnd c reason,
      Pqi.getCopyData = \nonBlocking -> fromCopyOutResult <$> Pq.getCopyData c nonBlocking,
      Pqi.loCreat = fmap fromOid <$> Pq.loCreat c,
      Pqi.loCreate = \oid -> fmap fromOid <$> Pq.loCreate c (toOid oid),
      Pqi.loImport = \path -> fmap fromOid <$> Pq.loImport c path,
      Pqi.loImportWithOid = \path oid -> fmap fromOid <$> Pq.loImportWithOid c path (toOid oid),
      Pqi.loExport = \oid path -> Pq.loExport c (toOid oid) path,
      Pqi.loOpen = \oid mode -> fmap fromLibPQLoFd <$> Pq.loOpen c (toOid oid) mode,
      Pqi.loWrite = \fd value -> Pq.loWrite c (toLibPQLoFd fd) value,
      Pqi.loRead = \fd len -> Pq.loRead c (toLibPQLoFd fd) len,
      Pqi.loSeek = \fd mode offset -> Pq.loSeek c (toLibPQLoFd fd) mode offset,
      Pqi.loTell = \fd -> Pq.loTell c (toLibPQLoFd fd),
      Pqi.loTruncate = \fd len -> Pq.loTruncate c (toLibPQLoFd fd) len,
      Pqi.loClose = \fd -> Pq.loClose c (toLibPQLoFd fd),
      Pqi.loUnlink = \oid -> Pq.loUnlink c (toOid oid),
      Pqi.clientEncoding = Pq.clientEncoding c,
      Pqi.setClientEncoding = \encoding -> Pq.setClientEncoding c encoding,
      Pqi.setErrorVerbosity = \verbosity ->
        fromVerbosity <$> Pq.setErrorVerbosity c (toVerbosity verbosity)
    }

-- | Build a 'Pqi.Result' whose fields close over the given
-- @postgresql-libpq@ result handle.
mkResult :: Pq.Result -> Pqi.Result
mkResult r =
  Pqi.Result
    { Pqi.resultStatus = fromExecStatus <$> Pq.resultStatus r,
      Pqi.resultErrorMessage = Pq.resultErrorMessage r,
      Pqi.resultErrorField = \field -> Pq.resultErrorField r (toFieldCode field),
      Pqi.unsafeFreeResult = Pq.unsafeFreeResult r,
      Pqi.ntuples = fromRow <$> Pq.ntuples r,
      Pqi.nfields = fromColumn <$> Pq.nfields r,
      Pqi.fname = \column -> Pq.fname r (toColumn column),
      Pqi.fnumber = \name -> fmap fromColumn <$> Pq.fnumber r name,
      Pqi.ftable = \column -> fromOid <$> Pq.ftable r (toColumn column),
      Pqi.ftablecol = \column -> fromColumn <$> Pq.ftablecol r (toColumn column),
      Pqi.fformat = \column -> fromFormat <$> Pq.fformat r (toColumn column),
      Pqi.ftype = \column -> fromOid <$> Pq.ftype r (toColumn column),
      Pqi.fmod = \column -> Pq.fmod r (toColumn column),
      Pqi.fsize = \column -> Pq.fsize r (toColumn column),
      Pqi.getvalue = \row column -> Pq.getvalue' r (toRow row) (toColumn column),
      Pqi.getvalue' = \row column -> Pq.getvalue' r (toRow row) (toColumn column),
      Pqi.getisnull = \row column -> Pq.getisnull r (toRow row) (toColumn column),
      Pqi.getlength = \row column -> Pq.getlength r (toRow row) (toColumn column),
      Pqi.nparams = fromIntegral <$> Pq.nparams r,
      Pqi.paramtype = \index -> fromOid <$> Pq.paramtype r (fromIntegral index),
      Pqi.cmdStatus = Pq.cmdStatus r,
      Pqi.cmdTuples = Pq.cmdTuples r
    }

-- | Build a 'Pqi.Cancel' whose field closes over the given
-- @postgresql-libpq@ cancellation handle.
mkCancel :: Pq.Cancel -> Pqi.Cancel
mkCancel handle =
  Pqi.Cancel
    { Pqi.cancel = Pq.cancel handle
    }

-- * 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