{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGState] -> ShowS
$cshowList :: [PGState] -> ShowS
show :: PGState -> String
$cshow :: PGState -> String
showsPrec :: Int -> PGState -> ShowS
$cshowsPrec :: Int -> PGState -> ShowS
Show, PGState -> PGState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PGState -> PGState -> Bool
$c/= :: PGState -> PGState -> Bool
== :: PGState -> PGState -> Bool
$c== :: PGState -> PGState -> Bool
Eq)

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

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

-- | Constructs a 'PGTlsMode' to validate the server certificate with given root
-- certificate (in PEM format)
pgTlsValidate :: PGTlsValidateMode -> BSC.ByteString -> Either String PGTlsMode
pgTlsValidate :: PGTlsValidateMode -> ByteString -> Either String PGTlsMode
pgTlsValidate PGTlsValidateMode
mode ByteString
certPem =
  case forall a.
(ASN1Object a, Eq a, Show a) =>
ByteString -> [SignedExact a]
readSignedObjectFromMemory ByteString
certPem of
    []  -> forall a b. a -> Either a b
Left String
"Could not parse any certificate in PEM"
    (SignedCertificate
x:[SignedCertificate]
_) -> 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGDatabase] -> ShowS
$cshowList :: [PGDatabase] -> ShowS
show :: PGDatabase -> String
$cshow :: PGDatabase -> String
showsPrec :: Int -> PGDatabase -> ShowS
$cshowsPrec :: Int -> PGDatabase -> ShowS
Show)

instance Eq PGDatabase where
#ifdef VERSION_tls
  PGDatabase Either (String, String) SockAddr
a1 ByteString
n1 ByteString
u1 ByteString
p1 [(ByteString, ByteString)]
l1 Bool
_ MessageFields -> IO ()
_ PGTlsMode
s1 == :: PGDatabase -> PGDatabase -> Bool
== PGDatabase Either (String, String) SockAddr
a2 ByteString
n2 ByteString
u2 ByteString
p2 [(ByteString, ByteString)]
l2 Bool
_ MessageFields -> IO ()
_ PGTlsMode
s2 =
    Either (String, String) SockAddr
a1 forall a. Eq a => a -> a -> Bool
== Either (String, String) SockAddr
a2 Bool -> Bool -> Bool
&& ByteString
n1 forall a. Eq a => a -> a -> Bool
== ByteString
n2 Bool -> Bool -> Bool
&& ByteString
u1 forall a. Eq a => a -> a -> Bool
== ByteString
u2 Bool -> Bool -> Bool
&& ByteString
p1 forall a. Eq a => a -> a -> Bool
== ByteString
p2 Bool -> Bool -> Bool
&& [(ByteString, ByteString)]
l1 forall a. Eq a => a -> a -> Bool
== [(ByteString, ByteString)]
l2 Bool -> Bool -> Bool
&& PGTlsMode
s1 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PGPreparedStatement -> PGPreparedStatement -> Bool
$c/= :: PGPreparedStatement -> PGPreparedStatement -> Bool
== :: PGPreparedStatement -> PGPreparedStatement -> Bool
$c== :: PGPreparedStatement -> PGPreparedStatement -> Bool
Eq, Int -> PGPreparedStatement -> ShowS
[PGPreparedStatement] -> ShowS
PGPreparedStatement -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGPreparedStatement] -> ShowS
$cshowList :: [PGPreparedStatement] -> ShowS
show :: PGPreparedStatement -> String
$cshow :: PGPreparedStatement -> String
showsPrec :: Int -> PGPreparedStatement -> ShowS
$cshowsPrec :: Int -> PGPreparedStatement -> ShowS
Show)

preparedStatementName :: PGPreparedStatement -> BS.ByteString
preparedStatementName :: PGPreparedStatement -> ByteString
preparedStatementName (PGPreparedStatement Integer
n) = String -> ByteString
BSC.pack forall a b. (a -> b) -> a -> b
$ 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 = 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 = 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
_ = 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
  forall (m :: * -> *). MonadIO m => Context -> m ()
TLS.bye Context
c forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOError
_ :: IOError) -> 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
_} = 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGColDescription] -> ShowS
$cshowList :: [PGColDescription] -> ShowS
show :: PGColDescription -> String
$cshow :: PGColDescription -> String
showsPrec :: Int -> PGColDescription -> ShowS
$cshowsPrec :: Int -> PGColDescription -> ShowS
Show)
type PGRowDescription = [PGColDescription]

type MessageFields = Map.Map Char BS.ByteString

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

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

emptyQueue :: Queue a
emptyQueue :: forall a. Queue a
emptyQueue = 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) = forall a. [a] -> [a] -> Queue a
Queue (a
aforall 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)) = (forall a. [a] -> [a] -> Queue a
Queue [a]
e [a]
d, forall a. a -> Maybe a
Just a
x)
deQueue (Queue (forall a. [a] -> [a]
reverse -> a
x:[a]
d) []) = (forall a. [a] -> [a] -> Queue a
Queue [] [a]
d, forall a. a -> Maybe a
Just a
x)
deQueue Queue a
q = (Queue a
q, 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGFrontendMessage] -> ShowS
$cshowList :: [PGFrontendMessage] -> ShowS
show :: PGFrontendMessage -> String
$cshow :: PGFrontendMessage -> String
showsPrec :: Int -> PGFrontendMessage -> ShowS
$cshowsPrec :: Int -> PGFrontendMessage -> ShowS
Show)

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

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

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

instance Exception PGError

-- |Produce a human-readable string representing the message
displayMessage :: MessageFields -> String
displayMessage :: MessageFields -> String
displayMessage MessageFields
m = String
"PG" forall a. [a] -> [a] -> [a]
++ Char -> String
f Char
'S' forall a. [a] -> [a] -> [a]
++ (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
fC then String
": " else String
" [" forall a. [a] -> [a] -> [a]
++ String
fC forall a. [a] -> [a] -> [a]
++ String
"]: ") forall a. [a] -> [a] -> [a]
++ Char -> String
f Char
'M' forall a. [a] -> [a] -> [a]
++ (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
fD then String
fD else Char
'\n' 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 forall a b. (a -> b) -> a -> b
$ 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 = 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) = 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 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 = forall a b. b -> Either a b
Right 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 = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PGDatabase -> Bool
pgDBDebug forall a b. (a -> b) -> a -> b
$ PGConnection -> PGDatabase
connDatabase PGConnection
c) forall a b. (a -> b) -> a -> b
$ do
  UTCTime
t <- IO UTCTime
getCurrentTime
  Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show UTCTime
t forall a. [a] -> [a] -> [a]
++ String
msg

connLogMessage :: PGConnection -> MessageFields -> IO ()
connLogMessage :: PGConnection -> MessageFields -> IO ()
connLogMessage = PGDatabase -> MessageFields -> IO ()
pgDBLogMessage 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 = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
BA.convertToBase Base
BA.Base16 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 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 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) = (forall a. Maybe a
Nothing, Word32 -> Builder
B.word32BE Word32
0x30000
  forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Fold.foldMap (\(ByteString
k, ByteString
v) -> ByteString -> Builder
byteStringNul ByteString
k forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteStringNul ByteString
v) [(ByteString, ByteString)]
kv forall a. Semigroup a => a -> a -> a
<> Builder
nul)
messageBody (CancelRequest Word32
pid Word32
key) = (forall a. Maybe a
Nothing, Word32 -> Builder
B.word32BE Word32
80877102
  forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
B.word32BE Word32
pid 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 } = (forall a. a -> Maybe a
Just Char
'B',
  ByteString -> Builder
byteStringNul ByteString
d
    forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteStringNul ByteString
n
    forall a. Semigroup a => a -> a -> a
<> (if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PGValue -> Bool
fmt PGValues
p
          then Word16 -> Builder
B.word16BE (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length PGValues
p) forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Fold.foldMap (Word16 -> Builder
B.word16BE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGValue -> Bool
fmt) PGValues
p
          else Word16 -> Builder
B.word16BE Word16
0)
    forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
B.word16BE (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length PGValues
p) forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Fold.foldMap PGValue -> Builder
val PGValues
p
    forall a. Semigroup a => a -> a -> a
<> (if forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
bc
          then Word16 -> Builder
B.word16BE (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool]
bc) forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Fold.foldMap (Word16 -> Builder
B.word16BE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
v) forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.byteString ByteString
v
  val (PGBinaryValue ByteString
v) = Word32 -> Builder
B.word32BE (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
v) forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.byteString ByteString
v
messageBody CloseStatement{ statementName :: PGFrontendMessage -> ByteString
statementName = ByteString
n } = (forall a. a -> Maybe a
Just Char
'C', 
  Char -> Builder
B.char7 Char
'S' forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteStringNul ByteString
n)
messageBody ClosePortal{ portalName :: PGFrontendMessage -> ByteString
portalName = ByteString
n } = (forall a. a -> Maybe a
Just Char
'C', 
  Char -> Builder
B.char7 Char
'P' forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteStringNul ByteString
n)
messageBody DescribeStatement{ statementName :: PGFrontendMessage -> ByteString
statementName = ByteString
n } = (forall a. a -> Maybe a
Just Char
'D',
  Char -> Builder
B.char7 Char
'S' forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteStringNul ByteString
n)
messageBody DescribePortal{ portalName :: PGFrontendMessage -> ByteString
portalName = ByteString
n } = (forall a. a -> Maybe a
Just Char
'D',
  Char -> Builder
B.char7 Char
'P' 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 } = (forall a. a -> Maybe a
Just Char
'E',
  ByteString -> Builder
byteStringNul ByteString
n forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
B.word32BE Word32
r)
messageBody PGFrontendMessage
Flush = (forall a. a -> Maybe a
Just Char
'H', 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 } = (forall a. a -> Maybe a
Just Char
'P',
  ByteString -> Builder
byteStringNul ByteString
n forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
lazyByteStringNul ByteString
s
    forall a. Semigroup a => a -> a -> a
<> Word16 -> Builder
B.word16BE (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word32]
t) forall a. Semigroup a => a -> a -> a
<> 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) = (forall a. a -> Maybe a
Just Char
'p',
  ByteString -> Builder
B.byteString ByteString
s forall a. Semigroup a => a -> a -> a
<> Builder
nul)
messageBody SimpleQuery{ queryString :: PGFrontendMessage -> ByteString
queryString = ByteString
s } = (forall a. a -> Maybe a
Just Char
'Q',
  ByteString -> Builder
lazyByteStringNul ByteString
s)
messageBody PGFrontendMessage
Sync = (forall a. a -> Maybe a
Just Char
'S', forall a. Monoid a => a
mempty)
messageBody PGFrontendMessage
Terminate = (forall a. a -> Maybe a
Just Char
'X', 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
  forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef PGState
sr forall a b. (a -> b) -> a -> b
$ PGFrontendMessage -> PGState -> PGState
state PGFrontendMessage
msg
  PGConnection -> String -> IO ()
connDebugMsg PGConnection
c forall a b. (a -> b) -> a -> b
$ String
"> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PGFrontendMessage
msg
  PGHandle -> Builder -> IO ()
pgPutBuilder PGHandle
h forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Fold.foldMap Char -> Builder
B.char7 Maybe Char
t forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
B.word32BE (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
4 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) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (ByteString -> ByteString
BSL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
B.toLazyByteString) 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 = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Char
w2c 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' = forall (m :: * -> *) a. Monad m => a -> m a
return forall k a. Map k a
Map.empty
  g Char
f = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (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' = forall {a}. (Eq a, Num a, Show a) => a -> Get PGBackendMessage
auth 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 = forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
AuthenticationOk
  auth a
3 = forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
AuthenticationCleartextPassword
  auth a
5 = ByteString -> PGBackendMessage
AuthenticationMD5Password forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
G.getByteString Int
4
  auth a
op = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"pgGetMessage: unsupported authentication type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
op
getMessageBody Char
't' = do
  Word16
numParams <- Get Word16
G.getWord16be
  [Word32] -> PGBackendMessage
ParameterDescription forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
numParams) Get Word32
G.getWord32be
getMessageBody Char
'T' = do
  Word16
numFields <- Get Word16
G.getWord16be
  [PGColDescription] -> PGBackendMessage
RowDescription forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
numFields) Get PGColDescription
getField where
  getField :: Get PGColDescription
getField = do
    ByteString
name <- Get ByteString
getByteStringNul
    Word32
oid <- Get Word32
G.getWord32be -- table OID
    Word16
col <- Get Word16
G.getWord16be -- column number
    Word32
typ' <- Get Word32
G.getWord32be -- type
    Word16
siz <- Get Word16
G.getWord16be -- type size
    Word32
tmod <- Get Word32
G.getWord32be -- type modifier
    Word16
fmt <- Get Word16
G.getWord16be -- format code
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PGColDescription
      { pgColName :: ByteString
pgColName = ByteString
name
      , pgColTable :: Word32
pgColTable = Word32
oid
      , pgColNumber :: Int16
pgColNumber = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
col
      , pgColType :: Word32
pgColType = Word32
typ'
      , pgColSize :: Int16
pgColSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
siz
      , pgColModifier :: Int32
pgColModifier = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
tmod
      , pgColBinary :: Bool
pgColBinary = forall a. Enum a => Int -> a
toEnum (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
fmt)
      }
getMessageBody Char
'Z' = PGState -> PGBackendMessage
ReadyForQuery forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall {m :: * -> *}. MonadFail m => Char -> m PGState
rs forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Char
w2c 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' = forall (m :: * -> *) a. Monad m => a -> m a
return PGState
StateIdle
  rs Char
'T' = forall (m :: * -> *) a. Monad m => a -> m a
return PGState
StateTransaction
  rs Char
'E' = forall (m :: * -> *) a. Monad m => a -> m a
return PGState
StateTransactionFailed
  rs Char
s = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"pgGetMessage: unknown ready state: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Char
s
getMessageBody Char
'1' = forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
ParseComplete
getMessageBody Char
'2' = forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
BindComplete
getMessageBody Char
'3' = forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
CloseComplete
getMessageBody Char
'C' = ByteString -> PGBackendMessage
CommandComplete forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
getByteStringNul
getMessageBody Char
'S' = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 ByteString -> ByteString -> PGBackendMessage
ParameterStatus Get ByteString
getByteStringNul Get ByteString
getByteStringNul
getMessageBody Char
'D' = do 
  Word16
numFields <- Get Word16
G.getWord16be
  PGValues -> PGBackendMessage
DataRow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
numFields) (forall {a}. Integral a => a -> Get PGValue
getField forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word32
G.getWord32be) where
  getField :: a -> Get PGValue
getField a
0xFFFFFFFF = forall (m :: * -> *) a. Monad m => a -> m a
return PGValue
PGNullValue
  getField a
len = ByteString -> PGValue
PGTextValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
G.getByteString (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' = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MessageFields
getMessageFields
getMessageBody Char
'I' = forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
EmptyQueryResponse
getMessageBody Char
'n' = forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
NoData
getMessageBody Char
's' = forall (m :: * -> *) a. Monad m => a -> m a
return PGBackendMessage
PortalSuspended
getMessageBody Char
'N' = MessageFields -> PGBackendMessage
NoticeResponse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get MessageFields
getMessageFields
getMessageBody Char
'A' = PGNotification -> PGBackendMessage
NotificationResponse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
  Word32 -> ByteString -> ByteString -> PGNotification
PGNotification
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
G.getWord32be
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ByteString
getByteStringNul
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ByteString
G.getLazyByteStringNul
getMessageBody Char
t = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"pgGetMessage: unknown message type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Char
t

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

class Show m => RecvMsg m where
  -- |Read from connection, returning immediate value or non-empty data
  recvMsgData :: PGConnection -> IO (Either m BS.ByteString)
  recvMsgData PGConnection
c = do
    ByteString
r <- PGHandle -> Int -> IO ByteString
pgGetSome (PGConnection -> PGHandle
connHandle PGConnection
c) Int
smallChunkSize
    if ByteString -> Bool
BS.null ByteString
r
      then do
        forall a. IORef a -> a -> IO ()
writeIORef (PGConnection -> IORef PGState
connState PGConnection
c) PGState
StateClosed
        PGHandle -> IO ()
pgCloseHandle (PGConnection -> PGHandle
connHandle PGConnection
c)
        -- Should this instead be a special PGError?
        forall a. IOError -> IO a
ioError forall a b. (a -> b) -> a -> b
$ IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
eofErrorType String
"PGConnection" forall a. Maybe a
Nothing forall a. Maybe a
Nothing
      else
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right ByteString
r)
  -- |Expected ReadyForQuery message
  recvMsgSync :: Maybe m
  recvMsgSync = forall a. Maybe a
Nothing
  -- |NotificationResponse message
  recvMsgNotif :: PGConnection -> PGNotification -> IO (Maybe m)
  recvMsgNotif PGConnection
c PGNotification
n = forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$
    forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (PGConnection -> IORef (Queue PGNotification)
connNotifications PGConnection
c) (forall a. a -> Queue a -> Queue a
enQueue PGNotification
n)
  -- |ErrorResponse message
  recvMsgErr :: PGConnection -> MessageFields -> IO (Maybe m)
  recvMsgErr PGConnection
c MessageFields
m = forall a. Maybe a
Nothing 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 = forall a. Maybe a
Nothing 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 forall a b. (a -> b) -> a -> b
$ String
"Unexpected server message: " forall a. [a] -> [a] -> [a]
++ 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RecvNonBlock] -> ShowS
$cshowList :: [RecvNonBlock] -> ShowS
show :: RecvNonBlock -> String
$cshow :: RecvNonBlock -> String
showsPrec :: Int -> RecvNonBlock -> ShowS
$cshowsPrec :: Int -> RecvNonBlock -> ShowS
Show)
instance RecvMsg RecvNonBlock where
#ifndef mingw32_HOST_OS
  recvMsgData :: PGConnection -> IO (Either RecvNonBlock ByteString)
recvMsgData PGConnection{connHandle :: PGConnection -> PGHandle
connHandle=PGSocket Socket
s} = do
    ByteString
r <- Socket -> Int -> IO ByteString
recvNonBlock Socket
s Int
smallChunkSize
    if ByteString -> Bool
BS.null ByteString
r
      then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left RecvNonBlock
RecvNonBlock)
      else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right ByteString
r)
#else
  recvMsgData PGConnection{connHandle=PGSocket _} =
    throwIO (userError "Non-blocking recvMsgData is not supported on mingw32 ATM")
#endif
#ifdef VERSION_tls
  recvMsgData PGConnection{connHandle :: PGConnection -> PGHandle
connHandle=PGTlsContext Context
_} =
    forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Non-blocking recvMsgData is not supported on TLS connections")
#endif

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

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

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

-- |Return any message or ReadyForQuery
instance RecvMsg (Either PGBackendMessage RecvSync) where
  recvMsgSync :: Maybe (Either PGBackendMessage RecvSync)
recvMsgSync = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right RecvSync
RecvSync
  recvMsgErr :: PGConnection
-> MessageFields -> IO (Maybe (Either PGBackendMessage RecvSync))
recvMsgErr PGConnection
_ = forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessageFields -> PGError
PGError
  recvMsg :: PGConnection
-> PGBackendMessage
-> IO (Maybe (Either PGBackendMessage RecvSync))
recvMsg PGConnection
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 } =
  forall {b}. RecvMsg b => Decoder PGBackendMessage -> IO b
rcv forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. IORef a -> IO a
readIORef IORef (Decoder PGBackendMessage)
dr where
  next :: Decoder PGBackendMessage -> IO ()
next = forall a. IORef a -> a -> IO ()
writeIORef IORef (Decoder PGBackendMessage)
dr
  new :: ByteString -> Decoder PGBackendMessage
new = 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 forall a b. (a -> b) -> a -> b
$ String
"< " forall a. [a] -> [a] -> [a]
++ 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) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
r -- not clear how can recover
  rcv d :: Decoder PGBackendMessage
d@(G.Partial Maybe ByteString -> Decoder PGBackendMessage
r) = forall m. RecvMsg m => PGConnection -> IO (Either m ByteString)
recvMsgData PGConnection
c forall a b. IO a -> IO b -> IO a
`onException` Decoder PGBackendMessage -> IO ()
next Decoder PGBackendMessage
d forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Decoder PGBackendMessage -> IO ()
next Decoder PGBackendMessage
d) (Decoder PGBackendMessage -> IO b
rcv forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ByteString -> Decoder PGBackendMessage
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)

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

-- |Connect to a PostgreSQL server.
pgConnect :: PGDatabase -> IO PGConnection
pgConnect :: PGDatabase -> IO PGConnection
pgConnect PGDatabase
db = do
  IORef (Map ByteString ByteString)
param <- forall a. a -> IO (IORef a)
newIORef forall k a. Map k a
Map.empty
  IORef PGState
state <- forall a. a -> IO (IORef a)
newIORef PGState
StateUnsync
  IORef Integer
prepc <- forall a. a -> IO (IORef a)
newIORef Integer
0
  IORef (Map (ByteString, [Word32]) PGPreparedStatement)
prepm <- forall a. a -> IO (IORef a)
newIORef forall k a. Map k a
Map.empty
  IORef (Decoder PGBackendMessage)
input <- forall a. a -> IO (IORef a)
newIORef Decoder PGBackendMessage
getMessage
  IORef Word
tr <- forall a. a -> IO (IORef a)
newIORef Word
0
  IORef (Queue PGNotification)
notif <- forall a. a -> IO (IORef a)
newIORef forall a. Queue a
emptyQueue
  AddrInfo
addr <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (\(String
h,String
p) -> forall a. [a] -> a
head forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
Net.getAddrInfo (forall a. a -> Maybe a
Just AddrInfo
defai) (forall a. a -> Maybe a
Just String
h) (forall a. a -> Maybe a
Just String
p))
    (\SockAddr
a -> forall (m :: * -> *) a. Monad m => a -> m a
return AddrInfo
defai{ addrAddress :: SockAddr
Net.addrAddress = SockAddr
a, addrFamily :: Family
Net.addrFamily = case SockAddr
a of
      Net.SockAddrInet{}  -> Family
Net.AF_INET
      Net.SockAddrInet6{} -> Family
Net.AF_INET6
      Net.SockAddrUnix{}  -> Family
Net.AF_UNIX
      SockAddr
_ -> Family
Net.AF_UNSPEC })
    forall a b. (a -> b) -> a -> b
$ PGDatabase -> Either (String, String) SockAddr
pgDBAddr PGDatabase
db
  Socket
sock <- Family -> SocketType -> CInt -> IO Socket
Net.socket (AddrInfo -> Family
Net.addrFamily AddrInfo
addr) (AddrInfo -> SocketType
Net.addrSocketType AddrInfo
addr) (AddrInfo -> CInt
Net.addrProtocol AddrInfo
addr)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AddrInfo -> Family
Net.addrFamily AddrInfo
addr forall a. Eq a => a -> a -> Bool
== Family
Net.AF_UNIX) forall a b. (a -> b) -> a -> b
$ Socket -> SocketOption -> Int -> IO ()
Net.setSocketOption Socket
sock SocketOption
Net.NoDelay Int
1
  Socket -> SockAddr -> IO ()
Net.connect Socket
sock forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
Net.addrAddress AddrInfo
addr
  PGHandle
pgHandle <- PGDatabase -> Socket -> IO PGHandle
mkPGHandle PGDatabase
db Socket
sock
  let c :: PGConnection
c = PGConnection
        { connHandle :: PGHandle
connHandle = PGHandle
pgHandle
        , connDatabase :: PGDatabase
connDatabase = PGDatabase
db
        , connPid :: Word32
connPid = Word32
0
        , connKey :: Word32
connKey = Word32
0
        , connParameters :: IORef (Map ByteString ByteString)
connParameters = IORef (Map ByteString ByteString)
param
        , connPreparedStatementCount :: IORef Integer
connPreparedStatementCount = IORef Integer
prepc
        , connPreparedStatementMap :: IORef (Map (ByteString, [Word32]) PGPreparedStatement)
connPreparedStatementMap = IORef (Map (ByteString, [Word32]) PGPreparedStatement)
prepm
        , connState :: IORef PGState
connState = IORef PGState
state
        , connTypeEnv :: PGTypeEnv
connTypeEnv = PGTypeEnv
unknownPGTypeEnv
        , connInput :: IORef (Decoder PGBackendMessage)
connInput = IORef (Decoder PGBackendMessage)
input
        , connTransaction :: IORef Word
connTransaction = IORef Word
tr
        , connNotifications :: IORef (Queue PGNotification)
connNotifications = IORef (Queue PGNotification)
notif
        }
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> PGFrontendMessage
StartupMessage forall a b. (a -> b) -> a -> b
$
    [ (ByteString
"user", PGDatabase -> ByteString
pgDBUser PGDatabase
db)
    , (ByteString
"database", PGDatabase -> ByteString
pgDBName PGDatabase
db)
    , (ByteString
"client_encoding", ByteString
"UTF8")
    , (ByteString
"standard_conforming_strings", ByteString
"on")
    , (ByteString
"bytea_output", ByteString
"hex")
    , (ByteString
"DateStyle", ByteString
"ISO, YMD")
    , (ByteString
"IntervalStyle", ByteString
"iso_8601")
    , (ByteString
"extra_float_digits", ByteString
"3")
    ] forall a. [a] -> [a] -> [a]
++ PGDatabase -> [(ByteString, ByteString)]
pgDBParams PGDatabase
db
  PGConnection -> IO ()
pgFlush PGConnection
c
  PGConnection -> IO PGConnection
conn PGConnection
c
  where
  defai :: AddrInfo
defai = AddrInfo
Net.defaultHints{ addrSocketType :: SocketType
Net.addrSocketType = SocketType
Net.Stream }
  conn :: PGConnection -> IO PGConnection
conn PGConnection
c = forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PGConnection -> Either PGBackendMessage RecvSync -> IO PGConnection
msg PGConnection
c
  msg :: PGConnection -> Either PGBackendMessage RecvSync -> IO PGConnection
msg PGConnection
c (Right RecvSync
RecvSync) = do
    Map ByteString ByteString
cp <- forall a. IORef a -> IO a
readIORef (PGConnection -> IORef (Map ByteString ByteString)
connParameters PGConnection
c)
    forall (m :: * -> *) a. Monad m => a -> m a
return PGConnection
c
      { connTypeEnv :: PGTypeEnv
connTypeEnv = PGTypeEnv
        { pgIntegerDatetimes :: Maybe Bool
pgIntegerDatetimes = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString
"on" forall a. Eq a => a -> a -> Bool
==) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
"integer_datetimes" Map ByteString ByteString
cp
        , pgServerVersion :: Maybe ByteString
pgServerVersion = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
"server_version" Map ByteString ByteString
cp
        }
      }
  msg PGConnection
c (Left (BackendKeyData Word32
p Word32
k)) = PGConnection -> IO PGConnection
conn PGConnection
c{ connPid :: Word32
connPid = Word32
p, connKey :: Word32
connKey = Word32
k }
  msg PGConnection
c (Left PGBackendMessage
AuthenticationOk) = PGConnection -> IO PGConnection
conn PGConnection
c
  msg PGConnection
c (Left PGBackendMessage
AuthenticationCleartextPassword) = do
    PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c forall a b. (a -> b) -> a -> b
$ ByteString -> PGFrontendMessage
PasswordMessage 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 forall a b. (a -> b) -> a -> b
$ ByteString -> PGFrontendMessage
PasswordMessage 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 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) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"pgConnect: unexpected response: " forall a. [a] -> [a] -> [a]
++ 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     -> 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
      ByteString
resp <- Socket -> Int -> IO ByteString
NetBS.recv Socket
sock Int
1
      case ByteString
resp of
        ByteString
"S" -> do
          Context
ctx <- forall (m :: * -> *) backend params.
(MonadIO m, HasBackend backend, TLSParams params) =>
backend -> params -> m Context
TLS.contextNew Socket
sock ClientParams
params
          forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Context -> m ()
TLS.handshake Context
ctx
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Context -> PGHandle
PGTlsContext Context
ctx
        ByteString
"N" -> forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Server does not support TLS")
        ByteString
_ -> forall e a. Exception e => e -> IO a
throwIO (String -> IOError
userError String
"Unexpected response from server when issuing SSLRequest")
    params :: ClientParams
params = (String -> ByteString -> ClientParams
TLS.defaultParamsClient String
tlsHost ByteString
tlsPort)
      { clientSupported :: Supported
TLS.clientSupported =
          forall a. Default a => a
def { supportedCiphers :: [Cipher]
TLS.supportedCiphers = [Cipher]
TLS.ciphersuite_strong }
      , clientShared :: Shared
TLS.clientShared = Shared
clientShared
      , clientHooks :: ClientHooks
TLS.clientHooks = ClientHooks
clientHooks
      }
    tlsHost :: String
tlsHost = case PGDatabase -> Either (String, String) SockAddr
pgDBAddr PGDatabase
db of
      Left (String
h,String
_) -> String
h
      Right (Net.SockAddrUnix String
s) -> String
s
      Right SockAddr
_ -> String
"some-socket"
    tlsPort :: ByteString
tlsPort = case PGDatabase -> Either (String, String) SockAddr
pgDBAddr PGDatabase
db of
      Left (String
_,String
p) -> String -> ByteString
BSC.pack String
p
      Right SockAddr
_    -> ByteString
"socket"
    clientShared :: Shared
clientShared =
      case PGDatabase -> PGTlsMode
pgDBTLS PGDatabase
db of
        PGTlsMode
TlsDisabled -> forall a. Default a => a
def { sharedValidationCache :: ValidationCache
TLS.sharedValidationCache = ValidationCache
noValidate }
        PGTlsMode
TlsNoValidate -> forall a. Default a => a
def { sharedValidationCache :: ValidationCache
TLS.sharedValidationCache = ValidationCache
noValidate }
        TlsValidate PGTlsValidateMode
_ SignedCertificate
sc -> forall a. Default a => a
def { sharedCAStore :: CertificateStore
TLS.sharedCAStore = [SignedCertificate] -> CertificateStore
makeCertificateStore [SignedCertificate
sc] }
    clientHooks :: ClientHooks
clientHooks =
      case PGDatabase -> PGTlsMode
pgDBTLS PGDatabase
db of
        TlsValidate PGTlsValidateMode
TlsValidateCA SignedCertificate
_ -> forall a. Default a => a
def { onServerCertificate :: OnServerCertificate
TLS.onServerCertificate = OnServerCertificate
validateNoCheckFQHN }
        PGTlsMode
_                           -> forall a. Default a => a
def
    validateNoCheckFQHN :: OnServerCertificate
validateNoCheckFQHN = HashALG
-> ValidationHooks -> ValidationChecks -> OnServerCertificate
Data.X509.Validation.validate HashALG
HashSHA256 forall a. Default a => a
def (forall a. Default a => a
def { checkFQHN :: Bool
TLS.checkFQHN = Bool
False })

    noValidate :: ValidationCache
noValidate = ValidationCacheQueryCallback
-> ValidationCacheAddCallback -> ValidationCache
TLS.ValidationCache
      (\ServiceID
_ Fingerprint
_ Certificate
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ValidationCacheResult
TLS.ValidationCachePass)
      (\ServiceID
_ Fingerprint
_ Certificate
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
    sslRequest :: ByteString
sslRequest = Builder -> ByteString
B.toLazyByteString (Word32 -> Builder
B.word32BE Word32
8 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 forall a b. IO a -> IO b -> IO a
`finally` PGHandle -> IO ()
pgCloseHandle PGHandle
h

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

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

pgSync :: PGConnection -> IO ()
pgSync :: PGConnection -> IO ()
pgSync c :: PGConnection
c@PGConnection{ connState :: PGConnection -> IORef PGState
connState = IORef PGState
sr } = do
  PGState
s <- forall a. IORef a -> IO a
readIORef IORef PGState
sr
  case PGState
s of
    PGState
StateClosed -> 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
  wait :: IO ()
wait = do
    RecvSync
RecvSync <- forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
    forall (m :: * -> *) a. Monad m => a -> m a
return ()
    
rowDescription :: PGBackendMessage -> PGRowDescription
rowDescription :: PGBackendMessage -> [PGColDescription]
rowDescription (RowDescription [PGColDescription]
d) = [PGColDescription]
d
rowDescription PGBackendMessage
NoData = []
rowDescription PGBackendMessage
m = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"describe: unexpected response: " forall a. [a] -> [a] -> [a]
++ 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
ParseComplete <- forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
h
  ParameterDescription [Word32]
ps <- forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
h
  (,) [Word32]
ps forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PGColDescription -> IO (ByteString, Word32, Bool)
desc forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGBackendMessage -> [PGColDescription]
rowDescription forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
h)
  where
  desc :: PGColDescription -> IO (ByteString, Word32, Bool)
desc (PGColDescription{ pgColName :: PGColDescription -> ByteString
pgColName = ByteString
name, pgColTable :: PGColDescription -> Word32
pgColTable = Word32
tab, pgColNumber :: PGColDescription -> Int16
pgColNumber = Int16
col, pgColType :: PGColDescription -> Word32
pgColType = Word32
typ }) = do
    Bool
n <- Word32 -> Int16 -> IO Bool
nullable Word32
tab Int16
col
    forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
name, Word32
typ, Bool
n)
  -- We don't get nullability indication from PostgreSQL, at least not directly.
  -- Without any hints, we have to assume that the result can be null and
  -- leave it up to the developer to figure it out.
  nullable :: Word32 -> Int16 -> IO Bool
nullable Word32
oid Int16
col
    | Bool
nulls Bool -> Bool -> Bool
&& Word32
oid forall a. Eq a => a -> a -> Bool
/= Word32
0 = do
      -- In cases where the resulting field is tracable to the column of a
      -- table, we can check there.
      (Int
_, [PGValues]
r) <- PGConnection
-> ByteString
-> [Word32]
-> PGValues
-> [Bool]
-> IO (Int, [PGValues])
pgPreparedQuery PGConnection
h ByteString
"SELECT attnotnull FROM pg_catalog.pg_attribute WHERE attrelid = $1 AND attnum = $2" [Word32
26, Word32
21] [forall a. PGRep a => a -> PGValue
pgEncodeRep (Word32
oid :: OID), forall a. PGRep a => a -> PGValue
pgEncodeRep (Int16
col :: Int16)] []
      case [PGValues]
r of
        [[PGValue
s]] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. PGRep a => PGValue -> a
pgDecodeRep PGValue
s
        [] -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        [PGValues]
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Failed to determine nullability of column #" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int16
col
    | Bool
otherwise = 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 = forall {a}. (Num a, Read a) => [ByteString] -> a
ra forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BSC.words where
  ra :: [ByteString] -> a
ra [] = -a
1
  ra [ByteString]
l = forall a. a -> Maybe a -> a
fromMaybe (-a
1) forall a b. (a -> b) -> a -> b
$ forall a. Read a => String -> Maybe a
readMaybe forall a b. (a -> b) -> a -> b
$ ByteString -> String
BSC.unpack forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [ByteString]
l

-- Do we need to use the PGColDescription here always, or are the request formats okay?
fixBinary :: [Bool] -> PGValues -> PGValues
fixBinary :: [Bool] -> PGValues -> PGValues
fixBinary (Bool
False:[Bool]
b) (PGBinaryValue ByteString
x:PGValues
r) = ByteString -> PGValue
PGTextValue ByteString
x 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 forall a. a -> [a] -> [a]
: [Bool] -> PGValues -> PGValues
fixBinary [Bool]
b PGValues
r
fixBinary (Bool
_:[Bool]
b) (PGValue
x:PGValues
r) = PGValue
x 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 forall a b. (a -> b) -> a -> b
$ ByteString -> PGFrontendMessage
SimpleQuery ByteString
sql
  PGConnection -> IO ()
pgFlush PGConnection
h
  forall {b}. (PGBackendMessage -> IO b) -> IO b
go forall {a}.
(Integral a, Read a) =>
PGBackendMessage -> IO (a, [PGValues])
start where 
  go :: (PGBackendMessage -> IO b) -> IO b
go = (forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
h forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)
  start :: PGBackendMessage -> IO (a, [PGValues])
start (RowDescription [PGColDescription]
rd) = forall {b}. (PGBackendMessage -> IO b) -> IO b
go forall a b. (a -> b) -> a -> b
$ forall {a} {b}.
(Integral a, Read a) =>
[Bool] -> ([PGValues] -> b) -> PGBackendMessage -> IO (a, b)
row (forall a b. (a -> b) -> [a] -> [b]
map PGColDescription -> Bool
pgColBinary [PGColDescription]
rd) forall a. a -> a
id
  start (CommandComplete ByteString
c) = forall {m :: * -> *} {a} {b}.
(Monad m, Integral a, Read a) =>
ByteString -> b -> m (a, b)
got ByteString
c []
  start PGBackendMessage
EmptyQueryResponse = forall (m :: * -> *) a. Monad m => a -> m a
return (a
0, [])
  start PGBackendMessage
m = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"pgSimpleQuery: unexpected response: " forall a. [a] -> [a] -> [a]
++ 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) = forall {b}. (PGBackendMessage -> IO b) -> IO b
go forall a b. (a -> b) -> a -> b
$ [Bool] -> ([PGValues] -> b) -> PGBackendMessage -> IO (a, b)
row [Bool]
bc ([PGValues] -> b
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Bool] -> PGValues -> PGValues
fixBinary [Bool]
bc PGValues
fs forall a. a -> [a] -> [a]
:))
  row [Bool]
_ [PGValues] -> b
r (CommandComplete ByteString
c) = 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 = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"pgSimpleQuery: unexpected row: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PGBackendMessage
m
  got :: ByteString -> b -> m (a, b)
got ByteString
c b
r = forall (m :: * -> *) a. Monad m => a -> m a
return (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 forall a b. (a -> b) -> a -> b
$ ByteString -> PGFrontendMessage
SimpleQuery ByteString
sql
  PGConnection -> IO ()
pgFlush PGConnection
h
  IO ()
go where
  go :: IO ()
go = forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
h 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) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  res Either PGBackendMessage RecvSync
m = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"pgSimpleQueries_: unexpected response: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Either PGBackendMessage RecvSync
m

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

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

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

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

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

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

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

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

-- |Rollback all active 'pgBegin's.
pgRollbackAll :: PGConnection -> IO ()
pgRollbackAll :: PGConnection -> IO ()
pgRollbackAll c :: PGConnection
c@PGConnection{ connTransaction :: PGConnection -> IORef Word
connTransaction = IORef Word
tr } = do
  forall a. IORef a -> a -> IO ()
writeIORef IORef Word
tr Word
0
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ PGConnection -> ByteString -> IO (Int, [PGValues])
pgSimpleQuery PGConnection
c 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
  forall a. IORef a -> a -> IO ()
writeIORef IORef Word
tr Word
0
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ PGConnection -> ByteString -> IO (Int, [PGValues])
pgSimpleQuery PGConnection
c 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
  forall a b. IO a -> IO b -> IO a
onException (do
    a
r <- IO a
f
    PGConnection -> IO ()
pgCommit PGConnection
c
    forall (m :: * -> *) a. Monad m => a -> m a
return a
r)
    (PGConnection -> IO ()
pgRollback PGConnection
c)

-- |Prepare, bind, execute, and close a single (unnamed) query, and return the number of rows affected, or Nothing if there are (ignored) result rows.
pgRun :: PGConnection -> BSL.ByteString -> [OID] -> PGValues -> IO (Maybe Integer)
pgRun :: PGConnection
-> ByteString -> [Word32] -> PGValues -> IO (Maybe Integer)
pgRun PGConnection
c ByteString
sql [Word32]
types PGValues
bind = do
  PGConnection -> IO ()
pgSync PGConnection
c
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c Parse{ 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 = forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  res (CommandComplete ByteString
d) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall i. (Integral i, Read i) => ByteString -> i
rowsAffected ByteString
d)
  res PGBackendMessage
EmptyQueryResponse = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Integer
0)
  res PGBackendMessage
m = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"pgRun: unexpected response: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PGBackendMessage
m

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

-- |Close a previously prepared query.
pgClose :: PGConnection -> PGPreparedStatement -> IO ()
pgClose :: PGConnection -> PGPreparedStatement -> IO ()
pgClose PGConnection
c PGPreparedStatement
n = do
  PGConnection -> IO ()
pgSync PGConnection
c
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c ClosePortal{ 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
CloseComplete <- forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
  PGBackendMessage
CloseComplete <- forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

-- |Fetch some rows from an executed prepared statement, returning the next N result rows (if any) and number of affected rows when complete.
pgFetch :: PGConnection -> PGPreparedStatement -> Word32 -- ^Maximum number of rows to return, or 0 for all
  -> IO ([PGValues], Maybe Integer)
pgFetch :: PGConnection
-> PGPreparedStatement -> Word32 -> IO ([PGValues], Maybe Integer)
pgFetch PGConnection
c PGPreparedStatement
n Word32
count = do
  PGConnection -> IO ()
pgSync PGConnection
c
  PGConnection -> PGFrontendMessage -> IO ()
pgSend PGConnection
c Execute{ 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 = forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c 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) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (PGValues
v forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ([PGValues], Maybe Integer)
go
  res PGBackendMessage
PortalSuspended = forall (m :: * -> *) a. Monad m => a -> m a
return ([], 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
CloseComplete <- forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
    forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall i. (Integral i, Read i) => ByteString -> i
rowsAffected ByteString
d)
  res PGBackendMessage
EmptyQueryResponse = forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. a -> Maybe a
Just Integer
0)
  res PGBackendMessage
m = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"pgFetch: unexpected response: " forall a. [a] -> [a] -> [a]
++ 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 =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c) forall (m :: * -> *) a. Monad m => a -> m a
return
   forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (PGConnection -> IORef (Queue PGNotification)
connNotifications PGConnection
c) forall a. Queue a -> (Queue a, Maybe a)
deQueue

-- |Retrieve any pending notifications.  Non-blocking.
pgGetNotifications :: PGConnection -> IO [PGNotification]
pgGetNotifications :: PGConnection -> IO [PGNotification]
pgGetNotifications PGConnection
c = do
  RecvNonBlock
RecvNonBlock <- forall m. RecvMsg m => PGConnection -> IO m
pgRecv PGConnection
c
  forall a. Queue a -> [a]
queueToList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (PGConnection -> IORef (Queue PGNotification)
connNotifications PGConnection
c) (forall a. Queue a
emptyQueue, )
  where
  queueToList :: Queue a -> [a]
  queueToList :: forall a. Queue a -> [a]
queueToList (Queue [a]
e [a]
d) = [a]
d forall 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 forall a. Ord a => a -> a -> Bool
< Int
0 = 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 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 forall a. Ord a => a -> a -> Bool
<= Int
0 = forall a. IOError -> IO a
ioError (String -> IOError
mkInvalidRecvArgError String
"Database.PostgreSQL.Typed.recvBufNonBlock")
 | Bool
otherwise   = do
    CInt
len <-
#if MIN_VERSION_network(3,1,0)
      forall r. Socket -> (CInt -> IO r) -> IO r
Net.withFdSocket Socket
s 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 (forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nbytes) CInt
0
    if CInt
len forall a. Eq a => a -> a -> Bool
== -CInt
1
      then do
        Errno
errno <- IO Errno
getErrno
        if Errno
errno forall a. Eq a => a -> a -> Bool
== Errno
eWOULDBLOCK
          then forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
          else forall e a. Exception e => e -> IO a
throwIO (String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError String
"recvBufNonBlock" Errno
errno forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just String
"Database.PostgreSQL.Typed"))
      else
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing) String
"non-positive length"


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