修bug，完善功能

chusql-server/app/Main.hs

@@ -2,7 +2,6 @@
 
 module Main (main) where
 
-import Control.Monad (when)
 import ChuSQL.Core.Engine.Storage.FFI (storageVersion)
 import ChuSQL.Core.Engine.Storage.IPC (closeConnection, localStorageLink, setStorageLink)
 import ChuSQL.Interface.Config (
@@ -23,7 +22,8 @@ import ChuSQL.Server.TCP (
     newServerEnv,
     runServer,
  )
-import Control.Exception (IOException, try, bracket_)
+import Control.Exception (IOException, bracket_, try)
+import Control.Monad (when)
 import qualified Data.Aeson as A
 import qualified Data.Aeson.KeyMap as KM
 import Data.Text (Text)
@@ -64,7 +64,7 @@ emptyOptions =
 parseArgs :: [String] -> Either String Options
 parseArgs = go emptyOptions
   where
-    -- | 逐条消费参数列表
+    -- \| 逐条消费参数列表
     go opts [] = Right opts
     go opts ("--help" : rest) = go opts{optHelp = True} rest
     go opts ("-h" : rest) = go opts{optHelp = True} rest
@@ -76,7 +76,7 @@ parseArgs = go emptyOptions
     go opts ("--max-rows" : v : rest) = withInt "--max-rows" v (\n -> go opts{optMaxRows = Just n} 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)
 
@@ -179,7 +179,9 @@ run opts = do
             env <- newServerEnv backend rootName configPath config limiter
             let announce port = putStrLn ("listening:    tcp://" ++ scHost config ++ ":" ++ show port)
             bracket_
-              (pure link) closeConnection (serve env announce)
+                (pure link)
+                closeConnection
+                (serve env announce)
 
 -- | 起 TCP 服务并处理绑定失败
 serve :: ServerEnv -> (Int -> IO ()) -> IO ()
@@ -205,7 +207,7 @@ checkInitialized backend = do
             putStrLn "!! For a damaged existing system catalog, stop all processes and try csql-bootstrap repair or recover."
             exitFailure
   where
-    -- | 应答里的 initialized 是不是 true
+    -- \| 应答里的 initialized 是不是 true
     statusInitialized (A.Object fields) = KM.lookup "initialized" fields == Just (A.Bool True)
     statusInitialized _ = False
 
@@ -213,17 +215,19 @@ checkInitialized backend = do
 reportCredential :: Backend -> Text -> Bool -> IO ()
 reportCredential backend rootName legacy = do
     putStrLn ("administrator: " ++ T.unpack rootName)
-    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"
     passwordless <- administratorPasswordless backend rootName
-    when passwordless
-      $ do putStrLn
-             "  !! the administrator has no password yet: sign in with an empty password, then set one"
-           putStrLn
-             "  !!   ALTER USER root IDENTIFIED BY '...'   (or use the account page in the Web UI)"
+    when passwordless $
+        do
+            putStrLn
+                "  !! the administrator has no password yet: sign in with an empty password, then set one"
+            putStrLn
+                "  !!   ALTER USER root IDENTIFIED BY '...'   (or use the account page in the Web UI)"
 
 -- | 探测存储是否可用，答不上 ping 就退出
 checkStorage :: Backend -> IO ()

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

@@ -1,11 +1,29 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module ChuSQL.Server.Accounts (
-    Accounts, AccountError (..), Principal (..), PasswordPolicy (..), defaultPasswordPolicy,
-    newAccounts, accountsPolicy, setAccountsPolicy, passwordAllowed,
-    ensureRootAccount, administratorPasswordless, rootUserName, principalName, principalIsRoot, principalIsCatalogManager,
-    authenticate, authenticateSudo, currentPrincipal,
-    listAccounts, findAccount, AccountCommand (..), accountCommand, runAccountCommand,
+    Accounts,
+    AccountError (..),
+    Principal (..),
+    PasswordPolicy (..),
+    defaultPasswordPolicy,
+    newAccounts,
+    accountsPolicy,
+    setAccountsPolicy,
+    passwordAllowed,
+    ensureRootAccount,
+    administratorPasswordless,
+    rootUserName,
+    principalName,
+    principalIsRoot,
+    principalIsCatalogManager,
+    authenticate,
+    authenticateSudo,
+    currentPrincipal,
+    listAccounts,
+    findAccount,
+    AccountCommand (..),
+    accountCommand,
+    runAccountCommand,
 ) where
 
 import ChuSQL.Core.Engine.Error (accountErrorCode)
@@ -32,7 +50,7 @@ data Principal
     deriving (Eq)
 
 instance Show Principal where
-    -- | 身份的可读形式
+    -- \| 身份的可读形式
     show (Root name) = "root " ++ show name
     show (Ordinary a) = "account " ++ show (accountUser a)
 
@@ -48,9 +66,10 @@ principalIsRoot (Ordinary a) = accountIsSuperuser a && accountEnabled a && accou
 
 -- | 判断身份是否可管理系统目录
 principalIsCatalogManager :: Principal -> Bool
-principalIsCatalogManager principal = principalIsRoot principal || case principal of
-    Ordinary a -> accountSystemCatalogManager a && accountEnabled a && accountCanLogin a
-    Root _ -> True
+principalIsCatalogManager principal =
+    principalIsRoot principal || case principal of
+        Ordinary a -> accountSystemCatalogManager a && accountEnabled a && accountCanLogin a
+        Root _ -> True
 
 data Accounts = Accounts
     { acBackend :: Backend
@@ -94,12 +113,13 @@ passwordAllowed policy password
     | classes < ppClasses policy = bad "password needs more character classes"
     | otherwise = Right ()
   where
-    -- | 构造一条请求错误
+    -- \| 构造一条请求错误
     bad = Left . AccountError "bad_request"
-    -- | 命中的字符类别数
+    -- \| 命中的字符类别数
     classes =
         length
-            ( filter id
+            ( filter
+                id
                 [ T.any isAsciiLower password
                 , T.any isAsciiUpper password
                 , T.any isDigit password
@@ -114,7 +134,7 @@ validateUserName name
         Left (AccountError "bad_request" "invalid account name")
     | otherwise = Right ()
   where
-    -- | 该字符是否允许使用
+    -- \| 该字符是否允许使用
     allowed c = isAscii c && (isAlphaNum c || c `elem` ("_.-" :: String))
 
 -- | 校验新身份的名称
@@ -132,7 +152,7 @@ storageResult :: Either String [Account] -> Either AccountError ()
 storageResult (Right _) = Right ()
 storageResult (Left message) = Left (AccountError code text)
   where
-    -- | 认得的码原样用，其余存储细节不外泄
+    -- \| 认得的码原样用，其余存储细节不外泄
     code = T.pack (accountErrorCode message)
     text = if code == failureCode then failureText else T.pack message
     AccountError failureCode failureText = storageFailure
@@ -200,18 +220,18 @@ authenticate service user password = withMVar (acLock service) $ \_ -> do
   where
     name = normalize user
     ordinaryRefused = AccountError "forbidden" "this server only accepts the administrator"
-    -- | 判断是否有已设置口令的登录管理员
+    -- \| 判断是否有已设置口令的登录管理员
     unset accounts = not (any (\a -> accountIsSuperuser a && accountEnabled a && accountCanLogin a && not (T.null (accountHash a))) accounts)
-    -- | 管理员登录
+    -- \| 管理员登录
     signInRoot accounts = case filter ((== name) . accountUser) accounts of
         [a] | T.null (accountHash a) && T.null password -> issue a
         [a] | accountCanLogin a && accountEnabled a && not (T.null (accountHash a)) && verifyPassword (accountHash a) password -> issue a
         _ -> pure (Left unauthorized)
-    -- | 普通账号登录
+    -- \| 普通账号登录
     signInOrdinary accounts = case filter ((== name) . accountUser) accounts of
         [a] | accountCanLogin a && accountEnabled a && not (T.null (accountHash a)) && verifyPassword (accountHash a) password -> issue a
         _ -> pure (Left unauthorized)
-    -- | 记一次登录再发会话
+    -- \| 记一次登录再发会话
     issue a = do
         stamp <- currentStamp
         written <- beAccounts (acBackend service) (ReqAccountLogin (accountUser a) (Just stamp))
@@ -279,8 +299,8 @@ resetPassword service name password = do
 dropUser :: Accounts -> Text -> IO (Either AccountError ())
 dropUser service name =
     case validateUserName name of
-            Left err -> pure (Left err)
-            Right () -> storageResult <$> beAccounts (acBackend service) (ReqAccountDrop (normalize name))
+        Left err -> pure (Left err)
+        Right () -> storageResult <$> beAccounts (acBackend service) (ReqAccountDrop (normalize name))
 
 -- | 账号管理命令：SQL 语句与一键接口在这上面汇合
 data AccountCommand
@@ -302,7 +322,7 @@ accountCommand _ = Nothing
 runAccountCommand :: Accounts -> Principal -> AccountCommand -> IO (Either AccountError ())
 runAccountCommand service principal command = withMVar (acLock service) $ const run
   where
-    -- | 校验并执行身份管理权限
+    -- \| 校验并执行身份管理权限
     run
         | not (principalIsCatalogManager principal) = pure (Left (AccountError "forbidden" "catalog manager required"))
         | not (principalIsRoot principal) = do
@@ -311,20 +331,21 @@ runAccountCommand service principal command = withMVar (acLock service) $ const
                 Left err -> pure (Left err)
                 Right accounts
                     | any (\a -> accountUser a == normalize (target command) && (accountIsSuperuser a || accountSystemCatalogManager a || accountAllowSudoAuth a)) accounts
-                        || privilegedChange command -> pure (Left (AccountError "forbidden" "superuser required to manage privileged identities"))
+                        || privilegedChange command ->
+                        pure (Left (AccountError "forbidden" "superuser required to manage privileged identities"))
                     | otherwise -> execute
         | otherwise = execute
-    -- | 获取身份管理的目标
+    -- \| 获取身份管理的目标
     target (CreateAccount name _) = name
     target (ResetAccountPassword name _) = name
     target (DropAccount name) = name
     target (AlterAccountAttributes name _) = name
-    -- | 判断是否修改特权属性
+    -- \| 判断是否修改特权属性
     privilegedChange (AlterAccountAttributes _ attributes) = any (\(key, _) -> key `elem` ["superuser", "system_catalog_manager", "allow_sudo_auth"]) attributes
     privilegedChange _ = False
-    -- | 执行已授权的身份命令
+    -- \| 执行已授权的身份命令
     execute = executeWith (if principalIsRoot principal then service else service{acBackend = (acBackend service){beAccounts = beAccounts (acBackend service) . ReqCatalogManage}})
-    -- | 通过受限存储请求执行管理操作
+    -- \| 通过受限存储请求执行管理操作
     executeWith managed = case command of
         CreateAccount name _ | normalize name == "public" -> pure (Left (AccountError "bad_request" "public is reserved for default privileges"))
         CreateAccount name password -> createUser managed name password
@@ -333,5 +354,14 @@ runAccountCommand service principal command = withMVar (acLock service) $ const
         AlterAccountAttributes name attributes
             | length (nub (map fst attributes)) /= length attributes -> pure (Left (AccountError "bad_request" "duplicate identity attribute"))
             | otherwise ->
-                storageResult <$> beAccounts (acBackend managed) (ReqIdentityAlter (normalize name)
-                    (lookup "login" attributes) (lookup "superuser" attributes) (lookup "enabled" attributes) (lookup "system_catalog_manager" attributes) (lookup "allow_sudo_auth" attributes))
+                storageResult
+                    <$> beAccounts
+                        (acBackend managed)
+                        ( ReqIdentityAlter
+                            (normalize name)
+                            (lookup "login" attributes)
+                            (lookup "superuser" attributes)
+                            (lookup "enabled" attributes)
+                            (lookup "system_catalog_manager" attributes)
+                            (lookup "allow_sudo_auth" attributes)
+                        )

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

@@ -1,8 +1,10 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 
 module ChuSQL.Server.Backend (
     StatementResult (..),
     Backend (..),
+    applyTransactionMemory,
     columnsFromStatement,
     currentStamp,
     exprTables,
@@ -21,11 +23,9 @@ module ChuSQL.Server.Backend (
     tableRefsOf,
 ) where
 
-import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
 import ChuSQL.Core.Engine (runStatement, runStatementM)
-import ChuSQL.Core.Model
 import ChuSQL.Core.Engine.Semantic (prepare)
-import ChuSQL.Core.Engine.Storage (MonadStorage (schema, snapshot))
+import ChuSQL.Core.Engine.Storage (MonadStorage (schema))
 import ChuSQL.Core.Engine.Storage.IPC (
     Account (..),
     Env,
@@ -34,22 +34,27 @@ import ChuSQL.Core.Engine.Storage.IPC (
     Response (..),
     SchemaColumn (..),
     TableInfo (..),
+    databaseSnapshot,
     envForDatabase,
     sendRawRequest,
     sendRequest,
+    snapshotDatabase,
  )
 import ChuSQL.Core.Engine.Syntax.AST
 import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
+import ChuSQL.Core.Model
 import ChuSQL.Core.Protocol (TxnOp (..))
-import Control.Concurrent.MVar (MVar, modifyMVar)
-import Data.List (nub, isPrefixOf)
-import Data.Text (Text)
-import Data.Time (getCurrentTime)
-import Data.Time.Format (defaultTimeLocale, formatTime)
+import Control.Concurrent.MVar (MVar, modifyMVar, newMVar)
 import qualified Data.Aeson as A
 import qualified Data.Aeson.KeyMap as KM
 import qualified Data.ByteString.Lazy.Char8 as BL
+import Data.List (isPrefixOf, nub)
+import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
+import qualified Data.Set as Set
+import Data.Text (Text)
 import qualified Data.Text as T
+import Data.Time (getCurrentTime)
+import Data.Time.Format (defaultTimeLocale, formatTime)
 
 -- 后端抽象：跑语句、取数据字典与账号，分 IPC（真存储）和内存（测试）两套实现。
 
@@ -59,18 +64,24 @@ data StatementResult = StatementResult
     }
 
 data Backend = Backend
-    { beStatement :: String -> IO (Either String StatementResult)
+    { beConcurrentTransactions :: Bool
+    , beBeginTransaction :: Bool -> IO (Either String (Maybe String, Database))
+    , beStageTransaction :: String -> [TxnOp] -> [String] -> IO (Either String ())
+    , bePreviewTransaction :: String -> IO (Either String (String, Database))
+    , beCommitTransaction :: String -> String -> IO (Either String ())
+    , beRollbackTransaction :: String -> IO (Either String ())
+    , beStatement :: String -> IO (Either String StatementResult)
     , beCatalog :: IO (Either String [TableInfo])
     , bePing :: IO Bool
     , beAccounts :: Request -> IO (Either String [Account])
     , beWithDatabase :: String -> Backend
     , beDatabases :: IO (Either String [String])
-    -- | 原样转发一条存储请求
     , beStorage :: A.Value -> IO (Either String A.Value)
-    -- | 取一份整库快照，当事务的起点
+    -- ^ 原样转发一条存储请求
     , beSnapshot :: IO (Either String Database)
-    -- | 事务提交：把一批写操作交给存储层应用
+    -- ^ 取一份整库快照，当事务的起点
     , beApplyTransaction :: [TxnOp] -> IO (Either String ())
+    -- ^ 事务提交：把一批写操作交给存储层应用
     }
 
 -- | 按给定列名取列，固定列顺序
@@ -79,7 +90,7 @@ columnsFromStatement db stmt = case prepare db stmt of
     Left _ -> []
     Right resolved -> columnsOf resolved
   where
-    -- | 从已准备的语句提取输出列名
+    -- \| 从已准备的语句提取输出列名
     columnsOf (SelectDistinct q) = columnsOf q
     columnsOf Select{selectItems = items} = map fst items
     columnsOf ShowDomains = ["domain", "base_type"]
@@ -88,47 +99,75 @@ columnsFromStatement db stmt = case prepare db stmt of
 -- | 走本地存储链路的后端
 ipcBackend :: IO Backend
 ipcBackend = do
-    let backend current = Backend
-            { beStatement = runIpc current
-            , beCatalog = do
-                response <- sendRequest (ReqInDatabase current ReqListCatalog)
-                pure $ case response of
-                    RespCatalog infos -> Right (filter (not . isDomainTable . tiTable) infos)
-                    RespError err -> Left err
-                    _ -> Left "unexpected catalog response"
-            , bePing = do
-                resp <- sendRequest ReqPing
-                pure (case resp of RespPong -> True; _ -> False)
-            , beAccounts = \req -> do
-                response <- sendRequest req
-                pure $ case response of
-                    RespAccounts accounts -> Right accounts
-                    RespError err -> Left err
-                    _ -> Left "unexpected account response"
-            , beWithDatabase = backend
-            , beDatabases = do
-                response <- sendRequest (ReqDatabase "list_databases" "")
-                pure $ case response of
-                    RespTables names -> Right names
-                    RespError err -> Left err
-                    _ -> Left "unexpected database response"
-            , beStorage = runRaw
-            , beSnapshot = runIPCStorageIn snapshot (sessionEnv current)
-            , beApplyTransaction = \ops -> do
-                response <- sendRequest (ReqInDatabase current (ReqApplyTransaction ops))
-                pure $ case response of
-                    RespOk -> Right ()
-                    RespError err -> Left err
-                    _ -> Left "unexpected transaction response"
-            }
+    snapshots <- newMVar Nothing
+    let backend current =
+            Backend
+                { beConcurrentTransactions = True
+                , beBeginTransaction = \serializable -> do
+                    response <- sendRequest (ReqInDatabase current (ReqMvccBegin serializable))
+                    pure $ case response of
+                        RespMvccSnapshot token infos rows _ -> (,) (Just token) <$> snapshotDatabase infos rows
+                        RespError err -> Left err
+                        _ -> Left "unexpected MVCC begin response"
+                , beStageTransaction = \token ops dependencies -> transactionRequest current (ReqMvccLock token ops dependencies)
+                , bePreviewTransaction = \token -> do
+                    response <- sendRequest (ReqInDatabase current (ReqMvccPreview token))
+                    pure $ case response of
+                        RespDomainSnapshot infos rows checkpoint -> (,) checkpoint <$> snapshotDatabase infos rows
+                        RespError err -> Left err
+                        _ -> Left "unexpected MVCC preview response"
+                , beCommitTransaction = \token checkpoint -> transactionRequest current (ReqMvccCommit token checkpoint)
+                , beRollbackTransaction = transactionRequest current . ReqMvccRollback
+                , beStatement = runIpc current
+                , beCatalog = do
+                    response <- sendRequest (ReqInDatabase current ReqListCatalog)
+                    pure $ case response of
+                        RespCatalog infos -> Right (filter (not . isDomainTable . tiTable) infos)
+                        RespError err -> Left err
+                        _ -> Left "unexpected catalog response"
+                , bePing = do
+                    resp <- sendRequest ReqPing
+                    pure (case resp of RespPong -> True; _ -> False)
+                , beAccounts = \req -> do
+                    response <- sendRequest req
+                    pure $ case response of
+                        RespAccounts accounts -> Right accounts
+                        RespError err -> Left err
+                        _ -> Left "unexpected account response"
+                , beWithDatabase = backend
+                , beDatabases = do
+                    response <- sendRequest (ReqDatabase "list_databases" "")
+                    pure $ case response of
+                        RespTables names -> Right names
+                        RespError err -> Left err
+                        _ -> Left "unexpected database response"
+                , beStorage = runRaw
+                , beSnapshot = modifyMVar snapshots $ \previous -> do
+                    let cached = case previous of Just (name, version) | name == current -> Just version; _ -> Nothing
+                    result <- databaseSnapshot cached (sessionEnv current)
+                    pure $ case result of
+                        Left err -> (previous, Left err)
+                        Right version -> (Just (current, version), Right (snd version))
+                , beApplyTransaction = \ops -> do
+                    response <- sendRequest (ReqInDatabase current (ReqApplyTransaction ops))
+                    pure $ case response of
+                        RespOk -> Right ()
+                        RespError err -> Left err
+                        _ -> Left "unexpected transaction response"
+                }
     -- 没有默认库：没选库时 current 是空串，任何请求都得先选库
     pure (backend "")
   where
-    -- | 会话的存储环境：库名跟这条连接走
+    -- 转发事务生命周期请求并保留存储错误。
+    transactionRequest current request = do
+        response <- sendRequest (ReqInDatabase current request)
+        pure $ case response of RespOk -> Right (); RespError err -> Left err; _ -> Left "unexpected MVCC response"
+
+    -- \| 会话的存储环境：库名跟这条连接走
     sessionEnv :: String -> Env
     sessionEnv current = envForDatabase (if null current then Nothing else Just current)
 
-    -- | 转发一条存储请求并解析响应
+    -- \| 转发一条存储请求并解析响应
     runRaw :: A.Value -> IO (Either String A.Value)
     runRaw payload = do
         response <- sendRawRequest (BL.toStrict (A.encode payload))
@@ -138,7 +177,7 @@ ipcBackend = do
                 Left err -> Left ("storage response is not valid JSON: " ++ err)
                 Right value -> Right value
 
-    -- | 走存储链路跑一条语句：表名不再补当前库前缀
+    -- \| 走存储链路跑一条语句：表名不再补当前库前缀
     -- 引擎侧的数据字典按当前库过滤之后键是裸表名，补前缀会让查表落空；
     -- 库名由 database 字段随请求带走，存储层自己按它分发。
     runIpc :: String -> String -> IO (Either String StatementResult)
@@ -166,7 +205,13 @@ memoryBackend = memoryBackendWith False
 memoryBackendWith :: Bool -> String -> MVar Database -> Backend
 memoryBackendWith trusted name ref =
     Backend
-        { beStatement = \sql -> case parseStatement sql >>= scopeDdl (if trusted then systemDatabaseName else name) of
+        { beConcurrentTransactions = False
+        , beBeginTransaction = \_ -> fmap (fmap (Nothing,)) (beSnapshot (memoryBackend name ref))
+        , beStageTransaction = \_ _ _ -> pure (Left "MVCC unavailable for memory backend")
+        , bePreviewTransaction = \_ -> pure (Left "MVCC unavailable for memory backend")
+        , beCommitTransaction = \_ _ -> pure (Left "MVCC unavailable for memory backend")
+        , beRollbackTransaction = \_ -> pure (Left "MVCC unavailable for memory backend")
+        , beStatement = \sql -> case parseStatement sql >>= scopeDdl (if trusted then systemDatabaseName else name) of
             Left e -> pure (Left e)
             -- 内存夹具也有"库"的概念：USE 只能切到它有的两个名字（自己 + system），
             -- 与 beDatabases 口径一致；引擎的内存存储不实现库管理，所以拦在这里。
@@ -200,31 +245,31 @@ memoryBackendWith trusted name ref =
             Right db' -> pure (mergeScoped db db', Right ())
         }
   where
-    -- | 按视角过滤库里的表
-    scoped db = [(lastTablePart key, table {tableName = lastTablePart key}) | (key, table) <- db, inScope key, domainKey key || not (hidden key)]
-    -- | 限定键只属于指定工作库
+    -- \| 按视角过滤库里的表
+    scoped db = [(lastTablePart key, table{tableName = lastTablePart key}) | (key, table) <- db, inScope key, domainKey key || not (hidden key)]
+    -- \| 限定键只属于指定工作库
     inScope key = case break (== '.') key of
         (_, []) -> True
         (database, _) -> T.toLower (T.pack database) == T.toLower (T.pack (if trusted then systemDatabaseName else name))
-    -- | 该视角下要隐藏的表
+    -- \| 该视角下要隐藏的表
     hidden = (if trusted then blocked else internalTable) . lastTablePart
-    -- | 判断裸名或限定名是否为类型目录
+    -- \| 判断裸名或限定名是否为类型目录
     domainKey = isDomainTable . lastTablePart
-    -- | 回写当前库并保留其他库和内部目录
+    -- \| 回写当前库并保留其他库和内部目录
     mergeScoped original changed =
         filter (\(key, _) -> not (inScope key) || (hidden key && not (domainKey key))) original
             ++ [(storageKey original key, table) | (key, table) <- changed]
-    -- | 保留夹具中的原始数据库限定键
+    -- \| 保留夹具中的原始数据库限定键
     storageKey original key = case [saved | (saved, _) <- original, inScope saved, lastTablePart saved == key] of
         saved : _ -> saved
         [] | any (\(saved, _) -> inScope saved && '.' `elem` saved) original -> (if trusted then systemDatabaseName else name) ++ "." ++ key
         [] -> key
-    -- | 取结果列名，空结果回落到解析
+    -- \| 取结果列名，空结果回落到解析
     colsOf db stmt rows = case rows of
         [] -> columnsFromStatement db stmt
         (r : _) -> map fst r
 
-    -- | 按目标库名挑视角
+    -- \| 按目标库名挑视角
     withDatabase target
         | target == systemDatabaseName = memoryBackendWith True name ref
         | target == name = memoryBackendWith False name ref
@@ -233,8 +278,9 @@ memoryBackendWith trusted name ref =
 
 -- 更新内存夹具的稳定表编号。
 syncMemoryObjects :: String -> Database -> Database
-syncMemoryObjects database db = (registry, Table registry [("name", TStr), ("id", TInt)] records Nothing Nothing Nothing)
-    : map identify (filter ((/= registry) . fst) db)
+syncMemoryObjects database db =
+    (registry, Table registry [("name", TStr), ("id", TInt)] records Nothing Nothing Nothing)
+        : map identify (filter ((/= registry) . fst) db)
   where
     registry = "__system_object_ids"
     previous = [(key, identifier) | row <- maybe [] tableRows (lookup registry db), Just (VStr key) <- [lookup "name" row], Just (VInt identifier) <- [lookup "id" row]]
@@ -242,10 +288,19 @@ syncMemoryObjects database db = (registry, Table registry [("name", TStr), ("id"
     retained = [(key, identifier) | (key, identifier) <- previous, key `elem` keys]
     high = maximum (0 : map snd previous)
     added = zip [key | key <- keys, key `notElem` map fst retained] [high + 1 ..]
-    -- | 将稳定目录编号附到表定义
+    -- \| 将稳定目录编号附到表定义
     identify (key, table) = case lookup (if '.' `elem` key then key else database ++ "." ++ key) (retained ++ added) of
-        Just identifier -> (key, table {tableIdentity = Just (TableIdentity
-            (if "system." `isPrefixOf` key || ('.' `notElem` key && database == "system") then 2 else 1) (fromIntegral identifier))})
+        Just identifier ->
+            ( key
+            , table
+                { tableIdentity =
+                    Just
+                        ( TableIdentity
+                            (if "system." `isPrefixOf` key || ('.' `notElem` key && database == "system") then 2 else 1)
+                            (fromIntegral identifier)
+                        )
+                }
+            )
         Nothing -> (key, table)
     records = [[("name", VStr key), ("id", VInt identifier)] | (key, identifier) <- ("__high_water", high + length added) : retained ++ added]
 
@@ -267,92 +322,108 @@ memorySecurityRequest database ref payload = modifyMVar ref $ \original -> do
     operation db = case field "method" of
         Just "resolve_object" -> do
             selected <- maybe (Left "missing database") Right (field "database")
-            if selected `notElem` [T.pack database, "system"] then Left "unknown database" else do
-                identifier <- case field "table" of
-                    Nothing -> Right A.Null
-                    Just table -> case [number | row <- maybe [] tableRows (lookup "__system_object_ids" db), lookup "name" row == Just (VStr (T.unpack (selected <> "." <> table))), Just (VInt number) <- [lookup "id" row]] of
-                        [number] -> Right (A.toJSON number)
-                        _ -> Left "unknown table"
-                Right (db, A.object ["status" A..= ("object" :: Text), "database_id" A..= (if selected == "system" then (2 :: Int) else 1), "object_id" A..= identifier])
+            if selected `notElem` [T.pack database, "system"]
+                then Left "unknown database"
+                else do
+                    identifier <- case field "table" of
+                        Nothing -> Right A.Null
+                        Just table -> case [number | row <- maybe [] tableRows (lookup "__system_object_ids" db), lookup "name" row == Just (VStr (T.unpack (selected <> "." <> table))), Just (VInt number) <- [lookup "id" row]] of
+                            [number] -> Right (A.toJSON number)
+                            _ -> Left "unknown table"
+                    Right (db, A.object ["status" A..= ("object" :: Text), "database_id" A..= (if selected == "system" then (2 :: Int) else 1), "object_id" A..= identifier])
         Just "object_acl_read" -> Right (db, A.object ["status" A..= ("rows" :: Text), "rows" A..= [A.object ["id" A..= (1 :: Int), "payload" A..= value] | row <- maybe [] tableRows (lookup acl db), Just (VStr value) <- [lookup "payload" row]]])
         Just "object_acl_replace" -> do
             let previous = case lookup acl db of Nothing -> Nothing; Just table -> case tableRows table of [[("payload", VStr value)]] -> Just (T.pack value); _ -> Just "invalid ACL"
-            if previous /= field "expected" then Left "object ACL changed concurrently" else do
-                value <- maybe (Left "missing ACL payload") Right (field "payload")
-                Right ((acl, Table acl [("payload", TStr)] [[("payload", VStr (T.unpack value))]] Nothing Nothing Nothing) : filter ((/= acl) . fst) db, A.object ["status" A..= ("ok" :: Text)])
+            if previous /= field "expected"
+                then Left "object ACL changed concurrently"
+                else do
+                    value <- maybe (Left "missing ACL payload") Right (field "payload")
+                    Right ((acl, Table acl [("payload", TStr)] [[("payload", VStr (T.unpack value))]] Nothing Nothing Nothing) : filter ((/= acl) . fst) db, A.object ["status" A..= ("ok" :: Text)])
         _ -> Left "storage is not available in this backend"
     acl = "__system_object_acl"
 
 -- | 把后端的语句与字典都改成同一条错误
 unavailableDatabase :: String -> Backend -> Backend
-unavailableDatabase message backend = backend
-    { beStatement = \_ -> pure (Left message)
-    , beCatalog = pure (Left message)
-    , beSnapshot = pure (Left message)
-    , beApplyTransaction = \_ -> pure (Left message)
-    }
+unavailableDatabase message backend =
+    backend
+        { beStatement = \_ -> pure (Left message)
+        , beCatalog = pure (Left message)
+        , beSnapshot = pure (Left message)
+        , beApplyTransaction = \_ -> pure (Left message)
+        }
 
 -- | 未选库时的视角：只放行不碰表的语句
 noDatabaseBackend :: Backend -> Backend
-noDatabaseBackend backend = backend
-    { beStatement = \sql -> case parseStatement sql of
-        Left e -> pure (Left e)
-        Right stmt
-            | statementNeedsDatabase stmt -> pure (Left "no database selected")
-            | otherwise -> beStatement backend sql
-    , beCatalog = pure (Left "no database selected")
-    , beSnapshot = pure (Left "no database selected")
-    , beApplyTransaction = \_ -> pure (Left "no database selected")
-    }
+noDatabaseBackend backend =
+    backend
+        { beStatement = \sql -> case parseStatement sql of
+            Left e -> pure (Left e)
+            Right stmt
+                | statementNeedsDatabase stmt -> pure (Left "no database selected")
+                | otherwise -> beStatement backend sql
+        , beCatalog = pure (Left "no database selected")
+        , beSnapshot = pure (Left "no database selected")
+        , beApplyTransaction = \_ -> pure (Left "no database selected")
+        }
 
 -- | 把一批事务写操作应用到内存库：先按 id 删，再按追加写
 applyTransactionMemory :: [TxnOp] -> Database -> Either String Database
 applyTransactionMemory ops db = foldl step (Right db) ops
   where
+    -- 顺序预演每个事务操作。
     step acc op = do
         current <- acc
         case op of
             TxnDelete name keys -> do
                 table <- lookupTable current name
-                pure (put (name, table {tableRows = [r | r <- tableRows table, not (doomed keys r)]}) current)
+                pure (put (name, table{tableRows = deleteFirst (Set.fromList keys) (tableRows table)}) current)
             TxnUpsert name rows -> do
                 table <- lookupTable current name
-                pure (put (name, table {tableRows = tableRows table ++ rows}) current)
+                pure (put (name, table{tableRows = tableRows table ++ rows}) current)
             TxnReplace name rows -> do
                 table <- lookupTable current name
-                pure (put (name, table {tableRows = rows}) current)
+                pure (put (name, table{tableRows = rows}) current)
 
-    -- | 换掉一张表，其余保持原顺序
+    -- \| 换掉一张表，其余保持原顺序
     put entry = map (\one@(name, _) -> if name == fst entry then entry else one)
 
-    -- | 这一行要不要删：按行里的 id 列比
-    doomed keys r = case lookup "id" r of
-        Just (VInt k) -> k `elem` keys
-        _ -> False
+    -- 与存储一致，每个删除键只删除首行。
+    deleteFirst _ [] = []
+    deleteFirst keys (row : rows) = case lookup "id" row of
+        Just (VInt key) | Set.member key keys -> deleteFirst (Set.delete key keys) rows
+        _ -> row : deleteFirst keys rows
 
 -- | 语句里出现的表
 statementTables :: Statement -> [Text]
-statementTables stmt = nub (case stmt of
-    SelectDistinct q -> statementTables q
-    Select{} ->
-        tableRefsOf (selectFrom stmt)
-            ++ concatMap exprTables (maybeToList (selectWhere stmt) ++ maybeToList (selectHaving stmt)
-                ++ map snd (selectItems stmt) ++ map Col (selectGroupBy stmt)
-                ++ mapMaybe (orderKeyExpression . fst) (selectOrderBy stmt))
-    Insert table _ rows -> T.pack table : concatMap exprTables (concat rows)
-    Update table assigns cond -> T.pack table : concatMap exprTables (map snd assigns ++ maybeToList cond)
-    Delete table cond -> T.pack table : concatMap exprTables (maybeToList cond)
-    CreateTable table _ -> [T.pack table]
-    DropTable table -> [T.pack table]
-    CreateIndex table _ -> [T.pack table]
-    DropIndex table _ -> [T.pack table]
-    DropColumn table _ -> [T.pack table]
-    AddColumn table _ -> [T.pack table]
-    RenameColumn table _ _ -> [T.pack table]
-    AlterColumnType table _ _ -> [T.pack table]
-    AlterColumnDefault table _ _ -> [T.pack table]
-    AlterColumnNull table _ _ -> [T.pack table]
-    _ -> [])
+statementTables stmt =
+    nub
+        ( case stmt of
+            SelectDistinct q -> statementTables q
+            Select{} ->
+                tableRefsOf (selectFrom stmt)
+                    ++ concatMap
+                        exprTables
+                        ( maybeToList (selectWhere stmt)
+                            ++ maybeToList (selectHaving stmt)
+                            ++ map snd (selectItems stmt)
+                            ++ map Col (selectGroupBy stmt)
+                            ++ mapMaybe (orderKeyExpression . fst) (selectOrderBy stmt)
+                        )
+            Insert table _ rows -> T.pack table : concatMap exprTables (concat rows)
+            Update table assigns cond -> T.pack table : concatMap exprTables (map snd assigns ++ maybeToList cond)
+            Delete table cond -> T.pack table : concatMap exprTables (maybeToList cond)
+            CreateTable table _ -> [T.pack table]
+            DropTable table -> [T.pack table]
+            CreateIndex table _ -> [T.pack table]
+            DropIndex table _ -> [T.pack table]
+            DropColumn table _ -> [T.pack table]
+            AddColumn table _ -> [T.pack table]
+            RenameColumn table _ _ -> [T.pack table]
+            AlterColumnType table _ _ -> [T.pack table]
+            AlterColumnDefault table _ _ -> [T.pack table]
+            AlterColumnNull table _ _ -> [T.pack table]
+            _ -> []
+        )
 
 -- | 语句需不需要一个当前库：出现的表里有没写库名的就必须要
 statementNeedsDatabase :: Statement -> Bool
@@ -368,6 +439,7 @@ statementNeedsDatabase stmt = case stmt of
     AlterColumnDefault{} -> True
     AlterColumnNull{} -> True
     CreateDomain{} -> True
+    AlterDomain{} -> True
     DropDomain{} -> True
     ShowDomains -> True
     _ -> not (null (statementTables stmt))
@@ -387,14 +459,14 @@ scopeDdl current statement = case statement of
     AlterColumnNull table column nullable -> (\key -> AlterColumnNull key column nullable) <$> target table
     _ -> statement <$ mapM_ checkReadTarget (statementTables statement)
   where
-    -- | 数据引用限定在当前工作库
+    -- \| 数据引用限定在当前工作库
     checkReadTarget table
         | null current = Left "no database selected"
         | otherwise = case T.breakOn "." table of
             (_, suffix) | T.null suffix -> Right ()
             (database, _) | T.toLower database == T.toLower (T.pack current) -> Right ()
             _ -> Left ("table is outside the current database: " ++ T.unpack table)
-    -- | 校验库限定名并取当前库中的表名
+    -- \| 校验库限定名并取当前库中的表名
     target table
         | null current = Left "no database selected"
         | otherwise = case break (== '.') table of
@@ -441,7 +513,7 @@ exprTables expr = case expr of
     MaxOf a -> exprTables a
     _ -> []
   where
-    -- | 两侧都取表名
+    -- \| 两侧都取表名
     both a b = exprTables a ++ exprTables b
 
 -- | 一张表的线上信息（内存实现：没有索引，统计与直方图现算）
@@ -458,10 +530,10 @@ tableInfoOf (name, tbl) =
         , tiHistograms = [(c, h) | (c, _) <- tableCols tbl, Just h <- [histogramOf (columnValues c)]]
         }
   where
-    -- | 一列的所有值
+    -- \| 一列的所有值
     columnValues c = [v | r <- tableRows tbl, Just v <- [lookup c r]]
 
-    -- | 一列的不同值个数
+    -- \| 一列的不同值个数
     distinctOf c = length (nub (columnValues c))
 
 -- | 本地列类型转线上字符串（和 IPC 那边同一套写法）
@@ -551,21 +623,36 @@ memoryAccounts db stamp req = do
                     _ -> Nothing
                 allowed = case command of ReqAccountsList -> True; ReqAccountCreate{} -> True; ReqAccountReset{} -> True; ReqAccountDrop{} -> True; ReqIdentityAlter _ _ Nothing _ Nothing Nothing -> True; _ -> False
             if not allowed || any (\a -> target == Just (accountUser a) && (accountIsSuperuser a || accountSystemCatalogManager a || accountAllowSudoAuth a)) accounts
-                then Left "superuser required to manage privileged identities" else memoryAccounts db stamp command
+                then Left "superuser required to manage privileged identities"
+                else memoryAccounts db stamp command
         ReqAccountsList -> Right accounts
         ReqIdentityInitialize admin
             | any (`elem` map accountUser accounts) legacyNames || length (nub legacyNames) /= length legacyNames -> Left "identity name collision"
-            | otherwise -> Right ([if legacyIdentity a && accountUser a == T.toLower admin then a{accountIsSuperuser = True} else a | a <- accounts] ++
-                [Account (highWater + offset) role "" 1 stamp Nothing False False True False False | (offset, role) <- zip [1..] legacyNames])
+            | otherwise ->
+                Right
+                    ( [if legacyIdentity a && accountUser a == T.toLower admin then a{accountIsSuperuser = True} else a | a <- accounts]
+                        ++ [Account (highWater + offset) role "" 1 stamp Nothing False False True False False | (offset, role) <- zip [1 ..] legacyNames]
+                    )
         ReqRoleCreate u
             | any ((== T.toLower u) . accountUser) accounts -> Left "identity already exists"
             | otherwise -> Right (accounts ++ [Account (highWater + 1) (T.toLower u) "" 1 stamp Nothing False False True False False])
         ReqIdentityAlter u login super enabled manager sudo -> case filter ((== T.toLower u) . accountUser) accounts of
-            [_] -> preserveSuper [if accountUser a == T.toLower u then a{accountCanLogin = fromMaybe (accountCanLogin a) login,
-                accountIsSuperuser = fromMaybe (accountIsSuperuser a) super, accountEnabled = fromMaybe (accountEnabled a) enabled,
-                accountSystemCatalogManager = fromMaybe (accountSystemCatalogManager a) manager,
-                accountAllowSudoAuth = fromMaybe (accountAllowSudoAuth a) sudo,
-                accountRevision = accountRevision a + 1} else a | a <- accounts] accounts
+            [_] ->
+                preserveSuper
+                    [ if accountUser a == T.toLower u
+                        then
+                            a
+                                { accountCanLogin = fromMaybe (accountCanLogin a) login
+                                , accountIsSuperuser = fromMaybe (accountIsSuperuser a) super
+                                , accountEnabled = fromMaybe (accountEnabled a) enabled
+                                , accountSystemCatalogManager = fromMaybe (accountSystemCatalogManager a) manager
+                                , accountAllowSudoAuth = fromMaybe (accountAllowSudoAuth a) sudo
+                                , accountRevision = accountRevision a + 1
+                                }
+                        else a
+                    | a <- accounts
+                    ]
+                    accounts
             _ -> Left "unknown account"
         ReqAccountCreate u h
             | any ((== T.toLower u) . accountUser) accounts -> Left "account already exists"
@@ -581,51 +668,51 @@ memoryAccounts db stamp req = do
             _ -> preserveSuper [x | x <- accounts, accountUser x /= T.toLower u] accounts
         _ -> Left "invalid account request"
   where
-    -- | 判断旧格式身份是否缺少属性
+    -- \| 判断旧格式身份是否缺少属性
     legacyIdentity account = any (legacyRow (accountUser account)) (maybe [] tableRows (lookup usersTable db))
-    -- | 检查旧身份的元数据版本
+    -- \| 检查旧身份的元数据版本
     legacyRow user row = case lookup "account" row of
         Just (VStr encoded) -> case A.decode (BL.pack encoded) of
             Just (A.Object fields) -> KM.lookup "user" fields == Just (A.String user) && not (KM.member "is_superuser" fields)
             _ -> False
         _ -> False
-    -- | 读取旧格式账号
+    -- \| 读取旧格式账号
     decodeAccount row = case lookup "account" row of
         Just (VStr encoded) -> A.eitherDecode (BL.pack encoded)
         _ -> Left "invalid account record"
-    -- | 合并身份与口令
+    -- \| 合并身份与口令
     decodeCredential row = do
         identity <- decodeAccount row
         case [hash | credential <- maybe [] tableRows (lookup usersTable db), lookup "id" credential == Just (VInt (fromInteger (accountId identity))), Just (VStr hash) <- [lookup "password_hash" credential]] of
             [hash] -> Right identity{accountHash = T.pack hash}
             _ -> Left "invalid identity credential"
-    -- | 保留启用的登录管理员
+    -- \| 保留启用的登录管理员
     preserveSuper next old
         | any activeSuper old && not (any activeSuper next) = Left "the last enabled login superuser cannot be removed"
         | otherwise = Right next
-    -- | 判断可登录管理员
+    -- \| 判断可登录管理员
     activeSuper a = accountEnabled a && accountCanLogin a && accountIsSuperuser a
 
 -- | 分开保存内存身份与口令并清理授权
 storeMemoryIdentities :: Database -> [Account] -> [Account] -> Database
 storeMemoryIdentities db previous accounts =
-    (usersTable, Table usersTable [("id", TInt), ("password_hash", TStr)] credentials Nothing Nothing Nothing) :
-    ("__system_identities", Table "__system_identities" [("account", TStr)] identities Nothing Nothing Nothing) :
-    ("__system_identity_sequence", Table "__system_identity_sequence" [("id", TInt)] [[("id", VInt highWater)]] Nothing Nothing Nothing) :
-    [(name, clean name table) | (name, table) <- db, name `notElem` [usersTable, "__system_identities", "__system_identity_sequence"]]
+    (usersTable, Table usersTable [("id", TInt), ("password_hash", TStr)] credentials Nothing Nothing Nothing)
+        : ("__system_identities", Table "__system_identities" [("account", TStr)] identities Nothing Nothing Nothing)
+        : ("__system_identity_sequence", Table "__system_identity_sequence" [("id", TInt)] [[("id", VInt highWater)]] Nothing Nothing Nothing)
+        : [(name, clean name table) | (name, table) <- db, name `notElem` [usersTable, "__system_identities", "__system_identity_sequence"]]
   where
-    -- | 保存口令与身份编号
+    -- \| 保存口令与身份编号
     credentials = [[("id", VInt (fromInteger (accountId a))), ("password_hash", VStr (T.unpack (accountHash a)))] | a <- accounts]
-    -- | 保存不含口令的身份记录
+    -- \| 保存不含口令的身份记录
     identities = [[("account", VStr (BL.unpack (A.encode a{accountHash = ""})))] | a <- accounts]
-    -- | 保留已用编号上界
+    -- \| 保留已用编号上界
     highWater = maximum (0 : map (fromInteger . accountId) accounts ++ [n | row <- maybe [] tableRows (lookup "__system_identity_sequence" db), Just (VInt n) <- [lookup "id" row]])
-    -- | 清理旧目录与失效的授权边
+    -- \| 清理旧目录与失效的授权边
     clean name table
         | name == rolesTable = table{tableRows = []}
         | name `elem` [grantsTable, optionsTable, membersTable] = table{tableRows = filter active (tableRows table)}
         | otherwise = table
-    -- | 识别已经删除的身份
+    -- \| 识别已经删除的身份
     removed = [accountUser a | a <- previous, accountUser a `notElem` map accountUser accounts]
-    -- | 排除已删除身份的授权和成员边
+    -- \| 排除已删除身份的授权和成员边
     active row = not (any (\field -> case lookup field row of Just (VStr value) -> T.pack value `elem` removed; _ -> False) ["role", "member"])

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

@@ -1,35 +1,35 @@
-module ChuSQL.Server.Catalog
-    ( Catalog
-    , newCatalog
-    , normalizeRole
-    , normalizeUser
-    , normalizeObject
-    , withCatalog
-    , withCatalogLock
-    , ensureCatalog
-    , eachAction
-    , readRoleNames
-    , readIdentities
-    , insertRole
-    , dropRole
-    , readGrants
-    , addGrant
-    , removeGrant
-    , readGrantOptions
-    , addGrantOption
-    , removeGrantOption
-    , readMembers
-    , addMember
-    , removeMember
-    ) where
+module ChuSQL.Server.Catalog (
+    Catalog,
+    newCatalog,
+    normalizeRole,
+    normalizeUser,
+    normalizeObject,
+    withCatalog,
+    withCatalogLock,
+    ensureCatalog,
+    eachAction,
+    readRoleNames,
+    readIdentities,
+    insertRole,
+    dropRole,
+    readGrants,
+    addGrant,
+    removeGrant,
+    readGrantOptions,
+    addGrantOption,
+    removeGrantOption,
+    readMembers,
+    addMember,
+    removeMember,
+) where
 
-import Control.Monad (void)
 import ChuSQL.Core.Model (Row, Value (..))
 import ChuSQL.Core.Protocol (Account (..), Request (..))
 import ChuSQL.Interface.Actions (escapeStringLiteral)
 import ChuSQL.Interface.Protocol (Grant (..))
 import ChuSQL.Server.Backend (Backend (..), StatementResult (..), grantsTable, membersTable, optionsTable, rolesTable)
 import Control.Concurrent.MVar (MVar, newMVar, withMVar)
+import Control.Monad (void)
 import Data.List (intercalate, isInfixOf)
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -77,7 +77,7 @@ withCatalog catalog action = withCatalogLock catalog $ do
 ensureCatalog :: Catalog -> IO (Either String ())
 ensureCatalog catalog = eachAction tableDefs (createTable catalog)
   where
-    -- | 三张系统表的定义
+    -- \| 三张系统表的定义
     tableDefs =
         [ (rolesTable, "(name VARCHAR(64))")
         , (grantsTable, "(role VARCHAR(64), privilege VARCHAR(16), object VARCHAR(128))")
@@ -191,7 +191,7 @@ grantOf row =
 
 -- | 一行带 grant option 的授权记录
 optionOf :: Row -> Grant
-optionOf row = (grantOf row) {grantable = True}
+optionOf row = (grantOf row){grantable = True}
 
 -- | 一行成员关系
 memberOf :: Row -> (Text, Text)
@@ -200,8 +200,14 @@ memberOf row = (normalizeRole (cell "role" row), normalizeUser (cell "member" ro
 -- | 拼一条删授权的语句
 deleteGrantSql :: String -> Text -> Text -> Text -> String
 deleteGrantSql table role privilege object =
-    "DELETE FROM " ++ table ++ " WHERE role = " ++ roleLiteral role
-        ++ " AND privilege = " ++ literal privilege ++ " AND object = " ++ literal object
+    "DELETE FROM "
+        ++ table
+        ++ " WHERE role = "
+        ++ roleLiteral role
+        ++ " AND privilege = "
+        ++ literal privilege
+        ++ " AND object = "
+        ++ literal object
 
 -- | 拼一条插入语句
 insertSql :: String -> [String] -> [Text] -> String

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

@@ -2,7 +2,6 @@
 
 module ChuSQL.Server.Normalization (normalizationBudget, normalizationReport, schemaFingerprint) where
 
-import Data.Maybe (fromMaybe)
 import qualified ChuSQL.Core.Engine.Normalization as N
 import ChuSQL.Core.Model (Column (..), parseColumnType)
 import ChuSQL.Core.Protocol (SchemaColumn (..), valueToJSON)
@@ -11,10 +10,11 @@ import Control.Concurrent.MVar
 import Control.Concurrent.QSem
 import Control.Exception (bracket_, evaluate, mask)
 import Crypto.Hash (Digest, SHA256, hash)
+import Data.Aeson (object, (.=))
 import qualified Data.Aeson as A
-import Data.Aeson ((.=), object)
 import qualified Data.ByteString.Lazy as BL
 import Data.List (nub, sort)
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
 import System.IO.Unsafe (unsafePerformIO)
@@ -32,8 +32,9 @@ normalizationBudget :: IO (Either (Text, Text) A.Value) -> IO (Either (Text, Tex
 normalizationBudget action = mask $ \restore -> do
     let (queued, slots) = analysisSlots
     admitted <- modifyMVar queued $ \count -> pure (if count < 8 then (count + 1, True) else (count, False))
-    if not admitted then pure (Left ("too_busy", "normalization queue is full")) else
-        bracket_ (pure ()) (modifyMVar_ queued (pure . subtract 1)) $ do
+    if not admitted
+        then pure (Left ("too_busy", "normalization queue is full"))
+        else bracket_ (pure ()) (modifyMVar_ queued (pure . subtract 1)) $ do
             result <- restore $ timeout 5000000 $ bracket_ (waitQSem slots) (signalQSem slots) $ do
                 outcome <- action
                 case outcome of
@@ -45,8 +46,17 @@ normalizationBudget action = mask $ \restore -> do
 
 -- 编码只影响语义的列信息。
 fingerprintColumn :: SchemaColumn -> A.Value
-fingerprintColumn c = A.toJSON [A.toJSON (scName c), A.toJSON (scType c), A.toJSON (scNullable c),
-    maybe A.Null valueToJSON (scDefault c), A.toJSON (scAutoIncrement c), A.toJSON (scPrimaryKey c), A.toJSON (scUnique c), A.toJSON (scCheck c)]
+fingerprintColumn c =
+    A.toJSON
+        [ A.toJSON (scName c)
+        , A.toJSON (scType c)
+        , A.toJSON (scNullable c)
+        , maybe A.Null valueToJSON (scDefault c)
+        , A.toJSON (scAutoIncrement c)
+        , A.toJSON (scPrimaryKey c)
+        , A.toJSON (scUnique c)
+        , A.toJSON (scCheck c)
+        ]
 
 -- 将稳定编号与列结构绑定到 SHA256。
 schemaFingerprint :: ObjectIdentity -> [SchemaColumn] -> Text
@@ -57,16 +67,29 @@ normalizationReport :: ObjectIdentity -> [SchemaColumn] -> Text -> Normalization
 normalizationReport identity columns view payload = do
     let fingerprint = schemaFingerprint identity columns
     if maybe False (/= identity) (nrExpectedObject payload) || maybe False (/= fingerprint) (nrExpectedSchema payload)
-        then Left ("conflict", "normalization object or schema has changed") else Right ()
+        then Left ("conflict", "normalization object or schema has changed")
+        else Right ()
     schema <- mapM column columns
     let declaration = nrDeclaration payload
         axioms = N.Declaration (ndKeys declaration) [N.Dependency a b | NormalizationDependency a b <- ndDependencies declaration] (ndComplete declaration) (ndAtomic declaration)
     analysis <- either (Left . (,) "bad_request" . T.pack) Right (N.analyzeNormalization schema axioms)
-    Right (object ["api_version" .= (1 :: Int), "database" .= nrDatabase payload, "table" .= last (T.splitOn "." (nrTable payload)),
-        "object" .= identity, "schema_fingerprint" .= fingerprint, "view" .= view, "schema" .= columns,
-        "declaration" .= canonicalDeclaration declaration, "candidate_keys" .= N.candidateKeys analysis,
-        "findings" .= map findingJSON (N.findings analysis), "suggestions" .= map decompositionJSON (N.suggestions analysis),
-        "conditional" .= True, "condition" .= ("Analysis is conditional on the declarations; SQL NULL, UNIQUE and bag semantics are not proofs of classical keys or lossless data migration." :: Text)])
+    Right
+        ( object
+            [ "api_version" .= (1 :: Int)
+            , "database" .= nrDatabase payload
+            , "table" .= last (T.splitOn "." (nrTable payload))
+            , "object" .= identity
+            , "schema_fingerprint" .= fingerprint
+            , "view" .= view
+            , "schema" .= columns
+            , "declaration" .= canonicalDeclaration declaration
+            , "candidate_keys" .= N.candidateKeys analysis
+            , "findings" .= map findingJSON (N.findings analysis)
+            , "suggestions" .= map decompositionJSON (N.suggestions analysis)
+            , "conditional" .= True
+            , "condition" .= ("Analysis is conditional on the declarations; SQL NULL, UNIQUE and bag semantics are not proofs of classical keys or lossless data migration." :: Text)
+            ]
+        )
   where
     -- 还原列类型及声明约束而不读取数据。
     column c = case parseColumnType (scType c) of
@@ -75,13 +98,21 @@ normalizationReport identity columns view payload = do
 
 -- 规范化经验证的声明属性集合。
 canonicalDeclaration :: NormalizationDeclaration -> NormalizationDeclaration
-canonicalDeclaration d = d {ndKeys = sort (nub (map N.canonical (ndKeys d))),
-    ndDependencies = [NormalizationDependency a b | (a, b) <- sort (nub [(N.canonical a, N.canonical b) | NormalizationDependency a b <- ndDependencies d])]}
+canonicalDeclaration d =
+    d
+        { ndKeys = sort (nub (map N.canonical (ndKeys d)))
+        , ndDependencies = [NormalizationDependency a b | (a, b) <- sort (nub [(N.canonical a, N.canonical b) | NormalizationDependency a b <- ndDependencies d])]
+        }
 
 -- 编码稳定范式标签及证据。
 findingJSON :: N.Finding -> A.Value
-findingJSON f = object ["normal_form" .= formTag (N.normalForm f), "verdict" .= verdictTag (N.verdict f),
-    "witnesses" .= [NormalizationDependency a b | N.Dependency a b <- N.witnesses f], "condition" .= N.condition f]
+findingJSON f =
+    object
+        [ "normal_form" .= formTag (N.normalForm f)
+        , "verdict" .= verdictTag (N.verdict f)
+        , "witnesses" .= [NormalizationDependency a b | N.Dependency a b <- N.witnesses f]
+        , "condition" .= N.condition f
+        ]
 
 -- 编码一次分解的理论结论。
 decompositionJSON :: N.Decomposition -> A.Value

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

@@ -1,23 +1,34 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module ChuSQL.Server.ObjectACL
-    ( objectAuthorize, objectGrant, objectRevoke, objectRevokeGrantOption, objectViews, objectClaim
-    , objectSelfViews, objectReconcile, objectAffected, objectOwner, objectConnect, objectPrepareCreate, objectUsers
-    ) where
+module ChuSQL.Server.ObjectACL (
+    objectAuthorize,
+    objectGrant,
+    objectRevoke,
+    objectRevokeGrantOption,
+    objectViews,
+    objectClaim,
+    objectSelfViews,
+    objectReconcile,
+    objectAffected,
+    objectOwner,
+    objectConnect,
+    objectPrepareCreate,
+    objectUsers,
+) where
 
-import Data.Either (fromRight)
-import Control.Monad (void)
 import ChuSQL.Core.Protocol (Account (..), TableInfo (..))
 import ChuSQL.Interface.Protocol (Grant (..))
 import ChuSQL.Server.Accounts (Principal, principalIsRoot, principalName)
 import ChuSQL.Server.Backend (Backend (..))
-import ChuSQL.Server.Catalog (Catalog, readIdentities, readMembers, readGrants, readGrantOptions)
+import ChuSQL.Server.Catalog (Catalog, readGrantOptions, readGrants, readIdentities, readMembers)
+import Control.Monad (void)
 import Data.Aeson (FromJSON, ToJSON)
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Key as K
 import qualified Data.Aeson.KeyMap as KM
 import qualified Data.ByteString.Lazy.Char8 as BL
+import Data.Either (fromRight)
 import Data.List (nub)
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -26,35 +37,40 @@ import GHC.Generics (Generic)
 
 -- 稳定对象权限目录：保存所有者、授予来源并计算有效授权链。
 
-data Target = Target { targetDatabase :: Text, targetTable :: Maybe Text, targetKind :: Text, targetName :: Text }
+data Target = Target {targetDatabase :: Text, targetTable :: Maybe Text, targetKind :: Text, targetName :: Text}
     deriving (Eq, Show, Generic)
 instance ToJSON Target
 instance FromJSON Target
 
-data Edge = Edge { edgeRole :: Text, edgeGrantor :: Text, edgeTarget :: Target, edgePrivilege :: Text, edgeOption :: Bool, edgeRoot :: Bool }
+data Edge = Edge {edgeRole :: Text, edgeGrantor :: Text, edgeTarget :: Target, edgePrivilege :: Text, edgeOption :: Bool, edgeRoot :: Bool}
     deriving (Eq, Show, Generic)
 instance ToJSON Edge
 instance FromJSON Edge
 
-data Owner = Owner { ownerRole :: Text, ownerTarget :: Target }
+data Owner = Owner {ownerRole :: Text, ownerTarget :: Target}
     deriving (Eq, Show, Generic)
 instance ToJSON Owner
 instance FromJSON Owner
 
-data Pending = Pending { pendingRole :: Text, pendingDatabase :: Text, pendingName :: Text }
+data Pending = Pending {pendingRole :: Text, pendingDatabase :: Text, pendingName :: Text}
     deriving (Eq, Show, Generic)
 instance ToJSON Pending
 instance FromJSON Pending
 
-data ACL = ACL { aclVersion :: Int, aclEdges :: [Edge], aclOwners :: [Owner], aclClosed :: [Text], aclPending :: [Pending] }
+data ACL = ACL {aclVersion :: Int, aclEdges :: [Edge], aclOwners :: [Owner], aclClosed :: [Text], aclPending :: [Pending]}
     deriving (Eq, Show, Generic)
 instance ToJSON ACL
 instance FromJSON ACL where
     -- 读取权限快照并兼容无声明的旧记录。
-    parseJSON = A.withObject "ACL" $ \fields -> ACL <$> fields A..: "aclVersion" <*> fields A..: "aclEdges"
-        <*> fields A..: "aclOwners" <*> fields A..: "aclClosed" <*> (fields A..:? "aclPending" A..!= [])
+    parseJSON = A.withObject "ACL" $ \fields ->
+        ACL
+            <$> fields A..: "aclVersion"
+            <*> fields A..: "aclEdges"
+            <*> fields A..: "aclOwners"
+            <*> fields A..: "aclClosed"
+            <*> (fields A..:? "aclPending" A..!= [])
 
-data Context = Context { contextIdentities :: [Account], contextMembers :: [(Text, Text)], contextTargets :: [Target] }
+data Context = Context {contextIdentities :: [Account], contextMembers :: [(Text, Text)], contextTargets :: [Target]}
 
 -- 解析存储响应并保留明确错误。
 request :: Backend -> A.Value -> IO (Either String A.Value)
@@ -85,18 +101,20 @@ resolve backend database raw = do
             | "database:" `T.isPrefixOf` object = (T.drop 9 object, Nothing, "database", object)
             | object == "*" || ".*" `T.isSuffixOf` object =
                 let scope = if object == "*" then database else T.dropEnd 2 object
-                in (scope, Nothing, "tables", scope <> ".*")
+                 in (scope, Nothing, "tables", scope <> ".*")
             | otherwise = case T.splitOn "." object of
                 [name] -> (database, Just name, "table", database <> "." <> name)
                 [db, name] -> (db, Just name, "table", object)
                 _ -> ("", Just "", "table", object)
-    if T.null selected then pure (Left "no database selected") else do
-        result <- request backend (A.object (["method" A..= ("resolve_object" :: Text), "database" A..= selected] ++ maybe [] (\name -> ["table" A..= name]) table))
-        pure $ do
-            value <- result
-            dbId <- field "database_id" value >>= identifier
-            tableId <- case table of Nothing -> Right Nothing; Just _ -> Just <$> (field "object_id" value >>= identifier)
-            if selected == "system" then Left "system objects cannot be granted" else Right (Target dbId tableId kind label)
+    if T.null selected
+        then pure (Left "no database selected")
+        else do
+            result <- request backend (A.object (["method" A..= ("resolve_object" :: Text), "database" A..= selected] ++ maybe [] (\name -> ["table" A..= name]) table))
+            pure $ do
+                value <- result
+                dbId <- field "database_id" value >>= identifier
+                tableId <- case table of Nothing -> Right Nothing; Just _ -> Just <$> (field "object_id" value >>= identifier)
+                if selected == "system" then Left "system objects cannot be granted" else Right (Target dbId tableId kind label)
 
 -- 展开当前 catalog 中的稳定业务对象。
 targets :: Backend -> IO (Either String [Target])
@@ -152,28 +170,33 @@ knownRole env value = value `elem` ["0", "public"] || any (\account -> T.pack (s
 roles :: Context -> Text -> [Text]
 roles env value = nub ("public" : go [value])
   where
-    pairs = [(parent, child) |
-               (parentName, childName) <- contextMembers env,
-               Right parent <- [roleId env parentName],
-               active env parent,
-               Right child <- [roleId env childName],
-               active env child]
+    pairs =
+        [ (parent, child)
+        | (parentName, childName) <- contextMembers env
+        , Right parent <- [roleId env parentName]
+        , active env parent
+        , Right child <- [roleId env childName]
+        , active env child
+        ]
     -- 展开成员关系的向上闭包。
-    go known = let more = [parent | (parent, child) <- pairs, child `elem` known, parent `notElem` known]
-               in if null more then known else go (nub (known ++ more))
+    go known =
+        let more = [parent | (parent, child) <- pairs, child `elem` known, parent `notElem` known]
+         in if null more then known else go (nub (known ++ more))
 
 -- 判断一个对象范围是否覆盖目标。
 covers :: Target -> Target -> Bool
-covers source target = targetDatabase source == targetDatabase target &&
-    (targetKind source == "tables" && targetKind target `elem` ["tables", "table"] || targetKind source == targetKind target && targetTable source == targetTable target)
+covers source target =
+    targetDatabase source == targetDatabase target
+        && (targetKind source == "tables" && targetKind target `elem` ["tables", "table"] || targetKind source == targetKind target && targetTable source == targetTable target)
 
 -- 判断稳定对象当前是否存在。
 exists :: Context -> Target -> Bool
 exists env target = any same (contextTargets env)
   where
     -- 核对数据库或表的稳定编号。
-    same current = targetDatabase current == targetDatabase target &&
-        (targetKind target == "tables" && targetKind current == "database" || targetKind current == targetKind target && targetTable current == targetTable target)
+    same current =
+        targetDatabase current == targetDatabase target
+            && (targetKind target == "tables" && targetKind current == "database" || targetKind current == targetKind target && targetTable current == targetTable target)
 
 -- 判断身份是否拥有指定对象。
 owns :: Context -> ACL -> Text -> Target -> Bool
@@ -181,14 +204,15 @@ owns env acl identity target = any (\owner -> ownerRole owner `elem` roles env i
 
 -- 计算仍有合法授予来源的授权闭包。
 effective :: Context -> ACL -> ACL
-effective env acl = acl {aclOwners = owners, aclEdges = grow roots, aclClosed = [value | value <- aclClosed acl, any (\target -> targetKind target == "database" && targetDatabase target == value) (contextTargets env)]}
+effective env acl = acl{aclOwners = owners, aclEdges = grow roots, aclClosed = [value | value <- aclClosed acl, any (\target -> targetKind target == "database" && targetDatabase target == value) (contextTargets env)]}
   where
     owners = [owner | owner <- aclOwners acl, knownRole env (ownerRole owner), exists env (ownerTarget owner)]
     candidates = [edge | edge <- aclEdges acl, knownRole env (edgeRole edge), knownRole env (edgeGrantor edge), exists env (edgeTarget edge)]
     roots = [edge | edge <- candidates, edgeRoot edge]
     -- 从独立授予根展开转授权链。
-    grow known = let more = [edge | edge <- candidates, edge `notElem` known, supported known edge]
-                 in if null more then known else grow (known ++ more)
+    grow known =
+        let more = [edge | edge <- candidates, edge `notElem` known, supported known edge]
+         in if null more then known else grow (known ++ more)
     -- 检查授予者的所有权或有效转授权。
     supported known edge = active env (edgeGrantor edge) && (owns env acl{aclOwners = owners} (edgeGrantor edge) (edgeTarget edge) || any (\source -> active env (edgeRole source) && edgeOption source && edgeRole source `elem` roles env (edgeGrantor edge) && edgePrivilege source == edgePrivilege edge && covers (edgeTarget source) (edgeTarget edge)) known)
 
@@ -201,16 +225,16 @@ readACL backend = do
         rows <- field "rows" value
         case rows of
             A.Array values -> case foldr (:) [] values of
-              [] -> Right (Nothing, Nothing)
-              [row] -> do
-                payload <- field "payload" row
-                case payload of
-                    A.String text -> case A.eitherDecodeStrict (TE.encodeUtf8 text) of
-                        Left err -> Left ("invalid object ACL: " ++ err)
-                        Right acl | aclVersion acl == 1 -> Right (Just text, Just acl)
-                        Right _ -> Left "unsupported object ACL version"
-                    _ -> Left "invalid object ACL payload"
-              _ -> Left "invalid object ACL rows"
+                [] -> Right (Nothing, Nothing)
+                [row] -> do
+                    payload <- field "payload" row
+                    case payload of
+                        A.String text -> case A.eitherDecodeStrict (TE.encodeUtf8 text) of
+                            Left err -> Left ("invalid object ACL: " ++ err)
+                            Right acl | aclVersion acl == 1 -> Right (Just text, Just acl)
+                            Right _ -> Left "unsupported object ACL version"
+                        _ -> Left "invalid object ACL payload"
+                _ -> Left "invalid object ACL rows"
             _ -> Left "invalid object ACL rows"
 
 -- 原子写入权限快照并检查并发版本。
@@ -230,8 +254,10 @@ migrate backend catalog env = do
     one options grant = case roleId env (grantRole grant) of
         Left _ -> pure (Right [])
         Right identity -> do
-            objects <- if grantObject grant == "*" then pure (Right [target | target <- contextTargets env, targetKind target == "table"])
-                else fmap (fmap (: [])) (resolve backend "" (grantObject grant))
+            objects <-
+                if grantObject grant == "*"
+                    then pure (Right [target | target <- contextTargets env, targetKind target == "table"])
+                    else fmap (fmap (: [])) (resolve backend "" (grantObject grant))
             let option = any (\row -> grantRole row == grantRole grant && grantPrivilege row == grantPrivilege grant && grantObject row == grantObject grant) options
             pure $ case objects of
                 Left "unknown table" -> Right []
@@ -248,8 +274,14 @@ load backend catalog = do
         Left err -> pure (Left err)
         Right (current, (previous, Just acl)) | null (aclPending acl) -> pure (Right (current, previous, effective current acl))
         Right (current, (previous, Just acl)) -> do
-            let recovered = [Owner (pendingRole pending) target | pending <- aclPending acl, target <- contextTargets current,
-                    targetKind target == "table", targetDatabase target == pendingDatabase pending, targetName target == pendingName pending]
+            let recovered =
+                    [ Owner (pendingRole pending) target
+                    | pending <- aclPending acl
+                    , target <- contextTargets current
+                    , targetKind target == "table"
+                    , targetDatabase target == pendingDatabase pending
+                    , targetName target == pendingName pending
+                    ]
                 next = acl{aclPending = [], aclOwners = recovered ++ [owner | owner <- aclOwners acl, ownerTarget owner `notElem` map ownerTarget recovered]}
             written <- writeACL backend previous (effective current next)
             case written of Left err -> pure (Left err); Right () -> load backend catalog
@@ -266,9 +298,10 @@ load backend catalog = do
 
 -- 检查作用域权限或所有权。
 allowed :: Context -> ACL -> Text -> Target -> Text -> Bool -> Bool
-allowed env acl identity target privilege option = owns env acl identity target ||
-    (not option && privilege == "connect" && targetKind target == "database" && targetDatabase target `notElem` aclClosed acl) ||
-    any (\edge -> active env (edgeRole edge) && edgeRole edge `elem` roles env identity && edgePrivilege edge == privilege && covers (edgeTarget edge) target && (not option || edgeOption edge)) (aclEdges acl)
+allowed env acl identity target privilege option =
+    owns env acl identity target
+        || (not option && privilege == "connect" && targetKind target == "database" && targetDatabase target `notElem` aclClosed acl)
+        || any (\edge -> active env (edgeRole edge) && edgeRole edge `elem` roles env identity && edgePrivilege edge == privilege && covers (edgeTarget edge) target && (not option || edgeOption edge)) (aclEdges acl)
 
 -- 按对象类型展开和校验权限名称。
 privileges :: Target -> [Text] -> Either String [Text]
@@ -276,10 +309,14 @@ privileges target names =
     if all (`elem` supported) expanded then Right expanded else Left "invalid privilege for object scope"
   where
     supported = if targetKind target == "database" then ["connect", "create"] else ["select", "insert", "update", "delete"]
-    expanded = nub (concatMap
-                      ((\ name -> if name == "all" then supported else [name])
-                         . T.toLower)
-                      names)
+    expanded =
+        nub
+            ( concatMap
+                ( (\name -> if name == "all" then supported else [name])
+                    . T.toLower
+                )
+                names
+            )
 
 -- 检查一组稳定对象上的业务权限。
 objectAuthorize :: Backend -> Catalog -> Principal -> Text -> [(Text, Text)] -> IO (Either String ())
@@ -310,18 +347,19 @@ objectGrant backend catalog principal database names object role option = do
             recipient <- roleId env role
             items <- privileges target names
             grantor <- if principalIsRoot principal then Right (fromRight "0" (roleId env (principalName principal))) else roleId env (principalName principal)
-            case [item |
-                    not (principalIsRoot principal),
-                    item <- items,
-                    not (allowed env acl grantor target item True)] of
+            case [ item
+                 | not (principalIsRoot principal)
+                 , item <- items
+                 , not (allowed env acl grantor target item True)
+                 ] of
                 item : _ -> Left ("grant option required: " ++ T.unpack (T.toUpper item <> " ON " <> object))
                 [] -> Right (recipient, grantor, items) of
-                    Left err -> pure (Left err)
-                    Right (recipient, grantor, items) -> do
-                        let edges = [Edge recipient grantor target item option (principalIsRoot principal) | item <- items]
-                            remaining = [edge | edge <- aclEdges acl, not (any (same edge) edges)]
-                            promoted = [edge {edgeOption = edgeOption edge || any (\old -> same old edge && edgeOption old) (aclEdges acl)} | edge <- edges]
-                        writeACL backend previous acl{aclEdges = remaining ++ promoted, aclClosed = if recipient == "public" && "connect" `elem` items then filter (/= targetDatabase target) (aclClosed acl) else aclClosed acl}
+            Left err -> pure (Left err)
+            Right (recipient, grantor, items) -> do
+                let edges = [Edge recipient grantor target item option (principalIsRoot principal) | item <- items]
+                    remaining = [edge | edge <- aclEdges acl, not (any (same edge) edges)]
+                    promoted = [edge{edgeOption = edgeOption edge || any (\old -> same old edge && edgeOption old) (aclEdges acl)} | edge <- edges]
+                writeACL backend previous acl{aclEdges = remaining ++ promoted, aclClosed = if recipient == "public" && "connect" `elem` items then filter (/= targetDatabase target) (aclClosed acl) else aclClosed acl}
   where
     -- 比较同一授予来源的授权键。
     same one other = edgeRole one == edgeRole other && edgeGrantor one == edgeGrantor other && edgeTarget one == edgeTarget other && edgePrivilege one == edgePrivilege other
@@ -350,7 +388,8 @@ revokeObject optionOnly backend catalog principal database names object role = d
                     next = acl{aclEdges = if optionOnly then map removeOption (aclEdges acl) else filter (not . matches) (aclEdges acl), aclClosed = if not optionOnly && recipient == "public" && "connect" `elem` items then nub (targetDatabase target : aclClosed acl) else aclClosed acl}
                     -- 保留基础权限并移除匹配来源的转授权。
                     removeOption edge = if matches edge then edge{edgeOption = False} else edge
-                if recipient == "public" && "connect" `elem` items && not manager then pure (Left "administrator required")
+                if recipient == "public" && "connect" `elem` items && not manager
+                    then pure (Left "administrator required")
                     else writeACL backend previous (effective env next)
 
 -- 返回公开名称形式的有效授权。
@@ -373,10 +412,12 @@ objectSelfViews backend catalog principal = do
         if active env identity then Right () else Left "permission denied: disabled identity"
         -- 使用当前权限闭包判断普通及转授权权限。
         let permitted target privilege option = principalIsRoot principal || allowed env acl identity target privilege option
-        Right [Grant (principalName principal) privilege (targetName target) (permitted target privilege True)
+        Right
+            [ Grant (principalName principal) privilege (targetName target) (permitted target privilege True)
             | target <- contextTargets env
             , privilege <- if targetKind target == "database" then ["connect", "create"] else ["select", "insert", "update", "delete"]
-            , permitted target privilege False]
+            , permitted target privilege False
+            ]
 
 -- 登记新对象的创建者为所有者。
 objectClaim :: Backend -> Catalog -> Principal -> Text -> Text -> IO (Either String ())
@@ -400,7 +441,8 @@ objectPrepareCreate backend catalog principal database raw = do
             Left err -> pure (Left err)
             Right identity -> do
                 let name = if "." `T.isInfixOf` raw then T.toLower raw else database <> "." <> T.toLower raw
-                if any ((== name) . targetName) (contextTargets env) then pure (Right ())
+                if any ((== name) . targetName) (contextTargets env)
+                    then pure (Right ())
                     else writeACL backend previous acl{aclPending = [Pending identity (targetDatabase target) name]}
 
 -- 清理失效身份、成员来源和已删除对象。
@@ -417,8 +459,9 @@ objectAffected backend catalog names = do
         (env, _, acl) <- loaded
         let edges = [(roleName env (edgeGrantor edge), roleName env (edgeRole edge)) | edge <- aclEdges acl] ++ contextMembers env
             -- 展开成员和转授权的受影响身份。
-            walk seen = let more = [child | (parent, child) <- edges, parent `elem` seen, child `notElem` seen, not (T.null child)]
-                        in if null more then seen else walk (nub (seen ++ more))
+            walk seen =
+                let more = [child | (parent, child) <- edges, parent `elem` seen, child `notElem` seen, not (T.null child)]
+                 in if null more then seen else walk (nub (seen ++ more))
         let normalized = map (T.toLower . T.strip) names
         Right (if "public" `elem` normalized then nub (walk normalized ++ map accountUser (filter (not . accountIsSuperuser) (contextIdentities env))) else walk normalized)
 
@@ -441,7 +484,8 @@ objectUsers backend catalog database object = do
     case (,) <$> loaded <*> resolved of
         Left err -> pure (Left err)
         Right ((env, _, acl), target) -> do
-            let related = [edgeRole edge | edge <- aclEdges acl, if targetKind target == "database" then targetDatabase (edgeTarget edge) == targetDatabase target else covers (edgeTarget edge) target]
-                    ++ [ownerRole owner | owner <- aclOwners acl, ownerTarget owner == target]
+            let related =
+                    [edgeRole edge | edge <- aclEdges acl, if targetKind target == "database" then targetDatabase (edgeTarget edge) == targetDatabase target else covers (edgeTarget edge) target]
+                        ++ [ownerRole owner | owner <- aclOwners acl, ownerTarget owner == target]
             result <- objectAffected backend catalog (nub (map (roleName env) related))
             pure (fmap (filter (\name -> not (any (\account -> accountUser account == name && accountIsSuperuser account) (contextIdentities env)))) result)

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

@@ -1,5 +1,3 @@
-
-
 module ChuSQL.Server.Policy (
     configurePasswordPolicy,
     policyFromValues,

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

@@ -1,31 +1,55 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module ChuSQL.Server.Privileges
-    ( Grant (..), Membership (..), PrivilegeCommand (..), PrivilegeError (..), Privileges, RoleView (..)
-    , affectedAccounts, authorize, authorizeTables, authorizeConnect, filterTables, listRoleViews, listSelfGrants
-    , newPrivileges, normalizeObject, privilegeCommand, runPrivilegeCommand, claimObject, prepareObject, reconcileObjects, affectedObject
-    ) where
+module ChuSQL.Server.Privileges (
+    Grant (..),
+    Membership (..),
+    PrivilegeCommand (..),
+    PrivilegeError (..),
+    Privileges,
+    RoleView (..),
+    affectedAccounts,
+    authorize,
+    authorizeTables,
+    authorizeConnect,
+    filterTables,
+    listRoleViews,
+    listSelfGrants,
+    newPrivileges,
+    normalizeObject,
+    privilegeCommand,
+    runPrivilegeCommand,
+    claimObject,
+    prepareObject,
+    reconcileObjects,
+    affectedObject,
+) where
 
-import Data.Maybe (maybeToList)
 import ChuSQL.Core.Engine.Syntax.AST
 import ChuSQL.Core.Protocol (Account (..))
 import ChuSQL.Interface.Protocol (Grant (..), RoleView (..))
-import ChuSQL.Server.Accounts (Principal, principalIsRoot, principalIsCatalogManager)
+import ChuSQL.Server.Accounts (Principal, principalIsCatalogManager, principalIsRoot)
 import ChuSQL.Server.Backend (Backend (..), exprTables, statementTables, systemDatabaseName)
 import ChuSQL.Server.Catalog
 import qualified ChuSQL.Server.ObjectACL as OA
 import Data.List (nub, sort)
+import Data.Maybe (maybeToList)
 import Data.Text (Text)
 import qualified Data.Text as T
 
 -- 权限服务：稳定对象授权、角色继承与受影响会话展开。
 
 data PrivilegeError = PrivilegeError Text Text deriving (Show, Eq)
-data Membership = Membership { memberRole :: Text, memberUser :: Text } deriving (Show, Eq, Ord)
-data PrivilegeCommand = CreateRoleCommand Text | DropRoleCommand Text
-    | GrantPrivilegesCommand [Text] Text Text Bool | RevokePrivilegesCommand [Text] Text Text | RevokeGrantOptionCommand [Text] Text Text
-    | GrantRoleCommand Text [Text] | RevokeRoleCommand Text [Text] deriving (Show, Eq)
-data Privileges = Privileges { pvCatalog :: Catalog, pvBackend :: Backend }
+data Membership = Membership {memberRole :: Text, memberUser :: Text} deriving (Show, Eq, Ord)
+data PrivilegeCommand
+    = CreateRoleCommand Text
+    | DropRoleCommand Text
+    | GrantPrivilegesCommand [Text] Text Text Bool
+    | RevokePrivilegesCommand [Text] Text Text
+    | RevokeGrantOptionCommand [Text] Text Text
+    | GrantRoleCommand Text [Text]
+    | RevokeRoleCommand Text [Text]
+    deriving (Show, Eq)
+data Privileges = Privileges {pvCatalog :: Catalog, pvBackend :: Backend}
 
 -- 创建权限目录服务。
 newPrivileges :: Backend -> IO Privileges
@@ -56,9 +80,10 @@ runPrivilegeCommand service principal database command = withTables service $ ca
             known <- catalog (readRoleNames directory)
             case known of
                 Left err -> pure (Left err)
-                Right names | normalizeRole role `elem` names -> pure (Left (PrivilegeError "conflict" ("role already exists: " <> role)))
-                            | normalizeRole role == "public" -> pure (Left (PrivilegeError "bad_request" "public is reserved for default privileges"))
-                            | otherwise -> catalog (insertRole directory role)
+                Right names
+                    | normalizeRole role `elem` names -> pure (Left (PrivilegeError "conflict" ("role already exists: " <> role)))
+                    | normalizeRole role == "public" -> pure (Left (PrivilegeError "bad_request" "public is reserved for default privileges"))
+                    | otherwise -> catalog (insertRole directory role)
     DropRoleCommand role
         | principalIsRoot principal -> after (catalog (dropRole directory role))
     GrantRoleCommand role members
@@ -94,12 +119,14 @@ validateMembers names pairs role members
     foldMembers edges (member : rest)
         | child `elem` closureUp edges [parent] = Left (PrivilegeError "conflict" ("role membership would create a cycle: " <> parent <> " and " <> child))
         | otherwise = foldMembers ((parent, child) : edges) rest
-      where child = normalizeUser member
+      where
+        child = normalizeUser member
 
 -- 展开角色的继承闭包。
 closureUp :: [(Text, Text)] -> [Text] -> [Text]
-closureUp edges known = let more = [parent | (parent, child) <- edges, child `elem` known, parent `notElem` known]
-                       in if null more then known else closureUp edges (nub (known ++ more))
+closureUp edges known =
+    let more = [parent | (parent, child) <- edges, child `elem` known, parent `notElem` known]
+     in if null more then known else closureUp edges (nub (known ++ more))
 
 -- 展开成员和转授权变更影响的全部身份。
 affectedAccounts :: Privileges -> PrivilegeCommand -> IO (Either PrivilegeError [Text])
@@ -173,12 +200,13 @@ listRoleViews service = withTables service $ do
     members <- catalog (readMembers (pvCatalog service))
     case (,) <$> names <*> members of
         Left err -> pure (Left err)
-        Right (identities, pairs) -> sequence
-                                       <$>
-                                         mapM
-                                           (view pairs)
-                                           (sort
-                                              (map accountUser (filter (not . accountCanLogin) identities)))
+        Right (identities, pairs) ->
+            sequence
+                <$> mapM
+                    (view pairs)
+                    ( sort
+                        (map accountUser (filter (not . accountCanLogin) identities))
+                    )
   where
     -- 组装一个角色的公开权限视图。
     view members name = do
@@ -228,13 +256,14 @@ catalog = fmap (either (Left . storageError) Right)
 storageError :: String -> PrivilegeError
 storageError message = PrivilegeError code (T.pack message)
   where
-    code | message == "no database selected" = "no_database"
-         | any (`T.isPrefixOf` T.pack message) ["permission denied:", "grant option required:", "object owner required", "administrator required", "system objects cannot be granted"] = "forbidden"
-         | any (`T.isPrefixOf` T.pack message) ["unknown role:", "unknown table", "unknown database"] = "not_found"
-         | message == "object ACL changed concurrently" = "conflict"
-         | message == "invalid privilege for object scope" = "bad_request"
-         | message == "the last enabled login superuser cannot be removed" = "bad_request"
-         | otherwise = "storage_error"
+    code
+        | message == "no database selected" = "no_database"
+        | any (`T.isPrefixOf` T.pack message) ["permission denied:", "grant option required:", "object owner required", "administrator required", "system objects cannot be granted"] = "forbidden"
+        | any (`T.isPrefixOf` T.pack message) ["unknown role:", "unknown table", "unknown database"] = "not_found"
+        | message == "object ACL changed concurrently" = "conflict"
+        | message == "invalid privilege for object scope" = "bad_request"
+        | message == "the last enabled login superuser cannot be removed" = "bad_request"
+        | otherwise = "storage_error"
 
 forbidden :: PrivilegeError
 forbidden = PrivilegeError "forbidden" "administrator required"

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

@@ -1,25 +1,31 @@
-module ChuSQL.Server.Security (readSecurity, writeSecurity) where
+module ChuSQL.Server.Security (readSecurity, writeSecurity, databaseSecurity, commitSecurity) where
 
-import Control.Monad (when)
 import Control.Concurrent.MVar
-import Control.Exception (bracket_, mask_)
+import Control.Exception (bracket, bracket_, mask_)
+import Control.Monad (when)
+import qualified Data.Map.Strict as Map
 import System.IO.Unsafe (unsafePerformIO)
 
--- 共享权限门：查询并行读取，权限和对象变更独占执行。
+-- 权限变更独占全局门，业务按库排序取门，允许不同库并行写。
+
+data Gate = Gate (MVar ()) (MVar ()) (MVar Int)
+
+-- 创建公平的共享读写门。
+newGate :: IO Gate
+newGate = Gate <$> newMVar () <*> newMVar () <*> newMVar 0
 
 {-# NOINLINE securityGate #-}
-securityGate :: (MVar (), MVar (), MVar Int)
-securityGate = unsafePerformIO $ do
-    turn <- newMVar ()
-    room <- newMVar ()
-    readers <- newMVar 0
-    pure (turn, room, readers)
+securityGate :: Gate
+securityGate = unsafePerformIO newGate
 
--- 并行执行权限稳定期间的查询。
-readSecurity :: IO a -> IO a
-readSecurity = bracket_ enter leave
+{-# NOINLINE databaseGates #-}
+databaseGates :: MVar (Map.Map String (Gate, Int))
+databaseGates = unsafePerformIO (newMVar Map.empty)
+
+-- 在共享门内执行并保证取消时归还计数。
+readGate :: Gate -> IO a -> IO a
+readGate (Gate turn room readers) = bracket_ enter leave
   where
-    (turn, room, readers) = securityGate
     -- 登记共享读取者。
     enter = withMVar turn $ \_ -> modifyMVar_ readers $ \count -> do
         when (count == 0) $ takeMVar room
@@ -29,8 +35,46 @@ readSecurity = bracket_ enter leave
         when (count == 1) $ putMVar room ()
         pure (count - 1)
 
--- 独占执行权限或对象变更。
+-- 独占执行写入及提交的校验与发布。
+writeGate :: Gate -> IO a -> IO a
+writeGate (Gate turn room _) action = withMVar turn $ \_ -> withMVar room (const action)
+
+-- 并行执行权限稳定期间的查询。
+readSecurity :: IO a -> IO a
+readSecurity = readGate securityGate
+
+-- 全局排除权限与对象变更期间的数据请求。
 writeSecurity :: IO a -> IO a
-writeSecurity action = withMVar turn $ \_ -> withMVar room (const action)
+writeSecurity = writeGate securityGate
+
+-- 按名称取库门，固定顺序避免跨库等待环。
+databaseSecurity :: [(String, Bool)] -> IO a -> IO a
+databaseSecurity accesses action = readSecurity (keyedSecurity accesses action)
+
+-- 只排序短暂提交检查，不阻塞行锁等待与准备。
+commitSecurity :: String -> IO a -> IO a
+commitSecurity database = keyedSecurity [("\0commit:" ++ database, True)]
+
+-- 管理有序键门及引用生命周期。
+keyedSecurity :: [(String, Bool)] -> IO a -> IO a
+keyedSecurity accesses action = bracket register unregister $ \gates -> lock gates action
   where
-    (turn, room, _) = securityGate
+    names = Map.toAscList (Map.fromListWith (||) (filter (not . null . fst) accesses))
+    -- 先登记所有等待者，防止等待中的门被释放。
+    register = modifyMVar databaseGates $ \existing -> do
+        entries <- mapM (entry existing) names
+        let updated = foldr (\(name, gate, count, _) -> Map.insert name (gate, count)) existing entries
+        pure (updated, entries)
+    -- 复用活跃门或创建首次访问的门。
+    entry existing (name, exclusive) = case Map.lookup name existing of
+        Just (gate, count) -> pure (name, gate, count + 1, exclusive)
+        Nothing -> do
+            gate <- newGate
+            pure (name, gate, 1, exclusive)
+    -- 最后一个持有者或等待者离开时回收门。
+    unregister entries = modifyMVar_ databaseGates $ \existing -> pure (foldr release existing entries)
+    -- 使用当前引用计数，避免覆盖并发登记。
+    release (name, _, _, _) = Map.update (\(gate, count) -> if count == 1 then Nothing else Just (gate, count - 1)) name
+    -- 递归持有有序门并在异常时逆序释放。
+    lock [] body = body
+    lock ((_, gate, _, exclusive) : rest) body = (if exclusive then writeGate else readGate) gate (lock rest body)

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

@@ -1,68 +1,73 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 
-module ChuSQL.Server.Session
-    ( QueryResult (..)
-    , Session
-    , SessionError (..)
-    , engineErrorCode
-    , newSession
-    , newSessionWith
-    , sessionUser
-    , sessionIsAdmin
-    , sessionDatabase
-    , isPlainIdentifier
-    , authenticateSession
-    , authenticateSessionCoded
-    , authenticateSudoSessionCoded
-    , switchDatabase
-    , runStatement
-    , runStatementCoded
-    , runStorageCoded
-    , analyzeNormalizationCoded
-    , catalog
-    , accounts
-    , roleViews
-    , databases
-    , policyOf
-    , reloadPolicy
-    , queryResultJson
-    ) where
+module ChuSQL.Server.Session (
+    QueryResult (..),
+    Session,
+    SessionError (..),
+    engineErrorCode,
+    newSession,
+    closeSession,
+    newSessionWith,
+    sessionUser,
+    sessionIsAdmin,
+    sessionDatabase,
+    isPlainIdentifier,
+    authenticateSession,
+    authenticateSessionCoded,
+    authenticateSudoSessionCoded,
+    switchDatabase,
+    runStatement,
+    runStatementCoded,
+    runStorageCoded,
+    analyzeNormalizationCoded,
+    catalog,
+    accounts,
+    roleViews,
+    databases,
+    policyOf,
+    reloadPolicy,
+    queryResultJson,
+) where
 
-import ChuSQL.Core.Model (Database, Row, Table (..), Value (..), Column (..), typeName)
-import ChuSQL.Core.Protocol
-    ( SchemaColumn(..),
-      Account(..),
-      Request(..),
-      QueryResult(..),
-      TxnOp(..),
-      queryResultJson )
-import ChuSQL.Interface.Normalization
-import ChuSQL.Server.Normalization (normalizationBudget, normalizationReport)
-import Data.Aeson.Types (parseEither)
-import qualified Data.ByteString.Lazy as BL
-import ChuSQL.Core.Engine.Storage.IPC (TableInfo (..))
 import qualified ChuSQL.Core.Engine as Engine
 import qualified ChuSQL.Core.Engine.Error as E
+import ChuSQL.Core.Engine.Runtime.Dependencies (domainDependencies, queryTables, validateDependencies)
+import ChuSQL.Core.Engine.Storage.IPC (TableInfo (..))
 import ChuSQL.Core.Engine.Syntax.AST (Statement (..))
 import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
+import ChuSQL.Core.Model (Column (..), Database, Row, Table (..), Value (..), lastTablePart, typeName)
+import ChuSQL.Core.Protocol (
+    Account (..),
+    QueryResult (..),
+    Request (..),
+    SchemaColumn (..),
+    TxnOp (..),
+    queryResultJson,
+ )
 import ChuSQL.Interface.AccountTable (systemTableInfo)
 import ChuSQL.Interface.Auth (defaultSessionPolicy, newSessionStore)
+import ChuSQL.Interface.Normalization
 import ChuSQL.Server.Accounts
-import ChuSQL.Server.Backend (Backend (..), StatementResult (..), columnsFromStatement, scopeDdl)
+import ChuSQL.Server.Backend (Backend (..), StatementResult (..), applyTransactionMemory, columnsFromStatement, scopeDdl)
+import ChuSQL.Server.Normalization (normalizationBudget, normalizationReport)
 import ChuSQL.Server.Policy (configurePasswordPolicy)
-import ChuSQL.Server.Privileges (PrivilegeCommand (..), PrivilegeError (..), Privileges, RoleView, Grant (..), affectedAccounts, affectedObject, authorize, authorizeTables, authorizeConnect, claimObject, prepareObject, reconcileObjects, filterTables, listRoleViews, listSelfGrants, newPrivileges, privilegeCommand, runPrivilegeCommand)
-import ChuSQL.Server.Security (readSecurity, writeSecurity)
+import ChuSQL.Server.Privileges (Grant (..), PrivilegeCommand (..), PrivilegeError (..), Privileges, RoleView, affectedAccounts, affectedObject, authorize, authorizeConnect, authorizeTables, claimObject, filterTables, listRoleViews, listSelfGrants, newPrivileges, prepareObject, privilegeCommand, reconcileObjects, runPrivilegeCommand)
+import ChuSQL.Server.Security (commitSecurity, databaseSecurity, readSecurity, writeSecurity)
 import Control.Exception (IOException, try)
-import Data.Bifunctor (first)
-import Data.Char (isAlpha, isAlphaNum)
-import Data.IORef (IORef, newIORef, readIORef, writeIORef)
-import Data.Maybe (isJust, fromMaybe)
-import qualified Data.IntMap.Strict as IM
-import qualified Data.IntSet as IS
-import Data.Text (Text)
-import qualified Data.Text as T
 import qualified Data.Aeson as A
 import qualified Data.Aeson.KeyMap as KM
+import Data.Aeson.Types (parseEither)
+import Data.Bifunctor (first)
+import qualified Data.ByteString.Lazy as BL
+import Data.Char (isAlpha, isAlphaNum)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import qualified Data.IntMap.Strict as IM
+import qualified Data.IntSet as IS
+import Data.List (nub)
+import Data.Maybe (fromMaybe, isJust)
+import Data.Text (Text)
+import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
 
 -- SQL 会话：Web、命令行与 TCP 服务器共用的账号、权限与语句执行入口。
@@ -97,6 +102,8 @@ data Transaction = Transaction
     , txSavepoints :: [(String, Database, [Statement])]
     , txStatements :: [Statement]
     , txObjects :: [(String, A.Value)]
+    , txToken :: Maybe String
+    , txSerializable :: Bool
     }
 
 -- | 开一个会话：账号与角色服务、配置策略都和 Web 端一致
@@ -117,6 +124,18 @@ newSessionWith backend name settingsFile changed = do
     transaction <- newIORef Nothing
     pure (Session backend accountsService privileges current principal identityStamp settingsFile transaction changed)
 
+-- 关闭连接时归还存储事务、版本引用与行锁。
+closeSession :: Session -> IO ()
+closeSession session = do
+    existing <- readIORef (ssTransaction session)
+    writeIORef (ssTransaction session) Nothing
+    case existing >>= txToken of
+        Nothing -> pure ()
+        Just token -> do
+            backend <- currentBackend session
+            result <- beRollbackTransaction backend token
+            either (ioError . userError) pure result
+
 -- | 当前生效的口令策略（只有管理员能看）
 policyOf :: Session -> IO (Either Text PasswordPolicy)
 policyOf session = do
@@ -195,7 +214,7 @@ storePrincipal session principal = do
         Right account -> do
             writeIORef (ssPrincipal session) (Just principal)
             writeIORef (ssIdentityStamp session) (Just (accountId account, accountRevision account))
-            writeIORef (ssTransaction session) Nothing
+            closeSession session
             writeIORef (ssCurrent session) ""
             pure (Right ())
 
@@ -216,7 +235,7 @@ switchDatabaseCoded session rawName
     | otherwise = go
   where
     name = T.toLower (T.strip rawName)
-    -- | 真的切库并记下当前库
+    -- \| 真的切库并记下当前库
     go = do
         who <- readIORef (ssPrincipal session)
         allowed <- case who of
@@ -237,17 +256,35 @@ runStatement session sql = fmap (first sessMessage) (runStatementCoded session s
 
 -- | 跑一条语句（带错误码）
 runStatementCoded :: Session -> Text -> IO (Either SessionError QueryResult)
-runStatementCoded session sql = gate $ do
-    valid <- validatePrincipal session
-    case valid of Left err -> pure (Left err); Right () -> runStatementUnlocked session sql
+runStatementCoded session sql = do
+    current <- readIORef (ssCurrent session)
+    gate current $ do
+        valid <- validatePrincipal session
+        case valid of Left err -> pure (Left err); Right () -> runStatementUnlocked session sql
   where
-    gate = case parseStatement (T.unpack sql) of
+    -- 对象及权限变更独占，数据请求按来源库排序。
+    gate current = case parseStatement (T.unpack sql) of
+        Right CommitTransaction -> databaseSecurity [(T.unpack current, not (beConcurrentTransactions (ssBackend session)))]
         Right statement | transactionDdl statement || isJust (accountCommand statement) || isJust (privilegeCommand statement) -> writeSecurity
-        _ -> readSecurity
+        Right statement -> databaseSecurity (accesses current statement)
+        Left _ -> readSecurity
+    -- 当前库写入独占，跨库查询依赖共享。
+    accesses current statement =
+        (T.unpack current, writing statement && not (beConcurrentTransactions (ssBackend session))) : [(source name, False) | name <- queryTables statement]
+      where
+        -- 无限定表使用当前工作库。
+        source name = case break (== '.') name of
+            (database, '.' : _) -> T.unpack (T.toLower (T.pack database))
+            _ -> T.unpack current
+    -- 只有数据写语句需要独占目标库。
+    writing Insert{} = True
+    writing Update{} = True
+    writing Delete{} = True
+    writing _ = False
 
 -- 在权限门内检查并执行管理员存储请求。
 runStorageCoded :: Session -> A.Value -> IO (Either SessionError A.Value)
-runStorageCoded session payload = writeSecurity $ do
+runStorageCoded session payload = gate $ do
     valid <- validatePrincipal session
     who <- readIORef (ssPrincipal session)
     case valid of
@@ -256,6 +293,11 @@ runStorageCoded session payload = writeSecurity $ do
             Nothing -> pure (Left (SessionError "unauthorized" "sign in first"))
             Just principal | not (principalIsRoot principal) -> pure (Left (SessionError "forbidden" "administrator required"))
             Just _ -> fmap (first (SessionError "storage_error" . T.pack)) (beStorage (ssBackend session) payload)
+  where
+    -- 在线整理期间允许普通数据语句进入。
+    gate = case payload of
+        A.Object object | KM.lookup "method" object == Just (A.String "compact") -> readSecurity
+        _ -> writeSecurity
 
 -- 检查登录身份的当前版本和启用状态。
 validatePrincipal :: Session -> IO (Either SessionError ())
@@ -285,7 +327,8 @@ runStatementUnlocked session sql = case parseStatement (T.unpack sql) of
                     Right () -> do
                         current <- readIORef (ssCurrent session)
                         pure (Right (emptyResult (Just current)))
-    Right BeginTransaction -> beginTransaction session
+    Right BeginTransaction -> beginTransaction session False
+    Right BeginSerializableTransaction -> beginTransaction session True
     Right CommitTransaction -> commitTransaction session
     Right RollbackTransaction -> rollbackTransaction session
     Right (Savepoint name) -> savepointTransaction session (T.pack name)
@@ -306,6 +349,7 @@ runStatementUnlocked session sql = case parseStatement (T.unpack sql) of
                         Left err -> pure (Left err)
                         Right ()
                             | isJust transaction && transactionData statement -> runInTransaction session statement
+                            | beConcurrentTransactions (ssBackend session) && transactionData statement -> runAutocommit session statement
                             | otherwise -> runObjectStatement session statement sql
     Left _ -> runPlain session sql
 
@@ -314,6 +358,7 @@ transactionDdl :: Statement -> Bool
 transactionDdl statement = case statement of
     CreateTable{} -> True
     CreateDomain{} -> True
+    AlterDomain{} -> True
     DropDomain{} -> True
     DropTable{} -> True
     CreateIndex{} -> True
@@ -339,14 +384,14 @@ transactionData statement = case statement of
     _ -> False
 
 -- | 开事务：把当前库整库做一份快照当起点
-beginTransaction :: Session -> IO (Either SessionError QueryResult)
-beginTransaction session = do
+beginTransaction :: Session -> Bool -> IO (Either SessionError QueryResult)
+beginTransaction session serializable = do
     allowed <- sessionConnectAllowed session
-    case allowed of Left err -> pure (Left err); Right () -> beginAuthorized session
+    case allowed of Left err -> pure (Left err); Right () -> beginAuthorized session serializable
 
 -- 在连接权限复核后建立事务快照。
-beginAuthorized :: Session -> IO (Either SessionError QueryResult)
-beginAuthorized session = do
+beginAuthorized :: Session -> Bool -> IO (Either SessionError QueryResult)
+beginAuthorized session serializable = do
     current <- readIORef (ssCurrent session)
     existing <- readIORef (ssTransaction session)
     case existing of
@@ -355,15 +400,20 @@ beginAuthorized session = do
             | T.null current -> pure (Left (SessionError "no_database" "no database selected"))
             | otherwise -> do
                 backend <- currentBackend session
-                snapshotResult <- beSnapshot backend
+                snapshotResult <-
+                    if beConcurrentTransactions backend
+                        then beBeginTransaction backend serializable
+                        else fmap (fmap (Nothing,)) (beSnapshot backend)
                 case snapshotResult of
                     Left err -> pure (Left (engineErrorCode err))
-                    Right db -> do
+                    Right (token, db) -> do
                         objects <- snapshotObjectIds session (map fst db)
                         case objects of
-                            Left err -> pure (Left err)
+                            Left err -> do
+                                released <- maybe (pure (Right ())) (beRollbackTransaction backend) token
+                                pure (either (Left . engineErrorCode) (const (Left err)) released)
                             Right ids -> do
-                                writeIORef (ssTransaction session) (Just (Transaction db db [] [] ids))
+                                writeIORef (ssTransaction session) (Just (Transaction db db [] [] ids token serializable))
                                 pure (Right (emptyResult (Just current)))
 
 -- | 提交：把快照差分交给存储层应用，成功才结束事务
@@ -379,25 +429,84 @@ commitTransaction session = do
             identities <- snapshotObjectIds session (map fst (txBase transaction))
             case connected >> sequence permissions >> identities of
                 Left err -> pure (Left err)
-                Right ids | ids /= txObjects transaction -> pure (Left (SessionError "serialization_failure" "transaction object identity changed"))
-                          | otherwise -> commitAuthorized session current transaction
+                Right ids
+                    | ids /= txObjects transaction -> pure (Left (SessionError "serialization_failure" "transaction object identity changed"))
+                    | otherwise -> commitAuthorized session current transaction
 
 -- 对象和权限复核后提交事务差分。
 commitAuthorized :: Session -> Text -> Transaction -> IO (Either SessionError QueryResult)
-commitAuthorized session current transaction = do
-            backend <- currentBackend session
-            liveResult <- beSnapshot backend
-            case liveResult of
-                Left err -> pure (Left (engineErrorCode err))
-                Right live -> let diffs = transactionDiffs (txBase transaction) (txStaged transaction) live in case transactionConflict diffs of
-                    Just msg -> pure (Left (SessionError "serialization_failure" (T.pack msg)))
-                    Nothing -> do
-                        applied <- beApplyTransaction backend (transactionOps diffs)
-                        case applied of
-                            Left err -> pure (Left (engineErrorCode err))
-                            Right () -> do
-                                writeIORef (ssTransaction session) Nothing
-                                pure (Right (emptyResult (Just current)))
+commitAuthorized session current transaction
+    | Just token <- txToken transaction = commitSecurity (T.unpack current) (commitMvcc session current transaction token)
+    | otherwise = commitLegacy session current transaction
+
+-- 在短提交门内校验最新合并行集并发布版本。
+commitMvcc :: Session -> Text -> Transaction -> String -> IO (Either SessionError QueryResult)
+commitMvcc session current transaction token = do
+    backend <- currentBackend session
+    preview <- bePreviewTransaction backend token
+    case preview of
+        Left err -> pure (Left (engineErrorCode err))
+        Right (checkpoint, candidate) -> do
+            let modified = changedTables (txBase transaction) (txStaged transaction)
+                names = modified ++ domainDependencies (txBase transaction) modified
+                dependencies = [(name, table) | (name, table) <- txBase transaction, name `elem` names]
+                checked = validateDependencies dependencies candidate >> mapM_ (validateFinal candidate) modified
+            case checked of
+                Left err -> pure (Left (SessionError "serialization_failure" (T.pack err)))
+                Right () -> do
+                    result <- beCommitTransaction backend token checkpoint
+                    case result of
+                        Left err -> pure (Left (engineErrorCode err))
+                        Right () -> do
+                            writeIORef (ssTransaction session) Nothing
+                            pure (Right (emptyResult (Just current)))
+  where
+    -- 复用 SQL 最终行集约束，避免存储重复规则。
+    validateFinal candidate name = maybe (Left "transaction table missing") (Engine.validateTableRows candidate) (lookup name candidate)
+
+-- 内存后端保留原差分提交与冲突行为。
+commitLegacy :: Session -> Text -> Transaction -> IO (Either SessionError QueryResult)
+commitLegacy session current transaction = do
+    backend <- currentBackend session
+    liveResult <- beSnapshot backend
+    case liveResult of
+        Left err -> pure (Left (engineErrorCode err))
+        Right live -> do
+            let base = txBase transaction
+                diffs = transactionDiffs base (txStaged transaction) live
+                modified =
+                    [ name
+                    | (name, diff) <- diffs
+                    , not (null (tdDeletes diff) && null (tdWrites diff)) || isJust (tdReplace diff)
+                    ]
+                readTables = if txSerializable transaction && not (null modified) then nub (map lastTablePart (concatMap queryTables (txStatements transaction))) else []
+                names = modified ++ readTables ++ domainDependencies base (modified ++ readTables)
+                dependencies = [(name, table) | (name, table) <- base, name `elem` names]
+                ops = transactionOps diffs
+                checked = do
+                    validateDependencies dependencies live
+                    maybe (Right ()) Left (transactionConflict diffs)
+                    mapM_ (validateRead base live) readTables
+                    candidate <- applyTransactionMemory ops live
+                    mapM_ (validateFinal candidate) modified
+            case checked of
+                Left msg -> pure (Left (SessionError "serialization_failure" (T.pack msg)))
+                Right () -> do
+                    applied <- beApplyTransaction backend ops
+                    case applied of
+                        Left err -> pure (Left (engineErrorCode err))
+                        Right () -> do
+                            writeIORef (ssTransaction session) Nothing
+                            pure (Right (emptyResult (Just current)))
+  where
+    -- 拒绝读过的表出现数据变化或幻行。
+    validateRead base live name = case (lookup name base, lookup name live) of
+        (Just before, Just after) | tableRows before == tableRows after -> Right ()
+        _ -> Left ("serializable transaction read changed: " ++ name)
+    -- 复用引擎规则检查合并后的最终行集。
+    validateFinal candidate name = case lookup name candidate of
+        Nothing -> Left ("transaction table missing: " ++ name)
+        Just table -> Engine.validateTableRows candidate table
 
 -- 检查当前数据库连接权限。
 sessionConnectAllowed :: Session -> IO (Either SessionError ())
@@ -412,9 +521,11 @@ sessionConnectAllowed session = do
 snapshotObjectIds :: Session -> [String] -> IO (Either SessionError [(String, A.Value)])
 snapshotObjectIds session names = do
     database <- readIORef (ssCurrent session)
-    if database == "system" then pure (Right []) else do
-        results <- mapM (one database) (filter (not . T.isPrefixOf "__system_" . T.pack) names)
-        pure (sequence results)
+    if database == "system"
+        then pure (Right [])
+        else do
+            results <- mapM (one database) (filter (not . T.isPrefixOf "__system_" . T.pack) names)
+            pure (sequence results)
   where
     -- 解析一个快照表的稳定对象编号。
     one database name = do
@@ -431,9 +542,14 @@ rollbackTransaction session = do
     existing <- readIORef (ssTransaction session)
     case existing of
         Nothing -> pure (Left (SessionError "query_error" "no transaction in progress"))
-        Just _ -> do
-            writeIORef (ssTransaction session) Nothing
-            pure (Right (emptyResult (Just current)))
+        Just transaction -> do
+            backend <- currentBackend session
+            result <- maybe (pure (Right ())) (beRollbackTransaction backend) (txToken transaction)
+            case result of
+                Left err -> pure (Left (engineErrorCode err))
+                Right () -> do
+                    writeIORef (ssTransaction session) Nothing
+                    pure (Right (emptyResult (Just current)))
 
 -- | 建保存点：把事务当前状态压进保存点栈
 savepointTransaction :: Session -> Text -> IO (Either SessionError QueryResult)
@@ -444,7 +560,7 @@ savepointTransaction session name = do
         Nothing -> pure (Left (SessionError "query_error" "no transaction in progress"))
         Just transaction -> do
             let stack = txSavepoints transaction ++ [(T.unpack name, txStaged transaction, txStatements transaction)]
-            writeIORef (ssTransaction session) (Just transaction {txSavepoints = stack})
+            writeIORef (ssTransaction session) (Just transaction{txSavepoints = stack})
             pure (Right (emptyResult (Just current)))
 
 -- | 回滚到保存点：事务状态退回保存点，该保存点保留
@@ -458,10 +574,13 @@ rollbackToSavepoint session name = do
             Nothing -> pure (Left (SessionError "query_error" ("no such savepoint: " <> name)))
             Just index -> do
                 let (_, staged, statements) = txSavepoints transaction !! index
-                writeIORef
-                    (ssTransaction session)
-                    (Just transaction {txStaged = staged, txStatements = statements, txSavepoints = take (index + 1) (txSavepoints transaction)})
-                pure (Right (emptyResult (Just current)))
+                let next = transaction{txStaged = staged, txStatements = statements, txSavepoints = take (index + 1) (txSavepoints transaction)}
+                stagedResult <- stageMvcc session next
+                case stagedResult of
+                    Left err -> pure (Left err)
+                    Right () -> do
+                        writeIORef (ssTransaction session) (Just next)
+                        pure (Right (emptyResult (Just current)))
 
 -- | 释放保存点：该保存点与它之后的保存点一起丢掉
 releaseSavepoint :: Session -> Text -> IO (Either SessionError QueryResult)
@@ -473,7 +592,7 @@ releaseSavepoint session name = do
         Just transaction -> case savepointIndex name (txSavepoints transaction) of
             Nothing -> pure (Left (SessionError "query_error" ("no such savepoint: " <> name)))
             Just index -> do
-                writeIORef (ssTransaction session) (Just transaction {txSavepoints = take index (txSavepoints transaction)})
+                writeIORef (ssTransaction session) (Just transaction{txSavepoints = take index (txSavepoints transaction)})
                 pure (Right (emptyResult (Just current)))
 
 -- | 最近一次同名保存点的下标
@@ -483,7 +602,7 @@ savepointIndex name entries =
         [] -> Nothing
         hits -> Just (last hits)
 
--- | 事务里跑一条数据语句：只动内存快照，不碰存储层
+-- | 执行事务数据语句并取得修改行锁
 runInTransaction :: Session -> Statement -> IO (Either SessionError QueryResult)
 runInTransaction session statement = do
     existing <- readIORef (ssTransaction session)
@@ -493,8 +612,48 @@ runInTransaction session statement = do
         Just transaction -> case scopeDdl (T.unpack current) statement >>= Engine.runStatement (txStaged transaction) of
             Left err -> pure (Left (engineErrorCode err))
             Right (staged, rows) -> do
-                writeIORef (ssTransaction session) (Just transaction {txStaged = staged, txStatements = statement : txStatements transaction})
-                pure (Right (resultOfStaged (txStaged transaction) statement rows))
+                let next = transaction{txStaged = staged, txStatements = statement : txStatements transaction}
+                locked <- stageMvcc session next
+                case locked of
+                    Left err -> pure (Left err)
+                    Right () -> do
+                        writeIORef (ssTransaction session) (Just next)
+                        pure (Right (resultOfStaged (txStaged transaction) statement rows))
+
+-- 自动提交语句同样拥有快照和原子提交边界。
+runAutocommit :: Session -> Statement -> IO (Either SessionError QueryResult)
+runAutocommit session statement = do
+    begun <- beginTransaction session False
+    case begun of
+        Left err -> pure (Left err)
+        Right _ -> do
+            executed <- runInTransaction session statement
+            case executed of
+                Left err -> do
+                    rolled <- rollbackTransaction session
+                    pure (const (Left err) =<< rolled)
+                Right rows -> do
+                    committed <- commitTransaction session
+                    case committed of
+                        Right _ -> pure (Right rows)
+                        Left err -> do
+                            rolled <- rollbackTransaction session
+                            pure (const (Left err) =<< rolled)
+
+-- 比较事务最终行集，保留原表顺序。
+changedTables :: Database -> Database -> [String]
+changedTables base staged = [name | (name, table) <- staged, fmap tableRows (lookup name base) /= Just (tableRows table)]
+
+-- 获取本事务实际修改行的锁并更新读依赖。
+stageMvcc :: Session -> Transaction -> IO (Either SessionError ())
+stageMvcc session transaction = case txToken transaction of
+    Nothing -> pure (Right ())
+    Just token -> do
+        backend <- currentBackend session
+        let modified = changedTables (txBase transaction) (txStaged transaction)
+            ops = [TxnReplace name (tableRows table) | (name, table) <- txStaged transaction, name `elem` modified]
+            dependencies = nub (map lastTablePart (concatMap queryTables (txStatements transaction)))
+        fmap (first engineErrorCode) (beStageTransaction backend token ops dependencies)
 
 -- | 事务内的结果集：空结果回落到解析出来的列名
 resultOfStaged :: Database -> Statement -> [Row] -> QueryResult
@@ -516,7 +675,7 @@ data TableDiff = TableDiff
 transactionOps :: [(String, TableDiff)] -> [TxnOp]
 transactionOps = concatMap opsOf
   where
-    -- | 一张表的请求：先删后写
+    -- \| 一张表的请求：先删后写
     opsOf (name, diff) =
         [TxnDelete name (tdDeletes diff) | not (null (tdDeletes diff))]
             ++ [TxnUpsert name (tdWrites diff) | not (null (tdWrites diff))]
@@ -533,16 +692,16 @@ transactionConflict diffs =
 transactionDiffs :: Database -> Database -> Database -> [(String, TableDiff)]
 transactionDiffs base staged live = [(name, diffFor name) | name <- names]
   where
-    -- | 事务里碰得着的表：数据语句不增删表
+    -- \| 事务里碰得着的表：数据语句不增删表
     names = nubKeys (map fst base ++ map fst staged)
 
-    -- | 一张表的差异
+    -- \| 一张表的差异
     diffFor name
         | stagedRows == baseRows = emptyDiff
         | all (isJust . rowKey) (baseRows ++ stagedRows) = keyedDiff
         -- 动过，库里还是基线：整表替换
-        | liveRows == baseRows = emptyDiff {tdReplace = Just stagedRows}
-        | otherwise = emptyDiff {tdConflict = Just ("write conflict on table " ++ name)}
+        | liveRows == baseRows = emptyDiff{tdReplace = Just stagedRows}
+        | otherwise = emptyDiff{tdConflict = Just ("write conflict on table " ++ name)}
       where
         baseRows = rowsOf name base
         stagedRows = rowsOf name staged
@@ -577,13 +736,13 @@ transactionDiffs base staged live = [(name, diffFor name) | name <- names]
                     [] -> Nothing
                 }
 
-    -- | 没有差异的空结果
+    -- \| 没有差异的空结果
     emptyDiff = TableDiff [] [] Nothing Nothing
 
-    -- | 表名去重但保持顺序
+    -- \| 表名去重但保持顺序
     nubKeys = foldr (\name acc -> if name `elem` acc then acc else name : acc) []
 
-    -- | 库里某张表的行
+    -- \| 库里某张表的行
     rowsOf name db = maybe [] tableRows (lookup name db)
 
 -- | 按整数 id 建立保留首行的查找表
@@ -759,14 +918,31 @@ currentBackend session = do
 showIdentities :: Session -> IO (Either SessionError QueryResult)
 showIdentities session = do
     admin <- maybe False principalIsCatalogManager <$> readIORef (ssPrincipal session)
-    if not admin then pure (Left (SessionError "forbidden" "catalog manager required")) else do
-        result <- beAccounts (ssBackend session) ReqAccountsList
-        pure $ case result of
-            Left err -> Left (SessionError "storage_error" (T.pack err))
-            Right identities -> Right (QueryResult ["id", "name", "can_login", "is_superuser", "enabled", "system_catalog_manager", "allow_sudo_auth", "created_at"]
-                [[VInt (fromInteger (accountId a)), VStr (T.unpack (accountUser a)), VBool (accountCanLogin a),
-                    VBool (accountIsSuperuser a), VBool (accountEnabled a), VBool (accountSystemCatalogManager a), VBool (accountAllowSudoAuth a), VStr (T.unpack (accountRegisteredAt a))] | a <- identities]
-                (length identities) False Nothing)
+    if not admin
+        then pure (Left (SessionError "forbidden" "catalog manager required"))
+        else do
+            result <- beAccounts (ssBackend session) ReqAccountsList
+            pure $ case result of
+                Left err -> Left (SessionError "storage_error" (T.pack err))
+                Right identities ->
+                    Right
+                        ( QueryResult
+                            ["id", "name", "can_login", "is_superuser", "enabled", "system_catalog_manager", "allow_sudo_auth", "created_at"]
+                            [ [ VInt (fromInteger (accountId a))
+                              , VStr (T.unpack (accountUser a))
+                              , VBool (accountCanLogin a)
+                              , VBool (accountIsSuperuser a)
+                              , VBool (accountEnabled a)
+                              , VBool (accountSystemCatalogManager a)
+                              , VBool (accountAllowSudoAuth a)
+                              , VStr (T.unpack (accountRegisteredAt a))
+                              ]
+                            | a <- identities
+                            ]
+                            (length identities)
+                            False
+                            Nothing
+                        )
 
 -- | 执行身份管理并通知受影响会话
 runAccount :: Session -> AccountCommand -> IO (Either SessionError QueryResult)
@@ -849,10 +1025,9 @@ resultOf result =
         , qrDatabase = Nothing
         }
   where
-    -- | 按列名取单元格
+    -- \| 按列名取单元格
     cellOf row name = fromMaybe VNull (lookup name row)
 
-
 -- 展示当前登录身份自己的有效权限。
 showSelfGrants :: Session -> IO (Either SessionError QueryResult)
 showSelfGrants session = do
@@ -863,10 +1038,15 @@ showSelfGrants session = do
             grants <- listSelfGrants (ssPrivileges session) principal
             pure $ case grants of
                 Left err -> Left (privilegeErrorOf err)
-                Right rows -> Right (QueryResult ["identity", "privilege", "object", "grant_option"]
-                    [[VStr (T.unpack (grantRole grant)), VStr (T.unpack (grantPrivilege grant)), VStr (T.unpack (grantObject grant)), VBool (grantable grant)] | grant <- rows]
-                    (length rows) False Nothing)
-
+                Right rows ->
+                    Right
+                        ( QueryResult
+                            ["identity", "privilege", "object", "grant_option"]
+                            [[VStr (T.unpack (grantRole grant)), VStr (T.unpack (grantPrivilege grant)), VStr (T.unpack (grantObject grant)), VBool (grantable grant)] | grant <- rows]
+                            (length rows)
+                            False
+                            Nothing
+                        )
 
 -- 在连接视图及权限稳定期间分析范式。
 analyzeNormalizationCoded :: Session -> NormalizationRequest -> IO (Either SessionError A.Value)
@@ -902,8 +1082,9 @@ normalizationView session table payload = do
             Left message -> pure (Left ("storage_error", message))
             Right identity -> case transaction of
                 Just tx -> case (lookup (T.unpack table) (txStaged tx), lookup (T.unpack table) (txObjects tx)) of
-                    (Just relation, Just oldObject) | objectIdentity oldObject == Right identity ->
-                        pure (normalizationReport identity (map normalizationColumn (tableCols relation)) "transaction_snapshot" payload)
+                    (Just relation, Just oldObject)
+                        | objectIdentity oldObject == Right identity ->
+                            pure (normalizationReport identity (map normalizationColumn (tableCols relation)) "transaction_snapshot" payload)
                     _ -> pure (Left ("conflict", "normalization snapshot object has changed"))
                 Nothing -> do
                     backend <- currentBackend session

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

@@ -1,6 +1,6 @@
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 
 module ChuSQL.Server.TCP (
     ServerConfig (..),
@@ -16,18 +16,17 @@ module ChuSQL.Server.TCP (
     isLocalPeer,
 ) where
 
+import qualified ChuSQL.Core.Engine.Error as E
+import ChuSQL.Core.Protocol (Account (..), Request (ReqIdentityInitialize))
 import ChuSQL.Interface.Config (ServerConfig (..), defaultServerConfig, loadServerConfigAt)
-import ChuSQL.Interface.Sudo (SudoCredential, createSudoCredential, removeSudoCredential, sudoChallenge, validSudoChallenge, isLocalPeer)
-import Data.Time.Clock (UTCTime, getCurrentTime)
 import ChuSQL.Interface.Policy (PasswordPolicy (..))
 import ChuSQL.Interface.Protocol (ClientRequest (..), ServerResponse (..), decodeRequest, encodeResponse, protocolVersion)
 import ChuSQL.Interface.RateLimit (RateLimiter, rateLimitBlock, rateLimitClear, rateLimitRecord)
-import qualified ChuSQL.Core.Engine.Error as E
-import ChuSQL.Core.Protocol (Account (..), Request (ReqIdentityInitialize))
+import ChuSQL.Interface.Sudo (SudoCredential, createSudoCredential, isLocalPeer, removeSudoCredential, sudoChallenge, validSudoChallenge)
 import ChuSQL.Server.Backend (Backend (..))
-import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), accounts, authenticateSessionCoded, authenticateSudoSessionCoded, isPlainIdentifier, catalog, databases, newSessionWith, policyOf, reloadPolicy, roleViews, analyzeNormalizationCoded, runStatementCoded, runStorageCoded, sessionIsAdmin, sessionUser)
-import ChuSQL.Server.Security (writeSecurity)
 import ChuSQL.Server.Privileges (newPrivileges, reconcileObjects)
+import ChuSQL.Server.Security (writeSecurity)
+import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), accounts, analyzeNormalizationCoded, authenticateSessionCoded, authenticateSudoSessionCoded, catalog, closeSession, databases, isPlainIdentifier, newSessionWith, policyOf, reloadPolicy, roleViews, runStatementCoded, runStorageCoded, sessionIsAdmin, sessionUser)
 import Control.Concurrent (forkIO)
 import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
 import Control.Exception (IOException, bracket, finally, onException, try)
@@ -39,6 +38,7 @@ import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe, isNothing)
 import Data.Text (Text)
 import qualified Data.Text as T
+import Data.Time.Clock (UTCTime, getCurrentTime)
 import Network.Socket (
     AddrInfo (..),
     AddrInfoFlag (AI_PASSIVE),
@@ -54,13 +54,13 @@ import Network.Socket (
     defaultHints,
     defaultProtocol,
     getAddrInfo,
-    getSocketName,
     getPeerName,
+    getSocketName,
     listen,
     setSocketOption,
     socket,
     socketToHandle,
-  )
+ )
 import System.IO (BufferMode (LineBuffering), Handle, IOMode (ReadWriteMode), hClose, hFlush, hPutStrLn, hSetBuffering, hSetNewlineMode, noNewlineTranslation, stderr)
 import System.IO.Error (eofErrorType, isEOFError, mkIOError)
 
@@ -106,11 +106,11 @@ dropConnectionsOf live names = do
     mapM_ markDropped hits
     pure (length hits)
   where
-    -- | 这条连接登录的账号在名单里吗
+    -- \| 这条连接登录的账号在名单里吗
     isOf wanted entry = do
         current <- readIORef (leWho entry)
         pure (maybe False (\name -> T.toLower name `elem` wanted) current)
-    -- | 只做标记：连接在下一次请求应答后收工
+    -- \| 只做标记：连接在下一次请求应答后收工
     markDropped entry = writeIORef (leDropped entry) True
 
 -- 服务器
@@ -163,10 +163,12 @@ runServer :: ServerEnv -> (Int -> IO ()) -> IO ()
 runServer env announce = bracket (listenSocket (scHost (srvConfig env)) (scPort (srvConfig env))) close $ \sock -> do
     port <- actualPort sock
     enableSudo env port
-    (do
-        announce port
-        stopped <- newMVar False
-        acceptLoop env sock stopped) `finally` disableSudo env
+    ( do
+            announce port
+            stopped <- newMVar False
+            acceptLoop env sock stopped
+        )
+        `finally` disableSudo env
 
 -- 为显式配置的本机身份映射创建凭据。
 enableSudo :: ServerEnv -> Int -> IO ()
@@ -174,14 +176,15 @@ enableSudo env port
     | T.null user = pure ()
     | not (isPlainIdentifier user) = ioError (userError "sudo_auth_user must be a plain identity name")
     | otherwise = modifyMVar_ (srvSudo env) $ \case
-                                                Just _
-                                                  -> ioError (userError "sudo authentication is already running")
-                                                Nothing
-                                                  -> do credential <- createSudoCredential port
-                                                        hPutStrLn
-                                                          stderr
-                                                          ("sudo_auth enabled: local elevated identity -> " ++ T.unpack user)
-                                                        pure (Just (port, user, credential))
+        Just _ ->
+            ioError (userError "sudo authentication is already running")
+        Nothing ->
+            do
+                credential <- createSudoCredential port
+                hPutStrLn
+                    stderr
+                    ("sudo_auth enabled: local elevated identity -> " ++ T.unpack user)
+                pure (Just (port, user, credential))
   where
     user = scSudoUser (srvConfig env)
 
@@ -227,7 +230,7 @@ actualPort sock = do
 acceptLoop :: ServerEnv -> Socket -> MVar Bool -> IO ()
 acceptLoop env sock stopped = loop
   where
-    -- | 等下一个连接
+    -- \| 等下一个连接
     loop = do
         stop <- readMVar stopped
         if stop
@@ -260,13 +263,13 @@ serveConnection env conn = do
     entry <- newLiveEntry (isLocalPeer peer)
     unregister <- registerConnection (srvLive env) entry
     session <- newSessionWith (srvBackend env) (srvRootName env) (srvSettingsFile env) (void . dropConnectionsOf (srvLive env))
-    outcome <- try (loop h session entry BSC.empty `finally` unregister) :: IO (Either IOException ())
+    outcome <- try (loop h session entry BSC.empty `finally` (closeSession session `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 entry pending = do
         frame <- readRequestLine h (scMaxMessage (srvConfig env)) pending
         case frame of
@@ -281,7 +284,7 @@ serveConnection env conn = do
                             (response, keepGoing) <- dispatch env session entry request
                             send h response
                             when keepGoing $ loop h session entry remaining
-    -- | 发一条响应并冲缓冲
+    -- \| 发一条响应并冲缓冲
     send h response = do
         BLC.hPutStr h (encodeResponse response)
         BLC.hPutStr h "\n"
@@ -291,7 +294,7 @@ serveConnection env conn = do
 readRequestLine :: Handle -> Int -> BSC.ByteString -> IO (Maybe (BSC.ByteString, BSC.ByteString))
 readRequestLine handle limit = collect [] 0
   where
-    -- | 按块读取至换行、超限或 EOF
+    -- \| 按块读取至换行、超限或 EOF
     collect parts total bytes = case BSC.elemIndex '\n' bytes of
         Just offset -> finish (BSC.take offset bytes : parts) (BSC.drop (offset + 1) bytes)
         Nothing
@@ -299,13 +302,14 @@ readRequestLine handle limit = collect [] 0
             | otherwise -> do
                 next <- BSC.hGetSome handle (max 1 (min 4094 (limit - used) + 2))
                 if BSC.null next
-                    then if used == 0
-                        then ioError (mkIOError eofErrorType "read request" (Just handle) Nothing)
-                        else finish (bytes : parts) BSC.empty
+                    then
+                        if used == 0
+                            then ioError (mkIOError eofErrorType "read request" (Just handle) Nothing)
+                            else finish (bytes : parts) BSC.empty
                     else collect (bytes : parts) used next
           where
             used = total + BSC.length bytes
-    -- | 合并并校验一行的有效长度
+    -- \| 合并并校验一行的有效长度
     finish parts remaining = do
         let line = BSC.dropWhileEnd (== '\r') (BSC.concat (reverse parts))
         pure (if BSC.length line > limit then Nothing else Just (line, remaining))
@@ -387,10 +391,13 @@ sudoLogin env session entry user proof = do
     who <- sessionUser session
     let key = T.toLower (T.strip user)
         mapped = maybe "" (\(_, name, _) -> name) configured
-        valid = leLocal entry && isNothing who && key == mapped
-            && case configured of
-                Just (_, _, credential) -> validSudoChallenge credential now challenge key proof
-                Nothing -> False
+        valid =
+            leLocal entry
+                && isNothing who
+                && key == mapped
+                && case configured of
+                    Just (_, _, credential) -> validSudoChallenge credential now challenge key proof
+                    Nothing -> False
     blocked <- rateLimitBlock (srvLimiter env) key
     response <- case blocked of
         Just _ -> pure (RespError "too_many_attempts" "too many failed sudo logins")
@@ -408,8 +415,15 @@ sudoLogin env session entry user proof = do
                     writeIORef (leWho entry) (Just key)
                     admin <- sessionIsAdmin session
                     pure (RespLogin key admin)
-    hPutStrLn stderr ("sudo_auth attempt: mapped_user=" ++ T.unpack mapped
-        ++ " local=" ++ show (leLocal entry) ++ " result=" ++ auditResult response)
+    hPutStrLn
+        stderr
+        ( "sudo_auth attempt: mapped_user="
+            ++ T.unpack mapped
+            ++ " local="
+            ++ show (leLocal entry)
+            ++ " result="
+            ++ auditResult response
+        )
     pure response
   where
     -- 提取不包含凭据的认证审计结果。
@@ -463,5 +477,5 @@ trimResult limit result
     | otherwise = result
 
 -- | show 成 Text
-tshow :: Show a => a -> Text
+tshow :: (Show a) => a -> Text
 tshow = T.pack . show

chusql-server/test/Spec.hs

@@ -3,7 +3,6 @@
 
 module Main (main) where
 
-import Data.Either (lefts)
 import ChuSQL.Core.Engine.Storage.IPC (
     Account (..),
     Request (ReqAccountCreate, ReqAccountReset, ReqAccountsList, ReqIdentityAlter),
@@ -13,20 +12,28 @@ import ChuSQL.Core.Engine.Storage.IPC (
     setStorageLink,
  )
 import ChuSQL.Core.Engine.Syntax.AST (Statement)
-import ChuSQL.Interface.Normalization
-import ChuSQL.Server.Normalization (normalizationBudget, normalizationReport, schemaFingerprint)
-import ChuSQL.Core.Protocol (SchemaColumn (..))
-import Data.IORef (newIORef, readIORef, writeIORef)
 import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
 import ChuSQL.Core.Model (Database, Histogram (..), Row, Table (..), TableIdentity (..), Value (..), pattern TInt, pattern TStr)
+import ChuSQL.Core.Protocol (SchemaColumn (..), TxnOp (..))
 import ChuSQL.Interface.Auth (hashPasswordWith)
-import ChuSQL.Interface.Protocol (ClientRequest (..), Grant (..), RoleView (..), ServerResponse (..), decodeRequest, encodeResponse, encodeRequest, decodeResponse)
+import ChuSQL.Interface.Link (clientQuery, clientSudoLogin, closeClient, connectClient)
+import ChuSQL.Interface.Normalization
+import ChuSQL.Interface.Protocol (ClientRequest (..), Grant (..), RoleView (..), ServerResponse (..), decodeRequest, decodeResponse, encodeRequest, encodeResponse)
 import ChuSQL.Interface.RateLimit (newRateLimiter)
-import ChuSQL.Interface.Link (connectClient, closeClient, clientSudoLogin, clientQuery)
-import ChuSQL.Interface.Sudo (SudoCredential, newSudoCredential, sudoProof, verifySudoProof, validSudoChallenge,
-    createSudoCredential, removeSudoCredential, readSudoCredential, sudoPrivileged)
+import ChuSQL.Interface.Sudo (
+    SudoCredential,
+    createSudoCredential,
+    newSudoCredential,
+    readSudoCredential,
+    removeSudoCredential,
+    sudoPrivileged,
+    sudoProof,
+    validSudoChallenge,
+    verifySudoProof,
+ )
 import ChuSQL.Server.Accounts (Principal (..), ensureRootAccount)
-import ChuSQL.Server.Backend (Backend (..), StatementResult (..), ipcBackend, memoryBackend)
+import ChuSQL.Server.Backend (Backend (..), StatementResult (..), applyTransactionMemory, ipcBackend, memoryBackend)
+import ChuSQL.Server.Normalization (normalizationBudget, normalizationReport, schemaFingerprint)
 import ChuSQL.Server.Privileges (
     PrivilegeCommand (..),
     PrivilegeError (..),
@@ -35,29 +42,28 @@ import ChuSQL.Server.Privileges (
     authorize,
     authorizeConnect,
     claimObject,
-    prepareObject,
     listRoleViews,
     listSelfGrants,
     newPrivileges,
+    prepareObject,
     runPrivilegeCommand,
  )
-import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), newSession, runStatementCoded, runStorageCoded, authenticateSessionCoded)
+import ChuSQL.Server.Security (databaseSecurity, writeSecurity)
+import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), authenticateSessionCoded, newSession, runStatementCoded, runStorageCoded)
 import ChuSQL.Server.TCP (
     ServerConfig (..),
     ServerEnv (..),
     ServerHandle (..),
     defaultServerConfig,
+    isLocalPeer,
     loadServerConfigAt,
     newServerEnv,
     startServer,
-    isLocalPeer,
  )
-import Control.Concurrent (forkIO, forkFinally, killThread, threadDelay)
+import Control.Concurrent (forkFinally, forkIO, killThread, threadDelay)
 import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, takeMVar)
-import System.Timeout (timeout)
-import Control.Exception (IOException, bracket, finally, try)
-import Control.Monad (replicateM_, void, (>=>), when)
-import Data.List (sort)
+import Control.Exception (IOException, bracket, evaluate, finally, try)
+import Control.Monad (forM_, replicateM_, void, when, (>=>))
 import Data.Aeson (decode)
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Key as K
@@ -65,16 +71,17 @@ import qualified Data.Aeson.KeyMap as KM
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BSC
 import qualified Data.ByteString.Lazy as BL
+import Data.Either (lefts)
+import Data.IORef (atomicModifyIORef', newIORef, readIORef, writeIORef)
+import Data.List (sort)
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
-import qualified Data.Vector as V
 import Data.Time.Clock (addUTCTime, diffUTCTime, getCurrentTime)
+import qualified Data.Vector as V
 import Network.Socket (
     AddrInfo (..),
     SockAddr (..),
-    tupleToHostAddress,
-    tupleToHostAddress6,
     SocketType (Stream),
     addrAddress,
     addrFamily,
@@ -84,6 +91,8 @@ import Network.Socket (
     getAddrInfo,
     socket,
     socketToHandle,
+    tupleToHostAddress,
+    tupleToHostAddress6,
     withSocketsDo,
  )
 import System.Directory (createDirectoryIfMissing, doesFileExist, getTemporaryDirectory, removeFile, removePathForcibly)
@@ -99,6 +108,8 @@ import System.IO (
     hSetNewlineMode,
     noNewlineTranslation,
  )
+import System.Mem.StableName (makeStableName)
+import System.Timeout (timeout)
 import Test.Hspec hiding (after, before)
 
 -- TCP 服务器测试：协议编解码、配置读取与真连服务器的端到端用例。
@@ -129,16 +140,19 @@ spec = do
                 connected <- connectClient "127.0.0.1" (shPort handle)
                 case connected of
                     Left message -> expectationFailure (T.unpack message)
-                    Right client -> (do
-                        clientSudoLogin client credential "local_user" >>= (`shouldBe` Right False)
-                        result <- clientQuery client "select 1"
-                        result `shouldSatisfy` isRightResult) `finally` closeClient client
+                    Right client ->
+                        ( do
+                            clientSudoLogin client credential "local_user" >>= (`shouldBe` Right False)
+                            result <- clientQuery client "select 1"
+                            result `shouldSatisfy` isRightResult
+                        )
+                            `finally` closeClient client
         it "only treats kernel loopback addresses as local" $ do
             isLocalPeer (SockAddrInet 7777 (tupleToHostAddress (127, 0, 0, 1))) `shouldBe` True
             isLocalPeer (SockAddrInet 7777 (tupleToHostAddress (192, 168, 1, 2))) `shouldBe` False
-            isLocalPeer (SockAddrInet6 7777 0 (tupleToHostAddress6 (0,0,0,0,0,0,0,1)) 0) `shouldBe` True
-            isLocalPeer (SockAddrInet6 7777 0 (tupleToHostAddress6 (0,0,0,0,0,65535,32512,1)) 0) `shouldBe` True
-            isLocalPeer (SockAddrInet6 7777 0 (tupleToHostAddress6 (0,0,0,0,0,65535,49320,1)) 0) `shouldBe` False
+            isLocalPeer (SockAddrInet6 7777 0 (tupleToHostAddress6 (0, 0, 0, 0, 0, 0, 0, 1)) 0) `shouldBe` True
+            isLocalPeer (SockAddrInet6 7777 0 (tupleToHostAddress6 (0, 0, 0, 0, 0, 65535, 32512, 1)) 0) `shouldBe` True
+            isLocalPeer (SockAddrInet6 7777 0 (tupleToHostAddress6 (0, 0, 0, 0, 0, 65535, 49320, 1)) 0) `shouldBe` False
         it "binds proofs to the instance, challenge, account and expiration" $ do
             credential <- newSudoCredential
             other <- newSudoCredential
@@ -153,18 +167,19 @@ spec = do
             validSudoChallenge credential now Nothing "local_user" proof `shouldBe` False
         it "requires an OS elevated identity to provision or read credentials" $ do
             privileged <- sudoPrivileged
-            if privileged then do
-                bracket (createSudoCredential 65534) (const (removeSudoCredential 65534)) $ \credential -> do
-                    stored <- readSudoCredential 65534
-                    case stored of
-                        Left message -> expectationFailure (T.unpack message)
-                        Right restored -> sudoProof restored "native" "local_user" `shouldBe` sudoProof credential "native" "local_user"
-                    duplicate <- try (createSudoCredential 65534) :: IO (Either IOException SudoCredential)
-                    duplicate `shouldSatisfy` isLeftResult
-            else do
-                created <- try (createSudoCredential 65534) :: IO (Either IOException SudoCredential)
-                created `shouldSatisfy` isLeftResult
-                readSudoCredential 65534 >>= (`shouldSatisfy` isLeftResult)
+            if privileged
+                then do
+                    bracket (createSudoCredential 65534) (const (removeSudoCredential 65534)) $ \credential -> do
+                        stored <- readSudoCredential 65534
+                        case stored of
+                            Left message -> expectationFailure (T.unpack message)
+                            Right restored -> sudoProof restored "native" "local_user" `shouldBe` sudoProof credential "native" "local_user"
+                        duplicate <- try (createSudoCredential 65534) :: IO (Either IOException SudoCredential)
+                        duplicate `shouldSatisfy` isLeftResult
+                else do
+                    created <- try (createSudoCredential 65534) :: IO (Either IOException SudoCredential)
+                    created `shouldSatisfy` isLeftResult
+                    readSudoCredential 65534 >>= (`shouldSatisfy` isLeftResult)
         it "logs in an ordinary mapped identity without elevating its privileges" $
             withTestSudo $ \_ handle credential -> withConnection handle $ \client -> do
                 answer <- tcpSudo client credential "local_user"
@@ -202,7 +217,8 @@ spec = do
         it "rejects disabled and NOLOGIN identities" $
             withTestSudo $ \_ handle credential -> withConnection handle $ \admin -> do
                 _ <- tcpLogin admin testRootName testRootPassword
-                mapM_ (checkSudoDisabled admin handle credential)
+                mapM_
+                    (checkSudoDisabled admin handle credential)
                     ["alter user local_user disabled", "alter user local_user enabled nologin"]
         it "does not inherit sudo authentication from a role" $
             withTestSudo $ \_ handle credential -> withConnection handle $ \admin -> do
@@ -224,6 +240,7 @@ spec = do
     tcpServerSpec
     privilegeSpec
     objectPrivilegeSpec
+    databaseGateSpec
     transactionSpec
     ipcConcurrencySpec
     identitySpec
@@ -245,9 +262,10 @@ identitySpec = describe "unified identities" $ do
             asText (at "status" shown) `shouldBe` "result"
             switched <- tcpQuery manager "use system"
             asText (at "status" switched) `shouldBe` "result"
-            mapM_ (tcpQuery manager
-                     >=>
-                       (\ reply -> asText (at "code" reply) `shouldBe` "forbidden"))
+            mapM_
+                ( tcpQuery manager
+                    >=> (\reply -> asText (at "code" reply) `shouldBe` "forbidden")
+                )
                 ["alter user manager superuser", "alter user managed system_catalog_manager", "alter user managed allow_sudo_auth", "alter user admin identified by 'Another-Pass123!'", "create database forbidden"]
     it "does not inherit catalog management through role membership" $ withTcpServer defaultServerConfig $ \_ handle ->
         withConnection handle $ \admin -> withConnection handle $ \worker -> do
@@ -312,9 +330,10 @@ identitySpec = describe "unified identities" $ do
     it "protects the last enabled login superuser" $ withTcpServer defaultServerConfig $ \_ handle ->
         withConnection handle $ \h -> do
             _ <- tcpLogin h "admin" "s3cret"
-            mapM_ (tcpQuery h
-                     >=>
-                       (\ reply -> asText (at "code" reply) `shouldBe` "bad_request"))
+            mapM_
+                ( tcpQuery h
+                    >=> (\reply -> asText (at "code" reply) `shouldBe` "bad_request")
+                )
                 ["alter user admin disabled", "alter role admin nologin", "alter user admin nosuperuser", "drop user admin", "drop role admin"]
             shown <- tcpQuery h "show roles"
             asText (at "status" shown) `shouldBe` "result"
@@ -383,22 +402,28 @@ testDatabaseName = "test"
 -- | users 5 行 + orders 1 行
 testDb :: Database
 testDb =
-    [ ( "users"
-      , Table
+    [
+        ( "users"
+        , Table
             "users"
             [("id", TInt), ("name", TStr), ("age", TInt)]
             [ [("id", VInt i), ("name", VStr ("user" ++ show i)), ("age", VInt (20 + i))]
             | i <- [1 .. 5]
             ]
-            Nothing Nothing Nothing
-      )
-    , ( "orders"
-      , Table
+            Nothing
+            Nothing
+            Nothing
+        )
+    ,
+        ( "orders"
+        , Table
             "orders"
             [("id", TInt), ("user_id", TInt)]
             [[("id", VInt 1), ("user_id", VInt 1)]]
-            Nothing Nothing Nothing
-      )
+            Nothing
+            Nothing
+            Nothing
+        )
     ]
 
 -- | 测试管理员名字
@@ -466,8 +491,8 @@ tempSettingsPath name = do
 removeIfExists :: FilePath -> IO ()
 removeIfExists path = do
     there <- doesFileExist path
-    when there
-      $ void (try (removeFile path) :: IO (Either IOException ()))
+    when there $
+        void (try (removeFile path) :: IO (Either IOException ()))
 
 -- | 起一台内存后端的测试服务器：管理员已设口令 `s3cret`
 withTcpServer :: ServerConfig -> (ServerEnv -> ServerHandle -> IO a) -> IO a
@@ -493,11 +518,11 @@ withTcpServerAs password config body = do
 withConnection :: ServerHandle -> (Handle -> IO a) -> IO a
 withConnection handle = bracket open closeQuietly
   where
-    -- | 关连接，忽略异常
+    -- \| 关连接，忽略异常
     closeQuietly h = do
         _ <- try (hClose h) :: IO (Either IOException ())
         pure ()
-    -- | 建连接并配成行缓冲句柄
+    -- \| 建连接并配成行缓冲句柄
     open = withSocketsDo $ do
         infos <- getAddrInfo (Just defaultHints{addrSocketType = Stream}) (Just "127.0.0.1") (Just (show (shPort handle)))
         info <- case infos of
@@ -1023,6 +1048,9 @@ privilegeSpec = describe "server privileges" $ do
 
     it "requires administrator privileges for domain commands" $ withPrivileges $ \service root -> do
         authorizeSql service root "CREATE DOMAIN code AS INT" `shouldReturn` Right ()
+        authorizeSql service root "ALTER DOMAIN code SET NOT NULL" `shouldReturn` Right ()
+        authorizeSql service (Ordinary testAccount) "ALTER DOMAIN code SET NOT NULL"
+            `shouldReturn` Left (PrivilegeError "forbidden" "administrator required")
         authorizeSql service (Ordinary testAccount) "CREATE DOMAIN code AS INT"
             `shouldReturn` Left (PrivilegeError "forbidden" "administrator required")
 
@@ -1071,8 +1099,11 @@ privilegeSpec = describe "server privileges" $ do
         _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
         _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" False)
         _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
-        mapM_ (\sql -> authorizeSql service (Ordinary testAccount) sql
-            `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON orders"))
+        mapM_
+            ( \sql ->
+                authorizeSql service (Ordinary testAccount) sql
+                    `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON orders")
+            )
             [ "SELECT COUNT(*) FROM users HAVING COUNT(*) > (SELECT COUNT(*) FROM orders)"
             , "SELECT name FROM users ORDER BY (SELECT COUNT(*) FROM orders) + id"
             ]
@@ -1172,8 +1203,9 @@ objectPrivilegeSpec = describe "stable object privileges" $ do
         mustRun (beStatement (beWithDatabase backend "test") "CREATE TABLE personal_owned (id INT)")
         claimObject service (Ordinary testAccount) testDatabase "personal_owned" `shouldReturn` Right ()
         grants <- listSelfGrants service (Ordinary testAccount)
-        fmap (filter ((== "test.personal_owned") . grantObject)) grants `shouldBe` Right
-            [Grant "alice" privilege "test.personal_owned" True | privilege <- ["select", "insert", "update", "delete"]]
+        fmap (filter ((== "test.personal_owned") . grantObject)) grants
+            `shouldBe` Right
+                [Grant "alice" privilege "test.personal_owned" True | privilege <- ["select", "insert", "update", "delete"]]
         grants `shouldSatisfy` either (const False) (not . any ((== "test.users") . grantObject))
 
     it "checks DISTINCT table reads and nested subqueries" $ withObjectPrivileges $ \_ service root -> do
@@ -1217,10 +1249,16 @@ objectPrivilegeSpec = describe "stable object privileges" $ do
         release <- newEmptyMVar
         finished <- newEmptyMVar
         revoked <- newEmptyMVar
-        let slow = backend{beWithDatabase = \name -> (beWithDatabase backend name){beStatement = \sql -> do
-                when (sql == "SELECT * FROM users")
-                  $ putMVar started () >> takeMVar release
-                beStatement (beWithDatabase backend name) sql}}
+        let slow =
+                backend
+                    { beWithDatabase = \name ->
+                        (beWithDatabase backend name)
+                            { beStatement = \sql -> do
+                                when (sql == "SELECT * FROM users") $
+                                    putMVar started () >> takeMVar release
+                                beStatement (beWithDatabase backend name) sql
+                            }
+                    }
         settings <- tempSettingsPath "permission-race"
         reader <- newSession slow testRootName settings
         admin <- newSession backend testRootName settings
@@ -1528,9 +1566,159 @@ failureCode = either sessCode (const "")
 intValues :: [[Value]] -> [Int]
 intValues rows = [n | row <- rows, Just (VInt n) <- [nth 0 row]]
 
+-- 数据库执行门的并行、等待与取消回归。
+databaseGateSpec :: Spec
+databaseGateSpec = describe "database execution gates" $ do
+    it "lets another database write while preserving same-database exclusion" $ do
+        entered <- newEmptyMVar
+        release <- newEmptyMVar
+        done <- newEmptyMVar
+        bracket (forkFinally (databaseSecurity [("gate_a", True)] (putMVar entered () >> takeMVar release)) (putMVar done)) killThread $ \_ -> do
+            takeMVar entered
+            timeout 1000000 (databaseSecurity [("gate_b", True)] (pure ())) `shouldReturn` Just ()
+            timeout 50000 (databaseSecurity [("gate_a", False)] (pure ())) `shouldReturn` Nothing
+            timeout 50000 (writeSecurity (pure ())) `shouldReturn` Nothing
+            putMVar release ()
+            result <- timeout 1000000 (takeMVar done)
+            case result of Just (Right ()) -> pure (); _ -> expectationFailure "database writer failed to finish"
+        timeout 1000000 (databaseSecurity [("gate_a", True)] (pure ())) `shouldReturn` Just ()
+        timeout 1000000 (writeSecurity (pure ())) `shouldReturn` Just ()
+
+    it "orders opposite dependency lists and releases cancelled waiters" $ do
+        entered <- newEmptyMVar
+        release <- newEmptyMVar
+        done <- newEmptyMVar
+        bracket (forkFinally (databaseSecurity [("gate_y", True), ("gate_x", False)] (putMVar entered () >> takeMVar release)) (putMVar done)) killThread $ \_ -> do
+            takeMVar entered
+            timeout 50000 (databaseSecurity [("gate_x", True), ("gate_y", False)] (pure ())) `shouldReturn` Nothing
+            putMVar release ()
+            result <- timeout 1000000 (takeMVar done)
+            case result of Just (Right ()) -> pure (); _ -> expectationFailure "ordered writer failed to finish"
+        timeout 1000000 (databaseSecurity [("gate_x", True), ("gate_y", True)] (pure ())) `shouldReturn` Just ()
+
 -- | 显式事务用例
 transactionSpec :: Spec
 transactionSpec = describe "server transactions" $ do
+    it "previews legacy duplicate deletion exactly as storage does" $ do
+        let old = Table "legacy" [("id", TInt), ("name", TStr)] [[("id", VInt 1), ("name", VStr "first")], [("id", VInt 1), ("name", VStr "second")]] Nothing Nothing Nothing
+        case applyTransactionMemory [TxnDelete "legacy" [1, 1]] [("legacy", old)] of
+            Left err -> expectationFailure err
+            Right db -> fmap tableRows (lookup "legacy" db) `shouldBe` Just [[("id", VInt 1), ("name", VStr "second")]]
+
+    it "rechecks UNIQUE on merged rows before publishing any table" $ withTwoSessions $ \first second -> do
+        _ <- mustSql first "CREATE TABLE registrations (id INT PRIMARY KEY, username TEXT UNIQUE)"
+        _ <- mustSql first "BEGIN"
+        _ <- mustSql second "BEGIN"
+        _ <- mustSql first "INSERT INTO registrations (id, username) VALUES (1, 'same')"
+        _ <- mustSql second "INSERT INTO registrations (id, username) VALUES (2, 'same')"
+        _ <- mustSql second "UPDATE users SET age = 99 WHERE id = 1"
+        _ <- mustSql first "COMMIT"
+        denied <- runStatementCoded second "COMMIT"
+        failureCode denied `shouldBe` "serialization_failure"
+        failureMessage denied `shouldBe` "UNIQUE: duplicate value in column username"
+        _ <- mustSql second "ROLLBACK"
+        sessionAge first 1 `shouldReturn` Just 21
+        rows <- mustSql first "SELECT id FROM registrations"
+        qrRows rows `shouldBe` [[VInt 1]]
+
+    it "allows distinct unique values and multiple NULLs after merging" $ withTwoSessions $ \first second -> do
+        _ <- mustSql first "CREATE TABLE registrations (id INT PRIMARY KEY, username TEXT UNIQUE)"
+        forM_ [first, second] $ \session -> void (mustSql session "BEGIN")
+        _ <- mustSql first "INSERT INTO registrations (id, username) VALUES (1, 'one'), (3, NULL)"
+        _ <- mustSql second "INSERT INTO registrations (id, username) VALUES (2, 'two'), (4, NULL)"
+        _ <- mustSql first "COMMIT"
+        _ <- mustSql second "COMMIT"
+        rows <- mustSql first "SELECT COUNT(*) FROM registrations"
+        qrRows rows `shouldBe` [[VInt 4]]
+
+    forM_ ["SELECT id FROM test.users WHERE id = 1", "SELECT id FROM users WHERE EXISTS (SELECT id FROM users WHERE age > 0)"] $ \readSql ->
+        it ("protects serializable read dependencies: " ++ T.unpack readSql) $ withTwoSessions $ \first second -> do
+            _ <- mustSql first "CREATE TABLE actions (id INT PRIMARY KEY)"
+            _ <- mustSql first "BEGIN TRANSACTION ISOLATION LEVEL SERIALIZABLE"
+            _ <- mustSql first readSql
+            _ <- mustSql first "INSERT INTO actions (id) VALUES (1)"
+            _ <- mustSql second "INSERT INTO users (id, name, age) VALUES (7, 'new', 20)"
+            denied <- runStatementCoded first "COMMIT"
+            failureCode denied `shouldBe` "serialization_failure"
+            _ <- mustSql first "ROLLBACK"
+            rows <- mustSql second "SELECT COUNT(*) FROM actions"
+            qrRows rows `shouldBe` [[VInt 0]]
+
+    it "forgets rolled-back reads and ignores unrelated table changes" $ withTwoSessions $ \first second -> do
+        _ <- mustSql first "CREATE TABLE actions (id INT PRIMARY KEY)"
+        _ <- mustSql first "START TRANSACTION ISOLATION LEVEL SERIALIZABLE"
+        _ <- mustSql first "SAVEPOINT before_read"
+        _ <- mustSql first "SELECT * FROM users"
+        _ <- mustSql first "ROLLBACK TO before_read"
+        _ <- mustSql first "INSERT INTO actions (id) VALUES (1)"
+        _ <- mustSql second "UPDATE users SET age = 99 WHERE id = 1"
+        _ <- mustSql first "COMMIT"
+        rows <- mustSql second "SELECT COUNT(*) FROM actions"
+        qrRows rows `shouldBe` [[VInt 1]]
+
+    it "allows a serializable read-only snapshot to finish" $ withTwoSessions $ \first second -> do
+        _ <- mustSql first "BEGIN ISOLATION LEVEL SERIALIZABLE"
+        _ <- mustSql first "SELECT * FROM users"
+        _ <- mustSql second "UPDATE users SET age = 99 WHERE id = 1"
+        void (mustSql first "COMMIT")
+
+    forM_ [("another commit", True), ("an autocommit update", False)] $ \(label, transactional) ->
+        it ("excludes " ++ label ++ " between conflict checking and publication") $ do
+            db <- newMVar testDb
+            settings <- tempSettingsPath "transaction-publication"
+            removeIfExists settings
+            armed <- newIORef False
+            snapshots <- newIORef (0 :: Int)
+            captured <- newEmptyMVar
+            release <- newEmptyMVar
+            secondSnapshot <- newEmptyMVar
+            let
+                -- 在首次提交取得快照后暂停发布。
+                pausedBackend original =
+                    original
+                        { beWithDatabase = pausedBackend . beWithDatabase original
+                        , beStatement = \sql -> do
+                            enabled <- readIORef armed
+                            when (enabled && not transactional && sql == "UPDATE users SET age = 32 WHERE id = 1") (putMVar secondSnapshot ())
+                            beStatement original sql
+                        , beSnapshot = do
+                            result <- beSnapshot original
+                            enabled <- readIORef armed
+                            when enabled $ do
+                                n <- atomicModifyIORef' snapshots (\count -> (count + 1, count))
+                                when (n == 0) (putMVar captured () >> takeMVar release)
+                                when (n == 1) (putMVar secondSnapshot ())
+                            pure result
+                        }
+                backend = pausedBackend (memoryBackend testDatabaseName db)
+            first <- newSession backend (T.pack testDatabaseName) settings
+            second <- newSession backend (T.pack testDatabaseName) settings
+            mapM_ (`mustSql` "USE test") [first, second]
+            _ <- mustSql first "BEGIN"
+            when transactional $ do
+                _ <- mustSql second "BEGIN"
+                void (mustSql second "UPDATE users SET age = 32 WHERE id = 1")
+            _ <- mustSql first "UPDATE users SET age = 31 WHERE id = 1"
+            writeIORef armed True
+            firstDone <- newEmptyMVar
+            secondDone <- newEmptyMVar
+            bracket (forkFinally (runStatementCoded first "COMMIT") (putMVar firstDone)) killThread $ \_ -> do
+                timeout 2000000 (takeMVar captured) `shouldReturn` Just ()
+                bracket (forkFinally (runStatementCoded second (if transactional then "COMMIT" else "UPDATE users SET age = 32 WHERE id = 1")) (putMVar secondDone)) killThread $ \_ -> do
+                    entered <- timeout 200000 (takeMVar secondSnapshot)
+                    putMVar release ()
+                    firstResult <- timeout 2000000 (takeMVar firstDone)
+                    secondResult <- timeout 2000000 (takeMVar secondDone)
+                    entered `shouldBe` Nothing
+                    case firstResult of
+                        Just (Right result) -> failureCode result `shouldBe` ""
+                        _ -> expectationFailure "first commit did not complete"
+                    case secondResult of
+                        Just (Right result) -> failureCode result `shouldBe` (if transactional then "serialization_failure" else "")
+                        _ -> expectationFailure "second commit did not complete"
+            when transactional $ void (mustSql second "ROLLBACK")
+            sessionAge first 1 `shouldReturn` Just (if transactional then 31 else 32)
+
     it "executes DISTINCT against the connection snapshot with output columns" $ withMemorySession $ \session -> do
         _ <- mustSql session "CREATE TABLE distinct_values (id INT, value INT)"
         _ <- mustSql session "INSERT INTO distinct_values (id,value) VALUES (1,7),(2,7),(3,8)"
@@ -1575,7 +1763,7 @@ transactionSpec = describe "server transactions" $ do
         updated <- beStatement backend "UPDATE users SET id = 3"
         void updated `shouldBe` Right ()
         snapshot <- beSnapshot (memoryBackend "other" ref)
-        fmap (map (tableRows . snd)) snapshot `shouldBe` Right [[[ ("id", VInt 2) ]]]
+        fmap (map (tableRows . snd)) snapshot `shouldBe` Right [[[("id", VInt 2)]]]
     it "keeps catalog and snapshot identities stable across system views and replacements" $ do
         ref <- newMVar [("test.users", Table "users" [("id", TInt)] [] Nothing Nothing Nothing)]
         let backend = memoryBackend "test" ref
@@ -1601,9 +1789,11 @@ transactionSpec = describe "server transactions" $ do
         fmap (map tiSchemaVersion) current `shouldBe` Right [Just 3]
         fmap (map (tableSchemaVersion . snd)) snapshot `shouldBe` Right [Just 3]
     it "rejects cross-database reads and writes including nested queries" $ withMemorySession $ \session -> do
-        mapM_ (\query -> do
-            result <- runStatementCoded session query
-            failureMessage result `shouldSatisfy` T.isInfixOf "outside the current database")
+        mapM_
+            ( \query -> do
+                result <- runStatementCoded session query
+                failureMessage result `shouldSatisfy` T.isInfixOf "outside the current database"
+            )
             [ "SELECT DISTINCT age FROM other.users"
             , "SELECT * FROM other.users"
             , "UPDATE other.users SET age = 1"
@@ -1632,6 +1822,8 @@ transactionSpec = describe "server transactions" $ do
         _ <- mustSql session "create domain code as int"
         _ <- mustSql session "create table typed (id code)"
         _ <- mustSql session "begin"
+        alterDenied <- runStatementCoded session "alter domain code set not null"
+        failureMessage alterDenied `shouldBe` "DDL is not allowed in a transaction"
         denied <- runStatementCoded session "drop domain code"
         failureMessage denied `shouldBe` "DDL is not allowed in a transaction"
         _ <- mustSql session "insert into typed (id) values (7)"
@@ -1639,6 +1831,24 @@ transactionSpec = describe "server transactions" $ do
         rows <- mustSql session "select id from typed"
         intValues (qrRows rows) `shouldBe` [7]
 
+    it "rejects stale transaction writes after a domain constraint changes" $ withTwoSessions $ \writer administrator -> do
+        void (mustSql administrator "CREATE DOMAIN quantity AS INT")
+        void (mustSql administrator "CREATE DOMAIN nested AS quantity")
+        void (mustSql administrator "CREATE TABLE domain_items (id INT, qty nested)")
+        void (mustSql writer "BEGIN")
+        void (mustSql writer "INSERT INTO domain_items (id, qty) VALUES (1, 0)")
+        void (mustSql administrator "ALTER DOMAIN quantity ADD CHECK (VALUE > 0)")
+        refused <- runStatementCoded writer "COMMIT"
+        failureCode refused `shouldBe` "serialization_failure"
+        void (mustSql writer "ROLLBACK")
+        rows <- mustSql administrator "SELECT qty FROM domain_items"
+        qrRows rows `shouldBe` []
+        void (mustSql writer "BEGIN")
+        void (mustSql writer "INSERT INTO domain_items (id, qty) VALUES (2, 2)")
+        void (mustSql writer "COMMIT")
+        saved <- mustSql administrator "SELECT qty FROM domain_items"
+        intValues (qrRows saved) `shouldBe` [2]
+
     it "keeps uncommitted rows invisible to other sessions until COMMIT" $ withTwoSessions $ \writer reader -> do
         _ <- mustSql writer "begin"
         _ <- mustSql writer "insert into users (id, name, age) values (6, 'six', 26)"
@@ -1684,11 +1894,12 @@ transactionSpec = describe "server transactions" $ do
         ref <- newMVar testDb
         settings <- tempSettingsPath "snapshot-failure"
         let base = memoryBackend testDatabaseName ref
-            -- | 保留测试后端并让快照读取失败
-            failing name = (beWithDatabase base name)
-                { beSnapshot = pure (Left "data page unreadable")
-                , beWithDatabase = failing
-                }
+            -- \| 保留测试后端并让快照读取失败
+            failing name =
+                (beWithDatabase base name)
+                    { beSnapshot = pure (Left "data page unreadable")
+                    , beWithDatabase = failing
+                    }
         session <- newSession (failing testDatabaseName) (T.pack testDatabaseName) settings
         void (mustSql session "USE test")
         result <- runStatementCoded session "BEGIN"
@@ -1708,12 +1919,15 @@ transactionSpec = describe "server transactions" $ do
         _ <- mustSql session "CREATE TABLE constrained_updates (id INT PRIMARY KEY, qty INT NOT NULL UNIQUE)"
         _ <- mustSql session "INSERT INTO constrained_updates (id, qty) VALUES (1, 2), (2, 3)"
         _ <- mustSql session "BEGIN"
-        mapM_ (\(query, marker) -> do
-            result <- runStatementCoded session query
-            failureMessage result `shouldSatisfy` T.isInfixOf marker)
-            [("UPDATE constrained_updates SET qty = NULL WHERE id = 1", "NOT NULL")
+        mapM_
+            ( \(query, marker) -> do
+                result <- runStatementCoded session query
+                failureMessage result `shouldSatisfy` T.isInfixOf marker
+            )
+            [ ("UPDATE constrained_updates SET qty = NULL WHERE id = 1", "NOT NULL")
             , ("UPDATE constrained_updates SET qty = 3 WHERE id = 1", "UNIQUE")
-            , ("UPDATE constrained_updates SET id = 2 WHERE id = 1", "UNIQUE")]
+            , ("UPDATE constrained_updates SET id = 2 WHERE id = 1", "UNIQUE")
+            ]
         unchanged <- mustSql session "SELECT qty FROM constrained_updates ORDER BY id"
         intValues (qrRows unchanged) `shouldBe` [2, 3]
         _ <- mustSql session "UPDATE constrained_updates SET qty = qty + 1"
@@ -2005,6 +2219,26 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
         intColumn "id" rowsA `shouldMatchList` [1 .. 20]
         intColumn "id" rowsB `shouldMatchList` [101 .. 120]
 
+    it "shares a committed snapshot and keeps old versions immutable" $ withIpcStorage $ do
+        base <- ipcBackend
+        mustRun (beStatement base "CREATE DATABASE alpha")
+        let alpha = beWithDatabase base "alpha"
+        mustRun (beStatement alpha "CREATE TABLE versions (id INT PRIMARY KEY, value INT)")
+        mustRun (beStatement alpha "INSERT INTO versions (id, value) VALUES (1, 10)")
+        first <- beSnapshot alpha >>= either fail pure
+        second <- beSnapshot alpha >>= either fail pure
+        firstName <- evaluate first >>= makeStableName
+        secondName <- evaluate second >>= makeStableName
+        (firstName == secondName) `shouldBe` True
+        mustRun (beStatement alpha "UPDATE versions SET value = 20 WHERE id = 1")
+        latest <- beSnapshot alpha >>= either fail pure
+        fmap tableRows (lookup "versions" first) `shouldBe` Just [[("id", VInt 1), ("value", VInt 10)]]
+        fmap tableRows (lookup "versions" latest) `shouldBe` Just [[("id", VInt 1), ("value", VInt 20)]]
+        mustRun (beStatement base "DROP DATABASE alpha")
+        mustRun (beStatement base "CREATE DATABASE alpha")
+        recreated <- beSnapshot alpha >>= either fail pure
+        map fst recreated `shouldNotContain` ["versions"]
+
     it "commits an explicit transaction to the real storage" $ withIpcStorage $ do
         base <- ipcBackend
         mustRun (beStatement base "CREATE DATABASE alpha")
@@ -2042,6 +2276,29 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
         rows <- rowsOf (beStatement alpha "SELECT id FROM t")
         intColumn "id" rows `shouldBe` [1]
 
+    it "merges disjoint row writes while retaining the old snapshot" $ withIpcStorage $ do
+        base <- ipcBackend
+        mustRun (beStatement base "CREATE DATABASE alpha")
+        let alpha = beWithDatabase base "alpha"
+        mustRun (beStatement alpha "CREATE TABLE items (id int, value int)")
+        mustRun (beStatement alpha "INSERT INTO items (id, value) VALUES (1, 10), (2, 20)")
+        settings <- tempSettingsPath "transaction-ipc-rows"
+        removeIfExists settings
+        first <- newSession alpha "alpha" settings
+        second <- newSession alpha "alpha" settings
+        _ <- mustSql first "use alpha"
+        _ <- mustSql second "use alpha"
+        _ <- mustSql first "begin"
+        _ <- mustSql second "begin"
+        _ <- mustSql first "update items set value = 11 where id = 1"
+        _ <- mustSql second "update items set value = 22 where id = 2"
+        _ <- mustSql first "commit"
+        old <- mustSql second "select value from items where id = 1"
+        intValues (qrRows old) `shouldBe` [10]
+        _ <- mustSql second "commit"
+        rows <- rowsOf (beStatement alpha "SELECT value FROM items ORDER BY id")
+        intColumn "value" rows `shouldBe` [11, 22]
+
     it "refuses the second COMMIT on the real storage" $ withIpcStorage $ do
         base <- ipcBackend
         mustRun (beStatement base "CREATE DATABASE alpha")
@@ -2057,17 +2314,15 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
         _ <- mustSql first "begin"
         _ <- mustSql second "begin"
         _ <- mustSql first "update users set age = 31 where id = 1"
-        _ <- mustSql second "update users set age = 42 where id = 1"
         _ <- mustSql first "commit"
-        denied <- runStatementCoded second "commit"
+        denied <- runStatementCoded second "update users set age = 42 where id = 1"
         failureCode denied `shouldBe` "serialization_failure"
-        failureMessage denied `shouldBe` "write conflict on table users, id 1"
+        failureMessage denied `shouldSatisfy` T.isInfixOf "row version changed"
         _ <- mustSql second "rollback"
         rows <- rowsOf (beStatement alpha "SELECT id, age FROM users")
         intColumn "id" rows `shouldBe` [1]
         intColumn "age" rows `shouldBe` [31]
 
-
 -- 判断明确错误返回。
 isLeftResult :: Either a b -> Bool
 isLeftResult (Left _) = True
@@ -2094,8 +2349,16 @@ tcpSudo client credential user = do
 
 -- 发送本机认证证明。
 tcpSudoProof :: Handle -> Text -> Text -> IO A.Value
-tcpSudoProof client user proof = tcpTalk client (BL.toStrict (A.encode (A.object
-    ["method" A..= ("sudo_login" :: Text), "user" A..= user, "proof" A..= proof])))
+tcpSudoProof client user proof =
+    tcpTalk
+        client
+        ( BL.toStrict
+            ( A.encode
+                ( A.object
+                    ["method" A..= ("sudo_login" :: Text), "user" A..= user, "proof" A..= proof]
+                )
+            )
+        )
 
 -- 验证身份禁用或取消登录后拒绝本机认证。
 checkSudoDisabled :: Handle -> ServerHandle -> SudoCredential -> Text -> IO ()
@@ -2111,7 +2374,6 @@ isRightResult :: Either a b -> Bool
 isRightResult (Right _) = True
 isRightResult _ = False
 
-
 -- 专用范式协议、权限、快照与预算回归。
 normalizationSpec :: Spec
 normalizationSpec = describe "normalization endpoint" $ do
@@ -2127,8 +2389,9 @@ normalizationSpec = describe "normalization endpoint" $ do
         let response = RespNormalization report
         decodeResponse (encodeResponse response) `shouldBe` Right response
         decodeResponse (encodeResponse (RespNormalization (A.object ["conditional" A..= True]))) `shouldSatisfy` either (const True) (const False)
-        mapM_ (\raw -> decodeNormalizationJSON raw `shouldSatisfy` either (T.isInfixOf "duplicate") (const False))
-            [ "{\"a\":1,\"a\":2}", "{\"a\":1,\"\\u0061\":2}", "{\"a\":[{\"b\":1,\"b\":2}]}" ]
+        mapM_
+            (\raw -> decodeNormalizationJSON raw `shouldSatisfy` either (T.isInfixOf "duplicate") (const False))
+            ["{\"a\":1,\"a\":2}", "{\"a\":1,\"\\u0061\":2}", "{\"a\":[{\"b\":1,\"b\":2}]}"]
         let unknown = A.object ["api_version" A..= (1 :: Int), "database" A..= ("test" :: Text), "table" A..= ("users" :: Text), "declaration" A..= nrDeclaration normalizationPayload, "ignored" A..= True]
         (A.fromJSON unknown :: A.Result NormalizationRequest) `shouldSatisfy` isJSONFailure
         decodeRequest (BL.toStrict (encodeRequest (ReqNormalization normalizationPayload{nrVersion = 2}))) `shouldSatisfy` either (const True) (const False)
@@ -2222,8 +2485,14 @@ normalizationSpec = describe "normalization endpoint" $ do
 
 -- 共用明确声明的用户表请求。
 normalizationPayload :: NormalizationRequest
-normalizationPayload = NormalizationRequest 1 "test" "users"
-    (NormalizationDeclaration [["id"]] [NormalizationDependency ["id"] ["name", "age"]] True (Just True)) Nothing Nothing
+normalizationPayload =
+    NormalizationRequest
+        1
+        "test"
+        "users"
+        (NormalizationDeclaration [["id"]] [NormalizationDependency ["id"] ["name", "age"]] True (Just True))
+        Nothing
+        Nothing
 
 -- 判断 JSON 类型校验失败。
 isJSONFailure :: A.Result a -> Bool