diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md diff --git a/ClickHaskell.cabal b/ClickHaskell.cabal new file mode 100644 --- /dev/null +++ b/ClickHaskell.cabal @@ -0,0 +1,108 @@ +Cabal-version: 3.4 + + +Name: ClickHaskell +Version: 0.1.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 +License: BSD-3-Clause +License-File: LICENSE +Copyright: 2023 Kovalev Dmitry +Build-Type: Simple + +extra-doc-files: + 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 + , bytestring < 0.13 + , binary < 9 + , 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 new file mode 100644 --- /dev/null +++ b/ClickHaskell.hs @@ -0,0 +1,418 @@ +{-# 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) diff --git a/ClickHaskell/Columns.hs b/ClickHaskell/Columns.hs new file mode 100644 --- /dev/null +++ b/ClickHaskell/Columns.hs @@ -0,0 +1,564 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/ClickHaskell/DbTypes.hs @@ -0,0 +1,553 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/ClickHaskell/DeSerialization.hs @@ -0,0 +1,218 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/ClickHaskell/NativeProtocol.hs @@ -0,0 +1,443 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/ClickHaskell/Parameters.hs @@ -0,0 +1,123 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/ClickHaskell/Versioning.hs @@ -0,0 +1,86 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Kovalev Dmitry + +All rights reserved. + +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. + + * 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. + +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 +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +# Description + +ClickHaskell is a 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/) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain