修bug，完善功能

2026-10-16 23:52:12 +08:00
1 parent 30364b1c4b
commit 6996e19694
@@ -2,16 +2,14 @@

 module Main (main) where

-import Control.Monad (when)
-import ChuSQL.Web.API (AppEnv (..), Live (..), newAppEnvAt, setLive, webApp)
 import ChuSQL.Interface.Auth (SessionPolicy (..), setPayloadPolicy)
 import ChuSQL.Interface.Config (
    ServerConfig (..),
    WebConfig (..),
    defaultUser,
+    legacyPasswordKey,
    loadServerConfigAt,
    loadWebConfigAt,
-    legacyPasswordKey,
    resolveStaticDir,
    rootUserName,
    staticDirCandidates,
@@ -20,7 +18,9 @@ import ChuSQL.Interface.Link (clientPing, closeClient, connectClient)
 import ChuSQL.Interface.RateLimit (newRateLimiter)
 import ChuSQL.Interface.Settings (effectiveSettings)
 import ChuSQL.Interface.TOML (resolveConfigPath)
+import ChuSQL.Web.API (AppEnv (..), Live (..), newAppEnvAt, setLive, webApp)
 import Control.Exception (IOException, try)
+import Control.Monad (when)
 import Data.Char (toLower)
 import Data.String (fromString)
 import Data.Text (Text)
@@ -79,7 +79,7 @@ emptyOptions =
 parseArgs :: [String] -> Either String Options
 parseArgs = go emptyOptions
  where
-    -- | 逐个参数累加进 Options
+    -- \| 逐个参数累加进 Options
    go opts [] = Right opts
    go opts ("--help" : rest) = go opts{optHelp = True} rest
    go opts ("-h" : rest) = go opts{optHelp = True} rest
@@ -99,11 +99,11 @@ parseArgs = go emptyOptions
    go opts ("--cookie-secure" : v : rest) = go opts{optCookieSecure = Just (isTrue v)} rest
    go _ (a : _) = Left ("unrecognized argument or missing value: " ++ a)

-    -- | 解析一个整数参数
+    -- \| 解析一个整数参数
    withInt :: String -> String -> (Int -> Either String Options) -> Either String Options
    withInt name v k = maybe (Left (name ++ " needs an integer, got: " ++ v)) k (readMaybe v)

-    -- | 把 1/true/yes/on 认成真
+    -- \| 把 1/true/yes/on 认成真
    isTrue :: String -> Bool
    isTrue s = map toLower s `elem` ["1", "true", "yes", "on"]

@@ -161,7 +161,7 @@ applyOptions cfg opts =
        , wcMaxSqlLength = orElse (optMaxSqlLength opts) (wcMaxSqlLength cfg)
        }
  where
-    -- | 有就用新的，没有留旧值
+    -- \| 有就用新的，没有留旧值
    orElse :: Maybe a -> a -> a
    orElse (Just x) _ = x
    orElse Nothing y = y
@@ -249,11 +249,12 @@ serve settings app = do
 reportCredential :: WebConfig -> Bool -> IO ()
 reportCredential cfg legacy = do
    putStrLn ("administrator: " ++ T.unpack (rootUserName cfg))
-    when legacy
-      $ do putStrLn
-             "  !! the [web] section still carries a plaintext password key; it is ignored now"
-           putStrLn
-             "  !! remove it: the administrator password lives in the __system_users system table"
+    when legacy $
+        do
+            putStrLn
+                "  !! the [web] section still carries a plaintext password key; it is ignored now"
+            putStrLn
+                "  !! remove it: the administrator password lives in the __system_users system table"

 -- | ping 一次 server，报告它通不通
 checkServer :: Text -> Int -> IO ()
@@ -1,5 +1,5 @@
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}

 module ChuSQL.Web.API (
    AppEnv (..),
@@ -21,10 +21,9 @@ module ChuSQL.Web.API (
    newAppEnvAt,
 ) where

-import Data.Either (fromRight)
-import ChuSQL.Core.Model (Row, Value (..))
 import ChuSQL.Core.Engine.Syntax.AST (Statement (BeginTransaction, CommitTransaction, RollbackTransaction))
 import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
+import ChuSQL.Core.Model (Row, Value (..))
 import ChuSQL.Core.Protocol (Account (..), QueryResult (..), SchemaColumn (..), TableInfo (..), valueToJSON)
 import ChuSQL.Interface.AccountTable (accountColumns, accountTableName, isAccountTable, passwordColumn, systemTableInfo)
 import ChuSQL.Interface.Actions (
@@ -103,7 +102,7 @@ import ChuSQL.Interface.Settings (
    writeSettingsFile,
 )
 import ChuSQL.Interface.TOML (defaultConfigFile)
-import ChuSQL.Web.Secure (bodyLimitDynamic, sameOriginOnly, securityHeaders, contentSecurityPolicy)
+import ChuSQL.Web.Secure (bodyLimitDynamic, contentSecurityPolicy, sameOriginOnly, securityHeaders)
 import ChuSQL.Web.Static (contentTypeOf, readStatic, safeRelative)
 import ChuSQL.Web.UISettings (
    readUISettings,
@@ -112,22 +111,23 @@ import ChuSQL.Web.UISettings (
    validateUISettings,
    writeUISettings,
 )
-import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, withMVar)
 import Control.Concurrent (forkIO, threadDelay)
+import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, withMVar)
 import Control.Exception (IOException, try)
-import Control.Monad (forever, when, unless)
+import Control.Monad (forever, unless, when)
 import Data.Aeson (FromJSON (..), eitherDecode, object, withObject, (.:), (.=))
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Key as K
 import qualified Data.Aeson.KeyMap as KM
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
+import Data.Either (fromRight)
 import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
 import Data.List (nub, sortBy)
 import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
 import Data.Maybe (catMaybes, fromMaybe, isJust)
 import Data.Scientific (fromFloatDigits)
+import qualified Data.Set as Set
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
@@ -291,7 +291,7 @@ serializeSessions locks app req respond = case sessionKey req of
        lock <- lockFor locks key
        withMVar lock (const (app req respond))
  where
-    -- | 取请求所属的会话令牌
+    -- \| 取请求所属的会话令牌
    sessionKey _ = do
        rawCookie <- lookup "Cookie" (requestHeaders req)
        parseCookieHeader sessionCookieName (TE.decodeUtf8With TEE.lenientDecode rawCookie)
@@ -360,13 +360,17 @@ withDatabase env action = do
                else do
                    editing <- header "X-ChuSQL-Edit"
                    req <- request
-                    let snapshotRead = isJust editing && ((requestMethod req == "GET" && take 2 (pathInfo req) == ["api", "tables"])
-                            || (requestMethod req == "POST" && pathInfo req == ["api", "normalization", "analyze"]))
+                    let snapshotRead =
+                            isJust editing
+                                && ( (requestMethod req == "GET" && take 2 (pathInfo req) == ["api", "tables"])
+                                        || (requestMethod req == "POST" && pathInfo req == ["api", "normalization", "analyze"])
+                                   )
                    console <- liftIO (readIORef (wsConsole ws))
                    caller <- consoleOwner
                    case console of
-                        Just (owner, database) | not snapshotRead &&
-                            (pathInfo req `notElem` [["api", "query"], ["api", "normalization", "analyze"]] || caller /= owner || (not (T.null chosen) && chosen /= database)) ->
+                        Just (owner, database)
+                            | not snapshotRead
+                                && (pathInfo req `notElem` [["api", "query"], ["api", "normalization", "analyze"]] || caller /= owner || (not (T.null chosen) && chosen /= database)) ->
                                apiError "conflict" "another SQL console owns this connection transaction; commit or rollback there first"
                        _ -> pure ()
                    current <- liftIO (sessionDatabase (wsSession ws))
@@ -395,14 +399,16 @@ requireSession env = do
            editHeader <- fmap TL.toStrict <$> header "X-ChuSQL-Edit"
            req <- request
            case editHeader of
-                Just editId | (requestMethod req == "GET" && take 2 (pathInfo req) == ["api", "tables"])
-                    || (requestMethod req == "POST" && pathInfo req == ["api", "normalization", "analyze"]) -> do
-                    active <- liftIO (readIORef (wsEdit ws))
-                    database <- maybe "" (T.toLower . TL.toStrict) <$> header "X-ChuSQL-Database"
-                    case active of
-                        Just (owner, name) | owner == editId && name == database ->
-                            pure ws {wsSession = wsEditor ws, wsClient = wsEditorClient ws}
-                        _ -> apiError "conflict" "the editing snapshot is no longer available; rollback and reload"
+                Just editId
+                    | (requestMethod req == "GET" && take 2 (pathInfo req) == ["api", "tables"])
+                        || (requestMethod req == "POST" && pathInfo req == ["api", "normalization", "analyze"]) -> do
+                        active <- liftIO (readIORef (wsEdit ws))
+                        database <- maybe "" (T.toLower . TL.toStrict) <$> header "X-ChuSQL-Database"
+                        case active of
+                            Just (owner, name)
+                                | owner == editId && name == database ->
+                                    pure ws{wsSession = wsEditor ws, wsClient = wsEditorClient ws}
+                            _ -> apiError "conflict" "the editing snapshot is no longer available; rollback and reload"
                _ -> pure ws

 -- | 关闭网页会话的两个服务端连接。
@@ -472,19 +478,22 @@ indexH env = do
            setHeader "Content-Security-Policy" (TL.fromStrict (contentSecurityPolicy (Just nonce)))
            setHeader "Content-Type" "text/html; charset=utf-8"
            raw (BL.fromStrict pageHtml)
+
 -- | 静态文件：白名单之外一律 404
 staticH :: AppEnv -> ActionM ()
 staticH env = do
    rel <- pathParam "file"
-    if rel == "index.html" then indexH env else case safeRelative rel of
-        Nothing -> reply404
-        Just _ -> do
-            content <- liftIO (readStatic (aeStaticDir env) (T.unpack rel))
-            case content of
-                Nothing -> reply404
-                Just page -> do
-                    setHeader "Content-Type" (TL.fromStrict (contentTypeOf (T.unpack rel)))
-                    raw (BL.fromStrict page)
+    if rel == "index.html"
+        then indexH env
+        else case safeRelative rel of
+            Nothing -> reply404
+            Just _ -> do
+                content <- liftIO (readStatic (aeStaticDir env) (T.unpack rel))
+                case content of
+                    Nothing -> reply404
+                    Just page -> do
+                        setHeader "Content-Type" (TL.fromStrict (contentTypeOf (T.unpack rel)))
+                        raw (BL.fromStrict page)

 -- | 统一的 JSON 404
 reply404 :: ActionM ()
@@ -748,7 +757,7 @@ accountRoute ws name
 accountRowsOf :: [Account] -> [Row]
 accountRowsOf = map accountRow
  where
-    -- | 一个账号转成一行
+    -- \| 一个账号转成一行
    accountRow a =
        [ ("id", VInt (fromIntegral (accountId a)))
        , ("user", VStr (T.unpack (accountUser a)))
@@ -768,7 +777,7 @@ systemTableJson count =
        , "columns" .= map accountColumnJson accountColumns
        ]
  where
-    -- | 一列转成线上 JSON
+    -- \| 一列转成线上 JSON
    accountColumnJson sc =
        object
            [ "name" .= scName sc
@@ -836,11 +845,11 @@ sortAccountRows Nothing rows = rows
 sortAccountRows (Just (column, ascending)) rows =
    sortBy compareUser rows
  where
-    -- | 比两个账号单元
+    -- \| 比两个账号单元
    compareUser a b = case (accountCell a column, accountCell b column) of
        (Just x, Just y) -> if ascending then compare x y else compare y x
        _ -> EQ
-    -- | 取账号行里某列的文本值
+    -- \| 取账号行里某列的文本值
    accountCell row name = case lookup (T.unpack name) row of
        Just VNull -> Just ""
        Just (VStr s) -> Just s
@@ -853,7 +862,7 @@ filterAccountRows :: [(Text, Value)] -> [Row] -> [Row]
 filterAccountRows [] rows = rows
 filterAccountRows filters rows = [r | r <- rows, all (matches r) filters]
  where
-    -- | 行是否满足一条等值条件
+    -- \| 行是否满足一条等值条件
    matches row (column, wanted) = case lookup (T.unpack column) row of
        Just value -> value == wanted
        Nothing -> False
@@ -942,7 +951,7 @@ applyLiveKeys :: AppEnv -> Map.Map Text Text -> IO [Text]
 applyLiveKeys env updates = do
    before <- readLive env
    let wanted = [k | k <- liveKeys, Map.member k updates]
-        -- | 取热改项的整数值
+        -- \| 取热改项的整数值
        intOf key = case T.strip (Map.findWithDefault "" key updates) of
            "" -> intFromText (effectiveValueOf (aeEffective env) key)
            given -> intFromText given
@@ -983,9 +992,10 @@ tablesH env = do
        Left message -> serverError message
        Right infos -> do
            let tables = [info | info <- infos, not (isAccountTable (T.pack (tiTable info)))]
-            extra <- if current == systemDatabase && wsAdmin ws
-                then (: []) . systemTableJson . length <$> requireAccounts ws
-                else pure []
+            extra <-
+                if current == systemDatabase && wsAdmin ws
+                    then (: []) . systemTableJson . length <$> requireAccounts ws
+                    else pure []
            json (map tableInfoJson tables ++ extra)

 -- | 单表结构
@@ -1072,7 +1082,7 @@ parseFilters info (Just rawFilter)
        Left _ -> Left "filter must be a JSON array of {column, value}"
        Right specs -> catMaybes <$> mapM toPair specs
  where
-    -- | 一条过滤条件转成列与引擎值
+    -- \| 一条过滤条件转成列与引擎值
    toPair (RowFilter column rawValue)
        | T.null rawValue = Right Nothing
        | otherwise = do
@@ -1080,7 +1090,7 @@ parseFilters info (Just rawFilter)
            ty <- maybe (Left ("unsupported column type for: " <> column)) Right (columnTypeOf (T.pack (scType schema)))
            value <- either (Left . T.pack) Right (coerceValue ty (A.String rawValue))
            pure (Just (column, value))
-    -- | 按列名找表结构里的列
+    -- \| 按列名找表结构里的列
    lookupColumn column = case [c | c <- tiColumns info, T.pack (scName c) == column] of
        (c : _) -> Just c
        [] -> Nothing
@@ -1102,7 +1112,7 @@ sortParam info = do
            | column `notElem` map (T.pack . scName) (tiColumns info) -> Left ("unknown column: " <> column)
            | otherwise -> Right (Just (column, dirOf rawDir))
  where
-    -- | dir 参数转排序方向
+    -- \| dir 参数转排序方向
    dirOf given = case fmap (T.toLower . T.strip) given of
        Just "desc" -> False
        _ -> True
@@ -1420,7 +1430,7 @@ settingsUpdates o = do
        then Left "no settings were given"
        else Map.fromList <$> mapM convert (KM.toList values)
  where
-    -- | 一个设置值转成文本
+    -- \| 一个设置值转成文本
    convert (k, v) = case v of
        A.String s -> Right (K.toText k, s)
        A.Number n -> Right (K.toText k, T.pack (show n))
@@ -1437,7 +1447,7 @@ decodeCreateTable o = do
        _ -> Left "columns must be an array"
    pure (CreateTableSpec name cols)
  where
-    -- | 一列 {name, type} 转成列结构
+    -- \| 一列 {name, type} 转成列结构
    decodeColumn (A.Object c) = ColumnSpec <$> textField "name" c <*> textField "type" c
    decodeColumn _ = Left "each column must be {name, type}"

@@ -1453,14 +1463,14 @@ readRowValues requireAll cols o = do
                else Left ("missing columns: " <> T.intercalate ", " (map T.pack missing))
        else pure provided
  where
-    -- | 一个列值按结构转成引擎值
+    -- \| 一个列值按结构转成引擎值
    convert (k, v) = do
        let name = K.toString k
        schema <- maybe (Left ("unknown column: " <> T.pack name)) Right (lookupSchema name)
        ty <- maybe (Left ("unsupported column type for: " <> T.pack name)) Right (columnTypeOf (T.pack (scType schema)))
        value <- either (Left . T.pack) Right (coerceValue ty v)
        pure (name, value)
-    -- | 按列名找表结构里的列
+    -- \| 按列名找表结构里的列
    lookupSchema name = case [c | c <- cols, scName c == name] of
        (c : _) -> Just c
        [] -> Nothing
@@ -1571,9 +1581,17 @@ editFailure :: Text -> Text -> Maybe Int -> Bool -> ActionM ()
 editFailure stateName message index reload = do
    let code = errorCodeOf message
    status (if code == "unauthorized" then status401 else if reload || code == "serialization_failure" then status409 else statusOf code)
-    json (object ["ok" .= False, "applied" .= (0 :: Int), "state" .= stateName,
-        "reloadRequired" .= reload, "error" .= code, "message" .= message,
-        "errors" .= [object ["index" .= index, "message" .= message]]])
+    json
+        ( object
+            [ "ok" .= False
+            , "applied" .= (0 :: Int)
+            , "state" .= stateName
+            , "reloadRequired" .= reload
+            , "error" .= code
+            , "message" .= message
+            , "errors" .= [object ["index" .= index, "message" .= message]]
+            ]
+        )

 -- | 回退提交失败的暂存语句并保留快照。
 resetEditAfterFailure :: WebSession -> Maybe Int -> Text -> ActionM ()
@@ -1749,7 +1767,7 @@ parseCookieHeader name headerValue = case [v | part <- T.splitOn ";" headerValue
    (v : _) -> Just v
    [] -> Nothing
  where
-    -- | 从一段 Cookie 里取指定键的值
+    -- \| 从一段 Cookie 里取指定键的值
    valueOf key part =
        let (k, rest) = T.breakOn "=" part
            value = T.strip (T.drop 1 rest)
@@ -1804,7 +1822,7 @@ tableInfoJson info =
        , "columns" .= map columnJson (tiColumns info)
        ]
  where
-    -- | 一列转成线上 JSON
+    -- \| 一列转成线上 JSON
    columnJson sc =
        object
            [ "name" .= scName sc
@@ -1869,7 +1887,7 @@ reply500 message = do
 findTable :: Text -> [TableInfo] -> Maybe TableInfo
 findTable name = go
  where
-    -- | 顺序找表
+    -- \| 顺序找表
    go [] = Nothing
    go (i : is) = if tiTable i == T.unpack name then Just i else go is

@@ -1884,7 +1902,7 @@ instance FromJSON LoginRequest where
        LoginRequest <$> o .: "user" <*> o .: "password"

 -- | 查询请求体
-data QueryRequest = QueryRequest
+newtype QueryRequest = QueryRequest
    { qrSql :: Text
    }

@@ -1897,8 +1915,9 @@ normalizationH env = do
    ws <- requireSession env
    rawBody <- body
    case decodeNormalizationJSON rawBody of
-        Left message | BL.length rawBody > 65536 -> reply413
-                     | otherwise -> reply400 "bad_request" message
+        Left message
+            | BL.length rawBody > 65536 -> reply413
+            | otherwise -> reply400 "bad_request" message
        Right value -> case A.fromJSON value :: A.Result NormalizationRequest of
            A.Error message -> reply400 "bad_request" (T.pack message)
            A.Success payload -> do
@@ -8,9 +8,9 @@ module ChuSQL.Web.Secure (
    bodyLimitDynamic,
 ) where

-import Data.Maybe (isNothing)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BSC
+import Data.Maybe (isNothing)
 import Data.Text (Text)
 import qualified Data.Text.Encoding as TE
 import Network.HTTP.Types (
@@ -11,7 +11,7 @@ import Data.Char (isAsciiLower, isAsciiUpper, isDigit, toLower)
 import Data.Text (Text)
 import qualified Data.Text as T
 import System.Directory (doesFileExist)
-import System.FilePath ((</>), takeExtension)
+import System.FilePath (takeExtension, (</>))

 -- 静态文件交付：文件名白名单加扩展名白名单，不做目录列举。

@@ -33,7 +33,7 @@ safeRelative t
    | map toLower (takeExtension (T.unpack t)) `notElem` allowedExtensions = Nothing
    | otherwise = Just (T.unpack t)
  where
-    -- | 文件名里是否出现不允许的字符
+    -- \| 文件名里是否出现不允许的字符
    badChar c = not (isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("._-" :: String))

 -- | 读一个静态文件；不存在（或是目录）给 Nothing
@@ -8,7 +8,6 @@ module ChuSQL.Web.UISettings (
    writeUISettings,
 ) where

-import Data.Maybe (fromMaybe)
 import Control.Exception (IOException, try)
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Key as K
@@ -16,6 +15,7 @@ import qualified Data.Aeson.KeyMap as KM
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.Map.Strict as Map
+import Data.Maybe (fromMaybe)
 import Data.Scientific (floatingOrInteger)
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -43,18 +43,18 @@ resolveUISettingsFile = do
            ready <- firstExistingDir uiSettingsFileCandidates
            pure (fromMaybe firstCandidate ready)
  where
-    -- | 首选候选路径
+    -- \| 首选候选路径
    firstCandidate = case uiSettingsFileCandidates of
        (p : _) -> p
        [] -> "chusql.ui.settings.json"

-    -- | 第一个存在的候选文件
+    -- \| 第一个存在的候选文件
    firstExistingFile [] = pure Nothing
    firstExistingFile (p : ps) = do
        ok <- doesFileExist p
        if ok then pure (Just p) else firstExistingFile ps

-    -- | 目录已存在的第一个候选
+    -- \| 目录已存在的第一个候选
    firstExistingDir [] = pure Nothing
    firstExistingDir (p : ps) = do
        let dir = takeDirectory p
@@ -65,7 +65,7 @@ resolveUISettingsFile = do
 validateUISettings :: A.Value -> Either String (Map.Map Text A.Value)
 validateUISettings (A.Object o) = Map.fromList <$> mapM checkField (KM.toList o)
  where
-    -- | 校验一个字段
+    -- \| 校验一个字段
    checkField (rawKey, value) =
        let key = K.toText rawKey
         in case key of
@@ -85,9 +85,8 @@ validateUISettings (A.Object o) = Map.fromList <$> mapM checkField (KM.toList o)
                "minimap" -> pair key <$> boolValue key value
                _ -> Left ("unknown setting: " ++ T.unpack key)

-    -- | 把键和值配成一对
+    -- \| 把键和值配成一对
    pair key value = (key, value)
-
 validateUISettings _ = Left "settings must be a JSON object"

 -- | 字体链最多几项
@@ -2,13 +2,13 @@

 module Main (main) where

-import ChuSQL.Interface.Link (closeClient, connectClient)
-import ChuSQL.Interface.Auth (SessionPolicy (..), defaultSessionPolicy, lookupPayload, setPayloadPolicy)
-import ChuSQL.Interface.RateLimit (newRateLimiter)
-import ChuSQL.Interface.Session (authenticateSession, newSession, runStatement)
-import qualified ChuSQL.Interface.Actions as Actions
 import qualified ChuSQL.Core.Model as Model
 import ChuSQL.Core.Runtime
+import qualified ChuSQL.Interface.Actions as Actions
+import ChuSQL.Interface.Auth (SessionPolicy (..), defaultSessionPolicy, lookupPayload, setPayloadPolicy)
+import ChuSQL.Interface.Link (closeClient, connectClient)
+import ChuSQL.Interface.RateLimit (newRateLimiter)
+import ChuSQL.Interface.Session (authenticateSession, newSession, runStatement)
 import ChuSQL.Interface.Settings (
    applySettings,
    defaultOf,
@@ -21,8 +21,8 @@ import ChuSQL.Interface.Settings (
 )
 import ChuSQL.Web.API (
    AppEnv (..),
-    WebSession (..),
    Live (..),
+    WebSession (..),
    defaultLive,
    isIdentifier,
    newAppEnvAt,
@@ -34,8 +34,8 @@ import ChuSQL.Web.Static (contentTypeOf, safeRelative)
 import ChuSQL.Web.UISettings (validateUISettings)
 import Control.Concurrent (forkFinally, forkIO)
 import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
-import Control.Exception (IOException, bracket, throwIO, try, bracket_)
-import Control.Monad (when, unless)
+import Control.Exception (IOException, bracket, bracket_, throwIO, try)
+import Control.Monad (unless, when)
 import Data.Aeson (encode, object, (.=))
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Key as K
@@ -44,8 +44,8 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BSC
 import qualified Data.ByteString.Lazy as BL
 import Data.Char (isDigit)
-import Data.List (isInfixOf)
 import Data.IORef (readIORef)
+import Data.List (isInfixOf)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
@@ -79,8 +79,8 @@ import System.Directory (
 import System.Environment (lookupEnv)
 import System.Exit (ExitCode (..))
 import System.FilePath ((</>))
-import System.Info (os)
 import System.IO (Handle, hGetLine)
+import System.Info (os)
 import System.Process (
    CreateProcess (std_err, std_out),
    ProcessHandle,
@@ -137,7 +137,7 @@ requestAs verb path hs payload = do
    app <- getState
    liftIO $ WT.runSession send app
  where
-    -- | 清空 cookie jar 后发出请求
+    -- \| 清空 cookie jar 后发出请求
    send = do
        WT.modifyClientCookies (const Map.empty)
        WT.srequest $
@@ -433,7 +433,7 @@ serverConfigText dataDir =
        , "data_dir = \"" ++ slashed dataDir ++ "\""
        ]
  where
-    -- | 反斜杠换成正斜杠
+    -- \| 反斜杠换成正斜杠
    slashed = map (\c -> if c == '\\' then '/' else c)

 -- | 逐行读 stdout 直到读出端口
@@ -472,8 +472,9 @@ locateServerExe = do
        Just path -> pure path
        Nothing -> fail "chusql-server was not found on PATH: run `stack build` first"

-- | 全新的数据目录还没有系统目录：先跑引导程序建表并补一个免密管理员，
-- server 才肯启动（未引导的目录会被它拒绝）。
+{- | 全新的数据目录还没有系统目录：先跑引导程序建表并补一个免密管理员，
+server 才肯启动（未引导的目录会被它拒绝）。
+-}
 seedSystemCatalog :: FilePath -> IO ()
 seedSystemCatalog config = do
    bootstrap <- locateBootstrapExe
@@ -525,8 +526,9 @@ unitSpec = describe "pure helpers" $ do
    it "escapes nested runtime string literals" $ do
        case resolveType builtinTypes (listType stringType) of
            Left err -> expectationFailure err
-            Right descriptor -> Actions.sqlLiteral (Model.VRuntime (descriptorId descriptor) (RList [RString "a'b"]))
-                `shouldBe` Right "LIST<String>('a''b')"
+            Right descriptor ->
+                Actions.sqlLiteral (Model.VRuntime (descriptorId descriptor) (RList [RString "a'b"]))
+                    `shouldBe` Right "LIST<String>('a''b')"
    it "parses the session cookie out of a Cookie header" $ do
        parseCookieHeader sessionCookieName "a=1; chusql_session=abc123; b=2" `shouldBe` Just "abc123"
        parseCookieHeader sessionCookieName "other=1" `shouldBe` Nothing
@@ -950,11 +952,20 @@ querySpec env = describe "the SQL console" $ do
            ensureAccount admin "normalization_web_reader" "Reader-Secret-1234"
            created <- testSql admin "CREATE TABLE normalization_web (id INT, course INT, name TEXT)"
            expectStatusWith "normalization table" created 200
-            let declaration = object ["declared_keys" .= ([["id", "course"]] :: [[Text]]),
-                    "dependencies" .= [object ["lhs" .= (["id"] :: [Text]), "rhs" .= (["name"] :: [Text])]],
-                    "dependencies_complete" .= True, "atomic_attributes" .= True]
-                payload = object ["api_version" .= (1 :: Int), "database" .= testDatabaseName,
-                    "table" .= ("normalization_web" :: Text), "declaration" .= declaration]
+            let declaration =
+                    object
+                        [ "declared_keys" .= ([["id", "course"]] :: [[Text]])
+                        , "dependencies" .= [object ["lhs" .= (["id"] :: [Text]), "rhs" .= (["name"] :: [Text])]]
+                        , "dependencies_complete" .= True
+                        , "atomic_attributes" .= True
+                        ]
+                payload =
+                    object
+                        [ "api_version" .= (1 :: Int)
+                        , "database" .= testDatabaseName
+                        , "table" .= ("normalization_web" :: Text)
+                        , "declaration" .= declaration
+                        ]
            unauthorized <- postAs (withDb testDatabaseName []) "/api/normalization/analyze" (encode payload)
            expectStatusWith "anonymous normalization" unauthorized 401
            reader <- ordinaryHeaders "normalization_web_reader" "Reader-Secret-1234"
@@ -969,9 +980,15 @@ querySpec env = describe "the SQL console" $ do
            check (map (asText . at "verdict") (items (at "findings" (jsonBody report))) `shouldBe` ["satisfied", "violated", "violated", "violated"])
            changed <- testSql admin "ALTER TABLE normalization_web ADD COLUMN extra INT"
            expectStatusWith "change normalization schema" changed 200
-            let stale = object ["api_version" .= (1 :: Int), "database" .= testDatabaseName,
-                    "table" .= ("normalization_web" :: Text), "declaration" .= declaration,
-                    "expected_object" .= at "object" (jsonBody report), "expected_schema_fingerprint" .= at "schema_fingerprint" (jsonBody report)]
+            let stale =
+                    object
+                        [ "api_version" .= (1 :: Int)
+                        , "database" .= testDatabaseName
+                        , "table" .= ("normalization_web" :: Text)
+                        , "declaration" .= declaration
+                        , "expected_object" .= at "object" (jsonBody report)
+                        , "expected_schema_fingerprint" .= at "schema_fingerprint" (jsonBody report)
+                        ]
            conflicted <- postAs (withDb testDatabaseName readerAgain) "/api/normalization/analyze" (encode stale)
            expectStatusWith "schema changed" conflicted 409
        it "uses a matching editing snapshot without creating a second transaction" $ do
@@ -983,8 +1000,13 @@ querySpec env = describe "the SQL console" $ do
            expectStatusWith "normalization edit begins" begun 200
            changed <- testSql admin "ALTER TABLE normalization_edit ADD COLUMN extra INT"
            expectStatusWith "live schema changes" changed 200
-            let payload = object ["api_version" .= (1 :: Int), "database" .= testDatabaseName,
-                    "table" .= ("normalization_edit" :: Text), "declaration" .= object []]
+            let payload =
+                    object
+                        [ "api_version" .= (1 :: Int)
+                        , "database" .= testDatabaseName
+                        , "table" .= ("normalization_edit" :: Text)
+                        , "declaration" .= object []
+                        ]
            snapshot <- postAs (("X-ChuSQL-Edit", "normalization-owner") : withDb testDatabaseName admin) "/api/normalization/analyze" (encode payload)
            expectStatusWith "analysis on edit connection" snapshot 200
            check (at "view" (jsonBody snapshot) `shouldBe` A.String "transaction_snapshot")
@@ -999,8 +1021,13 @@ querySpec env = describe "the SQL console" $ do
            created <- testSql admin "CREATE TABLE normalization_console (id INT)"
            expectStatusWith "console normalization table" created 200
            let owner = ("X-ChuSQL-Console", "normalization-console") : admin
-                payload = object ["api_version" .= (1 :: Int), "database" .= testDatabaseName,
-                    "table" .= ("normalization_console" :: Text), "declaration" .= object []]
+                payload =
+                    object
+                        [ "api_version" .= (1 :: Int)
+                        , "database" .= testDatabaseName
+                        , "table" .= ("normalization_console" :: Text)
+                        , "declaration" .= object []
+                        ]
            begun <- testSql owner "BEGIN"
            expectStatusWith "console begins" begun 200
            snapshot <- postAs (withDb testDatabaseName owner) "/api/normalization/analyze" (encode payload)
@@ -1013,8 +1040,11 @@ querySpec env = describe "the SQL console" $ do
        it "rejects duplicate declarations and oversized normalization bodies" $ do
            admin <- adminHeaders
            ensureDatabase admin testDatabaseName
-            duplicate <- postAs (withDb testDatabaseName admin) "/api/normalization/analyze"
-                "{\"api_version\":1,\"database\":\"test\",\"table\":\"users\",\"declaration\":{\"atomic_attributes\":true,\"atomic_attributes\":false}}"
+            duplicate <-
+                postAs
+                    (withDb testDatabaseName admin)
+                    "/api/normalization/analyze"
+                    "{\"api_version\":1,\"database\":\"test\",\"table\":\"users\",\"declaration\":{\"atomic_attributes\":true,\"atomic_attributes\":false}}"
            expectStatusWith "duplicate declaration fields" duplicate 400
            oversized <- postAs (withDb testDatabaseName admin) "/api/normalization/analyze" (BL.replicate 65537 32)
            expectStatusWith "normalization request bound" oversized 413
@@ -1050,6 +1080,19 @@ querySpec env = describe "the SQL console" $ do
            check (arrayLen envelope `shouldBe` 3)
            check (asInt (fromMaybe A.Null (nth 0 (items envelope))) `shouldBe` 1)
            check (asInt (fromMaybe A.Null (nth 1 (firstRow result))) `shouldBe` 3)
+            compared <- testSql hs "SELECT LIST<Int>(2) < LIST<Int>(10), MAYBE<Int>() = MAYBE<Int>(), LIST<Int>() = NULL"
+            expectStatusWith "compound comparison values" compared 200
+            check (firstRow compared `shouldBe` [A.Bool True, A.Bool True, A.Null])
+            created <- testSql hs "CREATE TABLE http_compound_caps (id INT, xs [Int])"
+            expectStatusWith "compound table" created 200
+            inserted <- testSql hs "INSERT INTO http_compound_caps (id,xs) VALUES (1, LIST<Int>(10)), (2, LIST<Int>(2)), (3, LIST<Int>(2))"
+            expectStatusWith "compound rows" inserted 200
+            ordered <- testSql hs "SELECT id FROM http_compound_caps ORDER BY xs"
+            expectStatusWith "compound ordering" ordered 200
+            check (at "rows" (jsonBody ordered) `shouldBe` A.toJSON ([[2], [3], [1]] :: [[Int]]))
+            grouped <- testSql hs "SELECT COUNT(*) FROM http_compound_caps GROUP BY xs ORDER BY xs"
+            expectStatusWith "compound grouping" grouped 200
+            check (at "rows" (jsonBody grouped) `shouldBe` A.toJSON ([[2], [1]] :: [[Int]]))
        it "runs DDL and DML and returns positional rows" $ do
            hs <- adminHeaders
            ensureDatabase hs testDatabaseName
@@ -1089,8 +1132,15 @@ querySpec env = describe "the SQL console" $ do

 -- | 发出编辑事务控制请求。
 editRequest :: [Header] -> BS.ByteString -> Text -> [A.Value] -> TestSession WT.SResponse
-editRequest hs path owner changes = postAs hs path (encode (object
-    ["id" .= owner, "database" .= testDatabaseName, "changes" .= changes]))
+editRequest hs path owner changes =
+    postAs
+        hs
+        path
+        ( encode
+            ( object
+                ["id" .= owner, "database" .= testDatabaseName, "changes" .= changes]
+            )
+        )

 -- | 在测试库执行一条 SQL。
 testSql :: [Header] -> Text -> TestSession WT.SResponse
@@ -1098,8 +1148,12 @@ testSql hs sql = postAs (withDb testDatabaseName hs) "/api/query" (encode (objec

 -- | 生成整数行插入编辑。
 editInsert :: Text -> Int -> A.Value
-editInsert table key = object ["op" .= ("insert" :: Text), "table" .= table,
-    "values" .= object ["id" .= key, "value" .= key]]
+editInsert table key =
+    object
+        [ "op" .= ("insert" :: Text)
+        , "table" .= table
+        , "values" .= object ["id" .= key, "value" .= key]
+        ]

 -- | 验证编辑原子性、隔离与失效清理。
 editSpec :: AppEnv -> Spec
@@ -1160,8 +1214,13 @@ editSpec env = describe "web editing transactions" $ withApp (webApp env) $ do
        expectStatusWith "concurrent update" updated 200
        snapshot <- getAs (("X-ChuSQL-Edit", "conflicts") : withDb testDatabaseName hs) "/api/tables/edit_conflicts/rows"
        check (firstRow snapshot `shouldBe` [A.Number 1, A.Number 10])
-        let change = object ["op" .= ("update" :: Text), "table" .= ("edit_conflicts" :: Text),
-                "pk" .= (1 :: Int), "set" .= object ["value" .= (30 :: Int)]]
+        let change =
+                object
+                    [ "op" .= ("update" :: Text)
+                    , "table" .= ("edit_conflicts" :: Text)
+                    , "pk" .= (1 :: Int)
+                    , "set" .= object ["value" .= (30 :: Int)]
+                    ]
        failed <- editRequest hs "/api/edit/commit" "conflicts" [change]
        expectStatusWith "serialization conflict" failed 409
        check (at "reloadRequired" (jsonBody failed) `shouldBe` A.Bool True)
@@ -1180,8 +1239,15 @@ editSpec env = describe "web editing transactions" $ withApp (webApp env) $ do
        expectStatusWith "repeated begin" repeated 200
        otherPage <- editRequest hs "/api/edit/begin" "intruder" []
        expectStatusWith "another page" otherPage 409
-        otherDatabase <- postAs hs "/api/edit/commit" (encode (object
-            ["id" .= ("owner" :: Text), "database" .= ("system" :: Text), "changes" .= ([] :: [A.Value])]))
+        otherDatabase <-
+            postAs
+                hs
+                "/api/edit/commit"
+                ( encode
+                    ( object
+                        ["id" .= ("owner" :: Text), "database" .= ("system" :: Text), "changes" .= ([] :: [A.Value])]
+                    )
+                )
        expectStatusWith "another database" otherDatabase 409
        forged <- getAs (("X-ChuSQL-Edit", "intruder") : withDb testDatabaseName hs) "/api/tables"
        expectStatusWith "another page snapshot" forged 409
@@ -1250,8 +1316,15 @@ editSpec env = describe "web editing transactions" $ withApp (webApp env) $ do
        expectStatusWith "console begin" begun 200
        rejected <- testSql intruder "ROLLBACK"
        expectStatusWith "other console rollback" rejected 409
-        rest <- postAs (withDb testDatabaseName hs) "/api/tables" (encode (object
-            ["name" .= ("edit_rest_intruder" :: Text), "columns" .= [column "id" "int"]]))
+        rest <-
+            postAs
+                (withDb testDatabaseName hs)
+                "/api/tables"
+                ( encode
+                    ( object
+                        ["name" .= ("edit_rest_intruder" :: Text), "columns" .= [column "id" "int"]]
+                    )
+                )
        expectStatusWith "REST write inside console transaction" rest 409
        closed <- postAs hs "/api/query/rollback" (encode (object ["console" .= ("page:console-a" :: Text)]))
        expectStatusWith "close owning console" closed 204
@@ -1265,10 +1338,12 @@ editSpec env = describe "web editing transactions" $ withApp (webApp env) $ do
        let token = fromMaybe "" (lookup "Cookie" hs >>= parseCookieHeader sessionCookieName . TE.decodeUtf8)
        stored <- liftIO (lookupPayload (aeSessions env) token)
        app <- getState
-        res <- liftIO $ bracket_
-                          (setPayloadPolicy (aeSessions env) (SessionPolicy (- 1) 86400))
-                          (setPayloadPolicy (aeSessions env) defaultSessionPolicy)
-                          (editFromApp app hs "expires" [])
+        res <-
+            liftIO $
+                bracket_
+                    (setPayloadPolicy (aeSessions env) (SessionPolicy (-1) 86400))
+                    (setPayloadPolicy (aeSessions env) defaultSessionPolicy)
+                    (editFromApp app hs "expires" [])
        expectStatusWith "expired commit" res 401
        case stored of
            Nothing -> check (expectationFailure "missing live web session")
@@ -1295,10 +1370,13 @@ editSpec env = describe "web editing transactions" $ withApp (webApp env) $ do
 editFromApp :: Wai.Application -> [Header] -> Text -> [A.Value] -> IO WT.SResponse
 editFromApp app hs owner changes = WT.runSession send app
  where
-    -- | 构造带 Cookie 的原子提交请求。
-    send = WT.srequest (WT.SRequest
-        (WT.setPath WT.defaultRequest {Wai.requestMethod = methodPost, Wai.requestHeaders = jsonHeaders hs} "/api/edit/commit")
-        (encode (object ["id" .= owner, "database" .= testDatabaseName, "changes" .= changes])))
+    -- \| 构造带 Cookie 的原子提交请求。
+    send =
+        WT.srequest
+            ( WT.SRequest
+                (WT.setPath WT.defaultRequest{Wai.requestMethod = methodPost, Wai.requestHeaders = jsonHeaders hs} "/api/edit/commit")
+                (encode (object ["id" .= owner, "database" .= testDatabaseName, "changes" .= changes]))
+            )

 -- | IDE 设置用例
 uiSettingsSpec :: AppEnv -> Spec