修复bug
This commit is contained in:
LIm1tZz7 committed
1 parent
fc9bbc20e4
commit
e87c4ee6a8
90 files changed
+3828
-452
No files matched your search
@@ -14,6 +14,7 @@ library
|
||||
exposed-modules: ChuSQL.Server.Accounts
|
||||
ChuSQL.Server.Backend
|
||||
ChuSQL.Server.Catalog
|
||||
ChuSQL.Server.Normalization
|
||||
ChuSQL.Server.Policy
|
||||
ChuSQL.Server.Privileges
|
||||
ChuSQL.Server.ObjectACL
|
||||
|
||||
@@ -41,7 +41,7 @@ import ChuSQL.Core.Engine.Syntax.AST
|
||||
import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
|
||||
import ChuSQL.Core.Protocol (TxnOp (..))
|
||||
import Control.Concurrent.MVar (MVar, modifyMVar, readMVar)
|
||||
import Data.List (nub)
|
||||
import Data.List (nub, isPrefixOf)
|
||||
import Data.Text (Text)
|
||||
import Data.Time (getCurrentTime)
|
||||
import Data.Time.Format (defaultTimeLocale, formatTime)
|
||||
@@ -75,6 +75,7 @@ data Backend = Backend
|
||||
-- | 按给定列名取列，固定列顺序
|
||||
columnsFromStatement :: Database -> Statement -> [String]
|
||||
columnsFromStatement db stmt = case prepare db stmt of
|
||||
Right (SelectDistinct q) -> columnsFromStatement db q
|
||||
Right (Select cols _ _ _ _ _) -> cols
|
||||
Right (SelectExpr items _ _ _ _ _) -> map fst items
|
||||
Right ShowDomains -> ["domain", "base_type"]
|
||||
@@ -173,9 +174,9 @@ memoryBackendWith trusted name ref =
|
||||
Right (db', rows)
|
||||
| any (\(key, _) -> hidden key && not (domainKey key)) db' -> pure (db, Left "reserved system table")
|
||||
| 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))))
|
||||
, beCatalog = modifyMVar ref $ \original -> do
|
||||
let db = syncMemoryObjects name original
|
||||
pure (db, Right (map tableInfoOf (filter (not . internalTable . fst) (scoped db))))
|
||||
, bePing = pure True
|
||||
, beAccounts = \req -> do
|
||||
stamp <- currentStamp
|
||||
@@ -187,7 +188,9 @@ memoryBackendWith trusted name ref =
|
||||
, beWithDatabase = withDatabase
|
||||
, beDatabases = pure (Right (nub [name, systemDatabaseName]))
|
||||
, beStorage = memorySecurityRequest name ref
|
||||
, beSnapshot = Right . scoped <$> readMVar ref
|
||||
, beSnapshot = modifyMVar ref $ \original -> do
|
||||
let db = syncMemoryObjects name original
|
||||
pure (db, Right (scoped db))
|
||||
, beApplyTransaction = \ops -> modifyMVar ref $ \db -> case applyTransactionMemory ops (scoped db) of
|
||||
Left err -> pure (db, Left err)
|
||||
Right db' -> pure (mergeScoped db db', Right ())
|
||||
@@ -226,7 +229,8 @@ memoryBackendWith trusted name ref =
|
||||
|
||||
-- 更新内存夹具的稳定表编号。
|
||||
syncMemoryObjects :: String -> Database -> Database
|
||||
syncMemoryObjects database db = (registry, Table registry [("name", TStr), ("id", TInt)] records Nothing) : filter ((/= registry) . fst) db
|
||||
syncMemoryObjects database db = (registry, Table registry [("name", TStr), ("id", TInt)] records Nothing Nothing Nothing)
|
||||
: map identify (filter ((/= registry) . fst) db)
|
||||
where
|
||||
registry = "__system_object_ids"
|
||||
previous = [(key, identifier) | row <- maybe [] tableRows (lookup registry db), Just (VStr key) <- [lookup "name" row], Just (VInt identifier) <- [lookup "id" row]]
|
||||
@@ -234,6 +238,11 @@ syncMemoryObjects database db = (registry, Table registry [("name", TStr), ("id"
|
||||
retained = [(key, identifier) | (key, identifier) <- previous, key `elem` keys]
|
||||
high = maximum (0 : map snd previous)
|
||||
added = zip [key | key <- keys, key `notElem` map fst retained] [high + 1 ..]
|
||||
-- | 将稳定目录编号附到表定义
|
||||
identify (key, table) = case lookup (if '.' `elem` key then key else database ++ "." ++ key) (retained ++ added) of
|
||||
Just identifier -> (key, table {tableIdentity = Just (TableIdentity
|
||||
(if "system." `isPrefixOf` key || ('.' `notElem` key && database == "system") then 2 else 1) (fromIntegral identifier))})
|
||||
Nothing -> (key, table)
|
||||
records = [[("name", VStr key), ("id", VInt identifier)] | (key, identifier) <- ("__high_water", high + length added) : retained ++ added]
|
||||
|
||||
-- 执行内存夹具的权限快照协议。
|
||||
@@ -266,7 +275,7 @@ memorySecurityRequest database ref payload = modifyMVar ref $ \original -> 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)])
|
||||
Right ((acl, Table acl [("payload", TStr)] [[("payload", VStr (T.unpack value))]] Nothing Nothing Nothing) : filter ((/= acl) . fst) db, A.object ["status" A..= ("ok" :: Text)])
|
||||
_ -> Left "storage is not available in this backend"
|
||||
acl = "__system_object_acl"
|
||||
|
||||
@@ -320,6 +329,7 @@ applyTransactionMemory ops db = foldl step (Right db) ops
|
||||
-- | 语句里出现的表
|
||||
statementTables :: Statement -> [Text]
|
||||
statementTables stmt = nub (case stmt of
|
||||
SelectDistinct q -> statementTables q
|
||||
Select{} ->
|
||||
tableRefsOf (selectFrom stmt)
|
||||
++ concatMap exprTables (maybe [] (: []) (selectWhere stmt) ++ map Col (selectCols stmt ++ selectGroupBy stmt ++ map fst (selectOrderBy stmt)))
|
||||
@@ -440,6 +450,8 @@ tableInfoOf (name, tbl) =
|
||||
, tiRows = length (tableRows tbl)
|
||||
, tiIndexes = []
|
||||
, tiStats = [(c, distinctOf c, False) | (c, _) <- tableCols tbl]
|
||||
, tiIdentity = tableIdentity tbl
|
||||
, tiSchemaVersion = tableSchemaVersion tbl
|
||||
, tiHistograms = [(c, h) | (c, _) <- tableCols tbl, Just h <- [histogramOf (columnValues c)]]
|
||||
}
|
||||
where
|
||||
@@ -594,9 +606,9 @@ memoryAccounts db stamp req = do
|
||||
-- | 分开保存内存身份与口令并清理授权
|
||||
storeMemoryIdentities :: Database -> [Account] -> [Account] -> Database
|
||||
storeMemoryIdentities db previous accounts =
|
||||
(usersTable, Table usersTable [("id", TInt), ("password_hash", TStr)] credentials Nothing) :
|
||||
("__system_identities", Table "__system_identities" [("account", TStr)] identities Nothing) :
|
||||
("__system_identity_sequence", Table "__system_identity_sequence" [("id", TInt)] [[("id", VInt highWater)]] Nothing) :
|
||||
(usersTable, Table usersTable [("id", TInt), ("password_hash", TStr)] credentials Nothing Nothing Nothing) :
|
||||
("__system_identities", Table "__system_identities" [("account", TStr)] identities Nothing Nothing Nothing) :
|
||||
("__system_identity_sequence", Table "__system_identity_sequence" [("id", TInt)] [[("id", VInt highWater)]] Nothing Nothing Nothing) :
|
||||
[(name, clean name table) | (name, table) <- db, name `notElem` [usersTable, "__system_identities", "__system_identity_sequence"]]
|
||||
where
|
||||
-- | 保存口令与身份编号
|
||||
|
||||
@@ -0,0 +1,100 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChuSQL.Server.Normalization (normalizationBudget, normalizationReport, schemaFingerprint) where
|
||||
|
||||
import qualified ChuSQL.Core.Engine.Normalization as N
|
||||
import ChuSQL.Core.Model (Column (..), parseColumnType)
|
||||
import ChuSQL.Core.Protocol (SchemaColumn (..), valueToJSON)
|
||||
import ChuSQL.Interface.Normalization
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Concurrent.QSem
|
||||
import Control.Exception (bracket_, evaluate, mask)
|
||||
import Crypto.Hash (Digest, SHA256, hash)
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Aeson ((.=), object)
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.List (nub, sort)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import System.Timeout (timeout)
|
||||
|
||||
-- 范式服务：有界执行、稳定 schema 指纹与引擎报告的线上表示。
|
||||
|
||||
{-# NOINLINE analysisSlots #-}
|
||||
-- 保存最多八个请求和两个执行槽。
|
||||
analysisSlots :: (MVar Int, QSem)
|
||||
analysisSlots = unsafePerformIO ((,) <$> newMVar 0 <*> newQSem 2)
|
||||
|
||||
-- 限制排队、执行时间及输出大小。
|
||||
normalizationBudget :: IO (Either (Text, Text) A.Value) -> IO (Either (Text, Text) A.Value)
|
||||
normalizationBudget action = mask $ \restore -> do
|
||||
let (queued, slots) = analysisSlots
|
||||
admitted <- modifyMVar queued $ \count -> pure (if count < 8 then (count + 1, True) else (count, False))
|
||||
if not admitted then pure (Left ("too_busy", "normalization queue is full")) else
|
||||
bracket_ (pure ()) (modifyMVar_ queued (pure . subtract 1)) $ do
|
||||
result <- restore $ timeout 5000000 $ bracket_ (waitQSem slots) (signalQSem slots) $ do
|
||||
outcome <- action
|
||||
case outcome of
|
||||
Left err -> pure (Left err)
|
||||
Right value -> do
|
||||
size <- evaluate (BL.length (BL.take 64001 (A.encode value)))
|
||||
pure (if size > 64000 then Left ("too_large", "normalization report exceeds transport budget") else Right value)
|
||||
pure (maybe (Left ("timeout", "normalization exceeded its five second budget")) id result)
|
||||
|
||||
-- 编码只影响语义的列信息。
|
||||
fingerprintColumn :: SchemaColumn -> A.Value
|
||||
fingerprintColumn c = A.toJSON [A.toJSON (scName c), A.toJSON (scType c), A.toJSON (scNullable c),
|
||||
maybe A.Null valueToJSON (scDefault c), A.toJSON (scAutoIncrement c), A.toJSON (scPrimaryKey c), A.toJSON (scUnique c), A.toJSON (scCheck c)]
|
||||
|
||||
-- 将稳定编号与列结构绑定到 SHA256。
|
||||
schemaFingerprint :: ObjectIdentity -> [SchemaColumn] -> Text
|
||||
schemaFingerprint (ObjectIdentity database table) columns = T.pack (show (hash (BL.toStrict (A.encode (A.toJSON [A.toJSON [show database, show table], A.toJSON (map fingerprintColumn columns)]))) :: Digest SHA256))
|
||||
|
||||
-- 绑定 schema 并编码只读分析报告。
|
||||
normalizationReport :: ObjectIdentity -> [SchemaColumn] -> Text -> NormalizationRequest -> Either (Text, Text) A.Value
|
||||
normalizationReport identity columns view payload = do
|
||||
let fingerprint = schemaFingerprint identity columns
|
||||
if maybe False (/= identity) (nrExpectedObject payload) || maybe False (/= fingerprint) (nrExpectedSchema payload)
|
||||
then Left ("conflict", "normalization object or schema has changed") else Right ()
|
||||
schema <- mapM column columns
|
||||
let declaration = nrDeclaration payload
|
||||
axioms = N.Declaration (ndKeys declaration) [N.Dependency a b | NormalizationDependency a b <- ndDependencies declaration] (ndComplete declaration) (ndAtomic declaration)
|
||||
analysis <- either (Left . (,) "bad_request" . T.pack) Right (N.analyzeNormalization schema axioms)
|
||||
Right (object ["api_version" .= (1 :: Int), "database" .= nrDatabase payload, "table" .= last (T.splitOn "." (nrTable payload)),
|
||||
"object" .= identity, "schema_fingerprint" .= fingerprint, "view" .= view, "schema" .= columns,
|
||||
"declaration" .= canonicalDeclaration declaration, "candidate_keys" .= N.candidateKeys analysis,
|
||||
"findings" .= map findingJSON (N.findings analysis), "suggestions" .= map decompositionJSON (N.suggestions analysis),
|
||||
"conditional" .= True, "condition" .= ("Analysis is conditional on the declarations; SQL NULL, UNIQUE and bag semantics are not proofs of classical keys or lossless data migration." :: Text)])
|
||||
where
|
||||
-- 还原列类型及声明约束而不读取数据。
|
||||
column c = case parseColumnType (scType c) of
|
||||
Nothing -> Left ("storage_error", "normalization: invalid schema type")
|
||||
Just ty -> Right (scName c, Column ty (scNullable c) (scDefault c) (scAutoIncrement c) (scUnique c) (scPrimaryKey c) (scCheck c))
|
||||
|
||||
-- 规范化经验证的声明属性集合。
|
||||
canonicalDeclaration :: NormalizationDeclaration -> NormalizationDeclaration
|
||||
canonicalDeclaration d = d {ndKeys = sort (nub (map N.canonical (ndKeys d))),
|
||||
ndDependencies = [NormalizationDependency a b | (a, b) <- sort (nub [(N.canonical a, N.canonical b) | NormalizationDependency a b <- ndDependencies d])]}
|
||||
|
||||
-- 编码稳定范式标签及证据。
|
||||
findingJSON :: N.Finding -> A.Value
|
||||
findingJSON f = object ["normal_form" .= formTag (N.normalForm f), "verdict" .= verdictTag (N.verdict f),
|
||||
"witnesses" .= [NormalizationDependency a b | N.Dependency a b <- N.witnesses f], "condition" .= N.condition f]
|
||||
|
||||
-- 编码一次分解的理论结论。
|
||||
decompositionJSON :: N.Decomposition -> A.Value
|
||||
decompositionJSON d = object ["relations" .= N.relations d, "lossless_join" .= verdictTag (N.losslessJoin d), "dependency_preserving" .= verdictTag (N.dependencyPreserving d)]
|
||||
|
||||
-- 输出稳定的范式名称。
|
||||
formTag :: N.NormalForm -> Text
|
||||
formTag N.NF1 = "1nf"
|
||||
formTag N.NF2 = "2nf"
|
||||
formTag N.NF3 = "3nf"
|
||||
formTag N.BCNF = "bcnf"
|
||||
|
||||
-- 输出稳定的结论标签。
|
||||
verdictTag :: N.Verdict -> Text
|
||||
verdictTag N.Satisfied = "satisfied"
|
||||
verdictTag N.Violated = "violated"
|
||||
verdictTag N.Insufficient = "insufficient"
|
||||
@@ -2,8 +2,8 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChuSQL.Server.ObjectACL
|
||||
( objectAuthorize, objectGrant, objectRevoke, objectViews, objectClaim
|
||||
, objectReconcile, objectAffected, objectOwner, objectConnect, objectPrepareCreate, objectUsers
|
||||
( objectAuthorize, objectGrant, objectRevoke, objectRevokeGrantOption, objectViews, objectClaim
|
||||
, objectSelfViews, objectReconcile, objectAffected, objectOwner, objectConnect, objectPrepareCreate, objectUsers
|
||||
) where
|
||||
|
||||
import ChuSQL.Core.Protocol (Account (..), TableInfo (..))
|
||||
@@ -315,19 +315,28 @@ objectGrant backend catalog principal database names object role option = do
|
||||
|
||||
-- 撤销授权并收敛失去来源的下游授权。
|
||||
objectRevoke :: Backend -> Catalog -> Principal -> Text -> [Text] -> Text -> Text -> IO (Either String ())
|
||||
objectRevoke backend catalog principal database names object role = do
|
||||
objectRevoke = revokeObject False
|
||||
|
||||
-- 仅撤销转授权能力并清理失效来源。
|
||||
objectRevokeGrantOption :: Backend -> Catalog -> Principal -> Text -> [Text] -> Text -> Text -> IO (Either String ())
|
||||
objectRevokeGrantOption = revokeObject True
|
||||
|
||||
-- 按授予来源撤销权限或转授权能力。
|
||||
revokeObject :: Bool -> Backend -> Catalog -> Principal -> Text -> [Text] -> Text -> Text -> IO (Either String ())
|
||||
revokeObject optionOnly 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
|
||||
Right ((env, previous, acl), target) -> case (,,) <$> roleId env role <*> privileges target names <*> (if principalIsRoot principal then Right "0" else roleId env (principalName principal)) 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
|
||||
Right (recipient, items, grantor) -> do
|
||||
let 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}
|
||||
next = acl{aclEdges = if optionOnly then map removeOption (aclEdges acl) else filter (not . matches) (aclEdges acl), aclClosed = if not optionOnly && recipient == "public" && "connect" `elem` items then nub (targetDatabase target : aclClosed acl) else aclClosed acl}
|
||||
-- 保留基础权限并移除匹配来源的转授权。
|
||||
removeOption edge = if matches edge then edge{edgeOption = False} else edge
|
||||
if recipient == "public" && "connect" `elem` items && not manager then pure (Left "administrator required")
|
||||
else writeACL backend previous (effective env next)
|
||||
|
||||
@@ -341,6 +350,21 @@ objectViews backend catalog role = do
|
||||
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])
|
||||
|
||||
-- 列出当前身份实际拥有的对象权限。
|
||||
objectSelfViews :: Backend -> Catalog -> Principal -> IO (Either String [Grant])
|
||||
objectSelfViews backend catalog principal = do
|
||||
loaded <- load backend catalog
|
||||
pure $ do
|
||||
(env, _, acl) <- loaded
|
||||
identity <- roleId env (principalName principal)
|
||||
if active env identity then Right () else Left "permission denied: disabled identity"
|
||||
-- 使用当前权限闭包判断普通及转授权权限。
|
||||
let permitted target privilege option = principalIsRoot principal || allowed env acl identity target privilege option
|
||||
Right [Grant (principalName principal) privilege (targetName target) (permitted target privilege True)
|
||||
| target <- contextTargets env
|
||||
, privilege <- if targetKind target == "database" then ["connect", "create"] else ["select", "insert", "update", "delete"]
|
||||
, permitted target privilege False]
|
||||
|
||||
-- 登记新对象的创建者为所有者。
|
||||
objectClaim :: Backend -> Catalog -> Principal -> Text -> Text -> IO (Either String ())
|
||||
objectClaim backend catalog principal database object = do
|
||||
|
||||
@@ -2,7 +2,7 @@
|
||||
|
||||
module ChuSQL.Server.Privileges
|
||||
( Grant (..), Membership (..), PrivilegeCommand (..), PrivilegeError (..), Privileges, RoleView (..)
|
||||
, affectedAccounts, authorize, authorizeTables, authorizeConnect, filterTables, listRoleViews
|
||||
, affectedAccounts, authorize, authorizeTables, authorizeConnect, filterTables, listRoleViews, listSelfGrants
|
||||
, newPrivileges, normalizeObject, privilegeCommand, runPrivilegeCommand, claimObject, prepareObject, reconcileObjects, affectedObject
|
||||
) where
|
||||
|
||||
@@ -22,7 +22,7 @@ import qualified Data.Text as T
|
||||
data PrivilegeError = PrivilegeError Text Text deriving (Show, Eq)
|
||||
data Membership = Membership { memberRole :: Text, memberUser :: Text } deriving (Show, Eq, Ord)
|
||||
data PrivilegeCommand = CreateRoleCommand Text | DropRoleCommand Text
|
||||
| GrantPrivilegesCommand [Text] Text Text Bool | RevokePrivilegesCommand [Text] Text Text
|
||||
| GrantPrivilegesCommand [Text] Text Text Bool | RevokePrivilegesCommand [Text] Text Text | RevokeGrantOptionCommand [Text] Text Text
|
||||
| GrantRoleCommand Text [Text] | RevokeRoleCommand Text [Text] deriving (Show, Eq)
|
||||
data Privileges = Privileges { pvCatalog :: Catalog, pvBackend :: Backend }
|
||||
|
||||
@@ -38,6 +38,7 @@ privilegeCommand statement = case statement of
|
||||
CreateRole name -> Just (CreateRoleCommand (T.pack name))
|
||||
DropRole name -> Just (DropRoleCommand (T.pack name))
|
||||
GrantPrivileges items object role option -> Just (GrantPrivilegesCommand (map (T.toLower . T.pack) items) (T.pack object) (T.pack role) option)
|
||||
RevokeGrantOption items object role -> Just (RevokeGrantOptionCommand (map (T.toLower . T.pack) items) (T.pack object) (T.pack role))
|
||||
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))
|
||||
@@ -47,6 +48,7 @@ privilegeCommand statement = case statement of
|
||||
runPrivilegeCommand :: Privileges -> Principal -> Text -> PrivilegeCommand -> IO (Either PrivilegeError ())
|
||||
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)
|
||||
RevokeGrantOptionCommand items object role -> catalog (OA.objectRevokeGrantOption backend directory principal database items object role)
|
||||
RevokePrivilegesCommand items object role -> catalog (OA.objectRevoke backend directory principal database items object role)
|
||||
CreateRoleCommand role
|
||||
| principalIsCatalogManager principal -> do
|
||||
@@ -106,6 +108,7 @@ affectedAccounts service command = withTables service (catalog (OA.objectAffecte
|
||||
CreateRoleCommand _ -> []
|
||||
DropRoleCommand role -> [role]
|
||||
GrantPrivilegesCommand _ _ role _ -> [role]
|
||||
RevokeGrantOptionCommand _ _ role -> [role]
|
||||
RevokePrivilegesCommand _ _ role -> [role]
|
||||
GrantRoleCommand _ members -> members
|
||||
RevokeRoleCommand _ members -> members
|
||||
@@ -195,6 +198,7 @@ reconcileObjects service = withTables service (catalog (OA.objectReconcile (pvBa
|
||||
-- 收集数据语句及子查询所需的表权限。
|
||||
requiredActions :: Statement -> Maybe [(Text, Text)]
|
||||
requiredActions statement = case statement of
|
||||
SelectDistinct q -> requiredActions q
|
||||
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))
|
||||
@@ -231,3 +235,7 @@ storageError message = PrivilegeError code (T.pack message)
|
||||
|
||||
forbidden :: PrivilegeError
|
||||
forbidden = PrivilegeError "forbidden" "administrator required"
|
||||
|
||||
-- 查询登录身份自己的有效权限。
|
||||
listSelfGrants :: Privileges -> Principal -> IO (Either PrivilegeError [Grant])
|
||||
listSelfGrants service principal = withTables service (catalog (OA.objectSelfViews (pvBackend service) (pvCatalog service) principal))
|
||||
@@ -18,6 +18,7 @@ module ChuSQL.Server.Session
|
||||
, runStatement
|
||||
, runStatementCoded
|
||||
, runStorageCoded
|
||||
, analyzeNormalizationCoded
|
||||
, catalog
|
||||
, accounts
|
||||
, roleViews
|
||||
@@ -27,7 +28,12 @@ module ChuSQL.Server.Session
|
||||
, queryResultJson
|
||||
) where
|
||||
|
||||
import ChuSQL.Core.Model (Database, Row, Table (..), Value (..))
|
||||
import ChuSQL.Core.Model (Database, Row, Table (..), Value (..), Column (..), typeName)
|
||||
import ChuSQL.Core.Protocol (SchemaColumn (..))
|
||||
import ChuSQL.Interface.Normalization
|
||||
import ChuSQL.Server.Normalization (normalizationBudget, normalizationReport)
|
||||
import Data.Aeson.Types (parseEither)
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import ChuSQL.Core.Protocol (Account (..), Request (..), QueryResult (..), TxnOp (..), queryResultJson)
|
||||
import ChuSQL.Core.Engine.Storage.IPC (TableInfo (..))
|
||||
import qualified ChuSQL.Core.Engine as Engine
|
||||
@@ -39,7 +45,7 @@ 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, affectedObject, authorize, authorizeConnect, claimObject, prepareObject, reconcileObjects, filterTables, listRoleViews, newPrivileges, privilegeCommand, runPrivilegeCommand)
|
||||
import ChuSQL.Server.Privileges (PrivilegeCommand (..), PrivilegeError (..), Privileges, RoleView, Grant (..), affectedAccounts, affectedObject, authorize, authorizeTables, authorizeConnect, claimObject, prepareObject, reconcileObjects, filterTables, listRoleViews, listSelfGrants, newPrivileges, privilegeCommand, runPrivilegeCommand)
|
||||
import ChuSQL.Server.Security (readSecurity, writeSecurity)
|
||||
import Control.Exception (IOException, try)
|
||||
import Data.Bifunctor (first)
|
||||
@@ -280,6 +286,7 @@ runStatementUnlocked session sql = case parseStatement (T.unpack sql) of
|
||||
Right (Savepoint name) -> savepointTransaction session (T.pack name)
|
||||
Right (RollbackToSavepoint name) -> rollbackToSavepoint session (T.pack name)
|
||||
Right (ReleaseSavepoint name) -> releaseSavepoint session (T.pack name)
|
||||
Right ShowGrants -> showSelfGrants session
|
||||
Right ShowRoles -> showIdentities session
|
||||
Right statement
|
||||
| Just command <- accountCommand statement -> runAccount session command
|
||||
@@ -319,6 +326,7 @@ transactionDdl statement = case statement of
|
||||
-- | 事务里只有数据语句走快照
|
||||
transactionData :: Statement -> Bool
|
||||
transactionData statement = case statement of
|
||||
SelectDistinct q -> transactionData q
|
||||
Select{} -> True
|
||||
SelectExpr{} -> True
|
||||
Insert{} -> True
|
||||
@@ -840,3 +848,72 @@ resultOf result =
|
||||
-- | 按列名取单元格
|
||||
cellOf row name = maybe VNull id (lookup name row)
|
||||
|
||||
|
||||
-- 展示当前登录身份自己的有效权限。
|
||||
showSelfGrants :: Session -> IO (Either SessionError QueryResult)
|
||||
showSelfGrants session = do
|
||||
who <- readIORef (ssPrincipal session)
|
||||
case who of
|
||||
Nothing -> pure (Left (SessionError "unauthorized" "sign in first"))
|
||||
Just principal -> do
|
||||
grants <- listSelfGrants (ssPrivileges session) principal
|
||||
pure $ case grants of
|
||||
Left err -> Left (privilegeErrorOf err)
|
||||
Right rows -> Right (QueryResult ["identity", "privilege", "object", "grant_option"]
|
||||
[[VStr (T.unpack (grantRole grant)), VStr (T.unpack (grantPrivilege grant)), VStr (T.unpack (grantObject grant)), VBool (grantable grant)] | grant <- rows]
|
||||
(length rows) False Nothing)
|
||||
|
||||
|
||||
-- 在连接视图及权限稳定期间分析范式。
|
||||
analyzeNormalizationCoded :: Session -> NormalizationRequest -> IO (Either SessionError A.Value)
|
||||
analyzeNormalizationCoded session payload = do
|
||||
result <- normalizationBudget $ readSecurity $ do
|
||||
valid <- validatePrincipal session
|
||||
current <- readIORef (ssCurrent session)
|
||||
who <- readIORef (ssPrincipal session)
|
||||
let table = last (T.splitOn "." (nrTable payload))
|
||||
case (valid, who, A.fromJSON (A.toJSON payload) :: A.Result NormalizationRequest) of
|
||||
(Left err, _, _) -> pure (Left (sessCode err, sessMessage err))
|
||||
(_, Nothing, _) -> pure (Left ("unauthorized", "sign in first"))
|
||||
(_, _, A.Error message) -> pure (Left ("bad_request", T.pack message))
|
||||
(_, Just principal, A.Success _)
|
||||
| BL.length (A.encode payload) > 65000 -> pure (Left ("too_large", "normalization request exceeds transport budget"))
|
||||
| current /= nrDatabase payload -> pure (Left ("bad_request", "normalization database differs from the selected database"))
|
||||
| current == "system" || "__system_" `T.isPrefixOf` table -> pure (Left ("forbidden", "normalization does not expose system objects"))
|
||||
| otherwise -> do
|
||||
allowed <- authorizeTables (ssPrivileges session) principal current [(table, "select")]
|
||||
case allowed of
|
||||
Left (PrivilegeError code message) -> pure (Left (code, message))
|
||||
Right () -> normalizationView session table payload
|
||||
pure (either (Left . uncurry SessionError) Right result)
|
||||
|
||||
-- 读取目录结构或当前连接的事务 schema。
|
||||
normalizationView :: Session -> Text -> NormalizationRequest -> IO (Either (Text, Text) A.Value)
|
||||
normalizationView session table payload = do
|
||||
live <- snapshotObjectIds session [T.unpack table]
|
||||
transaction <- readIORef (ssTransaction session)
|
||||
case live >>= maybe (Left (SessionError "not_found" "unknown table")) Right . lookup (T.unpack table) of
|
||||
Left err -> pure (Left (sessCode err, sessMessage err))
|
||||
Right object -> case objectIdentity object of
|
||||
Left message -> pure (Left ("storage_error", message))
|
||||
Right identity -> case transaction of
|
||||
Just tx -> case (lookup (T.unpack table) (txStaged tx), lookup (T.unpack table) (txObjects tx)) of
|
||||
(Just relation, Just oldObject) | objectIdentity oldObject == Right identity ->
|
||||
pure (normalizationReport identity (map normalizationColumn (tableCols relation)) "transaction_snapshot" payload)
|
||||
_ -> pure (Left ("conflict", "normalization snapshot object has changed"))
|
||||
Nothing -> do
|
||||
backend <- currentBackend session
|
||||
infos <- beCatalog backend
|
||||
pure $ case infos of
|
||||
Left message -> Left ("storage_error", T.pack message)
|
||||
Right relations -> case [tiColumns info | info <- relations, tiTable info == T.unpack table] of
|
||||
[columns] -> normalizationReport identity columns "live_schema" payload
|
||||
_ -> Left ("not_found", "unknown table")
|
||||
|
||||
-- 从目录响应中只取稳定编号。
|
||||
objectIdentity :: A.Value -> Either Text ObjectIdentity
|
||||
objectIdentity = first T.pack . parseEither (A.withObject "catalog object" $ \o -> ObjectIdentity <$> o A..: "database_id" <*> o A..: "object_id")
|
||||
|
||||
-- 将事务 schema 转成同一线上列结构。
|
||||
normalizationColumn :: (String, Column) -> SchemaColumn
|
||||
normalizationColumn (name, c) = SchemaColumn name (typeName (columnType c)) (columnNullable c) (columnDefault c) (columnAutoIncrement c) (columnPrimaryKey c) (columnUnique c) (columnCheck c)
|
||||
@@ -23,7 +23,7 @@ import ChuSQL.Interface.RateLimit (RateLimiter, rateLimitBlock, rateLimitClear,
|
||||
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, authenticateSudoSessionCoded, isPlainIdentifier, catalog, databases, newSessionWith, policyOf, reloadPolicy, roleViews, runStatementCoded, runStorageCoded, sessionIsAdmin, sessionUser)
|
||||
import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), accounts, authenticateSessionCoded, authenticateSudoSessionCoded, isPlainIdentifier, catalog, databases, newSessionWith, policyOf, reloadPolicy, roleViews, analyzeNormalizationCoded, runStatementCoded, runStorageCoded, sessionIsAdmin, sessionUser)
|
||||
import ChuSQL.Server.Security (writeSecurity)
|
||||
import ChuSQL.Server.Privileges (newPrivileges, reconcileObjects)
|
||||
import Control.Concurrent (forkIO)
|
||||
@@ -331,6 +331,9 @@ dispatch env session entry request = case request of
|
||||
ReqSudoLogin user proof -> do
|
||||
response <- sudoLogin env session entry user proof
|
||||
pure (response, True)
|
||||
ReqNormalization payload -> do
|
||||
result <- analyzeNormalizationCoded session payload
|
||||
pure (either (\err -> RespError (sessCode err) (sessMessage err)) RespNormalization result, True)
|
||||
ReqQuery sql -> do
|
||||
who <- sessionUser session
|
||||
response <- case who of
|
||||
|
||||
+242
-9
@@ -12,11 +12,14 @@ import ChuSQL.Core.Engine.Storage.IPC (
|
||||
setStorageLink,
|
||||
)
|
||||
import ChuSQL.Core.Engine.Syntax.AST (Statement)
|
||||
import ChuSQL.Interface.Normalization
|
||||
import ChuSQL.Server.Normalization (normalizationBudget, normalizationReport, schemaFingerprint)
|
||||
import ChuSQL.Core.Protocol (SchemaColumn (..))
|
||||
import Data.IORef (newIORef, readIORef, writeIORef)
|
||||
import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
|
||||
import ChuSQL.Core.Model (Database, Histogram (..), Row, Table (..), Value (..), pattern TInt, pattern TStr)
|
||||
import ChuSQL.Core.Model (Database, Histogram (..), Row, Table (..), TableIdentity (..), Value (..), pattern TInt, pattern TStr)
|
||||
import ChuSQL.Interface.Auth (hashPasswordWith)
|
||||
import ChuSQL.Interface.Protocol (ClientRequest (..), Grant (..), RoleView (..), ServerResponse (..), decodeRequest, encodeResponse)
|
||||
import ChuSQL.Interface.Protocol (ClientRequest (..), Grant (..), RoleView (..), ServerResponse (..), decodeRequest, encodeResponse, encodeRequest, decodeResponse)
|
||||
import ChuSQL.Interface.RateLimit (newRateLimiter)
|
||||
import ChuSQL.Interface.Link (connectClient, closeClient, clientSudoLogin, clientQuery)
|
||||
import ChuSQL.Interface.Sudo (SudoCredential, newSudoCredential, sudoProof, verifySudoProof, validSudoChallenge,
|
||||
@@ -33,6 +36,7 @@ import ChuSQL.Server.Privileges (
|
||||
claimObject,
|
||||
prepareObject,
|
||||
listRoleViews,
|
||||
listSelfGrants,
|
||||
newPrivileges,
|
||||
runPrivilegeCommand,
|
||||
)
|
||||
@@ -47,7 +51,7 @@ import ChuSQL.Server.TCP (
|
||||
startServer,
|
||||
isLocalPeer,
|
||||
)
|
||||
import Control.Concurrent (forkIO, threadDelay)
|
||||
import Control.Concurrent (forkIO, forkFinally, killThread, threadDelay)
|
||||
import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, takeMVar)
|
||||
import System.Timeout (timeout)
|
||||
import Control.Exception (IOException, bracket, finally, try)
|
||||
@@ -64,7 +68,7 @@ import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
import Data.Time.Clock (addUTCTime, getCurrentTime)
|
||||
import Data.Time.Clock (addUTCTime, diffUTCTime, getCurrentTime)
|
||||
import Network.Socket (
|
||||
AddrInfo (..),
|
||||
SockAddr (..),
|
||||
@@ -105,6 +109,7 @@ main = hspec spec
|
||||
-- | 全部用例
|
||||
spec :: Spec
|
||||
spec = do
|
||||
normalizationSpec
|
||||
describe "sudo authentication" $ do
|
||||
it "defaults to disabled and rejects unconfigured TCP authentication" $
|
||||
withTcpServer defaultServerConfig $ \_ handle -> withConnection handle $ \client -> do
|
||||
@@ -380,14 +385,14 @@ testDb =
|
||||
[ [("id", VInt i), ("name", VStr ("user" ++ show i)), ("age", VInt (20 + i))]
|
||||
| i <- [1 .. 5]
|
||||
]
|
||||
Nothing
|
||||
Nothing Nothing Nothing
|
||||
)
|
||||
, ( "orders"
|
||||
, Table
|
||||
"orders"
|
||||
[("id", TInt), ("user_id", TInt)]
|
||||
[[("id", VInt 1), ("user_id", VInt 1)]]
|
||||
Nothing
|
||||
Nothing Nothing Nothing
|
||||
)
|
||||
]
|
||||
|
||||
@@ -1125,6 +1130,44 @@ withObjectPrivileges body = do
|
||||
-- 验证对象作用域、授权来源和外部入口。
|
||||
objectPrivilegeSpec :: Spec
|
||||
objectPrivilegeSpec = describe "stable object privileges" $ do
|
||||
it "lists only the caller's effective grants including roles and PUBLIC" $ withObjectPrivileges $ \backend service root -> do
|
||||
runPrivilegeCommand service root testDatabase (CreateRoleCommand "self_reader") `shouldReturn` Right ()
|
||||
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "self_reader" True) `shouldReturn` Right ()
|
||||
runPrivilegeCommand service root testDatabase (GrantRoleCommand "self_reader" ["alice"]) `shouldReturn` Right ()
|
||||
grants <- listSelfGrants service (Ordinary testAccount)
|
||||
grants `shouldSatisfy` either (const False) (elem (Grant "alice" "select" "test.users" True))
|
||||
grants `shouldSatisfy` either (const False) (elem (Grant "alice" "connect" "database:test" False))
|
||||
grants `shouldSatisfy` either (const False) (all ((== "alice") . grantRole))
|
||||
runPrivilegeCommand service root testDatabase (RevokePrivilegesCommand ["select"] "users" "self_reader") `shouldReturn` Right ()
|
||||
after <- listSelfGrants service (Ordinary testAccount)
|
||||
after `shouldSatisfy` either (const False) (not . any ((== "test.users") . grantObject))
|
||||
_ <- beAccounts backend (ReqAccountReset "alice" (testPasswordHash "Alice-Secret-1234"))
|
||||
_ <- beAccounts backend (ReqAccountCreate testRootName (testPasswordHash testRootPassword))
|
||||
_ <- beAccounts backend (ReqIdentityAlter testRootName Nothing (Just True) Nothing Nothing Nothing)
|
||||
settings <- tempSettingsPath "self-grants"
|
||||
session <- newSession backend testRootName settings
|
||||
authenticateSessionCoded session "alice" "Alice-Secret-1234" `shouldReturn` Right ()
|
||||
result <- mustSql session "SHOW GRANTS"
|
||||
qrColumns result `shouldBe` ["identity", "privilege", "object", "grant_option"]
|
||||
qrRows result `shouldSatisfy` all (\row -> take 1 row == [VStr "alice"])
|
||||
rejected <- runStatementCoded session "SHOW GRANTS FOR admin"
|
||||
rejected `shouldSatisfy` either (const True) (const False)
|
||||
it "includes ownership permissions and excludes ungranted tables" $ withObjectPrivileges $ \backend service _ -> do
|
||||
mustRun (beStatement (beWithDatabase backend "test") "CREATE TABLE personal_owned (id INT)")
|
||||
claimObject service (Ordinary testAccount) testDatabase "personal_owned" `shouldReturn` Right ()
|
||||
grants <- listSelfGrants service (Ordinary testAccount)
|
||||
fmap (filter ((== "test.personal_owned") . grantObject)) grants `shouldBe` Right
|
||||
[Grant "alice" privilege "test.personal_owned" True | privilege <- ["select", "insert", "update", "delete"]]
|
||||
grants `shouldSatisfy` either (const False) (not . any ((== "test.users") . grantObject))
|
||||
|
||||
it "checks DISTINCT table reads and nested subqueries" $ withObjectPrivileges $ \_ service root -> do
|
||||
authorizeSql service (Ordinary testAccount) "SELECT DISTINCT age FROM users"
|
||||
`shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
|
||||
authorizeSql service (Ordinary testAccount) "SELECT DISTINCT d.age FROM (SELECT DISTINCT age FROM users) d"
|
||||
`shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
|
||||
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" False) `shouldReturn` Right ()
|
||||
authorizeSql service (Ordinary testAccount) "SELECT DISTINCT age FROM users" `shouldReturn` Right ()
|
||||
|
||||
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))")
|
||||
@@ -1204,6 +1247,41 @@ objectPrivilegeSpec = describe "stable object privileges" $ do
|
||||
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 "executes grant option revocation over TCP and keeps SELECT" $
|
||||
withTcpServer defaultServerConfig $ \_ handle -> withConnection handle $ \admin -> do
|
||||
_ <- tcpLogin admin "admin" "s3cret"
|
||||
_ <- tcpQuery admin "USE test"
|
||||
_ <- tcpQuery admin "CREATE USER option_reader IDENTIFIED BY 'Option-Reader-1234'"
|
||||
tcpQuery admin "GRANT SELECT ON users TO option_reader WITH GRANT OPTION" >>= \reply -> at "status" reply `shouldBe` A.String "result"
|
||||
tcpQuery admin "REVOKE GRANT OPTION FOR SELECT ON users FROM option_reader" >>= \reply -> at "status" reply `shouldBe` A.String "result"
|
||||
withConnection handle $ \reader -> do
|
||||
_ <- tcpLogin reader "option_reader" "Option-Reader-1234"
|
||||
_ <- tcpQuery reader "USE test"
|
||||
tcpQuery reader "SELECT DISTINCT age FROM users ORDER BY 1" >>= \reply -> at "status" reply `shouldBe` A.String "result"
|
||||
tcpQuery reader "SHOW GRANTS" >>= \reply -> at "status" reply `shouldBe` A.String "result"
|
||||
tcpQuery reader "GRANT SELECT ON users TO admin" >>= \reply -> at "code" reply `shouldBe` A.String "forbidden"
|
||||
it "revokes grant option while preserving data access and independent sources" $ 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" "carol" False) `shouldReturn` Right ()
|
||||
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "carol" False) `shouldReturn` Right ()
|
||||
affectedAccounts service (RevokeGrantOptionCommand ["select"] "users" "alice") `shouldReturn` Right ["alice", "bob", "carol"]
|
||||
runPrivilegeCommand service root testDatabase (RevokeGrantOptionCommand ["select"] "users" "alice") `shouldReturn` Right ()
|
||||
authorizeSql service (Ordinary testAccount) "SELECT * FROM users" `shouldReturn` Right ()
|
||||
grants <- listSelfGrants service (Ordinary testAccount)
|
||||
grants `shouldSatisfy` either (const False) (elem (Grant "alice" "select" "test.users" False))
|
||||
authorizeSql service (Ordinary testAccount{accountUser = "bob"}) "SELECT * FROM users"
|
||||
`shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
|
||||
authorizeSql service (Ordinary testAccount{accountUser = "carol"}) "SELECT * FROM users" `shouldReturn` Right ()
|
||||
runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" False)
|
||||
`shouldReturn` Left (PrivilegeError "forbidden" "grant option required: SELECT ON users")
|
||||
it "revokes only the caller's grant option source" $ withObjectPrivileges $ \_ service root -> do
|
||||
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" True) `shouldReturn` Right ()
|
||||
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" True) `shouldReturn` Right ()
|
||||
runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" True) `shouldReturn` Right ()
|
||||
runPrivilegeCommand service (Ordinary testAccount) testDatabase (RevokeGrantOptionCommand ["select"] "users" "bob") `shouldReturn` Right ()
|
||||
grants <- listSelfGrants service (Ordinary testAccount{accountUser = "bob"})
|
||||
grants `shouldSatisfy` either (const False) (elem (Grant "bob" "select" "test.users" True))
|
||||
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 ()
|
||||
@@ -1436,6 +1514,17 @@ intValues rows = [n | row <- rows, Just (VInt n) <- [nth 0 row]]
|
||||
-- | 显式事务用例
|
||||
transactionSpec :: Spec
|
||||
transactionSpec = describe "server transactions" $ do
|
||||
it "executes DISTINCT against the connection snapshot with output columns" $ withMemorySession $ \session -> do
|
||||
_ <- mustSql session "CREATE TABLE distinct_values (id INT, value INT)"
|
||||
_ <- mustSql session "INSERT INTO distinct_values (id,value) VALUES (1,7),(2,7),(3,8)"
|
||||
_ <- mustSql session "BEGIN"
|
||||
_ <- mustSql session "UPDATE distinct_values SET value = 9 WHERE id = 3"
|
||||
result <- mustSql session "SELECT DISTINCT value FROM distinct_values ORDER BY 1"
|
||||
qrColumns result `shouldBe` ["value"]
|
||||
qrRows result `shouldBe` [[VInt 7], [VInt 9]]
|
||||
_ <- mustSql session "ROLLBACK"
|
||||
pure ()
|
||||
|
||||
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]]
|
||||
@@ -1458,8 +1547,8 @@ transactionSpec = describe "server transactions" $ do
|
||||
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
|
||||
let local = Table "users" [("id", TInt)] [[("id", VInt 1)]] Nothing Nothing Nothing
|
||||
otherTable = Table "users" [("id", TInt)] [[("id", VInt 2)]] Nothing Nothing Nothing
|
||||
ref <- newMVar [("test.users", local), ("other.users", otherTable)]
|
||||
let backend = memoryBackend "test" ref
|
||||
selected <- beStatement backend "SELECT id FROM users"
|
||||
@@ -1470,11 +1559,36 @@ transactionSpec = describe "server transactions" $ do
|
||||
fmap (const ()) updated `shouldBe` Right ()
|
||||
snapshot <- beSnapshot (memoryBackend "other" ref)
|
||||
fmap (map (tableRows . snd)) snapshot `shouldBe` Right [[[ ("id", VInt 2) ]]]
|
||||
it "keeps catalog and snapshot identities stable across system views and replacements" $ do
|
||||
ref <- newMVar [("test.users", Table "users" [("id", TInt)] [] Nothing Nothing Nothing)]
|
||||
let backend = memoryBackend "test" ref
|
||||
first <- beCatalog backend
|
||||
fmap (map tiIdentity) first `shouldBe` Right [Just (TableIdentity 1 1)]
|
||||
_ <- beSnapshot (beWithDatabase backend "system")
|
||||
saved <- beSnapshot backend
|
||||
fmap (map (tableIdentity . snd)) saved `shouldBe` Right [Just (TableIdentity 1 1)]
|
||||
mustRun (beStatement backend "DROP TABLE users")
|
||||
mustRun (beStatement backend "CREATE TABLE users (id INT)")
|
||||
replaced <- beCatalog backend
|
||||
fmap (map tiIdentity) replaced `shouldBe` Right [Just (TableIdentity 1 2)]
|
||||
it "preserves memory schema versions in catalogs and snapshots" $ do
|
||||
ref <- newMVar []
|
||||
let backend = memoryBackend "test" ref
|
||||
fmap (const ()) <$> beStatement backend "CREATE TABLE versioned (id INT)" `shouldReturn` Right ()
|
||||
first <- beCatalog backend
|
||||
fmap (map tiSchemaVersion) first `shouldBe` Right [Just 1]
|
||||
fmap (const ()) <$> beStatement backend "ALTER TABLE versioned ADD COLUMN extra TEXT" `shouldReturn` Right ()
|
||||
fmap (const ()) <$> beStatement backend "ALTER TABLE versioned DROP COLUMN extra" `shouldReturn` Right ()
|
||||
current <- beCatalog backend
|
||||
snapshot <- beSnapshot backend
|
||||
fmap (map tiSchemaVersion) current `shouldBe` Right [Just 3]
|
||||
fmap (map (tableSchemaVersion . snd)) snapshot `shouldBe` Right [Just 3]
|
||||
it "rejects cross-database reads and writes including nested queries" $ withMemorySession $ \session -> do
|
||||
mapM_ (\query -> do
|
||||
result <- runStatementCoded session query
|
||||
failureMessage result `shouldSatisfy` T.isInfixOf "outside the current database")
|
||||
[ "SELECT * FROM other.users"
|
||||
[ "SELECT DISTINCT age FROM other.users"
|
||||
, "SELECT * FROM other.users"
|
||||
, "UPDATE other.users SET age = 1"
|
||||
, "DELETE FROM other.users"
|
||||
, "INSERT INTO other.users (id) VALUES (99)"
|
||||
@@ -1962,3 +2076,122 @@ checkSudoDisabled admin handle credential sql = do
|
||||
isRightResult :: Either a b -> Bool
|
||||
isRightResult (Right _) = True
|
||||
isRightResult _ = False
|
||||
|
||||
|
||||
-- 专用范式协议、权限、快照与预算回归。
|
||||
normalizationSpec :: Spec
|
||||
normalizationSpec = describe "normalization endpoint" $ do
|
||||
it "round-trips versioned requests and rejects unknown and duplicate fields" $ do
|
||||
decodeRequest (BL.toStrict (encodeRequest (ReqNormalization normalizationPayload))) `shouldBe` Right (ReqNormalization normalizationPayload)
|
||||
let large = ObjectIdentity 9007199254740993 18446744073709551615
|
||||
A.fromJSON (A.toJSON large) `shouldBe` A.Success large
|
||||
case A.eitherDecode "{\"database_id\":1e1000000000,\"object_id\":2}" :: Either String A.Value of
|
||||
Left message -> expectationFailure message
|
||||
Right value -> (A.fromJSON value :: A.Result ObjectIdentity) `shouldSatisfy` isJSONFailure
|
||||
|
||||
report <- either (fail . show) pure (normalizationReport (ObjectIdentity 1 2) [SchemaColumn name "int" True Nothing False False False Nothing | name <- ["id", "name", "age"]] "live_schema" normalizationPayload)
|
||||
let response = RespNormalization report
|
||||
decodeResponse (encodeResponse response) `shouldBe` Right response
|
||||
decodeResponse (encodeResponse (RespNormalization (A.object ["conditional" A..= True]))) `shouldSatisfy` either (const True) (const False)
|
||||
mapM_ (\raw -> decodeNormalizationJSON raw `shouldSatisfy` either (T.isInfixOf "duplicate") (const False))
|
||||
[ "{\"a\":1,\"a\":2}", "{\"a\":1,\"\\u0061\":2}", "{\"a\":[{\"b\":1,\"b\":2}]}" ]
|
||||
let unknown = A.object ["api_version" A..= (1 :: Int), "database" A..= ("test" :: Text), "table" A..= ("users" :: Text), "declaration" A..= nrDeclaration normalizationPayload, "ignored" A..= True]
|
||||
(A.fromJSON unknown :: A.Result NormalizationRequest) `shouldSatisfy` isJSONFailure
|
||||
decodeRequest (BL.toStrict (encodeRequest (ReqNormalization normalizationPayload{nrVersion = 2}))) `shouldSatisfy` either (const True) (const False)
|
||||
decodeRequest (BL.toStrict (encodeRequest (ReqNormalization normalizationPayload{nrTable = "other.users"}))) `shouldSatisfy` either (const True) (const False)
|
||||
it "does not infer completeness or atomicity and validates declaration budgets" $ do
|
||||
(A.fromJSON (A.object []) :: A.Result NormalizationDeclaration) `shouldBe` A.Success (NormalizationDeclaration [] [] False Nothing)
|
||||
let many = NormalizationDeclaration (replicate 257 ["id"]) [] True (Just True)
|
||||
(A.fromJSON (A.toJSON many) :: A.Result NormalizationDeclaration) `shouldSatisfy` isJSONFailure
|
||||
decodeNormalizationJSON (BL.replicate 65537 32) `shouldSatisfy` either (const True) (const False)
|
||||
(A.fromJSON (A.object ["dependencies" A..= [A.object ["lhs" A..= (["id"] :: [Text]), "rhs" A..= ([] :: [Text])]]]) :: A.Result NormalizationDeclaration) `shouldSatisfy` isJSONFailure
|
||||
it "authorizes ordinary SELECT users and refuses anonymous or system requests" $
|
||||
withTcpServer defaultServerConfig $ \_ handle -> withConnection handle $ \admin -> do
|
||||
anonymous <- tcpTalk admin (BL.toStrict (encodeRequest (ReqNormalization normalizationPayload)))
|
||||
at "code" anonymous `shouldBe` A.String "unauthorized"
|
||||
_ <- tcpLogin admin "admin" "s3cret"
|
||||
_ <- tcpQuery admin "USE test"
|
||||
_ <- tcpQuery admin "CREATE USER normalization_reader IDENTIFIED BY 'Reader-Secret-1234'"
|
||||
withConnection handle $ \reader -> do
|
||||
_ <- tcpLogin reader "normalization_reader" "Reader-Secret-1234"
|
||||
_ <- tcpQuery reader "USE test"
|
||||
denied <- tcpTalk reader (BL.toStrict (encodeRequest (ReqNormalization normalizationPayload)))
|
||||
at "code" denied `shouldBe` A.String "forbidden"
|
||||
_ <- tcpQuery admin "GRANT SELECT ON users TO normalization_reader"
|
||||
withConnection handle $ \reader -> do
|
||||
_ <- tcpLogin reader "normalization_reader" "Reader-Secret-1234"
|
||||
_ <- tcpQuery reader "USE test"
|
||||
reply <- tcpTalk reader (BL.toStrict (encodeRequest (ReqNormalization normalizationPayload)))
|
||||
at "status" reply `shouldBe` A.String "normalization"
|
||||
at "conditional" (at "analysis" reply) `shouldBe` A.Bool True
|
||||
length (items (at "findings" (at "analysis" reply))) `shouldBe` 4
|
||||
denied <- tcpTalk reader (BL.toStrict (encodeRequest (ReqNormalization normalizationPayload{nrTable = "__system_domain_secret"})))
|
||||
at "code" denied `shouldBe` A.String "forbidden"
|
||||
it "uses only the caller snapshot and refuses stable object replacement" $
|
||||
withTcpServer defaultServerConfig $ \_ handle -> withConnection handle $ \first -> withConnection handle $ \second -> do
|
||||
_ <- tcpLogin first "admin" "s3cret"
|
||||
_ <- tcpLogin second "admin" "s3cret"
|
||||
_ <- tcpQuery first "USE test"
|
||||
_ <- tcpQuery second "USE test"
|
||||
_ <- tcpQuery first "CREATE TABLE normalization_snapshot (id INT, value INT)"
|
||||
_ <- tcpQuery first "BEGIN"
|
||||
_ <- tcpQuery second "ALTER TABLE normalization_snapshot ADD COLUMN added INT"
|
||||
let payload = normalizationPayload{nrTable = "normalization_snapshot", nrDeclaration = NormalizationDeclaration [] [] False Nothing}
|
||||
old <- tcpTalk first (BL.toStrict (encodeRequest (ReqNormalization payload)))
|
||||
current <- tcpTalk second (BL.toStrict (encodeRequest (ReqNormalization payload)))
|
||||
at "view" (at "analysis" old) `shouldBe` A.String "transaction_snapshot"
|
||||
length (items (at "schema" (at "analysis" old))) `shouldBe` 2
|
||||
length (items (at "schema" (at "analysis" current))) `shouldBe` 3
|
||||
at "schema_fingerprint" (at "analysis" old) `shouldNotBe` at "schema_fingerprint" (at "analysis" current)
|
||||
_ <- tcpQuery second "DROP TABLE normalization_snapshot"
|
||||
_ <- tcpQuery second "CREATE TABLE normalization_snapshot (id INT, value INT)"
|
||||
stale <- tcpTalk first (BL.toStrict (encodeRequest (ReqNormalization payload)))
|
||||
at "code" stale `shouldBe` A.String "conflict"
|
||||
_ <- tcpQuery first "ROLLBACK"
|
||||
pure ()
|
||||
it "checks expected schema fingerprints and budgets the complete output" $ do
|
||||
let columns = [SchemaColumn ("c" ++ show n) "int" True Nothing False False False Nothing | n <- [0 .. 9 :: Int]]
|
||||
payload = normalizationPayload{nrDeclaration = NormalizationDeclaration [] [NormalizationDependency [] ["c9"]] True (Just True)}
|
||||
schemaFingerprint (ObjectIdentity 1 2) columns `shouldNotBe` schemaFingerprint (ObjectIdentity 1 3) columns
|
||||
normalizationReport (ObjectIdentity 1 2) columns "live_schema" payload{nrExpectedSchema = Just "outdated"}
|
||||
`shouldBe` Left ("conflict", "normalization object or schema has changed")
|
||||
result <- normalizationBudget (pure (normalizationReport (ObjectIdentity 1 2) columns "live_schema" payload))
|
||||
result `shouldSatisfy` either ((== "too_large") . fst) (const False)
|
||||
it "bounds the largest schema with maximum declared dependencies" $ do
|
||||
let columns = [SchemaColumn ("c" ++ show n) "int" True Nothing False False False Nothing | n <- [0 .. 11 :: Int]]
|
||||
payload = normalizationPayload{nrDeclaration = NormalizationDeclaration [] (replicate 256 (NormalizationDependency [] ["c11"])) True (Just True)}
|
||||
started <- getCurrentTime
|
||||
result <- normalizationBudget (pure (normalizationReport (ObjectIdentity 1 2) columns "live_schema" payload))
|
||||
ended <- getCurrentTime
|
||||
putStrLn ("normalization maximum input seconds: " ++ show (ended `diffUTCTime` started))
|
||||
result `shouldSatisfy` either ((`elem` ["too_large", "timeout"]) . fst) (const False)
|
||||
normalizationBudget (pure (Right A.Null)) `shouldReturn` Right A.Null
|
||||
it "releases admission and execution slots after cancellation" $ do
|
||||
started <- newEmptyMVar
|
||||
blocker <- newEmptyMVar
|
||||
done <- newEmptyMVar
|
||||
worker <- forkFinally (normalizationBudget (putMVar started () >> takeMVar blocker >> pure (Right A.Null))) (putMVar done)
|
||||
takeMVar started
|
||||
killThread worker
|
||||
takeMVar done >>= either (const (pure ())) (const (expectationFailure "cancelled analysis completed"))
|
||||
ready <- newEmptyMVar
|
||||
release <- newEmptyMVar
|
||||
finished <- newEmptyMVar
|
||||
replicateM_ 2 (void (forkFinally (normalizationBudget (putMVar ready () >> takeMVar release >> pure (Right A.Null))) (putMVar finished)))
|
||||
mapM_ (\_ -> timeout 1000000 (takeMVar ready) >>= (`shouldBe` Just ())) [1, 2 :: Int]
|
||||
replicateM_ 2 (putMVar release ())
|
||||
replicateM_ 2 (takeMVar finished >>= either (expectationFailure . show) (`shouldBe` Right A.Null))
|
||||
it "times out work and leaves the service usable" $ do
|
||||
result <- normalizationBudget (threadDelay 6000000 >> pure (Right A.Null))
|
||||
result `shouldSatisfy` either ((== "timeout") . fst) (const False)
|
||||
normalizationBudget (pure (Right A.Null)) `shouldReturn` Right A.Null
|
||||
|
||||
-- 共用明确声明的用户表请求。
|
||||
normalizationPayload :: NormalizationRequest
|
||||
normalizationPayload = NormalizationRequest 1 "test" "users"
|
||||
(NormalizationDeclaration [["id"]] [NormalizationDependency ["id"] ["name", "age"]] True (Just True)) Nothing Nothing
|
||||
|
||||
-- 判断 JSON 类型校验失败。
|
||||
isJSONFailure :: A.Result a -> Bool
|
||||
isJSONFailure (A.Error _) = True
|
||||
isJSONFailure _ = False
|
||||
Reference in new issue
Block a user