{-# 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)
#if defined(VERSION_cryptonite) || defined(VERSION_crypton)
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
$cshowsPrec :: Int -> PGState -> ShowS
showsPrec :: Int -> PGState -> ShowS
$cshow :: PGState -> String
show :: PGState -> String
$cshowList :: [PGState] -> ShowS
showList :: [PGState] -> ShowS
Show, PGState -> PGState -> Bool
(PGState -> PGState -> Bool)
-> (PGState -> PGState -> Bool) -> Eq PGState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PGState -> PGState -> Bool
== :: PGState -> PGState -> Bool
$c/= :: PGState -> PGState -> Bool
/= :: 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
$cshowsPrec :: Int -> PGTlsValidateMode -> ShowS
showsPrec :: Int -> PGTlsValidateMode -> ShowS
$cshow :: PGTlsValidateMode -> String
show :: PGTlsValidateMode -> String
$cshowList :: [PGTlsValidateMode] -> ShowS
showList :: [PGTlsValidateMode] -> ShowS
Show, PGTlsValidateMode -> PGTlsValidateMode -> Bool
(PGTlsValidateMode -> PGTlsValidateMode -> Bool)
-> (PGTlsValidateMode -> PGTlsValidateMode -> Bool)
-> Eq PGTlsValidateMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PGTlsValidateMode -> PGTlsValidateMode -> Bool
== :: PGTlsValidateMode -> PGTlsValidateMode -> Bool
$c/= :: PGTlsValidateMode -> PGTlsValidateMode -> Bool
/= :: 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
$c== :: PGTlsMode -> PGTlsMode -> Bool
== :: PGTlsMode -> PGTlsMode -> Bool
$c/= :: PGTlsMode -> PGTlsMode -> Bool
/= :: 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
$cshowsPrec :: Int -> PGTlsMode -> ShowS
showsPrec :: Int -> PGTlsMode -> ShowS
$cshow :: PGTlsMode -> String
show :: PGTlsMode -> String
$cshowList :: [PGTlsMode] -> ShowS
showList :: [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 -> [SignedCertificate]
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"
    (SignedCertificate
x:[SignedCertificate]
_) -> PGTlsMode -> Either String PGTlsMode
forall a b. b -> Either a b
Right (PGTlsValidateMode -> SignedCertificate -> PGTlsMode
TlsValidate PGTlsValidateMode
mode SignedCertificate
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
$cshowsPrec :: Int -> PGDatabase -> ShowS
showsPrec :: Int -> PGDatabase -> ShowS
$cshow :: PGDatabase -> String
show :: PGDatabase -> String
$cshowList :: [PGDatabase] -> ShowS
showList :: [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
$c== :: PGPreparedStatement -> PGPreparedStatement -> Bool
== :: PGPreparedStatement -> PGPreparedStatement -> Bool
$c/= :: PGPreparedStatement -> PGPreparedStatement -> Bool
/= :: 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
$cshowsPrec :: Int -> PGPreparedStatement -> ShowS
showsPrec :: Int -> PGPreparedStatement -> ShowS
$cshow :: PGPreparedStatement -> String
show :: PGPreparedStatement -> String
$cshowList :: [PGPreparedStatement] -> ShowS
showList :: [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 a. a -> IO a
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 a. a -> IO a
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
$cshowsPrec :: Int -> PGColDescription -> ShowS
showsPrec :: Int -> PGColDescription -> ShowS
$cshow :: PGColDescription -> String
show :: PGColDescription -> String
$cshowList :: [PGColDescription] -> ShowS
showList :: [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
$cshowsPrec :: Int -> PGNotification -> ShowS
showsPrec :: Int -> PGNotification -> ShowS
$cshow :: PGNotification -> String
show :: PGNotification -> String
$cshowList :: [PGNotification] -> ShowS
showList :: [PGNotification] -> ShowS
Show)

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

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

enQueue :: a -> Queue a -> Queue a
enQueue :: forall a. 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 :: forall a. 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
$cshowsPrec :: Int -> PGFrontendMessage -> ShowS
showsPrec :: Int -> PGFrontendMessage -> ShowS
$cshow :: PGFrontendMessage -> String
show :: PGFrontendMessage -> String
$cshowList :: [PGFrontendMessage] -> ShowS
showList :: [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
$cshowsPrec :: Int -> PGBackendMessage -> ShowS
showsPrec :: Int -> PGBackendMessage -> ShowS
$cshow :: PGBackendMessage -> String
show :: PGBackendMessage -> String
$cshowList :: [PGBackendMessage] -> ShowS
showList :: [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 a. [a] -> 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 a. [a] -> 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
  { 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
  t <- IO UTCTime
getCurrentTime
  hPutStrLn stderr $ show t ++ 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

#if defined(VERSION_cryptonite) || defined(VERSION_crypton)
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 m a. Monoid m => (a -> m) -> [a] -> m
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 a. [a] -> 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 m a. Monoid m => (a -> m) -> [a] -> m
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 a. [a] -> 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 m a. Monoid m => (a -> m) -> [a] -> m
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 a. [a] -> 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 m a. Monoid m => (a -> m) -> [a] -> m
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 a. [a] -> 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 m a. Monoid m => (a -> m) -> [a] -> m
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 m a. Monoid m => (a -> m) -> Maybe a -> m
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 b c d. (b -> c) -> (d, b) -> (d, c)
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 a b. (a -> b) -> Get a -> Get b
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 a. a -> Get a
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 a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
AuthenticationOk
  auth a
3 = PGBackendMessage -> Get PGBackendMessage
forall a. a -> Get a
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 a. String -> Get a
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
  numParams <- Get Word16
G.getWord16be
  ParameterDescription <$> replicateM (fromIntegral numParams) G.getWord32be
getMessageBody Char
'T' = do
  numFields <- Get Word16
G.getWord16be
  RowDescription <$> replicateM (fromIntegral numFields) getField where
  getField :: Get PGColDescription
getField = do
    name <- Get ByteString
getByteStringNul
    oid <- G.getWord32be -- table OID
    col <- G.getWord16be -- column number
    typ' <- G.getWord32be -- type
    siz <- G.getWord16be -- type size
    tmod <- G.getWord32be -- type modifier
    fmt <- G.getWord16be -- format code
    return $ PGColDescription
      { pgColName = name
      , pgColTable = oid
      , pgColNumber = fromIntegral col
      , pgColType = typ'
      , pgColSize = fromIntegral siz
      , pgColModifier = fromIntegral tmod
      , pgColBinary = toEnum (fromIntegral 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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PGState
StateIdle
  rs Char
'T' = PGState -> m PGState
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PGState
StateTransaction
  rs Char
'E' = PGState -> m PGState
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PGState
StateTransactionFailed
  rs Char
s = String -> m PGState
forall a. String -> m a
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 a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
ParseComplete
getMessageBody Char
'2' = PGBackendMessage -> Get PGBackendMessage
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
BindComplete
getMessageBody Char
'3' = PGBackendMessage -> Get PGBackendMessage
forall a. a -> Get a
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 
  numFields <- Get Word16
G.getWord16be
  DataRow <$> replicateM (fromIntegral numFields) (getField =<< G.getWord32be) where
  getField :: a -> Get PGValue
getField a
0xFFFFFFFF = PGValue -> Get PGValue
forall a. a -> Get a
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 a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
EmptyQueryResponse
getMessageBody Char
'n' = PGBackendMessage -> Get PGBackendMessage
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
NoData
getMessageBody Char
's' = PGBackendMessage -> Get PGBackendMessage
forall a. a -> Get a
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 a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ByteString
getByteStringNul
    Get (ByteString -> PGNotification)
-> Get ByteString -> Get PGNotification
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ByteString
G.getLazyByteStringNul
getMessageBody Char
t = String -> Get PGBackendMessage
forall a. String -> Get a
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
  typ <- Get Word8
G.getWord8
  len <- G.getWord32be
  G.isolate (fromIntegral len - 4) $ getMessageBody (w2c 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
    r <- PGHandle -> Int -> IO ByteString
pgGetSome (PGConnection -> PGHandle
connHandle PGConnection
c) Int
smallChunkSize
    if BS.null r
      then do
        writeIORef (connState c) StateClosed
        pgCloseHandle (connHandle c)
        -- Should this instead be a special PGError?
        ioError $ mkIOError eofErrorType "PGConnection" Nothing Nothing
      else
        return (Right 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 a b. a -> IO b -> IO a
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 a b. a -> IO b -> IO a
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 a b. a -> IO b -> IO a
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
$cshowsPrec :: Int -> RecvNonBlock -> ShowS
showsPrec :: Int -> RecvNonBlock -> ShowS
$cshow :: RecvNonBlock -> String
show :: RecvNonBlock -> String
$cshowList :: [RecvNonBlock] -> ShowS
showList :: [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
    r <- Socket -> Int -> IO ByteString
recvNonBlock Socket
s Int
smallChunkSize
    if BS.null r
      then return (Left RecvNonBlock)
      else return (Right 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. (HasCallStack, 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
$cshowsPrec :: Int -> RecvSync -> ShowS
showsPrec :: Int -> RecvSync -> ShowS
$cshow :: RecvSync -> String
show :: RecvSync -> String
$cshowList :: [RecvSync] -> ShowS
showList :: [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 a. a -> IO a
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. (HasCallStack, 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 a. a -> IO a
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. (HasCallStack, 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 a. a -> IO a
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 :: forall m. RecvMsg m => 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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO b
forall a. String -> IO a
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 a b. IO a -> (a -> 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 a b. a -> IO b -> IO a
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 a b. a -> IO b -> IO 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 a b. a -> IO b -> IO 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
    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 s' == StatePending
      then return recvMsgSync -- expected
      else recvMsg c 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 a b. IO a -> (a -> 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 a b. a -> IO b -> IO a
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
  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
  state <- newIORef StateUnsync
  prepc <- newIORef 0
  prepm <- newIORef Map.empty
  input <- newIORef getMessage
  tr <- newIORef 0
  notif <- newIORef emptyQueue
  addr <- either
    (\(String
h,String
p) -> [AddrInfo] -> AddrInfo
forall a. HasCallStack => [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]
forall (t :: * -> *).
GetAddrInfo t =>
Maybe AddrInfo -> Maybe String -> Maybe String -> IO (t 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AddrInfo
defai{ Net.addrAddress = a, Net.addrFamily = case 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 })
    $ pgDBAddr db
  sock <- Net.socket (Net.addrFamily addr) (Net.addrSocketType addr) (Net.addrProtocol addr)
  unless (Net.addrFamily addr == Net.AF_UNIX) $ Net.setSocketOption sock Net.NoDelay 1
  Net.connect sock $ Net.addrAddress addr
  pgHandle <- mkPGHandle db sock
  let c = 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
        }
  pgSend c $ StartupMessage $
    [ ("user", pgDBUser db)
    , ("database", pgDBName db)
    , ("client_encoding", "UTF8")
    , ("standard_conforming_strings", "on")
    , ("bytea_output", "hex")
    , ("DateStyle", "ISO, YMD")
    , ("IntervalStyle", "iso_8601")
    , ("extra_float_digits", "3")
    ] ++ pgDBParams db
  pgFlush c
  conn c
  where
  defai :: AddrInfo
defai = AddrInfo
Net.defaultHints{ Net.addrSocketType = 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 a b. IO a -> (a -> IO b) -> IO b
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
    cp <- IORef (Map ByteString ByteString) -> IO (Map ByteString ByteString)
forall a. IORef a -> IO a
readIORef (PGConnection -> IORef (Map ByteString ByteString)
connParameters PGConnection
c)
    return c
      { connTypeEnv = PGTypeEnv
        { pgIntegerDatetimes = fmap ("on" ==) $ Map.lookup "integer_datetimes" cp
        , pgServerVersion = Map.lookup "server_version" cp
        }
      }
  msg PGConnection
c (Left (BackendKeyData Word32
p Word32
k)) = PGConnection -> IO PGConnection
conn PGConnection
c{ connPid = p, connKey = 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
#if defined(VERSION_cryptonite) || defined(VERSION_crypton)
  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 a. String -> IO a
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Socket -> PGHandle
PGSocket Socket
sock)
    PGTlsMode
TlsNoValidate   -> IO PGHandle
mkTlsContext
    TlsValidate PGTlsValidateMode
_ SignedCertificate
_ -> IO PGHandle
mkTlsContext
  where
    mkTlsContext :: IO PGHandle
mkTlsContext = do
      Socket -> ByteString -> IO ()
NetBSL.sendAll Socket
sock ByteString
sslRequest
      resp <- Socket -> Int -> IO ByteString
NetBS.recv Socket
sock Int
1
      case resp of
        ByteString
"S" -> do
          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
          void $ TLS.handshake ctx
          pure $ PGTlsContext ctx
        ByteString
"N" -> IOError -> IO PGHandle
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (String -> IOError
userError String
"Server does not support TLS")
        ByteString
_ -> IOError -> IO PGHandle
forall e a. (HasCallStack, 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)
      { TLS.clientSupported =
          def { TLS.supportedCiphers = TLS.ciphersuite_strong }
      , TLS.clientShared = clientShared
      , TLS.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 { TLS.sharedValidationCache = noValidate }
        PGTlsMode
TlsNoValidate -> Shared
forall a. Default a => a
def { TLS.sharedValidationCache = noValidate }
        TlsValidate PGTlsValidateMode
_ SignedCertificate
sc -> Shared
forall a. Default a => a
def { TLS.sharedCAStore = makeCertificateStore [sc] }
    clientHooks :: ClientHooks
clientHooks =
      case PGDatabase -> PGTlsMode
pgDBTLS PGDatabase
db of
        TlsValidate PGTlsValidateMode
TlsValidateCA SignedCertificate
_ -> ClientHooks
forall a. Default a => a
def { TLS.onServerCertificate = validateNoCheckFQHN }
        PGTlsMode
_                           -> ClientHooks
forall a. Default a => a
def
    validateNoCheckFQHN :: CertificateStore
-> ValidationCache
-> ServiceID
-> CertificateChain
-> IO [FailedReason]
validateNoCheckFQHN = HashALG
-> ValidationHooks
-> ValidationChecks
-> CertificateStore
-> ValidationCache
-> ServiceID
-> CertificateChain
-> IO [FailedReason]
Data.X509.Validation.validate HashALG
HashSHA256 ValidationHooks
forall a. Default a => a
def (ValidationChecks
forall a. Default a => a
def { TLS.checkFQHN = False })

    noValidate :: ValidationCache
noValidate = ValidationCacheQueryCallback
-> ValidationCacheAddCallback -> ValidationCache
TLS.ValidationCache
      (\ServiceID
_ Fingerprint
_ Certificate
_ -> ValidationCacheResult -> IO ValidationCacheResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationCacheResult
TLS.ValidationCachePass)
      (\ServiceID
_ Fingerprint
_ Certificate
_ -> () -> IO ()
forall a. a -> IO a
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
  s <- IORef PGState -> IO PGState
forall a. IORef a -> IO a
readIORef IORef PGState
cs
  unless (s == StateClosed) $
    pgDisconnect 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
  s <- IORef PGState -> IO PGState
forall a. IORef a -> IO a
readIORef IORef PGState
cs
  if cd == d && s /= StateClosed
    then return c{ connDatabase = d }
    else do
      pgDisconnectOnce c
      pgConnect d

pgSync :: PGConnection -> IO ()
pgSync :: PGConnection -> IO ()
pgSync c :: PGConnection
c@PGConnection{ connState :: PGConnection -> IORef PGState
connState = IORef PGState
sr } = do
  s <- IORef PGState -> IO PGState
forall a. IORef a -> IO a
readIORef IORef PGState
sr
  case s of
    PGState
StateClosed -> String -> IO ()
forall a. String -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
  wait :: IO ()
wait = do
    RecvSync <- PGConnection -> IO RecvSync
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
    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{ queryString :: ByteString
queryString = ByteString
sql, statementName :: ByteString
statementName = ByteString
BS.empty, parseTypes :: [Word32]
parseTypes = [Word32]
types }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
h DescribeStatement{ statementName :: ByteString
statementName = ByteString
BS.empty }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
h PGFrontendMessage
Sync
  PGConnection -> IO ()
pgFlush PGConnection
h
  PGBackendMessage -> IO ([Word32], [(ByteString, Word32, Bool)])
ParseComplete <- PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
h
  ParameterDescription ps <- pgRecv h
  (,) ps <$> (mapM desc . rowDescription =<< pgRecv 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
    n <- Word32 -> Int16 -> IO Bool
nullable Word32
tab Int16
col
    return (name, typ, 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.
      (_, 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 r of
        [[PGValue
s]] -> Bool -> IO Bool
forall a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        [PGValues]
_ -> String -> IO Bool
forall a. String -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

rowsAffected :: (Integral i, Read i) => BS.ByteString -> i
rowsAffected :: forall i. (Integral i, Read i) => ByteString -> i
rowsAffected = [ByteString] -> i
forall {a}. (Num a, Read a) => [ByteString] -> a
ra ([ByteString] -> i)
-> (ByteString -> [ByteString]) -> ByteString -> i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BSC.words where
  ra :: [ByteString] -> a
ra [] = -a
1
  ra [ByteString]
l = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (-a
1) (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe a) -> String -> Maybe a
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. HasCallStack => [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 a b. IO a -> (a -> 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
0, [])
  start PGBackendMessage
m = String -> IO (a, [PGValues])
forall a. String -> IO a
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 a. String -> IO a
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 a. a -> m a
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 a b. IO a -> (a -> IO b) -> IO b
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  res Either PGBackendMessage RecvSync
m = String -> IO ()
forall a. String -> IO a
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
  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)
  (p, n) <- maybe
    (atomicModifyIORef' (connPreparedStatementCount c) (succ &&& (,) False . PGPreparedStatement))
    (return . (,) True) $ Map.lookup key m
  unless p $
    pgSend c Parse{ queryString = BSL.fromStrict sql, statementName = preparedStatementName n, parseTypes = types }
  pgSend c Bind{ portalName = BS.empty, statementName = preparedStatementName n, bindParameters = bind, binaryColumns = bc }
  let
    go = PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c IO PGBackendMessage -> (PGBackendMessage -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PGBackendMessage -> IO ()
start
    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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    start PGBackendMessage
r = String -> IO ()
forall a. String -> IO a
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
  return 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
  start <- PGConnection
-> ByteString -> [Word32] -> PGValues -> [Bool] -> IO (IO ())
pgPreparedBind PGConnection
c ByteString
sql [Word32]
types PGValues
bind [Bool]
bc
  pgSend c Execute{ portalName = BS.empty, executeRows = 0 }
  pgSend c Sync
  pgFlush c
  start
  go 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 a b. IO a -> (a -> IO b) -> IO 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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
0, [PGValues] -> b
r [])
  row [PGValues] -> b
_ PGBackendMessage
m = String -> IO (a, b)
forall a. String -> IO a
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
  start <- PGConnection
-> ByteString -> [Word32] -> PGValues -> [Bool] -> IO (IO ())
pgPreparedBind PGConnection
c ByteString
sql [Word32]
types PGValues
bind [Bool]
bc
  unsafeInterleaveIO $ do
    execute
    start
    go id
  where
  execute :: IO ()
execute = do
    PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c 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 a b. IO a -> (a -> IO b) -> IO b
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 a b. IO a -> IO b -> IO b
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PGValues] -> [PGValues]
r [])
  row [PGValues] -> [PGValues]
r PGBackendMessage
EmptyQueryResponse = [PGValues] -> IO [PGValues]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PGValues] -> [PGValues]
r [])
  row [PGValues] -> [PGValues]
_ PGBackendMessage
m = String -> IO [PGValues]
forall a. String -> IO a
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
  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)
  Fold.mapM_ (pgClose c) 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
  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 b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Word -> Word
forall a. a -> a
id)
  void $ pgSimpleQuery c $ BSLC.pack $ if t == 0 then "BEGIN" else "SAVEPOINT pgt" ++ show 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
  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
  void $ pgSimpleQuery c $ BSLC.pack $ if t == 0 then "ROLLBACK" else "ROLLBACK TO SAVEPOINT pgt" ++ show 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
  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
  void $ pgSimpleQuery c $ BSLC.pack $ if t == 0 then "COMMIT" else "RELEASE SAVEPOINT pgt" ++ show 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 :: forall a. 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
    r <- IO a
f
    pgCommit c
    return 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{ queryString :: ByteString
queryString = ByteString
sql, statementName :: ByteString
statementName = ByteString
BS.empty, parseTypes :: [Word32]
parseTypes = [Word32]
types }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c 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{ 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 a b. IO a -> (a -> IO b) -> IO b
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 a. String -> IO a
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
  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 b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Integer -> PGPreparedStatement
PGPreparedStatement)
  pgSync c
  pgSend c Parse{ queryString = sql, statementName = preparedStatementName n, parseTypes = types }
  pgSend c Sync
  pgFlush c
  ParseComplete <- pgRecv c
  return 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{ portalName :: ByteString
portalName = PGPreparedStatement -> ByteString
preparedStatementName PGPreparedStatement
n }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c CloseStatement{ statementName :: ByteString
statementName = PGPreparedStatement -> ByteString
preparedStatementName PGPreparedStatement
n }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c PGFrontendMessage
Sync
  PGConnection -> IO ()
pgFlush PGConnection
c
  PGBackendMessage -> IO ()
CloseComplete <- PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
  CloseComplete <- pgRecv c
  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{ portalName :: ByteString
portalName = ByteString
sn }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c 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{ portalName :: ByteString
portalName = ByteString
sn }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c PGFrontendMessage
Sync
  PGConnection -> IO ()
pgFlush PGConnection
c
  PGBackendMessage -> IO [PGColDescription]
CloseComplete <- PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
  BindComplete <- pgRecv c
  rowDescription <$> pgRecv 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{ 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 a b. IO a -> (a -> IO b) -> IO b
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 b c d. (b -> c) -> (b, d) -> (c, d)
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 a. a -> IO a
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{ portalName :: ByteString
portalName = PGPreparedStatement -> ByteString
preparedStatementName PGPreparedStatement
n }
    PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c PGFrontendMessage
Sync
    PGConnection -> IO ()
pgFlush PGConnection
c
    PGBackendMessage -> IO ([PGValues], Maybe Integer)
CloseComplete <- PGConnection -> IO PGBackendMessage
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
    return ([], Just $ rowsAffected d)
  res PGBackendMessage
EmptyQueryResponse = ([PGValues], Maybe Integer) -> IO ([PGValues], Maybe Integer)
forall a. a -> IO a
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 a. String -> IO a
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 a. a -> IO a
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 <- PGConnection -> IO RecvNonBlock
forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
  queueToList <$> atomicModifyIORef' (connNotifications c) (emptyQueue, )
  where
  queueToList :: Queue a -> [a]
  queueToList :: forall a. 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
    len <-
#if MIN_VERSION_network(3,1,0)
      Socket -> (CInt -> IO CInt) -> IO CInt
forall r. Socket -> (CInt -> IO r) -> IO r
Net.withFdSocket Socket
s ((CInt -> IO CInt) -> IO CInt) -> (CInt -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \CInt
fd ->
#elif MIN_VERSION_network(3,0,0)
      Net.fdSocket s >>= \fd ->
#else
      let fd = Net.fdSocket s in
#endif
        CInt -> Ptr CChar -> CSize -> CInt -> IO CInt
c_recv CInt
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) CInt
0
    if len == -1
      then do
        errno <- getErrno
        if errno == eWOULDBLOCK
          then return 0
          else throwIO (errnoToIOError "recvBufNonBlock" errno Nothing (Just "Database.PostgreSQL.Typed"))
      else
        return $ fromIntegral 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