v26.10.1 正式版

修复部分问题，优化性能，进一步推进类型系统

chusql-server/chusql-server.cabal

@@ -16,6 +16,8 @@ library
                       ChuSQL.Server.Catalog
                       ChuSQL.Server.Policy
                       ChuSQL.Server.Privileges
+                      ChuSQL.Server.ObjectACL
+                      ChuSQL.Server.Security
                       ChuSQL.Server.Session
                       ChuSQL.Server.TCP
     build-depends:    base >= 4.14 && < 5

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

@@ -4,7 +4,7 @@ module ChuSQL.Server.Accounts (
     Accounts, AccountError (..), Principal (..), PasswordPolicy (..), defaultPasswordPolicy,
     newAccounts, accountsPolicy, setAccountsPolicy, passwordAllowed,
     ensureRootAccount, administratorPasswordless, rootUserName, principalName, principalIsRoot, principalIsCatalogManager,
-    authenticate, currentPrincipal,
+    authenticate, authenticateSudo, currentPrincipal,
     listAccounts, findAccount, AccountCommand (..), accountCommand, runAccountCommand,
 ) where
 
@@ -153,7 +153,7 @@ ensureRootAccount backend name = do
             | otherwise -> do
                 created <- beAccounts backend (ReqAccountCreate (normalize name) "")
                 case created of
-                    Right _ -> storageResult <$> beAccounts backend (ReqIdentityAlter (normalize name) Nothing (Just True) Nothing Nothing)
+                    Right _ -> storageResult <$> beAccounts backend (ReqIdentityAlter (normalize name) Nothing (Just True) Nothing Nothing Nothing)
                     Left "account already exists" -> pure (Right ())
                     Left _ -> pure (Left storageFailure)
 
@@ -219,6 +219,21 @@ authenticate service user password = withMVar (acLock service) $ \_ -> do
             Left _ -> pure (Left storageFailure)
             Right _ -> Right <$> createVersionedSession (acSessions service) (accountUser a) (Just (accountRevision a))
 
+-- 为已验证的本机身份创建独立登录会话。
+authenticateSudo :: Accounts -> Text -> IO (Either AccountError Text)
+authenticateSudo service user = withMVar (acLock service) $ \_ -> do
+    stored <- readAccounts (acBackend service)
+    case stored of
+        Left err -> pure (Left err)
+        Right accounts -> case filter ((== normalize user) . accountUser) accounts of
+            [a] | accountEnabled a && accountCanLogin a && accountAllowSudoAuth a -> do
+                stamp <- currentStamp
+                written <- beAccounts (acBackend service) (ReqAccountLogin (accountUser a) (Just stamp))
+                case written of
+                    Left _ -> pure (Left storageFailure)
+                    Right _ -> Right <$> createVersionedSession (acSessions service) (accountUser a) (Just (accountRevision a))
+            _ -> pure (Left unauthorized)
+
 -- | 系统表里的账号清单（含管理员）
 listAccounts :: Accounts -> IO (Either AccountError [Account])
 listAccounts service = withMVar (acLock service) $ \_ -> fmap (fmap (filter (\a -> accountCanLogin a || not (T.null (accountHash a))))) (readAccounts (acBackend service))
@@ -295,7 +310,7 @@ runAccountCommand service principal command = withMVar (acLock service) $ \_ ->
             case identities of
                 Left err -> pure (Left err)
                 Right accounts
-                    | any (\a -> accountUser a == normalize (target command) && (accountIsSuperuser a || accountSystemCatalogManager a)) 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"))
                     | otherwise -> execute
         | otherwise = execute
@@ -305,12 +320,13 @@ runAccountCommand service principal command = withMVar (acLock service) $ \_ ->
     target (DropAccount name) = name
     target (AlterAccountAttributes name _) = name
     -- | 判断是否修改特权属性
-    privilegedChange (AlterAccountAttributes _ attributes) = any (\(key, _) -> key `elem` ["superuser", "system_catalog_manager"]) attributes
+    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 = \request -> beAccounts (acBackend service) (ReqCatalogManage request)}})
     -- | 通过受限存储请求执行管理操作
     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
         ResetAccountPassword name password -> resetPassword managed name password
         DropAccount name -> dropUser managed name
@@ -318,4 +334,4 @@ runAccountCommand service principal command = withMVar (acLock service) $ \_ ->
             | 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 "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

@@ -172,7 +172,7 @@ memoryBackendWith trusted name ref =
                 Left e -> pure (db, Left e)
                 Right (db', rows)
                     | any (\(key, _) -> hidden key && not (domainKey key)) db' -> pure (db, Left "reserved system table")
-                    | otherwise -> pure (mergeScoped db db', Right (StatementResult (colsOf (scoped db) stmt rows) rows))
+                    | otherwise -> pure (syncMemoryObjects name (mergeScoped db db'), Right (StatementResult (colsOf (scoped db) stmt rows) rows))
         , beCatalog = do
             db <- readMVar ref
             pure (Right (map tableInfoOf (filter (not . internalTable . fst) (scoped db))))
@@ -186,7 +186,7 @@ memoryBackendWith trusted name ref =
                     Right previous -> pure (case req of ReqAccountsList -> db; ReqCatalogManage ReqAccountsList -> db; _ -> storeMemoryIdentities db previous accounts, Right accounts)
         , beWithDatabase = withDatabase
         , beDatabases = pure (Right (nub [name, systemDatabaseName]))
-        , beStorage = \_ -> pure (Left "storage is not available in this backend")
+        , beStorage = memorySecurityRequest name ref
         , beSnapshot = Right . scoped <$> readMVar ref
         , beApplyTransaction = \ops -> modifyMVar ref $ \db -> case applyTransactionMemory ops (scoped db) of
             Left err -> pure (db, Left err)
@@ -224,6 +224,52 @@ memoryBackendWith trusted name ref =
         | null target = noDatabaseBackend (memoryBackendWith False name ref)
         | otherwise = unavailableDatabase ("unknown database: " ++ target) (memoryBackendWith False name ref)
 
+-- 更新内存夹具的稳定表编号。
+syncMemoryObjects :: String -> Database -> Database
+syncMemoryObjects database db = (registry, Table registry [("name", TStr), ("id", TInt)] records Nothing) : 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]]
+    keys = [if '.' `elem` key then key else database ++ "." ++ key | (key, _) <- db, not (internalTable (lastTablePart key))]
+    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 ..]
+    records = [[("name", VStr key), ("id", VInt identifier)] | (key, identifier) <- ("__high_water", high + length added) : retained ++ added]
+
+-- 执行内存夹具的权限快照协议。
+memorySecurityRequest :: String -> MVar Database -> A.Value -> IO (Either String A.Value)
+memorySecurityRequest database ref payload = modifyMVar ref $ \original -> do
+    let db = syncMemoryObjects database original
+    pure $ case operation db of
+        Left err -> (original, Left err)
+        Right (next, value) -> (next, Right value)
+  where
+    -- 读取协议文本字段。
+    field key = case payload of
+        A.Object fields -> case KM.lookup key fields of
+            Just (A.String value) -> Just value
+            _ -> Nothing
+        _ -> Nothing
+    -- 解析并执行一条权限请求。
+    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])
+        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) : 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
@@ -468,6 +514,10 @@ currentStamp = T.pack . formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" <$> get
 -- | 在内存账号表上执行一条账号请求
 memoryAccounts :: Database -> T.Text -> Request -> Either String [Account]
 memoryAccounts db stamp req = do
+    case req of
+        ReqAccountCreate name _ | T.toLower name == "public" -> Left "public is reserved for default privileges"
+        ReqRoleCreate name | T.toLower name == "public" -> Left "public is reserved for default privileges"
+        _ -> Right ()
     stored <- case lookup "__system_identities" db of
         Just table -> mapM decodeCredential (tableRows table)
         Nothing -> case lookup usersTable db of
@@ -482,28 +532,29 @@ memoryAccounts db stamp req = do
                     ReqAccountCreate name _ -> Just name
                     ReqAccountReset name _ -> Just name
                     ReqAccountDrop name -> Just name
-                    ReqIdentityAlter name _ Nothing _ Nothing -> Just name
+                    ReqIdentityAlter name _ Nothing _ Nothing Nothing -> Just name
                     _ -> Nothing
-                allowed = case command of ReqAccountsList -> True; ReqAccountCreate{} -> True; ReqAccountReset{} -> True; ReqAccountDrop{} -> True; ReqIdentityAlter _ _ Nothing _ Nothing -> True; _ -> False
-            if not allowed || any (\a -> target == Just (accountUser a) && (accountIsSuperuser a || accountSystemCatalogManager a)) accounts
+                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
         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 | (offset, role) <- zip [1..] legacyNames])
+                [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])
-        ReqIdentityAlter u login super enabled manager -> case filter ((== T.toLower u) . accountUser) accounts of
+            | 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 = maybe (accountCanLogin a) id login,
                 accountIsSuperuser = maybe (accountIsSuperuser a) id super, accountEnabled = maybe (accountEnabled a) id enabled,
                 accountSystemCatalogManager = maybe (accountSystemCatalogManager a) id manager,
+                accountAllowSudoAuth = maybe (accountAllowSudoAuth a) id 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"
-            | otherwise -> Right (accounts ++ [Account (highWater + 1) (T.toLower u) h 1 stamp Nothing True False True False])
+            | otherwise -> Right (accounts ++ [Account (highWater + 1) (T.toLower u) h 1 stamp Nothing True False True False False])
         ReqAccountReset u h -> case filter ((== T.toLower u) . accountUser) accounts of
             [_] -> Right [if accountUser x == T.toLower u then x{accountHash = h, accountRevision = accountRevision x + 1} else x | x <- accounts]
             _ -> Left "unknown account"

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

@@ -25,7 +25,7 @@ module ChuSQL.Server.Catalog
 
 import ChuSQL.Core.Model (Row, Value (..))
 import ChuSQL.Core.Protocol (Account (..), Request (..))
-import ChuSQL.Interface.Actions (sqlLiteral)
+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)
@@ -213,4 +213,4 @@ roleLiteral = literal . normalizeRole
 
 -- | 文本值的 SQL 字面量
 literal :: Text -> String
-literal = sqlLiteral . VStr . T.unpack
+literal text = "'" ++ escapeStringLiteral (T.unpack text) ++ "'"

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

@@ -0,0 +1,410 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Server.ObjectACL
+    ( objectAuthorize, objectGrant, objectRevoke, objectViews, objectClaim
+    , objectReconcile, objectAffected, objectOwner, objectConnect, objectPrepareCreate, objectUsers
+    ) where
+
+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 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.List (nub)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import GHC.Generics (Generic)
+
+-- 稳定对象权限目录：保存所有者、授予来源并计算有效授权链。
+
+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 }
+    deriving (Eq, Show, Generic)
+instance ToJSON Edge
+instance FromJSON Edge
+
+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 }
+    deriving (Eq, Show, Generic)
+instance ToJSON Pending
+instance FromJSON 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..!= [])
+
+data Context = Context { contextIdentities :: [Account], contextMembers :: [(Text, Text)], contextTargets :: [Target] }
+
+-- 解析存储响应并保留明确错误。
+request :: Backend -> A.Value -> IO (Either String A.Value)
+request backend payload = fmap (>>= response) (beStorage backend payload)
+  where
+    -- 检查响应状态。
+    response value@(A.Object fields) = case KM.lookup "status" fields of
+        Just (A.String "error") -> case KM.lookup "message" fields of Just (A.String message) -> Left (T.unpack message); _ -> Left "invalid storage error"
+        Just (A.String _) -> Right value
+        _ -> Left "invalid storage response"
+    response _ = Left "invalid storage response"
+
+-- 从响应取必需字段。
+field :: Text -> A.Value -> Either String A.Value
+field name (A.Object fields) = maybe (Left ("missing field: " ++ T.unpack name)) Right (KM.lookup (K.fromText name) fields)
+field _ _ = Left "invalid storage object"
+
+-- 将存储编号规范为文本。
+identifier :: A.Value -> Either String Text
+identifier (A.Number number) | number > 0 = Right (T.pack (BL.unpack (A.encode (A.Number number))))
+identifier _ = Left "invalid object identifier"
+
+-- 按 catalog 解析数据库或表对象。
+resolve :: Backend -> Text -> Text -> IO (Either String Target)
+resolve backend database raw = do
+    let object = T.toLower (T.strip raw)
+        (selected, table, kind, label) =
+            if "database:" `T.isPrefixOf` object then (T.drop 9 object, Nothing, "database", object)
+            else if object == "*" || ".*" `T.isSuffixOf` object then
+                let scope = if object == "*" then database else T.dropEnd 2 object
+                in (scope, Nothing, "tables", scope <> ".*")
+            else 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)
+
+-- 展开当前 catalog 中的稳定业务对象。
+targets :: Backend -> IO (Either String [Target])
+targets backend = do
+    names <- beDatabases backend
+    case names of
+        Left err -> pure (Left err)
+        Right databases -> fmap (fmap concat . sequence) $ mapM one (filter (/= "system") databases)
+  where
+    -- 展开一个数据库和它的表。
+    one name = do
+        database <- resolve backend "" ("database:" <> T.pack name)
+        catalog <- beCatalog (beWithDatabase backend name)
+        case catalog of
+            Left err -> pure (Left err)
+            Right infos -> do
+                tables <- mapM (resolve backend (T.pack name) . T.pack . tableNameOf) infos
+                pure ((:) <$> database <*> sequence tables)
+    -- 取数据字典的表名。
+    tableNameOf = tiTable
+
+-- 读取身份、成员边和对象字典。
+context :: Backend -> Catalog -> IO (Either String Context)
+context backend catalog = do
+    identities <- readIdentities catalog
+    members <- readMembers catalog
+    objects <- targets backend
+    pure (Context <$> identities <*> members <*> objects)
+
+-- 查找身份的稳定编号。
+roleId :: Context -> Text -> Either String Text
+roleId env name = case [T.pack (show (accountId account)) | account <- contextIdentities env, accountUser account == T.toLower name] of
+    [value] -> Right value
+    [] | T.toLower (T.strip name) == "public" -> Right "public"
+    _ -> Left ("unknown role: " ++ T.unpack name)
+
+-- 从编号查回公开身份名。
+roleName :: Context -> Text -> Text
+roleName _ "public" = "public"
+roleName env value = case [accountUser account | account <- contextIdentities env, T.pack (show (accountId account)) == value] of name : _ -> name; [] -> ""
+
+-- 判断身份当前是否贡献权限。
+active :: Context -> Text -> Bool
+active _ "0" = True
+active _ "public" = True
+active env value = any (\account -> T.pack (show (accountId account)) == value && accountEnabled account) (contextIdentities env)
+
+-- 判断稳定身份是否仍存在。
+knownRole :: Context -> Text -> Bool
+knownRole env value = value `elem` ["0", "public"] || any (\account -> T.pack (show (accountId account)) == value) (contextIdentities env)
+
+-- 展开一个身份继承的有效角色编号。
+roles :: Context -> Text -> [Text]
+roles env value = nub ("public" : go [value])
+  where
+    pairs = [(parent, child) | (parentName, childName) <- contextMembers env, Right parent <- [roleId env parentName], Right child <- [roleId env childName], active env parent, 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))
+
+-- 判断一个对象范围是否覆盖目标。
+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)
+
+-- 判断稳定对象当前是否存在。
+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)
+
+-- 判断身份是否拥有指定对象。
+owns :: Context -> ACL -> Text -> Target -> Bool
+owns env acl identity target = any (\owner -> ownerRole owner `elem` roles env identity && ownerTarget owner == target && active env (ownerRole owner)) (aclOwners acl)
+
+-- 计算仍有合法授予来源的授权闭包。
+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)]}
+  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)
+    -- 检查授予者的所有权或有效转授权。
+    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)
+
+-- 读取并校验权限快照。
+readACL :: Backend -> IO (Either String (Maybe Text, Maybe ACL))
+readACL backend = do
+    result <- request backend (A.object ["method" A..= ("object_acl_read" :: Text)])
+    pure $ do
+        value <- result
+        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"
+            _ -> Left "invalid object ACL rows"
+
+-- 原子写入权限快照并检查并发版本。
+writeACL :: Backend -> Maybe Text -> ACL -> IO (Either String ())
+writeACL backend expected acl = fmap (fmap (const ())) $ request backend (A.object ["method" A..= ("object_acl_replace" :: Text), "expected" A..= expected, "payload" A..= TE.decodeUtf8 (BL.toStrict (A.encode acl))])
+
+-- 将旧名称授权一次性绑定到现存对象。
+migrate :: Backend -> Catalog -> Context -> IO (Either String ACL)
+migrate backend catalog env = do
+    grants <- readGrants catalog
+    options <- readGrantOptions catalog
+    case (,) <$> grants <*> options of
+        Left err -> pure (Left err)
+        Right (rows, optionRows) -> fmap (fmap (\edges -> ACL 1 (concat edges) [] [] []) . sequence) (mapM (one optionRows) rows)
+  where
+    -- 转换一条旧授权记录。
+    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))
+            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 []
+                Left "unknown database" -> Right []
+                Left err -> Left err
+                Right found -> Right [Edge identity "0" target (grantPrivilege grant) option True | target <- found]
+
+-- 取得迁移完成且来源有效的权限快照。
+load :: Backend -> Catalog -> IO (Either String (Context, Maybe Text, ACL))
+load backend catalog = do
+    env <- context backend catalog
+    stored <- readACL backend
+    case (,) <$> env <*> stored of
+        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]
+                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
+        Right (current, (previous, Nothing)) -> do
+            migrated <- migrate backend catalog current
+            case migrated of
+                Left err -> pure (Left err)
+                Right acl -> do
+                    written <- writeACL backend previous acl
+                    case written of
+                        Left "object ACL changed concurrently" -> load backend catalog
+                        Left err -> pure (Left err)
+                        Right () -> load backend catalog
+
+-- 检查作用域权限或所有权。
+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)
+
+-- 按对象类型展开和校验权限名称。
+privileges :: Target -> [Text] -> Either String [Text]
+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]) (map T.toLower names))
+
+-- 检查一组稳定对象上的业务权限。
+objectAuthorize :: Backend -> Catalog -> Principal -> Text -> [(Text, Text)] -> IO (Either String ())
+objectAuthorize backend catalog principal database needed = do
+    loaded <- load backend catalog
+    objects <- mapM (resolve backend database . fst) needed
+    pure $ do
+        (env, _, acl) <- loaded
+        found <- sequence objects
+        identity <- roleId env (principalName principal)
+        if active env identity then Right () else Left "permission denied: disabled identity"
+        case [(name, privilege) | ((name, privilege), target) <- zip needed found, not (allowed env acl identity target privilege False)] of
+            [] -> Right ()
+            (name, privilege) : _ -> Left ("permission denied: " ++ T.unpack (T.toUpper privilege <> " ON " <> name))
+
+-- 检查数据库连接权限。
+objectConnect :: Backend -> Catalog -> Principal -> Text -> IO (Either String ())
+objectConnect backend catalog principal database = objectAuthorize backend catalog principal "" [("database:" <> database, "connect")]
+
+-- 授予权限并记录授予者的稳定身份。
+objectGrant :: Backend -> Catalog -> Principal -> Text -> [Text] -> Text -> Text -> Bool -> IO (Either String ())
+objectGrant backend catalog principal database names object role option = do
+    loaded <- load backend catalog
+    resolved <- resolve backend database object
+    case (,) <$> loaded <*> resolved of
+        Left err -> pure (Left err)
+        Right ((env, previous, acl), target) -> case do
+            recipient <- roleId env role
+            items <- privileges target names
+            grantor <- if principalIsRoot principal then Right (either (const "0") id (roleId env (principalName principal))) else roleId env (principalName principal)
+            case [item | item <- items, not (principalIsRoot principal), 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}
+  where
+    -- 比较同一授予来源的授权键。
+    same one other = edgeRole one == edgeRole other && edgeGrantor one == edgeGrantor other && edgeTarget one == edgeTarget other && edgePrivilege one == edgePrivilege other
+
+-- 撤销授权并收敛失去来源的下游授权。
+objectRevoke :: Backend -> Catalog -> Principal -> Text -> [Text] -> Text -> Text -> IO (Either String ())
+objectRevoke backend catalog principal database names object role = do
+    loaded <- load backend catalog
+    resolved <- resolve backend database object
+    case (,) <$> loaded <*> resolved of
+        Left err -> pure (Left err)
+        Right ((env, previous, acl), target) -> case (,) <$> roleId env role <*> privileges target names of
+            Left err -> pure (Left err)
+            Right (recipient, items) -> do
+                let grantor = either (const "") id (roleId env (principalName principal))
+                    manager = principalIsRoot principal || owns env acl grantor target
+                    -- 选择本次可撤销的授予来源。
+                    matches edge = edgeRole edge == recipient && edgeTarget edge == target && edgePrivilege edge `elem` items && (manager || edgeGrantor edge == grantor)
+                    next = acl{aclEdges = filter (not . matches) (aclEdges acl), aclClosed = if recipient == "public" && "connect" `elem` items then nub (targetDatabase target : aclClosed acl) else aclClosed acl}
+                if recipient == "public" && "connect" `elem` items && not manager then pure (Left "administrator required")
+                    else writeACL backend previous (effective env next)
+
+-- 返回公开名称形式的有效授权。
+objectViews :: Backend -> Catalog -> Text -> IO (Either String [Grant])
+objectViews backend catalog role = do
+    loaded <- load backend catalog
+    pure $ do
+        (env, _, acl) <- loaded
+        identity <- roleId env role
+        let mine = [edge | edge <- aclEdges acl, edgeRole edge == identity]
+        Right (nub [Grant role (edgePrivilege edge) (targetName (edgeTarget edge)) (any (\other -> edgeTarget other == edgeTarget edge && edgePrivilege other == edgePrivilege edge && edgeOption other) mine) | edge <- mine])
+
+-- 登记新对象的创建者为所有者。
+objectClaim :: Backend -> Catalog -> Principal -> Text -> Text -> IO (Either String ())
+objectClaim backend catalog principal database object = do
+    loaded <- load backend catalog
+    resolved <- resolve backend database object
+    case (,) <$> loaded <*> resolved of
+        Left err -> pure (Left err)
+        Right ((env, previous, acl), target) -> case roleId env (principalName principal) of
+            Left err -> pure (Left err)
+            Right identity -> writeACL backend previous acl{aclOwners = Owner identity target : filter ((/= target) . ownerTarget) (aclOwners acl)}
+
+-- 在建表前持久化创建者声明。
+objectPrepareCreate :: Backend -> Catalog -> Principal -> Text -> Text -> IO (Either String ())
+objectPrepareCreate backend catalog principal database raw = do
+    loaded <- load backend catalog
+    parent <- resolve backend "" ("database:" <> database)
+    case (,) <$> loaded <*> parent of
+        Left err -> pure (Left err)
+        Right ((env, previous, acl), target) -> case roleId env (principalName principal) of
+            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 ())
+                    else writeACL backend previous acl{aclPending = [Pending identity (targetDatabase target) name]}
+
+-- 清理失效身份、成员来源和已删除对象。
+objectReconcile :: Backend -> Catalog -> IO (Either String ())
+objectReconcile backend catalog = do
+    loaded <- load backend catalog
+    case loaded of Left err -> pure (Left err); Right (_, previous, acl) -> writeACL backend previous acl
+
+-- 列出对象权限变更需失效的身份。
+objectAffected :: Backend -> Catalog -> [Text] -> IO (Either String [Text])
+objectAffected backend catalog names = do
+    loaded <- load backend catalog
+    pure $ 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))
+        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)
+
+-- 检查稳定对象的所有者权限。
+objectOwner :: Backend -> Catalog -> Principal -> Text -> Text -> IO (Either String ())
+objectOwner backend catalog principal database object = do
+    loaded <- load backend catalog
+    resolved <- resolve backend database object
+    pure $ do
+        (env, _, acl) <- loaded
+        target <- resolved
+        identity <- roleId env (principalName principal)
+        if owns env acl identity target then Right () else Left "object owner required"
+
+-- 展开删除对象时需失效的授权身份。
+objectUsers :: Backend -> Catalog -> Text -> Text -> IO (Either String [Text])
+objectUsers backend catalog database object = do
+    loaded <- load backend catalog
+    resolved <- resolve backend database object
+    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]
+            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/Privileges.hs

@@ -1,445 +1,233 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module ChuSQL.Server.Privileges (
-    Grant (..),
-    Membership (..),
-    PrivilegeCommand (..),
-    PrivilegeError (..),
-    Privileges,
-    RoleView (..),
-    affectedAccounts,
-    authorize,
-    authorizeTables,
-    filterTables,
-    listRoleViews,
-    newPrivileges,
-    normalizeObject,
-    privilegeCommand,
-    runPrivilegeCommand,
-) where
+module ChuSQL.Server.Privileges
+    ( Grant (..), Membership (..), PrivilegeCommand (..), PrivilegeError (..), Privileges, RoleView (..)
+    , affectedAccounts, authorize, authorizeTables, authorizeConnect, filterTables, listRoleViews
+    , newPrivileges, normalizeObject, privilegeCommand, runPrivilegeCommand, claimObject, prepareObject, reconcileObjects, affectedObject
+    ) where
 
 import ChuSQL.Core.Engine.Syntax.AST
 import ChuSQL.Core.Protocol (Account (..))
-import ChuSQL.Server.Accounts (Principal, principalIsRoot, principalIsCatalogManager, principalName)
 import ChuSQL.Interface.Protocol (Grant (..), RoleView (..))
-import ChuSQL.Server.Backend (
-    Backend (..),
-    exprTables,
-    systemDatabaseName,
-    tableRefsOf,
- )
-import ChuSQL.Server.Catalog (
-    Catalog,
-    addGrant,
-    addGrantOption,
-    addMember,
-    dropRole,
-    eachAction,
-    insertRole,
-    newCatalog,
-    normalizeObject,
-    normalizeRole,
-    normalizeUser,
-    readGrantOptions,
-    readGrants,
-    readMembers,
-    readRoleNames,
-    readIdentities,
-    removeGrant,
-    removeGrantOption,
-    removeMember,
-    withCatalogLock,
-    ensureCatalog,
- )
+import ChuSQL.Server.Accounts (Principal, principalIsRoot, principalIsCatalogManager)
+import ChuSQL.Server.Backend (Backend (..), exprTables, tableRefsOf, systemDatabaseName)
+import ChuSQL.Server.Catalog
+import qualified ChuSQL.Server.ObjectACL as OA
 import Data.List (nub, sort)
 import Data.Text (Text)
 import qualified Data.Text as T
 
--- 角色与权限服务：角色、授权与成员关系落在 system 库的表里，并据此判权限。
+-- 权限服务：稳定对象授权、角色继承与受影响会话展开。
 
--- | 出错口径与账号服务一致
-data PrivilegeError = PrivilegeError Text Text
-    deriving (Show, Eq)
+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
+    | 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
-    | GrantRoleCommand Text [Text]
-    | RevokeRoleCommand Text [Text]
-    deriving (Show, Eq)
-
-data Privileges = Privileges
-    { pvCatalog :: Catalog
-    }
-
--- | 建权限服务，固定在 system 库上
+-- 创建权限目录服务。
 newPrivileges :: Backend -> IO Privileges
-newPrivileges base = Privileges <$> newCatalog (beWithDatabase base systemDatabaseName)
+newPrivileges backend = do
+    directory <- newCatalog (beWithDatabase backend systemDatabaseName)
+    pure (Privileges directory backend)
 
--- | 语句转管理命令，不认的给 Nothing
+-- 将管理语句转换为权限命令。
 privilegeCommand :: Statement -> Maybe PrivilegeCommand
-privilegeCommand stmt = case stmt of
+privilegeCommand statement = case statement of
     CreateRole name -> Just (CreateRoleCommand (T.pack name))
     DropRole name -> Just (DropRoleCommand (T.pack name))
-    GrantPrivileges privs obj role withOption ->
-        Just (GrantPrivilegesCommand (map T.toLower (map T.pack privs)) (T.pack obj) (T.pack role) withOption)
-    RevokePrivileges privs obj role ->
-        Just (RevokePrivilegesCommand (map T.toLower (map T.pack privs)) (T.pack obj) (T.pack role))
+    GrantPrivileges items object role option -> Just (GrantPrivilegesCommand (map (T.toLower . T.pack) items) (T.pack object) (T.pack role) option)
+    RevokePrivileges items object role -> Just (RevokePrivilegesCommand (map (T.toLower . T.pack) items) (T.pack object) (T.pack role))
     GrantRole role members -> Just (GrantRoleCommand (T.pack role) (map T.pack members))
     RevokeRole role members -> Just (RevokeRoleCommand (T.pack role) (map T.pack members))
     _ -> Nothing
 
--- | 执行管理命令：管理员全通，普通身份只能转授自己拿到的权限
+-- 执行角色管理或有来源记录的对象授权。
 runPrivilegeCommand :: Privileges -> Principal -> Text -> PrivilegeCommand -> IO (Either PrivilegeError ())
-runPrivilegeCommand service principal database command
-    | needsDatabase = pure (Left (PrivilegeError "no_database" "no database selected"))
-    | principalIsRoot principal = withTables service (applyCommand service database command)
-    | principalIsCatalogManager principal = case command of
-        CreateRoleCommand{} -> withTables service (applyCommand service database command)
-        DropRoleCommand{} -> pure (Left forbidden)
-        _ -> withTables service (delegateCommand service principal database command)
-    | otherwise = withTables service (delegateCommand service principal database command)
+runPrivilegeCommand service principal database command = withTables service $ case command of
+    GrantPrivilegesCommand items object role option -> catalog (OA.objectGrant backend directory principal database items object role option)
+    RevokePrivilegesCommand items object role -> catalog (OA.objectRevoke backend directory principal database items object role)
+    CreateRoleCommand role
+        | principalIsCatalogManager principal -> do
+            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)
+    DropRoleCommand role
+        | principalIsRoot principal -> after (catalog (dropRole directory role))
+    GrantRoleCommand role members
+        | principalIsRoot principal -> do
+            known <- catalog (readRoleNames directory)
+            edges <- catalog (readMembers directory)
+            case (,) <$> known <*> edges of
+                Left err -> pure (Left err)
+                Right (names, pairs) -> case validateMembers names pairs role members of
+                    Left err -> pure (Left err)
+                    Right () -> eachAction members $ \member -> if (normalizeRole role, normalizeUser member) `elem` pairs then pure (Right ()) else catalog (addMember directory role member)
+    RevokeRoleCommand role members
+        | principalIsRoot principal -> after (eachAction members (\member -> catalog (removeMember directory role member)))
+    _ -> pure (Left forbidden)
   where
-    -- | 授权到具体对象时需要先选库
-    needsDatabase = T.null database && case command of
-        GrantPrivilegesCommand _ object _ _ -> T.strip object /= "*"
-        RevokePrivilegesCommand _ object _ -> T.strip object /= "*"
-        _ -> False
+    backend = pvBackend service
+    directory = pvCatalog service
+    -- 清理成员或身份变更失效的授权链。
+    after action = do
+        result <- action
+        case result of Left err -> pure (Left err); Right () -> catalog (OA.objectReconcile backend directory)
 
--- | 一条命令会影响的账号：角色连它的成员一起展开，账号名原样留下
-affectedAccounts :: Privileges -> PrivilegeCommand -> IO [Text]
-affectedAccounts service command = do
-    known <- roleNames service
-    case known of
-        Left _ -> pure (direct command)
-        Right roles -> walk roles [] (direct command)
+-- 在写入前校验全部成员和循环依赖。
+validateMembers :: [Text] -> [(Text, Text)] -> Text -> [Text] -> Either PrivilegeError ()
+validateMembers names pairs role members
+    | parent `notElem` names = Left (PrivilegeError "not_found" ("unknown role: " <> role))
+    | any ((`notElem` names) . normalizeUser) members = Left (PrivilegeError "not_found" "unknown role member")
+    | otherwise = foldMembers pairs members
   where
-    -- | 命令直接点到的名字
-    direct cmd = case cmd of
+    parent = normalizeRole role
+    -- 逐项加入候选成员边并检查闭包。
+    foldMembers _ [] = Right ()
+    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
+
+-- 展开角色的继承闭包。
+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))
+
+-- 展开成员和转授权变更影响的全部身份。
+affectedAccounts :: Privileges -> PrivilegeCommand -> IO (Either PrivilegeError [Text])
+affectedAccounts service command = withTables service (catalog (OA.objectAffected (pvBackend service) (pvCatalog service) direct))
+  where
+    direct = case command of
         CreateRoleCommand _ -> []
         DropRoleCommand role -> [role]
         GrantPrivilegesCommand _ _ role _ -> [role]
         RevokePrivilegesCommand _ _ role -> [role]
         GrantRoleCommand _ members -> members
         RevokeRoleCommand _ members -> members
-    -- | 是角色就接着往下走它的成员，走过的名字不再走第二遍
-    walk _ seen [] = pure (reverse seen)
-    walk roles seen (name : rest)
-        | name `elem` seen = walk roles seen rest
-        | normalizeRole name `elem` roles = do
-            members <- membersOfRole service name
-            case members of
-                Left _ -> walk roles (name : seen) rest
-                Right found -> walk roles (name : seen) (found ++ rest)
-        | otherwise = walk roles (name : seen) rest
 
--- | 语句鉴权：管理员全通，普通身份按需查
+-- 检查 SQL 的对象作用域权限。
 authorize :: Privileges -> Principal -> Text -> Statement -> IO (Either PrivilegeError ())
-authorize service principal database stmt
+authorize service principal database statement
     | principalIsRoot principal = pure (Right ())
-    | otherwise = case requiredActions stmt of
-        Nothing -> pure (Left forbidden)
-        Just needed -> authorizeTables service principal database needed
+    | otherwise = case statement of
+        CreateTable{} -> authorizeTables service principal database [("database:" <> database, "create")]
+        DropDatabase name -> owner ("database:" <> T.pack name)
+        DropTable name -> owner (T.pack name)
+        CreateIndex name _ -> owner (T.pack name)
+        DropIndex name _ -> owner (T.pack name)
+        DropColumn name _ -> owner (T.pack name)
+        AddColumn name _ -> owner (T.pack name)
+        RenameColumn name _ _ -> owner (T.pack name)
+        AlterColumnType name _ _ -> owner (T.pack name)
+        AlterColumnDefault name _ _ -> owner (T.pack name)
+        AlterColumnNull name _ _ -> owner (T.pack name)
+        ShowDomains -> authorizeConnect service principal database
+        ShowDatabases -> pure (Right ())
+        _ -> case requiredActions statement of Nothing -> pure (Left forbidden); Just needed -> authorizeTables service principal database needed
+  where
+    -- 检查结构操作的对象所有权。
+    owner object = withTables service (catalog (OA.objectOwner (pvBackend service) (pvCatalog service) principal database object))
 
--- | 直接查一组 (表, 权限)：一键接口用这个
+-- 检查数据库的 CONNECT 权限。
+authorizeConnect :: Privileges -> Principal -> Text -> IO (Either PrivilegeError ())
+authorizeConnect service principal database
+    | principalIsRoot principal = pure (Right ())
+    | otherwise = withTables service (catalog (OA.objectConnect (pvBackend service) (pvCatalog service) principal database))
+
+-- 检查 CONNECT 和表上的业务权限。
 authorizeTables :: Privileges -> Principal -> Text -> [(Text, Text)] -> IO (Either PrivilegeError ())
 authorizeTables service principal database needed
     | principalIsRoot principal = pure (Right ())
+    | T.null database && any (not . T.isPrefixOf "database:" . fst) needed = pure (Left (PrivilegeError "no_database" "no database selected"))
     | otherwise = withTables service $ do
-        grants <- grantsOfUser service (principalName principal)
-        pure (grants >>= \found -> checkAll database found needed)
+        connected <- if T.null database then pure (Right ()) else catalog (OA.objectConnect (pvBackend service) (pvCatalog service) principal database)
+        case connected of Left err -> pure (Left err); Right () -> catalog (OA.objectAuthorize (pvBackend service) (pvCatalog service) principal database needed)
 
--- | 只留下用户有 SELECT 权的表
+-- 仅返回拥有 SELECT 权限的表名。
 filterTables :: Privileges -> Principal -> Text -> [Text] -> IO (Either PrivilegeError [Text])
 filterTables service principal database tables
     | principalIsRoot principal = pure (Right tables)
-    | otherwise = withTables service $ do
-        grants <- grantsOfUser service (principalName principal)
-        pure ((\found -> [table | table <- tables, checkAll database found [(table, "select")] == Right ()]) <$> grants)
+    | otherwise = do
+        connected <- authorizeConnect service principal database
+        case connected of
+            Left err -> pure (Left err)
+            Right () -> do
+                results <- mapM (\table -> authorizeTables service principal database [(table, "select")]) tables
+                pure $ case [err | Left err@(PrivilegeError code _) <- results, code /= "forbidden"] of
+                    err : _ -> Left err
+                    [] -> Right [table | (table, Right ()) <- zip tables results]
 
--- | 角色总览（REST 与测试用）
+-- 返回角色的有效对象授权和直接成员。
 listRoleViews :: Privileges -> IO (Either PrivilegeError [RoleView])
 listRoleViews service = withTables service $ do
-    names <- fmap (fmap (map accountUser . filter (not . accountCanLogin))) (catalog (readIdentities (pvCatalog service)))
-    case names of
+    names <- catalog (readIdentities (pvCatalog service))
+    members <- catalog (readMembers (pvCatalog service))
+    case (,) <$> names <*> members of
         Left err -> pure (Left err)
-        Right known -> sequence <$> mapM view (sort known)
+        Right (identities, pairs) -> fmap sequence $ mapM (view pairs) (sort (map accountUser (filter (not . accountCanLogin) identities)))
   where
-    -- | 组装一个角色的总览
-    view role = do
-        grants <- roleGrantsOf service role
-        members <- membersOfRole service role
-        pure (RoleView role <$> grants <*> members)
+    -- 组装一个角色的公开权限视图。
+    view members name = do
+        grants <- catalog (OA.objectViews (pvBackend service) (pvCatalog service) name)
+        pure ((\rows -> RoleView name rows [member | (role, member) <- members, role == name]) <$> grants)
 
--- | 一条语句需要哪些 (表, 权限)
+-- 登记创建对象的所有者。
+claimObject :: Privileges -> Principal -> Text -> Text -> IO (Either PrivilegeError ())
+claimObject service principal database object = withTables service (catalog (OA.objectClaim (pvBackend service) (pvCatalog service) principal database object))
+
+-- 持久化即将建表的所有者声明。
+prepareObject :: Privileges -> Principal -> Text -> Text -> IO (Either PrivilegeError ())
+prepareObject service principal database object = withTables service (catalog (OA.objectPrepareCreate (pvBackend service) (pvCatalog service) principal database object))
+
+-- 获取删除对象影响的授权身份。
+affectedObject :: Privileges -> Text -> Text -> IO (Either PrivilegeError [Text])
+affectedObject service database object = withTables service (catalog (OA.objectUsers (pvBackend service) (pvCatalog service) database object))
+
+-- 清理身份或对象删除后的权限记录。
+reconcileObjects :: Privileges -> IO (Either PrivilegeError ())
+reconcileObjects service = withTables service (catalog (OA.objectReconcile (pvBackend service) (pvCatalog service)))
+
+-- 收集数据语句及子查询所需的表权限。
 requiredActions :: Statement -> Maybe [(Text, Text)]
-requiredActions stmt = case stmt of
-    Select{} -> Just (selectNeeds (selectFrom stmt) (maybe [] (: []) (selectWhere stmt)))
-    SelectExpr{} ->
-        Just (selectNeeds (selectFrom stmt) (maybe [] (: []) (selectWhere stmt) ++ map snd (selectItems stmt)))
+requiredActions statement = case statement of
+    Select{} -> Just (selectNeeds (selectFrom statement) (maybe [] (: []) (selectWhere statement)))
+    SelectExpr{} -> Just (selectNeeds (selectFrom statement) (maybe [] (: []) (selectWhere statement) ++ map snd (selectItems statement)))
     Insert table _ rows -> Just ((T.pack table, "insert") : selectsOf (concat rows))
-    Update table assigns cond -> Just ((T.pack table, "update") : selectsOf (map snd assigns ++ maybe [] (: []) cond))
-    Delete table cond -> Just ((T.pack table, "delete") : selectsOf (maybe [] (: []) cond))
+    Update table assignments condition -> Just ((T.pack table, "update") : selectsOf (map snd assignments ++ maybe [] (: []) condition))
+    Delete table condition -> Just ((T.pack table, "delete") : selectsOf (maybe [] (: []) condition))
     _ -> Nothing
   where
-    -- | FROM 子句要的 SELECT 权限
-    selectNeeds source exprs = [(ref, "select") | ref <- nub (tableRefsOf source)] ++ selectsOf exprs
-    -- | 表达式里子查询要的 SELECT 权限
-    selectsOf exprs = [(ref, "select") | ref <- nub (concatMap exprTables exprs)]
+    -- 收集来源树和表达式的读取权限。
+    selectNeeds source expressions = [(ref, "select") | ref <- nub (tableRefsOf source)] ++ selectsOf expressions
+    -- 收集表达式中子查询的读取权限。
+    selectsOf expressions = [(ref, "select") | ref <- nub (concatMap exprTables expressions)]
 
--- | 每项 (表, 权限) 都要被某条授权覆盖
-checkAll :: Text -> [Grant] -> [(Text, Text)] -> Either PrivilegeError ()
-checkAll database grants needed = checkCovered database grants needed "permission denied: "
-
--- | 转授权要查 grant option，报错口径与普通鉴权分开
-checkOptions :: Text -> [Grant] -> [(Text, Text)] -> Either PrivilegeError ()
-checkOptions database grants needed = checkCovered database grants needed "grant option required: "
-
--- | 覆盖检查的公共实现
-checkCovered :: Text -> [Grant] -> [(Text, Text)] -> Text -> Either PrivilegeError ()
-checkCovered database grants needed prefix = case [pair | pair@(table, privilege) <- needed, not (covered table privilege)] of
-    [] -> Right ()
-    ((table, privilege) : _) ->
-        Left (PrivilegeError "forbidden" (prefix <> T.toUpper privilege <> " ON " <> table))
-  where
-    -- | 某一项是否被授权覆盖
-    covered table privilege =
-        let target = normalizeObject database table
-         in any
-                (\grant -> (grantObject grant == "*" || grantObject grant == target) && grantPrivilege grant == privilege)
-                grants
-
--- | 一个用户实际能用的授权：含角色继承
-grantsOfUser :: Privileges -> Text -> IO (Either PrivilegeError [Grant])
-grantsOfUser service user = do
-    members <- catalog (readMembers (pvCatalog service))
-    grants <- catalog (readGrants (pvCatalog service))
-    options <- catalog (readGrantOptions (pvCatalog service))
-    roles <- catalog (readIdentities (pvCatalog service))
-    pure $ do
-        memberRows <- members
-        grantRows <- grants
-        optionRows <- options
-        identities <- roles
-        let known = map accountUser (filter accountEnabled identities)
-            disabled = map accountUser (filter (not . accountEnabled) identities)
-            activeMembers = [(role, member) | (role, member) <- memberRows, role `elem` known, member `notElem` disabled]
-            edges = roleEdges activeMembers known
-            mine = if normalizeUser user `elem` disabled then [] else closureUp edges
-                (normalizeUser user : [role | (role, member) <- activeMembers, member == normalizeUser user])
-        pure [grant | grant <- grantRows ++ optionRows, grantRole grant `elem` mine]
-
--- | 一个用户手里的 grant option，只有这些能再转授
-optionsOfUser :: Privileges -> Text -> IO (Either PrivilegeError [Grant])
-optionsOfUser service user = fmap (fmap (filter grantable)) (grantsOfUser service user)
-
--- | 角色到角色的成员边：父角色在前
-roleEdges :: [(Text, Text)] -> [Text] -> [(Text, Text)]
-roleEdges members roles = [pair | pair@(_, child) <- members, child `elem` roles]
-
--- | 向上闭包：这群角色直接或间接所属的全部角色
-closureUp :: [(Text, Text)] -> [Text] -> [Text]
-closureUp edges = go
-  where
-    -- | 展开一轮，没有再新增就停
-    go known =
-        let more = [parent | (parent, child) <- edges, child `elem` known, parent `notElem` known]
-         in if null more then known else go (known ++ more)
-
--- | 一个角色挂着的授权，带 grant option 的会标出来
-roleGrantsOf :: Privileges -> Text -> IO (Either PrivilegeError [Grant])
-roleGrantsOf service role = do
-    grants <- catalog (readGrants (pvCatalog service))
-    options <- catalog (readGrantOptions (pvCatalog service))
-    pure (do
-        rows <- grants
-        optionRows <- options
-        let mine = filter (\grant -> grantRole grant == normalizeRole role) rows
-        pure (markOptions mine optionRows))
-
--- | 给授权标上有没有对应的 grant option
-markOptions :: [Grant] -> [Grant] -> [Grant]
-markOptions grants options = [grant {grantable = hasOption grant} | grant <- grants]
-  where
-    -- | 有没有一条同角色同权限同对象的 option
-    hasOption grant = any (same grant) options
-    -- | 两条授权指向同一处
-    same one other =
-        grantRole one == grantRole other
-            && grantPrivilege one == grantPrivilege other
-            && grantObject one == grantObject other
-
--- | 角色名清单（统一小写）
-roleNames :: Privileges -> IO (Either PrivilegeError [Text])
-roleNames service = catalog (readRoleNames (pvCatalog service))
-
--- | 一个角色的直接成员：用户与子角色
-membersOfRole :: Privileges -> Text -> IO (Either PrivilegeError [Text])
-membersOfRole service role = do
-    members <- catalog (readMembers (pvCatalog service))
-    pure (map snd . filter (\(name, _) -> name == normalizeRole role) <$> members)
-
--- | 角色必须存在，否则命令不落地
-requireRole :: Privileges -> Text -> IO (Either PrivilegeError ())
-requireRole service role = do
-    known <- roleNames service
-    pure $ case known of
-        Left err -> Left err
-        Right names
-            | normalizeRole role `elem` names -> Right ()
-            | otherwise -> Left (unknownRole role)
-
--- | 真正落库（表已经保证存在）
-applyCommand :: Privileges -> Text -> PrivilegeCommand -> IO (Either PrivilegeError ())
-applyCommand service database command = case command of
-    CreateRoleCommand role -> do
-        known <- roleNames service
-        case known of
-            Left err -> pure (Left err)
-            Right names
-                | normalizeRole role `elem` names -> pure (Left (PrivilegeError "conflict" ("role already exists: " <> role)))
-                | otherwise -> catalog (insertRole (pvCatalog service) role)
-    DropRoleCommand role -> do
-        allowed <- requireRole service role
-        case allowed of
-            Left err -> pure (Left err)
-            Right () -> catalog (dropRole (pvCatalog service) role)
-    GrantPrivilegesCommand privileges object role withOption -> do
-        allowed <- requireRole service role
-        case allowed of
-            Left err -> pure (Left err)
-            Right () ->
-                eachAction (expandPrivileges privileges) $ \privilege ->
-                    grantOne service withOption role privilege (normalizeObject database object)
-    RevokePrivilegesCommand privileges object role -> do
-        allowed <- requireRole service role
-        case allowed of
-            Left err -> pure (Left err)
-            Right () ->
-                eachAction (expandPrivileges privileges) $ \privilege ->
-                    revokeOne service role privilege (normalizeObject database object)
-    GrantRoleCommand role members -> do
-        allowed <- requireRole service role
-        case allowed of
-            Left err -> pure (Left err)
-            Right () -> do
-                known <- roleNames service
-                case known of
-                    Left err -> pure (Left err)
-                    Right roles -> eachAction members (grantMember service roles role)
-    RevokeRoleCommand role users -> do
-        allowed <- requireRole service role
-        case allowed of
-            Left err -> pure (Left err)
-            Right () -> eachAction users $ \user -> catalog (removeMember (pvCatalog service) role user)
-
--- | 落一条授权，带 grant option 的再落一条转授权
-grantOne :: Privileges -> Bool -> Text -> Text -> Text -> IO (Either PrivilegeError ())
-grantOne service withOption role privilege object = do
-    written <- catalog (addGrant (pvCatalog service) role privilege object)
-    case written of
-        Left err -> pure (Left err)
-        Right ()
-            | withOption -> catalog (addGrantOption (pvCatalog service) role privilege object)
-            | otherwise -> pure (Right ())
-
--- | 收一条授权，连同它的 grant option
-revokeOne :: Privileges -> Text -> Text -> Text -> IO (Either PrivilegeError ())
-revokeOne service role privilege object = do
-    dropped <- catalog (removeGrant (pvCatalog service) role privilege object)
-    case dropped of
-        Left err -> pure (Left err)
-        Right () -> catalog (removeGrantOption (pvCatalog service) role privilege object)
-
--- | 普通身份转授权：只放行 GRANT
-delegateCommand :: Privileges -> Principal -> Text -> PrivilegeCommand -> IO (Either PrivilegeError ())
-delegateCommand service principal database command = case command of
-    GrantPrivilegesCommand _ _ role _ -> do
-        allowed <- requireRole service role
-        case allowed of
-            Left err -> pure (Left err)
-            Right () -> do
-                owned <- optionsOfUser service (principalName principal)
-                case owned >>= \found -> checkOptions database found needed of
-                    Left err -> pure (Left err)
-                    Right () -> applyCommand service database command
-    _ -> pure (Left forbidden)
-  where
-    -- | 命令里每个 (对象, 权限) 都要对得上
-    needed = case command of
-        GrantPrivilegesCommand privileges object _ _ -> [(object, privilege) | privilege <- expandPrivileges privileges]
-        _ -> []
-
--- | 加一条成员边：名字是角色就查环，否则当用户加
-grantMember :: Privileges -> [Text] -> Text -> Text -> IO (Either PrivilegeError ())
-grantMember service roles role member = do
-    current <- membersOfRole service role
-    case current of
-        Left err -> pure (Left err)
-        Right known
-            | normalizeUser member `elem` known -> pure (Right ())
-            | normalizeRole member `notElem` roles -> catalog (addMember (pvCatalog service) role member)
-            | otherwise -> do
-                edges <- membershipEdges service
-                case edges of
-                    Left err -> pure (Left err)
-                    Right pairs
-                        | normalizeRole member `elem` closureUp pairs [normalizeRole role] ->
-                            pure (Left (cycleMember role member))
-                        | otherwise -> catalog (addMember (pvCatalog service) role member)
-
--- | 只保留两端都是角色的成员边
-membershipEdges :: Privileges -> IO (Either PrivilegeError [(Text, Text)])
-membershipEdges service = do
-    members <- catalog (readMembers (pvCatalog service))
-    roles <- roleNames service
-    pure (roleEdges <$> members <*> roles)
-
--- | 全程持锁，先保证系统表存在再跑动作
+-- 持目录锁并确保旧权限表存在。
 withTables :: Privileges -> IO (Either PrivilegeError a) -> IO (Either PrivilegeError a)
 withTables service action = withCatalogLock (pvCatalog service) $ do
     ready <- ensureCatalog (pvCatalog service)
-    case ready of
-        Left err -> pure (Left (storageError err))
-        Right () -> action
+    case ready of Left err -> pure (Left (storageError err)); Right () -> action
 
--- | 目录操作转成权限错误
+-- 将目录结果转换为权限错误。
 catalog :: IO (Either String a) -> IO (Either PrivilegeError a)
 catalog action = fmap (either (Left . storageError) Right) action
 
--- | 把 ALL 展开成四种具体权限
-expandPrivileges :: [Text] -> [Text]
-expandPrivileges privileges = nub (concatMap expand (map (T.toLower . T.strip) privileges))
+-- 分类稳定对象目录的明确错误。
+storageError :: String -> PrivilegeError
+storageError message = PrivilegeError code (T.pack message)
   where
-    -- | 展开一条权限名
-    expand "all" = ["select", "insert", "update", "delete"]
-    expand other = [other]
+    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"
-
--- | 未知角色的错误
-unknownRole :: Text -> PrivilegeError
-unknownRole role = PrivilegeError "not_found" ("unknown role: " <> role)
-
--- | 角色成员成环的错误
-cycleMember :: Text -> Text -> PrivilegeError
-cycleMember role member =
-    PrivilegeError "conflict" ("role membership would create a cycle: " <> normalizeRole role <> " and " <> normalizeRole member)
-
--- | 存储错误转成权限错误
-storageError :: String -> PrivilegeError
-storageError "the last enabled login superuser cannot be removed" = PrivilegeError "bad_request" "the last enabled login superuser cannot be removed"
-storageError message = PrivilegeError "storage_error" ("privilege storage: " <> T.pack message)

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

@@ -0,0 +1,35 @@
+module ChuSQL.Server.Security (readSecurity, writeSecurity) where
+
+import Control.Concurrent.MVar
+import Control.Exception (bracket_, mask_)
+import System.IO.Unsafe (unsafePerformIO)
+
+-- 共享权限门：查询并行读取，权限和对象变更独占执行。
+
+{-# NOINLINE securityGate #-}
+securityGate :: (MVar (), MVar (), MVar Int)
+securityGate = unsafePerformIO $ do
+    turn <- newMVar ()
+    room <- newMVar ()
+    readers <- newMVar 0
+    pure (turn, room, readers)
+
+-- 并行执行权限稳定期间的查询。
+readSecurity :: IO a -> IO a
+readSecurity = bracket_ enter leave
+  where
+    (turn, room, readers) = securityGate
+    -- 登记共享读取者。
+    enter = withMVar turn $ \_ -> modifyMVar_ readers $ \count -> do
+        if count == 0 then takeMVar room else pure ()
+        pure (count + 1)
+    -- 释放最后一个共享读取者。
+    leave = mask_ $ modifyMVar_ readers $ \count -> do
+        if count == 1 then putMVar room () else pure ()
+        pure (count - 1)
+
+-- 独占执行权限或对象变更。
+writeSecurity :: IO a -> IO a
+writeSecurity action = withMVar turn $ \_ -> withMVar room (const action)
+  where
+    (turn, room, _) = securityGate

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

@@ -13,9 +13,11 @@ module ChuSQL.Server.Session
     , isPlainIdentifier
     , authenticateSession
     , authenticateSessionCoded
+    , authenticateSudoSessionCoded
     , switchDatabase
     , runStatement
     , runStatementCoded
+    , runStorageCoded
     , catalog
     , accounts
     , roleViews
@@ -37,14 +39,19 @@ import ChuSQL.Interface.Auth (defaultSessionPolicy, newSessionStore)
 import ChuSQL.Server.Accounts
 import ChuSQL.Server.Backend (Backend (..), StatementResult (..), columnsFromStatement, scopeDdl)
 import ChuSQL.Server.Policy (configurePasswordPolicy)
-import ChuSQL.Server.Privileges (PrivilegeCommand (..), PrivilegeError (..), Privileges, RoleView, affectedAccounts, authorize, filterTables, listRoleViews, newPrivileges, privilegeCommand, runPrivilegeCommand)
+import ChuSQL.Server.Privileges (PrivilegeCommand (..), PrivilegeError (..), Privileges, RoleView, affectedAccounts, affectedObject, authorize, authorizeConnect, claimObject, prepareObject, reconcileObjects, filterTables, listRoleViews, newPrivileges, privilegeCommand, runPrivilegeCommand)
+import ChuSQL.Server.Security (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)
+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.Time.Clock (getCurrentTime)
 
 -- SQL 会话：Web、命令行与 TCP 服务器共用的账号、权限与语句执行入口。
@@ -66,6 +73,7 @@ data Session = Session
     , ssPrivileges :: Privileges
     , ssCurrent :: IORef Text
     , ssPrincipal :: IORef (Maybe Principal)
+    , ssIdentityStamp :: IORef (Maybe (Integer, Integer))
     , ssSettingsFile :: FilePath
     , ssTransaction :: IORef (Maybe Transaction)
     , ssChanged :: [Text] -> IO ()
@@ -75,7 +83,9 @@ data Session = Session
 data Transaction = Transaction
     { txBase :: Database
     , txStaged :: Database
-    , txSavepoints :: [(String, Database)]
+    , txSavepoints :: [(String, Database, [Statement])]
+    , txStatements :: [Statement]
+    , txObjects :: [(String, A.Value)]
     }
 
 -- | 开一个会话：账号与角色服务、配置策略都和 Web 端一致
@@ -92,8 +102,9 @@ newSessionWith backend name settingsFile changed = do
     -- 服务启动后只有系统库：没 USE 之前不预设任何工作库
     current <- newIORef ""
     principal <- newIORef Nothing
+    identityStamp <- newIORef Nothing
     transaction <- newIORef Nothing
-    pure (Session backend accountsService privileges current principal settingsFile transaction changed)
+    pure (Session backend accountsService privileges current principal identityStamp settingsFile transaction changed)
 
 -- | 当前生效的口令策略（只有管理员能看）
 policyOf :: Session -> IO (Either Text PasswordPolicy)
@@ -142,7 +153,7 @@ authenticateSession session user password =
 
 -- | 登录（带错误码）
 authenticateSessionCoded :: Session -> Text -> Text -> IO (Either SessionError ())
-authenticateSessionCoded session user password = do
+authenticateSessionCoded session user password = readSecurity $ do
     result <- authenticate (ssAccounts session) user password
     case result of
         Left err -> pure (Left (accountErrorOf err))
@@ -150,14 +161,39 @@ authenticateSessionCoded session user password = do
             who <- currentPrincipal (ssAccounts session) token
             case who of
                 Left err -> pure (Left (accountErrorOf err))
-                Right principal -> do
-                    writeIORef (ssPrincipal session) (Just principal)
-                    pure (Right ())
+                Right principal -> storePrincipal session principal
+
+-- 登录已通过本机凭据校验的映射账号。
+authenticateSudoSessionCoded :: Session -> Text -> IO (Either SessionError ())
+authenticateSudoSessionCoded session user = readSecurity $ do
+    result <- authenticateSudo (ssAccounts session) user
+    case result of
+        Left err -> pure (Left (accountErrorOf err))
+        Right token -> do
+            who <- currentPrincipal (ssAccounts session) token
+            case who of
+                Left err -> pure (Left (accountErrorOf err))
+                Right principal -> storePrincipal session principal
+
+-- 绑定身份版本并清理旧登录的事务。
+storePrincipal :: Session -> Principal -> IO (Either SessionError ())
+storePrincipal session principal = do
+    result <- findAccount (ssAccounts session) (principalName principal)
+    case result of
+        Left err -> pure (Left (accountErrorOf err))
+        Right account -> do
+            writeIORef (ssPrincipal session) (Just principal)
+            writeIORef (ssIdentityStamp session) (Just (accountId account, accountRevision account))
+            writeIORef (ssTransaction session) Nothing
+            writeIORef (ssCurrent session) ""
+            pure (Right ())
 
 -- | 换库；系统库只有 root 能进
 switchDatabase :: Session -> Text -> IO (Either Text ())
 switchDatabase session name =
-    fmap (first sessMessage) (switchDatabaseCoded session name)
+    readSecurity $ do
+        valid <- validatePrincipal session
+        case valid of Left err -> pure (Left (sessMessage err)); Right () -> fmap (first sessMessage) (switchDatabaseCoded session name)
 
 -- | 换库（带错误码）
 switchDatabaseCoded :: Session -> Text -> IO (Either SessionError ())
@@ -171,11 +207,18 @@ switchDatabaseCoded session rawName
     name = T.toLower (T.strip rawName)
     -- | 真的切库并记下当前库
     go = do
-        backend <- currentBackend session
-        result <- beStatement backend ("USE " ++ T.unpack name)
-        case result of
-            Left err -> pure (Left (engineErrorCode err))
-            Right _ -> writeIORef (ssCurrent session) name >> pure (Right ())
+        who <- readIORef (ssPrincipal session)
+        allowed <- case who of
+            Just principal | name /= "system" -> authorizeConnect (ssPrivileges session) principal name
+            _ -> pure (Right ())
+        case allowed of
+            Left err -> pure (Left (privilegeErrorOf err))
+            Right () -> do
+                backend <- currentBackend session
+                result <- beStatement backend ("USE " ++ T.unpack name)
+                case result of
+                    Left err -> pure (Left (engineErrorCode err))
+                    Right _ -> writeIORef (ssCurrent session) name >> pure (Right ())
 
 -- | 跑一条语句：USE、账号与角色语句分流，其余交引擎
 runStatement :: Session -> Text -> IO (Either Text QueryResult)
@@ -183,7 +226,43 @@ runStatement session sql = fmap (first sessMessage) (runStatementCoded session s
 
 -- | 跑一条语句（带错误码）
 runStatementCoded :: Session -> Text -> IO (Either SessionError QueryResult)
-runStatementCoded session sql = case parseStatement (T.unpack sql) of
+runStatementCoded session sql = gate $ do
+    valid <- validatePrincipal session
+    case valid of Left err -> pure (Left err); Right () -> runStatementUnlocked session sql
+  where
+    gate = case parseStatement (T.unpack sql) of
+        Right statement | transactionDdl statement || isJust (accountCommand statement) || isJust (privilegeCommand statement) -> writeSecurity
+        _ -> readSecurity
+
+-- 在权限门内检查并执行管理员存储请求。
+runStorageCoded :: Session -> A.Value -> IO (Either SessionError A.Value)
+runStorageCoded session payload = writeSecurity $ do
+    valid <- validatePrincipal session
+    who <- readIORef (ssPrincipal session)
+    case valid of
+        Left err -> pure (Left err)
+        Right () -> case who of
+            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)
+
+-- 检查登录身份的当前版本和启用状态。
+validatePrincipal :: Session -> IO (Either SessionError ())
+validatePrincipal session = do
+    who <- readIORef (ssPrincipal session)
+    stamp <- readIORef (ssIdentityStamp session)
+    case who of
+        Just principal -> do
+            result <- findAccount (ssAccounts session) (principalName principal)
+            pure $ case result of
+                Left err -> Left (accountErrorOf err)
+                Right current | stamp == Just (accountId current, accountRevision current) && accountEnabled current && accountCanLogin current && (not (principalIsRoot principal) || accountIsSuperuser current) -> Right ()
+                _ -> Left (SessionError "unauthorized" "session identity has changed")
+        _ -> pure (Right ())
+
+-- 在共享权限门内分发会话语句。
+runStatementUnlocked :: Session -> Text -> IO (Either SessionError QueryResult)
+runStatementUnlocked session sql = case parseStatement (T.unpack sql) of
     Right (UseDatabase name) -> do
         existing <- readIORef (ssTransaction session)
         case existing of
@@ -215,7 +294,7 @@ runStatementCoded session sql = case parseStatement (T.unpack sql) of
                         Left err -> pure (Left err)
                         Right ()
                             | isJust transaction && transactionData statement -> runInTransaction session statement
-                            | otherwise -> runPlain session sql
+                            | otherwise -> runObjectStatement session statement sql
     Left _ -> runPlain session sql
 
 -- | 事务里不许改结构，会话层直接拦下
@@ -250,6 +329,12 @@ transactionData statement = case statement of
 -- | 开事务：把当前库整库做一份快照当起点
 beginTransaction :: Session -> IO (Either SessionError QueryResult)
 beginTransaction session = do
+    allowed <- sessionConnectAllowed session
+    case allowed of Left err -> pure (Left err); Right () -> beginAuthorized session
+
+-- 在连接权限复核后建立事务快照。
+beginAuthorized :: Session -> IO (Either SessionError QueryResult)
+beginAuthorized session = do
     current <- readIORef (ssCurrent session)
     existing <- readIORef (ssTransaction session)
     case existing of
@@ -262,8 +347,12 @@ beginTransaction session = do
                 case snapshotResult of
                     Left err -> pure (Left (engineErrorCode err))
                     Right db -> do
-                        writeIORef (ssTransaction session) (Just (Transaction db db []))
-                        pure (Right (emptyResult (Just current)))
+                        objects <- snapshotObjectIds session (map fst db)
+                        case objects of
+                            Left err -> pure (Left err)
+                            Right ids -> do
+                                writeIORef (ssTransaction session) (Just (Transaction db db [] [] ids))
+                                pure (Right (emptyResult (Just current)))
 
 -- | 提交：把快照差分交给存储层应用，成功才结束事务
 commitTransaction :: Session -> IO (Either SessionError QueryResult)
@@ -273,20 +362,56 @@ commitTransaction session = do
     case existing of
         Nothing -> pure (Left (SessionError "query_error" "no transaction in progress"))
         Just transaction -> do
+            connected <- sessionConnectAllowed session
+            permissions <- mapM (authorized session) (txStatements transaction)
+            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
+
+-- 对象和权限复核后提交事务差分。
+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 -> case transactionConflict (txBase transaction) (txStaged transaction) live of
+                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 (txBase transaction) (txStaged transaction) live)
+                        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)))
 
+-- 检查当前数据库连接权限。
+sessionConnectAllowed :: Session -> IO (Either SessionError ())
+sessionConnectAllowed session = do
+    database <- readIORef (ssCurrent session)
+    who <- readIORef (ssPrincipal session)
+    case who of
+        Just principal | not (principalIsRoot principal), not (T.null database) -> fmap (first privilegeErrorOf) (authorizeConnect (ssPrivileges session) principal database)
+        _ -> pure (Right ())
+
+-- 保存事务使用的 catalog 对象编号。
+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)
+  where
+    -- 解析一个快照表的稳定对象编号。
+    one database name = do
+        result <- beStorage (ssBackend session) (A.object ["method" A..= ("resolve_object" :: Text), "database" A..= database, "table" A..= name])
+        pure $ case result of
+            Left err -> Left (SessionError "serialization_failure" (T.pack err))
+            Right value@(A.Object fields) | KM.lookup "status" fields == Just (A.String "object") -> Right (name, value)
+            Right _ -> Left (SessionError "serialization_failure" "transaction object no longer exists")
+
 -- | 回滚：快照丢掉，存储层没被改过
 rollbackTransaction :: Session -> IO (Either SessionError QueryResult)
 rollbackTransaction session = do
@@ -306,7 +431,7 @@ savepointTransaction session name = do
     case existing of
         Nothing -> pure (Left (SessionError "query_error" "no transaction in progress"))
         Just transaction -> do
-            let stack = txSavepoints transaction ++ [(T.unpack name, txStaged transaction)]
+            let stack = txSavepoints transaction ++ [(T.unpack name, txStaged transaction, txStatements transaction)]
             writeIORef (ssTransaction session) (Just transaction {txSavepoints = stack})
             pure (Right (emptyResult (Just current)))
 
@@ -320,10 +445,10 @@ rollbackToSavepoint session name = do
         Just transaction -> case savepointIndex name (txSavepoints transaction) of
             Nothing -> pure (Left (SessionError "query_error" ("no such savepoint: " <> name)))
             Just index -> do
-                let (_, staged) = txSavepoints transaction !! index
+                let (_, staged, statements) = txSavepoints transaction !! index
                 writeIORef
                     (ssTransaction session)
-                    (Just transaction {txStaged = staged, txSavepoints = take (index + 1) (txSavepoints transaction)})
+                    (Just transaction {txStaged = staged, txStatements = statements, txSavepoints = take (index + 1) (txSavepoints transaction)})
                 pure (Right (emptyResult (Just current)))
 
 -- | 释放保存点：该保存点与它之后的保存点一起丢掉
@@ -340,9 +465,9 @@ releaseSavepoint session name = do
                 pure (Right (emptyResult (Just current)))
 
 -- | 最近一次同名保存点的下标
-savepointIndex :: Text -> [(String, Database)] -> Maybe Int
+savepointIndex :: Text -> [(String, Database, [Statement])] -> Maybe Int
 savepointIndex name entries =
-    case [index | (index, (label, _)) <- zip [0 ..] entries, T.pack label == name] of
+    case [index | (index, (label, _, _)) <- zip [0 ..] entries, T.pack label == name] of
         [] -> Nothing
         hits -> Just (last hits)
 
@@ -356,7 +481,7 @@ 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})
+                writeIORef (ssTransaction session) (Just transaction {txStaged = staged, txStatements = statement : txStatements transaction})
                 pure (Right (resultOfStaged (txStaged transaction) statement rows))
 
 -- | 事务内的结果集：空结果回落到解析出来的列名
@@ -376,8 +501,8 @@ data TableDiff = TableDiff
     }
 
 -- | 提交差分：相对快照列出要删、要写与要替换的行
-transactionOps :: Database -> Database -> Database -> [TxnOp]
-transactionOps base staged live = concatMap opsOf (transactionDiffs base staged live)
+transactionOps :: [(String, TableDiff)] -> [TxnOp]
+transactionOps = concatMap opsOf
   where
     -- | 一张表的请求：先删后写
     opsOf (name, diff) =
@@ -386,9 +511,9 @@ transactionOps base staged live = concatMap opsOf (transactionDiffs base staged
             ++ [TxnReplace name rows | Just rows <- [tdReplace diff]]
 
 -- | 提交前校验：本事务动过的行是否已被别人改掉
-transactionConflict :: Database -> Database -> Database -> Maybe String
-transactionConflict base staged live =
-    case [msg | (_, diff) <- transactionDiffs base staged live, Just msg <- [tdConflict diff]] of
+transactionConflict :: [(String, TableDiff)] -> Maybe String
+transactionConflict diffs =
+    case [msg | (_, diff) <- diffs, Just msg <- [tdConflict diff]] of
         (msg : _) -> Just msg
         [] -> Nothing
 
@@ -401,9 +526,8 @@ transactionDiffs base staged live = [(name, diffFor name) | name <- names]
 
     -- | 一张表的差异
     diffFor name
-        | all (isJust . rowKey) (baseRows ++ stagedRows) = keyedDiff
-        -- 没动过这张表：别人改成什么样都不关本事务
         | stagedRows == baseRows = emptyDiff
+        | all (isJust . rowKey) (baseRows ++ stagedRows) = keyedDiff
         -- 动过，库里还是基线：整表替换
         | liveRows == baseRows = emptyDiff {tdReplace = Just stagedRows}
         | otherwise = emptyDiff {tdConflict = Just ("write conflict on table " ++ name)}
@@ -412,27 +536,30 @@ transactionDiffs base staged live = [(name, diffFor name) | name <- names]
         stagedRows = rowsOf name staged
         liveRows = rowsOf name live
 
-        baseByKey = [(k, r) | r <- baseRows, Just k <- [rowKey r]]
-        liveByKey = [(k, r) | r <- liveRows, Just k <- [rowKey r]]
-        stagedByKey = [(k, r) | r <- stagedRows, Just k <- [rowKey r]]
+        baseByKey = keyedRows baseRows
+        liveByKey = keyedRows liveRows
+        stagedByKey = keyedRows stagedRows
+        stagedEntries = [(k, r) | r <- stagedRows, Just k <- [rowKey r]]
 
         -- 本事务动过的键：内容改过、新增，或者删掉
-        written = [k | (k, r) <- stagedByKey, lookup k baseByKey /= Just r]
-        removed = [k | (k, _) <- baseByKey, not (any ((== k) . fst) stagedByKey)]
+        written = [k | (k, r) <- stagedEntries, IM.lookup k baseByKey /= Just r]
+        writtenSet = IS.fromList written
+        removed = [k | r <- baseRows, Just k <- [rowKey r], IM.notMember k stagedByKey]
+        removedSet = IS.fromList removed
         touched = written ++ removed
 
         -- 两边都删了算一致；其余只要跟基线不一样就是冲突
         victims =
             [ k
             | k <- touched
-            , lookup k liveByKey /= lookup k baseByKey
-            , not (k `elem` removed && lookup k liveByKey == Nothing)
+            , IM.lookup k liveByKey /= IM.lookup k baseByKey
+            , not (IS.member k removedSet && IM.notMember k liveByKey)
             ]
 
         keyedDiff =
             emptyDiff
-                { tdDeletes = [k | k <- touched, isJust (lookup k liveByKey)]
-                , tdWrites = [r | (k, r) <- stagedByKey, k `elem` written]
+                { tdDeletes = [k | k <- touched, IM.member k liveByKey]
+                , tdWrites = [r | (k, r) <- stagedEntries, IS.member k writtenSet]
                 , tdConflict = case victims of
                     (k : _) -> Just ("write conflict on table " ++ name ++ ", id " ++ show k)
                     [] -> Nothing
@@ -447,6 +574,10 @@ transactionDiffs base staged live = [(name, diffFor name) | name <- names]
     -- | 库里某张表的行
     rowsOf name db = maybe [] tableRows (lookup name db)
 
+-- | 按整数 id 建立保留首行的查找表
+keyedRows :: [Row] -> IM.IntMap Row
+keyedRows rows = IM.fromListWith (\_ earlier -> earlier) [(key, row) | row <- rows, Just key <- [rowKey row]]
+
 -- | 行 id：只有整数 id 才认，跟存储层删行的口径一致
 rowKey :: Row -> Maybe Int
 rowKey row = case lookup "id" row of
@@ -471,9 +602,64 @@ runPlain session sql = do
     result <- beStatement backend (T.unpack sql)
     pure (either (Left . engineErrorCode) (Right . resultOf) result)
 
+-- 执行对象结构变更并维护所有者和授权。
+runObjectStatement :: Session -> Statement -> Text -> IO (Either SessionError QueryResult)
+runObjectStatement session statement sql = do
+    who <- readIORef (ssPrincipal session)
+    database <- readIORef (ssCurrent session)
+    prepared <- case (who, statement) of
+        (Just principal, CreateTable name _) | database /= "system" -> prepareObject (ssPrivileges session) principal database (T.pack name)
+        _ -> pure (Right ())
+    affected <- case statement of
+        DropTable name | database /= "system" -> affectedObject (ssPrivileges session) database (T.pack name)
+        DropDatabase name | name /= "system" -> affectedObject (ssPrivileges session) "" ("database:" <> T.pack name)
+        _ -> pure (Right [])
+    case prepared >> affected of
+        Left err -> pure (Left (privilegeErrorOf err))
+        Right names -> do
+            result <- runPreparedObject session statement sql
+            notifyChanged session names
+            pure result
+
+-- 执行已登记创建声明的对象变更。
+runPreparedObject :: Session -> Statement -> Text -> IO (Either SessionError QueryResult)
+runPreparedObject session statement sql = do
+    result <- runPlain session sql
+    case result of
+        Left err -> case statement of
+            CreateTable{} -> do
+                cleaned <- reconcileObjects (ssPrivileges session)
+                pure $ case cleaned of
+                    Left failure -> Left (SessionError "storage_error" (sessMessage err <> "; creator intent cleanup failed: " <> privilegeMessage failure))
+                    Right () -> Left err
+            _ -> pure (Left err)
+        Right value -> do
+            who <- readIORef (ssPrincipal session)
+            database <- readIORef (ssCurrent session)
+            maintained <- case (who, statement) of
+                (Just principal, CreateTable name _) | database /= "system" -> claimObject (ssPrivileges session) principal database (T.pack name)
+                (Just principal, CreateDatabase name) -> claimObject (ssPrivileges session) principal "" ("database:" <> T.pack name)
+                (_, DropTable{}) -> reconcileObjects (ssPrivileges session)
+                (_, DropDatabase{}) -> reconcileObjects (ssPrivileges session)
+                _ -> pure (Right ())
+            case maintained of
+                Right () -> pure (Right value)
+                Left err -> do
+                    cleanup <- case statement of
+                        CreateTable name _ -> runPlain session ("DROP TABLE " <> T.pack name)
+                        CreateDatabase name -> runPlain session ("DROP DATABASE " <> T.pack name)
+                        _ -> pure (Right value)
+                    pure $ case cleanup of
+                        Left failure -> Left (SessionError "storage_error" (privilegeMessage err <> "; object cleanup failed: " <> sessMessage failure))
+                        Right _ -> Left (privilegeErrorOf err)
+
 -- | 数据字典；普通身份只看到有 SELECT 权的表
 catalog :: Session -> IO (Either Text [TableInfo])
-catalog session = do
+catalog session = withReadSession session (catalogUnlocked session)
+
+-- 在权限共享门内读取可见表目录。
+catalogUnlocked :: Session -> IO (Either Text [TableInfo])
+catalogUnlocked session = do
     current <- readIORef (ssCurrent session)
     if T.null current
         then pure (Left "no database selected")
@@ -509,13 +695,31 @@ withAccountInfo session tables = do
 
 -- | 库清单（\l 用）
 databases :: Session -> IO (Either Text [Text])
-databases session = do
+databases session = withReadSession session $ do
     result <- beDatabases (ssBackend session)
-    pure (either (Left . T.pack) (Right . map T.pack) result)
+    who <- readIORef (ssPrincipal session)
+    case (result, who) of
+        (Left err, _) -> pure (Left (T.pack err))
+        (Right names, Just principal) | not (principalIsRoot principal) -> do
+            checks <- mapM (check principal . T.pack) names
+            pure $ case [err | Left err@(PrivilegeError code _) <- checks, code /= "forbidden"] of
+                err : _ -> Left (privilegeMessage err)
+                [] -> Right [T.pack name | (name, Right ()) <- zip names checks]
+        (Right names, _) -> pure (Right (map T.pack names))
+  where
+    -- 检查业务库连接或系统目录管理权限。
+    check principal "system" = pure (if principalIsCatalogManager principal then Right () else Left (PrivilegeError "forbidden" "system catalog manager required"))
+    check principal name = authorizeConnect (ssPrivileges session) principal name
+
+-- 在共享权限门内复核会话并读取接口。
+withReadSession :: Session -> IO (Either Text a) -> IO (Either Text a)
+withReadSession session action = readSecurity $ do
+    valid <- validatePrincipal session
+    case valid of Left err -> pure (Left (sessMessage err)); Right () -> action
 
 -- | 角色总览，只给管理员
 roleViews :: Session -> IO (Either Text [RoleView])
-roleViews session = do
+roleViews session = withReadSession session $ do
     admin <- sessionIsAdmin session
     if not admin
         then pure (Left "administrator required")
@@ -525,7 +729,7 @@ roleViews session = do
 
 -- | 账号清单（\du 与账号管理页用）；只给管理员
 accounts :: Session -> IO (Either Text [Account])
-accounts session = do
+accounts session = withReadSession session $ do
     admin <- sessionIsAdmin session
     if not admin
         then pure (Left "administrator required")
@@ -547,9 +751,9 @@ showIdentities session = 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", "created_at"]
+            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), VStr (T.unpack (accountRegisteredAt a))] | a <- identities]
+                    VBool (accountIsSuperuser a), VBool (accountEnabled a), VBool (accountSystemCatalogManager a), VBool (accountAllowSudoAuth a), VStr (T.unpack (accountRegisteredAt a))] | a <- identities]
                 (length identities) False Nothing)
 
 -- | 执行身份管理并通知受影响会话
@@ -562,13 +766,17 @@ runAccount session command = do
             affected <- case command of
                 AlterAccountAttributes name _ -> affectedAccounts (ssPrivileges session) (DropRoleCommand name)
                 DropAccount name -> affectedAccounts (ssPrivileges session) (DropRoleCommand name)
-                _ -> pure (accountCommandUsers command)
-            result <- runAccountCommand (ssAccounts session) principal command
-            case result of
-                Left err -> pure (Left (accountErrorOf err))
-                Right () -> do
-                    notifyChanged session affected
-                    pure (Right (emptyResult Nothing))
+                _ -> pure (Right (accountCommandUsers command))
+            case affected of
+                Left err -> pure (Left (privilegeErrorOf err))
+                Right names -> do
+                    result <- runAccountCommand (ssAccounts session) principal command
+                    case result of
+                        Left err -> pure (Left (accountErrorOf err))
+                        Right () -> do
+                            cleaned <- reconcileObjects (ssPrivileges session)
+                            notifyChanged session names
+                            pure (either (Left . privilegeErrorOf) (const (Right (emptyResult Nothing))) cleaned)
 
 -- | 一条账号命令影响的账号
 accountCommandUsers :: AccountCommand -> [Text]
@@ -588,12 +796,15 @@ runPrivilege session command = do
             database <- readIORef (ssCurrent session)
             -- 受影响账号要趁命令落地之前算：删角色之后成员就查不到了
             affected <- affectedAccounts (ssPrivileges session) command
-            result <- runPrivilegeCommand (ssPrivileges session) principal database command
-            case result of
+            case affected of
                 Left err -> pure (Left (privilegeErrorOf err))
-                Right () -> do
-                    notifyChanged session affected
-                    pure (Right (emptyResult Nothing))
+                Right names -> do
+                    result <- runPrivilegeCommand (ssPrivileges session) principal database command
+                    case result of
+                        Left err -> pure (Left (privilegeErrorOf err))
+                        Right () -> do
+                            notifyChanged session names
+                            pure (Right (emptyResult Nothing))
 
 -- | 通知变更：把受影响的账号交给会话的变更钩子
 notifyChanged :: Session -> [Text] -> IO ()

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

@@ -11,19 +11,24 @@ module ChuSQL.Server.TCP (
     ServerHandle (..),
     startServer,
     runServer,
+    isLocalPeer,
 ) where
 
 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.Server.Backend (Backend (..))
-import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), accounts, authenticateSessionCoded, catalog, databases, newSessionWith, policyOf, reloadPolicy, roleViews, runStatementCoded, sessionIsAdmin, sessionUser)
+import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), accounts, authenticateSessionCoded, authenticateSudoSessionCoded, isPlainIdentifier, catalog, databases, newSessionWith, policyOf, reloadPolicy, roleViews, runStatementCoded, runStorageCoded, sessionIsAdmin, sessionUser)
+import ChuSQL.Server.Security (writeSecurity)
+import ChuSQL.Server.Privileges (newPrivileges, reconcileObjects)
 import Control.Concurrent (forkIO)
 import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
-import Control.Exception (IOException, finally, try)
+import Control.Exception (IOException, bracket, finally, onException, try)
 import Control.Monad (filterM, void)
 import qualified Data.ByteString.Char8 as BSC
 import qualified Data.ByteString.Lazy.Char8 as BLC
@@ -48,6 +53,7 @@ import Network.Socket (
     defaultProtocol,
     getAddrInfo,
     getSocketName,
+    getPeerName,
     listen,
     setSocketOption,
     socket,
@@ -64,6 +70,8 @@ import System.IO.Error (isEOFError)
 data LiveEntry = LiveEntry
     { leWho :: IORef (Maybe Text)
     , leDropped :: IORef Bool
+    , leLocal :: Bool
+    , leChallenge :: IORef (Maybe (Text, UTCTime))
     }
 
 -- | 在线连接登记：自增编号到连接条目
@@ -77,8 +85,8 @@ newLiveConnections :: IO LiveConnections
 newLiveConnections = LiveConnections <$> newIORef 0 <*> newMVar Map.empty
 
 -- | 新建一条连接条目
-newLiveEntry :: IO LiveEntry
-newLiveEntry = LiveEntry <$> newIORef Nothing <*> newIORef False
+newLiveEntry :: Bool -> IO LiveEntry
+newLiveEntry local = LiveEntry <$> newIORef Nothing <*> newIORef False <*> pure local <*> newIORef Nothing
 
 -- | 登记一条连接，返回注销动作
 registerConnection :: LiveConnections -> LiveEntry -> IO (IO ())
@@ -112,6 +120,7 @@ data ServerEnv = ServerEnv
     , srvConfig :: ServerConfig
     , srvLimiter :: RateLimiter
     , srvLive :: LiveConnections
+    , srvSudo :: MVar (Maybe (Int, Text, SudoCredential))
     }
 
 -- | 组装服务器环境：每个连接再各开一个会话
@@ -124,7 +133,13 @@ newServerEnv backend rootName settingsFile config limiter = do
             | any (\a -> accountEnabled a && accountCanLogin a && accountIsSuperuser a) identities -> pure ()
             | otherwise -> ioError (userError "identity migration failed: no enabled login superuser; stop all processes and try csql-bootstrap recover --config <settings.toml>; reset replaces system identities and grants")
     live <- newLiveConnections
-    pure (ServerEnv backend rootName settingsFile config limiter live)
+    privileges <- newPrivileges backend
+    recovered <- writeSecurity (reconcileObjects privileges)
+    case recovered of
+        Left err -> ioError (userError ("object privilege recovery failed: " ++ show err))
+        Right () -> pure ()
+    sudo <- newMVar Nothing
+    pure (ServerEnv backend rootName settingsFile config limiter live sudo)
 
 data ServerHandle = ServerHandle
     { shPort :: Int
@@ -136,18 +151,42 @@ startServer :: ServerEnv -> IO ServerHandle
 startServer env = do
     sock <- listenSocket (scHost (srvConfig env)) (scPort (srvConfig env))
     port <- actualPort sock
+    enableSudo env port `onException` close sock
     stopped <- newMVar False
     _ <- forkIO (acceptLoop env sock stopped)
-    pure (ServerHandle port (stopListening sock stopped))
+    pure (ServerHandle port (stopListening sock stopped `finally` disableSudo env))
 
 -- | 在调用线程里收连接（可执行文件用）；绑好端口先回调一次
 runServer :: ServerEnv -> (Int -> IO ()) -> IO ()
-runServer env announce = do
-    sock <- listenSocket (scHost (srvConfig env)) (scPort (srvConfig env))
+runServer env announce = bracket (listenSocket (scHost (srvConfig env)) (scPort (srvConfig env))) close $ \sock -> do
     port <- actualPort sock
-    announce port
-    stopped <- newMVar False
-    acceptLoop env sock stopped
+    enableSudo env port
+    (do
+        announce port
+        stopped <- newMVar False
+        acceptLoop env sock stopped) `finally` disableSudo env
+
+-- 为显式配置的本机身份映射创建凭据。
+enableSudo :: ServerEnv -> Int -> IO ()
+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) $ \current -> case current of
+        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)
+
+-- 清理本次服务实例的本机认证凭据。
+disableSudo :: ServerEnv -> IO ()
+disableSudo env = modifyMVar_ (srvSudo env) $ \current -> do
+    case current of
+        Nothing -> pure ()
+        Just (port, _, _) -> removeSudoCredential port
+    pure Nothing
 
 -- | 置停止标记并关掉监听套接字
 stopListening :: Socket -> MVar Bool -> IO ()
@@ -209,10 +248,11 @@ reportConnection env conn = do
 -- | 一个连接一个会话：一行一条 JSON，读到 EOF 就收工
 serveConnection :: ServerEnv -> Socket -> IO ()
 serveConnection env conn = do
+    peer <- getPeerName conn
     h <- socketToHandle conn ReadWriteMode
     hSetBuffering h LineBuffering
     hSetNewlineMode h noNewlineTranslation
-    entry <- newLiveEntry
+    entry <- newLiveEntry (isLocalPeer peer)
     unregister <- registerConnection (srvLive env) entry
     session <- newSessionWith (srvBackend env) (srvRootName env) (srvSettingsFile env) (\names -> void (dropConnectionsOf (srvLive env) names))
     outcome <- try (loop h session entry `finally` unregister) :: IO (Either IOException ())
@@ -250,11 +290,25 @@ dispatch env session entry request = case request of
         | version == protocolVersion -> pure (RespHello protocolVersion, True)
         | otherwise -> pure (RespError "bad_request" ("unsupported protocol version: " <> tshow version), True)
     ReqLogin user password -> do
+        writeIORef (leChallenge entry) Nothing
         response <- login env session user password
         case response of
             RespLogin who _ -> writeIORef (leWho entry) (Just who)
             _ -> pure ()
         pure (response, True)
+    ReqSudoChallenge -> do
+        configured <- readMVar (srvSudo env)
+        who <- sessionUser session
+        case configured of
+            Just _ | leLocal entry && who == Nothing -> do
+                nonce <- sudoChallenge
+                now <- getCurrentTime
+                writeIORef (leChallenge entry) (Just (nonce, now))
+                pure (RespSudoChallenge nonce, True)
+            _ -> pure (RespError "forbidden" "local sudo authentication is unavailable", True)
+    ReqSudoLogin user proof -> do
+        response <- sudoLogin env session entry user proof
+        pure (response, True)
     ReqQuery sql -> do
         who <- sessionUser session
         response <- case who of
@@ -268,18 +322,10 @@ dispatch env session entry request = case request of
                         Right queryResult -> RespResult (trimResult (scMaxRows (srvConfig env)) queryResult)
         pure (response, True)
     ReqStorage payload -> do
-        who <- sessionUser session
-        response <- case who of
-            Nothing -> pure (RespError "unauthorized" "sign in first")
-            Just _ -> do
-                admin <- sessionIsAdmin session
-                if not admin
-                    then pure (RespError "forbidden" "administrator required")
-                    else do
-                        result <- beStorage (srvBackend env) payload
-                        pure $ case result of
-                            Left err -> RespError "storage_error" (T.pack err)
-                            Right value -> RespStorage value
+        result <- runStorageCoded session payload
+        let response = case result of
+                Left err -> RespError (sessCode err) (sessMessage err)
+                Right value -> RespStorage value
         pure (response, True)
     ReqCatalog -> do
         response <- overSession session (catalog session) RespCatalog
@@ -302,6 +348,45 @@ dispatch env session entry request = case request of
     ReqPing -> pure (RespPong, True)
     ReqQuit -> pure (RespBye, False)
 
+-- 消费一次性证明并登录本机映射账号。
+sudoLogin :: ServerEnv -> Session -> LiveEntry -> Text -> Text -> IO ServerResponse
+sudoLogin env session entry user proof = do
+    challenge <- atomicModifyIORef' (leChallenge entry) (\value -> (Nothing, value))
+    configured <- readMVar (srvSudo env)
+    now <- getCurrentTime
+    who <- sessionUser session
+    let key = T.toLower (T.strip user)
+        mapped = maybe "" (\(_, name, _) -> name) configured
+        valid = leLocal entry && who == Nothing && 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")
+        Nothing | not valid -> do
+            rateLimitRecord (srvLimiter env) key
+            pure (RespError "unauthorized" "sudo authentication refused")
+        Nothing -> do
+            result <- authenticateSudoSessionCoded session key
+            case result of
+                Left err -> do
+                    rateLimitRecord (srvLimiter env) key
+                    pure (RespError (sessCode err) (sessMessage err))
+                Right () -> do
+                    rateLimitClear (srvLimiter env) key
+                    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)
+    pure response
+  where
+    -- 提取不包含凭据的认证审计结果。
+    auditResult RespLogin{} = "accepted"
+    auditResult (RespError code _) = T.unpack code
+    auditResult _ = "refused"
+
 -- | 口令策略在线上只有两个数字：最短长度与至少几类字符
 policyResponse :: PasswordPolicy -> ServerResponse
 policyResponse (PasswordPolicy minLength classes) = RespPolicy minLength classes

chusql-server/test/Spec.hs

@@ -5,18 +5,22 @@ module Main (main) where
 
 import ChuSQL.Core.Engine.Storage.IPC (
     Account (..),
-    Request (ReqAccountReset, ReqAccountsList),
+    Request (ReqAccountCreate, ReqAccountReset, ReqAccountsList, ReqIdentityAlter),
     TableInfo (..),
     closeConnection,
     localStorageLink,
     setStorageLink,
  )
 import ChuSQL.Core.Engine.Syntax.AST (Statement)
+import Data.IORef (newIORef, readIORef, writeIORef)
 import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
 import ChuSQL.Core.Model (Database, Histogram (..), Row, Table (..), Value (..), pattern TInt, pattern TStr)
 import ChuSQL.Interface.Auth (hashPasswordWith)
 import ChuSQL.Interface.Protocol (ClientRequest (..), Grant (..), RoleView (..), ServerResponse (..), decodeRequest, 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.Server.Accounts (Principal (..), ensureRootAccount)
 import ChuSQL.Server.Backend (Backend (..), StatementResult (..), ipcBackend, memoryBackend)
 import ChuSQL.Server.Privileges (
@@ -25,24 +29,30 @@ import ChuSQL.Server.Privileges (
     Privileges,
     affectedAccounts,
     authorize,
+    authorizeConnect,
+    claimObject,
+    prepareObject,
     listRoleViews,
     newPrivileges,
     runPrivilegeCommand,
  )
-import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), newSession, runStatementCoded)
+import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), newSession, runStatementCoded, runStorageCoded, authenticateSessionCoded)
 import ChuSQL.Server.TCP (
     ServerConfig (..),
-    ServerEnv,
+    ServerEnv (..),
     ServerHandle (..),
     defaultServerConfig,
     loadServerConfigAt,
     newServerEnv,
     startServer,
+    isLocalPeer,
  )
 import Control.Concurrent (forkIO, threadDelay)
-import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
+import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, takeMVar)
+import System.Timeout (timeout)
 import Control.Exception (IOException, bracket, finally, try)
 import Control.Monad (void)
+import Data.List (sort)
 import Data.Aeson (decode)
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Key as K
@@ -54,9 +64,12 @@ import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Vector as V
-import Data.Time.Clock (getCurrentTime)
+import Data.Time.Clock (addUTCTime, getCurrentTime)
 import Network.Socket (
     AddrInfo (..),
+    SockAddr (..),
+    tupleToHostAddress,
+    tupleToHostAddress6,
     SocketType (Stream),
     addrAddress,
     addrFamily,
@@ -81,7 +94,6 @@ import System.IO (
     hSetNewlineMode,
     noNewlineTranslation,
  )
-import System.Timeout (timeout)
 import Test.Hspec hiding (after, before)
 
 -- TCP 服务器测试：协议编解码、配置读取与真连服务器的端到端用例。
@@ -93,9 +105,119 @@ main = hspec spec
 -- | 全部用例
 spec :: Spec
 spec = do
+    describe "sudo authentication" $ do
+        it "defaults to disabled and rejects unconfigured TCP authentication" $
+            withTcpServer defaultServerConfig $ \_ handle -> withConnection handle $ \client -> do
+                scSudoUser defaultServerConfig `shouldBe` ""
+                challenge <- tcpTalk client "{\"method\":\"sudo_challenge\"}"
+                at "code" challenge `shouldBe` A.String "forbidden"
+                denied <- tcpTalk client "{\"method\":\"sudo_login\",\"user\":\"admin\",\"proof\":\"fake\"}"
+                at "code" denied `shouldBe` A.String "unauthorized"
+        it "loads an explicit normalized local identity mapping" $ do
+            path <- tempSettingsPath "sudo-config"
+            writeFile path (unlines ["[server]", "sudo_auth_user = " ++ show ("Local_User" :: String)])
+            config <- loadServerConfigAt path `finally` removeIfExists path
+            scSudoUser config `shouldBe` "local_user"
+        it "supports the client challenge and login exchange" $
+            withTestSudo $ \_ handle credential -> 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
+        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
+        it "binds proofs to the instance, challenge, account and expiration" $ do
+            credential <- newSudoCredential
+            other <- newSudoCredential
+            now <- getCurrentTime
+            let proof = sudoProof credential "nonce" "local_user"
+            verifySudoProof credential "nonce" "LOCAL_USER" proof `shouldBe` True
+            verifySudoProof other "nonce" "local_user" proof `shouldBe` False
+            verifySudoProof credential "other" "local_user" proof `shouldBe` False
+            verifySudoProof credential "nonce" "admin" proof `shouldBe` False
+            validSudoChallenge credential now (Just ("nonce", addUTCTime (-61) now)) "local_user" proof `shouldBe` False
+            validSudoChallenge credential now (Just ("nonce", addUTCTime 1 now)) "local_user" proof `shouldBe` False
+            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)
+        it "logs in an ordinary mapped identity without elevating its privileges" $
+            withTestSudo $ \_ handle credential -> withConnection handle $ \client -> do
+                answer <- tcpSudo client credential "local_user"
+                at "status" answer `shouldBe` A.String "ok"
+                at "admin" answer `shouldBe` A.Bool False
+                denied <- tcpQuery client "create database forbidden"
+                at "code" denied `shouldBe` A.String "forbidden"
+        it "rejects a forged proof and consumes its challenge" $
+            withTestSudo $ \_ handle credential -> withConnection handle $ \client -> do
+                nonce <- tcpTalk client "{\"method\":\"sudo_challenge\"}"
+                denied <- tcpTalk client "{\"method\":\"sudo_login\",\"user\":\"local_user\",\"proof\":\"forged\"}"
+                at "code" denied `shouldBe` A.String "unauthorized"
+                replay <- tcpSudoProof client "local_user" (sudoProof credential (asText (at "challenge" nonce)) "local_user")
+                at "code" replay `shouldBe` A.String "unauthorized"
+        it "rejects proof reuse on another connection and account mapping" $
+            withTestSudo $ \_ handle credential -> withConnection handle $ \first -> withConnection handle $ \second -> do
+                nonce <- tcpTalk first "{\"method\":\"sudo_challenge\"}"
+                let proof = sudoProof credential (asText (at "challenge" nonce)) "local_user"
+                replay <- tcpSudoProof second "local_user" proof
+                at "code" replay `shouldBe` A.String "unauthorized"
+                mismatch <- tcpSudo first credential "admin"
+                at "code" mismatch `shouldBe` A.String "unauthorized"
+        it "revokes the attribute and drops existing sudo sessions" $
+            withTestSudo $ \_ handle credential -> withConnection handle $ \admin -> withConnection handle $ \client -> do
+                _ <- tcpLogin admin testRootName testRootPassword
+                _ <- tcpSudo client credential "local_user"
+                changed <- tcpQuery admin "alter user local_user noallow_sudo_auth"
+                at "status" changed `shouldBe` A.String "result"
+                expired <- tcpQuery client "select 1"
+                at "code" expired `shouldBe` A.String "unauthorized"
+                tcpClosed client
+                withConnection handle $ \fresh -> do
+                    denied <- tcpSudo fresh credential "local_user"
+                    at "code" denied `shouldBe` A.String "unauthorized"
+        it "rejects disabled and NOLOGIN identities" $
+            withTestSudo $ \_ handle credential -> withConnection handle $ \admin -> do
+                _ <- tcpLogin admin testRootName testRootPassword
+                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
+                _ <- tcpLogin admin testRootName testRootPassword
+                _ <- tcpQuery admin "create role sudo_role"
+                _ <- tcpQuery admin "alter role sudo_role allow_sudo_auth"
+                _ <- tcpQuery admin "grant sudo_role to local_user"
+                _ <- tcpQuery admin "alter user local_user noallow_sudo_auth"
+                withConnection handle $ \client -> do
+                    denied <- tcpSudo client credential "local_user"
+                    at "code" denied `shouldBe` A.String "unauthorized"
+        it "keeps password login independent of the sudo attribute" $
+            withTestSudo $ \_ handle _ -> withConnection handle $ \client -> do
+                denied <- tcpLogin client "local_user" ""
+                at "code" denied `shouldBe` A.String "unauthorized"
+                accepted <- tcpLogin client "local_user" "Local-Pass123!"
+                at "status" accepted `shouldBe` A.String "ok"
     tcpSpec
     tcpServerSpec
     privilegeSpec
+    objectPrivilegeSpec
     transactionSpec
     ipcConcurrencySpec
     identitySpec
@@ -118,7 +240,7 @@ identitySpec = describe "unified identities" $ do
             switched <- tcpQuery manager "use system"
             asText (at "status" switched) `shouldBe` "result"
             mapM_ (\sql -> tcpQuery manager sql >>= \reply -> asText (at "code" reply) `shouldBe` "forbidden")
-                ["alter user manager superuser", "alter user managed system_catalog_manager", "alter user admin identified by 'Another-Pass123!'", "create database 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
             _ <- tcpLogin admin "admin" "s3cret"
@@ -139,7 +261,7 @@ identitySpec = describe "unified identities" $ do
             other <- tcpQuery h "create role alice"
             asText (at "code" other) `shouldBe` "conflict"
             shown <- tcpQuery h "show roles"
-            map asText (items (at "columns" shown)) `shouldBe` ["id", "name", "can_login", "is_superuser", "enabled", "system_catalog_manager", "created_at"]
+            map asText (items (at "columns" shown)) `shouldBe` ["id", "name", "can_login", "is_superuser", "enabled", "system_catalog_manager", "allow_sudo_auth", "created_at"]
             asInt (at "rowCount" shown) `shouldBe` 3
             reader <- tcpQuery h "alter role reader login nologin"
             asText (at "code" reader) `shouldBe` "bad_request"
@@ -697,7 +819,7 @@ tcpServerSpec = do
 
 -- | 一个普通账号
 testAccount :: Account
-testAccount = Account 0 "alice" "" 0 "" Nothing True False True False
+testAccount = Account 0 "alice" "" 0 "" Nothing True False True False False
 
 -- | 权限用例传的当前库名
 testDatabase :: Text
@@ -707,7 +829,10 @@ testDatabase = T.pack testDatabaseName
 withPrivileges :: (Privileges -> Principal -> IO a) -> IO a
 withPrivileges body = do
     db <- newMVar testDb
-    service <- newPrivileges (memoryBackend testDatabaseName db)
+    let backend = memoryBackend testDatabaseName db
+    _ <- beAccounts backend (ReqAccountCreate "alice" "hash")
+    _ <- beAccounts backend (ReqAccountCreate "bob" "hash")
+    service <- newPrivileges backend
     body service (Root testRootName)
 
 -- | 解析一条 SQL，失败就丢掉用例
@@ -747,7 +872,7 @@ privilegeSpec = describe "server privileges" $ do
         views <- listRoleViews service
         fmap (concatMap (map grantPrivilege) . map roleGrants) views
             `shouldBe` Right ["select", "insert", "update", "delete"]
-        fmap (concatMap (map grantObject) . map roleGrants) views `shouldBe` Right (replicate 4 "*")
+        fmap (concatMap (map grantObject) . map roleGrants) views `shouldBe` Right (replicate 4 "test.*")
 
     it "revokes a privilege again" $ withPrivileges $ \service root -> do
         _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
@@ -919,12 +1044,12 @@ privilegeSpec = describe "server privileges" $ do
         _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "inner" ["reader"])
         _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
         directly <- affectedAccounts service (RevokeRoleCommand "inner" ["bob"])
-        directly `shouldMatchList` ["bob"]
+        fmap sort directly `shouldBe` Right ["bob"]
         granted <- affectedAccounts service (GrantRoleCommand "writer" ["inner"])
-        granted `shouldMatchList` ["inner", "reader", "alice"]
+        fmap sort granted `shouldBe` Right (sort ["inner", "reader", "alice"])
         dropped <- affectedAccounts service (DropRoleCommand "inner")
-        dropped `shouldMatchList` ["inner", "reader", "alice"]
-        affectedAccounts service (CreateRoleCommand "other") `shouldReturn` []
+        fmap sort dropped `shouldBe` Right (sort ["inner", "reader", "alice"])
+        affectedAccounts service (CreateRoleCommand "other") `shouldReturn` Right []
 
     it "keeps the role tables on the real storage" $ withIpcStorage $ do
         base <- ipcBackend
@@ -944,6 +1069,7 @@ privilegeSpec = describe "server privileges" $ do
 
     it "inherits a role on the real storage" $ withIpcStorage $ do
         base <- ipcBackend
+        seedPrivilegeObjects base
         service <- newPrivileges base
         _ <- runPrivilegeCommand service (Root testRootName) testDatabase (CreateRoleCommand "reader")
         _ <- runPrivilegeCommand service (Root testRootName) testDatabase (CreateRoleCommand "writer")
@@ -955,6 +1081,7 @@ privilegeSpec = describe "server privileges" $ do
 
     it "keeps a grant option on the real storage" $ withIpcStorage $ do
         base <- ipcBackend
+        seedPrivilegeObjects base
         service <- newPrivileges base
         _ <- runPrivilegeCommand service (Root testRootName) testDatabase (CreateRoleCommand "reader")
         _ <- runPrivilegeCommand service (Root testRootName) testDatabase (CreateRoleCommand "writer")
@@ -968,6 +1095,239 @@ privilegeSpec = describe "server privileges" $ do
         fmap (map roleGrants) after `shouldBe` Right [[Grant "reader" "select" "test.users" True], [Grant "writer" "select" "test.users" False]]
 
 -- 真存储夹具：一个用例一份数据目录，跑完关链路删干净
+-- 创建独立的对象授权内存夹具。
+withObjectPrivileges :: (Backend -> Privileges -> Principal -> IO ()) -> IO ()
+withObjectPrivileges body = do
+    db <- newMVar testDb
+    let backend = memoryBackend testDatabaseName db
+    mapM_ (\name -> beAccounts backend (ReqAccountCreate name "hash") >>= either (fail . show) (const (pure ()))) ["alice", "bob", "carol"]
+    service <- newPrivileges backend
+    body backend service (Root testRootName)
+
+-- 验证对象作用域、授权来源和外部入口。
+objectPrivilegeSpec :: Spec
+objectPrivilegeSpec = describe "stable object privileges" $ do
+    it "migrates old table grants once and ignores later legacy writes" $ withObjectPrivileges $ \backend service _ -> do
+        let system = beWithDatabase backend "system"
+        mustRun (beStatement system "CREATE TABLE __system_grants (role VARCHAR(64), privilege VARCHAR(16), object VARCHAR(128))")
+        mustRun (beStatement system "INSERT INTO __system_grants (role, privilege, object) VALUES ('alice', 'select', 'test.users')")
+        authorizeSql service (Ordinary testAccount) "SELECT * FROM users" `shouldReturn` Right ()
+        mustRun (beStatement system "INSERT INTO __system_grants (role, privilege, object) VALUES ('bob', 'select', 'test.users')")
+        authorizeSql service (Ordinary testAccount{accountUser = "bob"}) "SELECT * FROM users" `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
+    it "recovers a durable creator intent after table creation and cancels absent objects" $ withIpcStorage $ do
+        backend <- ipcBackend
+        seedPrivilegeObjects backend
+        service <- newPrivileges backend
+        prepareObject service (Ordinary testAccount) "test" "recovered_owned" `shouldReturn` Right ()
+        mustRun (beStatement (beWithDatabase backend "test") "CREATE TABLE recovered_owned (id INT)")
+        closeConnection
+        dir <- ipcDataDir
+        opened <- localStorageLink (Just (dir ++ ".toml"))
+        link <- either fail pure opened
+        setStorageLink link
+        fresh <- ipcBackend >>= newPrivileges
+        authorizeSql fresh (Ordinary testAccount) "SELECT * FROM recovered_owned" `shouldReturn` Right ()
+        prepareObject fresh (Ordinary testAccount) "test" "never_created" `shouldReturn` Right ()
+        authorizeSql fresh (Ordinary testAccount) "SELECT * FROM recovered_owned" `shouldReturn` Right ()
+        mustRun (beStatement (beWithDatabase backend "test") "CREATE TABLE never_created (id INT)")
+        authorizeSql fresh (Ordinary testAccount) "SELECT * FROM never_created" `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON never_created")
+    it "holds authorization through a concurrent query and orders revocation after it" $ withObjectPrivileges $ \backend service root -> do
+        runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" False) `shouldReturn` Right ()
+        _ <- beAccounts backend (ReqAccountCreate testRootName (testPasswordHash testRootPassword))
+        _ <- beAccounts backend (ReqIdentityAlter testRootName Nothing (Just True) Nothing Nothing Nothing)
+        _ <- beAccounts backend (ReqAccountReset "alice" (testPasswordHash "Alice-Secret-1234"))
+        started <- newEmptyMVar
+        release <- newEmptyMVar
+        finished <- newEmptyMVar
+        revoked <- newEmptyMVar
+        let slow = backend{beWithDatabase = \name -> (beWithDatabase backend name){beStatement = \sql -> do
+                if sql == "SELECT * FROM users" then putMVar started () >> takeMVar release else pure ()
+                beStatement (beWithDatabase backend name) sql}}
+        settings <- tempSettingsPath "permission-race"
+        reader <- newSession slow testRootName settings
+        admin <- newSession backend testRootName settings
+        authenticateSessionCoded reader "alice" "Alice-Secret-1234" `shouldReturn` Right ()
+        authenticateSessionCoded admin testRootName testRootPassword `shouldReturn` Right ()
+        _ <- mustSql reader "USE test"
+        _ <- mustSql admin "USE test"
+        _ <- forkIO (runStatementCoded reader "SELECT * FROM users" >>= putMVar finished)
+        takeMVar started
+        _ <- forkIO (runStatementCoded admin "REVOKE SELECT ON users FROM alice" >>= putMVar revoked)
+        blocked <- timeout 100000 (takeMVar revoked)
+        case blocked of Nothing -> pure (); Just _ -> expectationFailure "revocation raced past an authorized query"
+        putMVar release ()
+        takeMVar finished >>= either (expectationFailure . show) (const (pure ()))
+        takeMVar revoked >>= either (expectationFailure . show) (const (pure ()))
+        result <- runStatementCoded reader "SELECT * FROM users"
+        case result of Left err -> sessCode err `shouldBe` "forbidden"; Right _ -> expectationFailure "revoked privilege remained active"
+    it "requires existing objects and validates database privilege scope" $ withObjectPrivileges $ \_ service root -> do
+        runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "missing" "alice" False)
+            `shouldReturn` Left (PrivilegeError "not_found" "unknown table")
+        runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "database:test" "alice" False)
+            `shouldReturn` Left (PrivilegeError "bad_request" "invalid privilege for object scope")
+    it "applies PUBLIC CONNECT defaults and explicit inherited connections" $ withObjectPrivileges $ \_ service root -> do
+        authorizeConnect service (Ordinary testAccount) "test" `shouldReturn` Right ()
+        runPrivilegeCommand service root "" (RevokePrivilegesCommand ["connect"] "database:test" "public") `shouldReturn` Right ()
+        authorizeConnect service (Ordinary testAccount) "test" `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: CONNECT ON database:test")
+        runPrivilegeCommand service root "" (CreateRoleCommand "connector") `shouldReturn` Right ()
+        runPrivilegeCommand service root "" (GrantPrivilegesCommand ["connect"] "database:test" "connector" False) `shouldReturn` Right ()
+        runPrivilegeCommand service root "" (GrantRoleCommand "connector" ["alice"]) `shouldReturn` Right ()
+        authorizeConnect service (Ordinary testAccount) "test" `shouldReturn` Right ()
+        runPrivilegeCommand service root "" (GrantPrivilegesCommand ["connect"] "database:test" "public" False) `shouldReturn` Right ()
+    it "grants CREATE without granting existing table access" $ withObjectPrivileges $ \_ service root -> do
+        runPrivilegeCommand service root "" (GrantPrivilegesCommand ["create"] "database:test" "alice" False) `shouldReturn` Right ()
+        authorizeSql service (Ordinary testAccount) "CREATE TABLE owned (id INT)" `shouldReturn` Right ()
+        authorizeSql service (Ordinary testAccount) "SELECT * FROM users" `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
+    it "gives table owners management and delegation without giving database management" $ withObjectPrivileges $ \_ service root -> do
+        claimObject service (Ordinary testAccount) testDatabase "users" `shouldReturn` Right ()
+        authorizeSql service (Ordinary testAccount) "DROP TABLE users" `shouldReturn` Right ()
+        authorizeSql service (Ordinary testAccount) "INSERT INTO users (id) VALUES (10)" `shouldReturn` Right ()
+        runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" False) `shouldReturn` Right ()
+        authorizeSql service (Ordinary testAccount) "DROP DATABASE test" `shouldReturn` Left (PrivilegeError "forbidden" "object owner required")
+        runPrivilegeCommand service root testDatabase (RevokePrivilegesCommand ["select"] "users" "alice") `shouldReturn` Right ()
+        authorizeSql service (Ordinary testAccount) "SELECT * FROM users" `shouldReturn` Right ()
+    it "cascades multihop delegations after the source grant is revoked" $ withObjectPrivileges $ \_ service root -> do
+        runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" True) `shouldReturn` Right ()
+        runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" True) `shouldReturn` Right ()
+        let bob = Ordinary testAccount{accountUser = "bob"}
+        runPrivilegeCommand service bob testDatabase (GrantPrivilegesCommand ["select"] "users" "carol" False) `shouldReturn` Right ()
+        affectedAccounts service (RevokePrivilegesCommand ["select"] "users" "alice") `shouldReturn` Right ["alice", "bob", "carol"]
+        runPrivilegeCommand service root testDatabase (RevokePrivilegesCommand ["select"] "users" "alice") `shouldReturn` Right ()
+        authorizeSql service (Ordinary testAccount{accountUser = "carol"}) "SELECT * FROM users"
+            `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
+    it "keeps an independent source when another delegation chain is revoked" $ withObjectPrivileges $ \_ service root -> do
+        runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" True) `shouldReturn` Right ()
+        runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" False) `shouldReturn` Right ()
+        runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" False) `shouldReturn` Right ()
+        runPrivilegeCommand service root testDatabase (RevokePrivilegesCommand ["select"] "users" "alice") `shouldReturn` Right ()
+        authorizeSql service (Ordinary testAccount{accountUser = "bob"}) "SELECT * FROM users" `shouldReturn` Right ()
+    it "removes delegations whose grantor loses an inherited source" $ withObjectPrivileges $ \_ service root -> do
+        runPrivilegeCommand service root testDatabase (CreateRoleCommand "delegator") `shouldReturn` Right ()
+        runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "delegator" True) `shouldReturn` Right ()
+        runPrivilegeCommand service root testDatabase (GrantRoleCommand "delegator" ["alice"]) `shouldReturn` Right ()
+        runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" False) `shouldReturn` Right ()
+        runPrivilegeCommand service root testDatabase (RevokeRoleCommand "delegator" ["alice"]) `shouldReturn` Right ()
+        authorizeSql service (Ordinary testAccount{accountUser = "bob"}) "SELECT * FROM users" `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
+    it "does not preserve circular delegation after its last independent root is revoked" $ withObjectPrivileges $ \_ service root -> do
+        runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" True) `shouldReturn` Right ()
+        runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" True) `shouldReturn` Right ()
+        runPrivilegeCommand service (Ordinary testAccount{accountUser = "bob"}) testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" True) `shouldReturn` Right ()
+        runPrivilegeCommand service root testDatabase (RevokePrivilegesCommand ["select"] "users" "alice") `shouldReturn` Right ()
+        authorizeSql service (Ordinary testAccount{accountUser = "bob"}) "SELECT * FROM users" `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
+    it "never transfers a dropped table's grant to a same-name replacement" $ withObjectPrivileges $ \backend service root -> do
+        runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" False) `shouldReturn` Right ()
+        mustRun (beStatement backend "DROP TABLE users")
+        mustRun (beStatement backend "CREATE TABLE users (id INT)")
+        authorizeSql service (Ordinary testAccount) "SELECT * FROM users" `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
+    it "does not let disabled grantors keep downstream grants alive" $ withObjectPrivileges $ \backend service root -> do
+        runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" True) `shouldReturn` Right ()
+        runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" False) `shouldReturn` Right ()
+        changed <- beAccounts backend (ReqIdentityAlter "alice" Nothing Nothing (Just False) Nothing Nothing)
+        either expectationFailure (const (pure ())) changed
+        authorizeSql service (Ordinary testAccount{accountUser = "bob"}) "SELECT * FROM users" `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
+    it "preserves dormant direct grants and ownership across unrelated ACL writes" $ withObjectPrivileges $ \backend service root -> do
+        runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" False) `shouldReturn` Right ()
+        mustRun (beStatement backend "CREATE TABLE owned (id INT)")
+        claimObject service (Ordinary testAccount) testDatabase "owned" `shouldReturn` Right ()
+        changed <- beAccounts backend (ReqIdentityAlter "alice" Nothing Nothing (Just False) Nothing Nothing)
+        either expectationFailure (const (pure ())) changed
+        runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" False) `shouldReturn` Right ()
+        enabled <- beAccounts backend (ReqIdentityAlter "alice" Nothing Nothing (Just True) Nothing Nothing)
+        either expectationFailure (const (pure ())) enabled
+        authorizeSql service (Ordinary testAccount) "SELECT * FROM users" `shouldReturn` Right ()
+        authorizeSql service (Ordinary testAccount) "DROP TABLE owned" `shouldReturn` Right ()
+    it "keeps same-name tables in separate database scopes and persists the ACL" $ withIpcStorage $ do
+        backend <- ipcBackend
+        seedPrivilegeObjects backend
+        mustRun (beStatement backend "CREATE DATABASE other")
+        mustRun (beStatement (beWithDatabase backend "other") "CREATE TABLE users (id INT)")
+        service <- newPrivileges backend
+        runPrivilegeCommand service (Root testRootName) "test" (GrantPrivilegesCommand ["select"] "users" "alice" False) `shouldReturn` Right ()
+        statement <- parseOrFail "SELECT * FROM users"
+        authorize service (Ordinary testAccount) "other" statement `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
+        closeConnection
+        dir <- ipcDataDir
+        opened <- localStorageLink (Just (dir ++ ".toml"))
+        link <- either fail pure opened
+        setStorageLink link
+        fresh <- ipcBackend >>= newPrivileges
+        authorize fresh (Ordinary testAccount) "test" statement `shouldReturn` Right ()
+        authorize fresh (Ordinary testAccount) "other" statement `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
+    it "checks CONNECT and CREATE through TCP and assigns ownership to the creator" $
+        withTcpServer defaultServerConfig $ \_ handle -> withConnection handle $ \admin -> do
+            _ <- tcpLogin admin "admin" "s3cret"
+            _ <- tcpQuery admin "CREATE USER object_owner IDENTIFIED BY 'Owner-Secret-1234'"
+            tcpQuery admin "REVOKE CONNECT ON DATABASE test FROM PUBLIC" >>= \reply -> at "status" reply `shouldBe` A.String "result"
+            withConnection handle $ \client -> do
+                _ <- tcpLogin client "object_owner" "Owner-Secret-1234"
+                tcpQuery client "USE test" >>= \reply -> at "code" reply `shouldBe` A.String "forbidden"
+            _ <- tcpQuery admin "GRANT CONNECT, CREATE ON DATABASE test TO object_owner"
+            withConnection handle $ \client -> do
+                _ <- tcpLogin client "object_owner" "Owner-Secret-1234"
+                tcpQuery client "USE test" >>= \reply -> at "status" reply `shouldBe` A.String "result"
+                tcpQuery client "CREATE TABLE owned_probe (id INT)" >>= \reply -> at "status" reply `shouldBe` A.String "result"
+                tcpQuery client "INSERT INTO owned_probe (id) VALUES (1)" >>= \reply -> at "status" reply `shouldBe` A.String "result"
+                tcpQuery client "SELECT * FROM users" >>= \reply -> at "code" reply `shouldBe` A.String "forbidden"
+                tcpTalk client "{\"method\":\"storage\",\"request\":{\"method\":\"scan\",\"database\":\"test\",\"table\":\"users\"}}" >>= \reply -> at "code" reply `shouldBe` A.String "forbidden"
+    it "disconnects downstream TCP grantees and protects staged commits after revocation" $
+        withTcpServer defaultServerConfig $ \_ handle -> withConnection handle $ \admin -> do
+            _ <- tcpLogin admin "admin" "s3cret"
+            _ <- tcpQuery admin "USE test"
+            _ <- tcpQuery admin "CREATE USER source_user IDENTIFIED BY 'Source-Secret-1234'"
+            _ <- tcpQuery admin "CREATE USER target_user IDENTIFIED BY 'Target-Secret-1234'"
+            _ <- tcpQuery admin "GRANT SELECT, UPDATE ON users TO source_user WITH GRANT OPTION"
+            withConnection handle $ \source -> do
+                _ <- tcpLogin source "source_user" "Source-Secret-1234"
+                _ <- tcpQuery source "USE test"
+                _ <- tcpQuery source "GRANT SELECT, UPDATE ON users TO target_user"
+                withConnection handle $ \target -> do
+                    _ <- tcpLogin target "target_user" "Target-Secret-1234"
+                    _ <- tcpQuery target "USE test"
+                    _ <- tcpQuery target "BEGIN"
+                    _ <- tcpQuery target "UPDATE users SET age = 90 WHERE id = 1"
+                    _ <- tcpQuery admin "REVOKE UPDATE ON users FROM source_user"
+                    tcpQuery target "COMMIT" >>= \reply -> at "code" reply `shouldBe` A.String "unauthorized"
+                    tcpClosed target
+                    reply <- tcpQuery admin "SELECT age FROM users WHERE id = 1"
+                    map items (items (at "rows" reply)) `shouldBe` [[A.Number 21]]
+    it "rejects a stale local transaction after a granted object is replaced" $ withObjectPrivileges $ \backend service root -> do
+        runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["all"] "users" "alice" False) `shouldReturn` Right ()
+        _ <- beAccounts backend (ReqAccountReset "alice" (testPasswordHash "Alice-Secret-1234"))
+        settings <- tempSettingsPath "object-transaction"
+        _ <- beAccounts backend (ReqAccountCreate testRootName (testPasswordHash testRootPassword))
+        _ <- beAccounts backend (ReqIdentityAlter testRootName Nothing (Just True) Nothing Nothing Nothing)
+        session <- newSession backend testRootName settings
+        authenticateSessionCoded session "alice" "Alice-Secret-1234" `shouldReturn` Right ()
+        _ <- mustSql session "USE test"
+        _ <- mustSql session "BEGIN"
+        _ <- mustSql session "UPDATE users SET age = 90 WHERE id = 1"
+        mustRun (beStatement backend "DROP TABLE users")
+        mustRun (beStatement backend "CREATE TABLE users (id INT, name VARCHAR(32), age INT)")
+        result <- runStatementCoded session "COMMIT"
+        case result of Left err -> sessCode err `shouldBe` "forbidden"; Right _ -> expectationFailure "stale transaction committed"
+    it "checks the current administrator identity before executing a raw storage request" $ withObjectPrivileges $ \backend _ _ -> do
+        _ <- beAccounts backend (ReqAccountCreate testRootName (testPasswordHash testRootPassword))
+        _ <- beAccounts backend (ReqIdentityAlter testRootName Nothing (Just True) Nothing Nothing Nothing)
+        _ <- beAccounts backend (ReqAccountCreate "spare_admin" "hash")
+        _ <- beAccounts backend (ReqIdentityAlter "spare_admin" Nothing (Just True) Nothing Nothing Nothing)
+        executed <- newIORef False
+        let guarded = backend{beStorage = \_ -> writeIORef executed True >> pure (Right A.Null)}
+        settings <- tempSettingsPath "raw-storage-identity"
+        session <- newSession guarded testRootName settings
+        authenticateSessionCoded session testRootName testRootPassword `shouldReturn` Right ()
+        changed <- beAccounts backend (ReqIdentityAlter testRootName Nothing (Just False) Nothing Nothing Nothing)
+        either expectationFailure (const (pure ())) changed
+        result <- runStorageCoded session (A.object ["method" A..= ("ping" :: Text)])
+        case result of Left err -> sessCode err `shouldBe` "unauthorized"; Right _ -> expectationFailure "stale administrator executed storage request"
+        readIORef executed `shouldReturn` False
+
+-- 为权限测试创建真实对象和登录身份。
+seedPrivilegeObjects :: Backend -> IO ()
+seedPrivilegeObjects backend = do
+    mustRun (beStatement backend "CREATE DATABASE test")
+    mustRun (beStatement (beWithDatabase backend "test") "CREATE TABLE users (id INT)")
+    result <- beAccounts backend (ReqAccountCreate "alice" "hash")
+    case result of Left err -> expectationFailure err; Right _ -> pure ()
 
 -- | 本次用例的数据目录（用例串行跑，固定名够用）
 ipcDataDir :: IO FilePath
@@ -1058,6 +1418,27 @@ intValues rows = [n | row <- rows, Just (VInt n) <- [nth 0 row]]
 -- | 显式事务用例
 transactionSpec :: Spec
 transactionSpec = describe "server transactions" $ do
+    it "preserves concurrent changes in a large untouched table" $ withTwoSessions $ \first second -> do
+        _ <- mustSql first "CREATE TABLE untouched (id INT, value INT)"
+        let values = T.intercalate "," [T.pack ("(" ++ show key ++ ",0)") | key <- [1 .. 5000 :: Int]]
+        _ <- mustSql first ("INSERT INTO untouched (id,value) VALUES " <> values)
+        _ <- mustSql first "BEGIN"
+        _ <- mustSql first "UPDATE users SET age = 77 WHERE id = 1"
+        _ <- mustSql second "UPDATE untouched SET value = 9 WHERE id = 5000"
+        _ <- mustSql first "COMMIT"
+        sessionAge first 1 `shouldReturn` Just 77
+        result <- mustSql first "SELECT value FROM untouched WHERE id = 5000"
+        qrRows result `shouldBe` [[VInt 9]]
+
+    it "preserves staged row order for unsorted integer ids" $ withMemorySession $ \session -> do
+        _ <- mustSql session "CREATE TABLE keys (id INT, value INT)"
+        _ <- mustSql session "INSERT INTO keys (id,value) VALUES (7,0),(-3,0),(4,0)"
+        _ <- mustSql session "BEGIN"
+        _ <- mustSql session "UPDATE keys SET value = 1"
+        _ <- mustSql session "COMMIT"
+        result <- mustSql session "SELECT id FROM keys"
+        qrRows result `shouldBe` [[VInt 7], [VInt (-3)], [VInt 4]]
+
     it "filters qualified memory tables and preserves other databases on writes" $ do
         let local = Table "users" [("id", TInt)] [[("id", VInt 1)]] Nothing
             otherTable = Table "users" [("id", TInt)] [[("id", VInt 2)]] Nothing
@@ -1504,3 +1885,46 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
         intColumn "id" rows `shouldBe` [1]
         intColumn "age" rows `shouldBe` [31]
 
+
+-- 判断明确错误返回。
+isLeftResult :: Either a b -> Bool
+isLeftResult (Left _) = True
+isLeftResult _ = False
+
+-- 启动带独立本机认证凭据的测试会话。
+withTestSudo :: (ServerEnv -> ServerHandle -> SudoCredential -> IO a) -> IO a
+withTestSudo body = withTcpServer defaultServerConfig $ \env handle -> do
+    credential <- newSudoCredential
+    withConnection handle $ \admin -> do
+        _ <- tcpLogin admin testRootName testRootPassword
+        created <- tcpQuery admin "create user local_user identified by 'Local-Pass123!'"
+        at "status" created `shouldBe` A.String "result"
+        enabled <- tcpQuery admin "alter user local_user allow_sudo_auth"
+        at "status" enabled `shouldBe` A.String "result"
+    modifyMVar_ (srvSudo env) (const (pure (Just (0, "local_user", credential))))
+    body env handle credential `finally` modifyMVar_ (srvSudo env) (const (pure Nothing))
+
+-- 交换本机挑战并提交账号绑定证明。
+tcpSudo :: Handle -> SudoCredential -> Text -> IO A.Value
+tcpSudo client credential user = do
+    challenge <- tcpTalk client "{\"method\":\"sudo_challenge\"}"
+    tcpSudoProof client user (sudoProof credential (asText (at "challenge" challenge)) user)
+
+-- 发送本机认证证明。
+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])))
+
+-- 验证身份禁用或取消登录后拒绝本机认证。
+checkSudoDisabled :: Handle -> ServerHandle -> SudoCredential -> Text -> IO ()
+checkSudoDisabled admin handle credential sql = do
+    changed <- tcpQuery admin sql
+    at "status" changed `shouldBe` A.String "result"
+    withConnection handle $ \client -> do
+        denied <- tcpSudo client credential "local_user"
+        at "code" denied `shouldBe` A.String "unauthorized"
+
+-- 判断明确成功返回。
+isRightResult :: Either a b -> Bool
+isRightResult (Right _) = True
+isRightResult _ = False