diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -0,0 +1,108 @@ +# 0.2.0 -- 23-03-2023 + +ClickHaskell documentation got it's own domain name: https://clickhaskell.dev/ + + +## Fixes: +- Improved multithreading connection usage (+ added test) +- Unexpected behavior on expected and result column type mismatches (+ added test) + +## Features: +- Additional GHC versions tests: `9.4.8`, `9.8.4`, `9.10.1` +- Query serialization support for UUID (+ added test) +- Export of client errors for exception handling +- Dropped vector dependency +- Introduced memory consumption test (64M limit) on parallel reading and writing of 1 million rows +- Added new reading wrapper for generateRandom function +- Depricating `Ch*` prefixes on types: + - `ChUInt*` -> `UInt*` (type synonyms to Word*) + - `ChInt*` -> `Int*` (reexport of Data.Int) + - `ChDate` -> `Date` (ClickHaskell type) + - `ChDateTime` -> `DateTime` (ClickHaskell type) + - `ChArray` -> `Array` (ClickHaskell type) + - `ChUUID` -> `UUID` (ClickHaskell type) +- openNativeConnection now passes $HOME and $USERNAME variables to query info + +## Breaking changes: +- ### New UserErrors on types and columns names missmatches + This change helps protect a user from unexpected behavior + `UnmatchedType` error occurs when the expected type doesn't match the resulting one + `UnmatchedColumn` error occurs when the expected column name doesn't match the resulting one + ```haskell + data ExpectedName = MkExpectedName + { expectedName :: ChInt64 + } + deriving (Generic) + deriving anyclass (ReadableFrom (Columns ExpectedColumns)) + + type ExpectedColumns = '[ Column "expectedName" ChInt64] + + -- Will throw UnmatchedColumn + void $ + select + @ExpectedColumns @ExpectedName connection + (toChType "SELECT * FROM generateRandom('unexpectedName Int64', 1, 10, 2) LIMIT 1") + pure + + -- Will throw UnmatchedType + void $ + select + @ExpectedColumns @ExpectedName connection + "SELECT * FROM generateRandom('expectedName String', 1, 10, 2) LIMIT 1" + pure + ``` + +- ### Migration to streaming API + The result of selects now exposes the block by block handling result. So you need to pass the handler and to process the list of results + ```haskell + result <- + sum <$> + select + @ExampleColumns + @ExampleData + connection "\ + \SELECT * \ + \FROM generateRandom('a1 Int64', 1, 10, 2) \ + \LIMIT 1_000_00 \ + \ " + ``` + now looks like + ```haskell + result <- + sum <$> + select + @ExampleColumns + @ExampleData + connection "\ + \SELECT * \ + \FROM generateRandom('a1 Int64', 1, 10, 2) \ + \LIMIT 1_000_00 \ + \ " + (pure . sum) + ``` + +- ### DateTime type now parametrized with timezone + Every DateTime type annotations + ```haskell + type A = ChDateTime -- DateTime + type B = ChDateTime -- DateTime('UTC') + ``` + should be changed with + ```haskell + type A = ChDateTime "" -- DateTime + type B = ChDateTime "UTC" -- DateTime('UTC') + ``` + +- ### Migration to single module distribution + You need to move all imports such as + ```haskell + import ClickHaskell.DbTypes (ChInt8) + ``` + to ClickHaskell module + ```haskell + import ClickHaskell (ChInt8) + ``` + +# 0.1.0 -- 04-12-2024 + +Initial release diff --git a/ClickHaskell.cabal b/ClickHaskell.cabal --- a/ClickHaskell.cabal +++ b/ClickHaskell.cabal @@ -2,15 +2,16 @@ Name: ClickHaskell -Version: 0.1.0 +Version: 0.2.0 Author: Kovalev Dmitry Maintainer: Kovalev Dmitry Category: ClickHouse Synopsis: ClickHouse driver Description: Small dependency footprint highlevel ClickHouse driver -Homepage: https://github.com/KovalevDima/ClickHaskell#readme -Bug-reports: https://github.com/KovalevDima/ClickHaskell/issues +Tested-with: GHC == 9.4.8, GHC == 9.6.6, GHC == 9.8.4, GHC == 9.10.1 +Homepage: https://clickhaskell.dev/ +Bug-reports: https://git.clickhaskell.dev/ License: BSD-3-Clause License-File: LICENSE Copyright: 2023 Kovalev Dmitry @@ -20,70 +21,24 @@ README.md ChangeLog.md -Flag release - Description: Pre-release build options - Manual: True - Default: False - -Flag dev - Description: Dump core - Manual: True - Default: False - - Source-repository head Type: git Location: https://github.com/KovalevDima/ClickHaskell - Subdir: ClickHaskell - Library Autogen-Modules: Paths_ClickHaskell Exposed-Modules: ClickHaskell - ClickHaskell.DbTypes - ClickHaskell.Parameters - ClickHaskell.NativeProtocol - ClickHaskell.DeSerialization - ClickHaskell.Versioning Other-Modules: Paths_ClickHaskell - ClickHaskell.Columns HS-Source-Dirs: ./ - default-extensions: - AllowAmbiguousTypes - DataKinds - DefaultSignatures - DeriveAnyClass - DeriveGeneric - DerivingStrategies - InstanceSigs - GADTs - NamedFieldPuns - StandaloneDeriving - UndecidableInstances GHC-Options: -Wall -fno-warn-type-defaults -Wunused-packages - if flag(release) - GHC-Options: -Werror - - if flag(dev) - GHC-Options: - -ddump-to-file - -ddump-simpl - -dsuppress-type-applications - -dsuppress-coercions - -dsuppress-idinfo - -dsuppress-type-signatures - -dsuppress-var-kinds - -dsuppress-module-prefixes - -dsuppress-uniques - Build-depends: -- GHC included libraries base >= 4.7 && <5 @@ -92,17 +47,8 @@ , deepseq < 1.6 , text < 2.2 , time < 1.13 - , vector < 0.14 -- External dependencies , network , wide-word < 0.2 Default-language: Haskell2010 - Default-Extensions: - FlexibleContexts - FlexibleInstances - MultiParamTypeClasses - TypeApplications - TypeFamilies - TypeOperators - ScopedTypeVariables diff --git a/ClickHaskell.hs b/ClickHaskell.hs --- a/ClickHaskell.hs +++ b/ClickHaskell.hs @@ -1,418 +1,1935 @@ {-# LANGUAGE - BangPatterns - , ConstraintKinds - , LambdaCase - , NumericUnderscores - , OverloadedStrings - , RecordWildCards -#-} - -module ClickHaskell - ( - -- * Connection - ChCredential(..), defaultCredentials - , Connection(..), openNativeConnection - - -- * Reading and writing - , Table - , Columns, Column, KnownColumn(..), DeserializableColumn(..) - - -- ** Reading - , ReadableFrom(..) - -- *** Simple - , select - , selectFrom - , selectFromView, View, parameter, Parameter - -- *** Streaming - , streamSelect - , streamSelectFrom - , streamSelectFromView - -- *** Internal - , handleSelect - - -- ** Writing - , WritableInto(..) - , insertInto - - -- * Ping database connection - , ping - ) where - --- Internal dependencies -import ClickHaskell.DbTypes -import ClickHaskell.NativeProtocol - ( mkDataPacket, DataPacket(..) - , mkHelloPacket, HelloParameters(..), mkAddendum - , mkPingPacket - , mkQueryPacket - , ServerPacketType(..), HelloResponse(..), ExceptionPacket, latestSupportedRevision - ) -import ClickHaskell.Versioning (ProtocolRevision) -import ClickHaskell.Columns - ( HasColumns (..), WritableInto (..), ReadableFrom (..) - , Columns, DeserializableColumns (..) - , Column, DeserializableColumn(..), KnownColumn(..) - ) -import ClickHaskell.Parameters (Parameter, parameter, parameters, Parameters, CheckParameters) -import ClickHaskell.DeSerialization (Serializable(..), Deserializable(..)) - --- GHC included -import Control.Exception (Exception, SomeException, bracketOnError, catch, finally, throwIO) -import Control.DeepSeq (NFData, (<$!!>)) -import Data.Binary.Get (Decoder (..), Get, runGetIncremental) -import Data.ByteString.Builder (byteString, toLazyByteString) -import Data.ByteString.Char8 as BS8 (fromStrict, pack) -import Data.ByteString.Lazy.Internal as BL (ByteString (..), LazyByteString) -import Data.Int (Int64) -import Data.Kind (Type) -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import Data.Typeable (Proxy (..)) -import GHC.Stack (HasCallStack, callStack, prettyCallStack) -import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) -import System.Timeout (timeout) - --- External -import Network.Socket as Sock -import Network.Socket.ByteString.Lazy (recv, sendAll) - --- * Connection - -data ChCredential = MkChCredential - { chLogin :: Text - , chPass :: Text - , chDatabase :: Text - , chHost :: HostName - , chPort :: ServiceName - } - -defaultCredentials :: ChCredential -defaultCredentials = MkChCredential - { chLogin = "default" - , chPass = "" - , chHost = "localhost" - , chDatabase = "default" - , chPort = "9000" - } - -data Connection = MkConnection - { sock :: Socket - , user :: ChString - , bufferSize :: Int64 - , revision :: ProtocolRevision - } - -openNativeConnection :: HasCallStack => ChCredential -> IO Connection -openNativeConnection MkChCredential{chHost, chPort, chLogin, chPass, chDatabase} = do - AddrInfo{addrFamily, addrSocketType, addrProtocol, addrAddress} - <- (maybe (throwIO $ ConnectionError NoAdressResolved) pure . listToMaybe) - =<< getAddrInfo - (Just defaultHints{addrFlags = [AI_ADDRCONFIG], addrSocketType = Stream}) - (Just chHost) - (Just chPort) - sock <- maybe (throwIO $ ConnectionError EstablishTimeout) pure - =<< timeout 3_000_000 ( - bracketOnError - (socket addrFamily addrSocketType addrProtocol) - (\sock -> - catch @SomeException - (finally - (shutdown sock ShutdownBoth) - (close sock) - ) - (const $ pure ()) - ) - (\sock -> do - setSocketOption sock NoDelay 1 - setSocketOption sock Sock.KeepAlive 1 - connect sock addrAddress - pure sock - ) - ) - - (sendAll sock . toLazyByteString . serialize latestSupportedRevision) - (mkHelloPacket MkHelloParameters{..}) - - (serverPacketType, _) <- rawBufferizedRead emptyBuffer (deserialize latestSupportedRevision) sock 4096 - case serverPacketType of - HelloResponse MkHelloResponse{server_revision} -> do - let revision = min server_revision latestSupportedRevision - (sendAll sock . toLazyByteString) (serialize revision mkAddendum) - pure MkConnection - { user = toChType chLogin - , revision - , sock - , bufferSize = 4096 - } - Exception exception -> throwIO (DatabaseException exception) - otherPacket -> throwIO (ProtocolImplementationError $ UnexpectedPacketType otherPacket) - - --- * Ping - -ping :: HasCallStack => Connection -> IO () -ping conn@MkConnection{sock, revision} = do - (sendAll sock . toLazyByteString) - (serialize revision mkPingPacket) - (responsePacket, _) <- continueReadDeserializable conn emptyBuffer - case responsePacket of - Pong -> pure () - Exception exception -> throwIO (DatabaseException exception) - otherPacket -> throwIO (ProtocolImplementationError . UnexpectedPacketType $ otherPacket) - - - - --- * Querying - -data Table (name :: Symbol) (columns :: [Type]) - -instance HasColumns (Table name columns) where - type GetColumns (Table _ columns) = columns - --- ** Selecting - --- *** Simple - -selectFrom :: - forall table record name columns - . - ( table ~ Table name columns - , KnownSymbol name - , ReadableFrom table record - ) - => - Connection -> IO [record] -selectFrom conn@MkConnection{sock, user, revision} = do - let query - = "SELECT " <> readingColumns @table @record - <> " FROM " <> (byteString . BS8.pack) (symbolVal $ Proxy @name) - (sendAll sock . toLazyByteString) - ( serialize revision (mkQueryPacket revision user (toChType query)) - <> serialize revision (mkDataPacket "" 0 0) - ) - handleSelect @table conn emptyBuffer pure - -select :: - forall columns record - . - ReadableFrom (Columns columns) record - => - Connection -> ChString -> IO [record] -select conn@MkConnection{sock, user, revision} query = do - (sendAll sock . toLazyByteString) - ( serialize revision (mkQueryPacket revision user query) - <> serialize revision (mkDataPacket "" 0 0) - ) - handleSelect @(Columns columns) conn emptyBuffer pure - -instance HasColumns (View name columns parameters) where - type GetColumns (View _ columns _) = columns - -data View (name :: Symbol) (columns :: [Type]) (parameters :: [Type]) - -selectFromView :: - forall view record name columns parameters passedParameters - . - ( ReadableFrom view record - , KnownSymbol name - , view ~ View name columns parameters - , CheckParameters parameters passedParameters - ) - => Connection -> (Parameters '[] -> Parameters passedParameters) -> IO [record] -selectFromView conn@MkConnection{..} interpreter = do - let query = - "SELECT " <> readingColumns @view @record <> - " FROM " <> (byteString . BS8.pack . symbolVal @name) Proxy <> parameters interpreter - (sendAll sock . toLazyByteString) - ( serialize revision (mkQueryPacket revision user (toChType query)) - <> serialize revision (mkDataPacket "" 0 0) - ) - handleSelect @view conn emptyBuffer pure - --- *** Streaming - -streamSelectFrom :: - forall table record name columns a - . - ( table ~ Table name columns - , KnownSymbol name - , ReadableFrom table record - , NFData a - ) - => - Connection -> ([record] -> IO [a]) -> IO [a] -streamSelectFrom conn@MkConnection{sock, user, revision} f = do - let query - = "SELECT " <> readingColumns @table @record - <> " FROM " <> (byteString . BS8.pack) (symbolVal $ Proxy @name) - (sendAll sock . toLazyByteString) - ( serialize revision (mkQueryPacket revision user (toChType query)) - <> serialize revision (mkDataPacket "" 0 0) - ) - let f' x = id <$!!> f x - handleSelect @table conn emptyBuffer f' - -streamSelect :: - forall columns record a - . - (ReadableFrom (Columns columns) record, NFData a) - => - Connection -> ChString -> ([record] -> IO [a]) -> IO [a] -streamSelect conn@MkConnection{sock, user, revision} query f = do - (sendAll sock . toLazyByteString) - ( serialize revision (mkQueryPacket revision user query) - <> serialize revision (mkDataPacket "" 0 0) - ) - let f' x = id <$!!> f x - handleSelect @(Columns columns) conn emptyBuffer f' - -streamSelectFromView :: - forall view record name columns parameters passedParameters a - . - ( ReadableFrom view record - , KnownSymbol name - , view ~ View name columns parameters - , NFData a - , CheckParameters parameters passedParameters - ) - => Connection -> (Parameters '[] -> Parameters passedParameters) -> ([record] -> IO [a]) -> IO [a] -streamSelectFromView conn@MkConnection{..} interpreter f = do - let query = - "SELECT " <> readingColumns @view @record <> - " FROM " <> (byteString . BS8.pack . symbolVal @name) Proxy <> parameters interpreter - (sendAll sock . toLazyByteString) - ( serialize revision (mkQueryPacket revision user (toChType query)) - <> serialize revision (mkDataPacket "" 0 0) - ) - let f' x = id <$!!> f x - handleSelect @view conn emptyBuffer f' - --- *** Internal - -handleSelect :: - forall hasColumns record a - . - ReadableFrom hasColumns record - => - Connection -> Buffer -> ([record] -> IO [a]) -> IO [a] -handleSelect conn previousBuffer f = do - (packet, buffer) <- continueReadDeserializable @ServerPacketType conn previousBuffer - case packet of - DataResponse MkDataPacket{columns_count, rows_count} -> do - case (columns_count, rows_count) of - (0, 0) -> handleSelect @hasColumns conn buffer f - (_, 0) -> do - (_, nextBuffer) <- continueReadColumns @hasColumns @record conn buffer 0 - handleSelect @hasColumns conn nextBuffer f - (_, rows) -> do - (columns, nextBuffer) <- continueReadColumns @hasColumns conn buffer rows - processedColumns <- f columns - (processedColumns ++) <$> handleSelect @hasColumns conn nextBuffer f - Progress _ -> handleSelect @hasColumns conn buffer f - ProfileInfo _ -> handleSelect @hasColumns conn buffer f - EndOfStream -> pure [] - Exception exception -> throwIO (DatabaseException exception) - otherPacket -> throwIO (ProtocolImplementationError $ UnexpectedPacketType otherPacket) - - --- ** Inserting - -insertInto :: - forall table record name columns - . - ( table ~ Table name columns - , WritableInto table record - , KnownSymbol name - ) - => Connection -> [record] -> IO () -insertInto conn@MkConnection{sock, user, revision} columnsData = do - let query = - "INSERT INTO " <> (byteString . BS8.pack) (symbolVal $ Proxy @name) - <> " (" <> writingColumns @table @record <> ") VALUES" - (sendAll sock . toLazyByteString) - ( serialize revision (mkQueryPacket revision user (toChType query)) - <> serialize revision (mkDataPacket "" 0 0) - ) - handleInsertResult @table conn emptyBuffer columnsData - -handleInsertResult :: forall columns record . WritableInto columns record => Connection -> Buffer -> [record] -> IO () -handleInsertResult conn@MkConnection{..} buffer records = do - (firstPacket, buffer1) <- continueReadDeserializable @ServerPacketType conn buffer - case firstPacket of - TableColumns _ -> handleInsertResult @columns conn buffer1 records - DataResponse packet -> do - (_emptyDataPacket, buffer2) <- continueReadRawColumns @(Columns (GetColumns columns)) conn buffer1 (rows_count packet) - (sendAll sock . toLazyByteString) - ( serialize revision (mkDataPacket "" (columnsCount @columns @record) (fromIntegral $ length records)) - <> serializeRecords @columns revision (fromIntegral $ length records) records - <> serialize revision (mkDataPacket "" 0 0) - ) - handleInsertResult @columns @record conn buffer2 [] - EndOfStream -> pure () - Exception exception -> throwIO (DatabaseException exception) - otherPacket -> throwIO (ProtocolImplementationError $ UnexpectedPacketType otherPacket) - - - - --- * Reading - -continueReadDeserializable :: Deserializable packet => Connection -> Buffer -> IO (packet, Buffer) -continueReadDeserializable MkConnection{..} buffer = rawBufferizedRead buffer (deserialize revision) sock bufferSize - -continueReadColumns :: forall columns record . ReadableFrom columns record => Connection -> Buffer -> UVarInt -> IO ([record], Buffer) -continueReadColumns MkConnection{..} buffer rows = rawBufferizedRead buffer (deserializeColumns @columns revision rows) sock bufferSize - -continueReadRawColumns :: forall columns . DeserializableColumns columns => Connection -> Buffer -> UVarInt -> IO (columns, Buffer) -continueReadRawColumns MkConnection{..} buffer rows = rawBufferizedRead buffer (deserializeRawColumns @columns revision rows) sock bufferSize - --- ** Bufferization - -type Buffer = LazyByteString - -emptyBuffer :: Buffer -emptyBuffer = BL.Empty - -rawBufferizedRead :: Buffer -> Get packet -> Socket -> Int64 -> IO (packet, Buffer) -rawBufferizedRead buffer parser sock bufSize = runBufferReader (recv sock bufSize) (runGetIncremental parser) buffer - -runBufferReader :: IO LazyByteString -> Decoder packet -> Buffer -> IO (packet, Buffer) -runBufferReader bufferFiller (Partial decoder) (BL.Chunk bs mChunk) - = runBufferReader bufferFiller (decoder $ Just bs) mChunk -runBufferReader bufferFiller (Partial decoder) BL.Empty = do - bufferFiller >>= \case - BL.Empty -> throwIO (DeserializationError "Expected more bytes while reading packet") - BL.Chunk bs mChunk -> runBufferReader bufferFiller (decoder $ Just bs) mChunk -runBufferReader _bufferFiller (Done leftover _consumed packet) _input = pure (packet, fromStrict leftover) -runBufferReader _initBuf (Fail _leftover _consumed msg) _buffer = throwIO (DeserializationError msg) - - - - --- * Errors handling - -data ClientError where - ConnectionError :: HasCallStack => ConnectionError -> ClientError - DatabaseException :: HasCallStack => ExceptionPacket -> ClientError - ProtocolImplementationError :: HasCallStack => ProtocolImplementationError -> ClientError - -instance Show ClientError where - show (ConnectionError connError) = "ConnectionError" <> show connError <> "\n" <> prettyCallStack callStack - show (DatabaseException exception) = "DatabaseException" <> show exception <> "\n" <> prettyCallStack callStack - show (ProtocolImplementationError err) = "ConnectionError" <> show err <> "\n" <> prettyCallStack callStack - -deriving anyclass instance Exception ClientError - -{- | - You shouldn't see this exceptions. Please report a bug if it appears --} -data ProtocolImplementationError - = UnexpectedPacketType ServerPacketType - | DeserializationError String - deriving (Show, Exception) - -data ConnectionError - = NoAdressResolved - | EstablishTimeout - deriving (Show, Exception) + AllowAmbiguousTypes + , ConstraintKinds + , DataKinds + , DefaultSignatures + , DeriveAnyClass + , DeriveGeneric + , DerivingStrategies + , DuplicateRecordFields + , GADTs + , GeneralizedNewtypeDeriving + , ImportQualifiedPost + , FlexibleContexts + , FlexibleInstances + , LambdaCase + , MultiParamTypeClasses + , NamedFieldPuns + , NoFieldSelectors + , NumericUnderscores + , OverloadedStrings + , RecordWildCards + , TupleSections + , TypeApplications + , TypeFamilies + , TypeOperators + , ScopedTypeVariables + , StandaloneDeriving + , UndecidableInstances +#-} + +{-# OPTIONS_GHC + -Wno-orphans + -Wno-unused-top-binds +#-} +{-# LANGUAGE BangPatterns #-} + +module ClickHaskell + ( + -- * Connection + ChCredential(..), defaultCredentials + , Connection(..), openNativeConnection + + -- * Reading and writing + , Table + , Columns, Column, KnownColumn(..), DeserializableColumn(..) + + -- * Reading + , ReadableFrom(..) + , select + , selectFrom + , selectFromView, View, parameter, Parameter, Parameters, viewParameters + , generateRandom + -- ** Internal + , handleSelect + + -- * Errors + , ClientError(..) + , ConnectionError(..) + , UserError(..) + , InternalError(..) + + -- * Writing + , WritableInto(..) + , insertInto + + -- * Ping database connection + , ping + + -- * ClickHouse types + , IsChType(ToChTypeName, chTypeName, defaultValueOfTypeName) + , ToChType(toChType) + , FromChType(fromChType) + , ToQueryPart(toQueryPart) + + , DateTime(..) + + , module Data.Int + , UInt8, UInt16, UInt32, UInt64, UInt128 + , Nullable + , LowCardinality, IsLowCardinalitySupported + , UUID(..) + , Array(..) + , ChString(..) + + , UVarInt(..) + , module Data.WideWord + + -- Deprecated Ch prefixed types. Use above one + , ChDate, ChDateTime + , ChUInt8, ChUInt16, ChUInt32, ChUInt64, ChUInt128 + , ChInt8, ChInt16, ChInt32, ChInt64, ChInt128 + , ChUUID + , ChArray + ) where + +-- Internal +import Paths_ClickHaskell (version) + +-- GHC included +import Control.Concurrent (MVar, newMVar, putMVar, takeMVar) +import Control.DeepSeq (NFData) +import Control.Exception (Exception, SomeException, bracketOnError, catch, finally, mask, onException, throw, throwIO) +import Control.Monad (forM, replicateM, void, when, (<$!>), (<=<)) +import Data.Binary.Get +import Data.Binary.Get.Internal (readN) +import Data.Bits (Bits (setBit, unsafeShiftL, unsafeShiftR, (.&.), (.|.))) +import Data.ByteString as BS (StrictByteString, length, take, toStrict) +import Data.ByteString.Builder +import Data.ByteString.Builder as BS (Builder, byteString) +import Data.ByteString.Char8 as BS8 (concatMap, length, pack, replicate, singleton) +import Data.Coerce (coerce) +import Data.IORef (IORef, atomicModifyIORef, atomicWriteIORef, newIORef, readIORef) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Constraint, Type) +import Data.List (uncons) +import Data.Maybe (listToMaybe) +import Data.String (IsString (..)) +import Data.Text (Text) +import Data.Text.Encoding as Text (encodeUtf8) +import Data.Time (UTCTime, ZonedTime, zonedTimeToUTC) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import Data.Type.Bool (If) +import Data.Type.Equality (type (==)) +import Data.Typeable (Proxy (..)) +import Data.Version (Version (..)) +import Data.Word (Word16, Word32, Word64, Word8) +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 (AppendSymbol, ErrorMessage (..), KnownNat, KnownSymbol, Nat, Symbol, TypeError, natVal, symbolVal) +import System.Environment (lookupEnv) +import System.Timeout (timeout) + +-- External +import Data.WideWord (Int128 (..), Word128(..)) +import Network.Socket hiding (SocketOption(..)) +import Network.Socket qualified as Sock (SocketOption(..)) +import Network.Socket.ByteString (recv) +import Network.Socket.ByteString.Lazy (sendAll) + +-- * Connection + +data ChCredential = MkChCredential + { chLogin :: Text + , chPass :: Text + , chDatabase :: Text + , chHost :: HostName + , chPort :: ServiceName + } + +defaultCredentials :: ChCredential +defaultCredentials = MkChCredential + { chLogin = "default" + , chPass = "" + , chHost = "localhost" + , chDatabase = "default" + , chPort = "9000" + } + +data Connection where MkConnection :: (MVar ConnectionState) -> Connection + +withConnection :: HasCallStack => Connection -> (ConnectionState -> IO a) -> IO a +withConnection (MkConnection connStateMVar) f = + mask $ \restore -> do + connState <- takeMVar connStateMVar + b <- onException + (restore (f connState)) + (putMVar connStateMVar =<< reopenConnection connState) + putMVar connStateMVar connState + return b + +data ConnectionState = MkConnectionState + { sock :: Socket + , user :: ChString + , hostname :: ChString + , os_user :: ChString + , buffer :: Buffer + , revision :: ProtocolRevision + , creds :: ChCredential + } + +data ConnectionError = NoAdressResolved | EstablishTimeout + deriving (Show, Exception) + +writeToConnection :: Serializable packet => ConnectionState -> packet -> IO () +writeToConnection MkConnectionState{sock, revision} packet = + (sendAll sock . toLazyByteString . serialize revision) packet + +writeToConnectionEncode :: ConnectionState -> (ProtocolRevision -> Builder) -> IO () +writeToConnectionEncode MkConnectionState{sock, revision} serializer = + (sendAll sock . toLazyByteString) (serializer revision) + +openNativeConnection :: HasCallStack => ChCredential -> IO Connection +openNativeConnection creds = fmap MkConnection . newMVar =<< createConnectionState creds + +reopenConnection :: ConnectionState -> IO ConnectionState +reopenConnection MkConnectionState{..} = do + flushBuffer buffer + close sock + createConnectionState creds + +createConnectionState :: ChCredential -> IO ConnectionState +createConnectionState creds@MkChCredential{chHost, chPort, chLogin, chPass, chDatabase} = do + hostname <- maybe "" toChType <$> lookupEnv "HOSTNAME" + os_user <- maybe "" toChType <$> lookupEnv "USER" + AddrInfo{addrFamily, addrSocketType, addrProtocol, addrAddress} + <- maybe (throwIO NoAdressResolved) pure . listToMaybe + =<< getAddrInfo + (Just defaultHints{addrFlags = [AI_ADDRCONFIG], addrSocketType = Stream}) + (Just chHost) + (Just chPort) + sock <- maybe (throwIO EstablishTimeout) pure + =<< timeout 3_000_000 ( + bracketOnError + (socket addrFamily addrSocketType addrProtocol) + (\sock -> + catch @SomeException + (finally + (shutdown sock ShutdownBoth) + (close sock) + ) + (const $ pure ()) + ) + (\sock -> do + setSocketOption sock Sock.NoDelay 1 + setSocketOption sock Sock.KeepAlive 1 + connect sock addrAddress + pure sock + ) + ) + + (sendAll sock . toLazyByteString . serialize latestSupportedRevision) + (mkHelloPacket MkHelloParameters{..}) + + buffer <- initBuffer 4096 sock + serverPacketType <- rawBufferizedRead buffer (deserialize latestSupportedRevision) + case serverPacketType of + HelloResponse MkHelloResponse{server_revision} -> do + let revision = min server_revision latestSupportedRevision + conn = MkConnectionState{user = toChType chLogin, ..} + writeToConnection conn mkAddendum + pure conn + Exception exception -> throwIO (UserError $ DatabaseException exception) + otherPacket -> throwIO (InternalError $ UnexpectedPacketType $ serverPacketToNum otherPacket) + + + + +-- * Ping + +ping :: HasCallStack => Connection -> IO () +ping conn = do + withConnection conn $ \connState@MkConnectionState{revision, buffer} -> do + writeToConnection connState mkPingPacket + responsePacket <- rawBufferizedRead buffer (deserialize revision) + case responsePacket of + Pong -> pure () + Exception exception -> throwIO (UserError $ DatabaseException exception) + otherPacket -> throwIO (InternalError $ UnexpectedPacketType $ serverPacketToNum otherPacket) + + + + +-- * Reading + +select :: + forall columns record result + . + (ReadableFrom (Columns columns) record) + => + Connection -> ChString -> ([record] -> IO result) -> IO [result] +select conn query f = do + withConnection conn $ \connState -> do + writeToConnection connState (mkQueryPacket connState query) + writeToConnection connState (mkDataPacket "" 0 0) + handleSelect @(Columns columns) connState (\x -> id <$!> f x) + +data Table (name :: Symbol) (columns :: [Type]) + +selectFrom :: + forall table record name columns a + . + ( table ~ Table name columns + , KnownSymbol name + , ReadableFrom table record + ) + => + Connection -> ([record] -> IO a) -> IO [a] +selectFrom conn f = do + withConnection conn $ \connState -> do + writeToConnection connState (mkQueryPacket connState (toChType query)) + writeToConnection connState (mkDataPacket "" 0 0) + handleSelect @table connState (\x -> id <$!> f x) + where + query = + "SELECT " <> readingColumns @table @record <> + " FROM " <> (byteString . BS8.pack) (symbolVal $ Proxy @name) + +data View (name :: Symbol) (columns :: [Type]) (parameters :: [Type]) + +selectFromView :: + forall view record result name columns parameters passedParameters + . + ( ReadableFrom view record + , KnownSymbol name + , view ~ View name columns parameters + , CheckParameters parameters passedParameters + ) + => Connection -> (Parameters '[] -> Parameters passedParameters) -> ([record] -> IO result) -> IO [result] +selectFromView conn interpreter f = do + withConnection conn $ \connState -> do + writeToConnection connState (mkQueryPacket connState (toChType query)) + writeToConnection connState (mkDataPacket "" 0 0) + handleSelect @view connState (\x -> id <$!> f x) + where + query = + "SELECT " <> readingColumns @view @record <> + " FROM " <> (byteString . BS8.pack . symbolVal @name) Proxy <> viewParameters interpreter + +generateRandom :: + forall columns record result + . + (ReadableFrom (Columns columns) record) + => + Connection -> (UInt64, UInt64, UInt64) -> UInt64 -> ([record] -> IO result) -> IO [result] +generateRandom conn (randomSeed, maxStrLen, maxArrayLen) limit f = do + withConnection conn $ \connState -> do + writeToConnection connState (mkQueryPacket connState query) + writeToConnection connState (mkDataPacket "" 0 0) + handleSelect @(Columns columns) connState (\x -> id <$!> f x) + where + query = + let columns = readingColumnsAndTypes @(Columns columns) @record + in toChType $ + "SELECT * FROM generateRandom(" <> + "'" <> columns <> "' ," <> + toQueryPart randomSeed <> "," <> + toQueryPart maxStrLen <> "," <> + toQueryPart maxArrayLen <> + ")" <> + " LIMIT " <> toQueryPart limit <> ";" + +-- *** Internal + +handleSelect :: + forall hasColumns record result + . + ReadableFrom hasColumns record + => + ConnectionState -> ([record] -> IO result) -> IO [result] +handleSelect MkConnectionState{..} f = loop [] + where + loop acc = rawBufferizedRead buffer (deserialize revision) >>= + \packet -> case packet of + DataResponse MkDataPacket{columns_count = 0, rows_count = 0} -> loop acc + DataResponse MkDataPacket{rows_count} -> do + result <- f =<< rawBufferizedRead buffer (deserializeColumns @hasColumns revision rows_count) + loop (result : acc) + Progress _ -> loop acc + ProfileInfo _ -> loop acc + EndOfStream -> pure acc + Exception exception -> throwIO (UserError $ DatabaseException exception) + otherPacket -> throwIO (InternalError $ UnexpectedPacketType $ serverPacketToNum otherPacket) + + + + +-- * Writing + +insertInto :: + forall table record name columns + . + ( table ~ Table name columns + , WritableInto table record + , KnownSymbol name + ) + => Connection -> [record] -> IO () +insertInto conn columnsData = do + withConnection conn $ \connState -> do + writeToConnection connState (mkQueryPacket connState query) + writeToConnection connState (mkDataPacket "" 0 0) + handleInsertResult @table connState columnsData + where + query = toChType $ + "INSERT INTO " <> (byteString . BS8.pack . symbolVal @name $ Proxy) + <> " (" <> writingColumns @table @record <> ") VALUES" + + +handleInsertResult :: forall columns record . WritableInto columns record => ConnectionState -> [record] -> IO () +handleInsertResult conn@MkConnectionState{..} records = do + firstPacket <- rawBufferizedRead buffer (deserialize revision) + case firstPacket of + TableColumns _ -> handleInsertResult @columns conn records + DataResponse MkDataPacket{} -> do + _emptyDataPacket <- rawBufferizedRead buffer (deserializeInsertHeader @columns @record revision) + writeToConnection conn (mkDataPacket "" (columnsCount @columns @record) (fromIntegral $ Prelude.length records)) + writeToConnectionEncode conn (serializeRecords @columns records) + writeToConnection conn (mkDataPacket "" 0 0) + handleInsertResult @columns @record conn [] + EndOfStream -> pure () + Exception exception -> throwIO (UserError $ DatabaseException exception) + otherPacket -> throwIO (InternalError $ UnexpectedPacketType $ serverPacketToNum otherPacket) + + + + +-- * Bufferization + +data Buffer = MkBuffer + { bufferSize :: Int + , bufferSocket :: Socket + , buff :: IORef StrictByteString + } + +initBuffer :: Int -> Socket -> IO Buffer +initBuffer size sock = MkBuffer size sock <$> newIORef "" + +flushBuffer :: Buffer -> IO () +flushBuffer MkBuffer{buff} = atomicWriteIORef buff "" + +readBuffer :: Buffer -> IO StrictByteString +readBuffer buffer@MkBuffer{..} = + readIORef buff + >>= (\currentBuffer -> + case BS.length currentBuffer of + 0 -> recv bufferSocket bufferSize + _ -> flushBuffer buffer *> pure currentBuffer + ) + +writeToBuffer :: Buffer -> StrictByteString -> IO () +writeToBuffer MkBuffer{..} val = void (atomicModifyIORef buff (val,)) + +rawBufferizedRead :: Buffer -> Get packet -> IO packet +rawBufferizedRead buffer parser = runBufferReader buffer (runGetIncremental parser) + +runBufferReader :: Buffer -> Decoder packet -> IO packet +runBufferReader buffer = \case + (Partial decoder) -> readBuffer buffer >>= runBufferReader buffer . decoder . Just + (Done leftover _consumed packet) -> packet <$ writeToBuffer buffer leftover + (Fail _leftover _consumed msg) -> throwIO (InternalError $ DeserializationError msg) + + + + +-- * Errors handling + +data ClientError where + UserError :: HasCallStack => UserError -> ClientError + InternalError :: HasCallStack => InternalError -> ClientError + +instance Show ClientError where + show (UserError err) = "UserError " <> show err <> "\n" <> prettyCallStack callStack + show (InternalError err) = "InternalError " <> show err <> "\n" <> prettyCallStack callStack + +deriving anyclass instance Exception ClientError + +{- | + You shouldn't see this exceptions. Please report a bug if it appears +-} +data InternalError + = UnexpectedPacketType UVarInt + | DeserializationError String + deriving (Show, Exception) + +data UserError + = UnmatchedType String + | UnmatchedColumn String + | DatabaseException ExceptionPacket + deriving (Show, Exception) + + + + +-- * Client packets + +data ClientPacketType + = Hello | Query | Data | Cancel | Ping | TablesStatusRequest + | KeepAlive | Scalar | IgnoredPartUUIDs | ReadTaskResponse + | MergeTreeReadTaskResponse | SSHChallengeRequest | SSHChallengeResponse + deriving (Enum) + +type family PacketTypeNumber (packetType :: ClientPacketType) + where + PacketTypeNumber Hello = 0; PacketTypeNumber Query = 1 + PacketTypeNumber Data = 2; PacketTypeNumber Cancel = 3 + PacketTypeNumber Ping = 4; PacketTypeNumber TablesStatusRequest = 5 + PacketTypeNumber KeepAlive = 6; PacketTypeNumber Scalar = 7 + PacketTypeNumber IgnoredPartUUIDs = 8; PacketTypeNumber ReadTaskResponse = 9 + PacketTypeNumber MergeTreeReadTaskResponse = 10; PacketTypeNumber SSHChallengeRequest = 11 + PacketTypeNumber SSHChallengeResponse = 12 + +data Packet (packetType :: ClientPacketType) = MkPacket + +packetNumVal :: forall packetType . KnownNat (PacketTypeNumber packetType) => UVarInt +packetNumVal = fromIntegral . natVal $ Proxy @(PacketTypeNumber packetType) + +instance + KnownNat (PacketTypeNumber packetType) + => + Serializable (Packet (packetType :: ClientPacketType)) where + serialize rev _ = serialize @UVarInt rev (packetNumVal @packetType) + +instance Deserializable (Packet (packetType :: ClientPacketType)) where + deserialize _rev = pure (MkPacket @packetType) + + +-- ** Hello + +data HelloParameters = MkHelloParameters + { chDatabase :: Text + , chLogin :: Text + , chPass :: Text + } + +mkHelloPacket :: HelloParameters -> HelloPacket +mkHelloPacket MkHelloParameters{chDatabase, chLogin, chPass} = + MkHelloPacket + { packet_type = MkPacket + , client_name, client_version_major, client_version_minor + , tcp_protocol_version = latestSupportedRevision + , default_database = toChType chDatabase + , user = toChType chLogin + , password = toChType chPass + } + +data HelloPacket = MkHelloPacket + { packet_type :: Packet Hello + , client_name :: ChString + , client_version_major :: UVarInt + , client_version_minor :: UVarInt + , tcp_protocol_version :: ProtocolRevision + , default_database :: ChString + , user :: ChString + , password :: ChString + } + deriving (Generic, Serializable) + + +data Addendum = MkAddendum{quota_key :: ChString `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_QUOTA_KEY} + deriving (Generic, Serializable) +mkAddendum :: Addendum +mkAddendum = MkAddendum{quota_key = MkSinceRevision ""} + + +-- ** Ping + +data PingPacket = MkPingPacket{packet_type :: Packet Ping} + deriving (Generic, Serializable) +mkPingPacket :: PingPacket +mkPingPacket = MkPingPacket{packet_type = MkPacket} + + +-- ** Query + +mkQueryPacket :: ConnectionState -> ChString -> QueryPacket +mkQueryPacket MkConnectionState{..} query = MkQueryPacket + { query_packet = MkPacket + , query_id = "" + , client_info = MkSinceRevision MkClientInfo + { query_kind = InitialQuery + , initial_user = user + , initial_query_id = "" + , initial_adress = "0.0.0.0:0" + , initial_time = MkSinceRevision 0 + , interface_type = 1 -- [tcp - 1, http - 2] + , os_user, hostname + , client_name, client_version_major, client_version_minor + , client_revision = revision + , quota_key = MkSinceRevision "" + , distrubuted_depth = MkSinceRevision 0 + , client_version_patch + , open_telemetry = MkSinceRevision 0 + , collaborate_with_initiator = MkSinceRevision 0 + , count_participating_replicas = MkSinceRevision 0 + , number_of_current_replica = MkSinceRevision 0 + } + , settings = MkDbSettings + , interserver_secret = MkSinceRevision "" + , query_stage = Complete + , compression = 0 + , query + , parameters = MkSinceRevision MkQueryParameters + } + +data QueryPacket = MkQueryPacket + { query_packet :: Packet Query + , query_id :: ChString + , client_info :: ClientInfo `SinceRevision` DBMS_MIN_REVISION_WITH_CLIENT_INFO + , settings :: DbSettings + , interserver_secret :: ChString `SinceRevision` DBMS_MIN_REVISION_WITH_INTERSERVER_SECRET + , query_stage :: QueryStage + , compression :: UVarInt + , query :: ChString + , parameters :: QueryParameters `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_PARAMETERS + } + deriving (Generic, Serializable) + +data DbSettings = MkDbSettings +instance Serializable DbSettings where serialize rev _ = serialize @ChString rev "" + +data QueryParameters = MkQueryParameters +instance Serializable QueryParameters where serialize rev _ = serialize @ChString rev "" + +data QueryStage + = FetchColumns | WithMergeableState | Complete + | WithMergeableStateAfterAggregation + | WithMergeableStateAfterAggregationAndLimit + deriving (Enum) + +instance Serializable QueryStage where + serialize rev = serialize @UVarInt rev . fromIntegral . fromEnum + + +data Flags = IMPORTANT | CUSTOM | OBSOLETE +_flagCode :: Flags -> UInt64 +_flagCode IMPORTANT = 0x01 +_flagCode CUSTOM = 0x02 +_flagCode OBSOLETE = 0x04 + +data ClientInfo = MkClientInfo + { query_kind :: QueryKind + , initial_user :: ChString + , initial_query_id :: ChString + , initial_adress :: ChString + , initial_time :: Int64 `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_INITIAL_QUERY_START_TIME + , interface_type :: UInt8 + , os_user :: ChString + , hostname :: ChString + , client_name :: ChString + , client_version_major :: UVarInt + , client_version_minor :: UVarInt + , client_revision :: ProtocolRevision + , quota_key :: ChString `SinceRevision` DBMS_MIN_REVISION_WITH_QUOTA_KEY_IN_CLIENT_INFO + , distrubuted_depth :: UVarInt `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_DISTRIBUTED_DEPTH + , client_version_patch :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_VERSION_PATCH + , open_telemetry :: UInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_OPENTELEMETRY + , collaborate_with_initiator :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_PARALLEL_REPLICAS + , count_participating_replicas :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_PARALLEL_REPLICAS + , number_of_current_replica :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_PARALLEL_REPLICAS + } + deriving (Generic, Serializable) + +data QueryKind = NoQuery | InitialQuery | SecondaryQuery +instance Serializable QueryKind where + serialize rev = serialize @UInt8 rev . (\case NoQuery -> 1; InitialQuery -> 2; SecondaryQuery -> 3) + +-- ** Data + +mkDataPacket :: ChString -> UVarInt -> UVarInt -> DataPacket +mkDataPacket table_name columns_count rows_count = + MkDataPacket + { packet_type = MkPacket + , table_name + , block_info = MkBlockInfo + { field_num1 = 1, is_overflows = 0 + , field_num2 = 2, bucket_num = -1 + , eof = 0 + } + , columns_count + , rows_count + } + +data DataPacket = MkDataPacket + { packet_type :: Packet Data + , table_name :: ChString + , block_info :: BlockInfo + , columns_count :: UVarInt + , rows_count :: UVarInt + } + deriving (Generic, Serializable, Deserializable) + +data BlockInfo = MkBlockInfo + { field_num1 :: UVarInt, is_overflows :: UInt8 + , field_num2 :: UVarInt, bucket_num :: Int32 + , eof :: UVarInt + } + deriving (Generic, Serializable, Deserializable) + + + + +-- * Server packets + +data ServerPacketType where + HelloResponse :: HelloResponse -> ServerPacketType + DataResponse :: DataPacket -> ServerPacketType + Exception :: ExceptionPacket -> ServerPacketType + Progress :: ProgressPacket -> ServerPacketType + Pong :: ServerPacketType + EndOfStream :: ServerPacketType + ProfileInfo :: ProfileInfo -> ServerPacketType + Totals :: ServerPacketType + Extremes :: ServerPacketType + TablesStatusResponse :: ServerPacketType + Log :: ServerPacketType + TableColumns :: TableColumns -> ServerPacketType + UUIDs :: ServerPacketType + ReadTaskRequest :: ServerPacketType + ProfileEvents :: ServerPacketType + UnknownPacket :: UVarInt -> ServerPacketType + +instance Deserializable ServerPacketType where + deserialize rev = do + packetNum <- deserialize @UVarInt rev + case packetNum of + 0 -> HelloResponse <$> deserialize rev + 1 -> DataResponse <$> deserialize rev + 2 -> Exception <$> deserialize rev + 3 -> Progress <$> deserialize rev + 4 -> pure Pong + 5 -> pure EndOfStream + 6 -> ProfileInfo <$> deserialize rev + 7 -> pure Totals + 8 -> pure Extremes + 9 -> pure TablesStatusResponse + 10 -> pure Log + 11 -> TableColumns <$> deserialize rev + 12 -> pure UUIDs + 13 -> pure ReadTaskRequest + 14 -> pure ProfileEvents + _ -> pure $ UnknownPacket packetNum + +serverPacketToNum :: ServerPacketType -> UVarInt +serverPacketToNum = \case + (HelloResponse _) -> 0; (DataResponse _) -> 1 + (Exception _) -> 2; (Progress _) -> 3; + (Pong) -> 4; (EndOfStream) -> 5 + (ProfileInfo _) -> 6; (Totals) -> 7 + (Extremes) -> 8; (TablesStatusResponse) -> 9 + (Log) -> 10; (TableColumns _) -> 11; + (UUIDs) -> 12; (ReadTaskRequest) -> 13 + (ProfileEvents) -> 14; (UnknownPacket num) -> num + + +-- ** HelloResponse + +{- + https://github.com/ClickHouse/ClickHouse/blob/eb4a74d7412a1fcf52727cd8b00b365d6b9ed86c/src/Client/Connection.cpp#L520 +-} +data HelloResponse = MkHelloResponse + { server_name :: ChString + , server_version_major :: UVarInt + , server_version_minor :: UVarInt + , server_revision :: ProtocolRevision + , server_parallel_replicas_proto :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_VERSIONED_PARALLEL_REPLICAS_PROTOCOL + , server_timezone :: ChString `SinceRevision` DBMS_MIN_REVISION_WITH_SERVER_TIMEZONE + , server_display_name :: ChString `SinceRevision` DBMS_MIN_REVISION_WITH_SERVER_DISPLAY_NAME + , server_version_patch :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_VERSION_PATCH + , proto_send_chunked_srv :: ChString `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_CHUNKED_PACKETS + , proto_recv_chunked_srv :: ChString `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_CHUNKED_PACKETS + , password_complexity_rules :: [PasswordComplexityRules] `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_PASSWORD_COMPLEXITY_RULES + , read_nonce :: UInt64 `SinceRevision` DBMS_MIN_REVISION_WITH_INTERSERVER_SECRET_V2 + } + deriving (Generic, Deserializable) + +data PasswordComplexityRules = MkPasswordComplexityRules + { original_pattern :: ChString + , exception_message :: ChString + } + deriving (Generic, Deserializable) + +instance Deserializable [PasswordComplexityRules] where + deserialize rev = do + len <- deserialize @UVarInt rev + replicateM (fromIntegral len) (deserialize @PasswordComplexityRules rev) + +-- ** Exception + +data ExceptionPacket = MkExceptionPacket + { code :: Int32 + , name :: ChString + , message :: ChString + , stack_trace :: ChString + , nested :: UInt8 + } + deriving (Generic, Show, Deserializable) + +-- ** Progress + +data ProgressPacket = MkProgressPacket + { rows :: UVarInt + , bytes :: UVarInt + , total_rows :: UVarInt + , total_bytes :: UVarInt `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_TOTAL_BYTES_IN_PROGRESS + , wrote_rows :: UVarInt `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_TOTAL_BYTES_IN_PROGRESS + , wrote_bytes :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_CLIENT_WRITE_INFO + , elapsed_ns :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_CLIENT_WRITE_INFO + } + deriving (Generic, Deserializable) + +-- ** ProfileInfo + +data ProfileInfo = MkProfileInfo + { rows :: UVarInt + , blocks :: UVarInt + , bytes :: UVarInt + , applied_limit :: UInt8 + , rows_before_limit :: UVarInt + , calculated_rows_before_limit :: UInt8 + , applied_aggregation :: UInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_ROWS_BEFORE_AGGREGATION + , rows_before_aggregation :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_ROWS_BEFORE_AGGREGATION + } + deriving (Generic, Deserializable) + +-- ** TableColumns + +data TableColumns = MkTableColumns + { table_name :: ChString + , table_columns :: ChString + } + deriving (Generic, Deserializable) + + + + + + + + +-- * Deserialization + +-- ** Generic API + +type GenericReadable record hasColumns = + ( Generic record + , GReadable (GetColumns hasColumns) (Rep record) + ) + +class HasColumns hasColumns => ReadableFrom hasColumns record + where + default deserializeColumns :: GenericReadable record hasColumns => ProtocolRevision -> UVarInt -> Get [record] + deserializeColumns :: ProtocolRevision -> UVarInt -> Get [record] + deserializeColumns rev size = do + list <- gFromColumns @(GetColumns hasColumns) rev size + pure $ do + element <- list + case to element of res -> pure $! res + + default readingColumns :: GenericReadable record hasColumns => Builder + readingColumns :: Builder + readingColumns + = maybe "" (uncurry (foldl (\a b -> a <> ", " <> b))) . uncons + . map fst + $ gReadingColumns @(GetColumns hasColumns) @(Rep record) + + default readingColumnsAndTypes :: GenericReadable record hasColumns => Builder + readingColumnsAndTypes :: Builder + readingColumnsAndTypes + = maybe "" (uncurry (foldl (\a b -> a <> ", " <> b))) . uncons + . map (\(colName, colType) -> colName <> " " <> colType) + $ gReadingColumns @(GetColumns hasColumns) @(Rep record) + + +class GReadable (columns :: [Type]) f + where + gFromColumns :: ProtocolRevision -> UVarInt -> Get [f p] + gReadingColumns :: [(Builder, Builder)] + +instance + GReadable columns f + => + GReadable columns (D1 c (C1 c2 f)) + where + {-# INLINE gFromColumns #-} + gFromColumns rev size = map (M1 . M1) <$> gFromColumns @columns rev size + gReadingColumns = gReadingColumns @columns @f + +instance + GReadable columns (left :*: (right1 :*: right2)) + => + GReadable columns ((left :*: right1) :*: right2) + where + {-# INLINE gFromColumns #-} + gFromColumns rev size = do + list <- gFromColumns @columns rev size + pure [(l :*: r1) :*: r2 | (l :*: (r1 :*: r2)) <- list] + gReadingColumns = gReadingColumns @columns @(left :*: (right1 :*: right2)) + +instance + ( KnownColumn (Column name chType) + , GReadable '[Column name chType] (S1 (MetaSel (Just name) a b f) rec) + , GReadable restColumns right + , '(Column name chType, restColumns) ~ TakeColumn name columns + ) + => + GReadable columns (S1 (MetaSel (Just name) a b f) rec :*: right) + where + {-# INLINE gFromColumns #-} + gFromColumns rev size = do + zipWith (:*:) + <$> gFromColumns @'[Column name chType] rev size + <*> gFromColumns @restColumns rev size + gReadingColumns = + (renderColumnName @(Column name chType), renderColumnType @(Column name chType)) + : gReadingColumns @restColumns @right + +instance + ( KnownColumn (Column name chType) + , DeserializableColumn (Column name chType) + , FromChType chType inputType + , '(Column name chType, restColumns) ~ TakeColumn name columns + ) => GReadable columns ((S1 (MetaSel (Just name) a b f)) (Rec0 inputType)) + where + {-# INLINE gFromColumns #-} + gFromColumns rev size = + map (M1 . K1 . fromChType @chType) . columnValues + <$> deserializeColumn @(Column name chType) rev True size + gReadingColumns = (renderColumnName @(Column name chType), renderColumnType @(Column name chType)) : [] + + +-- ** Column deserialization + +{-# SPECIALIZE replicateM :: Int -> Get chType -> Get [chType] #-} + +class DeserializableColumn column where + deserializeColumn :: ProtocolRevision -> Bool -> UVarInt -> Get column + +handleColumnHeader :: forall column . KnownColumn column => ProtocolRevision -> Bool -> Get () +handleColumnHeader rev isCheckRequired = do + let expectedColumnName = toChType (renderColumnName @column) + resultColumnName <- deserialize @ChString rev + when (isCheckRequired && resultColumnName /= expectedColumnName) + . throw . UserError . UnmatchedColumn + $ "Got column \"" <> show resultColumnName <> "\" but expected \"" <> show expectedColumnName <> "\"" + + let expectedType = toChType (renderColumnType @column) + resultType <- deserialize @ChString rev + when (isCheckRequired && resultType /= expectedType) + . throw . UserError . UnmatchedType + $ "Column " <> show resultColumnName <> " has type " <> show resultType <> ". But expected type is " <> show expectedType + +instance + ( KnownColumn (Column name chType) + , Deserializable chType + ) => + DeserializableColumn (Column name chType) where + {-# INLINE deserializeColumn #-} + deserializeColumn rev isCheckRequired rows = do + handleColumnHeader @(Column name chType) rev isCheckRequired + _isCustom <- deserialize @(UInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION) rev + column <- replicateM (fromIntegral rows) (deserialize @chType rev) + pure $ mkColumn @(Column name chType) column + +instance {-# OVERLAPPING #-} + ( KnownColumn (Column name (Nullable chType)) + , Deserializable chType + ) => + DeserializableColumn (Column name (Nullable chType)) where + {-# INLINE deserializeColumn #-} + deserializeColumn rev isCheckRequired rows = do + handleColumnHeader @(Column name (Nullable chType)) rev isCheckRequired + _isCustom <- deserialize @(UInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION) rev + nulls <- replicateM (fromIntegral rows) (deserialize @UInt8 rev) + nullable <- + forM + nulls + (\case + 0 -> Just <$> deserialize @chType rev + _ -> (Nothing <$ deserialize @chType rev) + ) + pure $ mkColumn @(Column name (Nullable chType)) nullable + +instance {-# OVERLAPPING #-} + ( KnownColumn (Column name (LowCardinality chType)) + , Deserializable chType + , IsLowCardinalitySupported chType + , TypeError ('Text "LowCardinality deserialization still unsupported") + ) => + DeserializableColumn (Column name (LowCardinality chType)) where + {-# INLINE deserializeColumn #-} + deserializeColumn rev isCheckRequired rows = do + handleColumnHeader @(Column name (LowCardinality chType)) rev isCheckRequired + _isCustom <- deserialize @(UInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION) rev + _serializationType <- (.&. 0xf) <$> deserialize @UInt64 rev + _index_size <- deserialize @Int64 rev + -- error $ "Trace | " <> show _serializationType <> " : " <> show _index_size + lc <- replicateM (fromIntegral rows) (toChType <$> deserialize @chType rev) + pure $ mkColumn @(Column name (LowCardinality chType)) lc + +instance {-# OVERLAPPING #-} + ( KnownColumn (Column name (Array chType)) + , Deserializable chType + , TypeError ('Text "Arrays deserialization still unsupported") + ) + => DeserializableColumn (Column name (Array chType)) where + {-# INLINE deserializeColumn #-} + deserializeColumn rev isCheckRequired _rows = do + handleColumnHeader @(Column name (Array chType)) rev isCheckRequired + _isCustom <- deserialize @(UInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION) rev + (arraySize, _offsets) <- readOffsets rev + _types <- replicateM (fromIntegral arraySize) (deserialize @chType rev) + pure $ mkColumn @(Column name (Array chType)) [] + where + readOffsets :: ProtocolRevision -> Get (UInt64, [UInt64]) + readOffsets revivion = do + size <- deserialize @UInt64 rev + (size, ) <$> go size + where + go arraySize = + do + nextOffset <- deserialize @UInt64 revivion + if arraySize >= nextOffset + then pure [nextOffset] + else (nextOffset :) <$> go arraySize + + +-- ** Generics + +class + Deserializable chType + where + {-# INLINE deserialize #-} + default deserialize :: (Generic chType, GDeserializable (Rep chType)) => ProtocolRevision -> Get chType + deserialize :: ProtocolRevision -> Get chType + deserialize rev = to <$> gDeserialize rev + +class GDeserializable f + where + gDeserialize :: ProtocolRevision -> Get (f p) + +instance + GDeserializable f + => + GDeserializable (D1 c (C1 c2 f)) + where + {-# INLINE gDeserialize #-} + gDeserialize rev = M1 . M1 <$> gDeserialize rev + +instance + GDeserializable (left :*: (right1 :*: right2)) + => + GDeserializable ((left :*: right1) :*: right2) + where + {-# INLINE gDeserialize #-} + gDeserialize rev = (\(l :*: (r1 :*: r2)) -> (l :*: r1) :*: r2) <$> gDeserialize rev + +instance + (GDeserializable (S1 metaSel field), GDeserializable right) + => + GDeserializable (S1 metaSel field :*: right) + where + {-# INLINE gDeserialize #-} + gDeserialize rev = (:*:) <$> gDeserialize rev <*> gDeserialize rev + +instance {-# OVERLAPPING #-} + (GDeserializable right) + => + (GDeserializable (S1 metaSel (Rec0 ProtocolRevision) :*: right)) + where + {-# INLINE gDeserialize #-} + gDeserialize rev = do + chosenRev <- min rev . coerce <$> deserialize @UVarInt rev + (:*:) (M1 $ K1 chosenRev) <$> gDeserialize @right chosenRev + +instance + Deserializable chType + => + GDeserializable (S1 (MetaSel (Just typeName) a b f) (Rec0 chType)) + where + {-# INLINE gDeserialize #-} + gDeserialize rev = M1 . K1 <$> deserialize @chType rev + + +-- ** Database types + +instance Deserializable Int8 where deserialize _ = toChType <$> getInt8; {-# INLINE deserialize #-} +instance Deserializable Int16 where deserialize _ = toChType <$> getInt16le; {-# INLINE deserialize #-} +instance Deserializable Int32 where deserialize _ = toChType <$> getInt32le; {-# INLINE deserialize #-} +instance Deserializable Int64 where deserialize _ = toChType <$> getInt64le; {-# INLINE deserialize #-} +instance Deserializable Int128 where deserialize _ = toChType <$> (flip Int128 <$> getWord64le <*> getWord64le); {-# INLINE deserialize #-} +instance Deserializable UInt8 where deserialize _ = toChType <$> getWord8; {-# INLINE deserialize #-} +instance Deserializable UInt16 where deserialize _ = toChType <$> getWord16le; {-# INLINE deserialize #-} +instance Deserializable UInt32 where deserialize _ = toChType <$> getWord32le; {-# INLINE deserialize #-} +instance Deserializable UInt64 where deserialize _ = toChType <$> getWord64le; {-# INLINE deserialize #-} +instance Deserializable UInt128 where deserialize _ = toChType <$> (flip Word128 <$> getWord64le <*> getWord64le); {-# INLINE deserialize #-} +instance Deserializable UUID where deserialize _ = MkChUUID <$!> (flip Word128 <$> getWord64le <*> getWord64le); {-# INLINE deserialize #-} +instance Deserializable ChString where deserialize = (\n -> toChType <$> readN n (BS.take n)) . fromIntegral <=< deserialize @UVarInt; {-# INLINE deserialize #-} +instance Deserializable Date where deserialize _ = toChType <$> getWord16le; {-# INLINE deserialize #-} +instance Deserializable (DateTime tz) where deserialize _ = toChType <$> getWord32le; {-# INLINE deserialize #-} +instance Deserializable UVarInt where + {-# INLINE deserialize #-} + deserialize _ = go 0 (0 :: UVarInt) + where + go i o | i < 10 = do + byte <- getWord8 + let o' = o .|. ((fromIntegral byte .&. 0x7f) `unsafeShiftL` (7 * i)) + if byte .&. 0x80 == 0 then pure $! o' else go (i + 1) $! o' + go _ _ = fail "input exceeds varuint size" + +-- ** FromChType + +class FromChType chType outputType where fromChType :: chType -> outputType + +instance FromChType UUID (Word64, Word64) where fromChType (MkChUUID (Word128 w64hi w64lo)) = (w64hi, w64lo) +instance {-# OVERLAPPABLE #-} (IsChType chType, chType ~ inputType) => FromChType chType inputType where fromChType = id +instance FromChType (DateTime tz) Word32 where fromChType = coerce +instance FromChType (DateTime tz) UTCTime where fromChType (MkDateTime w32) = posixSecondsToUTCTime (fromIntegral w32) +instance + FromChType chType inputType + => + FromChType (Nullable chType) (Nullable inputType) + where + fromChType = fmap (fromChType @chType) +instance FromChType chType (LowCardinality chType) where + fromChType = MkLowCardinality +instance FromChType Date Word16 where fromChType = coerce +instance + FromChType chType outputType + => + FromChType (LowCardinality chType) outputType + where + fromChType (MkLowCardinality value) = fromChType value +instance FromChType ChString StrictByteString where fromChType (MkChString string) = string +instance FromChType ChString Builder where fromChType (MkChString string) = byteString string +instance + ( TypeError + ( 'Text "ChString to Text using FromChType convertion could cause exception" + ':$$: 'Text "Decode ByteString manually if you are sure it's always can be decoded or replace it with ByteString" + ) + ) => + FromChType ChString Text + where + fromChType = error "Unreachable" +instance FromChType chType inputType => FromChType (Array chType) [inputType] + where + fromChType (MkChArray values) = map fromChType values + + + + + + + + +-- * Columns + +-- ** Columns extraction helper + +class HasColumns hasColumns where type GetColumns hasColumns :: [Type] +instance HasColumns (Columns columns) where type GetColumns (Columns columns) = columns +instance HasColumns (Table name columns) where type GetColumns (Table _ columns) = columns +instance HasColumns (View name columns params) where type GetColumns (View _ columns _) = columns + + +-- ** Take column by name from list of columns + +type family + TakeColumn (name :: Symbol) (columns :: [Type]) :: (Type, [Type]) + where + TakeColumn name columns = GoTakeColumn name columns '[] + +type family + GoTakeColumn name (columns :: [Type]) (acc :: [Type]) :: (Type, [Type]) + where + GoTakeColumn name (Column name chType ': columns) acc = '(Column name chType, acc ++ columns) + 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" + ) + +type family + (++) (list1 :: [Type]) (list2 :: [Type]) :: [Type] + where + (++) '[] list = list + (++) (head ': tail) list = tail ++ (head ': list) + + +data Columns (columns :: [Type]) where + Empty :: Columns '[] + AddColumn + :: KnownColumn (Column name chType) + => Column name chType + -> Columns columns + -> Columns (Column name chType ': columns) + +{- | +Column declaration + +For example: + +@ +type MyColumn = Column "myColumn" ChString +@ +-} +data Column (name :: Symbol) (chType :: Type) where + UInt8Column :: [UInt8] -> Column name UInt8; Int8Column :: [Int8] -> Column name Int8 + UInt16Column :: [UInt16] -> Column name UInt16; Int16Column :: [Int16] -> Column name Int16 + UInt32Column :: [UInt32] -> Column name UInt32; Int32Column :: [Int32] -> Column name Int32 + UInt64Column :: [UInt64] -> Column name UInt64; Int64Column :: [Int64] -> Column name Int64 + UInt128Column :: [UInt128] -> Column name UInt128; Int128Column :: [Int128] -> Column name Int128 + DateTimeColumn :: [DateTime tz] -> Column name (DateTime tz) + DateColumn :: [Date] -> Column name Date + UUIDColumn :: [UUID] -> Column name UUID + StringColumn :: [ChString] -> Column name ChString + ArrayColumn :: [Array chType] -> Column name (Array chType) + NullableColumn :: [Nullable chType] -> Column name (Nullable chType) + LowCardinalityColumn :: IsLowCardinalitySupported chType => [chType] -> Column name (LowCardinality chType) + +type family GetColumnName column :: Symbol where GetColumnName (Column name columnType) = name +type family GetColumnType column :: Type where GetColumnType (Column name columnType) = columnType + +{-# INLINE [0] columnValues #-} +columnValues :: Column name chType -> [chType] +columnValues column = case column of + (UInt8Column values) -> values; (UInt16Column values) -> values + (UInt32Column values) -> values; (UInt64Column values) -> values + (UInt128Column values) -> values; (Int8Column values) -> values + (Int16Column values) -> values; (Int32Column values) -> values + (Int64Column values) -> values; (Int128Column values) -> values + (DateColumn values) -> values; (DateTimeColumn values) -> values + (UUIDColumn values) -> values; (StringColumn values) -> values + (ArrayColumn values) -> values; (NullableColumn values) -> values + (LowCardinalityColumn values) -> map fromChType values + +class + ( IsChType (GetColumnType column) + , KnownSymbol (GetColumnName column) + ) => + KnownColumn column where + renderColumnName :: Builder + renderColumnName = (stringUtf8 . symbolVal @(GetColumnName column)) Proxy + + renderColumnType :: Builder + renderColumnType = chTypeName @(GetColumnType column) + + mkColumn :: [GetColumnType column] -> Column (GetColumnName column) (GetColumnType column) + +instance KnownSymbol name => KnownColumn (Column name UInt8) where mkColumn = UInt8Column +instance KnownSymbol name => KnownColumn (Column name UInt16) where mkColumn = UInt16Column +instance KnownSymbol name => KnownColumn (Column name UInt32) where mkColumn = UInt32Column +instance KnownSymbol name => KnownColumn (Column name UInt64) where mkColumn = UInt64Column +instance KnownSymbol name => KnownColumn (Column name UInt128) where mkColumn = UInt128Column +instance KnownSymbol name => KnownColumn (Column name Int8) where mkColumn = Int8Column +instance KnownSymbol name => KnownColumn (Column name Int16) where mkColumn = Int16Column +instance KnownSymbol name => KnownColumn (Column name Int32) where mkColumn = Int32Column +instance KnownSymbol name => KnownColumn (Column name Int64) where mkColumn = Int64Column +instance KnownSymbol name => KnownColumn (Column name Int128) where mkColumn = Int128Column +instance KnownSymbol name => KnownColumn (Column name Date) where mkColumn = DateColumn +instance + ( KnownSymbol name + , IsChType (DateTime tz) + ) => + KnownColumn (Column name (DateTime tz)) where mkColumn = DateTimeColumn +instance KnownSymbol name => KnownColumn (Column name UUID) where mkColumn = UUIDColumn +instance + ( KnownSymbol name + , IsChType chType + , IsChType (Nullable chType) + ) => + KnownColumn (Column name (Nullable chType)) where mkColumn = NullableColumn +instance KnownSymbol name => KnownColumn (Column name ChString) where mkColumn = StringColumn +instance + ( KnownSymbol name + , IsChType (LowCardinality chType) + , IsLowCardinalitySupported chType + ) => + KnownColumn (Column name (LowCardinality chType)) where mkColumn = LowCardinalityColumn . map fromChType +instance KnownSymbol name => KnownColumn (Column name (Array ChString)) where mkColumn = ArrayColumn + + +-- ** Columns + +instance + Serializable (Columns '[]) + where + {-# INLINE serialize #-} + serialize _rev Empty = "" + +instance (Serializable (Columns columns), Serializable col) + => + Serializable (Columns (col ': columns)) + where + {-# INLINE serialize #-} + serialize rev (AddColumn col columns) = serialize rev col <> serialize rev columns + +instance (KnownColumn (Column name chType), Serializable chType) + => + Serializable (Column name chType) where + {-# INLINE serialize #-} + serialize rev column + = serialize rev (toChType @ChString $ renderColumnName @(Column name chType)) + <> serialize rev (toChType @ChString $ renderColumnType @(Column name chType)) + -- serialization is not custom + <> afterRevision @DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION rev (serialize @UInt8 rev 0) + <> mconcat (Prelude.map (serialize @chType rev) (columnValues column)) + +instance {-# OVERLAPPING #-} + ( KnownColumn (Column name (Nullable chType)) + , IsChType chType + , Serializable chType + ) => Serializable (Column name (Nullable chType)) where + {-# INLINE serialize #-} + serialize rev column + = serialize rev (toChType @ChString $ renderColumnName @(Column name (Nullable chType))) + <> serialize rev (toChType @ChString $ renderColumnType @(Column name (Nullable chType))) + -- serialization is not custom + <> afterRevision @DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION rev (serialize @UInt8 rev 0) + -- Nulls + <> mconcat (Prelude.map (serialize @UInt8 rev . maybe 1 (const 0)) (columnValues column)) + -- Values + <> mconcat (Prelude.map (serialize @chType rev . maybe defaultValueOfTypeName id) (columnValues column)) + +instance {-# OVERLAPPING #-} + ( KnownColumn (Column name (Nullable chType)) + , IsChType chType + , Serializable chType + , TypeError ('Text "LowCardinality serialization still unsupported") + ) => Serializable (Column name (LowCardinality chType)) where + {-# INLINE serialize #-} + serialize rev (LowCardinalityColumn column) + = serialize rev (toChType @ChString $ renderColumnName @(Column name (Nullable chType))) + <> serialize rev (toChType @ChString $ renderColumnType @(Column name (Nullable chType))) + -- serialization is not custom + <> afterRevision @DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION rev (serialize @UInt8 rev 0) + <> undefined column + + + + + + + + +-- * Parameters + +type family KnownParameter param + where + KnownParameter (Parameter name parType) = (KnownSymbol name, IsChType parType, ToQueryPart parType) + +data Parameter (name :: Symbol) (chType :: Type) = MkParamater chType + +data Parameters parameters where + NoParameters :: Parameters '[] + AddParameter + :: KnownParameter (Parameter name chType) + => Parameter name chType + -> Parameters parameters + -> Parameters (Parameter name chType ': parameters) + +{- | +>>> viewParameters (parameter @"a3" @ChString ("a3Val" :: String) . parameter @"a2" @ChString ("a2Val" :: String)) +"(a3='a3Val', a2='a2Val')" +-} +viewParameters :: (Parameters '[] -> Parameters passedParameters) -> Builder +viewParameters interpreter = "(" <> renderParameters (interpreter NoParameters) <> ")" + +renderParameters :: Parameters params -> Builder +renderParameters NoParameters = "" +renderParameters (AddParameter param NoParameters) = renderParameter param +renderParameters (AddParameter param moreParams) = renderParameter param <> ", " <> renderParameters moreParams + + +parameter + :: forall name chType parameters userType + . (ToChType chType userType, KnownParameter (Parameter name chType)) + => userType -> Parameters parameters -> Parameters (Parameter name chType ': parameters) +parameter val = AddParameter (MkParamater $ toChType val) + +renderParameter :: forall name chType . KnownParameter (Parameter name chType) => Parameter name chType -> Builder +renderParameter (MkParamater chType) = (byteString . BS8.pack . symbolVal @name) Proxy <> "=" <> toQueryPart chType + +type family CheckParameters (required :: [Type]) (passed :: [Type]) :: Constraint + where + CheckParameters required passed = GoCheckParameters required passed '[] + +type family GoCheckParameters required passed acc :: Constraint + where + GoCheckParameters '[] '[] '[] = () + GoCheckParameters (Parameter name _ ': _) '[] '[] = TypeError ('Text "Missing parameter \"" :<>: 'Text name :<>: 'Text "\".") + GoCheckParameters '[] (p ': _) _ = TypeError ('Text "More parameters passed than used in the view") + GoCheckParameters '[] '[] (p ': _) = TypeError ('Text "More parameters passed than used in the view") + GoCheckParameters (Parameter name1 _ ': ps) '[] (Parameter name2 _ ': ps') = TypeError ('Text "Missing \"" :<>: 'Text name1 :<>: 'Text "\" in passed parameters") + GoCheckParameters (p ': ps) '[] (p' ': ps') = GoCheckParameters (p ': ps) (p' ': ps') '[] + GoCheckParameters (Parameter name1 _ ': ps) (Parameter name1 _ ': ps') acc = (GoCheckParameters ps ps' acc) + GoCheckParameters (Parameter name1 chType1 ': ps) (Parameter name2 chType2 ': ps') acc + = (GoCheckParameters (Parameter name1 chType1 ': ps) ps' (Parameter name2 chType2 ': acc)) + +class ToQueryPart chType where toQueryPart :: chType -> BS.Builder +instance ToQueryPart Int8 where toQueryPart = BS.byteString . BS8.pack . show +instance ToQueryPart Int16 where toQueryPart = BS.byteString . BS8.pack . show +instance ToQueryPart Int32 where toQueryPart = BS.byteString . BS8.pack . show +instance ToQueryPart Int64 where toQueryPart = BS.byteString . BS8.pack . show +instance ToQueryPart Int128 where toQueryPart = BS.byteString . BS8.pack . show +instance ToQueryPart UInt8 where toQueryPart = BS.byteString . BS8.pack . show +instance ToQueryPart UInt16 where toQueryPart = BS.byteString . BS8.pack . show +instance ToQueryPart UInt32 where toQueryPart = BS.byteString . BS8.pack . show +instance ToQueryPart UInt64 where toQueryPart = BS.byteString . BS8.pack . show +instance ToQueryPart UInt128 where toQueryPart = BS.byteString . BS8.pack . show +instance ToQueryPart chType => ToQueryPart (Nullable chType) + where + toQueryPart = maybe "null" toQueryPart +instance ToQueryPart chType => ToQueryPart (LowCardinality chType) + where + toQueryPart (MkLowCardinality chType) = toQueryPart chType +instance ToQueryPart UUID where + toQueryPart (MkChUUID (Word128 hi lo)) = mconcat + ["'", p 3 hi, p 2 hi, "-", p 1 hi, "-", p 0 hi, "-", p 3 lo, "-", p 2 lo, p 1 lo, p 0 lo, "'"] + where + p :: Int -> Word64 -> Builder + p shiftN word = word16HexFixed $ fromIntegral (word `unsafeShiftR` (shiftN*16)) +instance ToQueryPart ChString where + toQueryPart (MkChString string) = "'" <> escapeQuery string <> "'" + where + escapeQuery :: StrictByteString -> Builder + escapeQuery -- [ClickHaskell.DbTypes.ToDo.1]: Optimize + = BS.byteString . BS8.concatMap (\case '\'' -> "\\\'"; '\\' -> "\\\\"; sym -> BS8.singleton sym;) +instance ToQueryPart (DateTime tz) + where + toQueryPart chDateTime = let time = BS8.pack . show . fromChType @(DateTime tz) @Word32 $ chDateTime + in BS.byteString (BS8.replicate (10 - BS8.length time) '0' <> time) +instance (IsChType chType, ToQueryPart chType) => ToQueryPart (Array chType) + where + toQueryPart + = (\x -> "[" <> x <> "]") + . (maybe "" (uncurry (foldr (\a b -> a <> "," <> b))) . uncons + . map (toQueryPart @chType)) . fromChType @(Array chType) @[chType] + + + + + + + + +-- * Serialization + +-- *** Generic API + +type GenericWritable record columns = + ( Generic record + , GWritable columns (Rep record) + ) + +class + ( HasColumns (Columns (GetColumns columns)) + , Serializable (Columns (GetColumns columns)) + ) => + WritableInto columns record + where + default deserializeInsertHeader :: GenericWritable record (GetColumns columns) => ProtocolRevision -> Get () + deserializeInsertHeader :: ProtocolRevision -> Get () + deserializeInsertHeader rev = gDeserializeInsertHeader @(GetColumns columns) @(Rep record) rev + + default serializeRecords :: GenericWritable record (GetColumns columns) => [record] -> ProtocolRevision -> Builder + serializeRecords :: [record] -> ProtocolRevision -> Builder + serializeRecords records rev = gSerializeRecords @(GetColumns columns) rev (map from records) + + default writingColumns :: GenericWritable record (GetColumns columns) => Builder + writingColumns :: Builder + writingColumns = gWritingColumns @(GetColumns columns) @(Rep record) + + default columnsCount :: GenericWritable record (GetColumns columns) => UVarInt + columnsCount :: UVarInt + columnsCount = gColumnsCount @(GetColumns columns) @(Rep record) + +class GWritable (columns :: [Type]) f + where + gDeserializeInsertHeader :: ProtocolRevision -> Get () + gSerializeRecords :: ProtocolRevision -> [f p] -> Builder + gWritingColumns :: Builder + gColumnsCount :: UVarInt + +instance + GWritable columns f + => + GWritable columns (D1 c (C1 c2 f)) + where + {-# INLINE gSerializeRecords #-} + gSerializeRecords rev = gSerializeRecords @columns rev . map (unM1 . unM1) + gDeserializeInsertHeader rev = gDeserializeInsertHeader @columns @f rev + gWritingColumns = gWritingColumns @columns @f + gColumnsCount = gColumnsCount @columns @f + +instance + GWritable columns (left1 :*: (left2 :*: right)) + => + GWritable columns ((left1 :*: left2) :*: right) + where + {-# INLINE gSerializeRecords #-} + gSerializeRecords rev = gSerializeRecords @columns rev . map (\((l1 :*: l2) :*: r) -> l1 :*: (l2 :*: r)) + gDeserializeInsertHeader rev = void $ gDeserializeInsertHeader @columns @(left1 :*: (left2 :*: right)) rev + gWritingColumns = gWritingColumns @columns @(left1 :*: (left2 :*: right)) + gColumnsCount = gColumnsCount @columns @(left1 :*: (left2 :*: right)) + +instance + ( GWritable '[Column name chType] (S1 (MetaSel (Just name) a b f) rec) + , GWritable restColumns right + , '(Column name chType, restColumns)~ TakeColumn name columns + ) + => + GWritable columns (S1 (MetaSel (Just name) a b f) rec :*: right) + where + {-# INLINE gSerializeRecords #-} + gSerializeRecords rev + = (\(a, b) -> gSerializeRecords @'[Column name chType] rev a <> gSerializeRecords @restColumns rev b) + . unzip . map (\(l :*: r) -> (l, r)) + gDeserializeInsertHeader rev = do + gDeserializeInsertHeader @'[Column name chType] @(S1 (MetaSel (Just name) a b f) rec) rev + gDeserializeInsertHeader @restColumns @right rev + gWritingColumns = + gWritingColumns @'[Column name chType] @(S1 (MetaSel (Just name) a b f) rec) + <> ", " <> gWritingColumns @restColumns @right + gColumnsCount = gColumnsCount @'[Column name chType] @(S1 (MetaSel (Just name) a b f) rec) + gColumnsCount @restColumns @right + +instance {-# OVERLAPPING #-} + ( KnownColumn (Column name chType) + , ToChType chType inputType + , Serializable (Column name chType) + , DeserializableColumn (Column name chType) + , '(Column name chType, restColumns) ~ TakeColumn name columns + ) => + GWritable columns (S1 (MetaSel (Just name) a b f) (Rec0 inputType)) + where + {-# INLINE gSerializeRecords #-} + gSerializeRecords rev = serialize rev . mkColumn @(Column name chType) . map (toChType . unK1 . unM1) + gDeserializeInsertHeader rev = void $ deserializeColumn @(Column name chType) rev False 0 + gWritingColumns = renderColumnName @(Column name chType) + gColumnsCount = 1 + +class Serializable chType + where + default serialize :: (Generic chType, GSerializable (Rep chType)) => ProtocolRevision -> chType -> Builder + serialize :: ProtocolRevision -> chType -> Builder + serialize rev = gSerialize rev . from + +instance Serializable UVarInt where + serialize _ = go + where + go i + | i < 0x80 = word8 (fromIntegral i) + | otherwise = word8 (setBit (fromIntegral i) 7) <> go (i `unsafeShiftR` 7) +instance Serializable ChString where + serialize rev str = (serialize @UVarInt rev . fromIntegral . BS.length . fromChType) str <> fromChType str +instance Serializable UUID where serialize _ = (\(hi, lo) -> word64LE lo <> word64LE hi) . fromChType +instance Serializable Int8 where serialize _ = int8 . fromChType +instance Serializable Int16 where serialize _ = int16LE . fromChType +instance Serializable Int32 where serialize _ = int32LE . fromChType +instance Serializable Int64 where serialize _ = int64LE . fromChType +instance Serializable Int128 where serialize _ = (\(Int128 hi lo) -> word64LE lo <> word64LE hi) . fromChType +instance Serializable UInt8 where serialize _ = word8 . fromChType +instance Serializable UInt16 where serialize _ = word16LE . fromChType +instance Serializable UInt32 where serialize _ = word32LE . fromChType +instance Serializable UInt64 where serialize _ = word64LE . fromChType +instance Serializable UInt128 where serialize _ = (\(Word128 hi lo) -> word64LE lo <> word64LE hi) . fromChType +instance Serializable (DateTime tz) where serialize _ = word32LE . fromChType +instance Serializable Date where serialize _ = word16LE . fromChType + + +-- ** Generics + +class GSerializable f + where + gSerialize :: ProtocolRevision -> f p -> Builder + +instance + GSerializable f + => + GSerializable (D1 c (C1 c2 f)) + where + {-# INLINE gSerialize #-} + gSerialize rev (M1 (M1 re)) = gSerialize rev re + +instance + GSerializable (left1 :*: (left2 :*: right)) + => + GSerializable ((left1 :*: left2) :*: right) + where + {-# INLINE gSerialize #-} + gSerialize rev ((l1 :*: l2) :*: r) = gSerialize rev (l1 :*: (l2 :*: r)) + +instance + Serializable chType + => + GSerializable (S1 (MetaSel (Just typeName) a b f) (Rec0 chType)) + where + {-# INLINE gSerialize #-} + gSerialize rev = serialize rev . unK1 . unM1 + +instance + (Serializable chType, GSerializable right) + => + GSerializable (S1 (MetaSel (Just typeName) a b f) (Rec0 chType) :*: right) + where + {-# INLINE gSerialize #-} + gSerialize rev (left :*: right) + = (serialize rev . unK1 . unM1 $ left) <> gSerialize rev right + +-- ** ToChType + +class ToChType chType inputType where toChType :: inputType -> chType + +instance {-# OVERLAPPABLE #-} (IsChType chType, chType ~ inputType) => ToChType chType inputType where toChType = id +instance ToChType Int64 Int where toChType = fromIntegral +instance ToChType UInt128 UInt64 where toChType = fromIntegral +instance ToChType ChString StrictByteString where toChType = MkChString +instance ToChType ChString Builder where toChType = MkChString . toStrict . toLazyByteString +instance ToChType ChString String where toChType = MkChString . BS8.pack +instance ToChType ChString Text where toChType = MkChString . Text.encodeUtf8 +instance ToChType ChString Int where toChType = MkChString . BS8.pack . show +instance + ToChType inputType chType + => + ToChType (Nullable inputType) (Nullable chType) + where + toChType = fmap (toChType @inputType @chType) +instance ToChType inputType chType => ToChType (LowCardinality inputType) chType where toChType = MkLowCardinality . toChType +instance ToChType UUID Word64 where toChType = MkChUUID . flip Word128 0 +instance ToChType UUID (Word64, Word64) where toChType = MkChUUID . uncurry (flip Word128) +instance ToChType (DateTime tz) Word32 where toChType = MkDateTime +instance ToChType (DateTime tz) UTCTime where toChType = MkDateTime . floor . utcTimeToPOSIXSeconds +instance ToChType (DateTime tz) ZonedTime where toChType = MkDateTime . floor . utcTimeToPOSIXSeconds . zonedTimeToUTC +instance ToChType Date Word16 where toChType = MkChDate +instance ToChType chType inputType => ToChType (Array chType) [inputType] + where + toChType = MkChArray . map toChType + + + + + + + + +class + KnownSymbol (ToChTypeName chType) + => + IsChType chType + where + -- | Shows database original type name + -- + -- @ + -- type ToChTypeName ChString = \"String\" + -- type ToChTypeName (Nullable UInt32) = \"Nullable(UInt32)\" + -- @ + type ToChTypeName chType :: Symbol + + chTypeName :: Builder + chTypeName = byteString . BS8.pack . symbolVal @(ToChTypeName chType) $ Proxy + + defaultValueOfTypeName :: chType + +instance IsChType Int8 where + type ToChTypeName Int8 = "Int8" + defaultValueOfTypeName = 0 + +instance IsChType Int16 where + type ToChTypeName Int16 = "Int16" + defaultValueOfTypeName = 0 + +instance IsChType Int32 where + type ToChTypeName Int32 = "Int32" + defaultValueOfTypeName = 0 + +instance IsChType Int64 where + type ToChTypeName Int64 = "Int64" + defaultValueOfTypeName = 0 + +instance IsChType Int128 where + type ToChTypeName Int128 = "Int128" + defaultValueOfTypeName = 0 +-- | ClickHouse UInt8 column type +type UInt8 = Word8 +instance IsChType UInt8 where + type ToChTypeName UInt8 = "UInt8" + defaultValueOfTypeName = 0 + +-- | ClickHouse UInt16 column type +type UInt16 = Word16 +instance IsChType UInt16 where + type ToChTypeName UInt16 = "UInt16" + defaultValueOfTypeName = 0 + +-- | ClickHouse UInt32 column type +type UInt32 = Word32 +instance IsChType UInt32 where + type ToChTypeName UInt32 = "UInt32" + defaultValueOfTypeName = 0 + +-- | ClickHouse UInt64 column type +type UInt64 = Word64 +instance IsChType UInt64 where + type ToChTypeName UInt64 = "UInt64" + defaultValueOfTypeName = 0 + +-- | ClickHouse UInt128 column type +type UInt128 = Word128 +instance IsChType UInt128 where + type ToChTypeName UInt128 = "UInt128" + defaultValueOfTypeName = 0 + +-- | ClickHouse UUID column type +newtype UUID = MkChUUID Word128 + deriving newtype (Generic, Show, Eq, NFData, Bounded, Enum) +instance IsChType UUID where + type ToChTypeName UUID = "UUID" + defaultValueOfTypeName = MkChUUID 0 + +{- | +ClickHouse DateTime column type (paramtrized with timezone) + +>>> chTypeName @(DateTime "") +"DateTime" +>>> chTypeName @(DateTime "UTC") +"DateTime('UTC')" +-} +newtype DateTime (tz :: Symbol) = MkDateTime Word32 + deriving newtype (Show, Eq, Num, Bits, Enum, Ord, Real, Integral, Bounded, NFData) + +instance KnownSymbol (ToChTypeName (DateTime tz)) => IsChType (DateTime tz) + where + type ToChTypeName (DateTime tz) = If (tz == "") ("DateTime") ("DateTime('" `AppendSymbol` tz `AppendSymbol` "')") + defaultValueOfTypeName = MkDateTime 0 + +-- | ClickHouse String column type +newtype ChString = MkChString StrictByteString + deriving newtype (Show, Eq, IsString, NFData) +instance IsChType ChString where + type ToChTypeName ChString = "String" + defaultValueOfTypeName = "" + +-- | ClickHouse Date column type +newtype Date = MkChDate Word16 + deriving newtype (Show, Eq, Bits, Bounded, Enum, NFData) +instance IsChType Date where + type ToChTypeName Date = "Date" + defaultValueOfTypeName = MkChDate 0 + +-- | ClickHouse Array column type +newtype Array a = MkChArray [a] + deriving newtype (Show, Eq, NFData) +instance + KnownSymbol (AppendSymbol (AppendSymbol "Array(" (ToChTypeName chType)) ")") + => + IsChType (Array chType) + where + type ToChTypeName (Array chType) = "Array(" `AppendSymbol` ToChTypeName chType `AppendSymbol` ")" + defaultValueOfTypeName = MkChArray [] + + +type ChUInt8 = UInt8 ;{-# DEPRECATED ChUInt8 "Ch prefixed types are deprecated. Use UInt8 instead" #-} +type ChUInt16 = UInt16 ;{-# DEPRECATED ChUInt16 "Ch prefixed types are deprecated. Use UInt16 instead" #-} +type ChUInt32 = UInt32 ;{-# DEPRECATED ChUInt32 "Ch prefixed types are deprecated. Use UInt32 instead" #-} +type ChUInt64 = UInt64 ;{-# DEPRECATED ChUInt64 "Ch prefixed types are deprecated. Use UInt64 instead" #-} +type ChUInt128 = UInt128 ;{-# DEPRECATED ChUInt128 "Ch prefixed types are deprecated. Use UInt128 instead" #-} +type ChInt8 = Int8 ;{-# DEPRECATED ChInt8 "Ch prefixed types are deprecated. Use Int8 instead" #-} +type ChInt16 = Int16 ;{-# DEPRECATED ChInt16 "Ch prefixed types are deprecated. Use Int16 instead" #-} +type ChInt32 = Int32 ;{-# DEPRECATED ChInt32 "Ch prefixed types are deprecated. Use Int32 instead" #-} +type ChInt64 = Int64 ;{-# DEPRECATED ChInt64 "Ch prefixed types are deprecated. Use Int64 instead" #-} +type ChInt128 = Int128 ;{-# DEPRECATED ChInt128 "Ch prefixed types are deprecated. Use Int128 instead" #-} +type ChDateTime = DateTime ;{-# DEPRECATED ChDateTime "Ch prefixed types are deprecated. Use DateTime instead" #-} +type ChDate = Date ;{-# DEPRECATED ChDate "Ch prefixed types are deprecated. Use Date instead" #-} +type ChUUID = UUID ;{-# DEPRECATED ChUUID "Ch prefixed types are deprecated. Use UUID instead" #-} +type ChArray = Array ;{-# DEPRECATED ChArray "Ch prefixed types are deprecated. Use Array instead" #-} + + +-- | ClickHouse Nullable(T) column type +-- (type synonym for Maybe) +type Nullable = Maybe + +type NullableTypeName chType = "Nullable(" `AppendSymbol` ToChTypeName chType `AppendSymbol` ")" + +instance + ( IsChType chType + , KnownSymbol ("Nullable(" `AppendSymbol` ToChTypeName chType `AppendSymbol` ")") + ) + => + IsChType (Nullable chType) + where + type ToChTypeName (Nullable chType) = NullableTypeName chType + defaultValueOfTypeName = Nothing + + +-- | ClickHouse LowCardinality(T) column type +newtype LowCardinality chType = MkLowCardinality chType +instance + ( IsLowCardinalitySupported chType + , KnownSymbol ("LowCardinality(" `AppendSymbol` ToChTypeName chType `AppendSymbol` ")") + ) => + IsChType (LowCardinality chType) + where + type ToChTypeName (LowCardinality chType) = "LowCardinality(" `AppendSymbol` ToChTypeName chType `AppendSymbol` ")" + defaultValueOfTypeName = MkLowCardinality $ defaultValueOfTypeName @chType + +deriving newtype instance (Eq chType, IsLowCardinalitySupported chType) => Eq (LowCardinality chType) +deriving newtype instance (NFData chType, IsLowCardinalitySupported chType) => NFData (LowCardinality chType) +deriving newtype instance IsString (LowCardinality ChString) + +class IsChType chType => IsLowCardinalitySupported chType +instance IsLowCardinalitySupported ChString +instance + ( IsLowCardinalitySupported chType + , IsChType (Nullable chType) + ) => + IsLowCardinalitySupported (Nullable chType) + +instance {-# OVERLAPPABLE #-} + ( IsChType chType + , TypeError + ( 'Text "LowCardinality(" ':<>: 'ShowType chType ':<>: 'Text ") is unsupported" + ':$$: 'Text "Use one of these types:" + ':$$: 'Text " ChString" + ':$$: 'Text " DateTime" + ':$$: 'Text " Nullable(T)" + ) + ) => IsLowCardinalitySupported chType + + + + +{- | + Unsigned variable-length quantity encoding + + Part of protocol implementation +-} +newtype UVarInt = MkUVarInt Word64 + deriving newtype (Show, Eq, Num, Bits, Enum, Ord, Real, Integral, Bounded, NFData) + + + + + + + + +-- * Versioning + +client_version_major, client_version_minor :: UVarInt +client_version_patch :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_VERSION_PATCH +client_version_major = case versionBranch version of (x:_) -> fromIntegral x; _ -> 0 +client_version_minor = case versionBranch version of (_:x:_) -> fromIntegral x; _ -> 0 +client_version_patch = MkSinceRevision $ case versionBranch version of (_:_:x:_) -> fromIntegral x; _ -> 0 + +client_name :: ChString +client_name = fromString $ + "ClickHaskell-" + <> show client_version_major <> "." + <> show client_version_minor <> "." + <> show client_version_patch + +newtype ProtocolRevision = MkProtocolRevision Word64 + deriving newtype (Eq, Num, Ord) + +instance Serializable ProtocolRevision where serialize rev = serialize @UVarInt rev . coerce + +{-# INLINE [0] afterRevision #-} +afterRevision + :: forall revision monoid + . (KnownNat revision, Monoid monoid) + => ProtocolRevision -> monoid -> monoid +afterRevision chosenRevision monoid = + if chosenRevision >= (fromIntegral . natVal) (Proxy @revision) + then monoid + else mempty + +latestSupportedRevision :: ProtocolRevision +latestSupportedRevision = (fromIntegral . natVal) (Proxy @DBMS_TCP_PROTOCOL_VERSION) + +data SinceRevision a (revisionNumber :: Nat) = MkSinceRevision a | NotPresented +instance Show a => Show (SinceRevision a revisionNumber) where + show (MkSinceRevision a) = show a + show NotPresented = "" + +instance + (KnownNat revision, Deserializable chType) + => + Deserializable (SinceRevision chType revision) + where + deserialize rev = + if rev >= (fromIntegral . natVal) (Proxy @revision) + then MkSinceRevision <$> deserialize @chType rev + else pure NotPresented + +instance + (KnownNat revision, Serializable chType) + => + Serializable (SinceRevision chType revision) + where + serialize rev (MkSinceRevision val) = afterRevision @revision rev (serialize rev val) + serialize rev NotPresented = afterRevision @revision rev (error "Unexpected error") + + +{- + Slightly modified C++ sources: + https://github.com/ClickHouse/ClickHouse/blob/eb4a74d7412a1fcf52727cd8b00b365d6b9ed86c/src/Core/ProtocolDefines.h#L6 +-} +type DBMS_TCP_PROTOCOL_VERSION = 54448; + +type DBMS_MIN_REVISION_WITH_CLIENT_INFO = 54032; +type DBMS_MIN_REVISION_WITH_SERVER_TIMEZONE = 54058; +type DBMS_MIN_REVISION_WITH_QUOTA_KEY_IN_CLIENT_INFO = 54060; +--type DBMS_MIN_REVISION_WITH_TABLES_STATUS = 54226; +--type DBMS_MIN_REVISION_WITH_TIME_ZONE_PARAMETER_IN_DATETIME_DATA_TYPE = 54337; +type DBMS_MIN_REVISION_WITH_SERVER_DISPLAY_NAME = 54372; +type DBMS_MIN_REVISION_WITH_VERSION_PATCH = 54401; +--type DBMS_MIN_REVISION_WITH_SERVER_LOGS = 54406; +--type DBMS_MIN_REVISION_WITH_CURRENT_AGGREGATION_VARIANT_SELECTION_METHOD = 54448; +--type DBMS_MIN_MAJOR_VERSION_WITH_CURRENT_AGGREGATION_VARIANT_SELECTION_METHOD = 21; +--type DBMS_MIN_MINOR_VERSION_WITH_CURRENT_AGGREGATION_VARIANT_SELECTION_METHOD = 4; +--type DBMS_MIN_REVISION_WITH_COLUMN_DEFAULTS_METADATA = 54410; +--type DBMS_MIN_REVISION_WITH_LOW_CARDINALITY_TYPE = 54405; +type DBMS_MIN_REVISION_WITH_CLIENT_WRITE_INFO = 54420; +--type DBMS_MIN_REVISION_WITH_SETTINGS_SERIALIZED_AS_STRINGS = 54429; +--type DBMS_MIN_REVISION_WITH_SCALARS = 54429; +type DBMS_MIN_REVISION_WITH_OPENTELEMETRY = 54442; +--type DBMS_MIN_REVISION_WITH_AGGREGATE_FUNCTIONS_VERSIONING = 54452; +--type DBMS_CLUSTER_PROCESSING_PROTOCOL_VERSION = 1; +--type DBMS_MIN_SUPPORTED_PARALLEL_REPLICAS_PROTOCOL_VERSION = 3; +--type DBMS_PARALLEL_REPLICAS_MIN_VERSION_WITH_MARK_SEGMENT_SIZE_FIELD = 4; +--type DBMS_PARALLEL_REPLICAS_PROTOCOL_VERSION = 4; +type DBMS_MIN_REVISION_WITH_PARALLEL_REPLICAS = 54453; +--type DBMS_MERGE_TREE_PART_INFO_VERSION = 1; +type DBMS_MIN_REVISION_WITH_INTERSERVER_SECRET = 54441; +--type DBMS_MIN_REVISION_WITH_X_FORWARDED_FOR_IN_CLIENT_INFO = 54443; +--type DBMS_MIN_REVISION_WITH_REFERER_IN_CLIENT_INFO = 54447; +type DBMS_MIN_PROTOCOL_VERSION_WITH_DISTRIBUTED_DEPTH = 54448; +--type DBMS_MIN_PROTOCOL_VERSION_WITH_INCREMENTAL_PROFILE_EVENTS = 54451; +type DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION = 54454; +type DBMS_MIN_PROTOCOL_VERSION_WITH_INITIAL_QUERY_START_TIME = 54449; +--type DBMS_MIN_PROTOCOL_VERSION_WITH_PROFILE_EVENTS_IN_INSERT = 54456; +--type DBMS_MIN_PROTOCOL_VERSION_WITH_VIEW_IF_PERMITTED = 54457; +--type DBMS_MIN_PROTOCOL_VERSION_WITH_ADDENDUM = 54458; +type DBMS_MIN_PROTOCOL_VERSION_WITH_QUOTA_KEY = 54458; +type DBMS_MIN_PROTOCOL_VERSION_WITH_PARAMETERS = 54459; +--type DBMS_MIN_PROTOCOL_VERSION_WITH_SERVER_QUERY_TIME_IN_PROGRESS = 54460; +type DBMS_MIN_PROTOCOL_VERSION_WITH_PASSWORD_COMPLEXITY_RULES = 54461; +type DBMS_MIN_REVISION_WITH_INTERSERVER_SECRET_V2 = 54462; +type DBMS_MIN_PROTOCOL_VERSION_WITH_TOTAL_BYTES_IN_PROGRESS = 54463; +--type DBMS_MIN_PROTOCOL_VERSION_WITH_TIMEZONE_UPDATES = 54464; +--type DBMS_MIN_REVISION_WITH_SPARSE_SERIALIZATION = 54465; +--type DBMS_MIN_REVISION_WITH_SSH_AUTHENTICATION = 54466; +--type DBMS_MIN_REVISION_WITH_TABLE_READ_ONLY_CHECK = 54467; +--type DBMS_MIN_REVISION_WITH_SYSTEM_KEYWORDS_TABLE = 54468; +type DBMS_MIN_REVISION_WITH_ROWS_BEFORE_AGGREGATION = 54469; +type DBMS_MIN_PROTOCOL_VERSION_WITH_CHUNKED_PACKETS = 54470; +type DBMS_MIN_REVISION_WITH_VERSIONED_PARALLEL_REPLICAS_PROTOCOL = 54471; diff --git a/ClickHaskell/Columns.hs b/ClickHaskell/Columns.hs deleted file mode 100644 --- a/ClickHaskell/Columns.hs +++ /dev/null @@ -1,564 +0,0 @@ -{-# LANGUAGE - ConstraintKinds - , OverloadedStrings - , TypeFamilyDependencies - , TupleSections - , LambdaCase -#-} - -{-# OPTIONS_GHC - -Wno-orphans -#-} - -module ClickHaskell.Columns where - --- Internal dependencies -import ClickHaskell.DbTypes -import ClickHaskell.DeSerialization (Serializable (..), Deserializable(..)) -import ClickHaskell.Versioning (ProtocolRevision, SinceRevision, DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION, afterRevision) - --- GHC included -import Control.Monad (forM, replicateM) -import Data.Binary (Get) -import Data.Bits -import Data.ByteString.Builder (Builder, stringUtf8) -import Data.Kind (Type) -import Data.Typeable (Proxy (..)) -import Debug.Trace (traceShowId) -import GHC.Generics -import GHC.TypeLits (ErrorMessage (..), KnownSymbol, Symbol, TypeError, symbolVal) - --- * Columns - -emptyColumns :: Columns '[] -emptyColumns = Empty - -rowsCount :: Columns columns -> UVarInt -rowsCount (AddColumn col _) = columnSize col -rowsCount Empty = 0 - -{-# INLINE [0] appendColumn #-} -appendColumn - :: KnownColumn (Column name chType) - => Column name chType - -> Columns columns - -> Columns (Column name chType ': columns) -appendColumn = AddColumn - - -data Columns (columns :: [Type]) where - Empty :: Columns '[] - AddColumn - :: KnownColumn (Column name chType) - => Column name chType - -> Columns columns - -> Columns (Column name chType ': columns) - -{- | -Column declaration - -For example: - -@ -type MyColumn = Column "myColumn" ChString -@ --} -data Column (name :: Symbol) (chType :: Type) where - ChUInt8Column :: UVarInt -> [ChUInt8] -> Column name ChUInt8 - ChUInt16Column :: UVarInt -> [ChUInt16] -> Column name ChUInt16 - ChUInt32Column :: UVarInt -> [ChUInt32] -> Column name ChUInt32 - ChUInt64Column :: UVarInt -> [ChUInt64] -> Column name ChUInt64 - ChUInt128Column :: UVarInt -> [ChUInt128] -> Column name ChUInt128 - ChInt8Column :: UVarInt -> [ChInt8] -> Column name ChInt8 - ChInt16Column :: UVarInt -> [ChInt16] -> Column name ChInt16 - ChInt32Column :: UVarInt -> [ChInt32] -> Column name ChInt32 - ChInt64Column :: UVarInt -> [ChInt64] -> Column name ChInt64 - ChInt128Column :: UVarInt -> [ChInt128] -> Column name ChInt128 - ChDateColumn :: UVarInt -> [ChDate] -> Column name ChDate - ChDateTimeColumn :: UVarInt -> [ChDateTime] -> Column name ChDateTime - ChUUIDColumn :: UVarInt -> [ChUUID] -> Column name ChUUID - ChStringColumn :: UVarInt -> [ChString] -> Column name ChString - ChArrayColumn :: IsChType chType => UVarInt -> [ChArray chType] -> Column name (ChArray chType) - NullableColumn :: IsChType chType => UVarInt -> [Nullable chType] -> Column name (Nullable chType) - LowCardinalityColumn :: (IsLowCardinalitySupported chType, IsChType chType) => UVarInt -> [chType] -> Column name (LowCardinality chType) - -type family GetColumnName column :: Symbol - where - GetColumnName (Column name columnType) = name - -type family GetColumnType column :: Type - where - GetColumnType (Column name columnType) = columnType - -class - ( IsChType (GetColumnType column) - , KnownSymbol (GetColumnName column) - ) => - KnownColumn column where - renderColumnName :: Builder - renderColumnName = (stringUtf8 . symbolVal @(GetColumnName column)) Proxy - - renderColumnType :: Builder - renderColumnType = chTypeName @(GetColumnType column) - - mkColumn :: UVarInt -> [GetColumnType column] -> Column (GetColumnName column) (GetColumnType column) - -{-# INLINE [0] columnSize #-} -columnSize :: Column name chType -> UVarInt -columnSize column = case column of - (ChUInt8Column size _listValues) -> size - (ChUInt16Column size _listValues) -> size - (ChUInt32Column size _listValues) -> size - (ChUInt64Column size _listValues) -> size - (ChUInt128Column size _listValues) -> size - (ChInt8Column size _listValues) -> size - (ChInt16Column size _listValues) -> size - (ChInt32Column size _listValues) -> size - (ChInt64Column size _listValues) -> size - (ChInt128Column size _listValues) -> size - (ChDateColumn size _nullableValues) -> size - (ChDateTimeColumn size _nullableValues) -> size - (ChUUIDColumn size _nullableValues) -> size - (ChStringColumn size _values) -> size - (ChArrayColumn size _nullableValues) -> size - (NullableColumn size _nullableValues) -> size - (LowCardinalityColumn size _lowCardinalityValues) -> size - -{-# INLINE [0] columnValues #-} -columnValues :: Column name chType -> [chType] -columnValues column = case column of - (ChUInt8Column _size values) -> values - (ChUInt16Column _size values) -> values - (ChUInt32Column _size values) -> values - (ChUInt64Column _size values) -> values - (ChUInt128Column _size values) -> values - (ChInt8Column _size values) -> values - (ChInt16Column _size values) -> values - (ChInt32Column _size values) -> values - (ChInt64Column _size values) -> values - (ChInt128Column _size values) -> values - (ChDateColumn _size values) -> values - (ChDateTimeColumn _size values) -> values - (ChUUIDColumn _size values) -> values - (ChStringColumn _size values) -> values - (ChArrayColumn _size arrayValues) -> arrayValues - (NullableColumn _size nullableValues) -> nullableValues - (LowCardinalityColumn _size lowCardinalityValues) -> map fromChType lowCardinalityValues - -instance KnownSymbol name => KnownColumn (Column name ChUInt8) where mkColumn = ChUInt8Column -instance KnownSymbol name => KnownColumn (Column name ChUInt16) where mkColumn = ChUInt16Column -instance KnownSymbol name => KnownColumn (Column name ChUInt32) where mkColumn = ChUInt32Column -instance KnownSymbol name => KnownColumn (Column name ChUInt64) where mkColumn = ChUInt64Column -instance KnownSymbol name => KnownColumn (Column name ChUInt128) where mkColumn = ChUInt128Column -instance KnownSymbol name => KnownColumn (Column name ChInt8) where mkColumn = ChInt8Column -instance KnownSymbol name => KnownColumn (Column name ChInt16) where mkColumn = ChInt16Column -instance KnownSymbol name => KnownColumn (Column name ChInt32) where mkColumn = ChInt32Column -instance KnownSymbol name => KnownColumn (Column name ChInt64) where mkColumn = ChInt64Column -instance KnownSymbol name => KnownColumn (Column name ChInt128) where mkColumn = ChInt128Column -instance KnownSymbol name => KnownColumn (Column name ChDate) where mkColumn = ChDateColumn -instance KnownSymbol name => KnownColumn (Column name ChDateTime) where mkColumn = ChDateTimeColumn -instance KnownSymbol name => KnownColumn (Column name ChUUID) where mkColumn = ChUUIDColumn -instance - ( KnownSymbol name - , IsChType chType - , IsChType (Nullable chType) - ) => - KnownColumn (Column name (Nullable chType)) where mkColumn = NullableColumn -instance KnownSymbol name => KnownColumn (Column name ChString) where mkColumn = ChStringColumn -instance - ( KnownSymbol name - , IsChType (LowCardinality chType) - , IsLowCardinalitySupported chType - ) => - KnownColumn (Column name (LowCardinality chType)) where mkColumn size = LowCardinalityColumn size . map fromChType -instance KnownSymbol name => KnownColumn (Column name (ChArray ChString)) where mkColumn = ChArrayColumn - - --- ** Columns - -instance - Serializable (Columns '[]) - where - {-# INLINE serialize #-} - serialize _rev Empty = "" - -instance - ( Serializable (Columns columns) - , Serializable col - ) => - Serializable (Columns (col ': columns)) - where - {-# INLINE serialize #-} - serialize rev (AddColumn col columns) = serialize rev col <> serialize rev columns - -instance - ( KnownColumn (Column name chType) - , IsChType chType - , Serializable chType - ) => Serializable (Column name chType) where - {-# INLINE serialize #-} - serialize rev column - = serialize rev (toChType @ChString $ renderColumnName @(Column name chType)) - <> serialize rev (toChType @ChString $ renderColumnType @(Column name chType)) - -- serialization is not custom - <> afterRevision @DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION rev (serialize @ChUInt8 rev 0) - <> mconcat (Prelude.map (serialize @chType rev) (columnValues column)) - -instance {-# OVERLAPPING #-} - ( KnownColumn (Column name (Nullable chType)) - , IsChType chType - , Serializable chType - ) => Serializable (Column name (Nullable chType)) where - {-# INLINE serialize #-} - serialize rev column - = serialize rev (toChType @ChString $ renderColumnName @(Column name (Nullable chType))) - <> serialize rev (toChType @ChString $ renderColumnType @(Column name (Nullable chType))) - -- serialization is not custom - <> afterRevision @DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION rev (serialize @ChUInt8 rev 0) - -- Nulls - <> mconcat (Prelude.map (serialize @ChUInt8 rev . maybe 1 (const 0)) (columnValues column)) - -- Values - <> mconcat (Prelude.map (serialize @chType rev . maybe defaultValueOfTypeName id) (columnValues column)) - -instance {-# OVERLAPPING #-} - ( KnownColumn (Column name (Nullable chType)) - , IsChType chType - , Serializable chType - , TypeError ('Text "LowCardinality serialization still unsupported") - ) => Serializable (Column name (LowCardinality chType)) where - {-# INLINE serialize #-} - serialize rev (LowCardinalityColumn _ column) - = serialize rev (toChType @ChString $ renderColumnName @(Column name (Nullable chType))) - <> serialize rev (toChType @ChString $ renderColumnType @(Column name (Nullable chType))) - -- serialization is not custom - <> afterRevision @DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION rev (serialize @ChUInt8 rev 0) - <> undefined column - - - - - - - - - - --- * (De)serialization - --- ** Serialization - --- *** Generic API - -type GenericWritable record columns = - ( Generic record - , GWritable columns (Rep record) - ) - -class - ( HasColumns (Columns (GetColumns columns)) - , Serializable (Columns (GetColumns columns)) - , DeserializableColumns (Columns (GetColumns columns)) - ) => - WritableInto columns record - where - default serializeRecords :: GenericWritable record (GetColumns columns) => ProtocolRevision -> UVarInt -> [record] -> Builder - serializeRecords :: ProtocolRevision -> UVarInt -> [record] -> Builder - serializeRecords rev size = gSerializeRecords @(GetColumns columns) rev size . map from - - default writingColumns :: GenericWritable record (GetColumns columns) => Builder - writingColumns :: Builder - writingColumns = gWritingColumns @(GetColumns columns) @(Rep record) - - default columnsCount :: GenericWritable record (GetColumns columns) => UVarInt - columnsCount :: UVarInt - columnsCount = gColumnsCount @(GetColumns columns) @(Rep record) - -class GWritable (columns :: [Type]) f - where - gSerializeRecords :: ProtocolRevision -> UVarInt -> [f p] -> Builder - gWritingColumns :: Builder - gColumnsCount :: UVarInt - -instance - GWritable columns f - => - GWritable columns (D1 c (C1 c2 f)) - where - {-# INLINE gSerializeRecords #-} - gSerializeRecords rev size = gSerializeRecords @columns rev size . map (unM1 . unM1) - {-# INLINE gWritingColumns #-} - gWritingColumns = gWritingColumns @columns @f - gColumnsCount = gColumnsCount @columns @f - -instance - GWritable columns (left1 :*: (left2 :*: right)) - => - GWritable columns ((left1 :*: left2) :*: right) - where - {-# INLINE gSerializeRecords #-} - gSerializeRecords rev size = gSerializeRecords @columns rev size . map (\((l1 :*: l2) :*: r) -> l1 :*: (l2 :*: r)) - {-# INLINE gWritingColumns #-} - gWritingColumns = gWritingColumns @columns @(left1 :*: (left2 :*: right)) - gColumnsCount = gColumnsCount @columns @(left1 :*: (left2 :*: right)) - -instance - ( GWritable '[Column name chType] (S1 (MetaSel (Just name) a b f) rec) - , GWritable restColumns right - , '(Column name chType, restColumns)~ TakeColumn name columns - ) - => - GWritable columns (S1 (MetaSel (Just name) a b f) rec :*: right) - where - {-# INLINE gSerializeRecords #-} - gSerializeRecords rev size - = (\(a, b) -> gSerializeRecords @'[Column name chType] rev size a <> gSerializeRecords @restColumns rev size b) - . unzip . map (\(l :*: r) -> (l, r)) - - {-# INLINE gWritingColumns #-} - gWritingColumns = - gWritingColumns @'[Column name chType] @(S1 (MetaSel (Just name) a b f) rec) - <> ", " <> gWritingColumns @restColumns @right - gColumnsCount = gColumnsCount @'[Column name chType] @(S1 (MetaSel (Just name) a b f) rec) + gColumnsCount @restColumns @right - -instance {-# OVERLAPPING #-} - ( KnownColumn (Column name chType) - , ToChType chType inputType - , Serializable (Column name chType) - , '(Column name chType, restColumns) ~ TakeColumn name columns - ) => - GWritable columns (S1 (MetaSel (Just name) a b f) (Rec0 inputType)) - where - {-# INLINE gSerializeRecords #-} - gSerializeRecords rev size = serialize rev . mkColumn @(Column name chType) size . map (toChType . unK1 . unM1) - {-# INLINE gWritingColumns #-} - gWritingColumns = renderColumnName @(Column name chType) - gColumnsCount = 1 - - - - --- ** Deserialization - --- *** Generic API - -type GenericReadable record hasColumns = - ( Generic record - , GReadable (GetColumns hasColumns) (Rep record) - ) - -class - ( HasColumns hasColumns - , DeserializableColumns (Columns (GetColumns hasColumns)) - ) => - ReadableFrom hasColumns record - where - default deserializeColumns :: GenericReadable record hasColumns => ProtocolRevision -> UVarInt -> Get [record] - deserializeColumns :: ProtocolRevision -> UVarInt -> Get [record] - deserializeColumns rev size = map to <$> gFromColumns @(GetColumns hasColumns) rev size - - default readingColumns :: GenericReadable record hasColumns => Builder - readingColumns :: Builder - readingColumns = gReadingColumns @(GetColumns hasColumns) @(Rep record) - - -class GReadable (columns :: [Type]) f - where - gFromColumns :: ProtocolRevision -> UVarInt -> Get [f p] - gReadingColumns :: Builder - -instance - GReadable columns f - => - GReadable columns (D1 c (C1 c2 f)) - where - {-# INLINE gFromColumns #-} - gFromColumns rev size = map (M1 . M1) <$> gFromColumns @columns rev size - gReadingColumns = gReadingColumns @columns @f - -instance - GReadable columns (left :*: (right1 :*: right2)) - => - GReadable columns ((left :*: right1) :*: right2) - where - {-# INLINE gFromColumns #-} - gFromColumns rev size = do - list <- gFromColumns @columns rev size - pure [(l :*: r1) :*: r2 | (l :*: (r1 :*: r2)) <- list] - gReadingColumns = gReadingColumns @columns @(left :*: (right1 :*: right2)) - - -instance - ( KnownColumn (Column name chType) - , GReadable '[Column name chType] (S1 (MetaSel (Just name) a b f) rec) - , GReadable restColumns right - , '(Column name chType, restColumns) ~ TakeColumn name columns - ) - => - GReadable columns (S1 (MetaSel (Just name) a b f) rec :*: right) - where - {-# INLINE gFromColumns #-} - gFromColumns rev size = do - zipWith (:*:) - <$> gFromColumns @'[Column name chType] rev size - <*> gFromColumns @restColumns rev size - gReadingColumns = - renderColumnName @(Column name chType) - <> ", " <> gReadingColumns @restColumns @right - -instance - ( KnownColumn (Column name chType) - , DeserializableColumn (Column name chType) - , FromChType chType inputType - , '(Column name chType, restColumns) ~ TakeColumn name columns - ) => GReadable columns ((S1 (MetaSel (Just name) a b f)) (Rec0 inputType)) - where - {-# INLINE gFromColumns #-} - gFromColumns rev size = map (M1 . K1 . fromChType @chType) . columnValues <$> deserializeColumn @(Column name chType) rev size - gReadingColumns = renderColumnName @(Column name chType) - --- *** - --- ** Raw columns deserialization - -class DeserializableColumns columns where - deserializeRawColumns :: ProtocolRevision -> UVarInt -> Get columns - -instance - DeserializableColumns (Columns '[]) - where - {-# INLINE deserializeRawColumns #-} - deserializeRawColumns _rev _rows = pure Empty - -instance - ( KnownColumn (Column name chType) - , DeserializableColumn (Column name chType) - , DeserializableColumns (Columns extraColumns) - ) - => - DeserializableColumns (Columns (Column name chType ': extraColumns)) - where - {-# INLINE deserializeRawColumns #-} - deserializeRawColumns rev rows = - AddColumn - <$> deserializeColumn rev rows - <*> deserializeRawColumns @(Columns extraColumns) rev rows - - --- ** Column deserialization - -{-# SPECIALIZE replicateM :: Int -> Get chType -> Get [chType] #-} - -class DeserializableColumn column where - deserializeColumn :: ProtocolRevision -> UVarInt -> Get column - -instance - ( KnownColumn (Column name chType) - , Deserializable chType - ) => - DeserializableColumn (Column name chType) where - deserializeColumn rev rows = do - _columnName <- deserialize @ChString rev - _columnType <- deserialize @ChString rev - _isCustom <- deserialize @(ChUInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION) rev - column <- replicateM (fromIntegral rows) (deserialize @chType rev) - pure $ mkColumn @(Column name chType) rows column - -instance {-# OVERLAPPING #-} - ( KnownColumn (Column name (Nullable chType)) - , Deserializable chType - ) => - DeserializableColumn (Column name (Nullable chType)) where - deserializeColumn rev rows = do - _columnName <- deserialize @ChString rev - _columnType <- deserialize @ChString rev - _isCustom <- deserialize @(ChUInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION) rev - nulls <- replicateM (fromIntegral rows) (deserialize @ChUInt8 rev) - nullable <- - forM - nulls - (\case - 0 -> Just <$> deserialize @chType rev - _ -> (Nothing <$ deserialize @chType rev) - ) - pure $ mkColumn @(Column name (Nullable chType)) rows nullable - -instance {-# OVERLAPPING #-} - ( KnownColumn (Column name (LowCardinality chType)) - , Deserializable chType - , ToChType (LowCardinality chType) chType - , IsLowCardinalitySupported chType - , TypeError ('Text "LowCardinality deserialization still unsupported") - ) => - DeserializableColumn (Column name (LowCardinality chType)) where - deserializeColumn rev rows = do - _columnName <- deserialize @ChString rev - _columnType <- deserialize @ChString rev - _isCustom <- deserialize @(ChUInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION) rev - _serializationType <- (.&. 0xf) <$> deserialize @ChUInt64 rev - _index_size <- deserialize @ChInt64 rev - -- error $ "Trace | " <> show _serializationType <> " : " <> show _index_size - lc <- replicateM (fromIntegral rows) (toChType <$> deserialize @chType rev) - pure $ mkColumn @(Column name (LowCardinality chType)) rows lc - -instance {-# OVERLAPPING #-} - ( KnownColumn (Column name (ChArray chType)) - , Deserializable chType - , TypeError ('Text "Arrays deserialization still unsupported") - ) - => DeserializableColumn (Column name (ChArray chType)) where - deserializeColumn rev rows = do - _columnName <- deserialize @ChString rev - _columnType <- deserialize @ChString rev - _isCustom <- deserialize @(ChUInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION) rev - (arraySize, _offsets) <- traceShowId <$> readOffsets rev - _types <- replicateM (fromIntegral arraySize) (deserialize @chType rev) - pure $ mkColumn @(Column name (ChArray chType)) rows [] - where - readOffsets :: ProtocolRevision -> Get (ChUInt64, [ChUInt64]) - readOffsets revivion = do - size <- deserialize @ChUInt64 rev - (size, ) <$> go size - where - go arraySize = - do - nextOffset <- deserialize @ChUInt64 revivion - if arraySize >= nextOffset - then pure [nextOffset] - else (nextOffset :) <$> go arraySize - - - --- ** Columns extraction helper - -class - HasColumns hasColumns - where - type GetColumns hasColumns :: [Type] - -instance HasColumns (Columns columns) - where - type GetColumns (Columns columns) = columns - - --- ** Take column by name from list of columns - -type family - TakeColumn (name :: Symbol) (columns :: [Type]) :: (Type, [Type]) - where - TakeColumn name columns = GoTakeColumn name columns '[] - -type family - GoTakeColumn name (columns :: [Type]) (acc :: [Type]) :: (Type, [Type]) - where - GoTakeColumn name (Column name chType ': columns) acc = '(Column name chType, acc ++ columns) - 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" - ) - -type family - (++) (list1 :: [Type]) (list2 :: [Type]) :: [Type] - where - (++) '[] list = list - (++) (head ': tail) list = tail ++ (head ': list) diff --git a/ClickHaskell/DbTypes.hs b/ClickHaskell/DbTypes.hs deleted file mode 100644 --- a/ClickHaskell/DbTypes.hs +++ /dev/null @@ -1,553 +0,0 @@ -{-# LANGUAGE - GeneralizedNewtypeDeriving - , LambdaCase - , OverloadedStrings -#-} - -module ClickHaskell.DbTypes -( IsChType(ToChTypeName, chTypeName, defaultValueOfTypeName) -, ToChType(toChType) -, FromChType(fromChType) -, ToQueryPart(toQueryPart) - -, ChDateTime(..) -, ChDate(..) - -, ChInt8(..), ChInt16(..), ChInt32(..), ChInt64(..), ChInt128(..) -, ChUInt8(..), ChUInt16(..), ChUInt32(..), ChUInt64(..), ChUInt128(..) - -, ChString(..) -, ChUUID(..) - -, ChArray(..) -, Nullable -, LowCardinality, IsLowCardinalitySupported - -, UVarInt(..) -, module Data.WideWord -) where - --- Internal dependencies - --- External -import Data.WideWord (Int128 (..), Word128(..)) - --- GHC included -import Control.DeepSeq (NFData) -import Data.Bits (Bits (..)) -import Data.ByteString as BS (StrictByteString, toStrict) -import Data.ByteString.Builder as BS (Builder, byteString, toLazyByteString) -import Data.ByteString.Char8 as BS8 (concatMap, length, pack, replicate, singleton) -import Data.Coerce (coerce) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.List (uncons) -import Data.String (IsString) -import Data.Text as Text (Text) -import Data.Text.Encoding as Text (encodeUtf8) -import Data.Time (UTCTime, ZonedTime, zonedTimeToUTC) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) -import Data.Typeable (Proxy (..)) -import Data.Vector.Primitive.Mutable (Prim) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Generics -import GHC.TypeLits (AppendSymbol, ErrorMessage (..), KnownSymbol, Symbol, TypeError, symbolVal) - - -class - KnownSymbol (ToChTypeName chType) => - IsChType chType - where - -- | Shows database original type name - -- - -- @ - -- type ToChTypeName ChString = \"String\" - -- type ToChTypeName (Nullable ChUInt32) = \"Nullable(UInt32)\" - -- @ - type ToChTypeName chType :: Symbol - - chTypeName :: Builder - chTypeName = byteString . BS8.pack . symbolVal @(ToChTypeName chType) $ Proxy - - defaultValueOfTypeName :: chType - -class IsChType chType => ToChType chType inputType where toChType :: inputType -> chType -class IsChType chType => FromChType chType outputType where fromChType :: chType -> outputType -class IsChType chType => ToQueryPart chType where toQueryPart :: chType -> BS.Builder - -instance {-# OVERLAPPABLE #-} (IsChType chType, chType ~ inputType) => ToChType chType inputType where toChType = id -instance {-# OVERLAPPABLE #-} (IsChType chType, chType ~ inputType) => FromChType chType inputType where fromChType = id - - - --- | ClickHouse Nullable(T) column type --- (type synonym for Maybe) -type Nullable = Maybe - -type NullableTypeName chType = "Nullable(" `AppendSymbol` ToChTypeName chType `AppendSymbol` ")" - -{- -This instance leads to disable -Wmissing-methods -Need to move it's semantics to another instances - -instance {-# OVERLAPPING #-} - ( TypeError - ( 'Text (ToChTypeName (Nullable (LowCardinality chType))) ':<>: 'Text " is unsupported type in ClickHouse." - ':$$: 'Text "Use " ':<>: 'Text (ToChTypeName (LowCardinality (Nullable chType))) ':<>: 'Text " instead." - ) - , IsChType chType - ) => IsChType (Nullable (LowCardinality chType)) - where - defaultValueOfTypeName = error "Unreachable" - chTypeName = error "Unreachable" --} - -instance - ( IsChType chType - , KnownSymbol ("Nullable(" `AppendSymbol` ToChTypeName chType `AppendSymbol` ")") - ) - => - IsChType (Nullable chType) - where - type ToChTypeName (Nullable chType) = NullableTypeName chType - defaultValueOfTypeName = Nothing - -instance - ( ToQueryPart chType - , IsChType (Nullable chType) - ) - => - ToQueryPart (Nullable chType) - where - toQueryPart = maybe "null" toQueryPart - -instance - ( ToChType inputType chType - , IsChType (Nullable inputType) - ) - => - ToChType (Nullable inputType) (Nullable chType) - where - toChType = fmap (toChType @inputType @chType) - -instance - ( FromChType chType inputType - , IsChType (Nullable chType) - ) - => - FromChType (Nullable chType) (Nullable inputType) - where - fromChType = fmap (fromChType @chType) - - - - --- | ClickHouse LowCardinality(T) column type -newtype LowCardinality chType = MkLowCardinality chType -deriving newtype instance (Eq chType, IsLowCardinalitySupported chType) => Eq (LowCardinality chType) -deriving newtype instance (Show chType, IsLowCardinalitySupported chType) => Show (LowCardinality chType) -deriving newtype instance (NFData chType, IsLowCardinalitySupported chType) => NFData (LowCardinality chType) -deriving newtype instance IsString (LowCardinality ChString) - -class IsChType chType => IsLowCardinalitySupported chType -instance IsLowCardinalitySupported ChString -instance - ( IsLowCardinalitySupported chType - , IsChType (Nullable chType) - ) => - IsLowCardinalitySupported (Nullable chType) - -instance {-# OVERLAPPABLE #-} - ( IsChType chType - , TypeError - ( 'Text "LowCardinality(" ':<>: 'ShowType chType ':<>: 'Text ") is unsupported" - ':$$: 'Text "Use one of these types:" - ':$$: 'Text " ChString" - ':$$: 'Text " ChDateTime" - ':$$: 'Text " Nullable(T)" - ) - ) => IsLowCardinalitySupported chType - -instance - ( IsLowCardinalitySupported chType - , KnownSymbol ("LowCardinality(" `AppendSymbol` ToChTypeName chType `AppendSymbol` ")") - ) => - IsChType (LowCardinality chType) - where - type ToChTypeName (LowCardinality chType) = "LowCardinality(" `AppendSymbol` ToChTypeName chType `AppendSymbol` ")" - defaultValueOfTypeName = MkLowCardinality $ defaultValueOfTypeName @chType - -instance - ( ToChType inputType chType - , IsChType (LowCardinality inputType) - , IsLowCardinalitySupported inputType - ) - => - ToChType (LowCardinality inputType) chType - where - toChType = MkLowCardinality . toChType - -instance {-# OVERLAPPING #-} - ( IsChType (LowCardinality chType) - , IsLowCardinalitySupported chType - ) - => - ToChType (LowCardinality chType) chType - where - toChType = MkLowCardinality - -instance IsLowCardinalitySupported chType => ToChType chType (LowCardinality chType) - where - toChType (MkLowCardinality value) = value - -instance IsLowCardinalitySupported chType => FromChType chType (LowCardinality chType) - where - fromChType = MkLowCardinality - -instance - ( FromChType chType outputType - , IsChType (LowCardinality chType) - , IsLowCardinalitySupported chType - ) - => - FromChType (LowCardinality chType) outputType - where - fromChType (MkLowCardinality value) = fromChType value - -instance {-# OVERLAPPING #-} - ( IsChType (LowCardinality chType) - , IsLowCardinalitySupported chType - ) - => - FromChType (LowCardinality chType) chType - where - fromChType (MkLowCardinality value) = value - -instance - ( ToQueryPart chType - , IsChType (LowCardinality chType) - , IsLowCardinalitySupported chType - ) - => - ToQueryPart (LowCardinality chType) - where - toQueryPart (MkLowCardinality chType) = toQueryPart chType - - - - --- | ClickHouse UUID column type -newtype ChUUID = MkChUUID Word128 - deriving newtype (Generic, Show, Eq, NFData, Bounded, Prim, Enum) - -instance IsChType ChUUID where - type ToChTypeName ChUUID = "UUID" - defaultValueOfTypeName = MkChUUID 0 - - -instance ToChType ChUUID Word64 where toChType = MkChUUID . flip Word128 0 -instance ToChType ChUUID (Word64, Word64) where toChType = MkChUUID . uncurry (flip Word128) - -instance FromChType ChUUID (Word64, Word64) where fromChType (MkChUUID (Word128 w64hi w64lo)) = (w64hi, w64lo) - - - - --- | ClickHouse String column type -newtype ChString = MkChString StrictByteString - deriving newtype (Show, Eq, IsString, NFData) - -instance IsChType ChString where - type ToChTypeName ChString = "String" - defaultValueOfTypeName = "" - - -instance ToQueryPart ChString where toQueryPart (MkChString string) = "'" <> escapeQuery string <> "'" - -escapeQuery :: StrictByteString -> Builder -escapeQuery -- [ClickHaskell.DbTypes.ToDo.1]: Optimize - = BS.byteString - . BS8.concatMap (\case '\'' -> "\\\'"; '\\' -> "\\\\"; sym -> BS8.singleton sym;) - -instance ToChType ChString StrictByteString where toChType = MkChString -instance ToChType ChString Builder where toChType = MkChString . toStrict . toLazyByteString -instance ToChType ChString String where toChType = MkChString . BS8.pack -instance ToChType ChString Text where toChType = MkChString . Text.encodeUtf8 -instance ToChType ChString Int where toChType = MkChString . BS8.pack . show - -instance FromChType ChString StrictByteString where fromChType (MkChString string) = string -instance - ( TypeError - ( 'Text "ChString to Text using FromChType convertion could cause exception" - ':$$: 'Text "Decode ByteString manually if you are sure it's always can be decoded or replace it with ByteString" - ) - ) => - FromChType ChString Text - where - fromChType = error "Unreachable" - - - - --- | ClickHouse Int8 column type -newtype ChInt8 = MkChInt8 Int8 - deriving newtype (Show, Eq, Num, Prim, Bits, Enum, Ord, Real, Integral, Bounded, NFData) - -instance IsChType ChInt8 where - type ToChTypeName ChInt8 = "Int8" - defaultValueOfTypeName = 0 - -instance ToQueryPart ChInt8 - where - toQueryPart = BS.byteString . BS8.pack . show - -instance ToChType ChInt8 Int8 where toChType = MkChInt8 - -instance FromChType ChInt8 Int8 where fromChType = coerce - - - - --- | ClickHouse Int16 column type -newtype ChInt16 = MkChInt16 Int16 - deriving newtype (Show, Eq, Num, Prim, Bits, Enum, Ord, Real, Integral, Bounded, NFData) - -instance IsChType ChInt16 where - type ToChTypeName ChInt16 = "Int16" - defaultValueOfTypeName = 0 - -instance ToQueryPart ChInt16 where toQueryPart = BS.byteString . BS8.pack . show - -instance ToChType ChInt16 Int16 where toChType = MkChInt16 - -instance FromChType ChInt16 Int16 where fromChType (MkChInt16 int16) = int16 - - - - --- | ClickHouse Int32 column type -newtype ChInt32 = MkChInt32 Int32 - deriving newtype (Show, Eq, Num, Prim, Bits, Enum, Ord, Real, Integral, Bounded, NFData) - -instance IsChType ChInt32 where - type ToChTypeName ChInt32 = "Int32" - defaultValueOfTypeName = 0 - -instance ToQueryPart ChInt32 where toQueryPart = BS.byteString . BS8.pack . show - -instance ToChType ChInt32 Int32 where toChType = MkChInt32 - -instance FromChType ChInt32 Int32 where fromChType (MkChInt32 int32) = int32 - - - - --- | ClickHouse Int64 column type -newtype ChInt64 = MkChInt64 Int64 - deriving newtype (Show, Eq, Num, Prim, Bits, Enum, Ord, Real, Integral, Bounded, NFData) - -instance IsChType ChInt64 where - type ToChTypeName ChInt64 = "Int64" - defaultValueOfTypeName = 0 - -instance ToQueryPart ChInt64 where toQueryPart = BS.byteString . BS8.pack . show - -instance ToChType ChInt64 Int64 where toChType = MkChInt64 . fromIntegral -instance ToChType ChInt64 Int where toChType = MkChInt64 . fromIntegral - -instance FromChType ChInt64 Int64 where fromChType = coerce - - - - --- | ClickHouse Int128 column type -newtype ChInt128 = MkChInt128 Int128 - deriving newtype (Show, Eq, Num, Prim, Bits, Ord, Real, Enum, Integral, Bounded, NFData) - -instance IsChType ChInt128 where - type ToChTypeName ChInt128 = "Int128" - defaultValueOfTypeName = 0 - -instance ToQueryPart ChInt128 where toQueryPart = BS.byteString . BS8.pack . show - -instance ToChType ChInt128 Int128 where toChType = MkChInt128 . fromIntegral - -instance FromChType ChInt128 Int128 where fromChType (MkChInt128 int128) = int128 - - - - --- | ClickHouse UInt8 column type -newtype ChUInt8 = MkChUInt8 Word8 - deriving newtype (Show, Eq, Num, Prim, Bits, Enum, Ord, Real, Integral, Bounded, NFData) - -instance IsChType ChUInt8 where - type ToChTypeName ChUInt8 = "UInt8" - defaultValueOfTypeName = 0 - - -instance ToQueryPart ChUInt8 where toQueryPart = BS.byteString . BS8.pack . show - -instance ToChType ChUInt8 Word8 where toChType = MkChUInt8 - -instance FromChType ChUInt8 Word8 where fromChType (MkChUInt8 w8) = w8 - - - - --- | ClickHouse UInt16 column type -newtype ChUInt16 = MkChUInt16 Word16 - deriving newtype (Show, Eq, Num, Prim, Bits, Enum, Ord, Real, Integral, Bounded, NFData) - -instance IsChType ChUInt16 where - type ToChTypeName ChUInt16 = "UInt16" - defaultValueOfTypeName = 0 - -instance ToQueryPart ChUInt16 where toQueryPart = BS.byteString . BS8.pack . show - -instance ToChType ChUInt16 Word16 where toChType = coerce - -instance FromChType ChUInt16 Word16 where fromChType = coerce - - - - --- | ClickHouse UInt32 column type -newtype ChUInt32 = MkChUInt32 Word32 - deriving newtype (Show, Eq, Num, Prim, Bits, Enum, Ord, Real, Integral, Bounded, NFData) - -instance IsChType ChUInt32 where - type ToChTypeName ChUInt32 = "UInt32" - defaultValueOfTypeName = 0 - -instance ToQueryPart ChUInt32 where toQueryPart = BS.byteString . BS8.pack . show - -instance ToChType ChUInt32 Word32 where toChType = MkChUInt32 - -instance FromChType ChUInt32 Word32 where fromChType (MkChUInt32 word32) = word32 - - - - --- | ClickHouse UInt64 column type -newtype ChUInt64 = MkChUInt64 Word64 - deriving newtype (Show, Eq, Num, Prim, Bits, Enum, Ord, Real, Integral, Bounded, NFData) - -instance IsChType ChUInt64 where - type ToChTypeName ChUInt64 = "UInt64" - defaultValueOfTypeName = 0 - -instance ToQueryPart ChUInt64 where toQueryPart = BS.byteString . BS8.pack . show - -instance ToChType ChUInt64 Word64 where toChType = MkChUInt64 - -instance FromChType ChUInt64 Word64 where fromChType (MkChUInt64 w64) = w64 - - - - --- | ClickHouse UInt128 column type -newtype ChUInt128 = MkChUInt128 Word128 - deriving newtype (Show, Eq, Num, Prim, Bits, Enum, Ord, Real, Integral, Bounded, NFData) - -instance IsChType ChUInt128 where - type ToChTypeName ChUInt128 = "UInt128" - defaultValueOfTypeName = 0 - -instance ToQueryPart ChUInt128 where toQueryPart = BS.byteString . BS8.pack . show - -instance ToChType ChUInt128 Word128 where toChType = MkChUInt128 -instance ToChType ChUInt128 Word64 where toChType = MkChUInt128 . fromIntegral - -instance FromChType ChUInt128 Word128 where fromChType (MkChUInt128 w128) = w128 - - - - --- | ClickHouse DateTime column type -newtype ChDateTime = MkChDateTime Word32 - deriving newtype (Show, Eq, Prim, Num, Bits, Enum, Ord, Real, Integral, Bounded, NFData) - -instance IsChType ChDateTime - where - type ToChTypeName ChDateTime = "DateTime" - defaultValueOfTypeName = MkChDateTime 0 - -instance ToQueryPart ChDateTime - where - toQueryPart chDateTime = let time = BS8.pack . show . fromChType @ChDateTime @Word32 $ chDateTime - in BS.byteString (BS8.replicate (10 - BS8.length time) '0' <> time) - -instance ToChType ChDateTime Word32 where toChType = MkChDateTime -instance ToChType ChDateTime UTCTime where toChType = MkChDateTime . floor . utcTimeToPOSIXSeconds -instance ToChType ChDateTime ZonedTime where toChType = MkChDateTime . floor . utcTimeToPOSIXSeconds . zonedTimeToUTC - -instance FromChType ChDateTime Word32 where fromChType = coerce -instance FromChType ChDateTime UTCTime where fromChType (MkChDateTime w32) = posixSecondsToUTCTime (fromIntegral w32) - - - - -newtype ChDate = MkChDate Word16 - deriving newtype (Show, Eq, Prim, Bits, Bounded, Enum, NFData) - -instance IsChType ChDate where - type ToChTypeName ChDate = "Date" - defaultValueOfTypeName = MkChDate 0 - -instance ToChType ChDate Word16 where toChType = MkChDate - -instance FromChType ChDate Word16 where fromChType = coerce - - - - -newtype ChArray a = MkChArray [a] - deriving newtype (Show, Eq, NFData) - -instance - ( IsChType chType - , KnownSymbol (AppendSymbol (AppendSymbol "Array(" (ToChTypeName chType)) ")") - ) => - IsChType (ChArray chType) - where - type ToChTypeName (ChArray chType) = "Array(" `AppendSymbol` ToChTypeName chType `AppendSymbol` ")" - defaultValueOfTypeName = MkChArray [] - - - - -instance - ( ToQueryPart chType - , IsChType (ChArray chType) - ) => - ToQueryPart (ChArray chType) - where - toQueryPart - = (\x -> "[" <> x <> "]") - . (maybe "" (uncurry (foldr (\ a b -> a <> "," <> b))) - . uncons - . map (toQueryPart @chType)) - . fromChType - -instance - ( IsChType chType - , IsChType (ChArray chType) - ) => - FromChType (ChArray chType) [chType] where fromChType (MkChArray values) = values - -instance - ( ToChType chType inputType - , IsChType (ChArray chType) - ) => - ToChType (ChArray chType) [inputType] where toChType = MkChArray . map toChType - - - - -{- | - Unsigned variable-length quantity encoding - - Part of protocol implementation --} -newtype UVarInt = MkUVarInt Word64 - deriving newtype (Show, Eq, Num, Prim, Bits, Enum, Ord, Real, Integral, Bounded, NFData) diff --git a/ClickHaskell/DeSerialization.hs b/ClickHaskell/DeSerialization.hs deleted file mode 100644 --- a/ClickHaskell/DeSerialization.hs +++ /dev/null @@ -1,218 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module ClickHaskell.DeSerialization where - --- Internal dependencies -import ClickHaskell.Versioning (ProtocolRevision(..), SinceRevision (..), afterRevision) -import ClickHaskell.DbTypes - --- GHC included -import Data.Binary.Get -import Data.Binary.Get.Internal (readN) -import Data.Binary.Put -import Data.Bits (Bits (..)) -import Data.ByteString as BS (length, take) -import Data.ByteString.Builder (Builder, word8) -import Data.Coerce (coerce) -import Data.Typeable (Proxy (..)) -import GHC.Generics -import GHC.TypeLits (KnownNat, natVal) - --- * Deserialization - -class - Deserializable chType - where - default deserialize :: (Generic chType, GDeserializable (Rep chType)) => ProtocolRevision -> Get chType - deserialize :: ProtocolRevision -> Get chType - deserialize rev = to <$> gDeserialize rev - - --- ** Generics - -class GDeserializable f - where - gDeserialize :: ProtocolRevision -> Get (f p) - -instance - GDeserializable f - => - GDeserializable (D1 c (C1 c2 f)) - where - {-# INLINE gDeserialize #-} - gDeserialize rev = M1 . M1 <$> gDeserialize rev - -instance - GDeserializable (left :*: (right1 :*: right2)) - => - GDeserializable ((left :*: right1) :*: right2) - where - {-# INLINE gDeserialize #-} - gDeserialize rev = (\(l :*: (r1 :*: r2)) -> (l :*: r1) :*: r2) <$> gDeserialize rev - -instance - (GDeserializable (S1 metaSel field), GDeserializable right) - => - GDeserializable (S1 metaSel field :*: right) - where - {-# INLINE gDeserialize #-} - gDeserialize rev = (:*:) <$> gDeserialize rev <*> gDeserialize rev - -instance - Deserializable chType - => - GDeserializable (S1 (MetaSel (Just typeName) a b f) (Rec0 chType)) - where - {-# INLINE gDeserialize #-} - gDeserialize rev = M1 . K1 <$> deserialize @chType rev - - --- ** Versioning - -instance - ( KnownNat revision - , Deserializable chType - ) - => - Deserializable (SinceRevision chType revision) - where - deserialize rev = - if rev >= (fromIntegral . natVal) (Proxy @revision) - then MkSinceRevision <$> deserialize @chType rev - else pure NotPresented - -instance Deserializable ProtocolRevision where - deserialize rev = coerce <$> deserialize @UVarInt rev - - --- ** Database types - -instance Deserializable ChUUID where - deserialize _ = MkChUUID <$> (flip Word128 <$> getWord64le <*> getWord64le) - -instance Deserializable ChString where - deserialize rev = do - strSize <- fromIntegral <$> deserialize @UVarInt rev - toChType <$> readN strSize (BS.take strSize) - - -instance Deserializable ChInt8 where deserialize _ = toChType <$> getInt8 -instance Deserializable ChInt16 where deserialize _ = toChType <$> getInt16le -instance Deserializable ChInt32 where deserialize _ = toChType <$> getInt32le -instance Deserializable ChInt64 where deserialize _ = toChType <$> getInt64le -instance Deserializable ChInt128 where deserialize _ = toChType <$> (flip Int128 <$> getWord64le <*> getWord64le) -instance Deserializable ChUInt8 where deserialize _ = toChType <$> getWord8 -instance Deserializable ChUInt16 where deserialize _ = toChType <$> getWord16le -instance Deserializable ChUInt32 where deserialize _ = toChType <$> getWord32le -instance Deserializable ChUInt64 where deserialize _ = toChType <$> getWord64le -instance Deserializable ChUInt128 where deserialize _ = toChType <$> (flip Word128 <$> getWord64le <*> getWord64le) -instance Deserializable ChDateTime where deserialize _ = toChType <$> getWord32le -instance Deserializable ChDate where deserialize _ = toChType <$> getWord16le - -instance Deserializable UVarInt where - deserialize _ = go 0 (0 :: UVarInt) - where - go i o | i < 10 = do - byte <- getWord8 - let o' = o .|. ((fromIntegral byte .&. 0x7f) `unsafeShiftL` (7 * i)) - if byte .&. 0x80 == 0 then pure $! o' else go (i + 1) $! o' - go _ _ = fail "input exceeds varuint size" - - - - - - --- * Serialization - -class Serializable chType - where - default serialize :: (Generic chType, GSerializable (Rep chType)) => ProtocolRevision -> chType -> Builder - serialize :: ProtocolRevision -> chType -> Builder - serialize rev = gSerialize rev . from - - --- ** Versioning - -instance - ( KnownNat revision - , Serializable chType - ) - => - Serializable (SinceRevision chType revision) - where - serialize rev (MkSinceRevision val) = afterRevision @revision rev (serialize rev val) - serialize rev NotPresented = afterRevision @revision rev (error "Unexpected error") - -instance Serializable ProtocolRevision where - serialize rev = serialize @UVarInt rev . coerce - - --- ** Database types -instance Serializable UVarInt where - serialize _ = go - where - go i - | i < 0x80 = word8 (fromIntegral i) - | otherwise = word8 (setBit (fromIntegral i) 7) <> go (unsafeShiftR i 7) - -instance Serializable ChString where - serialize rev str - = (serialize @UVarInt rev . fromIntegral . BS.length . fromChType) str - <> (execPut . putByteString . fromChType) str - -instance Serializable ChUUID where serialize _ = execPut . (\(hi, lo) -> putWord64le lo <> putWord64le hi) . fromChType -instance Serializable ChInt8 where serialize _ = execPut . putInt8 . fromChType -instance Serializable ChInt16 where serialize _ = execPut . putInt16le . fromChType -instance Serializable ChInt32 where serialize _ = execPut . putInt32le . fromChType -instance Serializable ChInt64 where serialize _ = execPut . putInt64le . fromChType -instance Serializable ChInt128 where serialize _ = execPut . (\(Int128 hi lo) -> putWord64le lo <> putWord64le hi) . fromChType -instance Serializable ChUInt8 where serialize _ = execPut . putWord8 . fromChType -instance Serializable ChUInt16 where serialize _ = execPut . putWord16le . fromChType -instance Serializable ChUInt32 where serialize _ = execPut . putWord32le . fromChType -instance Serializable ChUInt64 where serialize _ = execPut . putWord64le . fromChType -instance Serializable ChUInt128 where serialize _ = execPut . (\(Word128 hi lo) -> putWord64le lo <> putWord64le hi) . fromChType -instance Serializable ChDateTime where serialize _ = execPut . putWord32le . fromChType -instance Serializable ChDate where serialize _ = execPut . putWord16le . fromChType - - - - --- ** Generics - -class GSerializable f - where - gSerialize :: ProtocolRevision -> f p -> Builder - -instance - GSerializable f - => - GSerializable (D1 c (C1 c2 f)) - where - {-# INLINE gSerialize #-} - gSerialize rev (M1 (M1 re)) = gSerialize rev re - -instance - GSerializable (left1 :*: (left2 :*: right)) - => - GSerializable ((left1 :*: left2) :*: right) - where - {-# INLINE gSerialize #-} - gSerialize rev ((l1 :*: l2) :*: r) = gSerialize rev (l1 :*: (l2 :*: r)) - -instance - Serializable chType - => - GSerializable (S1 (MetaSel (Just typeName) a b f) (Rec0 chType)) - where - {-# INLINE gSerialize #-} - gSerialize rev = serialize rev . unK1 . unM1 - -instance - (Serializable chType, GSerializable right) - => - GSerializable (S1 (MetaSel (Just typeName) a b f) (Rec0 chType) :*: right) - where - {-# INLINE gSerialize #-} - gSerialize rev (left :*: right) - = (serialize rev . unK1 . unM1 $ left) <> gSerialize rev right diff --git a/ClickHaskell/NativeProtocol.hs b/ClickHaskell/NativeProtocol.hs deleted file mode 100644 --- a/ClickHaskell/NativeProtocol.hs +++ /dev/null @@ -1,443 +0,0 @@ -{-# LANGUAGE - DuplicateRecordFields - , OverloadedStrings - , RecordWildCards -#-} - -module ClickHaskell.NativeProtocol where - --- Internal dependencies -import ClickHaskell.DbTypes -import ClickHaskell.DeSerialization (Serializable(..), Deserializable(..)) -import ClickHaskell.Versioning -import Paths_ClickHaskell (version) - --- GHC included -import Control.Monad (replicateM) -import Data.Text (Text) -import Data.Typeable (Proxy (..)) -import Data.Version (Version (..)) -import GHC.Generics (Generic) -import GHC.TypeLits (KnownNat, natVal) -import Data.String (IsString(..)) - --- * Compatibility - -latestSupportedRevision :: ProtocolRevision -latestSupportedRevision = mostRecentRevision - --- * Client packets - -data ClientPacketType - = Hello - | Query - | Data - | Cancel - | Ping - | TablesStatusRequest - | KeepAlive - | Scalar - | IgnoredPartUUIDs - | ReadTaskResponse - | MergeTreeReadTaskResponse - | SSHChallengeRequest - | SSHChallengeResponse - deriving (Enum, Show) - -type family PacketTypeNumber (packetType :: ClientPacketType) - where - PacketTypeNumber Hello = 0 - PacketTypeNumber Query = 1 - PacketTypeNumber Data = 2 - PacketTypeNumber Cancel = 3 - PacketTypeNumber Ping = 4 - PacketTypeNumber TablesStatusRequest = 5 - PacketTypeNumber KeepAlive = 6 - PacketTypeNumber Scalar = 7 - PacketTypeNumber IgnoredPartUUIDs = 8 - PacketTypeNumber ReadTaskResponse = 9 - PacketTypeNumber MergeTreeReadTaskResponse = 10 - PacketTypeNumber SSHChallengeRequest = 11 - PacketTypeNumber SSHChallengeResponse = 12 - -data Packet (packetType :: ClientPacketType) = MkPacket -instance KnownNat (PacketTypeNumber packetType) => Show (Packet (packetType :: ClientPacketType)) where - show _ = show . toEnum @ClientPacketType . fromIntegral $ packetNumVal @packetType - -packetNumVal :: forall packetType . KnownNat (PacketTypeNumber packetType) => UVarInt -packetNumVal = fromIntegral . natVal $ Proxy @(PacketTypeNumber packetType) - -instance - KnownNat (PacketTypeNumber packetType) - => - Serializable (Packet (packetType :: ClientPacketType)) where - serialize rev _ = serialize @UVarInt rev (packetNumVal @packetType) - -instance Deserializable (Packet (packetType :: ClientPacketType)) where - deserialize _rev = pure (MkPacket @packetType) - - --- ** Hello - -data HelloParameters = MkHelloParameters - { chDatabase :: Text - , chLogin :: Text - , chPass :: Text - } - -mkHelloPacket :: HelloParameters -> HelloPacket -mkHelloPacket MkHelloParameters{chDatabase, chLogin, chPass} = - MkHelloPacket - { packet_type = MkPacket - , client_name = clientNameAndVersion - , client_version_major = clientMajorVersion - , client_version_minor = clientMinorVersion - , tcp_protocol_version = latestSupportedRevision - , default_database = toChType chDatabase - , user = toChType chLogin - , password = toChType chPass - } - -data HelloPacket = MkHelloPacket - { packet_type :: Packet Hello - , client_name :: ChString - , client_version_major :: UVarInt - , client_version_minor :: UVarInt - , tcp_protocol_version :: ProtocolRevision - , default_database :: ChString - , user :: ChString - , password :: ChString - } - deriving (Generic, Serializable) - - -mkAddendum :: Addendum -mkAddendum = MkAddendum - { quota_key = MkSinceRevision "" - } - -data Addendum = MkAddendum - { quota_key :: ChString `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_QUOTA_KEY - } - deriving (Generic, Serializable) - - --- ** Ping - -mkPingPacket :: PingPacket -mkPingPacket = MkPingPacket{packet_type = MkPacket} - -data PingPacket = MkPingPacket{packet_type :: Packet Ping} - deriving (Generic, Serializable) - - --- ** Query - -mkQueryPacket :: ProtocolRevision -> ChString -> ChString -> QueryPacket -mkQueryPacket chosenRev user query = MkQueryPacket - { query_packet = MkPacket - , query_id = "" - , client_info = MkSinceRevision MkClientInfo - { query_kind = InitialQuery - , initial_user = user - , initial_query_id = "" - , initial_adress = "0.0.0.0:0" - , initial_time = MkSinceRevision 0 - , interface_type = 1 -- [tcp - 1, http - 2] - , os_user = "dmitry" - , hostname = "desktop" - , client_name = clientNameAndVersion - , client_major = clientMajorVersion - , client_minor = clientMinorVersion - , client_revision = chosenRev - , quota_key = MkSinceRevision "" - , distrubuted_depth = MkSinceRevision 0 - , client_patch = MkSinceRevision clientPatchVersion - , open_telemetry = MkSinceRevision 0 - , collaborate_with_initiator = MkSinceRevision 0 - , count_participating_replicas = MkSinceRevision 0 - , number_of_current_replica = MkSinceRevision 0 - } - , settings = MkDbSettings - , interserver_secret = MkSinceRevision "" - , query_stage = Complete - , compression = 0 - , query = query - , parameters = MkSinceRevision MkQueryParameters - } - -data QueryPacket = MkQueryPacket - { query_packet :: Packet Query - , query_id :: ChString - , client_info :: ClientInfo `SinceRevision` DBMS_MIN_REVISION_WITH_CLIENT_INFO - , settings :: DbSettings - , interserver_secret :: ChString `SinceRevision` DBMS_MIN_REVISION_WITH_INTERSERVER_SECRET - , query_stage :: QueryStage - , compression :: UVarInt - , query :: ChString - , parameters :: QueryParameters `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_PARAMETERS - } - deriving (Generic, Serializable) - -data DbSettings = MkDbSettings -instance Serializable DbSettings where serialize rev _ = serialize @ChString rev "" - -data QueryParameters = MkQueryParameters -instance Serializable QueryParameters where serialize rev _ = serialize @ChString rev "" - -data QueryStage - = FetchColumns - | WithMergeableState - | Complete - | WithMergeableStateAfterAggregation - | WithMergeableStateAfterAggregationAndLimit - deriving (Enum) - -instance Serializable QueryStage where - serialize rev = serialize @UVarInt rev . fromIntegral . fromEnum - -queryStageCode :: QueryStage -> UVarInt -queryStageCode = fromIntegral . fromEnum - -data Flags = IMPORTANT | CUSTOM | OBSOLETE -flagCode :: Flags -> ChUInt64 -flagCode IMPORTANT = 0x01 -flagCode CUSTOM = 0x02 -flagCode OBSOLETE = 0x04 - -data ClientInfo = MkClientInfo - { query_kind :: QueryKind - , initial_user :: ChString - , initial_query_id :: ChString - , initial_adress :: ChString - , initial_time :: ChInt64 `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_INITIAL_QUERY_START_TIME - , interface_type :: ChUInt8 - , os_user :: ChString - , hostname :: ChString - , client_name :: ChString - , client_major :: UVarInt - , client_minor :: UVarInt - , client_revision :: ProtocolRevision - , quota_key :: ChString `SinceRevision` DBMS_MIN_REVISION_WITH_QUOTA_KEY_IN_CLIENT_INFO - , distrubuted_depth :: UVarInt `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_DISTRIBUTED_DEPTH - , client_patch :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_VERSION_PATCH - , open_telemetry :: ChUInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_OPENTELEMETRY - , collaborate_with_initiator :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_PARALLEL_REPLICAS - , count_participating_replicas :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_PARALLEL_REPLICAS - , number_of_current_replica :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_PARALLEL_REPLICAS - } - deriving (Generic, Serializable) - -data QueryKind = NoQuery | InitialQuery | SecondaryQuery - deriving (Enum) - -instance Serializable QueryKind where - serialize rev = serialize @ChUInt8 rev . fromIntegral . fromEnum - - --- ** Data - -mkDataPacket :: ChString -> UVarInt -> UVarInt -> DataPacket -mkDataPacket table_name columns_count rows_count = - MkDataPacket - { packet_type = MkPacket - , table_name - , block_info = MkBlockInfo - { field_num1 = 1, is_overflows = 0 - , field_num2 = 2, bucket_num = -1 - , eof = 0 - } - , columns_count - , rows_count - } - -data DataPacket = MkDataPacket - { packet_type :: Packet Data - , table_name :: ChString - , block_info :: BlockInfo - , columns_count :: UVarInt - , rows_count :: UVarInt - } - deriving (Generic, Serializable, Deserializable, Show) - -data BlockInfo = MkBlockInfo - { field_num1 :: UVarInt, is_overflows :: ChUInt8 - , field_num2 :: UVarInt, bucket_num :: ChInt32 - , eof :: UVarInt - } - deriving (Generic, Serializable, Deserializable, Show) - - - - --- * Server packets - -data ServerPacketType where - HelloResponse :: HelloResponse -> ServerPacketType - DataResponse :: DataPacket -> ServerPacketType - Exception :: ExceptionPacket -> ServerPacketType - Progress :: ProgressPacket -> ServerPacketType - Pong :: ServerPacketType - EndOfStream :: ServerPacketType - ProfileInfo :: ProfileInfo -> ServerPacketType - Totals :: ServerPacketType - Extremes :: ServerPacketType - TablesStatusResponse :: ServerPacketType - Log :: ServerPacketType - TableColumns :: TableColumns -> ServerPacketType - UUIDs :: ServerPacketType - ReadTaskRequest :: ServerPacketType - ProfileEvents :: ServerPacketType - UnknownPacket :: UVarInt -> ServerPacketType - -instance Deserializable ServerPacketType where - deserialize rev = do - packetNum <- deserialize @UVarInt rev - case packetNum of - 0 -> HelloResponse <$> deserialize rev - 1 -> DataResponse <$> deserialize rev - 2 -> Exception <$> deserialize rev - 3 -> Progress <$> deserialize rev - 4 -> pure Pong - 5 -> pure EndOfStream - 6 -> ProfileInfo <$> deserialize rev - 7 -> pure Totals - 8 -> pure Extremes - 9 -> pure TablesStatusResponse - 10 -> pure Log - 11 -> TableColumns <$> deserialize rev - 12 -> pure UUIDs - 13 -> pure ReadTaskRequest - 14 -> pure ProfileEvents - _ -> pure $ UnknownPacket packetNum - -instance Show ServerPacketType where - show (HelloResponse hello) = "HelloResponse " <> show hello - show (DataResponse dataPacket) = "DataResponse " <> show dataPacket - show (Exception exception) = "Exception " <> show exception - show (Progress progress) = "Progress " <> show progress - show Pong = "Pong" - show EndOfStream = "EndOfStream" - show (ProfileInfo profileInfo) = "ProfileInfo " <> show profileInfo - show Totals = "Totals" - show Extremes = "Extremes" - show TablesStatusResponse = "TablesStatusResponse" - show Log = "Log" - show (TableColumns tabelColumnsPacket) = "TableColumns " <> show tabelColumnsPacket - show UUIDs = "UUIDs" - show ReadTaskRequest = "ReadTaskRequest" - show ProfileEvents = "ProfileEvents" - show (UnknownPacket packetNum) = "UnknownPacket: " <> show packetNum - --- ** HelloResponse - -{- - https://github.com/ClickHouse/ClickHouse/blob/eb4a74d7412a1fcf52727cd8b00b365d6b9ed86c/src/Client/Connection.cpp#L520 --} -data HelloResponse = MkHelloResponse - { server_name :: ChString - , server_version_major :: UVarInt - , server_version_minor :: UVarInt - , server_revision :: ProtocolRevision - , server_parallel_replicas_proto :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_VERSIONED_PARALLEL_REPLICAS_PROTOCOL - , server_timezone :: ChString `SinceRevision` DBMS_MIN_REVISION_WITH_SERVER_TIMEZONE - , server_display_name :: ChString `SinceRevision` DBMS_MIN_REVISION_WITH_SERVER_DISPLAY_NAME - , server_version_patch :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_VERSION_PATCH - , proto_send_chunked_srv :: ChString `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_CHUNKED_PACKETS - , proto_recv_chunked_srv :: ChString `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_CHUNKED_PACKETS - , password_complexity_rules :: [PasswordComplexityRules] `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_PASSWORD_COMPLEXITY_RULES - , read_nonce :: ChUInt64 `SinceRevision` DBMS_MIN_REVISION_WITH_INTERSERVER_SECRET_V2 - } - deriving (Generic, Show) - -instance Deserializable HelloResponse where - deserialize revision = do - server_name <- deserialize revision - server_version_major <- deserialize revision - server_version_minor <- deserialize revision - server_revision <- deserialize revision - -- Override current protocol revision for backward compatibility - let chosenRevision = min server_revision revision - server_parallel_replicas_proto <- deserialize chosenRevision - server_timezone <- deserialize chosenRevision - server_display_name <- deserialize chosenRevision - server_version_patch <- deserialize chosenRevision - proto_send_chunked_srv <- deserialize chosenRevision - proto_recv_chunked_srv <- deserialize chosenRevision - password_complexity_rules <- deserialize chosenRevision - read_nonce <- deserialize chosenRevision - pure MkHelloResponse{..} - -data PasswordComplexityRules = MkPasswordComplexityRules - { original_pattern :: ChString - , exception_message :: ChString - } - deriving (Generic, Deserializable, Show) - -instance Deserializable [PasswordComplexityRules] where - deserialize rev = do - len <- deserialize @UVarInt rev - replicateM (fromIntegral len) (deserialize @PasswordComplexityRules rev) - --- ** Exception - -data ExceptionPacket = MkExceptionPacket - { code :: ChInt32 - , name :: ChString - , message :: ChString - , stack_trace :: ChString - , nested :: ChUInt8 - } - deriving (Generic, Deserializable, Show) - --- ** Progress - -data ProgressPacket = MkProgressPacket - { rows :: UVarInt - , bytes :: UVarInt - , total_rows :: UVarInt - , total_bytes :: UVarInt `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_TOTAL_BYTES_IN_PROGRESS - , wrote_rows :: UVarInt `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_TOTAL_BYTES_IN_PROGRESS - , wrote_bytes :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_CLIENT_WRITE_INFO - , elapsed_ns :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_CLIENT_WRITE_INFO - } - deriving (Generic, Deserializable, Show) - --- ** ProfileInfo - -data ProfileInfo = MkProfileInfo - { rows :: UVarInt - , blocks :: UVarInt - , bytes :: UVarInt - , applied_limit :: ChUInt8 - , rows_before_limit :: UVarInt - , calculated_rows_before_limit :: ChUInt8 - , applied_aggregation :: ChUInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_ROWS_BEFORE_AGGREGATION - , rows_before_aggregation :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_ROWS_BEFORE_AGGREGATION - } - deriving (Generic, Deserializable, Show) - --- ** TableColumns - -data TableColumns = MkTableColumns - { table_name :: ChString - , table_columns :: ChString - } - deriving (Generic, Deserializable, Show) - - - - --- * Versioning - -clientMajorVersion, clientMinorVersion, clientPatchVersion :: UVarInt -clientMajorVersion = case versionBranch version of (x:_) -> fromIntegral x; _ -> 0 -clientMinorVersion = case versionBranch version of (_:x:_) -> fromIntegral x; _ -> 0 -clientPatchVersion = case versionBranch version of (_:_:x:_) -> fromIntegral x; _ -> 0 - -clientNameAndVersion :: ChString -clientNameAndVersion = fromString $ - "ClickHaskell-" - <> show clientMajorVersion <> "." - <> show clientMinorVersion <> "." - <> show clientPatchVersion <> "." diff --git a/ClickHaskell/Parameters.hs b/ClickHaskell/Parameters.hs deleted file mode 100644 --- a/ClickHaskell/Parameters.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE - OverloadedStrings - , TypeFamilyDependencies - , UndecidableInstances -#-} - -module ClickHaskell.Parameters where - --- Internal -import ClickHaskell.DbTypes (ToQueryPart(..), ToChType(..)) - --- GHC included -import Data.ByteString.Builder as BS (Builder, byteString) -import Data.ByteString.Char8 as BS8 (pack) -import Data.Data (Proxy (Proxy)) -import Data.Kind (Type, Constraint) -import GHC.TypeLits (TypeError, ErrorMessage (..), Symbol, KnownSymbol, symbolVal) -import Data.Type.Bool (If) -import Data.Type.Equality (type(==)) - -data Parameter (name :: Symbol) (chType :: Type) - --- | --- >>> parameters (parameter @"a3" @ChString ("a3Val" :: String) . parameter @"a2" @ChString ("a2Val" :: String)) --- "(a2='a2Val', a3='a3Val')" -parameters :: forall (params :: [Type]) . (Parameters '[] -> Parameters params) -> Builder -parameters interpreter = renderParameters $ interpreter (MkParametersInterpreter []) - -parameter - :: forall name chType parameters userType - . (InterpretableParameters parameters, ToChType chType userType, KnownSymbol name, ToQueryPart chType) - => userType -> Parameters parameters -> WithPassedParameter (Parameter name chType) parameters -parameter = interpretParameter . toChType - -renderParameters :: Parameters parameters -> Builder -renderParameters (MkParametersInterpreter (param:ps)) = "(" <> foldr (\p1 p2 -> p1 <> ", " <> p2) param ps <> ")" -renderParameters (MkParametersInterpreter []) = "" - - -{-# DEPRECATED ParametersInterpreter "This type would be removed in next major release. Use Parameters instead" #-} -type ParametersInterpreter a = Parameters a - -newtype Parameters (parameters :: [Type]) = - MkParametersInterpreter - { evaluatedParameters :: [Builder] - } - -class InterpretableParameters (ps :: [Type]) where - type WithPassedParameter p ps = withPassedParameter | withPassedParameter -> ps p - interpretParameter - :: forall name chType - . (KnownSymbol name, ToQueryPart chType) - => chType -> (Parameters ps -> WithPassedParameter (Parameter name chType) ps) - -instance InterpretableParameters '[] - where - type WithPassedParameter p '[] = Parameters '[p] - interpretParameter - :: forall name chType - . (KnownSymbol name, ToQueryPart chType) - => chType -> Parameters '[] -> WithPassedParameter (Parameter name chType) '[] - interpretParameter userType _ = MkParametersInterpreter [renderParameter @name @chType userType] - -instance InterpretableParameters (x ': xs) - where - type WithPassedParameter p (x ': xs) = Parameters (p ': (x ': xs)) - interpretParameter - :: forall name chType - . (KnownSymbol name, ToQueryPart chType) - => chType -> Parameters (x : xs) -> WithPassedParameter (Parameter name chType) (x : xs) - interpretParameter chType (MkParametersInterpreter{evaluatedParameters}) = - MkParametersInterpreter $ renderParameter @name @chType chType : evaluatedParameters - -renderParameter :: forall name chType . (KnownSymbol name, ToQueryPart chType) => chType -> Builder -renderParameter chType = (BS.byteString . BS8.pack . symbolVal @name) Proxy <> "=" <> toQueryPart chType - -type family CheckParameters - (tableFunctionParams :: [Type]) - (passedParams :: [Type]) - :: Constraint - where - CheckParameters tfs ps = (CheckDuplicates ps, GoCheckParameters tfs ps '[] True) - -type family CheckDuplicates - (passedParams :: [Type]) - :: Constraint - where - CheckDuplicates '[] = () - CheckDuplicates (p ': ps) = (CheckParamDuplicates p ps, CheckDuplicates ps) - -type family CheckParamDuplicates - (param :: Type) - (passedParams :: [Type]) - :: Constraint - where - CheckParamDuplicates _ '[] = () - CheckParamDuplicates (Parameter name1 chType) (Parameter name2 _ ': ps) = If - (name1 == name2) - (TypeError ('Text "Duplicated parameter \"" :<>: 'Text name1 :<>: 'Text "\" in passed parameters")) - (CheckParamDuplicates (Parameter name1 chType) ps) - -type family GoCheckParameters - (tableFunctionParams :: [Type]) - (passedParams :: [Type]) - (acc :: [Type]) - (firstRound :: Bool) - :: Constraint - where - GoCheckParameters '[] '[] '[] _ = () - GoCheckParameters (Parameter name _ ': _) '[] '[] _ = TypeError - ('Text "Missing \"" :<>: 'Text name :<>: 'Text "\" in passed parameters.") - GoCheckParameters '[] (p ': _) _ _ = - TypeError ('Text "More parameters passed than used in the view") - GoCheckParameters '[] '[] (p ': _) _ = - TypeError ('Text "More parameters passed than used in the view") - GoCheckParameters (Parameter name1 _ ': ps) '[] (Parameter name2 _ ': ps') False = - TypeError ('Text "Missing \"" :<>: 'Text name1 :<>: 'Text "\" in passed parameters") - GoCheckParameters (p ': ps) '[] (p' ': ps') True = - GoCheckParameters (p ': ps) (p' ': ps') '[] False - GoCheckParameters (Parameter name1 _ ': ps) (Parameter name1 _ ': ps') acc b = - (GoCheckParameters ps ps' acc True) - GoCheckParameters (Parameter name1 chType1 ': ps) (Parameter name2 chType2 ': ps') acc b = - (GoCheckParameters (Parameter name1 chType1 ': ps) ps' (Parameter name2 chType2 ': acc) b) diff --git a/ClickHaskell/Versioning.hs b/ClickHaskell/Versioning.hs deleted file mode 100644 --- a/ClickHaskell/Versioning.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module ClickHaskell.Versioning where - --- GHC included -import Data.Typeable (Proxy (..)) -import GHC.TypeLits -import Data.Word (Word64) - -newtype ProtocolRevision = MkProtocolRevision Word64 - deriving newtype (Show, Eq, Num, Ord) - -{-# INLINE [0] afterRevision #-} -afterRevision - :: forall revision monoid - . (KnownNat revision, Monoid monoid) - => ProtocolRevision -> monoid -> monoid -afterRevision chosenRevision monoid = - if chosenRevision >= (fromIntegral . natVal) (Proxy @revision) - then monoid - else mempty - -{-# INLINE [0] mostRecentRevision #-} -mostRecentRevision :: ProtocolRevision -mostRecentRevision = (fromIntegral . natVal) (Proxy @DBMS_TCP_PROTOCOL_VERSION) - -data SinceRevision a (revisionNumber :: Nat) = MkSinceRevision a | NotPresented -instance Show a => Show (SinceRevision a revisionNumber) where - show (MkSinceRevision a) = show a - show NotPresented = "" - --- ** Versions - -{- - Slightly modified C++ sources: - https://github.com/ClickHouse/ClickHouse/blob/eb4a74d7412a1fcf52727cd8b00b365d6b9ed86c/src/Core/ProtocolDefines.h#L6 --} -type DBMS_TCP_PROTOCOL_VERSION = 54448; - -type DBMS_MIN_REVISION_WITH_CLIENT_INFO = 54032; -type DBMS_MIN_REVISION_WITH_SERVER_TIMEZONE = 54058; -type DBMS_MIN_REVISION_WITH_QUOTA_KEY_IN_CLIENT_INFO = 54060; -type DBMS_MIN_REVISION_WITH_TABLES_STATUS = 54226; -type DBMS_MIN_REVISION_WITH_TIME_ZONE_PARAMETER_IN_DATETIME_DATA_TYPE = 54337; -type DBMS_MIN_REVISION_WITH_SERVER_DISPLAY_NAME = 54372; -type DBMS_MIN_REVISION_WITH_VERSION_PATCH = 54401; -type DBMS_MIN_REVISION_WITH_SERVER_LOGS = 54406; -type DBMS_MIN_REVISION_WITH_CURRENT_AGGREGATION_VARIANT_SELECTION_METHOD = 54448; -type DBMS_MIN_MAJOR_VERSION_WITH_CURRENT_AGGREGATION_VARIANT_SELECTION_METHOD = 21; -type DBMS_MIN_MINOR_VERSION_WITH_CURRENT_AGGREGATION_VARIANT_SELECTION_METHOD = 4; -type DBMS_MIN_REVISION_WITH_COLUMN_DEFAULTS_METADATA = 54410; -type DBMS_MIN_REVISION_WITH_LOW_CARDINALITY_TYPE = 54405; -type DBMS_MIN_REVISION_WITH_CLIENT_WRITE_INFO = 54420; -type DBMS_MIN_REVISION_WITH_SETTINGS_SERIALIZED_AS_STRINGS = 54429; -type DBMS_MIN_REVISION_WITH_SCALARS = 54429; -type DBMS_MIN_REVISION_WITH_OPENTELEMETRY = 54442; -type DBMS_MIN_REVISION_WITH_AGGREGATE_FUNCTIONS_VERSIONING = 54452; -type DBMS_CLUSTER_PROCESSING_PROTOCOL_VERSION = 1; -type DBMS_MIN_SUPPORTED_PARALLEL_REPLICAS_PROTOCOL_VERSION = 3; -type DBMS_PARALLEL_REPLICAS_MIN_VERSION_WITH_MARK_SEGMENT_SIZE_FIELD = 4; -type DBMS_PARALLEL_REPLICAS_PROTOCOL_VERSION = 4; -type DBMS_MIN_REVISION_WITH_PARALLEL_REPLICAS = 54453; -type DBMS_MERGE_TREE_PART_INFO_VERSION = 1; -type DBMS_MIN_REVISION_WITH_INTERSERVER_SECRET = 54441; -type DBMS_MIN_REVISION_WITH_X_FORWARDED_FOR_IN_CLIENT_INFO = 54443; -type DBMS_MIN_REVISION_WITH_REFERER_IN_CLIENT_INFO = 54447; -type DBMS_MIN_PROTOCOL_VERSION_WITH_DISTRIBUTED_DEPTH = 54448; -type DBMS_MIN_PROTOCOL_VERSION_WITH_INCREMENTAL_PROFILE_EVENTS = 54451; -type DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION = 54454; -type DBMS_MIN_PROTOCOL_VERSION_WITH_INITIAL_QUERY_START_TIME = 54449; -type DBMS_MIN_PROTOCOL_VERSION_WITH_PROFILE_EVENTS_IN_INSERT = 54456; -type DBMS_MIN_PROTOCOL_VERSION_WITH_VIEW_IF_PERMITTED = 54457; -type DBMS_MIN_PROTOCOL_VERSION_WITH_ADDENDUM = 54458; -type DBMS_MIN_PROTOCOL_VERSION_WITH_QUOTA_KEY = 54458; -type DBMS_MIN_PROTOCOL_VERSION_WITH_PARAMETERS = 54459; -type DBMS_MIN_PROTOCOL_VERSION_WITH_SERVER_QUERY_TIME_IN_PROGRESS = 54460; -type DBMS_MIN_PROTOCOL_VERSION_WITH_PASSWORD_COMPLEXITY_RULES = 54461; -type DBMS_MIN_REVISION_WITH_INTERSERVER_SECRET_V2 = 54462; -type DBMS_MIN_PROTOCOL_VERSION_WITH_TOTAL_BYTES_IN_PROGRESS = 54463; -type DBMS_MIN_PROTOCOL_VERSION_WITH_TIMEZONE_UPDATES = 54464; -type DBMS_MIN_REVISION_WITH_SPARSE_SERIALIZATION = 54465; -type DBMS_MIN_REVISION_WITH_SSH_AUTHENTICATION = 54466; -type DBMS_MIN_REVISION_WITH_TABLE_READ_ONLY_CHECK = 54467; -type DBMS_MIN_REVISION_WITH_SYSTEM_KEYWORDS_TABLE = 54468; -type DBMS_MIN_REVISION_WITH_ROWS_BEFORE_AGGREGATION = 54469; -type DBMS_MIN_PROTOCOL_VERSION_WITH_CHUNKED_PACKETS = 54470; -type DBMS_MIN_REVISION_WITH_VERSIONED_PARALLEL_REPLICAS_PROTOCOL = 54471; diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,28 @@ -Copyright (c) 2023, Kovalev Dmitry +BSD 3-Clause License -All rights reserved. +Copyright (c) 2025, Dmitry Kovalev Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. - * Neither the name of Kovalev Dmitry nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,14 @@ -# Description +# ClickHaskell -ClickHaskell is a Haskell implementation of\ -[ClickHouse](https://clickhouse.com/) DBMS Native protocol and client +Haskell implementation of [ClickHouse](https://clickhouse.com/) DBMS Native protocol and client -You can find more details on [documentation page](https://kovalevdima.github.io/ClickHaskell/) +ClickHaskell allows you: + +1. to handle 1+ million rows per second +2. to share single connection between multiple threads +3. to build reliable CI/CD and ship DBMS integrations faster + +Visit [Home page](https://clickhaskell.dev/) to learn more + +## ⚠️ Current version is unstable +ClickHaskell 1.0.0 will be released after most of the negative case tests have been implemented. Until then, you may encounter unexpected behavior