门禁拆分与提速

.gitignore

@@ -41,6 +41,9 @@ chusql-core/storage/data/
 # 一键启动脚本的默认数据目录与日志，不入库
 localdata/
 
+# 门禁运行时目录：脚本与 README 入库，临时目录与日志不入库
+gate-check/tmp/
+
 # 本机打出来的发行包（scripts/package.sh / package.ps1 的产物），不入库
 releases/
 

AGENTS.md

@@ -24,6 +24,8 @@
   `known-issues.txt`。
 
 ## 协作规则
+- 全量门禁入口：`gate-check/run-gate.ps1`（三条车道并行，日志写 `gate-check/logs/`）。
+- 门禁由项目所有者手动运行；agent 只跑改动模块的测试，拿到门禁结果后再提交。
 - engine / web / storage 使用规定测试入口。
 - 改动说明只在交流中记录。
 

chusql-server/src/ChuSQL/Server/Privileges.hs

@@ -7,6 +7,7 @@ module ChuSQL.Server.Privileges (
     PrivilegeError (..),
     Privileges,
     RoleView (..),
+    affectedAccounts,
     authorize,
     authorizeTables,
     filterTables,
@@ -111,6 +112,33 @@ runPrivilegeCommand service principal database command
         RevokePrivilegesCommand _ object _ -> T.strip object /= "*"
         _ -> False
 
+-- | 一条命令会影响的账号：角色连它的成员一起展开，账号名原样留下
+affectedAccounts :: Privileges -> PrivilegeCommand -> IO [Text]
+affectedAccounts service command = do
+    known <- roleNames service
+    case known of
+        Left _ -> pure (direct command)
+        Right roles -> walk roles [] (direct command)
+  where
+    -- | 命令直接点到的名字
+    direct cmd = case cmd of
+        CreateRoleCommand _ -> []
+        DropRoleCommand role -> [role]
+        GrantPrivilegesCommand _ _ role _ -> [role]
+        RevokePrivilegesCommand _ _ role -> [role]
+        GrantRoleCommand _ members -> members
+        RevokeRoleCommand _ members -> members
+    -- | 是角色就接着往下走它的成员，走过的名字不再走第二遍
+    walk roles seen [] = pure (reverse seen)
+    walk roles seen (name : rest)
+        | name `elem` seen = walk roles seen rest
+        | normalizeRole name `elem` roles = do
+            members <- membersOfRole service name
+            case members of
+                Left _ -> walk roles (name : seen) rest
+                Right found -> walk roles (name : seen) (found ++ rest)
+        | otherwise = walk roles (name : seen) rest
+
 -- | 语句鉴权：管理员全通，普通身份按需查
 authorize :: Privileges -> Principal -> Text -> Statement -> IO (Either PrivilegeError ())
 authorize service principal database stmt

chusql-server/src/ChuSQL/Server/Session.hs

@@ -6,6 +6,7 @@ module ChuSQL.Server.Session
     , SessionError (..)
     , engineErrorCode
     , newSession
+    , newSessionWith
     , sessionUser
     , sessionIsAdmin
     , sessionDatabase
@@ -36,7 +37,7 @@ import ChuSQL.Interface.Auth (defaultSessionPolicy, newSessionStore)
 import ChuSQL.Server.Accounts
 import ChuSQL.Server.Backend (Backend (..), StatementResult (..), columnsFromStatement)
 import ChuSQL.Server.Policy (configurePasswordPolicy)
-import ChuSQL.Server.Privileges (PrivilegeCommand, PrivilegeError (..), Privileges, RoleView, authorize, filterTables, listRoleViews, newPrivileges, privilegeCommand, runPrivilegeCommand)
+import ChuSQL.Server.Privileges (PrivilegeCommand, PrivilegeError (..), Privileges, RoleView, affectedAccounts, authorize, filterTables, listRoleViews, newPrivileges, privilegeCommand, runPrivilegeCommand)
 import Control.Exception (IOException, try)
 import Data.Bifunctor (first)
 import Data.Char (isAlpha, isAlphaNum)
@@ -67,6 +68,7 @@ data Session = Session
     , ssPrincipal :: IORef (Maybe Principal)
     , ssSettingsFile :: FilePath
     , ssTransaction :: IORef (Maybe Transaction)
+    , ssChanged :: [Text] -> IO ()
     }
 
 -- | 一条会话里的显式事务：开事务时的快照、事务内改到的状态与保存点栈
@@ -78,7 +80,11 @@ data Transaction = Transaction
 
 -- | 开一个会话：账号与角色服务、配置策略都和 Web 端一致
 newSession :: Backend -> Text -> FilePath -> IO Session
-newSession backend name settingsFile = do
+newSession backend name settingsFile = newSessionWith backend name settingsFile (const (pure ()))
+
+-- | 开会话并接上账号变更通知回调
+newSessionWith :: Backend -> Text -> FilePath -> ([Text] -> IO ()) -> IO Session
+newSessionWith backend name settingsFile changed = do
     sessions <- newSessionStore getCurrentTime defaultSessionPolicy
     accountsService <- newAccounts backend sessions name
     privileges <- newPrivileges backend
@@ -87,7 +93,7 @@ newSession backend name settingsFile = do
     current <- newIORef ""
     principal <- newIORef Nothing
     transaction <- newIORef Nothing
-    pure (Session backend accountsService privileges current principal settingsFile transaction)
+    pure (Session backend accountsService privileges current principal settingsFile transaction changed)
 
 -- | 当前生效的口令策略（只有管理员能看）
 policyOf :: Session -> IO (Either Text PasswordPolicy)
@@ -529,7 +535,7 @@ currentBackend session = do
     name <- readIORef (ssCurrent session)
     pure (beWithDatabase (ssBackend session) (T.unpack name))
 
--- | 账号语句走账号服务，普通账号一律拒绝
+-- | 账号语句走账号服务，普通账号一律拒绝；改完通知受影响账号
 runAccount :: Session -> AccountCommand -> IO (Either SessionError QueryResult)
 runAccount session command = do
     who <- readIORef (ssPrincipal session)
@@ -537,9 +543,20 @@ runAccount session command = do
         Nothing -> pure (Left (SessionError "unauthorized" "sign in first"))
         Just principal -> do
             result <- runAccountCommand (ssAccounts session) principal command
-            pure (either (Left . accountErrorOf) (const (Right (emptyResult Nothing))) result)
+            case result of
+                Left err -> pure (Left (accountErrorOf err))
+                Right () -> do
+                    notifyChanged session (accountCommandUsers command)
+                    pure (Right (emptyResult Nothing))
 
--- | 角色语句走权限服务，普通账号拒绝
+-- | 一条账号命令影响的账号
+accountCommandUsers :: AccountCommand -> [Text]
+accountCommandUsers command = case command of
+    CreateAccount _ _ -> []
+    ResetAccountPassword name _ -> [name]
+    DropAccount name -> [name]
+
+-- | 角色语句走权限服务，普通账号拒绝；改完通知受影响账号
 runPrivilege :: Session -> PrivilegeCommand -> IO (Either SessionError QueryResult)
 runPrivilege session command = do
     who <- readIORef (ssPrincipal session)
@@ -547,8 +564,18 @@ runPrivilege session command = do
         Nothing -> pure (Left (SessionError "unauthorized" "sign in first"))
         Just principal -> do
             database <- readIORef (ssCurrent session)
+            -- 受影响账号要趁命令落地之前算：删角色之后成员就查不到了
+            affected <- affectedAccounts (ssPrivileges session) command
             result <- runPrivilegeCommand (ssPrivileges session) principal database command
-            pure (either (Left . privilegeErrorOf) (const (Right (emptyResult Nothing))) result)
+            case result of
+                Left err -> pure (Left (privilegeErrorOf err))
+                Right () -> do
+                    notifyChanged session affected
+                    pure (Right (emptyResult Nothing))
+
+-- | 通知变更：把受影响的账号交给会话的变更钩子
+notifyChanged :: Session -> [Text] -> IO ()
+notifyChanged session names = ssChanged session (filter (not . T.null) names)
 
 -- | 账号错误转成会话错误
 accountErrorOf :: AccountError -> SessionError

chusql-server/src/ChuSQL/Server/TCP.hs

@@ -5,6 +5,8 @@ module ChuSQL.Server.TCP (
     defaultServerConfig,
     loadServerConfigAt,
     ServerEnv (..),
+    LiveConnections,
+    newLiveConnections,
     newServerEnv,
     ServerHandle (..),
     startServer,
@@ -17,13 +19,15 @@ import ChuSQL.Interface.Protocol (ClientRequest (..), ServerResponse (..), decod
 import ChuSQL.Interface.RateLimit (RateLimiter, rateLimitBlock, rateLimitClear, rateLimitRecord)
 import qualified ChuSQL.Core.Engine.Error as E
 import ChuSQL.Server.Backend (Backend (..))
-import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), accounts, authenticateSessionCoded, catalog, databases, newSession, policyOf, reloadPolicy, roleViews, runStatementCoded, sessionIsAdmin, sessionUser)
+import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), accounts, authenticateSessionCoded, catalog, databases, newSessionWith, policyOf, reloadPolicy, roleViews, runStatementCoded, sessionIsAdmin, sessionUser)
 import Control.Concurrent (forkIO)
 import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
-import Control.Exception (IOException, try)
-import Control.Monad (void)
+import Control.Exception (IOException, finally, try)
+import Control.Monad (filterM, void)
 import qualified Data.ByteString.Char8 as BSC
 import qualified Data.ByteString.Lazy.Char8 as BLC
+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
+import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -45,6 +49,8 @@ import Network.Socket (
     getSocketName,
     listen,
     setSocketOption,
+    shutdown,
+    ShutdownCmd (ShutdownBoth),
     socket,
     socketToHandle,
   )
@@ -53,6 +59,41 @@ import System.IO.Error (isEOFError)
 
 -- TCP 服务器：监听端口，一连接一会话，按一行一 JSON 收发协议消息。
 
+-- 在线连接与服务器环境
+
+-- | 在线连接登记：账号名加一个「关掉这条连接」的动作
+data LiveConnections = LiveConnections
+    { lcNext :: IORef Int
+    , lcLive :: MVar (Map.Map Int (IORef (Maybe Text), IO ()))
+    }
+
+-- | 建一张空的在线连接登记表
+newLiveConnections :: IO LiveConnections
+newLiveConnections = LiveConnections <$> newIORef 0 <*> newMVar Map.empty
+
+-- | 登记一条连接，返回注销动作
+registerConnection :: LiveConnections -> IORef (Maybe Text) -> IO () -> IO (IO ())
+registerConnection live who kick = do
+    n <- atomicModifyIORef' (lcNext live) (\i -> (i + 1, i))
+    modifyMVar_ (lcLive live) (pure . Map.insert n (who, kick))
+    pure (modifyMVar_ (lcLive live) (pure . Map.delete n))
+
+-- | 断开这些账号的在线连接，返回断开的条数
+dropConnectionsOf :: LiveConnections -> [Text] -> IO Int
+dropConnectionsOf live names = do
+    let wanted = map T.toLower (filter (not . T.null) names)
+    entries <- readMVar (lcLive live)
+    hits <- filterM (isOf wanted) (Map.elems entries)
+    mapM_ (tryKick . snd) hits
+    pure (length hits)
+  where
+    -- | 这条连接登录的账号在名单里吗
+    isOf wanted (who, _) = do
+        current <- readIORef who
+        pure (maybe False (\name -> T.toLower name `elem` wanted) current)
+    -- | 踢人失败不当错误：对端可能已经自己走了
+    tryKick kick = void (try kick :: IO (Either IOException ()))
+
 -- 服务器
 
 data ServerEnv = ServerEnv
@@ -61,12 +102,14 @@ data ServerEnv = ServerEnv
     , srvSettingsFile :: FilePath
     , srvConfig :: ServerConfig
     , srvLimiter :: RateLimiter
+    , srvLive :: LiveConnections
     }
 
 -- | 组装服务器环境：每个连接再各开一个会话
 newServerEnv :: Backend -> Text -> FilePath -> ServerConfig -> RateLimiter -> IO ServerEnv
-newServerEnv backend rootName settingsFile config limiter =
-    pure (ServerEnv backend rootName settingsFile config limiter)
+newServerEnv backend rootName settingsFile config limiter = do
+    live <- newLiveConnections
+    pure (ServerEnv backend rootName settingsFile config limiter live)
 
 data ServerHandle = ServerHandle
     { shPort :: Int
@@ -148,31 +191,48 @@ reportConnection env conn = do
         Left err -> hPutStrLn stderr ("connection failed: " ++ show err)
         Right () -> pure ()
 
+-- | 一条连接上跨请求的状态：登录账号、已被断开与注销动作
+data Connection = Connection
+    { cnWho :: IORef (Maybe Text)
+    , cnDropped :: IORef Bool
+    }
+
 -- | 一个连接一个会话：一行一条 JSON，读到 EOF 就收工
 serveConnection :: ServerEnv -> Socket -> IO ()
 serveConnection env conn = do
     h <- socketToHandle conn ReadWriteMode
     hSetBuffering h LineBuffering
     hSetNewlineMode h noNewlineTranslation
-    session <- newSession (srvBackend env) (srvRootName env) (srvSettingsFile env)
-    outcome <- try (loop h session) :: IO (Either IOException ())
+    who <- newIORef Nothing
+    dropped <- newIORef False
+    let kick = do
+            writeIORef dropped True
+            void (try (shutdown conn ShutdownBoth) :: IO (Either IOException ()))
+    unregister <- registerConnection (srvLive env) who kick
+    let connection = Connection who dropped
+    session <- newSessionWith (srvBackend env) (srvRootName env) (srvSettingsFile env) (\names -> void (dropConnectionsOf (srvLive env) names))
+    outcome <- try (loop h session connection `finally` unregister) :: IO (Either IOException ())
     case outcome of
         Left err | not (isEOFError err) -> hPutStrLn stderr ("connection error: " ++ show err)
         _ -> pure ()
     void (try (hClose h) :: IO (Either IOException ()))
   where
     -- | 逐行读请求并应答
-    loop h session = do
+    loop h session connection = do
         line <- BSC.hGetLine h
         let cleaned = BSC.dropWhileEnd (== '\r') line
         if BSC.length cleaned > scMaxMessage (srvConfig env)
-            then send h (RespError "too_large" "request line too large") >> loop h session
+            then send h (RespError "too_large" "request line too large") >> loop h session connection
             else case decodeRequest cleaned of
-                Left message -> send h (RespError "bad_request" message) >> loop h session
+                Left message -> send h (RespError "bad_request" message) >> loop h session connection
                 Right request -> do
-                    (response, keepGoing) <- dispatch env session request
+                    expired <- readIORef (cnDropped connection)
+                    if expired
+                        then send h (RespError "unauthorized" "session was dropped by an account change")
+                        else do
+                            (response, keepGoing) <- dispatch env session connection request
                             send h response
-                    if keepGoing then loop h session else pure ()
+                            if keepGoing then loop h session connection else pure ()
     -- | 发一条响应并冲缓冲
     send h response = do
         BLC.hPutStr h (encodeResponse response)
@@ -180,13 +240,16 @@ serveConnection env conn = do
         hFlush h
 
 -- | 一条请求一条响应，quit 后停连接
-dispatch :: ServerEnv -> Session -> ClientRequest -> IO (ServerResponse, Bool)
-dispatch env session request = case request of
+dispatch :: ServerEnv -> Session -> Connection -> ClientRequest -> IO (ServerResponse, Bool)
+dispatch env session connection request = case request of
     ReqHello version
         | version == protocolVersion -> pure (RespHello protocolVersion, True)
         | otherwise -> pure (RespError "bad_request" ("unsupported protocol version: " <> tshow version), True)
     ReqLogin user password -> do
         response <- login env session user password
+        case response of
+            RespLogin who _ -> writeIORef (cnWho connection) (Just who)
+            _ -> pure ()
         pure (response, True)
     ReqQuery sql -> do
         who <- sessionUser session

chusql-server/test/Spec.hs

@@ -23,6 +23,7 @@ import ChuSQL.Server.Privileges (
     PrivilegeCommand (..),
     PrivilegeError (..),
     Privileges,
+    affectedAccounts,
     authorize,
     listRoleViews,
     newPrivileges,
@@ -480,6 +481,67 @@ tcpServerSpec = do
                         blocked <- tcpQuery other "select * from users"
                         asText (at "code" blocked) `shouldBe` "unauthorized"
 
+    describe "TCP server: account changes drop live sessions" $ do
+        it "disconnects a member whose role was revoked" $
+            withTcpServer defaultServerConfig $ \_ handle ->
+                withConnection handle $ \admin -> do
+                    _ <- tcpLogin admin "admin" "s3cret"
+                    _ <- tcpQuery admin "create user bob identified by 'bob-password-1'"
+                    _ <- tcpQuery admin "create role reader"
+                    _ <- tcpQuery admin "use test"
+                    _ <- tcpQuery admin "grant select on users to reader"
+                    _ <- tcpQuery admin "grant reader to bob"
+                    withConnection handle $ \bob -> do
+                        _ <- tcpLogin bob "bob" "bob-password-1"
+                        _ <- tcpQuery bob "use test"
+                        allowed <- tcpQuery bob "select name from users"
+                        asText (at "status" allowed) `shouldBe` "result"
+                        _ <- tcpQuery admin "revoke reader from bob"
+                        tcpClosed bob
+        it "disconnects every member of a role that was dropped" $
+            withTcpServer defaultServerConfig $ \_ handle ->
+                withConnection handle $ \admin -> do
+                    _ <- tcpLogin admin "admin" "s3cret"
+                    _ <- tcpQuery admin "create user bob identified by 'bob-password-1'"
+                    _ <- tcpQuery admin "create role reader"
+                    _ <- tcpQuery admin "grant reader to bob"
+                    withConnection handle $ \bob -> do
+                        _ <- tcpLogin bob "bob" "bob-password-1"
+                        _ <- tcpQuery admin "drop role reader"
+                        tcpClosed bob
+        it "disconnects an account whose password was reset" $
+            withTcpServer defaultServerConfig $ \_ handle ->
+                withConnection handle $ \admin -> do
+                    _ <- tcpLogin admin "admin" "s3cret"
+                    _ <- tcpQuery admin "create user bob identified by 'bob-password-1'"
+                    withConnection handle $ \bob -> do
+                        _ <- tcpLogin bob "bob" "bob-password-1"
+                        _ <- tcpQuery admin "alter user bob identified by 'bob-password-2'"
+                        tcpClosed bob
+                    withConnection handle $ \again -> do
+                        relogin <- tcpLogin again "bob" "bob-password-2"
+                        asText (at "status" relogin) `shouldBe` "ok"
+        it "disconnects an account that was dropped" $
+            withTcpServer defaultServerConfig $ \_ handle ->
+                withConnection handle $ \admin -> do
+                    _ <- tcpLogin admin "admin" "s3cret"
+                    _ <- tcpQuery admin "create user bob identified by 'bob-password-1'"
+                    withConnection handle $ \bob -> do
+                        _ <- tcpLogin bob "bob" "bob-password-1"
+                        _ <- tcpQuery admin "drop user bob"
+                        tcpClosed bob
+        it "leaves the connections of untouched accounts alone" $
+            withTcpServer defaultServerConfig $ \_ handle ->
+                withConnection handle $ \admin -> do
+                    _ <- tcpLogin admin "admin" "s3cret"
+                    _ <- tcpQuery admin "create user bob identified by 'bob-password-1'"
+                    withConnection handle $ \bob -> do
+                        _ <- tcpLogin bob "bob" "bob-password-1"
+                        _ <- tcpQuery admin "create user carol identified by 'carol-password-1'"
+                        _ <- tcpQuery admin "alter user carol identified by 'carol-password-2'"
+                        still <- tcpQuery bob "use test"
+                        asText (at "status" still) `shouldBe` "result"
+
 -- 权限服务夹具：内存后端上的系统库视角
 
 -- | 一个普通账号
@@ -695,6 +757,17 @@ privilegeSpec = describe "server privileges" $ do
         authorizeSql service (Ordinary testAccount) "SELECT name FROM users WHERE id > ANY (SELECT id FROM orders)"
             `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON orders")
 
+    it "lists the accounts a role change touches, members included" $ withPrivileges $ \service root -> do
+        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
+        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "inner")
+        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "inner" ["reader"])
+        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
+        directly <- affectedAccounts service (RevokeRoleCommand "inner" ["bob"])
+        directly `shouldMatchList` ["inner", "bob", "reader", "alice"]
+        dropped <- affectedAccounts service (DropRoleCommand "inner")
+        dropped `shouldMatchList` ["inner", "reader", "alice"]
+        affectedAccounts service (CreateRoleCommand "other") `shouldReturn` []
+
     it "keeps the role tables on the real storage" $ withIpcStorage $ do
         base <- ipcBackend
         service <- newPrivileges base

gate-check/README.md

@@ -0,0 +1,44 @@
+# gate-check — 项目门禁
+
+独立门禁目录，不再放在 `localdata/`（那里只留历史日志）。入口是 `run-gate.ps1`，三条车道并行。
+
+## 快速开始
+
+```powershell
+pwsh -NoProfile -File gate-check/run-gate.ps1              # 全量
+pwsh -NoProfile -File gate-check/run-gate.ps1 -Clean       # 先清各项目自己的构建工件
+pwsh -NoProfile -File gate-check/run-gate.ps1 -Full        # 连依赖副本一起清（最慢，怀疑旧产物复用时才用）
+pwsh -NoProfile -File gate-check/run-gate.ps1 -NoLint      # 跳过 cargo clippy
+pwsh -NoProfile -File gate-check/run-gate.ps1 -Only server # 只跑一条车道：cargo|stack|comments
+```
+
+## 车道与步骤
+
+| 车道 | 步骤 | 说明 |
+| --- | --- | --- |
+| build | `cargo build --release` | 先单独跑：Haskell 测试要从 `chusql-core/storage/target/release` 加载动态库 |
+| cargo | `cargo test --release`、`cargo clippy --all-targets -- -D warnings` | `-NoLint` 跳过 clippy |
+| stack | engine → server → web → cli 的 `stack test <pkg> --fast` | 串行：stack 与快照目录不能并发写 |
+| comments | `comment-check.ps1`、`comment-purity.ps1` | 注释长度与注释纯度 |
+
+`build` 车道先跑完，再并行启动其余三条；这样动态库刷新与 Haskell 测试不会互相抢文件。
+
+## 退出码与日志
+
+- 每步打印一行 `STEP_EXIT <步骤> <码>`；任一非零则 `GATE_EXIT=1`，否则 `GATE_EXIT=0`。
+- 末尾打印 `STEPS=...`（各步骤退出码）与总用时。
+- 日志在 `gate-check/logs/<车道>.log`（stderr 在 `.err.log`），终端实时转发同一份内容；文件不进版本库。
+- `comment-check.ps1` 有问题数时退出 1；`comment-purity.ps1` 只报告差异，恒退出 0。
+
+## 相对旧脚本的提速点
+
+1. 默认不再 `stack clean --full`：改为零清理；`-Clean` 只清各项目自己的工件，`-Full` 才回到旧行为。
+2. 车道并行：Rust 测试 + clippy、四个 Haskell 套件、注释检查同时跑。
+3. 输出流式：旧脚本 `| Out-String` 要等整步跑完才吐字，这里逐行实时转发。
+4. 单车道开关 `-Only`，改一个模块时不用全量。
+
+## 约定
+
+- 门禁由项目所有者手动运行；agent 只跑模块级测试，不跑全量门禁。
+- 期望基线（随里程碑更新）：Engine 357 / Server 88 / Web 56 / CLI 10 / Rust 140。
+- 计数与主线进度以 `agent_credientials/project-plan.txt` 为准。

gate-check/comment-check.ps1

@@ -0,0 +1,140 @@
+# 注释规范合规检查：文件级注释 ≤3 行且 ≤90 字，函数级注释 ≤30 字
+# 有问题的文件不静默：问题数大于 0 时退出码为 1
+param([string]$Root = (Split-Path -Parent $PSScriptRoot), [string[]]$Only)
+
+$codeDirs = @('chusql-core','chusql-server','chusql-web','chusql-cli','chusql-bootstrap','chusql-interface','chusql-benchmark','scripts','gate-check')
+$files = @()
+foreach ($d in $codeDirs) {
+    $p = Join-Path $Root $d
+    if (Test-Path -LiteralPath $p) {
+        $files += Get-ChildItem -LiteralPath $p -Recurse -File -Include *.hs,*.rs,*.js,*.css,*.html,*.ps1,*.sh |
+            Where-Object { $_.FullName -notmatch '\\\.stack-work\\|\\dist-newstyle\\|\\target\\|\\node_modules\\|\\logs\\|\\tmp\\' }
+    }
+}
+if ($Only) { $files = $files | Where-Object { $n = $_.Name; ($Only | Where-Object { $n -like $_ }).Count -gt 0 } }
+$files = $files | Sort-Object FullName
+$files = $files | Where-Object { $_.FullName -notmatch '\\localdata\\' }
+
+$problems = @()
+$scanned = 0
+$fnCount = 0
+$fileBlockCount = 0
+
+foreach ($f in $files) {
+    $lines = @(Get-Content -LiteralPath $f.FullName)
+    $ext = $f.Extension.ToLower()
+    $scanned++
+
+    # ---- 函数级注释长度（只查每个函数/方法的“摘要行”：连续 doc 注释组第一行；# Safety 小节与非函数声明不计）----
+    $docRe = '^\s*(--\s*\|\s?|///\s?|//!\s?)(.*)$'
+    for ($i = 0; $i -lt $lines.Count; $i++) {
+        $l = $lines[$i]
+        $body = $null
+        if ($l -notmatch $docRe) {
+            if ($ext -eq '.js' -and $l -match '^\s*//\s?(.*)$') { $body = $Matches[1] } else { continue }
+        }
+        else { $body = $Matches[2] }
+        if ($i -gt 0) {
+            $prev = $lines[$i - 1]
+            $prevDoc = ($prev -match $docRe) -or ($ext -eq '.js' -and $prev -match '^\s*//\s?')
+            if ($prevDoc) { continue }
+        }
+        $k = $i
+        while ($k -lt $lines.Count -and (($lines[$k] -match $docRe) -or ($lines[$k] -match '^\s*#\[') -or ($ext -eq '.js' -and $lines[$k] -match '^\s*//'))) { $k++ }
+        $decl = if ($k -lt $lines.Count) { $lines[$k] } else { '' }
+        $isFn = switch ($ext) {
+            '.rs' { $decl -match '\bfn\s' }
+            '.hs' { $decl -match '^\s*[a-z_][A-Za-z0-9_'']*\s*::' }
+            '.js' { ($decl -match '^\s*(export\s+)?(async\s+)?function\b') -or ($decl -match '^\s*(export\s+)?(const|let|var)\s+[A-Za-z_$][\w$]*\s*=\s*(async\s*)?(function\b|\()') }
+            default { $false }
+        }
+        if (-not $isFn) { continue }
+        $t = $body.Trim()
+        if ($t -eq '' -or $t[0] -eq '#') { continue }
+        $fnCount++
+        if ($t.Length -gt 30) {
+            $problems += [pscustomobject]@{ Kind = 'FN-LONG'; File = $f.FullName; Line = $i + 1; Info = "$($t.Length)字 $t" }
+        }
+    }
+
+    # ---- 找出“外部引用”最后一行（含跨行的 import{...} / param(...) 块）----
+    $lastRef = -1
+    for ($i = 0; $i -lt $lines.Count; $i++) {
+        $l = $lines[$i]
+        $hit = $false
+        if ($l -match '^(import|use)\s' -or $l -match '^#\[macro_use\]' -or $l -match '^\s*#include\s' -or
+            $l -match '^@import\s' -or $l -match '^\s*<link\b' -or $l -match '^\s*<script\b.*\bsrc=') { $hit = $true }
+        if ($ext -ne '.hs' -and $l -match '^(param\s*\(|Set-StrictMode)') { $hit = $true }
+        if ($ext -eq '.ps1' -and $l -match '^\$ErrorActionPreference\s*=') { $hit = $true }
+        if ($ext -eq '.sh' -and ($l -match '^set -[eoux]' -or $l -match '^\.\s+"?[^"]*source' -or $l -match '^source\s')) { $hit = $true }
+        if (-not $hit) { continue }
+        $depth = ([regex]::Matches($l, '\(')).Count - ([regex]::Matches($l, '\)')).Count
+        $k = $i
+        while ($depth -gt 0 -and $k + 1 -lt $lines.Count) {
+            $k++
+            $depth += ([regex]::Matches($lines[$k], '\(')).Count - ([regex]::Matches($lines[$k], '\)')).Count
+        }
+        if ($ext -eq '.js' -and $l -match '^\s*import\b') {
+            while ($k + 1 -lt $lines.Count -and $lines[$k] -notmatch ';\s*$') { $k++ }
+        }
+        $lastRef = $k
+        $i = $k
+    }
+
+    # ---- Haskell：module 之前不该再有注释残留 ----
+    if ($ext -eq '.hs') {
+        for ($i = 0; $i -lt $lines.Count; $i++) {
+            if ($lines[$i] -match '^module\s') { break }
+            if ($lines[$i] -match '^\s*--' -and $lines[$i] -notmatch '^\{-#') {
+                $problems += [pscustomobject]@{ Kind = 'COMMENT-BEFORE-MODULE'; File = $f.FullName; Line = $i + 1; Info = $lines[$i].Trim() }
+            }
+        }
+    }
+
+    # ---- 文件级注释块 ----
+    $start = $lastRef + 1
+    # 跳过紧跟在引用后的空行
+    while ($start -lt $lines.Count -and $lines[$start].Trim() -eq '') { $start++ }
+    $block = @()
+    $j = $start
+    while ($j -lt $lines.Count) {
+        $l = $lines[$j]
+        if ($l.Trim() -eq '') { if ($block.Count -gt 0) { break } else { $j++; continue } }
+        if ($l -match '^\s*(--|//|#|/\*|\*|<!--|;)') { $block += $l.Trim(); $j++ } else { break }
+    }
+    if ($block.Count -eq 0) {
+        # 退一步：文件最顶部（跳过 shebang 与 {-# ... #-}）的注释块也算文件级注释（Rust //! / 脚本头部）
+        $t = 0
+        while ($t -lt $lines.Count -and ($lines[$t] -match '^#!' -or $lines[$t] -match '^\{-#' -or $lines[$t].Trim() -eq '')) { $t++ }
+        $top = @()
+        while ($t -lt $lines.Count -and $lines[$t] -match '^\s*(--|//|#|/\*|\*|<!--|;)') { $top += $lines[$t].Trim(); $t++ }
+        if ($top.Count -eq 0) {
+            $problems += [pscustomobject]@{ Kind = 'NO-FILE-COMMENT'; File = $f.FullName; Line = $start + 1; Info = $(if ($start -lt $lines.Count) { $lines[$start].Trim() } else { '<EOF>' }) }
+        }
+        else { $fileBlockCount++ }
+    }
+    else {
+        $fileBlockCount++
+        $chars = 0
+        foreach ($b in $block) {
+            $t = $b -replace '^\s*(--|//|#|/\*|\*|<!--|;)\s?', ''
+            $t = $t -replace '\s*\*/\s*$', ''
+            $chars += $t.Trim().Length
+        }
+        # 只统计“文件级”块（连续注释行中，如果第一行是 -- | 说明它其实是给紧随声明的 haddock，不算文件头）
+        $isHaddock = $block[0] -match '^--\s*\|\s' -or $block[0] -match '^///'
+        if (-not $isHaddock -and ($block.Count -gt 3 -or $chars -gt 90)) {
+            $problems += [pscustomobject]@{ Kind = 'FILE-BLOCK-LONG'; File = $f.FullName; Line = $start + 1; Info = "$($block.Count)行/$chars字" }
+        }
+    }
+}
+
+"扫描文件: $scanned"
+"函数级注释条数: $fnCount"
+"检出文件级注释块: $fileBlockCount"
+"问题数: $($problems.Count)"
+if ($problems.Count -gt 0) {
+    $problems | Format-Table -AutoSize -Wrap | Out-String -Width 220
+    exit 1
+}
+exit 0

gate-check/comment-purity.ps1

@@ -0,0 +1,62 @@
+# 注释纯度审计：去掉纯注释行后把工作区与 git index 逐行比对
+# 相同说明改动只有注释；有差异的文件会被列出，仅作人工判断不设退出码
+param([string]$Root = (Split-Path -Parent $PSScriptRoot))
+
+Set-Location $Root
+$dirs = @('chusql-core','chusql-server','chusql-web','chusql-cli','chusql-bootstrap','chusql-interface','chusql-benchmark','scripts','gate-check')
+$files = @()
+foreach ($d in $dirs) {
+    $p = Join-Path $Root $d
+    if (Test-Path -LiteralPath $p) {
+        $files += Get-ChildItem -LiteralPath $p -Recurse -File -Include *.hs,*.rs,*.js,*.css,*.html,*.ps1,*.sh |
+            Where-Object { $_.FullName -notmatch '\\\.stack-work\\|\\dist-newstyle\\|\\target\\|\\node_modules\\|\\localdata\\|\\logs\\|\\tmp\\' }
+    }
+}
+$files = $files | Sort-Object FullName
+
+function Is-CommentLine([string]$l, [string]$ext) {
+    switch ($ext) {
+        '.hs' { return $l -match '^\s*--' }
+        '.rs' { return $l -match '^\s*//' }
+        '.js' { return $l -match '^\s*(//|/\*|\*)' }
+        '.css' { return $l -match '^\s*(/\*|\*|//)' }
+        '.html' { return $l -match '^\s*(<!--|-->)' }
+        default { return $l -match '^\s*#' }
+    }
+}
+function Strip-Comments([string[]]$lines, [string]$ext) {
+    $out = New-Object System.Collections.Generic.List[string]
+    foreach ($l in $lines) { if (-not (Is-CommentLine $l $ext)) { $out.Add($l.TrimEnd()) } }
+    return , $out
+}
+
+$pure = 0; $new = 0; $diffFiles = @()
+foreach ($f in $files) {
+    $rel = (Resolve-Path -LiteralPath $f.FullName -Relative) -replace '^\.\\', '' -replace '\\', '/'
+    git cat-file -e ":$rel" 2>$null | Out-Null
+    $tracked = ($LASTEXITCODE -eq 0)
+    if (-not $tracked) { $new++; continue }
+    $wt = Strip-Comments @(Get-Content -LiteralPath $f.FullName) $f.Extension.ToLower()
+    $idx = Strip-Comments @(git show ":$rel") $f.Extension.ToLower()
+    if ($wt.Count -eq $idx.Count) {
+        $same = $true
+        for ($i = 0; $i -lt $wt.Count; $i++) { if ($wt[$i] -cne $idx[$i]) { $same = $false; break } }
+        if ($same) { $pure++; continue }
+    }
+    # 统计差异行
+    $set = @{}
+    foreach ($l in $idx) { if ($set.ContainsKey($l)) { $set[$l]++ } else { $set[$l] = 1 } }
+    $extra = @()
+    foreach ($l in $wt) {
+        if ($set.ContainsKey($l) -and $set[$l] -gt 0) { $set[$l]-- } else { $extra += $l }
+    }
+    $removed = @()
+    foreach ($k in $set.Keys) { if ($set[$k] -gt 0) { $removed += ("{0}x {1}" -f $set[$k], $k) } }
+    $diffFiles += [pscustomobject]@{ File = $rel; Added = $extra.Count; Removed = $removed.Count; Sample = (($extra | Select-Object -First 3) -join ' | ') }
+}
+
+"扫描文件: $($files.Count)"
+"仅注释变更（去注释后与 index 完全相同）: $pure"
+"index 无基线（新文件，跳过）: $new"
+"含非注释差异的文件: $($diffFiles.Count)"
+if ($diffFiles.Count -gt 0) { $diffFiles | Format-Table -AutoSize -Wrap | Out-String -Width 240 }

gate-check/run-gate.ps1

@@ -0,0 +1,119 @@
+# 门禁入口：并行跑 Rust / Haskell / 注释三条车道，日志实时输出
+# 用法见 README.md；-Clean 重建本地依赖，-Only 只跑一条车道
+param(
+    [string]$Root = (Split-Path -Parent $PSScriptRoot),
+    [switch]$Clean,
+    [switch]$Full,
+    [switch]$NoLint,
+    [string[]]$Only
+)
+$ErrorActionPreference = 'Stop'
+
+$LogDir = Join-Path $PSScriptRoot 'logs'
+$TmpDir = Join-Path $PSScriptRoot 'tmp'
+New-Item -ItemType Directory -Force -Path $LogDir, $TmpDir | Out-Null
+$env:PATH = (Join-Path $Root 'chusql-core\storage\target\release') + ';' + $env:PATH
+$env:TEMP = $TmpDir
+$env:TMP = $TmpDir
+Set-Location -LiteralPath $Root
+
+$colors = @{ build = 'DarkGray'; cargo = 'Yellow'; stack = 'Cyan'; comments = 'Green' }
+$laneNames = @('cargo', 'stack', 'comments')
+if ($Only) {
+    $laneNames = @($laneNames | Where-Object { $Only -contains $_ })
+    if ($laneNames.Count -eq 0) { throw "unknown lane: $($Only -join ',')" }
+}
+
+# 读日志里新出现的行并带车道前缀打印，只保留行数游标
+function Show-New([object]$Lane) {
+    foreach ($part in @('Log', 'ErrLog')) {
+        $path = $Lane.$part
+        $seen = [int]$Lane."Seen$part"
+        $lines = @()
+        try { $lines = @(Get-Content -LiteralPath $path -Encoding UTF8 -ErrorAction Stop) } catch { $lines = @() }
+        if ($lines.Count -gt $seen) {
+            foreach ($line in $lines[$seen..($lines.Count - 1)]) {
+                Write-Host ("{0} {1}" -f $Lane.Tag, $line) -ForegroundColor $colors[$Lane.Name]
+            }
+            $Lane."Seen$part" = $lines.Count
+        }
+    }
+}
+
+# 起一条车道：独立进程写自己的日志，主进程只做流式转发
+function Start-Lane([string]$Name) {
+    $log = Join-Path $LogDir "$Name.log"
+    $errLog = Join-Path $LogDir "$Name.err.log"
+    Remove-Item -LiteralPath $log, $errLog -Force -ErrorAction SilentlyContinue
+    $stepArgs = @('-NoProfile', '-File', (Join-Path $PSScriptRoot 'run-step.ps1'), '-Root', $Root, '-Kind', $Name)
+    if ($NoLint) { $stepArgs += '-NoLint' }
+    $proc = Start-Process -FilePath 'pwsh' -ArgumentList $stepArgs -RedirectStandardOutput $log `
+        -RedirectStandardError $errLog -NoNewWindow -PassThru
+    return [pscustomobject]@{
+        Name = $Name; Proc = $proc; Log = $log; ErrLog = $errLog
+        Tag = "[$Name]"; SeenLog = 0; SeenErrLog = 0; Exit = $null
+    }
+}
+
+# 等一批车道跑完，边等边转发输出
+function Wait-Lanes($Lanes) {
+    while ($true) {
+        $running = 0
+        foreach ($lane in $Lanes) {
+            $lane.Proc.Refresh()
+            Show-New $lane
+            if (-not $lane.Proc.HasExited) { $running++ }
+        }
+        if ($running -eq 0) { break }
+        Start-Sleep -Milliseconds 300
+    }
+    Start-Sleep -Milliseconds 400
+    foreach ($lane in $Lanes) { Show-New $lane; $lane.Exit = $lane.Proc.ExitCode }
+}
+
+# 清理本地依赖工件：-Clean 只清各项目自己的，-Full 连依赖副本一起清
+function Invoke-Clean {
+    foreach ($dir in @('chusql-core\engine', 'chusql-server', 'chusql-web', 'chusql-cli')) {
+        $argv = @('clean')
+        if ($Full) { $argv += '--full' }
+        Write-Host "== stack $($argv -join ' ') in $dir" -ForegroundColor DarkGray
+        Push-Location -LiteralPath (Join-Path $Root $dir)
+        try { & stack @argv 2>&1 | ForEach-Object { Write-Host "   $_" -ForegroundColor DarkGray } }
+        finally { Pop-Location }
+    }
+}
+
+$started = Get-Date
+if ($Clean -or $Full) { Invoke-Clean }
+
+# 先单独建好 Rust 动态库：Haskell 测试要从 target\release 加载它
+$build = Start-Lane 'build'
+Write-Host '== 先建 Rust 动态库' -ForegroundColor DarkGray
+Wait-Lanes @($build)
+
+Write-Host "== 车道并行：$($laneNames -join ' / ')" -ForegroundColor DarkGray
+$lanes = @()
+foreach ($name in $laneNames) { $lanes += Start-Lane $name }
+Wait-Lanes $lanes
+
+'--- 门禁结果 ---'
+$allExit = @($build.Exit)
+$failed = 0
+foreach ($lane in $lanes) {
+    $codes = @()
+    $steps = @(Select-String -LiteralPath $lane.Log -Pattern '^STEP_EXIT (\S+) (-?\d+)$' -ErrorAction SilentlyContinue)
+    foreach ($m in $steps) {
+        $codes += "$($m.Matches[0].Groups[1].Value)=$($m.Matches[0].Groups[2].Value)"
+    }
+    $allExit += $lane.Exit
+    if ($lane.Exit -ne 0) { $failed++ }
+    '车道 {0,-9} exit={1,-3} {2}' -f $lane.Name, $lane.Exit, ($codes -join ' ')
+    $tail = @(Get-Content -LiteralPath $lane.Log -Encoding UTF8 -ErrorAction SilentlyContinue | Select-Object -Last 5)
+    foreach ($line in $tail) { "    $line" }
+}
+$elapsed = [int]((Get-Date) - $started).TotalSeconds
+"用时: ${elapsed}s"
+"STEPS=$($allExit -join ',')"
+if ($failed -gt 0 -or $build.Exit -ne 0) { 'GATE_EXIT=1'; exit 1 }
+'GATE_EXIT=0'
+exit 0

gate-check/run-step.ps1

@@ -0,0 +1,59 @@
+# 单条车道：按 -Kind 依次跑步骤，每步打印 STEP_EXIT，全零才退出 0
+param(
+    [string]$Root = (Split-Path -Parent $PSScriptRoot),
+    [Parameter(Mandatory)][ValidateSet('build', 'cargo', 'stack', 'comments')][string]$Kind,
+    [switch]$NoLint
+)
+$ErrorActionPreference = 'Continue'
+$codes = @()
+
+# 跑一个步骤：切目录、输出原样透传、记录退出码
+function Invoke-Step([string]$Label, [string]$Dir, [string[]]$Argv) {
+    Write-Host "=== $Label ==="
+    $code = 1
+    Push-Location -LiteralPath $Dir
+    try {
+        $exe = $Argv[0]
+        $rest = @($Argv | Select-Object -Skip 1)
+        & $exe @rest
+        if ($null -ne $global:LASTEXITCODE) { $code = [int]$global:LASTEXITCODE }
+    }
+    catch {
+        Write-Host "--- $Label raised: $_"
+        $code = 1
+    }
+    finally { Pop-Location }
+    Write-Host "--- $Label exit $code"
+    "STEP_EXIT $Label $code"
+    $script:codes += $code
+}
+
+$storage = Join-Path $Root 'chusql-core\storage'
+$engine = Join-Path $Root 'chusql-core\engine'
+switch ($Kind) {
+    'build' {
+        Invoke-Step 'cargo-build' $storage @('cargo', 'build', '--release')
+    }
+    'cargo' {
+        Invoke-Step 'cargo-test' $storage @('cargo', 'test', '--release')
+        if (-not $NoLint) {
+            Invoke-Step 'cargo-clippy' $storage @('cargo', 'clippy', '--all-targets', '--', '-D', 'warnings')
+        }
+    }
+    'stack' {
+        Invoke-Step 'engine' $engine @('stack', 'test', 'chusql-core-engine', '--fast')
+        Invoke-Step 'server' (Join-Path $Root 'chusql-server') @('stack', 'test', 'chusql-server', '--fast')
+        Invoke-Step 'web' (Join-Path $Root 'chusql-web') @('stack', 'test', 'chusql-web', '--fast')
+        Invoke-Step 'cli' (Join-Path $Root 'chusql-cli') @('stack', 'test', 'chusql-cli', '--fast')
+    }
+    'comments' {
+        $check = Join-Path $PSScriptRoot 'comment-check.ps1'
+        $purity = Join-Path $PSScriptRoot 'comment-purity.ps1'
+        Invoke-Step 'comment-check' $Root @('pwsh', '-NoProfile', '-File', $check, '-Root', $Root)
+        Invoke-Step 'comment-purity' $Root @('pwsh', '-NoProfile', '-File', $purity, '-Root', $Root)
+    }
+}
+
+$failed = @($codes | Where-Object { $_ -ne 0 })
+if ($failed.Count -gt 0) { exit 1 }
+exit 0