准备可扩展类型系统工作，更合理的JOIN查询优化算法，并行查询

chusql-server/app/Main.hs

@@ -4,18 +4,17 @@ module Main (main) where
 
 import ChuSQL.Core.Engine.Storage.FFI (storageVersion)
 import ChuSQL.Core.Engine.Storage.IPC (closeConnection, localStorageLink, setStorageLink)
-import ChuSQL.Interface.Auth (Credential (..))
 import ChuSQL.Interface.Config (
     WebConfig (..),
-    defaultPassword,
     defaultUser,
+    legacyPasswordKey,
     loadWebConfigAt,
-    resolveCredential,
-    usingDefaultCredentials,
+    rootUserName,
  )
 import ChuSQL.Interface.RateLimit (newRateLimiter)
 import ChuSQL.Interface.Settings (readSettingsFile)
 import ChuSQL.Interface.TOML (resolveConfigPath)
+import ChuSQL.Server.Accounts (administratorPasswordless)
 import ChuSQL.Server.Backend (Backend (..), ipcBackend)
 import ChuSQL.Server.TCP (
     ServerConfig (..),
@@ -25,10 +24,12 @@ import ChuSQL.Server.TCP (
     runServer,
  )
 import Control.Exception (IOException, bracket, try)
-import qualified Data.Map.Strict as Map
+import qualified Data.Aeson as A
+import qualified Data.Aeson.KeyMap as KM
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
+import GHC.Conc (getNumProcessors, setNumCapabilities)
 import System.Environment (getArgs)
 import System.Exit (exitFailure)
 import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout)
@@ -88,7 +89,7 @@ usage = do
     putStrLn "        Windows: %APPDATA%\\ChuSQL\\chusql.toml"
     putStrLn "        other:   $XDG_CONFIG_HOME/ChuSQL/chusql.toml (or ~/.config/ChuSQL/chusql.toml)"
     putStrLn "        [storage] data_dir; [server] host/port/max_message/max_rows;"
-    putStrLn "        [web] user/password (administrator credentials)"
+    putStrLn "        [web] user (administrator name; the password lives in the system table)"
     putStrLn ""
     putStrLn "  --config FILE          read that config file instead"
     putStrLn "  --host H               listen address              ([server] host, default 127.0.0.1)"
@@ -103,9 +104,11 @@ usage = do
     putStrLn ""
     putStrLn "storage: this process loads the chusql_core_storage library in-process and owns the data directory"
     putStrLn ""
-    putStrLn "administrator password: user / password in the [web] section of chusql.toml, else the built-in demo"
-    putStrLn "  an empty password means the administrator signs in with no password; ordinary accounts are then refused"
-    putStrLn ("without either the demo administrator is " ++ T.unpack defaultUser ++ " / " ++ T.unpack defaultPassword)
+    putStrLn "administrator password: lives in the __system_users system table, never in chusql.toml"
+    putStrLn ("  the [web] user key only picks the administrator name (default " ++ T.unpack defaultUser ++ ")")
+    putStrLn ""
+    putStrLn "first run: the installer calls csql-bootstrap, which creates the system catalog"
+    putStrLn "  {\"method\":\"system_status\"} tells whether that happened; without it the server stops"
 
 -- | 命令行覆盖管理员
 applyWebOptions :: WebConfig -> Options -> WebConfig
@@ -129,9 +132,11 @@ orElse :: Maybe a -> a -> a
 orElse (Just x) _ = x
 orElse Nothing y = y
 
--- | 入口
+-- | 入口：开够能力数，分片扫描才真并行
 main :: IO ()
 main = do
+    caps <- getNumProcessors
+    setNumCapabilities (max 1 (min 8 caps))
     hSetBuffering stdout LineBuffering
     args <- getArgs
     case parseArgs args of
@@ -150,7 +155,8 @@ run opts = do
     base <- loadWebConfigAt configPath
     let cfg = applyWebOptions base opts
     saved <- readSettingsFile configPath
-    cred <- resolveCredential cfg saved
+    legacy <- legacyPasswordKey configPath
+    let rootName = rootUserName cfg saved
     config <- applyServerOptions <$> loadServerConfigAt configPath <*> pure opts
     opened <- localStorageLink (Just configPath)
     case opened of
@@ -162,13 +168,14 @@ run opts = do
             backend <- ipcBackend
             printBanner cfg config configPath
             checkStorage backend
-            reportCredential cred saved
+            checkInitialized backend
+            reportCredential backend rootName legacy
             limiter <-
                 newRateLimiter
                     getCurrentTime
                     (wcLoginMaxAttempts cfg)
                     (fromIntegral (wcLoginWindow cfg))
-            env <- newServerEnv backend cred configPath config limiter
+            env <- newServerEnv backend rootName configPath config limiter
             let announce port = putStrLn ("listening:    tcp://" ++ scHost config ++ ":" ++ show port)
             bracket (pure link) (const closeConnection) (const (serve env announce))
 
@@ -183,18 +190,37 @@ serve env announce = do
             putStrLn "  the port is probably taken or reserved by the system; try another one: --port 7777"
             exitFailure
 
--- | 报告口令来源，用内置默认口令时告警
-reportCredential :: Credential -> Map.Map Text Text -> IO ()
-reportCredential cred saved
-    | usingDefaultCredentials saved = do
-        putStrLn ""
-        putStrLn "  !! Administrator credentials are not configured; the built-in demo password is in use:"
-        putStrLn ("  !!   user " ++ T.unpack (credUser cred) ++ " / password " ++ T.unpack defaultPassword)
-        putStrLn "  !!   set user / password in the [web] section of chusql.toml and restart"
-        putStrLn ""
-    | T.null (credEncoded cred) =
-        putStrLn ("administrator: " ++ T.unpack (credUser cred) ++ " (passwordless: only the administrator may sign in)")
-    | otherwise = putStrLn ("administrator: " ++ T.unpack (credUser cred) ++ " (credentials come from the settings file only)")
+-- | 系统目录没引导过就不许起服务
+checkInitialized :: Backend -> IO ()
+checkInitialized backend = do
+    status <- beStorage backend (A.object ["method" A..= ("system_status" :: Text)])
+    case status of
+        Right value
+            | statusInitialized value -> putStrLn "system:       ready (the catalog is initialized)"
+        _ -> do
+            putStrLn "!! the system catalog is not initialized; run the bootstrap program first:"
+            putStrLn "!!   csql-bootstrap --config <chusql.toml> --password-stdin"
+            exitFailure
+  where
+    -- | 应答里的 initialized 是不是 true
+    statusInitialized (A.Object fields) = KM.lookup "initialized" fields == Just (A.Bool True)
+    statusInitialized _ = False
+
+-- | 报告管理员账号状态：配置里还留着明文口令、或还没设口令都提醒
+reportCredential :: Backend -> Text -> Bool -> IO ()
+reportCredential backend rootName legacy = do
+    putStrLn ("administrator: " ++ T.unpack rootName)
+    if legacy
+        then do
+            putStrLn "  !! the [web] section still carries a plaintext password key; it is ignored now"
+            putStrLn "  !! remove it: the administrator password lives in the __system_users system table"
+        else pure ()
+    passwordless <- administratorPasswordless backend rootName
+    if passwordless
+        then do
+            putStrLn "  !! the administrator has no password yet: sign in with an empty password, then set one"
+            putStrLn "  !!   ALTER USER root IDENTIFIED BY '...'   (or use the account page in the Web UI)"
+        else pure ()
 
 -- | 探测存储是否可用，答不上 ping 就退出
 checkStorage :: Backend -> IO ()

chusql-server/chusql-server.cabal

@@ -13,6 +13,7 @@ library
     hs-source-dirs:   src
     exposed-modules:  ChuSQL.Server.Accounts
                       ChuSQL.Server.Backend
+                      ChuSQL.Server.Catalog
                       ChuSQL.Server.Policy
                       ChuSQL.Server.Privileges
                       ChuSQL.Server.Session
@@ -40,6 +41,7 @@ executable chusql-server
     main-is:          Main.hs
     hs-source-dirs:   app
     build-depends:    base
+                    , aeson
                     , chusql-core-engine
                     , chusql-core-model
                     , chusql-interface

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

@@ -3,11 +3,12 @@
 module ChuSQL.Server.Accounts (
     Accounts, AccountError (..), Principal (..), PasswordPolicy (..), defaultPasswordPolicy,
     newAccounts, accountsPolicy, setAccountsPolicy, passwordAllowed,
-    rootUserName, principalName, principalIsRoot,
+    ensureRootAccount, administratorPasswordless, rootUserName, principalName, principalIsRoot,
     authenticate, currentPrincipal,
     listAccounts, findAccount, AccountCommand (..), accountCommand, runAccountCommand,
 ) where
 
+import ChuSQL.Core.Engine.Error (accountErrorCode)
 import ChuSQL.Core.Engine.Storage.IPC (Account (..), Request (..))
 import ChuSQL.Core.Engine.Syntax.AST (Statement (..))
 import ChuSQL.Interface.Auth
@@ -19,11 +20,11 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.Text (Text)
 import qualified Data.Text as T
 
--- 账号服务：root 来自配置，普通账号由 root 用 CREATE/ALTER/DROP USER 管理，口令在此校验并派生哈希。
+-- 账号服务：管理员是系统表里名字固定的那一行，口令哈希存在表里，普通账号由管理员用 CREATE/ALTER/DROP USER 管理。
 
 data AccountError = AccountError Text Text deriving (Show, Eq)
 
--- | 当前身份：配置里的管理员，或系统表里的一个普通账号
+-- | 当前身份：名字固定的管理员，或系统表里的一个普通账号
 data Principal
     = Root Text
     | Ordinary Account
@@ -39,7 +40,7 @@ principalName :: Principal -> Text
 principalName (Root name) = name
 principalName (Ordinary a) = accountUser a
 
--- | 是不是配置里的管理员
+-- | 是不是名字固定的管理员
 principalIsRoot :: Principal -> Bool
 principalIsRoot (Root _) = True
 principalIsRoot (Ordinary _) = False
@@ -49,23 +50,23 @@ data Accounts = Accounts
     , acSessions :: SessionStore
     , acLock :: MVar ()
     , acPolicy :: IORef PasswordPolicy
-    , acRoot :: Credential
+    , acRootName :: Text
     }
 
--- | 建账号服务，记录配置根账号
-newAccounts :: Backend -> SessionStore -> Credential -> IO Accounts
-newAccounts backend sessions credential = do
+-- | 建账号服务，记下管理员名字
+newAccounts :: Backend -> SessionStore -> Text -> IO Accounts
+newAccounts backend sessions name = do
     lock <- newMVar ()
     policy <- newIORef defaultPasswordPolicy
-    pure (Accounts backend sessions lock policy credential)
+    pure (Accounts backend sessions lock policy (normalize name))
 
 -- | 账号名统一小写去空白
 normalize :: Text -> Text
 normalize = T.toLower . T.strip
 
--- | 配置里的管理员叫什么
+-- | 管理员叫什么
 rootName :: Accounts -> Text
-rootName = normalize . credUser . acRoot
+rootName = acRootName
 
 -- | 管理员名字（界面显示用）
 rootUserName :: Accounts -> Text
@@ -123,16 +124,42 @@ storageFailure = AccountError "storage_error" "account storage unavailable"
 unauthorized :: AccountError
 unauthorized = AccountError "unauthorized" "invalid account or session"
 
--- | 存储侧报错翻成账号错误
+-- | 存储侧报错翻成账号错误，码统一由引擎错误表给出
 storageResult :: Either String [Account] -> Either AccountError ()
 storageResult (Right _) = Right ()
-storageResult (Left "account already exists") = Left (AccountError "conflict" "account already exists")
-storageResult (Left "unknown account") = Left (AccountError "not_found" "unknown account")
-storageResult (Left _) = Left storageFailure
+storageResult (Left message) = Left (AccountError code text)
+  where
+    -- | 认得的码原样用，其余存储细节不外泄
+    code = T.pack (accountErrorCode message)
+    text = if code == failureCode then failureText else T.pack message
+    AccountError failureCode failureText = storageFailure
 
--- | 读系统表里的普通账号
-readAccounts :: Accounts -> IO (Either AccountError [Account])
-readAccounts service = fmap (either (const (Left storageFailure)) Right) (beAccounts (acBackend service) ReqAccountsList)
+-- | 读系统表里的账号
+readAccounts :: Backend -> IO (Either AccountError [Account])
+readAccounts backend = fmap (either (const (Left storageFailure)) Right) (beAccounts backend ReqAccountsList)
+
+-- | 表里没有管理员那一行就补一行空哈希，表示还没设口令
+ensureRootAccount :: Backend -> Text -> IO (Either AccountError ())
+ensureRootAccount backend name = do
+    stored <- readAccounts backend
+    case stored of
+        Left err -> pure (Left err)
+        Right accounts
+            | any ((== normalize name) . accountUser) accounts -> pure (Right ())
+            | otherwise -> do
+                created <- beAccounts backend (ReqAccountCreate (normalize name) "")
+                pure $ case created of
+                    Right _ -> Right ()
+                    Left "account already exists" -> Right ()
+                    Left _ -> Left storageFailure
+
+-- | 管理员是不是还没设口令
+administratorPasswordless :: Backend -> Text -> IO Bool
+administratorPasswordless backend name = do
+    stored <- readAccounts backend
+    pure $ case stored of
+        Right accounts -> any (\a -> accountUser a == normalize name && T.null (accountHash a)) accounts
+        Left _ -> False
 
 -- | 按令牌解析当前身份，版本对不上即失效
 currentUnlocked :: Accounts -> Text -> IO (Either AccountError Principal)
@@ -140,66 +167,63 @@ currentUnlocked service token = do
     session <- lookupVersionedSession (acSessions service) token
     case session of
         Nothing -> pure (Left unauthorized)
-        Just (user, revision)
-            | user == rootName service && revision == Nothing -> pure (Right (Root (rootName service)))
-            | otherwise -> do
-                stored <- readAccounts service
-                pure $ do
-                    accounts <- stored
-                    account <- case filter ((== user) . accountUser) accounts of
-                        [a] -> Right a
-                        _ -> Left unauthorized
-                    if revision == Just (accountRevision account)
-                        then Right (Ordinary account)
-                        else Left unauthorized
+        Just (user, revision) -> do
+            stored <- readAccounts (acBackend service)
+            pure $ do
+                accounts <- stored
+                account <- case filter ((== user) . accountUser) accounts of
+                    [a] -> Right a
+                    _ -> Left unauthorized
+                if revision == Just (accountRevision account)
+                    then Right (if user == rootName service then Root user else Ordinary account)
+                    else Left unauthorized
 
 -- | 加锁解析当前身份
 currentPrincipal :: Accounts -> Text -> IO (Either AccountError Principal)
 currentPrincipal service token = withMVar (acLock service) $ \_ -> currentUnlocked service token
 
--- | 登录：先比 root，再查普通账号；空口令即免密
+-- | 登录：比哈希，管理员未设口令时只收空口令
 authenticate :: Accounts -> Text -> Text -> IO (Either AccountError Text)
-authenticate service user password = withMVar (acLock service) $ \_ ->
-    if normalize user == rootName service
-        then signInRoot
-        else
-            if passwordless
-                then pure (Left (AccountError "forbidden" "this server only accepts the administrator"))
-                else signInOrdinary
+authenticate service user password = withMVar (acLock service) $ \_ -> do
+    stored <- readAccounts (acBackend service)
+    case stored of
+        Left err -> pure (Left err)
+        Right accounts
+            | name == rootName service -> signInRoot accounts
+            | unset accounts -> pure (Left ordinaryRefused)
+            | otherwise -> signInOrdinary accounts
   where
-    -- | 配置里没有口令
-    passwordless = T.null (credEncoded (acRoot service))
+    name = normalize user
+    ordinaryRefused = AccountError "forbidden" "this server only accepts the administrator"
+    -- | 管理员那一行还没设口令（或压根不在表里）
+    unset accounts = case filter ((== rootName service) . accountUser) accounts of
+        [a] -> T.null (accountHash a)
+        _ -> True
     -- | 管理员登录
-    signInRoot
-        | passwordless =
-            if T.null password
-                then Right <$> createVersionedSession (acSessions service) (rootName service) Nothing
-                else pure (Left unauthorized)
-        | verifyPassword (credEncoded (acRoot service)) password =
-            Right <$> createVersionedSession (acSessions service) (rootName service) Nothing
-        | otherwise = pure (Left unauthorized)
+    signInRoot accounts = case filter ((== rootName service) . accountUser) accounts of
+        [a] | T.null (accountHash a) && T.null password -> issue a
+        [a] | not (T.null (accountHash a)) && verifyPassword (accountHash a) password -> issue a
+        _ -> pure (Left unauthorized)
     -- | 普通账号登录
-    signInOrdinary = do
-        stored <- readAccounts service
-        case stored of
-            Left err -> pure (Left err)
-            Right accounts -> case filter ((== normalize user) . accountUser) accounts of
-                [a] | verifyPassword (accountHash a) password -> 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)
+    signInOrdinary accounts = case filter ((== name) . accountUser) accounts of
+        [a] | not (T.null (accountHash a)) && verifyPassword (accountHash a) password -> issue a
+        _ -> pure (Left unauthorized)
+    -- | 记一次登录再发会话
+    issue a = do
+        stamp <- currentStamp
+        written <- beAccounts (acBackend service) (ReqAccountLogin (accountUser a) (Just stamp))
+        case written of
+            Left _ -> pure (Left storageFailure)
+            Right _ -> Right <$> createVersionedSession (acSessions service) (accountUser a) (Just (accountRevision a))
 
--- | 系统表里的普通账号清单（root 专用）
+-- | 系统表里的账号清单（含管理员）
 listAccounts :: Accounts -> IO (Either AccountError [Account])
-listAccounts service = withMVar (acLock service) $ \_ -> readAccounts service
+listAccounts service = withMVar (acLock service) $ \_ -> readAccounts (acBackend service)
 
--- | 按用户名找一个普通账号
+-- | 按用户名找一个账号
 findAccount :: Accounts -> Text -> IO (Either AccountError Account)
 findAccount service name = withMVar (acLock service) $ \_ -> do
-    stored <- readAccounts service
+    stored <- readAccounts (acBackend service)
     pure $ do
         accounts <- stored
         case filter ((== normalize name) . accountUser) accounts of
@@ -217,22 +241,26 @@ createUser service name password = withMVar (acLock service) $ \_ -> do
             encoded <- hashPassword password
             storageResult <$> beAccounts (acBackend service) (ReqAccountCreate (normalize name) encoded)
 
--- | 管理员重置普通账号口令
+-- | 设账号口令；管理员不受口令策略约束，空口令即免密
 resetPassword :: Accounts -> Text -> Text -> IO (Either AccountError ())
 resetPassword service name password = withMVar (acLock service) $ \_ -> do
     policy <- accountsPolicy service
-    case validateNewName service name >> passwordAllowed policy password of
+    let admin = normalize name == rootName service
+        checked = if admin then validateUserName name else validateNewName service name >> passwordAllowed policy password
+    case checked of
         Left err -> pure (Left err)
         Right () -> do
-            encoded <- hashPassword password
+            encoded <- if admin && T.null password then pure "" else hashPassword password
             storageResult <$> beAccounts (acBackend service) (ReqAccountReset (normalize name) encoded)
 
 -- | 删一个普通账号
 dropUser :: Accounts -> Text -> IO (Either AccountError ())
 dropUser service name = withMVar (acLock service) $ \_ ->
-    case validateUserName name of
-        Left err -> pure (Left err)
-        Right () -> storageResult <$> beAccounts (acBackend service) (ReqAccountDrop (normalize name))
+    if normalize name == rootName service
+        then pure (Left (AccountError "bad_request" "the administrator cannot be dropped"))
+        else case validateUserName name of
+            Left err -> pure (Left err)
+            Right () -> storageResult <$> beAccounts (acBackend service) (ReqAccountDrop (normalize name))
 
 -- | 账号管理命令：SQL 语句与一键接口在这上面汇合
 data AccountCommand

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

@@ -158,7 +158,7 @@ memoryBackendWith trusted name ref =
             modifyMVar ref $ \db -> case memoryAccounts db stamp req of
                 Left err -> pure (db, Left err)
                 Right accounts -> pure ((usersTable, Table usersTable [("account", TStr)]
-                    [[("account", VStr (BL.unpack (A.encode a))) ] | a <- accounts]) : filter ((/= usersTable) . fst) db, Right accounts)
+                    [[("account", VStr (BL.unpack (A.encode a))) ] | a <- accounts] Nothing) : filter ((/= usersTable) . fst) db, Right accounts)
         , beWithDatabase = withDatabase
         , beDatabases = pure (Right (nub [name, systemDatabaseName]))
         , beStorage = \_ -> pure (Left "storage is not available in this backend")
@@ -367,7 +367,7 @@ systemDatabaseName :: String
 systemDatabaseName = "system"
 
 usersTable :: String
-usersTable = "__chusql_users"
+usersTable = "__system_users"
 
 -- | 角色与授权表的名字，不带内部前缀
 rolesTable :: String
@@ -384,7 +384,7 @@ internalNames = [rolesTable, grantsTable, membersTable]
 
 -- | 名字是否带内部表前缀
 reserved :: String -> Bool
-reserved = T.isPrefixOf "__chusql_" . T.toLower . T.pack
+reserved = T.isPrefixOf "__system_" . T.toLower . T.pack
 
 -- | 是不是服务自己的内部表
 internalTable :: String -> Bool

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

@@ -0,0 +1,189 @@
+module ChuSQL.Server.Catalog
+    ( Catalog
+    , newCatalog
+    , normalizeRole
+    , normalizeUser
+    , normalizeObject
+    , withCatalog
+    , withCatalogLock
+    , ensureCatalog
+    , eachAction
+    , readRoleNames
+    , insertRole
+    , dropRole
+    , readGrants
+    , addGrant
+    , removeGrant
+    , readMembers
+    , addMember
+    , removeMember
+    ) where
+
+import ChuSQL.Core.Model (Row, Value (..))
+import ChuSQL.Interface.Actions (sqlLiteral)
+import ChuSQL.Interface.Protocol (Grant (..))
+import ChuSQL.Server.Backend (Backend (..), StatementResult (..), grantsTable, membersTable, rolesTable)
+import Control.Concurrent.MVar (MVar, newMVar, withMVar)
+import Data.List (intercalate, isInfixOf)
+import Data.Text (Text)
+import qualified Data.Text as T
+
+-- 内部目录（系统表）的唯一访问入口，调用方不拼 SQL
+
+-- | 三张系统表的读写都在这里，外面只认下面这些操作
+data Catalog = Catalog
+    { catBackend :: Backend
+    , catLock :: MVar ()
+    }
+
+-- | 建一个目录句柄
+newCatalog :: Backend -> IO Catalog
+newCatalog backend = Catalog backend <$> newMVar ()
+
+-- | 角色名统一小写去空白
+normalizeRole :: Text -> Text
+normalizeRole = T.toLower . T.strip
+
+-- | 用户名统一小写去空白
+normalizeUser :: Text -> Text
+normalizeUser = T.toLower . T.strip
+
+-- | 授权对象落库口径：`*` 原样，裸表名按当前库补全
+normalizeObject :: Text -> Text -> Text
+normalizeObject database object
+    | T.strip object == T.pack "*" = T.pack "*"
+    | T.any (== '.') object = T.toLower (T.strip object)
+    | otherwise = normalizeUser database <> T.pack "." <> normalizeUser object
+
+-- | 加锁跑一段目录动作
+withCatalogLock :: Catalog -> IO a -> IO a
+withCatalogLock catalog action = withMVar (catLock catalog) (const action)
+
+-- | 建表后跑一段目录动作
+withCatalog :: Catalog -> IO (Either String a) -> IO (Either String a)
+withCatalog catalog action = withCatalogLock catalog $ do
+    ready <- ensureCatalog catalog
+    case ready of
+        Left err -> pure (Left err)
+        Right () -> action
+
+-- | 确保三张系统表存在，已存在算成功
+ensureCatalog :: Catalog -> IO (Either String ())
+ensureCatalog catalog = eachAction tableDefs (createTable catalog)
+  where
+    -- | 三张系统表的定义
+    tableDefs =
+        [ (rolesTable, "(name VARCHAR(64))")
+        , (grantsTable, "(role VARCHAR(64), privilege VARCHAR(16), object VARCHAR(128))")
+        , (membersTable, "(role VARCHAR(64), member VARCHAR(64))")
+        ]
+
+-- | 建一张系统表，已存在算成功
+createTable :: Catalog -> (String, String) -> IO (Either String ())
+createTable catalog (table, columns) = do
+    result <- beStatement (catBackend catalog) ("CREATE TABLE " ++ table ++ " " ++ columns)
+    pure $ case result of
+        Right _ -> Right ()
+        Left err
+            | "exists" `isInfixOf` err -> Right ()
+            | otherwise -> Left err
+
+-- | 跑一条系统表写语句
+exec :: Catalog -> String -> IO (Either String ())
+exec catalog sql = fmap (either Left (const (Right ()))) (beStatement (catBackend catalog) sql)
+
+-- | 读一张系统表
+readRows :: Catalog -> String -> IO (Either String [Row])
+readRows catalog table = fmap (fmap srRows) (beStatement (catBackend catalog) ("SELECT * FROM " ++ table))
+
+-- | 角色名清单
+readRoleNames :: Catalog -> IO (Either String [Text])
+readRoleNames catalog = fmap (fmap (map (normalizeRole . cell "name"))) (readRows catalog rolesTable)
+
+-- | 新建一个角色
+insertRole :: Catalog -> Text -> IO (Either String ())
+insertRole catalog role = exec catalog (insertSql rolesTable ["name"] [normalizeRole role])
+
+-- | 删掉一个角色，连同它的授权与成员
+dropRole :: Catalog -> Text -> IO (Either String ())
+dropRole catalog role = do
+    first <- exec catalog ("DELETE FROM " ++ rolesTable ++ " WHERE name = " ++ roleLiteral role)
+    second <- exec catalog ("DELETE FROM " ++ grantsTable ++ " WHERE role = " ++ roleLiteral role)
+    third <- exec catalog ("DELETE FROM " ++ membersTable ++ " WHERE role = " ++ roleLiteral role)
+    pure (sequence_ [first, second, third])
+
+-- | 全部授权
+readGrants :: Catalog -> IO (Either String [Grant])
+readGrants catalog = fmap (fmap (map grantOf)) (readRows catalog grantsTable)
+
+-- | 记一条授权，同名的先清掉
+addGrant :: Catalog -> Text -> Text -> Text -> IO (Either String ())
+addGrant catalog role privilege object = do
+    cleared <- removeGrant catalog role privilege object
+    case cleared of
+        Left err -> pure (Left err)
+        Right () -> exec catalog (insertSql grantsTable ["role", "privilege", "object"] [normalizeRole role, privilege, object])
+
+-- | 取消一条授权
+removeGrant :: Catalog -> Text -> Text -> Text -> IO (Either String ())
+removeGrant catalog role privilege object = exec catalog (deleteGrantSql role privilege object)
+
+-- | 全部成员关系
+readMembers :: Catalog -> IO (Either String [(Text, Text)])
+readMembers catalog = fmap (fmap (map memberOf)) (readRows catalog membersTable)
+
+-- | 记一条成员关系
+addMember :: Catalog -> Text -> Text -> IO (Either String ())
+addMember catalog role user = exec catalog (insertSql membersTable ["role", "member"] [normalizeRole role, normalizeUser user])
+
+-- | 取消一条成员关系
+removeMember :: Catalog -> Text -> Text -> IO (Either String ())
+removeMember catalog role user =
+    exec catalog ("DELETE FROM " ++ membersTable ++ " WHERE role = " ++ roleLiteral role ++ " AND member = " ++ literal (normalizeUser user))
+
+-- | 一串动作挨着跑，遇到第一个错误就停
+eachAction :: [a] -> (a -> IO (Either e ())) -> IO (Either e ())
+eachAction [] _ = pure (Right ())
+eachAction (item : rest) action = do
+    result <- action item
+    case result of
+        Left err -> pure (Left err)
+        Right () -> eachAction rest action
+
+-- | 行里取一列文本
+cell :: String -> Row -> Text
+cell column row = case lookup column row of
+    Just (VStr value) -> T.pack value
+    _ -> T.empty
+
+-- | 一行授权记录
+grantOf :: Row -> Grant
+grantOf row =
+    Grant
+        { grantRole = normalizeRole (cell "role" row)
+        , grantPrivilege = T.toLower (T.strip (cell "privilege" row))
+        , grantObject = T.toLower (T.strip (cell "object" row))
+        }
+
+-- | 一行成员关系
+memberOf :: Row -> (Text, Text)
+memberOf row = (normalizeRole (cell "role" row), normalizeUser (cell "member" row))
+
+-- | 拼一条删授权的语句
+deleteGrantSql :: Text -> Text -> Text -> String
+deleteGrantSql role privilege object =
+    "DELETE FROM " ++ grantsTable ++ " WHERE role = " ++ roleLiteral role
+        ++ " AND privilege = " ++ literal privilege ++ " AND object = " ++ literal object
+
+-- | 拼一条插入语句
+insertSql :: String -> [String] -> [Text] -> String
+insertSql table columns values =
+    "INSERT INTO " ++ table ++ " (" ++ intercalate ", " columns ++ ") VALUES (" ++ intercalate ", " (map literal values) ++ ")"
+
+-- | 角色名的 SQL 字面量
+roleLiteral :: Text -> String
+roleLiteral = literal . normalizeRole
+
+-- | 文本值的 SQL 字面量
+literal :: Text -> String
+literal = sqlLiteral . VStr . T.unpack

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

@@ -17,23 +17,35 @@ module ChuSQL.Server.Privileges (
     runPrivilegeCommand,
 ) where
 
-import ChuSQL.Core.Model (Row, Value (..))
 import ChuSQL.Core.Engine.Syntax.AST
 import ChuSQL.Server.Accounts (Principal, principalIsRoot, principalName)
-import ChuSQL.Interface.Actions (sqlLiteral)
 import ChuSQL.Interface.Protocol (Grant (..), RoleView (..))
 import ChuSQL.Server.Backend (
     Backend (..),
-    StatementResult (..),
     exprTables,
-    grantsTable,
-    membersTable,
-    rolesTable,
     systemDatabaseName,
     tableRefsOf,
  )
-import Control.Concurrent.MVar (MVar, newMVar, withMVar)
-import Data.List (intercalate, isInfixOf, nub, sort)
+import ChuSQL.Server.Catalog (
+    Catalog,
+    addGrant,
+    addMember,
+    dropRole,
+    eachAction,
+    insertRole,
+    newCatalog,
+    normalizeObject,
+    normalizeRole,
+    normalizeUser,
+    readGrants,
+    readMembers,
+    readRoleNames,
+    removeGrant,
+    removeMember,
+    withCatalogLock,
+    ensureCatalog,
+ )
+import Data.List (nub, sort)
 import Data.Text (Text)
 import qualified Data.Text as T
 
@@ -63,15 +75,12 @@ data PrivilegeCommand
     deriving (Show, Eq)
 
 data Privileges = Privileges
-    { pvBackend :: Backend
-    , pvLock :: MVar ()
+    { pvCatalog :: Catalog
     }
 
 -- | 建权限服务，固定在 system 库上
 newPrivileges :: Backend -> IO Privileges
-newPrivileges base = do
-    lock <- newMVar ()
-    pure (Privileges (beWithDatabase base systemDatabaseName) lock)
+newPrivileges base = Privileges <$> newCatalog (beWithDatabase base systemDatabaseName)
 
 -- | 语句转管理命令，不认的给 Nothing
 privilegeCommand :: Statement -> Maybe PrivilegeCommand
@@ -137,13 +146,6 @@ listRoleViews service = withTables service $ do
         members <- membersOfRole service role
         pure (RoleView role <$> grants <*> members)
 
--- | 授权对象落库口径：`*` 原样，裸表名按当前库补全
-normalizeObject :: Text -> Text -> Text
-normalizeObject database object
-    | T.strip object == "*" = "*"
-    | T.any (== '.') object = T.toLower (T.strip object)
-    | otherwise = normalizeUser database <> "." <> normalizeUser object
-
 -- | 一条语句需要哪些 (表, 权限)
 requiredActions :: Statement -> Maybe [(Text, Text)]
 requiredActions stmt = case stmt of
@@ -177,34 +179,29 @@ checkAll database grants needed = case [pair | pair@(table, privilege) <- needed
 -- | 一个用户实际能用的授权：他所属角色身上的那些
 grantsOfUser :: Privileges -> Text -> IO (Either PrivilegeError [Grant])
 grantsOfUser service user = do
-    members <- readRows service membersTable
-    rows <- readRows service grantsTable
+    members <- catalog (readMembers (pvCatalog service))
+    grants <- catalog (readGrants (pvCatalog service))
     pure $ do
         memberRows <- members
-        grantRows <- rows
-        let mine = [normalizeRole (cell "role" row) | row <- memberRows, normalizeUser (cell "member" row) == normalizeUser user]
-        pure [grantOf row | row <- grantRows, normalizeRole (cell "role" row) `elem` mine]
+        grantRows <- grants
+        let mine = [role | (role, member) <- memberRows, member == normalizeUser user]
+        pure [grant | grant <- grantRows, grantRole grant `elem` mine]
 
 -- | 一个角色挂着的授权
 roleGrantsOf :: Privileges -> Text -> IO (Either PrivilegeError [Grant])
 roleGrantsOf service role = do
-    rows <- readRows service grantsTable
-    pure $ fmap (map grantOf . filter (\row -> normalizeRole (cell "role" row) == normalizeRole role)) rows
+    grants <- catalog (readGrants (pvCatalog service))
+    pure (filter (\grant -> grantRole grant == normalizeRole role) <$> grants)
 
 -- | 角色名清单（统一小写）
 roleNames :: Privileges -> IO (Either PrivilegeError [Text])
-roleNames service = do
-    rows <- readRows service rolesTable
-    pure (map (normalizeRole . cell "name") <$> rows)
+roleNames service = catalog (readRoleNames (pvCatalog service))
 
 -- | 一个角色的成员清单
 membersOfRole :: Privileges -> Text -> IO (Either PrivilegeError [Text])
 membersOfRole service role = do
-    rows <- readRows service membersTable
-    pure $
-        fmap
-            (map (normalizeUser . cell "member") . filter (\row -> normalizeRole (cell "role" row) == normalizeRole role))
-            rows
+    members <- catalog (readMembers (pvCatalog service))
+    pure (map snd . filter (\(name, _) -> name == normalizeRole role) <$> members)
 
 -- | 角色必须存在，否则命令不落地
 requireRole :: Privileges -> Text -> IO (Either PrivilegeError ())
@@ -225,129 +222,55 @@ applyCommand service database command = case command of
             Left err -> pure (Left err)
             Right names
                 | normalizeRole role `elem` names -> pure (Left (PrivilegeError "conflict" ("role already exists: " <> role)))
-                | otherwise -> exec service (insertSql rolesTable ["name"] [normalizeRole role])
+                | otherwise -> catalog (insertRole (pvCatalog service) role)
     DropRoleCommand role -> do
         allowed <- requireRole service role
         case allowed of
             Left err -> pure (Left err)
-            Right () -> do
-                first <- exec service ("DELETE FROM " ++ rolesTable ++ " WHERE name = " ++ roleLiteral role)
-                second <- exec service ("DELETE FROM " ++ grantsTable ++ " WHERE role = " ++ roleLiteral role)
-                third <- exec service ("DELETE FROM " ++ membersTable ++ " WHERE role = " ++ roleLiteral role)
-                pure (sequence_ [first, second, third])
+            Right () -> catalog (dropRole (pvCatalog service) role)
     GrantPrivilegesCommand privileges object role -> do
         allowed <- requireRole service role
         case allowed of
             Left err -> pure (Left err)
-            Right () -> each (expandPrivileges privileges) $ \privilege -> do
-                let target = normalizeObject database object
-                cleared <- exec service (deleteGrantSql role privilege target)
-                case cleared of
-                    Left err -> pure (Left err)
-                    Right () ->
-                        exec service (insertSql grantsTable ["role", "privilege", "object"] [normalizeRole role, privilege, target])
+            Right () ->
+                eachAction (expandPrivileges privileges) $ \privilege ->
+                    catalog (addGrant (pvCatalog service) role privilege (normalizeObject database object))
     RevokePrivilegesCommand privileges object role -> do
         allowed <- requireRole service role
         case allowed of
             Left err -> pure (Left err)
             Right () ->
-                each (expandPrivileges privileges) $ \privilege ->
-                    exec service (deleteGrantSql role privilege (normalizeObject database object))
+                eachAction (expandPrivileges privileges) $ \privilege ->
+                    catalog (removeGrant (pvCatalog service) role privilege (normalizeObject database object))
     GrantRoleCommand role users -> do
         allowed <- requireRole service role
         case allowed of
             Left err -> pure (Left err)
             Right () ->
-                each users $ \user -> do
+                eachAction users $ \user -> do
                     known <- membersOfRole service role
                     case known of
                         Left err -> pure (Left err)
                         Right members
                             | normalizeUser user `elem` members -> pure (Right ())
-                            | otherwise ->
-                                exec service (insertSql membersTable ["role", "member"] [normalizeRole role, normalizeUser user])
+                            | otherwise -> catalog (addMember (pvCatalog service) role user)
     RevokeRoleCommand role users -> do
         allowed <- requireRole service role
         case allowed of
             Left err -> pure (Left err)
-            Right () ->
-                each users $ \user ->
-                    exec
-                        service
-                        ( "DELETE FROM " ++ membersTable ++ " WHERE role = " ++ roleLiteral role
-                            ++ " AND member = " ++ literal (normalizeUser user)
-                        )
+            Right () -> eachAction users $ \user -> catalog (removeMember (pvCatalog service) role user)
 
--- | 建表只在第一次用时做；已经有了就算成功
+-- | 全程持锁，先保证系统表存在再跑动作
 withTables :: Privileges -> IO (Either PrivilegeError a) -> IO (Either PrivilegeError a)
-withTables service action = withMVar (pvLock service) $ \_ -> do
-    ready <- ensureTables service
+withTables service action = withCatalogLock (pvCatalog service) $ do
+    ready <- ensureCatalog (pvCatalog service)
     case ready of
-        Left err -> pure (Left err)
+        Left err -> pure (Left (storageError err))
         Right () -> action
 
--- | 确保三张内部表存在
-ensureTables :: Privileges -> IO (Either PrivilegeError ())
-ensureTables service = each tableDefs (createTable service)
-  where
-    -- | 三张内部表的定义
-    tableDefs =
-        [ (rolesTable, "(name VARCHAR(64))")
-        , (grantsTable, "(role VARCHAR(64), privilege VARCHAR(16), object VARCHAR(128))")
-        , (membersTable, "(role VARCHAR(64), member VARCHAR(64))")
-        ]
-
--- | 建一张内部表，已存在算成功
-createTable :: Privileges -> (String, String) -> IO (Either PrivilegeError ())
-createTable service (table, columns) = do
-    result <- beStatement (pvBackend service) ("CREATE TABLE " ++ table ++ " " ++ columns)
-    pure $ case result of
-        Right _ -> Right ()
-        Left err
-            | "exists" `isInfixOf` err -> Right ()
-            | otherwise -> Left (storageError err)
-
--- | 跑一条内部写语句
-exec :: Privileges -> String -> IO (Either PrivilegeError ())
-exec service sql = do
-    result <- beStatement (pvBackend service) sql
-    pure $ case result of
-        Left err -> Left (storageError err)
-        Right _ -> Right ()
-
--- | 读一张内部表
-readRows :: Privileges -> String -> IO (Either PrivilegeError [Row])
-readRows service table = do
-    result <- beStatement (pvBackend service) ("SELECT * FROM " ++ table)
-    pure $ case result of
-        Left err -> Left (storageError err)
-        Right res -> Right (srRows res)
-
--- | 行里取一列文本
-cell :: String -> Row -> Text
-cell column row = case lookup column row of
-    Just (VStr value) -> T.pack value
-    _ -> ""
-
--- | 一行记录转成授权
-grantOf :: Row -> Grant
-grantOf row =
-    Grant
-        { grantRole = normalizeRole (cell "role" row)
-        , grantPrivilege = T.toLower (T.strip (cell "privilege" row))
-        , grantObject = T.toLower (T.strip (cell "object" row))
-        }
-
--- | 拼一条删授权的 SQL
-deleteGrantSql :: Text -> Text -> Text -> String
-deleteGrantSql role privilege object =
-    "DELETE FROM " ++ grantsTable ++ " WHERE role = " ++ roleLiteral role
-        ++ " AND privilege = " ++ literal privilege ++ " AND object = " ++ literal object
-
--- | 拼一条插入的 SQL
-insertSql :: String -> [String] -> [Text] -> String
-insertSql table columns values =
-    "INSERT INTO " ++ table ++ " (" ++ intercalate ", " columns ++ ") VALUES (" ++ intercalate ", " (map literal values) ++ ")"
+-- | 目录操作转成权限错误
+catalog :: IO (Either String a) -> IO (Either PrivilegeError a)
+catalog action = fmap (either (Left . storageError) Right) action
 
 -- | 把 ALL 展开成四种具体权限
 expandPrivileges :: [Text] -> [Text]
@@ -357,31 +280,6 @@ expandPrivileges privileges = nub (concatMap expand (map (T.toLower . T.strip) p
     expand "all" = ["select", "insert", "update", "delete"]
     expand other = [other]
 
--- | 一串动作挨着跑，遇到第一个错误就停
-each :: [a] -> (a -> IO (Either PrivilegeError ())) -> IO (Either PrivilegeError ())
-each [] _ = pure (Right ())
-each (item : rest) action = do
-    result <- action item
-    case result of
-        Left err -> pure (Left err)
-        Right () -> each rest action
-
--- | 角色名的 SQL 字面量
-roleLiteral :: Text -> String
-roleLiteral = literal . normalizeRole
-
--- | 文本值的 SQL 字面量
-literal :: Text -> String
-literal = sqlLiteral . VStr . T.unpack
-
--- | 角色名统一小写去空白
-normalizeRole :: Text -> Text
-normalizeRole = T.toLower . T.strip
-
--- | 用户名统一小写去空白
-normalizeUser :: Text -> Text
-normalizeUser = T.toLower . T.strip
-
 forbidden :: PrivilegeError
 forbidden = PrivilegeError "forbidden" "administrator required"
 

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

@@ -27,10 +27,11 @@ module ChuSQL.Server.Session
 import ChuSQL.Core.Model (Value (..))
 import ChuSQL.Core.Protocol (Account, QueryResult (..), queryResultJson)
 import ChuSQL.Core.Engine.Storage.IPC (TableInfo (..))
+import qualified ChuSQL.Core.Engine.Error as E
 import ChuSQL.Core.Engine.Syntax.AST (Statement (..))
 import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
 import ChuSQL.Interface.AccountTable (systemTableInfo)
-import ChuSQL.Interface.Auth (Credential, defaultSessionPolicy, newSessionStore)
+import ChuSQL.Interface.Auth (defaultSessionPolicy, newSessionStore)
 import ChuSQL.Server.Accounts
 import ChuSQL.Server.Backend (Backend (..), StatementResult (..))
 import ChuSQL.Server.Policy (configurePasswordPolicy)
@@ -54,12 +55,7 @@ data SessionError = SessionError
 
 -- | 引擎报错翻成错误码
 engineErrorCode :: String -> SessionError
-engineErrorCode err
-    | "no database selected" `T.isInfixOf` message = SessionError "no_database" message
-    | "unknown table" `T.isInfixOf` message = SessionError "not_found" message
-    | otherwise = SessionError "query_error" message
-  where
-    message = T.pack err
+engineErrorCode err = SessionError (T.pack (E.errorCode err)) (T.pack err)
 
 data Session = Session
     { ssBackend :: Backend
@@ -71,10 +67,10 @@ data Session = Session
     }
 
 -- | 开一个会话：账号与角色服务、配置策略都和 Web 端一致
-newSession :: Backend -> Credential -> FilePath -> IO Session
-newSession backend credential settingsFile = do
+newSession :: Backend -> Text -> FilePath -> IO Session
+newSession backend name settingsFile = do
     sessions <- newSessionStore getCurrentTime defaultSessionPolicy
-    accountsService <- newAccounts backend sessions credential
+    accountsService <- newAccounts backend sessions name
     privileges <- newPrivileges backend
     configurePasswordPolicy accountsService settingsFile
     -- 服务启动后只有系统库：没 USE 之前不预设任何工作库
@@ -106,7 +102,7 @@ reloadPolicy session = do
 sessionUser :: Session -> IO (Maybe Text)
 sessionUser session = fmap principalName <$> readIORef (ssPrincipal session)
 
--- | 是不是配置里的 root
+-- | 是不是管理员
 sessionIsAdmin :: Session -> IO Bool
 sessionIsAdmin session = maybe False principalIsRoot <$> readIORef (ssPrincipal session)
 

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

@@ -11,11 +11,11 @@ module ChuSQL.Server.TCP (
     runServer,
 ) where
 
-import ChuSQL.Interface.Auth (Credential)
 import ChuSQL.Interface.Config (ServerConfig (..), defaultServerConfig, loadServerConfigAt)
 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.Server.Backend (Backend (..))
 import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), accounts, authenticateSessionCoded, catalog, databases, newSession, policyOf, reloadPolicy, roleViews, runStatementCoded, sessionIsAdmin, sessionUser)
 import Control.Concurrent (forkIO)
@@ -57,16 +57,16 @@ import System.IO.Error (isEOFError)
 
 data ServerEnv = ServerEnv
     { srvBackend :: Backend
-    , srvCredential :: Credential
+    , srvRootName :: Text
     , srvSettingsFile :: FilePath
     , srvConfig :: ServerConfig
     , srvLimiter :: RateLimiter
     }
 
 -- | 组装服务器环境：每个连接再各开一个会话
-newServerEnv :: Backend -> Credential -> FilePath -> ServerConfig -> RateLimiter -> IO ServerEnv
-newServerEnv backend credential settingsFile config limiter =
-    pure (ServerEnv backend credential settingsFile config limiter)
+newServerEnv :: Backend -> Text -> FilePath -> ServerConfig -> RateLimiter -> IO ServerEnv
+newServerEnv backend rootName settingsFile config limiter =
+    pure (ServerEnv backend rootName settingsFile config limiter)
 
 data ServerHandle = ServerHandle
     { shPort :: Int
@@ -154,7 +154,7 @@ serveConnection env conn = do
     h <- socketToHandle conn ReadWriteMode
     hSetBuffering h LineBuffering
     hSetNewlineMode h noNewlineTranslation
-    session <- newSession (srvBackend env) (srvCredential env) (srvSettingsFile env)
+    session <- newSession (srvBackend env) (srvRootName env) (srvSettingsFile env)
     outcome <- try (loop h session) :: IO (Either IOException ())
     case outcome of
         Left err | not (isEOFError err) -> hPutStrLn stderr ("connection error: " ++ show err)
@@ -253,10 +253,7 @@ overSession session action wrap = do
 
 -- | 会话层的失败文案归一到协议错误码
 sessionCode :: Text -> Text
-sessionCode message
-    | message == "no database selected" = "no_database"
-    | message == "administrator required" = "forbidden"
-    | otherwise = "query_error"
+sessionCode = T.pack . E.errorCode . T.unpack
 
 -- | 登录：按账号名限流，成功清账
 login :: ServerEnv -> Session -> Text -> Text -> IO ServerResponse

chusql-server/test/Spec.hs

@@ -3,11 +3,23 @@
 
 module Main (main) where
 
+import ChuSQL.Core.Engine.Storage.IPC (Account (..), Request (ReqAccountReset))
+import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
 import ChuSQL.Core.Model (Database, Table (..), Value (..), pattern TInt, pattern TStr)
-import ChuSQL.Interface.Auth (Credential (..), hashPasswordWith)
-import ChuSQL.Interface.Protocol (ClientRequest (..), ServerResponse (..), decodeRequest, encodeResponse)
+import ChuSQL.Interface.Auth (hashPasswordWith)
+import ChuSQL.Interface.Protocol (ClientRequest (..), Grant (..), RoleView (..), ServerResponse (..), decodeRequest, encodeResponse)
 import ChuSQL.Interface.RateLimit (newRateLimiter)
-import ChuSQL.Server.Backend (memoryBackend)
+import ChuSQL.Server.Accounts (Principal (..), ensureRootAccount)
+import ChuSQL.Server.Backend (Backend (..), memoryBackend)
+import ChuSQL.Server.Privileges (
+    PrivilegeCommand (..),
+    PrivilegeError (..),
+    Privileges,
+    authorize,
+    listRoleViews,
+    newPrivileges,
+    runPrivilegeCommand,
+ )
 import ChuSQL.Server.Session (QueryResult (..))
 import ChuSQL.Server.TCP (
     ServerConfig (..),
@@ -74,6 +86,7 @@ spec :: Spec
 spec = do
     tcpSpec
     tcpServerSpec
+    privilegeSpec
 
 -- 夹具：内存后端装在 MVar 里，跟 Web 测试同一套表
 
@@ -91,18 +104,28 @@ testDb =
             [ [("id", VInt i), ("name", VStr ("user" ++ show i)), ("age", VInt (20 + i))]
             | i <- [1 .. 5]
             ]
+            Nothing
       )
     , ( "orders"
       , Table
             "orders"
             [("id", TInt), ("user_id", TInt)]
             [[("id", VInt 1), ("user_id", VInt 1)]]
+            Nothing
       )
     ]
 
--- | 测试账号：迭代次数压低（跑得快），口令 `s3cret`
-testCredential :: Credential
-testCredential = Credential "admin" (hashPasswordWith 1000 (BS.replicate 16 7) "s3cret")
+-- | 测试管理员名字
+testRootName :: Text
+testRootName = "admin"
+
+-- | 测试管理员口令
+testRootPassword :: Text
+testRootPassword = "s3cret"
+
+-- | 口令哈希：迭代次数压低，跑得快
+testPasswordHash :: Text -> Text
+testPasswordHash raw = hashPasswordWith 1000 (BS.replicate 16 7) raw
 
 -- 小工具
 
@@ -159,14 +182,23 @@ removeIfExists path = do
     there <- doesFileExist path
     if there then void (try (removeFile path) :: IO (Either IOException ())) else pure ()
 
--- | 起一台内存后端的测试服务器
+-- | 起一台内存后端的测试服务器：管理员已设口令 `s3cret`
 withTcpServer :: ServerConfig -> (ServerEnv -> ServerHandle -> IO a) -> IO a
-withTcpServer config body = do
+withTcpServer = withTcpServerAs (Just testRootPassword)
+
+-- | 起内存后端测试服务器；Nothing 表示首启未设口令
+withTcpServerAs :: Maybe Text -> ServerConfig -> (ServerEnv -> ServerHandle -> IO a) -> IO a
+withTcpServerAs password config body = do
     db <- newMVar testDb
     limiter <- newRateLimiter getCurrentTime 50 300
     path <- tempSettingsPath "tcp-server"
     removeIfExists path
-    env <- newServerEnv (memoryBackend testDatabaseName db) testCredential path config{scPort = 0} limiter
+    let backend = memoryBackend testDatabaseName db
+    _ <- ensureRootAccount backend testRootName
+    case password of
+        Nothing -> pure ()
+        Just raw -> void (beAccounts backend (ReqAccountReset testRootName (testPasswordHash raw)))
+    env <- newServerEnv backend testRootName path config{scPort = 0} limiter
     handle <- startServer env
     body env handle `finally` shStop handle
 
@@ -321,6 +353,14 @@ tcpServerSpec = do
                     asText (at "status" reply) `shouldBe` "error"
                     asText (at "code" reply) `shouldBe` "unauthorized"
                     asText (at "message" reply) `shouldBe` "sign in first"
+        it "signs the administrator in with an empty password until one is set" $
+            withTcpServerAs Nothing defaultServerConfig $ \_ handle ->
+                withConnection handle $ \h -> do
+                    wrong <- tcpLogin h "admin" "nope"
+                    asText (at "code" wrong) `shouldBe` "unauthorized"
+                    good <- tcpLogin h "admin" ""
+                    asText (at "status" good) `shouldBe` "ok"
+                    asBool (at "admin" good) `shouldBe` True
         it "refuses a wrong password and then accepts the right one" $
             withTcpServer defaultServerConfig $ \_ handle ->
                 withConnection handle $ \h -> do
@@ -414,3 +454,94 @@ tcpServerSpec = do
                     withConnection handle $ \other -> do
                         blocked <- tcpQuery other "select * from users"
                         asText (at "code" blocked) `shouldBe` "unauthorized"
+
+-- 权限服务夹具：内存后端上的系统库视角
+
+-- | 一个普通账号
+testAccount :: Account
+testAccount = Account 0 "alice" "" 0 "" Nothing
+
+-- | 权限用例传的当前库名
+testDatabase :: Text
+testDatabase = T.pack testDatabaseName
+
+-- | 一个空的权限服务加管理员身份
+withPrivileges :: (Privileges -> Principal -> IO a) -> IO a
+withPrivileges body = do
+    db <- newMVar testDb
+    service <- newPrivileges (memoryBackend testDatabaseName db)
+    body service (Root testRootName)
+
+-- | 权限与目录 API 用例
+privilegeSpec :: Spec
+privilegeSpec = describe "server privileges" $ do
+    it "creates a role and lists it" $ withPrivileges $ \service root -> do
+        created <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
+        created `shouldBe` Right ()
+        views <- listRoleViews service
+        fmap (map roleName) views `shouldBe` Right ["reader"]
+
+    it "refuses a role that already exists" $ withPrivileges $ \service root -> do
+        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
+        again <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
+        again `shouldBe` Left (PrivilegeError "conflict" "role already exists: reader")
+
+    it "grants a privilege on a table and shows it in the role view" $ withPrivileges $ \service root -> do
+        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
+        granted <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader")
+        granted `shouldBe` Right ()
+        views <- listRoleViews service
+        fmap (map roleGrants) views `shouldBe` Right [[Grant "reader" "select" "test.users"]]
+
+    it "expands ALL and keeps a star object as is" $ withPrivileges $ \service root -> do
+        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
+        _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["all"] "*" "reader")
+        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 "*")
+
+    it "revokes a privilege again" $ withPrivileges $ \service root -> do
+        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
+        _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader")
+        _ <- runPrivilegeCommand service root testDatabase (RevokePrivilegesCommand ["select"] "users" "reader")
+        views <- listRoleViews service
+        fmap (map roleGrants) views `shouldBe` Right [[]]
+
+    it "adds and removes members" $ withPrivileges $ \service root -> do
+        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
+        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
+        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice", "bob"])
+        views <- listRoleViews service
+        fmap (map roleMembers) views `shouldBe` Right [["alice", "bob"]]
+        _ <- runPrivilegeCommand service root testDatabase (RevokeRoleCommand "reader" ["alice"])
+        remaining <- listRoleViews service
+        fmap (map roleMembers) remaining `shouldBe` Right [["bob"]]
+
+    it "drops a role together with its grants and members" $ withPrivileges $ \service root -> do
+        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
+        _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader")
+        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
+        dropped <- runPrivilegeCommand service root testDatabase (DropRoleCommand "reader")
+        dropped `shouldBe` Right ()
+        views <- listRoleViews service
+        views `shouldBe` Right []
+
+    it "refuses a command on a role that does not exist" $ withPrivileges $ \service root -> do
+        missing <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "ghost")
+        missing `shouldBe` Left (PrivilegeError "not_found" "unknown role: ghost")
+
+    it "refuses a table grant without a selected database" $ withPrivileges $ \service root -> do
+        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
+        refused <- runPrivilegeCommand service root "" (GrantPrivilegesCommand ["select"] "users" "reader")
+        refused `shouldBe` Left (PrivilegeError "no_database" "no database selected")
+
+    it "refuses a non-administrator" $ withPrivileges $ \service _ -> do
+        refused <- runPrivilegeCommand service (Ordinary testAccount) testDatabase (CreateRoleCommand "reader")
+        refused `shouldBe` Left (PrivilegeError "forbidden" "administrator required")
+
+    it "authorizes the administrator on any statement" $ withPrivileges $ \service root ->
+        case parseStatement "SELECT * FROM users" of
+            Left err -> expectationFailure err
+            Right stmt -> authorize service root testDatabase stmt `shouldReturn` Right ()
+