{- |
  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  -}
  , overrideInitConnection, BufferArgs(..)
  , overrideHostname
  , overrideOsUser
  , overrideDefaultPort
  , overrideMaxRevision

  {- * Statements and commands -}

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

  {- ** Settings -}
  , passSettings
  , addSetting

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

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

-- 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 Data.Type.Equality
import Data.Type.Bool
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
  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
  osUser   <- maybe (lookupEnv "USER")     (pure . Just) mOsUser
  connectionState <-
    createConnectionState auth
      . (maybe id overrideHostname hostname)
      . (maybe id overrideOsUser osUser)
      $ creds
  MkConnection <$> newMVar 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)
-> (ClientError -> Bool)
-> Exception ClientError
SomeException -> Maybe ClientError
ClientError -> Bool
ClientError -> String
ClientError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: ClientError -> SomeException
toException :: ClientError -> SomeException
$cfromException :: SomeException -> Maybe ClientError
fromException :: SomeException -> Maybe ClientError
$cdisplayException :: ClientError -> String
displayException :: ClientError -> String
$cbacktraceDesired :: ClientError -> Bool
backtraceDesired :: ClientError -> Bool
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)
-> (UserError -> Bool)
-> Exception UserError
SomeException -> Maybe UserError
UserError -> Bool
UserError -> String
UserError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: UserError -> SomeException
toException :: UserError -> SomeException
$cfromException :: SomeException -> Maybe UserError
fromException :: SomeException -> Maybe UserError
$cdisplayException :: UserError -> String
displayException :: UserError -> String
$cbacktraceDesired :: UserError -> Bool
backtraceDesired :: UserError -> Bool
Exception)


-- ** Low level

-- *** SELECT

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

  Returns __block processing__ result
-}
select ::
  forall columns output result
  .
  HasCallStack
  =>
  ClickHaskell columns output
  =>
  Select columns output -> Connection -> ([output] -> IO result) -> IO [result]
select :: forall (columns :: [*]) output result.
(HasCallStack, ClickHaskell columns output) =>
Select columns output
-> Connection -> ([output] -> IO result) -> IO [result]
select (MkSelect [(Builder, Builder)] -> ChString
mkQuery DbSettings
setts) 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
. (ProtocolRevision -> ClientPacket -> Builder)
-> ClientPacket -> ProtocolRevision -> Builder
forall a b c. (a -> b -> c) -> b -> a -> c
flip ProtocolRevision -> ClientPacket -> Builder
forall chType.
Serializable chType =>
ProtocolRevision -> chType -> Builder
serialize  
      (ClientPacket -> ProtocolRevision -> Builder)
-> ([(Builder, Builder)] -> ClientPacket)
-> [(Builder, Builder)]
-> ProtocolRevision
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryPacketArgs -> ClientPacket
mkQueryPacket
      (QueryPacketArgs -> ClientPacket)
-> ([(Builder, Builder)] -> QueryPacketArgs)
-> [(Builder, Builder)]
-> ClientPacket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionState -> DbSettings -> ChString -> QueryPacketArgs
mkQueryArgs ConnectionState
connState DbSettings
setts
      (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 (\ProtocolRevision
rev -> ProtocolRevision -> ClientPacket -> Builder
forall chType.
Serializable chType =>
ProtocolRevision -> chType -> Builder
serialize ProtocolRevision
rev (ClientPacket -> Builder)
-> (DataPacket -> ClientPacket) -> DataPacket -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataPacket -> ClientPacket
Data (DataPacket -> Builder) -> DataPacket -> Builder
forall a b. (a -> b) -> a -> b
$ ChString -> UVarInt -> UVarInt -> DataPacket
mkDataPacket 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. (HasCallStack, 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 <- [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)
        loopSelect connState (result : acc)
      ProfileEvents ProfileEventsPacket
_     -> ConnectionState -> [result] -> IO [result]
loopSelect ConnectionState
connState [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. (HasCallStack, Exception e) => e -> IO a
throwIO (HasCallStack => ExceptionPacket -> ClientError
ExceptionPacket -> ClientError
DatabaseException ExceptionPacket
exception)
      ServerPacket
otherPacket         -> ClientError -> IO [result]
forall e a. (HasCallStack, 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
  .
  HasCallStack
  =>
  ClickHaskell columns record
  =>
  Insert columns record -> Connection -> [record] -> IO ()
insert :: forall (columns :: [*]) record.
(HasCallStack, ClickHaskell columns record) =>
Insert columns record -> Connection -> [record] -> IO ()
insert (MkInsert [(Builder, Builder)] -> ChString
mkQuery DbSettings
dbSettings) 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
. (ProtocolRevision -> ClientPacket -> Builder)
-> ClientPacket -> ProtocolRevision -> Builder
forall a b c. (a -> b -> c) -> b -> a -> c
flip ProtocolRevision -> ClientPacket -> Builder
forall chType.
Serializable chType =>
ProtocolRevision -> chType -> Builder
serialize  
      (ClientPacket -> ProtocolRevision -> Builder)
-> ([(Builder, Builder)] -> ClientPacket)
-> [(Builder, Builder)]
-> ProtocolRevision
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryPacketArgs -> ClientPacket
mkQueryPacket
      (QueryPacketArgs -> ClientPacket)
-> ([(Builder, Builder)] -> QueryPacketArgs)
-> [(Builder, Builder)]
-> ClientPacket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnectionState -> DbSettings -> ChString -> QueryPacketArgs
mkQueryArgs ConnectionState
connState DbSettings
dbSettings
      (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 (\ProtocolRevision
rev -> ProtocolRevision -> ClientPacket -> Builder
forall chType.
Serializable chType =>
ProtocolRevision -> chType -> Builder
serialize ProtocolRevision
rev (ClientPacket -> Builder)
-> (DataPacket -> ClientPacket) -> DataPacket -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataPacket -> ClientPacket
Data (DataPacket -> Builder) -> DataPacket -> Builder
forall a b. (a -> b) -> a -> b
$ ChString -> UVarInt -> UVarInt -> DataPacket
mkDataPacket 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
    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 firstPacket of
      TableColumns      TableColumns
_ -> ConnectionState -> IO ()
loopInsert ConnectionState
connState 
      DataResponse MkDataPacket{} -> do
        _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 = 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 = forall (columns :: [*]) record.
ClickHaskell columns record =>
UVarInt
columnsCount @columns @record
        writeToConnection connState (\ProtocolRevision
rev -> ProtocolRevision -> ClientPacket -> Builder
forall chType.
Serializable chType =>
ProtocolRevision -> chType -> Builder
serialize ProtocolRevision
rev (ClientPacket -> Builder)
-> (DataPacket -> ClientPacket) -> DataPacket -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataPacket -> ClientPacket
Data (DataPacket -> Builder) -> DataPacket -> Builder
forall a b. (a -> b) -> a -> b
$ ChString -> UVarInt -> UVarInt -> DataPacket
mkDataPacket ChString
"" UVarInt
cols UVarInt
rows)
        writeToConnection connState (serializeColumns @columns columnsData)
        writeToConnection connState (\ProtocolRevision
rev -> ProtocolRevision -> ClientPacket -> Builder
forall chType.
Serializable chType =>
ProtocolRevision -> chType -> Builder
serialize ProtocolRevision
rev (ClientPacket -> Builder)
-> (DataPacket -> ClientPacket) -> DataPacket -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataPacket -> ClientPacket
Data (DataPacket -> Builder) -> DataPacket -> Builder
forall a b. (a -> b) -> a -> b
$ ChString -> UVarInt -> UVarInt -> DataPacket
mkDataPacket ChString
"" UVarInt
0 UVarInt
0)
        loopInsert 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. (HasCallStack, Exception e) => e -> IO a
throwIO (HasCallStack => ExceptionPacket -> ClientError
ExceptionPacket -> ClientError
DatabaseException ExceptionPacket
exception)
      ServerPacket
otherPacket         -> ClientError -> IO ()
forall e a. (HasCallStack, 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)
    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 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. (HasCallStack, Exception e) => e -> IO a
throwIO (HasCallStack => ExceptionPacket -> ClientError
ExceptionPacket -> ClientError
DatabaseException ExceptionPacket
exception)
      ServerPacket
otherPacket         -> ClientError -> IO ()
forall e a. (HasCallStack, 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 -> Command -> IO ()
command :: HasCallStack => Connection -> Command -> IO ()
command Connection
conn (MkCommand ChString
query DbSettings
settings) = 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 ())
-> (QueryPacketArgs -> ProtocolRevision -> Builder)
-> QueryPacketArgs
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProtocolRevision -> ClientPacket -> Builder)
-> ClientPacket -> ProtocolRevision -> Builder
forall a b c. (a -> b -> c) -> b -> a -> c
flip ProtocolRevision -> ClientPacket -> Builder
forall chType.
Serializable chType =>
ProtocolRevision -> chType -> Builder
serialize
      (ClientPacket -> ProtocolRevision -> Builder)
-> (QueryPacketArgs -> ClientPacket)
-> QueryPacketArgs
-> ProtocolRevision
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryPacketArgs -> ClientPacket
mkQueryPacket
      (QueryPacketArgs -> IO ()) -> QueryPacketArgs -> IO ()
forall a b. (a -> b) -> a -> b
$ ConnectionState -> DbSettings -> ChString -> QueryPacketArgs
mkQueryArgs ConnectionState
connState DbSettings
settings ChString
query
    ConnectionState -> (ProtocolRevision -> Builder) -> IO ()
writeToConnection ConnectionState
connState (\ProtocolRevision
rev -> ProtocolRevision -> ClientPacket -> Builder
forall chType.
Serializable chType =>
ProtocolRevision -> chType -> Builder
serialize ProtocolRevision
rev (ClientPacket -> Builder)
-> (DataPacket -> ClientPacket) -> DataPacket -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataPacket -> ClientPacket
Data (DataPacket -> Builder) -> DataPacket -> Builder
forall a b. (a -> b) -> a -> b
$ ChString -> UVarInt -> UVarInt -> DataPacket
mkDataPacket 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. (HasCallStack, Exception e) => e -> IO a
throwIO (HasCallStack => ExceptionPacket -> ClientError
ExceptionPacket -> ClientError
DatabaseException ExceptionPacket
exception)
      ServerPacket
otherPacket         -> ClientError -> IO ()
forall e a. (HasCallStack, 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 GenericClickHaskell record columns =>  ClickHaskell columns record
  where
  default deserializeColumns :: 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 (ZonkAny 0) -> record
forall a x. Generic a => Rep a x -> a
forall x. Rep record x -> record
to

  default serializeColumns :: [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 (ZonkAny 1)
forall x. record -> Rep record x
forall a x. Generic a => a -> Rep a x
from

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

  default columnsCount :: 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 -> DbSettings -> ChString -> QueryPacketArgs
mkQueryArgs :: ConnectionState -> DbSettings -> 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
..} DbSettings
settings ChString
query = MkQueryPacketArgs {ProtocolRevision
ChString
DbSettings
revision :: ProtocolRevision
initial_user :: ChString
os_user :: ChString
hostname :: ChString
settings :: DbSettings
query :: ChString
revision :: ProtocolRevision
settings :: DbSettings
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 Decoder packet
dec = case Decoder packet
dec of
    (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. (HasCallStack, 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
    connState <- MVar ConnectionState -> IO ConnectionState
forall a. MVar a -> IO a
takeMVar MVar ConnectionState
connStateMVar
    b <- onException
      (restore (f connState))
      (do
        newConnState <- recreateConnectionState auth connState
        putMVar connStateMVar newConnState
      )
    putMVar connStateMVar connState
    return 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, ProtocolRevision
maxRevision :: ProtocolRevision
maxRevision :: ConnectionArgs -> ProtocolRevision
maxRevision} = do
  Buffer -> Builder -> IO ()
writeConn Buffer
buffer
    (Builder -> IO ())
-> (ClientPacket -> Builder) -> ClientPacket -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolRevision -> ClientPacket -> Builder
forall chType.
Serializable chType =>
ProtocolRevision -> chType -> Builder
serialize ProtocolRevision
maxRevision
    (ClientPacket -> IO ()) -> ClientPacket -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> ProtocolRevision -> ClientPacket
mkHelloPacket String
db String
user String
pass ProtocolRevision
maxRevision
  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
maxRevision)
  case 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
maxRevision
              , 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 Addendum
mkAddendum)
      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. (HasCallStack, Exception e) => e -> IO a
throwIO (HasCallStack => ExceptionPacket -> ClientError
ExceptionPacket -> ClientError
DatabaseException ExceptionPacket
exception)
    ServerPacket
otherPacket         -> ClientError -> IO ConnectionState
forall e a. (HasCallStack, 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
  , GClickHaskell columns (S1 (MetaSel (Just name) a b f) (Rec0 inputType))
  )
  =>
  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
    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
    rights <- gDeserializeColumns @columns @right doCheck rev size id
    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) lefts 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
  , mColumn ~ TakeColumn name columns
  , If
      (mColumn == Nothing)
      (TypeError
        (    'Text "There is no column \"" :<>: 'Text name :<>: 'Text "\" in table"
        :$$: 'Text "You can't use this field"
        )
      )
      (Just (Column name chType) ~ mColumn)
  ) => 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 -> ColumnHeader -> Get ()
validateColumnHeader @(Column name chType) Bool
doCheck ProtocolRevision
rev (ColumnHeader -> Get ()) -> Get ColumnHeader -> Get ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall chType.
Serializable chType =>
ProtocolRevision -> Get chType
deserialize @ColumnHeader 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
    =  ProtocolRevision -> ColumnHeader -> Builder
forall chType.
Serializable chType =>
ProtocolRevision -> chType -> Builder
serialize ProtocolRevision
rev (forall column. KnownColumn column => ColumnHeader
mkHeader @(Column name chType))
    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

validateColumnHeader :: forall column . KnownColumn column => Bool -> ProtocolRevision -> ColumnHeader -> Get ()
validateColumnHeader :: forall column.
KnownColumn column =>
Bool -> ProtocolRevision -> ColumnHeader -> Get ()
validateColumnHeader Bool
doCheck ProtocolRevision
rev MkColumnHeader{SinceRevision UInt8 DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION
ChString
name :: ChString
type_ :: ChString
is_custom :: SinceRevision UInt8 DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION
is_custom :: ColumnHeader
-> SinceRevision UInt8 DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION
type_ :: ColumnHeader -> ChString
name :: ColumnHeader -> ChString
..} = do
  let expectedColumnName :: ChString
expectedColumnName = Builder -> ChString
forall chType userType.
ToChType chType userType =>
userType -> chType
toChType (forall column. KnownColumn column => Builder
renderColumnName @column)
      resultColumnName :: ChString
resultColumnName = ChString
name
  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. (HasCallStack, 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 = ProtocolRevision -> ChString -> ChString
fallbackTypeName ProtocolRevision
rev (ChString -> ChString) -> ChString -> ChString
forall a b. (a -> b) -> a -> b
$ Builder -> ChString
forall chType userType.
ToChType chType userType =>
userType -> chType
toChType (forall column. KnownColumn column => Builder
renderColumnType @column)
      resultType :: ChString
resultType = ProtocolRevision -> ChString -> ChString
fallbackTypeName ProtocolRevision
rev ChString
type_
  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. (HasCallStack, 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

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

type family
  GoTakeColumn name (columns :: [Type]) (acc :: [Type]) :: Maybe Type
  where
  GoTakeColumn name (Column name chType ': columns) acc = Just (Column name chType)
  GoTakeColumn name (Column name1 chType ': columns) acc = (GoTakeColumn name columns (Column name1 chType ': acc))
  GoTakeColumn name '[] acc = Nothing