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

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