ClickHaskell
2 |
3 | Haskell implementation of [ClickHouse](https://clickhouse.com/) DBMS Native protocol and client
4 |
5 | ## Why ClickHouse+Haskell?
6 |
7 | ClickHouse is a well known open source DBMS for building data intensive apps
8 |
9 | Its design philosophy is close to functional programming due to `append-only`, support of `lambdas` and `higher-order functions`
10 |
11 | It's a best-in-class database for storing data in event-driven architecture
12 |
13 | ## Why ClickHaskell?
14 |
15 | Pros:
16 |
17 | 35 | ├contribution/ Development related code 36 | ├library/ ClickHaskell source code 37 | └documentation/ clickhaskell.dev/ source code 38 |39 | 40 | ## General state of ClickHouse+Haskell 41 | 42 | There are no other actively maintained open source alternatives to ClickHaskell at this moment. 43 | 44 | All of the abandoned projects have hard-to-maintain codebases and poorer QA: 45 | 46 |
" )
44 | . putLinesInfo fp
45 | . parseTagsOptions parseOptions{optTagPosition=True}
46 | $ str
47 |
48 | putLinesInfo :: FilePath -> [Tag String] -> [Tag String]
49 | putLinesInfo fp = go []
50 | where
51 | go acc ((TagPosition line _):(TagOpen "code" attrs):xs) =
52 | if ("data-lang","haskell") `elem` attrs
53 | then (TagOpen "code" attrs) : TagText ("#line " <> show (line+1) <> " " <> show fp <> "\n") : go acc xs
54 | else (TagOpen "code" attrs) : go acc xs
55 | go acc (x:xs) = x : go acc xs
56 | go acc [] = acc
57 |
--------------------------------------------------------------------------------
/contribution/html2hs/html2hs.cabal:
--------------------------------------------------------------------------------
1 | Cabal-version: 3.0
2 |
3 |
4 | name: html2hs
5 | version: 0.0.0.1
6 | build-type: Simple
7 | license: BSD-3-Clause
8 |
9 | executable html2hs
10 | main-is: Html2Hs.hs
11 | build-depends:
12 | base
13 | , tagsoup
14 | ghc-options:
15 | -threaded -Wall
16 | default-language: Haskell2010
17 |
--------------------------------------------------------------------------------
/contribution/localServer.nix:
--------------------------------------------------------------------------------
1 | {app, agent, docDirPath, inputs, pkgs}:
2 | {
3 | imports = [inputs.services-flake.processComposeModules.default];
4 | services.clickhouse."database" = {
5 | enable = true;
6 | initialDatabases = [ {name="default";} ];
7 | extraConfig = {
8 | http_port = 8123;
9 | listen-host = "localhost";
10 | tcp_port_secure = 9440;
11 | openSSL = {
12 | server = {
13 | certificateFile = ./certs/localhost.crt;
14 | privateKeyFile = ./certs/localhost.key;
15 | };
16 | };
17 | };
18 | };
19 | settings.processes = {
20 | "executable" = {
21 | command = ''
22 | CLICKHASKELL_STATIC_FILES_DIR=./documentation/ \
23 | EVENTLOG_SOCKET_PATH="./data/.eventlog.sock" \
24 | DEV= \
25 | ${app.program} +RTS -l-agpf --eventlog-flush-interval=1 -RTS
26 | '';
27 | depends_on."database".condition = "process_healthy";
28 | };
29 | "agent" = {
30 | command = ''
31 | sleep 3
32 | EVENTLOG_SOCKET_PATH="./data/.eventlog.sock" \
33 | ${agent.program}
34 | '';
35 | depends_on."executable".condition = "process_started";
36 | };
37 | };
38 | services.grafana."grafana" = {
39 | enable = true;
40 | http_port = 8080;
41 | datasources = [
42 | {
43 | name = "ClickHouse";
44 | type = "grafana-clickhouse-datasource";
45 | jsonData = {
46 | port = "9000";
47 | host = "localhost";
48 | };
49 | }
50 | ];
51 | declarativePlugins = [
52 | pkgs.grafanaPlugins.grafana-clickhouse-datasource
53 | ];
54 | };
55 | }
56 |
--------------------------------------------------------------------------------
/contribution/modules/eventlog-writer/ClickHaskell-eventlog-writer.cabal:
--------------------------------------------------------------------------------
1 | Cabal-version: 3.0
2 | name: ClickHaskell-eventlog-writer
3 | version: 0.0.0.1
4 | build-type: Simple
5 | license: BSD-3-Clause
6 |
7 | executable eventlog-agent
8 | main-is: eventlog-agent.hs
9 | default-language: Haskell2010
10 | build-depends:
11 | ClickHaskell
12 | , aeson
13 | , async
14 | , base >=4.7 && <5
15 | , bytestring
16 | , text
17 | , time
18 | , network
19 | , stm
20 | , ghc-events
21 | ghc-options:
22 | -Wall
23 | -Wunused-packages
24 |
--------------------------------------------------------------------------------
/contribution/modules/eventlog-writer/eventlog-agent.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE NumericUnderscores #-}
2 | {-# LANGUAGE TypeApplications #-}
3 | {-# LANGUAGE LambdaCase #-}
4 | {-# LANGUAGE RecordWildCards #-}
5 | {-# LANGUAGE NamedFieldPuns #-}
6 | {-# LANGUAGE OverloadedStrings #-}
7 | {-# LANGUAGE TupleSections #-}
8 | {-# LANGUAGE DataKinds #-}
9 | {-# LANGUAGE TypeSynonymInstances #-}
10 | {-# LANGUAGE FlexibleInstances #-}
11 | {-# LANGUAGE MultiParamTypeClasses #-}
12 | {-# LANGUAGE DeriveGeneric #-}
13 | {-# LANGUAGE DeriveAnyClass #-}
14 |
15 | module Main (main) where
16 |
17 | import ClickHaskell
18 | import Control.Concurrent (threadDelay)
19 | import Control.Concurrent.Async (Concurrently (..))
20 | import Control.Concurrent.STM (TBQueue, atomically, flushTBQueue, newTBQueueIO, writeTBQueue)
21 | import Control.Exception (SomeException, bracketOnError, catch, finally)
22 | import Control.Monad (forever, void)
23 | import Data.ByteString as BS (ByteString, length)
24 | import Data.IORef (IORef, atomicModifyIORef, atomicWriteIORef, newIORef, readIORef)
25 | import Data.Text as T (pack)
26 | import Data.Time (UTCTime, getCurrentTime)
27 | import GHC.Generics (Generic)
28 | import GHC.RTS.Events (Event (..), EventInfo (..), Header)
29 | import GHC.RTS.Events.Incremental (Decoder (..), decodeEvents, decodeHeader)
30 | import Network.Socket
31 | import Network.Socket.ByteString (recv)
32 | import System.Environment (lookupEnv)
33 | import System.Timeout (timeout)
34 |
35 | main :: IO ()
36 | main = do
37 | lookupEnv "EVENTLOG_SOCKET_PATH"
38 | >>= \case
39 | Nothing -> pure ()
40 | Just socketPath -> do
41 | conn <- initChConnection
42 | queue <- newTBQueueIO @EventRep 1_000_000
43 | time <- getCurrentTime
44 | runConcurrently
45 | $ pure ()
46 | *> runClickHouseWriter conn queue
47 | *> chEventlogWrite socketPath (atomically . writeTBQueue queue . eventToRep time)
48 |
49 |
50 | -- * Network
51 |
52 | chEventlogWrite :: FilePath -> (Event -> IO ()) -> Concurrently ()
53 | chEventlogWrite socketPath writeEvent = Concurrently $ do
54 | sock <-
55 | maybe (error "Socket connection timeout") pure
56 | =<< timeout 3_000_000 (
57 | bracketOnError
58 | (socket AF_UNIX Stream 0)
59 | (\sock ->
60 | catch @SomeException
61 | (finally (shutdown sock ShutdownBoth) (close sock))
62 | (const $ pure ())
63 | )
64 | (\sock -> do
65 | connect sock (SockAddrUnix socketPath)
66 | pure sock
67 | )
68 | )
69 | streamFromSocket writeEvent sock
70 |
71 |
72 | streamFromSocket :: (Event -> IO ()) -> Socket -> IO ()
73 | streamFromSocket writeEvent sock = do
74 | buffer <- initBuffer sock
75 | header <- readHeader buffer decodeHeader
76 | (void . forever) (processEvents buffer writeEvent (decodeEvents header))
77 |
78 | processEvents :: Buffer -> (a -> IO ()) -> Decoder a -> IO ()
79 | processEvents buff writeEvent decoder = case decoder of
80 | Produce res dec -> do
81 | writeEvent res
82 | processEvents buff writeEvent dec
83 | Consume dec -> do
84 | buffValue <- readBuffer buff
85 | processEvents buff writeEvent (dec buffValue)
86 | Error _bs err -> error err
87 | Done _ -> error "Unexpected done"
88 |
89 |
90 | readHeader :: Buffer -> Decoder Header -> IO Header
91 | readHeader buff decoder = case decoder of
92 | Consume dec -> readHeader buff . dec =<< readBuffer buff
93 | Produce res (Done left) -> writeToBuffer buff left *> pure res
94 | Error _bs err -> error err
95 | Produce _res _dec -> error "Unexpected extra result in header decoder"
96 | Done _ -> error "Unexpected done in header decoder"
97 |
98 |
99 | data Buffer = MkBuffer {bufferSocket :: Socket, buff :: IORef ByteString}
100 |
101 | initBuffer :: Socket -> IO Buffer
102 | initBuffer sock = MkBuffer sock <$> newIORef ""
103 |
104 | writeToBuffer :: Buffer -> BS.ByteString -> IO ()
105 | writeToBuffer MkBuffer{..} val = void (atomicModifyIORef buff (val,))
106 |
107 | readBuffer :: Buffer -> IO BS.ByteString
108 | readBuffer MkBuffer{..} =
109 | readIORef buff
110 | >>= (\currentBuffer ->
111 | case BS.length currentBuffer of
112 | 0 -> recv bufferSocket 4096
113 | _ -> atomicWriteIORef buff "" *> pure currentBuffer
114 | )
115 |
116 |
117 |
118 |
119 | -- * ClickHouse
120 |
121 | runClickHouseWriter :: Connection -> TBQueue EventRep -> Concurrently ()
122 | runClickHouseWriter conn queue =
123 | Concurrently $
124 | void . forever $ do
125 | write conn =<< atomically (flushTBQueue queue)
126 | threadDelay 1_000_000
127 |
128 | initChConnection :: IO Connection
129 | initChConnection = do
130 | host <- lookupEnv "CLICKHOUSE_HOST"
131 | db <- lookupEnv "CLICKHOUSE_DB"
132 | user <- lookupEnv "CLICKHOUSE_USER"
133 | pass <- lookupEnv "CLICKHOUSE_PASS"
134 | conn <-
135 | openConnection
136 | . maybe id (setPort) host
137 | . maybe id (setUser . T.pack) user
138 | . maybe id (setPassword . T.pack) pass
139 | . maybe id (setDatabase . T.pack) db
140 | $ defaultConnectionArgs
141 | createEventLogTable conn
142 | pure conn
143 |
144 | data EventRep = MkEventRep
145 | { startTime :: UTCTime
146 | , evTime :: UInt64
147 | , evType :: ByteString
148 | }
149 | deriving (Generic, ClickHaskell EventLogColumns)
150 |
151 | write :: Connection -> [EventRep] -> IO ()
152 | write = insertInto @EventLogTable @EventRep
153 |
154 | type EventLogTable = Table "haskell_eventlog" EventLogColumns
155 | type EventLogColumns =
156 | '[ Column "startTime" (DateTime "")
157 | , Column "evTime" (DateTime64 9 "")
158 | , Column "evType" (ChString)
159 | ]
160 |
161 | createEventLogTable :: Connection -> IO ()
162 | createEventLogTable conn = command conn
163 | "CREATE TABLE IF NOT EXISTS haskell_eventlog \
164 | \( \
165 | \ `startTime` DateTime, \
166 | \ `evTime` DateTime64(9), \
167 | \ `evType` LowCardinality(String) \
168 | \) \
169 | \ENGINE = MergeTree \
170 | \PARTITION BY evType \
171 | \ORDER BY evType \
172 | \SETTINGS index_granularity = 8192;"
173 |
174 |
175 | eventToRep :: UTCTime -> Event -> EventRep
176 | eventToRep startTime Event{evTime, evSpec} = case evSpec of
177 | EventBlock{} -> let evType = "EventBlock" in MkEventRep{..}
178 | UnknownEvent{} -> let evType = "UnknownEvent" in MkEventRep{..}
179 | Startup{} -> let evType = "Startup" in MkEventRep{..}
180 | Shutdown{} -> let evType = "Shutdown" in MkEventRep{..}
181 | CreateThread{} -> let evType = "CreateThread" in MkEventRep{..}
182 | RunThread{} -> let evType = "RunThread" in MkEventRep{..}
183 | StopThread{} -> let evType = "StopThread" in MkEventRep{..}
184 | ThreadRunnable{} -> let evType = "ThreadRunnable" in MkEventRep{..}
185 | MigrateThread{} -> let evType = "MigrateThread" in MkEventRep{..}
186 | WakeupThread{} -> let evType = "WakeupThread" in MkEventRep{..}
187 | ThreadLabel{} -> let evType = "ThreadLabel" in MkEventRep{..}
188 | CreateSparkThread{} -> let evType = "CreateSparkThread" in MkEventRep{..}
189 | SparkCounters{} -> let evType = "SparkCounters" in MkEventRep{..}
190 | SparkCreate{} -> let evType = "SparkCreate" in MkEventRep{..}
191 | SparkDud{} -> let evType = "SparkDud" in MkEventRep{..}
192 | SparkOverflow{} -> let evType = "SparkOverflow" in MkEventRep{..}
193 | SparkRun{} -> let evType = "SparkRun" in MkEventRep{..}
194 | SparkSteal{} -> let evType = "SparkSteal" in MkEventRep{..}
195 | SparkFizzle{} -> let evType = "SparkFizzle" in MkEventRep{..}
196 | SparkGC{} -> let evType = "SparkGC" in MkEventRep{..}
197 | TaskCreate{} -> let evType = "TaskCreate" in MkEventRep{..}
198 | TaskMigrate{} -> let evType = "TaskMigrate" in MkEventRep{..}
199 | TaskDelete{} -> let evType = "TaskDelete" in MkEventRep{..}
200 | RequestSeqGC{} -> let evType = "RequestSeqGC" in MkEventRep{..}
201 | RequestParGC{} -> let evType = "RequestParGC" in MkEventRep{..}
202 | StartGC{} -> let evType = "StartGC" in MkEventRep{..}
203 | GCWork{} -> let evType = "GCWork" in MkEventRep{..}
204 | GCIdle{} -> let evType = "GCIdle" in MkEventRep{..}
205 | GCDone{} -> let evType = "GCDone" in MkEventRep{..}
206 | EndGC{} -> let evType = "EndGC" in MkEventRep{..}
207 | GlobalSyncGC{} -> let evType = "GlobalSyncGC" in MkEventRep{..}
208 | GCStatsGHC{} -> let evType = "GCStatsGHC" in MkEventRep{..}
209 | MemReturn{} -> let evType = "MemReturn" in MkEventRep{..}
210 | HeapAllocated{} -> let evType = "HeapAllocated" in MkEventRep{..}
211 | HeapSize{} -> let evType = "HeapSize" in MkEventRep{..}
212 | BlocksSize{} -> let evType = "BlocksSize" in MkEventRep{..}
213 | HeapLive{} -> let evType = "HeapLive" in MkEventRep{..}
214 | HeapInfoGHC{} -> let evType = "HeapInfoGHC" in MkEventRep{..}
215 | CapCreate{} -> let evType = "CapCreate" in MkEventRep{..}
216 | CapDelete{} -> let evType = "CapDelete" in MkEventRep{..}
217 | CapDisable{} -> let evType = "CapDisable" in MkEventRep{..}
218 | CapEnable{} -> let evType = "CapEnable" in MkEventRep{..}
219 | CapsetCreate{} -> let evType = "CapsetCreate" in MkEventRep{..}
220 | CapsetDelete{} -> let evType = "CapsetDelete" in MkEventRep{..}
221 | CapsetAssignCap{} -> let evType = "CapsetAssignCap" in MkEventRep{..}
222 | CapsetRemoveCap{} -> let evType = "CapsetRemoveCap" in MkEventRep{..}
223 | RtsIdentifier{} -> let evType = "RtsIdentifier" in MkEventRep{..}
224 | ProgramArgs{} -> let evType = "ProgramArgs" in MkEventRep{..}
225 | ProgramEnv{} -> let evType = "ProgramEnv" in MkEventRep{..}
226 | OsProcessPid{} -> let evType = "OsProcessPid" in MkEventRep{..}
227 | OsProcessParentPid{} -> let evType = "OsProcessParentPid" in MkEventRep{..}
228 | WallClockTime{} -> let evType = "WallClockTime" in MkEventRep{..}
229 | Message{} -> let evType = "Message" in MkEventRep{..}
230 | UserMessage{} -> let evType = "UserMessage" in MkEventRep{..}
231 | UserMarker{} -> let evType = "UserMarker" in MkEventRep{..}
232 | Version{} -> let evType = "Version" in MkEventRep{..}
233 | ProgramInvocation{} -> let evType = "ProgramInvocation" in MkEventRep{..}
234 | CreateMachine{} -> let evType = "CreateMachine" in MkEventRep{..}
235 | KillMachine{} -> let evType = "KillMachine" in MkEventRep{..}
236 | CreateProcess{} -> let evType = "CreateProcess" in MkEventRep{..}
237 | KillProcess{} -> let evType = "KillProcess" in MkEventRep{..}
238 | AssignThreadToProcess{} -> let evType = "AssignThreadToProcess" in MkEventRep{..}
239 | EdenStartReceive{} -> let evType = "EdenStartReceive" in MkEventRep{..}
240 | EdenEndReceive{} -> let evType = "EdenEndReceive" in MkEventRep{..}
241 | SendMessage{} -> let evType = "SendMessage" in MkEventRep{..}
242 | ReceiveMessage{} -> let evType = "ReceiveMessage" in MkEventRep{..}
243 | SendReceiveLocalMessage{} -> let evType = "SendReceiveLocalMessage" in MkEventRep{..}
244 | InternString{} -> let evType = "InternString" in MkEventRep{..}
245 | MerStartParConjunction{} -> let evType = "MerStartParConjunction" in MkEventRep{..}
246 | MerEndParConjunction{} -> let evType = "MerEndParConjunction" in MkEventRep{..}
247 | MerEndParConjunct{} -> let evType = "MerEndParConjunct" in MkEventRep{..}
248 | MerCreateSpark{} -> let evType = "MerCreateSpark" in MkEventRep{..}
249 | MerFutureCreate{} -> let evType = "MerFutureCreate" in MkEventRep{..}
250 | MerFutureWaitNosuspend{} -> let evType = "MerFutureWaitNosuspend" in MkEventRep{..}
251 | MerFutureWaitSuspended{} -> let evType = "MerFutureWaitSuspended" in MkEventRep{..}
252 | MerFutureSignal{} -> let evType = "MerFutureSignal" in MkEventRep{..}
253 | MerLookingForGlobalThread{} -> let evType = "MerLookingForGlobalThread" in MkEventRep{..}
254 | MerWorkStealing{} -> let evType = "MerWorkStealing" in MkEventRep{..}
255 | MerLookingForLocalSpark{} -> let evType = "MerLookingForLocalSpark" in MkEventRep{..}
256 | MerReleaseThread{} -> let evType = "MerReleaseThread" in MkEventRep{..}
257 | MerCapSleeping{} -> let evType = "MerCapSleeping" in MkEventRep{..}
258 | MerCallingMain{} -> let evType = "MerCallingMain" in MkEventRep{..}
259 | PerfName{} -> let evType = "PerfName" in MkEventRep{..}
260 | PerfCounter{} -> let evType = "PerfCounter" in MkEventRep{..}
261 | PerfTracepoint{} -> let evType = "PerfTracepoint" in MkEventRep{..}
262 | HeapProfBegin{} -> let evType = "HeapProfBegin" in MkEventRep{..}
263 | HeapProfCostCentre{} -> let evType = "HeapProfCostCentre" in MkEventRep{..}
264 | InfoTableProv{} -> let evType = "InfoTableProv" in MkEventRep{..}
265 | HeapProfSampleBegin{} -> let evType = "HeapProfSampleBegin" in MkEventRep{..}
266 | HeapProfSampleEnd{} -> let evType = "HeapProfSampleEnd" in MkEventRep{..}
267 | HeapBioProfSampleBegin{} -> let evType = "HeapBioProfSampleBegin" in MkEventRep{..}
268 | HeapProfSampleCostCentre{} -> let evType = "HeapProfSampleCostCentre" in MkEventRep{..}
269 | HeapProfSampleString{} -> let evType = "HeapProfSampleString" in MkEventRep{..}
270 | ProfSampleCostCentre{} -> let evType = "ProfSampleCostCentre" in MkEventRep{..}
271 | ProfBegin{} -> let evType = "ProfBegin" in MkEventRep{..}
272 | UserBinaryMessage{} -> let evType = "UserBinaryMessage" in MkEventRep{..}
273 | ConcMarkBegin{} -> let evType = "ConcMarkBegin" in MkEventRep{..}
274 | ConcMarkEnd{} -> let evType = "ConcMarkEnd" in MkEventRep{..}
275 | ConcSyncBegin{} -> let evType = "ConcSyncBegin" in MkEventRep{..}
276 | ConcSyncEnd{} -> let evType = "ConcSyncEnd" in MkEventRep{..}
277 | ConcSweepBegin{} -> let evType = "ConcSweepBegin" in MkEventRep{..}
278 | ConcSweepEnd{} -> let evType = "ConcSweepEnd" in MkEventRep{..}
279 | ConcUpdRemSetFlush{} -> let evType = "ConcUpdRemSetFlush" in MkEventRep{..}
280 | NonmovingHeapCensus{} -> let evType = "NonmovingHeapCensus" in MkEventRep{..}
281 | NonmovingPrunedSegments{} -> let evType = "NonmovingPrunedSegments" in MkEventRep{..}
282 | TickyCounterDef{} -> let evType = "TickyCounterDef" in MkEventRep{..}
283 | TickyCounterSample{} -> let evType = "TickyCounterSample" in MkEventRep{..}
284 | TickyBeginSample{} -> let evType = "TickyBeginSample" in MkEventRep{..}
285 |
--------------------------------------------------------------------------------
/contribution/modules/protocol-docs/ChProtocolDocs.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE AllowAmbiguousTypes #-}
2 | {-# LANGUAGE DefaultSignatures #-}
3 | {-# LANGUAGE TypeApplications #-}
4 | {-# LANGUAGE FlexibleContexts #-}
5 | {-# LANGUAGE TypeFamilies #-}
6 | {-# LANGUAGE ScopedTypeVariables #-}
7 | {-# LANGUAGE FlexibleInstances #-}
8 | {-# LANGUAGE TypeOperators #-}
9 | {-# LANGUAGE StandaloneDeriving #-}
10 | {-# LANGUAGE DeriveAnyClass #-}
11 | {-# LANGUAGE DataKinds #-}
12 | {-# LANGUAGE UndecidableInstances #-}
13 |
14 | module ChProtocolDocs (serverDoc) where
15 |
16 | import ClickHaskell
17 | ( ExceptionPacket(..),
18 | HelloResponse(..),
19 | PasswordComplexityRules(..),
20 | ProfileInfo(..),
21 | ProgressPacket(..),
22 | TableColumns(..),
23 | IsChType(..), SinceRevision, UVarInt, ProtocolRevision
24 | )
25 | import Data.Kind
26 | import Data.Proxy
27 | import GHC.Generics
28 | import GHC.TypeLits (KnownSymbol, symbolVal, natVal, KnownNat)
29 | import Text.Blaze.Html
30 | import Text.Blaze.Html.Renderer.Pretty (renderHtml)
31 | import Text.Blaze.Html5 (table, td, tr, h1, h3, thead, tbody, th)
32 | import Data.ByteString.Lazy.Char8 as BS8
33 |
34 |
35 | serverDoc :: ByteString
36 | serverDoc = (BS8.pack . renderHtml . mconcat)
37 | [ h1 (string "Server packets")
38 | , toDocPart @ExceptionPacket
39 | , toDocPart @HelloResponse
40 | , toDocPart @ProfileInfo
41 | , toDocPart @ProgressPacket
42 | , toDocPart @TableColumns
43 | ]
44 |
45 | class ToDocPart docPart where
46 | default toDocPart :: (Generic docPart, GToDocPart (Rep docPart)) => Html
47 | toDocPart :: Html
48 | toDocPart = gToDocPart @(Rep docPart)
49 |
50 | deriving instance ToDocPart ExceptionPacket
51 | deriving instance ToDocPart HelloResponse
52 | deriving instance ToDocPart ProfileInfo
53 | deriving instance ToDocPart ProgressPacket
54 | deriving instance ToDocPart TableColumns
55 |
56 |
57 | class GToDocPart (f :: Type -> Type) where
58 | gToDocPart :: Html
59 |
60 | instance
61 | (GToDocPart f, KnownSymbol name)
62 | =>
63 | GToDocPart (D1 (MetaData name m p nt) (C1 c2 f))
64 | where
65 | gToDocPart = do
66 | h3 (string $ symbolVal @name $ Proxy)
67 | table $ do
68 | thead $ do
69 | th (string "Field")
70 | th (string "type")
71 | th (string "since")
72 | tbody (gToDocPart @f)
73 |
74 | instance (GToDocPart left, GToDocPart right) => GToDocPart (left :*: right)
75 | where
76 | gToDocPart = gToDocPart @left <> gToDocPart @right
77 |
78 | instance
79 | (KnownSymbol name, GToDocPart rec)
80 | =>
81 | GToDocPart ((S1 (MetaSel (Just name) a b f)) rec) where
82 | gToDocPart = tr $ do
83 | (td . string) (symbolVal @name Proxy)
84 | gToDocPart @rec
85 |
86 | instance {-# OVERLAPPABLE #-}
87 | HasName chType
88 | =>
89 | GToDocPart (Rec0 chType) where
90 | gToDocPart = do
91 | (td . string) (fieldName @chType)
92 | (td . string) ("-")
93 |
94 | instance
95 | (HasName chType, KnownNat rev)
96 | =>
97 | GToDocPart (Rec0 (chType `SinceRevision` rev)) where
98 | gToDocPart = do
99 | (td . string) (fieldName @chType)
100 | (td . string) (show $ natVal @rev Proxy)
101 |
102 |
103 | class HasName hasName where fieldName :: String
104 | instance HasName UVarInt where fieldName = "UVarInt"
105 | instance HasName ProtocolRevision where fieldName = "UVarInt"
106 | instance HasName [PasswordComplexityRules] where fieldName = "[PasswordComplexityRules]"
107 |
108 | instance {-# OVERLAPPABLE #-} IsChType chType => HasName chType where
109 | fieldName = chTypeName @chType
110 |
--------------------------------------------------------------------------------
/contribution/modules/protocol-docs/ClickHaskell-protocol-docs.cabal:
--------------------------------------------------------------------------------
1 | Cabal-version: 3.0
2 | name: ClickHaskell-protocol-docs
3 | version: 0.0.0.1
4 | build-type: Simple
5 | license: BSD-3-Clause
6 |
7 | library
8 | default-language: Haskell2010
9 | Exposed-Modules:
10 | ChProtocolDocs
11 | build-depends:
12 | ClickHaskell
13 | , base >=4.7 && <5
14 | , bytestring
15 | , blaze-html
16 | , blaze-markup
17 | ghc-options:
18 | -Wall
19 | -Wunused-packages
20 |
--------------------------------------------------------------------------------
/contribution/modules/visits/ChVisits.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | {-# LANGUAGE RecordWildCards #-}
3 | {-# LANGUAGE DataKinds #-}
4 | {-# LANGUAGE DeriveAnyClass #-}
5 | {-# LANGUAGE DuplicateRecordFields #-}
6 | {-# LANGUAGE DerivingStrategies #-}
7 | {-# LANGUAGE NumericUnderscores #-}
8 | {-# LANGUAGE TypeApplications #-}
9 | {-# LANGUAGE NamedFieldPuns #-}
10 | {-# LANGUAGE DeriveGeneric #-}
11 |
12 | module ChVisits where
13 |
14 | import ClickHaskell
15 | ( ChString, DateTime
16 | , UInt16, UInt32
17 | , ClickHaskell, insertInto, command
18 | , Connection, openConnection, defaultConnectionArgs
19 | , Column, Table
20 | , View, selectFromView, Parameter, parameter
21 | )
22 | import Control.Concurrent (threadDelay)
23 | import Control.Concurrent.Async (Concurrently (..))
24 | import Control.Concurrent.STM (TBQueue, TChan, TVar, atomically, flushTBQueue, newTVarIO, writeTChan, writeTVar)
25 | import Control.Exception (SomeException, catch)
26 | import Control.Monad (forever)
27 | import Data.Aeson (ToJSON)
28 | import Data.ByteString (StrictByteString)
29 | import Data.Time (UTCTime)
30 | import Data.Word (Word32)
31 | import GHC.Generics (Generic)
32 |
33 |
34 | data DocsStatisticsArgs = MkDocsStatisticsArgs
35 | { docsStatQueue :: TBQueue DocsStatistics
36 | , broadcastChan :: TChan HistoryData
37 | }
38 |
39 | initVisitsTracker :: DocsStatisticsArgs -> IO (Concurrently (), TVar HistoryData)
40 | initVisitsTracker MkDocsStatisticsArgs{..} = do
41 | clickHouse <- openConnection defaultConnectionArgs
42 |
43 | command clickHouse
44 | "CREATE TABLE IF NOT EXISTS default.ClickHaskellStats \
45 | \( \
46 | \ `time` DateTime, \
47 | \ `path` LowCardinality(String), \
48 | \ `remoteAddr` UInt32 \
49 | \) \
50 | \ENGINE = MergeTree \
51 | \PARTITION BY path \
52 | \ORDER BY path \
53 | \SETTINGS index_granularity = 8192;"
54 |
55 | command clickHouse
56 | "CREATE OR REPLACE VIEW default.historyByHours \
57 | \AS SELECT \
58 | \ toUInt32(intDiv(toUInt32(time), 3600) * 3600) AS hour, \
59 | \ toUInt32(countDistinct(remoteAddr)) AS visits \
60 | \FROM default.ClickHaskellStats \
61 | \WHERE hour > (now() - ({hoursLength:UInt16} * 3600)) \
62 | \GROUP BY hour \
63 | \ORDER BY hour ASC;"
64 |
65 | currentHistory <- newTVarIO . History =<< readCurrentHistoryLast clickHouse 24
66 |
67 | pure
68 | ( Concurrently (forever $ do
69 | catch (do
70 | dataToWrite <- (atomically . flushTBQueue) docsStatQueue
71 | insertInto @DocsStatTable clickHouse dataToWrite
72 | )
73 | (print @SomeException)
74 | threadDelay 5_000_000
75 | )
76 | *>
77 | Concurrently (forever $ do
78 | historyByHours <- readCurrentHistoryLast clickHouse 1
79 | case historyByHours of
80 | update:_ -> atomically $ (writeTChan broadcastChan) (HistoryUpdate update)
81 | _ -> pure ()
82 | threadDelay 1_000_000
83 | )
84 | *>
85 | Concurrently (forever $ do
86 | atomically . writeTVar currentHistory . History =<< readCurrentHistoryLast clickHouse 24
87 | threadDelay 300_000_000
88 | )
89 | , currentHistory
90 | )
91 |
92 | readCurrentHistoryLast :: Connection -> UInt16 -> IO [HourData]
93 | readCurrentHistoryLast clickHouse hours =
94 | concat <$>
95 | selectFromView
96 | @HistoryByHours
97 | clickHouse
98 | (parameter @"hoursLength" @UInt16 hours)
99 | pure
100 |
101 | data HistoryData = History{history :: [HourData]} | HistoryUpdate{realtime :: HourData}
102 | deriving stock (Generic)
103 | deriving anyclass (ToJSON)
104 |
105 | -- ** Writing data
106 |
107 | data DocsStatistics = MkDocsStatistics
108 | { time :: UTCTime
109 | , path :: StrictByteString
110 | , remoteAddr :: Word32
111 | }
112 | deriving stock (Generic)
113 | deriving anyclass (ClickHaskell DocStatColumns)
114 |
115 | type DocsStatTable = Table "ClickHaskellStats" DocStatColumns
116 | type DocStatColumns =
117 | '[ Column "time" (DateTime "")
118 | , Column "path" ChString
119 | , Column "remoteAddr" UInt32
120 | ]
121 |
122 | -- ** Reading data
123 |
124 | data HourData = MkHourData
125 | { hour :: Word32
126 | , visits :: Word32
127 | }
128 | deriving stock (Generic)
129 | deriving anyclass (ToJSON, ClickHaskell HistoryColumns)
130 |
131 | type HistoryByHours =
132 | View
133 | "historyByHours"
134 | HistoryColumns
135 | '[ Parameter "hoursLength" UInt16
136 | ]
137 | type HistoryColumns =
138 | '[ Column "hour" UInt32
139 | , Column "visits" UInt32
140 | ]
141 |
--------------------------------------------------------------------------------
/contribution/modules/visits/ClickHaskell-visits.cabal:
--------------------------------------------------------------------------------
1 | Cabal-version: 3.0
2 | name: ClickHaskell-visits
3 | version: 0.0.0.1
4 | build-type: Simple
5 | license: BSD-3-Clause
6 |
7 | library
8 | default-language: Haskell2010
9 | Exposed-Modules:
10 | ChVisits
11 | build-depends:
12 | ClickHaskell
13 | , aeson
14 | , async
15 | , base >=4.7 && <5
16 | , bytestring
17 | , time
18 | , stm
19 | ghc-options:
20 | -Wall
21 | -Wunused-packages
22 |
--------------------------------------------------------------------------------
/contribution/project.nix:
--------------------------------------------------------------------------------
1 | { pkgs
2 | , ghc ? "ghc966"
3 | }:
4 | {
5 | autoWire = ["packages" "apps"];
6 | basePackages = pkgs.haskell.packages.${ghc};
7 | settings = {
8 | ClickHaskell = {libraryProfiling = true; haddock = true;};
9 | prof-1bil-stream = {libraryProfiling = true; executableProfiling = true;};
10 | prof-simple = {libraryProfiling = true; executableProfiling = true;};
11 | };
12 | }
13 |
--------------------------------------------------------------------------------
/contribution/server/index.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | {-# LANGUAGE RecordWildCards #-}
3 | {-# LANGUAGE DataKinds #-}
4 | {-# LANGUAGE DeriveAnyClass #-}
5 | {-# LANGUAGE DuplicateRecordFields #-}
6 | {-# LANGUAGE DerivingStrategies #-}
7 | {-# LANGUAGE NumericUnderscores #-}
8 | {-# LANGUAGE TypeApplications #-}
9 | {-# LANGUAGE NamedFieldPuns #-}
10 | {-# LANGUAGE DeriveGeneric #-}
11 | {-# LANGUAGE BlockArguments #-}
12 |
13 | import ChProtocolDocs (serverDoc)
14 | import ChVisits (DocsStatistics (..), DocsStatisticsArgs (..), HistoryData, initVisitsTracker)
15 | import Control.Concurrent.Async (Concurrently (..))
16 | import Control.Concurrent.STM (TBQueue, TChan, TVar, atomically, dupTChan, newBroadcastTChanIO, newTBQueueIO, readTChan, readTVarIO, writeTBQueue)
17 | import Control.Monad (filterM, forM, forever)
18 | import Data.Aeson (encode)
19 | import Data.ByteString (StrictByteString)
20 | import Data.ByteString.Char8 as BS8 (pack, unpack)
21 | import Data.ByteString.Lazy as B (LazyByteString, readFile)
22 | import Data.HashMap.Strict as HM (HashMap, empty, fromList, lookup, unions, insert)
23 | import Data.Maybe (isJust)
24 | import Data.Text as T (pack)
25 | import Data.Time (getCurrentTime)
26 | import GHC.Eventlog.Socket (start)
27 | import Net.IPv4 (decodeUtf8, getIPv4)
28 | import Network.HTTP.Types (status200, status404)
29 | import Network.HTTP.Types.Header (hContentType)
30 | import Network.Mime (MimeType, defaultMimeLookup)
31 | import Network.Socket (Family (..), SockAddr (..), SocketType (..), bind, listen, maxListenQueue, socket)
32 | import Network.Wai (Application, Request (..), responseLBS)
33 | import Network.Wai.Handler.Warp (Port, defaultSettings, runSettings, runSettingsSocket, setPort)
34 | import Network.Wai.Handler.WebSockets (websocketsOr)
35 | import Network.WebSockets as WebSocket (ServerApp, acceptRequest, sendTextData)
36 | import Network.WebSockets.Connection (defaultConnectionOptions)
37 | import System.Directory (doesDirectoryExist, listDirectory)
38 | import System.Environment (lookupEnv)
39 | import System.FilePath (dropFileName, dropTrailingPathSeparator, normalise, replaceExtension, takeExtension, takeFileName, ())
40 |
41 |
42 | main :: IO ()
43 | main = do
44 | maybe mempty start
45 | =<< lookupEnv "EVENTLOG_SOCKET_PATH"
46 |
47 | mSocketPath <- lookupEnv "CLICKHASKELL_PAGE_SOCKET_PATH"
48 | mStaticFiles <- lookupEnv "CLICKHASKELL_STATIC_FILES_DIR"
49 | isDev <- isJust <$> lookupEnv "DEV"
50 |
51 | docsStatQueue <- newTBQueueIO 100_000
52 | broadcastChan <- newBroadcastTChanIO
53 |
54 | (visitsCollector, currentHistory) <- initVisitsTracker MkDocsStatisticsArgs{..}
55 |
56 | server <-
57 | let mkBroadcastChan = atomically (dupTChan broadcastChan)
58 | in initServer MkServerArgs{..}
59 |
60 | runConcurrently
61 | $ pure ()
62 | *> visitsCollector
63 | *> server
64 |
65 |
66 | {-
67 |
68 | * Web application core logic
69 |
70 | -}
71 |
72 | type StaticFiles = HashMap StrictByteString (MimeType, IO LazyByteString)
73 |
74 | data ServerArgs = MkServerArgs
75 | { isDev :: Bool
76 | , mStaticFiles :: Maybe String
77 | , mSocketPath :: Maybe FilePath
78 | , docsStatQueue :: TBQueue DocsStatistics
79 | , currentHistory :: TVar HistoryData
80 | , mkBroadcastChan :: IO (TChan HistoryData)
81 | }
82 |
83 | initServer :: ServerArgs -> IO (Concurrently())
84 | initServer args@MkServerArgs{mStaticFiles, mSocketPath, isDev} = do
85 | staticFiles <-
86 | maybe
87 | (pure HM.empty)
88 | (listFilesWithContents isDev)
89 | mStaticFiles
90 |
91 | let
92 | staticFilesWithDoc
93 | = id
94 | . insert "/protocol/server" ("text/html", pure serverDoc)
95 | $ staticFiles
96 | app = websocketsOr
97 | defaultConnectionOptions
98 | (wsServer args)
99 | (httpApp args staticFilesWithDoc)
100 |
101 | pure $
102 | Concurrently $ do
103 | case SockAddrUnix <$> mSocketPath of
104 | Nothing -> do
105 | let port = 3000 :: Port
106 | putStrLn $ "Starting server on http://localhost:" <> show port
107 | runSettings (setPort port defaultSettings) app
108 | Just sockAddr -> do
109 | sock <- socket AF_UNIX Stream 0
110 | putStrLn $ "Starting server on UNIX socket: " ++ (show sockAddr)
111 | bind sock sockAddr
112 | listen sock maxListenQueue
113 | runSettingsSocket defaultSettings sock app
114 |
115 |
116 | httpApp :: ServerArgs -> StaticFiles -> Application
117 | httpApp MkServerArgs{docsStatQueue} staticFiles req f = do
118 | time <- getCurrentTime
119 | let path = (dropIndexHtml . BS8.unpack . rawPathInfo) req
120 | remoteAddr = maybe 0 getIPv4 (decodeUtf8 =<< Prelude.lookup "X-Real-IP" (requestHeaders req))
121 | case HM.lookup path staticFiles of
122 | Nothing -> f (responseLBS status404 [("Content-Type", "text/plain")] "404 - Not Found")
123 | Just (mimeType, content) -> do
124 | (atomically . writeTBQueue docsStatQueue) MkDocsStatistics{..}
125 | f . responseLBS status200 [(hContentType, mimeType)] =<< content
126 |
127 | wsServer :: ServerArgs -> ServerApp
128 | wsServer MkServerArgs{mkBroadcastChan, currentHistory} pending = do
129 | conn <- acceptRequest pending
130 | sendTextData conn =<< (encode <$> readTVarIO currentHistory)
131 | clientChan <- mkBroadcastChan
132 | forever $ do
133 | sendTextData conn =<< (fmap encode . atomically . readTChan) clientChan
134 |
135 | listFilesWithContents :: Bool -> FilePath -> IO StaticFiles
136 | listFilesWithContents isDev dir = go "."
137 | where
138 | go subPath = do
139 | paths <- map (subPath ) <$> listDirectory (dir subPath)
140 | files <- (`filterM` paths) $ \path ->
141 | (&&)
142 | <$> (fmap not . doesDirectoryExist) (dir path)
143 | <*> (pure . isDocFile) (dir path)
144 | fileContents <- forM files $ \file -> do
145 | content <- B.readFile (dir file)
146 | let contentLoader = if isDev then B.readFile (dir file) else pure content
147 | return
148 | ( prepareFilePath file
149 | , (defaultMimeLookup (T.pack $ filePathToUrlPath file), contentLoader)
150 | )
151 | nestedMaps <- mapM go =<< filterM (\path -> doesDirectoryExist (dir path)) paths
152 | return $ HM.unions (HM.fromList fileContents : nestedMaps)
153 |
154 | isDocFile :: FilePath -> Bool
155 | isDocFile fp
156 | | takeExtension fp `elem` [".html", ".lhs", ".ttf", ".svg", ".css", ".js"] = True
157 | | otherwise = False
158 |
159 | prepareFilePath :: FilePath -> StrictByteString
160 | prepareFilePath = dropIndexHtml . filePathToUrlPath . normalise . ("/" )
161 |
162 | filePathToUrlPath :: FilePath -> FilePath
163 | filePathToUrlPath fp
164 | | takeExtension fp == ".lhs" = replaceExtension fp "html"
165 | | otherwise = fp
166 |
167 | dropIndexHtml :: FilePath -> StrictByteString
168 | dropIndexHtml fp = BS8.pack . dropTrailingPathSeparator $
169 | if takeFileName fp == "index.html"
170 | then dropFileName fp
171 | else fp
172 |
--------------------------------------------------------------------------------
/contribution/server/server.cabal:
--------------------------------------------------------------------------------
1 | Cabal-version: 3.0
2 | name: server
3 | version: 0.0.0.1
4 | build-type: Simple
5 | license: BSD-3-Clause
6 |
7 | executable server
8 | default-language: Haskell2010
9 | main-is: index.hs
10 | build-depends:
11 | ClickHaskell
12 | , ClickHaskell-protocol-docs
13 | , ClickHaskell-visits
14 | , aeson
15 | , async
16 | , base >=4.7 && <5
17 | , bytestring
18 | , directory
19 | , eventlog-socket
20 | , filepath
21 | , http-types
22 | , ip
23 | , unordered-containers
24 | , mime-types
25 | , network
26 | , text
27 | , time
28 | , stm
29 | , wai
30 | , warp
31 | , wai-websockets
32 | , websockets
33 | ghc-options:
34 | -threaded
35 | -Wall -Wunused-packages
36 | -rtsopts "-with-rtsopts=-T -A8m -AL32m -N"
37 |
--------------------------------------------------------------------------------
/contribution/systemModule.nix:
--------------------------------------------------------------------------------
1 | self: {
2 | config,
3 | lib,
4 | pkgs,
5 | ...
6 | }:
7 | let
8 | user = config.ClickHaskell.user;
9 | group = config.ClickHaskell.group;
10 | dataDir = config.ClickHaskell.path;
11 | domain = config.ClickHaskell.domain;
12 | pageDir = config.ClickHaskell.pagePackage;
13 | server = config.ClickHaskell.serverPackage;
14 | in
15 | {
16 | options.ClickHaskell = {
17 | user = lib.mkOption {
18 | type = lib.types.str;
19 | default = "ClickHaskell";
20 | description = "The user as which to run ClickHaskell server.";
21 | };
22 | group = lib.mkOption {
23 | type = lib.types.str;
24 | default = user;
25 | description = "The group as which to run ClickHaskell server.";
26 | };
27 | path = lib.mkOption {
28 | type = lib.types.passwdEntry lib.types.path;
29 | default = "/var/lib/ClickHaskell";
30 | description = "Filepath to state directory";
31 | };
32 | domain = lib.mkOption {
33 | type = lib.types.str;
34 | default = "clickhaskell.dev";
35 | description = "Domain name for ClickHaskell infrastructure";
36 | };
37 | serverPackage = lib.mkOption {
38 | type = lib.types.package;
39 | default = self.packages.${pkgs.system}."ghc984-server";
40 | };
41 | pagePackage = lib.mkOption {
42 | type = lib.types.package;
43 | default = self.packages.${pkgs.system}."documentation";
44 | };
45 | };
46 | config = {
47 | services = {
48 | hydra = {
49 | enable = true;
50 | hydraURL = "http://localhost:3000"; # externally visible URL
51 | notificationSender = "hydra@localhost"; # e-mail of hydra service
52 | buildMachinesFiles = [];
53 | useSubstitutes = true;
54 | };
55 | clickhouse = {
56 | enable = true;
57 | };
58 | };
59 |
60 | users = {
61 | groups.ClickHaskell = {};
62 | users.ClickHaskell = {
63 | group = group;
64 | homeMode = "755";
65 | home = "${dataDir}";
66 | isSystemUser = true;
67 | };
68 | };
69 |
70 | security.acme = {
71 | acceptTerms = true;
72 | certs = {
73 | "${domain}" = {
74 | group = "ClickHaskell";
75 | email = "letsencrypt@${domain}";
76 | extraDomainNames = [ "git.${domain}" ];
77 | };
78 | };
79 | };
80 | systemd.tmpfiles.rules = [
81 | "d '${dataDir}' 0770 ${user} ${group} - -"
82 | ];
83 | systemd.services = {
84 | ClickHaskell = {
85 | wantedBy = [ "multi-user.target" ];
86 | environment = {
87 | CLICKHASKELL_PAGE_SOCKET_PATH = "ClickHaskell.sock";
88 | CLICKHASKELL_STATIC_FILES_DIR = pageDir;
89 | };
90 | serviceConfig = {
91 | Restart = "always";
92 | User = user;
93 | Group = group;
94 | ReadWritePaths = [ dataDir ];
95 | ExecStart = ''
96 | ${server + /bin/server}
97 | '';
98 | UMask= "007";
99 | WorkingDirectory = dataDir;
100 | };
101 | startLimitIntervalSec = 30;
102 | startLimitBurst = 10;
103 | };
104 | };
105 | };
106 | }
107 |
--------------------------------------------------------------------------------
/contribution/testing.nix:
--------------------------------------------------------------------------------
1 | {app, inputs, pkgs}:
2 | let
3 | programName = builtins.baseNameOf app.program;
4 | isPerformanceTest = pkgs.lib.hasPrefix "prof-" programName;
5 | in
6 | {
7 | imports = [inputs.services-flake.processComposeModules.default];
8 | services.clickhouse."database" = {
9 | enable = true;
10 | extraConfig = {
11 | http_port = 8123;
12 | listen-host = "localhost";
13 | tcp_port_secure = 9440;
14 | openSSL = {
15 | server = {
16 | certificateFile = ./certs/localhost.crt;
17 | privateKeyFile = ./certs/localhost.key;
18 | };
19 | };
20 | };
21 | initialDatabases = [ {name="default";} ];
22 | };
23 | settings.processes = {
24 | "executable" = {
25 | command = "${app.program}";
26 | availability.exit_on_end = isPerformanceTest == false;
27 | depends_on."database".condition = "process_healthy";
28 | };
29 | dump-artifacts = pkgs.lib.mkIf isPerformanceTest {
30 | command = "
31 | ${pkgs.lib.getExe' pkgs.haskellPackages.eventlog2html "eventlog2html"} ./${programName}.eventlog
32 | rm ./${programName}.eventlog
33 | rm ./${programName}.hp
34 | ";
35 | availability.exit_on_end = true;
36 | depends_on."executable".condition = "process_completed_successfully";
37 | };
38 | };
39 | }
40 |
--------------------------------------------------------------------------------
/documentation/assets/Hasklig-Bold.ttf:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/KovalevDima/ClickHaskell/e3552c65e24403802ea53939f1707e5782e123f4/documentation/assets/Hasklig-Bold.ttf
--------------------------------------------------------------------------------
/documentation/assets/Hasklig-Regular.ttf:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/KovalevDima/ClickHaskell/e3552c65e24403802ea53939f1707e5782e123f4/documentation/assets/Hasklig-Regular.ttf
--------------------------------------------------------------------------------
/documentation/assets/github-stars.js:
--------------------------------------------------------------------------------
1 | const url = "https://api.github.com/repos/KovalevDima/ClickHaskell";
2 | fetch(url)
3 | .then(async response => {
4 | return({data: await response.json(), ok: response.ok})
5 | })
6 | .then(handledResponse => {
7 | if (handledResponse.ok) {
8 | var div = document.getElementById('stars');
9 | div.innerHTML += handledResponse.data.stargazers_count;
10 | div.innerHTML += `
11 |
16 | `
17 | }
18 | })
19 | .catch(console.error);
20 |
--------------------------------------------------------------------------------
/documentation/assets/index.css:
--------------------------------------------------------------------------------
1 | @font-face {
2 | font-family: 'Hasklig';
3 | font-weight: monospace;
4 | src: local('Hasklig'), url('/assets/Hasklig-Regular.ttf');
5 | }
6 | @font-face {
7 | font-family: 'Hasklig';
8 | font-weight: bold;
9 | src: local('Hasklig'), url('/assets/Hasklig-Bold.ttf');
10 | }
11 | html {
12 | align-items: center;
13 | background-color: #121212;
14 | color: rgb(155, 155, 155);
15 | display: flex;
16 | margin: 0px;
17 | justify-content: center;
18 | font-family: 'Hasklig', monospace;
19 | }
20 | code {font-family: 'Hasklig', monospace}
21 | header {
22 | padding: 4px 8px;
23 | align-items: center;
24 | display: flex;
25 | column-gap: 10px;
26 | flex-direction: row;
27 | justify-content: space-between;
28 | height: 40px;
29 | background-color: rgb(30, 30, 30);
30 | }
31 | header div {
32 | display: flex;
33 | flex-direction: row;
34 | }
35 | header div a {
36 | display:flex; align-items:center;
37 | column-gap:3px; padding: 2px;
38 | font-size:18px; text-decoration: none;
39 | border: 2px solid; border-radius: 5px; border-color: rgb(30, 30, 30);
40 | background-color: #121212;
41 | }
42 | body {
43 | margin-top: 0px;
44 | max-width: 720px;
45 | width: 100%;
46 | }
47 | table{
48 | border: 1px solid;
49 | border-collapse: collapse;
50 | }
51 | th,td{
52 | border: 1px solid;
53 | padding: 5px 3px 3px 5px;
54 | }
55 | main {padding: 0px 8px 0px 8px; }
56 | a {color: rgb(155, 155, 155);}
57 | a:link {color: rgb(155, 155, 155);}
58 | a:hover {color: rgb(155, 155, 155);}
59 | a:visited {color: rgb(155, 155, 155);}
60 |
--------------------------------------------------------------------------------
/documentation/assets/logo.svg:
--------------------------------------------------------------------------------
1 |
37 |
--------------------------------------------------------------------------------
/documentation/assets/routing.js:
--------------------------------------------------------------------------------
1 | let visitsChart;
2 | let chartData = {
3 | labels: [],
4 | datasets: [{ label: 'Visitors', data: [], backgroundColor: '#121212' }]
5 | };
6 |
7 | function initChart() {
8 | const canvas = document.getElementById('visitsChart');
9 | if (!canvas) return;
10 |
11 | const ctx = canvas.getContext('2d');
12 |
13 | if (visitsChart) {
14 | visitsChart.destroy();
15 | }
16 |
17 | visitsChart = new Chart(ctx, {
18 | type: 'bar',
19 | data: chartData,
20 | options: {
21 | scales: {
22 | x: { title: { display: true, text: "Hours" } },
23 | y: { beginAtZero: true }
24 | }
25 | }
26 | });
27 | }
28 |
29 | function formatHour(posixTime) {
30 | const date = new Date(posixTime * 1000);
31 | return `${date.getHours()}`.padStart(2, '0');
32 | }
33 |
--------------------------------------------------------------------------------
/documentation/assets/websockets.js:
--------------------------------------------------------------------------------
1 | let socket;
2 |
3 | document.addEventListener('DOMContentLoaded', () => {
4 | const main = document.querySelector('main');
5 |
6 | async function loadPage(path) {
7 | try {
8 | const res = await fetch(path);
9 | const text = await res.text();
10 | const doc = new DOMParser().parseFromString(text, 'text/html');
11 | const newMain = doc.querySelector('main');
12 | main.innerHTML = newMain ? newMain.innerHTML : text;
13 |
14 | document.querySelectorAll('pre code').forEach(block => {
15 | hljs.highlightElement(block);
16 | });
17 |
18 | if (document.getElementById('visitsChart')) {
19 | initChart();
20 | }
21 |
22 | } catch (err) {
23 | main.innerHTML = `Ошибка загрузки страницы
`;
24 | }
25 | }
26 |
27 | function handleHash() {
28 | const path = location.hash.slice(1);
29 | if (path) { loadPage(path); } else { loadPage('/'); }
30 | }
31 |
32 | function initWebSocket() {
33 | if (socket) return;
34 |
35 | socket = new WebSocket(`${window.location.protocol === 'https:' ? 'wss' : 'ws'}://${location.host}`);
36 | socket.onopen = () => console.log('WebSocket connected');
37 | socket.onmessage = event => {
38 | const data = JSON.parse(event.data);
39 | if (data.history) {
40 | chartData.labels = data.history.map(item => formatHour(item.hour));
41 | chartData.datasets[0].data = data.history.map(item => item.visits);
42 | } else if (data.realtime) {
43 | const formattedHour = formatHour(data.realtime.hour);
44 | const index = chartData.labels.indexOf(formattedHour);
45 | if (index !== -1) {
46 | chartData.datasets[0].data[index] = data.realtime.visits;
47 | }
48 | }
49 | visitsChart.update();
50 | };
51 | socket.onerror = error => console.error('WebSocket error:', error);
52 | socket.onclose = () => console.log('WebSocket closed');
53 | }
54 |
55 | window.addEventListener('hashchange', handleHash);
56 | handleHash();
57 | initWebSocket();
58 | });
59 |
--------------------------------------------------------------------------------
/documentation/contribution.html:
--------------------------------------------------------------------------------
1 | Setup Nix
2 |
3 | ClickHaskell contributors using Nix package manager to setup everything.
4 | You can install it via official installer and enable flakes
5 |
6 |
7 |
8 | After you have Nix installed you can:
9 | nix develop
11 |
12 | to manually enter shell with provided:
13 | cabal, ghc, haskell-laguage-server, clickhouse-client
14 |
15 | You can also setup direnv to automatically enter the shell
16 |
17 | Run routine actions
18 |
19 | Start database and documentation server
20 |
21 | nix run
23 |
24 |
25 | Initialize database and run tests
26 |
27 | nix run .#test-ghc966-tests
29 |
30 |
31 | Initilization database and run profiling
32 |
33 | nix run .#test-ghc966-prof-simple
35 |
36 |
37 | Reinitialize database
38 |
39 | rm -rf ./data
41 |
42 | (and then restart process-compose)
43 |
--------------------------------------------------------------------------------
/documentation/index.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 |
9 |
10 |
11 | ClickHaskell
12 |
13 |
14 |
15 |
16 |
17 |
18 |
19 |
20 |
21 |
22 |
23 |
24 |
25 |
26 |
27 |
28 |
37 | 
38 | ClickHaskell
39 |
40 |
41 |
64 |
65 |
73 |
74 | Efficiency
75 |
76 | Powerful Haskell runtime system with the fastest analytical database.
77 | ClickHaskell is designed to:
78 |
79 |
80 | - Handle millions of rows of data in constant memory
81 | - Efficiently utilize Haskell concurrent runtime
82 |
83 | Real-time analytics example
84 | You are receiving data via WebSockets and generating
85 | it by loading any page from a unique IP address
86 |
87 |
88 |
89 |
91 |
92 |
93 |
94 |
--------------------------------------------------------------------------------
/documentation/performance/p1-million-rw/index.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE
2 | DataKinds
3 | , DeriveAnyClass
4 | , DeriveGeneric
5 | , DerivingStrategies
6 | , NumericUnderscores
7 | , OverloadedStrings
8 | , TypeApplications
9 | #-}
10 |
11 | module Main (main) where
12 |
13 | -- Internal
14 | import ClickHaskell
15 |
16 | -- GHC included
17 | import Data.ByteString (ByteString)
18 | import Data.Word (Word32)
19 | import Debug.Trace (traceMarkerIO)
20 | import GHC.Generics (Generic)
21 |
22 |
23 | main :: IO ()
24 | main = do
25 | traceMarkerIO "Initialization"
26 | readingConnection <- openConnection defaultConnectionArgs
27 | writingConnection <- openConnection defaultConnectionArgs
28 |
29 | let totalRows = 1_000_000
30 | command readingConnection
31 | "CREATE TABLE IF NOT EXISTS profiler \
32 | \(\
33 | \ `a1` Int64, \
34 | \ `a2` String, \
35 | \ `a3` DateTime, \
36 | \ `a4` UUID, \
37 | \ `a5` Int32, \
38 | \ `a6` Nullable(String), \
39 | \ `a7` String \
40 | \) \
41 | \ENGINE = MergeTree \
42 | \PARTITION BY () \
43 | \ORDER BY ();"
44 |
45 | _ <-
46 | generateRandom
47 | @ExampleColumns
48 | @ExampleData
49 | readingConnection
50 | (1, 10, 2)
51 | totalRows
52 | (insertInto @(Table "profiler" ExampleColumns) writingConnection)
53 |
54 | print $ "Writing done. " <> show totalRows <> " rows was written"
55 |
56 |
57 | data ExampleData = MkExampleData
58 | { a1 :: Int64
59 | , a3 :: Word32
60 | , a4 :: UUID
61 | , a2 :: ByteString
62 | , a5 :: Int32
63 | , a6 :: Nullable ChString
64 | , a7 :: ChString
65 | }
66 | deriving (Generic)
67 | deriving anyclass (ClickHaskell ExampleColumns)
68 |
69 |
70 | type ExampleColumns =
71 | '[ Column "a1" Int64
72 | , Column "a2" ChString
73 | , Column "a3" (DateTime "")
74 | , Column "a4" UUID
75 | , Column "a5" Int32
76 | , Column "a6" (Nullable ChString)
77 | , Column "a7" ChString
78 | ]
79 |
--------------------------------------------------------------------------------
/documentation/performance/p1-million-rw/prof-simple.cabal:
--------------------------------------------------------------------------------
1 | Cabal-version: 3.0
2 |
3 | name: prof-simple
4 | version: 0.0.0.1
5 | build-type: Simple
6 | license: BSD-3-Clause
7 |
8 | common dump-core
9 | ghc-options:
10 | -ddump-to-file
11 | -ddump-simpl
12 | -ddump-spec
13 | -ddump-simpl-stats
14 | -ddump-rule-firings
15 | -dsuppress-all
16 | -dsuppress-uniques
17 | if impl(ghc >= 9.4)
18 | ghc-options:
19 | -dlint
20 |
21 | -- * Profiling
22 |
23 | executable prof-simple
24 | import: dump-core
25 | main-is: index.hs
26 | hs-source-dirs: .
27 | ghc-options:
28 | -O2 -Wall
29 | -rtsopts -threaded
30 | if impl(ghc >= 9.4)
31 | ghc-prof-options:
32 | -fprof-late
33 | ghc-prof-options:
34 | "-with-rtsopts=-s -M32m -A4m -AL8m -pa -hy -L250 -l-agu -N1"
35 | build-depends:
36 | ClickHaskell
37 | , base
38 | , bytestring
39 | default-language: Haskell2010
40 |
--------------------------------------------------------------------------------
/documentation/performance/p2-100-million-r/index.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE
2 | DataKinds
3 | , DeriveAnyClass
4 | , DeriveGeneric
5 | , DerivingStrategies
6 | , NumericUnderscores
7 | , OverloadedStrings
8 | , TypeApplications
9 | #-}
10 |
11 | module PT2OneBillionStream (main) where
12 |
13 | -- Internal
14 | import ClickHaskell
15 |
16 | -- GHC included
17 | import Debug.Trace (traceMarkerIO)
18 | import GHC.Generics (Generic)
19 | import Control.DeepSeq (NFData)
20 |
21 |
22 | main :: IO ()
23 | main = do
24 | traceMarkerIO "Initialization"
25 | connection <- openConnection defaultConnectionArgs
26 |
27 | let totalRows = 100_000_000
28 |
29 | result <-
30 | sum <$>
31 | generateRandom
32 | @ExampleColumns
33 | @ExampleData
34 | connection
35 | (1, 10, 2)
36 | totalRows
37 | (pure . length)
38 |
39 | print $ "Processing done. " <> show result <> " rows was processed"
40 |
41 |
42 | data ExampleData = MkExampleData
43 | { a1 :: Int64
44 | }
45 | deriving (Generic, Show, NFData)
46 | deriving anyclass (ClickHaskell ExampleColumns)
47 |
48 |
49 | type ExampleColumns =
50 | '[ Column "a1" Int64
51 | ]
52 |
--------------------------------------------------------------------------------
/documentation/performance/p2-100-million-r/prof-1bil-stream.cabal:
--------------------------------------------------------------------------------
1 | Cabal-version: 3.0
2 |
3 | name: prof-1bil-stream
4 | version: 0.0.0.1
5 | build-type: Simple
6 | license: BSD-3-Clause
7 |
8 | common dump-core
9 | ghc-options:
10 | -ddump-to-file
11 | -ddump-simpl
12 | -ddump-spec
13 | -ddump-simpl-stats
14 | -ddump-rule-firings
15 | -dsuppress-all
16 | -dsuppress-uniques
17 | if impl(ghc >= 9.4)
18 | ghc-options:
19 | -dlint
20 |
21 | -- * Profiling
22 |
23 | executable prof-1bil-stream
24 | import: dump-core
25 | main-is: index.hs
26 | hs-source-dirs: .
27 | ghc-options:
28 | -O2 -threaded
29 | -main-is PT2OneBillionStream
30 | -Wall
31 | if impl(ghc >= 9.4)
32 | ghc-prof-options:
33 | -fprof-late
34 | ghc-prof-options:
35 | -rtsopts "-with-rtsopts=-s -A8m -AL256m -p -hy -L250 -l-agu -N1"
36 | build-depends:
37 | ClickHaskell
38 | , base
39 | , bytestring
40 | , deepseq
41 | default-language: Haskell2010
42 |
--------------------------------------------------------------------------------
/documentation/testing/T1QuerySerialization.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE
2 | AllowAmbiguousTypes
3 | , DataKinds
4 | , DeriveGeneric
5 | , FlexibleContexts
6 | , FlexibleInstances
7 | , MultiParamTypeClasses
8 | , OverloadedStrings
9 | , TypeFamilies
10 | , TypeApplications
11 | , UndecidableInstances
12 | , ScopedTypeVariables
13 | #-}
14 |
15 | module T1QuerySerialization
16 | ( t1
17 | ) where
18 |
19 | -- Internal
20 | import ClickHaskell
21 | ( Connection(..)
22 | , ClickHaskell, select
23 | , Column, KnownColumn, SerializableColumn
24 | , IsChType(..), ToChType(..)
25 | , ToQueryPart(..)
26 | , UInt8, UInt16, UInt32, UInt64
27 | , Int8, Int16, Int32, Int64
28 | , ChString, UUID, DateTime -- , DateTime64
29 | )
30 |
31 | -- GHC included
32 | import Control.Monad (when)
33 | import Data.ByteString as BS (singleton)
34 | import Data.ByteString.Char8 as BS8 (pack)
35 | import Data.ByteString.Builder (toLazyByteString, byteString)
36 | import GHC.Generics (Generic)
37 |
38 |
39 | t1 :: Connection -> IO ()
40 | t1 conn = do
41 | runTestForType @Int8 conn [minBound, toEnum 0, maxBound]
42 | runTestForType @Int16 conn [minBound, toEnum 0, maxBound]
43 | runTestForType @Int32 conn [minBound, toEnum 0, maxBound]
44 | runTestForType @Int64 conn [minBound, toEnum 0, maxBound]
45 | runTestForType @UInt8 conn [minBound, toEnum 0, maxBound]
46 | runTestForType @UInt16 conn [minBound, toEnum 0, maxBound]
47 | runTestForType @UInt32 conn [minBound, toEnum 0, maxBound]
48 | runTestForType @UInt64 conn [minBound, toEnum 0, maxBound]
49 | runTestForType @UUID conn [minBound, toEnum 0, maxBound]
50 | runTestForType @(DateTime "") conn [minBound, toEnum 0, maxBound]
51 | -- runTestForType @(DateTime64 0 "") conn [minBound, toEnum 0, maxBound]
52 | runTestForType @ChString conn (map (toChType . BS.singleton) [1..255])
53 | -- ToDo: runTestForType @(LowCardinality ChString) connection (map (toChType . BS.singleton) [0..255])
54 | -- ToDo: runTestForType @(ChArray ChString) connection [toChType $ map BS.singleton [0..255]]
55 | -- ToDo: runTestForType @(ChArray ChInt64) connection [toChType [0 :: ChInt64 .. 255]]
56 |
57 |
58 | runTestForType ::
59 | forall chType
60 | .
61 | ( ToQueryPart chType
62 | , IsChType chType
63 | , Eq chType
64 | , Show chType
65 | , ClickHaskell '[Column "testSample" chType] (TestSample chType)
66 | )
67 | =>
68 | Connection -> [chType] -> IO ()
69 | runTestForType connection testValues = do
70 | let typeName = (byteString . BS8.pack) (chTypeName @chType)
71 | mapM_
72 | (\chType -> do
73 | [selectChType] <-
74 | concat <$>
75 | select
76 | @'[Column "testSample" chType]
77 | @(TestSample chType)
78 | connection
79 | (toChType ("SELECT CAST(" <> toQueryPart chType <> ", '" <> typeName <> "') as testSample;"))
80 | pure
81 |
82 | (when (chType /= testSample selectChType) . error)
83 | ( "Deserialized value of type " <> show (toLazyByteString typeName) <> " unmatched:"
84 | <> " Expected: " <> show chType
85 | <> ". But got: " <> show selectChType <> "."
86 | )
87 | )
88 | testValues
89 |
90 | print (toLazyByteString typeName <> ": Ok")
91 |
92 |
93 | data TestSample chType = MkTestSample {testSample :: chType}
94 | deriving (Generic, Show)
95 |
96 |
97 | instance
98 | ( SerializableColumn (Column "testSample" chType)
99 | , KnownColumn (Column "testSample" chType)
100 | )
101 | =>
102 | ClickHaskell '[Column "testSample" chType] (TestSample chType)
103 |
--------------------------------------------------------------------------------
/documentation/testing/T2WriteReadEquality.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE
2 | DataKinds
3 | , AllowAmbiguousTypes
4 | , DeriveGeneric
5 | , FlexibleContexts
6 | , FlexibleInstances
7 | , MultiParamTypeClasses
8 | , OverloadedStrings
9 | , ScopedTypeVariables
10 | , TypeApplications
11 | , TypeFamilies
12 | #-}
13 |
14 | module T2WriteReadEquality
15 | ( t2
16 | ) where
17 |
18 | -- Internal
19 | import ClickHaskell
20 | ( ClickHaskell, selectFrom, insertInto
21 | , command
22 | , Connection
23 | , Table
24 | , Column
25 | , toChType
26 | , UInt8, UInt16, UInt32, UInt64, UInt128
27 | , UUID, DateTime, ChString, Int128, Word128
28 | , Nullable, DateTime64
29 | )
30 |
31 | -- GHC included
32 | import Control.Monad (when)
33 | import Data.Int (Int16, Int32, Int64, Int8)
34 | import Data.Word (Word16, Word32, Word64, Word8)
35 | import GHC.Generics (Generic)
36 |
37 | t2 :: Connection -> IO ()
38 | t2 connection = do
39 | command connection createTableQuery
40 | command connection "TRUNCATE writeReadEqualityTable;"
41 |
42 | insertInto
43 | @TestTable
44 | @TestData
45 | connection
46 | [testData]
47 |
48 | [result] <-
49 | concat <$>
50 | selectFrom
51 | @TestTable
52 | @TestData
53 | connection
54 | pure
55 |
56 | let testLabel = "WriteReadEquality: "
57 |
58 | (when (result /= testData) . error)
59 | ( testLabel <> "Unequal result.\n"
60 | <> "Writed data: " <> show testData <> "\n"
61 | <> "Readed data: " <> show result)
62 |
63 | print $ testLabel <> "Ok"
64 |
65 |
66 | type TestTable = Table "writeReadEqualityTable" TestColumns
67 | type TestColumns =
68 | '[ Column "dateTime" (DateTime "UTC")
69 | , Column "dateTimeNullable" (Nullable (DateTime "UTC"))
70 | , Column "dateTime64" (DateTime64 3 "UTC")
71 | , Column "dateTime64Nullable" (Nullable (DateTime64 3 "UTC"))
72 | , Column "int128" Int128
73 | , Column "int128Nullable" (Nullable Int128)
74 | , Column "int16" Int16
75 | , Column "int16Nullable" (Nullable Int16)
76 | , Column "int32" Int32
77 | , Column "int32Nullable" (Nullable Int32)
78 | , Column "int64" Int64
79 | , Column "int64Nullable" (Nullable Int64)
80 | , Column "int8" Int8
81 | , Column "int8Nullable" (Nullable Int8)
82 | , Column "string" ChString
83 | , Column "stringNullable" (Nullable ChString)
84 | , Column "uint128" UInt128
85 | , Column "uint128Nullable" (Nullable UInt128)
86 | , Column "uint16" UInt16
87 | , Column "uint16Nullable" (Nullable UInt16)
88 | , Column "uint32" UInt32
89 | , Column "uint32Nullable" (Nullable UInt32)
90 | , Column "uint64" UInt64
91 | , Column "uint64Nullable" (Nullable UInt64)
92 | , Column "uint8" UInt8
93 | , Column "uint8Nullable" (Nullable UInt8)
94 | , Column "uuid" UUID
95 | , Column "uuidNullable" (Nullable UUID)
96 | ]
97 |
98 | data TestData = MkTestData
99 | { dateTime :: DateTime "UTC"
100 | , dateTimeNullable :: Nullable (DateTime "UTC")
101 | , dateTime64 :: DateTime64 3 "UTC"
102 | , dateTime64Nullable :: Nullable (DateTime64 3 "UTC")
103 | , int128 :: Int128
104 | , int128Nullable :: Nullable Int128
105 | , int16 :: Int16
106 | , int16Nullable :: Nullable Int16
107 | , int32 :: Int32
108 | , int32Nullable :: Nullable Int32
109 | , int64 :: Int64
110 | , int64Nullable :: Nullable Int64
111 | , int8 :: Int8
112 | , int8Nullable :: Nullable Int8
113 | , string :: ChString
114 | , stringNullable :: Nullable ChString
115 | , uint128 :: UInt128
116 | , uint128Nullable :: Nullable UInt128
117 | , uint16 :: UInt16
118 | , uint16Nullable :: Nullable UInt16
119 | , uint32 :: UInt32
120 | , uint32Nullable :: Nullable UInt32
121 | , uint64 :: UInt64
122 | , uint64Nullable :: Nullable UInt64
123 | , uint8 :: UInt8
124 | , uint8Nullable :: Nullable UInt8
125 | , uuid :: UUID
126 | , uuidNullable :: Nullable UUID
127 | }
128 | deriving (Generic, Show, Eq)
129 |
130 | instance ClickHaskell TestColumns TestData
131 |
132 | testData :: TestData
133 | testData = MkTestData
134 | { dateTime = toChType (0 :: Word32)
135 | , dateTimeNullable = Just 42
136 | , dateTime64 = 42
137 | , dateTime64Nullable = Just 42
138 | , int128 = toChType (-128 :: Int128)
139 | , int128Nullable = toChType $ Just (-128 :: Int128)
140 | , int16 = toChType (-16 :: Int16)
141 | , int16Nullable = toChType $ Just (-16 :: Int16)
142 | , int32 = toChType (-32 :: Int32)
143 | , int32Nullable = toChType $ Just (-32 :: Int32)
144 | , int64 = toChType (-64 :: Int64)
145 | , int64Nullable = toChType $ Just (-64 :: Int64)
146 | , int8 = toChType (-8 :: Int8)
147 | , int8Nullable = toChType $ Just (-8 :: Int8)
148 | , string = "string"
149 | , stringNullable = Just "string"
150 | , uint128 = toChType (128 :: Word128)
151 | , uint128Nullable = toChType $ Just (128 :: Word128)
152 | , uint16 = toChType (16 :: Word16)
153 | , uint16Nullable = toChType $ Just (16 :: Word16)
154 | , uint32 = toChType (32 :: Word32)
155 | , uint32Nullable = toChType $ Just (32 :: Word32)
156 | , uint64 = toChType (64 :: Word64)
157 | , uint64Nullable = toChType $ Just (64 :: Word64)
158 | , uint8 = toChType (8 :: Word8)
159 | , uint8Nullable = toChType $ Just (8 :: Word8)
160 | , uuid = let pos = (^) @Word64 @Word64 16 in
161 | toChType ((pos 3)*4 + (pos 2)*2 )
162 | -- ^ 00000000-0000-0000-0000-000000004200
163 | , uuidNullable = Nothing
164 | }
165 |
166 | createTableQuery :: ChString
167 | createTableQuery =
168 | "CREATE TABLE IF NOT EXISTS writeReadEqualityTable \
169 | \( \
170 | \ `dateTime` DateTime('UTC'), \
171 | \ `dateTime64` DateTime64(3, 'UTC'), \
172 | \ `dateTimeNullable` Nullable(DateTime('UTC')), \
173 | \ `dateTime64Nullable` Nullable(DateTime64(3, 'UTC')), \
174 | \ `int128` Int128, \
175 | \ `int128Nullable` Nullable(Int128), \
176 | \ `int16` Int16, \
177 | \ `int16Nullable` Nullable(Int16), \
178 | \ `int32` Int32, \
179 | \ `int32Nullable` Nullable(Int32), \
180 | \ `int64` Int64, \
181 | \ `int64Nullable` Nullable (Int64), \
182 | \ `int8` Int8, \
183 | \ `int8Nullable` Nullable(Int8), \
184 | \ `string` String, \
185 | \ `stringNullable` Nullable(String), \
186 | \ `uint128` UInt128, \
187 | \ `uint128Nullable` Nullable(UInt128), \
188 | \ `uint16` UInt16, \
189 | \ `uint16Nullable` Nullable (UInt16), \
190 | \ `uint32` UInt32, \
191 | \ `uint32Nullable` Nullable(UInt32), \
192 | \ `uint64` UInt64, \
193 | \ `uint64Nullable` Nullable(UInt64), \
194 | \ `uint8` UInt8, \
195 | \ `uint8Nullable` Nullable(UInt8), \
196 | \ `uuid` UUID, \
197 | \ `uuidNullable` Nullable(UUID) \
198 | \) \
199 | \ENGINE = MergeTree \
200 | \PARTITION BY () \
201 | \ORDER BY ();"
202 |
--------------------------------------------------------------------------------
/documentation/testing/T3Multithreading.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE
2 | DataKinds
3 | , DeriveAnyClass
4 | , DeriveGeneric
5 | , DerivingStrategies
6 | , TypeApplications
7 | #-}
8 |
9 | module T3Multithreading where
10 |
11 | -- Internal
12 | import ClickHaskell
13 |
14 | -- GHC included
15 | import Control.Concurrent.Async (replicateConcurrently_)
16 | import GHC.Generics (Generic)
17 | import GHC.Stack (HasCallStack)
18 |
19 |
20 | t3 :: HasCallStack => Connection -> IO ()
21 | t3 connection = do
22 | replicateConcurrently_ 10000 (
23 | generateRandom
24 | @ExampleColumns
25 | @ExampleData
26 | connection
27 | (1, 10, 2)
28 | 1
29 | pure
30 | )
31 | print "Multithreading: Ok"
32 |
33 | data ExampleData = MkExampleData
34 | { a1 :: Int64
35 | }
36 | deriving (Generic)
37 | deriving anyclass (ClickHaskell ExampleColumns)
38 |
39 |
40 | type ExampleColumns =
41 | '[ Column "a1" Int64
42 | ]
43 |
--------------------------------------------------------------------------------
/documentation/testing/T4MissmatchErrors.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE
2 | DataKinds
3 | , DeriveAnyClass
4 | , DeriveGeneric
5 | , DerivingStrategies
6 | , TypeApplications
7 | , ScopedTypeVariables
8 | #-}
9 |
10 | module T4MissmatchErrors where
11 |
12 | -- Internal
13 | import ClickHaskell
14 |
15 | -- GHC included
16 | import Control.Exception (try)
17 | import GHC.Generics (Generic)
18 | import GHC.Stack (HasCallStack)
19 |
20 |
21 | t4 :: HasCallStack => Connection -> IO ()
22 | t4 connection = do
23 | res1 <-
24 | try (
25 | select
26 | @ExpectedColumns
27 | @ExpectedName
28 | connection
29 | (toChType "SELECT * FROM generateRandom('unexpectedName Int64', 1, 10, 2) LIMIT 1")
30 | pure
31 | )
32 | case res1 of
33 | Left (UserError (UnmatchedColumn _)) -> pure ()
34 | Right _ -> error "Expected an error, but got success"
35 | Left e -> error ("MissmatchErrors: " <> show e)
36 |
37 | res2 <-
38 | try (
39 | select
40 | @ExpectedColumns
41 | @ExpectedName
42 | connection
43 | (toChType "SELECT * FROM generateRandom('expectedName UInt64', 1, 10, 2) LIMIT 1")
44 | pure
45 | )
46 | case res2 of
47 | Left (UserError (UnmatchedType _)) -> pure ()
48 | Right _ -> error "Expected an error, but got success"
49 | Left e -> error ("MissmatchErrors: " <> show e)
50 |
51 | res3 <-
52 | try (
53 | select
54 | @ExpectedColumns
55 | @ExpectedName
56 | connection
57 | (toChType "SELECT * FROM generateRandom('expectedName Int64, unexpectedColumn Int64', 1, 10, 2) LIMIT 1")
58 | pure
59 | )
60 | case res3 of
61 | Left (UserError (UnmatchedColumnsCount _)) -> pure ()
62 | Right _ -> error "Expected an error, but got success"
63 | Left e -> error ("MissmatchErrors: " <> show e)
64 |
65 | print "MissmatchErrors: Ok"
66 |
67 |
68 | data ExpectedName = MkExpectedName
69 | { expectedName :: Int64
70 | }
71 | deriving (Generic)
72 | deriving anyclass (ClickHaskell ExpectedColumns)
73 |
74 |
75 | type ExpectedColumns =
76 | '[ Column "expectedName" Int64
77 | ]
78 |
--------------------------------------------------------------------------------
/documentation/testing/index.lhs:
--------------------------------------------------------------------------------
1 | Testing
2 |
3 | {-# LANGUAGE OverloadedStrings #-}
5 | module Tests where
6 |
7 |
8 |
9 | import T1QuerySerialization (t1)
11 |
12 |
13 | 1. Builds queries like
14 | SELECT CAST(5, 'UInt8') as testSample;
15 | via ToQueryPart type class for every supported type
16 | 2. Executes select
17 | 3. Parses the result
18 | 4. Checks if result equals initial value
19 |
20 | import T2WriteReadEquality (t2)
22 |
23 |
24 | 1. Runs insertInto of a sample into the all supported types table
25 | 2. Runs selectFrom from the same table
26 | 3. Checks if result equals sample value
27 |
28 |
29 | import T3Multithreading (t3)
31 |
32 | 1. Runs 10000 concurrent queries via single connection
33 |
34 |
35 | import T4MissmatchErrors (t4)
37 |
38 | 1. Runs queries with types and names missmatch and handles error
39 |
40 |
41 | How to run
42 | You can manually run database and tests:
43 |
44 | nix run .#testing
46 |
47 |
48 |
49 | Main function
50 |
51 | import ClickHaskell (openConnection, defaultConnectionArgs, overrideTLS)
53 | import Network.TLS (defaultParamsClient, ClientParams (..), Shared (..), ValidationCache (..), ValidationCacheResult (..))
54 | import Data.Default.Class
55 |
56 | main :: IO ()
57 | main = do
58 | connection <- openConnection
59 | . overrideTLS (defaultParamsClient "localhost" "9440")
60 | { clientShared = def
61 | { sharedValidationCache =
62 | ValidationCache
63 | (\_ _ _ -> return ValidationCachePass)
64 | (\_ _ _ -> return ())
65 | }
66 | }
67 | $ defaultConnectionArgs
68 | mapM_
69 | (\runner -> runner connection)
70 | [t1,t2,t3,t4]
71 |
72 |
--------------------------------------------------------------------------------
/documentation/testing/tests.cabal:
--------------------------------------------------------------------------------
1 | Cabal-version: 3.0
2 |
3 | name: tests
4 | version: 0.0.0.1
5 | build-type: Simple
6 | license: BSD-3-Clause
7 |
8 | executable tests
9 | main-is: index.lhs
10 | hs-source-dirs: .
11 | ghc-options:
12 | -O2 -threaded -rtsopts
13 | -main-is Tests
14 | -pgmL html2hs -Wall
15 | build-tool-depends: html2hs:html2hs
16 | build-depends:
17 | ClickHaskell
18 | , async
19 | , tls
20 | , data-default-class
21 | , base >=4.7 && <5
22 | , bytestring
23 | other-modules:
24 | T1QuerySerialization
25 | T2WriteReadEquality
26 | T3Multithreading
27 | T4MissmatchErrors
28 | default-language: Haskell2010
29 |
--------------------------------------------------------------------------------
/documentation/usage/index.lhs:
--------------------------------------------------------------------------------
1 | usage
2 |
3 | Lets write simple executable with generic usage examples
4 |
5 |
6 | Before we start we need to define module
7 | {-# LANGUAGE DataKinds, DeriveAnyClass, OverloadedStrings #-}
9 |
10 | module Main where
11 |
12 | import ClickHaskell
13 | import GHC.Generics (Generic)
14 |
15 |
16 |
17 |
18 | General preparation
19 |
20 | ClickHaskell provides unique API in area of DBMS clients
21 |
22 | We need to define our types
23 |
24 | data ExampleData = MkExampleData
26 | { a1 :: Int32
27 | , a2 :: ChString
28 | , a3 :: UInt32
29 | }
30 | deriving (Generic, Show)
31 |
32 | type ExampleCols =
33 | '[ Column "a1" Int32
34 | , Column "a2" ChString
35 | , Column "a3" (DateTime "")
36 | ]
37 |
38 |
39 | and generate client side code
40 |
41 | {- Before GHC 9.8 its better to use standalone deriving
43 | since type errors occures exact on deriving declaration.
44 | -}
45 | deriving instance ClickHaskell ExampleCols ExampleData
46 |
47 |
48 | Command
49 |
50 | Also we should create the table and view
51 |
52 | createView :: Connection -> IO ()
54 | createView connection =
55 | command
56 | connection
57 | "CREATE OR REPLACE VIEW exampleView \
58 | \AS SELECT * \
59 | \FROM generateRandom('a1 Int32, a2 String, a3 DateTime', 1, 10, 2) \
60 | \WHERE (a1 > {a1MoreThan:Int32}) AND (a1 < {a1LessThan:Int32}) \
61 | \LIMIT 5;"
62 |
63 | createTable :: Connection -> IO ()
64 | createTable connection =
65 | command
66 | connection
67 | "CREATE TABLE IF NOT EXISTS exampleTable ( \
68 | \ `a1` Int32, \
69 | \ `a2` String, \
70 | \ `a3` DateTime, \
71 | \) \
72 | \ENGINE = MergeTree \
73 | \PARTITION BY () \
74 | \ORDER BY ();"
75 |
76 |
77 |
78 |
79 | View
80 |
81 | exampleView :: Connection -> IO [ExampleData]
83 | exampleView connection =
84 | mconcat <$>
85 | selectFromView
86 | @(View "exampleView" ExampleCols ExampleParams)
87 | @ExampleData
88 | connection
89 | exampleParams
90 | pure
91 |
92 | exampleParams :: Parameters '[] -> Parameters ExampleParams
93 | exampleParams =
94 | ( parameter @"a1MoreThan" @Int32 ((-100_000) :: Int32)
95 | . parameter @"a1LessThan" @Int32 ((100_000) :: Int32)
96 | )
97 |
98 | type ExampleParams =
99 | '[ Parameter "a1MoreThan" Int32
100 | , Parameter "a1LessThan" Int32
101 | ]
102 |
103 |
104 |
105 |
106 | Insert
107 |
108 | exampleInsert :: Connection -> [ExampleData] -> IO ()
110 | exampleInsert connection x =
111 | insertInto
112 | @(Table "exampleTable" ExampleCols)
113 | @ExampleData
114 | connection
115 | x
116 |
117 |
118 |
119 |
120 | Select
121 |
122 | exampleSelect :: Connection -> IO [ExampleData]
124 | exampleSelect connection =
125 | mconcat <$>
126 | select
127 | @ExampleCols
128 | @ExampleData
129 | connection
130 | "SELECT CAST(5, 'Int32') as a1, 'hello' as a2, CAST(5, 'DateTime') as a3 LIMIT 5;"
131 | pure
132 |
133 |
134 |
135 |
136 | Connection
137 |
138 | main :: IO ()
140 | main = do
141 | connection <- openConnection defaultConnectionArgs
142 |
143 | createView connection
144 | createTable connection
145 |
146 | selectRes <- exampleSelect connection
147 | viewRes <- exampleView connection
148 |
149 | exampleInsert connection (selectRes <> viewRes)
150 |
151 |
--------------------------------------------------------------------------------
/documentation/usage/usage.cabal:
--------------------------------------------------------------------------------
1 | Cabal-version: 3.0
2 |
3 | name: usage
4 | version: 0.0.0.1
5 | build-type: Simple
6 | license: BSD-3-Clause
7 |
8 | executable usage
9 | default-language: Haskell2010
10 | default-extensions:
11 | DeriveGeneric,
12 | FlexibleInstances,
13 | MultiParamTypeClasses,
14 | NumericUnderscores,
15 | TypeApplications,
16 | StandaloneDeriving
17 | main-is: index.lhs
18 | build-depends:
19 | ClickHaskell
20 | , base >=4.7 && <5
21 | , bytestring
22 | ghc-options: -pgmL html2hs -Wall
23 | build-tool-depends: html2hs:html2hs
24 |
--------------------------------------------------------------------------------
/flake.lock:
--------------------------------------------------------------------------------
1 | {
2 | "nodes": {
3 | "flake-parts": {
4 | "inputs": {
5 | "nixpkgs-lib": "nixpkgs-lib"
6 | },
7 | "locked": {
8 | "lastModified": 1748821116,
9 | "narHash": "sha256-F82+gS044J1APL0n4hH50GYdPRv/5JWm34oCJYmVKdE=",
10 | "owner": "hercules-ci",
11 | "repo": "flake-parts",
12 | "rev": "49f0870db23e8c1ca0b5259734a02cd9e1e371a1",
13 | "type": "github"
14 | },
15 | "original": {
16 | "owner": "hercules-ci",
17 | "repo": "flake-parts",
18 | "type": "github"
19 | }
20 | },
21 | "haskell-flake": {
22 | "locked": {
23 | "lastModified": 1749105244,
24 | "narHash": "sha256-gV/B1PWOwpLjy2OCHMS/fJ8GItMRoflW/g3kXB8/skg=",
25 | "owner": "srid",
26 | "repo": "haskell-flake",
27 | "rev": "af2ba40f23824556b12d1cdfdf392e263876d644",
28 | "type": "github"
29 | },
30 | "original": {
31 | "owner": "srid",
32 | "repo": "haskell-flake",
33 | "type": "github"
34 | }
35 | },
36 | "nixpkgs": {
37 | "locked": {
38 | "lastModified": 1749213349,
39 | "narHash": "sha256-UAaWOyQhdp7nXzsbmLVC67fo+QetzoTm9hsPf9X3yr4=",
40 | "owner": "nixos",
41 | "repo": "nixpkgs",
42 | "rev": "a4ff0e3c64846abea89662bfbacf037ef4b34207",
43 | "type": "github"
44 | },
45 | "original": {
46 | "owner": "nixos",
47 | "ref": "nixpkgs-unstable",
48 | "repo": "nixpkgs",
49 | "type": "github"
50 | }
51 | },
52 | "nixpkgs-lib": {
53 | "locked": {
54 | "lastModified": 1748740939,
55 | "narHash": "sha256-rQaysilft1aVMwF14xIdGS3sj1yHlI6oKQNBRTF40cc=",
56 | "owner": "nix-community",
57 | "repo": "nixpkgs.lib",
58 | "rev": "656a64127e9d791a334452c6b6606d17539476e2",
59 | "type": "github"
60 | },
61 | "original": {
62 | "owner": "nix-community",
63 | "repo": "nixpkgs.lib",
64 | "type": "github"
65 | }
66 | },
67 | "process-compose-flake": {
68 | "locked": {
69 | "lastModified": 1740324671,
70 | "narHash": "sha256-djc+wRG9L70jlW95Ck4GKr7nTPp1drfsXshJkYZAd9s=",
71 | "owner": "Platonic-Systems",
72 | "repo": "process-compose-flake",
73 | "rev": "2a17e49b8a5d32278ed77e4a881f992472be18a1",
74 | "type": "github"
75 | },
76 | "original": {
77 | "owner": "Platonic-Systems",
78 | "repo": "process-compose-flake",
79 | "type": "github"
80 | }
81 | },
82 | "root": {
83 | "inputs": {
84 | "flake-parts": "flake-parts",
85 | "haskell-flake": "haskell-flake",
86 | "nixpkgs": "nixpkgs",
87 | "process-compose-flake": "process-compose-flake",
88 | "services-flake": "services-flake"
89 | }
90 | },
91 | "services-flake": {
92 | "locked": {
93 | "lastModified": 1749209232,
94 | "narHash": "sha256-tvlhavTHoF4ARof6edyTzvuhBJkzeApJW2ZOPlOdxDM=",
95 | "owner": "juspay",
96 | "repo": "services-flake",
97 | "rev": "a660855823837f6ecdd422b7854b74f81174a1c6",
98 | "type": "github"
99 | },
100 | "original": {
101 | "owner": "juspay",
102 | "repo": "services-flake",
103 | "type": "github"
104 | }
105 | }
106 | },
107 | "root": "root",
108 | "version": 7
109 | }
110 |
--------------------------------------------------------------------------------
/flake.nix:
--------------------------------------------------------------------------------
1 | {
2 | description = "ClickHaskell";
3 | inputs = {
4 | nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
5 | flake-parts.url = "github:hercules-ci/flake-parts";
6 | haskell-flake.url = "github:srid/haskell-flake";
7 | process-compose-flake.url = "github:Platonic-Systems/process-compose-flake";
8 | services-flake.url = "github:juspay/services-flake";
9 | };
10 |
11 | outputs = {self, flake-parts, nixpkgs, ...} @ inputs:
12 | flake-parts.lib.mkFlake {inherit inputs;} {
13 | systems = nixpkgs.lib.systems.flakeExposed;
14 | imports = [
15 | inputs.haskell-flake.flakeModule
16 | inputs.process-compose-flake.flakeModule
17 | ];
18 | perSystem = {self', pkgs, config, lib, ...}:
19 | let
20 | mapMergeAttrsList = f: x: lib.mergeAttrsList (map f x);
21 | supportedGHCs = ["ghc8107" "ghc902" "ghc928" "ghc948" "ghc966" "ghc984" "ghc9101" "ghc9122"];
22 | in
23 | {
24 | process-compose = {
25 | default = import ./contribution/localServer.nix {
26 | inherit inputs pkgs;
27 | app = self'.apps.ghc984-server;
28 | agent = self'.apps.ghc984-eventlog-agent;
29 | docDirPath = self'.packages."documentation";
30 | };
31 | }
32 | //
33 | mapMergeAttrsList
34 | ({ghc, app}: {
35 | "test-${ghc}-${app}" = import ./contribution/testing.nix {
36 | inherit pkgs inputs;
37 | app = self'.apps."${ghc}-${app}";
38 | };
39 | }
40 | )
41 | (lib.cartesianProduct {
42 | ghc = supportedGHCs;
43 | app = ["prof-1bil-stream" "prof-simple" "tests"];
44 | });
45 | haskellProjects =
46 | mapMergeAttrsList
47 | (ghc: {"${ghc}" = import ./contribution/project.nix {inherit pkgs ghc;};})
48 | supportedGHCs;
49 | devShells =
50 | mapMergeAttrsList
51 | (ghc: {"dev-${ghc}" = pkgs.mkShell {
52 | inputsFrom = [];
53 | packages = with pkgs; with haskellPackages; with (self'.packages);
54 | [ clickhouse nil eventlog2html graphmod
55 | self'.packages."${ghc}-html2hs" haskell.compiler."${ghc}" cabal-install
56 | ];
57 | };
58 | })
59 | supportedGHCs
60 | //
61 | {
62 | default = pkgs.mkShell {
63 | inputsFrom = [config.haskellProjects.ghc984.outputs.devShell];
64 | packages = with pkgs; with haskellPackages; with (self'.packages);
65 | [clickhouse nil eventlog2html graphmod ghc984-html2hs];
66 | };
67 | };
68 | # Build documnetation
69 | packages = {
70 | "documentation" = import ./contribution/documentation.nix {inherit pkgs;};
71 | "ClickHaskell-dist" = import ./contribution/hackage.nix {
72 | inherit pkgs;
73 | distPackage = self'.packages.ghc984-ClickHaskell;
74 | };
75 | };
76 | };
77 | }
78 | //
79 | {
80 | nixosModules = {
81 | default = import ./contribution/systemModule.nix self;
82 | };
83 | hydraJobs = { inherit (self) packages; };
84 | };
85 | }
86 |
--------------------------------------------------------------------------------
/library/ChangeLog.md:
--------------------------------------------------------------------------------
1 | # 1.0.0 -- ?
2 |
3 | ## Features:
4 | - Support and CI for GHCs: `8.10.7`, `9.0.2`, `9.2.8`
5 | - ~20% optimization of time and alloc (perf test 1 benchmark)
6 | - Added function `command` for statements with no result
7 | - Added DateTime64 type support
8 |
9 | ## Fixes:
10 | - Fixed unexpected behavior when the number of result columns was different from expected.
11 | A `UserError` exception `UnmatchedColumnsCount` is now raised in such cases
12 |
13 | ## Breaking changes:
14 | - ### Generic API changes
15 | `ReadableFrom` and `WritableInto` was replaced with `ClickHaskell`\
16 | Now you should declare single instance for every API parts
17 | ```haskell
18 | data MyData =
19 | ...
20 | deriving (Generic)
21 | deriving anyclass (ClickHaskell ExampleColumns)
22 | ```
23 | ```haskell
24 | data MyData =
25 | ...
26 | deriving (Generic)
27 | deriving anyclass
28 | ( ReadableFrom (Columns ExampleColumns)
29 | , WritableInto (Table "profiler" ExampleColumns)
30 | )
31 | ```
32 | - ### `Columns` type was deleted
33 | - ### `Serializable` type class was unexported
34 | - ### `DeserializableColumn` type class was renamed to `SerializableColumn`
35 | - ### `IsChType` instance changes
36 | `ToChType` type family was deleted
37 | - ### Connection initialization API changes
38 | 1. `ChCredential` renamed to `ConnectionArgs`
39 | 2. `defaultCredentials` renamed to `defaultConnectionArgs`
40 | 3. `openNativeConnection` renamed to `openConnection`
41 | 4. `ConnectionArgs` constructor now are not exported
42 |
43 | You need to use new modifiers:\
44 | `setHost`, `setPort`, `setUser`, `setDatabase`, `setPassword`
45 |
46 | Connection initialization example:
47 | ```haskell
48 | initMyConnection :: IO Connection
49 | initMyConnection = do
50 | connection <-
51 | openConnection
52 | . setUser "default"
53 | . setPassword ""
54 | . setDatabase "default"
55 | . setPort "9000"
56 | . setHost "localhost"
57 | $ defaultConnectionArgs
58 | pure connection
59 | ```
60 |
61 | # 0.2.0 -- 23-03-2023
62 |
63 | ClickHaskell documentation got it's own domain name: https://clickhaskell.dev/
64 |
65 |
66 | ## Fixes:
67 | - Improved multithreading connection usage (+ added test)
68 | - Unexpected behavior on expected and result column type mismatches (+ added test)
69 |
70 | ## Features:
71 | - Additional GHC versions tests: `9.4.8`, `9.8.4`, `9.10.1`
72 | - Query serialization support for UUID (+ added test)
73 | - Export of client errors for exception handling
74 | - Dropped vector dependency
75 | - Introduced memory consumption test (64M limit) on parallel reading and writing of 1 million rows
76 | - Added new reading wrapper for generateRandom function
77 | - Depricating `Ch*` prefixes on types:
78 | - `ChUInt*` -> `UInt*` (type synonyms to Word*)
79 | - `ChInt*` -> `Int*` (reexport of Data.Int)
80 | - `ChDate` -> `Date` (ClickHaskell type)
81 | - `ChDateTime` -> `DateTime` (ClickHaskell type)
82 | - `ChArray` -> `Array` (ClickHaskell type)
83 | - `ChUUID` -> `UUID` (ClickHaskell type)
84 | - openNativeConnection now passes $HOME and $USERNAME variables to query info
85 |
86 | ## Breaking changes:
87 | - ### New UserErrors on types and columns names missmatches
88 | This change helps protect a user from unexpected behavior
89 | `UnmatchedType` error occurs when the expected type doesn't match the resulting one
90 | `UnmatchedColumn` error occurs when the expected column name doesn't match the resulting one
91 | ```haskell
92 | data ExpectedName = MkExpectedName
93 | { expectedName :: ChInt64
94 | }
95 | deriving (Generic)
96 | deriving anyclass (ReadableFrom (Columns ExpectedColumns))
97 |
98 | type ExpectedColumns = '[ Column "expectedName" ChInt64]
99 |
100 | -- Will throw UnmatchedColumn
101 | void $
102 | select
103 | @ExpectedColumns @ExpectedName connection
104 | (toChType "SELECT * FROM generateRandom('unexpectedName Int64', 1, 10, 2) LIMIT 1")
105 | pure
106 |
107 | -- Will throw UnmatchedType
108 | void $
109 | select
110 | @ExpectedColumns @ExpectedName connection
111 | "SELECT * FROM generateRandom('expectedName String', 1, 10, 2) LIMIT 1"
112 | pure
113 | ```
114 |
115 | - ### Migration to streaming API
116 | 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
117 | ```haskell
118 | result <-
119 | sum <$>
120 | select
121 | @ExampleColumns
122 | @ExampleData
123 | connection "\
124 | \SELECT * \
125 | \FROM generateRandom('a1 Int64', 1, 10, 2) \
126 | \LIMIT 1_000_00 \
127 | \ "
128 | ```
129 | now looks like
130 | ```haskell
131 | result <-
132 | sum <$>
133 | select
134 | @ExampleColumns
135 | @ExampleData
136 | connection "\
137 | \SELECT * \
138 | \FROM generateRandom('a1 Int64', 1, 10, 2) \
139 | \LIMIT 1_000_00 \
140 | \ "
141 | (pure . sum)
142 | ```
143 |
144 | - ### DateTime type now parametrized with timezone
145 | Every DateTime type annotations
146 | ```haskell
147 | type A = ChDateTime -- DateTime
148 | type B = ChDateTime -- DateTime('UTC')
149 | ```
150 | should be changed with
151 | ```haskell
152 | type A = ChDateTime "" -- DateTime
153 | type B = ChDateTime "UTC" -- DateTime('UTC')
154 | ```
155 |
156 | - ### Migration to single module distribution
157 | You need to move all imports such as
158 | ```haskell
159 | import ClickHaskell.DbTypes (ChInt8)
160 | ```
161 | to ClickHaskell module
162 | ```haskell
163 | import ClickHaskell (ChInt8)
164 | ```
165 |
166 | # 0.1.0 -- 04-12-2024
167 |
168 | Initial release
169 |
--------------------------------------------------------------------------------
/library/ClickHaskell.cabal:
--------------------------------------------------------------------------------
1 | Cabal-version: 3.0
2 |
3 |
4 | Name: ClickHaskell
5 | Version: 1.0.0
6 |
7 | Author: Kovalev Dmitry
8 | Maintainer: Kovalev Dmitry
9 | Category: ClickHouse
10 | Synopsis: ClickHouse driver
11 | Description: Small dependency footprint highlevel ClickHouse driver
12 | Tested-with: GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, GHC == 9.4.8, GHC == 9.6.6, GHC == 9.8.4, GHC == 9.10.1
13 | Homepage: https://clickhaskell.dev/
14 | Bug-reports: https://git.clickhaskell.dev/
15 | License: BSD-3-Clause
16 | License-File: LICENSE
17 | Copyright: 2023 Kovalev Dmitry
18 | Build-Type: Simple
19 |
20 | extra-doc-files:
21 | README.md
22 | ChangeLog.md
23 |
24 | Source-repository head
25 | Type: git
26 | Location: https://github.com/KovalevDima/ClickHaskell
27 |
28 | Flag dev
29 | Description: Dumps Core representation
30 | Default: False
31 | Manual: True
32 |
33 | Library
34 | Autogen-Modules:
35 | Paths_ClickHaskell
36 | Exposed-Modules:
37 | ClickHaskell
38 | Other-Modules:
39 | Paths_ClickHaskell
40 | HS-Source-Dirs:
41 | ./
42 | GHC-Options:
43 | -Wall
44 | -Wunused-packages
45 |
46 | Build-depends:
47 | -- GHC included libraries
48 | base >= 4.7 && <5
49 | , bytestring < 1
50 | , binary < 9
51 | , deepseq < 2
52 | , text < 3
53 | , time < 2
54 |
55 | -- External dependencies
56 | , network < 4
57 | , tls < 3
58 | , wide-word < 1
59 |
60 | if flag(dev)
61 | GHC-Options:
62 | -ddump-to-file
63 | -ddump-simpl
64 | -ddump-spec
65 | -ddump-simpl-stats
66 | -ddump-rule-firings
67 | -dsuppress-all
68 | -dsuppress-uniques
69 |
70 | default-language: Haskell2010
71 | default-extensions:
72 | AllowAmbiguousTypes
73 | ConstraintKinds
74 | DataKinds
75 | DefaultSignatures
76 | DeriveAnyClass
77 | DeriveGeneric
78 | DerivingStrategies
79 | DuplicateRecordFields
80 | GADTs
81 | GeneralizedNewtypeDeriving
82 | ImportQualifiedPost
83 | FlexibleContexts
84 | FlexibleInstances
85 | LambdaCase
86 | MultiParamTypeClasses
87 | NamedFieldPuns
88 | NumericUnderscores
89 | OverloadedStrings
90 | RecordWildCards
91 | TupleSections
92 | TypeApplications
93 | TypeFamilies
94 | TypeOperators
95 | ScopedTypeVariables
96 | StandaloneDeriving
97 | UndecidableInstances
98 |
--------------------------------------------------------------------------------
/library/ClickHaskell.hs:
--------------------------------------------------------------------------------
1 | {-# OPTIONS_GHC
2 | -Wno-orphans
3 | -Wno-unused-top-binds
4 | -Wno-unused-imports
5 | #-}
6 |
7 | {- |
8 | Module: ClickHaskell
9 | Copyright: (c) 2023 Dmitry Kovalev
10 | License: BSD-3-Clause
11 | Maintainer: Dmitry Kovalev
12 | Stability: Experimental
13 |
14 | For full documentation, visit: https://clickhaskell.dev/
15 | -}
16 |
17 | module ClickHaskell
18 | (
19 | {- * Connection -}
20 | ConnectionArgs, defaultConnectionArgs
21 | , setHost, setPort, setUser, setDatabase, setPassword
22 | , Connection(..), openConnection
23 | {- ** TLS -}
24 | , setSecure, overrideTLS
25 |
26 | {- * Errors -}
27 | , ClientError(..)
28 | , ConnectionError(..)
29 | , UserError(..)
30 | , InternalError(..)
31 |
32 | {- * Client wrappers -}
33 | {- ** SELECT -}
34 | , select, selectFrom, selectFromView, generateRandom
35 | , ClickHaskell(..), FromChType(fromChType)
36 | {- ** INSERT -}
37 | , insertInto
38 | , ToChType(toChType)
39 | {- ** Arbitrary commands -}, command, ping
40 | {- ** Shared -}
41 | , Column, KnownColumn, SerializableColumn
42 | , Table, View
43 | {- *** Query -}
44 | , ToQueryPart(toQueryPart), parameter, Parameter, Parameters, viewParameters
45 |
46 | {- * ClickHouse types -}
47 | , IsChType(chTypeName, defaultValueOfTypeName)
48 | , DateTime(..), DateTime64
49 | , Int8, Int16, Int32, Int64, Int128(..)
50 | , UInt8, UInt16, UInt32, UInt64, UInt128, Word128(..)
51 | , Nullable
52 | , LowCardinality, IsLowCardinalitySupported
53 | , UUID(..)
54 | , Array(..)
55 | , ChString(..)
56 |
57 |
58 | {- * Protocol parts -}
59 |
60 | {- ** Shared -}
61 | , UVarInt(..), SinceRevision(..), ProtocolRevision
62 | {- *** Data packet -}, DataPacket(..), BlockInfo(..)
63 |
64 | {- ** Client -}, ClientPacket(..)
65 | {- *** Hello -}, HelloPacket(..), Addendum(..)
66 | {- *** Query -}
67 | , QueryPacket(..)
68 | , DbSettings(..), QueryParameters(..), QueryStage(..)
69 | , ClientInfo(..), QueryKind(..)
70 |
71 | {- ** Server -}, ServerPacket(..)
72 | {- *** Hello -}, HelloResponse(..), PasswordComplexityRules(..)
73 | {- *** Exception -}, ExceptionPacket(..)
74 | {- *** Progress -}, ProgressPacket(..)
75 | {- *** ProfileInfo -}, ProfileInfo(..)
76 | {- *** TableColumns -}, TableColumns(..)
77 | ) where
78 |
79 | -- Internal
80 | import Paths_ClickHaskell (version)
81 |
82 | -- GHC included
83 | import Control.Applicative (liftA2)
84 | import Control.Concurrent (MVar, newMVar, putMVar, takeMVar)
85 | import Control.DeepSeq (NFData)
86 | import Control.Exception (Exception, SomeException, bracketOnError, catch, finally, mask, onException, throw, throwIO)
87 | import Control.Monad (forM, replicateM, when, (<$!>), (<=<))
88 | import Data.Binary.Get
89 | import Data.Bits (Bits (setBit, unsafeShiftL, unsafeShiftR, (.&.), (.|.)))
90 | import Data.ByteString as BS (ByteString, length, take)
91 | import Data.ByteString.Builder
92 | import Data.ByteString.Char8 as BS8 (concatMap, length, pack, replicate, singleton)
93 | import Data.ByteString.Lazy as BSL (toStrict, ByteString)
94 | import Data.Coerce (coerce)
95 | import Data.IORef (IORef, atomicModifyIORef, atomicWriteIORef, newIORef, readIORef)
96 | import Data.Int (Int16, Int32, Int64, Int8)
97 | import Data.Kind (Type)
98 | import Data.List (uncons)
99 | import Data.Maybe (listToMaybe, fromMaybe)
100 | import Data.String (IsString (..))
101 | import Data.Text (Text)
102 | import Data.Text.Encoding as Text (encodeUtf8)
103 | import Data.Time (UTCTime, ZonedTime, zonedTimeToUTC)
104 | import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
105 | import Data.Typeable (Proxy (..))
106 | import Data.Version (Version (..))
107 | import Data.Word (Word16, Word32, Word64, Word8)
108 | import GHC.Generics (C1, D1, Generic (..), K1 (K1, unK1), M1 (M1, unM1), Meta (MetaSel), Rec0, S1, type (:*:) (..))
109 | import GHC.Stack (HasCallStack, callStack, prettyCallStack)
110 | import GHC.TypeLits (ErrorMessage (..), KnownNat, KnownSymbol, Nat, Symbol, TypeError, natVal, symbolVal)
111 | import System.Environment (lookupEnv)
112 | import System.Timeout (timeout)
113 |
114 | -- External
115 | import Data.WideWord (Int128 (..), Word128(..))
116 | import Network.Socket hiding (SocketOption(..))
117 | import Network.Socket qualified as Sock (SocketOption(..))
118 | import Network.Socket.ByteString (recv)
119 | import Network.Socket.ByteString.Lazy (sendAll)
120 | import Network.TLS (ClientParams (..), contextNew, contextClose, sendData, recvData, defaultParamsClient, handshake)
121 |
122 | -- * Connection
123 |
124 | {- |
125 | See `defaultConnectionArgs` for documentation
126 | -}
127 | data ConnectionArgs = MkConnectionArgs
128 | { user :: Text
129 | , pass :: Text
130 | , db :: Text
131 | , host :: HostName
132 | , mPort :: Maybe ServiceName
133 | , isTLS :: Bool
134 | , overriddenTLS :: Maybe ClientParams
135 | , initBuffer :: HostName -> SockAddr -> Socket -> IO Buffer
136 | }
137 |
138 | {- |
139 | Default connection settings which follows __clickhouse-client__ defaults
140 |
141 | Use `setUser`, `setPassword`, `setHost`, `setPort`, `setDatabase`
142 | to modify connection defaults.
143 |
144 | Or 'setSecure', 'overrideTLS' to configure TLS connection
145 | -}
146 | defaultConnectionArgs :: ConnectionArgs
147 | defaultConnectionArgs = MkConnectionArgs
148 | { user = "default"
149 | , pass = ""
150 | , host = "localhost"
151 | , db = "default"
152 | , isTLS = False
153 | , mPort = Nothing
154 | , overriddenTLS = Nothing
155 | , initBuffer = \_hostname addrAddress sock -> do
156 | setSocketOption sock Sock.NoDelay 1
157 | setSocketOption sock Sock.KeepAlive 1
158 | connect sock addrAddress
159 | buff <- newIORef ""
160 | pure
161 | MkBuffer
162 | { writeSock = \bs -> sendAll sock bs
163 | , readSock = recv sock 4096
164 | , closeSock = close sock
165 | , buff
166 | }
167 | }
168 |
169 | {-|
170 | Sets custom TLS settings and applies 'setSecure'
171 | -}
172 | overrideTLS :: ClientParams -> ConnectionArgs -> ConnectionArgs
173 | overrideTLS clientParams MkConnectionArgs{..} =
174 | setSecure $ MkConnectionArgs{overriddenTLS = Just clientParams, ..}
175 |
176 | {-|
177 | Sets TLS connection
178 |
179 | Uses 9443 port by default. Watch 'setPort' to override it
180 | -}
181 | setSecure :: ConnectionArgs -> ConnectionArgs
182 | setSecure MkConnectionArgs{..} =
183 | MkConnectionArgs{initBuffer = initTLS, isTLS=True, ..}
184 | where
185 | initTLS = \hostname addrAddress sock -> do
186 | setSocketOption sock Sock.NoDelay 1
187 | setSocketOption sock Sock.KeepAlive 1
188 | connect sock addrAddress
189 | let defClientParams = (defaultParamsClient hostname "")
190 | context <- contextNew sock (fromMaybe defClientParams overriddenTLS)
191 | handshake context
192 | buff <- newIORef ""
193 | pure
194 | MkBuffer
195 | { writeSock = \bs -> sendData context bs
196 | , readSock = recvData context
197 | , closeSock = contextClose context
198 | , buff
199 | }
200 |
201 | {- |
202 | Overrides default user __"default"__
203 | -}
204 | setUser :: Text -> ConnectionArgs -> ConnectionArgs
205 | setUser new MkConnectionArgs{..} = MkConnectionArgs{user=new, ..}
206 |
207 | {- |
208 | Overrides default password __""__
209 | -}
210 | setPassword :: Text -> ConnectionArgs -> ConnectionArgs
211 | setPassword new MkConnectionArgs{..} = MkConnectionArgs{pass=new, ..}
212 |
213 | {- |
214 | Overrides default hostname __"localhost"__
215 | -}
216 | setHost :: HostName -> ConnectionArgs -> ConnectionArgs
217 | setHost new MkConnectionArgs{..} = MkConnectionArgs{host=new, ..}
218 |
219 | {- |
220 | Overrides default port __9000__ (or __9443__ for TLS)
221 | -}
222 | setPort :: ServiceName -> ConnectionArgs -> ConnectionArgs
223 | setPort new MkConnectionArgs{..} = MkConnectionArgs{mPort=Just new, ..}
224 |
225 | {- |
226 | Overrides default database __"default"__
227 | -}
228 | setDatabase :: Text -> ConnectionArgs -> ConnectionArgs
229 | setDatabase new MkConnectionArgs{..} = MkConnectionArgs{db=new, ..}
230 |
231 | data Connection where MkConnection :: (MVar ConnectionState) -> Connection
232 |
233 | withConnection :: HasCallStack => Connection -> (ConnectionState -> IO a) -> IO a
234 | withConnection (MkConnection connStateMVar) f =
235 | mask $ \restore -> do
236 | connState <- takeMVar connStateMVar
237 | b <- onException
238 | (restore (f connState))
239 | (putMVar connStateMVar =<< reopenConnection connState)
240 | putMVar connStateMVar connState
241 | return b
242 |
243 | data ConnectionState = MkConnectionState
244 | { user :: ChString
245 | , hostname :: ChString
246 | , os_user :: ChString
247 | , buffer :: Buffer
248 | , revision :: ProtocolRevision
249 | , creds :: ConnectionArgs
250 | }
251 |
252 | writeToConnection :: Serializable packet => ConnectionState -> packet -> IO ()
253 | writeToConnection MkConnectionState{revision, buffer} packet =
254 | (writeSock buffer . toLazyByteString . serialize revision) packet
255 |
256 | writeToConnectionEncode :: ConnectionState -> (ProtocolRevision -> Builder) -> IO ()
257 | writeToConnectionEncode MkConnectionState{revision, buffer} serializer =
258 | (writeSock buffer . toLazyByteString) (serializer revision)
259 |
260 | openConnection :: HasCallStack => ConnectionArgs -> IO Connection
261 | openConnection creds = fmap MkConnection . newMVar =<< createConnectionState creds
262 |
263 | reopenConnection :: ConnectionState -> IO ConnectionState
264 | reopenConnection MkConnectionState{creds, buffer} = do
265 | flushBuffer buffer
266 | closeSock buffer
267 | createConnectionState creds
268 |
269 | createConnectionState :: ConnectionArgs -> IO ConnectionState
270 | createConnectionState creds@MkConnectionArgs {user, pass, db, host, mPort, initBuffer, isTLS} = do
271 | let port = fromMaybe (if isTLS then "9440" else "9000") mPort
272 | hostname <- maybe "" toChType <$> lookupEnv "HOSTNAME"
273 | os_user <- maybe "" toChType <$> lookupEnv "USER"
274 | AddrInfo{addrFamily, addrSocketType, addrProtocol, addrAddress}
275 | <- maybe (throwIO NoAdressResolved) pure . listToMaybe
276 | =<< getAddrInfo
277 | (Just defaultHints{addrFlags = [AI_ADDRCONFIG], addrSocketType = Stream})
278 | (Just host)
279 | (Just port)
280 | buffer <- maybe (throwIO EstablishTimeout) pure
281 | =<< timeout 3_000_000 (
282 | bracketOnError
283 | (socket addrFamily addrSocketType addrProtocol)
284 | (\sock ->
285 | catch @SomeException
286 | (finally (shutdown sock ShutdownBoth) (close sock))
287 | (const $ pure ())
288 | )
289 | (\sock -> initBuffer host addrAddress sock)
290 | )
291 |
292 | (writeSock buffer . toLazyByteString . serialize latestSupportedRevision)
293 | (mkHelloPacket db user pass)
294 | serverPacketType <- rawBufferizedRead buffer (deserialize latestSupportedRevision)
295 | case serverPacketType of
296 | HelloResponse MkHelloResponse{server_revision} -> do
297 | let revision = min server_revision latestSupportedRevision
298 | conn = MkConnectionState{user = toChType user, ..}
299 | writeToConnection conn MkAddendum{quota_key = MkSinceRevision ""}
300 | pure conn
301 | Exception exception -> throwIO (UserError $ DatabaseException exception)
302 | otherPacket -> throwIO (InternalError $ UnexpectedPacketType $ serverPacketToNum otherPacket)
303 |
304 |
305 | {- |
306 | Might be used for any command without data responses
307 |
308 | For example: CREATE, TRUNCATE, KILL, SET, GRANT
309 |
310 | __Throws exception if any data was returned__
311 | -}
312 | command :: HasCallStack => Connection -> ChString -> IO ()
313 | command conn query = do
314 | withConnection conn $ \connState -> do
315 | writeToConnection connState (mkQueryPacket connState query)
316 | writeToConnection connState (mkDataPacket "" 0 0)
317 | handleCreate connState
318 | where
319 | handleCreate :: ConnectionState -> IO ()
320 | handleCreate MkConnectionState{..} =
321 | rawBufferizedRead buffer (deserialize revision)
322 | >>= \packet -> case packet of
323 | EndOfStream -> pure ()
324 | Exception exception -> throwIO (UserError $ DatabaseException exception)
325 | otherPacket -> throwIO (InternalError $ UnexpectedPacketType $ serverPacketToNum otherPacket)
326 |
327 |
328 | -- * Ping
329 |
330 | ping :: HasCallStack => Connection -> IO ()
331 | ping conn = do
332 | withConnection conn $ \connState@MkConnectionState{revision, buffer} -> do
333 | writeToConnection connState Ping
334 | responsePacket <- rawBufferizedRead buffer (deserialize revision)
335 | case responsePacket of
336 | Pong -> pure ()
337 | Exception exception -> throwIO (UserError $ DatabaseException exception)
338 | otherPacket -> throwIO (InternalError $ UnexpectedPacketType $ serverPacketToNum otherPacket)
339 |
340 |
341 |
342 |
343 | -- * Client wrappers
344 |
345 | -- ** SELECT
346 |
347 | select ::
348 | forall columns output result
349 | .
350 | ClickHaskell columns output
351 | =>
352 | Connection -> ChString -> ([output] -> IO result) -> IO [result]
353 | select conn query f = do
354 | withConnection conn $ \connState -> do
355 | writeToConnection connState (mkQueryPacket connState query)
356 | writeToConnection connState (mkDataPacket "" 0 0)
357 | handleSelect @columns connState (\x -> id <$!> f x)
358 |
359 | selectFrom ::
360 | forall table output result
361 | .
362 | ClickHaskellTable table output
363 | =>
364 | Connection -> ([output] -> IO result) -> IO [result]
365 | selectFrom conn f = select @(GetColumns table) conn query f
366 | where
367 | query = toChType $
368 | "SELECT " <> columns @(GetColumns table) @output <>
369 | " FROM " <> tableName @table
370 |
371 | selectFromView ::
372 | forall view output result parameters
373 | .
374 | ClickHaskellView view output
375 | =>
376 | Connection -> (Parameters '[] -> Parameters parameters) -> ([output] -> IO result) -> IO [result]
377 | selectFromView conn interpreter f = select @(GetColumns view) conn query f
378 | where
379 | query = toChType $
380 | "SELECT " <> columns @(GetColumns view) @output <>
381 | " FROM " <> tableName @view <> viewParameters interpreter
382 |
383 | generateRandom ::
384 | forall columns output result
385 | .
386 | ClickHaskell columns output
387 | =>
388 | Connection -> (UInt64, UInt64, UInt64) -> UInt64 -> ([output] -> IO result) -> IO [result]
389 | generateRandom conn (randomSeed, maxStrLen, maxArrayLen) limit f = select @columns conn query f
390 | where
391 | query = toChType $
392 | "SELECT * FROM generateRandom(" <>
393 | "'" <> readingColumnsAndTypes @columns @output <> "' ," <>
394 | toQueryPart randomSeed <> "," <>
395 | toQueryPart maxStrLen <> "," <>
396 | toQueryPart maxArrayLen <>
397 | ")" <>
398 | " LIMIT " <> toQueryPart limit <> ";"
399 |
400 | -- | Internal
401 | handleSelect ::
402 | forall columns output result
403 | .
404 | ClickHaskell columns output
405 | =>
406 | ConnectionState -> ([output] -> IO result) -> IO [result]
407 | handleSelect MkConnectionState{..} f = loop []
408 | where
409 | loop acc = rawBufferizedRead buffer (deserialize revision) >>=
410 | \packet -> case packet of
411 | DataResponse MkDataPacket{columns_count = 0, rows_count = 0} -> loop acc
412 | DataResponse MkDataPacket{columns_count, rows_count} -> do
413 | let expected = columnsCount @columns @output
414 | when (columns_count /= expected) $
415 | (throw . UserError . UnmatchedColumnsCount)
416 | ("Expected " <> show expected <> " columns but got " <> show columns_count)
417 | result <- f =<< rawBufferizedRead buffer (deserializeColumns @columns True revision rows_count)
418 | loop (result : acc)
419 | Progress _ -> loop acc
420 | ProfileInfo _ -> loop acc
421 | EndOfStream -> pure acc
422 | Exception exception -> throwIO (UserError $ DatabaseException exception)
423 | otherPacket -> throwIO (InternalError $ UnexpectedPacketType $ serverPacketToNum otherPacket)
424 |
425 |
426 | -- ** INSERT
427 |
428 | insertInto ::
429 | forall table record
430 | .
431 | ClickHaskellTable table record
432 | =>
433 | Connection -> [record] -> IO ()
434 | insertInto conn columnsData = do
435 | withConnection conn $ \connState -> do
436 | writeToConnection connState (mkQueryPacket connState query)
437 | writeToConnection connState (mkDataPacket "" 0 0)
438 | handleInsertResult @(GetColumns table) connState columnsData
439 | where
440 | query = toChType $
441 | "INSERT INTO " <> tableName @table
442 | <> " (" <> columns @(GetColumns table) @record <> ") VALUES"
443 |
444 | -- | Internal
445 | handleInsertResult :: forall columns record . ClickHaskell columns record => ConnectionState -> [record] -> IO ()
446 | handleInsertResult conn@MkConnectionState{..} records = do
447 | firstPacket <- rawBufferizedRead buffer (deserialize revision)
448 | case firstPacket of
449 | TableColumns _ -> handleInsertResult @columns conn records
450 | DataResponse MkDataPacket{} -> do
451 | _emptyDataPacket <- rawBufferizedRead buffer (deserializeColumns @columns @record False revision 0)
452 | writeToConnection conn (mkDataPacket "" (columnsCount @columns @record) (fromIntegral $ Prelude.length records))
453 | writeToConnectionEncode conn (serializeRecords @columns records)
454 | writeToConnection conn (mkDataPacket "" 0 0)
455 | handleInsertResult @columns @record conn []
456 | EndOfStream -> pure ()
457 | Exception exception -> throwIO (UserError $ DatabaseException exception)
458 | otherPacket -> throwIO (InternalError $ UnexpectedPacketType $ serverPacketToNum otherPacket)
459 |
460 | -- ** Common parts
461 |
462 | type family GetTableName table :: Symbol
463 | type instance (GetTableName (Table name columns)) = name
464 | type instance (GetTableName (View name columns params)) = name
465 |
466 | type family GetColumns table :: [Type]
467 | type instance (GetColumns (Table name columns)) = columns
468 | type instance GetColumns (View name columns params) = columns
469 |
470 | tableName :: forall table . KnownSymbol (GetTableName table) => Builder
471 | tableName = (byteString . BS8.pack) (symbolVal $ Proxy @(GetTableName table))
472 |
473 | class IsTable table
474 |
475 | -- | Type wrapper for statements generation
476 | data Table (name :: Symbol) (columns :: [Type])
477 | instance IsTable (Table name columns) where
478 |
479 | type ClickHaskellTable table record =
480 | ( IsTable table
481 | , KnownSymbol (GetTableName table)
482 | , ClickHaskell (GetColumns table) record
483 | )
484 |
485 |
486 | class IsView view
487 |
488 | -- | Type wrapper for statements generation
489 | data View (name :: Symbol) (columns :: [Type]) (parameters :: [Type])
490 | instance IsView (View name columns parameters)
491 |
492 | type ClickHaskellView view record =
493 | ( IsView view
494 | , KnownSymbol (GetTableName view)
495 | , ClickHaskell (GetColumns view) record
496 | )
497 |
498 |
499 |
500 |
501 | -- * Bufferization
502 |
503 | data Buffer = MkBuffer
504 | { readSock :: IO BS.ByteString
505 | , writeSock :: BSL.ByteString -> IO ()
506 | , closeSock :: IO ()
507 | , buff :: IORef BS.ByteString
508 | }
509 |
510 | flushBuffer :: Buffer -> IO ()
511 | flushBuffer MkBuffer{buff} = atomicWriteIORef buff ""
512 |
513 | rawBufferizedRead :: Buffer -> Get packet -> IO packet
514 | rawBufferizedRead buffer@MkBuffer{..} parser = runBufferReader (runGetIncremental parser)
515 | where
516 | runBufferReader :: Decoder packet -> IO packet
517 | runBufferReader = \case
518 | (Partial decoder) -> readBuffer >>= runBufferReader . decoder . Just
519 | (Done leftover _consumed packet) -> packet <$ atomicModifyIORef buff (leftover,)
520 | (Fail _leftover _consumed msg) -> throwIO (InternalError $ DeserializationError msg)
521 |
522 | readBuffer :: IO BS.ByteString
523 | readBuffer =
524 | readIORef buff
525 | >>= (\currentBuffer ->
526 | case BS.length currentBuffer of
527 | 0 -> readSock
528 | _ -> flushBuffer buffer *> pure currentBuffer
529 | )
530 |
531 |
532 |
533 |
534 | -- * Errors handling
535 |
536 | {- |
537 | A wrapper for all client-related errors
538 | -}
539 | data ClientError where
540 | UserError :: HasCallStack => UserError -> ClientError
541 | InternalError :: HasCallStack => InternalError -> ClientError
542 | deriving anyclass (Exception)
543 |
544 | instance Show ClientError where
545 | show (UserError err) = "UserError " <> show err <> "\n" <> prettyCallStack callStack
546 | show (InternalError err) = "InternalError " <> show err <> "\n" <> prettyCallStack callStack
547 |
548 | {- |
549 | Errors occured on connection operations
550 | -}
551 | data ConnectionError
552 | = NoAdressResolved
553 | -- ^ Occurs when 'getAddrInfo' returns an empty result
554 | | EstablishTimeout
555 | -- ^ Occurs on 'socket' connection timeout
556 | deriving (Show, Exception)
557 |
558 | {- |
559 | Errors intended to be handled by developers
560 | -}
561 | data UserError
562 | = UnmatchedType String
563 | -- ^ Column type mismatch in data packet
564 | | UnmatchedColumn String
565 | -- ^ Column name mismatch in data packet
566 | | UnmatchedColumnsCount String
567 | -- ^ Occurs when actual columns count less or more than expected
568 | | DatabaseException ExceptionPacket
569 | -- ^ Database responded with an exception packet
570 | deriving (Show, Exception)
571 |
572 | {- |
573 | These exceptions might indicate internal bugs.
574 |
575 | If you encounter one, please report it.
576 | -}
577 | data InternalError
578 | = UnexpectedPacketType UVarInt
579 | | DeserializationError String
580 | deriving (Show, Exception)
581 |
582 |
583 |
584 |
585 | -- * Client packets
586 |
587 | data ClientPacket where
588 | Hello :: HelloPacket -> ClientPacket
589 | Query :: QueryPacket -> ClientPacket
590 | Data :: DataPacket -> ClientPacket
591 | Cancel :: ClientPacket
592 | Ping :: ClientPacket
593 | TablesStatusRequest :: ClientPacket
594 | KeepAlive :: ClientPacket
595 | Scalar :: ClientPacket
596 | IgnoredPartUUIDs :: ClientPacket
597 | ReadTaskResponse :: ClientPacket
598 | MergeTreeReadTaskResponse :: ClientPacket
599 | SSHChallengeRequest :: ClientPacket
600 | SSHChallengeResponse :: ClientPacket
601 | deriving (Generic)
602 |
603 | instance Serializable ClientPacket where
604 | serialize rev packet = case packet of
605 | (Hello p) -> serialize @UVarInt rev 0 <> serialize rev p
606 | (Query p) -> serialize @UVarInt rev 1 <> serialize rev p
607 | (Data p) -> serialize @UVarInt rev 2 <> serialize rev p
608 | (Cancel) -> serialize @UVarInt rev 3
609 | (Ping) -> serialize @UVarInt rev 4
610 | (TablesStatusRequest) -> serialize @UVarInt rev 5
611 | (KeepAlive) -> serialize @UVarInt rev 6
612 | (Scalar) -> serialize @UVarInt rev 7
613 | (IgnoredPartUUIDs) -> serialize @UVarInt rev 8
614 | (ReadTaskResponse) -> serialize @UVarInt rev 9
615 | (MergeTreeReadTaskResponse) -> serialize @UVarInt rev 10
616 | (SSHChallengeRequest) -> serialize @UVarInt rev 11
617 | (SSHChallengeResponse) -> serialize @UVarInt rev 12
618 |
619 | -- ** Hello
620 |
621 | mkHelloPacket :: Text -> Text -> Text -> ClientPacket
622 | mkHelloPacket db user pass = Hello
623 | MkHelloPacket
624 | { client_name = clientName
625 | , client_version_major = major
626 | , client_version_minor = minor
627 | , tcp_protocol_version = latestSupportedRevision
628 | , default_database = toChType db
629 | , user = toChType user
630 | , pass = toChType pass
631 | }
632 |
633 | data HelloPacket = MkHelloPacket
634 | { client_name :: ChString
635 | , client_version_major :: UVarInt
636 | , client_version_minor :: UVarInt
637 | , tcp_protocol_version :: ProtocolRevision
638 | , default_database :: ChString
639 | , user :: ChString
640 | , pass :: ChString
641 | }
642 | deriving (Generic, Serializable)
643 |
644 |
645 | data Addendum = MkAddendum{quota_key :: ChString `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_QUOTA_KEY}
646 | deriving (Generic, Serializable)
647 |
648 | -- ** Query
649 |
650 | mkQueryPacket :: ConnectionState -> ChString -> ClientPacket
651 | mkQueryPacket MkConnectionState{..} query = Query
652 | MkQueryPacket
653 | { query_id = ""
654 | , client_info = MkSinceRevision MkClientInfo
655 | { query_kind = InitialQuery
656 | , initial_user = user
657 | , initial_query_id = ""
658 | , initial_adress = "0.0.0.0:0"
659 | , initial_time = MkSinceRevision 0
660 | , interface_type = 1 -- [tcp - 1, http - 2]
661 | , os_user, hostname
662 | , client_name = clientName
663 | , client_version_major = major
664 | , client_version_minor = minor
665 | , client_revision = revision
666 | , quota_key = MkSinceRevision ""
667 | , distrubuted_depth = MkSinceRevision 0
668 | , client_version_patch = MkSinceRevision patch
669 | , open_telemetry = MkSinceRevision 0
670 | , collaborate_with_initiator = MkSinceRevision 0
671 | , count_participating_replicas = MkSinceRevision 0
672 | , number_of_current_replica = MkSinceRevision 0
673 | }
674 | , settings = MkDbSettings
675 | , interserver_secret = MkSinceRevision ""
676 | , query_stage = Complete
677 | , compression = 0
678 | , query
679 | , parameters = MkSinceRevision MkQueryParameters
680 | }
681 |
682 | data QueryPacket = MkQueryPacket
683 | { query_id :: ChString
684 | , client_info :: ClientInfo `SinceRevision` DBMS_MIN_REVISION_WITH_CLIENT_INFO
685 | , settings :: DbSettings
686 | , interserver_secret :: ChString `SinceRevision` DBMS_MIN_REVISION_WITH_INTERSERVER_SECRET
687 | , query_stage :: QueryStage
688 | , compression :: UVarInt
689 | , query :: ChString
690 | , parameters :: QueryParameters `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_PARAMETERS
691 | }
692 | deriving (Generic, Serializable)
693 |
694 | data DbSettings = MkDbSettings
695 | instance Serializable DbSettings where serialize rev _ = serialize @ChString rev ""
696 |
697 | data QueryParameters = MkQueryParameters
698 | instance Serializable QueryParameters where serialize rev _ = serialize @ChString rev ""
699 |
700 | data QueryStage
701 | = FetchColumns | WithMergeableState | Complete
702 | | WithMergeableStateAfterAggregation
703 | | WithMergeableStateAfterAggregationAndLimit
704 | deriving (Enum)
705 |
706 | instance Serializable QueryStage where
707 | serialize rev = serialize @UVarInt rev . fromIntegral . fromEnum
708 |
709 |
710 | data Flags = IMPORTANT | CUSTOM | OBSOLETE
711 | _flagCode :: Flags -> UInt64
712 | _flagCode IMPORTANT = 0x01
713 | _flagCode CUSTOM = 0x02
714 | _flagCode OBSOLETE = 0x04
715 |
716 | data ClientInfo = MkClientInfo
717 | { query_kind :: QueryKind
718 | , initial_user :: ChString
719 | , initial_query_id :: ChString
720 | , initial_adress :: ChString
721 | , initial_time :: Int64 `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_INITIAL_QUERY_START_TIME
722 | , interface_type :: UInt8
723 | , os_user :: ChString
724 | , hostname :: ChString
725 | , client_name :: ChString
726 | , client_version_major :: UVarInt
727 | , client_version_minor :: UVarInt
728 | , client_revision :: ProtocolRevision
729 | , quota_key :: ChString `SinceRevision` DBMS_MIN_REVISION_WITH_QUOTA_KEY_IN_CLIENT_INFO
730 | , distrubuted_depth :: UVarInt `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_DISTRIBUTED_DEPTH
731 | , client_version_patch :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_VERSION_PATCH
732 | , open_telemetry :: UInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_OPENTELEMETRY
733 | , collaborate_with_initiator :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_PARALLEL_REPLICAS
734 | , count_participating_replicas :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_PARALLEL_REPLICAS
735 | , number_of_current_replica :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_PARALLEL_REPLICAS
736 | }
737 | deriving (Generic, Serializable)
738 |
739 | data QueryKind = NoQuery | InitialQuery | SecondaryQuery
740 | instance Serializable QueryKind where
741 | serialize rev = serialize @UInt8 rev . (\case NoQuery -> 1; InitialQuery -> 2; SecondaryQuery -> 3)
742 |
743 | -- ** Data
744 |
745 | mkDataPacket :: ChString -> UVarInt -> UVarInt -> ClientPacket
746 | mkDataPacket table_name columns_count rows_count = Data
747 | MkDataPacket
748 | { table_name
749 | , block_info = MkBlockInfo
750 | { field_num1 = 1, is_overflows = 0
751 | , field_num2 = 2, bucket_num = -1
752 | , eof = 0
753 | }
754 | , columns_count
755 | , rows_count
756 | }
757 |
758 | data DataPacket = MkDataPacket
759 | { table_name :: ChString
760 | , block_info :: BlockInfo
761 | , columns_count :: UVarInt
762 | , rows_count :: UVarInt
763 | }
764 | deriving (Generic, Serializable, Deserializable)
765 |
766 | data BlockInfo = MkBlockInfo
767 | { field_num1 :: UVarInt, is_overflows :: UInt8
768 | , field_num2 :: UVarInt, bucket_num :: Int32
769 | , eof :: UVarInt
770 | }
771 | deriving (Generic, Serializable, Deserializable)
772 |
773 |
774 |
775 |
776 | -- * Server packets
777 |
778 | data ServerPacket where
779 | HelloResponse :: HelloResponse -> ServerPacket
780 | DataResponse :: DataPacket -> ServerPacket
781 | Exception :: ExceptionPacket -> ServerPacket
782 | Progress :: ProgressPacket -> ServerPacket
783 | Pong :: ServerPacket
784 | EndOfStream :: ServerPacket
785 | ProfileInfo :: ProfileInfo -> ServerPacket
786 | Totals :: ServerPacket
787 | Extremes :: ServerPacket
788 | TablesStatusResponse :: ServerPacket
789 | Log :: ServerPacket
790 | TableColumns :: TableColumns -> ServerPacket
791 | UUIDs :: ServerPacket
792 | ReadTaskRequest :: ServerPacket
793 | ProfileEvents :: ServerPacket
794 | UnknownPacket :: UVarInt -> ServerPacket
795 |
796 | instance Deserializable ServerPacket where
797 | deserialize rev = do
798 | packetNum <- deserialize @UVarInt rev
799 | case packetNum of
800 | 0 -> HelloResponse <$> deserialize rev
801 | 1 -> DataResponse <$> deserialize rev
802 | 2 -> Exception <$> deserialize rev
803 | 3 -> Progress <$> deserialize rev
804 | 4 -> pure Pong
805 | 5 -> pure EndOfStream
806 | 6 -> ProfileInfo <$> deserialize rev
807 | 7 -> pure Totals
808 | 8 -> pure Extremes
809 | 9 -> pure TablesStatusResponse
810 | 10 -> pure Log
811 | 11 -> TableColumns <$> deserialize rev
812 | 12 -> pure UUIDs
813 | 13 -> pure ReadTaskRequest
814 | 14 -> pure ProfileEvents
815 | _ -> pure $ UnknownPacket packetNum
816 |
817 | serverPacketToNum :: ServerPacket -> UVarInt
818 | serverPacketToNum = \case
819 | (HelloResponse _) -> 0; (DataResponse _) -> 1
820 | (Exception _) -> 2; (Progress _) -> 3;
821 | (Pong) -> 4; (EndOfStream) -> 5
822 | (ProfileInfo _) -> 6; (Totals) -> 7
823 | (Extremes) -> 8; (TablesStatusResponse) -> 9
824 | (Log) -> 10; (TableColumns _) -> 11;
825 | (UUIDs) -> 12; (ReadTaskRequest) -> 13
826 | (ProfileEvents) -> 14; (UnknownPacket num) -> num
827 |
828 |
829 | {-
830 | https://github.com/ClickHouse/ClickHouse/blob/eb4a74d7412a1fcf52727cd8b00b365d6b9ed86c/src/Client/Connection.cpp#L520
831 | -}
832 | data HelloResponse = MkHelloResponse
833 | { server_name :: ChString
834 | , server_version_major :: UVarInt
835 | , server_version_minor :: UVarInt
836 | , server_revision :: ProtocolRevision
837 | , server_parallel_replicas_proto :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_VERSIONED_PARALLEL_REPLICAS_PROTOCOL
838 | , server_timezone :: ChString `SinceRevision` DBMS_MIN_REVISION_WITH_SERVER_TIMEZONE
839 | , server_display_name :: ChString `SinceRevision` DBMS_MIN_REVISION_WITH_SERVER_DISPLAY_NAME
840 | , server_version_patch :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_VERSION_PATCH
841 | , proto_send_chunked_srv :: ChString `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_CHUNKED_PACKETS
842 | , proto_recv_chunked_srv :: ChString `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_CHUNKED_PACKETS
843 | , password_complexity_rules :: [PasswordComplexityRules] `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_PASSWORD_COMPLEXITY_RULES
844 | , read_nonce :: UInt64 `SinceRevision` DBMS_MIN_REVISION_WITH_INTERSERVER_SECRET_V2
845 | }
846 | deriving (Generic, Deserializable)
847 |
848 | data PasswordComplexityRules = MkPasswordComplexityRules
849 | { original_pattern :: ChString
850 | , exception_message :: ChString
851 | }
852 | deriving (Generic, Deserializable)
853 |
854 | instance Deserializable [PasswordComplexityRules] where
855 | deserialize rev = do
856 | len <- deserialize @UVarInt rev
857 | replicateM (fromIntegral len) (deserialize @PasswordComplexityRules rev)
858 |
859 | data ExceptionPacket = MkExceptionPacket
860 | { code :: Int32
861 | , name :: ChString
862 | , message :: ChString
863 | , stack_trace :: ChString
864 | , nested :: UInt8
865 | }
866 | deriving (Generic, Show, Deserializable)
867 |
868 | data ProgressPacket = MkProgressPacket
869 | { rows :: UVarInt
870 | , bytes :: UVarInt
871 | , total_rows :: UVarInt
872 | , total_bytes :: UVarInt `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_TOTAL_BYTES_IN_PROGRESS
873 | , wrote_rows :: UVarInt `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_TOTAL_BYTES_IN_PROGRESS
874 | , wrote_bytes :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_CLIENT_WRITE_INFO
875 | , elapsed_ns :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_CLIENT_WRITE_INFO
876 | }
877 | deriving (Generic, Deserializable)
878 |
879 | data ProfileInfo = MkProfileInfo
880 | { rows :: UVarInt
881 | , blocks :: UVarInt
882 | , bytes :: UVarInt
883 | , applied_limit :: UInt8
884 | , rows_before_limit :: UVarInt
885 | , calculated_rows_before_limit :: UInt8
886 | , applied_aggregation :: UInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_ROWS_BEFORE_AGGREGATION
887 | , rows_before_aggregation :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_ROWS_BEFORE_AGGREGATION
888 | }
889 | deriving (Generic, Deserializable)
890 |
891 | data TableColumns = MkTableColumns
892 | { table_name :: ChString
893 | , table_columns :: ChString
894 | }
895 | deriving (Generic, Deserializable)
896 |
897 |
898 |
899 |
900 |
901 |
902 |
903 |
904 | -- * Deserialization
905 |
906 | -- ** Generic API
907 |
908 | type GenericClickHaskell record hasColumns =
909 | ( Generic record
910 | , GClickHaskell hasColumns (Rep record)
911 | )
912 |
913 | class ClickHaskell columns record
914 | where
915 | default deserializeColumns :: GenericClickHaskell record columns => Bool -> ProtocolRevision -> UVarInt -> Get [record]
916 | deserializeColumns :: Bool -> ProtocolRevision -> UVarInt -> Get [record]
917 | deserializeColumns isCheckRequired rev size = do
918 | list <- gFromColumns @columns isCheckRequired rev size
919 | pure $ do
920 | element <- list
921 | case to element of res -> pure $! res
922 |
923 | default columns :: GenericClickHaskell record columns => Builder
924 | columns :: Builder
925 | columns = buildCols (gReadingColumns @columns @(Rep record))
926 | where
927 | buildCols [] = mempty
928 | buildCols ((col, _):[]) = col
929 | buildCols ((col, _):rest) = col <> ", " <> buildCols rest
930 |
931 | default readingColumnsAndTypes :: GenericClickHaskell record columns => Builder
932 | readingColumnsAndTypes :: Builder
933 | readingColumnsAndTypes = buildColsTypes (gReadingColumns @columns @(Rep record))
934 | where
935 | buildColsTypes [] = mempty
936 | buildColsTypes ((col, typ):[]) = col <> " " <> typ
937 | buildColsTypes ((col, typ):rest) = col <> " " <> typ <> ", " <> buildColsTypes rest
938 |
939 | default serializeRecords :: GenericClickHaskell record columns => [record] -> ProtocolRevision -> Builder
940 | serializeRecords :: [record] -> ProtocolRevision -> Builder
941 | serializeRecords records rev = gSerializeRecords @columns rev (map from records)
942 |
943 | default columnsCount :: GenericClickHaskell record columns => UVarInt
944 | columnsCount :: UVarInt
945 | columnsCount = gColumnsCount @columns @(Rep record)
946 |
947 | class GClickHaskell (columns :: [Type]) f
948 | where
949 | gFromColumns :: Bool -> ProtocolRevision -> UVarInt -> Get [f p]
950 | gReadingColumns :: [(Builder, Builder)]
951 | gSerializeRecords :: ProtocolRevision -> [f p] -> Builder
952 | gColumnsCount :: UVarInt
953 |
954 | instance
955 | GClickHaskell columns f
956 | =>
957 | GClickHaskell columns (D1 c (C1 c2 f))
958 | where
959 | {-# INLINE gFromColumns #-}
960 | gFromColumns isCheckRequired rev size = map (M1 . M1) <$> gFromColumns @columns isCheckRequired rev size
961 | gReadingColumns = gReadingColumns @columns @f
962 | {-# INLINE gSerializeRecords #-}
963 | gSerializeRecords rev = gSerializeRecords @columns rev . map (unM1 . unM1)
964 | gColumnsCount = gColumnsCount @columns @f
965 |
966 | instance
967 | (GClickHaskell columns left, GClickHaskell columns right)
968 | =>
969 | GClickHaskell columns (left :*: right)
970 | where
971 | {-# INLINE gFromColumns #-}
972 | gFromColumns isCheckRequired rev size =
973 | liftA2 (zipWith (:*:))
974 | (gFromColumns @columns @left isCheckRequired rev size)
975 | (gFromColumns @columns @right isCheckRequired rev size)
976 | gReadingColumns = gReadingColumns @columns @left ++ gReadingColumns @columns @right
977 | {-# INLINE gSerializeRecords #-}
978 | gSerializeRecords rev xs =
979 | (\(ls,rs) -> gSerializeRecords @columns rev ls <> gSerializeRecords @columns rev rs)
980 | (foldr (\(l :*: r) (accL, accR) -> (l:accL, r:accR)) ([], []) xs)
981 | gColumnsCount = gColumnsCount @columns @left + gColumnsCount @columns @right
982 |
983 |
984 | instance
985 | ( KnownColumn (Column name chType)
986 | , SerializableColumn (Column name chType)
987 | , FromChType chType inputType
988 | , ToChType chType inputType
989 | , Column name chType ~ TakeColumn name columns
990 | ) => GClickHaskell columns ((S1 (MetaSel (Just name) a b f)) (Rec0 inputType))
991 | where
992 | {-# INLINE gFromColumns #-}
993 | gFromColumns isCheckRequired rev size =
994 | map (M1 . K1 . fromChType @chType) . columnValues
995 | <$> deserializeColumn @(Column name chType) rev isCheckRequired size
996 | gReadingColumns = (renderColumnName @(Column name chType), renderColumnType @(Column name chType)) : []
997 | {-# INLINE gSerializeRecords #-}
998 | gSerializeRecords rev = serializeColumn rev . mkColumn @(Column name chType) . map (toChType . unK1 . unM1)
999 | gColumnsCount = 1
1000 |
1001 |
1002 | type family
1003 | TakeColumn (name :: Symbol) (columns :: [Type]) :: Type
1004 | where
1005 | TakeColumn name columns = GoTakeColumn name columns '[]
1006 |
1007 | type family
1008 | GoTakeColumn name (columns :: [Type]) (acc :: [Type]) :: Type
1009 | where
1010 | GoTakeColumn name (Column name chType ': columns) acc = Column name chType
1011 | GoTakeColumn name (Column name1 chType ': columns) acc = (GoTakeColumn name columns (Column name1 chType ': acc))
1012 | GoTakeColumn name '[] acc = TypeError
1013 | ( 'Text "There is no column \"" :<>: 'Text name :<>: 'Text "\" in table"
1014 | :$$: 'Text "You can't use this field"
1015 | )
1016 |
1017 |
1018 | -- ** Column deserialization
1019 |
1020 | {-# SPECIALIZE replicateM :: Int -> Get chType -> Get [chType] #-}
1021 |
1022 | class SerializableColumn column where
1023 | deserializeColumn :: ProtocolRevision -> Bool -> UVarInt -> Get column
1024 | serializeColumn :: ProtocolRevision -> column -> Builder
1025 |
1026 | handleColumnHeader :: forall column . KnownColumn column => ProtocolRevision -> Bool -> Get ()
1027 | handleColumnHeader rev isCheckRequired = do
1028 | let expectedColumnName = toChType (renderColumnName @column)
1029 | resultColumnName <- deserialize @ChString rev
1030 | when (isCheckRequired && resultColumnName /= expectedColumnName)
1031 | . throw . UserError . UnmatchedColumn
1032 | $ "Got column \"" <> show resultColumnName <> "\" but expected \"" <> show expectedColumnName <> "\""
1033 |
1034 | let expectedType = toChType (renderColumnType @column)
1035 | resultType <- deserialize @ChString rev
1036 | when (isCheckRequired && resultType /= expectedType)
1037 | . throw . UserError . UnmatchedType
1038 | $ "Column " <> show resultColumnName <> " has type " <> show resultType <> ". But expected type is " <> show expectedType
1039 |
1040 | _isCustom <- deserialize @(UInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION) rev
1041 | pure ()
1042 |
1043 | instance
1044 | ( KnownColumn (Column name chType)
1045 | , Deserializable chType
1046 | , Serializable chType
1047 | , IsChType chType
1048 | ) =>
1049 | SerializableColumn (Column name chType) where
1050 | {-# INLINE deserializeColumn #-}
1051 | deserializeColumn rev isCheckRequired rows = do
1052 | handleColumnHeader @(Column name chType) rev isCheckRequired
1053 | mkColumn @(Column name chType)
1054 | <$> replicateM (fromIntegral rows) (deserialize @chType rev)
1055 |
1056 | {-# INLINE serializeColumn #-}
1057 | serializeColumn rev column
1058 | = serialize rev (toChType @ChString $ renderColumnName @(Column name chType))
1059 | <> serialize rev (toChType @ChString $ renderColumnType @(Column name chType))
1060 | -- serialization is not custom
1061 | <> afterRevision @DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION rev (serialize @UInt8 rev 0)
1062 | <> mconcat (Prelude.map (serialize @chType rev) (columnValues column))
1063 |
1064 | instance {-# OVERLAPPING #-}
1065 | ( KnownColumn (Column name (Nullable chType))
1066 | , Deserializable chType
1067 | , Serializable chType
1068 | , IsChType chType
1069 | ) =>
1070 | SerializableColumn (Column name (Nullable chType)) where
1071 | {-# INLINE deserializeColumn #-}
1072 | deserializeColumn rev isCheckRequired rows = do
1073 | handleColumnHeader @(Column name (Nullable chType)) rev isCheckRequired
1074 | nulls <- replicateM (fromIntegral rows) (deserialize @UInt8 rev)
1075 | mkColumn @(Column name (Nullable chType)) <$>
1076 | forM
1077 | nulls
1078 | (\case
1079 | 0 -> Just <$> deserialize @chType rev
1080 | _ -> (Nothing <$ deserialize @chType rev)
1081 | )
1082 |
1083 | {-# INLINE serializeColumn #-}
1084 | serializeColumn rev column
1085 | = serialize rev (toChType @ChString $ renderColumnName @(Column name (Nullable chType)))
1086 | <> serialize rev (toChType @ChString $ renderColumnType @(Column name (Nullable chType)))
1087 | -- serialization is not custom
1088 | <> afterRevision @DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION rev (serialize @UInt8 rev 0)
1089 | -- Nulls
1090 | <> mconcat (Prelude.map (serialize @UInt8 rev . maybe 1 (const 0)) (columnValues column))
1091 | -- Values
1092 | <> mconcat (Prelude.map (serialize @chType rev . maybe defaultValueOfTypeName id) (columnValues column))
1093 |
1094 | instance {-# OVERLAPPING #-}
1095 | ( KnownColumn (Column name (LowCardinality chType))
1096 | , Deserializable chType
1097 | , IsLowCardinalitySupported chType
1098 | , TypeError ('Text "LowCardinality deserialization still unsupported")
1099 | ) =>
1100 | SerializableColumn (Column name (LowCardinality chType)) where
1101 | {-# INLINE deserializeColumn #-}
1102 | deserializeColumn rev isCheckRequired rows = do
1103 | handleColumnHeader @(Column name (LowCardinality chType)) rev isCheckRequired
1104 | _serializationType <- (.&. 0xf) <$> deserialize @UInt64 rev
1105 | _index_size <- deserialize @Int64 rev
1106 | -- error $ "Trace | " <> show _serializationType <> " : " <> show _index_size
1107 | mkColumn @(Column name (LowCardinality chType))
1108 | <$> replicateM (fromIntegral rows) (toChType <$> deserialize @chType rev)
1109 |
1110 | {-# INLINE serializeColumn #-}
1111 | serializeColumn rev (LowCardinalityColumn column)
1112 | = serialize rev (toChType @ChString $ renderColumnName @(Column name (Nullable chType)))
1113 | <> serialize rev (toChType @ChString $ renderColumnType @(Column name (Nullable chType)))
1114 | -- serialization is not custom
1115 | <> afterRevision @DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION rev (serialize @UInt8 rev 0)
1116 | <> undefined column
1117 |
1118 | instance {-# OVERLAPPING #-}
1119 | ( KnownColumn (Column name (Array chType))
1120 | , Deserializable chType
1121 | , TypeError ('Text "Arrays deserialization still unsupported")
1122 | )
1123 | => SerializableColumn (Column name (Array chType)) where
1124 | {-# INLINE deserializeColumn #-}
1125 | deserializeColumn rev isCheckRequired _rows = do
1126 | handleColumnHeader @(Column name (Array chType)) rev isCheckRequired
1127 | (arraySize, _offsets) <- readOffsets rev
1128 | _types <- replicateM (fromIntegral arraySize) (deserialize @chType rev)
1129 | pure $ mkColumn @(Column name (Array chType)) []
1130 | where
1131 | readOffsets :: ProtocolRevision -> Get (UInt64, [UInt64])
1132 | readOffsets revivion = do
1133 | size <- deserialize @UInt64 rev
1134 | (size, ) <$> go size
1135 | where
1136 | go arraySize =
1137 | do
1138 | nextOffset <- deserialize @UInt64 revivion
1139 | if arraySize >= nextOffset
1140 | then pure [nextOffset]
1141 | else (nextOffset :) <$> go arraySize
1142 |
1143 | {-# INLINE serializeColumn #-}
1144 | serializeColumn _rev _column = undefined
1145 |
1146 | -- ** Generics
1147 |
1148 | class
1149 | Deserializable chType
1150 | where
1151 | {-# INLINE deserialize #-}
1152 | default deserialize :: (Generic chType, GDeserial (Rep chType)) => ProtocolRevision -> Get chType
1153 | deserialize :: ProtocolRevision -> Get chType
1154 | deserialize rev = to <$> gDeserialize rev
1155 |
1156 | class GDeserial f
1157 | where
1158 | gDeserialize :: ProtocolRevision -> Get (f p)
1159 |
1160 | instance GDeserial f => GDeserial (D1 c (C1 c2 f))
1161 | where
1162 | gDeserialize rev = M1 . M1 <$> gDeserialize rev
1163 | {-# INLINE gDeserialize #-}
1164 |
1165 | instance (GDeserial left, GDeserial right) => GDeserial (left :*: right) where
1166 | gDeserialize rev = liftA2 (:*:) (gDeserialize rev) (gDeserialize rev)
1167 | {-# INLINE gDeserialize #-}
1168 |
1169 | instance {-# OVERLAPPING #-}
1170 | GDeserial right => GDeserial (S1 metaSel (Rec0 ProtocolRevision) :*: right) where
1171 | gDeserialize rev = do
1172 | chosenRev <- min rev . coerce <$> deserialize @UVarInt rev
1173 | liftA2 (:*:) (pure . M1 . K1 $ chosenRev) (gDeserialize @right chosenRev)
1174 | {-# INLINE gDeserialize #-}
1175 |
1176 | instance
1177 | Deserializable chType
1178 | =>
1179 | GDeserial (S1 metaSel (Rec0 chType))
1180 | where
1181 | {-# INLINE gDeserialize #-}
1182 | gDeserialize rev = M1 . K1 <$> deserialize @chType rev
1183 |
1184 |
1185 | -- ** Database types
1186 |
1187 | instance Deserializable Int8 where deserialize _ = toChType <$> getInt8; {-# INLINE deserialize #-}
1188 | instance Deserializable Int16 where deserialize _ = toChType <$> getInt16le; {-# INLINE deserialize #-}
1189 | instance Deserializable Int32 where deserialize _ = toChType <$> getInt32le; {-# INLINE deserialize #-}
1190 | instance Deserializable Int64 where deserialize _ = toChType <$> getInt64le; {-# INLINE deserialize #-}
1191 | instance Deserializable Int128 where deserialize _ = toChType <$> liftA2 (flip Int128) getWord64le getWord64le; {-# INLINE deserialize #-}
1192 | instance Deserializable UInt8 where deserialize _ = toChType <$> getWord8; {-# INLINE deserialize #-}
1193 | instance Deserializable UInt16 where deserialize _ = toChType <$> getWord16le; {-# INLINE deserialize #-}
1194 | instance Deserializable UInt32 where deserialize _ = toChType <$> getWord32le; {-# INLINE deserialize #-}
1195 | instance Deserializable UInt64 where deserialize _ = toChType <$> getWord64le; {-# INLINE deserialize #-}
1196 | instance Deserializable UInt128 where deserialize _ = toChType <$> liftA2 (flip Word128) getWord64le getWord64le; {-# INLINE deserialize #-}
1197 | instance Deserializable UUID where deserialize _ = MkChUUID <$> liftA2 (flip Word128) getWord64le getWord64le; {-# INLINE deserialize #-}
1198 | instance Deserializable Date where deserialize _ = toChType <$> getWord16le; {-# INLINE deserialize #-}
1199 | instance Deserializable (DateTime tz) where deserialize _ = toChType <$> getWord32le; {-# INLINE deserialize #-}
1200 | instance Deserializable (DateTime64 precision tz) where deserialize _ = toChType <$> getWord64le; {-# INLINE deserialize #-}
1201 | instance Deserializable ChString where
1202 | {-# INLINE deserialize #-}
1203 | deserialize = fmap toChType . getByteString . fromIntegral <=< deserialize @UVarInt
1204 | instance Deserializable UVarInt where
1205 | {-# INLINE deserialize #-}
1206 | deserialize _ = go 0 (0 :: UVarInt)
1207 | where
1208 | go i o | i < 10 = do
1209 | byte <- getWord8
1210 | let o' = o .|. ((fromIntegral byte .&. 0x7f) `unsafeShiftL` (7 * i))
1211 | if byte .&. 0x80 == 0 then pure $! o' else go (i + 1) $! o'
1212 | go _ _ = fail "input exceeds varuint size"
1213 |
1214 | -- ** FromChType
1215 |
1216 | class FromChType chType outputType where fromChType :: chType -> outputType
1217 |
1218 | instance FromChType UUID (Word64, Word64) where fromChType (MkChUUID (Word128 w64hi w64lo)) = (w64hi, w64lo)
1219 | instance {-# OVERLAPPABLE #-} (IsChType chType, chType ~ inputType) => FromChType chType inputType where fromChType = id
1220 | instance FromChType (DateTime tz) Word32 where fromChType = coerce
1221 | instance FromChType (DateTime tz) UTCTime where fromChType (MkDateTime w32) = posixSecondsToUTCTime (fromIntegral w32)
1222 | instance FromChType (DateTime64 precision tz) Word64 where fromChType = coerce
1223 | instance
1224 | FromChType chType inputType
1225 | =>
1226 | FromChType (Nullable chType) (Nullable inputType)
1227 | where
1228 | fromChType = fmap (fromChType @chType)
1229 | instance FromChType chType (LowCardinality chType) where
1230 | fromChType = MkLowCardinality
1231 | instance FromChType Date Word16 where fromChType = coerce
1232 | instance
1233 | FromChType chType outputType
1234 | =>
1235 | FromChType (LowCardinality chType) outputType
1236 | where
1237 | fromChType (MkLowCardinality value) = fromChType value
1238 | instance FromChType ChString BS.ByteString where fromChType (MkChString string) = string
1239 | instance FromChType ChString Builder where fromChType (MkChString string) = byteString string
1240 | instance
1241 | ( TypeError
1242 | ( 'Text "ChString to Text using FromChType convertion could cause exception"
1243 | ':$$: 'Text "Decode ByteString manually if you are sure it's always can be decoded or replace it with ByteString"
1244 | )
1245 | ) =>
1246 | FromChType ChString Text
1247 | where
1248 | fromChType = error "Unreachable"
1249 | instance FromChType chType inputType => FromChType (Array chType) [inputType]
1250 | where
1251 | fromChType (MkChArray values) = map fromChType values
1252 |
1253 |
1254 |
1255 |
1256 |
1257 |
1258 |
1259 |
1260 | -- * Column
1261 |
1262 | {- |
1263 | Column declaration
1264 |
1265 | For example:
1266 |
1267 | @
1268 | type MyColumn = Column "myColumn" ChString
1269 | @
1270 | -}
1271 | data Column (name :: Symbol) (chType :: Type) where
1272 | UInt8Column :: [UInt8] -> Column name UInt8; Int8Column :: [Int8] -> Column name Int8
1273 | UInt16Column :: [UInt16] -> Column name UInt16; Int16Column :: [Int16] -> Column name Int16
1274 | UInt32Column :: [UInt32] -> Column name UInt32; Int32Column :: [Int32] -> Column name Int32
1275 | UInt64Column :: [UInt64] -> Column name UInt64; Int64Column :: [Int64] -> Column name Int64
1276 | UInt128Column :: [UInt128] -> Column name UInt128; Int128Column :: [Int128] -> Column name Int128
1277 | DateTimeColumn :: [DateTime tz] -> Column name (DateTime tz)
1278 | DateTime64Column :: [DateTime64 precision tz] -> Column name (DateTime64 precision tz)
1279 | DateColumn :: [Date] -> Column name Date
1280 | UUIDColumn :: [UUID] -> Column name UUID
1281 | StringColumn :: [ChString] -> Column name ChString
1282 | ArrayColumn :: [Array chType] -> Column name (Array chType)
1283 | NullableColumn :: [Nullable chType] -> Column name (Nullable chType)
1284 | LowCardinalityColumn :: IsLowCardinalitySupported chType => [chType] -> Column name (LowCardinality chType)
1285 |
1286 | type family GetColumnName column :: Symbol where GetColumnName (Column name columnType) = name
1287 | type family GetColumnType column :: Type where GetColumnType (Column name columnType) = columnType
1288 |
1289 | {-# INLINE [0] columnValues #-}
1290 | columnValues :: Column name chType -> [chType]
1291 | columnValues column = case column of
1292 | (UInt8Column values) -> values; (UInt16Column values) -> values
1293 | (UInt32Column values) -> values; (UInt64Column values) -> values
1294 | (UInt128Column values) -> values; (Int8Column values) -> values
1295 | (Int16Column values) -> values; (Int32Column values) -> values
1296 | (Int64Column values) -> values; (Int128Column values) -> values
1297 | (DateColumn values) -> values; (DateTimeColumn values) -> values; (DateTime64Column values) -> values;
1298 | (UUIDColumn values) -> values; (StringColumn values) -> values
1299 | (ArrayColumn values) -> values; (NullableColumn values) -> values
1300 | (LowCardinalityColumn values) -> map fromChType values
1301 |
1302 | class
1303 | ( IsChType (GetColumnType column)
1304 | , KnownSymbol (GetColumnName column)
1305 | ) =>
1306 | KnownColumn column where
1307 | renderColumnName :: Builder
1308 | renderColumnName = (stringUtf8 . symbolVal @(GetColumnName column)) Proxy
1309 |
1310 | renderColumnType :: Builder
1311 | renderColumnType = byteString . BS8.pack $ chTypeName @(GetColumnType column)
1312 |
1313 | mkColumn :: [GetColumnType column] -> Column (GetColumnName column) (GetColumnType column)
1314 |
1315 | instance KnownSymbol name => KnownColumn (Column name UInt8) where mkColumn = UInt8Column
1316 | instance KnownSymbol name => KnownColumn (Column name UInt16) where mkColumn = UInt16Column
1317 | instance KnownSymbol name => KnownColumn (Column name UInt32) where mkColumn = UInt32Column
1318 | instance KnownSymbol name => KnownColumn (Column name UInt64) where mkColumn = UInt64Column
1319 | instance KnownSymbol name => KnownColumn (Column name UInt128) where mkColumn = UInt128Column
1320 | instance KnownSymbol name => KnownColumn (Column name Int8) where mkColumn = Int8Column
1321 | instance KnownSymbol name => KnownColumn (Column name Int16) where mkColumn = Int16Column
1322 | instance KnownSymbol name => KnownColumn (Column name Int32) where mkColumn = Int32Column
1323 | instance KnownSymbol name => KnownColumn (Column name Int64) where mkColumn = Int64Column
1324 | instance KnownSymbol name => KnownColumn (Column name Int128) where mkColumn = Int128Column
1325 | instance KnownSymbol name => KnownColumn (Column name Date) where mkColumn = DateColumn
1326 | instance
1327 | ( KnownSymbol name
1328 | , IsChType (DateTime tz)
1329 | ) =>
1330 | KnownColumn (Column name (DateTime tz)) where mkColumn = DateTimeColumn
1331 | instance
1332 | ( KnownSymbol name
1333 | , IsChType (DateTime64 precision tz)
1334 | ) =>
1335 | KnownColumn (Column name (DateTime64 precision tz)) where mkColumn = DateTime64Column
1336 | instance KnownSymbol name => KnownColumn (Column name UUID) where mkColumn = UUIDColumn
1337 | instance
1338 | ( KnownSymbol name
1339 | , IsChType chType
1340 | , IsChType (Nullable chType)
1341 | ) =>
1342 | KnownColumn (Column name (Nullable chType)) where mkColumn = NullableColumn
1343 | instance KnownSymbol name => KnownColumn (Column name ChString) where mkColumn = StringColumn
1344 | instance
1345 | ( KnownSymbol name
1346 | , IsChType (LowCardinality chType)
1347 | , IsLowCardinalitySupported chType
1348 | ) =>
1349 | KnownColumn (Column name (LowCardinality chType)) where mkColumn = LowCardinalityColumn . map fromChType
1350 | instance KnownSymbol name => KnownColumn (Column name (Array ChString)) where mkColumn = ArrayColumn
1351 |
1352 |
1353 |
1354 |
1355 |
1356 |
1357 |
1358 |
1359 | -- * Parameters
1360 |
1361 | type family KnownParameter param
1362 | where
1363 | KnownParameter (Parameter name parType) = (KnownSymbol name, IsChType parType, ToQueryPart parType)
1364 |
1365 | data Parameter (name :: Symbol) (chType :: Type) = MkParamater chType
1366 |
1367 | data Parameters parameters where
1368 | NoParameters :: Parameters '[]
1369 | AddParameter
1370 | :: KnownParameter (Parameter name chType)
1371 | => Parameter name chType
1372 | -> Parameters parameters
1373 | -> Parameters (Parameter name chType ': parameters)
1374 |
1375 | {- |
1376 | >>> viewParameters (parameter @"a3" @ChString ("a3Val" :: String) . parameter @"a2" @ChString ("a2Val" :: String))
1377 | "(a3='a3Val', a2='a2Val')"
1378 | -}
1379 | viewParameters :: (Parameters '[] -> Parameters passedParameters) -> Builder
1380 | viewParameters interpreter = "(" <> renderParameters (interpreter NoParameters) <> ")"
1381 |
1382 | renderParameters :: Parameters params -> Builder
1383 | renderParameters NoParameters = ""
1384 | renderParameters (AddParameter param NoParameters) = renderParameter param
1385 | renderParameters (AddParameter param moreParams) = renderParameter param <> ", " <> renderParameters moreParams
1386 |
1387 |
1388 | parameter
1389 | :: forall name chType parameters userType
1390 | . (ToChType chType userType, KnownParameter (Parameter name chType))
1391 | => userType -> Parameters parameters -> Parameters (Parameter name chType ': parameters)
1392 | parameter val = AddParameter (MkParamater $ toChType val)
1393 |
1394 | renderParameter :: forall name chType . KnownParameter (Parameter name chType) => Parameter name chType -> Builder
1395 | renderParameter (MkParamater chType) = (byteString . BS8.pack . symbolVal @name) Proxy <> "=" <> toQueryPart chType
1396 |
1397 |
1398 | class ToQueryPart chType where toQueryPart :: chType -> Builder
1399 | instance ToQueryPart Int8 where toQueryPart = byteString . BS8.pack . show
1400 | instance ToQueryPart Int16 where toQueryPart = byteString . BS8.pack . show
1401 | instance ToQueryPart Int32 where toQueryPart = byteString . BS8.pack . show
1402 | instance ToQueryPart Int64 where toQueryPart = byteString . BS8.pack . show
1403 | instance ToQueryPart Int128 where toQueryPart = byteString . BS8.pack . show
1404 | instance ToQueryPart UInt8 where toQueryPart = byteString . BS8.pack . show
1405 | instance ToQueryPart UInt16 where toQueryPart = byteString . BS8.pack . show
1406 | instance ToQueryPart UInt32 where toQueryPart = byteString . BS8.pack . show
1407 | instance ToQueryPart UInt64 where toQueryPart = byteString . BS8.pack . show
1408 | instance ToQueryPart UInt128 where toQueryPart = byteString . BS8.pack . show
1409 | instance ToQueryPart chType => ToQueryPart (Nullable chType)
1410 | where
1411 | toQueryPart = maybe "null" toQueryPart
1412 | instance ToQueryPart chType => ToQueryPart (LowCardinality chType)
1413 | where
1414 | toQueryPart (MkLowCardinality chType) = toQueryPart chType
1415 | instance ToQueryPart UUID where
1416 | toQueryPart (MkChUUID (Word128 hi lo)) = mconcat
1417 | ["'", p 3 hi, p 2 hi, "-", p 1 hi, "-", p 0 hi, "-", p 3 lo, "-", p 2 lo, p 1 lo, p 0 lo, "'"]
1418 | where
1419 | p :: Int -> Word64 -> Builder
1420 | p shiftN word = word16HexFixed $ fromIntegral (word `unsafeShiftR` (shiftN*16))
1421 | instance ToQueryPart ChString where
1422 | toQueryPart (MkChString string) = "'" <> escapeQuery string <> "'"
1423 | where
1424 | escapeQuery :: BS.ByteString -> Builder
1425 | escapeQuery = byteString . BS8.concatMap (\case '\'' -> "\\\'"; '\\' -> "\\\\"; sym -> singleton sym;)
1426 |
1427 | -- ToDo: Need to be fixed
1428 | -- instance ToQueryPart (DateTime64 precision tz)
1429 | -- where
1430 | -- toQueryPart chDateTime =
1431 | -- let time = BS8.pack . show . fromChType @_ @Word64 $ chDateTime
1432 | -- in byteString (BS8.replicate (12 - BS8.length time) '0' <> time)
1433 |
1434 | instance ToQueryPart (DateTime tz)
1435 | where
1436 | toQueryPart chDateTime = let time = BS8.pack . show . fromChType @(DateTime tz) @Word32 $ chDateTime
1437 | in byteString (BS8.replicate (10 - BS8.length time) '0' <> time)
1438 | instance (IsChType chType, ToQueryPart chType) => ToQueryPart (Array chType)
1439 | where
1440 | toQueryPart
1441 | = (\x -> "[" <> x <> "]")
1442 | . (maybe "" (uncurry (foldr (\a b -> a <> "," <> b))) . uncons
1443 | . map (toQueryPart @chType)) . fromChType @(Array chType) @[chType]
1444 |
1445 |
1446 |
1447 |
1448 |
1449 |
1450 |
1451 |
1452 | -- * Serialization
1453 |
1454 | -- *** Generic API
1455 |
1456 | class Serializable chType
1457 | where
1458 | default serialize :: (Generic chType, GSerial (Rep chType)) => ProtocolRevision -> chType -> Builder
1459 | serialize :: ProtocolRevision -> chType -> Builder
1460 | serialize rev = gSerialize rev . from
1461 |
1462 | instance Serializable UVarInt where
1463 | serialize _ = go
1464 | where
1465 | go i
1466 | | i < 0x80 = word8 (fromIntegral i)
1467 | | otherwise = word8 (setBit (fromIntegral i) 7) <> go (i `unsafeShiftR` 7)
1468 | instance Serializable ChString where
1469 | serialize rev str = (serialize @UVarInt rev . fromIntegral . BS.length . fromChType) str <> fromChType str
1470 | instance Serializable UUID where serialize _ = (\(hi, lo) -> word64LE lo <> word64LE hi) . fromChType
1471 | instance Serializable Int8 where serialize _ = int8 . fromChType
1472 | instance Serializable Int16 where serialize _ = int16LE . fromChType
1473 | instance Serializable Int32 where serialize _ = int32LE . fromChType
1474 | instance Serializable Int64 where serialize _ = int64LE . fromChType
1475 | instance Serializable Int128 where serialize _ = (\(Int128 hi lo) -> word64LE lo <> word64LE hi) . fromChType
1476 | instance Serializable UInt8 where serialize _ = word8 . fromChType
1477 | instance Serializable UInt16 where serialize _ = word16LE . fromChType
1478 | instance Serializable UInt32 where serialize _ = word32LE . fromChType
1479 | instance Serializable UInt64 where serialize _ = word64LE . fromChType
1480 | instance Serializable UInt128 where serialize _ = (\(Word128 hi lo) -> word64LE lo <> word64LE hi) . fromChType
1481 | instance Serializable (DateTime tz) where serialize _ = word32LE . fromChType
1482 | instance Serializable (DateTime64 precision tz) where serialize _ = word64LE . fromChType
1483 | instance Serializable Date where serialize _ = word16LE . fromChType
1484 |
1485 |
1486 | -- ** Generics
1487 |
1488 | class GSerial f where
1489 | gSerialize :: ProtocolRevision -> f p -> Builder
1490 |
1491 | instance GSerial f => GSerial (D1 c (C1 c2 f)) where
1492 | gSerialize rev (M1 (M1 re)) = gSerialize rev re
1493 | {-# INLINE gSerialize #-}
1494 |
1495 | instance (GSerial left1, GSerial right) => GSerial (left1 :*: right) where
1496 | gSerialize rev (l :*: r) = gSerialize rev l <> gSerialize rev r
1497 | {-# INLINE gSerialize #-}
1498 |
1499 | instance Serializable chType => GSerial (S1 metaSel (Rec0 chType)) where
1500 | gSerialize rev (M1 (K1 re)) = serialize rev re
1501 | {-# INLINE gSerialize #-}
1502 |
1503 |
1504 | -- ** ToChType
1505 |
1506 | class ToChType chType inputType where toChType :: inputType -> chType
1507 |
1508 | instance {-# OVERLAPPABLE #-} (IsChType chType, chType ~ inputType) => ToChType chType inputType where toChType = id
1509 | instance ToChType Int64 Int where toChType = fromIntegral
1510 | instance ToChType UInt128 UInt64 where toChType = fromIntegral
1511 | instance ToChType ChString BS.ByteString where toChType = MkChString
1512 | instance ToChType ChString Builder where toChType = MkChString . toStrict . toLazyByteString
1513 | instance ToChType ChString String where toChType = MkChString . BS8.pack
1514 | instance ToChType ChString Text where toChType = MkChString . Text.encodeUtf8
1515 | instance ToChType ChString Int where toChType = MkChString . BS8.pack . show
1516 | instance
1517 | ToChType inputType chType
1518 | =>
1519 | ToChType (Nullable inputType) (Nullable chType)
1520 | where
1521 | toChType = fmap (toChType @inputType @chType)
1522 | instance ToChType inputType chType => ToChType (LowCardinality inputType) chType where toChType = MkLowCardinality . toChType
1523 | instance ToChType UUID Word64 where toChType = MkChUUID . flip Word128 0
1524 | instance ToChType UUID (Word64, Word64) where toChType = MkChUUID . uncurry (flip Word128)
1525 | instance ToChType (DateTime tz) Word32 where toChType = MkDateTime
1526 | instance ToChType (DateTime tz) UTCTime where toChType = MkDateTime . floor . utcTimeToPOSIXSeconds
1527 | instance ToChType (DateTime tz) ZonedTime where toChType = MkDateTime . floor . utcTimeToPOSIXSeconds . zonedTimeToUTC
1528 | instance ToChType (DateTime64 precision tz) Word64 where toChType = MkDateTime64
1529 | instance ToChType Date Word16 where toChType = MkChDate
1530 | instance ToChType chType inputType => ToChType (Array chType) [inputType]
1531 | where
1532 | toChType = MkChArray . map toChType
1533 |
1534 |
1535 |
1536 |
1537 |
1538 |
1539 |
1540 |
1541 | class IsChType chType
1542 | where
1543 | -- | Shows database original type name
1544 | --
1545 | -- @
1546 | -- chTypeName \@ChString = \"String\"
1547 | -- chTypeName \@(Nullable UInt32) = \"Nullable(UInt32)\"
1548 | -- @
1549 | chTypeName :: String
1550 |
1551 | defaultValueOfTypeName :: chType
1552 |
1553 | instance IsChType Int8 where; chTypeName = "Int8"; defaultValueOfTypeName = 0
1554 | instance IsChType Int16 where; chTypeName = "Int16"; defaultValueOfTypeName = 0
1555 | instance IsChType Int32 where; chTypeName = "Int32"; defaultValueOfTypeName = 0
1556 | instance IsChType Int64 where; chTypeName = "Int64"; defaultValueOfTypeName = 0
1557 | instance IsChType Int128 where; chTypeName = "Int128"; defaultValueOfTypeName = 0
1558 |
1559 | {- | ClickHouse UInt8 column type -}
1560 | type UInt8 = Word8
1561 | instance IsChType UInt8 where; chTypeName = "UInt8"; defaultValueOfTypeName = 0
1562 |
1563 | {- | ClickHouse UInt16 column type -}
1564 | type UInt16 = Word16
1565 | instance IsChType UInt16 where; chTypeName = "UInt16"; defaultValueOfTypeName = 0
1566 |
1567 | {- | ClickHouse UInt32 column type -}
1568 | type UInt32 = Word32
1569 | instance IsChType UInt32 where; chTypeName = "UInt32"; defaultValueOfTypeName = 0
1570 |
1571 | {- | ClickHouse UInt64 column type -}
1572 | type UInt64 = Word64
1573 | instance IsChType UInt64 where; chTypeName = "UInt64"; defaultValueOfTypeName = 0
1574 |
1575 | {- | ClickHouse UInt128 column type -}
1576 | type UInt128 = Word128
1577 | instance IsChType UInt128 where; chTypeName = "UInt128"; defaultValueOfTypeName = 0
1578 |
1579 | {- | ClickHouse Date column type -}
1580 | newtype Date = MkChDate Word16
1581 | deriving newtype (Show, Eq, Bits, Bounded, Enum, NFData, Num)
1582 | instance IsChType Date where; chTypeName = "Date"; defaultValueOfTypeName = 0
1583 |
1584 | {- | ClickHouse String column type -}
1585 | newtype ChString = MkChString BS.ByteString
1586 | deriving newtype (Show, Eq, IsString, NFData)
1587 | instance IsChType ChString where; chTypeName = "String"; defaultValueOfTypeName = ""
1588 |
1589 | {- | ClickHouse UUID column type -}
1590 | newtype UUID = MkChUUID Word128
1591 | deriving newtype (Generic, Show, Eq, NFData, Bounded, Enum, Num)
1592 | instance IsChType UUID where; chTypeName = "UUID"; defaultValueOfTypeName = 0
1593 |
1594 | {- | ClickHouse Nullable(T) column type
1595 | (type synonym for Maybe)
1596 | -}
1597 | type Nullable = Maybe
1598 | instance IsChType chType => IsChType (Nullable chType)
1599 | where
1600 | chTypeName = "Nullable(" <> chTypeName @chType <> ")"
1601 | defaultValueOfTypeName = Nothing
1602 |
1603 | {- |
1604 | ClickHouse DateTime column type (paramtrized with timezone)
1605 |
1606 | >>> chTypeName @(DateTime "")
1607 | "DateTime"
1608 | >>> chTypeName @(DateTime "UTC")
1609 | "DateTime('UTC')"
1610 | -}
1611 | newtype DateTime (tz :: Symbol) = MkDateTime Word32
1612 | deriving newtype (Show, Eq, Num, Bits, Enum, Ord, Real, Integral, Bounded, NFData)
1613 |
1614 | instance KnownSymbol tz => IsChType (DateTime tz)
1615 | where
1616 | chTypeName = case (symbolVal @tz Proxy) of
1617 | "" -> "DateTime"
1618 | tz -> "DateTime('" <> tz <> "')"
1619 | defaultValueOfTypeName = MkDateTime 0
1620 |
1621 | {- |
1622 | ClickHouse DateTime64 column type (paramtrized with timezone)
1623 |
1624 | >>> chTypeName @(DateTime64 3 "")
1625 | "DateTime64(3)"
1626 | >>> chTypeName @(DateTime64 3 "UTC")
1627 | "DateTime64(3, 'UTC')"
1628 | -}
1629 | newtype DateTime64 (precision :: Nat) (tz :: Symbol) = MkDateTime64 Word64
1630 | deriving newtype (Show, Eq, Num, Bits, Enum, Ord, Real, Integral, Bounded, NFData)
1631 |
1632 | instance
1633 | (KnownSymbol tz, KnownNat precision)
1634 | =>
1635 | IsChType (DateTime64 precision tz)
1636 | where
1637 | chTypeName =
1638 | let
1639 | prec = show (natVal @precision Proxy)
1640 | in
1641 | case symbolVal @tz Proxy of
1642 | "" -> "DateTime64(" <> prec <> ")"
1643 | tz -> "DateTime64(" <> prec <> ", '" <> tz <> "')"
1644 | defaultValueOfTypeName = MkDateTime64 0
1645 |
1646 |
1647 | -- | ClickHouse Array column type
1648 | newtype Array a = MkChArray [a]
1649 | deriving newtype (Show, Eq, NFData)
1650 | instance IsChType chType => IsChType (Array chType)
1651 | where
1652 | chTypeName = "Array(" <> chTypeName @chType <> ")"
1653 | defaultValueOfTypeName = MkChArray []
1654 |
1655 | -- | ClickHouse LowCardinality(T) column type
1656 | newtype LowCardinality chType = MkLowCardinality chType
1657 | instance IsLowCardinalitySupported chType => IsChType (LowCardinality chType)
1658 | where
1659 | chTypeName = "LowCardinality(" <> chTypeName @chType <> ")"
1660 | defaultValueOfTypeName = MkLowCardinality $ defaultValueOfTypeName @chType
1661 |
1662 | deriving newtype instance (Eq chType, IsLowCardinalitySupported chType) => Eq (LowCardinality chType)
1663 | deriving newtype instance (NFData chType, IsLowCardinalitySupported chType) => NFData (LowCardinality chType)
1664 | deriving newtype instance IsString (LowCardinality ChString)
1665 |
1666 | class IsChType chType => IsLowCardinalitySupported chType
1667 | instance IsLowCardinalitySupported ChString
1668 | instance
1669 | ( IsLowCardinalitySupported chType
1670 | , IsChType (Nullable chType)
1671 | ) =>
1672 | IsLowCardinalitySupported (Nullable chType)
1673 |
1674 | instance {-# OVERLAPPABLE #-}
1675 | ( IsChType chType
1676 | , TypeError
1677 | ( 'Text "LowCardinality(" ':<>: 'ShowType chType ':<>: 'Text ") is unsupported"
1678 | ':$$: 'Text "Use one of these types:"
1679 | ':$$: 'Text " ChString"
1680 | ':$$: 'Text " DateTime"
1681 | ':$$: 'Text " Nullable(T)"
1682 | )
1683 | ) => IsLowCardinalitySupported chType
1684 |
1685 |
1686 |
1687 |
1688 |
1689 |
1690 |
1691 |
1692 | -- * Protocol parts
1693 |
1694 | {- |
1695 | Unsigned variable-length quantity encoding
1696 |
1697 | Part of protocol implementation
1698 | -}
1699 | newtype UVarInt = MkUVarInt Word64
1700 | deriving newtype (Show, Eq, Num, Bits, Enum, Ord, Real, Integral, Bounded, NFData)
1701 |
1702 |
1703 | major, minor, patch :: UVarInt
1704 | major = case versionBranch version of (x:_) -> fromIntegral x; _ -> 0
1705 | minor = case versionBranch version of (_:x:_) -> fromIntegral x; _ -> 0
1706 | patch = case versionBranch version of (_:_:x:_) -> fromIntegral x; _ -> 0
1707 |
1708 | clientName :: ChString
1709 | clientName = fromString $
1710 | "ClickHaskell-" <> show major <> "." <> show minor <> "." <> show patch
1711 |
1712 | newtype ProtocolRevision = MkProtocolRevision UVarInt
1713 | deriving newtype (Eq, Num, Ord, Serializable)
1714 |
1715 | {-# INLINE [0] afterRevision #-}
1716 | afterRevision
1717 | :: forall rev monoid
1718 | . (KnownNat rev, Monoid monoid)
1719 | => ProtocolRevision -> monoid -> monoid
1720 | afterRevision chosenRevision monoid =
1721 | if chosenRevision >= (fromIntegral . natVal) (Proxy @rev)
1722 | then monoid
1723 | else mempty
1724 |
1725 | latestSupportedRevision :: ProtocolRevision
1726 | latestSupportedRevision = (fromIntegral . natVal) (Proxy @DBMS_TCP_PROTOCOL_VERSION)
1727 |
1728 | data SinceRevision a (revisionNumber :: Nat) = MkSinceRevision a | NotPresented
1729 |
1730 | instance
1731 | (KnownNat revision, Deserializable chType)
1732 | =>
1733 | Deserializable (SinceRevision chType revision)
1734 | where
1735 | deserialize rev =
1736 | if rev >= (fromIntegral . natVal) (Proxy @revision)
1737 | then MkSinceRevision <$> deserialize @chType rev
1738 | else pure NotPresented
1739 |
1740 | instance
1741 | (KnownNat revision, Serializable chType)
1742 | =>
1743 | Serializable (SinceRevision chType revision)
1744 | where
1745 | serialize rev (MkSinceRevision val) = afterRevision @revision rev (serialize rev val)
1746 | serialize rev NotPresented = afterRevision @revision rev (error "Unexpected error")
1747 |
1748 |
1749 | {-
1750 | Slightly modified C++ sources:
1751 | https://github.com/ClickHouse/ClickHouse/blob/eb4a74d7412a1fcf52727cd8b00b365d6b9ed86c/src/Core/ProtocolDefines.h#L6
1752 | -}
1753 | type DBMS_TCP_PROTOCOL_VERSION = 54448;
1754 |
1755 | type DBMS_MIN_REVISION_WITH_CLIENT_INFO = 54032;
1756 | type DBMS_MIN_REVISION_WITH_SERVER_TIMEZONE = 54058;
1757 | type DBMS_MIN_REVISION_WITH_QUOTA_KEY_IN_CLIENT_INFO = 54060;
1758 | type DBMS_MIN_REVISION_WITH_TABLES_STATUS = 54226;
1759 | type DBMS_MIN_REVISION_WITH_TIME_ZONE_PARAMETER_IN_DATETIME_DATA_TYPE = 54337;
1760 | type DBMS_MIN_REVISION_WITH_SERVER_DISPLAY_NAME = 54372;
1761 | type DBMS_MIN_REVISION_WITH_VERSION_PATCH = 54401;
1762 | type DBMS_MIN_REVISION_WITH_SERVER_LOGS = 54406;
1763 | type DBMS_MIN_REVISION_WITH_CURRENT_AGGREGATION_VARIANT_SELECTION_METHOD = 54448;
1764 | type DBMS_MIN_MAJOR_VERSION_WITH_CURRENT_AGGREGATION_VARIANT_SELECTION_METHOD = 21;
1765 | type DBMS_MIN_MINOR_VERSION_WITH_CURRENT_AGGREGATION_VARIANT_SELECTION_METHOD = 4;
1766 | type DBMS_MIN_REVISION_WITH_COLUMN_DEFAULTS_METADATA = 54410;
1767 | type DBMS_MIN_REVISION_WITH_LOW_CARDINALITY_TYPE = 54405;
1768 | type DBMS_MIN_REVISION_WITH_CLIENT_WRITE_INFO = 54420;
1769 | type DBMS_MIN_REVISION_WITH_SETTINGS_SERIALIZED_AS_STRINGS = 54429;
1770 | type DBMS_MIN_REVISION_WITH_SCALARS = 54429;
1771 | type DBMS_MIN_REVISION_WITH_OPENTELEMETRY = 54442;
1772 | type DBMS_MIN_REVISION_WITH_AGGREGATE_FUNCTIONS_VERSIONING = 54452;
1773 | type DBMS_CLUSTER_PROCESSING_PROTOCOL_VERSION = 1;
1774 | type DBMS_MIN_SUPPORTED_PARALLEL_REPLICAS_PROTOCOL_VERSION = 3;
1775 | type DBMS_PARALLEL_REPLICAS_MIN_VERSION_WITH_MARK_SEGMENT_SIZE_FIELD = 4;
1776 | type DBMS_PARALLEL_REPLICAS_PROTOCOL_VERSION = 4;
1777 | type DBMS_MIN_REVISION_WITH_PARALLEL_REPLICAS = 54453;
1778 | type DBMS_MERGE_TREE_PART_INFO_VERSION = 1;
1779 | type DBMS_MIN_REVISION_WITH_INTERSERVER_SECRET = 54441;
1780 | type DBMS_MIN_REVISION_WITH_X_FORWARDED_FOR_IN_CLIENT_INFO = 54443;
1781 | type DBMS_MIN_REVISION_WITH_REFERER_IN_CLIENT_INFO = 54447;
1782 | type DBMS_MIN_PROTOCOL_VERSION_WITH_DISTRIBUTED_DEPTH = 54448;
1783 | type DBMS_MIN_PROTOCOL_VERSION_WITH_INCREMENTAL_PROFILE_EVENTS = 54451;
1784 | type DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION = 54454;
1785 | type DBMS_MIN_PROTOCOL_VERSION_WITH_INITIAL_QUERY_START_TIME = 54449;
1786 | type DBMS_MIN_PROTOCOL_VERSION_WITH_PROFILE_EVENTS_IN_INSERT = 54456;
1787 | type DBMS_MIN_PROTOCOL_VERSION_WITH_VIEW_IF_PERMITTED = 54457;
1788 | type DBMS_MIN_PROTOCOL_VERSION_WITH_ADDENDUM = 54458;
1789 | type DBMS_MIN_PROTOCOL_VERSION_WITH_QUOTA_KEY = 54458;
1790 | type DBMS_MIN_PROTOCOL_VERSION_WITH_PARAMETERS = 54459;
1791 | type DBMS_MIN_PROTOCOL_VERSION_WITH_SERVER_QUERY_TIME_IN_PROGRESS = 54460;
1792 | type DBMS_MIN_PROTOCOL_VERSION_WITH_PASSWORD_COMPLEXITY_RULES = 54461;
1793 | type DBMS_MIN_REVISION_WITH_INTERSERVER_SECRET_V2 = 54462;
1794 | type DBMS_MIN_PROTOCOL_VERSION_WITH_TOTAL_BYTES_IN_PROGRESS = 54463;
1795 | type DBMS_MIN_PROTOCOL_VERSION_WITH_TIMEZONE_UPDATES = 54464;
1796 | type DBMS_MIN_REVISION_WITH_SPARSE_SERIALIZATION = 54465;
1797 | type DBMS_MIN_REVISION_WITH_SSH_AUTHENTICATION = 54466;
1798 | type DBMS_MIN_REVISION_WITH_TABLE_READ_ONLY_CHECK = 54467;
1799 | type DBMS_MIN_REVISION_WITH_SYSTEM_KEYWORDS_TABLE = 54468;
1800 | type DBMS_MIN_REVISION_WITH_ROWS_BEFORE_AGGREGATION = 54469;
1801 | type DBMS_MIN_PROTOCOL_VERSION_WITH_CHUNKED_PACKETS = 54470;
1802 | type DBMS_MIN_REVISION_WITH_VERSIONED_PARALLEL_REPLICAS_PROTOCOL = 54471;
1803 |
--------------------------------------------------------------------------------
/library/LICENSE:
--------------------------------------------------------------------------------
1 | BSD 3-Clause License
2 |
3 | Copyright (c) 2025, Dmitry Kovalev
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | 1. Redistributions of source code must retain the above copyright notice, this
9 | list of conditions and the following disclaimer.
10 |
11 | 2. Redistributions in binary form must reproduce the above copyright notice,
12 | this list of conditions and the following disclaimer in the documentation
13 | and/or other materials provided with the distribution.
14 |
15 | 3. Neither the name of the copyright holder nor the names of its
16 | contributors may be used to endorse or promote products derived from
17 | this software without specific prior written permission.
18 |
19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
20 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
21 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
25 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
27 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29 |
--------------------------------------------------------------------------------
/library/README.md:
--------------------------------------------------------------------------------
1 | # 
ClickHaskell
2 |
3 | Haskell implementation of [ClickHouse](https://clickhouse.com/) DBMS Native protocol and client
4 |
5 | ClickHaskell allows you:
6 |
7 | 1. to handle 1+ million rows per second
8 | 2. to share single connection between multiple threads
9 | 3. to build reliable CI/CD and ship DBMS integrations faster
10 |
11 | Visit [Home page](https://clickhaskell.dev/) to learn more
12 |
--------------------------------------------------------------------------------
/secrets.yaml:
--------------------------------------------------------------------------------
1 | hackage:
2 | api_key: ENC[AES256_GCM,data:dJv0MH/U07dGWOlSOkKhRPlQbfxuW/FUEIups6aI8Wa07QHBBzmD/nNdACMiRHVmVwQgMIVfJOE+VyDcW77mnA==,iv:ySOoUpzz2spJkvVP83U8qbOGNzkMCQuhukrmuSjLtAo=,tag:o/1ZEHpXnF24UI6cmk4DsA==,type:str]
3 | sops:
4 | kms: []
5 | gcp_kms: []
6 | azure_kv: []
7 | hc_vault: []
8 | age:
9 | - recipient: age16xv4vkjmzp59qnx5yp6uhsxrenhlt9ruehgw5nwzxapy6lfdyqfsg5sj2m
10 | enc: |
11 | -----BEGIN AGE ENCRYPTED FILE-----
12 | YWdlLWVuY3J5cHRpb24ub3JnL3YxCi0+IFgyNTUxOSBmZG41TVIyYzZ5Y1dpVmMx
13 | aUtRQTBLZmZ4bFdzZHFVMDdERkpDNm5YQlFBCmpmNG11ZjE4aEpQTzlBeUVENFlU
14 | R1J1OVpHSUd2dHNRaDQrR2ZtVW1LNjQKLS0tIHJBMDVPYTNvSEJvUHpzdVdPVmlJ
15 | VHNINHcrb0ROZjhOQ1BOeUJTMXY4b0EKtZu2R7hdodbfDD81JQw1SH8xTAXe2W1Q
16 | j81ZZP/Tn+rkGNKjO2XMItXcSFUBbq+qudjYLdCrCHMiDgsPdWwCnQ==
17 | -----END AGE ENCRYPTED FILE-----
18 | lastmodified: "2025-02-16T02:11:04Z"
19 | mac: ENC[AES256_GCM,data:zditx3RsgVTnEVPRrViHMc8GpnpMkc7AxzgUulNrGDB8Gd9uoWbHNItRTqvo3JfDGi29mwVXyizpIUw/+yikokw2X0W4qoBDEDg8OsHj/avk8YqTEK/7dpolW+KKn35dLWztdr+4ukC2JzY3mvVu/hyWy3Txq/8F+deOxjeXixU=,iv:jGzpwy4CnQNPBgT17Vi2Sr/omAJpd07V7//cCP2NUZQ=,tag:TqHD9CbMkMwZ+S80QmG+Qw==,type:str]
20 | pgp: []
21 | unencrypted_suffix: _unencrypted
22 | version: 3.9.4
23 |
--------------------------------------------------------------------------------