{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
-- Copyright 2010, 2011, 2012, 2013 Chris Forno
-- Copyright 2014-2018 Dylan Simon

-- |The Protocol module allows for direct, low-level communication with a
--  PostgreSQL server over TCP/IP. You probably don't want to use this module
--  directly.

module Database.PostgreSQL.Typed.Protocol ( 
    PGDatabase(..)
  , defaultPGDatabase
  , PGConnection
  , PGError(..)
#ifdef VERSION_tls
  , PGTlsMode(..)
  , PGTlsValidateMode (..)
#endif
  , pgErrorCode
  , pgConnectionDatabase
  , pgTypeEnv
  , pgConnect
  , pgDisconnect
  , pgReconnect
  -- * Query operations
  , pgDescribe
  , pgSimpleQuery
  , pgSimpleQueries_
  , pgPreparedQuery
  , pgPreparedLazyQuery
  , pgCloseStatement
  -- * Transactions
  , pgBegin
  , pgCommit
  , pgRollback
  , pgCommitAll
  , pgRollbackAll
  , pgTransaction
  -- * HDBC support
  , pgDisconnectOnce
  , pgRun
  , PGPreparedStatement
  , pgPrepare
  , pgClose
  , PGColDescription(..)
  , PGRowDescription
  , pgBind
  , pgFetch
  -- * Notifications
  , PGNotification(..)
  , pgGetNotification
  , pgGetNotifications
#ifdef VERSION_tls
  -- * TLS Helpers
  , pgTlsValidate
#endif
  , pgSupportsTls
  ) where

#if !MIN_VERSION_base(4,8,0)
import           Control.Applicative ((<$>), (<$))
#endif
import           Control.Arrow ((&&&), first, second)
import           Control.Exception (Exception, onException, finally, throwIO)
#ifdef VERSION_tls
import           Control.Exception (catch)
#endif
import           Control.Monad (void, liftM2, replicateM, when, unless)
#ifdef VERSION_cryptonite
import qualified Crypto.Hash as Hash
import qualified Data.ByteArray.Encoding as BA
#endif
import qualified Data.Binary.Get as G
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Char8 as BSC
import           Data.ByteString.Internal (w2c, createAndTrim)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSLC
import           Data.ByteString.Lazy.Internal (smallChunkSize)
#ifdef VERSION_tls
import           Data.Default (def)
#endif
import qualified Data.Foldable as Fold
import           Data.IORef (IORef, newIORef, writeIORef, readIORef, atomicModifyIORef, atomicModifyIORef', modifyIORef')
import           Data.Int (Int32, Int16)
import qualified Data.Map.Lazy as Map
import           Data.Maybe (fromMaybe)
import           Data.Monoid ((<>))
#if !MIN_VERSION_base(4,8,0)
import           Data.Monoid (mempty)
#endif
import           Data.Time.Clock (getCurrentTime)
import           Data.Tuple (swap)
import           Data.Typeable (Typeable)
#if !MIN_VERSION_base(4,8,0)
import           Data.Word (Word)
#endif
import           Data.Word (Word32, Word8)
#ifdef VERSION_tls
import           Data.X509 (SignedCertificate, HashALG(HashSHA256))
import           Data.X509.Memory (readSignedObjectFromMemory)
import           Data.X509.CertificateStore (makeCertificateStore)
import qualified Data.X509.Validation
#endif
#ifndef mingw32_HOST_OS
import           Foreign.C.Error (eWOULDBLOCK, getErrno, errnoToIOError)
import           Foreign.C.Types (CChar(..), CInt(..), CSize(..))
import           Foreign.Ptr (Ptr, castPtr)
import           GHC.IO.Exception (IOErrorType(InvalidArgument))
#endif
import qualified Network.Socket as Net
import qualified Network.Socket.ByteString as NetBS
import qualified Network.Socket.ByteString.Lazy as NetBSL
#ifdef VERSION_tls
import qualified Network.TLS as TLS
import qualified Network.TLS.Extra.Cipher as TLS
#endif
import           System.IO (stderr, hPutStrLn)
import           System.IO.Error (IOError, mkIOError, eofErrorType, ioError, ioeSetErrorString)
import           System.IO.Unsafe (unsafeInterleaveIO)
import           Text.Read (readMaybe)
import           Text.Show.Functions ()

import Database.PostgreSQL.Typed.Types
import Database.PostgreSQL.Typed.Dynamic

data PGState
  = StateUnsync -- no Sync
  | StatePending -- expecting ReadyForQuery
  -- ReadyForQuery received:
  | StateIdle
  | StateTransaction
  | StateTransactionFailed
  -- Terminate sent or EOF received
  | StateClosed
  deriving (Int -> PGState -> ShowS
[PGState] -> ShowS
PGState -> String
(Int -> PGState -> ShowS)
-> (PGState -> String) -> ([PGState] -> ShowS) -> Show PGState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGState] -> ShowS
$cshowList :: [PGState] -> ShowS
show :: PGState -> String
$cshow :: PGState -> String
showsPrec :: Int -> PGState -> ShowS
$cshowsPrec :: Int -> PGState -> ShowS
Show, PGState -> PGState -> Bool
(PGState -> PGState -> Bool)
-> (PGState -> PGState -> Bool) -> Eq PGState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PGState -> PGState -> Bool
$c/= :: PGState -> PGState -> Bool
== :: PGState -> PGState -> Bool
$c== :: PGState -> PGState -> Bool
Eq)

#ifdef VERSION_tls
data PGTlsValidateMode
  = TlsValidateFull
  -- ^ Equivalent to sslmode=verify-full. Ie: Check the FQHN against the
  -- certicate's CN
  | TlsValidateCA
  -- ^ Equivalent to sslmode=verify-ca. Ie: Only check that the certificate has
  -- been signed by the root certificate we provide
  deriving (Int -> PGTlsValidateMode -> ShowS
[PGTlsValidateMode] -> ShowS
PGTlsValidateMode -> String
(Int -> PGTlsValidateMode -> ShowS)
-> (PGTlsValidateMode -> String)
-> ([PGTlsValidateMode] -> ShowS)
-> Show PGTlsValidateMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGTlsValidateMode] -> ShowS
$cshowList :: [PGTlsValidateMode] -> ShowS
show :: PGTlsValidateMode -> String
$cshow :: PGTlsValidateMode -> String
showsPrec :: Int -> PGTlsValidateMode -> ShowS
$cshowsPrec :: Int -> PGTlsValidateMode -> ShowS
Show, PGTlsValidateMode -> PGTlsValidateMode -> Bool
(PGTlsValidateMode -> PGTlsValidateMode -> Bool)
-> (PGTlsValidateMode -> PGTlsValidateMode -> Bool)
-> Eq PGTlsValidateMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PGTlsValidateMode -> PGTlsValidateMode -> Bool
$c/= :: PGTlsValidateMode -> PGTlsValidateMode -> Bool
== :: PGTlsValidateMode -> PGTlsValidateMode -> Bool
$c== :: PGTlsValidateMode -> PGTlsValidateMode -> Bool
Eq)

data PGTlsMode
  = TlsDisabled
  -- ^ TLS is disabled
  | TlsNoValidate
  | TlsValidate PGTlsValidateMode SignedCertificate
  deriving (PGTlsMode -> PGTlsMode -> Bool
(PGTlsMode -> PGTlsMode -> Bool)
-> (PGTlsMode -> PGTlsMode -> Bool) -> Eq PGTlsMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PGTlsMode -> PGTlsMode -> Bool
$c/= :: PGTlsMode -> PGTlsMode -> Bool
== :: PGTlsMode -> PGTlsMode -> Bool
$c== :: PGTlsMode -> PGTlsMode -> Bool
Eq, Int -> PGTlsMode -> ShowS
[PGTlsMode] -> ShowS
PGTlsMode -> String
(Int -> PGTlsMode -> ShowS)
-> (PGTlsMode -> String)
-> ([PGTlsMode] -> ShowS)
-> Show PGTlsMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGTlsMode] -> ShowS
$cshowList :: [PGTlsMode] -> ShowS
show :: PGTlsMode -> String
$cshow :: PGTlsMode -> String
showsPrec :: Int -> PGTlsMode -> ShowS
$cshowsPrec :: Int -> PGTlsMode -> ShowS
Show)

-- | Constructs a 'PGTlsMode' to validate the server certificate with given root
-- certificate (in PEM format)
pgTlsValidate :: PGTlsValidateMode -> BSC.ByteString -> Either String PGTlsMode
pgTlsValidate :: PGTlsValidateMode -> ByteString -> Either String PGTlsMode
pgTlsValidate PGTlsValidateMode
mode ByteString
certPem =
  case ByteString -> [SignedExact Certificate]
forall a.
(ASN1Object a, Eq a, Show a) =>
ByteString -> [SignedExact a]
readSignedObjectFromMemory ByteString
certPem of
    []  -> String -> Either String PGTlsMode
forall a b. a -> Either a b
Left String
"Could not parse any certificate in PEM"
    (SignedExact Certificate
x:[SignedExact Certificate]
_) -> PGTlsMode -> Either String PGTlsMode
forall a b. b -> Either a b
Right (PGTlsValidateMode -> SignedExact Certificate -> PGTlsMode
TlsValidate PGTlsValidateMode
mode SignedExact Certificate
x)

pgSupportsTls :: PGConnection -> Bool
pgSupportsTls :: PGConnection -> Bool
pgSupportsTls PGConnection{connHandle :: PGConnection -> PGHandle
connHandle=PGTlsContext Context
_} = Bool
True
pgSupportsTls PGConnection
_ = Bool
False
#else
pgSupportsTls :: PGConnection -> Bool
pgSupportsTls _ = False
#endif

-- |Information for how to connect to a database, to be passed to 'pgConnect'.
data PGDatabase = PGDatabase
  { PGDatabase -> Either (String, String) SockAddr
pgDBAddr :: Either (Net.HostName, Net.ServiceName) Net.SockAddr -- ^ The address to connect to the server
  , PGDatabase -> ByteString
pgDBName :: BS.ByteString -- ^ The name of the database
  , PGDatabase -> ByteString
pgDBUser, PGDatabase -> ByteString
pgDBPass :: BS.ByteString
  , PGDatabase -> [(ByteString, ByteString)]
pgDBParams :: [(BS.ByteString, BS.ByteString)] -- ^ Extra parameters to set for the connection (e.g., ("TimeZone", "UTC"))
  , PGDatabase -> Bool
pgDBDebug :: Bool -- ^ Log all low-level server messages
  , PGDatabase -> MessageFields -> IO ()
pgDBLogMessage :: MessageFields -> IO () -- ^ How to log server notice messages (e.g., @print . PGError@)
#ifdef VERSION_tls
  , PGDatabase -> PGTlsMode
pgDBTLS :: PGTlsMode -- ^ TLS mode
#endif
  } deriving (Int -> PGDatabase -> ShowS
[PGDatabase] -> ShowS
PGDatabase -> String
(Int -> PGDatabase -> ShowS)
-> (PGDatabase -> String)
-> ([PGDatabase] -> ShowS)
-> Show PGDatabase
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGDatabase] -> ShowS
$cshowList :: [PGDatabase] -> ShowS
show :: PGDatabase -> String
$cshow :: PGDatabase -> String
showsPrec :: Int -> PGDatabase -> ShowS
$cshowsPrec :: Int -> PGDatabase -> ShowS
Show)

instance Eq PGDatabase where
#ifdef VERSION_tls
  PGDatabase Either (String, String) SockAddr
a1 ByteString
n1 ByteString
u1 ByteString
p1 [(ByteString, ByteString)]
l1 Bool
_ MessageFields -> IO ()
_ PGTlsMode
s1 == :: PGDatabase -> PGDatabase -> Bool
== PGDatabase Either (String, String) SockAddr
a2 ByteString
n2 ByteString
u2 ByteString
p2 [(ByteString, ByteString)]
l2 Bool
_ MessageFields -> IO ()
_ PGTlsMode
s2 =
    Either (String, String) SockAddr
a1 Either (String, String) SockAddr
-> Either (String, String) SockAddr -> Bool
forall a. Eq a => a -> a -> Bool
== Either (String, String) SockAddr
a2 Bool -> Bool -> Bool
&& ByteString
n1 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
n2 Bool -> Bool -> Bool
&& ByteString
u1 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
u2 Bool -> Bool -> Bool
&& ByteString
p1 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
p2 Bool -> Bool -> Bool
&& [(ByteString, ByteString)]
l1 [(ByteString, ByteString)] -> [(ByteString, ByteString)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(ByteString, ByteString)]
l2 Bool -> Bool -> Bool
&& PGTlsMode
s1 PGTlsMode -> PGTlsMode -> Bool
forall a. Eq a => a -> a -> Bool
== PGTlsMode
s2
#else
  PGDatabase a1 n1 u1 p1 l1 _ _ == PGDatabase a2 n2 u2 p2 l2 _ _ =
    a1 == a2 && n1 == n2 && u1 == u2 && p1 == p2 && l1 == l2
#endif

newtype PGPreparedStatement = PGPreparedStatement Integer
  deriving (PGPreparedStatement -> PGPreparedStatement -> Bool
(PGPreparedStatement -> PGPreparedStatement -> Bool)
-> (PGPreparedStatement -> PGPreparedStatement -> Bool)
-> Eq PGPreparedStatement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PGPreparedStatement -> PGPreparedStatement -> Bool
$c/= :: PGPreparedStatement -> PGPreparedStatement -> Bool
== :: PGPreparedStatement -> PGPreparedStatement -> Bool
$c== :: PGPreparedStatement -> PGPreparedStatement -> Bool
Eq, Int -> PGPreparedStatement -> ShowS
[PGPreparedStatement] -> ShowS
PGPreparedStatement -> String
(Int -> PGPreparedStatement -> ShowS)
-> (PGPreparedStatement -> String)
-> ([PGPreparedStatement] -> ShowS)
-> Show PGPreparedStatement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGPreparedStatement] -> ShowS
$cshowList :: [PGPreparedStatement] -> ShowS
show :: PGPreparedStatement -> String
$cshow :: PGPreparedStatement -> String
showsPrec :: Int -> PGPreparedStatement -> ShowS
$cshowsPrec :: Int -> PGPreparedStatement -> ShowS
Show)

preparedStatementName :: PGPreparedStatement -> BS.ByteString
preparedStatementName :: PGPreparedStatement -> ByteString
preparedStatementName (PGPreparedStatement Integer
n) = String -> ByteString
BSC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
n

data PGHandle
  = PGSocket Net.Socket
#ifdef VERSION_tls
  | PGTlsContext TLS.Context
#endif

pgPutBuilder :: PGHandle -> B.Builder -> IO ()
pgPutBuilder :: PGHandle -> Builder -> IO ()
pgPutBuilder (PGSocket Socket
s) Builder
b = Socket -> ByteString -> IO ()
NetBSL.sendAll Socket
s (Builder -> ByteString
B.toLazyByteString Builder
b)
#ifdef VERSION_tls
pgPutBuilder (PGTlsContext Context
c) Builder
b = Context -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
TLS.sendData Context
c (Builder -> ByteString
B.toLazyByteString Builder
b)
#endif

pgPut:: PGHandle -> BS.ByteString -> IO ()
pgPut :: PGHandle -> ByteString -> IO ()
pgPut (PGSocket Socket
s) ByteString
bs = Socket -> ByteString -> IO ()
NetBS.sendAll Socket
s ByteString
bs
#ifdef VERSION_tls
pgPut (PGTlsContext Context
c) ByteString
bs = Context -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
TLS.sendData Context
c ([ByteString] -> ByteString
BSL.fromChunks [ByteString
bs])
#endif

pgGetSome :: PGHandle -> Int -> IO BSC.ByteString
pgGetSome :: PGHandle -> Int -> IO ByteString
pgGetSome (PGSocket Socket
s) Int
count = Socket -> Int -> IO ByteString
NetBS.recv Socket
s Int
count
#ifdef VERSION_tls
pgGetSome (PGTlsContext Context
c) Int
_ = Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
TLS.recvData Context
c
#endif

pgCloseHandle :: PGHandle -> IO ()
pgCloseHandle :: PGHandle -> IO ()
pgCloseHandle (PGSocket Socket
s) = Socket -> IO ()
Net.close Socket
s
#ifdef VERSION_tls
pgCloseHandle (PGTlsContext Context
c) = do
  Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
TLS.bye Context
c IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOError
_ :: IOError) -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Context -> IO ()
TLS.contextClose Context
c
#endif

pgFlush :: PGConnection -> IO ()
pgFlush :: PGConnection -> IO ()
pgFlush PGConnection{connHandle :: PGConnection -> PGHandle
connHandle=PGSocket Socket
_} = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
#ifdef VERSION_tls
pgFlush PGConnection{connHandle :: PGConnection -> PGHandle
connHandle=PGTlsContext Context
c} = Context -> IO ()
TLS.contextFlush Context
c
#endif

-- |An established connection to the PostgreSQL server.
-- These objects are not thread-safe and must only be used for a single request at a time.
data PGConnection = PGConnection
  { PGConnection -> PGHandle
connHandle :: PGHandle
  , PGConnection -> PGDatabase
connDatabase :: !PGDatabase
  , PGConnection -> Word32
connPid :: !Word32 -- unused
  , PGConnection -> Word32
connKey :: !Word32 -- unused
  , PGConnection -> PGTypeEnv
connTypeEnv :: PGTypeEnv
  , PGConnection -> IORef (Map ByteString ByteString)
connParameters :: IORef (Map.Map BS.ByteString BS.ByteString)
  , PGConnection -> IORef Integer
connPreparedStatementCount :: IORef Integer
  , PGConnection
-> IORef (Map (ByteString, [Word32]) PGPreparedStatement)
connPreparedStatementMap :: IORef (Map.Map (BS.ByteString, [OID]) PGPreparedStatement)
  , PGConnection -> IORef PGState
connState :: IORef PGState
  , PGConnection -> IORef (Decoder PGBackendMessage)
connInput :: IORef (G.Decoder PGBackendMessage)
  , PGConnection -> IORef Word
connTransaction :: IORef Word
  , PGConnection -> IORef (Queue PGNotification)
connNotifications :: IORef (Queue PGNotification)
  }

data PGColDescription = PGColDescription
  { PGColDescription -> ByteString
pgColName :: BS.ByteString
  , PGColDescription -> Word32
pgColTable :: !OID
  , PGColDescription -> Int16
pgColNumber :: !Int16
  , PGColDescription -> Word32
pgColType :: !OID
  , PGColDescription -> Int16
pgColSize :: !Int16
  , PGColDescription -> Int32
pgColModifier :: !Int32
  , PGColDescription -> Bool
pgColBinary :: !Bool
  } deriving (Int -> PGColDescription -> ShowS
[PGColDescription] -> ShowS
PGColDescription -> String
(Int -> PGColDescription -> ShowS)
-> (PGColDescription -> String)
-> ([PGColDescription] -> ShowS)
-> Show PGColDescription
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGColDescription] -> ShowS
$cshowList :: [PGColDescription] -> ShowS
show :: PGColDescription -> String
$cshow :: PGColDescription -> String
showsPrec :: Int -> PGColDescription -> ShowS
$cshowsPrec :: Int -> PGColDescription -> ShowS
Show)
type PGRowDescription = [PGColDescription]

type MessageFields = Map.Map Char BS.ByteString

data PGNotification = PGNotification
  { PGNotification -> Word32
pgNotificationPid :: !Word32
  , PGNotification -> ByteString
pgNotificationChannel :: !BS.ByteString
  , PGNotification -> ByteString
pgNotificationPayload :: BSL.ByteString
  } deriving (Int -> PGNotification -> ShowS
[PGNotification] -> ShowS
PGNotification -> String
(Int -> PGNotification -> ShowS)
-> (PGNotification -> String)
-> ([PGNotification] -> ShowS)
-> Show PGNotification
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGNotification] -> ShowS
$cshowList :: [PGNotification] -> ShowS
show :: PGNotification -> String
$cshow :: PGNotification -> String
showsPrec :: Int -> PGNotification -> ShowS
$cshowsPrec :: Int -> PGNotification -> ShowS
Show)

-- |Simple amortized fifo
data Queue a = Queue [a] [a]

emptyQueue :: Queue a
emptyQueue :: Queue a
emptyQueue = [a] -> [a] -> Queue a
forall a. [a] -> [a] -> Queue a
Queue [] []

enQueue :: a -> Queue a -> Queue a
enQueue :: a -> Queue a -> Queue a
enQueue a
a (Queue [a]
e [a]
d) = [a] -> [a] -> Queue a
forall a. [a] -> [a] -> Queue a
Queue (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
e) [a]
d

deQueue :: Queue a -> (Queue a, Maybe a)
deQueue :: Queue a -> (Queue a, Maybe a)
deQueue (Queue [a]
e (a
x:[a]
d)) = ([a] -> [a] -> Queue a
forall a. [a] -> [a] -> Queue a
Queue [a]
e [a]
d, a -> Maybe a
forall a. a -> Maybe a
Just a
x)
deQueue (Queue ([a] -> [a]
forall a. [a] -> [a]
reverse -> a
x:[a]
d) []) = ([a] -> [a] -> Queue a
forall a. [a] -> [a] -> Queue a
Queue [] [a]
d, a -> Maybe a
forall a. a -> Maybe a
Just a
x)
deQueue Queue a
q = (Queue a
q, Maybe a
forall a. Maybe a
Nothing)

-- |PGFrontendMessage represents a PostgreSQL protocol message that we'll send.
-- See <http://www.postgresql.org/docs/current/interactive/protocol-message-formats.html>.
data PGFrontendMessage
  = StartupMessage [(BS.ByteString, BS.ByteString)] -- only sent first
  | CancelRequest !Word32 !Word32 -- sent first on separate connection
  | Bind { PGFrontendMessage -> ByteString
portalName :: BS.ByteString, PGFrontendMessage -> ByteString
statementName :: BS.ByteString, PGFrontendMessage -> PGValues
bindParameters :: PGValues, PGFrontendMessage -> [Bool]
binaryColumns :: [Bool] }
  | CloseStatement { statementName :: BS.ByteString }
  | ClosePortal { portalName :: BS.ByteString }
  -- |Describe a SQL query/statement. The SQL string can contain
  --  parameters ($1, $2, etc.).
  | DescribeStatement { statementName :: BS.ByteString }
  | DescribePortal { portalName :: BS.ByteString }
  | Execute { portalName :: BS.ByteString, PGFrontendMessage -> Word32
executeRows :: !Word32 }
  | Flush
  -- |Parse SQL Destination (prepared statement)
  | Parse { statementName :: BS.ByteString, PGFrontendMessage -> ByteString
queryString :: BSL.ByteString, PGFrontendMessage -> [Word32]
parseTypes :: [OID] }
  | PasswordMessage BS.ByteString
  -- |SimpleQuery takes a simple SQL string. Parameters ($1, $2,
  --  etc.) aren't allowed.
  | SimpleQuery { queryString :: BSL.ByteString }
  | Sync
  | Terminate
  deriving (Int -> PGFrontendMessage -> ShowS
[PGFrontendMessage] -> ShowS
PGFrontendMessage -> String
(Int -> PGFrontendMessage -> ShowS)
-> (PGFrontendMessage -> String)
-> ([PGFrontendMessage] -> ShowS)
-> Show PGFrontendMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGFrontendMessage] -> ShowS
$cshowList :: [PGFrontendMessage] -> ShowS
show :: PGFrontendMessage -> String
$cshow :: PGFrontendMessage -> String
showsPrec :: Int -> PGFrontendMessage -> ShowS
$cshowsPrec :: Int -> PGFrontendMessage -> ShowS
Show)

-- |PGBackendMessage represents a PostgreSQL protocol message that we'll receive.
-- See <http://www.postgresql.org/docs/current/interactive/protocol-message-formats.html>.
data PGBackendMessage
  = AuthenticationOk
  | AuthenticationCleartextPassword
  | AuthenticationMD5Password BS.ByteString
  -- AuthenticationSCMCredential
  | BackendKeyData Word32 Word32
  | BindComplete
  | CloseComplete
  | CommandComplete BS.ByteString
  -- |Each DataRow (result of a query) is a list of 'PGValue', which are assumed to be text unless known to be otherwise.
  | DataRow PGValues
  | EmptyQueryResponse
  -- |An ErrorResponse contains the severity, "SQLSTATE", and
  --  message of an error. See
  --  <http://www.postgresql.org/docs/current/interactive/protocol-error-fields.html>.
  | ErrorResponse { PGBackendMessage -> MessageFields
messageFields :: MessageFields }
  | NoData
  | NoticeResponse { messageFields :: MessageFields }
  | NotificationResponse PGNotification
  -- |A ParameterDescription describes the type of a given SQL
  --  query/statement parameter ($1, $2, etc.). Unfortunately,
  --  PostgreSQL does not give us nullability information for the
  --  parameter.
  | ParameterDescription [OID]
  | ParameterStatus BS.ByteString BS.ByteString
  | ParseComplete
  | PortalSuspended
  | ReadyForQuery PGState
  -- |A RowDescription contains the name, type, table OID, and
  --  column number of the resulting columns(s) of a query. The
  --  column number is useful for inferring nullability.
  | RowDescription PGRowDescription
  deriving (Int -> PGBackendMessage -> ShowS
[PGBackendMessage] -> ShowS
PGBackendMessage -> String
(Int -> PGBackendMessage -> ShowS)
-> (PGBackendMessage -> String)
-> ([PGBackendMessage] -> ShowS)
-> Show PGBackendMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGBackendMessage] -> ShowS
$cshowList :: [PGBackendMessage] -> ShowS
show :: PGBackendMessage -> String
$cshow :: PGBackendMessage -> String
showsPrec :: Int -> PGBackendMessage -> ShowS
$cshowsPrec :: Int -> PGBackendMessage -> ShowS
Show)

-- |PGException is thrown upon encountering an 'ErrorResponse' with severity of
--  ERROR, FATAL, or PANIC. It holds the message of the error.
newtype PGError = PGError { PGError -> MessageFields
pgErrorFields :: MessageFields }
  deriving (Typeable)

instance Show PGError where
  show :: PGError -> String
show (PGError MessageFields
m) = MessageFields -> String
displayMessage MessageFields
m

instance Exception PGError

-- |Produce a human-readable string representing the message
displayMessage :: MessageFields -> String
displayMessage :: MessageFields -> String
displayMessage MessageFields
m = String
"PG" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
f Char
'S' String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
fC then String
": " else String
" [" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fC String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]: ") String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
f Char
'M' String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
fD then String
fD else Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
: String
fD)
  where
  fC :: String
fC = Char -> String
f Char
'C'
  fD :: String
fD = Char -> String
f Char
'D'
  f :: Char -> String
f Char
c = ByteString -> String
BSC.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Char -> MessageFields -> ByteString
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ByteString
BS.empty Char
c MessageFields
m

makeMessage :: BS.ByteString -> BS.ByteString -> MessageFields
makeMessage :: ByteString -> ByteString -> MessageFields
makeMessage ByteString
m ByteString
d = [(Char, ByteString)] -> MessageFields
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList [(Char
'D', ByteString
d), (Char
'M', ByteString
m)]

-- |Message SQLState code.
--  See <http://www.postgresql.org/docs/current/static/errcodes-appendix.html>.
pgErrorCode :: PGError -> BS.ByteString
pgErrorCode :: PGError -> ByteString
pgErrorCode (PGError MessageFields
e) = ByteString -> Char -> MessageFields -> ByteString
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ByteString
BS.empty Char
'C' MessageFields
e

defaultLogMessage :: MessageFields -> IO ()
defaultLogMessage :: MessageFields -> IO ()
defaultLogMessage = Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ())
-> (MessageFields -> String) -> MessageFields -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessageFields -> String
displayMessage

-- |A database connection with sane defaults:
-- localhost:5432:postgres
defaultPGDatabase :: PGDatabase
defaultPGDatabase :: PGDatabase
defaultPGDatabase = PGDatabase :: Either (String, String) SockAddr
-> ByteString
-> ByteString
-> ByteString
-> [(ByteString, ByteString)]
-> Bool
-> (MessageFields -> IO ())
-> PGTlsMode
-> PGDatabase
PGDatabase
  { pgDBAddr :: Either (String, String) SockAddr
pgDBAddr = SockAddr -> Either (String, String) SockAddr
forall a b. b -> Either a b
Right (SockAddr -> Either (String, String) SockAddr)
-> SockAddr -> Either (String, String) SockAddr
forall a b. (a -> b) -> a -> b
$ PortNumber -> Word32 -> SockAddr
Net.SockAddrInet PortNumber
5432 ((Word8, Word8, Word8, Word8) -> Word32
Net.tupleToHostAddress (Word8
127,Word8
0,Word8
0,Word8
1))
  , pgDBName :: ByteString
pgDBName = ByteString
"postgres"
  , pgDBUser :: ByteString
pgDBUser = ByteString
"postgres"
  , pgDBPass :: ByteString
pgDBPass = ByteString
BS.empty
  , pgDBParams :: [(ByteString, ByteString)]
pgDBParams = []
  , pgDBDebug :: Bool
pgDBDebug = Bool
False
  , pgDBLogMessage :: MessageFields -> IO ()
pgDBLogMessage = MessageFields -> IO ()
defaultLogMessage
#ifdef VERSION_tls
  , pgDBTLS :: PGTlsMode
pgDBTLS = PGTlsMode
TlsDisabled
#endif
  }

connDebugMsg :: PGConnection -> String -> IO ()
connDebugMsg :: PGConnection -> String -> IO ()
connDebugMsg PGConnection
c String
msg = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PGDatabase -> Bool
pgDBDebug (PGDatabase -> Bool) -> PGDatabase -> Bool
forall a b. (a -> b) -> a -> b
$ PGConnection -> PGDatabase
connDatabase PGConnection
c) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  UTCTime
t <- IO UTCTime
getCurrentTime
  Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
forall a. Show a => a -> String
show UTCTime
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg

connLogMessage :: PGConnection -> MessageFields -> IO ()
connLogMessage :: PGConnection -> MessageFields -> IO ()
connLogMessage = PGDatabase -> MessageFields -> IO ()
pgDBLogMessage (PGDatabase -> MessageFields -> IO ())
-> (PGConnection -> PGDatabase)
-> PGConnection
-> MessageFields
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGConnection -> PGDatabase
connDatabase

-- |The database information for this connection.
pgConnectionDatabase :: PGConnection -> PGDatabase
pgConnectionDatabase :: PGConnection -> PGDatabase
pgConnectionDatabase = PGConnection -> PGDatabase
connDatabase

-- |The type environment for this connection.
pgTypeEnv :: PGConnection -> PGTypeEnv
pgTypeEnv :: PGConnection -> PGTypeEnv
pgTypeEnv = PGConnection -> PGTypeEnv
connTypeEnv

#ifdef VERSION_cryptonite
md5 :: BS.ByteString -> BS.ByteString
md5 :: ByteString -> ByteString
md5 = Base -> Digest MD5 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
BA.convertToBase Base
BA.Base16 (Digest MD5 -> ByteString)
-> (ByteString -> Digest MD5) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Digest MD5
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Hash.hash :: BS.ByteString -> Hash.Digest Hash.MD5)
#endif


nul :: B.Builder
nul :: Builder
nul = Word8 -> Builder
B.word8 Word8
0

byteStringNul :: BS.ByteString -> B.Builder
byteStringNul :: ByteString -> Builder
byteStringNul ByteString
s = ByteString -> Builder
B.byteString ByteString
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
nul

lazyByteStringNul :: BSL.ByteString -> B.Builder
lazyByteStringNul :: ByteString -> Builder
lazyByteStringNul ByteString
s = ByteString -> Builder
B.lazyByteString ByteString
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
nul

-- |Given a message, determine the (optional) type ID and the body
messageBody :: PGFrontendMessage -> (Maybe Char, B.Builder)
messageBody :: PGFrontendMessage -> (Maybe Char, Builder)
messageBody (StartupMessage [(ByteString, ByteString)]
kv) = (Maybe Char
forall a. Maybe a
Nothing, Word32 -> Builder
B.word32BE Word32
0x30000
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ((ByteString, ByteString) -> Builder)
-> [(ByteString, ByteString)] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Fold.foldMap (\(ByteString
k, ByteString
v) -> ByteString -> Builder
byteStringNul ByteString
k Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteStringNul ByteString
v) [(ByteString, ByteString)]
kv Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
nul)
messageBody (CancelRequest Word32
pid Word32
key) = (Maybe Char
forall a. Maybe a
Nothing, Word32 -> Builder
B.word32BE Word32
80877102
  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
B.word32BE Word32
pid Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
B.word32BE Word32
key)
messageBody Bind{ portalName :: PGFrontendMessage -> ByteString
portalName = ByteString
d, statementName :: PGFrontendMessage -> ByteString
statementName = ByteString
n, bindParameters :: PGFrontendMessage -> PGValues
bindParameters = PGValues
p, binaryColumns :: PGFrontendMessage -> [Bool]
binaryColumns = [Bool]
bc } = (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'B',
  ByteString -> Builder
byteStringNul ByteString
d
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteStringNul ByteString
n
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (if (PGValue -> Bool) -> PGValues -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PGValue -> Bool
fmt PGValues
p
          then Word16 -> Builder
B.word16BE (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ PGValues -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length PGValues
p) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (PGValue -> Builder) -> PGValues -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Fold.foldMap (Word16 -> Builder
B.word16BE (Word16 -> Builder) -> (PGValue -> Word16) -> PGValue -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> (PGValue -> Int) -> PGValue -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Int) -> (PGValue -> Bool) -> PGValue -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGValue -> Bool
fmt) PGValues
p
          else Word16 -> Builder
B.word16BE Word16
0)
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
B.word16BE (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ PGValues -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length PGValues
p) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (PGValue -> Builder) -> PGValues -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Fold.foldMap PGValue -> Builder
val PGValues
p
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
bc
          then Word16 -> Builder
B.word16BE (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ [Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool]
bc) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Bool -> Builder) -> [Bool] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Fold.foldMap (Word16 -> Builder
B.word16BE (Word16 -> Builder) -> (Bool -> Word16) -> Bool -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> (Bool -> Int) -> Bool -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum) [Bool]
bc
          else Word16 -> Builder
B.word16BE Word16
0))
  where
  fmt :: PGValue -> Bool
fmt (PGBinaryValue ByteString
_) = Bool
True
  fmt PGValue
_ = Bool
False
  val :: PGValue -> Builder
val PGValue
PGNullValue = Int32 -> Builder
B.int32BE (-Int32
1)
  val (PGTextValue ByteString
v) = Word32 -> Builder
B.word32BE (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
v) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.byteString ByteString
v
  val (PGBinaryValue ByteString
v) = Word32 -> Builder
B.word32BE (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
v) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.byteString ByteString
v
messageBody CloseStatement{ statementName :: PGFrontendMessage -> ByteString
statementName = ByteString
n } = (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'C', 
  Char -> Builder
B.char7 Char
'S' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteStringNul ByteString
n)
messageBody ClosePortal{ portalName :: PGFrontendMessage -> ByteString
portalName = ByteString
n } = (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'C', 
  Char -> Builder
B.char7 Char
'P' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteStringNul ByteString
n)
messageBody DescribeStatement{ statementName :: PGFrontendMessage -> ByteString
statementName = ByteString
n } = (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'D',
  Char -> Builder
B.char7 Char
'S' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteStringNul ByteString
n)
messageBody DescribePortal{ portalName :: PGFrontendMessage -> ByteString
portalName = ByteString
n } = (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'D',
  Char -> Builder
B.char7 Char
'P' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteStringNul ByteString
n)
messageBody Execute{ portalName :: PGFrontendMessage -> ByteString
portalName = ByteString
n, executeRows :: PGFrontendMessage -> Word32
executeRows = Word32
r } = (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'E',
  ByteString -> Builder
byteStringNul ByteString
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
B.word32BE Word32
r)
messageBody PGFrontendMessage
Flush = (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'H', Builder
forall a. Monoid a => a
mempty)
messageBody Parse{ statementName :: PGFrontendMessage -> ByteString
statementName = ByteString
n, queryString :: PGFrontendMessage -> ByteString
queryString = ByteString
s, parseTypes :: PGFrontendMessage -> [Word32]
parseTypes = [Word32]
t } = (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'P',
  ByteString -> Builder
byteStringNul ByteString
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
lazyByteStringNul ByteString
s
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
B.word16BE (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ [Word32] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word32]
t) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Word32 -> Builder) -> [Word32] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Fold.foldMap Word32 -> Builder
B.word32BE [Word32]
t)
messageBody (PasswordMessage ByteString
s) = (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'p',
  ByteString -> Builder
B.byteString ByteString
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
nul)
messageBody SimpleQuery{ queryString :: PGFrontendMessage -> ByteString
queryString = ByteString
s } = (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'Q',
  ByteString -> Builder
lazyByteStringNul ByteString
s)
messageBody PGFrontendMessage
Sync = (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'S', Builder
forall a. Monoid a => a
mempty)
messageBody PGFrontendMessage
Terminate = (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'X', Builder
forall a. Monoid a => a
mempty)

-- |Send a message to PostgreSQL (low-level).
pgSend :: PGConnection -> PGFrontendMessage -> IO ()
pgSend :: PGConnection -> PGFrontendMessage -> IO ()
pgSend c :: PGConnection
c@PGConnection{ connHandle :: PGConnection -> PGHandle
connHandle = PGHandle
h, connState :: PGConnection -> IORef PGState
connState = IORef PGState
sr } PGFrontendMessage
msg = do
  IORef PGState -> (PGState -> PGState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef PGState
sr ((PGState -> PGState) -> IO ()) -> (PGState -> PGState) -> IO ()
forall a b. (a -> b) -> a -> b
$ PGFrontendMessage -> PGState -> PGState
state PGFrontendMessage
msg
  PGConnection -> String -> IO ()
connDebugMsg PGConnection
c (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGFrontendMessage -> String
forall a. Show a => a -> String
show PGFrontendMessage
msg
  PGHandle -> Builder -> IO ()
pgPutBuilder PGHandle
h (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ (Char -> Builder) -> Maybe Char -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Fold.foldMap Char -> Builder
B.char7 Maybe Char
t Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
B.word32BE (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
b)
  PGHandle -> ByteString -> IO ()
pgPut PGHandle
h ByteString
b -- or B.hPutBuilder? But we've already had to convert to BS to get length
  where
  (Maybe Char
t, ByteString
b) = (Builder -> ByteString)
-> (Maybe Char, Builder) -> (Maybe Char, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
B.toLazyByteString) ((Maybe Char, Builder) -> (Maybe Char, ByteString))
-> (Maybe Char, Builder) -> (Maybe Char, ByteString)
forall a b. (a -> b) -> a -> b
$ PGFrontendMessage -> (Maybe Char, Builder)
messageBody PGFrontendMessage
msg
  state :: PGFrontendMessage -> PGState -> PGState
state PGFrontendMessage
_ PGState
StateClosed = PGState
StateClosed
  state PGFrontendMessage
Sync PGState
_ = PGState
StatePending
  state SimpleQuery{} PGState
_ = PGState
StatePending
  state PGFrontendMessage
Terminate PGState
_ = PGState
StateClosed
  state PGFrontendMessage
_ PGState
_ = PGState
StateUnsync


getByteStringNul :: G.Get BS.ByteString
getByteStringNul :: Get ByteString
getByteStringNul = (ByteString -> ByteString) -> Get ByteString -> Get ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
BSL.toStrict Get ByteString
G.getLazyByteStringNul

getMessageFields :: G.Get MessageFields
getMessageFields :: Get MessageFields
getMessageFields = Char -> Get MessageFields
g (Char -> Get MessageFields)
-> (Word8 -> Char) -> Word8 -> Get MessageFields
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Char
w2c (Word8 -> Get MessageFields) -> Get Word8 -> Get MessageFields
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word8
G.getWord8 where
  g :: Char -> Get MessageFields
g Char
'\0' = MessageFields -> Get MessageFields
forall (m :: * -> *) a. Monad m => a -> m a
return MessageFields
forall k a. Map k a
Map.empty
  g Char
f = (ByteString -> MessageFields -> MessageFields)
-> Get ByteString -> Get MessageFields -> Get MessageFields
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (Char -> ByteString -> MessageFields -> MessageFields
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Char
f) Get ByteString
getByteStringNul Get MessageFields
getMessageFields

-- |Parse an incoming message.
getMessageBody :: Char -> G.Get PGBackendMessage
getMessageBody :: Char -> Get PGBackendMessage
getMessageBody Char
'R' = Word32 -> Get PGBackendMessage
forall a. (Eq a, Num a, Show a) => a -> Get PGBackendMessage
auth (Word32 -> Get PGBackendMessage)
-> Get Word32 -> Get PGBackendMessage
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word32
G.getWord32be where
  auth :: a -> Get PGBackendMessage
auth a
0 = PGBackendMessage -> Get PGBackendMessage
forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
AuthenticationOk
  auth a
3 = PGBackendMessage -> Get PGBackendMessage
forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
AuthenticationCleartextPassword
  auth a
5 = ByteString -> PGBackendMessage
AuthenticationMD5Password (ByteString -> PGBackendMessage)
-> Get ByteString -> Get PGBackendMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
G.getByteString Int
4
  auth a
op = String -> Get PGBackendMessage
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get PGBackendMessage) -> String -> Get PGBackendMessage
forall a b. (a -> b) -> a -> b
$ String
"pgGetMessage: unsupported authentication type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
op
getMessageBody Char
't' = do
  Word16
numParams <- Get Word16
G.getWord16be
  [Word32] -> PGBackendMessage
ParameterDescription ([Word32] -> PGBackendMessage)
-> Get [Word32] -> Get PGBackendMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get Word32 -> Get [Word32]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
numParams) Get Word32
G.getWord32be
getMessageBody Char
'T' = do
  Word16
numFields <- Get Word16
G.getWord16be
  [PGColDescription] -> PGBackendMessage
RowDescription ([PGColDescription] -> PGBackendMessage)
-> Get [PGColDescription] -> Get PGBackendMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get PGColDescription -> Get [PGColDescription]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
numFields) Get PGColDescription
getField where
  getField :: Get PGColDescription
getField = do
    ByteString
name <- Get ByteString
getByteStringNul
    Word32
oid <- Get Word32
G.getWord32be -- table OID
    Word16
col <- Get Word16
G.getWord16be -- column number
    Word32
typ' <- Get Word32
G.getWord32be -- type
    Word16
siz <- Get Word16
G.getWord16be -- type size
    Word32
tmod <- Get Word32
G.getWord32be -- type modifier
    Word16
fmt <- Get Word16
G.getWord16be -- format code
    PGColDescription -> Get PGColDescription
forall (m :: * -> *) a. Monad m => a -> m a
return (PGColDescription -> Get PGColDescription)
-> PGColDescription -> Get PGColDescription
forall a b. (a -> b) -> a -> b
$ PGColDescription :: ByteString
-> Word32
-> Int16
-> Word32
-> Int16
-> Int32
-> Bool
-> PGColDescription
PGColDescription
      { pgColName :: ByteString
pgColName = ByteString
name
      , pgColTable :: Word32
pgColTable = Word32
oid
      , pgColNumber :: Int16
pgColNumber = Word16 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
col
      , pgColType :: Word32
pgColType = Word32
typ'
      , pgColSize :: Int16
pgColSize = Word16 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
siz
      , pgColModifier :: Int32
pgColModifier = Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
tmod
      , pgColBinary :: Bool
pgColBinary = Int -> Bool
forall a. Enum a => Int -> a
toEnum (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
fmt)
      }
getMessageBody Char
'Z' = PGState -> PGBackendMessage
ReadyForQuery (PGState -> PGBackendMessage)
-> Get PGState -> Get PGBackendMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Get PGState
forall (m :: * -> *). MonadFail m => Char -> m PGState
rs (Char -> Get PGState) -> (Word8 -> Char) -> Word8 -> Get PGState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Char
w2c (Word8 -> Get PGState) -> Get Word8 -> Get PGState
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word8
G.getWord8) where
  rs :: Char -> m PGState
rs Char
'I' = PGState -> m PGState
forall (m :: * -> *) a. Monad m => a -> m a
return PGState
StateIdle
  rs Char
'T' = PGState -> m PGState
forall (m :: * -> *) a. Monad m => a -> m a
return PGState
StateTransaction
  rs Char
'E' = PGState -> m PGState
forall (m :: * -> *) a. Monad m => a -> m a
return PGState
StateTransactionFailed
  rs Char
s = String -> m PGState
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m PGState) -> String -> m PGState
forall a b. (a -> b) -> a -> b
$ String
"pgGetMessage: unknown ready state: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
s
getMessageBody Char
'1' = PGBackendMessage -> Get PGBackendMessage
forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
ParseComplete
getMessageBody Char
'2' = PGBackendMessage -> Get PGBackendMessage
forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
BindComplete
getMessageBody Char
'3' = PGBackendMessage -> Get PGBackendMessage
forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
CloseComplete
getMessageBody Char
'C' = ByteString -> PGBackendMessage
CommandComplete (ByteString -> PGBackendMessage)
-> Get ByteString -> Get PGBackendMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
getByteStringNul
getMessageBody Char
'S' = (ByteString -> ByteString -> PGBackendMessage)
-> Get ByteString -> Get ByteString -> Get PGBackendMessage
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 ByteString -> ByteString -> PGBackendMessage
ParameterStatus Get ByteString
getByteStringNul Get ByteString
getByteStringNul
getMessageBody Char
'D' = do 
  Word16
numFields <- Get Word16
G.getWord16be
  PGValues -> PGBackendMessage
DataRow (PGValues -> PGBackendMessage)
-> Get PGValues -> Get PGBackendMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get PGValue -> Get PGValues
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
numFields) (Word32 -> Get PGValue
forall a. Integral a => a -> Get PGValue
getField (Word32 -> Get PGValue) -> Get Word32 -> Get PGValue
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word32
G.getWord32be) where
  getField :: a -> Get PGValue
getField a
0xFFFFFFFF = PGValue -> Get PGValue
forall (m :: * -> *) a. Monad m => a -> m a
return PGValue
PGNullValue
  getField a
len = ByteString -> PGValue
PGTextValue (ByteString -> PGValue) -> Get ByteString -> Get PGValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
G.getByteString (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
len)
  -- could be binary, too, but we don't know here, so have to choose one
getMessageBody Char
'K' = (Word32 -> Word32 -> PGBackendMessage)
-> Get Word32 -> Get Word32 -> Get PGBackendMessage
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Word32 -> Word32 -> PGBackendMessage
BackendKeyData Get Word32
G.getWord32be Get Word32
G.getWord32be
getMessageBody Char
'E' = MessageFields -> PGBackendMessage
ErrorResponse (MessageFields -> PGBackendMessage)
-> Get MessageFields -> Get PGBackendMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MessageFields
getMessageFields
getMessageBody Char
'I' = PGBackendMessage -> Get PGBackendMessage
forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
EmptyQueryResponse
getMessageBody Char
'n' = PGBackendMessage -> Get PGBackendMessage
forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
NoData
getMessageBody Char
's' = PGBackendMessage -> Get PGBackendMessage
forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
PortalSuspended
getMessageBody Char
'N' = MessageFields -> PGBackendMessage
NoticeResponse (MessageFields -> PGBackendMessage)
-> Get MessageFields -> Get PGBackendMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MessageFields
getMessageFields
getMessageBody Char
'A' = PGNotification -> PGBackendMessage
NotificationResponse (PGNotification -> PGBackendMessage)
-> Get PGNotification -> Get PGBackendMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
  Word32 -> ByteString -> ByteString -> PGNotification
PGNotification
    (Word32 -> ByteString -> ByteString -> PGNotification)
-> Get Word32 -> Get (ByteString -> ByteString -> PGNotification)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
G.getWord32be
    Get (ByteString -> ByteString -> PGNotification)
-> Get ByteString -> Get (ByteString -> PGNotification)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ByteString
getByteStringNul
    Get (ByteString -> PGNotification)
-> Get ByteString -> Get PGNotification
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ByteString
G.getLazyByteStringNul
getMessageBody Char
t = String -> Get PGBackendMessage
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get PGBackendMessage) -> String -> Get PGBackendMessage
forall a b. (a -> b) -> a -> b
$ String
"pgGetMessage: unknown message type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
t

getMessage :: G.Decoder PGBackendMessage
getMessage :: Decoder PGBackendMessage
getMessage = Get PGBackendMessage -> Decoder PGBackendMessage
forall a. Get a -> Decoder a
G.runGetIncremental (Get PGBackendMessage -> Decoder PGBackendMessage)
-> Get PGBackendMessage -> Decoder PGBackendMessage
forall a b. (a -> b) -> a -> b
$ do
  Word8
typ <- Get Word8
G.getWord8
  Word32
len <- Get Word32
G.getWord32be
  Int -> Get PGBackendMessage -> Get PGBackendMessage
forall a. Int -> Get a -> Get a
G.isolate (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4) (Get PGBackendMessage -> Get PGBackendMessage)
-> Get PGBackendMessage -> Get PGBackendMessage
forall a b. (a -> b) -> a -> b
$ Char -> Get PGBackendMessage
getMessageBody (Word8 -> Char
w2c Word8
typ)

class Show m => RecvMsg m where
  -- |Read from connection, returning immediate value or non-empty data
  recvMsgData :: PGConnection -> IO (Either m BS.ByteString)
  recvMsgData PGConnection
c = do
    ByteString
r <- PGHandle -> Int -> IO ByteString
pgGetSome (PGConnection -> PGHandle
connHandle PGConnection
c) Int
smallChunkSize
    if ByteString -> Bool
BS.null ByteString
r
      then do
        IORef PGState -> PGState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (PGConnection -> IORef PGState
connState PGConnection
c) PGState
StateClosed
        PGHandle -> IO ()
pgCloseHandle (PGConnection -> PGHandle
connHandle PGConnection
c)
        -- Should this instead be a special PGError?
        IOError -> IO (Either m ByteString)
forall a. IOError -> IO a
ioError (IOError -> IO (Either m ByteString))
-> IOError -> IO (Either m ByteString)
forall a b. (a -> b) -> a -> b
$ IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
eofErrorType String
"PGConnection" Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
      else
        Either m ByteString -> IO (Either m ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Either m ByteString
forall a b. b -> Either a b
Right ByteString
r)
  -- |Expected ReadyForQuery message
  recvMsgSync :: Maybe m
  recvMsgSync = Maybe m
forall a. Maybe a
Nothing
  -- |NotificationResponse message
  recvMsgNotif :: PGConnection -> PGNotification -> IO (Maybe m)
  recvMsgNotif PGConnection
c PGNotification
n = Maybe m
forall a. Maybe a
Nothing Maybe m -> IO () -> IO (Maybe m)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$
    IORef (Queue PGNotification)
-> (Queue PGNotification -> Queue PGNotification) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (PGConnection -> IORef (Queue PGNotification)
connNotifications PGConnection
c) (PGNotification -> Queue PGNotification -> Queue PGNotification
forall a. a -> Queue a -> Queue a
enQueue PGNotification
n)
  -- |ErrorResponse message
  recvMsgErr :: PGConnection -> MessageFields -> IO (Maybe m)
  recvMsgErr PGConnection
c MessageFields
m = Maybe m
forall a. Maybe a
Nothing Maybe m -> IO () -> IO (Maybe m)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$
    PGConnection -> MessageFields -> IO ()
connLogMessage PGConnection
c MessageFields
m
  -- |Any other unhandled message
  recvMsg :: PGConnection -> PGBackendMessage -> IO (Maybe m)
  recvMsg PGConnection
c PGBackendMessage
m = Maybe m
forall a. Maybe a
Nothing Maybe m -> IO () -> IO (Maybe m)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 
    PGConnection -> MessageFields -> IO ()
connLogMessage PGConnection
c (ByteString -> ByteString -> MessageFields
makeMessage (String -> ByteString
BSC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"Unexpected server message: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGBackendMessage -> String
forall a. Show a => a -> String
show PGBackendMessage
m) ByteString
"Each statement should only contain a single query")

-- |Process all pending messages
data RecvNonBlock = RecvNonBlock deriving (Int -> RecvNonBlock -> ShowS
[RecvNonBlock] -> ShowS
RecvNonBlock -> String
(Int -> RecvNonBlock -> ShowS)
-> (RecvNonBlock -> String)
-> ([RecvNonBlock] -> ShowS)
-> Show RecvNonBlock
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RecvNonBlock] -> ShowS
$cshowList :: [RecvNonBlock] -> ShowS
show :: RecvNonBlock -> String
$cshow :: RecvNonBlock -> String
showsPrec :: Int -> RecvNonBlock -> ShowS
$cshowsPrec :: Int -> RecvNonBlock -> ShowS
Show)
instance RecvMsg RecvNonBlock where
#ifndef mingw32_HOST_OS
  recvMsgData :: PGConnection -> IO (Either RecvNonBlock ByteString)
recvMsgData PGConnection{connHandle :: PGConnection -> PGHandle
connHandle=PGSocket Socket
s} = do
    ByteString
r <- Socket -> Int -> IO ByteString
recvNonBlock Socket
s Int
smallChunkSize
    if ByteString -> Bool
BS.null ByteString
r
      then Either RecvNonBlock ByteString
-> IO (Either RecvNonBlock ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecvNonBlock -> Either RecvNonBlock ByteString
forall a b. a -> Either a b
Left RecvNonBlock
RecvNonBlock)
      else Either RecvNonBlock ByteString
-> IO (Either RecvNonBlock ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Either RecvNonBlock ByteString
forall a b. b -> Either a b
Right ByteString
r)
#else
  recvMsgData PGConnection{connHandle=PGSocket _} =
    throwIO (userError "Non-blocking recvMsgData is not supported on mingw32 ATM")
#endif
#ifdef VERSION_tls
  recvMsgData PGConnection{connHandle :: PGConnection -> PGHandle
connHandle=PGTlsContext Context
_} =
    IOError -> IO (Either RecvNonBlock ByteString)
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Non-blocking recvMsgData is not supported on TLS connections")
#endif

-- |Wait for ReadyForQuery
data RecvSync = RecvSync deriving (Int -> RecvSync -> ShowS
[RecvSync] -> ShowS
RecvSync -> String
(Int -> RecvSync -> ShowS)
-> (RecvSync -> String) -> ([RecvSync] -> ShowS) -> Show RecvSync
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RecvSync] -> ShowS
$cshowList :: [RecvSync] -> ShowS
show :: RecvSync -> String
$cshow :: RecvSync -> String
showsPrec :: Int -> RecvSync -> ShowS
$cshowsPrec :: Int -> RecvSync -> ShowS
Show)
instance RecvMsg RecvSync where
  recvMsgSync :: Maybe RecvSync
recvMsgSync = RecvSync -> Maybe RecvSync
forall a. a -> Maybe a
Just RecvSync
RecvSync

-- |Wait for NotificationResponse
instance RecvMsg PGNotification where
  recvMsgNotif :: PGConnection -> PGNotification -> IO (Maybe PGNotification)
recvMsgNotif PGConnection
_ = Maybe PGNotification -> IO (Maybe PGNotification)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PGNotification -> IO (Maybe PGNotification))
-> (PGNotification -> Maybe PGNotification)
-> PGNotification
-> IO (Maybe PGNotification)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGNotification -> Maybe PGNotification
forall a. a -> Maybe a
Just

-- |Return any message (throwing errors)
instance RecvMsg PGBackendMessage where
  recvMsgErr :: PGConnection -> MessageFields -> IO (Maybe PGBackendMessage)
recvMsgErr PGConnection
_ = PGError -> IO (Maybe PGBackendMessage)
forall e a. Exception e => e -> IO a
throwIO (PGError -> IO (Maybe PGBackendMessage))
-> (MessageFields -> PGError)
-> MessageFields
-> IO (Maybe PGBackendMessage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessageFields -> PGError
PGError
  recvMsg :: PGConnection -> PGBackendMessage -> IO (Maybe PGBackendMessage)
recvMsg PGConnection
_ = Maybe PGBackendMessage -> IO (Maybe PGBackendMessage)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PGBackendMessage -> IO (Maybe PGBackendMessage))
-> (PGBackendMessage -> Maybe PGBackendMessage)
-> PGBackendMessage
-> IO (Maybe PGBackendMessage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGBackendMessage -> Maybe PGBackendMessage
forall a. a -> Maybe a
Just

-- |Return any message or ReadyForQuery
instance RecvMsg (Either PGBackendMessage RecvSync) where
  recvMsgSync :: Maybe (Either PGBackendMessage RecvSync)
recvMsgSync = Either PGBackendMessage RecvSync
-> Maybe (Either PGBackendMessage RecvSync)
forall a. a -> Maybe a
Just (Either PGBackendMessage RecvSync
 -> Maybe (Either PGBackendMessage RecvSync))
-> Either PGBackendMessage RecvSync
-> Maybe (Either PGBackendMessage RecvSync)
forall a b. (a -> b) -> a -> b
$ RecvSync -> Either PGBackendMessage RecvSync
forall a b. b -> Either a b
Right RecvSync
RecvSync
  recvMsgErr :: PGConnection
-> MessageFields -> IO (Maybe (Either PGBackendMessage RecvSync))
recvMsgErr PGConnection
_ = PGError -> IO (Maybe (Either PGBackendMessage RecvSync))
forall e a. Exception e => e -> IO a
throwIO (PGError -> IO (Maybe (Either PGBackendMessage RecvSync)))
-> (MessageFields -> PGError)
-> MessageFields
-> IO (Maybe (Either PGBackendMessage RecvSync))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessageFields -> PGError
PGError
  recvMsg :: PGConnection
-> PGBackendMessage
-> IO (Maybe (Either PGBackendMessage RecvSync))
recvMsg PGConnection
_ = Maybe (Either PGBackendMessage RecvSync)
-> IO (Maybe (Either PGBackendMessage RecvSync))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either PGBackendMessage RecvSync)
 -> IO (Maybe (Either PGBackendMessage RecvSync)))
-> (PGBackendMessage -> Maybe (Either PGBackendMessage RecvSync))
-> PGBackendMessage
-> IO (Maybe (Either PGBackendMessage RecvSync))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either PGBackendMessage RecvSync
-> Maybe (Either PGBackendMessage RecvSync)
forall a. a -> Maybe a
Just (Either PGBackendMessage RecvSync
 -> Maybe (Either PGBackendMessage RecvSync))
-> (PGBackendMessage -> Either PGBackendMessage RecvSync)
-> PGBackendMessage
-> Maybe (Either PGBackendMessage RecvSync)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGBackendMessage -> Either PGBackendMessage RecvSync
forall a b. a -> Either a b
Left

-- |Receive the next message from PostgreSQL (low-level).
pgRecv :: RecvMsg m => PGConnection -> IO m
pgRecv :: PGConnection -> IO m
pgRecv c :: PGConnection
c@PGConnection{ connInput :: PGConnection -> IORef (Decoder PGBackendMessage)
connInput = IORef (Decoder PGBackendMessage)
dr, connState :: PGConnection -> IORef PGState
connState = IORef PGState
sr } =
  Decoder PGBackendMessage -> IO m
forall b. RecvMsg b => Decoder PGBackendMessage -> IO b
rcv (Decoder PGBackendMessage -> IO m)
-> IO (Decoder PGBackendMessage) -> IO m
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Decoder PGBackendMessage) -> IO (Decoder PGBackendMessage)
forall a. IORef a -> IO a
readIORef IORef (Decoder PGBackendMessage)
dr where
  next :: Decoder PGBackendMessage -> IO ()
next = IORef (Decoder PGBackendMessage)
-> Decoder PGBackendMessage -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Decoder PGBackendMessage)
dr
  new :: ByteString -> Decoder PGBackendMessage
new = Decoder PGBackendMessage -> ByteString -> Decoder PGBackendMessage
forall a. Decoder a -> ByteString -> Decoder a
G.pushChunk Decoder PGBackendMessage
getMessage

  -- read and parse
  rcv :: Decoder PGBackendMessage -> IO b
rcv (G.Done ByteString
b ByteOffset
_ PGBackendMessage
m) = do
    PGConnection -> String -> IO ()
connDebugMsg PGConnection
c (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"< " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGBackendMessage -> String
forall a. Show a => a -> String
show PGBackendMessage
m
    Decoder PGBackendMessage -> PGBackendMessage -> IO b
got (ByteString -> Decoder PGBackendMessage
new ByteString
b) PGBackendMessage
m
  rcv (G.Fail ByteString
_ ByteOffset
_ String
r) = Decoder PGBackendMessage -> IO ()
next (ByteString -> Decoder PGBackendMessage
new ByteString
BS.empty) IO () -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO b
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
r -- not clear how can recover
  rcv d :: Decoder PGBackendMessage
d@(G.Partial Maybe ByteString -> Decoder PGBackendMessage
r) = PGConnection -> IO (Either b ByteString)
forall m. RecvMsg m => PGConnection -> IO (Either m ByteString)
recvMsgData PGConnection
c IO (Either b ByteString) -> IO () -> IO (Either b ByteString)
forall a b. IO a -> IO b -> IO a
`onException` Decoder PGBackendMessage -> IO ()
next Decoder PGBackendMessage
d IO (Either b ByteString) -> (Either b ByteString -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    (b -> IO b) -> (ByteString -> IO b) -> Either b ByteString -> IO b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (b -> IO () -> IO b
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Decoder PGBackendMessage -> IO ()
next Decoder PGBackendMessage
d) (Decoder PGBackendMessage -> IO b
rcv (Decoder PGBackendMessage -> IO b)
-> (ByteString -> Decoder PGBackendMessage) -> ByteString -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ByteString -> Decoder PGBackendMessage
r (Maybe ByteString -> Decoder PGBackendMessage)
-> (ByteString -> Maybe ByteString)
-> ByteString
-> Decoder PGBackendMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just)

  -- process message
  msg :: PGBackendMessage -> IO (Maybe a)
msg (ParameterStatus ByteString
k ByteString
v) = Maybe a
forall a. Maybe a
Nothing Maybe a -> IO () -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$
    IORef (Map ByteString ByteString)
-> (Map ByteString ByteString -> Map ByteString ByteString)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (PGConnection -> IORef (Map ByteString ByteString)
connParameters PGConnection
c) (ByteString
-> ByteString
-> Map ByteString ByteString
-> Map ByteString ByteString
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ByteString
k ByteString
v)
  msg (NoticeResponse MessageFields
m) = Maybe a
forall a. Maybe a
Nothing Maybe a -> IO () -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$
    PGConnection -> MessageFields -> IO ()
connLogMessage PGConnection
c MessageFields
m
  msg (ErrorResponse MessageFields
m) =
    PGConnection -> MessageFields -> IO (Maybe a)
forall m.
RecvMsg m =>
PGConnection -> MessageFields -> IO (Maybe m)
recvMsgErr PGConnection
c MessageFields
m
  msg m :: PGBackendMessage
m@(ReadyForQuery PGState
s) = do
    PGState
s' <- IORef PGState -> (PGState -> (PGState, PGState)) -> IO PGState
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef PGState
sr (PGState
s, )
    if PGState
s' PGState -> PGState -> Bool
forall a. Eq a => a -> a -> Bool
== PGState
StatePending
      then Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall m. RecvMsg m => Maybe m
recvMsgSync -- expected
      else PGConnection -> PGBackendMessage -> IO (Maybe a)
forall m.
RecvMsg m =>
PGConnection -> PGBackendMessage -> IO (Maybe m)
recvMsg PGConnection
c PGBackendMessage
m -- unexpected
  msg (NotificationResponse PGNotification
n) =
    PGConnection -> PGNotification -> IO (Maybe a)
forall m.
RecvMsg m =>
PGConnection -> PGNotification -> IO (Maybe m)
recvMsgNotif PGConnection
c PGNotification
n
  msg m :: PGBackendMessage
m@PGBackendMessage
AuthenticationOk = do
    IORef PGState -> PGState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef PGState
sr PGState
StatePending
    PGConnection -> PGBackendMessage -> IO (Maybe a)
forall m.
RecvMsg m =>
PGConnection -> PGBackendMessage -> IO (Maybe m)
recvMsg PGConnection
c PGBackendMessage
m
  msg PGBackendMessage
m = PGConnection -> PGBackendMessage -> IO (Maybe a)
forall m.
RecvMsg m =>
PGConnection -> PGBackendMessage -> IO (Maybe m)
recvMsg PGConnection
c PGBackendMessage
m
  got :: Decoder PGBackendMessage -> PGBackendMessage -> IO b
got Decoder PGBackendMessage
d PGBackendMessage
m = PGBackendMessage -> IO (Maybe b)
forall a. RecvMsg a => PGBackendMessage -> IO (Maybe a)
msg PGBackendMessage
m IO (Maybe b) -> IO () -> IO (Maybe b)
forall a b. IO a -> IO b -> IO a
`onException` Decoder PGBackendMessage -> IO ()
next Decoder PGBackendMessage
d IO (Maybe b) -> (Maybe b -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    IO b -> (b -> IO b) -> Maybe b -> IO b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Decoder PGBackendMessage -> IO b
rcv Decoder PGBackendMessage
d) (b -> IO () -> IO b
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Decoder PGBackendMessage -> IO ()
next Decoder PGBackendMessage
d)

-- |Connect to a PostgreSQL server.
pgConnect :: PGDatabase -> IO PGConnection
pgConnect :: PGDatabase -> IO PGConnection
pgConnect PGDatabase
db = do
  IORef (Map ByteString ByteString)
param <- Map ByteString ByteString -> IO (IORef (Map ByteString ByteString))
forall a. a -> IO (IORef a)
newIORef Map ByteString ByteString
forall k a. Map k a
Map.empty
  IORef PGState
state <- PGState -> IO (IORef PGState)
forall a. a -> IO (IORef a)
newIORef PGState
StateUnsync
  IORef Integer
prepc <- Integer -> IO (IORef Integer)
forall a. a -> IO (IORef a)
newIORef Integer
0
  IORef (Map (ByteString, [Word32]) PGPreparedStatement)
prepm <- Map (ByteString, [Word32]) PGPreparedStatement
-> IO (IORef (Map (ByteString, [Word32]) PGPreparedStatement))
forall a. a -> IO (IORef a)
newIORef Map (ByteString, [Word32]) PGPreparedStatement
forall k a. Map k a
Map.empty
  IORef (Decoder PGBackendMessage)
input <- Decoder PGBackendMessage -> IO (IORef (Decoder PGBackendMessage))
forall a. a -> IO (IORef a)
newIORef Decoder PGBackendMessage
getMessage
  IORef Word
tr <- Word -> IO (IORef Word)
forall a. a -> IO (IORef a)
newIORef Word
0
  IORef (Queue PGNotification)
notif <- Queue PGNotification -> IO (IORef (Queue PGNotification))
forall a. a -> IO (IORef a)
newIORef Queue PGNotification
forall a. Queue a
emptyQueue
  AddrInfo
addr <- ((String, String) -> IO AddrInfo)
-> (SockAddr -> IO AddrInfo)
-> Either (String, String) SockAddr
-> IO AddrInfo
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (\(String
h,String
p) -> [AddrInfo] -> AddrInfo
forall a. [a] -> a
head ([AddrInfo] -> AddrInfo) -> IO [AddrInfo] -> IO AddrInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
Net.getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
defai) (String -> Maybe String
forall a. a -> Maybe a
Just String
h) (String -> Maybe String
forall a. a -> Maybe a
Just String
p))
    (\SockAddr
a -> AddrInfo -> IO AddrInfo
forall (m :: * -> *) a. Monad m => a -> m a
return AddrInfo
defai{ addrAddress :: SockAddr
Net.addrAddress = SockAddr
a, addrFamily :: Family
Net.addrFamily = case SockAddr
a of
      Net.SockAddrInet{}  -> Family
Net.AF_INET
      Net.SockAddrInet6{} -> Family
Net.AF_INET6
      Net.SockAddrUnix{}  -> Family
Net.AF_UNIX
      SockAddr
_ -> Family
Net.AF_UNSPEC })
    (Either (String, String) SockAddr -> IO AddrInfo)
-> Either (String, String) SockAddr -> IO AddrInfo
forall a b. (a -> b) -> a -> b
$ PGDatabase -> Either (String, String) SockAddr
pgDBAddr PGDatabase
db
  Socket
sock <- Family -> SocketType -> ProtocolNumber -> IO Socket
Net.socket (AddrInfo -> Family
Net.addrFamily AddrInfo
addr) (AddrInfo -> SocketType
Net.addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
Net.addrProtocol AddrInfo
addr)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AddrInfo -> Family
Net.addrFamily AddrInfo
addr Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
== Family
Net.AF_UNIX) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> SocketOption -> Int -> IO ()
Net.setSocketOption Socket
sock SocketOption
Net.NoDelay Int
1
  Socket -> SockAddr -> IO ()
Net.connect Socket
sock (SockAddr -> IO ()) -> SockAddr -> IO ()
forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
Net.addrAddress AddrInfo
addr
  PGHandle
pgHandle <- PGDatabase -> Socket -> IO PGHandle
mkPGHandle PGDatabase
db Socket
sock
  let c :: PGConnection
c = PGConnection :: PGHandle
-> PGDatabase
-> Word32
-> Word32
-> PGTypeEnv
-> IORef (Map ByteString ByteString)
-> IORef Integer
-> IORef (Map (ByteString, [Word32]) PGPreparedStatement)
-> IORef PGState
-> IORef (Decoder PGBackendMessage)
-> IORef Word
-> IORef (Queue PGNotification)
-> PGConnection
PGConnection
        { connHandle :: PGHandle
connHandle = PGHandle
pgHandle
        , connDatabase :: PGDatabase
connDatabase = PGDatabase
db
        , connPid :: Word32
connPid = Word32
0
        , connKey :: Word32
connKey = Word32
0
        , connParameters :: IORef (Map ByteString ByteString)
connParameters = IORef (Map ByteString ByteString)
param
        , connPreparedStatementCount :: IORef Integer
connPreparedStatementCount = IORef Integer
prepc
        , connPreparedStatementMap :: IORef (Map (ByteString, [Word32]) PGPreparedStatement)
connPreparedStatementMap = IORef (Map (ByteString, [Word32]) PGPreparedStatement)
prepm
        , connState :: IORef PGState
connState = IORef PGState
state
        , connTypeEnv :: PGTypeEnv
connTypeEnv = PGTypeEnv
unknownPGTypeEnv
        , connInput :: IORef (Decoder PGBackendMessage)
connInput = IORef (Decoder PGBackendMessage)
input
        , connTransaction :: IORef Word
connTransaction = IORef Word
tr
        , connNotifications :: IORef (Queue PGNotification)
connNotifications = IORef (Queue PGNotification)
notif
        }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c (PGFrontendMessage -> IO ()) -> PGFrontendMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> PGFrontendMessage
StartupMessage ([(ByteString, ByteString)] -> PGFrontendMessage)
-> [(ByteString, ByteString)] -> PGFrontendMessage
forall a b. (a -> b) -> a -> b
$
    [ (ByteString
"user", PGDatabase -> ByteString
pgDBUser PGDatabase
db)
    , (ByteString
"database", PGDatabase -> ByteString
pgDBName PGDatabase
db)
    , (ByteString
"client_encoding", ByteString
"UTF8")
    , (ByteString
"standard_conforming_strings", ByteString
"on")
    , (ByteString
"bytea_output", ByteString
"hex")
    , (ByteString
"DateStyle", ByteString
"ISO, YMD")
    , (ByteString
"IntervalStyle", ByteString
"iso_8601")
    , (ByteString
"extra_float_digits", ByteString
"3")
    ] [(ByteString, ByteString)]
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. [a] -> [a] -> [a]
++ PGDatabase -> [(ByteString, ByteString)]
pgDBParams PGDatabase
db
  PGConnection -> IO ()
pgFlush PGConnection
c
  PGConnection -> IO PGConnection
conn PGConnection
c
  where
  defai :: AddrInfo
defai = AddrInfo
Net.defaultHints{ addrSocketType :: SocketType
Net.addrSocketType = SocketType
Net.Stream }
  conn :: PGConnection -> IO PGConnection
conn PGConnection
c = PGConnection -> IO (Either PGBackendMessage RecvSync)
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c IO (Either PGBackendMessage RecvSync)
-> (Either PGBackendMessage RecvSync -> IO PGConnection)
-> IO PGConnection
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PGConnection -> Either PGBackendMessage RecvSync -> IO PGConnection
msg PGConnection
c
  msg :: PGConnection -> Either PGBackendMessage RecvSync -> IO PGConnection
msg PGConnection
c (Right RecvSync
RecvSync) = do
    Map ByteString ByteString
cp <- IORef (Map ByteString ByteString) -> IO (Map ByteString ByteString)
forall a. IORef a -> IO a
readIORef (PGConnection -> IORef (Map ByteString ByteString)
connParameters PGConnection
c)
    PGConnection -> IO PGConnection
forall (m :: * -> *) a. Monad m => a -> m a
return PGConnection
c
      { connTypeEnv :: PGTypeEnv
connTypeEnv = PGTypeEnv :: Maybe Bool -> Maybe ByteString -> PGTypeEnv
PGTypeEnv
        { pgIntegerDatetimes :: Maybe Bool
pgIntegerDatetimes = (ByteString -> Bool) -> Maybe ByteString -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString
"on" ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe ByteString -> Maybe Bool) -> Maybe ByteString -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Map ByteString ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
"integer_datetimes" Map ByteString ByteString
cp
        , pgServerVersion :: Maybe ByteString
pgServerVersion = ByteString -> Map ByteString ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
"server_version" Map ByteString ByteString
cp
        }
      }
  msg PGConnection
c (Left (BackendKeyData Word32
p Word32
k)) = PGConnection -> IO PGConnection
conn PGConnection
c{ connPid :: Word32
connPid = Word32
p, connKey :: Word32
connKey = Word32
k }
  msg PGConnection
c (Left PGBackendMessage
AuthenticationOk) = PGConnection -> IO PGConnection
conn PGConnection
c
  msg PGConnection
c (Left PGBackendMessage
AuthenticationCleartextPassword) = do
    PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c (PGFrontendMessage -> IO ()) -> PGFrontendMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> PGFrontendMessage
PasswordMessage (ByteString -> PGFrontendMessage)
-> ByteString -> PGFrontendMessage
forall a b. (a -> b) -> a -> b
$ PGDatabase -> ByteString
pgDBPass PGDatabase
db
    PGConnection -> IO ()
pgFlush PGConnection
c
    PGConnection -> IO PGConnection
conn PGConnection
c
#ifdef VERSION_cryptonite
  msg PGConnection
c (Left (AuthenticationMD5Password ByteString
salt)) = do
    PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c (PGFrontendMessage -> IO ()) -> PGFrontendMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> PGFrontendMessage
PasswordMessage (ByteString -> PGFrontendMessage)
-> ByteString -> PGFrontendMessage
forall a b. (a -> b) -> a -> b
$ ByteString
"md5" ByteString -> ByteString -> ByteString
`BS.append` ByteString -> ByteString
md5 (ByteString -> ByteString
md5 (PGDatabase -> ByteString
pgDBPass PGDatabase
db ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> PGDatabase -> ByteString
pgDBUser PGDatabase
db) ByteString -> ByteString -> ByteString
`BS.append` ByteString
salt)
    PGConnection -> IO ()
pgFlush PGConnection
c
    PGConnection -> IO PGConnection
conn PGConnection
c
#endif
  msg PGConnection
_ (Left PGBackendMessage
m) = String -> IO PGConnection
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO PGConnection) -> String -> IO PGConnection
forall a b. (a -> b) -> a -> b
$ String
"pgConnect: unexpected response: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGBackendMessage -> String
forall a. Show a => a -> String
show PGBackendMessage
m

mkPGHandle :: PGDatabase -> Net.Socket -> IO PGHandle
#ifdef VERSION_tls
mkPGHandle :: PGDatabase -> Socket -> IO PGHandle
mkPGHandle PGDatabase
db Socket
sock =
  case PGDatabase -> PGTlsMode
pgDBTLS PGDatabase
db of
    PGTlsMode
TlsDisabled     -> PGHandle -> IO PGHandle
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Socket -> PGHandle
PGSocket Socket
sock)
    PGTlsMode
TlsNoValidate   -> IO PGHandle
mkTlsContext
    TlsValidate PGTlsValidateMode
_ SignedExact Certificate
_ -> IO PGHandle
mkTlsContext
  where
    mkTlsContext :: IO PGHandle
mkTlsContext = do
      Socket -> ByteString -> IO ()
NetBSL.sendAll Socket
sock ByteString
sslRequest
      ByteString
resp <- Socket -> Int -> IO ByteString
NetBS.recv Socket
sock Int
1
      case ByteString
resp of
        ByteString
"S" -> do
          Context
ctx <- Socket -> ClientParams -> IO Context
forall (m :: * -> *) backend params.
(MonadIO m, HasBackend backend, TLSParams params) =>
backend -> params -> m Context
TLS.contextNew Socket
sock ClientParams
params
          IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
TLS.handshake Context
ctx
          PGHandle -> IO PGHandle
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PGHandle -> IO PGHandle) -> PGHandle -> IO PGHandle
forall a b. (a -> b) -> a -> b
$ Context -> PGHandle
PGTlsContext Context
ctx
        ByteString
"N" -> IOError -> IO PGHandle
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Server does not support TLS")
        ByteString
_ -> IOError -> IO PGHandle
forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Unexpected response from server when issuing SSLRequest")
    params :: ClientParams
params = (String -> ByteString -> ClientParams
TLS.defaultParamsClient String
tlsHost ByteString
tlsPort)
      { clientSupported :: Supported
TLS.clientSupported =
          Supported
forall a. Default a => a
def { supportedCiphers :: [Cipher]
TLS.supportedCiphers = [Cipher]
TLS.ciphersuite_strong }
      , clientShared :: Shared
TLS.clientShared = Shared
clientShared
      , clientHooks :: ClientHooks
TLS.clientHooks = ClientHooks
clientHooks
      }
    tlsHost :: String
tlsHost = case PGDatabase -> Either (String, String) SockAddr
pgDBAddr PGDatabase
db of
      Left (String
h,String
_) -> String
h
      Right (Net.SockAddrUnix String
s) -> String
s
      Right SockAddr
_ -> String
"some-socket"
    tlsPort :: ByteString
tlsPort = case PGDatabase -> Either (String, String) SockAddr
pgDBAddr PGDatabase
db of
      Left (String
_,String
p) -> String -> ByteString
BSC.pack String
p
      Right SockAddr
_    -> ByteString
"socket"
    clientShared :: Shared
clientShared =
      case PGDatabase -> PGTlsMode
pgDBTLS PGDatabase
db of
        PGTlsMode
TlsDisabled -> Shared
forall a. Default a => a
def { sharedValidationCache :: ValidationCache
TLS.sharedValidationCache = ValidationCache
noValidate }
        PGTlsMode
TlsNoValidate -> Shared
forall a. Default a => a
def { sharedValidationCache :: ValidationCache
TLS.sharedValidationCache = ValidationCache
noValidate }
        TlsValidate PGTlsValidateMode
_ SignedExact Certificate
sc -> Shared
forall a. Default a => a
def { sharedCAStore :: CertificateStore
TLS.sharedCAStore = [SignedExact Certificate] -> CertificateStore
makeCertificateStore [SignedExact Certificate
sc] }
    clientHooks :: ClientHooks
clientHooks =
      case PGDatabase -> PGTlsMode
pgDBTLS PGDatabase
db of
        TlsValidate PGTlsValidateMode
TlsValidateCA SignedExact Certificate
_ -> ClientHooks
forall a. Default a => a
def { onServerCertificate :: OnServerCertificate
TLS.onServerCertificate = OnServerCertificate
validateNoCheckFQHN }
        PGTlsMode
_                           -> ClientHooks
forall a. Default a => a
def
    validateNoCheckFQHN :: OnServerCertificate
validateNoCheckFQHN = HashALG
-> ValidationHooks -> ValidationChecks -> OnServerCertificate
Data.X509.Validation.validate HashALG
HashSHA256 ValidationHooks
forall a. Default a => a
def (ValidationChecks
forall a. Default a => a
def { checkFQHN :: Bool
TLS.checkFQHN = Bool
False })

    noValidate :: ValidationCache
noValidate = ValidationCacheQueryCallback
-> ValidationCacheAddCallback -> ValidationCache
TLS.ValidationCache
      (\ServiceID
_ Fingerprint
_ Certificate
_ -> ValidationCacheResult -> IO ValidationCacheResult
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationCacheResult
TLS.ValidationCachePass)
      (\ServiceID
_ Fingerprint
_ Certificate
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    sslRequest :: ByteString
sslRequest = Builder -> ByteString
B.toLazyByteString (Word32 -> Builder
B.word32BE Word32
8 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
B.word32BE Word32
80877103)
#else
mkPGHandle _ sock = pure (PGSocket sock)
#endif

-- |Disconnect cleanly from the PostgreSQL server.
pgDisconnect :: PGConnection -- ^ a handle from 'pgConnect'
             -> IO ()
pgDisconnect :: PGConnection -> IO ()
pgDisconnect c :: PGConnection
c@PGConnection{ connHandle :: PGConnection -> PGHandle
connHandle = PGHandle
h } =
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c PGFrontendMessage
Terminate IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` PGHandle -> IO ()
pgCloseHandle PGHandle
h

-- |Disconnect cleanly from the PostgreSQL server, but only if it's still connected.
pgDisconnectOnce :: PGConnection -- ^ a handle from 'pgConnect'
                 -> IO ()
pgDisconnectOnce :: PGConnection -> IO ()
pgDisconnectOnce c :: PGConnection
c@PGConnection{ connState :: PGConnection -> IORef PGState
connState = IORef PGState
cs } = do
  PGState
s <- IORef PGState -> IO PGState
forall a. IORef a -> IO a
readIORef IORef PGState
cs
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PGState
s PGState -> PGState -> Bool
forall a. Eq a => a -> a -> Bool
== PGState
StateClosed) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    PGConnection -> IO ()
pgDisconnect PGConnection
c

-- |Possibly re-open a connection to a different database, either reusing the connection if the given database is already connected or closing it and opening a new one.
-- Regardless, the input connection must not be used afterwards.
pgReconnect :: PGConnection -> PGDatabase -> IO PGConnection
pgReconnect :: PGConnection -> PGDatabase -> IO PGConnection
pgReconnect c :: PGConnection
c@PGConnection{ connDatabase :: PGConnection -> PGDatabase
connDatabase = PGDatabase
cd, connState :: PGConnection -> IORef PGState
connState = IORef PGState
cs } PGDatabase
d = do
  PGState
s <- IORef PGState -> IO PGState
forall a. IORef a -> IO a
readIORef IORef PGState
cs
  if PGDatabase
cd PGDatabase -> PGDatabase -> Bool
forall a. Eq a => a -> a -> Bool
== PGDatabase
d Bool -> Bool -> Bool
&& PGState
s PGState -> PGState -> Bool
forall a. Eq a => a -> a -> Bool
/= PGState
StateClosed
    then PGConnection -> IO PGConnection
forall (m :: * -> *) a. Monad m => a -> m a
return PGConnection
c{ connDatabase :: PGDatabase
connDatabase = PGDatabase
d }
    else do
      PGConnection -> IO ()
pgDisconnectOnce PGConnection
c
      PGDatabase -> IO PGConnection
pgConnect PGDatabase
d

pgSync :: PGConnection -> IO ()
pgSync :: PGConnection -> IO ()
pgSync c :: PGConnection
c@PGConnection{ connState :: PGConnection -> IORef PGState
connState = IORef PGState
sr } = do
  PGState
s <- IORef PGState -> IO PGState
forall a. IORef a -> IO a
readIORef IORef PGState
sr
  case PGState
s of
    PGState
StateClosed -> String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"pgSync: operation on closed connection"
    PGState
StatePending -> IO ()
wait
    PGState
StateUnsync -> do
      PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c PGFrontendMessage
Sync
      PGConnection -> IO ()
pgFlush PGConnection
c
      IO ()
wait
    PGState
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
  wait :: IO ()
wait = do
    RecvSync
RecvSync <- PGConnection -> IO RecvSync
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    
rowDescription :: PGBackendMessage -> PGRowDescription
rowDescription :: PGBackendMessage -> [PGColDescription]
rowDescription (RowDescription [PGColDescription]
d) = [PGColDescription]
d
rowDescription PGBackendMessage
NoData = []
rowDescription PGBackendMessage
m = String -> [PGColDescription]
forall a. HasCallStack => String -> a
error (String -> [PGColDescription]) -> String -> [PGColDescription]
forall a b. (a -> b) -> a -> b
$ String
"describe: unexpected response: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGBackendMessage -> String
forall a. Show a => a -> String
show PGBackendMessage
m

-- |Describe a SQL statement/query. A statement description consists of 0 or
-- more parameter descriptions (a PostgreSQL type) and zero or more result
-- field descriptions (for queries) (consist of the name of the field, the
-- type of the field, and a nullability indicator).
pgDescribe :: PGConnection -> BSL.ByteString -- ^ SQL string
                  -> [OID] -- ^ Optional type specifications
                  -> Bool -- ^ Guess nullability, otherwise assume everything is
                  -> IO ([OID], [(BS.ByteString, OID, Bool)]) -- ^ a list of parameter types, and a list of result field names, types, and nullability indicators.
pgDescribe :: PGConnection
-> ByteString
-> [Word32]
-> Bool
-> IO ([Word32], [(ByteString, Word32, Bool)])
pgDescribe PGConnection
h ByteString
sql [Word32]
types Bool
nulls = do
  PGConnection -> IO ()
pgSync PGConnection
h
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
h Parse :: ByteString -> ByteString -> [Word32] -> PGFrontendMessage
Parse{ queryString :: ByteString
queryString = ByteString
sql, statementName :: ByteString
statementName = ByteString
BS.empty, parseTypes :: [Word32]
parseTypes = [Word32]
types }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
h DescribeStatement :: ByteString -> PGFrontendMessage
DescribeStatement{ statementName :: ByteString
statementName = ByteString
BS.empty }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
h PGFrontendMessage
Sync
  PGConnection -> IO ()
pgFlush PGConnection
h
  PGBackendMessage
ParseComplete <- PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
h
  ParameterDescription [Word32]
ps <- PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
h
  (,) [Word32]
ps ([(ByteString, Word32, Bool)]
 -> ([Word32], [(ByteString, Word32, Bool)]))
-> IO [(ByteString, Word32, Bool)]
-> IO ([Word32], [(ByteString, Word32, Bool)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((PGColDescription -> IO (ByteString, Word32, Bool))
-> [PGColDescription] -> IO [(ByteString, Word32, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PGColDescription -> IO (ByteString, Word32, Bool)
desc ([PGColDescription] -> IO [(ByteString, Word32, Bool)])
-> (PGBackendMessage -> [PGColDescription])
-> PGBackendMessage
-> IO [(ByteString, Word32, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGBackendMessage -> [PGColDescription]
rowDescription (PGBackendMessage -> IO [(ByteString, Word32, Bool)])
-> IO PGBackendMessage -> IO [(ByteString, Word32, Bool)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
h)
  where
  desc :: PGColDescription -> IO (ByteString, Word32, Bool)
desc (PGColDescription{ pgColName :: PGColDescription -> ByteString
pgColName = ByteString
name, pgColTable :: PGColDescription -> Word32
pgColTable = Word32
tab, pgColNumber :: PGColDescription -> Int16
pgColNumber = Int16
col, pgColType :: PGColDescription -> Word32
pgColType = Word32
typ }) = do
    Bool
n <- Word32 -> Int16 -> IO Bool
nullable Word32
tab Int16
col
    (ByteString, Word32, Bool) -> IO (ByteString, Word32, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
name, Word32
typ, Bool
n)
  -- We don't get nullability indication from PostgreSQL, at least not directly.
  -- Without any hints, we have to assume that the result can be null and
  -- leave it up to the developer to figure it out.
  nullable :: Word32 -> Int16 -> IO Bool
nullable Word32
oid Int16
col
    | Bool
nulls Bool -> Bool -> Bool
&& Word32
oid Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0 = do
      -- In cases where the resulting field is tracable to the column of a
      -- table, we can check there.
      (Int
_, [PGValues]
r) <- PGConnection
-> ByteString
-> [Word32]
-> PGValues
-> [Bool]
-> IO (Int, [PGValues])
pgPreparedQuery PGConnection
h ByteString
"SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = $1 AND attnum = $2" [Word32
26, Word32
21] [Word32 -> PGValue
forall a. PGRep a => a -> PGValue
pgEncodeRep (Word32
oid :: OID), Int16 -> PGValue
forall a. PGRep a => a -> PGValue
pgEncodeRep (Int16
col :: Int16)] []
      case [PGValues]
r of
        [[PGValue
s]] -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ PGValue -> Bool
forall a. PGRep a => PGValue -> a
pgDecodeRep PGValue
s
        [] -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        [PGValues]
_ -> String -> IO Bool
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ String
"Failed to determine nullability of column #" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int16 -> String
forall a. Show a => a -> String
show Int16
col
    | Bool
otherwise = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

rowsAffected :: (Integral i, Read i) => BS.ByteString -> i
rowsAffected :: ByteString -> i
rowsAffected = [ByteString] -> i
forall p. (Num p, Read p) => [ByteString] -> p
ra ([ByteString] -> i)
-> (ByteString -> [ByteString]) -> ByteString -> i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BSC.words where
  ra :: [ByteString] -> p
ra [] = -p
1
  ra [ByteString]
l = p -> Maybe p -> p
forall a. a -> Maybe a -> a
fromMaybe (-p
1) (Maybe p -> p) -> Maybe p -> p
forall a b. (a -> b) -> a -> b
$ String -> Maybe p
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe p) -> String -> Maybe p
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BSC.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
forall a. [a] -> a
last [ByteString]
l

-- Do we need to use the PGColDescription here always, or are the request formats okay?
fixBinary :: [Bool] -> PGValues -> PGValues
fixBinary :: [Bool] -> PGValues -> PGValues
fixBinary (Bool
False:[Bool]
b) (PGBinaryValue ByteString
x:PGValues
r) = ByteString -> PGValue
PGTextValue ByteString
x PGValue -> PGValues -> PGValues
forall a. a -> [a] -> [a]
: [Bool] -> PGValues -> PGValues
fixBinary [Bool]
b PGValues
r
fixBinary (Bool
True :[Bool]
b) (PGTextValue ByteString
x:PGValues
r) = ByteString -> PGValue
PGBinaryValue ByteString
x PGValue -> PGValues -> PGValues
forall a. a -> [a] -> [a]
: [Bool] -> PGValues -> PGValues
fixBinary [Bool]
b PGValues
r
fixBinary (Bool
_:[Bool]
b) (PGValue
x:PGValues
r) = PGValue
x PGValue -> PGValues -> PGValues
forall a. a -> [a] -> [a]
: [Bool] -> PGValues -> PGValues
fixBinary [Bool]
b PGValues
r
fixBinary [Bool]
_ PGValues
l = PGValues
l

-- |A simple query is one which requires sending only a single 'SimpleQuery'
-- message to the PostgreSQL server. The query is sent as a single string; you
-- cannot bind parameters. Note that queries can return 0 results (an empty
-- list).
pgSimpleQuery :: PGConnection -> BSL.ByteString -- ^ SQL string
                   -> IO (Int, [PGValues]) -- ^ The number of rows affected and a list of result rows
pgSimpleQuery :: PGConnection -> ByteString -> IO (Int, [PGValues])
pgSimpleQuery PGConnection
h ByteString
sql = do
  PGConnection -> IO ()
pgSync PGConnection
h
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
h (PGFrontendMessage -> IO ()) -> PGFrontendMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> PGFrontendMessage
SimpleQuery ByteString
sql
  PGConnection -> IO ()
pgFlush PGConnection
h
  (PGBackendMessage -> IO (Int, [PGValues])) -> IO (Int, [PGValues])
forall b. (PGBackendMessage -> IO b) -> IO b
go PGBackendMessage -> IO (Int, [PGValues])
forall a.
(Integral a, Read a) =>
PGBackendMessage -> IO (a, [PGValues])
start where 
  go :: (PGBackendMessage -> IO b) -> IO b
go = (PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
h IO PGBackendMessage -> (PGBackendMessage -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)
  start :: PGBackendMessage -> IO (a, [PGValues])
start (RowDescription [PGColDescription]
rd) = (PGBackendMessage -> IO (a, [PGValues])) -> IO (a, [PGValues])
forall b. (PGBackendMessage -> IO b) -> IO b
go ((PGBackendMessage -> IO (a, [PGValues])) -> IO (a, [PGValues]))
-> (PGBackendMessage -> IO (a, [PGValues])) -> IO (a, [PGValues])
forall a b. (a -> b) -> a -> b
$ [Bool]
-> ([PGValues] -> [PGValues])
-> PGBackendMessage
-> IO (a, [PGValues])
forall a b.
(Integral a, Read a) =>
[Bool] -> ([PGValues] -> b) -> PGBackendMessage -> IO (a, b)
row ((PGColDescription -> Bool) -> [PGColDescription] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map PGColDescription -> Bool
pgColBinary [PGColDescription]
rd) [PGValues] -> [PGValues]
forall a. a -> a
id
  start (CommandComplete ByteString
c) = ByteString -> [PGValues] -> IO (a, [PGValues])
forall (m :: * -> *) a b.
(Monad m, Integral a, Read a) =>
ByteString -> b -> m (a, b)
got ByteString
c []
  start PGBackendMessage
EmptyQueryResponse = (a, [PGValues]) -> IO (a, [PGValues])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
0, [])
  start PGBackendMessage
m = String -> IO (a, [PGValues])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (a, [PGValues])) -> String -> IO (a, [PGValues])
forall a b. (a -> b) -> a -> b
$ String
"pgSimpleQuery: unexpected response: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGBackendMessage -> String
forall a. Show a => a -> String
show PGBackendMessage
m
  row :: [Bool] -> ([PGValues] -> b) -> PGBackendMessage -> IO (a, b)
row [Bool]
bc [PGValues] -> b
r (DataRow PGValues
fs) = (PGBackendMessage -> IO (a, b)) -> IO (a, b)
forall b. (PGBackendMessage -> IO b) -> IO b
go ((PGBackendMessage -> IO (a, b)) -> IO (a, b))
-> (PGBackendMessage -> IO (a, b)) -> IO (a, b)
forall a b. (a -> b) -> a -> b
$ [Bool] -> ([PGValues] -> b) -> PGBackendMessage -> IO (a, b)
row [Bool]
bc ([PGValues] -> b
r ([PGValues] -> b) -> ([PGValues] -> [PGValues]) -> [PGValues] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Bool] -> PGValues -> PGValues
fixBinary [Bool]
bc PGValues
fs PGValues -> [PGValues] -> [PGValues]
forall a. a -> [a] -> [a]
:))
  row [Bool]
_ [PGValues] -> b
r (CommandComplete ByteString
c) = ByteString -> b -> IO (a, b)
forall (m :: * -> *) a b.
(Monad m, Integral a, Read a) =>
ByteString -> b -> m (a, b)
got ByteString
c ([PGValues] -> b
r [])
  row [Bool]
_ [PGValues] -> b
_ PGBackendMessage
m = String -> IO (a, b)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (a, b)) -> String -> IO (a, b)
forall a b. (a -> b) -> a -> b
$ String
"pgSimpleQuery: unexpected row: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGBackendMessage -> String
forall a. Show a => a -> String
show PGBackendMessage
m
  got :: ByteString -> b -> m (a, b)
got ByteString
c b
r = (a, b) -> m (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> a
forall i. (Integral i, Read i) => ByteString -> i
rowsAffected ByteString
c, b
r)

-- |A simple query which may contain multiple queries (separated by semi-colons) whose results are all ignored.
-- This function can also be used for \"SET\" parameter queries if necessary, but it's safer better to use 'pgDBParams'.
pgSimpleQueries_ :: PGConnection -> BSL.ByteString -- ^ SQL string
                   -> IO ()
pgSimpleQueries_ :: PGConnection -> ByteString -> IO ()
pgSimpleQueries_ PGConnection
h ByteString
sql = do
  PGConnection -> IO ()
pgSync PGConnection
h
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
h (PGFrontendMessage -> IO ()) -> PGFrontendMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> PGFrontendMessage
SimpleQuery ByteString
sql
  PGConnection -> IO ()
pgFlush PGConnection
h
  IO ()
go where
  go :: IO ()
go = PGConnection -> IO (Either PGBackendMessage RecvSync)
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
h IO (Either PGBackendMessage RecvSync)
-> (Either PGBackendMessage RecvSync -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either PGBackendMessage RecvSync -> IO ()
res
  res :: Either PGBackendMessage RecvSync -> IO ()
res (Left (RowDescription [PGColDescription]
_)) = IO ()
go
  res (Left (CommandComplete ByteString
_)) = IO ()
go
  res (Left PGBackendMessage
EmptyQueryResponse) = IO ()
go
  res (Left (DataRow PGValues
_)) = IO ()
go
  res (Right RecvSync
RecvSync) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  res Either PGBackendMessage RecvSync
m = String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"pgSimpleQueries_: unexpected response: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Either PGBackendMessage RecvSync -> String
forall a. Show a => a -> String
show Either PGBackendMessage RecvSync
m

pgPreparedBind :: PGConnection -> BS.ByteString -> [OID] -> PGValues -> [Bool] -> IO (IO ())
pgPreparedBind :: PGConnection
-> ByteString -> [Word32] -> PGValues -> [Bool] -> IO (IO ())
pgPreparedBind PGConnection
c ByteString
sql [Word32]
types PGValues
bind [Bool]
bc = do
  PGConnection -> IO ()
pgSync PGConnection
c
  Map (ByteString, [Word32]) PGPreparedStatement
m <- IORef (Map (ByteString, [Word32]) PGPreparedStatement)
-> IO (Map (ByteString, [Word32]) PGPreparedStatement)
forall a. IORef a -> IO a
readIORef (PGConnection
-> IORef (Map (ByteString, [Word32]) PGPreparedStatement)
connPreparedStatementMap PGConnection
c)
  (Bool
p, PGPreparedStatement
n) <- IO (Bool, PGPreparedStatement)
-> (PGPreparedStatement -> IO (Bool, PGPreparedStatement))
-> Maybe PGPreparedStatement
-> IO (Bool, PGPreparedStatement)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    (IORef Integer
-> (Integer -> (Integer, (Bool, PGPreparedStatement)))
-> IO (Bool, PGPreparedStatement)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (PGConnection -> IORef Integer
connPreparedStatementCount PGConnection
c) (Integer -> Integer
forall a. Enum a => a -> a
succ (Integer -> Integer)
-> (Integer -> (Bool, PGPreparedStatement))
-> Integer
-> (Integer, (Bool, PGPreparedStatement))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (,) Bool
False (PGPreparedStatement -> (Bool, PGPreparedStatement))
-> (Integer -> PGPreparedStatement)
-> Integer
-> (Bool, PGPreparedStatement)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> PGPreparedStatement
PGPreparedStatement))
    ((Bool, PGPreparedStatement) -> IO (Bool, PGPreparedStatement)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, PGPreparedStatement) -> IO (Bool, PGPreparedStatement))
-> (PGPreparedStatement -> (Bool, PGPreparedStatement))
-> PGPreparedStatement
-> IO (Bool, PGPreparedStatement)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) Bool
True) (Maybe PGPreparedStatement -> IO (Bool, PGPreparedStatement))
-> Maybe PGPreparedStatement -> IO (Bool, PGPreparedStatement)
forall a b. (a -> b) -> a -> b
$ (ByteString, [Word32])
-> Map (ByteString, [Word32]) PGPreparedStatement
-> Maybe PGPreparedStatement
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ByteString, [Word32])
key Map (ByteString, [Word32]) PGPreparedStatement
m
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
p (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c Parse :: ByteString -> ByteString -> [Word32] -> PGFrontendMessage
Parse{ queryString :: ByteString
queryString = ByteString -> ByteString
BSL.fromStrict ByteString
sql, statementName :: ByteString
statementName = PGPreparedStatement -> ByteString
preparedStatementName PGPreparedStatement
n, parseTypes :: [Word32]
parseTypes = [Word32]
types }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c Bind :: ByteString -> ByteString -> PGValues -> [Bool] -> PGFrontendMessage
Bind{ portalName :: ByteString
portalName = ByteString
BS.empty, statementName :: ByteString
statementName = PGPreparedStatement -> ByteString
preparedStatementName PGPreparedStatement
n, bindParameters :: PGValues
bindParameters = PGValues
bind, binaryColumns :: [Bool]
binaryColumns = [Bool]
bc }
  let
    go :: IO ()
go = PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c IO PGBackendMessage -> (PGBackendMessage -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PGBackendMessage -> IO ()
start
    start :: PGBackendMessage -> IO ()
start PGBackendMessage
ParseComplete = do
      IORef (Map (ByteString, [Word32]) PGPreparedStatement)
-> (Map (ByteString, [Word32]) PGPreparedStatement
    -> Map (ByteString, [Word32]) PGPreparedStatement)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (PGConnection
-> IORef (Map (ByteString, [Word32]) PGPreparedStatement)
connPreparedStatementMap PGConnection
c) ((Map (ByteString, [Word32]) PGPreparedStatement
  -> Map (ByteString, [Word32]) PGPreparedStatement)
 -> IO ())
-> (Map (ByteString, [Word32]) PGPreparedStatement
    -> Map (ByteString, [Word32]) PGPreparedStatement)
-> IO ()
forall a b. (a -> b) -> a -> b
$
        (ByteString, [Word32])
-> PGPreparedStatement
-> Map (ByteString, [Word32]) PGPreparedStatement
-> Map (ByteString, [Word32]) PGPreparedStatement
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ByteString, [Word32])
key PGPreparedStatement
n
      IO ()
go
    start PGBackendMessage
BindComplete = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    start PGBackendMessage
r = String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"pgPrepared: unexpected response: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGBackendMessage -> String
forall a. Show a => a -> String
show PGBackendMessage
r
  IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
go
  where key :: (ByteString, [Word32])
key = (ByteString
sql, [Word32]
types)

-- |Prepare a statement, bind it, and execute it.
-- If the given statement has already been prepared (and not yet closed) on this connection, it will be re-used.
pgPreparedQuery :: PGConnection -> BS.ByteString -- ^ SQL statement with placeholders
  -> [OID] -- ^ Optional type specifications (only used for first call)
  -> PGValues -- ^ Paremeters to bind to placeholders
  -> [Bool] -- ^ Requested binary format for result columns
  -> IO (Int, [PGValues])
pgPreparedQuery :: PGConnection
-> ByteString
-> [Word32]
-> PGValues
-> [Bool]
-> IO (Int, [PGValues])
pgPreparedQuery PGConnection
c ByteString
sql [Word32]
types PGValues
bind [Bool]
bc = do
  IO ()
start <- PGConnection
-> ByteString -> [Word32] -> PGValues -> [Bool] -> IO (IO ())
pgPreparedBind PGConnection
c ByteString
sql [Word32]
types PGValues
bind [Bool]
bc
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c Execute :: ByteString -> Word32 -> PGFrontendMessage
Execute{ portalName :: ByteString
portalName = ByteString
BS.empty, executeRows :: Word32
executeRows = Word32
0 }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c PGFrontendMessage
Sync
  PGConnection -> IO ()
pgFlush PGConnection
c
  IO ()
start
  ([PGValues] -> [PGValues]) -> IO (Int, [PGValues])
forall a b. (Integral a, Read a) => ([PGValues] -> b) -> IO (a, b)
go [PGValues] -> [PGValues]
forall a. a -> a
id
  where
  go :: ([PGValues] -> b) -> IO (a, b)
go [PGValues] -> b
r = PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c IO PGBackendMessage -> (PGBackendMessage -> IO (a, b)) -> IO (a, b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([PGValues] -> b) -> PGBackendMessage -> IO (a, b)
row [PGValues] -> b
r
  row :: ([PGValues] -> b) -> PGBackendMessage -> IO (a, b)
row [PGValues] -> b
r (DataRow PGValues
fs) = ([PGValues] -> b) -> IO (a, b)
go ([PGValues] -> b
r ([PGValues] -> b) -> ([PGValues] -> [PGValues]) -> [PGValues] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Bool] -> PGValues -> PGValues
fixBinary [Bool]
bc PGValues
fs PGValues -> [PGValues] -> [PGValues]
forall a. a -> [a] -> [a]
:))
  row [PGValues] -> b
r (CommandComplete ByteString
d) = (a, b) -> IO (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> a
forall i. (Integral i, Read i) => ByteString -> i
rowsAffected ByteString
d, [PGValues] -> b
r [])
  row [PGValues] -> b
r PGBackendMessage
EmptyQueryResponse = (a, b) -> IO (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
0, [PGValues] -> b
r [])
  row [PGValues] -> b
_ PGBackendMessage
m = String -> IO (a, b)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (a, b)) -> String -> IO (a, b)
forall a b. (a -> b) -> a -> b
$ String
"pgPreparedQuery: unexpected row: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGBackendMessage -> String
forall a. Show a => a -> String
show PGBackendMessage
m

-- |Like 'pgPreparedQuery' but requests results lazily in chunks of the given size.
-- Does not use a named portal, so other requests may not intervene.
pgPreparedLazyQuery :: PGConnection -> BS.ByteString -> [OID] -> PGValues -> [Bool] -> Word32 -- ^ Chunk size (1 is common, 0 is all-at-once)
  -> IO [PGValues]
pgPreparedLazyQuery :: PGConnection
-> ByteString
-> [Word32]
-> PGValues
-> [Bool]
-> Word32
-> IO [PGValues]
pgPreparedLazyQuery PGConnection
c ByteString
sql [Word32]
types PGValues
bind [Bool]
bc Word32
count = do
  IO ()
start <- PGConnection
-> ByteString -> [Word32] -> PGValues -> [Bool] -> IO (IO ())
pgPreparedBind PGConnection
c ByteString
sql [Word32]
types PGValues
bind [Bool]
bc
  IO [PGValues] -> IO [PGValues]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [PGValues] -> IO [PGValues]) -> IO [PGValues] -> IO [PGValues]
forall a b. (a -> b) -> a -> b
$ do
    IO ()
execute
    IO ()
start
    ([PGValues] -> [PGValues]) -> IO [PGValues]
go [PGValues] -> [PGValues]
forall a. a -> a
id
  where
  execute :: IO ()
execute = do
    PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c Execute :: ByteString -> Word32 -> PGFrontendMessage
Execute{ portalName :: ByteString
portalName = ByteString
BS.empty, executeRows :: Word32
executeRows = Word32
count }
    PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c PGFrontendMessage
Flush
    PGConnection -> IO ()
pgFlush PGConnection
c
  go :: ([PGValues] -> [PGValues]) -> IO [PGValues]
go [PGValues] -> [PGValues]
r = PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c IO PGBackendMessage
-> (PGBackendMessage -> IO [PGValues]) -> IO [PGValues]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([PGValues] -> [PGValues]) -> PGBackendMessage -> IO [PGValues]
row [PGValues] -> [PGValues]
r
  row :: ([PGValues] -> [PGValues]) -> PGBackendMessage -> IO [PGValues]
row [PGValues] -> [PGValues]
r (DataRow PGValues
fs) = ([PGValues] -> [PGValues]) -> IO [PGValues]
go ([PGValues] -> [PGValues]
r ([PGValues] -> [PGValues])
-> ([PGValues] -> [PGValues]) -> [PGValues] -> [PGValues]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Bool] -> PGValues -> PGValues
fixBinary [Bool]
bc PGValues
fs PGValues -> [PGValues] -> [PGValues]
forall a. a -> [a] -> [a]
:))
  row [PGValues] -> [PGValues]
r PGBackendMessage
PortalSuspended = [PGValues] -> [PGValues]
r ([PGValues] -> [PGValues]) -> IO [PGValues] -> IO [PGValues]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [PGValues] -> IO [PGValues]
forall a. IO a -> IO a
unsafeInterleaveIO (IO ()
execute IO () -> IO [PGValues] -> IO [PGValues]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ([PGValues] -> [PGValues]) -> IO [PGValues]
go [PGValues] -> [PGValues]
forall a. a -> a
id)
  row [PGValues] -> [PGValues]
r (CommandComplete ByteString
_) = [PGValues] -> IO [PGValues]
forall (m :: * -> *) a. Monad m => a -> m a
return ([PGValues] -> [PGValues]
r [])
  row [PGValues] -> [PGValues]
r PGBackendMessage
EmptyQueryResponse = [PGValues] -> IO [PGValues]
forall (m :: * -> *) a. Monad m => a -> m a
return ([PGValues] -> [PGValues]
r [])
  row [PGValues] -> [PGValues]
_ PGBackendMessage
m = String -> IO [PGValues]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO [PGValues]) -> String -> IO [PGValues]
forall a b. (a -> b) -> a -> b
$ String
"pgPreparedLazyQuery: unexpected row: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGBackendMessage -> String
forall a. Show a => a -> String
show PGBackendMessage
m

-- |Close a previously prepared query (if necessary).
pgCloseStatement :: PGConnection -> BS.ByteString -> [OID] -> IO ()
pgCloseStatement :: PGConnection -> ByteString -> [Word32] -> IO ()
pgCloseStatement PGConnection
c ByteString
sql [Word32]
types = do
  Maybe PGPreparedStatement
mn <- IORef (Map (ByteString, [Word32]) PGPreparedStatement)
-> (Map (ByteString, [Word32]) PGPreparedStatement
    -> (Map (ByteString, [Word32]) PGPreparedStatement,
        Maybe PGPreparedStatement))
-> IO (Maybe PGPreparedStatement)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef (PGConnection
-> IORef (Map (ByteString, [Word32]) PGPreparedStatement)
connPreparedStatementMap PGConnection
c) ((Map (ByteString, [Word32]) PGPreparedStatement
  -> (Map (ByteString, [Word32]) PGPreparedStatement,
      Maybe PGPreparedStatement))
 -> IO (Maybe PGPreparedStatement))
-> (Map (ByteString, [Word32]) PGPreparedStatement
    -> (Map (ByteString, [Word32]) PGPreparedStatement,
        Maybe PGPreparedStatement))
-> IO (Maybe PGPreparedStatement)
forall a b. (a -> b) -> a -> b
$
    (Maybe PGPreparedStatement,
 Map (ByteString, [Word32]) PGPreparedStatement)
-> (Map (ByteString, [Word32]) PGPreparedStatement,
    Maybe PGPreparedStatement)
forall a b. (a, b) -> (b, a)
swap ((Maybe PGPreparedStatement,
  Map (ByteString, [Word32]) PGPreparedStatement)
 -> (Map (ByteString, [Word32]) PGPreparedStatement,
     Maybe PGPreparedStatement))
-> (Map (ByteString, [Word32]) PGPreparedStatement
    -> (Maybe PGPreparedStatement,
        Map (ByteString, [Word32]) PGPreparedStatement))
-> Map (ByteString, [Word32]) PGPreparedStatement
-> (Map (ByteString, [Word32]) PGPreparedStatement,
    Maybe PGPreparedStatement)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, [Word32])
 -> PGPreparedStatement -> Maybe PGPreparedStatement)
-> (ByteString, [Word32])
-> Map (ByteString, [Word32]) PGPreparedStatement
-> (Maybe PGPreparedStatement,
    Map (ByteString, [Word32]) PGPreparedStatement)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\(ByteString, [Word32])
_ PGPreparedStatement
_ -> Maybe PGPreparedStatement
forall a. Maybe a
Nothing) (ByteString
sql, [Word32]
types)
  (PGPreparedStatement -> IO ())
-> Maybe PGPreparedStatement -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
Fold.mapM_ (PGConnection -> PGPreparedStatement -> IO ()
pgClose PGConnection
c) Maybe PGPreparedStatement
mn

-- |Begin a new transaction. If there is already a transaction in progress (created with 'pgBegin' or 'pgTransaction') instead creates a savepoint.
pgBegin :: PGConnection -> IO ()
pgBegin :: PGConnection -> IO ()
pgBegin c :: PGConnection
c@PGConnection{ connTransaction :: PGConnection -> IORef Word
connTransaction = IORef Word
tr } = do
  Word
t <- IORef Word -> (Word -> (Word, Word)) -> IO Word
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Word
tr (Word -> Word
forall a. Enum a => a -> a
succ (Word -> Word) -> (Word -> Word) -> Word -> (Word, Word)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Word -> Word
forall a. a -> a
id)
  IO (Int, [PGValues]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Int, [PGValues]) -> IO ()) -> IO (Int, [PGValues]) -> IO ()
forall a b. (a -> b) -> a -> b
$ PGConnection -> ByteString -> IO (Int, [PGValues])
pgSimpleQuery PGConnection
c (ByteString -> IO (Int, [PGValues]))
-> ByteString -> IO (Int, [PGValues])
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BSLC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ if Word
t Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
0 then String
"BEGIN" else String
"SAVEPOINT pgt" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
t

predTransaction :: Word -> (Word, Word)
predTransaction :: Word -> (Word, Word)
predTransaction Word
0 = (Word
0, String -> Word
forall a. HasCallStack => String -> a
error String
"pgTransaction: no transactions")
predTransaction Word
x = (Word
x', Word
x') where x' :: Word
x' = Word -> Word
forall a. Enum a => a -> a
pred Word
x

-- |Rollback to the most recent 'pgBegin'.
pgRollback :: PGConnection -> IO ()
pgRollback :: PGConnection -> IO ()
pgRollback c :: PGConnection
c@PGConnection{ connTransaction :: PGConnection -> IORef Word
connTransaction = IORef Word
tr } = do
  Word
t <- IORef Word -> (Word -> (Word, Word)) -> IO Word
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Word
tr Word -> (Word, Word)
predTransaction
  IO (Int, [PGValues]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Int, [PGValues]) -> IO ()) -> IO (Int, [PGValues]) -> IO ()
forall a b. (a -> b) -> a -> b
$ PGConnection -> ByteString -> IO (Int, [PGValues])
pgSimpleQuery PGConnection
c (ByteString -> IO (Int, [PGValues]))
-> ByteString -> IO (Int, [PGValues])
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BSLC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ if Word
t Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
0 then String
"ROLLBACK" else String
"ROLLBACK TO SAVEPOINT pgt" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
t

-- |Commit the most recent 'pgBegin'.
pgCommit :: PGConnection -> IO ()
pgCommit :: PGConnection -> IO ()
pgCommit c :: PGConnection
c@PGConnection{ connTransaction :: PGConnection -> IORef Word
connTransaction = IORef Word
tr } = do
  Word
t <- IORef Word -> (Word -> (Word, Word)) -> IO Word
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Word
tr Word -> (Word, Word)
predTransaction
  IO (Int, [PGValues]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Int, [PGValues]) -> IO ()) -> IO (Int, [PGValues]) -> IO ()
forall a b. (a -> b) -> a -> b
$ PGConnection -> ByteString -> IO (Int, [PGValues])
pgSimpleQuery PGConnection
c (ByteString -> IO (Int, [PGValues]))
-> ByteString -> IO (Int, [PGValues])
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BSLC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ if Word
t Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
0 then String
"COMMIT" else String
"RELEASE SAVEPOINT pgt" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
t

-- |Rollback all active 'pgBegin's.
pgRollbackAll :: PGConnection -> IO ()
pgRollbackAll :: PGConnection -> IO ()
pgRollbackAll c :: PGConnection
c@PGConnection{ connTransaction :: PGConnection -> IORef Word
connTransaction = IORef Word
tr } = do
  IORef Word -> Word -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Word
tr Word
0
  IO (Int, [PGValues]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Int, [PGValues]) -> IO ()) -> IO (Int, [PGValues]) -> IO ()
forall a b. (a -> b) -> a -> b
$ PGConnection -> ByteString -> IO (Int, [PGValues])
pgSimpleQuery PGConnection
c (ByteString -> IO (Int, [PGValues]))
-> ByteString -> IO (Int, [PGValues])
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BSLC.pack String
"ROLLBACK"

-- |Commit all active 'pgBegin's.
pgCommitAll :: PGConnection -> IO ()
pgCommitAll :: PGConnection -> IO ()
pgCommitAll c :: PGConnection
c@PGConnection{ connTransaction :: PGConnection -> IORef Word
connTransaction = IORef Word
tr } = do
  IORef Word -> Word -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Word
tr Word
0
  IO (Int, [PGValues]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Int, [PGValues]) -> IO ()) -> IO (Int, [PGValues]) -> IO ()
forall a b. (a -> b) -> a -> b
$ PGConnection -> ByteString -> IO (Int, [PGValues])
pgSimpleQuery PGConnection
c (ByteString -> IO (Int, [PGValues]))
-> ByteString -> IO (Int, [PGValues])
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BSLC.pack String
"COMMIT"

-- |Wrap a computation in a 'pgBegin', 'pgCommit' block, or 'pgRollback' on exception.
pgTransaction :: PGConnection -> IO a -> IO a
pgTransaction :: PGConnection -> IO a -> IO a
pgTransaction PGConnection
c IO a
f = do
  PGConnection -> IO ()
pgBegin PGConnection
c
  IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
onException (do
    a
r <- IO a
f
    PGConnection -> IO ()
pgCommit PGConnection
c
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r)
    (PGConnection -> IO ()
pgRollback PGConnection
c)

-- |Prepare, bind, execute, and close a single (unnamed) query, and return the number of rows affected, or Nothing if there are (ignored) result rows.
pgRun :: PGConnection -> BSL.ByteString -> [OID] -> PGValues -> IO (Maybe Integer)
pgRun :: PGConnection
-> ByteString -> [Word32] -> PGValues -> IO (Maybe Integer)
pgRun PGConnection
c ByteString
sql [Word32]
types PGValues
bind = do
  PGConnection -> IO ()
pgSync PGConnection
c
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c Parse :: ByteString -> ByteString -> [Word32] -> PGFrontendMessage
Parse{ queryString :: ByteString
queryString = ByteString
sql, statementName :: ByteString
statementName = ByteString
BS.empty, parseTypes :: [Word32]
parseTypes = [Word32]
types }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c Bind :: ByteString -> ByteString -> PGValues -> [Bool] -> PGFrontendMessage
Bind{ portalName :: ByteString
portalName = ByteString
BS.empty, statementName :: ByteString
statementName = ByteString
BS.empty, bindParameters :: PGValues
bindParameters = PGValues
bind, binaryColumns :: [Bool]
binaryColumns = [] }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c Execute :: ByteString -> Word32 -> PGFrontendMessage
Execute{ portalName :: ByteString
portalName = ByteString
BS.empty, executeRows :: Word32
executeRows = Word32
1 } -- 0 does not mean none
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c PGFrontendMessage
Sync
  PGConnection -> IO ()
pgFlush PGConnection
c
  IO (Maybe Integer)
go where
  go :: IO (Maybe Integer)
go = PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c IO PGBackendMessage
-> (PGBackendMessage -> IO (Maybe Integer)) -> IO (Maybe Integer)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PGBackendMessage -> IO (Maybe Integer)
res
  res :: PGBackendMessage -> IO (Maybe Integer)
res PGBackendMessage
ParseComplete = IO (Maybe Integer)
go
  res PGBackendMessage
BindComplete = IO (Maybe Integer)
go
  res (DataRow PGValues
_) = IO (Maybe Integer)
go
  res PGBackendMessage
PortalSuspended = Maybe Integer -> IO (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing
  res (CommandComplete ByteString
d) = Maybe Integer -> IO (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Integer
forall i. (Integral i, Read i) => ByteString -> i
rowsAffected ByteString
d)
  res PGBackendMessage
EmptyQueryResponse = Maybe Integer -> IO (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0)
  res PGBackendMessage
m = String -> IO (Maybe Integer)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Maybe Integer)) -> String -> IO (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ String
"pgRun: unexpected response: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGBackendMessage -> String
forall a. Show a => a -> String
show PGBackendMessage
m

-- |Prepare a single query and return its handle.
pgPrepare :: PGConnection -> BSL.ByteString -> [OID] -> IO PGPreparedStatement
pgPrepare :: PGConnection -> ByteString -> [Word32] -> IO PGPreparedStatement
pgPrepare PGConnection
c ByteString
sql [Word32]
types = do
  PGPreparedStatement
n <- IORef Integer
-> (Integer -> (Integer, PGPreparedStatement))
-> IO PGPreparedStatement
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (PGConnection -> IORef Integer
connPreparedStatementCount PGConnection
c) (Integer -> Integer
forall a. Enum a => a -> a
succ (Integer -> Integer)
-> (Integer -> PGPreparedStatement)
-> Integer
-> (Integer, PGPreparedStatement)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Integer -> PGPreparedStatement
PGPreparedStatement)
  PGConnection -> IO ()
pgSync PGConnection
c
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c Parse :: ByteString -> ByteString -> [Word32] -> PGFrontendMessage
Parse{ queryString :: ByteString
queryString = ByteString
sql, statementName :: ByteString
statementName = PGPreparedStatement -> ByteString
preparedStatementName PGPreparedStatement
n, parseTypes :: [Word32]
parseTypes = [Word32]
types }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c PGFrontendMessage
Sync
  PGConnection -> IO ()
pgFlush PGConnection
c
  PGBackendMessage
ParseComplete <- PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
  PGPreparedStatement -> IO PGPreparedStatement
forall (m :: * -> *) a. Monad m => a -> m a
return PGPreparedStatement
n

-- |Close a previously prepared query.
pgClose :: PGConnection -> PGPreparedStatement -> IO ()
pgClose :: PGConnection -> PGPreparedStatement -> IO ()
pgClose PGConnection
c PGPreparedStatement
n = do
  PGConnection -> IO ()
pgSync PGConnection
c
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c ClosePortal :: ByteString -> PGFrontendMessage
ClosePortal{ portalName :: ByteString
portalName = PGPreparedStatement -> ByteString
preparedStatementName PGPreparedStatement
n }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c CloseStatement :: ByteString -> PGFrontendMessage
CloseStatement{ statementName :: ByteString
statementName = PGPreparedStatement -> ByteString
preparedStatementName PGPreparedStatement
n }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c PGFrontendMessage
Sync
  PGConnection -> IO ()
pgFlush PGConnection
c
  PGBackendMessage
CloseComplete <- PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
  PGBackendMessage
CloseComplete <- PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- |Bind a prepared statement, and return the row description.
-- After 'pgBind', you must either call 'pgFetch' until it completes (returns @(_, 'Just' _)@) or 'pgFinish' before calling 'pgBind' again on the same prepared statement.
pgBind :: PGConnection -> PGPreparedStatement -> PGValues -> IO PGRowDescription
pgBind :: PGConnection
-> PGPreparedStatement -> PGValues -> IO [PGColDescription]
pgBind PGConnection
c PGPreparedStatement
n PGValues
bind = do
  PGConnection -> IO ()
pgSync PGConnection
c
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c ClosePortal :: ByteString -> PGFrontendMessage
ClosePortal{ portalName :: ByteString
portalName = ByteString
sn }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c Bind :: ByteString -> ByteString -> PGValues -> [Bool] -> PGFrontendMessage
Bind{ portalName :: ByteString
portalName = ByteString
sn, statementName :: ByteString
statementName = ByteString
sn, bindParameters :: PGValues
bindParameters = PGValues
bind, binaryColumns :: [Bool]
binaryColumns = [] }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c DescribePortal :: ByteString -> PGFrontendMessage
DescribePortal{ portalName :: ByteString
portalName = ByteString
sn }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c PGFrontendMessage
Sync
  PGConnection -> IO ()
pgFlush PGConnection
c
  PGBackendMessage
CloseComplete <- PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
  PGBackendMessage
BindComplete <- PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
  PGBackendMessage -> [PGColDescription]
rowDescription (PGBackendMessage -> [PGColDescription])
-> IO PGBackendMessage -> IO [PGColDescription]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
  where sn :: ByteString
sn = PGPreparedStatement -> ByteString
preparedStatementName PGPreparedStatement
n

-- |Fetch some rows from an executed prepared statement, returning the next N result rows (if any) and number of affected rows when complete.
pgFetch :: PGConnection -> PGPreparedStatement -> Word32 -- ^Maximum number of rows to return, or 0 for all
  -> IO ([PGValues], Maybe Integer)
pgFetch :: PGConnection
-> PGPreparedStatement -> Word32 -> IO ([PGValues], Maybe Integer)
pgFetch PGConnection
c PGPreparedStatement
n Word32
count = do
  PGConnection -> IO ()
pgSync PGConnection
c
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c Execute :: ByteString -> Word32 -> PGFrontendMessage
Execute{ portalName :: ByteString
portalName = PGPreparedStatement -> ByteString
preparedStatementName PGPreparedStatement
n, executeRows :: Word32
executeRows = Word32
count }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c PGFrontendMessage
Sync
  PGConnection -> IO ()
pgFlush PGConnection
c
  IO ([PGValues], Maybe Integer)
go where
  go :: IO ([PGValues], Maybe Integer)
go = PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c IO PGBackendMessage
-> (PGBackendMessage -> IO ([PGValues], Maybe Integer))
-> IO ([PGValues], Maybe Integer)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PGBackendMessage -> IO ([PGValues], Maybe Integer)
res
  res :: PGBackendMessage -> IO ([PGValues], Maybe Integer)
res (DataRow PGValues
v) = ([PGValues] -> [PGValues])
-> ([PGValues], Maybe Integer) -> ([PGValues], Maybe Integer)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (PGValues
v PGValues -> [PGValues] -> [PGValues]
forall a. a -> [a] -> [a]
:) (([PGValues], Maybe Integer) -> ([PGValues], Maybe Integer))
-> IO ([PGValues], Maybe Integer) -> IO ([PGValues], Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ([PGValues], Maybe Integer)
go
  res PGBackendMessage
PortalSuspended = ([PGValues], Maybe Integer) -> IO ([PGValues], Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Maybe Integer
forall a. Maybe a
Nothing)
  res (CommandComplete ByteString
d) = do
    PGConnection -> IO ()
pgSync PGConnection
c
    PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c ClosePortal :: ByteString -> PGFrontendMessage
ClosePortal{ portalName :: ByteString
portalName = PGPreparedStatement -> ByteString
preparedStatementName PGPreparedStatement
n }
    PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c PGFrontendMessage
Sync
    PGConnection -> IO ()
pgFlush PGConnection
c
    PGBackendMessage
CloseComplete <- PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
    ([PGValues], Maybe Integer) -> IO ([PGValues], Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Integer
forall i. (Integral i, Read i) => ByteString -> i
rowsAffected ByteString
d)
  res PGBackendMessage
EmptyQueryResponse = ([PGValues], Maybe Integer) -> IO ([PGValues], Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0)
  res PGBackendMessage
m = String -> IO ([PGValues], Maybe Integer)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ([PGValues], Maybe Integer))
-> String -> IO ([PGValues], Maybe Integer)
forall a b. (a -> b) -> a -> b
$ String
"pgFetch: unexpected response: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PGBackendMessage -> String
forall a. Show a => a -> String
show PGBackendMessage
m

-- |Retrieve a notifications, blocking if necessary.
pgGetNotification :: PGConnection -> IO PGNotification
pgGetNotification :: PGConnection -> IO PGNotification
pgGetNotification PGConnection
c =
  IO PGNotification
-> (PGNotification -> IO PGNotification)
-> Maybe PGNotification
-> IO PGNotification
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PGConnection -> IO PGNotification
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c) PGNotification -> IO PGNotification
forall (m :: * -> *) a. Monad m => a -> m a
return
   (Maybe PGNotification -> IO PGNotification)
-> IO (Maybe PGNotification) -> IO PGNotification
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Queue PGNotification)
-> (Queue PGNotification
    -> (Queue PGNotification, Maybe PGNotification))
-> IO (Maybe PGNotification)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (PGConnection -> IORef (Queue PGNotification)
connNotifications PGConnection
c) Queue PGNotification
-> (Queue PGNotification, Maybe PGNotification)
forall a. Queue a -> (Queue a, Maybe a)
deQueue

-- |Retrieve any pending notifications.  Non-blocking.
pgGetNotifications :: PGConnection -> IO [PGNotification]
pgGetNotifications :: PGConnection -> IO [PGNotification]
pgGetNotifications PGConnection
c = do
  RecvNonBlock
RecvNonBlock <- PGConnection -> IO RecvNonBlock
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
  Queue PGNotification -> [PGNotification]
forall a. Queue a -> [a]
queueToList (Queue PGNotification -> [PGNotification])
-> IO (Queue PGNotification) -> IO [PGNotification]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Queue PGNotification)
-> (Queue PGNotification
    -> (Queue PGNotification, Queue PGNotification))
-> IO (Queue PGNotification)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (PGConnection -> IORef (Queue PGNotification)
connNotifications PGConnection
c) (Queue PGNotification
forall a. Queue a
emptyQueue, )
  where
  queueToList :: Queue a -> [a]
  queueToList :: Queue a -> [a]
queueToList (Queue [a]
e [a]
d) = [a]
d [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
e


--TODO: Implement non-blocking recv on mingw32
#ifndef mingw32_HOST_OS
recvNonBlock
  :: Net.Socket        -- ^ Connected socket
  -> Int               -- ^ Maximum number of bytes to receive
  -> IO BS.ByteString  -- ^ Data received
recvNonBlock :: Socket -> Int -> IO ByteString
recvNonBlock Socket
s Int
nbytes
  | Int
nbytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = IOError -> IO ByteString
forall a. IOError -> IO a
ioError (String -> IOError
mkInvalidRecvArgError String
"Database.PostgreSQL.Typed.Protocol.recvNonBlock")
  | Bool
otherwise  = Int -> (Ptr Word8 -> IO Int) -> IO ByteString
createAndTrim Int
nbytes ((Ptr Word8 -> IO Int) -> IO ByteString)
-> (Ptr Word8 -> IO Int) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> Socket -> Ptr Word8 -> Int -> IO Int
recvBufNonBlock Socket
s Ptr Word8
ptr Int
nbytes

recvBufNonBlock :: Net.Socket -> Ptr Word8 -> Int -> IO Int
recvBufNonBlock :: Socket -> Ptr Word8 -> Int -> IO Int
recvBufNonBlock Socket
s Ptr Word8
ptr Int
nbytes
 | Int
nbytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = IOError -> IO Int
forall a. IOError -> IO a
ioError (String -> IOError
mkInvalidRecvArgError String
"Database.PostgreSQL.Typed.recvBufNonBlock")
 | Bool
otherwise   = do
    ProtocolNumber
len <-
#if MIN_VERSION_network(3,1,0)
      Socket
-> (ProtocolNumber -> IO ProtocolNumber) -> IO ProtocolNumber
forall r. Socket -> (ProtocolNumber -> IO r) -> IO r
Net.withFdSocket Socket
s ((ProtocolNumber -> IO ProtocolNumber) -> IO ProtocolNumber)
-> (ProtocolNumber -> IO ProtocolNumber) -> IO ProtocolNumber
forall a b. (a -> b) -> a -> b
$ \ProtocolNumber
fd ->
#elif MIN_VERSION_network(3,0,0)
      Net.fdSocket s >>= \fd ->
#else
      let fd = Net.fdSocket s in
#endif
        ProtocolNumber
-> Ptr CChar -> CSize -> ProtocolNumber -> IO ProtocolNumber
c_recv ProtocolNumber
fd (Ptr Word8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr) (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nbytes) ProtocolNumber
0
    if ProtocolNumber
len ProtocolNumber -> ProtocolNumber -> Bool
forall a. Eq a => a -> a -> Bool
== -ProtocolNumber
1
      then do
        Errno
errno <- IO Errno
getErrno
        if Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eWOULDBLOCK
          then Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
          else IOError -> IO Int
forall e a. Exception e => e -> IO a
throwIO (String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError String
"recvBufNonBlock" Errno
errno Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
"Database.PostgreSQL.Typed"))
      else
        Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ ProtocolNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ProtocolNumber
len

mkInvalidRecvArgError :: String -> IOError
mkInvalidRecvArgError :: String -> IOError
mkInvalidRecvArgError String
loc = IOError -> String -> IOError
ioeSetErrorString (IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError
                                    IOErrorType
InvalidArgument
                                    String
loc Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing) String
"non-positive length"


foreign import ccall unsafe "recv"
  c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt
#endif