{- |
  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
  , Connection(..), openConnection
  {- ** Hacking  -}
  , overrideNetwork, overrideHostname, overrideOsUser
  , mkBuffer

  {- * Statements and commands -}

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

  {- ** SELECT -}
  {- *** Runner -}, select
  {- *** Statements -}
  , Select, unsafeMkSelect
  , fromGenerateRandom
  , fromTable
  {- *** View -}
  , fromView
  , parameter, Parameter, Parameters, viewParameters
  {- ** INSERT -}
  , Insert, unsafeMkInsert
  , insert
  , intoTable
  {- *** Modifiers -}
  , ToQueryPart(toQueryPart)
  
  {- ** Ping -}, ping
  {- ** Commands -}, command

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


  {- * 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, 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 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)

-- External
import Data.WideWord (Int128 (..), Word128 (..))

-- * Connection

openConnection :: HasCallStack => ConnectionArgs -> IO Connection
openConnection :: HasCallStack => ConnectionArgs -> IO Connection
openConnection creds :: ConnectionArgs
creds@MkConnectionArgs{Maybe String
mHostname :: Maybe String
mHostname :: ConnectionArgs -> Maybe String
mHostname, Maybe String
mOsUser :: Maybe String
mOsUser :: ConnectionArgs -> Maybe String
mOsUser} = do
  Maybe String
hostname <- IO (Maybe String)
-> (String -> IO (Maybe String))
-> Maybe String
-> IO (Maybe String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO (Maybe String)
lookupEnv String
"HOSTNAME") (Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO (Maybe String))
-> (String -> Maybe String) -> String -> IO (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just) Maybe String
mHostname
  Maybe String
osUser   <- IO (Maybe String)
-> (String -> IO (Maybe String))
-> Maybe String
-> IO (Maybe String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO (Maybe String)
lookupEnv String
"USER")     (Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO (Maybe String))
-> (String -> Maybe String) -> String -> IO (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just) Maybe String
mOsUser
  ConnectionState
connectionState <-
    (Buffer -> ConnectionArgs -> IO ConnectionState)
-> ConnectionArgs -> IO ConnectionState
createConnectionState Buffer -> ConnectionArgs -> IO ConnectionState
auth
      (ConnectionArgs -> IO ConnectionState)
-> (ConnectionArgs -> ConnectionArgs)
-> ConnectionArgs
-> IO ConnectionState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ConnectionArgs -> ConnectionArgs)
-> (String -> ConnectionArgs -> ConnectionArgs)
-> Maybe String
-> ConnectionArgs
-> ConnectionArgs
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ConnectionArgs -> ConnectionArgs
forall a. a -> a
id String -> ConnectionArgs -> ConnectionArgs
overrideHostname Maybe String
hostname)
      (ConnectionArgs -> ConnectionArgs)
-> (ConnectionArgs -> ConnectionArgs)
-> ConnectionArgs
-> ConnectionArgs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ConnectionArgs -> ConnectionArgs)
-> (String -> ConnectionArgs -> ConnectionArgs)
-> Maybe String
-> ConnectionArgs
-> ConnectionArgs
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ConnectionArgs -> ConnectionArgs
forall a. a -> a
id String -> ConnectionArgs -> ConnectionArgs
overrideOsUser Maybe String
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

  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 -> String)
-> Exception ClientError
SomeException -> Maybe ClientError
ClientError -> String
ClientError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: ClientError -> SomeException
toException :: ClientError -> SomeException
$cfromException :: SomeException -> Maybe ClientError
fromException :: SomeException -> Maybe ClientError
$cdisplayException :: ClientError -> String
displayException :: ClientError -> String
Exception)

instance Show ClientError where
  show :: ClientError -> String
show (UnmatchedResult UserError
err) = String
"UserError " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UserError -> String
forall a. Show a => a -> String
show UserError
err String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack
  show (DatabaseException ExceptionPacket
err) = String
"DatabaseException " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ExceptionPacket -> String
forall a. Show a => a -> String
show ExceptionPacket
err String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack
  show (InternalError InternalError
err) = String
"InternalError " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> InternalError -> String
forall a. Show a => a -> String
show InternalError
err String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> CallStack -> String
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 -> String
(Int -> UserError -> ShowS)
-> (UserError -> String)
-> ([UserError] -> ShowS)
-> Show UserError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserError -> ShowS
showsPrec :: Int -> UserError -> ShowS
$cshow :: UserError -> String
show :: UserError -> String
$cshowList :: [UserError] -> ShowS
showList :: [UserError] -> ShowS
Show, Show UserError
Typeable UserError
(Typeable UserError, Show UserError) =>
(UserError -> SomeException)
-> (SomeException -> Maybe UserError)
-> (UserError -> String)
-> Exception UserError
SomeException -> Maybe UserError
UserError -> String
UserError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: UserError -> SomeException
toException :: UserError -> SomeException
$cfromException :: SomeException -> Maybe UserError
fromException :: SomeException -> Maybe UserError
$cdisplayException :: UserError -> String
displayException :: UserError -> String
Exception)


-- ** Low level

-- *** SELECT

{- |
  Takes `Select`, `Connection` and __block processing__ function

  Returns __block processing__ result
-}
select ::
  forall columns output result
  .
  ClickHaskell columns output
  =>
  Select columns output -> Connection -> ([output] -> IO result) -> IO [result]
select :: forall (columns :: [*]) output result.
ClickHaskell columns output =>
Select columns output
-> Connection -> ([output] -> IO result) -> IO [result]
select (MkSelect [(Builder, Builder)] -> ChString
mkQuery) Connection
conn [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
      ((ProtocolRevision -> Builder) -> IO ())
-> ([(Builder, Builder)] -> ProtocolRevision -> Builder)
-> [(Builder, Builder)]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryPacketArgs -> ProtocolRevision -> Builder
serializeQueryPacket
      (QueryPacketArgs -> ProtocolRevision -> Builder)
-> ([(Builder, Builder)] -> QueryPacketArgs)
-> [(Builder, Builder)]
-> ProtocolRevision
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionState -> ChString -> QueryPacketArgs
mkQueryArgs ConnectionState
connState
      (ChString -> QueryPacketArgs)
-> ([(Builder, Builder)] -> ChString)
-> [(Builder, Builder)]
-> QueryPacketArgs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Builder, Builder)] -> ChString
mkQuery
      ([(Builder, Builder)] -> IO ()) -> [(Builder, Builder)] -> IO ()
forall a b. (a -> b) -> a -> b
$ forall (columns :: [*]) record.
ClickHaskell columns record =>
[(Builder, Builder)]
expectedColumns @columns @output
    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
ChString
ConnectionArgs
Buffer
buffer :: Buffer
revision :: ProtocolRevision
initial_user :: ChString
os_user :: ChString
hostname :: ChString
creds :: ConnectionArgs
creds :: ConnectionState -> ConnectionArgs
hostname :: ConnectionState -> ChString
os_user :: ConnectionState -> ChString
initial_user :: ConnectionState -> ChString
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 ())
-> (String -> ClientError) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => UserError -> ClientError
UserError -> ClientError
UnmatchedResult (UserError -> ClientError)
-> (String -> UserError) -> String -> ClientError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UserError
UnmatchedColumnsCount)
            (String
"Expected " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UVarInt -> String
forall a. Show a => a -> String
show UVarInt
expected String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" columns but got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UVarInt -> String
forall a. Show a => a -> String
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]
deserializeColumns @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
  =>
  Insert columns record -> Connection -> [record] -> IO ()
insert :: forall (columns :: [*]) record.
ClickHaskell columns record =>
Insert columns record -> Connection -> [record] -> IO ()
insert (MkInsert [(Builder, Builder)] -> ChString
mkQuery) Connection
conn [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
      ((ProtocolRevision -> Builder) -> IO ())
-> ([(Builder, Builder)] -> ProtocolRevision -> Builder)
-> [(Builder, Builder)]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryPacketArgs -> ProtocolRevision -> Builder
serializeQueryPacket
      (QueryPacketArgs -> ProtocolRevision -> Builder)
-> ([(Builder, Builder)] -> QueryPacketArgs)
-> [(Builder, Builder)]
-> ProtocolRevision
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionState -> ChString -> QueryPacketArgs
mkQueryArgs ConnectionState
connState
      (ChString -> QueryPacketArgs)
-> ([(Builder, Builder)] -> ChString)
-> [(Builder, Builder)]
-> QueryPacketArgs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Builder, Builder)] -> ChString
mkQuery
      ([(Builder, Builder)] -> IO ()) -> [(Builder, Builder)] -> IO ()
forall a b. (a -> b) -> a -> b
$ forall (columns :: [*]) record.
ClickHaskell columns record =>
[(Builder, Builder)]
expectedColumns @columns @record
    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
ChString
ConnectionArgs
Buffer
creds :: ConnectionState -> ConnectionArgs
hostname :: ConnectionState -> ChString
os_user :: ConnectionState -> ChString
initial_user :: ConnectionState -> ChString
revision :: ConnectionState -> ProtocolRevision
buffer :: ConnectionState -> Buffer
buffer :: Buffer
revision :: ProtocolRevision
initial_user :: ChString
os_user :: ChString
hostname :: ChString
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]
deserializeColumns @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
serializeColumns @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
ChString
ConnectionArgs
Buffer
creds :: ConnectionState -> ConnectionArgs
hostname :: ConnectionState -> ChString
os_user :: ConnectionState -> ChString
initial_user :: ConnectionState -> ChString
revision :: ConnectionState -> ProtocolRevision
buffer :: ConnectionState -> Buffer
buffer :: Buffer
revision :: ProtocolRevision
initial_user :: ChString
os_user :: ChString
hostname :: ChString
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 deserializeColumns :: GenericClickHaskell record columns => Bool -> ProtocolRevision -> UVarInt -> Get [record]
  deserializeColumns :: Bool -> ProtocolRevision -> UVarInt -> Get [record]
  deserializeColumns Bool
doCheck ProtocolRevision
rev UVarInt
size = forall (columns :: [*]) (f :: * -> *) p res.
GClickHaskell columns f =>
Bool -> ProtocolRevision -> UVarInt -> (f p -> res) -> Get [res]
gDeserializeColumns @columns Bool
doCheck 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 serializeColumns :: GenericClickHaskell record columns => [record] -> ProtocolRevision -> Builder
  serializeColumns :: [record] -> ProtocolRevision -> Builder
  serializeColumns [record]
records ProtocolRevision
rev = forall (columns :: [*]) (f :: * -> *) res p.
GClickHaskell columns f =>
ProtocolRevision -> [res] -> (res -> f p) -> Builder
gSerializeRecords @columns ProtocolRevision
rev [record]
records record -> Rep record Any
forall x. record -> Rep record x
forall a x. Generic a => a -> Rep a x
from

  default expectedColumns :: GenericClickHaskell record columns => [(Builder, Builder)]
  expectedColumns :: [(Builder, Builder)]
  expectedColumns = forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
[(Builder, Builder)]
gExpectedColumns @columns @(Rep record)

  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)
  )




-- * Internal

mkQueryArgs :: ConnectionState -> ChString -> QueryPacketArgs
mkQueryArgs :: ConnectionState -> ChString -> QueryPacketArgs
mkQueryArgs MkConnectionState {ProtocolRevision
ChString
ConnectionArgs
Buffer
creds :: ConnectionState -> ConnectionArgs
hostname :: ConnectionState -> ChString
os_user :: ConnectionState -> ChString
initial_user :: ConnectionState -> ChString
revision :: ConnectionState -> ProtocolRevision
buffer :: ConnectionState -> Buffer
buffer :: Buffer
revision :: ProtocolRevision
initial_user :: ChString
os_user :: ChString
hostname :: ChString
creds :: ConnectionArgs
..} ChString
query = MkQueryPacketArgs {ChString
initial_user :: ChString
os_user :: ChString
hostname :: ChString
query :: ChString
query :: ChString
os_user :: ChString
hostname :: ChString
initial_user :: ChString
..}

-- ** Connection

readBuffer :: Buffer -> Get a -> IO a
readBuffer :: forall a. Buffer -> Get a -> IO a
readBuffer MkBuffer{IO ByteString
readBuff :: IO ByteString
readBuff :: Buffer -> IO ByteString
readBuff, ByteString -> IO ()
writeBuff :: ByteString -> IO ()
writeBuff :: Buffer -> ByteString -> IO ()
writeBuff} Get a
parser = Decoder a -> IO a
forall packet. Decoder packet -> IO packet
runBufferReader (Get a -> Decoder a
forall a. Get a -> Decoder a
runGetIncremental Get a
parser)
  where
  runBufferReader :: Decoder packet -> IO packet
  runBufferReader :: forall packet. Decoder packet -> IO packet
runBufferReader = \case
    (Partial Maybe ByteString -> Decoder packet
decoder) -> IO ByteString
readBuff IO ByteString -> (ByteString -> IO packet) -> IO packet
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Decoder packet -> IO packet
forall packet. Decoder packet -> IO packet
runBufferReader (Decoder packet -> IO packet)
-> (ByteString -> Decoder packet) -> ByteString -> IO packet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ByteString -> Decoder packet
decoder (Maybe ByteString -> Decoder packet)
-> (ByteString -> Maybe ByteString) -> ByteString -> Decoder packet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just
    (Done ByteString
leftover ByteOffset
_consumed packet
packet) -> packet
packet packet -> IO () -> IO packet
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> IO ()
writeBuff ByteString
leftover
    (Fail ByteString
_leftover ByteOffset
_consumed String
msg) -> ClientError -> IO packet
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
$ String -> InternalError
DeserializationError String
msg)


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))
      (do
        ConnectionState
newConnState <- (Buffer -> ConnectionArgs -> IO ConnectionState)
-> ConnectionState -> IO ConnectionState
recreateConnectionState Buffer -> ConnectionArgs -> IO ConnectionState
auth ConnectionState
connState
        MVar ConnectionState -> ConnectionState -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ConnectionState
connStateMVar ConnectionState
newConnState
      )
    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

auth :: Buffer -> ConnectionArgs -> IO ConnectionState
auth :: Buffer -> ConnectionArgs -> IO ConnectionState
auth Buffer
buffer creds :: ConnectionArgs
creds@MkConnectionArgs{String
db :: String
db :: ConnectionArgs -> String
db, String
user :: String
user :: ConnectionArgs -> String
user, String
pass :: String
pass :: ConnectionArgs -> String
pass, Maybe String
mOsUser :: ConnectionArgs -> Maybe String
mOsUser :: Maybe String
mOsUser, Maybe String
mHostname :: ConnectionArgs -> Maybe String
mHostname :: Maybe String
mHostname} = do
  (Buffer -> Builder -> IO ()
writeConn Buffer
buffer (Builder -> IO ())
-> (ProtocolRevision -> Builder) -> ProtocolRevision -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> ProtocolRevision -> Builder
seriliazeHelloPacket String
db String
user String
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 conn :: ConnectionState
conn =
            MkConnectionState
              { revision :: ProtocolRevision
revision     = ProtocolRevision -> ProtocolRevision -> ProtocolRevision
forall a. Ord a => a -> a -> a
min ProtocolRevision
server_revision ProtocolRevision
latestSupportedRevision
              , os_user :: ChString
os_user      = ChString -> (String -> ChString) -> Maybe String -> ChString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ChString
"" String -> ChString
forall chType userType.
ToChType chType userType =>
userType -> chType
toChType Maybe String
mOsUser
              , hostname :: ChString
hostname     = ChString -> (String -> ChString) -> Maybe String -> ChString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ChString
"" String -> ChString
forall chType userType.
ToChType chType userType =>
userType -> chType
toChType Maybe String
mHostname
              , initial_user :: ChString
initial_user = String -> ChString
forall chType userType.
ToChType chType userType =>
userType -> chType
toChType String
user
              , ConnectionArgs
Buffer
creds :: ConnectionArgs
buffer :: Buffer
buffer :: Buffer
creds :: ConnectionArgs
..
              }
      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
  -}
  gDeserializeColumns :: Bool -> ProtocolRevision -> UVarInt -> (f p -> res) -> Get [res]
  gSerializeRecords :: ProtocolRevision -> [res] -> (res -> f p) -> Builder
  {-
    and affected columns extractor
  -}
  gExpectedColumns :: [(Builder, Builder)]
  gColumnsCount :: UVarInt

{-
  Unwrapping data type constructor
    data Record = MkRecord ..
-}
instance
  GClickHaskell columns f
  =>
  GClickHaskell columns (D1 c (C1 c2 f))
  where
  {-# INLINE gDeserializeColumns #-}
  gDeserializeColumns :: forall p res.
Bool
-> ProtocolRevision
-> UVarInt
-> (D1 c (C1 c2 f) p -> res)
-> Get [res]
gDeserializeColumns Bool
doCheck 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]
gDeserializeColumns @columns Bool
doCheck 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] -> (res -> D1 c (C1 c2 f) p) -> Builder
gSerializeRecords ProtocolRevision
rev [res]
xs res -> D1 c (C1 c2 f) p
f = forall (columns :: [*]) (f :: * -> *) res p.
GClickHaskell columns f =>
ProtocolRevision -> [res] -> (res -> f p) -> Builder
gSerializeRecords @columns ProtocolRevision
rev [res]
xs (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)

  gExpectedColumns :: [(Builder, Builder)]
gExpectedColumns = forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
[(Builder, Builder)]
gExpectedColumns @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 :*: (right1 :*: right2))
  =>
  GClickHaskell columns ((left :*: right1) :*: right2)
  where
  {-# INLINE gDeserializeColumns #-}
  gDeserializeColumns :: forall p res.
Bool
-> ProtocolRevision
-> UVarInt
-> ((:*:) (left :*: right1) right2 p -> res)
-> Get [res]
gDeserializeColumns Bool
doCheck ProtocolRevision
rev UVarInt
size (:*:) (left :*: right1) right2 p -> res
f =
    forall (columns :: [*]) (f :: * -> *) p res.
GClickHaskell columns f =>
Bool -> ProtocolRevision -> UVarInt -> (f p -> res) -> Get [res]
gDeserializeColumns @columns @(left :*: (right1 :*: right2)) Bool
doCheck ProtocolRevision
rev UVarInt
size
      (\(left p
l :*: (right1 p
r1:*:right2 p
r2)) -> (:*:) (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))

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

  gExpectedColumns :: [(Builder, Builder)]
gExpectedColumns = forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
[(Builder, Builder)]
gExpectedColumns @columns @(left :*: (right1 :*: right2))
  gColumnsCount :: UVarInt
gColumnsCount = forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
UVarInt
gColumnsCount @columns @(left :*: (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 gDeserializeColumns #-}
  gDeserializeColumns :: forall p res.
Bool
-> ProtocolRevision
-> UVarInt
-> ((:*:)
      (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType)) right p
    -> res)
-> Get [res]
gDeserializeColumns Bool
doCheck 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]
gDeserializeColumns @columns @(S1 (MetaSel (Just name) a b f) (Rec0 inputType)) Bool
doCheck 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]
gDeserializeColumns @columns @right Bool
doCheck ProtocolRevision
rev UVarInt
size right p -> right p
forall a. a -> a
id
    (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
 -> right p -> res)
-> [S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p]
-> [right p]
-> Get [res]
forall l r a. (l -> r -> a) -> [l] -> [r] -> Get [a]
deserializeProduct (\S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
l right p
r -> (:*:) (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType)) right p
-> res
f ((:*:) (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType)) right p
 -> res)
-> (:*:)
     (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType)) right p
-> res
forall a b. (a -> b) -> a -> b
$ 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]
lefts [right p]
rights

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

  gExpectedColumns :: [(Builder, Builder)]
gExpectedColumns = forall (columns :: [*]) (f :: * -> *).
GClickHaskell columns f =>
[(Builder, Builder)]
gExpectedColumns @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)]
gExpectedColumns @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

deserializeProduct ::  (l -> r -> a) -> [l] -> [r] -> Get [a]
deserializeProduct :: forall l r a. (l -> r -> a) -> [l] -> [r] -> Get [a]
deserializeProduct l -> r -> a
f [l]
lefts [r]
rights = [a] -> [l] -> [r] -> Get [a]
goDeserialize [] [l]
lefts [r]
rights
  where
  goDeserialize :: [a] -> [l] -> [r] -> Get [a]
goDeserialize ![a]
acc (l
l:[l]
ls) (r
r:[r]
rs) = [a] -> [l] -> [r] -> Get [a]
goDeserialize ((a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc) (a -> [a]) -> a -> [a]
forall a b. (a -> b) -> a -> b
$! l -> r -> a
f l
l r
r) [l]
ls [r]
rs
  goDeserialize ![a]
acc [] [] = [a] -> Get [a]
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
acc
  goDeserialize [a]
_ [l]
_ [r]
_ = String -> Get [a]
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Mismatched lengths in gDeserializeColumns"

{-
  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 gDeserializeColumns #-}
  gDeserializeColumns :: forall p res.
Bool
-> ProtocolRevision
-> UVarInt
-> (S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p -> res)
-> Get [res]
gDeserializeColumns Bool
doCheck 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
doCheck 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]
-> (res -> S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p)
-> Builder
gSerializeRecords ProtocolRevision
rev [res]
values res -> S1 ('MetaSel ('Just name) a b f) (Rec0 inputType) p
f
    =  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

  gExpectedColumns :: [(Builder, Builder)]
gExpectedColumns = (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
doCheck 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
doCheck 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 ())
-> (String -> ClientError) -> String -> Get ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => UserError -> ClientError
UserError -> ClientError
UnmatchedResult (UserError -> ClientError)
-> (String -> UserError) -> String -> ClientError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UserError
UnmatchedColumn
      (String -> Get ()) -> String -> Get ()
forall a b. (a -> b) -> a -> b
$ String
"Got column \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ChString -> String
forall a. Show a => a -> String
show ChString
resultColumnName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\" but expected \"" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ChString -> String
forall a. Show a => a -> String
show ChString
expectedColumnName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\""

  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
doCheck 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 ())
-> (String -> ClientError) -> String -> Get ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => UserError -> ClientError
UserError -> ClientError
UnmatchedResult (UserError -> ClientError)
-> (String -> UserError) -> String -> ClientError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UserError
UnmatchedType
      (String -> Get ()) -> String -> Get ()
forall a b. (a -> b) -> a -> b
$ String
"Column " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ChString -> String
forall a. Show a => a -> String
show ChString
resultColumnName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" has type " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ChString -> String
forall a. Show a => a -> String
show ChString
resultType String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
". But expected type is " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ChString -> String
forall a. Show a => a -> String
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"
    )