From 42f977248819e09801c69b6f8a0ef32d52d53e18 Mon Sep 17 00:00:00 2001 From: Nadeem Bitar Date: Fri, 16 Oct 2026 06:01:50 -0700 Subject: [PATCH 1/2] fix(protocol): correct QueryKind wire codes --- library/ClickHaskell.cabal | 22 ++++++++++++--- library/ClickHaskell/Protocol/Client.hs | 12 ++++---- library/test/query-kind/Main.hs | 37 +++++++++++++++++++++++++ 3 files changed, 61 insertions(+), 10 deletions(-) create mode 100644 library/test/query-kind/Main.hs diff --git a/library/ClickHaskell.cabal b/library/ClickHaskell.cabal index b7d82280..569ee2ac 100644 --- a/library/ClickHaskell.cabal +++ b/library/ClickHaskell.cabal @@ -30,10 +30,7 @@ Flag dev Default: False Manual: True -Library - Exposed-Modules: - ClickHaskell - ClickHaskell.Protocol +common clickhaskell-settings Other-Modules: ClickHaskell.Connection ClickHaskell.Protocol.Client @@ -120,3 +117,20 @@ Library ScopedTypeVariables StandaloneDeriving UndecidableInstances + + +Library + import: clickhaskell-settings + Exposed-Modules: + ClickHaskell + ClickHaskell.Protocol + +Test-Suite query-kind-regressions + import: clickhaskell-settings + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/query-kind + other-modules: + ClickHaskell + ClickHaskell.Protocol + ghc-options: -threaded diff --git a/library/ClickHaskell/Protocol/Client.hs b/library/ClickHaskell/Protocol/Client.hs index 168fb32a..ba6919c9 100644 --- a/library/ClickHaskell/Protocol/Client.hs +++ b/library/ClickHaskell/Protocol/Client.hs @@ -246,15 +246,15 @@ data QueryKind = NoQuery | InitialQuery | SecondaryQuery instance Serializable QueryKind where serialize rev kind = serialize @UInt8 rev $ case kind of - NoQuery -> 1 - InitialQuery -> 2 - SecondaryQuery -> 3 + NoQuery -> 0 + InitialQuery -> 1 + SecondaryQuery -> 2 deserialize rev = do kindCode <- deserialize @UInt8 rev case kindCode of - 1 -> pure NoQuery - 2 -> pure InitialQuery - 3 -> pure SecondaryQuery + 0 -> pure NoQuery + 1 -> pure InitialQuery + 2 -> pure SecondaryQuery num -> fail ("Unknown QueryKind " <> show num) data Jwt = MkJwt ChString diff --git a/library/test/query-kind/Main.hs b/library/test/query-kind/Main.hs new file mode 100644 index 00000000..6de4707d --- /dev/null +++ b/library/test/query-kind/Main.hs @@ -0,0 +1,37 @@ +module Main (main) where + +import System.Timeout (timeout) + +import ClickHaskell.Primitive (Serializable(..)) +import ClickHaskell.Protocol (QueryKind(..)) +import Control.Monad (forM_, unless) +import Data.Binary.Get (runGetOrFail) +import Data.ByteString.Builder (toLazyByteString) +import qualified Data.ByteString.Lazy as BL + +main :: IO () +main = do + result <- timeout 5000000 runTests + case result of + Just () -> pure () + Nothing -> fail "regression suite timed out" + +runTests :: IO () +runTests = do + -- Fixed protocol values, rather than a serializer/deserializer round trip. + forM_ [(NoQuery, 0), (InitialQuery, 1), (SecondaryQuery, 2)] $ \(kind, code) -> do + unless (toLazyByteString (serialize 1 kind) == BL.singleton code) $ + fail ("wrong wire code for " ++ kindName kind) + case runGetOrFail (deserialize @QueryKind 1) (BL.singleton code) of + Right (rest, _, decoded) | BL.null rest && kindName decoded == kindName kind -> pure () + _ -> fail ("wrong decoding for wire code " ++ show code) + forM_ [3, 255] $ \code -> + case runGetOrFail (deserialize @QueryKind 1) (BL.singleton code) of + Left _ -> pure () + Right _ -> fail ("accepted invalid query kind " ++ show code) + putStrLn "QueryKind wire-code regressions passed" + +kindName :: QueryKind -> String +kindName NoQuery = "NoQuery" +kindName InitialQuery = "InitialQuery" +kindName SecondaryQuery = "SecondaryQuery" From 8af22d3b86cc3f1c866a6728e72ebc267d25eef9 Mon Sep 17 00:00:00 2001 From: KovalevDima Date: Fri, 16 Oct 2026 21:23:58 +0000 Subject: [PATCH 2/2] Drop unnecessary test --- library/ClickHaskell.cabal | 22 ++++---------------- library/test/query-kind/Main.hs | 37 --------------------------------- 2 files changed, 4 insertions(+), 55 deletions(-) delete mode 100644 library/test/query-kind/Main.hs diff --git a/library/ClickHaskell.cabal b/library/ClickHaskell.cabal index 569ee2ac..b7d82280 100644 --- a/library/ClickHaskell.cabal +++ b/library/ClickHaskell.cabal @@ -30,7 +30,10 @@ Flag dev Default: False Manual: True -common clickhaskell-settings +Library + Exposed-Modules: + ClickHaskell + ClickHaskell.Protocol Other-Modules: ClickHaskell.Connection ClickHaskell.Protocol.Client @@ -117,20 +120,3 @@ common clickhaskell-settings ScopedTypeVariables StandaloneDeriving UndecidableInstances - - -Library - import: clickhaskell-settings - Exposed-Modules: - ClickHaskell - ClickHaskell.Protocol - -Test-Suite query-kind-regressions - import: clickhaskell-settings - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test/query-kind - other-modules: - ClickHaskell - ClickHaskell.Protocol - ghc-options: -threaded diff --git a/library/test/query-kind/Main.hs b/library/test/query-kind/Main.hs deleted file mode 100644 index 6de4707d..00000000 --- a/library/test/query-kind/Main.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Main (main) where - -import System.Timeout (timeout) - -import ClickHaskell.Primitive (Serializable(..)) -import ClickHaskell.Protocol (QueryKind(..)) -import Control.Monad (forM_, unless) -import Data.Binary.Get (runGetOrFail) -import Data.ByteString.Builder (toLazyByteString) -import qualified Data.ByteString.Lazy as BL - -main :: IO () -main = do - result <- timeout 5000000 runTests - case result of - Just () -> pure () - Nothing -> fail "regression suite timed out" - -runTests :: IO () -runTests = do - -- Fixed protocol values, rather than a serializer/deserializer round trip. - forM_ [(NoQuery, 0), (InitialQuery, 1), (SecondaryQuery, 2)] $ \(kind, code) -> do - unless (toLazyByteString (serialize 1 kind) == BL.singleton code) $ - fail ("wrong wire code for " ++ kindName kind) - case runGetOrFail (deserialize @QueryKind 1) (BL.singleton code) of - Right (rest, _, decoded) | BL.null rest && kindName decoded == kindName kind -> pure () - _ -> fail ("wrong decoding for wire code " ++ show code) - forM_ [3, 255] $ \code -> - case runGetOrFail (deserialize @QueryKind 1) (BL.singleton code) of - Left _ -> pure () - Right _ -> fail ("accepted invalid query kind " ++ show code) - putStrLn "QueryKind wire-code regressions passed" - -kindName :: QueryKind -> String -kindName NoQuery = "NoQuery" -kindName InitialQuery = "InitialQuery" -kindName SecondaryQuery = "SecondaryQuery"