修复错误,优化性能,实现类型系统,优化安装卸载过程
This commit is contained in:
1 parent
fd5f320360
commit
48eec484b7
104 files changed
+4127
-845
No files matched your search
@@ -2,9 +2,10 @@ cabal-version: 2.4
|
||||
|
||||
name: chusql-core-engine
|
||||
version: 1.0.0
|
||||
synopsis: ChuSQL 执行引擎:SQL 词法与语法分析、表达式求值
|
||||
description: ChuSQL 服务端执行引擎。负责 SQL 词法分析与 AST 构建、
|
||||
WHERE 条件表达式求值、关系代数运算与内存表管理。
|
||||
synopsis: ChuSQL SQL parsing, query planning, and execution engine
|
||||
description: Provides SQL tokenization, syntax and semantic analysis, query
|
||||
planning and optimization, expression evaluation, and relational
|
||||
algebra execution, with in-memory and persistent storage support.
|
||||
build-type: Simple
|
||||
|
||||
library
|
||||
|
||||
@@ -99,6 +99,15 @@ runStatementUncheckedM db (Update tbl assigns mWhere) =
|
||||
runStatementUncheckedM _ (CreateTable name cols) = do
|
||||
result <- createTable name cols
|
||||
pure (result >> Right [])
|
||||
runStatementUncheckedM _ (CreateDomain name base) = do
|
||||
result <- createTable (domainTableName name) [("base", plainColumn base)]
|
||||
pure (result >> Right [])
|
||||
runStatementUncheckedM _ (DropDomain name) = do
|
||||
result <- dropTable (domainTableName name)
|
||||
pure (result >> Right [])
|
||||
runStatementUncheckedM db ShowDomains = pure (Right
|
||||
[[("domain", VStr (drop (length (domainTableName "")) name)), ("base_type", VStr (typeName (columnType base)))]
|
||||
| (name, table) <- db, isDomainTable name, Just base <- [lookup "base" (tableCols table)]])
|
||||
runStatementUncheckedM _ (DropTable name) = do
|
||||
result <- dropTable name
|
||||
pure (result >> Right [])
|
||||
@@ -123,6 +132,8 @@ runStatementUncheckedM db (AlterColumnNull tbl col nullable) =
|
||||
alterTable db tbl (\table -> setColumnNullable col nullable (tableCols table) (tableRows table))
|
||||
runStatementUncheckedM _ CreateUser{} = pure (Left "CREATE USER is executed by the account service")
|
||||
runStatementUncheckedM _ AlterUser{} = pure (Left "ALTER USER is executed by the account service")
|
||||
runStatementUncheckedM _ AlterIdentity{} = pure (Left "ALTER ROLE is executed by the account service")
|
||||
runStatementUncheckedM _ ShowRoles = pure (Left "SHOW ROLES is executed by the account service")
|
||||
runStatementUncheckedM _ DropUser{} = pure (Left "DROP USER is executed by the account service")
|
||||
runStatementUncheckedM _ CreateRole{} = pure (Left "CREATE ROLE is executed by the privilege service")
|
||||
runStatementUncheckedM _ DropRole{} = pure (Left "DROP ROLE is executed by the privilege service")
|
||||
|
||||
@@ -135,27 +135,33 @@ filterPairsM ::
|
||||
[Row] ->
|
||||
[Row] ->
|
||||
m (Either String [Row])
|
||||
filterPairsM db outer kind ncols cond lrows rrows = go lrows []
|
||||
filterPairsM db outer kind ncols cond lrows rrows = go lrows [] HM.empty
|
||||
where
|
||||
refs = subqueryRefsIn cond
|
||||
-- | 逐左行配对,左连接没配上就补 NULL
|
||||
go [] acc = pure (Right (reverse acc))
|
||||
go (l : ls) acc = do
|
||||
hits <- keep l rrows []
|
||||
go [] acc _ = pure (Right (reverse acc))
|
||||
go (l : ls) acc cache = do
|
||||
hits <- keep l rrows [] cache
|
||||
case hits of
|
||||
Left e -> pure (Left e)
|
||||
Right hs -> do
|
||||
Right (hs, nextCache) -> do
|
||||
let hs' = case (kind, hs) of
|
||||
(LeftJoin, []) -> [l ++ nullRow]
|
||||
_ -> hs
|
||||
go ls (reverse hs' ++ acc)
|
||||
go ls (reverse hs' ++ acc) nextCache
|
||||
-- | 拿一行右行去比条件
|
||||
keep _ [] acc = pure (Right (reverse acc))
|
||||
keep l (r : rs) acc = do
|
||||
ok <- evalCondForRowM db cond (l ++ r ++ outer)
|
||||
case ok of
|
||||
keep _ [] acc cache = pure (Right (reverse acc, cache))
|
||||
keep l (r : rs) acc cache = do
|
||||
let env = l ++ r ++ outer
|
||||
key = bindingKey refs env
|
||||
resolved <- case HM.lookup key cache of
|
||||
Just expression -> pure (Right expression)
|
||||
Nothing -> substSubqueries db cond env
|
||||
case resolved of
|
||||
Left e -> pure (Left e)
|
||||
Right True -> keep l rs ((l ++ r) : acc)
|
||||
Right False -> keep l rs acc
|
||||
Right expression -> case evalCondForRow expression env of
|
||||
Left e -> pure (Left e)
|
||||
Right matches -> keep l rs (if matches then (l ++ r) : acc else acc) (HM.insert key expression cache)
|
||||
nullRow = [(c, VNull) | c <- ncols]
|
||||
|
||||
-- | 索引连接:右表是裸 Scan 时逐左行点查
|
||||
@@ -197,6 +203,7 @@ floatType :: ColumnType -> Bool
|
||||
floatType CFloat = True
|
||||
floatType CDouble = True
|
||||
floatType (CDecimal _ _) = True
|
||||
floatType (CDomain _ base) = floatType base
|
||||
floatType _ = False
|
||||
|
||||
-- | 是不是浮点值
|
||||
@@ -249,7 +256,14 @@ evalAggregate outer keys aggs rows = do
|
||||
|
||||
-- | 绑定键:子查询引用的外层列在这一行上的取值
|
||||
bindingKey :: [String] -> Row -> String
|
||||
bindingKey refs env = show [(c, lookup c env) | c <- refs]
|
||||
bindingKey refs env = show [(c, bindingValue c env) | c <- refs]
|
||||
|
||||
-- | 查已解析外层引用对应的物理列值
|
||||
bindingValue :: String -> Row -> Maybe Value
|
||||
bindingValue column env = case lookup column env of
|
||||
Just value -> Just value
|
||||
Nothing | '.' `elem` column -> lookup (reverse (takeWhile (/= '.') (reverse column))) [(key, value) | (key, value) <- env, '.' `notElem` key]
|
||||
Nothing -> Nothing
|
||||
|
||||
-- | 每个绑定留第一行当样本,去掉重复绑定
|
||||
bindingSamples :: [String] -> Row -> [Row] -> [(String, Row)]
|
||||
@@ -414,7 +428,14 @@ substSubqueries db e env = case e of
|
||||
runSubqueryRows :: (MonadStorage m) => Database -> Subquery -> Row -> m (Either String [Row])
|
||||
runSubqueryRows db sq outer = case translate (subqueryStatement sq) of
|
||||
Left e -> pure (Left e)
|
||||
Right op -> evalRelOpIn db outer (optimize db op)
|
||||
Right op -> case mapM bind (subqueryRefs sq) of
|
||||
Left err -> pure (Left err)
|
||||
Right bindings -> evalRelOpIn db (bindings ++ outer) (optimize db op)
|
||||
where
|
||||
-- | 给外层物理列补回已解析的限定名
|
||||
bind column = case bindingValue column outer of
|
||||
Just value -> Right (column, value)
|
||||
Nothing -> Left ("unknown outer column: " ++ column)
|
||||
|
||||
-- | 单子求值:Scan/点查/范围查都问存储
|
||||
evalRelOpM :: (MonadStorage m) => Database -> RelOp -> m (Either String [Row])
|
||||
|
||||
@@ -1,7 +1,7 @@
|
||||
module ChuSQL.Core.Engine.Algebra.JoinOrder (reorderJoins) where
|
||||
|
||||
import ChuSQL.Core.Engine.Algebra.Cost (pointRows, rangeRows, selectivityOf, tableMetaOf)
|
||||
import ChuSQL.Core.Engine.Algebra.Expr (colsInExpr, hasDivision)
|
||||
import ChuSQL.Core.Engine.Algebra.Expr (colsInExpr, hasDivision, hasSubquery)
|
||||
import ChuSQL.Core.Engine.Algebra.Op (RelOp (..), relOpCols)
|
||||
import ChuSQL.Core.Engine.Syntax.AST (Expr (..), JoinKind (..))
|
||||
import ChuSQL.Core.Model
|
||||
@@ -46,8 +46,13 @@ leafRows db op = case op of
|
||||
Scan _ t _ -> rowCountOf db t
|
||||
Lookup _ t c _ -> pointRows <$> tableMetaOf db t <*> pure c
|
||||
Range _ t c lo hi -> (\m -> rangeRows m c lo hi) <$> tableMetaOf db t
|
||||
Filter p x -> scaleRows db p x <$> leafRows db x
|
||||
Filter p x | not (hasDivision p || hasSubquery p) -> scaleRows db p x <$> leafRows db x
|
||||
Project _ x -> leafRows db x
|
||||
Compute items x | all (\(_, e) -> not (hasDivision e || hasSubquery e)) items -> leafRows db x
|
||||
Sort _ x -> leafRows db x
|
||||
Limit n x -> min (max 0 n) <$> leafRows db x
|
||||
Derived _ x -> leafRows db x
|
||||
Unit -> Just 1
|
||||
_ -> Nothing
|
||||
|
||||
-- | 表统计里的行数
|
||||
|
||||
@@ -117,8 +117,16 @@ pushProject db need (Join kind l r c)
|
||||
pushProject db need leaf@(Scan a t _)
|
||||
| needsAll need = leaf
|
||||
| all (`elem` need) (relOpCols db leaf) = leaf
|
||||
| otherwise = Scan a t (Just (nub (map (unqualify a) need)))
|
||||
pushProject _ _ (Derived a x) = Derived a x
|
||||
| otherwise = Scan a t (Just (nub [column | requested <- need, let column = physicalColumn requested, column `elem` available]))
|
||||
where
|
||||
available = map (unqualify a) (relOpCols db (Scan a t Nothing))
|
||||
-- | 把扫描限定列换成存储物理列名
|
||||
physicalColumn column = unqualify (Just (deriveQualifier a t)) (unqualify a column)
|
||||
pushProject db need (Derived a x)
|
||||
| needsAll need || all (`elem` wanted) (relOpCols db x) = Derived a (pushProject db ["*"] x)
|
||||
| otherwise = Derived a (Project wanted (pushProject db wanted x))
|
||||
where
|
||||
wanted = nub (map (unqualify a) need)
|
||||
pushProject db need leaf@(Lookup _ _ _ _) = pushProjectLeaf db need leaf
|
||||
pushProject db need leaf@(Range _ _ _ _ _) = pushProjectLeaf db need leaf
|
||||
|
||||
|
||||
@@ -1,8 +1,9 @@
|
||||
module ChuSQL.Core.Engine.Algebra.Planner (translate) where
|
||||
|
||||
import ChuSQL.Core.Engine.Algebra.Expr (aggregatesIn)
|
||||
import ChuSQL.Core.Engine.Algebra.Expr (aggregatesIn, colsInExpr)
|
||||
import ChuSQL.Core.Engine.Algebra.Op
|
||||
import ChuSQL.Core.Engine.Syntax.AST
|
||||
import Data.List (nub)
|
||||
|
||||
-- 计划生成:把语句翻译成算子树。
|
||||
|
||||
@@ -91,5 +92,16 @@ translate q = case q of
|
||||
SelectExpr items fromC mWhere groupBy orderBy mLimit -> do
|
||||
plan0 <- source fromC mWhere
|
||||
let (plan, items') = grouped groupBy items plan0
|
||||
Right (Compute items' (limited orderBy mLimit plan))
|
||||
Right $ if any (\(c, _) -> c `elem` map fst items') orderBy
|
||||
then orderedProjection items' orderBy mLimit plan
|
||||
else Compute items' (limited orderBy mLimit plan)
|
||||
_ -> Left "only SELECT is supported by translate"
|
||||
|
||||
-- | 在排序前计算别名并保留输出顺序
|
||||
orderedProjection :: [(String, Expr)] -> [(String, SortDir)] -> Maybe Int -> RelOp -> RelOp
|
||||
orderedProjection items orderBy mLimit plan =
|
||||
Compute items (limited ordering mLimit (Compute (carried ++ keys) plan))
|
||||
where
|
||||
carried = [(column, Col column) | column <- nub (concatMap (colsInExpr . snd) items)]
|
||||
keys = [("$order" ++ show n, maybe (Col c) id (lookup c items)) | (n, (c, _)) <- zip [1 :: Int ..] orderBy]
|
||||
ordering = [(key, direction) | ((key, _), (_, direction)) <- zip keys orderBy]
|
||||
@@ -36,6 +36,8 @@ errorRules =
|
||||
[ ErrorRule "no database selected" NoDatabaseError "no_database"
|
||||
, ErrorRule "administrator required" PermissionError "forbidden"
|
||||
, ErrorRule "unknown table" CatalogError "not_found"
|
||||
, ErrorRule "unknown domain" CatalogError "not_found"
|
||||
, ErrorRule "domain is still used" CatalogError "query_error"
|
||||
, ErrorRule "unknown column" CatalogError "query_error"
|
||||
, ErrorRule "unknown database" CatalogError "not_found"
|
||||
, ErrorRule "unknown role" CatalogError "not_found"
|
||||
@@ -72,5 +74,7 @@ errorCode message = maybe "query_error" ruleCode (errorLike message)
|
||||
-- | 账号服务对外的错误码
|
||||
accountErrorCode :: String -> String
|
||||
accountErrorCode "account already exists" = "conflict"
|
||||
accountErrorCode "identity already exists" = "conflict"
|
||||
accountErrorCode "the last enabled login superuser cannot be removed" = "bad_request"
|
||||
accountErrorCode "unknown account" = "not_found"
|
||||
accountErrorCode _ = "storage_error"
|
||||
@@ -5,7 +5,7 @@ import ChuSQL.Core.Model
|
||||
import ChuSQL.Core.Engine.Syntax.AST
|
||||
import ChuSQL.Core.Engine.Syntax.Parser (parseExpression)
|
||||
import Data.Char (isAlphaNum, isAscii, toLower)
|
||||
import Data.List (intercalate, isInfixOf, isPrefixOf, nub)
|
||||
import Data.List (intercalate, isInfixOf, isPrefixOf, isSuffixOf, nub)
|
||||
|
||||
-- 语义检查:表和列在不在、类型对不对,全部在执行前查。
|
||||
|
||||
@@ -53,10 +53,15 @@ checkFrom db outer (FromJoin _ left right cond) = do
|
||||
checkBool db "ON" (Scope env outer) cond
|
||||
Right env
|
||||
|
||||
-- | 派生表里 NULL 字面量列没有具体类型,按字符串处理
|
||||
-- | 保留派生表输出的类型或未定型 NULL
|
||||
derivedType :: InferredType -> ColumnType
|
||||
derivedType (InferType t) = t
|
||||
derivedType InferNull = CStr
|
||||
derivedType InferNull = CNull
|
||||
|
||||
-- | 将列类型还原为表达式推导类型
|
||||
inferredColumnType :: ColumnType -> InferredType
|
||||
inferredColumnType CNull = InferNull
|
||||
inferredColumnType ty = InferType ty
|
||||
|
||||
-- | 合并两层列,本层优先且不重复
|
||||
scopedEnv :: [(String, Column)] -> [(String, Column)] -> [(String, Column)]
|
||||
@@ -113,7 +118,7 @@ renderType (InferType t) = typeLabel t
|
||||
|
||||
-- | 推导表达式的类型(子查询也在这里整条查一遍)
|
||||
inferExpr :: Database -> String -> Scope -> Expr -> Either String InferredType
|
||||
inferExpr _ place env (Col c) = InferType . columnType . snd <$> scopeAt place env c
|
||||
inferExpr _ place env (Col c) = inferredColumnType . columnType . snd <$> scopeAt place env c
|
||||
inferExpr _ _ _ LitNull = Right InferNull
|
||||
inferExpr _ _ _ (LitInt _) = Right (InferType CInt)
|
||||
inferExpr _ _ _ (LitFloat _) = Right (InferType CFloat)
|
||||
@@ -213,7 +218,7 @@ inferSubqueryOutput db outerScope sq = case subqueryStatement sq of
|
||||
-- | 查这一列的推导类型
|
||||
columnTypeOf env c = do
|
||||
(_, col) <- scopeAt "SELECT" (Scope env enclosing) c
|
||||
Right (c, InferType (columnType col))
|
||||
Right (c, inferredColumnType (columnType col))
|
||||
|
||||
-- | 聚合的参数:列要在,且不能嵌套聚合
|
||||
aggregateArg :: Database -> String -> Scope -> Expr -> Either String InferredType
|
||||
@@ -282,7 +287,7 @@ boolean db place env a b = do
|
||||
where
|
||||
-- | 挨个查操作数是不是布尔
|
||||
boolOperand _ _ InferNull = Right ()
|
||||
boolOperand _ _ (InferType CBool) = Right ()
|
||||
boolOperand _ _ (InferType ty) | typeClassOf ty == BooleanClass = Right ()
|
||||
boolOperand p other t = Left (p ++ ": operator needs TBool on both sides, got " ++ renderType other ++ " and " ++ renderType t)
|
||||
|
||||
-- | 要求条件能算出布尔
|
||||
@@ -292,7 +297,7 @@ checkBool db place env e = do
|
||||
t <- inferExpr db place env e
|
||||
case t of
|
||||
InferNull -> Right ()
|
||||
InferType CBool -> Right ()
|
||||
InferType x | typeClassOf x == BooleanClass -> Right ()
|
||||
InferType x -> Left (place ++ ": condition must be a boolean, got " ++ typeLabel x)
|
||||
|
||||
-- | 检查赋值列和类型
|
||||
@@ -321,10 +326,88 @@ check db q = () <$ prepare db q
|
||||
-- | 执行前解析列名并检查类型
|
||||
prepare :: Database -> Statement -> Either String Statement
|
||||
prepare db q = do
|
||||
resolved <- resolveStatement db q
|
||||
checkResolved db resolved
|
||||
typed <- resolveDomainTypes db q
|
||||
let visible = filter (not . isDomainTable . fst) db
|
||||
resolved <- resolveStatement visible typed
|
||||
case resolved of
|
||||
CreateDomain name base -> do
|
||||
checkDomainName name
|
||||
checkTypeParameters base
|
||||
case base of
|
||||
CVarchar n | n <= 0 -> Left "CREATE DOMAIN: length must be positive"
|
||||
CChar n | n <= 0 -> Left "CREATE DOMAIN: length must be positive"
|
||||
CDecimal p s | p <= 0 || p > 308 || s < 0 || s > p -> Left "CREATE DOMAIN: invalid precision or scale"
|
||||
_ -> Right ()
|
||||
if any ((== domainTableName name) . fst) db
|
||||
then Left ("domain already exists: " ++ name)
|
||||
else Right ()
|
||||
DropDomain name -> do
|
||||
_ <- maybe (Left ("unknown domain: " ++ name)) Right (lookup (domainTableName name) db)
|
||||
if any (any (usesDomain name . columnType . snd) . tableCols . snd) db
|
||||
then Left ("domain is still used by a column: " ++ name)
|
||||
else Right ()
|
||||
ShowDomains -> Right ()
|
||||
_ -> do
|
||||
if any (isDomainTable . lastTablePart) (ddlTargets resolved)
|
||||
then Left "reserved domain catalog"
|
||||
else Right ()
|
||||
checkResolved visible resolved
|
||||
pure resolved
|
||||
|
||||
-- | 检查命名类型的名称
|
||||
checkDomainName :: String -> Either String ()
|
||||
checkDomainName name
|
||||
| null name || length name > 48 = Left "CREATE DOMAIN: name must contain 1 to 48 characters"
|
||||
| any (\c -> not (isAscii c && (isAlphaNum c || c == '_'))) name = Left "CREATE DOMAIN: invalid name"
|
||||
| Just _ <- parseColumnType name = Left "CREATE DOMAIN: built-in type name is reserved"
|
||||
| "__system_" `isPrefixOf` map toLower name = Left "CREATE DOMAIN: reserved name"
|
||||
| otherwise = Right ()
|
||||
|
||||
-- | 判断列类型是否引用指定命名类型
|
||||
usesDomain :: String -> ColumnType -> Bool
|
||||
usesDomain name (CDomain other base) = map toLower name == map toLower other || usesDomain name base
|
||||
usesDomain _ _ = False
|
||||
|
||||
-- | 列出结构语句的目标表
|
||||
ddlTargets :: Statement -> [String]
|
||||
ddlTargets statement = case statement of
|
||||
CreateTable name _ -> [name]
|
||||
DropTable name -> [name]
|
||||
CreateIndex name _ -> [name]
|
||||
DropIndex name _ -> [name]
|
||||
AddColumn name _ -> [name]
|
||||
DropColumn name _ -> [name]
|
||||
RenameColumn name _ _ -> [name]
|
||||
AlterColumnType name _ _ -> [name]
|
||||
AlterColumnDefault name _ _ -> [name]
|
||||
AlterColumnNull name _ _ -> [name]
|
||||
_ -> []
|
||||
|
||||
-- | 从 schema 解析列上的命名类型
|
||||
resolveDomainTypes :: Database -> Statement -> Either String Statement
|
||||
resolveDomainTypes db statement = case statement of
|
||||
CreateDomain name base -> CreateDomain name <$> resolveType base
|
||||
CreateTable name cols -> CreateTable name <$> mapM resolveColumnType cols
|
||||
AddColumn name col -> AddColumn name <$> resolveColumnType col
|
||||
AlterColumnType name col ty -> AlterColumnType name col <$> resolveType ty
|
||||
_ -> Right statement
|
||||
where
|
||||
-- | 解析一列的类型
|
||||
resolveColumnType (name, col) = do
|
||||
ty <- resolveType (columnType col)
|
||||
Right (name, col {columnType = ty})
|
||||
-- | 从类型目录取基础类型
|
||||
resolveType = resolveWith []
|
||||
-- | 递归解析类型并拒绝循环定义
|
||||
resolveWith seen (CDomain name _)
|
||||
| map toLower name `elem` seen = Left ("cyclic domain definition: " ++ name)
|
||||
| otherwise = do
|
||||
table <- maybe (Left ("unknown domain: " ++ name)) Right (lookup (domainTableName name) db)
|
||||
base <- maybe (Left ("invalid domain catalog: " ++ name)) Right (lookup "base" (tableCols table))
|
||||
resolved <- resolveWith (map toLower name : seen) (columnType base)
|
||||
Right (CDomain (map toLower name) resolved)
|
||||
resolveWith _ ty = Right ty
|
||||
|
||||
-- | 检查已解析的语句
|
||||
checkResolved :: Database -> Statement -> Either String ()
|
||||
checkResolved db = checkResolvedWith db []
|
||||
@@ -350,8 +433,8 @@ checkResolvedWith db outer q = case q of
|
||||
env <- checkFrom db outer fromC
|
||||
let full = Scope env outer
|
||||
mapM_ (\item -> () <$ inferExpr db "SELECT" full (snd item)) items
|
||||
checkGrouping full groupBy items
|
||||
checkColumns "ORDER BY" full (map fst orderBy)
|
||||
checkGrouping full groupBy (items ++ [(c, Col c) | (c, _) <- orderBy, c `notElem` map fst items])
|
||||
mapM_ (checkOrder full items . fst) orderBy
|
||||
mapM_ (checkNoAggregate "WHERE") mWhere
|
||||
mapM_ (checkBool db "WHERE" full) mWhere
|
||||
Insert tbl cols rows -> do
|
||||
@@ -420,6 +503,7 @@ checkResolvedWith db outer q = case q of
|
||||
AlterColumnType tbl col ty -> do
|
||||
t <- lookupTable db tbl
|
||||
c <- requireColumn "ALTER COLUMN" t col
|
||||
checkTypeParameters ty
|
||||
if columnAutoIncrement c && not (integerType ty)
|
||||
then Left "ALTER COLUMN: AUTO_INCREMENT column must stay an integer type"
|
||||
else Right ()
|
||||
@@ -435,6 +519,12 @@ checkResolvedWith db outer q = case q of
|
||||
else Right ()
|
||||
CreateUser name password -> checkAccount name password
|
||||
AlterUser name password -> checkAccount name password
|
||||
AlterIdentity name attributes -> do
|
||||
checkRoleName name
|
||||
if length (nub (map fst attributes)) == length attributes
|
||||
then Right ()
|
||||
else Left "duplicate identity attribute"
|
||||
ShowRoles -> Right ()
|
||||
DropUser name -> checkUserName name
|
||||
CreateRole name -> checkRoleName name
|
||||
DropRole name -> checkRoleName name
|
||||
@@ -456,6 +546,9 @@ checkResolvedWith db outer q = case q of
|
||||
DropDatabase name -> checkDatabaseName name
|
||||
UseDatabase name -> checkDatabaseName name
|
||||
ShowDatabases -> Right ()
|
||||
CreateDomain{} -> Right ()
|
||||
DropDomain{} -> Right ()
|
||||
ShowDomains -> Right ()
|
||||
-- | 事务控制由会话层执行,语义层不做列检查
|
||||
BeginTransaction -> Right ()
|
||||
CommitTransaction -> Right ()
|
||||
@@ -485,6 +578,7 @@ checkInsertTargets t cols = mapM_ checkTarget (tableCols t)
|
||||
-- | 检查一列定义是否合法(names 给 CHECK 用)
|
||||
checkColumnDefs :: [String] -> [(String, Column)] -> Either String ()
|
||||
checkColumnDefs names cols = do
|
||||
mapM_ (checkTypeParameters . columnType . snd) cols
|
||||
mapM_ (\(_, c) -> mapM_ (checkDefault c) (columnDefault c)) cols
|
||||
mapM_ (\(_, c) -> checkAutoIncrement c) cols
|
||||
if length [() | (_, c) <- cols, columnAutoIncrement c] > 1
|
||||
@@ -492,6 +586,16 @@ checkColumnDefs names cols = do
|
||||
else Right ()
|
||||
checkChecks names cols
|
||||
|
||||
-- | 校验列类型的长度和精度参数
|
||||
checkTypeParameters :: ColumnType -> Either String ()
|
||||
checkTypeParameters (CDomain _ base) = checkTypeParameters base
|
||||
checkTypeParameters CNull = Left "NULL is only valid as an inferred query output"
|
||||
checkTypeParameters (CDecimal p s)
|
||||
| p <= 0 || p > 308 || s < 0 || s > p = Left "invalid decimal precision or scale"
|
||||
checkTypeParameters (CVarchar n) | n <= 0 = Left "character length must be positive"
|
||||
checkTypeParameters (CChar n) | n <= 0 = Left "character length must be positive"
|
||||
checkTypeParameters _ = Right ()
|
||||
|
||||
-- | 自增列必须是整数列
|
||||
checkAutoIncrement :: Column -> Either String ()
|
||||
checkAutoIncrement c
|
||||
@@ -502,8 +606,8 @@ checkAutoIncrement c
|
||||
checkDefault :: Column -> Value -> Either String ()
|
||||
checkDefault c v
|
||||
| VNull <- v = Right ()
|
||||
| valueFits (columnType c) v = Right ()
|
||||
| otherwise = Left ("DEFAULT: value does not fit column type " ++ show c)
|
||||
| valueFits (columnType c) v = () <$ coerceValue (columnType c) v
|
||||
| otherwise = Left ("DEFAULT: value does not fit column type " ++ typeLabel (columnType c))
|
||||
|
||||
-- | CHECK 里的列必须存在
|
||||
checkChecks :: [String] -> [(String, Column)] -> Either String ()
|
||||
@@ -717,6 +821,13 @@ resolveSelect db q@Select{} = resolveQuery db [] q (map (\c -> (c, Col c)) (sele
|
||||
resolveSelect db q@SelectExpr{} = resolveQuery db [] q (selectItems q)
|
||||
resolveSelect _ q = Right q
|
||||
|
||||
-- | 检查排序输出别名或来源列
|
||||
checkOrder :: Scope -> [(String, Expr)] -> String -> Either String ()
|
||||
checkOrder env items column = case [e | (label, e) <- items, label == column] of
|
||||
[] -> checkColumns "ORDER BY" env [column]
|
||||
[_] -> Right ()
|
||||
_ -> Left ("ORDER BY: ambiguous projection alias: " ++ column)
|
||||
|
||||
-- | 解析投影、条件、排序与连接引用
|
||||
resolveQuery :: Database -> [(String, Column)] -> Statement -> [(String, Expr)] -> Either String Statement
|
||||
resolveQuery db outer q items = do
|
||||
@@ -727,7 +838,13 @@ resolveQuery db outer q items = do
|
||||
FromTable Nothing tbl -> unqualify (Just (deriveQualifier Nothing tbl)) c
|
||||
_ -> c
|
||||
-- | 查一列并换算成物理名
|
||||
name place c = physical . fst <$> scopedColumnAt place env outer c
|
||||
name place c
|
||||
| length (filter (== '.') c) == 2, not (qualifiedReference c) = Left (missingColumn place c env)
|
||||
| otherwise = physical . fst <$> scopedColumnAt place env outer c
|
||||
-- | 库限定列只引用来源中的真实表名
|
||||
qualifiedReference c = qualifiedReferenceIn db (selectFrom q) c
|
||||
|| (any (\(key, _) -> length (filter (== '.') key) == 1 && ("." ++ key) `isSuffixOf` c) outer
|
||||
&& (not (any (elem '.' . fst) db) || any (\(table, _) -> (table ++ ".") `isPrefixOf` c) db))
|
||||
-- | 换算一个投影项:带别名时保留别名做输出列名
|
||||
output (label, Col c) = do
|
||||
k <- name "SELECT" c
|
||||
@@ -742,11 +859,29 @@ resolveQuery db outer q items = do
|
||||
else mapM output items
|
||||
condition <- mapM (resolveExpr db env outer (name "WHERE")) (selectWhere q)
|
||||
grouping <- mapM (name "GROUP BY") (selectGroupBy q)
|
||||
ordering <- mapM (\(c, d) -> (\k -> (k, d)) <$> name "ORDER BY" c) (selectOrderBy q)
|
||||
-- | 优先解析唯一投影别名,再查来源列
|
||||
let orderName c = case [label | (label, _) <- projected, label == c, qIsExpression] of
|
||||
[] -> name "ORDER BY" c
|
||||
[label] -> Right label
|
||||
_ -> Left ("ORDER BY: ambiguous projection alias: " ++ c)
|
||||
qIsExpression = case q of SelectExpr{} -> True; _ -> False
|
||||
ordering <- mapM (\(c, d) -> (\k -> (k, d)) <$> orderName c) (selectOrderBy q)
|
||||
pure $ case q of
|
||||
Select{} -> Select (map fst projected) source condition grouping ordering (selectLimit q)
|
||||
_ -> SelectExpr projected source condition grouping ordering (selectLimit q)
|
||||
|
||||
-- | 收集没有别名遮蔽的来源表名
|
||||
sourceTableNames :: FromClause -> [String]
|
||||
sourceTableNames (FromTable Nothing table) = [table]
|
||||
sourceTableNames (FromJoin _ left right _) = sourceTableNames left ++ sourceTableNames right
|
||||
sourceTableNames _ = []
|
||||
|
||||
-- | 库限定引用必须使用当前来源的表名
|
||||
qualifiedReferenceIn :: Database -> FromClause -> String -> Bool
|
||||
qualifiedReferenceIn db source c = any (\table -> (table ++ ".") `isPrefixOf` c) tables
|
||||
where
|
||||
tables = sourceTableNames source ++ [key | table <- sourceTableNames source, Right (key, _) <- [resolveTable db table]]
|
||||
|
||||
-- | 单表不加限定名,其余来源交给 resolveFrom
|
||||
resolveSource :: Database -> [(String, Column)] -> FromClause -> Either String FromClause
|
||||
resolveSource db outer fromC = case fromC of
|
||||
@@ -769,7 +904,11 @@ resolveFrom db outer (FromJoin kind left right cond) = do
|
||||
l <- resolveFrom db outer left
|
||||
r <- resolveFrom db outer right
|
||||
env <- checkFrom db outer (FromJoin kind l r cond)
|
||||
c <- resolveExpr db env outer (fmap fst . columnAt "ON" env) cond
|
||||
-- | 连接条件也拒绝不存在的库前缀
|
||||
let joinName column
|
||||
| length (filter (== '.') column) == 2, not (qualifiedReferenceIn db (FromJoin kind left right cond) column) = Left (missingColumn "ON" column env)
|
||||
| otherwise = fst <$> columnAt "ON" env column
|
||||
c <- resolveExpr db env outer joinName cond
|
||||
pure (FromJoin kind l r c)
|
||||
|
||||
-- | 派生表的输出列名:列取裸名,表达式保留原标签
|
||||
|
||||
@@ -7,6 +7,7 @@ module ChuSQL.Core.Engine.Storage.FFI (
|
||||
openStorage,
|
||||
closeStorage,
|
||||
storageRequest,
|
||||
maintainStorage,
|
||||
) where
|
||||
|
||||
import Control.Exception (SomeException, try)
|
||||
@@ -40,6 +41,21 @@ foreign import ccall unsafe "chusql_storage_free"
|
||||
foreign import ccall unsafe "chusql_storage_last_error"
|
||||
cStorageLastError :: Ptr CSize -> IO (Ptr CChar)
|
||||
|
||||
foreign import ccall safe "chusql_storage_maintenance"
|
||||
cStorageMaintenance :: CString -> Ptr CChar -> CSize -> Ptr (Ptr CChar) -> Ptr CSize -> IO CInt
|
||||
|
||||
-- | 离线修复系统目录并返回结果
|
||||
maintainStorage :: FilePath -> BS.ByteString -> IO (Either String BS.ByteString)
|
||||
maintainStorage path payload = withCString path $ \config ->
|
||||
BS.useAsCStringLen payload $ \(input, size) -> alloca $ \outRef -> alloca $ \lenRef -> do
|
||||
code <- cStorageMaintenance config input (fromIntegral size) outRef lenRef
|
||||
if code /= 0 then Left <$> lastError else do
|
||||
output <- peek outRef
|
||||
len <- peek lenRef
|
||||
bytes <- BS.packCStringLen (output, fromIntegral len)
|
||||
cStorageFree output len
|
||||
pure (Right bytes)
|
||||
|
||||
-- | 库版本(Rust 侧的 CARGO_PKG_VERSION)
|
||||
storageVersion :: IO String
|
||||
storageVersion = cStorageVersion >>= peekCString
|
||||
|
||||
@@ -2,6 +2,7 @@ module ChuSQL.Core.Engine.Storage.Memory (MemoryStorage (runMemoryStorage)) wher
|
||||
|
||||
import ChuSQL.Core.Model
|
||||
import ChuSQL.Core.Engine.Storage
|
||||
import qualified Data.HashSet as HS
|
||||
|
||||
-- 内存实现:Database 上的状态,错误通道是 Either String。
|
||||
|
||||
@@ -74,11 +75,32 @@ instance MonadStorage MemoryStorage where
|
||||
-- \| 原样返回当前库
|
||||
snapshot = MemoryStorage $ \db -> Right (db, db)
|
||||
|
||||
-- \| 返回实时行数与去重统计的无数据结构
|
||||
schema = MemoryStorage $ \db -> Right (map describe db, db)
|
||||
where
|
||||
-- | 将存储数据汇总为结构统计
|
||||
describe (name, table) =
|
||||
(name, table {tableRows = [], tableMeta = Just metadata})
|
||||
where
|
||||
metadata = TableMeta (length (tableRows table)) distinct [] []
|
||||
distinct = [columnStatistics column (tableRows table) | (column, _) <- tableCols table]
|
||||
|
||||
-- \| 改表结构:列定义与行一起换
|
||||
replaceSchema name cols rows = MemoryStorage $ \db -> case lookup name db of
|
||||
Nothing -> Right (Left ("unknown table: " ++ name), db)
|
||||
Just tbl -> Right (Right (), replaceTable name tbl{tableCols = cols, tableRows = rows} db)
|
||||
|
||||
-- | 对列值去重并限制统计内存
|
||||
columnStatistics :: String -> [Row] -> (String, Int, Bool)
|
||||
columnStatistics column rows = go rows HS.empty
|
||||
where
|
||||
-- | 累积规范化值,达到上限后停止
|
||||
go remaining values
|
||||
| HS.size values >= 4096 = (column, 4096, True)
|
||||
| otherwise = case remaining of
|
||||
[] -> (column, HS.size values, False)
|
||||
row : rest -> go rest (maybe values (\v -> HS.insert (canonicalValue v) values) (lookup column row))
|
||||
|
||||
-- | 用给定表替换同名表
|
||||
replaceTable :: String -> Table -> Database -> Database
|
||||
replaceTable name table =
|
||||
|
||||
@@ -25,6 +25,9 @@ data Statement
|
||||
| Delete String (Maybe Expr)
|
||||
| Update String [(String, Expr)] (Maybe Expr)
|
||||
| CreateTable String [(String, Column)]
|
||||
| CreateDomain String ColumnType
|
||||
| DropDomain String
|
||||
| ShowDomains
|
||||
| DropTable String
|
||||
| CreateIndex String String
|
||||
| DropIndex String String
|
||||
@@ -36,6 +39,8 @@ data Statement
|
||||
| AlterColumnNull String String Bool
|
||||
| CreateUser String String
|
||||
| AlterUser String String
|
||||
| AlterIdentity String [(String, Bool)]
|
||||
| ShowRoles
|
||||
| DropUser String
|
||||
-- | 新角色:权限的载体,用户靠成员资格继承它的权限
|
||||
| CreateRole String
|
||||
|
||||
@@ -8,7 +8,7 @@ import ChuSQL.Core.Engine.Syntax.AST
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)
|
||||
import Data.Char (isAlpha, isAlphaNum, isHexDigit, isSpace, toLower, toUpper)
|
||||
import Data.List (intercalate)
|
||||
import Data.List (intercalate, isInfixOf)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Void (Void)
|
||||
import Text.Megaparsec
|
||||
@@ -475,8 +475,25 @@ alterUserStatement = do
|
||||
keyword "alter"
|
||||
keyword "user"
|
||||
name <- userName
|
||||
pw <- identifiedBy
|
||||
return (AlterUser name pw)
|
||||
(AlterUser name <$> identifiedBy) <|> (AlterIdentity name <$> some identityAttribute)
|
||||
|
||||
-- | 读身份属性开关
|
||||
identityAttribute :: Parser (String, Bool)
|
||||
identityAttribute = choice
|
||||
[ ("system_catalog_manager", True) <$ keyword "system_catalog_manager"
|
||||
, ("system_catalog_manager", False) <$ keyword "nosystem_catalog_manager"
|
||||
, ("login", True) <$ keyword "login", ("login", False) <$ keyword "nologin"
|
||||
, ("superuser", True) <$ keyword "superuser", ("superuser", False) <$ keyword "nosuperuser"
|
||||
, ("enabled", True) <$ keyword "enabled", ("enabled", False) <$ keyword "disabled"
|
||||
]
|
||||
|
||||
-- | 读 ALTER ROLE 属性或口令
|
||||
alterRoleStatement :: Parser Statement
|
||||
alterRoleStatement = do
|
||||
keyword "alter"
|
||||
keyword "role"
|
||||
name <- userName
|
||||
(AlterUser name <$> identifiedBy) <|> (AlterIdentity name <$> some identityAttribute)
|
||||
|
||||
-- | 读 DROP USER
|
||||
dropUserStatement :: Parser Statement
|
||||
@@ -599,6 +616,7 @@ columnTypeP =
|
||||
, keyword "date" >> pure CDate
|
||||
, keyword "timestamp" >> pure CTimestamp
|
||||
, keyword "blob" >> pure CBlob
|
||||
, (\name -> CDomain (map toLower name) CStr) <$> identifier
|
||||
]
|
||||
|
||||
-- | DECIMAL 的精度与小数位
|
||||
@@ -682,7 +700,14 @@ renameColumns name cols q@Select { selectCols = names } = do
|
||||
)
|
||||
renameColumns name cols q@SelectExpr { selectItems = items } = do
|
||||
checkCteArity name cols (map snd items)
|
||||
Right q { selectItems = zip cols (map snd items) }
|
||||
ordering <- mapM renameOrder (selectOrderBy q)
|
||||
Right q { selectItems = zip cols (map snd items), selectOrderBy = ordering }
|
||||
where
|
||||
-- | 列清单同步改写内层排序输出别名
|
||||
renameOrder (column, direction) = case [new | ((old, _), new) <- zip items cols, old == column] of
|
||||
[] -> Right (column, direction)
|
||||
[new] -> Right (new, direction)
|
||||
_ -> Left ("WITH: ambiguous ORDER BY alias: " ++ column)
|
||||
renameColumns _ _ _ = Left "WITH: a CTE must be a SELECT"
|
||||
|
||||
-- | 列清单个数必须和本体输出一致
|
||||
@@ -808,7 +833,7 @@ transactionStatement =
|
||||
parseStatement :: String -> Either String Statement
|
||||
parseStatement input =
|
||||
case runParser (sc *> statementP <* sc <* eof) "<query>" input of
|
||||
Left err -> Left (errorBundlePretty err)
|
||||
Left err -> Left (safeParseError input err)
|
||||
Right q -> Right q
|
||||
where
|
||||
-- | 按关键字分派到各语句解析器
|
||||
@@ -819,12 +844,17 @@ parseStatement input =
|
||||
<|> try (CreateDatabase <$> (keyword "create" *> keyword "database" *> identifier))
|
||||
<|> try (DropDatabase <$> (keyword "drop" *> keyword "database" *> identifier))
|
||||
<|> (UseDatabase <$> (keyword "use" *> identifier))
|
||||
<|> (ShowDatabases <$ (keyword "show" *> keyword "databases"))
|
||||
<|> try (ShowDatabases <$ (keyword "show" *> keyword "databases"))
|
||||
<|> try (ShowDomains <$ (keyword "show" *> keyword "domains"))
|
||||
<|> try (CreateDomain <$> (keyword "create" *> keyword "domain" *> identifier) <*> (keyword "as" *> columnTypeP))
|
||||
<|> try (DropDomain <$> (keyword "drop" *> keyword "domain" *> identifier))
|
||||
<|> insertStatement
|
||||
<|> deleteStatement
|
||||
<|> updateStatement
|
||||
<|> try createUserStatement
|
||||
<|> try alterUserStatement
|
||||
<|> try alterRoleStatement
|
||||
<|> try (ShowRoles <$ (keyword "show" *> keyword "roles"))
|
||||
<|> try dropUserStatement
|
||||
<|> try createRoleStatement
|
||||
<|> try dropRoleStatement
|
||||
@@ -840,9 +870,15 @@ parseStatement input =
|
||||
parseExpression :: String -> Either String Expr
|
||||
parseExpression input =
|
||||
case runParser (sc *> expr <* sc <* eof) "<expr>" input of
|
||||
Left err -> Left (errorBundlePretty err)
|
||||
Left err -> Left (safeParseError input err)
|
||||
Right e -> Right e
|
||||
|
||||
-- | 隐去含口令输入的解析诊断
|
||||
safeParseError :: String -> ParseErrorBundle String Void -> String
|
||||
safeParseError input errors
|
||||
| any (`isInfixOf` map toLower input) ["password", "identified"] = "syntax error in credential statement (input redacted)"
|
||||
| otherwise = errorBundlePretty errors
|
||||
|
||||
-- | 表名至多有一个库前缀。
|
||||
tableName :: Parser String
|
||||
tableName = do
|
||||
|
||||
@@ -104,9 +104,91 @@ chainDB = [("a", chainA), ("b", chainB), ("c", chainC)]
|
||||
chainDBWithoutStats :: Database
|
||||
chainDBWithoutStats = [(n, t { tableMeta = Nothing }) | (n, t) <- chainDB]
|
||||
|
||||
-- | 顺序执行命名类型测试语句
|
||||
domainSql :: Database -> [String] -> Either String (Database, [Row])
|
||||
domainSql db [] = Right (db, [])
|
||||
domainSql db [sql] = parseStatement sql >>= runStatement db
|
||||
domainSql db (sql : rest) = do
|
||||
statement <- parseStatement sql
|
||||
(next, _) <- runStatement db statement
|
||||
domainSql next rest
|
||||
|
||||
-- | 跑引擎层全部 hspec 用例
|
||||
main :: IO ()
|
||||
main = hspec $ do
|
||||
describe "identity syntax" $ do
|
||||
it "parses role and user attributes with their aliases" $ do
|
||||
parseStatement "ALTER ROLE worker LOGIN SUPERUSER ENABLED" `shouldBe` Right (AlterIdentity "worker" [("login", True), ("superuser", True), ("enabled", True)])
|
||||
parseStatement "ALTER USER worker NOLOGIN NOSUPERUSER DISABLED" `shouldBe` Right (AlterIdentity "worker" [("login", False), ("superuser", False), ("enabled", False)])
|
||||
parseStatement "ALTER ROLE worker IDENTIFIED BY 'Pass123!'" `shouldBe` Right (AlterUser "worker" "Pass123!")
|
||||
parseStatement "SHOW ROLES" `shouldBe` Right ShowRoles
|
||||
it "rejects empty unknown and repeated attributes" $ do
|
||||
parseStatement "ALTER ROLE worker" `shouldSatisfy` isLeft
|
||||
parseStatement "ALTER USER worker ACTIVE" `shouldSatisfy` isLeft
|
||||
prepare [] (AlterIdentity "worker" [("login", True), ("login", False)]) `shouldSatisfy` isLeft
|
||||
describe "ChuSQL.Core.Engine (DOMAIN)" $ do
|
||||
it "parses domain commands and named columns" $ do
|
||||
parseStatement "CREATE DOMAIN amount AS DECIMAL(12,2)" `shouldBe` Right (CreateDomain "amount" (CDecimal 12 2))
|
||||
parseStatement "DROP DOMAIN amount" `shouldBe` Right (DropDomain "amount")
|
||||
parseStatement "SHOW DOMAINS" `shouldBe` Right ShowDomains
|
||||
parseStatement "CREATE TABLE items (price amount)" `shouldBe` Right (CreateTable "items" [("price", plainColumn (CDomain "amount" CStr))])
|
||||
it "keeps a named type while applying its base semantics" $ do
|
||||
let result = domainSql [] ["CREATE DOMAIN label AS VARCHAR(3)", "CREATE TABLE items (name label)", "INSERT INTO items (name) VALUES ('abc')"]
|
||||
case result of
|
||||
Left err -> expectationFailure err
|
||||
Right (db, _) -> do
|
||||
fmap columnType (lookup "items" db >>= lookup "name" . tableCols) `shouldBe` Just (CDomain "label" (CVarchar 3))
|
||||
fmap snd (domainSql db ["SELECT name FROM items"]) `shouldBe` Right [[("name", VStr "abc")]]
|
||||
domainSql db ["INSERT INTO items (name) VALUES ('long')"] `shouldSatisfy` isLeft
|
||||
it "rejects unknown, duplicate and built-in domains" $ do
|
||||
mapM_ (\sql -> domainSql [] sql `shouldSatisfy` isLeft)
|
||||
[ ["CREATE TABLE items (name missing)"]
|
||||
, ["CREATE DOMAIN INT AS INT"]
|
||||
, ["CREATE DOMAIN a AS INT", "CREATE DOMAIN A AS INT"]
|
||||
, ["CREATE DOMAIN a AS missing"]
|
||||
, ["CREATE DOMAIN bad AS VARCHAR(0)"]
|
||||
]
|
||||
it "resolves nested domains and preserves their names and base checks" $ do
|
||||
let result = domainSql [] ["CREATE DOMAIN label AS VARCHAR(3)", "CREATE DOMAIN product_label AS label", "CREATE DOMAIN title AS product_label", "CREATE TABLE items (name title)", "INSERT INTO items (name) VALUES ('abc')"]
|
||||
case result of
|
||||
Left err -> expectationFailure err
|
||||
Right (db, _) -> do
|
||||
fmap columnType (lookup "items" db >>= lookup "name" . tableCols) `shouldBe` Just (CDomain "title" (CDomain "product_label" (CDomain "label" (CVarchar 3))))
|
||||
fmap snd (domainSql db ["SELECT name FROM items"]) `shouldBe` Right [[("name", VStr "abc")]]
|
||||
domainSql db ["INSERT INTO items (name) VALUES ('long')"] `shouldSatisfy` isLeft
|
||||
domainSql db ["DROP DOMAIN label"] `shouldSatisfy` isLeft
|
||||
it "protects domain dependencies even without user columns" $ do
|
||||
domainSql [] ["CREATE DOMAIN a AS INT", "CREATE DOMAIN b AS a", "DROP DOMAIN a"] `shouldSatisfy` isLeft
|
||||
fmap snd (domainSql [] ["CREATE DOMAIN a AS INT", "CREATE DOMAIN b AS a", "DROP DOMAIN b", "DROP DOMAIN a", "SHOW DOMAINS"]) `shouldBe` Right []
|
||||
domainSql [] ["CREATE DOMAIN self AS self"] `shouldSatisfy` isLeft
|
||||
it "uses nested domains in column additions and conversions" $ do
|
||||
fmap snd (domainSql [] ["CREATE DOMAIN a AS INT", "CREATE DOMAIN b AS a", "CREATE TABLE items (id INT)", "INSERT INTO items (id) VALUES (2)", "ALTER TABLE items ADD COLUMN qty b", "ALTER TABLE items ALTER COLUMN id TYPE b", "SELECT id + 1 AS next, qty FROM items"]) `shouldBe` Right [[("next", VInt 3), ("qty", VNull)]]
|
||||
it "rejects cyclic catalog definitions without recursing forever" $ do
|
||||
case domainSql [] ["CREATE DOMAIN a AS INT", "CREATE DOMAIN b AS a"] of
|
||||
Left err -> expectationFailure err
|
||||
Right (db, _) -> do
|
||||
let cyclic = map (\(name, table) -> if name == domainTableName "a" then (name, table {tableCols = [("base", plainColumn (CDomain "b" CStr))]}) else (name, table)) db
|
||||
fmap snd (domainSql cyclic ["CREATE TABLE items (id b)"]) `shouldBe` Left "cyclic domain definition: b"
|
||||
it "prevents dropping a domain until its columns are removed" $ do
|
||||
domainSql [] ["CREATE DOMAIN code AS INT", "CREATE TABLE items (code code)", "DROP DOMAIN code"] `shouldSatisfy` isLeft
|
||||
fmap snd (domainSql [] ["CREATE DOMAIN code AS INT", "CREATE TABLE items (code code)", "DROP TABLE items", "DROP DOMAIN code", "SHOW DOMAINS"]) `shouldBe` Right []
|
||||
domainSql [] ["DROP DOMAIN missing"] `shouldSatisfy` isLeft
|
||||
it "resolves domains in ADD COLUMN and ALTER COLUMN TYPE" $ do
|
||||
fmap snd (domainSql [] ["CREATE DOMAIN code AS INT", "CREATE TABLE items (id INT)", "INSERT INTO items (id) VALUES (1)", "ALTER TABLE items ADD COLUMN code code", "ALTER TABLE items ALTER COLUMN id TYPE code", "SELECT id, code FROM items"]) `shouldBe` Right [[("id", VInt 1), ("code", VNull)]]
|
||||
it "hides and protects the domain catalog from SQL" $ do
|
||||
domainSql [] ["CREATE DOMAIN code AS INT", "SELECT * FROM __system_domain_code"] `shouldSatisfy` isLeft
|
||||
domainSql [] ["CREATE DOMAIN code AS INT", "DROP TABLE __system_domain_code"] `shouldSatisfy` isLeft
|
||||
domainSql [] ["CREATE TABLE __system_domain_fake (base INT)"] `shouldSatisfy` isLeft
|
||||
it "round trips named types and compares using the base type" $ do
|
||||
let ty = CDomain "amount" (CDecimal 12 2)
|
||||
parseColumnType (typeName ty) `shouldBe` Just ty
|
||||
comparableTypes ty CInt `shouldBe` True
|
||||
integerType (CDomain "code" CInt) `shouldBe` True
|
||||
coerceValue (CDomain "code" CInt) (VStr "bad") `shouldSatisfy` isLeft
|
||||
it "uses numeric domain columns in expressions and sorting" $ do
|
||||
fmap snd (domainSql [] ["CREATE DOMAIN quantity AS INT", "CREATE TABLE items (qty quantity)", "INSERT INTO items (qty) VALUES (2), (1)", "SELECT qty + 1 AS next FROM items ORDER BY qty"]) `shouldBe` Right [[("next", VInt 2)], [("next", VInt 3)]]
|
||||
it "uses boolean domains as conditions and logical operands" $ do
|
||||
fmap snd (domainSql [] ["CREATE DOMAIN flag AS BOOL", "CREATE TABLE items (active flag)", "INSERT INTO items (active) VALUES (TRUE), (FALSE), (NULL)", "SELECT active FROM items WHERE active AND TRUE"]) `shouldBe` Right [[("active", VBool True)]]
|
||||
describe "ChuSQL.Core.Engine.Syntax.Parser" $ do
|
||||
it "resolves table-qualified columns inside database-qualified tables" $ do
|
||||
let db = [("sales.users", users)]
|
||||
@@ -114,6 +196,11 @@ main = hspec $ do
|
||||
`shouldBe` Right [[("name", VStr "Alice")]]
|
||||
rowsOf (parseStatement "SELECT sales.users.name FROM sales.users WHERE sales.users.id = 1" >>= runStatement db)
|
||||
`shouldBe` Right [[("name", VStr "Alice")]]
|
||||
let related = [("sales.users", users), ("sales.orders", orders)]
|
||||
rowsOf (parseStatement "SELECT sales.users.name FROM sales.users WHERE EXISTS (SELECT orders.id FROM sales.orders WHERE orders.user_id = sales.users.id)" >>= runStatement related)
|
||||
`shouldBe` Right [[("name", VStr "Alice")], [("name", VStr "Bob")]]
|
||||
rowsOf (parseStatement "SELECT sales.users.name FROM sales.users WHERE EXISTS (SELECT orders.id FROM sales.orders WHERE orders.user_id = intruder.users.id)" >>= runStatement related)
|
||||
`shouldSatisfy` either (isInfixOf "unknown column") (const False)
|
||||
|
||||
it "derives the column prefix when the session schema is scoped to one database" $ do
|
||||
let scoped = [("users", users)]
|
||||
@@ -1110,6 +1197,32 @@ main = hspec $ do
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
describe "ChuSQL.Core.Engine (ORDER BY)" $ do
|
||||
it "sorts projection aliases with source keys and LIMIT" $ do
|
||||
let query = "SELECT age + 1 AS next, name FROM users ORDER BY next DESC, name LIMIT 2"
|
||||
rowsOf (parseStatement query >>= runStatement testDB)
|
||||
`shouldBe` Right [[("next", VInt 31), ("name", VStr "Carol")], [("next", VInt 26), ("name", VStr "Alice")]]
|
||||
sameResultAsUnoptimized query
|
||||
it "prefers output aliases over same-named source columns" $
|
||||
rowsOf (parseStatement "SELECT -age AS age FROM users ORDER BY age LIMIT 1" >>= runStatement testDB)
|
||||
`shouldBe` Right [[("age", VInt (-30))]]
|
||||
it "evaluates non-ordering projections after LIMIT" $ do
|
||||
rowsOf (parseStatement "SELECT name AS who, 1 / (age - 25) AS value FROM users ORDER BY who DESC LIMIT 1" >>= runStatement testDB)
|
||||
`shouldBe` Right [[("who", VStr "Carol"), ("value", VInt 0)]]
|
||||
rowsOf (parseStatement "SELECT 1 / 0 AS bad FROM users ORDER BY bad LIMIT 0" >>= runStatement testDB)
|
||||
`shouldSatisfy` isLeft
|
||||
it "sorts aggregate aliases and rejects ungrouped source sort keys" $ do
|
||||
rowsOf (parseStatement "SELECT user_id, count(*) AS total FROM orders GROUP BY user_id ORDER BY total DESC" >>= runStatement testDB)
|
||||
`shouldBe` Right [[("user_id", VInt 1), ("total", VInt 2)], [("user_id", VInt 2), ("total", VInt 1)]]
|
||||
(parseStatement "SELECT count(*) AS total FROM users ORDER BY age" >>= runStatement testDB)
|
||||
`shouldSatisfy` isLeft
|
||||
it "keeps ordering aliases when a CTE renames its outputs" $
|
||||
rowsOf (parseStatement "WITH t(x) AS (SELECT age + 1 AS next FROM users ORDER BY next DESC LIMIT 1) SELECT x FROM t" >>= runStatement testDB)
|
||||
`shouldBe` Right [[("t.x", VInt 31)]]
|
||||
it "rejects duplicate ordering aliases without changing duplicate outputs" $ do
|
||||
(parseStatement "SELECT age AS x, id AS x FROM users ORDER BY x" >>= runStatement testDB)
|
||||
`shouldSatisfy` either (isInfixOf "ambiguous projection alias") (const False)
|
||||
rowsOf (parseStatement "SELECT age AS x, id AS x, name AS who FROM users ORDER BY who LIMIT 1" >>= runStatement testDB)
|
||||
`shouldBe` Right [[("x", VInt 25), ("x", VInt 1), ("who", VStr "Alice")]]
|
||||
it "parses ORDER BY DESC" $ do
|
||||
case parseStatement "SELECT name FROM users ORDER BY age DESC" of
|
||||
Right q -> selectOrderBy q `shouldBe` [("age", Desc)]
|
||||
@@ -1402,6 +1515,38 @@ main = hspec $ do
|
||||
sameResultAsUnoptimized "SELECT u.name FROM users u WHERE EXISTS (SELECT * FROM orders o WHERE o.user_id = u.id)"
|
||||
|
||||
describe "ChuSQL.Core.Engine (子查询去相关)" $ do
|
||||
it "reuses an uncorrelated JOIN subquery across all pairs" $ do
|
||||
let query = "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id AND o.product IN (SELECT product FROM orders WHERE user_id = 1)"
|
||||
(result, scans) = countedRun query
|
||||
fmap (map (map snd)) result `shouldBe` Right [[VStr "Alice", VStr "Book"], [VStr "Alice", VStr "Cup"]]
|
||||
scanTimes "orders" scans `shouldBe` 2
|
||||
sameResultAsUnoptimized query
|
||||
|
||||
it "reuses JOIN subqueries by values from both sides" $ do
|
||||
let query = "SELECT o.product FROM orders o JOIN users u ON o.user_id = u.id AND EXISTS (SELECT id FROM users x WHERE x.id = o.user_id AND x.age = u.age)"
|
||||
(result, scans) = countedRun query
|
||||
fmap (map (map snd)) result `shouldBe` Right [[VStr "Book"], [VStr "Pen"], [VStr "Cup"]]
|
||||
scanTimes "users" scans `shouldBe` 7
|
||||
sameResultAsUnoptimized query
|
||||
|
||||
it "keeps unmatched LEFT JOIN rows with a cached subquery" $ do
|
||||
let query = "SELECT u.name, o.product FROM users u LEFT JOIN orders o ON u.id = o.user_id AND EXISTS (SELECT id FROM users WHERE id = 1)"
|
||||
(result, scans) = countedRun query
|
||||
fmap (map (map snd)) result `shouldBe` Right [[VStr "Alice", VStr "Book"], [VStr "Alice", VStr "Cup"], [VStr "Bob", VStr "Pen"], [VStr "Carol", VNull]]
|
||||
scanTimes "users" scans `shouldBe` 2
|
||||
sameResultAsUnoptimized query
|
||||
|
||||
it "does not evaluate JOIN subqueries when there are no pairs" $ do
|
||||
let query = "SELECT u.name FROM users u LEFT JOIN (SELECT id FROM orders WHERE id < 0) o ON EXISTS (SELECT 1 / 0 FROM orders)"
|
||||
(result, scans) = countedRun query
|
||||
fmap (map (map snd)) result `shouldBe` Right [[VStr "Alice"], [VStr "Bob"], [VStr "Carol"]]
|
||||
scanTimes "orders" scans `shouldBe` 1
|
||||
sameResultAsUnoptimized query
|
||||
|
||||
it "propagates JOIN subquery errors before subsequent pairs" $ do
|
||||
fst (countedRun "SELECT u.name FROM users u JOIN orders o ON EXISTS (SELECT 1 / 0 FROM orders)")
|
||||
`shouldSatisfy` either (isInfixOf "division by zero") (const False)
|
||||
|
||||
it "runs a non-correlated subquery only once" $ do
|
||||
let (result, scans) = countedRun "SELECT name FROM users WHERE id IN (SELECT user_id FROM orders)"
|
||||
fmap (map (map snd)) result `shouldBe` Right [[VStr "Alice"], [VStr "Bob"]]
|
||||
@@ -1603,6 +1748,28 @@ main = hspec $ do
|
||||
relOp = Filter cond (Limit 2 (Scan Nothing "users" Nothing))
|
||||
optimize testDB relOp `shouldBe` relOp
|
||||
|
||||
it "projects derived outputs without dropping expression errors" $ do
|
||||
let original = Project ["d.name"] (Derived (Just "d") (Compute [("name", Col "name"), ("bad", Div (LitInt 1) (LitInt 0))] (Scan Nothing "users" Nothing)))
|
||||
evalRelOp testDB (optimize testDB original) `shouldBe` evalRelOp testDB original
|
||||
evalRelOp testDB original `shouldBe` Left "division by zero"
|
||||
sameResultAsUnoptimized "SELECT d.name FROM (SELECT name, age FROM users) d WHERE d.age > 20 ORDER BY d.name"
|
||||
|
||||
it "supplies memory schema statistics without exposing rows" $ do
|
||||
case runMemoryStorage (schema :: MemoryStorage Database) testDB of
|
||||
Left err -> expectationFailure err
|
||||
Right (structures, _) -> do
|
||||
map (tableRows . snd) structures `shouldBe` [[], []]
|
||||
fmap (fmap metaRowCount . tableMeta) (lookup "users" structures) `shouldBe` Just (Just 3)
|
||||
|
||||
it "uses derived schema estimates for safe join reordering" $ do
|
||||
let query = "SELECT d.name FROM (SELECT id, name FROM a) d JOIN b ON d.id = b.a_id JOIN c ON b.id = c.b_id ORDER BY d.name"
|
||||
case parseStatement query >>= prepare chainDB >>= translate of
|
||||
Left err -> expectationFailure err
|
||||
Right original -> do
|
||||
let optimized = optimize chainDB original
|
||||
planTables optimized `shouldBe` ["b", "c", "a"]
|
||||
evalRelOp chainDB optimized `shouldBe` evalRelOp chainDB original
|
||||
|
||||
it "is idempotent after reaching a fixed point" $ do
|
||||
case parseStatement "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id WHERE u.age > 20" of
|
||||
Left err -> expectationFailure err
|
||||
@@ -2034,6 +2201,20 @@ main = hspec $ do
|
||||
runIPCStorageIn (scan "iso") alpha `shouldReturn` Right [[("id", VInt 1)]]
|
||||
runIPCStorageIn (scan "iso") beta `shouldReturn` Right [[("id", VInt 2)]]
|
||||
|
||||
it "persists nested domains and named columns across restart" $ do
|
||||
withTestSession $ \srv -> do
|
||||
withServerEnv srv $ do
|
||||
runIPCStorage (runStatementM (CreateDomain "label" (CVarchar 3))) `shouldReturn` Right []
|
||||
runIPCStorage (runStatementM (CreateDomain "product_label" (CDomain "label" CStr))) `shouldReturn` Right []
|
||||
runIPCStorage (runStatementM (CreateTable "typed" [("name", plainColumn (CDomain "product_label" CStr))])) `shouldReturn` Right []
|
||||
runIPCStorage (runStatementM (Insert "typed" ["name"] [[LitStr "abc"]])) `shouldReturn` Right []
|
||||
closeConnection
|
||||
openSessionIn (dataDir srv)
|
||||
withServerEnv srv $ do
|
||||
runIPCStorage (runStatementM ShowDomains) `shouldReturn` Right [[("domain", VStr "label"), ("base_type", VStr "varchar(3)")], [("domain", VStr "product_label"), ("base_type", VStr "domain(label,varchar(3))")]]
|
||||
runIPCStorage (runStatementM (Insert "typed" ["name"] [[LitStr "long"]])) >>= (`shouldSatisfy` isLeft)
|
||||
runIPCStorage (runStatementM (DropDomain "label")) >>= (`shouldSatisfy` isLeft)
|
||||
|
||||
it "rows survive a restart on the same data directory" $ do
|
||||
withTestSession $ \srv -> do
|
||||
withServerEnv srv $ runIPCStorage (insert "persist" [("id", VInt 42)]) `shouldReturn` Right ()
|
||||
@@ -2081,6 +2262,16 @@ main = hspec $ do
|
||||
-- 存储层的日志现在直接打在本进程的输出里,没有单独的 debug.log 可读;
|
||||
-- 「走索引而不是全表扫」由下面 CREATE INDEX 那组用例与 Rust 侧 runtime 测试覆盖。
|
||||
|
||||
it "keeps correlated outer references out of physical scan columns" $ do
|
||||
withTestSession $ \srv -> withServerEnv srv $ do
|
||||
runIPCStorage (runStatementM (CreateTable "outer_t" [("id", TInt), ("name", TStr)])) `shouldReturn` Right []
|
||||
runIPCStorage (runStatementM (CreateTable "inner_t" [("id", TInt), ("user_id", TInt), ("unused", TStr)])) `shouldReturn` Right []
|
||||
runIPCStorage (runStatementM (Insert "outer_t" ["id", "name"] [[LitInt 1, LitStr "one"], [LitInt 2, LitStr "two"]])) `shouldReturn` Right []
|
||||
runIPCStorage (runStatementM (Insert "inner_t" ["id", "user_id", "unused"] [[LitInt 10, LitInt 1, LitStr "x"]])) `shouldReturn` Right []
|
||||
case parseStatement "SELECT u.name FROM outer_t u WHERE EXISTS (SELECT id FROM inner_t o WHERE o.user_id = u.id)" of
|
||||
Left err -> expectationFailure err
|
||||
Right statement -> runIPCStorage (runStatementM statement) `shouldReturn` Right [[("u.name", VStr "one")]]
|
||||
|
||||
it "CREATE INDEX makes a query on that column use the index" $ do
|
||||
withTestSession $ \srv -> withServerEnv srv $ do
|
||||
_ <- runIPCStorage (runStatementM (CreateTable "ix_t" [("id", TInt), ("code", TInt)]))
|
||||
@@ -2273,6 +2464,31 @@ main = hspec $ do
|
||||
vals seeded "SELECT age * 2 FROM users WHERE name = 'Nine'" `shouldBe` Right [[VNull]]
|
||||
|
||||
describe "ChuSQL.Core.Engine (TYPES)" $ do
|
||||
it "checks rounded decimal precision, finite values and domains" $ do
|
||||
coerceValue (CDecimal 4 2) (VFloat 99.994) `shouldBe` Right (VFloat 99.99)
|
||||
mapM_ (\value -> coerceValue (CDecimal 4 2) value `shouldSatisfy` isLeft)
|
||||
[VFloat 99.995, VFloat (-99.995), VInt 100, VFloat (0 / 0), VFloat (1 / 0)]
|
||||
coerceValue (CDecimal 2 0) (VFloat 2.5) `shouldBe` Right (VFloat 2)
|
||||
coerceValue (CDomain "amount" (CDecimal 4 2)) (VInt 100) `shouldSatisfy` isLeft
|
||||
coerceValue (CDecimal 309 0) (VInt 1) `shouldSatisfy` isLeft
|
||||
it "rejects invalid decimal definitions and overflowing defaults" $ do
|
||||
mapM_ (\query -> (parseStatement query >>= runStatement testDB) `shouldSatisfy` isLeft)
|
||||
["CREATE TABLE bad (v DECIMAL(2,3))", "CREATE TABLE bad (v DECIMAL(309,0))", "CREATE TABLE bad (v DECIMAL(2,0) DEFAULT 100)"]
|
||||
it "does not expose password input in syntax errors" $ do
|
||||
let query = "ALTER USER alice IDENTIFIED BY 'never-expose-this' trailing"
|
||||
parseStatement query `shouldSatisfy` either (\err -> "syntax" `isInfixOf` err && not ("never-expose-this" `isInfixOf` err)) (const False)
|
||||
it "rejects arbitrary prefixes for unqualified schema columns" $ do
|
||||
resolveColumn "intruder.id" [("id", TInt)] `shouldSatisfy` isLeft
|
||||
resolveColumn "wrong.u.id" [("id", TInt)] `shouldSatisfy` isLeft
|
||||
mapM_ (\query -> (parseStatement query >>= runStatement testDB) `shouldSatisfy` isLeft)
|
||||
["SELECT wrong.users.id FROM users", "SELECT wrong.u.id FROM users u", "SELECT users.id FROM users JOIN orders ON wrong.users.id = orders.user_id"]
|
||||
it "preserves untyped NULL through derived tables and CTEs" $ do
|
||||
mapM_ (\query -> rowsOf (parseStatement query >>= runStatement testDB) `shouldBe` Right [[("answer", VNull)]])
|
||||
[ "SELECT d.n + 1 AS answer FROM (SELECT NULL AS n) d"
|
||||
, "SELECT d.n AND TRUE AS answer FROM (SELECT NULL AS n) d"
|
||||
, "WITH t AS (SELECT NULL AS n) SELECT t.n + 1 AS answer FROM t"
|
||||
, "SELECT d.n + 1 AS answer FROM (SELECT x.n FROM (SELECT NULL AS n) x) d"
|
||||
]
|
||||
-- vals:在给定库上跑 SQL 只取值
|
||||
let vals db input = fmap (map (map snd)) (parseStatement input >>= rowsOf . runStatement db)
|
||||
-- withTable:先建表,返回新库
|
||||
@@ -2296,7 +2512,7 @@ main = hspec $ do
|
||||
, ("k", plainColumn CBool)
|
||||
]
|
||||
)
|
||||
parseStatement "CREATE TABLE t (a nope)" `shouldSatisfy` isLeft
|
||||
fmap snd (domainSql [] ["CREATE TABLE t (a nope)"]) `shouldBe` Left "unknown domain: nope"
|
||||
|
||||
it "reads and writes float literals" $ do
|
||||
vals testDB "SELECT 1.5 + 1" `shouldBe` Right [[VFloat 2.5]]
|
||||
|
||||
Reference in new issue
Block a user