module Hpgsql.Msgs (AuthenticationResponse (..), AuthenticationMethod (..), BackendKeyData (..), Bind (..), BindComplete (..), CancelRequest (..), CommandComplete (..), CopyData (..), CopyDone (..), CopyFail (..), CopyInResponse (..), DataRow (..), Describe (..), ErrorDetail (..), ErrorResponse (..), Execute (..), Flush (..), NoData (..), ParameterStatus (..), Query (..), ReadyForQuery (..), RowDescription (..), StartupMessage (..), ToPgMessage (..), FromPgMessage (..), PgMsgParser (..), Terminate (..), TransactionStatus (..), NoticeResponse (..), NotificationResponse (..), Parse (..), ParseComplete (..), PasswordMessage (..), Sync (..), parsePgMessage, nulTermCString) where

import Control.Applicative (Alternative (..))
import Control.Monad (replicateM)
import qualified Crypto.Hash.MD5 as MD5
import qualified Data.Attoparsec.ByteString as Parsec
import qualified Data.Attoparsec.ByteString.Lazy as LazyParsec
import qualified Data.Attoparsec.Text as TextParsec
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString.Internal (w2c)
import qualified Data.ByteString.Lazy as LBS
import Data.Functor (void)
import Data.Int (Int16, Int32)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Serialize as Cereal
import Data.Text (Text)
import Data.Text.Encoding (decodeASCII, decodeUtf8)
import Data.Word (Word8)
import Hpgsql.Builder (BinaryField, Builder, builderLength)
import qualified Hpgsql.Builder as Builder
import Hpgsql.InternalTypes (BindComplete (..), CommandComplete (..), CopyInResponse (..), DataRow (..), ErrorDetail (..), ErrorResponse (..), NoData (..), NotificationResponse (..), ParseComplete (..), ReadyForQuery (..), RowDescription (..), TransactionStatus (..))
import Hpgsql.TypeInfo (Oid (..))

class ToPgMessage a where
  toPgMessage :: a -> Builder

newtype PgMsgParser a
  = PgMsgParser
      ( Char ->
        -- \| Message contents after the Int32 length attribute
        LBS.ByteString ->
        Maybe a
      )
  deriving stock ((forall a b. (a -> b) -> PgMsgParser a -> PgMsgParser b)
-> (forall a b. a -> PgMsgParser b -> PgMsgParser a)
-> Functor PgMsgParser
forall a b. a -> PgMsgParser b -> PgMsgParser a
forall a b. (a -> b) -> PgMsgParser a -> PgMsgParser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> PgMsgParser a -> PgMsgParser b
fmap :: forall a b. (a -> b) -> PgMsgParser a -> PgMsgParser b
$c<$ :: forall a b. a -> PgMsgParser b -> PgMsgParser a
<$ :: forall a b. a -> PgMsgParser b -> PgMsgParser a
Functor)

instance Applicative PgMsgParser where
  pure :: forall a. a -> PgMsgParser a
pure a
a = (Char -> ByteString -> Maybe a) -> PgMsgParser a
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe a) -> PgMsgParser a)
-> (Char -> ByteString -> Maybe a) -> PgMsgParser a
forall a b. (a -> b) -> a -> b
$ \Char
_ ByteString
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
a

  -- TODO: Is this Applicative correct? Double-check laws
  PgMsgParser Char -> ByteString -> Maybe (a -> b)
f <*> :: forall a b. PgMsgParser (a -> b) -> PgMsgParser a -> PgMsgParser b
<*> PgMsgParser Char -> ByteString -> Maybe a
p = (Char -> ByteString -> Maybe b) -> PgMsgParser b
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe b) -> PgMsgParser b)
-> (Char -> ByteString -> Maybe b) -> PgMsgParser b
forall a b. (a -> b) -> a -> b
$ \Char
c ByteString
r -> Char -> ByteString -> Maybe (a -> b)
f Char
c ByteString
r Maybe (a -> b) -> Maybe a -> Maybe b
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> ByteString -> Maybe a
p Char
c ByteString
r

instance Alternative PgMsgParser where
  empty :: forall a. PgMsgParser a
empty = (Char -> ByteString -> Maybe a) -> PgMsgParser a
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe a) -> PgMsgParser a)
-> (Char -> ByteString -> Maybe a) -> PgMsgParser a
forall a b. (a -> b) -> a -> b
$ \Char
_ ByteString
_ -> Maybe a
forall a. Maybe a
Nothing
  PgMsgParser Char -> ByteString -> Maybe a
p1 <|> :: forall a. PgMsgParser a -> PgMsgParser a -> PgMsgParser a
<|> PgMsgParser Char -> ByteString -> Maybe a
p2 = (Char -> ByteString -> Maybe a) -> PgMsgParser a
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe a) -> PgMsgParser a)
-> (Char -> ByteString -> Maybe a) -> PgMsgParser a
forall a b. (a -> b) -> a -> b
$ \Char
c ByteString
restOfMsg -> Char -> ByteString -> Maybe a
p1 Char
c ByteString
restOfMsg Maybe a -> Maybe a -> Maybe a
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> ByteString -> Maybe a
p2 Char
c ByteString
restOfMsg

class FromPgMessage a where
  msgParser :: PgMsgParser a

parsePgMessage :: Char -> LBS.ByteString -> PgMsgParser a -> Maybe a
parsePgMessage :: forall a. Char -> ByteString -> PgMsgParser a -> Maybe a
parsePgMessage Char
c ByteString
restOfMsg (PgMsgParser Char -> ByteString -> Maybe a
parseFunc) = Char -> ByteString -> Maybe a
parseFunc Char
c ByteString
restOfMsg

colParser :: Parsec.Parser (Text, Oid)
colParser :: Parser (Text, Oid)
colParser = do
  colName <- Parser Text
nulTerminatedCStringParser -- Column name as C string
  void $ Parsec.take (4 + 2)
  -- TODO: OIDs are unsigned integers! Try `select (-1)::oid` to see. Change to UInt32 somehow
  typOid <- either fail pure . Cereal.decode @Int32 =<< Parsec.take 4
  void $ Parsec.take (2 + 4 + 2)
  pure (colName, Oid (fromIntegral typOid))

nulTerminatedCStringParser :: Parsec.Parser Text
nulTerminatedCStringParser :: Parser Text
nulTerminatedCStringParser = do
  stringWithoutNul <- (Word8 -> Bool) -> Parser ByteString ByteString
Parsec.takeWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0)
  Parsec.skip (== 0)
  pure $ decodeUtf8 stringWithoutNul

newtype AuthenticationResponse = AuthenticationResponse AuthenticationMethod
  deriving stock (Int -> AuthenticationResponse -> ShowS
[AuthenticationResponse] -> ShowS
AuthenticationResponse -> String
(Int -> AuthenticationResponse -> ShowS)
-> (AuthenticationResponse -> String)
-> ([AuthenticationResponse] -> ShowS)
-> Show AuthenticationResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AuthenticationResponse -> ShowS
showsPrec :: Int -> AuthenticationResponse -> ShowS
$cshow :: AuthenticationResponse -> String
show :: AuthenticationResponse -> String
$cshowList :: [AuthenticationResponse] -> ShowS
showList :: [AuthenticationResponse] -> ShowS
Show)

data AuthenticationMethod = AuthOk | AuthKerberosV5 | AuthCleartextPassword | AuthMD5Password LBS.ByteString | AuthGSS | AuthGSSContinue | AuthSSPI | AuthSASL | AuthSASLContinue | AuthSASLFinal
  deriving stock (Int -> AuthenticationMethod -> ShowS
[AuthenticationMethod] -> ShowS
AuthenticationMethod -> String
(Int -> AuthenticationMethod -> ShowS)
-> (AuthenticationMethod -> String)
-> ([AuthenticationMethod] -> ShowS)
-> Show AuthenticationMethod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AuthenticationMethod -> ShowS
showsPrec :: Int -> AuthenticationMethod -> ShowS
$cshow :: AuthenticationMethod -> String
show :: AuthenticationMethod -> String
$cshowList :: [AuthenticationMethod] -> ShowS
showList :: [AuthenticationMethod] -> ShowS
Show)

data PasswordMessage
  = -- | Two last are username and password
    PasswordMessage AuthenticationMethod String String
  deriving stock (Int -> PasswordMessage -> ShowS
[PasswordMessage] -> ShowS
PasswordMessage -> String
(Int -> PasswordMessage -> ShowS)
-> (PasswordMessage -> String)
-> ([PasswordMessage] -> ShowS)
-> Show PasswordMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PasswordMessage -> ShowS
showsPrec :: Int -> PasswordMessage -> ShowS
$cshow :: PasswordMessage -> String
show :: PasswordMessage -> String
$cshowList :: [PasswordMessage] -> ShowS
showList :: [PasswordMessage] -> ShowS
Show)

data BackendKeyData = BackendKeyData {BackendKeyData -> Int32
backendPid :: Int32, BackendKeyData -> Int32
backendSecretKey :: Int32}
  deriving stock (Int -> BackendKeyData -> ShowS
[BackendKeyData] -> ShowS
BackendKeyData -> String
(Int -> BackendKeyData -> ShowS)
-> (BackendKeyData -> String)
-> ([BackendKeyData] -> ShowS)
-> Show BackendKeyData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BackendKeyData -> ShowS
showsPrec :: Int -> BackendKeyData -> ShowS
$cshow :: BackendKeyData -> String
show :: BackendKeyData -> String
$cshowList :: [BackendKeyData] -> ShowS
showList :: [BackendKeyData] -> ShowS
Show)

data Bind = Bind {Bind -> [BinaryField]
paramsValuesInOrder :: ![BinaryField], Bind -> Int
resultColumnFmts :: !Int, Bind -> Maybe String
preparedStmtHash :: !(Maybe String)}
  deriving stock (Int -> Bind -> ShowS
[Bind] -> ShowS
Bind -> String
(Int -> Bind -> ShowS)
-> (Bind -> String) -> ([Bind] -> ShowS) -> Show Bind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Bind -> ShowS
showsPrec :: Int -> Bind -> ShowS
$cshow :: Bind -> String
show :: Bind -> String
$cshowList :: [Bind] -> ShowS
showList :: [Bind] -> ShowS
Show)

-- | PId first, secret key second
data CancelRequest = CancelRequest Int32 Int32
  deriving stock (Int -> CancelRequest -> ShowS
[CancelRequest] -> ShowS
CancelRequest -> String
(Int -> CancelRequest -> ShowS)
-> (CancelRequest -> String)
-> ([CancelRequest] -> ShowS)
-> Show CancelRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CancelRequest -> ShowS
showsPrec :: Int -> CancelRequest -> ShowS
$cshow :: CancelRequest -> String
show :: CancelRequest -> String
$cshowList :: [CancelRequest] -> ShowS
showList :: [CancelRequest] -> ShowS
Show)

newtype CopyData = CopyData Builder

instance Show CopyData where
  show :: CopyData -> String
show CopyData
_ = String
"CopyData"

data Describe = Describe
  deriving stock (Int -> Describe -> ShowS
[Describe] -> ShowS
Describe -> String
(Int -> Describe -> ShowS)
-> (Describe -> String) -> ([Describe] -> ShowS) -> Show Describe
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Describe -> ShowS
showsPrec :: Int -> Describe -> ShowS
$cshow :: Describe -> String
show :: Describe -> String
$cshowList :: [Describe] -> ShowS
showList :: [Describe] -> ShowS
Show)

data Execute = Execute
  deriving stock (Int -> Execute -> ShowS
[Execute] -> ShowS
Execute -> String
(Int -> Execute -> ShowS)
-> (Execute -> String) -> ([Execute] -> ShowS) -> Show Execute
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Execute -> ShowS
showsPrec :: Int -> Execute -> ShowS
$cshow :: Execute -> String
show :: Execute -> String
$cshowList :: [Execute] -> ShowS
showList :: [Execute] -> ShowS
Show)

data CopyDone = CopyDone
  deriving stock (Int -> CopyDone -> ShowS
[CopyDone] -> ShowS
CopyDone -> String
(Int -> CopyDone -> ShowS)
-> (CopyDone -> String) -> ([CopyDone] -> ShowS) -> Show CopyDone
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CopyDone -> ShowS
showsPrec :: Int -> CopyDone -> ShowS
$cshow :: CopyDone -> String
show :: CopyDone -> String
$cshowList :: [CopyDone] -> ShowS
showList :: [CopyDone] -> ShowS
Show)

newtype CopyFail = CopyFail {CopyFail -> String
causeForFailure :: String}
  deriving stock (Int -> CopyFail -> ShowS
[CopyFail] -> ShowS
CopyFail -> String
(Int -> CopyFail -> ShowS)
-> (CopyFail -> String) -> ([CopyFail] -> ShowS) -> Show CopyFail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CopyFail -> ShowS
showsPrec :: Int -> CopyFail -> ShowS
$cshow :: CopyFail -> String
show :: CopyFail -> String
$cshowList :: [CopyFail] -> ShowS
showList :: [CopyFail] -> ShowS
Show)

data Flush = Flush
  deriving stock (Int -> Flush -> ShowS
[Flush] -> ShowS
Flush -> String
(Int -> Flush -> ShowS)
-> (Flush -> String) -> ([Flush] -> ShowS) -> Show Flush
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Flush -> ShowS
showsPrec :: Int -> Flush -> ShowS
$cshow :: Flush -> String
show :: Flush -> String
$cshowList :: [Flush] -> ShowS
showList :: [Flush] -> ShowS
Show)

newtype NoticeResponse = NoticeResponse (Map ErrorDetail LBS.ByteString)
  deriving stock (Int -> NoticeResponse -> ShowS
[NoticeResponse] -> ShowS
NoticeResponse -> String
(Int -> NoticeResponse -> ShowS)
-> (NoticeResponse -> String)
-> ([NoticeResponse] -> ShowS)
-> Show NoticeResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NoticeResponse -> ShowS
showsPrec :: Int -> NoticeResponse -> ShowS
$cshow :: NoticeResponse -> String
show :: NoticeResponse -> String
$cshowList :: [NoticeResponse] -> ShowS
showList :: [NoticeResponse] -> ShowS
Show)

newtype Query = Query ByteString

instance Show Query where
  show :: Query -> String
show Query
_ = String
"Query"

data Parse = Parse {Parse -> ByteString
queryString :: !ByteString, Parse -> [Maybe Oid]
specifiedParameterTypes :: ![Maybe Oid], Parse -> Maybe String
preparedStmtHash :: !(Maybe String)}

instance Show Parse where
  show :: Parse -> String
show Parse {[Maybe Oid]
Maybe String
ByteString
queryString :: Parse -> ByteString
specifiedParameterTypes :: Parse -> [Maybe Oid]
preparedStmtHash :: Parse -> Maybe String
queryString :: ByteString
specifiedParameterTypes :: [Maybe Oid]
preparedStmtHash :: Maybe String
..} = String
"Parse (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Maybe Oid] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe Oid]
specifiedParameterTypes) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" params specified) - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
queryString

data ParameterStatus = ParameterStatus {ParameterStatus -> Text
parameterName :: !Text, ParameterStatus -> Text
parameterValue :: !Text}
  deriving stock (Int -> ParameterStatus -> ShowS
[ParameterStatus] -> ShowS
ParameterStatus -> String
(Int -> ParameterStatus -> ShowS)
-> (ParameterStatus -> String)
-> ([ParameterStatus] -> ShowS)
-> Show ParameterStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParameterStatus -> ShowS
showsPrec :: Int -> ParameterStatus -> ShowS
$cshow :: ParameterStatus -> String
show :: ParameterStatus -> String
$cshowList :: [ParameterStatus] -> ShowS
showList :: [ParameterStatus] -> ShowS
Show)

data StartupMessage = StartupMessage {StartupMessage -> String
user :: String, StartupMessage -> String
database :: String, StartupMessage -> String
options :: String}
  deriving stock (Int -> StartupMessage -> ShowS
[StartupMessage] -> ShowS
StartupMessage -> String
(Int -> StartupMessage -> ShowS)
-> (StartupMessage -> String)
-> ([StartupMessage] -> ShowS)
-> Show StartupMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StartupMessage -> ShowS
showsPrec :: Int -> StartupMessage -> ShowS
$cshow :: StartupMessage -> String
show :: StartupMessage -> String
$cshowList :: [StartupMessage] -> ShowS
showList :: [StartupMessage] -> ShowS
Show)

data Sync = Sync
  deriving stock (Int -> Sync -> ShowS
[Sync] -> ShowS
Sync -> String
(Int -> Sync -> ShowS)
-> (Sync -> String) -> ([Sync] -> ShowS) -> Show Sync
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Sync -> ShowS
showsPrec :: Int -> Sync -> ShowS
$cshow :: Sync -> String
show :: Sync -> String
$cshowList :: [Sync] -> ShowS
showList :: [Sync] -> ShowS
Show)

data Terminate = Terminate
  deriving stock (Int -> Terminate -> ShowS
[Terminate] -> ShowS
Terminate -> String
(Int -> Terminate -> ShowS)
-> (Terminate -> String)
-> ([Terminate] -> ShowS)
-> Show Terminate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Terminate -> ShowS
showsPrec :: Int -> Terminate -> ShowS
$cshow :: Terminate -> String
show :: Terminate -> String
$cshowList :: [Terminate] -> ShowS
showList :: [Terminate] -> ShowS
Show)

instance FromPgMessage AuthenticationResponse where
  msgParser :: PgMsgParser AuthenticationResponse
msgParser = (Char -> ByteString -> Maybe AuthenticationResponse)
-> PgMsgParser AuthenticationResponse
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe AuthenticationResponse)
 -> PgMsgParser AuthenticationResponse)
-> (Char -> ByteString -> Maybe AuthenticationResponse)
-> PgMsgParser AuthenticationResponse
forall a b. (a -> b) -> a -> b
$ \Char
c ByteString
restOfMsg -> case Char
c of
    Char
'R' -> case ByteString -> Int64
LBS.length ByteString
restOfMsg of
      Int64
4 ->
        case forall a. Serialize a => ByteString -> Either String a
Cereal.decodeLazy @Int32 ByteString
restOfMsg of
          Right Int32
0 -> AuthenticationResponse -> Maybe AuthenticationResponse
forall a. a -> Maybe a
Just (AuthenticationResponse -> Maybe AuthenticationResponse)
-> AuthenticationResponse -> Maybe AuthenticationResponse
forall a b. (a -> b) -> a -> b
$ AuthenticationMethod -> AuthenticationResponse
AuthenticationResponse AuthenticationMethod
AuthOk
          Right Int32
2 -> AuthenticationResponse -> Maybe AuthenticationResponse
forall a. a -> Maybe a
Just (AuthenticationResponse -> Maybe AuthenticationResponse)
-> AuthenticationResponse -> Maybe AuthenticationResponse
forall a b. (a -> b) -> a -> b
$ AuthenticationMethod -> AuthenticationResponse
AuthenticationResponse AuthenticationMethod
AuthKerberosV5
          Right Int32
3 -> AuthenticationResponse -> Maybe AuthenticationResponse
forall a. a -> Maybe a
Just (AuthenticationResponse -> Maybe AuthenticationResponse)
-> AuthenticationResponse -> Maybe AuthenticationResponse
forall a b. (a -> b) -> a -> b
$ AuthenticationMethod -> AuthenticationResponse
AuthenticationResponse AuthenticationMethod
AuthCleartextPassword
          Right Int32
7 -> AuthenticationResponse -> Maybe AuthenticationResponse
forall a. a -> Maybe a
Just (AuthenticationResponse -> Maybe AuthenticationResponse)
-> AuthenticationResponse -> Maybe AuthenticationResponse
forall a b. (a -> b) -> a -> b
$ AuthenticationMethod -> AuthenticationResponse
AuthenticationResponse AuthenticationMethod
AuthGSS
          Right Int32
9 -> AuthenticationResponse -> Maybe AuthenticationResponse
forall a. a -> Maybe a
Just (AuthenticationResponse -> Maybe AuthenticationResponse)
-> AuthenticationResponse -> Maybe AuthenticationResponse
forall a b. (a -> b) -> a -> b
$ AuthenticationMethod -> AuthenticationResponse
AuthenticationResponse AuthenticationMethod
AuthSSPI
          Either String Int32
_ -> Maybe AuthenticationResponse
forall a. Maybe a
Nothing
      Int64
8 -> case (ByteString -> Either String Int32)
-> (ByteString, ByteString) -> (Either String Int32, ByteString)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. Serialize a => ByteString -> Either String a
Cereal.decodeLazy @Int32) ((ByteString, ByteString) -> (Either String Int32, ByteString))
-> (ByteString, ByteString) -> (Either String Int32, ByteString)
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> (ByteString, ByteString)
LBS.splitAt Int64
4 ByteString
restOfMsg of
        (Right Int32
5, ByteString
salt) -> AuthenticationResponse -> Maybe AuthenticationResponse
forall a. a -> Maybe a
Just (AuthenticationResponse -> Maybe AuthenticationResponse)
-> AuthenticationResponse -> Maybe AuthenticationResponse
forall a b. (a -> b) -> a -> b
$ AuthenticationMethod -> AuthenticationResponse
AuthenticationResponse (ByteString -> AuthenticationMethod
AuthMD5Password ByteString
salt)
        (Either String Int32, ByteString)
_ -> Maybe AuthenticationResponse
forall a. Maybe a
Nothing -- We don't care too much about parsing every possible response yet
      Int64
_ -> Maybe AuthenticationResponse
forall a. Maybe a
Nothing -- We don't care too much about parsing every possible response yet
    Char
_ -> Maybe AuthenticationResponse
forall a. Maybe a
Nothing

instance FromPgMessage BackendKeyData where
  msgParser :: PgMsgParser BackendKeyData
msgParser = (Char -> ByteString -> Maybe BackendKeyData)
-> PgMsgParser BackendKeyData
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe BackendKeyData)
 -> PgMsgParser BackendKeyData)
-> (Char -> ByteString -> Maybe BackendKeyData)
-> PgMsgParser BackendKeyData
forall a b. (a -> b) -> a -> b
$ \Char
c (Int64 -> ByteString -> (ByteString, ByteString)
LBS.splitAt Int64
4 -> (ByteString
pidBS, ByteString
secretBS)) -> case Char
c of
    Char
'K' -> case (,) (Int32 -> Int32 -> (Int32, Int32))
-> Either String Int32 -> Either String (Int32 -> (Int32, Int32))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => ByteString -> Either String a
Cereal.decodeLazy @Int32 ByteString
pidBS Either String (Int32 -> (Int32, Int32))
-> Either String Int32 -> Either String (Int32, Int32)
forall a b.
Either String (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => ByteString -> Either String a
Cereal.decodeLazy @Int32 ByteString
secretBS of
      Right (Int32
pid, Int32
secret) -> BackendKeyData -> Maybe BackendKeyData
forall a. a -> Maybe a
Just (BackendKeyData -> Maybe BackendKeyData)
-> BackendKeyData -> Maybe BackendKeyData
forall a b. (a -> b) -> a -> b
$ BackendKeyData {backendPid :: Int32
backendPid = Int32
pid, backendSecretKey :: Int32
backendSecretKey = Int32
secret}
      Left String
_ -> Maybe BackendKeyData
forall a. Maybe a
Nothing
    Char
_ -> Maybe BackendKeyData
forall a. Maybe a
Nothing

instance FromPgMessage BindComplete where
  msgParser :: PgMsgParser BindComplete
msgParser = (Char -> ByteString -> Maybe BindComplete)
-> PgMsgParser BindComplete
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe BindComplete)
 -> PgMsgParser BindComplete)
-> (Char -> ByteString -> Maybe BindComplete)
-> PgMsgParser BindComplete
forall a b. (a -> b) -> a -> b
$ \Char
c ByteString
_restOfMsg -> case Char
c of
    Char
'2' -> BindComplete -> Maybe BindComplete
forall a. a -> Maybe a
Just BindComplete
BindComplete
    Char
_ -> Maybe BindComplete
forall a. Maybe a
Nothing

instance FromPgMessage CommandComplete where
  msgParser :: PgMsgParser CommandComplete
msgParser = (Char -> ByteString -> Maybe CommandComplete)
-> PgMsgParser CommandComplete
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe CommandComplete)
 -> PgMsgParser CommandComplete)
-> (Char -> ByteString -> Maybe CommandComplete)
-> PgMsgParser CommandComplete
forall a b. (a -> b) -> a -> b
$ \Char
c ByteString
restOfMsg -> case Char
c of
    Char
'C' ->
      let astext :: Text
astext = ByteString -> Text
decodeASCII (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> ByteString
LBS.dropEnd Int64
1 ByteString
restOfMsg
       in case Parser Int64 -> Text -> Either String Int64
forall a. Parser a -> Text -> Either String a
TextParsec.parseOnly ((Parser Int64
ins Parser Int64 -> Parser Int64 -> Parser Int64
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Int64
del Parser Int64 -> Parser Int64 -> Parser Int64
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Int64
upd Parser Int64 -> Parser Int64 -> Parser Int64
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Int64
merge Parser Int64 -> Parser Int64 -> Parser Int64
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Int64
sel Parser Int64 -> Parser Int64 -> Parser Int64
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Int64
move Parser Int64 -> Parser Int64 -> Parser Int64
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Int64
fetch Parser Int64 -> Parser Int64 -> Parser Int64
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Int64
copy) Parser Int64 -> Parser Text () -> Parser Int64
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
TextParsec.endOfInput) Text
astext of
            Left String
_ -> CommandComplete -> Maybe CommandComplete
forall a. a -> Maybe a
Just (CommandComplete -> Maybe CommandComplete)
-> CommandComplete -> Maybe CommandComplete
forall a b. (a -> b) -> a -> b
$ Int64 -> CommandComplete
CommandComplete Int64
0
            Right Int64
n -> CommandComplete -> Maybe CommandComplete
forall a. a -> Maybe a
Just (CommandComplete -> Maybe CommandComplete)
-> CommandComplete -> Maybe CommandComplete
forall a b. (a -> b) -> a -> b
$ Int64 -> CommandComplete
CommandComplete Int64
n
    Char
_ -> Maybe CommandComplete
forall a. Maybe a
Nothing
    where
      ins :: Parser Int64
ins = Text -> Parser Text
TextParsec.string Text
"INSERT 0 " Parser Text -> Parser Int64 -> Parser Int64
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Int64
forall a. Integral a => Parser a
TextParsec.decimal
      del :: Parser Int64
del = Text -> Parser Text
TextParsec.string Text
"DELETE " Parser Text -> Parser Int64 -> Parser Int64
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Int64
forall a. Integral a => Parser a
TextParsec.decimal
      upd :: Parser Int64
upd = Text -> Parser Text
TextParsec.string Text
"UPDATE " Parser Text -> Parser Int64 -> Parser Int64
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Int64
forall a. Integral a => Parser a
TextParsec.decimal
      merge :: Parser Int64
merge = Text -> Parser Text
TextParsec.string Text
"MERGE " Parser Text -> Parser Int64 -> Parser Int64
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Int64
forall a. Integral a => Parser a
TextParsec.decimal
      sel :: Parser Int64
sel = Text -> Parser Text
TextParsec.string Text
"SELECT " Parser Text -> Parser Int64 -> Parser Int64
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Int64
forall a. Integral a => Parser a
TextParsec.decimal
      move :: Parser Int64
move = Text -> Parser Text
TextParsec.string Text
"MOVE " Parser Text -> Parser Int64 -> Parser Int64
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Int64
forall a. Integral a => Parser a
TextParsec.decimal
      fetch :: Parser Int64
fetch = Text -> Parser Text
TextParsec.string Text
"FETCH " Parser Text -> Parser Int64 -> Parser Int64
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Int64
forall a. Integral a => Parser a
TextParsec.decimal
      copy :: Parser Int64
copy = Text -> Parser Text
TextParsec.string Text
"COPY " Parser Text -> Parser Int64 -> Parser Int64
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Int64
forall a. Integral a => Parser a
TextParsec.decimal

instance ToPgMessage CancelRequest where
  toPgMessage :: CancelRequest -> Builder
toPgMessage (CancelRequest Int32
pid Int32
secret) =
    Int32 -> Builder
Builder.int32BE (Int32
4 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
4 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
4 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
4) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
Builder.int32BE Int32
80877102 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
Builder.int32BE Int32
pid Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
Builder.int32BE Int32
secret

instance ToPgMessage CopyData where
  toPgMessage :: CopyData -> Builder
toPgMessage (CopyData Builder
bs) =
    let len :: Int32
len = Builder -> Int32
Builder.builderLength Builder
bs
     in Char -> Builder
Builder.char7 Char
'd' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
Builder.int32BE (Int32
4 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
len) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
bs

instance ToPgMessage CopyFail where
  toPgMessage :: CopyFail -> Builder
toPgMessage (CopyFail String
bs) =
    let cstr :: Builder
cstr = String -> Builder
nulTermCString String
bs
     in Char -> Builder
Builder.char7 Char
'f' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
Builder.int32BE (Int32
4 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
bs) Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
cstr

instance ToPgMessage CopyDone where
  toPgMessage :: CopyDone -> Builder
toPgMessage CopyDone
CopyDone =
    Char -> Builder
Builder.char7 Char
'c' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
Builder.int32BE Int32
4

instance ToPgMessage Describe where
  toPgMessage :: Describe -> Builder
toPgMessage Describe
Describe =
    let unnamedPortal :: Builder
unnamedPortal = String -> Builder
nulTermCString String
""
     in Char -> Builder
Builder.char7 Char
'D' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
Builder.int32BE (Int32
4 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
1 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
1) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char7 Char
'P' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
unnamedPortal

instance ToPgMessage Execute where
  toPgMessage :: Execute -> Builder
toPgMessage Execute
_ =
    let unnamedPortal :: Builder
unnamedPortal = String -> Builder
nulTermCString String
""
        Int32
infiniteRowsToReturn :: Int32 = Int32
0
        contents :: Builder
contents = Builder
unnamedPortal Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
Builder.int32BE Int32
infiniteRowsToReturn
        contentsLen :: Int32
contentsLen = Int64 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int32) -> Int64 -> Int32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LBS.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toLazyByteString Builder
contents
     in Char -> Builder
Builder.char7 Char
'E' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
Builder.int32BE (Int32
4 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
contentsLen) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
contents

instance ToPgMessage Flush where
  toPgMessage :: Flush -> Builder
toPgMessage Flush
Flush =
    Char -> Builder
Builder.char7 Char
'H' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
Builder.int32BE Int32
4

instance FromPgMessage CopyInResponse where
  msgParser :: PgMsgParser CopyInResponse
msgParser = (Char -> ByteString -> Maybe CopyInResponse)
-> PgMsgParser CopyInResponse
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe CopyInResponse)
 -> PgMsgParser CopyInResponse)
-> (Char -> ByteString -> Maybe CopyInResponse)
-> PgMsgParser CopyInResponse
forall a b. (a -> b) -> a -> b
$ \Char
c ByteString
_ -> case Char
c of
    Char
'G' -> CopyInResponse -> Maybe CopyInResponse
forall a. a -> Maybe a
Just CopyInResponse
CopyInResponse
    Char
_ -> Maybe CopyInResponse
forall a. Maybe a
Nothing

instance FromPgMessage DataRow where
  msgParser :: PgMsgParser DataRow
msgParser = (Char -> ByteString -> Maybe DataRow) -> PgMsgParser DataRow
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe DataRow) -> PgMsgParser DataRow)
-> (Char -> ByteString -> Maybe DataRow) -> PgMsgParser DataRow
forall a b. (a -> b) -> a -> b
$ \Char
c !ByteString
restOfMsg -> case Char
c of
    Char
'D' -> DataRow -> Maybe DataRow
forall a. a -> Maybe a
Just (DataRow -> Maybe DataRow) -> DataRow -> Maybe DataRow
forall a b. (a -> b) -> a -> b
$ DataRow {rowColumnData :: ByteString
rowColumnData = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> ByteString
LBS.drop Int64
2 ByteString
restOfMsg}
    Char
_ -> Maybe DataRow
forall a. Maybe a
Nothing

instance FromPgMessage NoData where
  msgParser :: PgMsgParser NoData
msgParser = (Char -> ByteString -> Maybe NoData) -> PgMsgParser NoData
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe NoData) -> PgMsgParser NoData)
-> (Char -> ByteString -> Maybe NoData) -> PgMsgParser NoData
forall a b. (a -> b) -> a -> b
$ \Char
c ByteString
_ -> case Char
c of
    Char
'n' -> NoData -> Maybe NoData
forall a. a -> Maybe a
Just NoData
NoData
    Char
_ -> Maybe NoData
forall a. Maybe a
Nothing

instance FromPgMessage ParameterStatus where
  msgParser :: PgMsgParser ParameterStatus
msgParser = (Char -> ByteString -> Maybe ParameterStatus)
-> PgMsgParser ParameterStatus
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe ParameterStatus)
 -> PgMsgParser ParameterStatus)
-> (Char -> ByteString -> Maybe ParameterStatus)
-> PgMsgParser ParameterStatus
forall a b. (a -> b) -> a -> b
$ \Char
c !ByteString
restOfMsg -> case Char
c of
    Char
'S' -> case Parser (Text, Text) -> ByteString -> Either String (Text, Text)
forall a. Parser a -> ByteString -> Either String a
LazyParsec.parseOnly (((,) (Text -> Text -> (Text, Text))
-> Parser Text -> Parser ByteString (Text -> (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
nulTerminatedCStringParser Parser ByteString (Text -> (Text, Text))
-> Parser Text -> Parser (Text, Text)
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text
nulTerminatedCStringParser) Parser (Text, Text) -> Parser ByteString () -> Parser (Text, Text)
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
Parsec.endOfInput) ByteString
restOfMsg of
      Left String
_ -> String -> Maybe ParameterStatus
forall a. HasCallStack => String -> a
error String
"Failed parsing ParameterStatus"
      Right (Text
parameterName, Text
parameterValue) -> ParameterStatus -> Maybe ParameterStatus
forall a. a -> Maybe a
Just (ParameterStatus -> Maybe ParameterStatus)
-> ParameterStatus -> Maybe ParameterStatus
forall a b. (a -> b) -> a -> b
$ ParameterStatus {Text
parameterName :: Text
parameterValue :: Text
parameterName :: Text
parameterValue :: Text
..}
    Char
_ -> Maybe ParameterStatus
forall a. Maybe a
Nothing

instance FromPgMessage ParseComplete where
  msgParser :: PgMsgParser ParseComplete
msgParser = (Char -> ByteString -> Maybe ParseComplete)
-> PgMsgParser ParseComplete
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe ParseComplete)
 -> PgMsgParser ParseComplete)
-> (Char -> ByteString -> Maybe ParseComplete)
-> PgMsgParser ParseComplete
forall a b. (a -> b) -> a -> b
$ \Char
c ByteString
_ -> case Char
c of
    Char
'1' -> ParseComplete -> Maybe ParseComplete
forall a. a -> Maybe a
Just ParseComplete
ParseComplete
    Char
_ -> Maybe ParseComplete
forall a. Maybe a
Nothing

instance ToPgMessage PasswordMessage where
  toPgMessage :: PasswordMessage -> Builder
toPgMessage (PasswordMessage AuthenticationMethod
crypt String
username String
password) =
    let passwordBs :: Builder
passwordBs = case AuthenticationMethod
crypt of
          AuthenticationMethod
AuthCleartextPassword -> String -> Builder
nulTermCString String
password
          AuthMD5Password (ByteString -> ByteString
LBS.toStrict -> ByteString
salt) ->
            let passwordBytes :: ByteString
passwordBytes = Builder -> ByteString
Builder.toStrictByteString (String -> Builder
Builder.string7 String
password)
                usernameBytes :: ByteString
usernameBytes = Builder -> ByteString
Builder.toStrictByteString (String -> Builder
Builder.string7 String
username)
                innerHex :: ByteString
innerHex = ByteString -> ByteString
bytestringToHex (ByteString -> ByteString
MD5.hash (ByteString
passwordBytes ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
usernameBytes))
                outerHex :: ByteString
outerHex = ByteString -> ByteString
bytestringToHex (ByteString -> ByteString
MD5.hash (ByteString
innerHex ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
salt))
             in ByteString -> Builder
Builder.byteString ByteString
"md5" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.byteString ByteString
outerHex Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
Builder.word8 Word8
0
          AuthenticationMethod
_ -> String -> Builder
forall a. HasCallStack => String -> a
error String
"PasswordMessage method not implemented"
        msgLen :: Int32
msgLen = Builder -> Int32
builderLength Builder
passwordBs Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
4
     in Char -> Builder
Builder.char7 Char
'p' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
Builder.int32BE Int32
msgLen Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
passwordBs

instance ToPgMessage Query where
  toPgMessage :: Query -> Builder
toPgMessage (Query ByteString
bs) =
    -- TODO: Do we check if bytestring's length is too long or just continue ignoring the possibility?
    Char -> Builder
Builder.char7 Char
'Q' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
Builder.int32BE (Int32
5 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bs)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.byteString ByteString
bs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
Builder.word8 Word8
0

instance ToPgMessage Sync where
  toPgMessage :: Sync -> Builder
toPgMessage Sync
Sync =
    Char -> Builder
Builder.char7 Char
'S' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
Builder.int32BE Int32
4

instance ToPgMessage Terminate where
  toPgMessage :: Terminate -> Builder
toPgMessage Terminate
Terminate =
    Char -> Builder
Builder.char7 Char
'X' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
Builder.int32BE Int32
4

nulTermCString :: String -> Builder
nulTermCString :: String -> Builder
nulTermCString String
s = String -> Builder
Builder.string7 String
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
Builder.word8 Word8
0

bytestringToHex :: ByteString -> ByteString
bytestringToHex :: ByteString -> ByteString
bytestringToHex = (Word8 -> ByteString) -> ByteString -> ByteString
BS.concatMap (\Word8
w -> let (Word8
hi, Word8
lo) = Word8
w Word8 -> Word8 -> (Word8, Word8)
forall a. Integral a => a -> a -> (a, a)
`divMod` Word8
16 in [Word8] -> ByteString
BS.pack [Word8 -> Word8
forall {a}. (Ord a, Num a) => a -> a
hexChar Word8
hi, Word8 -> Word8
forall {a}. (Ord a, Num a) => a -> a
hexChar Word8
lo])
  where
    hexChar :: a -> a
hexChar a
n
      | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
10 = a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
48
      | Bool
otherwise = a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
87

instance ToPgMessage Bind where
  toPgMessage :: Bind -> Builder
toPgMessage Bind {Int
[BinaryField]
Maybe String
paramsValuesInOrder :: Bind -> [BinaryField]
resultColumnFmts :: Bind -> Int
preparedStmtHash :: Bind -> Maybe String
paramsValuesInOrder :: [BinaryField]
resultColumnFmts :: Int
preparedStmtHash :: Maybe String
..} =
    let unnamedDestPortal :: Builder
unnamedDestPortal = String -> Builder
nulTermCString String
""
        preparedStmtName :: Builder
preparedStmtName = String -> Builder
nulTermCString (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
preparedStmtHash
        Int16
numParamFmtCodesAllBinary :: Int16 = Int16
1
        Int16
fmtCodesBinary :: Int16 = Int16
1
        Int16
numQryParams :: Int16 = Int -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int16) -> Int -> Int16
forall a b. (a -> b) -> a -> b
$ [BinaryField] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BinaryField]
paramsValuesInOrder
        paramsLenAndVals :: Builder
paramsLenAndVals =
          ByteString -> Builder
Builder.lazyByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$
            Builder -> ByteString
Builder.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
              [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$
                (BinaryField -> Builder) -> [BinaryField] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map
                  BinaryField -> Builder
Builder.binaryField
                  [BinaryField]
paramsValuesInOrder
        Int16
numResultColumnsFmtCodes :: Int16 = Int -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
resultColumnFmts
        resultColumnsFmtCodes :: Builder
resultColumnsFmtCodes =
          [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$
            (Int -> Builder) -> [Int] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map
              (Builder -> Int -> Builder
forall a b. a -> b -> a
const (Builder -> Int -> Builder) -> Builder -> Int -> Builder
forall a b. (a -> b) -> a -> b
$ Int16 -> Builder
Builder.int16BE Int16
1)
              [Int
1 .. Int
resultColumnFmts]
        contents :: Builder
contents = Builder
unnamedDestPortal Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
preparedStmtName Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int16 -> Builder
Builder.int16BE Int16
numParamFmtCodesAllBinary Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int16 -> Builder
Builder.int16BE Int16
fmtCodesBinary Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int16 -> Builder
Builder.int16BE Int16
numQryParams Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
paramsLenAndVals Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int16 -> Builder
Builder.int16BE Int16
numResultColumnsFmtCodes Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
resultColumnsFmtCodes
        contentsLen :: Int32
contentsLen = Int64 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int32) -> Int64 -> Int32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LBS.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toLazyByteString Builder
contents
     in Char -> Builder
Builder.char7 Char
'B' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
Builder.int32BE (Int32
4 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
contentsLen) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
contents

instance ToPgMessage Parse where
  toPgMessage :: Parse -> Builder
toPgMessage Parse {[Maybe Oid]
Maybe String
ByteString
queryString :: Parse -> ByteString
specifiedParameterTypes :: Parse -> [Maybe Oid]
preparedStmtHash :: Parse -> Maybe String
queryString :: ByteString
specifiedParameterTypes :: [Maybe Oid]
preparedStmtHash :: Maybe String
..} =
    let preparedStmtName :: Builder
preparedStmtName = String -> Builder
nulTermCString (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
preparedStmtHash
        Int16
numParamsSpecified :: Int16 = Int -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int16) -> Int -> Int16
forall a b. (a -> b) -> a -> b
$ [Maybe Oid] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe Oid]
specifiedParameterTypes
        -- A 0 for an OID means "type unspecified", and is what we use when we don't know the type
        paramOids :: Builder
paramOids = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ (Maybe Oid -> Builder) -> [Maybe Oid] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Int32 -> Builder
Builder.int32BE (Int32 -> Builder) -> (Maybe Oid -> Int32) -> Maybe Oid -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> (Oid -> Int32) -> Maybe Oid -> Int32
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int32
0 Oid -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Maybe Oid]
specifiedParameterTypes
        contents :: Builder
contents = Builder
preparedStmtName Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
Builder.byteString ByteString
queryString Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
Builder.word8 Word8
0 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int16 -> Builder
Builder.int16BE Int16
numParamsSpecified Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
paramOids
        contentsLen :: Int32
contentsLen = Int64 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int32) -> Int64 -> Int32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LBS.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toLazyByteString Builder
contents
     in Char -> Builder
Builder.char7 Char
'P' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
Builder.int32BE (Int32
4 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
contentsLen) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
contents

instance ToPgMessage StartupMessage where
  toPgMessage :: StartupMessage -> Builder
toPgMessage StartupMessage {String
user :: StartupMessage -> String
database :: StartupMessage -> String
options :: StartupMessage -> String
user :: String
database :: String
options :: String
..} =
    let Int16
protocolMajorVersion :: Int16 = Int16
3
        Int16
protocolMinorVersion :: Int16 = Int16
0
        userBS :: Builder
userBS = String -> Builder
nulTermCString String
"user" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
nulTermCString String
user
        databaseBS :: Builder
databaseBS = String -> Builder
nulTermCString String
"database" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
nulTermCString String
database
        optionsBS :: Builder
optionsBS = String -> Builder
nulTermCString String
"options" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
nulTermCString String
options
        contents :: Builder
contents = Int16 -> Builder
Builder.int16BE Int16
protocolMajorVersion Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int16 -> Builder
Builder.int16BE Int16
protocolMinorVersion Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
userBS Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
databaseBS Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
optionsBS Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
Builder.word8 Word8
0
        contentsLen :: Int32
contentsLen = Int64 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int32) -> Int64 -> Int32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LBS.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toLazyByteString Builder
contents
     in -- TODO: What protocol version do we announce? We're following the example from the docs for now
        -- TODO: Can we send things like client_encoding, DateStyle, et. al as options here?

        Int32 -> Builder
Builder.int32BE (Int32
4 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
contentsLen) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
contents

instance FromPgMessage ReadyForQuery where
  msgParser :: PgMsgParser ReadyForQuery
msgParser = (Char -> ByteString -> Maybe ReadyForQuery)
-> PgMsgParser ReadyForQuery
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe ReadyForQuery)
 -> PgMsgParser ReadyForQuery)
-> (Char -> ByteString -> Maybe ReadyForQuery)
-> PgMsgParser ReadyForQuery
forall a b. (a -> b) -> a -> b
$ \Char
c ByteString
restOfMsg -> case (Char
c, ByteString
restOfMsg) of
    (Char
'Z', ByteString
"I") -> ReadyForQuery -> Maybe ReadyForQuery
forall a. a -> Maybe a
Just (ReadyForQuery -> Maybe ReadyForQuery)
-> ReadyForQuery -> Maybe ReadyForQuery
forall a b. (a -> b) -> a -> b
$ TransactionStatus -> ReadyForQuery
ReadyForQuery TransactionStatus
TransIdle
    (Char
'Z', ByteString
"T") -> ReadyForQuery -> Maybe ReadyForQuery
forall a. a -> Maybe a
Just (ReadyForQuery -> Maybe ReadyForQuery)
-> ReadyForQuery -> Maybe ReadyForQuery
forall a b. (a -> b) -> a -> b
$ TransactionStatus -> ReadyForQuery
ReadyForQuery TransactionStatus
TransInTrans
    (Char
'Z', ByteString
"E") -> ReadyForQuery -> Maybe ReadyForQuery
forall a. a -> Maybe a
Just (ReadyForQuery -> Maybe ReadyForQuery)
-> ReadyForQuery -> Maybe ReadyForQuery
forall a b. (a -> b) -> a -> b
$ TransactionStatus -> ReadyForQuery
ReadyForQuery TransactionStatus
TransInError
    (Char, ByteString)
_ -> Maybe ReadyForQuery
forall a. Maybe a
Nothing

instance FromPgMessage RowDescription where
  msgParser :: PgMsgParser RowDescription
msgParser = (Char -> ByteString -> Maybe RowDescription)
-> PgMsgParser RowDescription
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe RowDescription)
 -> PgMsgParser RowDescription)
-> (Char -> ByteString -> Maybe RowDescription)
-> PgMsgParser RowDescription
forall a b. (a -> b) -> a -> b
$ \Char
c ByteString
restOfMsg ->
    if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'T'
      then
        let (ByteString
numColsBS, ByteString
colContents) = Int64 -> ByteString -> (ByteString, ByteString)
LBS.splitAt Int64
2 ByteString
restOfMsg
            numCols :: Int16
numCols = (String -> Int16)
-> (Int16 -> Int16) -> Either String Int16 -> Int16
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Int16
forall a. HasCallStack => String -> a
error Int16 -> Int16
forall a. a -> a
id (Either String Int16 -> Int16) -> Either String Int16 -> Int16
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => ByteString -> Either String a
Cereal.decodeLazy @Int16 ByteString
numColsBS
            allColOidsParser :: Parsec.Parser [(Text, Oid)]
            allColOidsParser :: Parser [(Text, Oid)]
allColOidsParser = Int -> Parser (Text, Oid) -> Parser [(Text, Oid)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
numCols) Parser (Text, Oid)
colParser
         in case Parser [(Text, Oid)] -> ByteString -> Either String [(Text, Oid)]
forall a. Parser a -> ByteString -> Either String a
LazyParsec.parseOnly (Parser [(Text, Oid)]
allColOidsParser Parser [(Text, Oid)]
-> Parser ByteString () -> Parser [(Text, Oid)]
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
Parsec.endOfInput) ByteString
colContents of
              Left String
err -> String -> Maybe RowDescription
forall a. HasCallStack => String -> a
error (String -> Maybe RowDescription) -> String -> Maybe RowDescription
forall a b. (a -> b) -> a -> b
$ String
"Error parsing row's column types' OIDs: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
              Right [(Text, Oid)]
v -> RowDescription -> Maybe RowDescription
forall a. a -> Maybe a
Just (RowDescription -> Maybe RowDescription)
-> RowDescription -> Maybe RowDescription
forall a b. (a -> b) -> a -> b
$ [(Text, Oid)] -> RowDescription
RowDescription [(Text, Oid)]
v
      else Maybe RowDescription
forall a. Maybe a
Nothing

instance FromPgMessage ErrorResponse where
  msgParser :: PgMsgParser ErrorResponse
msgParser = (Char -> ByteString -> Maybe ErrorResponse)
-> PgMsgParser ErrorResponse
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe ErrorResponse)
 -> PgMsgParser ErrorResponse)
-> (Char -> ByteString -> Maybe ErrorResponse)
-> PgMsgParser ErrorResponse
forall a b. (a -> b) -> a -> b
$ \Char
c ByteString
restOfMsg ->
    if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'E'
      then Maybe ErrorResponse
forall a. Maybe a
Nothing
      else
        if ByteString -> Int64
LBS.length ByteString
restOfMsg Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0
          then ErrorResponse -> Maybe ErrorResponse
forall a. a -> Maybe a
Just (ErrorResponse -> Maybe ErrorResponse)
-> ErrorResponse -> Maybe ErrorResponse
forall a b. (a -> b) -> a -> b
$ Map ErrorDetail ByteString -> ErrorResponse
ErrorResponse Map ErrorDetail ByteString
forall a. Monoid a => a
mempty
          else
            let errorFields :: [ByteString]
errorFields = Word8 -> ByteString -> [ByteString]
LBS.split Word8
0 ByteString
restOfMsg
                parseSingleErrorField :: ByteString -> Maybe (ErrorDetail, ByteString)
parseSingleErrorField ByteString
ef = do
                  -- Maybe monad
                  (fieldErrorByte, fieldErrorBs) <- ByteString -> Maybe (Word8, ByteString)
LBS.uncons ByteString
ef
                  errDetail <- byteToErrorDetail fieldErrorByte
                  pure (errDetail, fieldErrorBs)
             in ErrorResponse -> Maybe ErrorResponse
forall a. a -> Maybe a
Just (ErrorResponse -> Maybe ErrorResponse)
-> ErrorResponse -> Maybe ErrorResponse
forall a b. (a -> b) -> a -> b
$ Map ErrorDetail ByteString -> ErrorResponse
ErrorResponse (Map ErrorDetail ByteString -> ErrorResponse)
-> Map ErrorDetail ByteString -> ErrorResponse
forall a b. (a -> b) -> a -> b
$ [(ErrorDetail, ByteString)] -> Map ErrorDetail ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ErrorDetail, ByteString)] -> Map ErrorDetail ByteString)
-> [(ErrorDetail, ByteString)] -> Map ErrorDetail ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> Maybe (ErrorDetail, ByteString))
-> [ByteString] -> [(ErrorDetail, ByteString)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ByteString -> Maybe (ErrorDetail, ByteString)
parseSingleErrorField [ByteString]
errorFields

instance FromPgMessage NoticeResponse where
  msgParser :: PgMsgParser NoticeResponse
msgParser = (Char -> ByteString -> Maybe NoticeResponse)
-> PgMsgParser NoticeResponse
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe NoticeResponse)
 -> PgMsgParser NoticeResponse)
-> (Char -> ByteString -> Maybe NoticeResponse)
-> PgMsgParser NoticeResponse
forall a b. (a -> b) -> a -> b
$ \Char
c ByteString
restOfMsg ->
    if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'N'
      then Maybe NoticeResponse
forall a. Maybe a
Nothing
      else
        -- TODO NOTICEs are exactly like ErrorResponses, so we could use a single parser
        if ByteString -> Int64
LBS.length ByteString
restOfMsg Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0
          then NoticeResponse -> Maybe NoticeResponse
forall a. a -> Maybe a
Just (NoticeResponse -> Maybe NoticeResponse)
-> NoticeResponse -> Maybe NoticeResponse
forall a b. (a -> b) -> a -> b
$ Map ErrorDetail ByteString -> NoticeResponse
NoticeResponse Map ErrorDetail ByteString
forall a. Monoid a => a
mempty
          else
            let errorFields :: [ByteString]
errorFields = Word8 -> ByteString -> [ByteString]
LBS.split Word8
0 ByteString
restOfMsg
                parseSingleErrorField :: ByteString -> Maybe (ErrorDetail, ByteString)
parseSingleErrorField ByteString
ef = do
                  -- Maybe monad
                  (fieldErrorByte, fieldErrorBs) <- ByteString -> Maybe (Word8, ByteString)
LBS.uncons ByteString
ef
                  errDetail <- byteToErrorDetail fieldErrorByte
                  pure (errDetail, fieldErrorBs)
             in NoticeResponse -> Maybe NoticeResponse
forall a. a -> Maybe a
Just (NoticeResponse -> Maybe NoticeResponse)
-> NoticeResponse -> Maybe NoticeResponse
forall a b. (a -> b) -> a -> b
$ Map ErrorDetail ByteString -> NoticeResponse
NoticeResponse (Map ErrorDetail ByteString -> NoticeResponse)
-> Map ErrorDetail ByteString -> NoticeResponse
forall a b. (a -> b) -> a -> b
$ [(ErrorDetail, ByteString)] -> Map ErrorDetail ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ErrorDetail, ByteString)] -> Map ErrorDetail ByteString)
-> [(ErrorDetail, ByteString)] -> Map ErrorDetail ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> Maybe (ErrorDetail, ByteString))
-> [ByteString] -> [(ErrorDetail, ByteString)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ByteString -> Maybe (ErrorDetail, ByteString)
parseSingleErrorField [ByteString]
errorFields

instance FromPgMessage NotificationResponse where
  msgParser :: PgMsgParser NotificationResponse
msgParser = (Char -> ByteString -> Maybe NotificationResponse)
-> PgMsgParser NotificationResponse
forall a. (Char -> ByteString -> Maybe a) -> PgMsgParser a
PgMsgParser ((Char -> ByteString -> Maybe NotificationResponse)
 -> PgMsgParser NotificationResponse)
-> (Char -> ByteString -> Maybe NotificationResponse)
-> PgMsgParser NotificationResponse
forall a b. (a -> b) -> a -> b
$ \Char
c ByteString
restOfMsg ->
    if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'A'
      then Maybe NotificationResponse
forall a. Maybe a
Nothing
      else
        let (ByteString
notifierPidBs, ByteString
channelNameAndPayload) = Int64 -> ByteString -> (ByteString, ByteString)
LBS.splitAt Int64
4 ByteString
restOfMsg
            notifierPid :: Int32
notifierPid = (String -> Int32)
-> (Int32 -> Int32) -> Either String Int32 -> Int32
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Int32
forall a. HasCallStack => String -> a
error Int32 -> Int32
forall a. a -> a
id (Either String Int32 -> Int32) -> Either String Int32 -> Int32
forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => ByteString -> Either String a
Cereal.decodeLazy @Int32 ByteString
notifierPidBs
         in case Parser NotificationResponse
-> ByteString -> Either String NotificationResponse
forall a. Parser a -> ByteString -> Either String a
LazyParsec.parseOnly
              ((Int32 -> Text -> Text -> NotificationResponse
NotificationResponse Int32
notifierPid (Text -> Text -> NotificationResponse)
-> Parser Text -> Parser ByteString (Text -> NotificationResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
nulTerminatedCStringParser Parser ByteString (Text -> NotificationResponse)
-> Parser Text -> Parser NotificationResponse
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text
nulTerminatedCStringParser) Parser NotificationResponse
-> Parser ByteString () -> Parser NotificationResponse
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
Parsec.endOfInput)
              ByteString
channelNameAndPayload of
              Left String
_ -> Maybe NotificationResponse
forall a. Maybe a
Nothing
              Right NotificationResponse
notif -> NotificationResponse -> Maybe NotificationResponse
forall a. a -> Maybe a
Just NotificationResponse
notif

byteToErrorDetail :: Word8 -> Maybe ErrorDetail
byteToErrorDetail :: Word8 -> Maybe ErrorDetail
byteToErrorDetail Word8
b = case Word8 -> Char
w2c Word8
b of
  -- Taken from https://www.postgresql.org/docs/current/protocol-error-fields.html
  Char
'S' -> Maybe ErrorDetail
forall a. Maybe a
Nothing -- This is localized severity which can make code locale-dependent, so we don't want it!
  Char
'V' -> ErrorDetail -> Maybe ErrorDetail
forall a. a -> Maybe a
Just ErrorDetail
ErrorSeverity
  -- S

  --     Severity: the field contents are ERROR, FATAL, or PANIC (in an error message), or WARNING, NOTICE, DEBUG, INFO, or LOG (in a notice message), or a localized translation of one of these. Always present.
  -- V

  --     Severity: the field contents are ERROR, FATAL, or PANIC (in an error message), or WARNING, NOTICE, DEBUG, INFO, or LOG (in a notice message). This is identical to the S field except that the contents are never localized. This is present only in messages generated by PostgreSQL versions 9.6 and later.
  Char
'C' -> ErrorDetail -> Maybe ErrorDetail
forall a. a -> Maybe a
Just ErrorDetail
ErrorCode
  -- C

  --     Code: the SQLSTATE code for the error (see Appendix A). Not localizable. Always present.
  Char
'M' -> ErrorDetail -> Maybe ErrorDetail
forall a. a -> Maybe a
Just ErrorDetail
ErrorHumanReadableMsg
  -- M

  --     Message: the primary human-readable error message. This should be accurate but terse (typically one line). Always present.
  Char
'D' -> ErrorDetail -> Maybe ErrorDetail
forall a. a -> Maybe a
Just ErrorDetail
ErrorDetail
  -- D

  --     Detail: an optional secondary error message carrying more detail about the problem. Might run to multiple lines.
  Char
'H' -> ErrorDetail -> Maybe ErrorDetail
forall a. a -> Maybe a
Just ErrorDetail
ErrorHint
  -- H

  --     Hint: an optional suggestion what to do about the problem. This is intended to differ from Detail in that it offers advice (potentially inappropriate) rather than hard facts. Might run to multiple lines.
  Char
'P' -> ErrorDetail -> Maybe ErrorDetail
forall a. a -> Maybe a
Just ErrorDetail
ErrorPosition
  -- P

  --     Position: the field value is a decimal ASCII integer, indicating an error cursor position as an index into the original query string. The first character has index 1, and positions are measured in characters not bytes.
  Char
'p' -> ErrorDetail -> Maybe ErrorDetail
forall a. a -> Maybe a
Just ErrorDetail
ErrorInternalPosition
  -- p

  --     Internal position: this is defined the same as the P field, but it is used when the cursor position refers to an internally generated command rather than the one submitted by the client. The q field will always appear when this field appears.
  Char
'q' -> ErrorDetail -> Maybe ErrorDetail
forall a. a -> Maybe a
Just ErrorDetail
ErrorInternalCommand
  -- q

  --     Internal query: the text of a failed internally-generated command. This could be, for example, an SQL query issued by a PL/pgSQL function.
  Char
'W' -> ErrorDetail -> Maybe ErrorDetail
forall a. a -> Maybe a
Just ErrorDetail
ErrorContext
  -- W

  --     Where: an indication of the context in which the error occurred. Presently this includes a call stack traceback of active procedural language functions and internally-generated queries. The trace is one entry per line, most recent first.
  Char
's' -> ErrorDetail -> Maybe ErrorDetail
forall a. a -> Maybe a
Just ErrorDetail
ErrorSchema
  -- s

  --     Schema name: if the error was associated with a specific database object, the name of the schema containing that object, if any.
  Char
't' -> ErrorDetail -> Maybe ErrorDetail
forall a. a -> Maybe a
Just ErrorDetail
ErrorTable
  -- t

  --     Table name: if the error was associated with a specific table, the name of the table. (Refer to the schema name field for the name of the table's schema.)
  Char
'c' -> ErrorDetail -> Maybe ErrorDetail
forall a. a -> Maybe a
Just ErrorDetail
ErrorColumn
  -- c

  --     Column name: if the error was associated with a specific table column, the name of the column. (Refer to the schema and table name fields to identify the table.)
  Char
'd' -> ErrorDetail -> Maybe ErrorDetail
forall a. a -> Maybe a
Just ErrorDetail
ErrorType
  -- d

  --     Data type name: if the error was associated with a specific data type, the name of the data type. (Refer to the schema name field for the name of the data type's schema.)
  Char
'n' -> ErrorDetail -> Maybe ErrorDetail
forall a. a -> Maybe a
Just ErrorDetail
ErrorConstraint
  -- n

  --     Constraint name: if the error was associated with a specific constraint, the name of the constraint. Refer to fields listed above for the associated table or domain. (For this purpose, indexes are treated as constraints, even if they weren't created with constraint syntax.)
  Char
'F' -> ErrorDetail -> Maybe ErrorDetail
forall a. a -> Maybe a
Just ErrorDetail
ErrorSourceFile
  -- F

  --     File: the file name of the source-code location where the error was reported.
  Char
'L' -> ErrorDetail -> Maybe ErrorDetail
forall a. a -> Maybe a
Just ErrorDetail
ErrorSourceLine
  -- L

  --     Line: the line number of the source-code location where the error was reported.
  Char
'R' -> ErrorDetail -> Maybe ErrorDetail
forall a. a -> Maybe a
Just ErrorDetail
ErrorSourceRoutine
  -- R

  --     Routine: the name of the source-code routine reporting the error.
  Char
_ -> Maybe ErrorDetail
forall a. Maybe a
Nothing