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/e5a31d17da4febde4d94d9bef6c518bbf647c352/documentation/assets/Hasklig-Bold.ttf
--------------------------------------------------------------------------------
/documentation/assets/Hasklig-Regular.ttf:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/KovalevDima/ClickHaskell/e5a31d17da4febde4d94d9bef6c518bbf647c352/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 -p -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, liftA3)
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, void, when, (<$!>), (<=<))
88 | import Data.Binary.Get
89 | import Data.Binary.Get.Internal (readN)
90 | import Data.Bits (Bits (setBit, unsafeShiftL, unsafeShiftR, (.&.), (.|.)))
91 | import Data.ByteString as BS (ByteString, length, take)
92 | import Data.ByteString.Builder
93 | import Data.ByteString.Builder as BS (Builder, byteString)
94 | import Data.ByteString.Char8 as BS8 (concatMap, length, pack, replicate, singleton)
95 | import Data.ByteString.Lazy as BSL (toStrict, ByteString)
96 | import Data.Coerce (coerce)
97 | import Data.IORef (IORef, atomicModifyIORef, atomicWriteIORef, newIORef, readIORef)
98 | import Data.Int (Int16, Int32, Int64, Int8)
99 | import Data.Kind (Constraint, Type)
100 | import Data.List (uncons)
101 | import Data.Maybe (listToMaybe, fromMaybe)
102 | import Data.String (IsString (..))
103 | import Data.Text (Text)
104 | import Data.Text.Encoding as Text (encodeUtf8)
105 | import Data.Time (UTCTime, ZonedTime, zonedTimeToUTC)
106 | import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
107 | import Data.Type.Bool (If)
108 | import Data.Type.Equality (type (==))
109 | import Data.Typeable (Proxy (..))
110 | import Data.Version (Version (..))
111 | import Data.Word (Word16, Word32, Word64, Word8)
112 | import GHC.Generics (C1, D1, Generic (..), K1 (K1, unK1), M1 (M1, unM1), Meta (MetaSel), Rec0, S1, type (:*:) (..))
113 | import GHC.Stack (HasCallStack, callStack, prettyCallStack)
114 | import GHC.TypeLits (AppendSymbol, ErrorMessage (..), KnownNat, KnownSymbol, Nat, Symbol, TypeError, natVal, symbolVal)
115 | import System.Environment (lookupEnv)
116 | import System.Timeout (timeout)
117 |
118 | -- External
119 | import Data.WideWord (Int128 (..), Word128(..))
120 | import Network.Socket hiding (SocketOption(..))
121 | import Network.Socket qualified as Sock (SocketOption(..))
122 | import Network.Socket.ByteString (recv)
123 | import Network.Socket.ByteString.Lazy (sendAll)
124 | import Network.TLS (ClientParams (..), contextNew, contextClose, sendData, recvData, defaultParamsClient, handshake)
125 |
126 | -- * Connection
127 |
128 | {- |
129 | See `defaultConnectionArgs` for documentation
130 | -}
131 | data ConnectionArgs = MkConnectionArgs
132 | { user :: Text
133 | , pass :: Text
134 | , db :: Text
135 | , host :: HostName
136 | , mPort :: Maybe ServiceName
137 | , isTLS :: Bool
138 | , overriddenTLS :: Maybe ClientParams
139 | , initBuffer :: HostName -> SockAddr -> Socket -> IO Buffer
140 | }
141 |
142 | {- |
143 | Default connection settings which follows __clickhouse-client__ defaults
144 |
145 | Use `setUser`, `setPassword`, `setHost`, `setPort`, `setDatabase`
146 | to modify connection defaults.
147 |
148 | Or 'setSecure', 'overrideTLS' to configure TLS connection
149 | -}
150 | defaultConnectionArgs :: ConnectionArgs
151 | defaultConnectionArgs = MkConnectionArgs
152 | { user = "default"
153 | , pass = ""
154 | , host = "localhost"
155 | , db = "default"
156 | , isTLS = False
157 | , mPort = Nothing
158 | , overriddenTLS = Nothing
159 | , initBuffer = \_hostname addrAddress sock -> do
160 | setSocketOption sock Sock.NoDelay 1
161 | setSocketOption sock Sock.KeepAlive 1
162 | connect sock addrAddress
163 | buff <- newIORef ""
164 | pure
165 | MkBuffer
166 | { writeSock = \bs -> sendAll sock bs
167 | , readSock = recv sock 4096
168 | , closeSock = close sock
169 | , buff
170 | }
171 | }
172 |
173 | {-|
174 | Sets custom TLS settings and applies 'setSecure'
175 | -}
176 | overrideTLS :: ClientParams -> ConnectionArgs -> ConnectionArgs
177 | overrideTLS clientParams MkConnectionArgs{..} =
178 | setSecure $ MkConnectionArgs{overriddenTLS = Just clientParams, ..}
179 |
180 | {-|
181 | Sets TLS connection
182 |
183 | Uses 9443 port by default. Watch 'setPort' to override it
184 | -}
185 | setSecure :: ConnectionArgs -> ConnectionArgs
186 | setSecure MkConnectionArgs{..} =
187 | MkConnectionArgs{initBuffer = initTLS, isTLS=True, ..}
188 | where
189 | initTLS = \hostname addrAddress sock -> do
190 | setSocketOption sock Sock.NoDelay 1
191 | setSocketOption sock Sock.KeepAlive 1
192 | connect sock addrAddress
193 | let defClientParams = (defaultParamsClient hostname "")
194 | context <- contextNew sock (fromMaybe defClientParams overriddenTLS)
195 | handshake context
196 | buff <- newIORef ""
197 | pure
198 | MkBuffer
199 | { writeSock = \bs -> sendData context bs
200 | , readSock = recvData context
201 | , closeSock = contextClose context
202 | , buff
203 | }
204 |
205 | {- |
206 | Overrides default user __"default"__
207 | -}
208 | setUser :: Text -> ConnectionArgs -> ConnectionArgs
209 | setUser new MkConnectionArgs{..} = MkConnectionArgs{user=new, ..}
210 |
211 | {- |
212 | Overrides default password __""__
213 | -}
214 | setPassword :: Text -> ConnectionArgs -> ConnectionArgs
215 | setPassword new MkConnectionArgs{..} = MkConnectionArgs{pass=new, ..}
216 |
217 | {- |
218 | Overrides default hostname __"localhost"__
219 | -}
220 | setHost :: HostName -> ConnectionArgs -> ConnectionArgs
221 | setHost new MkConnectionArgs{..} = MkConnectionArgs{host=new, ..}
222 |
223 | {- |
224 | Overrides default port __9000__ (or __9443__ for TLS)
225 | -}
226 | setPort :: ServiceName -> ConnectionArgs -> ConnectionArgs
227 | setPort new MkConnectionArgs{..} = MkConnectionArgs{mPort=Just new, ..}
228 |
229 | {- |
230 | Overrides default database __"default"__
231 | -}
232 | setDatabase :: Text -> ConnectionArgs -> ConnectionArgs
233 | setDatabase new MkConnectionArgs{..} = MkConnectionArgs{db=new, ..}
234 |
235 | data Connection where MkConnection :: (MVar ConnectionState) -> Connection
236 |
237 | withConnection :: HasCallStack => Connection -> (ConnectionState -> IO a) -> IO a
238 | withConnection (MkConnection connStateMVar) f =
239 | mask $ \restore -> do
240 | connState <- takeMVar connStateMVar
241 | b <- onException
242 | (restore (f connState))
243 | (putMVar connStateMVar =<< reopenConnection connState)
244 | putMVar connStateMVar connState
245 | return b
246 |
247 | data ConnectionState = MkConnectionState
248 | { user :: ChString
249 | , hostname :: ChString
250 | , os_user :: ChString
251 | , buffer :: Buffer
252 | , revision :: ProtocolRevision
253 | , creds :: ConnectionArgs
254 | }
255 |
256 | writeToConnection :: Serializable packet => ConnectionState -> packet -> IO ()
257 | writeToConnection MkConnectionState{revision, buffer} packet =
258 | (writeSock buffer . toLazyByteString . serialize revision) packet
259 |
260 | writeToConnectionEncode :: ConnectionState -> (ProtocolRevision -> Builder) -> IO ()
261 | writeToConnectionEncode MkConnectionState{revision, buffer} serializer =
262 | (writeSock buffer . toLazyByteString) (serializer revision)
263 |
264 | openConnection :: HasCallStack => ConnectionArgs -> IO Connection
265 | openConnection creds = fmap MkConnection . newMVar =<< createConnectionState creds
266 |
267 | reopenConnection :: ConnectionState -> IO ConnectionState
268 | reopenConnection MkConnectionState{creds, buffer} = do
269 | flushBuffer buffer
270 | closeSock buffer
271 | createConnectionState creds
272 |
273 | createConnectionState :: ConnectionArgs -> IO ConnectionState
274 | createConnectionState creds@MkConnectionArgs {user, pass, db, host, mPort, initBuffer, isTLS} = do
275 | let port = fromMaybe (if isTLS then "9440" else "9000") mPort
276 | hostname <- maybe "" toChType <$> lookupEnv "HOSTNAME"
277 | os_user <- maybe "" toChType <$> lookupEnv "USER"
278 | AddrInfo{addrFamily, addrSocketType, addrProtocol, addrAddress}
279 | <- maybe (throwIO NoAdressResolved) pure . listToMaybe
280 | =<< getAddrInfo
281 | (Just defaultHints{addrFlags = [AI_ADDRCONFIG], addrSocketType = Stream})
282 | (Just host)
283 | (Just port)
284 | buffer <- maybe (throwIO EstablishTimeout) pure
285 | =<< timeout 3_000_000 (
286 | bracketOnError
287 | (socket addrFamily addrSocketType addrProtocol)
288 | (\sock ->
289 | catch @SomeException
290 | (finally (shutdown sock ShutdownBoth) (close sock))
291 | (const $ pure ())
292 | )
293 | (\sock -> initBuffer host addrAddress sock)
294 | )
295 |
296 | (writeSock buffer . toLazyByteString . serialize latestSupportedRevision)
297 | (mkHelloPacket db user pass)
298 | serverPacketType <- rawBufferizedRead buffer (deserialize latestSupportedRevision)
299 | case serverPacketType of
300 | HelloResponse MkHelloResponse{server_revision} -> do
301 | let revision = min server_revision latestSupportedRevision
302 | conn = MkConnectionState{user = toChType user, ..}
303 | writeToConnection conn MkAddendum{quota_key = MkSinceRevision ""}
304 | pure conn
305 | Exception exception -> throwIO (UserError $ DatabaseException exception)
306 | otherPacket -> throwIO (InternalError $ UnexpectedPacketType $ serverPacketToNum otherPacket)
307 |
308 |
309 | {- |
310 | Might be used for any command without data responses
311 |
312 | For example: CREATE, TRUNCATE, KILL, SET, GRANT
313 |
314 | __Throws exception if any data was returned__
315 | -}
316 | command :: HasCallStack => Connection -> ChString -> IO ()
317 | command conn query = do
318 | withConnection conn $ \connState -> do
319 | writeToConnection connState (mkQueryPacket connState query)
320 | writeToConnection connState (mkDataPacket "" 0 0)
321 | handleCreate connState
322 | where
323 | handleCreate :: ConnectionState -> IO ()
324 | handleCreate MkConnectionState{..} =
325 | rawBufferizedRead buffer (deserialize revision)
326 | >>= \packet -> case packet of
327 | EndOfStream -> pure ()
328 | Exception exception -> throwIO (UserError $ DatabaseException exception)
329 | otherPacket -> throwIO (InternalError $ UnexpectedPacketType $ serverPacketToNum otherPacket)
330 |
331 |
332 | -- * Ping
333 |
334 | ping :: HasCallStack => Connection -> IO ()
335 | ping conn = do
336 | withConnection conn $ \connState@MkConnectionState{revision, buffer} -> do
337 | writeToConnection connState Ping
338 | responsePacket <- rawBufferizedRead buffer (deserialize revision)
339 | case responsePacket of
340 | Pong -> pure ()
341 | Exception exception -> throwIO (UserError $ DatabaseException exception)
342 | otherPacket -> throwIO (InternalError $ UnexpectedPacketType $ serverPacketToNum otherPacket)
343 |
344 |
345 |
346 |
347 | -- * Reading
348 |
349 | class IsTable table where
350 | type GetColumns table :: [Type]
351 | tableName :: Builder
352 |
353 | class HasParameters view where
354 | type GetParams view :: [Type]
355 |
356 |
357 | select ::
358 | forall columns output result
359 | .
360 | ClickHaskell columns output
361 | =>
362 | Connection -> ChString -> ([output] -> IO result) -> IO [result]
363 | select conn query f = do
364 | withConnection conn $ \connState -> do
365 | writeToConnection connState (mkQueryPacket connState query)
366 | writeToConnection connState (mkDataPacket "" 0 0)
367 | handleSelect @columns connState (\x -> id <$!> f x)
368 |
369 | data Table (name :: Symbol) (columns :: [Type])
370 |
371 | instance KnownSymbol name => IsTable (Table name columns) where
372 | type GetColumns (Table name columns) = columns
373 | tableName = (byteString . BS8.pack) (symbolVal $ Proxy @name)
374 |
375 | type ClickHaskellTable table record =
376 | ( IsTable table
377 | , ClickHaskell (GetColumns table) record
378 | )
379 |
380 | selectFrom ::
381 | forall table output result
382 | .
383 | ClickHaskellTable table output
384 | =>
385 | Connection -> ([output] -> IO result) -> IO [result]
386 | selectFrom conn f = select @(GetColumns table) conn query f
387 | where
388 | query = toChType $
389 | "SELECT " <> columns @(GetColumns table) @output <>
390 | " FROM " <> tableName @table
391 |
392 | data View (name :: Symbol) (columns :: [Type]) (parameters :: [Type])
393 |
394 | selectFromView ::
395 | forall view output result name columns parameters passedParameters
396 | .
397 | ( ClickHaskell columns output
398 | , KnownSymbol name
399 | , view ~ View name columns parameters
400 | )
401 | => Connection -> (Parameters '[] -> Parameters passedParameters) -> ([output] -> IO result) -> IO [result]
402 | selectFromView conn interpreter f = select @columns conn query f
403 | where
404 | query = toChType $
405 | "SELECT " <> columns @columns @output <>
406 | " FROM " <> (byteString . BS8.pack . symbolVal @name) Proxy <> viewParameters interpreter
407 |
408 | generateRandom ::
409 | forall columns output result
410 | .
411 | ClickHaskell columns output
412 | =>
413 | Connection -> (UInt64, UInt64, UInt64) -> UInt64 -> ([output] -> IO result) -> IO [result]
414 | generateRandom conn (randomSeed, maxStrLen, maxArrayLen) limit f = select @columns conn query f
415 | where
416 | query = toChType $
417 | "SELECT * FROM generateRandom(" <>
418 | "'" <> readingColumnsAndTypes @columns @output <> "' ," <>
419 | toQueryPart randomSeed <> "," <>
420 | toQueryPart maxStrLen <> "," <>
421 | toQueryPart maxArrayLen <>
422 | ")" <>
423 | " LIMIT " <> toQueryPart limit <> ";"
424 |
425 | -- *** Internal
426 |
427 | handleSelect ::
428 | forall columns output result
429 | .
430 | ClickHaskell columns output
431 | =>
432 | ConnectionState -> ([output] -> IO result) -> IO [result]
433 | handleSelect MkConnectionState{..} f = loop []
434 | where
435 | loop acc = rawBufferizedRead buffer (deserialize revision) >>=
436 | \packet -> case packet of
437 | DataResponse MkDataPacket{columns_count = 0, rows_count = 0} -> loop acc
438 | DataResponse MkDataPacket{columns_count, rows_count} -> do
439 | let expected = columnsCount @columns @output
440 | when (columns_count /= expected) $
441 | (throw . UserError . UnmatchedColumnsCount)
442 | ("Expected " <> show expected <> " columns but got " <> show columns_count)
443 | result <- f =<< rawBufferizedRead buffer (deserializeColumns @columns True revision rows_count)
444 | loop (result : acc)
445 | Progress _ -> loop acc
446 | ProfileInfo _ -> loop acc
447 | EndOfStream -> pure acc
448 | Exception exception -> throwIO (UserError $ DatabaseException exception)
449 | otherPacket -> throwIO (InternalError $ UnexpectedPacketType $ serverPacketToNum otherPacket)
450 |
451 |
452 |
453 |
454 | -- * Writing
455 |
456 | insertInto ::
457 | forall table record name columns
458 | .
459 | ( table ~ Table name columns
460 | , ClickHaskell columns record
461 | , KnownSymbol name
462 | )
463 | => Connection -> [record] -> IO ()
464 | insertInto conn columnsData = do
465 | withConnection conn $ \connState -> do
466 | writeToConnection connState (mkQueryPacket connState query)
467 | writeToConnection connState (mkDataPacket "" 0 0)
468 | handleInsertResult @columns connState columnsData
469 | where
470 | query = toChType $
471 | "INSERT INTO " <> (byteString . BS8.pack . symbolVal @name $ Proxy)
472 | <> " (" <> columns @columns @record <> ") VALUES"
473 |
474 |
475 | handleInsertResult :: forall columns record . ClickHaskell columns record => ConnectionState -> [record] -> IO ()
476 | handleInsertResult conn@MkConnectionState{..} records = do
477 | firstPacket <- rawBufferizedRead buffer (deserialize revision)
478 | case firstPacket of
479 | TableColumns _ -> handleInsertResult @columns conn records
480 | DataResponse MkDataPacket{} -> do
481 | _emptyDataPacket <- rawBufferizedRead buffer (deserializeColumns @columns @record False revision 0)
482 | writeToConnection conn (mkDataPacket "" (columnsCount @columns @record) (fromIntegral $ Prelude.length records))
483 | writeToConnectionEncode conn (serializeRecords @columns records)
484 | writeToConnection conn (mkDataPacket "" 0 0)
485 | handleInsertResult @columns @record conn []
486 | EndOfStream -> pure ()
487 | Exception exception -> throwIO (UserError $ DatabaseException exception)
488 | otherPacket -> throwIO (InternalError $ UnexpectedPacketType $ serverPacketToNum otherPacket)
489 |
490 |
491 |
492 |
493 | -- * Bufferization
494 |
495 | data Buffer = MkBuffer
496 | { readSock :: IO BS.ByteString
497 | , writeSock :: BSL.ByteString -> IO ()
498 | , closeSock :: IO ()
499 | , buff :: IORef BS.ByteString
500 | }
501 |
502 | flushBuffer :: Buffer -> IO ()
503 | flushBuffer MkBuffer{buff} = atomicWriteIORef buff ""
504 |
505 | rawBufferizedRead :: Buffer -> Get packet -> IO packet
506 | rawBufferizedRead buffer@MkBuffer{..} parser = runBufferReader (runGetIncremental parser)
507 | where
508 | runBufferReader :: Decoder packet -> IO packet
509 | runBufferReader = \case
510 | (Partial decoder) -> readBuffer >>= runBufferReader . decoder . Just
511 | (Done leftover _consumed packet) -> packet <$ atomicModifyIORef buff (leftover,)
512 | (Fail _leftover _consumed msg) -> throwIO (InternalError $ DeserializationError msg)
513 |
514 | readBuffer :: IO BS.ByteString
515 | readBuffer =
516 | readIORef buff
517 | >>= (\currentBuffer ->
518 | case BS.length currentBuffer of
519 | 0 -> readSock
520 | _ -> flushBuffer buffer *> pure currentBuffer
521 | )
522 |
523 |
524 |
525 |
526 | -- * Errors handling
527 |
528 | {- |
529 | A wrapper for all client-related errors
530 | -}
531 | data ClientError where
532 | UserError :: HasCallStack => UserError -> ClientError
533 | InternalError :: HasCallStack => InternalError -> ClientError
534 | deriving anyclass (Exception)
535 |
536 | instance Show ClientError where
537 | show (UserError err) = "UserError " <> show err <> "\n" <> prettyCallStack callStack
538 | show (InternalError err) = "InternalError " <> show err <> "\n" <> prettyCallStack callStack
539 |
540 | {- |
541 | Errors occured on connection operations
542 | -}
543 | data ConnectionError
544 | = NoAdressResolved
545 | -- ^ Occurs when 'getAddrInfo' returns an empty result
546 | | EstablishTimeout
547 | -- ^ Occurs on 'socket' connection timeout
548 | deriving (Show, Exception)
549 |
550 | {- |
551 | Errors intended to be handled by developers
552 | -}
553 | data UserError
554 | = UnmatchedType String
555 | -- ^ Column type mismatch in data packet
556 | | UnmatchedColumn String
557 | -- ^ Column name mismatch in data packet
558 | | UnmatchedColumnsCount String
559 | -- ^ Occurs when actual columns count less or more than expected
560 | | DatabaseException ExceptionPacket
561 | -- ^ Database responded with an exception packet
562 | deriving (Show, Exception)
563 |
564 | {- |
565 | These exceptions might indicate internal bugs.
566 |
567 | If you encounter one, please report it.
568 | -}
569 | data InternalError
570 | = UnexpectedPacketType UVarInt
571 | | DeserializationError String
572 | deriving (Show, Exception)
573 |
574 |
575 |
576 |
577 | -- * Client packets
578 |
579 | data ClientPacket where
580 | Hello :: HelloPacket -> ClientPacket
581 | Query :: QueryPacket -> ClientPacket
582 | Data :: DataPacket -> ClientPacket
583 | Cancel :: ClientPacket
584 | Ping :: ClientPacket
585 | TablesStatusRequest :: ClientPacket
586 | KeepAlive :: ClientPacket
587 | Scalar :: ClientPacket
588 | IgnoredPartUUIDs :: ClientPacket
589 | ReadTaskResponse :: ClientPacket
590 | MergeTreeReadTaskResponse :: ClientPacket
591 | SSHChallengeRequest :: ClientPacket
592 | SSHChallengeResponse :: ClientPacket
593 | deriving (Generic)
594 |
595 | instance Serializable ClientPacket where
596 | serialize rev packet = case packet of
597 | (Hello p) -> serialize @UVarInt rev 0 <> serialize rev p
598 | (Query p) -> serialize @UVarInt rev 1 <> serialize rev p
599 | (Data p) -> serialize @UVarInt rev 2 <> serialize rev p
600 | (Cancel) -> serialize @UVarInt rev 3
601 | (Ping) -> serialize @UVarInt rev 4
602 | (TablesStatusRequest) -> serialize @UVarInt rev 5
603 | (KeepAlive) -> serialize @UVarInt rev 6
604 | (Scalar) -> serialize @UVarInt rev 7
605 | (IgnoredPartUUIDs) -> serialize @UVarInt rev 8
606 | (ReadTaskResponse) -> serialize @UVarInt rev 9
607 | (MergeTreeReadTaskResponse) -> serialize @UVarInt rev 10
608 | (SSHChallengeRequest) -> serialize @UVarInt rev 11
609 | (SSHChallengeResponse) -> serialize @UVarInt rev 12
610 |
611 | -- ** Hello
612 |
613 | mkHelloPacket :: Text -> Text -> Text -> ClientPacket
614 | mkHelloPacket db user pass = Hello
615 | MkHelloPacket
616 | { client_name = clientName
617 | , client_version_major = major
618 | , client_version_minor = minor
619 | , tcp_protocol_version = latestSupportedRevision
620 | , default_database = toChType db
621 | , user = toChType user
622 | , pass = toChType pass
623 | }
624 |
625 | data HelloPacket = MkHelloPacket
626 | { client_name :: ChString
627 | , client_version_major :: UVarInt
628 | , client_version_minor :: UVarInt
629 | , tcp_protocol_version :: ProtocolRevision
630 | , default_database :: ChString
631 | , user :: ChString
632 | , pass :: ChString
633 | }
634 | deriving (Generic, Serializable)
635 |
636 |
637 | data Addendum = MkAddendum{quota_key :: ChString `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_QUOTA_KEY}
638 | deriving (Generic, Serializable)
639 |
640 | -- ** Query
641 |
642 | mkQueryPacket :: ConnectionState -> ChString -> ClientPacket
643 | mkQueryPacket MkConnectionState{..} query = Query
644 | MkQueryPacket
645 | { query_id = ""
646 | , client_info = MkSinceRevision MkClientInfo
647 | { query_kind = InitialQuery
648 | , initial_user = user
649 | , initial_query_id = ""
650 | , initial_adress = "0.0.0.0:0"
651 | , initial_time = MkSinceRevision 0
652 | , interface_type = 1 -- [tcp - 1, http - 2]
653 | , os_user, hostname
654 | , client_name = clientName
655 | , client_version_major = major
656 | , client_version_minor = minor
657 | , client_revision = revision
658 | , quota_key = MkSinceRevision ""
659 | , distrubuted_depth = MkSinceRevision 0
660 | , client_version_patch = MkSinceRevision patch
661 | , open_telemetry = MkSinceRevision 0
662 | , collaborate_with_initiator = MkSinceRevision 0
663 | , count_participating_replicas = MkSinceRevision 0
664 | , number_of_current_replica = MkSinceRevision 0
665 | }
666 | , settings = MkDbSettings
667 | , interserver_secret = MkSinceRevision ""
668 | , query_stage = Complete
669 | , compression = 0
670 | , query
671 | , parameters = MkSinceRevision MkQueryParameters
672 | }
673 |
674 | data QueryPacket = MkQueryPacket
675 | { query_id :: ChString
676 | , client_info :: ClientInfo `SinceRevision` DBMS_MIN_REVISION_WITH_CLIENT_INFO
677 | , settings :: DbSettings
678 | , interserver_secret :: ChString `SinceRevision` DBMS_MIN_REVISION_WITH_INTERSERVER_SECRET
679 | , query_stage :: QueryStage
680 | , compression :: UVarInt
681 | , query :: ChString
682 | , parameters :: QueryParameters `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_PARAMETERS
683 | }
684 | deriving (Generic, Serializable)
685 |
686 | data DbSettings = MkDbSettings
687 | instance Serializable DbSettings where serialize rev _ = serialize @ChString rev ""
688 |
689 | data QueryParameters = MkQueryParameters
690 | instance Serializable QueryParameters where serialize rev _ = serialize @ChString rev ""
691 |
692 | data QueryStage
693 | = FetchColumns | WithMergeableState | Complete
694 | | WithMergeableStateAfterAggregation
695 | | WithMergeableStateAfterAggregationAndLimit
696 | deriving (Enum)
697 |
698 | instance Serializable QueryStage where
699 | serialize rev = serialize @UVarInt rev . fromIntegral . fromEnum
700 |
701 |
702 | data Flags = IMPORTANT | CUSTOM | OBSOLETE
703 | _flagCode :: Flags -> UInt64
704 | _flagCode IMPORTANT = 0x01
705 | _flagCode CUSTOM = 0x02
706 | _flagCode OBSOLETE = 0x04
707 |
708 | data ClientInfo = MkClientInfo
709 | { query_kind :: QueryKind
710 | , initial_user :: ChString
711 | , initial_query_id :: ChString
712 | , initial_adress :: ChString
713 | , initial_time :: Int64 `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_INITIAL_QUERY_START_TIME
714 | , interface_type :: UInt8
715 | , os_user :: ChString
716 | , hostname :: ChString
717 | , client_name :: ChString
718 | , client_version_major :: UVarInt
719 | , client_version_minor :: UVarInt
720 | , client_revision :: ProtocolRevision
721 | , quota_key :: ChString `SinceRevision` DBMS_MIN_REVISION_WITH_QUOTA_KEY_IN_CLIENT_INFO
722 | , distrubuted_depth :: UVarInt `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_DISTRIBUTED_DEPTH
723 | , client_version_patch :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_VERSION_PATCH
724 | , open_telemetry :: UInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_OPENTELEMETRY
725 | , collaborate_with_initiator :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_PARALLEL_REPLICAS
726 | , count_participating_replicas :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_PARALLEL_REPLICAS
727 | , number_of_current_replica :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_PARALLEL_REPLICAS
728 | }
729 | deriving (Generic, Serializable)
730 |
731 | data QueryKind = NoQuery | InitialQuery | SecondaryQuery
732 | instance Serializable QueryKind where
733 | serialize rev = serialize @UInt8 rev . (\case NoQuery -> 1; InitialQuery -> 2; SecondaryQuery -> 3)
734 |
735 | -- ** Data
736 |
737 | mkDataPacket :: ChString -> UVarInt -> UVarInt -> ClientPacket
738 | mkDataPacket table_name columns_count rows_count = Data
739 | MkDataPacket
740 | { table_name
741 | , block_info = MkBlockInfo
742 | { field_num1 = 1, is_overflows = 0
743 | , field_num2 = 2, bucket_num = -1
744 | , eof = 0
745 | }
746 | , columns_count
747 | , rows_count
748 | }
749 |
750 | data DataPacket = MkDataPacket
751 | { table_name :: ChString
752 | , block_info :: BlockInfo
753 | , columns_count :: UVarInt
754 | , rows_count :: UVarInt
755 | }
756 | deriving (Generic, Serializable, Deserializable)
757 |
758 | data BlockInfo = MkBlockInfo
759 | { field_num1 :: UVarInt, is_overflows :: UInt8
760 | , field_num2 :: UVarInt, bucket_num :: Int32
761 | , eof :: UVarInt
762 | }
763 | deriving (Generic, Serializable, Deserializable)
764 |
765 |
766 |
767 |
768 | -- * Server packets
769 |
770 | data ServerPacket where
771 | HelloResponse :: HelloResponse -> ServerPacket
772 | DataResponse :: DataPacket -> ServerPacket
773 | Exception :: ExceptionPacket -> ServerPacket
774 | Progress :: ProgressPacket -> ServerPacket
775 | Pong :: ServerPacket
776 | EndOfStream :: ServerPacket
777 | ProfileInfo :: ProfileInfo -> ServerPacket
778 | Totals :: ServerPacket
779 | Extremes :: ServerPacket
780 | TablesStatusResponse :: ServerPacket
781 | Log :: ServerPacket
782 | TableColumns :: TableColumns -> ServerPacket
783 | UUIDs :: ServerPacket
784 | ReadTaskRequest :: ServerPacket
785 | ProfileEvents :: ServerPacket
786 | UnknownPacket :: UVarInt -> ServerPacket
787 |
788 | instance Deserializable ServerPacket where
789 | deserialize rev = do
790 | packetNum <- deserialize @UVarInt rev
791 | case packetNum of
792 | 0 -> HelloResponse <$> deserialize rev
793 | 1 -> DataResponse <$> deserialize rev
794 | 2 -> Exception <$> deserialize rev
795 | 3 -> Progress <$> deserialize rev
796 | 4 -> pure Pong
797 | 5 -> pure EndOfStream
798 | 6 -> ProfileInfo <$> deserialize rev
799 | 7 -> pure Totals
800 | 8 -> pure Extremes
801 | 9 -> pure TablesStatusResponse
802 | 10 -> pure Log
803 | 11 -> TableColumns <$> deserialize rev
804 | 12 -> pure UUIDs
805 | 13 -> pure ReadTaskRequest
806 | 14 -> pure ProfileEvents
807 | _ -> pure $ UnknownPacket packetNum
808 |
809 | serverPacketToNum :: ServerPacket -> UVarInt
810 | serverPacketToNum = \case
811 | (HelloResponse _) -> 0; (DataResponse _) -> 1
812 | (Exception _) -> 2; (Progress _) -> 3;
813 | (Pong) -> 4; (EndOfStream) -> 5
814 | (ProfileInfo _) -> 6; (Totals) -> 7
815 | (Extremes) -> 8; (TablesStatusResponse) -> 9
816 | (Log) -> 10; (TableColumns _) -> 11;
817 | (UUIDs) -> 12; (ReadTaskRequest) -> 13
818 | (ProfileEvents) -> 14; (UnknownPacket num) -> num
819 |
820 |
821 | {-
822 | https://github.com/ClickHouse/ClickHouse/blob/eb4a74d7412a1fcf52727cd8b00b365d6b9ed86c/src/Client/Connection.cpp#L520
823 | -}
824 | data HelloResponse = MkHelloResponse
825 | { server_name :: ChString
826 | , server_version_major :: UVarInt
827 | , server_version_minor :: UVarInt
828 | , server_revision :: ProtocolRevision
829 | , server_parallel_replicas_proto :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_VERSIONED_PARALLEL_REPLICAS_PROTOCOL
830 | , server_timezone :: ChString `SinceRevision` DBMS_MIN_REVISION_WITH_SERVER_TIMEZONE
831 | , server_display_name :: ChString `SinceRevision` DBMS_MIN_REVISION_WITH_SERVER_DISPLAY_NAME
832 | , server_version_patch :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_VERSION_PATCH
833 | , proto_send_chunked_srv :: ChString `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_CHUNKED_PACKETS
834 | , proto_recv_chunked_srv :: ChString `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_CHUNKED_PACKETS
835 | , password_complexity_rules :: [PasswordComplexityRules] `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_PASSWORD_COMPLEXITY_RULES
836 | , read_nonce :: UInt64 `SinceRevision` DBMS_MIN_REVISION_WITH_INTERSERVER_SECRET_V2
837 | }
838 | deriving (Generic, Deserializable)
839 |
840 | data PasswordComplexityRules = MkPasswordComplexityRules
841 | { original_pattern :: ChString
842 | , exception_message :: ChString
843 | }
844 | deriving (Generic, Deserializable)
845 |
846 | instance Deserializable [PasswordComplexityRules] where
847 | deserialize rev = do
848 | len <- deserialize @UVarInt rev
849 | replicateM (fromIntegral len) (deserialize @PasswordComplexityRules rev)
850 |
851 | data ExceptionPacket = MkExceptionPacket
852 | { code :: Int32
853 | , name :: ChString
854 | , message :: ChString
855 | , stack_trace :: ChString
856 | , nested :: UInt8
857 | }
858 | deriving (Generic, Show, Deserializable)
859 |
860 | data ProgressPacket = MkProgressPacket
861 | { rows :: UVarInt
862 | , bytes :: UVarInt
863 | , total_rows :: UVarInt
864 | , total_bytes :: UVarInt `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_TOTAL_BYTES_IN_PROGRESS
865 | , wrote_rows :: UVarInt `SinceRevision` DBMS_MIN_PROTOCOL_VERSION_WITH_TOTAL_BYTES_IN_PROGRESS
866 | , wrote_bytes :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_CLIENT_WRITE_INFO
867 | , elapsed_ns :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_CLIENT_WRITE_INFO
868 | }
869 | deriving (Generic, Deserializable)
870 |
871 | data ProfileInfo = MkProfileInfo
872 | { rows :: UVarInt
873 | , blocks :: UVarInt
874 | , bytes :: UVarInt
875 | , applied_limit :: UInt8
876 | , rows_before_limit :: UVarInt
877 | , calculated_rows_before_limit :: UInt8
878 | , applied_aggregation :: UInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_ROWS_BEFORE_AGGREGATION
879 | , rows_before_aggregation :: UVarInt `SinceRevision` DBMS_MIN_REVISION_WITH_ROWS_BEFORE_AGGREGATION
880 | }
881 | deriving (Generic, Deserializable)
882 |
883 | data TableColumns = MkTableColumns
884 | { table_name :: ChString
885 | , table_columns :: ChString
886 | }
887 | deriving (Generic, Deserializable)
888 |
889 |
890 |
891 |
892 |
893 |
894 |
895 |
896 | -- * Deserialization
897 |
898 | -- ** Generic API
899 |
900 | type GenericClickHaskell record hasColumns =
901 | ( Generic record
902 | , GClickHaskell hasColumns (Rep record)
903 | )
904 |
905 | class ClickHaskell columns record
906 | where
907 | default deserializeColumns :: GenericClickHaskell record columns => Bool -> ProtocolRevision -> UVarInt -> Get [record]
908 | deserializeColumns :: Bool -> ProtocolRevision -> UVarInt -> Get [record]
909 | deserializeColumns isCheckRequired rev size = do
910 | list <- gFromColumns @columns isCheckRequired rev size
911 | pure $ do
912 | element <- list
913 | case to element of res -> pure $! res
914 |
915 | default columns :: GenericClickHaskell record columns => Builder
916 | columns :: Builder
917 | columns = buildCols (gReadingColumns @columns @(Rep record))
918 | where
919 | buildCols [] = mempty
920 | buildCols ((col, _):[]) = col
921 | buildCols ((col, _):rest) = col <> ", " <> buildCols rest
922 |
923 | default readingColumnsAndTypes :: GenericClickHaskell record columns => Builder
924 | readingColumnsAndTypes :: Builder
925 | readingColumnsAndTypes = buildColsTypes (gReadingColumns @columns @(Rep record))
926 | where
927 | buildColsTypes [] = mempty
928 | buildColsTypes ((col, typ):[]) = col <> " " <> typ
929 | buildColsTypes ((col, typ):rest) = col <> " " <> typ <> ", " <> buildColsTypes rest
930 |
931 | default serializeRecords :: GenericClickHaskell record columns => [record] -> ProtocolRevision -> Builder
932 | serializeRecords :: [record] -> ProtocolRevision -> Builder
933 | serializeRecords records rev = gSerializeRecords @columns rev (map from records)
934 |
935 | default columnsCount :: GenericClickHaskell record columns => UVarInt
936 | columnsCount :: UVarInt
937 | columnsCount = gColumnsCount @columns @(Rep record)
938 |
939 | class GClickHaskell (columns :: [Type]) f
940 | where
941 | gFromColumns :: Bool -> ProtocolRevision -> UVarInt -> Get [f p]
942 | gReadingColumns :: [(Builder, Builder)]
943 | gSerializeRecords :: ProtocolRevision -> [f p] -> Builder
944 | gColumnsCount :: UVarInt
945 |
946 | instance
947 | GClickHaskell columns f
948 | =>
949 | GClickHaskell columns (D1 c (C1 c2 f))
950 | where
951 | {-# INLINE gFromColumns #-}
952 | gFromColumns isCheckRequired rev size = map (M1 . M1) <$> gFromColumns @columns isCheckRequired rev size
953 | gReadingColumns = gReadingColumns @columns @f
954 | {-# INLINE gSerializeRecords #-}
955 | gSerializeRecords rev = gSerializeRecords @columns rev . map (unM1 . unM1)
956 | gColumnsCount = gColumnsCount @columns @f
957 |
958 | instance
959 | (GClickHaskell columns left, GClickHaskell columns right)
960 | =>
961 | GClickHaskell columns (left :*: right)
962 | where
963 | {-# INLINE gFromColumns #-}
964 | gFromColumns isCheckRequired rev size =
965 | liftA2 (zipWith (:*:))
966 | (gFromColumns @columns @left isCheckRequired rev size)
967 | (gFromColumns @columns @right isCheckRequired rev size)
968 | gReadingColumns = gReadingColumns @columns @left ++ gReadingColumns @columns @right
969 | {-# INLINE gSerializeRecords #-}
970 | gSerializeRecords rev xs =
971 | (\(ls,rs) -> gSerializeRecords @columns rev ls <> gSerializeRecords @columns rev rs)
972 | (foldr (\(l :*: r) (accL, accR) -> (l:accL, r:accR)) ([], []) xs)
973 | gColumnsCount = gColumnsCount @columns @left + gColumnsCount @columns @right
974 |
975 |
976 | instance
977 | ( KnownColumn (Column name chType)
978 | , SerializableColumn (Column name chType)
979 | , FromChType chType inputType
980 | , ToChType chType inputType
981 | , Column name chType ~ TakeColumn name columns
982 | ) => GClickHaskell columns ((S1 (MetaSel (Just name) a b f)) (Rec0 inputType))
983 | where
984 | {-# INLINE gFromColumns #-}
985 | gFromColumns isCheckRequired rev size =
986 | map (M1 . K1 . fromChType @chType) . columnValues
987 | <$> deserializeColumn @(Column name chType) rev isCheckRequired size
988 | gReadingColumns = (renderColumnName @(Column name chType), renderColumnType @(Column name chType)) : []
989 | {-# INLINE gSerializeRecords #-}
990 | gSerializeRecords rev = serializeColumn rev . mkColumn @(Column name chType) . map (toChType . unK1 . unM1)
991 | gColumnsCount = 1
992 |
993 |
994 | type family
995 | TakeColumn (name :: Symbol) (columns :: [Type]) :: Type
996 | where
997 | TakeColumn name columns = GoTakeColumn name columns '[]
998 |
999 | type family
1000 | GoTakeColumn name (columns :: [Type]) (acc :: [Type]) :: Type
1001 | where
1002 | GoTakeColumn name (Column name chType ': columns) acc = Column name chType
1003 | GoTakeColumn name (Column name1 chType ': columns) acc = (GoTakeColumn name columns (Column name1 chType ': acc))
1004 | GoTakeColumn name '[] acc = TypeError
1005 | ( 'Text "There is no column \"" :<>: 'Text name :<>: 'Text "\" in table"
1006 | :$$: 'Text "You can't use this field"
1007 | )
1008 |
1009 |
1010 | -- ** Column deserialization
1011 |
1012 | {-# SPECIALIZE replicateM :: Int -> Get chType -> Get [chType] #-}
1013 |
1014 | class SerializableColumn column where
1015 | deserializeColumn :: ProtocolRevision -> Bool -> UVarInt -> Get column
1016 | serializeColumn :: ProtocolRevision -> column -> Builder
1017 |
1018 | handleColumnHeader :: forall column . KnownColumn column => ProtocolRevision -> Bool -> Get ()
1019 | handleColumnHeader rev isCheckRequired = do
1020 | let expectedColumnName = toChType (renderColumnName @column)
1021 | resultColumnName <- deserialize @ChString rev
1022 | when (isCheckRequired && resultColumnName /= expectedColumnName)
1023 | . throw . UserError . UnmatchedColumn
1024 | $ "Got column \"" <> show resultColumnName <> "\" but expected \"" <> show expectedColumnName <> "\""
1025 |
1026 | let expectedType = toChType (renderColumnType @column)
1027 | resultType <- deserialize @ChString rev
1028 | when (isCheckRequired && resultType /= expectedType)
1029 | . throw . UserError . UnmatchedType
1030 | $ "Column " <> show resultColumnName <> " has type " <> show resultType <> ". But expected type is " <> show expectedType
1031 |
1032 | _isCustom <- deserialize @(UInt8 `SinceRevision` DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION) rev
1033 | pure ()
1034 |
1035 | instance
1036 | ( KnownColumn (Column name chType)
1037 | , Deserializable chType
1038 | , Serializable chType
1039 | , IsChType chType
1040 | ) =>
1041 | SerializableColumn (Column name chType) where
1042 | {-# INLINE deserializeColumn #-}
1043 | deserializeColumn rev isCheckRequired rows = do
1044 | handleColumnHeader @(Column name chType) rev isCheckRequired
1045 | mkColumn @(Column name chType)
1046 | <$> replicateM (fromIntegral rows) (deserialize @chType rev)
1047 |
1048 | {-# INLINE serializeColumn #-}
1049 | serializeColumn rev column
1050 | = serialize rev (toChType @ChString $ renderColumnName @(Column name chType))
1051 | <> serialize rev (toChType @ChString $ renderColumnType @(Column name chType))
1052 | -- serialization is not custom
1053 | <> afterRevision @DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION rev (serialize @UInt8 rev 0)
1054 | <> mconcat (Prelude.map (serialize @chType rev) (columnValues column))
1055 |
1056 | instance {-# OVERLAPPING #-}
1057 | ( KnownColumn (Column name (Nullable chType))
1058 | , Deserializable chType
1059 | , Serializable chType
1060 | , IsChType chType
1061 | ) =>
1062 | SerializableColumn (Column name (Nullable chType)) where
1063 | {-# INLINE deserializeColumn #-}
1064 | deserializeColumn rev isCheckRequired rows = do
1065 | handleColumnHeader @(Column name (Nullable chType)) rev isCheckRequired
1066 | nulls <- replicateM (fromIntegral rows) (deserialize @UInt8 rev)
1067 | mkColumn @(Column name (Nullable chType)) <$>
1068 | forM
1069 | nulls
1070 | (\case
1071 | 0 -> Just <$> deserialize @chType rev
1072 | _ -> (Nothing <$ deserialize @chType rev)
1073 | )
1074 |
1075 | {-# INLINE serializeColumn #-}
1076 | serializeColumn rev column
1077 | = serialize rev (toChType @ChString $ renderColumnName @(Column name (Nullable chType)))
1078 | <> serialize rev (toChType @ChString $ renderColumnType @(Column name (Nullable chType)))
1079 | -- serialization is not custom
1080 | <> afterRevision @DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION rev (serialize @UInt8 rev 0)
1081 | -- Nulls
1082 | <> mconcat (Prelude.map (serialize @UInt8 rev . maybe 1 (const 0)) (columnValues column))
1083 | -- Values
1084 | <> mconcat (Prelude.map (serialize @chType rev . maybe defaultValueOfTypeName id) (columnValues column))
1085 |
1086 | instance {-# OVERLAPPING #-}
1087 | ( KnownColumn (Column name (LowCardinality chType))
1088 | , Deserializable chType
1089 | , IsLowCardinalitySupported chType
1090 | , TypeError ('Text "LowCardinality deserialization still unsupported")
1091 | ) =>
1092 | SerializableColumn (Column name (LowCardinality chType)) where
1093 | {-# INLINE deserializeColumn #-}
1094 | deserializeColumn rev isCheckRequired rows = do
1095 | handleColumnHeader @(Column name (LowCardinality chType)) rev isCheckRequired
1096 | _serializationType <- (.&. 0xf) <$> deserialize @UInt64 rev
1097 | _index_size <- deserialize @Int64 rev
1098 | -- error $ "Trace | " <> show _serializationType <> " : " <> show _index_size
1099 | mkColumn @(Column name (LowCardinality chType))
1100 | <$> replicateM (fromIntegral rows) (toChType <$> deserialize @chType rev)
1101 |
1102 | {-# INLINE serializeColumn #-}
1103 | serializeColumn rev (LowCardinalityColumn column)
1104 | = serialize rev (toChType @ChString $ renderColumnName @(Column name (Nullable chType)))
1105 | <> serialize rev (toChType @ChString $ renderColumnType @(Column name (Nullable chType)))
1106 | -- serialization is not custom
1107 | <> afterRevision @DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION rev (serialize @UInt8 rev 0)
1108 | <> undefined column
1109 |
1110 | instance {-# OVERLAPPING #-}
1111 | ( KnownColumn (Column name (Array chType))
1112 | , Deserializable chType
1113 | , TypeError ('Text "Arrays deserialization still unsupported")
1114 | )
1115 | => SerializableColumn (Column name (Array chType)) where
1116 | {-# INLINE deserializeColumn #-}
1117 | deserializeColumn rev isCheckRequired _rows = do
1118 | handleColumnHeader @(Column name (Array chType)) rev isCheckRequired
1119 | (arraySize, _offsets) <- readOffsets rev
1120 | _types <- replicateM (fromIntegral arraySize) (deserialize @chType rev)
1121 | pure $ mkColumn @(Column name (Array chType)) []
1122 | where
1123 | readOffsets :: ProtocolRevision -> Get (UInt64, [UInt64])
1124 | readOffsets revivion = do
1125 | size <- deserialize @UInt64 rev
1126 | (size, ) <$> go size
1127 | where
1128 | go arraySize =
1129 | do
1130 | nextOffset <- deserialize @UInt64 revivion
1131 | if arraySize >= nextOffset
1132 | then pure [nextOffset]
1133 | else (nextOffset :) <$> go arraySize
1134 |
1135 | {-# INLINE serializeColumn #-}
1136 | serializeColumn _rev _column = undefined
1137 |
1138 | -- ** Generics
1139 |
1140 | class
1141 | Deserializable chType
1142 | where
1143 | {-# INLINE deserialize #-}
1144 | default deserialize :: (Generic chType, GDeserial (Rep chType)) => ProtocolRevision -> Get chType
1145 | deserialize :: ProtocolRevision -> Get chType
1146 | deserialize rev = to <$> gDeserialize rev
1147 |
1148 | class GDeserial f
1149 | where
1150 | gDeserialize :: ProtocolRevision -> Get (f p)
1151 |
1152 | instance GDeserial f => GDeserial (D1 c (C1 c2 f))
1153 | where
1154 | gDeserialize rev = M1 . M1 <$> gDeserialize rev
1155 | {-# INLINE gDeserialize #-}
1156 |
1157 | instance (GDeserial left, GDeserial right) => GDeserial (left :*: right) where
1158 | gDeserialize rev = liftA2 (:*:) (gDeserialize rev) (gDeserialize rev)
1159 | {-# INLINE gDeserialize #-}
1160 |
1161 | instance {-# OVERLAPPING #-}
1162 | GDeserial right => GDeserial (S1 metaSel (Rec0 ProtocolRevision) :*: right) where
1163 | gDeserialize rev = do
1164 | chosenRev <- min rev . coerce <$> deserialize @UVarInt rev
1165 | liftA2 (:*:) (pure . M1 . K1 $ chosenRev) (gDeserialize @right chosenRev)
1166 | {-# INLINE gDeserialize #-}
1167 |
1168 | instance
1169 | Deserializable chType
1170 | =>
1171 | GDeserial (S1 metaSel (Rec0 chType))
1172 | where
1173 | {-# INLINE gDeserialize #-}
1174 | gDeserialize rev = M1 . K1 <$> deserialize @chType rev
1175 |
1176 |
1177 | -- ** Database types
1178 |
1179 | instance Deserializable Int8 where deserialize _ = toChType <$> getInt8; {-# INLINE deserialize #-}
1180 | instance Deserializable Int16 where deserialize _ = toChType <$> getInt16le; {-# INLINE deserialize #-}
1181 | instance Deserializable Int32 where deserialize _ = toChType <$> getInt32le; {-# INLINE deserialize #-}
1182 | instance Deserializable Int64 where deserialize _ = toChType <$> getInt64le; {-# INLINE deserialize #-}
1183 | instance Deserializable Int128 where deserialize _ = toChType <$> liftA2 (flip Int128) getWord64le getWord64le; {-# INLINE deserialize #-}
1184 | instance Deserializable UInt8 where deserialize _ = toChType <$> getWord8; {-# INLINE deserialize #-}
1185 | instance Deserializable UInt16 where deserialize _ = toChType <$> getWord16le; {-# INLINE deserialize #-}
1186 | instance Deserializable UInt32 where deserialize _ = toChType <$> getWord32le; {-# INLINE deserialize #-}
1187 | instance Deserializable UInt64 where deserialize _ = toChType <$> getWord64le; {-# INLINE deserialize #-}
1188 | instance Deserializable UInt128 where deserialize _ = toChType <$> liftA2 (flip Word128) getWord64le getWord64le; {-# INLINE deserialize #-}
1189 | instance Deserializable UUID where deserialize _ = MkChUUID <$> liftA2 (flip Word128) getWord64le getWord64le; {-# INLINE deserialize #-}
1190 | instance Deserializable Date where deserialize _ = toChType <$> getWord16le; {-# INLINE deserialize #-}
1191 | instance Deserializable (DateTime tz) where deserialize _ = toChType <$> getWord32le; {-# INLINE deserialize #-}
1192 | instance Deserializable (DateTime64 precision tz) where deserialize _ = toChType <$> getWord64le; {-# INLINE deserialize #-}
1193 | instance Deserializable ChString where
1194 | {-# INLINE deserialize #-}
1195 | deserialize = (\n -> toChType <$> readN n (BS.take n)) . fromIntegral <=< deserialize @UVarInt
1196 | instance Deserializable UVarInt where
1197 | {-# INLINE deserialize #-}
1198 | deserialize _ = go 0 (0 :: UVarInt)
1199 | where
1200 | go i o | i < 10 = do
1201 | byte <- getWord8
1202 | let o' = o .|. ((fromIntegral byte .&. 0x7f) `unsafeShiftL` (7 * i))
1203 | if byte .&. 0x80 == 0 then pure $! o' else go (i + 1) $! o'
1204 | go _ _ = fail "input exceeds varuint size"
1205 |
1206 | -- ** FromChType
1207 |
1208 | class FromChType chType outputType where fromChType :: chType -> outputType
1209 |
1210 | instance FromChType UUID (Word64, Word64) where fromChType (MkChUUID (Word128 w64hi w64lo)) = (w64hi, w64lo)
1211 | instance {-# OVERLAPPABLE #-} (IsChType chType, chType ~ inputType) => FromChType chType inputType where fromChType = id
1212 | instance FromChType (DateTime tz) Word32 where fromChType = coerce
1213 | instance FromChType (DateTime tz) UTCTime where fromChType (MkDateTime w32) = posixSecondsToUTCTime (fromIntegral w32)
1214 | instance FromChType (DateTime64 precision tz) Word64 where fromChType = coerce
1215 | instance
1216 | FromChType chType inputType
1217 | =>
1218 | FromChType (Nullable chType) (Nullable inputType)
1219 | where
1220 | fromChType = fmap (fromChType @chType)
1221 | instance FromChType chType (LowCardinality chType) where
1222 | fromChType = MkLowCardinality
1223 | instance FromChType Date Word16 where fromChType = coerce
1224 | instance
1225 | FromChType chType outputType
1226 | =>
1227 | FromChType (LowCardinality chType) outputType
1228 | where
1229 | fromChType (MkLowCardinality value) = fromChType value
1230 | instance FromChType ChString BS.ByteString where fromChType (MkChString string) = string
1231 | instance FromChType ChString Builder where fromChType (MkChString string) = byteString string
1232 | instance
1233 | ( TypeError
1234 | ( 'Text "ChString to Text using FromChType convertion could cause exception"
1235 | ':$$: 'Text "Decode ByteString manually if you are sure it's always can be decoded or replace it with ByteString"
1236 | )
1237 | ) =>
1238 | FromChType ChString Text
1239 | where
1240 | fromChType = error "Unreachable"
1241 | instance FromChType chType inputType => FromChType (Array chType) [inputType]
1242 | where
1243 | fromChType (MkChArray values) = map fromChType values
1244 |
1245 |
1246 |
1247 |
1248 |
1249 |
1250 |
1251 |
1252 | -- * Column
1253 |
1254 | {- |
1255 | Column declaration
1256 |
1257 | For example:
1258 |
1259 | @
1260 | type MyColumn = Column "myColumn" ChString
1261 | @
1262 | -}
1263 | data Column (name :: Symbol) (chType :: Type) where
1264 | UInt8Column :: [UInt8] -> Column name UInt8; Int8Column :: [Int8] -> Column name Int8
1265 | UInt16Column :: [UInt16] -> Column name UInt16; Int16Column :: [Int16] -> Column name Int16
1266 | UInt32Column :: [UInt32] -> Column name UInt32; Int32Column :: [Int32] -> Column name Int32
1267 | UInt64Column :: [UInt64] -> Column name UInt64; Int64Column :: [Int64] -> Column name Int64
1268 | UInt128Column :: [UInt128] -> Column name UInt128; Int128Column :: [Int128] -> Column name Int128
1269 | DateTimeColumn :: [DateTime tz] -> Column name (DateTime tz)
1270 | DateTime64Column :: [DateTime64 precision tz] -> Column name (DateTime64 precision tz)
1271 | DateColumn :: [Date] -> Column name Date
1272 | UUIDColumn :: [UUID] -> Column name UUID
1273 | StringColumn :: [ChString] -> Column name ChString
1274 | ArrayColumn :: [Array chType] -> Column name (Array chType)
1275 | NullableColumn :: [Nullable chType] -> Column name (Nullable chType)
1276 | LowCardinalityColumn :: IsLowCardinalitySupported chType => [chType] -> Column name (LowCardinality chType)
1277 |
1278 | type family GetColumnName column :: Symbol where GetColumnName (Column name columnType) = name
1279 | type family GetColumnType column :: Type where GetColumnType (Column name columnType) = columnType
1280 |
1281 | {-# INLINE [0] columnValues #-}
1282 | columnValues :: Column name chType -> [chType]
1283 | columnValues column = case column of
1284 | (UInt8Column values) -> values; (UInt16Column values) -> values
1285 | (UInt32Column values) -> values; (UInt64Column values) -> values
1286 | (UInt128Column values) -> values; (Int8Column values) -> values
1287 | (Int16Column values) -> values; (Int32Column values) -> values
1288 | (Int64Column values) -> values; (Int128Column values) -> values
1289 | (DateColumn values) -> values; (DateTimeColumn values) -> values; (DateTime64Column values) -> values;
1290 | (UUIDColumn values) -> values; (StringColumn values) -> values
1291 | (ArrayColumn values) -> values; (NullableColumn values) -> values
1292 | (LowCardinalityColumn values) -> map fromChType values
1293 |
1294 | class
1295 | ( IsChType (GetColumnType column)
1296 | , KnownSymbol (GetColumnName column)
1297 | ) =>
1298 | KnownColumn column where
1299 | renderColumnName :: Builder
1300 | renderColumnName = (stringUtf8 . symbolVal @(GetColumnName column)) Proxy
1301 |
1302 | renderColumnType :: Builder
1303 | renderColumnType = byteString . BS8.pack $ chTypeName @(GetColumnType column)
1304 |
1305 | mkColumn :: [GetColumnType column] -> Column (GetColumnName column) (GetColumnType column)
1306 |
1307 | instance KnownSymbol name => KnownColumn (Column name UInt8) where mkColumn = UInt8Column
1308 | instance KnownSymbol name => KnownColumn (Column name UInt16) where mkColumn = UInt16Column
1309 | instance KnownSymbol name => KnownColumn (Column name UInt32) where mkColumn = UInt32Column
1310 | instance KnownSymbol name => KnownColumn (Column name UInt64) where mkColumn = UInt64Column
1311 | instance KnownSymbol name => KnownColumn (Column name UInt128) where mkColumn = UInt128Column
1312 | instance KnownSymbol name => KnownColumn (Column name Int8) where mkColumn = Int8Column
1313 | instance KnownSymbol name => KnownColumn (Column name Int16) where mkColumn = Int16Column
1314 | instance KnownSymbol name => KnownColumn (Column name Int32) where mkColumn = Int32Column
1315 | instance KnownSymbol name => KnownColumn (Column name Int64) where mkColumn = Int64Column
1316 | instance KnownSymbol name => KnownColumn (Column name Int128) where mkColumn = Int128Column
1317 | instance KnownSymbol name => KnownColumn (Column name Date) where mkColumn = DateColumn
1318 | instance
1319 | ( KnownSymbol name
1320 | , IsChType (DateTime tz)
1321 | ) =>
1322 | KnownColumn (Column name (DateTime tz)) where mkColumn = DateTimeColumn
1323 | instance
1324 | ( KnownSymbol name
1325 | , IsChType (DateTime64 precision tz)
1326 | ) =>
1327 | KnownColumn (Column name (DateTime64 precision tz)) where mkColumn = DateTime64Column
1328 | instance KnownSymbol name => KnownColumn (Column name UUID) where mkColumn = UUIDColumn
1329 | instance
1330 | ( KnownSymbol name
1331 | , IsChType chType
1332 | , IsChType (Nullable chType)
1333 | ) =>
1334 | KnownColumn (Column name (Nullable chType)) where mkColumn = NullableColumn
1335 | instance KnownSymbol name => KnownColumn (Column name ChString) where mkColumn = StringColumn
1336 | instance
1337 | ( KnownSymbol name
1338 | , IsChType (LowCardinality chType)
1339 | , IsLowCardinalitySupported chType
1340 | ) =>
1341 | KnownColumn (Column name (LowCardinality chType)) where mkColumn = LowCardinalityColumn . map fromChType
1342 | instance KnownSymbol name => KnownColumn (Column name (Array ChString)) where mkColumn = ArrayColumn
1343 |
1344 |
1345 |
1346 |
1347 |
1348 |
1349 |
1350 |
1351 | -- * Parameters
1352 |
1353 | type family KnownParameter param
1354 | where
1355 | KnownParameter (Parameter name parType) = (KnownSymbol name, IsChType parType, ToQueryPart parType)
1356 |
1357 | data Parameter (name :: Symbol) (chType :: Type) = MkParamater chType
1358 |
1359 | data Parameters parameters where
1360 | NoParameters :: Parameters '[]
1361 | AddParameter
1362 | :: KnownParameter (Parameter name chType)
1363 | => Parameter name chType
1364 | -> Parameters parameters
1365 | -> Parameters (Parameter name chType ': parameters)
1366 |
1367 | {- |
1368 | >>> viewParameters (parameter @"a3" @ChString ("a3Val" :: String) . parameter @"a2" @ChString ("a2Val" :: String))
1369 | "(a3='a3Val', a2='a2Val')"
1370 | -}
1371 | viewParameters :: (Parameters '[] -> Parameters passedParameters) -> Builder
1372 | viewParameters interpreter = "(" <> renderParameters (interpreter NoParameters) <> ")"
1373 |
1374 | renderParameters :: Parameters params -> Builder
1375 | renderParameters NoParameters = ""
1376 | renderParameters (AddParameter param NoParameters) = renderParameter param
1377 | renderParameters (AddParameter param moreParams) = renderParameter param <> ", " <> renderParameters moreParams
1378 |
1379 |
1380 | parameter
1381 | :: forall name chType parameters userType
1382 | . (ToChType chType userType, KnownParameter (Parameter name chType))
1383 | => userType -> Parameters parameters -> Parameters (Parameter name chType ': parameters)
1384 | parameter val = AddParameter (MkParamater $ toChType val)
1385 |
1386 | renderParameter :: forall name chType . KnownParameter (Parameter name chType) => Parameter name chType -> Builder
1387 | renderParameter (MkParamater chType) = (byteString . BS8.pack . symbolVal @name) Proxy <> "=" <> toQueryPart chType
1388 |
1389 |
1390 | class ToQueryPart chType where toQueryPart :: chType -> BS.Builder
1391 | instance ToQueryPart Int8 where toQueryPart = byteString . BS8.pack . show
1392 | instance ToQueryPart Int16 where toQueryPart = byteString . BS8.pack . show
1393 | instance ToQueryPart Int32 where toQueryPart = byteString . BS8.pack . show
1394 | instance ToQueryPart Int64 where toQueryPart = byteString . BS8.pack . show
1395 | instance ToQueryPart Int128 where toQueryPart = byteString . BS8.pack . show
1396 | instance ToQueryPart UInt8 where toQueryPart = byteString . BS8.pack . show
1397 | instance ToQueryPart UInt16 where toQueryPart = byteString . BS8.pack . show
1398 | instance ToQueryPart UInt32 where toQueryPart = byteString . BS8.pack . show
1399 | instance ToQueryPart UInt64 where toQueryPart = byteString . BS8.pack . show
1400 | instance ToQueryPart UInt128 where toQueryPart = byteString . BS8.pack . show
1401 | instance ToQueryPart chType => ToQueryPart (Nullable chType)
1402 | where
1403 | toQueryPart = maybe "null" toQueryPart
1404 | instance ToQueryPart chType => ToQueryPart (LowCardinality chType)
1405 | where
1406 | toQueryPart (MkLowCardinality chType) = toQueryPart chType
1407 | instance ToQueryPart UUID where
1408 | toQueryPart (MkChUUID (Word128 hi lo)) = mconcat
1409 | ["'", p 3 hi, p 2 hi, "-", p 1 hi, "-", p 0 hi, "-", p 3 lo, "-", p 2 lo, p 1 lo, p 0 lo, "'"]
1410 | where
1411 | p :: Int -> Word64 -> Builder
1412 | p shiftN word = word16HexFixed $ fromIntegral (word `unsafeShiftR` (shiftN*16))
1413 | instance ToQueryPart ChString where
1414 | toQueryPart (MkChString string) = "'" <> escapeQuery string <> "'"
1415 | where
1416 | escapeQuery :: BS.ByteString -> Builder
1417 | escapeQuery = byteString . BS8.concatMap (\case '\'' -> "\\\'"; '\\' -> "\\\\"; sym -> singleton sym;)
1418 |
1419 | -- ToDo: Need to be fixed
1420 | -- instance ToQueryPart (DateTime64 precision tz)
1421 | -- where
1422 | -- toQueryPart chDateTime =
1423 | -- let time = BS8.pack . show . fromChType @_ @Word64 $ chDateTime
1424 | -- in byteString (BS8.replicate (12 - BS8.length time) '0' <> time)
1425 |
1426 | instance ToQueryPart (DateTime tz)
1427 | where
1428 | toQueryPart chDateTime = let time = BS8.pack . show . fromChType @(DateTime tz) @Word32 $ chDateTime
1429 | in byteString (BS8.replicate (10 - BS8.length time) '0' <> time)
1430 | instance (IsChType chType, ToQueryPart chType) => ToQueryPart (Array chType)
1431 | where
1432 | toQueryPart
1433 | = (\x -> "[" <> x <> "]")
1434 | . (maybe "" (uncurry (foldr (\a b -> a <> "," <> b))) . uncons
1435 | . map (toQueryPart @chType)) . fromChType @(Array chType) @[chType]
1436 |
1437 |
1438 |
1439 |
1440 |
1441 |
1442 |
1443 |
1444 | -- * Serialization
1445 |
1446 | -- *** Generic API
1447 |
1448 | class Serializable chType
1449 | where
1450 | default serialize :: (Generic chType, GSerial (Rep chType)) => ProtocolRevision -> chType -> Builder
1451 | serialize :: ProtocolRevision -> chType -> Builder
1452 | serialize rev = gSerialize rev . from
1453 |
1454 | instance Serializable UVarInt where
1455 | serialize _ = go
1456 | where
1457 | go i
1458 | | i < 0x80 = word8 (fromIntegral i)
1459 | | otherwise = word8 (setBit (fromIntegral i) 7) <> go (i `unsafeShiftR` 7)
1460 | instance Serializable ChString where
1461 | serialize rev str = (serialize @UVarInt rev . fromIntegral . BS.length . fromChType) str <> fromChType str
1462 | instance Serializable UUID where serialize _ = (\(hi, lo) -> word64LE lo <> word64LE hi) . fromChType
1463 | instance Serializable Int8 where serialize _ = int8 . fromChType
1464 | instance Serializable Int16 where serialize _ = int16LE . fromChType
1465 | instance Serializable Int32 where serialize _ = int32LE . fromChType
1466 | instance Serializable Int64 where serialize _ = int64LE . fromChType
1467 | instance Serializable Int128 where serialize _ = (\(Int128 hi lo) -> word64LE lo <> word64LE hi) . fromChType
1468 | instance Serializable UInt8 where serialize _ = word8 . fromChType
1469 | instance Serializable UInt16 where serialize _ = word16LE . fromChType
1470 | instance Serializable UInt32 where serialize _ = word32LE . fromChType
1471 | instance Serializable UInt64 where serialize _ = word64LE . fromChType
1472 | instance Serializable UInt128 where serialize _ = (\(Word128 hi lo) -> word64LE lo <> word64LE hi) . fromChType
1473 | instance Serializable (DateTime tz) where serialize _ = word32LE . fromChType
1474 | instance Serializable (DateTime64 precision tz) where serialize _ = word64LE . fromChType
1475 | instance Serializable Date where serialize _ = word16LE . fromChType
1476 |
1477 |
1478 | -- ** Generics
1479 |
1480 | class GSerial f where
1481 | gSerialize :: ProtocolRevision -> f p -> Builder
1482 |
1483 | instance GSerial f => GSerial (D1 c (C1 c2 f)) where
1484 | gSerialize rev (M1 (M1 re)) = gSerialize rev re
1485 | {-# INLINE gSerialize #-}
1486 |
1487 | instance (GSerial left1, GSerial right) => GSerial (left1 :*: right) where
1488 | gSerialize rev (l :*: r) = gSerialize rev l <> gSerialize rev r
1489 | {-# INLINE gSerialize #-}
1490 |
1491 | instance Serializable chType => GSerial (S1 metaSel (Rec0 chType)) where
1492 | gSerialize rev (M1 (K1 re)) = serialize rev re
1493 | {-# INLINE gSerialize #-}
1494 |
1495 |
1496 | -- ** ToChType
1497 |
1498 | class ToChType chType inputType where toChType :: inputType -> chType
1499 |
1500 | instance {-# OVERLAPPABLE #-} (IsChType chType, chType ~ inputType) => ToChType chType inputType where toChType = id
1501 | instance ToChType Int64 Int where toChType = fromIntegral
1502 | instance ToChType UInt128 UInt64 where toChType = fromIntegral
1503 | instance ToChType ChString BS.ByteString where toChType = MkChString
1504 | instance ToChType ChString Builder where toChType = MkChString . toStrict . toLazyByteString
1505 | instance ToChType ChString String where toChType = MkChString . BS8.pack
1506 | instance ToChType ChString Text where toChType = MkChString . Text.encodeUtf8
1507 | instance ToChType ChString Int where toChType = MkChString . BS8.pack . show
1508 | instance
1509 | ToChType inputType chType
1510 | =>
1511 | ToChType (Nullable inputType) (Nullable chType)
1512 | where
1513 | toChType = fmap (toChType @inputType @chType)
1514 | instance ToChType inputType chType => ToChType (LowCardinality inputType) chType where toChType = MkLowCardinality . toChType
1515 | instance ToChType UUID Word64 where toChType = MkChUUID . flip Word128 0
1516 | instance ToChType UUID (Word64, Word64) where toChType = MkChUUID . uncurry (flip Word128)
1517 | instance ToChType (DateTime tz) Word32 where toChType = MkDateTime
1518 | instance ToChType (DateTime tz) UTCTime where toChType = MkDateTime . floor . utcTimeToPOSIXSeconds
1519 | instance ToChType (DateTime tz) ZonedTime where toChType = MkDateTime . floor . utcTimeToPOSIXSeconds . zonedTimeToUTC
1520 | instance ToChType (DateTime64 precision tz) Word64 where toChType = MkDateTime64
1521 | instance ToChType Date Word16 where toChType = MkChDate
1522 | instance ToChType chType inputType => ToChType (Array chType) [inputType]
1523 | where
1524 | toChType = MkChArray . map toChType
1525 |
1526 |
1527 |
1528 |
1529 |
1530 |
1531 |
1532 |
1533 | class IsChType chType
1534 | where
1535 | -- | Shows database original type name
1536 | --
1537 | -- @
1538 | -- chTypeName \@ChString = \"String\"
1539 | -- chTypeName \@(Nullable UInt32) = \"Nullable(UInt32)\"
1540 | -- @
1541 | chTypeName :: String
1542 |
1543 | defaultValueOfTypeName :: chType
1544 |
1545 | instance IsChType Int8 where; chTypeName = "Int8"; defaultValueOfTypeName = 0
1546 | instance IsChType Int16 where; chTypeName = "Int16"; defaultValueOfTypeName = 0
1547 | instance IsChType Int32 where; chTypeName = "Int32"; defaultValueOfTypeName = 0
1548 | instance IsChType Int64 where; chTypeName = "Int64"; defaultValueOfTypeName = 0
1549 | instance IsChType Int128 where; chTypeName = "Int128"; defaultValueOfTypeName = 0
1550 |
1551 | {- | ClickHouse UInt8 column type -}
1552 | type UInt8 = Word8
1553 | instance IsChType UInt8 where; chTypeName = "UInt8"; defaultValueOfTypeName = 0
1554 |
1555 | {- | ClickHouse UInt16 column type -}
1556 | type UInt16 = Word16
1557 | instance IsChType UInt16 where; chTypeName = "UInt16"; defaultValueOfTypeName = 0
1558 |
1559 | {- | ClickHouse UInt32 column type -}
1560 | type UInt32 = Word32
1561 | instance IsChType UInt32 where; chTypeName = "UInt32"; defaultValueOfTypeName = 0
1562 |
1563 | {- | ClickHouse UInt64 column type -}
1564 | type UInt64 = Word64
1565 | instance IsChType UInt64 where; chTypeName = "UInt64"; defaultValueOfTypeName = 0
1566 |
1567 | {- | ClickHouse UInt128 column type -}
1568 | type UInt128 = Word128
1569 | instance IsChType UInt128 where; chTypeName = "UInt128"; defaultValueOfTypeName = 0
1570 |
1571 | {- | ClickHouse Date column type -}
1572 | newtype Date = MkChDate Word16
1573 | deriving newtype (Show, Eq, Bits, Bounded, Enum, NFData, Num)
1574 | instance IsChType Date where; chTypeName = "Date"; defaultValueOfTypeName = 0
1575 |
1576 | {- | ClickHouse String column type -}
1577 | newtype ChString = MkChString BS.ByteString
1578 | deriving newtype (Show, Eq, IsString, NFData)
1579 | instance IsChType ChString where; chTypeName = "String"; defaultValueOfTypeName = ""
1580 |
1581 | {- | ClickHouse UUID column type -}
1582 | newtype UUID = MkChUUID Word128
1583 | deriving newtype (Generic, Show, Eq, NFData, Bounded, Enum, Num)
1584 | instance IsChType UUID where; chTypeName = "UUID"; defaultValueOfTypeName = 0
1585 |
1586 | {- | ClickHouse Nullable(T) column type
1587 | (type synonym for Maybe)
1588 | -}
1589 | type Nullable = Maybe
1590 | instance IsChType chType => IsChType (Nullable chType)
1591 | where
1592 | chTypeName = "Nullable(" <> chTypeName @chType <> ")"
1593 | defaultValueOfTypeName = Nothing
1594 |
1595 | {- |
1596 | ClickHouse DateTime column type (paramtrized with timezone)
1597 |
1598 | >>> chTypeName @(DateTime "")
1599 | "DateTime"
1600 | >>> chTypeName @(DateTime "UTC")
1601 | "DateTime('UTC')"
1602 | -}
1603 | newtype DateTime (tz :: Symbol) = MkDateTime Word32
1604 | deriving newtype (Show, Eq, Num, Bits, Enum, Ord, Real, Integral, Bounded, NFData)
1605 |
1606 | type DateTimeTypeName tz = If (tz == "") ("DateTime") ("DateTime('" `AppendSymbol` tz `AppendSymbol` "')")
1607 |
1608 | instance KnownSymbol (DateTimeTypeName tz) => IsChType (DateTime tz)
1609 | where
1610 | chTypeName = symbolVal @(DateTimeTypeName tz) $ Proxy
1611 | defaultValueOfTypeName = MkDateTime 0
1612 |
1613 | {- |
1614 | ClickHouse DateTime64 column type (paramtrized with timezone)
1615 |
1616 | >>> chTypeName @(DateTime64 3 "")
1617 | "DateTime64(3)"
1618 | >>> chTypeName @(DateTime64 3 "UTC")
1619 | "DateTime64(3, 'UTC')"
1620 | -}
1621 | newtype DateTime64 (precision :: Nat) (tz :: Symbol) = MkDateTime64 Word64
1622 | deriving newtype (Show, Eq, Num, Bits, Enum, Ord, Real, Integral, Bounded, NFData)
1623 |
1624 | instance
1625 | (KnownSymbol tz, KnownNat precision)
1626 | =>
1627 | IsChType (DateTime64 precision tz)
1628 | where
1629 | chTypeName =
1630 | let
1631 | prec = show (natVal @precision Proxy)
1632 | tz = symbolVal @tz Proxy
1633 | in
1634 | case tz of
1635 | "" -> "DateTime64(" <> prec <> ")"
1636 | _ -> "DateTime64(" <> prec <> ", '" <> tz <> "')"
1637 | defaultValueOfTypeName = MkDateTime64 0
1638 |
1639 |
1640 | -- | ClickHouse Array column type
1641 | newtype Array a = MkChArray [a]
1642 | deriving newtype (Show, Eq, NFData)
1643 | instance IsChType chType => IsChType (Array chType)
1644 | where
1645 | chTypeName = "Array(" <> chTypeName @chType <> ")"
1646 | defaultValueOfTypeName = MkChArray []
1647 |
1648 | -- | ClickHouse LowCardinality(T) column type
1649 | newtype LowCardinality chType = MkLowCardinality chType
1650 | instance IsLowCardinalitySupported chType => IsChType (LowCardinality chType)
1651 | where
1652 | chTypeName = "LowCardinality(" <> chTypeName @chType <> ")"
1653 | defaultValueOfTypeName = MkLowCardinality $ defaultValueOfTypeName @chType
1654 |
1655 | deriving newtype instance (Eq chType, IsLowCardinalitySupported chType) => Eq (LowCardinality chType)
1656 | deriving newtype instance (NFData chType, IsLowCardinalitySupported chType) => NFData (LowCardinality chType)
1657 | deriving newtype instance IsString (LowCardinality ChString)
1658 |
1659 | class IsChType chType => IsLowCardinalitySupported chType
1660 | instance IsLowCardinalitySupported ChString
1661 | instance
1662 | ( IsLowCardinalitySupported chType
1663 | , IsChType (Nullable chType)
1664 | ) =>
1665 | IsLowCardinalitySupported (Nullable chType)
1666 |
1667 | instance {-# OVERLAPPABLE #-}
1668 | ( IsChType chType
1669 | , TypeError
1670 | ( 'Text "LowCardinality(" ':<>: 'ShowType chType ':<>: 'Text ") is unsupported"
1671 | ':$$: 'Text "Use one of these types:"
1672 | ':$$: 'Text " ChString"
1673 | ':$$: 'Text " DateTime"
1674 | ':$$: 'Text " Nullable(T)"
1675 | )
1676 | ) => IsLowCardinalitySupported chType
1677 |
1678 |
1679 |
1680 |
1681 |
1682 |
1683 |
1684 |
1685 | -- * Protocol parts
1686 |
1687 | {- |
1688 | Unsigned variable-length quantity encoding
1689 |
1690 | Part of protocol implementation
1691 | -}
1692 | newtype UVarInt = MkUVarInt Word64
1693 | deriving newtype (Show, Eq, Num, Bits, Enum, Ord, Real, Integral, Bounded, NFData)
1694 |
1695 |
1696 | major, minor, patch :: UVarInt
1697 | major = case versionBranch version of (x:_) -> fromIntegral x; _ -> 0
1698 | minor = case versionBranch version of (_:x:_) -> fromIntegral x; _ -> 0
1699 | patch = case versionBranch version of (_:_:x:_) -> fromIntegral x; _ -> 0
1700 |
1701 | clientName :: ChString
1702 | clientName = fromString $
1703 | "ClickHaskell-" <> show major <> "." <> show minor <> "." <> show patch
1704 |
1705 | newtype ProtocolRevision = MkProtocolRevision UVarInt
1706 | deriving newtype (Eq, Num, Ord, Serializable)
1707 |
1708 | {-# INLINE [0] afterRevision #-}
1709 | afterRevision
1710 | :: forall rev monoid
1711 | . (KnownNat rev, Monoid monoid)
1712 | => ProtocolRevision -> monoid -> monoid
1713 | afterRevision chosenRevision monoid =
1714 | if chosenRevision >= (fromIntegral . natVal) (Proxy @rev)
1715 | then monoid
1716 | else mempty
1717 |
1718 | latestSupportedRevision :: ProtocolRevision
1719 | latestSupportedRevision = (fromIntegral . natVal) (Proxy @DBMS_TCP_PROTOCOL_VERSION)
1720 |
1721 | data SinceRevision a (revisionNumber :: Nat) = MkSinceRevision a | NotPresented
1722 |
1723 | instance
1724 | (KnownNat revision, Deserializable chType)
1725 | =>
1726 | Deserializable (SinceRevision chType revision)
1727 | where
1728 | deserialize rev =
1729 | if rev >= (fromIntegral . natVal) (Proxy @revision)
1730 | then MkSinceRevision <$> deserialize @chType rev
1731 | else pure NotPresented
1732 |
1733 | instance
1734 | (KnownNat revision, Serializable chType)
1735 | =>
1736 | Serializable (SinceRevision chType revision)
1737 | where
1738 | serialize rev (MkSinceRevision val) = afterRevision @revision rev (serialize rev val)
1739 | serialize rev NotPresented = afterRevision @revision rev (error "Unexpected error")
1740 |
1741 |
1742 | {-
1743 | Slightly modified C++ sources:
1744 | https://github.com/ClickHouse/ClickHouse/blob/eb4a74d7412a1fcf52727cd8b00b365d6b9ed86c/src/Core/ProtocolDefines.h#L6
1745 | -}
1746 | type DBMS_TCP_PROTOCOL_VERSION = 54448;
1747 |
1748 | type DBMS_MIN_REVISION_WITH_CLIENT_INFO = 54032;
1749 | type DBMS_MIN_REVISION_WITH_SERVER_TIMEZONE = 54058;
1750 | type DBMS_MIN_REVISION_WITH_QUOTA_KEY_IN_CLIENT_INFO = 54060;
1751 | type DBMS_MIN_REVISION_WITH_TABLES_STATUS = 54226;
1752 | type DBMS_MIN_REVISION_WITH_TIME_ZONE_PARAMETER_IN_DATETIME_DATA_TYPE = 54337;
1753 | type DBMS_MIN_REVISION_WITH_SERVER_DISPLAY_NAME = 54372;
1754 | type DBMS_MIN_REVISION_WITH_VERSION_PATCH = 54401;
1755 | type DBMS_MIN_REVISION_WITH_SERVER_LOGS = 54406;
1756 | type DBMS_MIN_REVISION_WITH_CURRENT_AGGREGATION_VARIANT_SELECTION_METHOD = 54448;
1757 | type DBMS_MIN_MAJOR_VERSION_WITH_CURRENT_AGGREGATION_VARIANT_SELECTION_METHOD = 21;
1758 | type DBMS_MIN_MINOR_VERSION_WITH_CURRENT_AGGREGATION_VARIANT_SELECTION_METHOD = 4;
1759 | type DBMS_MIN_REVISION_WITH_COLUMN_DEFAULTS_METADATA = 54410;
1760 | type DBMS_MIN_REVISION_WITH_LOW_CARDINALITY_TYPE = 54405;
1761 | type DBMS_MIN_REVISION_WITH_CLIENT_WRITE_INFO = 54420;
1762 | type DBMS_MIN_REVISION_WITH_SETTINGS_SERIALIZED_AS_STRINGS = 54429;
1763 | type DBMS_MIN_REVISION_WITH_SCALARS = 54429;
1764 | type DBMS_MIN_REVISION_WITH_OPENTELEMETRY = 54442;
1765 | type DBMS_MIN_REVISION_WITH_AGGREGATE_FUNCTIONS_VERSIONING = 54452;
1766 | type DBMS_CLUSTER_PROCESSING_PROTOCOL_VERSION = 1;
1767 | type DBMS_MIN_SUPPORTED_PARALLEL_REPLICAS_PROTOCOL_VERSION = 3;
1768 | type DBMS_PARALLEL_REPLICAS_MIN_VERSION_WITH_MARK_SEGMENT_SIZE_FIELD = 4;
1769 | type DBMS_PARALLEL_REPLICAS_PROTOCOL_VERSION = 4;
1770 | type DBMS_MIN_REVISION_WITH_PARALLEL_REPLICAS = 54453;
1771 | type DBMS_MERGE_TREE_PART_INFO_VERSION = 1;
1772 | type DBMS_MIN_REVISION_WITH_INTERSERVER_SECRET = 54441;
1773 | type DBMS_MIN_REVISION_WITH_X_FORWARDED_FOR_IN_CLIENT_INFO = 54443;
1774 | type DBMS_MIN_REVISION_WITH_REFERER_IN_CLIENT_INFO = 54447;
1775 | type DBMS_MIN_PROTOCOL_VERSION_WITH_DISTRIBUTED_DEPTH = 54448;
1776 | type DBMS_MIN_PROTOCOL_VERSION_WITH_INCREMENTAL_PROFILE_EVENTS = 54451;
1777 | type DBMS_MIN_REVISION_WITH_CUSTOM_SERIALIZATION = 54454;
1778 | type DBMS_MIN_PROTOCOL_VERSION_WITH_INITIAL_QUERY_START_TIME = 54449;
1779 | type DBMS_MIN_PROTOCOL_VERSION_WITH_PROFILE_EVENTS_IN_INSERT = 54456;
1780 | type DBMS_MIN_PROTOCOL_VERSION_WITH_VIEW_IF_PERMITTED = 54457;
1781 | type DBMS_MIN_PROTOCOL_VERSION_WITH_ADDENDUM = 54458;
1782 | type DBMS_MIN_PROTOCOL_VERSION_WITH_QUOTA_KEY = 54458;
1783 | type DBMS_MIN_PROTOCOL_VERSION_WITH_PARAMETERS = 54459;
1784 | type DBMS_MIN_PROTOCOL_VERSION_WITH_SERVER_QUERY_TIME_IN_PROGRESS = 54460;
1785 | type DBMS_MIN_PROTOCOL_VERSION_WITH_PASSWORD_COMPLEXITY_RULES = 54461;
1786 | type DBMS_MIN_REVISION_WITH_INTERSERVER_SECRET_V2 = 54462;
1787 | type DBMS_MIN_PROTOCOL_VERSION_WITH_TOTAL_BYTES_IN_PROGRESS = 54463;
1788 | type DBMS_MIN_PROTOCOL_VERSION_WITH_TIMEZONE_UPDATES = 54464;
1789 | type DBMS_MIN_REVISION_WITH_SPARSE_SERIALIZATION = 54465;
1790 | type DBMS_MIN_REVISION_WITH_SSH_AUTHENTICATION = 54466;
1791 | type DBMS_MIN_REVISION_WITH_TABLE_READ_ONLY_CHECK = 54467;
1792 | type DBMS_MIN_REVISION_WITH_SYSTEM_KEYWORDS_TABLE = 54468;
1793 | type DBMS_MIN_REVISION_WITH_ROWS_BEFORE_AGGREGATION = 54469;
1794 | type DBMS_MIN_PROTOCOL_VERSION_WITH_CHUNKED_PACKETS = 54470;
1795 | type DBMS_MIN_REVISION_WITH_VERSIONED_PARALLEL_REPLICAS_PROTOCOL = 54471;
1796 |
--------------------------------------------------------------------------------
/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 |
--------------------------------------------------------------------------------