修复错误,优化性能,实现类型系统,优化安装卸载过程

This commit is contained in:
LIm1tZz7 committed 2026-10-05 00:15:01 +08:00
1 parent fd5f320360
commit 48eec484b7
104 files changed
+4127 -845

No files matched your search

+4 -3
View File
@@ -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
+217 -1
View File
@@ -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]]