{- |
  Module:      ClickHaskell
  Copyright:   (c) 2023 Dmitry Kovalev
  License:     BSD-3-Clause
  Maintainer:  Dmitry Kovalev
  Stability:   Experimental

  For full documentation, visit: https://clickhaskell.dev/
-}

module ClickHaskell
  (
  {- * Connection -}
    ConnectionArgs, defaultConnectionArgs
  , setHost, setPort, setUser, setDatabase, setPassword
  , overrideNetwork, overrideHostname, overrideOsUser
  , Connection(..), openConnection
  , Buffer(..)

  {- * Statements and commands -}

  {- ** Exceptions -}
  , ClientError(..)
  , ConnectionError(..)
  , UserError(..)
  , InternalError(..)

  {- ** Low level -}
  {- *** SELECT -}, select
  {- *** INSERT -}, insert
  {- *** Commands -}, command
  {- *** Ping -}, ping

  {- ** Wrappers -}
  , Table, View
  , selectFrom, selectFromView, generateRandom
  , insertInto

  {- ** Deriving -}
  , ClickHaskell(..)
  , ToChType(toChType, fromChType)
  , SerializableColumn
  , Column, KnownColumn

  {- ** Query -}
  , ToQueryPart(toQueryPart), parameter, Parameter, Parameters, viewParameters


  {- * ClickHouse types -}
  , IsChType(chTypeName, defaultValueOfTypeName)
  , DateTime(..), DateTime64
  , Int8, Int16, Int32, Int64, Int128(..)
  , UInt8, UInt16, UInt32, UInt64, UInt128, UInt256, Word128(..)
  , Nullable
  , LowCardinality, IsLowCardinalitySupported
  , UUID(..)
  , Array(..)
  , ChString(..)


  {- * Protocol parts -}

  {- ** Shared -}
  , UVarInt(..), SinceRevision(..), ProtocolRevision
  {- *** Data packet -}, DataPacket(..), BlockInfo(..)

  {- ** Client -}, ClientPacket(..)
  {- *** Hello -}, HelloPacket(..), Addendum(..)
  {- *** Query -}
  , QueryPacket(..)
  , DbSettings(..), QueryParameters(..), QueryStage(..)
  , ClientInfo(..), QueryKind(..)
  
  {- ** Server -}, ServerPacket(..)
  {- *** Hello -}, HelloResponse(..), PasswordComplexityRules(..)
  {- *** Exception -}, ExceptionPacket(..)
  {- *** Progress -}, ProgressPacket(..)
  {- *** ProfileInfo -}, ProfileInfo(..)
  {- *** TableColumns -}, TableColumns(..)
  ) where

-- Internal
import ClickHaskell.Columns
import ClickHaskell.Connection
import ClickHaskell.Packets
import ClickHaskell.Primitive
import ClickHaskell.Statements

-- GHC included
import Control.Concurrent (newMVar, putMVar, takeMVar)
import Control.Exception (Exception, SomeException, bracketOnError, catch, finally, mask, onException, throw, throwIO)
import Control.Monad (when)
import Data.Binary.Get
import Data.ByteString.Builder
import Data.Int (Int16, Int32, Int64, Int8)
import Data.Kind (Type)
import Data.Maybe (fromMaybe, listToMaybe)
import GHC.Generics (C1, D1, Generic (..), K1 (K1, unK1), M1 (M1, unM1), Meta (MetaSel), Rec0, S1, type (:*:) (..))
import GHC.Stack (HasCallStack, callStack, prettyCallStack)
import GHC.TypeLits (ErrorMessage (..), TypeError)
import System.Environment (lookupEnv)
import System.Timeout (timeout)

-- External
import Data.WideWord (Int128 (..), Word128 (..))
import Network.Socket hiding (SocketOption (..))

-- * Connection

openConnection :: HasCallStack => ConnectionArgs -> IO Connection
openConnection :: HasCallStack => ConnectionArgs -> IO Connection
openConnection creds :: ConnectionArgs
creds@MkConnectionArgs{Maybe ServiceName
mHostname :: Maybe ServiceName
mHostname :: ConnectionArgs -> Maybe ServiceName
mHostname, Maybe ServiceName
mOsUser :: Maybe ServiceName
mOsUser :: ConnectionArgs -> Maybe ServiceName
mOsUser} = do
  Maybe ServiceName
hostname <- IO (Maybe ServiceName)
-> (ServiceName -> IO (Maybe ServiceName))
-> Maybe ServiceName
-> IO (Maybe ServiceName)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ServiceName -> IO (Maybe ServiceName)
lookupEnv ServiceName
"HOSTNAME") (Maybe ServiceName -> IO (Maybe ServiceName)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ServiceName -> IO (Maybe ServiceName))
-> (ServiceName -> Maybe ServiceName)
-> ServiceName
-> IO (Maybe ServiceName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceName -> Maybe ServiceName
forall a. a -> Maybe a
Just) Maybe ServiceName
mHostname
  Maybe ServiceName
osUser   <- IO (Maybe ServiceName)
-> (ServiceName -> IO (Maybe ServiceName))
-> Maybe ServiceName
-> IO (Maybe ServiceName)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ServiceName -> IO (Maybe ServiceName)
lookupEnv ServiceName
"USER")     (Maybe ServiceName -> IO (Maybe ServiceName)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ServiceName -> IO (Maybe ServiceName))
-> (ServiceName -> Maybe ServiceName)
-> ServiceName
-> IO (Maybe ServiceName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceName -> Maybe ServiceName
forall a. a -> Maybe a
Just) Maybe ServiceName
mOsUser
  ConnectionState
connectionState <-
    ConnectionArgs -> IO ConnectionState
createConnectionState
      (ConnectionArgs -> IO ConnectionState)
-> (ConnectionArgs -> ConnectionArgs)
-> ConnectionArgs
-> IO ConnectionState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ConnectionArgs -> ConnectionArgs)
-> (ServiceName -> ConnectionArgs -> ConnectionArgs)
-> Maybe ServiceName
-> ConnectionArgs
-> ConnectionArgs
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ConnectionArgs -> ConnectionArgs
forall a. a -> a
id ServiceName -> ConnectionArgs -> ConnectionArgs
overrideHostname Maybe ServiceName
hostname)
      (ConnectionArgs -> ConnectionArgs)
-> (ConnectionArgs -> ConnectionArgs)
-> ConnectionArgs
-> ConnectionArgs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ConnectionArgs -> ConnectionArgs)
-> (ServiceName -> ConnectionArgs -> ConnectionArgs)
-> Maybe ServiceName
-> ConnectionArgs
-> ConnectionArgs
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ConnectionArgs -> ConnectionArgs
forall a. a -> a
id ServiceName -> ConnectionArgs -> ConnectionArgs
overrideOsUser Maybe ServiceName
osUser)
      (ConnectionArgs -> IO ConnectionState)
-> ConnectionArgs -> IO ConnectionState
forall a b. (a -> b) -> a -> b
$ ConnectionArgs
creds
  MVar ConnectionState -> Connection
MkConnection (MVar ConnectionState -> Connection)
-> IO (MVar ConnectionState) -> IO Connection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConnectionState -> IO (MVar ConnectionState)
forall a. a -> IO (MVar a)
newMVar ConnectionState
connectionState

-- * Statements and commands

-- ** Exceptions 

{- |
  A wrapper for all client-related errors

  You should this exception when you work with any ClickHaskell IO function.

  e.g. `command`, `select`, `insert` etc
  
-}
data ClientError where
  UnmatchedResult :: HasCallStack => UserError -> ClientError
    -- ^ Query result unmatched with declared specialization
  DatabaseException :: HasCallStack => ExceptionPacket -> ClientError
    -- ^ Database responded with an exception packet
  InternalError :: HasCallStack => InternalError -> ClientError
  deriving anyclass (Show ClientError
Typeable ClientError
(Typeable ClientError, Show ClientError) =>
(ClientError -> SomeException)
-> (SomeException -> Maybe ClientError)
-> (ClientError -> ServiceName)
-> Exception ClientError
SomeException -> Maybe ClientError
ClientError -> ServiceName
ClientError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> ServiceName) -> Exception e
$ctoException :: ClientError -> SomeException
toException :: ClientError -> SomeException
$cfromException :: SomeException -> Maybe ClientError
fromException :: SomeException -> Maybe ClientError
$cdisplayException :: ClientError -> ServiceName
displayException :: ClientError -> ServiceName
Exception)

instance Show ClientError where
  show :: ClientError -> ServiceName
show (UnmatchedResult UserError
err) = ServiceName
"UserError " ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> UserError -> ServiceName
forall a. Show a => a -> ServiceName
show UserError
err ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> ServiceName
"\n" ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> CallStack -> ServiceName
prettyCallStack CallStack
HasCallStack => CallStack
callStack
  show (DatabaseException ExceptionPacket
err) = ServiceName
"DatabaseException " ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> ExceptionPacket -> ServiceName
forall a. Show a => a -> ServiceName
show ExceptionPacket
err ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> ServiceName
"\n" ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> CallStack -> ServiceName
prettyCallStack CallStack
HasCallStack => CallStack
callStack
  show (InternalError InternalError
err) = ServiceName
"InternalError " ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> InternalError -> ServiceName
forall a. Show a => a -> ServiceName
show InternalError
err ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> ServiceName
"\n" ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> CallStack -> ServiceName
prettyCallStack CallStack
HasCallStack => CallStack
callStack

{- |
  Errors intended to be handled by developers
-}
data UserError
  = UnmatchedType String
  -- ^ Column type mismatch in data packet
  | UnmatchedColumn String
  -- ^ Column name mismatch in data packet
  | UnmatchedColumnsCount String
  -- ^ Occurs when actual columns count less or more than expected
  deriving (Int -> UserError -> ShowS
[UserError] -> ShowS
UserError -> ServiceName
(Int -> UserError -> ShowS)
-> (UserError -> ServiceName)
-> ([UserError] -> ShowS)
-> Show UserError
forall a.
(Int -> a -> ShowS)
-> (a -> ServiceName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserError -> ShowS
showsPrec :: Int -> UserError -> ShowS
$cshow :: UserError -> ServiceName
show :: UserError -> ServiceName
$cshowList :: [UserError] -> ShowS
showList :: [UserError] -> ShowS
Show, Show UserError
Typeable UserError
(Typeable UserError, Show UserError) =>
(UserError -> SomeException)
-> (SomeException -> Maybe UserError)
-> (UserError -> ServiceName)
-> Exception UserError
SomeException -> Maybe UserError
UserError -> ServiceName
UserError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> ServiceName) -> Exception e
$ctoException :: UserError -> SomeException
toException :: UserError -> SomeException
$cfromException :: SomeException -> Maybe UserError
fromException :: SomeException -> Maybe UserError
$cdisplayException :: UserError -> ServiceName
displayException :: UserError -> ServiceName
Exception)


-- ** Low level

-- *** SELECT

select ::
  forall columns output result
  .
  ClickHaskell columns output
  =>
  Connection -> ChString -> ([output] -> IO result) -> IO [result]
select :: forall (columns :: [*]) output result.
ClickHaskell columns output =>
Connection -> ChString -> ([output] -> IO result) -> IO [result]
select Connection
conn ChString
query [output] -> IO result
f = do
  Connection -> (ConnectionState -> IO [result]) -> IO [result]
forall a.
HasCallStack =>
Connection -> (ConnectionState -> IO a) -> IO a
withConnection Connection
conn ((ConnectionState -> IO [result]) -> IO [result])
-> (ConnectionState -> IO [result]) -> IO [result]
forall a b. (a -> b) -> a -> b
$ \ConnectionState
connState -> do
    ConnectionState -> (ProtocolRevision -> Builder) -> IO ()
writeToConnection ConnectionState
connState (QueryPacketArgs -> ProtocolRevision -> Builder
serializeQueryPacket (QueryPacketArgs -> ProtocolRevision -> Builder)
-> QueryPacketArgs -> ProtocolRevision -> Builder
forall a b. (a -> b) -> a -> b
$ ConnectionState -> ChString -> QueryPacketArgs
mkQueryArgs ConnectionState
connState ChString
query)
    ConnectionState -> (ProtocolRevision -> Builder) -> IO ()
writeToConnection ConnectionState
connState (ChString -> UVarInt -> UVarInt -> ProtocolRevision -> Builder
serializeDataPacket ChString
"" UVarInt
0 UVarInt
0)
    ConnectionState -> [result] -> IO [result]
loopSelect ConnectionState
connState []
  where
  loopSelect :: ConnectionState -> [result] -> IO [result]
loopSelect connState :: ConnectionState
connState@MkConnectionState{ProtocolRevision
ConnectionArgs
Buffer
buffer :: Buffer
revision :: ProtocolRevision
creds :: ConnectionArgs
creds :: ConnectionState -> ConnectionArgs
revision :: ConnectionState -> ProtocolRevision
buffer :: ConnectionState -> Buffer
..} [result]
acc =
    Buffer -> Get ServerPacket -> IO ServerPacket
forall a. Buffer -> Get a -> IO a
readBuffer Buffer
buffer (ProtocolRevision -> Get ServerPacket
forall chType.
Serializable chType =>
ProtocolRevision -> Get chType
deserialize ProtocolRevision
revision)
    IO ServerPacket -> (ServerPacket -> IO [result]) -> IO [result]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ServerPacket
packet -> case ServerPacket
packet of
      DataResponse MkDataPacket{columns_count :: DataPacket -> UVarInt
columns_count = UVarInt
0, rows_count :: DataPacket -> UVarInt
rows_count = UVarInt
0} -> ConnectionState -> [result] -> IO [result]
loopSelect ConnectionState
connState [result]
acc
      DataResponse MkDataPacket{UVarInt
columns_count :: DataPacket -> UVarInt
columns_count :: UVarInt
columns_count, UVarInt
rows_count :: DataPacket -> UVarInt
rows_count :: UVarInt
rows_count} -> do
        let expected :: UVarInt
expected = forall (columns :: [*]) record.
ClickHaskell columns record =>
UVarInt
columnsCount @columns @output
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UVarInt
columns_count UVarInt -> UVarInt -> Bool
forall a. Eq a => a -> a -> Bool
/= UVarInt
expected) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          (ClientError -> IO ()
forall a e. Exception e => e -> a
throw (ClientError -> IO ())
-> (ServiceName -> ClientError) -> ServiceName -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => UserError -> ClientError
UserError -> ClientError
UnmatchedResult (UserError -> ClientError)
-> (ServiceName -> UserError) -> ServiceName -> ClientError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceName -> UserError
UnmatchedColumnsCount)
            (ServiceName
"Expected " ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> UVarInt -> ServiceName
forall a. Show a => a -> ServiceName
show UVarInt
expected ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> ServiceName
" columns but got " ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> UVarInt -> ServiceName
forall a. Show a => a -> ServiceName
show UVarInt
columns_count)
        !result
result <- [output] -> IO result
f ([output] -> IO result) -> IO [output] -> IO result
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Buffer -> Get [output] -> IO [output]
forall a. Buffer -> Get a -> IO a
readBuffer Buffer
buffer (forall (columns :: [*]) record.
ClickHaskell columns record =>
Bool -> ProtocolRevision -> UVarInt -> Get [record]
deserializeRecords @columns Bool
True ProtocolRevision
revision UVarInt
rows_count)
        ConnectionState -> [result] -> IO [result]
loopSelect ConnectionState
connState (result
result result -> [result] -> [result]
forall a. a -> [a] -> [a]
: [result]
acc)
      Progress    ProgressPacket
_       -> ConnectionState -> [result] -> IO [result]
loopSelect ConnectionState
connState [result]
acc
      ProfileInfo ProfileInfo
_       -> ConnectionState -> [result] -> IO [result]
loopSelect ConnectionState
connState [result]
acc
      ServerPacket
EndOfStream         -> [result] -> IO [result]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [result]
acc
      Exception ExceptionPacket
exception -> ClientError -> IO [result]
forall e a. Exception e => e -> IO a
throwIO (HasCallStack => ExceptionPacket -> ClientError
ExceptionPacket -> ClientError
DatabaseException ExceptionPacket
exception)
      ServerPacket
otherPacket         -> ClientError -> IO [result]
forall e a. Exception e => e -> IO a
throwIO (HasCallStack => InternalError -> ClientError
InternalError -> ClientError
InternalError (InternalError -> ClientError) -> InternalError -> ClientError
forall a b. (a -> b) -> a -> b
$ UVarInt -> InternalError
UnexpectedPacketType (UVarInt -> InternalError) -> UVarInt -> InternalError
forall a b. (a -> b) -> a -> b
$ ServerPacket -> UVarInt
serverPacketToNum ServerPacket
otherPacket)

-- *** INSERT

insert ::
  forall columns record
  .
  ClickHaskell columns record
  =>
  Connection -> ChString -> [record] -> IO ()
insert :: forall (columns :: [*]) record.
ClickHaskell columns record =>
Connection -> ChString -> [record] -> IO ()
insert Connection
conn ChString
query [record]
columnsData = do
  Connection -> (ConnectionState -> IO ()) -> IO ()
forall a.
HasCallStack =>
Connection -> (ConnectionState -> IO a) -> IO a
withConnection Connection
conn ((ConnectionState -> IO ()) -> IO ())
-> (ConnectionState -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ConnectionState
connState -> do
    ConnectionState -> (ProtocolRevision -> Builder) -> IO ()
writeToConnection ConnectionState
connState (QueryPacketArgs -> ProtocolRevision -> Builder
serializeQueryPacket (QueryPacketArgs -> ProtocolRevision -> Builder)
-> QueryPacketArgs -> ProtocolRevision -> Builder
forall a b. (a -> b) -> a -> b
$ ConnectionState -> ChString -> QueryPacketArgs
mkQueryArgs ConnectionState
connState ChString
query)
    ConnectionState -> (ProtocolRevision -> Builder) -> IO ()
writeToConnection ConnectionState
connState (ChString -> UVarInt -> UVarInt -> ProtocolRevision -> Builder
serializeDataPacket ChString
"" UVarInt
0 UVarInt
0)
    ConnectionState -> IO ()
loopInsert ConnectionState
connState
  where
  loopInsert :: ConnectionState -> IO ()
loopInsert connState :: ConnectionState
connState@MkConnectionState{ProtocolRevision
ConnectionArgs
Buffer
creds :: ConnectionState -> ConnectionArgs
revision :: ConnectionState -> ProtocolRevision
buffer :: ConnectionState -> Buffer
buffer :: Buffer
revision :: ProtocolRevision
creds :: ConnectionArgs
..}  = do
    ServerPacket
firstPacket <- Buffer -> Get ServerPacket -> IO ServerPacket
forall a. Buffer -> Get a -> IO a
readBuffer Buffer
buffer (ProtocolRevision -> Get ServerPacket
forall chType.
Serializable chType =>
ProtocolRevision -> Get chType
deserialize ProtocolRevision
revision)
    case ServerPacket
firstPacket of
      TableColumns      TableColumns
_ -> ConnectionState -> IO ()
loopInsert ConnectionState
connState 
      DataResponse MkDataPacket{} -> do
        [record]
_emptyDataPacket <- Buffer -> Get [record] -> IO [record]
forall a. Buffer -> Get a -> IO a
readBuffer Buffer
buffer (forall (columns :: [*]) record.
ClickHaskell columns record =>
Bool -> ProtocolRevision -> UVarInt -> Get [record]
deserializeRecords @columns @record Bool
False ProtocolRevision
revision UVarInt
0)
        let rows :: UVarInt
rows = Int -> UVarInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([record] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [record]
columnsData)
            cols :: UVarInt
cols = forall (columns :: [*]) record.
ClickHaskell columns record =>
UVarInt
columnsCount @columns @record
        ConnectionState -> (ProtocolRevision -> Builder) -> IO ()
writeToConnection ConnectionState
connState (ChString -> UVarInt -> UVarInt -> ProtocolRevision -> Builder
serializeDataPacket ChString
"" UVarInt
cols UVarInt
rows)
        ConnectionState -> (ProtocolRevision -> Builder) -> IO ()
writeToConnection ConnectionState
connState (forall (columns :: [*]) record.
ClickHaskell columns record =>
[record] -> ProtocolRevision -> Builder
serializeRecords @columns [record]
columnsData)
        ConnectionState -> (ProtocolRevision -> Builder) -> IO ()
writeToConnection ConnectionState
connState (ChString -> UVarInt -> UVarInt -> ProtocolRevision -> Builder
serializeDataPacket ChString
"" UVarInt
0 UVarInt
0)
        ConnectionState -> IO ()
loopInsert ConnectionState
connState
      ServerPacket
EndOfStream         -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Exception ExceptionPacket
exception -> ClientError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (HasCallStack => ExceptionPacket -> ClientError
ExceptionPacket -> ClientError
DatabaseException ExceptionPacket
exception)
      ServerPacket
otherPacket         -> ClientError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (HasCallStack => InternalError -> ClientError
InternalError -> ClientError
InternalError (InternalError -> ClientError) -> InternalError -> ClientError
forall a b. (a -> b) -> a -> b
$ UVarInt -> InternalError
UnexpectedPacketType (UVarInt -> InternalError) -> UVarInt -> InternalError
forall a b. (a -> b) -> a -> b
$ ServerPacket -> UVarInt
serverPacketToNum ServerPacket
otherPacket)

-- *** Ping

{- |
  Sends `Ping` packet and handles `Pong` packet
-}
ping :: HasCallStack => Connection -> IO ()
ping :: HasCallStack => Connection -> IO ()
ping Connection
conn = do
  Connection -> (ConnectionState -> IO ()) -> IO ()
forall a.
HasCallStack =>
Connection -> (ConnectionState -> IO a) -> IO a
withConnection Connection
conn ((ConnectionState -> IO ()) -> IO ())
-> (ConnectionState -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \connState :: ConnectionState
connState@MkConnectionState{ProtocolRevision
revision :: ConnectionState -> ProtocolRevision
revision :: ProtocolRevision
revision, Buffer
buffer :: ConnectionState -> Buffer
buffer :: Buffer
buffer} -> do
    ConnectionState -> (ProtocolRevision -> Builder) -> IO ()
writeToConnection ConnectionState
connState (\ProtocolRevision
rev -> ProtocolRevision -> ClientPacket -> Builder
forall chType.
Serializable chType =>
ProtocolRevision -> chType -> Builder
serialize ProtocolRevision
rev ClientPacket
Ping)
    ServerPacket
responsePacket <- Buffer -> Get ServerPacket -> IO ServerPacket
forall a. Buffer -> Get a -> IO a
readBuffer Buffer
buffer (ProtocolRevision -> Get ServerPacket
forall chType.
Serializable chType =>
ProtocolRevision -> Get chType
deserialize ProtocolRevision
revision)
    case ServerPacket
responsePacket of
      ServerPacket
Pong                -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Exception ExceptionPacket
exception -> ClientError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (HasCallStack => ExceptionPacket -> ClientError
ExceptionPacket -> ClientError
DatabaseException ExceptionPacket
exception)
      ServerPacket
otherPacket         -> ClientError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (HasCallStack => InternalError -> ClientError
InternalError -> ClientError
InternalError (InternalError -> ClientError) -> InternalError -> ClientError
forall a b. (a -> b) -> a -> b
$ UVarInt -> InternalError
UnexpectedPacketType (UVarInt -> InternalError) -> UVarInt -> InternalError
forall a b. (a -> b) -> a -> b
$ ServerPacket -> UVarInt
serverPacketToNum ServerPacket
otherPacket)

-- *** Commands

{- |
  Might be used for any command without data responses

  For example: CREATE, TRUNCATE, KILL, SET, GRANT

  __Throws exception if any data was returned__
-}
command :: HasCallStack => Connection -> ChString -> IO ()
command :: HasCallStack => Connection -> ChString -> IO ()
command Connection
conn ChString
query = do
  Connection -> (ConnectionState -> IO ()) -> IO ()
forall a.
HasCallStack =>
Connection -> (ConnectionState -> IO a) -> IO a
withConnection Connection
conn ((ConnectionState -> IO ()) -> IO ())
-> (ConnectionState -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ConnectionState
connState -> do
    ConnectionState -> (ProtocolRevision -> Builder) -> IO ()
writeToConnection ConnectionState
connState (QueryPacketArgs -> ProtocolRevision -> Builder
serializeQueryPacket (ConnectionState -> ChString -> QueryPacketArgs
mkQueryArgs ConnectionState
connState ChString
query))
    ConnectionState -> (ProtocolRevision -> Builder) -> IO ()
writeToConnection ConnectionState
connState (ChString -> UVarInt -> UVarInt -> ProtocolRevision -> Builder
serializeDataPacket ChString
"" UVarInt
0 UVarInt
0)
    ConnectionState -> IO ()
handleCreate ConnectionState
connState
  where
  handleCreate :: ConnectionState -> IO ()
  handleCreate :: ConnectionState -> IO ()
handleCreate MkConnectionState{ProtocolRevision
ConnectionArgs
Buffer
creds :: ConnectionState -> ConnectionArgs
revision :: ConnectionState -> ProtocolRevision
buffer :: ConnectionState -> Buffer
buffer :: Buffer
revision :: ProtocolRevision
creds :: ConnectionArgs
..} =
    Buffer -> Get ServerPacket -> IO ServerPacket
forall a. Buffer -> Get a -> IO a
readBuffer Buffer
buffer (ProtocolRevision -> Get ServerPacket
forall chType.
Serializable chType =>
ProtocolRevision -> Get chType
deserialize ProtocolRevision
revision)
    IO ServerPacket -> (ServerPacket -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ServerPacket
packet -> case ServerPacket
packet of
      ServerPacket
EndOfStream         -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Exception ExceptionPacket
exception -> ClientError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (HasCallStack => ExceptionPacket -> ClientError
ExceptionPacket -> ClientError
DatabaseException ExceptionPacket
exception)
      ServerPacket
otherPacket         -> ClientError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (HasCallStack => InternalError -> ClientError
InternalError -> ClientError
InternalError (InternalError -> ClientError) -> InternalError -> ClientError
forall a b. (a -> b) -> a -> b
$ UVarInt -> InternalError
UnexpectedPacketType (UVarInt -> InternalError) -> UVarInt -> InternalError
forall a b. (a -> b) -> a -> b
$ ServerPacket -> UVarInt
serverPacketToNum ServerPacket
otherPacket)


-- ** Deriving

class ClickHaskell columns record
  where
  default deserializeRecords :: GenericClickHaskell record columns => Bool -> ProtocolRevision -> UVarInt -> Get [record]
  deserializeRecords :: Bool -> ProtocolRevision -> UVarInt -> Get [record]
  deserializeRecords Bool
isCheckRequired ProtocolRevision
rev UVarInt
size =
    forall (columns :: [*]) (f :: * -> *) p res.
GClickHaskell columns f =>
Bool -> ProtocolRevision -> UVarInt -> (f p -> res) -> Get [res]
gDeserializeRecords @columns Bool
isCheckRequired ProtocolRevision
rev UVarInt
size Rep record Any -> record
forall a x. Generic a => Rep a x -> a
forall x. Rep record x -> record
to

  default serializeRecords :: GenericClickHaskell record columns => [record] -> ProtocolRevision -> Builder
  serializeRecords :: [record] -> ProtocolRevision -> Builder
  serializeRecords [record]
records ProtocolRevision
rev = forall (columns :: [*]) (f :: * -> *) res p.
GClickHaskell columns f =>
ProtocolRevision -> (res -> f p) -> [res] -> Builder
gSerializeRecords @columns ProtocolRevision
rev record -> Rep record Any
forall x. record -> Rep record x
forall a x. Generic a => a -> Rep a x
from [record]
records

  default columns :: GenericClickHaskell record columns => Builder
  columns :: Builder
  columns = [(Builder, Builder)] -> Builder
forall {a} {b}. (Monoid a, IsString a) => [(a, b)] -> a
buildCols (forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
[(Builder, Builder)]
gReadingColumns @columns @(Rep record))
    where
    buildCols :: [(a, b)] -> a
buildCols [] = a
forall a. Monoid a => a
mempty
    buildCols ((a
col, b
_):[])   = a
col
    buildCols ((a
col, b
_):[(a, b)]
rest) = a
col a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
", " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> [(a, b)] -> a
buildCols [(a, b)]
rest

  default readingColumnsAndTypes :: GenericClickHaskell record columns => Builder
  readingColumnsAndTypes ::  Builder
  readingColumnsAndTypes = [(Builder, Builder)] -> Builder
forall {a}. (Monoid a, IsString a) => [(a, a)] -> a
buildColsTypes (forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
[(Builder, Builder)]
gReadingColumns @columns @(Rep record))
    where
    buildColsTypes :: [(a, a)] -> a
buildColsTypes [] = a
forall a. Monoid a => a
mempty
    buildColsTypes ((a
col, a
typ):[])   = a
col a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
typ
    buildColsTypes ((a
col, a
typ):[(a, a)]
rest) = a
col a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
typ a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
", " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> [(a, a)] -> a
buildColsTypes [(a, a)]
rest

  default columnsCount :: GenericClickHaskell record columns => UVarInt
  columnsCount :: UVarInt
  columnsCount = forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
UVarInt
gColumnsCount @columns @(Rep record)

type GenericClickHaskell record hasColumns =
  ( Generic record
  , GClickHaskell hasColumns (Rep record)
  )


-- ** Wrappers

type ClickHaskellTable table record =
  ( IsTable table
  , ClickHaskell (GetColumns table) record
  )

type ClickHaskellView view record =
  ( IsView view
  , ClickHaskell (GetColumns view) record
  )

selectFrom ::
  forall table output result
  .
  ClickHaskellTable table output
  =>
  Connection -> ([output] -> IO result) -> IO [result]
selectFrom :: forall table output result.
ClickHaskellTable table output =>
Connection -> ([output] -> IO result) -> IO [result]
selectFrom Connection
conn [output] -> IO result
f = forall (columns :: [*]) output result.
ClickHaskell columns output =>
Connection -> ChString -> ([output] -> IO result) -> IO [result]
select @(GetColumns table) Connection
conn ChString
query [output] -> IO result
f
  where
  query :: ChString
query = Builder -> ChString
forall chType userType.
ToChType chType userType =>
userType -> chType
toChType (Builder -> ChString) -> Builder -> ChString
forall a b. (a -> b) -> a -> b
$
    Builder
"SELECT " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> forall (columns :: [*]) record.
ClickHaskell columns record =>
Builder
columns @(GetColumns table) @output Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Builder
" FROM " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> forall table. KnownSymbol (GetTableName table) => Builder
tableName @table

selectFromView ::
  forall view output result parameters
  .
  ClickHaskellView view output
  =>
  Connection -> (Parameters '[] -> Parameters parameters) -> ([output] -> IO result) -> IO [result]
selectFromView :: forall view output result (parameters :: [*]).
ClickHaskellView view output =>
Connection
-> (Parameters '[] -> Parameters parameters)
-> ([output] -> IO result)
-> IO [result]
selectFromView Connection
conn Parameters '[] -> Parameters parameters
interpreter [output] -> IO result
f = forall (columns :: [*]) output result.
ClickHaskell columns output =>
Connection -> ChString -> ([output] -> IO result) -> IO [result]
select @(GetColumns view) Connection
conn ChString
query [output] -> IO result
f
  where
  query :: ChString
query = Builder -> ChString
forall chType userType.
ToChType chType userType =>
userType -> chType
toChType (Builder -> ChString) -> Builder -> ChString
forall a b. (a -> b) -> a -> b
$
    Builder
"SELECT " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> forall (columns :: [*]) record.
ClickHaskell columns record =>
Builder
columns @(GetColumns view) @output Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Builder
" FROM " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> forall table. KnownSymbol (GetTableName table) => Builder
tableName @view Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Parameters '[] -> Parameters parameters) -> Builder
forall (passedParameters :: [*]).
(Parameters '[] -> Parameters passedParameters) -> Builder
viewParameters Parameters '[] -> Parameters parameters
interpreter

generateRandom ::
  forall columns output result
  .
  ClickHaskell columns output
  =>
  Connection -> (UInt64, UInt64, UInt64) -> UInt64 -> ([output] -> IO result) -> IO [result]
generateRandom :: forall (columns :: [*]) output result.
ClickHaskell columns output =>
Connection
-> (UInt64, UInt64, UInt64)
-> UInt64
-> ([output] -> IO result)
-> IO [result]
generateRandom Connection
conn (UInt64
randomSeed, UInt64
maxStrLen, UInt64
maxArrayLen) UInt64
limit [output] -> IO result
f = forall (columns :: [*]) output result.
ClickHaskell columns output =>
Connection -> ChString -> ([output] -> IO result) -> IO [result]
select @columns Connection
conn ChString
query [output] -> IO result
f
  where
  query :: ChString
query = Builder -> ChString
forall chType userType.
ToChType chType userType =>
userType -> chType
toChType (Builder -> ChString) -> Builder -> ChString
forall a b. (a -> b) -> a -> b
$
    Builder
"SELECT * FROM generateRandom(" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"'" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> forall (columns :: [*]) record.
ClickHaskell columns record =>
Builder
readingColumnsAndTypes @columns @output Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"' ," Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
          UInt64 -> Builder
forall chType. ToQueryPart chType => chType -> Builder
toQueryPart UInt64
randomSeed Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"," Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
          UInt64 -> Builder
forall chType. ToQueryPart chType => chType -> Builder
toQueryPart UInt64
maxStrLen Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"," Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
          UInt64 -> Builder
forall chType. ToQueryPart chType => chType -> Builder
toQueryPart UInt64
maxArrayLen Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
      Builder
")" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Builder
" LIMIT " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> UInt64 -> Builder
forall chType. ToQueryPart chType => chType -> Builder
toQueryPart UInt64
limit Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
";"

insertInto ::
  forall table record
  .
  ClickHaskellTable table record
  =>
  Connection -> [record] -> IO ()
insertInto :: forall table record.
ClickHaskellTable table record =>
Connection -> [record] -> IO ()
insertInto Connection
conn [record]
columnsData = forall (columns :: [*]) record.
ClickHaskell columns record =>
Connection -> ChString -> [record] -> IO ()
insert @(GetColumns table) Connection
conn ChString
query [record]
columnsData
  where
  query :: ChString
query = Builder -> ChString
forall chType userType.
ToChType chType userType =>
userType -> chType
toChType (Builder -> ChString) -> Builder -> ChString
forall a b. (a -> b) -> a -> b
$
    Builder
"INSERT INTO " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> forall table. KnownSymbol (GetTableName table) => Builder
tableName @table
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" (" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> forall (columns :: [*]) record.
ClickHaskell columns record =>
Builder
columns @(GetColumns table) @record Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
") VALUES"




-- * Internal

mkQueryArgs :: ConnectionState -> ChString -> QueryPacketArgs
mkQueryArgs :: ConnectionState -> ChString -> QueryPacketArgs
mkQueryArgs MkConnectionState{creds :: ConnectionState -> ConnectionArgs
creds=MkConnectionArgs{Bool
ServiceName
Maybe ServiceName
ServiceName -> SockAddr -> Socket -> IO Buffer
mHostname :: ConnectionArgs -> Maybe ServiceName
mOsUser :: ConnectionArgs -> Maybe ServiceName
user :: ServiceName
pass :: ServiceName
db :: ServiceName
host :: ServiceName
mPort :: Maybe ServiceName
isTLS :: Bool
mOsUser :: Maybe ServiceName
mHostname :: Maybe ServiceName
initBuffer :: ServiceName -> SockAddr -> Socket -> IO Buffer
initBuffer :: ConnectionArgs -> ServiceName -> SockAddr -> Socket -> IO Buffer
isTLS :: ConnectionArgs -> Bool
mPort :: ConnectionArgs -> Maybe ServiceName
host :: ConnectionArgs -> ServiceName
db :: ConnectionArgs -> ServiceName
pass :: ConnectionArgs -> ServiceName
user :: ConnectionArgs -> ServiceName
..}} ChString
query
  = MkQueryPacketArgs{ServiceName
Maybe ServiceName
ChString
user :: ServiceName
mOsUser :: Maybe ServiceName
mHostname :: Maybe ServiceName
query :: ChString
query :: ChString
mHostname :: Maybe ServiceName
mOsUser :: Maybe ServiceName
user :: ServiceName
..}

-- ** Connection

readBuffer :: Buffer -> Get a -> IO a
readBuffer :: forall a. Buffer -> Get a -> IO a
readBuffer Buffer
buffer Get a
deseralize =
  forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch @InternalError
    (Buffer -> Get a -> IO a
forall a. Buffer -> Get a -> IO a
rawBufferRead Buffer
buffer Get a
deseralize)
    (ClientError -> IO a
forall e a. Exception e => e -> IO a
throwIO (ClientError -> IO a)
-> (InternalError -> ClientError) -> InternalError -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => InternalError -> ClientError
InternalError -> ClientError
InternalError)

withConnection :: HasCallStack => Connection -> (ConnectionState -> IO a) -> IO a
withConnection :: forall a.
HasCallStack =>
Connection -> (ConnectionState -> IO a) -> IO a
withConnection (MkConnection MVar ConnectionState
connStateMVar) ConnectionState -> IO a
f =
  ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    ConnectionState
connState <- MVar ConnectionState -> IO ConnectionState
forall a. MVar a -> IO a
takeMVar MVar ConnectionState
connStateMVar
    a
b <- IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
onException
      (IO a -> IO a
forall a. IO a -> IO a
restore (ConnectionState -> IO a
f ConnectionState
connState))
      (MVar ConnectionState -> ConnectionState -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ConnectionState
connStateMVar (ConnectionState -> IO ()) -> IO ConnectionState -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ConnectionState -> IO ConnectionState
reopenConnection ConnectionState
connState)
    MVar ConnectionState -> ConnectionState -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ConnectionState
connStateMVar ConnectionState
connState
    a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
b

reopenConnection :: ConnectionState -> IO ConnectionState
reopenConnection :: ConnectionState -> IO ConnectionState
reopenConnection MkConnectionState{ConnectionArgs
creds :: ConnectionState -> ConnectionArgs
creds :: ConnectionArgs
creds, Buffer
buffer :: ConnectionState -> Buffer
buffer :: Buffer
buffer} = do
  Buffer -> IO ()
flushBuffer Buffer
buffer
  Buffer -> IO ()
closeSock Buffer
buffer
  ConnectionArgs -> IO ConnectionState
createConnectionState ConnectionArgs
creds

createConnectionState :: ConnectionArgs -> IO ConnectionState
createConnectionState :: ConnectionArgs -> IO ConnectionState
createConnectionState creds :: ConnectionArgs
creds@MkConnectionArgs {ServiceName
user :: ConnectionArgs -> ServiceName
user :: ServiceName
user, ServiceName
pass :: ConnectionArgs -> ServiceName
pass :: ServiceName
pass, ServiceName
db :: ConnectionArgs -> ServiceName
db :: ServiceName
db, ServiceName
host :: ConnectionArgs -> ServiceName
host :: ServiceName
host, Maybe ServiceName
mPort :: ConnectionArgs -> Maybe ServiceName
mPort :: Maybe ServiceName
mPort, ServiceName -> SockAddr -> Socket -> IO Buffer
initBuffer :: ConnectionArgs -> ServiceName -> SockAddr -> Socket -> IO Buffer
initBuffer :: ServiceName -> SockAddr -> Socket -> IO Buffer
initBuffer, Bool
isTLS :: ConnectionArgs -> Bool
isTLS :: Bool
isTLS} = do
  let port :: ServiceName
port = ServiceName -> Maybe ServiceName -> ServiceName
forall a. a -> Maybe a -> a
fromMaybe (if Bool
isTLS then ServiceName
"9440" else ServiceName
"9000") Maybe ServiceName
mPort
  AddrInfo{Family
addrFamily :: Family
addrFamily :: AddrInfo -> Family
addrFamily, SocketType
addrSocketType :: SocketType
addrSocketType :: AddrInfo -> SocketType
addrSocketType, ProtocolNumber
addrProtocol :: ProtocolNumber
addrProtocol :: AddrInfo -> ProtocolNumber
addrProtocol, SockAddr
addrAddress :: SockAddr
addrAddress :: AddrInfo -> SockAddr
addrAddress}
    <- IO AddrInfo
-> (AddrInfo -> IO AddrInfo) -> Maybe AddrInfo -> IO AddrInfo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ConnectionError -> IO AddrInfo
forall e a. Exception e => e -> IO a
throwIO ConnectionError
NoAdressResolved) AddrInfo -> IO AddrInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe AddrInfo -> IO AddrInfo)
-> ([AddrInfo] -> Maybe AddrInfo) -> [AddrInfo] -> IO AddrInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [AddrInfo] -> Maybe AddrInfo
forall a. [a] -> Maybe a
listToMaybe
    ([AddrInfo] -> IO AddrInfo) -> IO [AddrInfo] -> IO AddrInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe AddrInfo
-> Maybe ServiceName -> Maybe ServiceName -> IO [AddrInfo]
forall (t :: * -> *).
GetAddrInfo t =>
Maybe AddrInfo
-> Maybe ServiceName -> Maybe ServiceName -> IO (t AddrInfo)
getAddrInfo
      (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
defaultHints{addrFlags = [AI_ADDRCONFIG], addrSocketType = Stream})
      (ServiceName -> Maybe ServiceName
forall a. a -> Maybe a
Just ServiceName
host)
      (ServiceName -> Maybe ServiceName
forall a. a -> Maybe a
Just ServiceName
port)
  Buffer
buffer <- IO Buffer -> (Buffer -> IO Buffer) -> Maybe Buffer -> IO Buffer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ConnectionError -> IO Buffer
forall e a. Exception e => e -> IO a
throwIO ConnectionError
EstablishTimeout) Buffer -> IO Buffer
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Maybe Buffer -> IO Buffer) -> IO (Maybe Buffer) -> IO Buffer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> IO Buffer -> IO (Maybe Buffer)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
3_000_000 (
      IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Buffer) -> IO Buffer
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        (Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
addrFamily SocketType
addrSocketType ProtocolNumber
addrProtocol)
        (\Socket
sock ->
          forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch @SomeException
            (IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally (Socket -> ShutdownCmd -> IO ()
shutdown Socket
sock ShutdownCmd
ShutdownBoth) (Socket -> IO ()
close Socket
sock))
            (IO () -> SomeException -> IO ()
forall a b. a -> b -> a
const (IO () -> SomeException -> IO ())
-> IO () -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        )
        (\Socket
sock -> ServiceName -> SockAddr -> Socket -> IO Buffer
initBuffer ServiceName
host SockAddr
addrAddress Socket
sock)
      )

  (Buffer -> Builder -> IO ()
writeSock Buffer
buffer (Builder -> IO ())
-> (ProtocolRevision -> Builder) -> ProtocolRevision -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceName
-> ServiceName -> ServiceName -> ProtocolRevision -> Builder
seriliazeHelloPacket ServiceName
db ServiceName
user ServiceName
pass) ProtocolRevision
latestSupportedRevision
  ServerPacket
serverPacketType <- Buffer -> Get ServerPacket -> IO ServerPacket
forall a. Buffer -> Get a -> IO a
readBuffer Buffer
buffer (ProtocolRevision -> Get ServerPacket
forall chType.
Serializable chType =>
ProtocolRevision -> Get chType
deserialize ProtocolRevision
latestSupportedRevision)
  case ServerPacket
serverPacketType of
    HelloResponse MkHelloResponse{ProtocolRevision
server_revision :: ProtocolRevision
server_revision :: HelloResponse -> ProtocolRevision
server_revision} -> do
      let revision :: ProtocolRevision
revision = ProtocolRevision -> ProtocolRevision -> ProtocolRevision
forall a. Ord a => a -> a -> a
min ProtocolRevision
server_revision ProtocolRevision
latestSupportedRevision
          conn :: ConnectionState
conn = MkConnectionState{ProtocolRevision
ConnectionArgs
Buffer
creds :: ConnectionArgs
revision :: ProtocolRevision
buffer :: Buffer
creds :: ConnectionArgs
buffer :: Buffer
revision :: ProtocolRevision
..}
      ConnectionState -> (ProtocolRevision -> Builder) -> IO ()
writeToConnection ConnectionState
conn (\ProtocolRevision
rev -> ProtocolRevision -> Addendum -> Builder
forall chType.
Serializable chType =>
ProtocolRevision -> chType -> Builder
serialize ProtocolRevision
rev MkAddendum{quota_key :: SinceRevision ChString DBMS_MIN_PROTOCOL_VERSION_WITH_QUOTA_KEY
quota_key = ChString
-> SinceRevision ChString DBMS_MIN_PROTOCOL_VERSION_WITH_QUOTA_KEY
forall a (revisionNumber :: Nat).
a -> SinceRevision a revisionNumber
MkSinceRevision ChString
""})
      ConnectionState -> IO ConnectionState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnectionState
conn
    Exception ExceptionPacket
exception -> ClientError -> IO ConnectionState
forall e a. Exception e => e -> IO a
throwIO (HasCallStack => ExceptionPacket -> ClientError
ExceptionPacket -> ClientError
DatabaseException ExceptionPacket
exception)
    ServerPacket
otherPacket         -> ClientError -> IO ConnectionState
forall e a. Exception e => e -> IO a
throwIO (HasCallStack => InternalError -> ClientError
InternalError -> ClientError
InternalError (InternalError -> ClientError) -> InternalError -> ClientError
forall a b. (a -> b) -> a -> b
$ UVarInt -> InternalError
UnexpectedPacketType (UVarInt -> InternalError) -> UVarInt -> InternalError
forall a b. (a -> b) -> a -> b
$ ServerPacket -> UVarInt
serverPacketToNum ServerPacket
otherPacket)


-- ** Serialization Generic API


class GClickHaskell (columns :: [Type]) f
  where

  {-
    Generic deriving can be a bit tricky

    You can think of it as
    1) Columns serialization logic generator
    2) Columns-to-rows(list of records) transposer
  -}
  gDeserializeRecords :: Bool -> ProtocolRevision -> UVarInt -> (f p -> res) -> Get [res]
  gSerializeRecords :: ProtocolRevision -> (res -> f p) -> [res] -> Builder
  {-
    and affected columns extractor
  -}
  gReadingColumns :: [(Builder, Builder)]
  gColumnsCount :: UVarInt

{-
  Unwrapping data type constructor
    data Record = MkRecord ..
-}
instance
  GClickHaskell columns f
  =>
  GClickHaskell columns (D1 c (C1 c2 f))
  where
  {-# INLINE gDeserializeRecords #-}
  gDeserializeRecords :: forall p res.
Bool
-> ProtocolRevision
-> UVarInt
-> (D1 c (C1 c2 f) p -> res)
-> Get [res]
gDeserializeRecords Bool
isCheckRequired ProtocolRevision
rev UVarInt
size D1 c (C1 c2 f) p -> res
f =
    forall (columns :: [*]) (f :: * -> *) p res.
GClickHaskell columns f =>
Bool -> ProtocolRevision -> UVarInt -> (f p -> res) -> Get [res]
gDeserializeRecords @columns Bool
isCheckRequired ProtocolRevision
rev UVarInt
size (D1 c (C1 c2 f) p -> res
f (D1 c (C1 c2 f) p -> res)
-> (f p -> D1 c (C1 c2 f) p) -> f p -> res
forall b c a. (b -> c) -> (a -> b) -> a -> c
. C1 c2 f p -> D1 c (C1 c2 f) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (C1 c2 f p -> D1 c (C1 c2 f) p)
-> (f p -> C1 c2 f p) -> f p -> D1 c (C1 c2 f) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f p -> C1 c2 f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1)

  {-# INLINE gSerializeRecords #-}
  gSerializeRecords :: forall res p.
ProtocolRevision -> (res -> D1 c (C1 c2 f) p) -> [res] -> Builder
gSerializeRecords ProtocolRevision
rev res -> D1 c (C1 c2 f) p
f = forall (columns :: [*]) (f :: * -> *) res p.
GClickHaskell columns f =>
ProtocolRevision -> (res -> f p) -> [res] -> Builder
gSerializeRecords @columns ProtocolRevision
rev (M1 C c2 f p -> f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (M1 C c2 f p -> f p) -> (res -> M1 C c2 f p) -> res -> f p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. D1 c (C1 c2 f) p -> M1 C c2 f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (D1 c (C1 c2 f) p -> M1 C c2 f p)
-> (res -> D1 c (C1 c2 f) p) -> res -> M1 C c2 f p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. res -> D1 c (C1 c2 f) p
f)

  gReadingColumns :: [(Builder, Builder)]
gReadingColumns = forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
[(Builder, Builder)]
gReadingColumns @columns @f
  gColumnsCount :: UVarInt
gColumnsCount = forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
UVarInt
gColumnsCount @columns @f

{-
  Flattening of generic products

  For example
    (
      field_1::T1 :*: field_2::T2)
    ) :*: (
        field_3::T3 :*: field_4::T4
      )

  turns into
    field_1::T1 :*: (
      field_2::T2 :*: (field_3::T3 :*: field_4::T4)
    )
-}
instance
  ( GClickHaskell columns left
  , GClickHaskell columns (right1 :*: right2)
  )
  =>
  GClickHaskell columns ((left :*: right1) :*: right2)
  where
  {-# INLINE gDeserializeRecords #-}
  gDeserializeRecords :: forall p res.
Bool
-> ProtocolRevision
-> UVarInt
-> ((:*:) (left :*: right1) right2 p -> res)
-> Get [res]
gDeserializeRecords Bool
isCheckRequired ProtocolRevision
rev UVarInt
size (:*:) (left :*: right1) right2 p -> res
f = do
    [left p]
lefts  <- forall (columns :: [*]) (f :: * -> *) p res.
GClickHaskell columns f =>
Bool -> ProtocolRevision -> UVarInt -> (f p -> res) -> Get [res]
gDeserializeRecords @columns @left  Bool
isCheckRequired ProtocolRevision
rev UVarInt
size left p -> left p
forall a. a -> a
id
    [(:*:) right1 right2 p]
rights <- forall (columns :: [*]) (f :: * -> *) p res.
GClickHaskell columns f =>
Bool -> ProtocolRevision -> UVarInt -> (f p -> res) -> Get [res]
gDeserializeRecords @columns @(right1 :*: right2) Bool
isCheckRequired ProtocolRevision
rev UVarInt
size (:*:) right1 right2 p -> (:*:) right1 right2 p
forall a. a -> a
id
    let goDeserialize :: [res] -> [left p] -> [(:*:) right1 right2 p] -> Get [res]
goDeserialize ![res]
acc (left p
l:[left p]
ls) ((right1 p
r1 :*: right2 p
r2):[(:*:) right1 right2 p]
rs) = [res] -> [left p] -> [(:*:) right1 right2 p] -> Get [res]
goDeserialize ((res -> [res] -> [res]
forall a. a -> [a] -> [a]
:[res]
acc) (res -> [res]) -> res -> [res]
forall a b. (a -> b) -> a -> b
$! (:*:) (left :*: right1) right2 p -> res
f ((left p
l left p -> right1 p -> (:*:) left right1 p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: right1 p
r1)(:*:) left right1 p -> right2 p -> (:*:) (left :*: right1) right2 p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*:right2 p
r2)) [left p]
ls [(:*:) right1 right2 p]
rs
        goDeserialize ![res]
acc [] [] = [res] -> Get [res]
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [res]
acc
        goDeserialize [res]
_ [left p]
_ [(:*:) right1 right2 p]
_ = ServiceName -> Get [res]
forall a. ServiceName -> Get a
forall (m :: * -> *) a. MonadFail m => ServiceName -> m a
fail ServiceName
"Mismatched lengths in gDeserializeRecords"
    [res] -> [left p] -> [(:*:) right1 right2 p] -> Get [res]
goDeserialize [] [left p]
lefts [(:*:) right1 right2 p]
rights

  {-# INLINE gSerializeRecords #-}
  gSerializeRecords :: forall res p.
ProtocolRevision
-> (res -> (:*:) (left :*: right1) right2 p) -> [res] -> Builder
gSerializeRecords ProtocolRevision
rev res -> (:*:) (left :*: right1) right2 p
f [res]
xs
    =  forall (columns :: [*]) (f :: * -> *) res p.
GClickHaskell columns f =>
ProtocolRevision -> (res -> f p) -> [res] -> Builder
gSerializeRecords @columns @left                ProtocolRevision
rev ((\((left p
l:*:right1 p
_) :*: right2 p
_) -> left p
l) ((:*:) (left :*: right1) right2 p -> left p)
-> (res -> (:*:) (left :*: right1) right2 p) -> res -> left p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. res -> (:*:) (left :*: right1) right2 p
f) [res]
xs
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> forall (columns :: [*]) (f :: * -> *) res p.
GClickHaskell columns f =>
ProtocolRevision -> (res -> f p) -> [res] -> Builder
gSerializeRecords @columns @(right1 :*: right2) ProtocolRevision
rev ((\((left p
_ :*: right1 p
r1) :*:right2 p
r2) -> right1 p
r1 right1 p -> right2 p -> (:*:) right1 right2 p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: right2 p
r2) ((:*:) (left :*: right1) right2 p -> (:*:) right1 right2 p)
-> (res -> (:*:) (left :*: right1) right2 p)
-> res
-> (:*:) right1 right2 p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. res -> (:*:) (left :*: right1) right2 p
f) [res]
xs

  gReadingColumns :: [(Builder, Builder)]
gReadingColumns = forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
[(Builder, Builder)]
gReadingColumns @columns @left [(Builder, Builder)]
-> [(Builder, Builder)] -> [(Builder, Builder)]
forall a. [a] -> [a] -> [a]
++ forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
[(Builder, Builder)]
gReadingColumns @columns @(right1 :*: right2)
  gColumnsCount :: UVarInt
gColumnsCount = forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
UVarInt
gColumnsCount @columns @left UVarInt -> UVarInt -> UVarInt
forall a. Num a => a -> a -> a
+ forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
UVarInt
gColumnsCount @columns @(right1 :*: right2)

{-
  Unwrapping a product starting with a field

  field_n::Tn :*: (..)
-}
instance
  ( GClickHaskell columns right
  , KnownColumn (Column name chType)
  , SerializableColumn (Column name chType)
  , ToChType chType inputType
  , Column name chType ~ TakeColumn name columns
  )
  =>
  GClickHaskell columns ((S1 (MetaSel (Just name) a b f)) (Rec0 inputType) :*: right)
  where
  {-# INLINE gDeserializeRecords #-}
  gDeserializeRecords :: forall p res.
Bool
-> ProtocolRevision
-> UVarInt
-> ((:*:)
      (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType)) right p
    -> res)
-> Get [res]
gDeserializeRecords Bool
isCheckRequired ProtocolRevision
rev UVarInt
size (:*:) (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType)) right p
-> res
f = do
    [S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p]
lefts  <- forall (columns :: [*]) (f :: * -> *) p res.
GClickHaskell columns f =>
Bool -> ProtocolRevision -> UVarInt -> (f p -> res) -> Get [res]
gDeserializeRecords @columns @(S1 (MetaSel (Just name) a b f) (Rec0 inputType)) Bool
isCheckRequired ProtocolRevision
rev UVarInt
size S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
-> S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
forall a. a -> a
id
    [right p]
rights <- forall (columns :: [*]) (f :: * -> *) p res.
GClickHaskell columns f =>
Bool -> ProtocolRevision -> UVarInt -> (f p -> res) -> Get [res]
gDeserializeRecords @columns @right Bool
isCheckRequired ProtocolRevision
rev UVarInt
size right p -> right p
forall a. a -> a
id
    let goDeserialize :: [res]
-> [S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p]
-> [right p]
-> Get [res]
goDeserialize ![res]
acc (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
l:[S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p]
ls) (right p
r:[right p]
rs) = [res]
-> [S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p]
-> [right p]
-> Get [res]
goDeserialize ((res -> [res] -> [res]
forall a. a -> [a] -> [a]
:[res]
acc) (res -> [res]) -> res -> [res]
forall a b. (a -> b) -> a -> b
$! (:*:) (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType)) right p
-> res
f (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
l S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
-> right p
-> (:*:)
     (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType)) right p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: right p
r)) [S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p]
ls [right p]
rs
        goDeserialize ![res]
acc [] [] = [res] -> Get [res]
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [res]
acc
        goDeserialize [res]
_ [S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p]
_ [right p]
_ = ServiceName -> Get [res]
forall a. ServiceName -> Get a
forall (m :: * -> *) a. MonadFail m => ServiceName -> m a
fail ServiceName
"Mismatched lengths in gDeserializeRecords"
    [res]
-> [S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p]
-> [right p]
-> Get [res]
goDeserialize [] [S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p]
lefts [right p]
rights

  {-# INLINE gSerializeRecords #-}
  gSerializeRecords :: forall res p.
ProtocolRevision
-> (res
    -> (:*:)
         (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType)) right p)
-> [res]
-> Builder
gSerializeRecords ProtocolRevision
rev res
-> (:*:)
     (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType)) right p
f [res]
xs
    =  forall (columns :: [*]) (f :: * -> *) res p.
GClickHaskell columns f =>
ProtocolRevision -> (res -> f p) -> [res] -> Builder
gSerializeRecords @columns ProtocolRevision
rev ((\(S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
l:*:right p
_) -> S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
l) ((:*:) (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType)) right p
 -> S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p)
-> (res
    -> (:*:)
         (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType)) right p)
-> res
-> S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. res
-> (:*:)
     (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType)) right p
f) [res]
xs
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> forall (columns :: [*]) (f :: * -> *) res p.
GClickHaskell columns f =>
ProtocolRevision -> (res -> f p) -> [res] -> Builder
gSerializeRecords @columns ProtocolRevision
rev ((\(S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
_:*:right p
r) -> right p
r) ((:*:) (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType)) right p
 -> right p)
-> (res
    -> (:*:)
         (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType)) right p)
-> res
-> right p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. res
-> (:*:)
     (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType)) right p
f) [res]
xs

  gReadingColumns :: [(Builder, Builder)]
gReadingColumns = forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
[(Builder, Builder)]
gReadingColumns @columns @(S1 (MetaSel (Just name) a b f) (Rec0 inputType)) [(Builder, Builder)]
-> [(Builder, Builder)] -> [(Builder, Builder)]
forall a. [a] -> [a] -> [a]
++ forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
[(Builder, Builder)]
gReadingColumns @columns @right
  gColumnsCount :: UVarInt
gColumnsCount = forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
UVarInt
gColumnsCount @columns @(S1 (MetaSel (Just name) a b f) (Rec0 inputType)) UVarInt -> UVarInt -> UVarInt
forall a. Num a => a -> a -> a
+ forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
UVarInt
gColumnsCount @columns @right

{-
  Unwrapping a single generic field (recursion breaker)

  field::Tn
-}
instance
  ( KnownColumn (Column name chType)
  , SerializableColumn (Column name chType)
  , ToChType chType inputType
  , Column name chType ~ TakeColumn name columns
  ) => GClickHaskell columns ((S1 (MetaSel (Just name) a b f)) (Rec0 inputType))
  where
  {-# INLINE gDeserializeRecords #-}
  gDeserializeRecords :: forall p res.
Bool
-> ProtocolRevision
-> UVarInt
-> (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p -> res)
-> Get [res]
gDeserializeRecords Bool
isCheckRequired ProtocolRevision
rev UVarInt
size S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p -> res
f = do
    forall column.
KnownColumn column =>
Bool -> ProtocolRevision -> Get ()
handleColumnHeader @(Column name chType) Bool
isCheckRequired ProtocolRevision
rev
    forall column a.
SerializableColumn column =>
ProtocolRevision
-> UVarInt -> (GetColumnType column -> a) -> Get [a]
deserializeColumn @(Column name chType) ProtocolRevision
rev UVarInt
size (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p -> res
f (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p -> res)
-> (chType -> S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p)
-> chType
-> res
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rec0 inputType p
-> S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Rec0 inputType p
 -> S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p)
-> (chType -> Rec0 inputType p)
-> chType
-> S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. inputType -> Rec0 inputType p
forall k i c (p :: k). c -> K1 i c p
K1 (inputType -> Rec0 inputType p)
-> (chType -> inputType) -> chType -> Rec0 inputType p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. chType -> inputType
forall chType userType.
ToChType chType userType =>
chType -> userType
fromChType)

  {-# INLINE gSerializeRecords #-}
  gSerializeRecords :: forall res p.
ProtocolRevision
-> (res -> S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p)
-> [res]
-> Builder
gSerializeRecords ProtocolRevision
rev res -> S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
f [res]
values
    =  forall chType.
Serializable chType =>
ProtocolRevision -> chType -> Builder
serialize @ChString ProtocolRevision
rev (Builder -> ChString
forall chType userType.
ToChType chType userType =>
userType -> chType
toChType (forall column. KnownColumn column => Builder
renderColumnName @(Column name chType)))
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> forall chType.
Serializable chType =>
ProtocolRevision -> chType -> Builder
serialize @ChString ProtocolRevision
rev (Builder -> ChString
forall chType userType.
ToChType chType userType =>
userType -> chType
toChType (forall column. KnownColumn column => Builder
renderColumnType @(Column name chType)))
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> forall (rev :: Nat) monoid.
(KnownNat rev, Monoid monoid) =>
ProtocolRevision -> monoid -> monoid
afterRevision @DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION ProtocolRevision
rev (forall chType.
Serializable chType =>
ProtocolRevision -> chType -> Builder
serialize @UInt8 ProtocolRevision
rev UInt8
0)
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> forall column a.
SerializableColumn column =>
ProtocolRevision -> (a -> GetColumnType column) -> [a] -> Builder
serializeColumn @(Column name chType) ProtocolRevision
rev (inputType -> chType
forall chType userType.
ToChType chType userType =>
userType -> chType
toChType (inputType -> chType) -> (res -> inputType) -> res -> chType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 R inputType p -> inputType
forall k i c (p :: k). K1 i c p -> c
unK1 (K1 R inputType p -> inputType)
-> (res -> K1 R inputType p) -> res -> inputType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
-> K1 R inputType p
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
 -> K1 R inputType p)
-> (res -> S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p)
-> res
-> K1 R inputType p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. res -> S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
f) [res]
values

  gReadingColumns :: [(Builder, Builder)]
gReadingColumns = (forall column. KnownColumn column => Builder
renderColumnName @(Column name chType), forall column. KnownColumn column => Builder
renderColumnType @(Column name chType)) (Builder, Builder) -> [(Builder, Builder)] -> [(Builder, Builder)]
forall a. a -> [a] -> [a]
: []
  gColumnsCount :: UVarInt
gColumnsCount = UVarInt
1

handleColumnHeader :: forall column . KnownColumn column => Bool -> ProtocolRevision -> Get ()
handleColumnHeader :: forall column.
KnownColumn column =>
Bool -> ProtocolRevision -> Get ()
handleColumnHeader Bool
isCheckRequired ProtocolRevision
rev = do
  let expectedColumnName :: ChString
expectedColumnName = Builder -> ChString
forall chType userType.
ToChType chType userType =>
userType -> chType
toChType (forall column. KnownColumn column => Builder
renderColumnName @column)
  ChString
resultColumnName <- forall chType.
Serializable chType =>
ProtocolRevision -> Get chType
deserialize @ChString ProtocolRevision
rev
  Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isCheckRequired Bool -> Bool -> Bool
&& ChString
resultColumnName ChString -> ChString -> Bool
forall a. Eq a => a -> a -> Bool
/= ChString
expectedColumnName) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
    ClientError -> Get ()
forall a e. Exception e => e -> a
throw (ClientError -> Get ())
-> (ServiceName -> ClientError) -> ServiceName -> Get ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => UserError -> ClientError
UserError -> ClientError
UnmatchedResult (UserError -> ClientError)
-> (ServiceName -> UserError) -> ServiceName -> ClientError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceName -> UserError
UnmatchedColumn
      (ServiceName -> Get ()) -> ServiceName -> Get ()
forall a b. (a -> b) -> a -> b
$ ServiceName
"Got column \"" ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> ChString -> ServiceName
forall a. Show a => a -> ServiceName
show ChString
resultColumnName ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> ServiceName
"\" but expected \"" ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> ChString -> ServiceName
forall a. Show a => a -> ServiceName
show ChString
expectedColumnName ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> ServiceName
"\""

  let expectedType :: ChString
expectedType = Builder -> ChString
forall chType userType.
ToChType chType userType =>
userType -> chType
toChType (forall column. KnownColumn column => Builder
renderColumnType @column)
  ChString
resultType <- forall chType.
Serializable chType =>
ProtocolRevision -> Get chType
deserialize @ChString ProtocolRevision
rev
  Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isCheckRequired Bool -> Bool -> Bool
&& ChString
resultType ChString -> ChString -> Bool
forall a. Eq a => a -> a -> Bool
/= ChString
expectedType) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
    ClientError -> Get ()
forall a e. Exception e => e -> a
throw (ClientError -> Get ())
-> (ServiceName -> ClientError) -> ServiceName -> Get ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => UserError -> ClientError
UserError -> ClientError
UnmatchedResult (UserError -> ClientError)
-> (ServiceName -> UserError) -> ServiceName -> ClientError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceName -> UserError
UnmatchedType
      (ServiceName -> Get ()) -> ServiceName -> Get ()
forall a b. (a -> b) -> a -> b
$ ServiceName
"Column " ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> ChString -> ServiceName
forall a. Show a => a -> ServiceName
show ChString
resultColumnName ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> ServiceName
" has type " ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> ChString -> ServiceName
forall a. Show a => a -> ServiceName
show ChString
resultType ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> ServiceName
". But expected type is " ServiceName -> ShowS
forall a. Semigroup a => a -> a -> a
<> ChString -> ServiceName
forall a. Show a => a -> ServiceName
show ChString
expectedType

  SinceRevision UInt8 DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION
_isCustom <- forall chType.
Serializable chType =>
ProtocolRevision -> Get chType
deserialize @(UInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION) ProtocolRevision
rev
  () -> Get ()
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

type family
  TakeColumn name columns :: Type
  where
  TakeColumn name columns = GoTakeColumn name columns '[]

type family
  GoTakeColumn name (columns :: [Type]) (acc :: [Type]) :: Type
  where
  GoTakeColumn name (Column name chType ': columns) acc = Column name chType
  GoTakeColumn name (Column name1 chType ': columns) acc = (GoTakeColumn name columns (Column name1 chType ': acc))
  GoTakeColumn name '[]                 acc = TypeError
    (    'Text "There is no column \"" :<>: 'Text name :<>: 'Text "\" in table"
    :$$: 'Text "You can't use this field"
    )