{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Database.PostgreSQL.Typed.Protocol (
PGDatabase(..)
, defaultPGDatabase
, PGConnection
, PGError(..)
#ifdef VERSION_tls
, PGTlsMode(..)
, PGTlsValidateMode (..)
#endif
, pgErrorCode
, pgConnectionDatabase
, pgTypeEnv
, pgConnect
, pgDisconnect
, pgReconnect
, pgDescribe
, pgSimpleQuery
, pgSimpleQueries_
, pgPreparedQuery
, pgPreparedLazyQuery
, pgCloseStatement
, pgBegin
, pgCommit
, pgRollback
, pgCommitAll
, pgRollbackAll
, pgTransaction
, pgDisconnectOnce
, pgRun
, PGPreparedStatement
, pgPrepare
, pgClose
, PGColDescription(..)
, PGRowDescription
, pgBind
, pgFetch
, PGNotification(..)
, pgGetNotification
, pgGetNotifications
#ifdef VERSION_tls
, 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
| StatePending
| StateIdle
| StateTransaction
| StateTransactionFailed
| 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
| TlsValidateCA
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
| 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)
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
data PGDatabase = PGDatabase
{ PGDatabase -> Either (String, String) SockAddr
pgDBAddr :: Either (Net.HostName, Net.ServiceName) Net.SockAddr
, PGDatabase -> ByteString
pgDBName :: BS.ByteString
, PGDatabase -> ByteString
pgDBUser, PGDatabase -> ByteString
pgDBPass :: BS.ByteString
, PGDatabase -> [(ByteString, ByteString)]
pgDBParams :: [(BS.ByteString, BS.ByteString)]
, PGDatabase -> Bool
pgDBDebug :: Bool
, PGDatabase -> MessageFields -> IO ()
pgDBLogMessage :: MessageFields -> IO ()
#ifdef VERSION_tls
, PGDatabase -> PGTlsMode
pgDBTLS :: PGTlsMode
#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
data PGConnection = PGConnection
{ PGConnection -> PGHandle
connHandle :: PGHandle
, PGConnection -> PGDatabase
connDatabase :: !PGDatabase
, PGConnection -> Word32
connPid :: !Word32
, PGConnection -> Word32
connKey :: !Word32
, 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)
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)
data PGFrontendMessage
= StartupMessage [(BS.ByteString, BS.ByteString)]
| CancelRequest !Word32 !Word32
| 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 }
| DescribeStatement { statementName :: BS.ByteString }
| DescribePortal { portalName :: BS.ByteString }
| Execute { portalName :: BS.ByteString, PGFrontendMessage -> Word32
executeRows :: !Word32 }
| Flush
| Parse { statementName :: BS.ByteString, PGFrontendMessage -> ByteString
queryString :: BSL.ByteString, PGFrontendMessage -> [Word32]
parseTypes :: [OID] }
| PasswordMessage BS.ByteString
| 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)
data PGBackendMessage
= AuthenticationOk
| AuthenticationCleartextPassword
| AuthenticationMD5Password BS.ByteString
| BackendKeyData Word32 Word32
| BindComplete
| CloseComplete
| CommandComplete BS.ByteString
| DataRow PGValues
| EmptyQueryResponse
| ErrorResponse { PGBackendMessage -> MessageFields
messageFields :: MessageFields }
| NoData
| NoticeResponse { messageFields :: MessageFields }
| NotificationResponse PGNotification
| ParameterDescription [OID]
| ParameterStatus BS.ByteString BS.ByteString
| ParseComplete
| PortalSuspended
| ReadyForQuery PGState
| 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)
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
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)]
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
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
pgConnectionDatabase :: PGConnection -> PGDatabase
pgConnectionDatabase :: PGConnection -> PGDatabase
pgConnectionDatabase = PGConnection -> PGDatabase
connDatabase
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
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)
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
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
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
Word16
col <- Get Word16
G.getWord16be
Word32
typ' <- Get Word32
G.getWord32be
Word16
siz <- Get Word16
G.getWord16be
Word32
tmod <- Get Word32
G.getWord32be
Word16
fmt <- Get Word16
G.getWord16be
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)
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
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)
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)
recvMsgSync :: Maybe m
recvMsgSync = forall a. Maybe a
Nothing
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)
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
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")
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
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
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
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
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
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
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
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)
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
else forall m.
RecvMsg m =>
PGConnection -> PGBackendMessage -> IO (Maybe m)
recvMsg PGConnection
c PGBackendMessage
m
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)
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
pgDisconnect :: PGConnection
-> 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
pgDisconnectOnce :: PGConnection
-> 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
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
pgDescribe :: PGConnection -> BSL.ByteString
-> [OID]
-> Bool
-> IO ([OID], [(BS.ByteString, OID, Bool)])
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)
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
(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
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
pgSimpleQuery :: PGConnection -> BSL.ByteString
-> IO (Int, [PGValues])
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)
pgSimpleQueries_ :: PGConnection -> BSL.ByteString
-> 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)
pgPreparedQuery :: PGConnection -> BS.ByteString
-> [OID]
-> PGValues
-> [Bool]
-> 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
pgPreparedLazyQuery :: PGConnection -> BS.ByteString -> [OID] -> PGValues -> [Bool] -> Word32
-> 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
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
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
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
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
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"
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"
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)
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 }
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
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
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 ()
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
pgFetch :: PGConnection -> PGPreparedStatement -> Word32
-> 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
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
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
#ifndef mingw32_HOST_OS
recvNonBlock
:: Net.Socket
-> Int
-> IO BS.ByteString
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