-- | Internal types for the native adapter, separated from 'Connection.hs' to
-- keep 'mkResult'\/'mkCancel' (and the pure formatting helpers they build on)
-- next to the data they close over.
module Pqi.Native.Types
  ( NativeResult (..),
    NativeCancel (..),
    mkResult,
    mkCancel,
    formatErrorFields,
    formatResultError,
  )
where

import Control.Exception (IOException, try)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Char8 as ByteString.Char8
import Data.Char (isDigit)
import Data.List (findIndex)
import qualified Data.Map.Strict as Map
import Pqi
  ( Cancel (..),
    ExecStatus (..),
    FieldCode (..),
    Format (..),
    PipelineStatus (..),
    Result (..),
  )
import Pqi.Native.Prelude
import qualified Pqi.Native.Transport as Transport
import Pqi.Native.Transport.Message (FieldDescription (..), cancelRequest)

-- | A fully materialized result. The native adapter buffers the entire result
-- in memory, so the accessors are pure lookups and 'unsafeFreeResult' is a
-- no-op.
data NativeResult = NativeResult
  { NativeResult -> ExecStatus
status :: ExecStatus,
    NativeResult -> [FieldDescription]
fields :: [FieldDescription],
    NativeResult -> [[Maybe ByteString]]
rows :: [[Maybe ByteString]],
    NativeResult -> Maybe ByteString
commandTag :: Maybe ByteString,
    NativeResult -> Map Word8 ByteString
errorFields :: Map.Map Word8 ByteString,
    NativeResult -> [Word32]
paramOids :: [Word32],
    -- | The query text that produced this result (used to format @LINE N:@
    -- position context in 'resultErrorMessage', matching libpq's behaviour).
    -- Empty for non-error results and for async results where the query is
    -- unavailable.
    NativeResult -> ByteString
queryText :: ByteString
  }
  deriving stock (NativeResult -> NativeResult -> Bool
(NativeResult -> NativeResult -> Bool)
-> (NativeResult -> NativeResult -> Bool) -> Eq NativeResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NativeResult -> NativeResult -> Bool
== :: NativeResult -> NativeResult -> Bool
$c/= :: NativeResult -> NativeResult -> Bool
/= :: NativeResult -> NativeResult -> Bool
Eq, Int -> NativeResult -> ShowS
[NativeResult] -> ShowS
NativeResult -> String
(Int -> NativeResult -> ShowS)
-> (NativeResult -> String)
-> ([NativeResult] -> ShowS)
-> Show NativeResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NativeResult -> ShowS
showsPrec :: Int -> NativeResult -> ShowS
$cshow :: NativeResult -> String
show :: NativeResult -> String
$cshowList :: [NativeResult] -> ShowS
showList :: [NativeResult] -> ShowS
Show)

-- | A standalone cancellation handle for the native adapter.
--
-- Carries references to connection state so the cancel implementation can
-- decide whether a network round-trip is necessary:
--
-- * @asyncPendingRef@: False when nothing is in flight at all - skip the
--   round-trip entirely.
-- * @pipelineStatusRef@ + @pendingCommandsRef@: in pipeline mode,
--   @asyncPending@ stays True even after all @CommandComplete@ messages
--   have arrived (while @ReadyForQuery@ is still unread).  Sending a cancel
--   in that window produces a stale signal that can interrupt the very next
--   command (e.g. the @ABORT@ issued during clean-up).  Checking
--   @pendingCommands > 0@ instead avoids the stale cancel: once all command
--   completions are in, @pendingCommands@ is 0 and the server is idle.
data NativeCancel = NativeCancel
  { NativeCancel -> ByteString
host :: ByteString,
    NativeCancel -> Int
port :: Int,
    NativeCancel -> Int32
pid :: Int32,
    NativeCancel -> Int32
secret :: Int32,
    NativeCancel -> IORef Bool
asyncPendingRef :: IORef Bool,
    NativeCancel -> IORef PipelineStatus
pipelineStatusRef :: IORef PipelineStatus,
    NativeCancel -> IORef Int
pendingCommandsRef :: IORef Int
  }

-- | Like 'formatResultError' but without a client query text (for
-- connection-level errors, which never carry a statement-position field).
formatErrorFields :: Map.Map Word8 ByteString -> ByteString
formatErrorFields :: Map Word8 ByteString -> ByteString
formatErrorFields = ByteString -> Map Word8 ByteString -> ByteString
formatResultError ByteString
""

-- | Format error\/notice fields into a message string matching libpq's
-- @PQresultErrorMessage@ at DEFAULT verbosity with @SHOW_CONTEXT_ERRORS@
-- visibility.
--
-- Field order (matching libpq):
-- 1. @\<Severity\>:  \<Message\>\\n@
-- 2. @LINE N: \<query line\>\\n        \^\\n@ (statement position via @queryText@ + @\'P\'@ field)
-- 3. @LINE N: \<internal query\>\\n        \^\\nQUERY: \<internal query\>\\n@ (@\'q\'@+@\'p\'@ fields)
-- 4. @DETAIL:  \<D\>\\n@
-- 5. @HINT:  \<H\>\\n@
-- 6. @CONTEXT:  \<W\>\\n@ (ERROR\/FATAL\/PANIC only)
formatResultError :: ByteString -> Map.Map Word8 ByteString -> ByteString
formatResultError :: ByteString -> Map Word8 ByteString -> ByteString
formatResultError ByteString
queryText Map Word8 ByteString
fields =
  case Word8 -> Map Word8 ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word8
0x4d Map Word8 ByteString
fields of
    Maybe ByteString
Nothing -> ByteString
""
    Just ByteString
msg ->
      let sev :: ByteString
sev = ByteString -> Word8 -> Map Word8 ByteString -> ByteString
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ByteString
"" Word8
0x53 Map Word8 ByteString
fields
          isError :: Bool
isError = ByteString
sev ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString
"ERROR", ByteString
"FATAL", ByteString
"PANIC"]
          line1 :: ByteString
line1 = (if ByteString -> Bool
ByteString.null ByteString
sev then ByteString
msg else ByteString
sev ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
":  " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
msg) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"
          -- Statement position ('P', 0x50): needs client query text
          stmtCtx :: ByteString
stmtCtx = case Word8 -> Map Word8 ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word8
0x50 Map Word8 ByteString
fields of
            Just ByteString
posStr
              | Bool -> Bool
not (ByteString -> Bool
ByteString.null ByteString
queryText) ->
                  ByteString -> (Int -> ByteString) -> Maybe Int -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (ByteString -> Int -> ByteString
positionContext ByteString
queryText) (ByteString -> Maybe Int
readPositiveInt ByteString
posStr)
            Maybe ByteString
_ -> ByteString
""
          -- Internal query+position ('q'=0x71, 'p'=0x70): both in wire fields
          intCtx :: ByteString
intCtx = case (Word8 -> Map Word8 ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word8
0x71 Map Word8 ByteString
fields, Word8 -> Map Word8 ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word8
0x70 Map Word8 ByteString
fields) of
            (Just ByteString
intQuery, Just ByteString
posStr) ->
              ByteString -> (Int -> ByteString) -> Maybe Int -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                ByteString
""
                (\Int
p -> ByteString -> Int -> ByteString
positionContext ByteString
intQuery Int
p ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"QUERY:  " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
intQuery ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n")
                (ByteString -> Maybe Int
readPositiveInt ByteString
posStr)
            (Maybe ByteString, Maybe ByteString)
_ -> ByteString
""
          detLine :: ByteString
detLine = case Word8 -> Map Word8 ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word8
0x44 Map Word8 ByteString
fields of
            Just ByteString
det -> ByteString
"DETAIL:  " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
det ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"
            Maybe ByteString
_ -> ByteString
""
          hntLine :: ByteString
hntLine = case Word8 -> Map Word8 ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word8
0x48 Map Word8 ByteString
fields of
            Just ByteString
hnt -> ByteString
"HINT:  " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
hnt ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"
            Maybe ByteString
_ -> ByteString
""
          ctxLine :: ByteString
ctxLine = case Word8 -> Map Word8 ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word8
0x57 Map Word8 ByteString
fields of
            Just ByteString
ctx | Bool
isError -> ByteString
"CONTEXT:  " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
ctx ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"
            Maybe ByteString
_ -> ByteString
""
       in ByteString
line1 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
stmtCtx ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
intCtx ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
detLine ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
hntLine ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
ctxLine

-- | Build the @LINE N: \<text\>\\n        \^\\n@ block for a 1-indexed position
-- within a query string, matching libpq's formatting exactly.
positionContext :: ByteString -> Int -> ByteString
positionContext :: ByteString -> Int -> ByteString
positionContext ByteString
query Int
pos =
  let pos0 :: Int
pos0 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      before :: ByteString
before = Int -> ByteString -> ByteString
ByteString.take Int
pos0 ByteString
query
      lineNum :: Int
lineNum = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
ByteString.length ((Word8 -> Bool) -> ByteString -> ByteString
ByteString.filter (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x0a) ByteString
before)
      lineStart :: Int
lineStart = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Word8 -> ByteString -> Maybe Int
ByteString.elemIndexEnd Word8
0x0a ByteString
before)
      col :: Int
col = Int
pos0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lineStart
      rest :: ByteString
rest = Int -> ByteString -> ByteString
ByteString.drop Int
lineStart ByteString
query
      lineText :: ByteString
lineText = (Word8 -> Bool) -> ByteString -> ByteString
ByteString.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0x0a) ByteString
rest
      prefix :: ByteString
prefix = String -> ByteString
ByteString.Char8.pack (String
"LINE " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
lineNum String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": ")
      caret :: ByteString
caret = Int -> Word8 -> ByteString
ByteString.replicate (ByteString -> Int
ByteString.length ByteString
prefix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
col) Word8
0x20 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"^\n"
   in ByteString
prefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
lineText ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
caret

readPositiveInt :: ByteString -> Maybe Int
readPositiveInt :: ByteString -> Maybe Int
readPositiveInt ByteString
bs = case ByteString -> Maybe (Int, ByteString)
ByteString.Char8.readInt ByteString
bs of
  Just (Int
n, ByteString
_) | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
  Maybe (Int, ByteString)
_ -> Maybe Int
forall a. Maybe a
Nothing

-- | Build a 'Result' whose fields close over the given fully materialized
-- 'NativeResult'.
mkResult :: NativeResult -> Result
mkResult :: NativeResult -> Result
mkResult NativeResult
result =
  Result
    { resultStatus :: IO ExecStatus
resultStatus = ExecStatus -> IO ExecStatus
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NativeResult -> ExecStatus
status NativeResult
result),
      resultErrorMessage :: IO (Maybe ByteString)
resultErrorMessage = Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Map Word8 ByteString -> ByteString
formatResultError (NativeResult -> ByteString
queryText NativeResult
result) (NativeResult -> Map Word8 ByteString
errorFields NativeResult
result))),
      resultErrorField :: FieldCode -> IO (Maybe ByteString)
resultErrorField = \FieldCode
field -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8 -> Map Word8 ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (FieldCode -> Word8
fieldCodeByte FieldCode
field) (NativeResult -> Map Word8 ByteString
errorFields NativeResult
result)),
      unsafeFreeResult :: IO ()
unsafeFreeResult = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (),
      ntuples :: IO Int32
ntuples = Int32 -> IO Int32
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([[Maybe ByteString]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (NativeResult -> [[Maybe ByteString]]
rows NativeResult
result))),
      nfields :: IO Int32
nfields = Int32 -> IO Int32
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([FieldDescription] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (NativeResult -> [FieldDescription]
fields NativeResult
result))),
      fname :: Int32 -> IO (Maybe ByteString)
fname = \Int32
column -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ do
        FieldDescription
fd <- [FieldDescription] -> Int32 -> Maybe FieldDescription
forall a. [a] -> Int32 -> Maybe a
atMay (NativeResult -> [FieldDescription]
fields NativeResult
result) Int32
column
        if ByteString -> Bool
ByteString.null (FieldDescription -> ByteString
name FieldDescription
fd) then Maybe ByteString
forall a. Maybe a
Nothing else ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (FieldDescription -> ByteString
name FieldDescription
fd),
      fnumber :: ByteString -> IO (Maybe Int32)
fnumber = \ByteString
colName ->
        Maybe Int32 -> IO (Maybe Int32)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> Maybe Int -> Maybe Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldDescription -> Bool) -> [FieldDescription] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\FieldDescription
field -> FieldDescription -> ByteString
name FieldDescription
field ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> ByteString
foldIdentifier ByteString
colName) (NativeResult -> [FieldDescription]
fields NativeResult
result)),
      ftable :: Int32 -> IO Word32
ftable = \Int32
column -> Word32 -> IO Word32
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32
-> (FieldDescription -> Word32) -> Maybe FieldDescription -> Word32
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word32
0 FieldDescription -> Word32
tableOid ([FieldDescription] -> Int32 -> Maybe FieldDescription
forall a. [a] -> Int32 -> Maybe a
atMay (NativeResult -> [FieldDescription]
fields NativeResult
result) Int32
column)),
      ftablecol :: Int32 -> IO Int32
ftablecol = \Int32
column ->
        Int32 -> IO Int32
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int32
-> (FieldDescription -> Int32) -> Maybe FieldDescription -> Int32
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int32
0 (\FieldDescription
field -> Int16 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FieldDescription -> Int16
columnAttributeNumber FieldDescription
field :: Int16)) ([FieldDescription] -> Int32 -> Maybe FieldDescription
forall a. [a] -> Int32 -> Maybe a
atMay (NativeResult -> [FieldDescription]
fields NativeResult
result) Int32
column)),
      fformat :: Int32 -> IO Format
fformat = \Int32
column ->
        Format -> IO Format
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Format
-> (FieldDescription -> Format) -> Maybe FieldDescription -> Format
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Format
Text (\FieldDescription
field -> Int16 -> Format
formatOf (FieldDescription -> Int16
formatCode FieldDescription
field)) ([FieldDescription] -> Int32 -> Maybe FieldDescription
forall a. [a] -> Int32 -> Maybe a
atMay (NativeResult -> [FieldDescription]
fields NativeResult
result) Int32
column)),
      ftype :: Int32 -> IO Word32
ftype = \Int32
column -> Word32 -> IO Word32
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32
-> (FieldDescription -> Word32) -> Maybe FieldDescription -> Word32
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word32
0 FieldDescription -> Word32
typeOid ([FieldDescription] -> Int32 -> Maybe FieldDescription
forall a. [a] -> Int32 -> Maybe a
atMay (NativeResult -> [FieldDescription]
fields NativeResult
result) Int32
column)),
      fmod :: Int32 -> IO Int
fmod = \Int32
column ->
        Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> (FieldDescription -> Int) -> Maybe FieldDescription -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (\FieldDescription
field -> Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FieldDescription -> Int32
typeModifier FieldDescription
field :: Int32)) ([FieldDescription] -> Int32 -> Maybe FieldDescription
forall a. [a] -> Int32 -> Maybe a
atMay (NativeResult -> [FieldDescription]
fields NativeResult
result) Int32
column)),
      fsize :: Int32 -> IO Int
fsize = \Int32
column ->
        Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> (FieldDescription -> Int) -> Maybe FieldDescription -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (\FieldDescription
field -> Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FieldDescription -> Int16
typeSize FieldDescription
field :: Int16)) ([FieldDescription] -> Int32 -> Maybe FieldDescription
forall a. [a] -> Int32 -> Maybe a
atMay (NativeResult -> [FieldDescription]
fields NativeResult
result) Int32
column)),
      getvalue :: Int32 -> Int32 -> IO (Maybe ByteString)
getvalue = \Int32
row Int32
column -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (NativeResult -> Int32 -> Int32 -> Maybe (Maybe ByteString)
cellAt NativeResult
result Int32
row Int32
column)),
      getvalue' :: Int32 -> Int32 -> IO (Maybe ByteString)
getvalue' = \Int32
row Int32
column -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (NativeResult -> Int32 -> Int32 -> Maybe (Maybe ByteString)
cellAt NativeResult
result Int32
row Int32
column)),
      getisnull :: Int32 -> Int32 -> IO Bool
getisnull = \Int32
row Int32
column -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
-> (Maybe ByteString -> Bool) -> Maybe (Maybe ByteString) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing (NativeResult -> Int32 -> Int32 -> Maybe (Maybe ByteString)
cellAt NativeResult
result Int32
row Int32
column)),
      getlength :: Int32 -> Int32 -> IO Int
getlength = \Int32
row Int32
column -> Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> (Maybe ByteString -> Int) -> Maybe (Maybe ByteString) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int -> (ByteString -> Int) -> Maybe ByteString -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 ByteString -> Int
ByteString.length) (NativeResult -> Int32 -> Int32 -> Maybe (Maybe ByteString)
cellAt NativeResult
result Int32
row Int32
column)),
      nparams :: IO Int32
nparams = Int32 -> IO Int32
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word32] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (NativeResult -> [Word32]
paramOids NativeResult
result))),
      paramtype :: Int32 -> IO Word32
paramtype = \Int32
index -> Word32 -> IO Word32
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32 -> Maybe Word32 -> Word32
forall a. a -> Maybe a -> a
fromMaybe Word32
0 ([Word32] -> Int32 -> Maybe Word32
forall a. [a] -> Int32 -> Maybe a
atMay (NativeResult -> [Word32]
paramOids NativeResult
result) Int32
index)),
      cmdStatus :: IO (Maybe ByteString)
cmdStatus = Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (NativeResult -> Maybe ByteString
commandTag NativeResult
result))),
      cmdTuples :: IO (Maybe ByteString)
cmdTuples = Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" ByteString -> ByteString
affectedRows (NativeResult -> Maybe ByteString
commandTag NativeResult
result)))
    }

-- | Build a 'Cancel' whose field closes over the given 'NativeCancel'.
mkCancel :: NativeCancel -> Cancel
mkCancel :: NativeCancel -> Cancel
mkCancel NativeCancel
nc =
  Cancel
    { cancel :: IO (Either ByteString ())
cancel = do
        Bool
pending <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (NativeCancel -> IORef Bool
asyncPendingRef NativeCancel
nc)
        if Bool -> Bool
not Bool
pending
          then Either ByteString () -> IO (Either ByteString ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either ByteString ()
forall a b. b -> Either a b
Right ())
          else do
            Transport
transport <- ByteString -> Int -> IO Transport
Transport.connect (NativeCancel -> ByteString
host NativeCancel
nc) (NativeCancel -> Int
port NativeCancel
nc)
            Transport -> Write -> IO ()
Transport.send Transport
transport (Int32 -> Int32 -> Write
cancelRequest (NativeCancel -> Int32
pid NativeCancel
nc) (NativeCancel -> Int32
secret NativeCancel
nc))
            -- Read until EOF to ensure the server has processed the cancel request
            -- before we close the connection. This matches libpq's PQcancel behavior
            -- and prevents the cancel signal from racing with the next query.
            Either IOException ()
_ <- forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (Transport -> IO ()
Transport.readUntilClosed Transport
transport)
            Transport -> IO ()
Transport.close Transport
transport
            Either ByteString () -> IO (Either ByteString ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either ByteString ()
forall a b. b -> Either a b
Right ())
    }

-- * Helpers for 'mkResult'

atMay :: [a] -> Int32 -> Maybe a
atMay :: forall a. [a] -> Int32 -> Maybe a
atMay [a]
xs Int32
i
  | Int32
i Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
0 = Maybe a
forall a. Maybe a
Nothing
  | Bool
otherwise = case Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i) [a]
xs of
      a
x : [a]
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
      [] -> Maybe a
forall a. Maybe a
Nothing

cellAt :: NativeResult -> Int32 -> Int32 -> Maybe (Maybe ByteString)
cellAt :: NativeResult -> Int32 -> Int32 -> Maybe (Maybe ByteString)
cellAt NativeResult
result Int32
row Int32
column = do
  [Maybe ByteString]
rowValues <- [[Maybe ByteString]] -> Int32 -> Maybe [Maybe ByteString]
forall a. [a] -> Int32 -> Maybe a
atMay (NativeResult -> [[Maybe ByteString]]
rows NativeResult
result) Int32
row
  [Maybe ByteString] -> Int32 -> Maybe (Maybe ByteString)
forall a. [a] -> Int32 -> Maybe a
atMay [Maybe ByteString]
rowValues Int32
column

formatOf :: Int16 -> Format
formatOf :: Int16 -> Format
formatOf = \case
  Int16
1 -> Format
Binary
  Int16
_ -> Format
Text

foldIdentifier :: ByteString -> ByteString
foldIdentifier :: ByteString -> ByteString
foldIdentifier = [Word8] -> ByteString
ByteString.pack ([Word8] -> ByteString)
-> (ByteString -> [Word8]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> [Word8]
forall {a}. (Num a, Ord a) => [a] -> [a]
outside ([Word8] -> [Word8])
-> (ByteString -> [Word8]) -> ByteString -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
ByteString.unpack
  where
    quote :: a
quote = a
0x22
    outside :: [a] -> [a]
outside = \case
      [] -> []
      a
c : [a]
rest
        | a
c a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall {a}. Num a => a
quote -> [a] -> [a]
inside [a]
rest
        | Bool
otherwise -> a -> a
forall {a}. (Ord a, Num a) => a -> a
asciiToLower a
c a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
outside [a]
rest
    inside :: [a] -> [a]
inside = \case
      [] -> []
      a
c : [a]
rest
        | a
c a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall {a}. Num a => a
quote -> case [a]
rest of
            a
c' : [a]
rest' | a
c' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
forall {a}. Num a => a
quote -> a
forall {a}. Num a => a
quote a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
inside [a]
rest'
            [a]
_ -> [a] -> [a]
outside [a]
rest
        | Bool
otherwise -> a
c a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
inside [a]
rest
    asciiToLower :: a -> a
asciiToLower a
c
      | a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0x41 Bool -> Bool -> Bool
&& a
c a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0x5a = a
c a -> a -> a
forall a. Num a => a -> a -> a
+ a
0x20
      | Bool
otherwise = a
c

fieldCodeByte :: FieldCode -> Word8
fieldCodeByte :: FieldCode -> Word8
fieldCodeByte = \case
  FieldCode
DiagSeverity -> Word8
0x53 -- 'S'
  FieldCode
DiagSqlstate -> Word8
0x43 -- 'C'
  FieldCode
DiagMessagePrimary -> Word8
0x4d -- 'M'
  FieldCode
DiagMessageDetail -> Word8
0x44 -- 'D'
  FieldCode
DiagMessageHint -> Word8
0x48 -- 'H'
  FieldCode
DiagStatementPosition -> Word8
0x50 -- 'P'
  FieldCode
DiagInternalPosition -> Word8
0x70 -- 'p'
  FieldCode
DiagInternalQuery -> Word8
0x71 -- 'q'
  FieldCode
DiagContext -> Word8
0x57 -- 'W'
  FieldCode
DiagSourceFile -> Word8
0x46 -- 'F'
  FieldCode
DiagSourceLine -> Word8
0x4c -- 'L'
  FieldCode
DiagSourceFunction -> Word8
0x52 -- 'R'

-- | The affected-row count from a @CommandComplete@ tag, matching
-- @PQcmdTuples@: the last whitespace-delimited token if it is all digits (which
-- covers @INSERT oid rows@, @UPDATE n@, @SELECT n@, …), else empty.
affectedRows :: ByteString -> ByteString
affectedRows :: ByteString -> ByteString
affectedRows ByteString
tag =
  case ByteString -> [ByteString]
ByteString.Char8.words ByteString
tag of
    [] -> ByteString
""
    [ByteString]
tokens ->
      let final :: ByteString
final = [ByteString] -> ByteString
forall a. HasCallStack => [a] -> a
last [ByteString]
tokens
       in if Bool -> Bool
not (ByteString -> Bool
ByteString.null ByteString
final) Bool -> Bool -> Bool
&& (Char -> Bool) -> ByteString -> Bool
ByteString.Char8.all Char -> Bool
isDigit ByteString
final
            then ByteString
final
            else ByteString
""