ChuNa7a/ChuSQL
1
0 Fork 0
Code Issues Pull Requests Actions 7 Packages Projects Releases Wiki Activity

推进
build / build (push) Blocked by required conditions
Details
tests / build (push) Waiting to run
Details
tests / tests (push) Canceled after 0s
Details

Browse Source
This commit is contained in:
ChuNa7a committed 2026-10-15 22:21:57 +08:00
1 parent a45e33f94b
commit 4b8c9d9e78
67 files changed
+2551 -876
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

chusql-core/engine/chusql-core-engine.cabal
+1
View File
@@ -46,6 +46,7 @@ library
, parser-combinators
, scientific
, text
, transformers
, unordered-containers
, vector
extra-libraries: chusql_core_storage
chusql-core/engine/src/ChuSQL/Core/Engine.hs
+239 -128
View File
@@ -1,15 +1,18 @@
module ChuSQL.Core.Engine (runStatement, runStatementM, rowsOf) where
module ChuSQL.Core.Engine (runStatement, runStatementM, rowsOf, BoundWrite, bindWrite, executeWriteM) where
import ChuSQL.Core.Engine.Algebra.Eval (evalCondForRowM, evalExprM)
import ChuSQL.Core.Engine.Algebra.Expr (evalCondForRow, evalExpr)
import ChuSQL.Core.Engine.Runtime.Query (bindQuery, executeQueryM)
import ChuSQL.Core.Engine.Semantic (prepare, prepareRowExpression)
import ChuSQL.Core.Engine.Runtime.Relation (bindWriteColumns, orderRow)
import ChuSQL.Core.Engine.Runtime.Dependencies (queryTables, domainDependencies, typeDependencies, validateDependencies)
import ChuSQL.Core.Engine.Semantic (prepare, prepareCheckExpression)
import ChuSQL.Core.Engine.Storage (MonadStorage (..))
import ChuSQL.Core.Engine.Storage.Memory (MemoryStorage (runMemoryStorage))
import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Engine.Syntax.Parser (parseExpression)
import ChuSQL.Core.Model
import Data.HashSet qualified as HS
import Data.HashMap.Strict qualified as HM
import Data.Maybe (mapMaybe)
-- 引擎入口：检查语义、按语句分发执行，另有内存实现与泛型版本。
@@ -33,68 +36,140 @@ runStatementM (UseDatabase name) = fmap (fmap (const [])) (useDatabase name)
runStatementM ShowDatabases = fmap (fmap (map (\name -> [("database", VStr name)]))) listDatabases
runStatementM q = do
result <- schema
case result >>= \db -> (,) db <$> prepare db q of
case result of
Left err -> pure (Left err)
Right (db, resolved) -> runStatementUncheckedM db resolved
-- | 按语句类型分发（已检查过）
runStatementUncheckedM :: (MonadStorage m) => Database -> Statement -> m (Either String [Row])
runStatementUncheckedM db q@SelectDistinct{} =
case bindQuery db q of
Left e -> pure (Left e)
Right bound -> executeQueryM bound
runStatementUncheckedM db q@Select{} =
case bindQuery db q of
Left e -> pure (Left e)
Right bound -> executeQueryM bound
runStatementUncheckedM db (Insert tbl cols rows) =
case lookupTable db tbl of
Left e -> pure (Left e)
Right table -> do
current <- existingRows tbl table
case current >>= \current' -> buildRows table current' cols rows of
Right db
| SelectDistinct{} <- q -> runStatementUncheckedM db q
| Select{} <- q -> runStatementUncheckedM db q
| null (queryTables q) -> case prepare db q >>= bindWriteColumns db of
Left err -> pure (Left err)
Right rs -> do
result <- insertMany tbl rs
pure (result >> Right [])
runStatementUncheckedM db (Delete tbl mWhere) = do
rowsResult <- scan tbl
case rowsResult of
Right resolved -> runStatementUncheckedM db resolved
| otherwise -> case bindWrite db q of
Left err -> pure (Left err)
Right bound -> executeWriteM bound
-- | 保存已有表写入的 schema、依赖及执行动作
data BoundWrite = BoundWrite Database Database WriteAction
-- | 区分已绑定的数据修改与结构变更
data WriteAction
= InsertAction String InsertPlan [[Expr]]
| UpdateAction String UpdatePlan
| DeleteAction String [String] (Maybe Expr)
| StructureAction Statement
-- | 保存 INSERT 目标、输入宽度及约束
data InsertPlan = InsertPlan [BoundInsertColumn] Int (Maybe (String, Column)) CheckPlan ConstraintPlan
-- | 保存 UPDATE 布局、赋值、条件及约束
data UpdatePlan = UpdatePlan [String] [BoundAssignment] (Maybe Expr) CheckPlan ConstraintPlan
-- | 仅用 schema 绑定已有表写入及结构变更
bindWrite :: Database -> Statement -> Either String BoundWrite
bindWrite db statement = case statement of
Select{} -> unsupported
SelectDistinct{} -> unsupported
_ | null (queryTables statement) -> unsupported
| otherwise -> do
resolved <- prepare catalog statement >>= bindWriteColumns catalog
let sources = queryTables resolved
mapM_ (lookupTable catalog) sources
let names = sources ++ domainDependencies catalog sources ++ typeDependencies catalog (declaredTypes resolved)
dependencies = [(name, table) | (name, table) <- catalog, name `elem` names]
action <- bindWriteAction catalog resolved
Right (BoundWrite catalog dependencies action)
where
catalog = [(name, table{tableRows = []}) | (name, table) <- db]
unsupported = Left "bound writes require an existing table target"
-- | 新声明类型也须保留领域依赖
declaredTypes resolved = case resolved of
AddColumn _ (_, column) -> [columnType column]
AlterColumnType _ _ ty -> [ty]
_ -> []
-- | 复查结构后执行可复用的绑定写计划
executeWriteM :: MonadStorage m => BoundWrite -> m (Either String [Row])
executeWriteM (BoundWrite catalog dependencies action) = do
current <- schema
case current >>= validateDependencies dependencies of
Left err -> pure (Left err)
Right () -> withWriteSchemaGuard dependencies (executeWriteActionM catalog action)
-- | 在绑定阶段固定目标槽位与行约束
bindWriteAction :: Database -> Statement -> Either String WriteAction
bindWriteAction catalog statement = case statement of
Insert target columns rows -> do
table <- lookupTable catalog target
checks <- checkPlan table
let plan = InsertPlan (bindInsertTargets (tableCols table) columns) (length columns)
(autoColumn table) checks (constraintPlan (tableCols table))
Right (InsertAction target plan rows)
Update target assignments condition -> do
table <- lookupTable catalog target
bound <- bindUpdateTargets (tableCols table) assignments
checks <- checkPlan table
let plan = UpdatePlan (map fst (tableCols table)) bound condition checks (constraintPlan (tableCols table))
Right (UpdateAction target plan)
Delete target condition -> do
table <- lookupTable catalog target
Right (DeleteAction target (map fst (tableCols table)) condition)
_ -> Right (StructureAction statement)
-- | 直接执行已绑定的数据修改或结构动作
executeWriteActionM :: MonadStorage m => Database -> WriteAction -> m (Either String [Row])
executeWriteActionM _ (InsertAction target plan rows) = do
current <- existingRows target plan
case current >>= \current' -> buildRows plan current' rows of
Left err -> pure (Left err)
Right built -> do
result <- insertMany target built
pure (result >> Right [])
executeWriteActionM catalog (UpdateAction target (UpdatePlan columns assignments condition checks constraints)) = do
current <- scan target
case current >>= mapM (orderRow columns) of
Left err -> pure (Left err)
Right rows -> do
split <- splitByConditionM db mWhere rows
updated <- mapM (updateRowM catalog checks condition assignments) rows
case sequence updated >>= \newRows -> enforceConstraints constraints [] newRows >> Right newRows of
Left err -> pure (Left err)
Right newRows -> do
result <- replaceAll target newRows
pure (result >> Right [])
executeWriteActionM catalog (DeleteAction target columns condition) = do
current <- scan target
case current >>= mapM (orderRow columns) of
Left err -> pure (Left err)
Right rows -> do
split <- splitByConditionM catalog condition rows
case split of
Left err -> pure (Left err)
Right (doomed, kept) ->
case mapM rowId doomed of
Right ids -> do
result <- deleteKeys tbl ids
pure (result >> Right [])
Left _ -> do
result <- replaceAll tbl kept
pure (result >> Right [])
Right (doomed, kept) -> case mapM rowId doomed of
Right ids -> do
result <- deleteKeys target ids
pure (result >> Right [])
Left _ -> do
result <- replaceAll target kept
pure (result >> Right [])
where
-- \| 取行里的整数 id，取不到就报错
rowId :: Row -> Either String Int
rowId r = case lookup "id" r of
Just (VInt k) -> Right k
-- | 取整数主键，否则使用原有整表删除路径
rowId row = case lookup "id" row of
Just (VInt key) -> Right key
_ -> Left "row has no integer id"
runStatementUncheckedM db (Update tbl assigns mWhere) =
case lookupTable db tbl of
Left e -> pure (Left e)
Right table -> do
rowsResult <- scan tbl
case rowsResult of
Left err -> pure (Left err)
Right rows -> case checkPlan table of
Left err -> pure (Left err)
Right plan -> do
newRows <- mapM (updateRowM db table plan mWhere assigns) rows
case sequence newRows of
Left err -> pure (Left err)
Right rs -> do
result <- replaceAll tbl rs
pure (result >> Right [])
executeWriteActionM catalog (StructureAction statement) = runStatementUncheckedM catalog statement
-- | 绑定并执行查询语句
runQueryM :: MonadStorage m => Database -> Statement -> m (Either String [Row])
runQueryM db q = case bindQuery db q of
Left e -> pure (Left e)
Right bound -> executeQueryM bound
-- | 分发语句，查询由 BoundQuery 绑定
runStatementUncheckedM :: (MonadStorage m) => Database -> Statement -> m (Either String [Row])
runStatementUncheckedM db q@SelectDistinct{} = runQueryM db q
runStatementUncheckedM db q@Select{} = runQueryM db q
runStatementUncheckedM _ Insert{} = pure (Left "INSERT requires a bound write plan")
runStatementUncheckedM _ Update{} = pure (Left "UPDATE requires a bound write plan")
runStatementUncheckedM _ Delete{} = pure (Left "DELETE requires a bound write plan")
runStatementUncheckedM _ (CreateTable name cols) = do
result <- createTable name cols
pure (result >> Right [])
@@ -160,61 +235,64 @@ runStatementUncheckedM _ RollbackToSavepoint{} = pure (Left "ROLLBACK TO is exec
runStatementUncheckedM _ ReleaseSavepoint{} = pure (Left "RELEASE is executed by the session")
-- | 只有需要读全表才能判断约束时才扫表
existingRows :: (MonadStorage m) => String -> Table -> m (Either String [Row])
existingRows tbl table
| needsRows table = scan tbl
existingRows :: (MonadStorage m) => String -> InsertPlan -> m (Either String [Row])
existingRows tbl (InsertPlan _ _ auto _ (ConstraintPlan _ _ unique))
| Just _ <- auto = scan tbl
| not (null unique) = scan tbl
| otherwise = pure (Right [])
where
-- \| 这一表有没有要判约束的列
needsRows t = any (constraintColumn . snd) (tableCols t)
-- \| 这一列带不带要判的约束
constraintColumn c = columnAutoIncrement c || columnUnique c || columnPrimaryKey c
-- | 插一行：补齐缺列、给自增值、收类型、查约束
buildRows :: Table -> [Row] -> [String] -> [[Expr]] -> Either String [Row]
buildRows table current cols rows = do
values <- mapM (mapM (\e -> evalExpr e [])) rows
if any (\vals -> length vals /= length cols) values
buildRows :: InsertPlan -> [Row] -> [[Expr]] -> Either String [Row]
buildRows (InsertPlan layout width auto checks constraints) current rows = do
values <- mapM (mapM (`evalExpr` [])) rows
if any (\vals -> length vals /= width) values
then Left "column count does not match value count"
else do
let auto = autoColumn table
go auto (autoStart auto current) values []
else go (autoStart auto current) values []
where
-- \| 逐行构造，最后统一查一遍约束
go _ _ [] acc = do
go _ [] acc = do
let built = reverse acc
plan <- checkPlan table
mapM_ (runChecks plan) built
enforceNotNull (tableCols table) built
enforceUnique (tableCols table) (current ++ built)
mapM_ (runChecks checks) built
enforceConstraints constraints current built
Right built
go auto counter (vals : rest) acc = do
(row, counter') <- buildRow table auto cols counter vals
go auto counter' rest (row : acc)
go counter (vals : rest) acc = do
(row, counter') <- buildRow layout auto counter vals
go counter' rest (row : acc)
-- | 按列定义补出一行
buildRow :: Table -> Maybe (String, Column) -> [String] -> Int -> [Value] -> Either String (Row, Int)
buildRow table auto cols counter vals = go (tableCols table) counter []
-- | 保存输出列定义及可选 VALUES 槽位
data BoundInsertColumn = BoundInsertColumn String Column (Maybe Int)
-- | 把已校验的目标清单绑定为输入槽位
bindInsertTargets :: [(String, Column)] -> [String] -> [BoundInsertColumn]
bindInsertTargets columns targets =
[BoundInsertColumn name column (lookup name positions) | (name, column) <- columns]
where
provided = zip cols vals
positions = zip targets [0 ..]
-- | 按绑定槽位和列定义补出一行
buildRow :: [BoundInsertColumn] -> Maybe (String, Column) -> Int -> [Value] -> Either String (Row, Int)
buildRow layout auto counter vals = go layout counter []
where
provided = HM.fromList (zip [0 :: Int ..] vals)
-- \| 按列定义逐列补值
go [] c acc = Right (reverse acc, c)
go ((name, col) : rest) c acc = do
(v, c') <- pick name col c
go (BoundInsertColumn name col position : rest) c acc = do
supplied <- mapM (\slot -> maybe (Left ("missing bound INSERT value: " ++ name)) Right (HM.lookup slot provided)) position
(v, c') <- pick name col supplied c
v' <- coerceValue (columnType col) v
go rest c' ((name, v') : acc)
-- \| 决定这一列取什么值
pick name col c
pick name col supplied c
| Just (autoName, _) <- auto
, name == autoName
, maybe True (== VNull) (lookup name provided) =
, maybe True (== VNull) supplied =
Right (VInt c, c + 1)
| Just v <- lookup name provided = Right (v, bump name col c v)
| Just v <- supplied = Right (v, bump name c v)
| Just d <- columnDefault col = Right (d, c)
| columnNullable col = Right (VNull, c)
| otherwise = Left ("INSERT: column " ++ name ++ " is NOT NULL and has no default")
-- \| 自增值跟着已有的值往前推
bump name _ c v
bump name c v
| Just (autoName, _) <- auto
, name == autoName =
max (c + 1) (valueInt v + 1)
@@ -239,11 +317,11 @@ autoStart (Just (name, _)) rows = case [n | r <- rows, Just (VInt n) <- [lookup
ns -> maximum ns + 1
-- | 一次解析出来的 CHECK 条件
type CheckPlan = [(String, Expr)]
data CheckPlan = CheckPlan [String] [(String, Expr)]
-- | 把表上的 CHECK 文本解析成条件，每语句只解析一次
-- | 按 schema 解析并绑定表上全部 CHECK
checkPlan :: Table -> Either String CheckPlan
checkPlan table = mapM parse (mapMaybe checked (tableCols table))
checkPlan table = CheckPlan (map fst (tableCols table)) <$> mapM parse (mapMaybe checked (tableCols table))
where
-- \| 只挑出带 CHECK 文本的列
checked (name, col) = (,) name <$> columnCheck col
@@ -251,15 +329,17 @@ checkPlan table = mapM parse (mapMaybe checked (tableCols table))
parse (name, text) = case parseExpression text of
Left err -> Left ("CHECK on " ++ name ++ ": " ++ firstLine err)
Right e -> do
bound <- prepareRowExpression (tableCols table) e
bound <- prepareCheckExpression (tableCols table) e
Right (name, bound)
-- | 执行解析好的 CHECK 条件
runChecks :: CheckPlan -> Row -> Either String ()
runChecks plan row = mapM_ check plan
runChecks (CheckPlan columns plan) row = do
ordered <- orderRow columns row
mapM_ (check ordered) plan
where
-- \| 跑一条 CHECK
check (name, e) = case evalCondForRow e row of
check ordered (name, e) = case evalCondForRow e ordered of
Left err -> Left ("CHECK on " ++ name ++ ": " ++ err)
Right True -> Right ()
Right False -> Left ("CHECK on " ++ name ++ " failed")
@@ -268,23 +348,41 @@ runChecks plan row = mapM_ check plan
firstLine :: String -> String
firstLine = takeWhile (/= '\n')
-- | NOT NULL 检查
enforceNotNull :: [(String, Column)] -> [Row] -> Either String ()
enforceNotNull cols rows = mapM_ check cols
-- | 保存非空及唯一键的固定列槽位
data ConstraintPlan = ConstraintPlan [String] [(String, Expr)] [(String, Expr)]
-- | 按 schema 一次绑定行集约束目标
constraintPlan :: [(String, Column)] -> ConstraintPlan
constraintPlan columns = ConstraintPlan (map fst columns) required unique
where
-- \| 查这一列的 NOT NULL
check (name, col)
| columnNullable col = Right ()
| any (\r -> lookup name r == Just VNull) rows = Left ("NOT NULL: column " ++ name ++ " cannot be null")
| otherwise = Right ()
slots = [(name, column, ColumnSlot slot name) | (slot, (name, column)) <- zip [0 ..] columns]
required = [(name, reference) | (name, column, reference) <- slots, not (columnNullable column)]
unique = [(name, reference) | (name, column, reference) <- slots, columnUnique column || columnPrimaryKey column]
-- | 检查新行非空及合并旧行后的唯一性
enforceConstraints :: ConstraintPlan -> [Row] -> [Row] -> Either String ()
enforceConstraints (ConstraintPlan columns required unique) current rows = do
enforceNotNull required rows
orderedCurrent <- mapM (orderRow columns) current
enforceUnique unique (orderedCurrent ++ rows)
-- | NOT NULL 检查
enforceNotNull :: [(String, Expr)] -> [Row] -> Either String ()
enforceNotNull targets rows = mapM_ check targets
where
-- | 按 schema 槽位检查 NOT NULL
check (name, reference) = do
values <- mapM (evalExpr reference) rows
if VNull `elem` values
then Left ("NOT NULL: column " ++ name ++ " cannot be null")
else Right ()
-- | 唯一性检查（NULL 之间不算冲突）
enforceUnique :: [(String, Column)] -> [Row] -> Either String ()
enforceUnique cols rows = mapM_ check targets
enforceUnique :: [(String, Expr)] -> [Row] -> Either String ()
enforceUnique targets rows = mapM_ check targets
where
targets = [(n, c) | (n, c) <- cols, columnUnique c || columnPrimaryKey c]
-- \| 查这一列有没有重复值
check (name, _) = go name HS.empty (mapMaybe (lookup name) rows)
check (name, reference) = mapM (evalExpr reference) rows >>= go name HS.empty
-- \| 逐个值比过去
go _ _ [] = Right ()
-- \| NULL 不算冲突，跳过
@@ -294,8 +392,8 @@ enforceUnique cols rows = mapM_ check targets
| otherwise = go name (HS.insert (canonicalValue v) seen) rest
-- | UPDATE 的一行（条件与赋值都可能带子查询）
updateRowM :: (MonadStorage m) => Database -> Table -> CheckPlan -> Maybe Expr -> [(String, Expr)] -> Row -> m (Either String Row)
updateRowM db table plan cond asgns row = do
updateRowM :: (MonadStorage m) => Database -> CheckPlan -> Maybe Expr -> [BoundAssignment] -> Row -> m (Either String Row)
updateRowM db plan cond asgns row = do
keep <- case cond of
Nothing -> pure (Right True)
Just e -> evalCondForRowM db e row
@@ -303,25 +401,39 @@ updateRowM db table plan cond asgns row = do
Left err -> pure (Left err)
Right False -> pure (Right row)
Right True -> do
row' <- applyUpdatesM db table asgns row
row' <- applyUpdatesM db asgns row
pure (row' >>= \r -> runChecks plan r >> Right r)
-- | 依次求值、收类型并覆盖列（表达式可以带子查询）
applyUpdatesM :: (MonadStorage m) => Database -> Table -> [(String, Expr)] -> Row -> m (Either String Row)
applyUpdatesM _ _ [] row = pure (Right row)
applyUpdatesM db table ((col, e) : rest) row = do
v <- evalExprM db e row
case v of
Left err -> pure (Left err)
Right val -> case colType table col of
Just def -> case coerceValue (columnType def) val of
Left err -> pure (Left err)
Right v' -> applyUpdatesM db table rest (setColumn col v' row)
Nothing -> applyUpdatesM db table rest (setColumn col val row)
-- | 保存赋值目标槽位、列定义和右侧表达式
data BoundAssignment = BoundAssignment Int String Column Expr
-- | 覆盖一列
setColumn :: String -> Value -> Row -> Row
setColumn col v = map (\(k, val) -> if k == col then (k, v) else (k, val))
-- | 按 schema 一次绑定全部赋值目标
bindUpdateTargets :: [(String, Column)] -> [(String, Expr)] -> Either String [BoundAssignment]
bindUpdateTargets columns = mapM bindTarget
where
-- | 只接受唯一目标并保留列定义
bindTarget (name, expression) = case [(slot, column) | (slot, (key, column)) <- zip [0 ..] columns, key == name] of
[(slot, column)] -> Right (BoundAssignment slot name column expression)
[] -> Left ("UPDATE: unknown target column: " ++ name)
_ -> Left ("UPDATE: ambiguous target column: " ++ name)
-- | 依次求值并按目标槽位收类型和覆盖
applyUpdatesM :: (MonadStorage m) => Database -> [BoundAssignment] -> Row -> m (Either String Row)
applyUpdatesM _ [] row = pure (Right row)
applyUpdatesM db (assignment@(BoundAssignment _ _ _ e) : rest) row = do
v <- evalExprM db e row
case v >>= writeAssignment assignment row of
Left err -> pure (Left err)
Right updated -> applyUpdatesM db rest updated
-- | 校验目标位置并只覆盖该槽位的值
writeAssignment :: BoundAssignment -> Row -> Value -> Either String Row
writeAssignment (BoundAssignment slot name column _) row value = case splitAt slot row of
(before, (key, _) : after) | slot >= 0, key == name -> do
coerced <- coerceValue (columnType column) value
Right (before ++ ((name, coerced) : after))
(_, []) -> Left ("missing bound column: " ++ name)
_ -> Left ("bound column position mismatch: " ++ name)
-- | 按条件把行分成待删和保留两拨（条件可以带子查询）
splitByConditionM :: (MonadStorage m) => Database -> Maybe Expr -> [Row] -> m (Either String ([Row], [Row]))
@@ -348,7 +460,7 @@ alterTable db tbl change = case lookupTable db tbl of
Left e -> pure (Left e)
Right table -> do
rowsResult <- scan tbl
case rowsResult of
case rowsResult >>= mapM (orderRow (map fst (tableCols table))) of
Left e -> pure (Left e)
Right rows -> case change table{tableRows = rows} >>= checkAltered of
Left e -> pure (Left e)
@@ -361,8 +473,7 @@ alterTable db tbl change = case lookupTable db tbl of
let table = Table tbl cols rows Nothing Nothing Nothing
plan <- checkPlan table
mapM_ (runChecks plan) rows
enforceNotNull cols rows
enforceUnique cols rows
enforceConstraints (constraintPlan cols) [] rows
Right (cols, rows)
-- | ADD COLUMN：老行补默认值或 NULL
chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Cost.hs
+3 -2
View File
@@ -1,5 +1,6 @@
module ChuSQL.Core.Engine.Algebra.Cost (tableMetaOf, probeCost, pointRows, rangeRows, selectivityOf, indexCheaper) where
import Data.Maybe (fromMaybe)
import ChuSQL.Core.Model
-- 统计与成本估算：行数、不同值数、列直方图与索引探路页数。
@@ -32,8 +33,8 @@ estimateRows h lo hi = max 0 (min total (round (sum (zipWith overlap [0 ..] (his
where
total = sum (histBuckets h)
width = if histHigh h > histLow h then (histHigh h - histLow h) / fromIntegral (length (histBuckets h)) else 0
lower = maybe (-1 / 0) id (boundOf lo)
upper = maybe (1 / 0) id (boundOf hi)
lower = fromMaybe (- (1 / 0)) (boundOf lo)
upper = fromMaybe (1 / 0) (boundOf hi)
-- | 第 i 个桶与区间重叠的行数
overlap :: Int -> Int -> Double
overlap i count
chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Eval.hs
+155 -73
View File
@@ -1,24 +1,44 @@
{-# LANGUAGE TupleSections #-}
module ChuSQL.Core.Engine.Algebra.Eval (evalRelOp, evalRelOpM, evalExprM, evalCondForRowM) where
import ChuSQL.Core.Engine.Algebra.Cost (tableMetaOf)
import ChuSQL.Core.Engine.Algebra.Expr (evalCondForRow, evalExpr, hasSubquery, quantifiedCompare, subqueryRefsIn)
import ChuSQL.Core.Engine.Algebra.Expr (evalCondForRow, evalExpr, hasSubquery, quantifiedCompare, subquerySlotsIn, subqueryColumns)
import ChuSQL.Core.Engine.Algebra.Optimize (optimize)
import ChuSQL.Core.Engine.Algebra.Op
import ChuSQL.Core.Engine.Algebra.Planner (translate)
import ChuSQL.Core.Engine.Algebra.Sort (sortRows, sortBoundRows)
import ChuSQL.Core.Engine.Runtime.Relation (bindRelOpColumns)
import ChuSQL.Core.Engine.Builtin (aggregateArg, builtinOfExpr, invokeBuiltin, unsupportedAggregate)
import ChuSQL.Core.Engine.Runtime.Relation (bindRelOpColumns, orderRow)
import ChuSQL.Core.Engine.Builtin (aggregateArg, builtinOfExpr, invokeBuiltin, unsupportedAggregate, inValues)
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Storage (IndexResult (..), MonadStorage (..))
import ChuSQL.Core.Engine.Storage.Memory (runMemoryStorage)
import ChuSQL.Core.Engine.Syntax.AST (Expr (..), JoinKind (..), Subquery (..))
import Control.Monad (filterM)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Strict (StateT, evalStateT, gets, modify')
import Data.List (nub)
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
-- 执行：按算子树算出结果行，外层行供相关子查询引用。
-- | 单次执行共享已物化结果，不跨查询保留
type Execution m a = StateT (HM.HashMap String [Row]) m a
-- | 首次使用时执行，成功结果供后续引用复用
materialize :: Monad m => String -> Execution m (Either String [Row]) -> Execution m (Either String [Row])
materialize key action = do
cached <- gets (HM.lookup key)
case cached of
Just rows -> pure (Right rows)
Nothing -> do
result <- action
case result of
Left _ -> pure result
Right rows -> do
modify' (HM.insert key rows)
pure result
-- | 只保留清单里的列，顺序照清单
project :: [String] -> Row -> Row
project ["*"] row = row
@@ -96,14 +116,7 @@ columnName _ = Nothing
-- | 在存储边界按输入布局排列行
orderedRows :: [String] -> [Row] -> Either String [Row]
orderedRows columns = mapM order
where
-- | 按列布局排列一行
order row = mapM (column row) columns
-- | 缺少物理列时明确报错
column row name = case lookup name row of
Just value -> Right (name, value)
Nothing -> Left ("missing bound column: " ++ name)
orderedRows columns = mapM (orderRow columns)
-- | 连接两批行：等值键走哈希，否则嵌套循环
joinRowsIn ::
@@ -115,7 +128,7 @@ joinRowsIn ::
Expr ->
[Row] ->
[Row] ->
m (Either String [Row])
Execution m (Either String [Row])
joinRowsIn db outer kind rcols cond lrows rrows =
case equiKeys (rowsCols lrows) rcols cond of
Just ks -> pure (Right (hashJoin kind ks ncols lrows rrows))
@@ -124,6 +137,37 @@ joinRowsIn db outer kind rcols cond lrows rrows =
-- 右表为空时行上没有列名，用算子推导出来的列名补 NULL
ncols = if null rrows then rcols else rowsCols rrows
-- | 哈希判定存在性，仅输出原始左行
semiRows :: SemiKind -> Expr -> Expr -> Row -> [Row] -> [Row] -> Either String [Row]
semiRows kind left right outer leftRows rightRows = do
values <- mapM (evalExpr right . (++ outer)) rightRows
let keys = HS.fromList [canonicalValue value | value <- values, value /= VNull]
hasNull = VNull `elem` values
hashSafe = all safeNumber values
-- | NULL 与数值边界沿用表达式比较规则
keep row = do
value <- evalExpr left (row ++ outer)
if value == VNull
then Right (kind == NonMatching || kind == NotIn && null values)
else if hashSafe && safeNumber value
then let found = HS.member (canonicalValue value) keys
in Right (case kind of
Matching -> found
NonMatching -> not found
NotIn -> not found && not hasNull)
else do
result <- inValues value values
Right (case kind of
Matching -> result == VBool True
NonMatching -> result /= VBool True
NotIn -> result == VBool False)
filterM keep leftRows
where
-- | 大数混合比较退回既有逐值语义
safeNumber (VInt value) = abs (toInteger value) <= 9007199254740992
safeNumber (VFloat value) = abs value <= 9007199254740992
safeNumber _ = True
-- | 左连接配不上的左行补 NULL，内连接丢弃
unmatched :: JoinKind -> Row -> [String] -> [Row]
unmatched InnerJoin _ _ = []
@@ -156,10 +200,10 @@ filterPairsM ::
Expr ->
[Row] ->
[Row] ->
m (Either String [Row])
Execution m (Either String [Row])
filterPairsM db outer kind ncols cond lrows rrows = go lrows [] HM.empty
where
refs = subqueryRefsIn cond
refs = subquerySlotsIn cond
-- | 逐左行配对，左连接没配上就补 NULL
go [] acc _ = pure (Right (reverse acc))
go (l : ls) acc cache = do
@@ -175,15 +219,17 @@ filterPairsM db outer kind ncols cond lrows rrows = go lrows [] HM.empty
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 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)
case bindingKey refs env of
Left err -> pure (Left err)
Right key -> do
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 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 时逐左行点查
@@ -198,13 +244,13 @@ probeIndexJoin ::
[String] ->
Expr ->
Row ->
m (Either String (Maybe [Row]))
Execution m (Either String (Maybe [Row]))
probeIndexJoin db outer kind mAlias t ks rcols cond l = case lookup (ekLeft ks) l of
Nothing -> pure (Right (Just (unmatched kind l rcols)))
Just k
| not (indexSafe db t (unqualify mAlias (ekRight ks)) k) -> pure (Right Nothing)
| otherwise -> do
res <- lookupByColumn t (unqualify mAlias (ekRight ks)) k
res <- lift (lookupByColumn t (unqualify mAlias (ekRight ks)) k)
case res of
Left e -> pure (Left e)
Right NoIndex -> pure (Right Nothing)
@@ -251,7 +297,7 @@ groupRows outer keys rows = go rows (HM.empty, [])
-- | 一组行上求同一个表达式（外层列从 outer 取）
valuesOf :: Row -> Expr -> [Row] -> Either String [Value]
valuesOf outer e rows = mapM (evalExpr e . (++ outer)) rows
valuesOf outer e = mapM (evalExpr e . (++ outer))
-- | 一个聚合算子在一组行上的结果，统一走内置函数权威
evalAgg :: Row -> Expr -> [Row] -> Either String Value
@@ -275,8 +321,15 @@ evalAggregate outer keys aggs rows = do
mapM (oneGroup outer (map fst keys) aggs) top
-- | 绑定键：子查询引用的外层列在这一行上的取值
bindingKey :: [String] -> Row -> String
bindingKey refs env = show [(c, bindingValue c env) | c <- refs]
bindingKey :: [Expr] -> Row -> Either String String
bindingKey refs env = show <$> mapM (\reference -> (,) reference <$> bindingReferenceValue reference env) refs
-- | 按已绑定槽位取值，原始计划保留名称入口
bindingReferenceValue :: Expr -> Row -> Either String Value
bindingReferenceValue (Col name) env = case bindingValue name env of
Just value -> Right value
Nothing -> Left ("unknown outer column: " ++ name)
bindingReferenceValue expression env = evalExpr expression env
-- | 查已解析外层引用对应的物理列值
bindingValue :: String -> Row -> Maybe Value
@@ -286,15 +339,15 @@ bindingValue column env = case lookup column env of
Nothing -> Nothing
-- | 每个绑定留第一行当样本，去掉重复绑定
bindingSamples :: [String] -> Row -> [Row] -> [(String, Row)]
bindingSamples :: [Expr] -> Row -> [Row] -> Either String [(String, Row)]
bindingSamples refs outer rows = go rows HM.empty []
where
-- | 逐行按绑定键去重
go [] _ acc = reverse acc
go (r : rs) seen acc =
go [] _ acc = Right (reverse acc)
go (r : rs) seen acc = do
let env = r ++ outer
k = bindingKey refs env
in case HM.lookup k seen of
k <- bindingKey refs env
case HM.lookup k seen of
Just _ -> go rs seen acc
Nothing -> go rs (HM.insert k () seen) ((k, env) : acc)
@@ -305,28 +358,34 @@ bindingsTableM ::
Row ->
[Expr] ->
[Row] ->
m (Either String (HM.HashMap String [Expr]))
bindingsTableM db outer exprs rows = do
built <- mapM swap (bindingSamples refs outer rows)
pure (fmap HM.fromList (sequence built))
Execution m (Either String (HM.HashMap String [Expr]))
bindingsTableM db outer exprs rows = case bindingSamples refs outer rows of
Left err -> pure (Left err)
Right samples -> do
built <- mapM swap samples
pure (fmap HM.fromList (sequence built))
where
refs = nub (concatMap subqueryRefsIn exprs)
refs = nub (concatMap subquerySlotsIn exprs)
-- | 一个绑定样本上把子查询全换成字面量
swap (key, env) = do
es <- mapM (\e -> substSubqueries db e env) exprs
pure (fmap (\xs -> (key, xs)) (sequence es))
pure (fmap (key,) (sequence es))
-- | 取这一行绑定换好的表达式；没有这个绑定就是内部错误
boundExprs :: [String] -> Row -> HM.HashMap String [Expr] -> Either String [Expr]
boundExprs refs env table = case HM.lookup (bindingKey refs env) table of
Just es -> Right es
Nothing -> Left "subquery binding is missing"
boundExprs :: [Expr] -> Row -> HM.HashMap String [Expr] -> Either String [Expr]
boundExprs refs env table = do
key <- bindingKey refs env
case HM.lookup key table of
Just es -> Right es
Nothing -> Left "subquery binding is missing"
-- | 取这一行绑定换好的唯一表达式
boundExpr :: [String] -> Row -> HM.HashMap String [Expr] -> Either String Expr
boundExpr refs env table = case boundExprs refs env table of
Right [x] -> Right x
_ -> Left "subquery binding is missing"
boundExpr :: [Expr] -> Row -> HM.HashMap String [Expr] -> Either String Expr
boundExpr refs env table = do
expressions <- boundExprs refs env table
case expressions of
[x] -> Right x
_ -> Left "subquery binding is missing"
-- | 单子过滤：条件本身是单子求值的
filterRowsM :: (Monad m) => (Row -> m (Either String Bool)) -> [Row] -> m (Either String [Row])
@@ -342,26 +401,34 @@ filterRowsM p = go []
Right False -> go acc rs
-- | 按投影顺序逐项求值（可以带子查询）
computeM :: (MonadStorage m) => Database -> Row -> [(String, Expr)] -> Row -> m (Either String Row)
computeM :: (MonadStorage m) => Database -> Row -> [(String, Expr)] -> Row -> Execution m (Either String Row)
computeM db outer items row = go items []
where
-- | 逐项求值并攒成一行
go [] acc = pure (Right (reverse acc))
go ((label, e) : rest) acc = do
v <- evalExprM db e (row ++ outer)
v <- evalExprIn db e (row ++ outer)
case v of
Left err -> pure (Left err)
Right val -> go rest ((label, val) : acc)
-- | 表达式求值（先把子查询求成字面量）
evalExprM :: (MonadStorage m) => Database -> Expr -> Row -> m (Either String Value)
evalExprM db e env = do
evalExprM db e env = evalStateT (evalExprIn db e env) HM.empty
-- | 在当前执行中求值并共享子查询物化
evalExprIn :: MonadStorage m => Database -> Expr -> Row -> Execution m (Either String Value)
evalExprIn db e env = do
e' <- substSubqueries db e env
pure (e' >>= \x -> evalExpr x env)
-- | 条件求值（先把子查询求成字面量）
evalCondForRowM :: (MonadStorage m) => Database -> Expr -> Row -> m (Either String Bool)
evalCondForRowM db e env = do
evalCondForRowM db e env = evalStateT (evalCondIn db e env) HM.empty
-- | 在当前执行中判定条件并共享物化
evalCondIn :: MonadStorage m => Database -> Expr -> Row -> Execution m (Either String Bool)
evalCondIn db e env = do
e' <- substSubqueries db e env
pure (e' >>= \x -> evalCondForRow x env)
@@ -380,7 +447,7 @@ scalarResult rows = do
_ -> Left "scalar subquery returned more than one row"
-- | 把子查询求值成字面量；子查询的错直接往上传
substSubqueries :: (MonadStorage m) => Database -> Expr -> Row -> m (Either String Expr)
substSubqueries :: (MonadStorage m) => Database -> Expr -> Row -> Execution m (Either String Expr)
substSubqueries db e env = case e of
Construct tid arguments -> do
bound <- mapM (\argument -> substSubqueries db argument env) arguments
@@ -450,39 +517,42 @@ substSubqueries db e env = case e of
Left err -> pure (Left err)
Right a' -> do
rb <- substSubqueries db b env
pure ((ctor a') <$> rb)
pure (ctor a' <$> rb)
-- | 递归处理一个子表达式
un ctor a = do
ra <- substSubqueries db a env
pure (ctor <$> ra)
-- | 跑子查询：翻译成算子树再求值，外层行做相关子查询的绑定
runSubqueryRows :: (MonadStorage m) => Database -> Subquery -> Row -> m (Either String [Row])
runSubqueryRows :: (MonadStorage m) => Database -> Subquery -> Row -> Execution m (Either String [Row])
runSubqueryRows db sq outer = case translate (subqueryStatement sq) of
Left e -> pure (Left e)
Right op -> case mapM bind (subqueryRefs sq) of
Right op -> case mapM bind (subqueryColumns sq) of
Left err -> pure (Left err)
Right bindings -> case bindRelOpColumns db (map fst (bindings ++ outer)) (optimize db op) of
Left err -> pure (Left err)
Right bound -> evalRelOpIn db (bindings ++ outer) bound
Right bound -> materialize (show ("subquery", subqueryStatement sq, bindings, fallback))
(evalRelOpIn db (bindings ++ outer) bound)
where
-- | 原始调用未证明依赖完整，保留整个外层行
fallback = case sq of
Subquery{} -> Just outer
BoundSubquery{} -> Nothing
-- | 给外层物理列补回已解析的限定名
bind column = case bindingValue column outer of
Just value -> Right (column, value)
Nothing -> Left ("unknown outer column: " ++ column)
bind (column, expression) = (,) column <$> bindingReferenceValue expression outer
-- | 单子求值：Scan/点查/范围查都问存储
evalRelOpM :: (MonadStorage m) => Database -> RelOp -> m (Either String [Row])
evalRelOpM db = evalRelOpIn db []
evalRelOpM db op = evalStateT (evalRelOpIn db [] op) HM.empty
-- | 纯求值（内存存储，子查询走同一条路径）
evalRelOp :: Database -> RelOp -> Either String [Row]
evalRelOp db op = do
(result, _) <- runMemoryStorage (evalRelOpIn db [] op) db
(result, _) <- runMemoryStorage (evalRelOpM db op) db
result
-- | 带外层行的执行器
evalRelOpIn :: (MonadStorage m) => Database -> Row -> RelOp -> m (Either String [Row])
evalRelOpIn :: (MonadStorage m) => Database -> Row -> RelOp -> Execution m (Either String [Row])
evalRelOpIn _ _ Unit = pure (Right [[]])
evalRelOpIn db outer (Compute items op) = do
rows <- evalRelOpIn db outer op
@@ -496,7 +566,7 @@ evalRelOpIn db outer (Compute items op) = do
table <- bindingsTableM db outer (map snd items) rs
pure (table >>= \t -> traverse (computeBound t) rs)
where
refs = nub (concatMap (subqueryRefsIn . snd) items)
refs = nub (concatMap (subquerySlotsIn . snd) items)
-- | 用这一行绑定换好的表达式算出一行
computeBound table r = do
es <- boundExprs refs (r ++ outer) table
@@ -511,13 +581,13 @@ evalRelOpIn db _ (Scan mAlias tbl cols) = do
res <- scanTable db tbl cols
pure (res >>= orderedRows (relOpCols db (Scan mAlias tbl cols)) . prefixRows mAlias)
evalRelOpIn db outer (Lookup mAlias tbl col k) = do
res <- lookupByColumn tbl col k
res <- lift (lookupByColumn tbl col k)
case res of
Left e -> pure (Left e)
Right NoIndex -> scanFiltered db outer mAlias tbl (lookupCondition mAlias col k)
Right (IndexRows rows) -> pure (orderedRows (relOpCols db (Lookup mAlias tbl col k)) (prefixRows mAlias rows))
evalRelOpIn db outer (Range mAlias tbl col lo hi) = do
res <- scanRange tbl col lo hi
res <- lift (scanRange tbl col lo hi)
case res of
Left e -> pure (Left e)
Right Nothing -> scanFiltered db outer mAlias tbl (rangeCondition mAlias col lo hi)
@@ -527,12 +597,12 @@ evalRelOpIn db outer (Filter e op) = do
case rows of
Left err -> pure (Left err)
Right rs
| not (hasSubquery e) -> filterRowsM (\r -> evalCondForRowM db e (r ++ outer)) rs
| not (hasSubquery e) -> filterRowsM (\r -> evalCondIn db e (r ++ outer)) rs
| otherwise -> do
table <- bindingsTableM db outer [e] rs
pure (table >>= \t -> filterM (keepBound t) rs)
where
refs = nub (subqueryRefsIn e)
refs = nub (subquerySlotsIn e)
-- | 用这一行绑定换好的条件判定
keepBound table r = do
e' <- boundExpr refs (r ++ outer) table
@@ -553,8 +623,20 @@ evalRelOpIn db outer (Limit n op) = do
rows <- evalRelOpIn db outer op
pure (fmap (take n) rows)
evalRelOpIn db outer (Derived mAlias op) = do
rows <- evalRelOpIn db outer op
rows <- materialize (show ("derived", op, outer)) (evalRelOpIn db outer op)
pure (fmap (prefixRows mAlias) rows)
evalRelOpIn db outer (SemiJoin kind left right l r query) = do
rows <- evalRelOpIn db outer l
case rows of
Left err -> pure (Left err)
Right [] -> pure (Right [])
Right leftRows -> do
-- | 独立 IN 沿用子查询身份，跨算子复用结果
let key = case query of
Just statement -> show ("subquery", statement, [] :: Row, Nothing :: Maybe Row)
Nothing -> show ("derived", r, outer)
rightRows <- materialize key (evalRelOpIn db outer r)
pure (rightRows >>= semiRows kind left right outer leftRows)
evalRelOpIn db outer (Join kind l r c) = do
lres <- evalRelOpIn db outer l
case lres of
@@ -583,7 +665,7 @@ scanFiltered ::
Maybe String ->
String ->
Expr ->
m (Either String [Row])
Execution m (Either String [Row])
scanFiltered db outer mAlias tbl cond = do
res <- scanTable db tbl Nothing
pure $ do
@@ -595,12 +677,12 @@ parallelRowThreshold :: Int
parallelRowThreshold = 1000
-- | 表够大且存储支持并行时按分片扫，否则顺序扫
scanTable :: (MonadStorage m) => Database -> String -> Maybe [String] -> m (Either String [Row])
scanTable :: (MonadStorage m) => Database -> String -> Maybe [String] -> Execution m (Either String [Row])
scanTable db tbl cols = do
width <- parallelShards
width <- lift parallelShards
if width > 1 && rows >= parallelRowThreshold
then scanShards width tbl cols
else maybe (scan tbl) (scanColumns tbl) cols
then lift (scanShards width tbl cols)
else lift (maybe (scan tbl) (scanColumns tbl) cols)
where
-- | 统计里的行数，没有统计算 0
rows = maybe 0 metaRowCount (tableMetaOf db tbl)
chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Expr.hs
+44 -27
View File
@@ -1,4 +1,4 @@
module ChuSQL.Core.Engine.Algebra.Expr (evalExpr, evalCondForRow, colsInExpr, subqueryRefsIn, aggregatesIn, hasAggregate, bareColumns, hasSubquery, hasDivision, inValues, threeValuedNot, quantifiedCompare) where
module ChuSQL.Core.Engine.Algebra.Expr (evalExpr, evalCondForRow, colsInExpr, subqueryRefsIn, subquerySlotsIn, subqueryColumns, aggregatesIn, hasAggregate, bareColumns, hasSubquery, hasDivision, inValues, threeValuedNot, quantifiedCompare) where
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Syntax.AST
@@ -20,10 +20,10 @@ evalExpr (OuterColumnSlot localWidth slot name) row
| otherwise = evalExpr (ColumnSlot slot name) (drop localWidth row)
evalExpr (FunctionCall name _) _ = Left ("unbound function call: " ++ name)
evalExpr (Construct _ _) _ = Left "unbound runtime constructor"
evalExpr (BoundConstruct tid arguments) row = mapM (\argument -> evalExpr argument row) arguments >>= constructSQLValue tid
evalExpr (BoundConstruct tid arguments) row = mapM (`evalExpr` row) arguments >>= constructSQLValue tid
evalExpr (RuntimeLiteral tid value) _ = coerceValue (CRuntime tid) (VRuntime tid value)
evalExpr (BoundFunction fid tid arguments) row =
mapM (\argument -> evalExpr argument row) arguments >>= invokeSQLFunction fid tid
mapM (`evalExpr` row) arguments >>= invokeSQLFunction fid tid
evalExpr LitNull _ = Right VNull
evalExpr (LitInt n) _ = Right (VInt n)
evalExpr (LitFloat d) _ = Right (VFloat d)
@@ -55,13 +55,13 @@ evalExpr (IsNotNull a) row = do
Right (VBool (v /= VNull))
evalExpr (InList a es negated) row = do
v <- evalExpr a row
vs <- mapM (\e -> evalExpr e row) es
vs <- mapM (`evalExpr` row) es
r <- inValues v vs
Right (if negated then threeValuedNot r else r)
evalExpr (ScalarSub _) _ = Left subqueryNeedsDatabase
evalExpr (InSub _ _ _) _ = Left subqueryNeedsDatabase
evalExpr (InSub {}) _ = Left subqueryNeedsDatabase
evalExpr (ExistsSub _ _) _ = Left subqueryNeedsDatabase
evalExpr (QuantCmp _ _ _ _) _ = Left subqueryNeedsDatabase
evalExpr (QuantCmp {}) _ = Left subqueryNeedsDatabase
evalExpr agg _ = Left ("aggregate functions are not allowed here: " ++ show agg)
-- | 子查询要连上存储才能跑
@@ -112,21 +112,34 @@ colsInExpr _ = []
-- | 表达式里子查询引用的外层列
subqueryRefsIn :: Expr -> [String]
subqueryRefsIn e = case e of
Construct _ arguments -> concatMap subqueryRefsIn arguments
BoundConstruct _ arguments -> concatMap subqueryRefsIn arguments
FunctionCall _ arguments -> concatMap subqueryRefsIn arguments
BoundFunction _ _ arguments -> concatMap subqueryRefsIn arguments
ScalarSub sq -> subqueryRefs sq
InSub a sq _ -> subqueryRefsIn a ++ subqueryRefs sq
InList a es _ -> concatMap subqueryRefsIn (a : es)
ExistsSub sq _ -> subqueryRefs sq
QuantCmp _ a sq _ -> subqueryRefsIn a ++ subqueryRefs sq
subqueryRefsIn = subqueryReferences subqueryRefs
-- | 提取子查询依赖的父布局表达式
subquerySlotsIn :: Expr -> [Expr]
subquerySlotsIn = subqueryReferences (map snd . subqueryColumns)
-- | 取得原始或已绑定的外部列
subqueryColumns :: Subquery -> [(String, Expr)]
subqueryColumns (Subquery _ names) = [(name, Col name) | name <- names]
subqueryColumns (BoundSubquery _ _ bindings) = bindings
-- | 收集表达式中子查询的外部引用
subqueryReferences :: (Subquery -> [a]) -> Expr -> [a]
subqueryReferences references e = case e of
Construct _ arguments -> concatMap collect arguments
BoundConstruct _ arguments -> concatMap collect arguments
FunctionCall _ arguments -> concatMap collect arguments
BoundFunction _ _ arguments -> concatMap collect arguments
ScalarSub sq -> references sq
InSub a sq _ -> collect a ++ references sq
InList a es _ -> concatMap collect (a : es)
ExistsSub sq _ -> references sq
QuantCmp _ a sq _ -> collect a ++ references sq
Add a b -> both a b
Sub a b -> both a b
Mul a b -> both a b
Div a b -> both a b
Neg a -> subqueryRefsIn a
Neg a -> collect a
Gt a b -> both a b
Lt a b -> both a b
Eq a b -> both a b
@@ -135,17 +148,19 @@ subqueryRefsIn e = case e of
NotEq a b -> both a b
And a b -> both a b
Or a b -> both a b
IsNull a -> subqueryRefsIn a
IsNotNull a -> subqueryRefsIn a
CountOf a -> subqueryRefsIn a
SumOf a -> subqueryRefsIn a
AvgOf a -> subqueryRefsIn a
MinOf a -> subqueryRefsIn a
MaxOf a -> subqueryRefsIn a
IsNull a -> collect a
IsNotNull a -> collect a
CountOf a -> collect a
SumOf a -> collect a
AvgOf a -> collect a
MinOf a -> collect a
MaxOf a -> collect a
_ -> []
where
-- | 递归收集当前提取器的引用
collect = subqueryReferences references
-- | 两个子表达式的外层列拼起来
both a b = subqueryRefsIn a ++ subqueryRefsIn b
both a b = collect a ++ collect b
-- | 表达式里有没有除法（除法可能报错，不能提前或延后求值）
hasDivision :: Expr -> Bool
@@ -181,10 +196,10 @@ hasSubquery e = case e of
FunctionCall _ arguments -> any hasSubquery arguments
BoundFunction _ _ arguments -> any hasSubquery arguments
ScalarSub _ -> True
InSub _ _ _ -> True
InSub {} -> True
InList a es _ -> any hasSubquery (a : es)
ExistsSub _ _ -> True
QuantCmp _ _ _ _ -> True
QuantCmp {} -> True
Add a b -> both a b
Sub a b -> both a b
Mul a b -> both a b
@@ -224,6 +239,8 @@ aggregatesIn e = case e of
a@(MinOf _) -> [a]
a@(MaxOf _) -> [a]
QuantCmp _ a _ _ -> aggregatesIn a
InSub a _ _ -> aggregatesIn a
InList a values _ -> aggregatesIn a ++ concatMap aggregatesIn values
Add a b -> both a b
Sub a b -> both a b
Mul a b -> both a b
chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/JoinOrder.hs
+10 -11
View File
@@ -1,5 +1,6 @@
module ChuSQL.Core.Engine.Algebra.JoinOrder (reorderJoins) where
import Data.Maybe (fromMaybe)
import ChuSQL.Core.Engine.Algebra.Cost (pointRows, rangeRows, selectivityOf, tableMetaOf)
import ChuSQL.Core.Engine.Algebra.Expr (colsInExpr, hasDivision, hasSubquery)
import ChuSQL.Core.Engine.Algebra.Op (RelOp (..), relOpCols)
@@ -23,6 +24,7 @@ pass db free (Project cols x) = Project cols (pass db free x)
pass db free (Compute items x) = Compute items (pass db free x)
pass db free (Filter p x) = Filter p (pass db free x)
pass db free (Derived a x) = Derived a (pass db free x)
pass db free (SemiJoin kind left right l r query) = SemiJoin kind left right (pass db free l) (pass db False r) query
pass db free (Join kind l r c)
| free
, Just (leaves, conds) <- innerChain (Join kind l r c)
@@ -38,7 +40,7 @@ innerChain (Join InnerJoin l r c) = do
(ls, lcs) <- innerChain l
(rs, rcs) <- innerChain r
pure (ls ++ rs, lcs ++ rcs ++ [c])
innerChain (Join _ _ _ _) = Nothing
innerChain (Join {}) = Nothing
innerChain op = Just ([op], [])
-- | 叶子算子的估算行数，拿不到统计就是 Nothing
@@ -79,7 +81,7 @@ scaleRows db p x rows = case p of
GtE _ _ -> quarter
LtE _ _ -> quarter
NotEq _ _ -> quarter
QuantCmp _ _ _ _ -> quarter
QuantCmp {} -> quarter
And a b -> max 1 (min (scaleRows db a x rows) (scaleRows db b x rows))
_ -> quarter
where
@@ -101,11 +103,9 @@ leafSource _ = Nothing
-- | 某列在叶子统计里的不同值数
distinctOf :: Database -> RelOp -> String -> Maybe Int
distinctOf db leaf col = do
(alias, t) <- leafSource leaf
m <- tableMetaOf db t
num <- lookup (unqualify alias col) [(c, n) | (c, n, _) <- metaDistinct m]
pure num
distinctOf db leaf col = do (alias, t) <- leafSource leaf
m <- tableMetaOf db t
lookup (unqualify alias col) [(c, n) | (c, n, _) <- metaDistinct m]
-- | 若干叶子里某列最大的不同值数
distinctOn :: Database -> [RelOp] -> String -> Maybe Int
@@ -138,11 +138,11 @@ stepRows db have acc x conds = case keyDistinct db have x conds of
Just v | v > 1 -> max 1 (acc * rows `div` v)
_ -> acc * rows
where
rows = maybe 1 id (leafRows db x)
rows = fromMaybe 1 (leafRows db x)
-- | 一批叶子按给定顺序连接，累加每一步的中间结果
chainCost :: Database -> [RelOp] -> [Expr] -> Int
chainCost db (l : ls) conds = go [l] (maybe 1 id (leafRows db l)) ls
chainCost db (l : ls) conds = go [l] (fromMaybe 1 (leafRows db l)) ls
where
-- | 逐步接上后面的叶子
go _ _ [] = 0
@@ -213,8 +213,7 @@ rebuildChain _ [] _ = Unit
-- | 挂不上去的条件套成 Filter
applyConds :: [Expr] -> RelOp -> RelOp
applyConds [] op = op
applyConds (c : cs) op = Filter c (applyConds cs op)
applyConds cs op = foldr Filter op cs
-- | 条件的列是不是都在可用列里
subsetOf :: [String] -> [String] -> Bool
chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Op.hs
+10 -2
View File
@@ -1,10 +1,13 @@
module ChuSQL.Core.Engine.Algebra.Op (RelOp (..), relOpCols, renderPlan) where
module ChuSQL.Core.Engine.Algebra.Op (RelOp (..), SemiKind (..), relOpCols, renderPlan) where
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Syntax.AST (Expr, JoinKind (..), SortDir)
import ChuSQL.Core.Engine.Syntax.AST (Expr, Statement, JoinKind (..), SortDir)
-- 关系代数算子定义、输出列推导与算子树文本渲染。
-- | 区分存在匹配、无匹配与 NULL 感知排除
data SemiKind = Matching | NonMatching | NotIn deriving (Show, Eq)
data RelOp
= Scan (Maybe String) String (Maybe [String])
| Lookup (Maybe String) String String Value
@@ -20,6 +23,8 @@ data RelOp
| BoundSort [(Expr, SortDir)] RelOp
| Limit Int RelOp
| Join JoinKind RelOp RelOp Expr
-- | 末项仅保存独立 IN 的物化身份
| SemiJoin SemiKind Expr Expr RelOp RelOp (Maybe Statement)
| Derived (Maybe String) RelOp
deriving (Show, Eq)
@@ -46,6 +51,7 @@ relOpCols db (Sort _ x) = relOpCols db x
relOpCols db (BoundSort _ x) = relOpCols db x
relOpCols db (Limit _ x) = relOpCols db x
relOpCols db (Join _ l r _) = relOpCols db l ++ relOpCols db r
relOpCols db (SemiJoin _ _ _ l _ _) = relOpCols db l
relOpCols db (Derived mAlias x) = map (qualify mAlias) (relOpCols db x)
-- | 连接的显示名
@@ -81,6 +87,8 @@ renderPlan = go 0
BoundSort s x -> pad ++ "BoundSort " ++ show s ++ "\n" ++ go (ind + 1) x
Limit n x -> pad ++ "Limit " ++ show n ++ "\n" ++ go (ind + 1) x
Join k l r c -> pad ++ kindLabel k ++ " on " ++ show c ++ "\n" ++ go (ind + 1) l ++ "\n" ++ go (ind + 1) r
SemiJoin k left right l r _ -> pad ++ "SemiJoin " ++ show k ++ " keys=" ++ show (left, right)
++ "\n" ++ go (ind + 1) l ++ "\n" ++ go (ind + 1) r
Derived a x -> pad ++ "Derived " ++ show a ++ "\n" ++ go (ind + 1) x
where
pad = replicate (ind * 2) ' '
chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Optimize.hs
+55 -6
View File
@@ -3,9 +3,10 @@ module ChuSQL.Core.Engine.Algebra.Optimize (optimize, pushProject) where
import ChuSQL.Core.Engine.Algebra.Cost (indexCheaper, pointRows, rangeRows, tableMetaOf)
import ChuSQL.Core.Engine.Algebra.Expr (colsInExpr, evalExpr, hasDivision)
import ChuSQL.Core.Engine.Algebra.JoinOrder (reorderJoins)
import ChuSQL.Core.Engine.Algebra.Op (RelOp (..), relOpCols)
import ChuSQL.Core.Engine.Algebra.Op (RelOp (..), SemiKind (..), relOpCols)
import ChuSQL.Core.Engine.Algebra.Planner (translate)
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Syntax.AST (Expr (..), JoinKind (..))
import ChuSQL.Core.Engine.Syntax.AST (Expr (..), JoinKind (..), Statement (..), FromClause (..), Subquery (..))
import Data.List (nub)
-- 查询优化：谓词下推、投影下推、常量折叠、扫描方式与连接顺序选择。
@@ -36,8 +37,7 @@ partitionPred have = foldr pick ([], [])
-- | 依次套上若干 Filter
applyFilters :: [Expr] -> RelOp -> RelOp
applyFilters [] op = op
applyFilters (e : es) op = applyFilters es (Filter e op)
applyFilters es op = foldl (flip Filter) op es
-- | Filter 压在内连接上时下推
pushJoin :: Database -> Expr -> RelOp -> RelOp -> Expr -> RelOp
@@ -75,6 +75,7 @@ pushOne _ op = op
planHasDivision :: RelOp -> Bool
planHasDivision (Filter p x) = hasDivision p || planHasDivision x
planHasDivision (Join _ l r c) = hasDivision c || planHasDivision l || planHasDivision r
planHasDivision (SemiJoin _ left right l r _) = hasDivision left || hasDivision right || planHasDivision l || planHasDivision r
planHasDivision (Compute items x) = any (hasDivision . snd) items || planHasDivision x
planHasDivision (Project _ x) = planHasDivision x
planHasDivision (Distinct x) = planHasDivision x
@@ -109,6 +110,9 @@ pushProject db need (Filter p x) = Filter p (pushProject db (need ++ colsInExpr
pushProject db _ (Distinct x) = Distinct (pushProject db (relOpCols db x) x)
pushProject db need (Sort spec x) = Sort spec (pushProject db (need ++ map fst spec) x)
pushProject db need (Limit n x) = Limit n (pushProject db need x)
pushProject db need (SemiJoin kind left right l r query) =
SemiJoin kind left right (pushProject db (need ++ colsInExpr left) l)
(pushProject db (colsInExpr right) r) query
pushProject db need (Join kind l r c)
| needsAll need = Join kind (pushProject db need l) (pushProject db need r) c
| otherwise =
@@ -131,8 +135,8 @@ pushProject db need (Derived a 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
pushProject db need leaf@(Lookup {}) = pushProjectLeaf db need leaf
pushProject db need leaf@(Range {}) = pushProjectLeaf db need leaf
-- | 折一个表达式节点
foldNode :: Expr -> Expr
@@ -179,8 +183,52 @@ worthRange db t col lo hi = case tableMetaOf db t of
Nothing -> True
Just m -> indexCheaper m col (rangeRows m col lo hi)
-- | 将独立 IN 或简单等值 EXISTS 变为半连接
semiJoin :: Database -> Expr -> RelOp -> Maybe RelOp
semiJoin db (InSub left query negated) source
| null (subqueryRefs query), safeKey left
, Right right <- translate (subqueryStatement query)
, [column] <- relOpCols db right, column /= "*" =
Just (SemiJoin (if negated then NotIn else Matching) left (Col column) source right (Just (subqueryStatement query)))
semiJoin db (ExistsSub query negated) source
| [reference] <- subqueryRefs query
, Select items (FromTable alias table) (Just (Eq (Col a) (Col b))) [] Nothing [] Nothing <- subqueryStatement query
, let scan = Scan alias table Nothing
columns = relOpCols db scan
, all (localProjection columns . snd) items
, Just column <- localKey columns reference a b
, let physical = if reference `elem` relOpCols db source then reference else reverse (takeWhile (/= '.') (reverse reference))
, physical `elem` relOpCols db source =
Just (SemiJoin (if negated then NonMatching else Matching) (Col physical) (Col "$semikey") source
(Compute (items ++ [("$semikey", Col column)]) scan) Nothing)
semiJoin _ _ _ = Nothing
-- | 只允许无求值错误的左键
safeKey :: Expr -> Bool
safeKey Col{} = True
safeKey LitNull = True
safeKey LitInt{} = True
safeKey LitFloat{} = True
safeKey LitStr{} = True
safeKey LitBool{} = True
safeKey _ = False
-- | 投影仅保留当前来源的普通列
localProjection :: [String] -> Expr -> Bool
localProjection columns (Col column) = column `elem` columns
localProjection _ expression = safeKey expression && null (colsInExpr expression)
-- | 提取与唯一外层引用比较的本地列
localKey :: [String] -> String -> String -> String -> Maybe String
localKey columns reference a b
| a == reference, b `elem` columns, b /= reference = Just b
| b == reference, a `elem` columns, a /= reference = Just a
| otherwise = Nothing
-- | 单节点重写
rewriteNode :: Database -> RelOp -> RelOp
rewriteNode db (Filter expression source)
| Just joined <- semiJoin db expression source = joined
rewriteNode db (Filter (Eq (Col k) (LitInt v)) (Scan mAlias t Nothing))
| worthLookup db t (unqualify mAlias k) = Lookup mAlias t (unqualify mAlias k) (VInt v)
rewriteNode db (Filter (Eq (Col k) (LitStr v)) (Scan mAlias t Nothing))
@@ -258,6 +306,7 @@ optimizeRelOp db = rewriteNode db . descend
descend (Sort spec x) = Sort spec (optimizeRelOp db x)
descend (Limit n x) = Limit n (optimizeRelOp db x)
descend (Join kind l r c) = Join kind (optimizeRelOp db l) (optimizeRelOp db r) c
descend (SemiJoin kind left right l r query) = SemiJoin kind left right (optimizeRelOp db l) (optimizeRelOp db r) query
descend (Derived a x) = Derived a (optimizeRelOp db x)
descend x = x
chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Planner.hs
+52 -21
View File
@@ -1,3 +1,5 @@
{-# LANGUAGE TupleSections #-}
module ChuSQL.Core.Engine.Algebra.Planner (translate) where
import ChuSQL.Core.Engine.Algebra.Expr (aggregatesIn, colsInExpr)
@@ -30,7 +32,7 @@ nameAggs items = go (1 :: Int) [] (concatMap (aggregatesIn . snd) items)
go _ acc [] = reverse acc
go n acc (e : es)
| any ((== e) . snd) acc = go n acc es
| otherwise = go (n + 1) (("agg" ++ show n, e) : acc) es
| otherwise = go (n + 1) (("$agg" ++ show n, e) : acc) es
-- | 把聚合调用换成对聚合结果的引用
rewriteAggs :: [(String, Expr)] -> Expr -> Expr
@@ -53,22 +55,17 @@ rewriteAggs aggs e = case [label | (label, agg) <- aggs, agg == e] of
LtE a b -> LtE (go a) (go b)
NotEq a b -> NotEq (go a) (go b)
QuantCmp op a sq q -> QuantCmp op (go a) sq q
InSub a sq negated -> InSub (go a) sq negated
InList a values negated -> InList (go a) (map go values) negated
And a b -> And (go a) (go b)
Or a b -> Or (go a) (go b)
IsNull a -> IsNull (go a)
IsNotNull a -> IsNotNull (go a)
other -> other
where
-- | 递归替换当前查询层的聚合引用
go = rewriteAggs aggs
-- | 过滤 + 分组：没有分组也没有聚合时原样返回
grouped :: [String] -> [(String, Expr)] -> RelOp -> (RelOp, [(String, Expr)])
grouped keys items base
| null keys && null aggs = (base, items)
| otherwise = (Aggregate keys aggs base, [(label, rewriteAggs aggs e) | (label, e) <- items])
where
aggs = nameAggs items
-- | 排序 + 截断
limited :: [(String, SortDir)] -> Maybe Int -> RelOp -> RelOp
limited orderBy mLimit op = case mLimit of
@@ -79,7 +76,7 @@ limited orderBy mLimit op = case mLimit of
[] -> op
spec -> Sort spec op
-- | 翻成：过滤 -> 分组 -> 排序 -> 截断 -> 取列
-- | 生成过滤、聚合、HAVING、排序和投影计划
translate :: Statement -> Either String RelOp
translate q = case q of
SelectDistinct inner -> do
@@ -87,22 +84,56 @@ translate q = case q of
plan <- case inner of
s@Select{} -> translate s { selectOrderBy = [], selectLimit = Nothing }
_ -> Left "DISTINCT requires SELECT"
Right (limited ordering (selectLimit inner) (Distinct plan))
Select items fromC mWhere groupBy orderBy mLimit -> do
let labels = case inner of
Select { selectItems = items } -> map fst items
_ -> []
keys <- mapM (distinctKey labels) ordering
namedOrdering <- mapM (columnKey labels) ordering
let sorted
| null keys = Distinct plan
| any (\(column, _) -> length (filter (== column) labels) > 1) namedOrdering = BoundSort keys (Distinct plan)
| otherwise = Sort namedOrdering (Distinct plan)
Right (maybe sorted (`Limit` sorted) (selectLimit inner))
Select items fromC mWhere groupBy having orderBy mLimit -> do
plan0 <- source fromC mWhere
let (plan, items') = grouped groupBy items plan0
Right $ if all (\(label, expression) -> expression == Col label) items'
then Project (map fst items') (limited orderBy mLimit plan)
else if any (\(c, _) -> c `elem` map fst items') orderBy
then orderedProjection items' orderBy mLimit plan
else Compute items' (limited orderBy mLimit plan)
expressions <- mapM (orderExpression items . fst) orderBy
let aggs = nameAggs (items ++ [("having", expression) | expression <- maybe [] pure having]
++ map ("order",) expressions)
aggregate = not (null groupBy && null aggs && null having)
grouped = if aggregate then Aggregate groupBy aggs plan0 else plan0
plan = maybe grouped (\condition -> Filter (rewriteAggs aggs condition) grouped) having
items' = [(label, rewriteAggs aggs expression) | (label, expression) <- items]
ordering = zip (map (rewriteAggs aggs) expressions) (map snd orderBy)
-- | 简单列排序保留可优化的名称算子
named (Col column, direction) = Just (column, direction)
named _ = Nothing
-- | 保持普通投影在 LIMIT 之后求值
projected child
| all (\(label, expression) -> expression == Col label) items' = Project (map fst items') child
| otherwise = Compute items' child
Right (case mapM named ordering of
Just spec -> projected (limited spec mLimit plan)
Nothing -> orderedProjection items' ordering mLimit plan)
_ -> Left "only SELECT is supported by translate"
where
-- | 简单投影的序号映射到来源列
columnKey columns (column, direction) = do
position <- orderPosition (length columns) column
case position of
Just slot -> Right (columns !! slot, direction)
Nothing -> Left "DISTINCT: sorting requires an output position"
-- | 去重后按指定输出位置或唯一名称排序
distinctKey columns (column, direction) = do
position <- orderPosition (length columns) column
case position of
Just slot -> Right (ColumnSlot slot (columns !! slot), direction)
Nothing -> Left "DISTINCT: sorting requires an output position"
-- | 在排序前计算别名并保留输出顺序
orderedProjection :: [(String, Expr)] -> [(String, SortDir)] -> Maybe Int -> RelOp -> RelOp
orderedProjection :: [(String, Expr)] -> [(Expr, 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]
keys = [("$order" ++ show n, expression) | (n, (expression, _)) <- zip [1 :: Int ..] orderBy]
ordering = [(key, direction) | ((key, _), (_, direction)) <- zip keys orderBy]
carried = [(column, Col column) | column <- nub (concatMap (colsInExpr . snd) items)]
chusql-core/engine/src/ChuSQL/Core/Engine/Builtin.hs
+2 -1
View File
@@ -303,8 +303,9 @@ threeValuedNot :: Value -> Value
threeValuedNot (VBool b) = VBool (not b)
threeValuedNot _ = VNull
-- | IN 三值逻辑：命中为真，碰 NULL 得 NULL
-- | IN 空集为假，非空集按三值逻辑比较
inValues :: Value -> [Value] -> Either String Value
inValues _ [] = Right (VBool False)
inValues VNull _ = Right VNull
inValues v vs = do
results <- mapM (\x -> executeOperator OpEq [v, x]) vs
chusql-core/engine/src/ChuSQL/Core/Engine/Normalization.hs
+2 -2
View File
@@ -63,7 +63,7 @@ keysOf attrs f =
[ x
| x <- subsequences attrs
, super x
, all (not . super) [x \\ [a] | a <- x]
, (not . any super) [x \\ [a] | a <- x]
]
where
-- 判断闭包是否覆盖关系。
@@ -123,7 +123,7 @@ analyzeNormalization schema declaration
results =
Finding NF1 atomic [] "attributes must have atomic domains; requires an explicit declaration"
: [classify NF2 partial, classify NF3 third, classify BCNF boyce]
decompositions = [split d | d <- take 1 boyce, complete, atomic == Satisfied]
decompositions = [split d | complete, atomic == Satisfied, d <- take 1 boyce]
-- 校验字段集合。
valid xs = length xs == length (canonical xs) && subset xs attrs
-- 校验依赖声明。
chusql-core/engine/src/ChuSQL/Core/Engine/Parallel.hs
+2 -2
View File
@@ -9,7 +9,7 @@ import Control.Concurrent (forkIO)
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import Control.Concurrent.MVar (MVar, modifyMVar, newEmptyMVar, newMVar, putMVar, takeMVar)
import Control.Exception (SomeException, throwIO, try)
import Control.Monad (forever)
import Control.Monad (forever, join)
import System.IO.Unsafe (unsafePerformIO)
-- 并行执行：常驻工作线程池，结果按提交顺序收回。
@@ -53,7 +53,7 @@ workerPool size = modifyMVar poolRef reuse
-- | 一个工作线程：等待并执行队首待办
worker :: Chan (IO ()) -> IO ()
worker jobs = forever (readChan jobs >>= id)
worker jobs = forever (join (readChan jobs))
-- | 往池里丢一个待办
submit :: Pool -> IO () -> IO ()
chusql-core/engine/src/ChuSQL/Core/Engine/Runtime/Dependencies.hs
+38 -8
View File
@@ -1,24 +1,54 @@
module ChuSQL.Core.Engine.Runtime.Dependencies (queryTables, domainDependencies) where
module ChuSQL.Core.Engine.Runtime.Dependencies (queryTables, domainDependencies, typeDependencies, validateDependencies) where
import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Model (Database, ColumnType (..), columnType, tableCols, domainTableName, lastTablePart)
import ChuSQL.Core.Model (Database, ColumnType (..), columnType, tableCols, tableIdentity, tableSchemaVersion, domainTableName, lastTablePart)
import Data.List (nub)
-- 收集查询及嵌套表达式的表依赖，供绑定执行前校验目录。
-- 收集读写语句及嵌套表达式的表依赖，供执行期校验目录。
-- | 收集全部查询来源表
-- | 复查绑定依赖的身份、版本及列定义
validateDependencies :: Database -> Database -> Either String ()
validateDependencies expected current = mapM_ validate expected
where
-- | 数据和统计变化不使结构绑定失效
validate (name, table) = case lookup name current of
Just actual | tableIdentity actual /= tableIdentity table -> Left ("bound query object changed: " ++ name)
Just actual | tableSchemaVersion actual /= tableSchemaVersion table -> Left ("bound query schema changed: " ++ name)
Just actual | tableCols actual == tableCols table -> Right ()
_ -> Left ("bound query schema changed: " ++ name)
-- | 收集读写目标、来源及子查询依赖
queryTables :: Statement -> [String]
queryTables statement = nub (case statement of
SelectDistinct child -> queryTables child
Select items source condition _ _ _ -> sourceTables source
Select items source condition _ having ordering _ -> sourceTables source
++ concatMap (expressionTables . snd) items ++ concatMap expressionTables condition
++ concatMap expressionTables having
++ concatMap (maybe [] expressionTables . orderKeyExpression . fst) ordering
Insert target _ rows -> target : concatMap (concatMap expressionTables) rows
Update target assignments condition -> target : concatMap (expressionTables . snd) assignments
++ concatMap expressionTables condition
Delete target condition -> target : concatMap expressionTables condition
DropTable target -> [target]
CreateIndex target _ -> [target]
DropIndex target _ -> [target]
DropColumn target _ -> [target]
AddColumn target _ -> [target]
RenameColumn target _ _ -> [target]
AlterColumnType target _ _ -> [target]
AlterColumnDefault target _ _ -> [target]
AlterColumnNull target _ _ -> [target]
_ -> [])
-- | 收集来源列依赖的领域定义
domainDependencies :: Database -> [String] -> [String]
domainDependencies catalog sources = collect []
[domain | (name, table) <- catalog, name `elem` sources
, (_, column) <- tableCols table, domain <- typeDomains (columnType column)]
domainDependencies catalog sources = typeDependencies catalog
[columnType column | (name, table) <- catalog, name `elem` sources
, (_, column) <- tableCols table]
-- | 收集声明类型依赖的领域目录
typeDependencies :: Database -> [ColumnType] -> [String]
typeDependencies catalog types = collect [] (concatMap typeDomains types)
where
-- | 递归展开定义并防止重复访问
collect seen [] = seen
chusql-core/engine/src/ChuSQL/Core/Engine/Runtime/Functions.hs
+3 -1
View File
@@ -3,6 +3,7 @@ module ChuSQL.Core.Engine.Runtime.Functions
, builtinFunctions, resolveFunction, resolveNullableFunction, functionSignature, invokeFunction
) where
import Control.Monad (zipWithM_)
import ChuSQL.Core.Engine.Runtime.Types
import Data.Char (toLower)
@@ -60,7 +61,8 @@ invokeFunction types (FunctionRegistry functions) fid values =
case [(sig, implementation) | (sig, implementation) <- functions, signatureId sig == fid] of
[(sig, implementation)]
| length values == length (signatureArguments sig) -> do
sequence_ (zipWith (validateValue types) (signatureArguments sig) values)
zipWithM_
(validateValue types) (signatureArguments sig) values
result <- implementation values
validateValue types (signatureResult sig) result
Right result
chusql-core/engine/src/ChuSQL/Core/Engine/Runtime/Query.hs
+4 -12
View File
@@ -12,7 +12,7 @@ import ChuSQL.Core.Engine.Storage (MonadStorage (schema, withSchemaGuard))
import ChuSQL.Core.Engine.Runtime.SQL (sqlType)
import ChuSQL.Core.Engine.Runtime.Types (TypeId)
import ChuSQL.Core.Engine.Runtime.Relation (bindRelOpColumns)
import ChuSQL.Core.Engine.Runtime.Dependencies (queryTables, domainDependencies)
import ChuSQL.Core.Engine.Runtime.Dependencies (queryTables, domainDependencies, validateDependencies)
import ChuSQL.Core.Model
-- SQL 查询绑定边界：保存解析后的类型、函数身份及输出 schema。
@@ -57,22 +57,14 @@ bindQuery catalog statement = do
executeQueryM :: MonadStorage m => BoundQuery -> m (Either String [Row])
executeQueryM (BoundQuery catalog dependencies columns _ plan) = do
current <- schema
case current >>= validateSchema of
case current >>= validateDependencies guardedTables of
Left err -> pure (Left err)
Right () -> do
result <- withSchemaGuard [(name, table) | (name, table) <- catalog, name `elem` dependencies]
result <- withSchemaGuard guardedTables
(evalRelOpM catalog plan)
pure (result >>= mapM validateRow)
where
-- | 拒绝绑定目录中的结构变化
validateSchema current = mapM_ (validateTable current)
[(name, table) | (name, table) <- catalog, name `elem` dependencies]
-- | 比较列定义而不比较数据或统计
validateTable current (name, expected) = case lookup name current of
Just actual | tableIdentity actual /= tableIdentity expected -> Left ("bound query object changed: " ++ name)
Just actual | tableSchemaVersion actual /= tableSchemaVersion expected -> Left ("bound query schema changed: " ++ name)
Just actual | tableCols actual == tableCols expected -> Right ()
_ -> Left ("bound query schema changed: " ++ name)
guardedTables = [(name, table) | (name, table) <- catalog, name `elem` dependencies]
-- | 校验完整输出行而不重新解析函数
validateRow row
| map fst row /= map fst columns = Left "bound query output schema mismatch"
chusql-core/engine/src/ChuSQL/Core/Engine/Runtime/Relation.hs
+70 -18
View File
@@ -1,10 +1,36 @@
module ChuSQL.Core.Engine.Runtime.Relation (bindRelOpColumns) where
module ChuSQL.Core.Engine.Runtime.Relation (bindRelOpColumns, bindWriteColumns, bindSlots, orderRow) where
import ChuSQL.Core.Engine.Algebra.Op
import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Model (Database)
import ChuSQL.Core.Model (Database, Row, lookupTable, tableCols)
-- 优化完成后按算子输入布局绑定列槽位，外层行作为独立尾部布局。
-- 按关系或写语句的输入布局绑定列槽位，并排列存储返回行。
-- | 按目标表布局绑定写入表达式
bindWriteColumns :: Database -> Statement -> Either String Statement
bindWriteColumns db statement = case statement of
Insert table columns rows -> Insert table columns <$> mapM (mapM (bindSlots [] [])) rows
Update table assignments condition -> do
columns <- map fst . tableCols <$> lookupTable db table
bound <- mapM (bindItem columns) assignments
predicate <- mapM (bindSlots columns []) condition
Right (Update table bound predicate)
Delete table condition -> do
columns <- map fst . tableCols <$> lookupTable db table
Delete table <$> mapM (bindSlots columns []) condition
_ -> Right statement
where
-- | 保留写入目标并绑定右侧表达式
bindItem columns (name, expression) = (,) name <$> bindSlots columns [] expression
-- | 按绑定布局排列一行并拒绝缺列
orderRow :: [String] -> Row -> Either String Row
orderRow columns row = mapM column columns
where
-- | 保留列名并取得物理值
column name = case lookup name row of
Just value -> Right (name, value)
Nothing -> Left ("missing bound column: " ++ name)
-- | 绑定关系算子的输入列位置
bindRelOpColumns :: Database -> [String] -> RelOp -> Either String RelOp
@@ -14,11 +40,7 @@ bindRelOpColumns db outer = bind
bind op = case op of
Filter expression child -> Filter <$> expressionIn child expression <*> bind child
Compute items child -> Compute <$> mapM (itemIn child) items <*> bind child
Aggregate keys items child ->
BoundAggregate
<$> mapM (itemIn child) [(name, Col name) | name <- keys]
<*> mapM (itemIn child) items
<*> bind child
Aggregate keys items child -> bind (BoundAggregate [(name, Col name) | name <- keys] items child)
BoundAggregate keys items child ->
BoundAggregate
<$> mapM (itemIn child) keys
@@ -29,15 +51,19 @@ bindRelOpColumns db outer = bind
<$> bind left
<*> bind right
<*> bindSlots (relOpCols db left ++ relOpCols db right) outer condition
SemiJoin kind leftKey rightKey left right query ->
SemiJoin kind
<$> expressionIn left leftKey
<*> expressionIn right rightKey
<*> bind left
<*> bind right
<*> pure query
Project columns child -> do
let names = if columns == ["*"] then relOpCols db child else columns
items <- mapM (itemIn child) [(name, Col name) | name <- names]
Compute items <$> bind child
Distinct child -> Distinct <$> bind child
Sort ordering child ->
BoundSort
<$> mapM (sortIn child) [(Col name, direction) | (name, direction) <- ordering]
<*> bind child
Sort ordering child -> bind (BoundSort [(Col name, direction) | (name, direction) <- ordering] child)
BoundSort ordering child -> BoundSort <$> mapM (sortIn child) ordering <*> bind child
Limit count child -> Limit count <$> bind child
Derived alias child -> Derived alias <$> bind child
@@ -55,10 +81,11 @@ bindSlots columns outer expression = case expression of
Col name -> case slots columns name of
slot : _ -> Right (ColumnSlot slot name)
[] -> outerReference name
ColumnSlot _ name -> case slots columns name of
slot : _ -> Right (ColumnSlot slot name)
[] -> Left ("unknown local column: " ++ name)
OuterColumnSlot _ _ name -> outerReference name
ColumnSlot slot name -> ColumnSlot <$> rebindSlot columns slot name "unknown local column: " <*> pure name
OuterColumnSlot width slot name
| width < 0 -> Left ("bound column position mismatch: " ++ name)
| otherwise -> OuterColumnSlot (length columns)
<$> rebindSlot outer slot name "unknown column: " <*> pure name
FunctionCall name arguments -> FunctionCall name <$> mapM bind arguments
BoundFunction fid tid arguments -> BoundFunction fid tid <$> mapM bind arguments
Construct ty arguments -> Construct ty <$> mapM bind arguments
@@ -83,18 +110,43 @@ bindSlots columns outer expression = case expression of
AvgOf a -> AvgOf <$> bind a
MinOf a -> MinOf <$> bind a
MaxOf a -> MaxOf <$> bind a
InSub a query negated -> InSub <$> bind a <*> pure query <*> pure negated
ScalarSub query -> ScalarSub <$> bindSubquery query
InSub a query negated -> InSub <$> bind a <*> bindSubquery query <*> pure negated
InList a values negated -> InList <$> bind a <*> mapM bind values <*> pure negated
QuantCmp op a query quantifier -> QuantCmp op <$> bind a <*> pure query <*> pure quantifier
ExistsSub query negated -> ExistsSub <$> bindSubquery query <*> pure negated
QuantCmp op a query quantifier -> QuantCmp op <$> bind a <*> bindSubquery query <*> pure quantifier
_ -> Right expression
where
-- \| 绑定当前布局的子表达式
bind = bindSlots columns outer
-- \| 查找布局中首次出现的列
slots names name = [slot | (slot, key) <- zip [0 ..] names, key == name]
-- | 保留有效位置，仅允许唯一列重定位
rebindSlot names slot name missing
| slot < 0 = Left ("bound column position mismatch: " ++ name)
| take 1 (drop slot names) == [name] = Right slot
| otherwise = case slots names name of
[position] -> Right position
[] -> Left (missing ++ name)
_ -> Left ("ambiguous bound column: " ++ name)
-- \| 在外层布局绑定并保留作用域
outerReference name = case slots outer name of
slot : _ -> Right (OuterColumnSlot (length columns) slot name)
[] -> Left ("unknown column: " ++ name)
-- | 将子查询自由变量绑定到父输入布局
bindSubquery query = do
references <- case query of
Subquery _ names -> mapM reference names
BoundSubquery _ names references
| map fst references == names -> mapM rebind references
| otherwise -> Left "bound subquery references mismatch"
Right (BoundSubquery (subqueryStatement query) (subqueryRefs query) references)
-- | 补回限定名之前先绑定真实物理列
reference name = do
let physical = if name `elem` (columns ++ outer) then name else reverse (takeWhile (/= '.') (reverse name))
boundReference <- bind (Col physical)
Right (name, boundReference)
-- | 重绑定时保留局部或外层身份
rebind (name, boundReference) = (,) name <$> bind boundReference
-- \| 绑定两个操作数
binary constructor a b = constructor <$> bind a <*> bind b
chusql-core/engine/src/ChuSQL/Core/Engine/Runtime/SQL.hs
+3 -1
View File
@@ -1,5 +1,6 @@
module ChuSQL.Core.Engine.Runtime.SQL (resolveSQLFunction, sqlResultType, invokeSQLFunction, sqlType, constructSQLValue) where
import Control.Monad (zipWithM_)
import ChuSQL.Core.Engine.Runtime.Functions
import ChuSQL.Core.Engine.Runtime.Types
import ChuSQL.Core.Model (ColumnType (..), Value (..))
@@ -52,7 +53,8 @@ invokeSQLFunction fid expected values = do
if length values /= length (signatureArguments sig)
then Left "function argument count mismatch"
else do
sequence_ (zipWith validateArgument (signatureArguments sig) values)
zipWithM_
validateArgument (signatureArguments sig) values
if VNull `elem` values
then Right VNull
else do
chusql-core/engine/src/ChuSQL/Core/Engine/Semantic.hs
+132 -96
View File
@@ -1,8 +1,11 @@
module ChuSQL.Core.Engine.Semantic (check, prepare, prepareRowExpression, querySchema) where
{-# LANGUAGE TupleSections #-}
module ChuSQL.Core.Engine.Semantic (check, prepare, prepareRowExpression, prepareCheckExpression, querySchema) where
import ChuSQL.Core.Engine.Algebra.Expr (bareColumns, colsInExpr, hasAggregate)
import Control.Monad (void)
import ChuSQL.Core.Engine.Algebra.Expr (bareColumns, colsInExpr, hasAggregate, hasSubquery)
import ChuSQL.Core.Engine.Runtime.Functions (FunctionSignature (..), builtinFunctions, functionSignature)
import ChuSQL.Core.Engine.Runtime.SQL (resolveSQLFunction, sqlResultType, sqlType)
import ChuSQL.Core.Engine.Runtime.Relation (bindSlots)
import ChuSQL.Core.Engine.Runtime.Types
import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Engine.Syntax.Parser (parseExpression)
@@ -30,24 +33,29 @@ querySchema db statement = do
columns <- inferSubqueryOutput db (Scope [] []) (Subquery statement [])
Right [(name, plainColumn (derivedType ty)) | (name, ty) <- columns]
-- | 检查期的作用域：本层优先，外层兜底
-- | 从最近层到最远层保存外部作用域
type EnclosingScopes = [[(String, Column)]]
-- | 保存本层与各层外部列
data Scope = Scope
{ scopeInner :: [(String, Column)]
, scopeOuter :: [(String, Column)]
, scopeOuter :: EnclosingScopes
}
-- | 本层先查，查不到再落外层；本层同名引起歧义时不往外层让
-- | 逐层解析列，本层歧义不向外层回退
scopeAt :: String -> Scope -> String -> Either String (String, Column)
scopeAt place scope c
| null (scopeOuter scope) = columnAt place (scopeInner scope) c
| otherwise = case columnAt place (scopeInner scope) c of
scopeAt place scope c = search (scopeFrames scope)
where
-- | 在最近的可见列层停止查找
search [] = Left (missingColumn place c (concat (scopeFrames scope)))
search (columns : rest) = case columnAt place columns c of
Right entry -> Right entry
Left err
| "ambiguous column:" `isInfixOf` err -> Left err
| otherwise -> columnAt place (scopeOuter scope) c
| otherwise -> search rest
-- | 收集 FROM 的列，列前缀由表名推导
checkFrom :: Database -> [(String, Column)] -> FromClause -> Either String [(String, Column)]
checkFrom :: Database -> EnclosingScopes -> FromClause -> Either String [(String, Column)]
checkFrom _ _ FromUnit = Right []
checkFrom db _ (FromTable mAlias tbl) = do
(key, t) <- resolveTable db tbl
@@ -72,13 +80,9 @@ inferredColumnType :: ColumnType -> InferredType
inferredColumnType CNull = InferNull
inferredColumnType ty = InferType ty
-- | 合并两层列，本层优先且不重复
scopedEnv :: [(String, Column)] -> [(String, Column)] -> [(String, Column)]
scopedEnv env outer = env ++ [o | o <- outer, o `notElem` env]
-- | 把作用域摊平成一层的列清单
scopeFlat :: Scope -> [(String, Column)]
scopeFlat scope = scopedEnv (scopeInner scope) (scopeOuter scope)
-- | 进入子查询时保留每层的列边界
scopeFrames :: Scope -> EnclosingScopes
scopeFrames scope = scopeInner scope : scopeOuter scope
-- | 拼“列不存在”的报错
missingColumn :: String -> String -> [(String, Column)] -> String
@@ -91,7 +95,7 @@ missingColumn place c env =
-- | 检查列是否都在环境里
checkColumns :: String -> Scope -> [String] -> Either String ()
checkColumns place env = mapM_ (\c -> if c == allColumns then Right () else () <$ scopeAt place env c)
checkColumns place env = mapM_ (\c -> if c == allColumns then Right () else void (scopeAt place env c))
-- | 在一层里查一列，报错时带上子句名与可用列
columnAt :: String -> [(String, Column)] -> String -> Either String (String, Column)
@@ -107,18 +111,19 @@ checkNoAggregate place e
| otherwise = Right ()
-- | 分组查询里，没被聚合的列必须出现在 GROUP BY 里
checkGrouping :: Scope -> [String] -> [(String, Expr)] -> Either String ()
checkGrouping env keys items
| null keys && not (any (hasAggregate . snd) items) = Right ()
checkGrouping :: Scope -> [String] -> [(String, Expr)] -> Maybe Expr -> Either String ()
checkGrouping env keys items having
| null keys && null having && not (any (hasAggregate . snd) items) = Right ()
| otherwise = do
checkColumns "GROUP BY" env keys
mapM_ (checkRuntimeColumn "GROUP BY" env) keys
mapM_ okCol (nub (concatMap (bareColumns . snd) items))
mapM_ okCol (nub (concatMap (bareColumns . snd) items ++ concatMap bareColumns having))
where
-- \| 这一列能不能出现在分组查询里
okCol c
| c == allColumns = Left "SELECT: * cannot be selected together with GROUP BY"
| c `elem` keys = Right ()
| Left _ <- resolveColumn c (scopeInner env) = Right ()
| otherwise = Left ("SELECT: column " ++ c ++ " must appear in GROUP BY or be aggregated")
-- | 渲染一个推导类型
@@ -232,6 +237,7 @@ itemType place want got
-- | 推导子查询的输出列与类型
inferSubqueryOutput :: Database -> Scope -> Subquery -> Either String [(String, InferredType)]
inferSubqueryOutput _ _ BoundSubquery{} = Left "execution subquery cannot be used in semantic input"
inferSubqueryOutput db outerScope sq = case subqueryStatement sq of
SelectDistinct q -> do
columns <- inferSubqueryOutput db outerScope sq{subqueryStatement = q}
@@ -241,10 +247,10 @@ inferSubqueryOutput db outerScope sq = case subqueryStatement sq of
q@Select{selectItems = items} -> do
env <- checkFrom db enclosing (selectFrom q)
checkResolvedWith db enclosing q
mapM (\(l, e) -> (\t -> (l, t)) <$> inferExpr db "SELECT" (Scope env enclosing) e) items
mapM (\(l, e) -> (l,) <$> inferExpr db "SELECT" (Scope env enclosing) e) items
_ -> Left "subquery must be a SELECT"
where
enclosing = scopeFlat outerScope
enclosing = scopeFrames outerScope
-- | 聚合的参数：列要在，且不能嵌套聚合
aggregateArg :: Database -> String -> Scope -> Expr -> Either String InferredType
@@ -347,7 +353,7 @@ checkAssign db t = checkTyped db "UPDATE" (Scope (tableCols t) []) t
-- | 按语句类型分派检查
check :: Database -> Statement -> Either String ()
check db q = () <$ prepare db q
check db q = void (prepare db q)
-- | 执行前解析列名并检查类型
prepare :: Database -> Statement -> Either String Statement
@@ -439,21 +445,25 @@ checkResolved :: Database -> Statement -> Either String ()
checkResolved db = checkResolvedWith db []
-- | 检查已解析的语句；outer 是相关子查询能看见的外层列
checkResolvedWith :: Database -> [(String, Column)] -> Statement -> Either String ()
checkResolvedWith :: Database -> EnclosingScopes -> Statement -> Either String ()
checkResolvedWith db outer q = case q of
SelectDistinct inner -> () <$ inferSubqueryOutput db (Scope [] outer) (Subquery (SelectDistinct inner) [])
Select items fromC mWhere groupBy orderBy _ -> do
SelectDistinct inner -> void (inferSubqueryOutput db (Scope [] outer) (Subquery (SelectDistinct inner) []))
Select items fromC mWhere groupBy having orderBy _ -> do
env <- checkFrom db outer fromC
let full = Scope env outer
direct = all (\(label, expression) -> expression == Col label) items
mapM_ (\item -> () <$ inferExpr db "SELECT" full (snd item)) items
checkGrouping full groupBy (items ++ [(c, Col c) | (c, _) <- orderBy, not direct, c `notElem` map fst items])
mapM_ ((if direct then checkRuntimeColumn "ORDER BY" full else checkOrder db full items) . fst) orderBy
mapM_ (inferExpr db "SELECT" full . snd) items
ordering <- mapM (orderExpression items . fst) orderBy
mapM_ (checkBool db "HAVING" full) having
checkGrouping full groupBy (items ++ zip (map (show . fst) orderBy) ordering) having
mapM_ (checkOrder db full items . fst) orderBy
mapM_ (checkNoAggregate "WHERE") mWhere
mapM_ (checkBool db "WHERE" full) mWhere
Insert tbl cols rows -> do
t <- lookupTable db tbl
checkColumns "INSERT" (Scope (tableCols t) []) cols
case [name | name <- cols, length (filter (== name) cols) > 1] of
name : _ -> Left ("INSERT: duplicate target column: " ++ name)
[] -> Right ()
if null rows
then Left "INSERT: no values"
else mapM_ (mapM_ (checkValue db t) . zip cols) rows
@@ -474,7 +484,7 @@ checkResolvedWith db outer q = case q of
if length names /= length (nub names)
then Left ("CREATE TABLE: duplicate column names in " ++ name)
else Right ()
checkColumnDefs (map fst cols) cols
checkColumnDefs cols cols
DropTable name ->
if null name
then Left "DROP TABLE: empty table name"
@@ -497,12 +507,14 @@ checkResolvedWith db outer q = case q of
if col == idColumn
then Left "DROP COLUMN: the built-in id column cannot be dropped"
else Right ()
let remaining = filter ((/= col) . fst) (tableCols t)
checkChecks remaining remaining
AddColumn tbl def -> do
t <- lookupTable db tbl
if fst def `elem` tableCols' t
then Left ("ADD COLUMN: column already exists: " ++ fst def)
else Right ()
checkColumnDefs (tableCols' t ++ [fst def]) [def]
checkColumnDefs (tableCols t ++ [def]) [def]
RenameColumn tbl old new -> do
t <- lookupTable db tbl
if old `notElem` tableCols' t
@@ -514,6 +526,8 @@ checkResolvedWith db outer q = case q of
if new `elem` tableCols' t
then Left ("RENAME COLUMN: column already exists: " ++ new)
else Right ()
let renamed = [(if name == old then new else name, column) | (name, column) <- tableCols t]
checkChecks renamed renamed
AlterColumnType tbl col ty -> do
t <- lookupTable db tbl
c <- requireColumn "ALTER COLUMN" t col
@@ -521,10 +535,12 @@ checkResolvedWith db outer q = case q of
if columnAutoIncrement c && not (integerType ty)
then Left "ALTER COLUMN: AUTO_INCREMENT column must stay an integer type"
else Right ()
let changed = [(name, if name == col then column{columnType = ty} else column) | (name, column) <- tableCols t]
checkColumnDefs changed changed
AlterColumnDefault tbl col def -> do
t <- lookupTable db tbl
c <- requireColumn "ALTER COLUMN" t col
mapM_ (\v -> checkDefault c v) def
mapM_ (checkDefault c) def
AlterColumnNull tbl col nullable -> do
t <- lookupTable db tbl
c <- requireColumn "ALTER COLUMN" t col
@@ -591,9 +607,9 @@ checkInsertTargets t cols = mapM_ checkTarget (tableCols t)
| Just _ <- columnDefault c = Right ()
| otherwise = Left ("INSERT: column " ++ name ++ " is NOT NULL and has no default")
-- | 检查一列定义是否合法（names 给 CHECK 用）
checkColumnDefs :: [String] -> [(String, Column)] -> Either String ()
checkColumnDefs names cols = do
-- | 依据完整 schema 校验新增列定义
checkColumnDefs :: [(String, Column)] -> [(String, Column)] -> Either String ()
checkColumnDefs schemaColumns cols = do
mapM_ (checkTypeParameters . columnType . snd) cols
mapM_ (\(_, c) -> mapM_ (checkDefault c) (columnDefault c)) cols
mapM_ (\(_, c) -> checkAutoIncrement c) cols
@@ -601,7 +617,7 @@ checkColumnDefs names cols = do
if length [() | (_, c) <- cols, columnAutoIncrement c] > 1
then Left "CREATE TABLE: at most one AUTO_INCREMENT column is allowed"
else Right ()
checkChecks names cols
checkChecks schemaColumns cols
where
-- \| 拒绝缺少能力实现的运行时键
checkRuntimeKey (_, column)
@@ -613,7 +629,7 @@ checkColumnDefs names cols = do
-- | 校验列类型的长度和精度参数
checkTypeParameters :: ColumnType -> Either String ()
checkTypeParameters (CDomain _ base) = checkTypeParameters base
checkTypeParameters (CRuntime tid) = () <$ describeType builtinTypes tid
checkTypeParameters (CRuntime tid) = void (describeType builtinTypes tid)
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"
@@ -631,23 +647,20 @@ checkAutoIncrement c
checkDefault :: Column -> Value -> Either String ()
checkDefault c v
| VNull <- v = Right ()
| valueFits (columnType c) v = () <$ coerceValue (columnType c) v
| valueFits (columnType c) v = void (coerceValue (columnType c) v)
| otherwise = Left ("DEFAULT: value does not fit column type " ++ typeLabel (columnType c))
-- | CHECK 里的列必须存在
checkChecks :: [String] -> [(String, Column)] -> Either String ()
checkChecks names = mapM_ checkOne
-- | 按完整 schema 校验 CHECK 条件
checkChecks :: [(String, Column)] -> [(String, Column)] -> Either String ()
checkChecks columns = mapM_ checkOne
where
-- \| 查这一列的 CHECK
checkOne (_, c) = case columnCheck c of
Nothing -> Right ()
Just text -> case parseExpression text of
Left err -> Left ("CHECK: " ++ firstLine err)
Right e -> mapM_ (known e) (colsInExpr e)
-- \| 这个列名在不在定义里
known _ col
| col `elem` names = Right ()
| otherwise = Left ("CHECK: unknown column: " ++ col)
Right e -> void (prepareCheckExpression columns e)
-- | 只保留解析错误的第一行
firstLine = takeWhile (/= '\n')
-- | 账号名上限
@@ -728,7 +741,7 @@ idColumn = "id"
resolveExpr ::
Database ->
[(String, Column)] ->
[(String, Column)] ->
EnclosingScopes ->
(String -> Either String String) ->
Expr ->
Either String Expr
@@ -766,11 +779,11 @@ resolveExpr db env outer f e = case e of
AvgOf a -> AvgOf <$> resolveExpr db env outer f a
MinOf a -> MinOf <$> resolveExpr db env outer f a
MaxOf a -> MaxOf <$> resolveExpr db env outer f a
ScalarSub sq -> ScalarSub <$> resolveSubquery db (env ++ outer) sq
InSub a sq negated -> InSub <$> resolveExpr db env outer f a <*> resolveSubquery db (env ++ outer) sq <*> pure negated
ScalarSub sq -> ScalarSub <$> resolveSubquery db (env : outer) sq
InSub a sq negated -> InSub <$> resolveExpr db env outer f a <*> resolveSubquery db (env : outer) sq <*> pure negated
InList a es negated -> InList <$> resolveExpr db env outer f a <*> mapM (resolveExpr db env outer f) es <*> pure negated
ExistsSub sq negated -> ExistsSub <$> resolveSubquery db (env ++ outer) sq <*> pure negated
QuantCmp op a sq q -> QuantCmp op <$> resolveExpr db env outer f a <*> resolveSubquery db (env ++ outer) sq <*> pure q
ExistsSub sq negated -> ExistsSub <$> resolveSubquery db (env : outer) sq <*> pure negated
QuantCmp op a sq q -> QuantCmp op <$> resolveExpr db env outer f a <*> resolveSubquery db (env : outer) sq <*> pure q
_ -> Right e
where
-- \| 递归处理两个子表达式
@@ -799,7 +812,18 @@ prepareRowExpression :: [(String, Column)] -> Expr -> Either String Expr
prepareRowExpression columns expression = do
bound <- resolveExpr [] columns [] (nameIn columns "expression") expression
_ <- inferExpr [] "expression" (Scope columns []) bound
Right bound
bindSlots (map fst columns) [] bound
-- | 统一绑定 DDL 与写入使用的 CHECK
prepareCheckExpression :: [(String, Column)] -> Expr -> Either String Expr
prepareCheckExpression columns expression = do
checkNoAggregate "CHECK" expression
if hasSubquery expression
then Left "CHECK: subqueries are not allowed here"
else Right ()
resolved <- resolveExpr [] columns [] (nameIn columns "CHECK") expression
checkBool [] "CHECK" (Scope columns []) resolved
bindSlots (map fst columns) [] resolved
-- | 将推导类型转换为可空参数类型
inferredArgument :: InferredType -> Maybe ColumnType
@@ -807,30 +831,34 @@ inferredArgument InferNull = Nothing
inferredArgument (InferType ty) = Just ty
-- | 解析子查询，并记下它引用的外层列
resolveSubquery :: Database -> [(String, Column)] -> Subquery -> Either String Subquery
resolveSubquery :: Database -> EnclosingScopes -> Subquery -> Either String Subquery
resolveSubquery _ _ BoundSubquery{} = Left "execution subquery cannot be used in semantic input"
resolveSubquery db outer sq = do
stmt <- resolveSubqueryStatement db outer (subqueryStatement sq)
pure (Subquery stmt (outerRefsOf db stmt))
references <- outerRefsOf db outer stmt
pure (Subquery stmt references)
-- | 子查询里指向外层作用域的列（内层查不到的列就是外层引用）
outerRefsOf :: Database -> Statement -> [String]
outerRefsOf db stmt = nub [c | c <- statementColumns stmt, not (inInner c)]
outerRefsOf :: Database -> EnclosingScopes -> Statement -> Either String [String]
outerRefsOf db outer stmt = do
inner <- checkFrom db outer (statementFrom stmt)
columns <- statementColumns stmt
Right (nub [c | c <- columns, not (inInner inner c)])
where
inner = case checkFrom db [] (statementFrom stmt) of
Right env -> env
Left _ -> []
-- \| 这一列能不能在内层解析到
inInner c = case resolveColumn c inner of
inInner inner c = case resolveColumn c inner of
Right _ -> True
Left _ -> False
-- | 一条语句里出现的所有列引用
statementColumns :: Statement -> [String]
statementColumns :: Statement -> Either String [String]
statementColumns stmt = case stmt of
SelectDistinct q -> statementColumns q
Select items fromC mWhere groupBy orderBy _ ->
concatMap (colsInExpr . snd) items ++ fromColumns fromC ++ concatMap colsInExpr mWhere ++ groupBy ++ map fst orderBy
_ -> []
Select items fromC mWhere groupBy having orderBy _ -> do
ordering <- mapM (orderExpression items . fst) orderBy
Right (concatMap (colsInExpr . snd) items ++ fromColumns fromC
++ concatMap colsInExpr mWhere ++ groupBy ++ concatMap colsInExpr having ++ concatMap colsInExpr ordering)
_ -> Right []
where
-- \| 取 FROM 里出现的列
fromColumns FromUnit = []
@@ -845,7 +873,7 @@ statementFrom Select{selectFrom = fromC} = fromC
statementFrom _ = FromUnit
-- | 解析子查询里的 SELECT
resolveSubqueryStatement :: Database -> [(String, Column)] -> Statement -> Either String Statement
resolveSubqueryStatement :: Database -> EnclosingScopes -> Statement -> Either String Statement
resolveSubqueryStatement db outer (SelectDistinct q) = SelectDistinct <$> resolveSubqueryStatement db outer q
resolveSubqueryStatement db outer q@Select{} = resolveQuery db outer q (selectItems q)
resolveSubqueryStatement _ _ _ = Left "subquery must be a SELECT"
@@ -859,7 +887,7 @@ resolveStatement db q = case q of
(key, t) <- resolveTable db tbl
let env = tableCols t
name = nameIn env "UPDATE"
assigns' <- mapM (\(c, e) -> (\e' -> (c, e')) <$> resolveExpr db env [] name e) assigns
assigns' <- mapM (\(c, e) -> (c,) <$> resolveExpr db env [] name e) assigns
w <- mapM (resolveExpr db env [] (nameIn env "WHERE")) mWhere
pure (Update key assigns' w)
Delete tbl mWhere -> do
@@ -877,27 +905,33 @@ resolveStatement db q = case q of
nameIn :: [(String, Column)] -> String -> String -> Either String String
nameIn env place c = fst <$> columnAt place env c
-- | 内层先查，查不到再落到外层；内层同名引起的歧义不往外层让
scopedColumnAt :: String -> [(String, Column)] -> [(String, Column)] -> String -> Either String (String, Column)
scopedColumnAt place inner outer c = scopeAt place (Scope inner outer) c
-- | 解析原始引用，最近来源限定名遮蔽远层
scopedColumnAt :: String -> [(String, Column)] -> EnclosingScopes -> String -> Either String (String, Column)
scopedColumnAt place inner outer c
| length (filter (== '.') c) == 1
, columns : _ <- filter ownsSource (inner : outer) = columnAt place columns c
| otherwise = scopeAt place (Scope inner outer) c
where
qualifier = takeWhile (/= '.') c ++ "."
-- | 判断当前层是否声明该来源限定名
ownsSource = any (isPrefixOf qualifier . fst)
-- | 单表保留原表头，连接使用唯一前缀
resolveSelect :: Database -> Statement -> Either String Statement
resolveSelect db q@Select{} = resolveQuery db [] q (selectItems q)
resolveSelect _ q = Right q
-- | 检查排序输出别名或来源列
checkOrder :: Database -> Scope -> [(String, Expr)] -> String -> Either String ()
checkOrder db env items column = case [e | (label, e) <- items, label == column] of
[] -> checkRuntimeColumn "ORDER BY" env column
[expression] -> () <$ (inferExpr db "ORDER BY" env expression >>= requireOrdering "ORDER BY")
_ -> Left ("ORDER BY: ambiguous projection alias: " ++ column)
-- | 检查排序表达式的类型能力
checkOrder :: Database -> Scope -> [(String, Expr)] -> OrderKey -> Either String ()
checkOrder db env items column = do
expression <- orderExpression items column
void (inferExpr db "ORDER BY" env expression >>= requireOrdering "ORDER BY")
-- | 校验列已有排序能力
checkRuntimeColumn :: String -> Scope -> String -> Either String ()
checkRuntimeColumn place env column = do
(_, definition) <- scopeAt place env column
() <$ requireOrdering place (InferType (columnType definition))
void (requireOrdering place (InferType (columnType definition)))
-- | 拒绝尚未注册能力的复合类型
requireOrdering :: String -> InferredType -> Either String InferredType
@@ -907,7 +941,7 @@ requireOrdering place inferred@(InferType ty)
requireOrdering _ inferred = Right inferred
-- | 解析投影、条件、排序与连接引用
resolveQuery :: Database -> [(String, Column)] -> Statement -> [(String, Expr)] -> Either String Statement
resolveQuery :: Database -> EnclosingScopes -> Statement -> [(String, Expr)] -> Either String Statement
resolveQuery db outer q items = do
source <- resolveSource db outer (selectFrom q)
env <- checkFrom db outer source
@@ -922,7 +956,12 @@ resolveQuery db outer q items = do
-- \| 库限定列只引用来源中的真实表名
qualifiedReference c =
qualifiedReferenceIn db (selectFrom q) c
|| ( any (\(key, _) -> length (filter (== '.') key) == 1 && ("." ++ key) `isSuffixOf` c) outer
|| ( any
(any
(\ (key, _)
-> length (filter (== '.') key) == 1
&& ("." ++ key) `isSuffixOf` c))
outer
&& (not (any (elem '.' . fst) db) || any (\(table, _) -> (table ++ ".") `isPrefixOf` c) db)
)
-- \| 换算一个投影项：带别名时保留别名做输出列名
@@ -941,18 +980,15 @@ 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)
-- \| 优先解析唯一投影别名，再查来源列
let orderName c
| "$position" `isPrefixOf` c = case reads (drop 9 c) of
[(n, "")] | n > 0, n <= length projected -> Right (fst (projected !! (n - 1)))
_ -> Left "ORDER BY: position is outside the select list"
| otherwise = case [label | (label, _) <- projected, label == c, qIsExpression] of
[] -> name "ORDER BY" c
[label] -> Right label
_ -> Left ("ORDER BY: ambiguous projection alias: " ++ c)
qIsExpression = any (\(label, expression) -> expression /= Col label) items
ordering <- mapM (\(c, d) -> (\k -> (k, d)) <$> orderName c) (selectOrderBy q)
pure (Select projected source condition grouping ordering (selectLimit q))
having <- mapM (resolveExpr db env outer (name "HAVING")) (selectHaving q)
-- | 整项名称可用输出别名，复合表达式只查来源
let orderKey key@(OrderColumn column)
| column `elem` map fst projected = key <$ orderExpression projected key
| otherwise = OrderColumn <$> name "ORDER BY" column
orderKey key@(OrderPosition _) = key <$ orderPosition (length projected) key
orderKey (OrderExpression expression) = OrderExpression <$> resolveExpr db env outer (name "ORDER BY") expression
ordering <- mapM (\(key, direction) -> (, direction) <$> orderKey key) (selectOrderBy q)
pure (Select projected source condition grouping having ordering (selectLimit q))
-- | 收集没有别名遮蔽的来源表名
sourceTableNames :: FromClause -> [String]
@@ -967,7 +1003,7 @@ qualifiedReferenceIn db source c = any (\table -> (table ++ ".") `isPrefixOf` c)
tables = sourceTableNames source ++ [key | table <- sourceTableNames source, Right (key, _) <- [resolveTable db table]]
-- | 单表不加限定名，其余来源交给 resolveFrom
resolveSource :: Database -> [(String, Column)] -> FromClause -> Either String FromClause
resolveSource :: Database -> EnclosingScopes -> FromClause -> Either String FromClause
resolveSource db outer fromC = case fromC of
FromTable mAlias tbl -> do
(key, _) <- resolveTable db tbl
@@ -975,7 +1011,7 @@ resolveSource db outer fromC = case fromC of
other -> resolveFrom db outer other
-- | 连接两侧与派生表都要先解析，再取环境解析 ON
resolveFrom :: Database -> [(String, Column)] -> FromClause -> Either String FromClause
resolveFrom :: Database -> EnclosingScopes -> FromClause -> Either String FromClause
resolveFrom _ _ FromUnit = Right FromUnit
resolveFrom db _ (FromTable alias tbl) = do
(key, _) <- resolveTable db tbl
@@ -991,7 +1027,7 @@ resolveFrom db outer (FromJoin kind left right cond) = do
-- \| 连接条件也拒绝不存在的库前缀
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
| otherwise = fst <$> scopedColumnAt "ON" env outer column
c <- resolveExpr db env outer joinName cond
pure (FromJoin kind l r c)
chusql-core/engine/src/ChuSQL/Core/Engine/Storage.hs
+6 -2
View File
@@ -13,10 +13,14 @@ data IndexResult
deriving (Show, Eq)
class (Monad m) => MonadStorage m where
-- \| 在稳定存储视图中执行绑定读取
-- \| 在实际读写前验证绑定依赖
withSchemaGuard :: Database -> m (Either String a) -> m (Either String a)
withSchemaGuard _ _ = pure (Left "bound schema guards are unavailable in this storage")
-- | 确认写守卫能力后执行绑定写入
withWriteSchemaGuard :: Database -> m (Either String a) -> m (Either String a)
withWriteSchemaGuard _ _ = pure (Left "bound write schema guards are unavailable in this storage")
-- \| 建一个库
createDatabase :: String -> m (Either String ())
createDatabase _ = pure (Left "database management is unavailable in this storage")
@@ -48,7 +52,7 @@ class (Monad m) => MonadStorage m where
-- \| 按分片并行扫描并按分片序拼接；默认退回顺序扫描
scanShards :: Int -> String -> Maybe [String] -> m (Either String [Row])
scanShards _ t cols = maybe (scan t) (scanColumns t) cols
scanShards _ t = maybe (scan t) (scanColumns t)
-- \| 追加一行
insert :: String -> Row -> m (Either String ())
chusql-core/engine/src/ChuSQL/Core/Engine/Storage/IPC.hs
+64 -54
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -30,6 +31,8 @@ module ChuSQL.Core.Engine.Storage.IPC (
doListCatalog,
) where
import Data.Foldable (for_)
import Control.Monad (when)
import ChuSQL.Core.Engine.Parallel (parallelShardLimit, poolRun, workerPool)
import ChuSQL.Core.Engine.Storage
import ChuSQL.Core.Engine.Storage.FFI (closeStorage, openStorage, storageRequest)
@@ -110,13 +113,13 @@ withStorageLink = bracket enter leave
case current of
Nothing -> pure ()
Just _ -> modifyMVar_ users $ \count -> do
if count == 0 then takeMVar idle else pure ()
when (count == 0) $ takeMVar idle
pure (count + 1)
pure current
-- \| 最后一个请求结束后发出空闲信号
leave Nothing = pure ()
leave (Just _) = mask_ $ modifyMVar_ users $ \count -> do
if count == 1 then putMVar idle () else pure ()
when (count == 1) $ putMVar idle ()
pure (count - 1)
-- | 装入一条链路；一个进程只装一次
@@ -137,22 +140,21 @@ localStorageLink path = fmap (fmap toLink) (openStorage path)
-- | 关掉当前链路（进程退出前调用）；没有链路就什么都不做
closeConnection :: IO ()
closeConnection = modifyMVar_ linkRef $ \current -> withMVar (snd linkUsers) $ \_ -> do
case current of
Nothing -> pure ()
Just link -> slClose link
for_ current slClose
pure Nothing
-- | 发一条请求并解码应答；链路没装就报错，不崩
sendRequest :: Request -> IO Response
sendRequest req = withStorageLink $ \current -> case current of
Nothing -> pure (RespError "storage not configured")
Just link -> do
raw <- slRequest link (BL.toStrict (encode req))
case raw of
Left e -> pure (RespError ("storage error: " ++ e))
Right bytes -> case eitherDecodeStrict (BS.dropWhileEnd (== 13) bytes) of
Left e -> pure (RespError ("decode error: " ++ e))
Right resp -> pure resp
sendRequest req = withStorageLink $ \case
Nothing -> pure (RespError "storage not configured")
Just link
-> do raw <- slRequest link (BL.toStrict (encode req))
case raw of
Left e -> pure (RespError ("storage error: " ++ e))
Right bytes
-> case eitherDecodeStrict (BS.dropWhileEnd (== 13) bytes) of
Left e -> pure (RespError ("decode error: " ++ e))
Right resp -> pure resp
-- | 原样转发一条载荷给存储库
sendRawRequest :: BS.ByteString -> IO (Either String BS.ByteString)
@@ -241,21 +243,23 @@ okOnly _ = Nothing
-- | 发 Scan
doScan :: Env -> String -> IO (Either String [Row])
doScan env t = ask env "scan" (ReqScan t) $ \resp -> case resp of
RespRows rows -> Just rows
_ -> Nothing
doScan env t = ask env "scan" (ReqScan t) $ \case
RespRows rows -> Just rows
_ -> Nothing
-- | 发带投影的 Scan
doScanColumns :: Env -> String -> [String] -> IO (Either String [Row])
doScanColumns env t cols = ask env "scan" (ReqScanColumns t cols) $ \resp -> case resp of
RespRows rows -> Just [[(c, v) | c <- cols, Just v <- [lookup c row]] | row <- rows]
_ -> Nothing
doScanColumns env t cols = ask env "scan" (ReqScanColumns t cols) $ \case
RespRows rows
-> Just
[[(c, v) | c <- cols, Just v <- [lookup c row]] | row <- rows]
_ -> Nothing
-- | 发分片 Scan：只取第 shard 片
doScanShard :: Env -> String -> Maybe [String] -> Int -> Int -> IO (Either String [Row])
doScanShard env t cols shard shards = ask env "scan_shard" (ReqScanShard t cols shard shards) $ \resp -> case resp of
RespRows rows -> Just rows
_ -> Nothing
doScanShard env t cols shard shards = ask env "scan_shard" (ReqScanShard t cols shard shards) $ \case
RespRows rows -> Just rows
_ -> Nothing
-- | 发 Insert（索引由存储层维护）
doInsert :: Env -> String -> Row -> IO (Either String ())
@@ -271,22 +275,22 @@ doDeleteKeys env t ks = ask env "delete_keys" (ReqDeleteKeys t ks) okOnly
-- | 发 ListTables
doListTables :: Env -> IO (Either String [String])
doListTables env = ask env "list_tables" ReqListTables $ \resp -> case resp of
RespTables ts -> Just ts
_ -> Nothing
doListTables env = ask env "list_tables" ReqListTables $ \case
RespTables ts -> Just ts
_ -> Nothing
-- | 一次拿全库 schema
doListCatalog :: Env -> IO (Either String [TableInfo])
doListCatalog env = ask env "list_catalog" ReqListCatalog $ \resp -> case resp of
RespCatalog xs -> Just xs
_ -> Nothing
doListCatalog env = ask env "list_catalog" ReqListCatalog $ \case
RespCatalog xs -> Just xs
_ -> Nothing
-- | 按某一列的索引取一行（键可以是整数或字符串）
doLookupByColumn :: Env -> String -> String -> Value -> IO (Either String IndexResult)
doLookupByColumn env t c k = ask env "lookup_by_index" (ReqLookupByColumn t c k) $ \resp -> case resp of
RespRows rows -> Just (IndexRows rows)
RespNoIndex -> Just NoIndex
_ -> Nothing
doLookupByColumn env t c k = ask env "lookup_by_index" (ReqLookupByColumn t c k) $ \case
RespRows rows -> Just (IndexRows rows)
RespNoIndex -> Just NoIndex
_ -> Nothing
-- | 范围扫描：没有可用索引就回 Nothing，让上层退回扫描
doScanRange ::
@@ -296,16 +300,16 @@ doScanRange ::
Maybe (Value, Bool) ->
Maybe (Value, Bool) ->
IO (Either String (Maybe [Row]))
doScanRange env t c lo hi = ask env "range_by_index" (ReqRangeByIndex t c lo hi) $ \resp -> case resp of
RespRows rows -> Just (Just rows)
RespNoIndex -> Just Nothing
_ -> Nothing
doScanRange env t c lo hi = ask env "range_by_index" (ReqRangeByIndex t c lo hi) $ \case
RespRows rows -> Just (Just rows)
RespNoIndex -> Just Nothing
_ -> Nothing
-- | 发 DescribeTable
doDescribeTable :: Env -> String -> IO (Either String TableInfo)
doDescribeTable env t = ask env "describe_table" (ReqDescribeTable t) $ \resp -> case resp of
RespSchema info -> Just info
_ -> Nothing
doDescribeTable env t = ask env "describe_table" (ReqDescribeTable t) $ \case
RespSchema info -> Just info
_ -> Nothing
-- | 发 DropTable
doDropTable :: Env -> String -> IO (Either String ())
@@ -349,6 +353,16 @@ instance MonadStorage IPCStorage where
withSchemaGuard dependencies action = IPCStorage $ \env ->
runIPCStorageIn action env{envSchemaGuard = Just dependencies}
-- | 写前握手，旧存储不能先写入后才报错
withWriteSchemaGuard dependencies action = IPCStorage $ \env -> case dependencies of
[] -> pure (Left "bound write requires a target schema guard")
(target, _) : _ -> do
ready <- guardedRequest env dependencies (ReqValidateWrite target)
case ready of
RespOk -> runIPCStorageIn (withSchemaGuard dependencies action) env
RespError err -> pure (Left err)
_ -> pure (Left "unexpected response to validate_write")
-- \| 建一个库
createDatabase name = IPCStorage $ \env -> ask env "create_database" (ReqDatabase "create_database" name) okOnly
@@ -359,20 +373,18 @@ instance MonadStorage IPCStorage where
useDatabase name = IPCStorage $ \env -> ask env "use_database" (ReqDatabase "use_database" name) okOnly
-- \| 列出现有库
listDatabases = IPCStorage $ \env -> ask env "list_databases" (ReqDatabase "list_databases" "") $ \resp -> case resp of
RespTables names -> Just names
_ -> Nothing
listDatabases = IPCStorage $ \env -> ask env "list_databases" (ReqDatabase "list_databases" "") $ \case
RespTables names -> Just names
_ -> Nothing
-- \| 发 Scan
scan t = IPCStorage (\env -> doScan env t)
scan t = IPCStorage (`doScan` t)
-- \| 只取指定列
scanColumns t cols = IPCStorage (\env -> doScanColumns env t cols)
-- \| 并行分片数：按 RTS 能力数，封顶在 parallelShardLimit
parallelShards = IPCStorage $ \_ -> do
caps <- getNumCapabilities
pure (max 1 (min parallelShardLimit caps))
parallelShards = IPCStorage $ \_ -> do max 1 . min parallelShardLimit <$> getNumCapabilities
-- \| 分片并行扫，再按分片序拼接
scanShards width t cols
@@ -407,7 +419,7 @@ instance MonadStorage IPCStorage where
replaceSchema name cols rows = IPCStorage $ \env -> ask env "replace_schema" (ReqReplaceSchema name (map toWire cols) rows) okOnly
-- \| 发 DropTable
dropTable name = IPCStorage (\env -> doDropTable env name)
dropTable name = IPCStorage (`doDropTable` name)
-- \| 建索引
createIndex t c = IPCStorage $ \env -> ask env "create_index" (ReqCreateIndex t c) okOnly
@@ -439,9 +451,9 @@ instance MonadStorage IPCStorage where
-- \| 只问数据字典要结构，设了当前库只留它的表
schema = IPCStorage $ \env -> do
result <- ask env "all_catalogs" ReqAllCatalog $ \resp -> case resp of
RespCatalog infos -> Just infos
_ -> Nothing
result <- ask env "all_catalogs" ReqAllCatalog $ \case
RespCatalog infos -> Just infos
_ -> Nothing
pure (fmap (concatMap (visibleTables (envDatabase env))) result)
-- | 线上表信息转引擎侧统计
@@ -452,9 +464,7 @@ metaOf info = TableMeta (tiRows info) (tiStats info) (tiHistograms info) (tiInde
visibleTables :: Maybe String -> TableInfo -> [(String, Table)]
visibleTables current info
| Just db <- current =
if unqualify (Just db) (tiTable info) /= tiTable info
then [bare named]
else []
[bare named | unqualify (Just db) (tiTable info) /= tiTable info]
| otherwise = [bare info]
where
named = info{tiTable = unqualify current (tiTable info)}
chusql-core/engine/src/ChuSQL/Core/Engine/Storage/Memory.hs
+3
View File
@@ -30,6 +30,9 @@ instance MonadStorage MemoryStorage where
-- \| 纯状态视图在求值期间不受外部修改
withSchemaGuard _ action = action
-- | 纯状态写入不受外部结构变更影响
withWriteSchemaGuard _ action = action
-- \| 全表扫描
scan t = MemoryStorage $ \db -> do
tbl <- lookupTable db t
chusql-core/engine/src/ChuSQL/Core/Engine/Syntax/AST.hs
+54 -8
View File
@@ -1,4 +1,4 @@
module ChuSQL.Core.Engine.Syntax.AST (Statement (..), FromClause (..), JoinKind (..), Expr (..), Subquery (..), Quantifier (..), CompareOp (..), SortDir (..), makeSelect, distinctOrdering) where
module ChuSQL.Core.Engine.Syntax.AST (Statement (..), FromClause (..), JoinKind (..), Expr (..), Subquery (..), Quantifier (..), CompareOp (..), SortDir (..), OrderKey (..), makeSelect, distinctOrdering, orderPosition, orderExpression, orderKeyExpression) where
import ChuSQL.Core.Model (Column (..), ColumnType, Value (..))
import ChuSQL.Core.Engine.Runtime.Types (TypeId, TypeExpr, RuntimeValue)
@@ -13,7 +13,8 @@ data Statement
, selectFrom :: FromClause
, selectWhere :: Maybe Expr
, selectGroupBy :: [String]
, selectOrderBy :: [(String, SortDir)]
, selectHaving :: Maybe Expr
, selectOrderBy :: [(OrderKey, SortDir)]
, selectLimit :: Maybe Int
}
| SelectDistinct Statement
@@ -89,6 +90,11 @@ data Subquery = Subquery
{ subqueryStatement :: Statement
, subqueryRefs :: [String]
}
| BoundSubquery
{ subqueryStatement :: Statement
, subqueryRefs :: [String]
, subquerySlots :: [(String, Expr)]
}
deriving (Show, Eq)
-- | 量词：ANY 至少一行成立，ALL 每一行都成立
@@ -159,6 +165,10 @@ data SortDir
| Desc
deriving (Show, Eq)
-- | 区分排序列、输出序号与来源表达式
data OrderKey = OrderColumn String | OrderPosition Int | OrderExpression Expr
deriving (Show, Eq)
-- | 造一个最简单的 SELECT
makeSelect :: [String] -> String -> Maybe Expr -> Statement
makeSelect cols tbl w =
@@ -167,24 +177,60 @@ makeSelect cols tbl w =
, selectFrom = FromTable Nothing tbl
, selectWhere = w
, selectGroupBy = []
, selectHaving = Nothing
, selectOrderBy = []
, selectLimit = Nothing
}
-- | 将去重排序映射到输出列
distinctOrdering :: Statement -> Either String [(String, SortDir)]
distinctOrdering :: Statement -> Either String [(OrderKey, SortDir)]
distinctOrdering q@Select{} = resolveDistinctOrdering q
distinctOrdering _ = Left "DISTINCT requires SELECT"
-- | 校验排序序号并返回从零开始的位置
orderPosition :: Int -> OrderKey -> Either String (Maybe Int)
orderPosition width (OrderPosition position)
| position > 0, position <= width = Right (Just (position - 1))
| otherwise = Left "ORDER BY: position is outside the select list"
orderPosition _ _ = Right Nothing
-- | 按序号、唯一别名或来源列解析排序表达式
orderExpression :: [(String, Expr)] -> OrderKey -> Either String Expr
orderExpression _ (OrderExpression expression) = Right expression
orderExpression items key@(OrderPosition _) = do
position <- orderPosition (length items) key
case position of
Just slot -> Right (snd (items !! slot))
Nothing -> Left "ORDER BY: missing output position"
orderExpression items (OrderColumn column) = case [expression | (label, expression) <- items, label == column] of
[] -> Right (Col column)
[expression] -> Right expression
expressions | all (== Col column) expressions -> Right (Col column)
_ -> Left ("ORDER BY: ambiguous projection alias: " ++ column)
-- | 收集原始排序键中可能含子查询的表达式
orderKeyExpression :: OrderKey -> Maybe Expr
orderKeyExpression (OrderColumn column) = Just (Col column)
orderKeyExpression (OrderExpression expression) = Just expression
orderKeyExpression (OrderPosition _) = Nothing
-- | 解析去重输出的排序列
resolveDistinctOrdering :: Statement -> Either String [(String, SortDir)]
resolveDistinctOrdering :: Statement -> Either String [(OrderKey, SortDir)]
resolveDistinctOrdering q = mapM resolve (selectOrderBy q)
where
items = case q of
Select { selectItems = projected } -> projected
_ -> []
-- | 排序键必须出现在去重结果中
resolve (column, direction) = case [label | (label, e) <- items, label == column || e == Col column] of
[label] -> Right (label, direction)
[] -> Left "DISTINCT: ORDER BY column must appear in the select list"
_ -> Left "DISTINCT: ambiguous ORDER BY column"
resolve (key, direction) = do
position <- orderPosition (length items) key
case position of
Just _ -> Right (key, direction)
Nothing -> case [slot | (slot, (label, expression)) <- zip [1 ..] items, matches key label expression] of
[slot] -> Right (OrderPosition slot, direction)
[] -> Left "DISTINCT: ORDER BY column must appear in the select list"
_ -> Left "DISTINCT: ambiguous ORDER BY column"
-- | 名称或完整表达式必须对应去重输出项
matches (OrderColumn column) label expression = label == column || expression == Col column
matches (OrderExpression key) _ expression = key == expression
matches (OrderPosition _) _ _ = False
chusql-core/engine/src/ChuSQL/Core/Engine/Syntax/Parser.hs
+58 -41
View File
@@ -1,7 +1,9 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ImportQualifiedPost #-}
module ChuSQL.Core.Engine.Syntax.Parser (parseStatement, parseExpression) where
import Data.Functor (($>))
import ChuSQL.Core.Model (Column (..), ColumnType (..), Value (..), plainColumn)
import ChuSQL.Core.Engine.Builtin (Builtin (..), builtinName, builtinNames, builtinNode, compareNode)
import ChuSQL.Core.Engine.Syntax.AST
@@ -259,15 +261,19 @@ literalValue =
-- | 负浮点字面量
negateLit d = VFloat (negate d)
-- | 一个排序列
orderItem :: Parser (String, SortDir)
-- | 一个排序键：输出序号、列名或表达式
orderItem :: Parser (OrderKey, SortDir)
orderItem = do
col <- qualifiedName <|> (("$position" ++) . show <$> integer)
expression <- expr
dir <- sortDir
return (col, dir)
let key = case expression of
LitInt position -> OrderPosition position
Col column -> OrderColumn column
_ -> OrderExpression expression
return (key, dir)
-- | ORDER BY 的列表
orderByClause :: Parser [(String, SortDir)]
orderByClause :: Parser [(OrderKey, SortDir)]
orderByClause = do
keyword "order"
keyword "by"
@@ -337,6 +343,7 @@ reservedWords =
, "auto_increment"
, "type"
, "group"
, "having"
, "with"
, "any"
, "all"
@@ -358,9 +365,10 @@ tableRef = do
-- | 连接类型：内连接 / 左外连接
joinKind :: Parser JoinKind
joinKind =
try (keyword "left" *> optional (keyword "outer") *> keyword "join" *> return LeftJoin)
<|> try (keyword "inner" *> keyword "join" *> return InnerJoin)
<|> (keyword "join" *> return InnerJoin)
try ((keyword "left" *> optional (keyword "outer") *> keyword "join")
$> LeftJoin)
<|> try ((keyword "inner" *> keyword "join") $> InnerJoin)
<|> (keyword "join" $> InnerJoin)
-- | FROM 里的一个来源：表或派生表
fromSource :: Parser FromClause
@@ -422,11 +430,9 @@ createTableStatement = do
-- | 读 DROP TABLE
dropTableStatement :: Parser Statement
dropTableStatement = do
keyword "drop"
keyword "table"
name <- tableName
return (DropTable name)
dropTableStatement = do keyword "drop"
keyword "table"
DropTable <$> tableName
-- | 读 CREATE INDEX（列名即索引名）
createIndexStatement :: Parser Statement
@@ -485,12 +491,10 @@ alterTableStatement = do
-- | 读 CREATE USER，口令是明文
createUserStatement :: Parser Statement
createUserStatement = do
keyword "create"
keyword "user"
name <- userName
pw <- identifiedBy
return (CreateUser name pw)
createUserStatement = do keyword "create"
keyword "user"
name <- userName
CreateUser name <$> identifiedBy
-- | 读 IDENTIFIED BY '口令'
identifiedBy :: Parser String
@@ -529,11 +533,9 @@ alterRoleStatement = do
-- | 读 DROP USER
dropUserStatement :: Parser Statement
dropUserStatement = do
keyword "drop"
keyword "user"
name <- userName
return (DropUser name)
dropUserStatement = do keyword "drop"
keyword "user"
DropUser <$> userName
-- | 读 CREATE ROLE
createRoleStatement :: Parser Statement
@@ -613,11 +615,18 @@ columnDef = do
columnConstraint :: Parser (Column -> Column)
columnConstraint =
choice
[ try (keyword "not" *> keyword "null" *> pure (\c -> c{columnNullable = False}))
, keyword "null" *> pure (\c -> c{columnNullable = True})
, keyword "auto_increment" *> pure (\c -> c{columnAutoIncrement = True, columnNullable = False})
, try (keyword "primary" *> keyword "key" *> pure (\c -> c{columnPrimaryKey = True, columnUnique = True, columnNullable = False}))
, keyword "unique" *> pure (\c -> c{columnUnique = True})
[ try ((keyword "not" *> keyword "null")
$> (\ c -> c {columnNullable = False}))
, keyword "null" $> (\ c -> c {columnNullable = True})
, keyword "auto_increment"
$>
(\ c -> c {columnAutoIncrement = True, columnNullable = False})
, try ((keyword "primary" *> keyword "key")
$>
(\ c
-> c {columnPrimaryKey = True, columnUnique = True,
columnNullable = False}))
, keyword "unique" $> (\ c -> c {columnUnique = True})
, keyword "default" *> ((\v c -> c{columnDefault = Just v}) <$> literalValue)
, keyword "check" *> ((\s c -> c{columnCheck = Just s}) <$> checkText)
]
@@ -639,18 +648,18 @@ columnTypeP =
, keyword "int" >> pure CInt
, keyword "bigint" >> pure CBigInt
, keyword "smallint" >> pure CSmallInt
, (keyword "varchar" >>) (maybe CStr CVarchar <$> optional sizeParen)
, (keyword "char" >>) (maybe (CChar 1) CChar <$> optional sizeParen)
, keyword "varchar" >> (maybe CStr CVarchar <$> optional sizeParen)
, keyword "char" >> (maybe (CChar 1) CChar <$> optional sizeParen)
, keyword "text" >> pure CStr
, keyword "str" >> pure CStr
, keyword "boolean" >> pure CBool
, keyword "bool" >> pure CBool
, keyword "float" >> pure CFloat
, keyword "real" >> pure CFloat
, try (keyword "double" *> keyword "precision" *> pure CDouble)
, try ((keyword "double" *> keyword "precision") $> CDouble)
, keyword "double" >> pure CDouble
, (keyword "decimal" >>) decimalType
, (keyword "numeric" >>) decimalType
, keyword "decimal" >> decimalType
, keyword "numeric" >> decimalType
, keyword "date" >> pure CDate
, keyword "timestamp" >> pure CTimestamp
, keyword "blob" >> pure CBlob
@@ -695,9 +704,10 @@ selectStatement = do
fromC <- fromMaybe FromUnit <$> optional (keyword "from" *> fromClause)
mWhere <- optional (keyword "where" *> expr)
groupBy <- fromMaybe [] <$> optional groupByClause
having <- optional (keyword "having" *> expr)
orderBy <- fromMaybe [] <$> optional orderByClause
mLimit <- optional limitClause
pure $ (if distinct then SelectDistinct else id) (Select cols fromC mWhere groupBy orderBy mLimit)
pure $ (if distinct then SelectDistinct else id) (Select cols fromC mWhere groupBy having orderBy mLimit)
-- | 读 WITH：展开每个 CTE 再读主查询
withStatement :: Parser Statement
@@ -747,10 +757,11 @@ renameColumns name cols q@Select { selectItems = items } = do
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)
renameOrder (OrderColumn column, direction) = case [new | ((old, _), new) <- zip items cols, old == column] of
[] -> Right (OrderColumn column, direction)
[new] -> Right (OrderColumn new, direction)
_ -> Left ("WITH: ambiguous ORDER BY alias: " ++ column)
renameOrder ordering = Right ordering
renameColumns _ _ _ = Left "WITH: a CTE must be a SELECT"
-- | 列清单个数必须和本体输出一致
@@ -765,10 +776,16 @@ expandStatement env stmt = case stmt of
SelectDistinct q -> SelectDistinct <$> expandStatement env q
q@Select { selectFrom = fromC, selectItems = items, selectWhere = mWhere } -> do
fromC' <- expandClause env fromC
items' <- traverse (\(name, e) -> fmap ((,) name) (expandExpr env e)) items
items' <- traverse (\(name, e) -> fmap (name,) (expandExpr env e)) items
w <- traverse (expandExpr env) mWhere
Right q { selectFrom = fromC', selectItems = items', selectWhere = w }
having <- traverse (expandExpr env) (selectHaving q)
ordering <- mapM expandOrder (selectOrderBy q)
Right q { selectFrom = fromC', selectItems = items', selectWhere = w, selectHaving = having, selectOrderBy = ordering }
_ -> Right stmt
where
-- | 展开排序表达式中的 CTE 子查询
expandOrder (OrderExpression expression, direction) = (,) . OrderExpression <$> expandExpr env expression <*> pure direction
expandOrder ordering = Right ordering
-- | 来源树里的 CTE 引用换成派生表
expandClause :: [(String, Statement)] -> FromClause -> Either String FromClause
@@ -811,7 +828,7 @@ expandExpr env e = case e of
ScalarSub sq -> ScalarSub <$> goSub sq
InSub x sq neg -> (\x' sq' -> InSub x' sq' neg) <$> go x <*> goSub sq
InList x es neg -> (\x' es' -> InList x' es' neg) <$> go x <*> traverse go es
ExistsSub sq neg -> (\sq' -> ExistsSub sq' neg) <$> goSub sq
ExistsSub sq neg -> (`ExistsSub` neg) <$> goSub sq
QuantCmp op x sq q -> (\x' sq' -> QuantCmp op x' sq' q) <$> go x <*> goSub sq
_ -> Right e
where
chusql-core/engine/test/RuntimeSpec.hs
+399 -4
View File
@@ -3,17 +3,17 @@ module RuntimeSpec (spec) where
import ChuSQL.Core.Engine.Runtime.Types
import ChuSQL.Core.Engine.Runtime.Functions
import ChuSQL.Core.Engine.Runtime.Binding
import ChuSQL.Core.Engine.Runtime.Relation (bindRelOpColumns)
import ChuSQL.Core.Engine.Runtime.Relation (bindRelOpColumns, bindWriteColumns)
import qualified ChuSQL.Core.Engine.Algebra.Op as Rel
import ChuSQL.Core.Engine.Algebra.Expr (evalExpr)
import ChuSQL.Core.Engine.Algebra.Expr (evalExpr, subquerySlotsIn)
import ChuSQL.Core.Engine.Algebra.Eval (evalRelOp)
import ChuSQL.Core.Engine.Algebra.Sort (sortBoundRows)
import ChuSQL.Core.Engine.Storage.Memory (runMemoryStorage)
import qualified ChuSQL.Core.Engine.Runtime.Query as Query
import ChuSQL.Core.Engine (rowsOf, runStatement)
import ChuSQL.Core.Engine (rowsOf, runStatement, runStatementM, bindWrite, executeWriteM)
import ChuSQL.Core.Engine.Semantic (prepare, prepareRowExpression)
import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
import ChuSQL.Core.Engine.Syntax.AST (Expr (..), Statement (..), SortDir (..))
import ChuSQL.Core.Engine.Syntax.AST (Expr (..), Statement (..), Subquery (..), FromClause (..), SortDir (..))
import qualified ChuSQL.Core.Model as SQL
import ChuSQL.Core.Protocol (valueToJSON, valueFromJSON, TableInfo (..))
import qualified Data.Aeson as A
@@ -22,6 +22,8 @@ import Data.Aeson.Types (parseEither)
import Data.Hashable (hash)
import Control.Monad (foldM)
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.List (isInfixOf)
import Data.Bifunctor (second)
import Test.Hspec
-- 运行时类型、函数绑定、物理编码和类型化查询测试。
@@ -38,6 +40,90 @@ sqlCatalog = foldM apply []
-- | 检查运行时类型基础契约
spec :: Spec
spec = do
describe "bound write plans" $ do
it "reuses INSERT targets and constraints while refreshing the auto counter" $ do
let result = do
db <- sqlCatalog ["CREATE DOMAIN cached_quantity AS INT"
, "CREATE TABLE cached_insert (id INT AUTO_INCREMENT PRIMARY KEY, qty cached_quantity DEFAULT 2, tag TEXT CHECK (length(tag) > 1))"]
statement <- parseStatement "INSERT INTO cached_insert (tag) VALUES ('abc')"
bound <- bindWrite db statement
(first, inserted) <- runMemoryStorage (executeWriteM bound) db
first
let reversed = [(name, table {SQL.tableRows = map reverse (SQL.tableRows table)}) | (name, table) <- inserted]
(secondResult, final) <- runMemoryStorage (executeWriteM bound) reversed
secondResult
select <- parseStatement "SELECT id, qty, tag FROM cached_insert"
map (map snd) <$> rowsOf (runStatement final select)
result `shouldBe` Right [[SQL.VInt 1, SQL.VInt 2, SQL.VStr "abc"], [SQL.VInt 2, SQL.VInt 2, SQL.VStr "abc"]]
it "reuses ordered UPDATE targets and final-row uniqueness checks" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE cached_update (id INT PRIMARY KEY, qty INT NOT NULL UNIQUE CHECK (qty < 10))"
, "INSERT INTO cached_update (id, qty) VALUES (1, 1), (2, 8)"]
statement <- parseStatement "UPDATE cached_update SET qty = qty + 1, qty = qty + id WHERE id = 1"
bound <- bindWrite db statement
duplicate <- parseStatement "UPDATE cached_update SET qty = 8 WHERE id = 1" >>= bindWrite db
(first, updated) <- runMemoryStorage (executeWriteM bound) db
first
(secondResult, twice) <- runMemoryStorage (executeWriteM bound) updated
secondResult
(rejected, unchanged) <- runMemoryStorage (executeWriteM duplicate) twice
Right (SQL.tableRows <$> lookup "cached_update" twice, rejected
, SQL.tableRows <$> lookup "cached_update" unchanged)
rows = Just [[("id", SQL.VInt 1), ("qty", SQL.VInt 5)], [("id", SQL.VInt 2), ("qty", SQL.VInt 8)]]
result `shouldBe` Right (rows, Left "UNIQUE: duplicate value in column qty", rows)
it "defers assignment errors until a reused plan matches a current row" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE deferred_write (id INT, qty INT CHECK (qty > 0))"]
statement <- parseStatement "UPDATE deferred_write SET qty = 1 / 0 WHERE id = 9"
bound <- bindWrite db statement
(empty, initial) <- runMemoryStorage (executeWriteM bound) db
empty
inserted <- parseStatement "INSERT INTO deferred_write (id, qty) VALUES (9, 5)" >>= runStatement initial
(rejected, final) <- runMemoryStorage (executeWriteM bound) (fst inserted)
Right (rejected, SQL.tableRows <$> lookup "deferred_write" final)
result `shouldBe` Right (Left "division by zero", Just [[("id", SQL.VInt 9), ("qty", SQL.VInt 5)]])
it "rejects stale INSERT UPDATE and DELETE plans before changing rows" $ do
mapM_ (\source -> do
let result = do
db <- sqlCatalog ["CREATE TABLE saved_write (id INT, qty INT)", "INSERT INTO saved_write (id, qty) VALUES (1, 5)"]
statement <- parseStatement source
bound <- bindWrite db statement
added <- parseStatement "ALTER TABLE saved_write ADD COLUMN extra TEXT" >>= runStatement db
restored <- parseStatement "ALTER TABLE saved_write DROP COLUMN extra" >>= runStatement (fst added)
(rejected, final) <- runMemoryStorage (executeWriteM bound) (fst restored)
Right (rejected, SQL.tableRows <$> lookup "saved_write" final)
result `shouldBe` Right (Left "bound query schema changed: saved_write", Just [[("id", SQL.VInt 1), ("qty", SQL.VInt 5)]]))
[ "INSERT INTO saved_write (id, qty) VALUES (2, 8)"
, "UPDATE saved_write SET qty = qty + 1"
, "DELETE FROM saved_write WHERE id = 1"
]
it "reuses a write plan across data and unrelated schema changes" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE reusable_write (id INT, qty INT)", "CREATE TABLE unrelated_write (id INT)", "INSERT INTO reusable_write (id, qty) VALUES (1, 5)"]
statement <- parseStatement "UPDATE reusable_write SET qty = qty + 1 WHERE id = 1"
bound <- bindWrite db statement
changed <- parseStatement "INSERT INTO reusable_write (id, qty) VALUES (2, 9)" >>= runStatement db
unrelated <- parseStatement "ALTER TABLE unrelated_write ADD COLUMN extra TEXT" >>= runStatement (fst changed)
(first, updated) <- runMemoryStorage (executeWriteM bound) (fst unrelated)
first
(secondResult, final) <- runMemoryStorage (executeWriteM bound) updated
secondResult
Right (SQL.tableRows <$> lookup "reusable_write" final)
result `shouldBe` Right (Just [[("id", SQL.VInt 1), ("qty", SQL.VInt 7)], [("id", SQL.VInt 2), ("qty", SQL.VInt 9)]])
it "rejects replaced targets and changed subquery or DOMAIN dependencies" $ do
let result = do
db <- sqlCatalog ["CREATE DOMAIN quantity AS INT", "CREATE TABLE dependent_write (id quantity)", "CREATE TABLE source_write (id INT)"]
statement <- parseStatement "UPDATE dependent_write SET id = (SELECT MAX(id) FROM source_write)"
let identified = [(name, table {SQL.tableIdentity = Just (SQL.TableIdentity 1 1)}) | (name, table) <- db]
bound <- bindWrite identified statement
let replaced = [(name, if name == "dependent_write" then table {SQL.tableIdentity = Just (SQL.TableIdentity 1 2)} else table) | (name, table) <- identified]
domainChanged = [(name, if name == SQL.domainTableName "quantity" then table {SQL.tableSchemaVersion = Just 2} else table) | (name, table) <- identified]
changed <- parseStatement "ALTER TABLE source_write ADD COLUMN extra TEXT" >>= runStatement identified
target <- fst <$> runMemoryStorage (executeWriteM bound) replaced
dependency <- fst <$> runMemoryStorage (executeWriteM bound) (fst changed)
domain <- fst <$> runMemoryStorage (executeWriteM bound) domainChanged
Right (target, dependency, domain)
result `shouldBe` Right (Left "bound query object changed: dependent_write", Left "bound query schema changed: source_write", Left "bound query schema changed: __system_domain_quantity")
describe "runtime type registry" $ do
it "keeps a fixed identity encoding across releases" $ withType (listType intType) $ \tid ->
encodeType tid `shouldBe` BS.pack "[1,[5,[[1,[]]]]]"
@@ -58,6 +144,173 @@ spec = do
resolveType builtinTypes (TypeApply (TypeConstructorId 5) []) `shouldSatisfy` isFailure
it "rejects arguments to Int" $
resolveType builtinTypes (TypeApply (TypeConstructorId 1) [intType]) `shouldSatisfy` isFailure
describe "bound write expressions" $ do
it "rejects missing existing key columns instead of skipping uniqueness checks" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE constraint_slots (id INT PRIMARY KEY, qty INT UNIQUE)"]
insert <- parseStatement "INSERT INTO constraint_slots (id, qty) VALUES (2, 3)"
let damaged = [(name, table {SQL.tableRows = [[("qty", SQL.VInt 9)]]}) | (name, table) <- db]
Right (runStatement damaged insert)
case result of
Right rejected -> rejected `shouldSatisfy` either (isInfixOf "missing bound column: id") (const False)
Left err -> expectationFailure err
it "checks existing INSERT keys and ALTER constraints with reversed physical columns" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE constraint_order (id INT PRIMARY KEY, qty INT UNIQUE)"
, "INSERT INTO constraint_order (id, qty) VALUES (1, 2), (2, 3)"]
let reversed = [(name, table {SQL.tableRows = map reverse (SQL.tableRows table)}) | (name, table) <- db]
insert <- parseStatement "INSERT INTO constraint_order (qty, id) VALUES (4, 3)"
(inserted, _) <- runStatement reversed insert
alter <- parseStatement "ALTER TABLE constraint_order ALTER COLUMN qty SET NOT NULL"
(altered, _) <- runStatement inserted alter
select <- parseStatement "SELECT id, qty FROM constraint_order"
map (map snd) <$> rowsOf (runStatement altered select)
result `shouldBe` Right [[SQL.VInt 1, SQL.VInt 2], [SQL.VInt 2, SQL.VInt 3], [SQL.VInt 3, SQL.VInt 4]]
it "rejects missing ALTER input before evaluating bound constraints" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE altered_missing (id INT, qty INT UNIQUE)"]
alter <- parseStatement "ALTER TABLE altered_missing ALTER COLUMN qty SET NOT NULL"
let damaged = [(name, table {SQL.tableRows = [[("id", SQL.VInt 1)]]}) | (name, table) <- db]
Right (runStatement damaged alter)
case result of
Right rejected -> rejected `shouldSatisfy` either (isInfixOf "missing bound column: qty") (const False)
Left err -> expectationFailure err
it "rejects UPDATE nullability and final-row uniqueness violations" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE update_constraints (id INT PRIMARY KEY, qty INT NOT NULL UNIQUE)"
, "INSERT INTO update_constraints (id, qty) VALUES (1, 2), (2, 3)"]
nullable <- parseStatement "UPDATE update_constraints SET qty = NULL WHERE id = 1"
duplicate <- parseStatement "UPDATE update_constraints SET qty = 3 WHERE id = 1"
primary <- parseStatement "UPDATE update_constraints SET id = 2 WHERE id = 1"
Right (db, [(nullable, "NOT NULL"), (duplicate, "UNIQUE"), (primary, "UNIQUE")])
case result of
Right (db, statements) -> mapM_ (\(statement, marker) ->
case runMemoryStorage (runStatementM statement) db of
Right (Left err, unchanged) -> do
err `shouldSatisfy` isInfixOf marker
map (second SQL.tableRows) unchanged
`shouldBe` map (second SQL.tableRows) db
other -> expectationFailure (show other)) statements
Left err -> expectationFailure err
it "checks UPDATE uniqueness after all rows rather than each replacement" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE update_unique (id INT PRIMARY KEY, qty INT UNIQUE)"
, "INSERT INTO update_unique (id, qty) VALUES (1, 2), (2, 3), (3, NULL), (4, NULL)"
, "UPDATE update_unique SET qty = qty + 1 WHERE id < 3"]
select <- parseStatement "SELECT id, qty FROM update_unique"
map (map snd) <$> rowsOf (runStatement db select)
result `shouldBe` Right [[SQL.VInt 1, SQL.VInt 3], [SQL.VInt 2, SQL.VInt 4]
, [SQL.VInt 3, SQL.VNull], [SQL.VInt 4, SQL.VNull]]
it "rejects repeated INSERT targets instead of discarding later values" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE insert_targets (id INT, qty INT)"]
statement <- parseStatement "INSERT INTO insert_targets (id, qty, qty) VALUES (1, 2, 9)"
runStatement db statement
result `shouldSatisfy` either (isInfixOf "INSERT: duplicate target column: qty") (const False)
it "binds reordered INSERT inputs while retaining defaults, NULL and auto numbering" $ do
let result = do
db <- sqlCatalog ["CREATE DOMAIN insert_label AS VARCHAR(4)"
, "CREATE TABLE insert_slots (id INT AUTO_INCREMENT PRIMARY KEY, label insert_label DEFAULT 'ok', qty INT DEFAULT 7)"
, "INSERT INTO insert_slots (qty, label, id) VALUES (NULL, 'ab', 10), (3, 'cd', NULL), (4, 'ef', 2)"
, "INSERT INTO insert_slots (label) VALUES ('gh')"
, "INSERT INTO insert_slots (qty) VALUES (8)"]
select <- parseStatement "SELECT id, label, qty FROM insert_slots"
map (map snd) <$> rowsOf (runStatement db select)
result `shouldBe` Right [[SQL.VInt 10, SQL.VStr "ab", SQL.VNull]
, [SQL.VInt 11, SQL.VStr "cd", SQL.VInt 3]
, [SQL.VInt 2, SQL.VStr "ef", SQL.VInt 4]
, [SQL.VInt 12, SQL.VStr "gh", SQL.VInt 7]
, [SQL.VInt 13, SQL.VStr "ok", SQL.VInt 8]]
it "binds write predicates and assignments to target schema positions" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE write_slots (id INT, qty INT)"]
statement <- parseStatement "UPDATE write_slots SET qty = qty + id WHERE id = 1"
prepare db statement >>= bindWriteColumns db
result `shouldBe` Right (Update "write_slots"
[("qty", Add (ColumnSlot 1 "qty") (ColumnSlot 0 "id"))]
(Just (Eq (ColumnSlot 0 "id") (LitInt 1))))
it "binds CHECK columns inside resolved function calls" $ do
let columns = [("id", SQL.plainColumn SQL.CInt), ("name", SQL.plainColumn SQL.CStr)]
result = prepareRowExpression columns (Gt (FunctionCall "length" [Col "name"]) (LitInt 1))
case result of
Right (Gt (BoundFunction (FunctionId 1) _ [ColumnSlot 1 "name"]) (LitInt 1)) -> pure ()
_ -> expectationFailure (show result)
it "preserves sequential updates and row order with reversed physical columns" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE write_slots (id INT, qty INT CHECK (qty >= 0))"
, "INSERT INTO write_slots (id, qty) VALUES (1, 2), (2, 10), (3, 5)"]
let reversed = [(name, table {SQL.tableRows = map reverse (SQL.tableRows table)}) | (name, table) <- db]
update <- parseStatement "UPDATE write_slots SET qty = qty + 1, qty = qty + id WHERE id = 1"
(updated, _) <- runStatement reversed update
delete <- parseStatement "DELETE FROM write_slots WHERE qty = 10"
(remaining, _) <- runStatement updated delete
select <- parseStatement "SELECT id, qty FROM write_slots"
map (map snd) <$> rowsOf (runStatement remaining select)
result `shouldBe` Right [[SQL.VInt 1, SQL.VInt 4], [SQL.VInt 3, SQL.VInt 5]]
it "keeps nested DOMAIN coercion, defaults and nullable writes" $ do
let result = do
db <- sqlCatalog ["CREATE DOMAIN short_label AS VARCHAR(4)", "CREATE DOMAIN label AS short_label"
, "CREATE TABLE write_domains (id INT, name label CHECK (length(name) > 1), qty INT DEFAULT 2)"
, "INSERT INTO write_domains (id, name) VALUES (1, 'abc')"]
select <- parseStatement "SELECT id, name, qty FROM write_domains"
original <- map (map snd) <$> rowsOf (runStatement db select)
update <- parseStatement "UPDATE write_domains SET qty = NULL WHERE id = 1"
(updated, _) <- runStatement db update
rejected <- parseStatement "UPDATE write_domains SET name = 'abcde' WHERE id = 1"
rows <- map (map snd) <$> rowsOf (runStatement updated select)
Right (original, rows, runStatement updated rejected)
case result of
Right (original, rows, rejected) -> do
original `shouldBe` [[SQL.VInt 1, SQL.VStr "abc", SQL.VInt 2]]
rows `shouldBe` [[SQL.VInt 1, SQL.VStr "abc", SQL.VNull]]
rejected `shouldSatisfy` isFailure
Left err -> expectationFailure err
it "keeps correlated subqueries in bound assignments and DELETE predicates" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE write_outer (id INT, qty INT)"
, "CREATE TABLE write_inner (id INT)"
, "INSERT INTO write_outer (id, qty) VALUES (1, 2), (2, 10)"
, "INSERT INTO write_inner (id) VALUES (2)"]
update <- parseStatement "UPDATE write_outer SET qty = qty + (SELECT i.id FROM write_inner i WHERE i.id = qty) WHERE id = 1"
(updated, _) <- runStatement db update
select <- parseStatement "SELECT id, qty FROM write_outer"
changed <- map (map snd) <$> rowsOf (runStatement updated select)
delete <- parseStatement "DELETE FROM write_outer WHERE EXISTS (SELECT i.id FROM write_inner i WHERE i.id = qty - 2)"
(remaining, _) <- runStatement updated delete
kept <- map (map snd) <$> rowsOf (runStatement remaining select)
Right (changed, kept)
result `shouldBe` Right ([[SQL.VInt 1, SQL.VInt 4], [SQL.VInt 2, SQL.VInt 10]]
, [[SQL.VInt 2, SQL.VInt 10]])
it "checks altered rows using schema order and keeps CHECK failures explicit" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE write_checks (id INT, qty INT CHECK (qty > id))"
, "INSERT INTO write_checks (id, qty) VALUES (1, 3)"]
let reversed = [(name, table {SQL.tableRows = map reverse (SQL.tableRows table)}) | (name, table) <- db]
alter <- parseStatement "ALTER TABLE write_checks ADD COLUMN note TEXT DEFAULT 'ok'"
(altered, _) <- runStatement reversed alter
invalid <- parseStatement "UPDATE write_checks SET qty = 0 WHERE id = 1"
Right (runStatement altered invalid)
case result of
Right (Left err) -> err `shouldSatisfy` isInfixOf "CHECK on qty failed"
other -> expectationFailure (show other)
it "does not evaluate skipped assignments or empty DELETE predicates" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE write_lazy (id INT, qty INT)"
, "INSERT INTO write_lazy (id, qty) VALUES (1, 2)"]
update <- parseStatement "UPDATE write_lazy SET qty = 1 / 0 WHERE id = 99"
(updated, _) <- runStatement db update
delete <- parseStatement "DELETE FROM write_lazy"
(empty, _) <- runStatement updated delete
invalid <- parseStatement "DELETE FROM write_lazy WHERE 1 / 0 = 1"
runStatement empty invalid
result `shouldSatisfy` either (const False) (const True)
it "rejects missing physical columns before a write" $ do
let db = [("write_missing", SQL.Table "write_missing"
[("id", SQL.plainColumn SQL.CInt), ("qty", SQL.plainColumn SQL.CInt)]
[[("id", SQL.VInt 1)]] Nothing Nothing Nothing)]
mapM_ (\source -> rowsOf (parseStatement source >>= runStatement db)
`shouldBe` Left "missing bound column: qty")
["UPDATE write_missing SET id = 2", "DELETE FROM write_missing WHERE id = 1"]
describe "runtime encoding" $ do
it "round trips nested lists, optional values and tuples" $ do
let ty = tupleType [listType (maybeType intType), stringType, doubleType, boolType]
@@ -223,6 +476,16 @@ spec = do
rejected <- fst <$> runMemoryStorage (Query.executeQueryM bound) (fst referenced)
Right (accepted, rejected)
result `shouldBe` Right (Right [[("n", SQL.VNull)]], Left "bound query schema changed: referenced")
it "guards tables referenced only by HAVING or expression ordering" $ do
let result query = do
db <- sqlCatalog ["CREATE TABLE main_rows (id INT)", "CREATE TABLE dependency_rows (id INT)"]
bound <- parseStatement query >>= Query.bindQuery db
changed <- parseStatement "ALTER TABLE dependency_rows ADD COLUMN extra TEXT" >>= runStatement db
fst <$> runMemoryStorage (Query.executeQueryM bound) (fst changed)
mapM_ (\query -> result query `shouldBe` Right (Left "bound query schema changed: dependency_rows"))
[ "SELECT COUNT(*) FROM main_rows HAVING COUNT(*) > (SELECT COUNT(*) FROM dependency_rows)"
, "SELECT id FROM main_rows ORDER BY (SELECT COUNT(*) FROM dependency_rows) + id"
]
it "rejects schema drift before executing an empty bound query" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE bound_items (id INT)"]
@@ -304,6 +567,45 @@ spec = do
it "binds outer references after the local relation layout" $ do
bindRelOpColumns [] ["outer.id"] (Rel.Compute [("id", Col "outer.id")] Rel.Unit)
`shouldBe` Right (Rel.Compute [("id", OuterColumnSlot 0 0 "outer.id")] Rel.Unit)
it "binds subquery references to parent slots before execution" $ do
let statement = Select [("value", Col "parent.id")] FromUnit Nothing [] Nothing [] Nothing
query = Subquery statement ["parent.id"]
source = Rel.Compute [("id", LitInt 1)] Rel.Unit
plan = Rel.Compute [("value", ScalarSub query)] source
bindRelOpColumns [] [] plan `shouldBe` Right (Rel.Compute
[("value", ScalarSub (BoundSubquery statement ["parent.id"] [("parent.id", ColumnSlot 0 "id")]))] source)
case bindRelOpColumns [] [] plan of
Left err -> expectationFailure err
Right bound -> evalRelOp [] bound `shouldBe` Right [[("value", SQL.VInt 1)]]
it "keeps exact outer subquery references ahead of local physical fallbacks" $ do
let statement = Select [("value", Col "parent.id")] FromUnit Nothing [] Nothing [] Nothing
query = Subquery statement ["parent.id"]
source = Rel.Compute [("id", LitInt 1)] Rel.Unit
bindRelOpColumns [] ["parent.id"] (Rel.Compute [("value", ScalarSub query)] source)
`shouldBe` Right (Rel.Compute [("value", ScalarSub (BoundSubquery statement ["parent.id"]
[("parent.id", OuterColumnSlot 1 0 "parent.id")]))] source)
it "uses distinct bound positions when subqueries share a diagnostic name" $ do
let statement = Select [("value", Col "x")] FromUnit Nothing [] Nothing [] Nothing
first = ScalarSub (BoundSubquery statement ["x"] [("x", ColumnSlot 0 "a")])
second = ScalarSub (BoundSubquery statement ["x"] [("x", ColumnSlot 1 "b")])
table = SQL.Table "slot_cache" [("a", SQL.plainColumn SQL.CInt), ("b", SQL.plainColumn SQL.CInt)]
[[("a", SQL.VInt 1), ("b", SQL.VInt 2)], [("a", SQL.VInt 1), ("b", SQL.VInt 3)]] Nothing Nothing Nothing
plan = Rel.Compute [("first", first), ("second", second)] (Rel.Scan Nothing "slot_cache" Nothing)
subquerySlotsIn (Add first second) `shouldBe` [ColumnSlot 0 "a", ColumnSlot 1 "b"]
evalRelOp [("slot_cache", table)] plan `shouldBe` Right
[[("first", SQL.VInt 1), ("second", SQL.VInt 2)]
, [("first", SQL.VInt 1), ("second", SQL.VInt 3)]]
it "rejects bound subquery layout mismatches instead of looking up names" $ do
let statement = Select [("value", Col "id")] FromUnit Nothing [] Nothing [] Nothing
query = BoundSubquery statement ["id"] [("id", ColumnSlot 0 "id")]
wrongLayout = Rel.Compute [("other", LitInt 2), ("id", LitInt 1)] Rel.Unit
evalRelOp [] (Rel.Compute [("value", ScalarSub query)] wrongLayout)
`shouldBe` Left "bound column position mismatch: id"
prepareRowExpression [] (ScalarSub query)
`shouldBe` Left "execution subquery cannot be used in semantic input"
bindRelOpColumns [] [] (Rel.Compute [("value", ScalarSub
(BoundSubquery statement ["id"] []))] Rel.Unit)
`shouldBe` Left "bound subquery references mismatch"
it "preserves outer scope identity when rebinding beside a local name" $ do
let source = Rel.Compute [("id", LitInt 1)] Rel.Unit
expression = OuterColumnSlot 0 0 "id"
@@ -315,6 +617,37 @@ spec = do
`shouldBe` Left "unknown column: id"
prepareRowExpression [] expression `shouldBe` Left "execution column cannot be used in semantic input"
prepareRowExpression [] (ColumnSlot 0 "id") `shouldBe` Left "execution column cannot be used in semantic input"
it "preserves duplicate column positions when rebinding local and outer slots" $ do
let source = Rel.Compute [("id", LitInt 1), ("id", LitInt 9)] Rel.Unit
plan = Rel.Compute [("value", ColumnSlot 1 "id")] source
bindRelOpColumns [] [] plan `shouldBe` Right plan
(bindRelOpColumns [] [] plan >>= evalRelOp [])
`shouldBe` Right [[("value", SQL.VInt 9)]]
bindRelOpColumns [] ["id", "id"] (Rel.Compute [("value", OuterColumnSlot 0 1 "id")] source)
`shouldBe` Right (Rel.Compute [("value", OuterColumnSlot 2 1 "id")] source)
it "rejects ambiguous slot relocation and invalid bound positions" $ do
let source = Rel.Compute [("other", LitInt 0), ("id", LitInt 1), ("id", LitInt 9)] Rel.Unit
bindRelOpColumns [] [] (Rel.Compute [("value", ColumnSlot 0 "id")] source)
`shouldBe` Left "ambiguous bound column: id"
bindRelOpColumns [] ["other", "id", "id"] (Rel.Compute [("value", OuterColumnSlot 0 0 "id")] Rel.Unit)
`shouldBe` Left "ambiguous bound column: id"
bindRelOpColumns [] [] (Rel.Compute [("value", ColumnSlot (-1) "id")] source)
`shouldBe` Left "bound column position mismatch: id"
bindRelOpColumns [] ["id"] (Rel.Compute [("value", OuterColumnSlot (-1) 0 "id")] Rel.Unit)
`shouldBe` Left "bound column position mismatch: id"
bindRelOpColumns [] [] (Rel.Compute [("value", ColumnSlot 0 "id")]
(Rel.Compute [("other", LitInt 0), ("id", LitInt 9)] Rel.Unit))
`shouldBe` Right (Rel.Compute [("value", ColumnSlot 1 "id")]
(Rel.Compute [("other", LitInt 0), ("id", LitInt 9)] Rel.Unit))
it "keeps duplicate parent slots distinct through subquery rebinding and caching" $ do
let statement = Select [("value", Col "x")] FromUnit Nothing [] Nothing [] Nothing
first = ScalarSub (BoundSubquery statement ["x"] [("x", ColumnSlot 0 "id")])
second = ScalarSub (BoundSubquery statement ["x"] [("x", ColumnSlot 1 "id")])
source = Rel.Compute [("id", LitInt 1), ("id", LitInt 9)] Rel.Unit
plan = Rel.Compute [("first", first), ("second", second)] source
bindRelOpColumns [] [] plan `shouldBe` Right plan
(bindRelOpColumns [] [] plan >>= evalRelOp [])
`shouldBe` Right [[("first", SQL.VInt 1), ("second", SQL.VInt 9)]]
it "keeps inner shadowing and multi-level correlated SQL references" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE scoped_items (id INT)"
@@ -323,6 +656,68 @@ spec = do
rows <- rowsOf (runStatement db statement)
Right (map (map snd) rows)
result `shouldBe` Right [[SQL.VInt 1, SQL.VInt 1, SQL.VInt 1], [SQL.VInt 2, SQL.VInt 2, SQL.VInt 2]]
it "resolves the nearest of several enclosing column scopes" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE scope_far (id INT)", "CREATE TABLE scope_near (id INT)"
, "INSERT INTO scope_far (id) VALUES (1), (2)", "INSERT INTO scope_near (id) VALUES (10), (11)"]
statement <- parseStatement "SELECT o.id, (SELECT (SELECT id) FROM scope_near n WHERE n.id = o.id + 9) AS nearest FROM scope_far o"
map (map snd) <$> rowsOf (runStatement db statement)
result `shouldBe` Right [[SQL.VInt 1, SQL.VInt 10], [SQL.VInt 2, SQL.VInt 11]]
it "keeps enclosing scopes separate when aliases and DOMAIN types overlap" $ withType stringType $ \tid -> do
let result = do
db <- sqlCatalog ["CREATE DOMAIN scope_label AS VARCHAR(4)"
, "CREATE TABLE scope_far (value INT)", "CREATE TABLE scope_near (value scope_label)"
, "INSERT INTO scope_far (value) VALUES (7)", "INSERT INTO scope_near (value) VALUES ('abc')"]
statement <- parseStatement "SELECT (SELECT (SELECT length(s.value)) FROM scope_near s) AS size FROM scope_far s"
rows <- map (map snd) <$> rowsOf (runStatement db statement)
domain <- parseStatement "SELECT (SELECT (SELECT s.value) FROM scope_near s) AS label FROM scope_far s"
bound <- Query.bindQuery db domain
Right (rows, Query.queryTypes bound)
result `shouldBe` Right ([[SQL.VInt 3]], [("label", Query.DomainType "scope_label" (Query.RuntimeType tid))])
it "skips empty or unrelated enclosing scopes and preserves NULL" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE scope_far (id INT)", "CREATE TABLE scope_near (name TEXT)"
, "INSERT INTO scope_far (id) VALUES (NULL), (4)", "INSERT INTO scope_near (name) VALUES ('n')"]
statement <- parseStatement "SELECT (SELECT (SELECT (SELECT id)) FROM scope_near n) AS echoed FROM scope_far o"
map (map snd) <$> rowsOf (runStatement db statement)
result `shouldBe` Right [[SQL.VNull], [SQL.VInt 4]]
it "does not resolve an ambiguous nearer scope against a farther one" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE scope_far (id INT)", "CREATE TABLE scope_near (id INT)"]
statement <- parseStatement "SELECT (SELECT (SELECT id) FROM scope_near a JOIN scope_near b ON a.id = b.id) FROM scope_far o"
rowsOf (runStatement db statement)
result `shouldSatisfy` either (isInfixOf "ambiguous column") (const False)
it "does not take a missing column from a shadowed source alias" $ do
let result source = do
db <- sqlCatalog ["CREATE TABLE source_far (id INT)", "CREATE TABLE source_near (other INT)"
, "INSERT INTO source_far (id) VALUES (1)", "INSERT INTO source_near (other) VALUES (10)"]
statement <- parseStatement source
rowsOf (runStatement db statement)
mapM_ (\source -> result source `shouldSatisfy` either (isInfixOf "unknown column") (const False))
["SELECT (SELECT s.id FROM source_near s) FROM source_far s"
, "SELECT (SELECT (SELECT s.id) FROM source_near s) FROM source_far s"]
it "keeps bare far columns visible when the nearer alias has no such column" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE source_far (id INT)", "CREATE TABLE source_near (other INT)"
, "INSERT INTO source_far (id) VALUES (1), (2)", "INSERT INTO source_near (other) VALUES (10)"]
statement <- parseStatement "SELECT (SELECT (SELECT id) FROM source_near s) AS inherited FROM source_far s"
map (map snd) <$> rowsOf (runStatement db statement)
result `shouldBe` Right [[SQL.VInt 1], [SQL.VInt 2]]
it "uses lexical scopes in IN, EXISTS and quantified subqueries" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE scope_far (id INT)", "CREATE TABLE scope_near (id INT)"
, "INSERT INTO scope_far (id) VALUES (1)", "INSERT INTO scope_near (id) VALUES (10)"]
statement <- parseStatement "SELECT (SELECT 10 IN (SELECT id) AND EXISTS (SELECT 1 WHERE id = 10) AND 10 = ALL (SELECT id) FROM scope_near n) AS matched FROM scope_far o"
map (map snd) <$> rowsOf (runStatement db statement)
result `shouldBe` Right [[SQL.VBool True]]
it "resolves JOIN conditions against the nearest enclosing scope" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE scope_far (value INT)", "CREATE TABLE scope_near (value INT)"
, "CREATE TABLE scope_join (id INT)", "INSERT INTO scope_far (value) VALUES (1)"
, "INSERT INTO scope_near (value) VALUES (10)", "INSERT INTO scope_join (id) VALUES (10)"]
statement <- parseStatement "SELECT (SELECT (SELECT a.id FROM scope_join a JOIN scope_join b ON a.id = value AND b.id = a.id) FROM scope_near n) AS matched FROM scope_far o"
map (map snd) <$> rowsOf (runStatement db statement)
result `shouldBe` Right [[SQL.VInt 10]]
it "executes SQL against reversed physical column order" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE slot_items (id INT, name TEXT)"
chusql-core/engine/test/Spec.hs
+555 -38
View File
@@ -1,7 +1,9 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}
module Main where
import Data.Either (fromRight)
import ChuSQL.Core.Engine.Algebra.Cost (rangeRows, selectivityOf)
import ChuSQL.Core.Engine.Algebra.Eval (evalRelOp, evalRelOpM)
import ChuSQL.Core.Engine.Algebra.Expr (colsInExpr, evalExpr)
@@ -25,7 +27,7 @@ import ChuSQL.Core.Engine.Syntax.Parser
import Control.Concurrent (forkFinally, forkIO, killThread, threadDelay)
import Control.Concurrent.Chan (newChan, readChan, writeChan)
import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar, tryPutMVar)
import Control.Monad (replicateM_, void)
import Control.Monad (replicateM_, void, when)
import Control.Exception (ErrorCall, IOException, bracket_, finally, try)
import Data.Hashable (hash)
import qualified Data.ByteString as BS
@@ -141,6 +143,26 @@ main = hspec $ do
`shouldBe` Right (RevokeGrantOption ["SELECT", "UPDATE"] "users" "alice")
parseStatement "REVOKE GRANT OPTION FOR reader FROM alice" `shouldSatisfy` either (const True) (const False)
describe "ORDER BY positions" $ do
it "sorts the selected output position despite duplicate aliases" $ do
let sql = "SELECT age AS x, -age AS x FROM users ORDER BY 2 LIMIT 1"
rowsOf (parseStatement sql >>= runStatement testDB)
`shouldBe` Right [[("x", VInt 30), ("x", VInt (-30))]]
sameResultAsUnoptimized sql
rowsOf (parseStatement "SELECT DISTINCT age AS x, -age AS x FROM users ORDER BY 2 LIMIT 1" >>= runStatement testDB)
`shouldBe` Right [[("x", VInt 30), ("x", VInt (-30))]]
rowsOf (parseStatement "SELECT DISTINCT user_id, user_id FROM orders ORDER BY 2 DESC" >>= runStatement testDB)
`shouldBe` Right [[("user_id", VInt 2), ("user_id", VInt 2)], [("user_id", VInt 1), ("user_id", VInt 1)]]
rowsOf (parseStatement "SELECT age, age FROM users ORDER BY age LIMIT 1" >>= runStatement testDB)
`shouldBe` Right [[("age", VInt 17), ("age", VInt 17)]]
it "preserves ordinal grouping, correlation and delayed projection errors" $ do
rowsOf (parseStatement "SELECT user_id AS x, count(*) AS x FROM orders GROUP BY user_id ORDER BY 2 DESC" >>= runStatement testDB)
`shouldBe` Right [[("x", VInt 1), ("x", VInt 2)], [("x", VInt 2), ("x", VInt 1)]]
rowsOf (parseStatement "SELECT name AS x, 1 / (age - 25) AS x FROM users ORDER BY 1 DESC LIMIT 1" >>= runStatement testDB)
`shouldBe` Right [[("x", VStr "Carol"), ("x", VInt 0)]]
rowsOf (parseStatement "SELECT o.id, (SELECT i.age AS x FROM users i WHERE i.id = o.id ORDER BY 1 LIMIT 1) AS age FROM users o ORDER BY 1" >>= runStatement testDB)
`shouldBe` Right [[("o.id", VInt 1), ("age", VInt 25)], [("o.id", VInt 2), ("age", VInt 17)], [("o.id", VInt 3), ("age", VInt 30)]]
rowsOf (parseStatement "WITH t(a, b) AS (SELECT age AS x, -age AS x FROM users ORDER BY 2 LIMIT 1) SELECT * FROM t" >>= runStatement testDB)
`shouldBe` Right [[("t.a", VInt 30), ("t.b", VInt (-30))]]
it "resolves positions after wildcard expansion and before limiting" $ do
rowsOf (parseStatement "SELECT * FROM orders ORDER BY 2 DESC, 1 DESC LIMIT 2" >>= runStatement testDB)
`shouldBe` Right [tableRows orders !! 1, tableRows orders !! 2]
@@ -149,6 +171,19 @@ main = hspec $ do
it "rejects zero and positions beyond the output" $ do
mapM_ (\sql -> (parseStatement sql >>= runStatement testDB) `shouldSatisfy` either (isInfixOf "outside the select list") (const False))
["SELECT id FROM users ORDER BY 0", "SELECT id FROM users ORDER BY 2"]
it "keeps NULL and equal-key row order when mixing ordinals and aliases" $ do
let rows = [[("id", VInt n), ("name", VStr "same"), ("age", value)]
| (n, value) <- [(1, VInt 2), (2, VNull), (3, VInt 2)]]
db = [("users", users { tableRows = rows })]
sql = "SELECT id AS x, age AS x, name AS tag FROM users ORDER BY 2, tag"
rowsOf (parseStatement sql >>= runStatement db)
`shouldBe` Right [[("x", VInt 2), ("x", VNull), ("tag", VStr "same")]
, [("x", VInt 1), ("x", VInt 2), ("tag", VStr "same")]
, [("x", VInt 3), ("x", VInt 2), ("tag", VStr "same")]]
(parseStatement "SELECT LIST<Int>(1) AS x, id AS x FROM users ORDER BY 1" >>= runStatement testDB)
`shouldSatisfy` either (isInfixOf "capability is not registered") (const False)
(parseStatement "SELECT age AS x, id AS x FROM users ORDER BY 1, x" >>= runStatement testDB)
`shouldSatisfy` either (isInfixOf "ambiguous projection alias") (const False)
describe "SELECT DISTINCT" $ do
it "deduplicates projected values before ordering and limiting" $ do
let db = [("orders", orders { tableRows = tableRows orders ++ tableRows orders })]
@@ -193,6 +228,21 @@ main = hspec $ do
}
(runIPCStorage (withSchemaGuard [] (scan "ignored"))
`shouldReturn` Left "storage did not confirm bound schema guard") `finally` closeConnection
it "rejects an ignored write handshake before sending the mutation" $ do
requests <- newMVar []
setStorageLink StorageLink
{ slRequest = \payload -> do
modifyMVar_ requests (pure . (payload :))
pure (Right (BSC.pack "{\"status\":\"ok\"}"))
, slClose = pure ()
}
flip finally closeConnection $ do
runIPCStorage (withWriteSchemaGuard [("ignored", users)]
(insert "ignored" [("id", VInt 1)]))
`shouldReturn` Left "storage did not confirm bound schema guard"
sent <- readMVar requests
length sent `shouldBe` 1
head sent `shouldSatisfy` BS.isInfixOf (BSC.pack "\"method\":\"validate_write\"")
it "propagates catalog failures through snapshot, schema and SQL" $ do
setStorageLink StorageLink
{ slRequest = \_ -> pure (Right (BSC.pack "{\"status\":\"error\",\"message\":\"catalog unavailable\"}"))
@@ -573,6 +623,7 @@ main = hspec $ do
(Eq (Col "id") (Col "user_id"))
, selectWhere = Nothing
, selectGroupBy = []
, selectHaving = Nothing
, selectOrderBy = []
, selectLimit = Nothing
}
@@ -591,6 +642,7 @@ main = hspec $ do
(Eq (Col "u.id") (Col "o.user_id"))
, selectWhere = Nothing
, selectGroupBy = []
, selectHaving = Nothing
, selectOrderBy = []
, selectLimit = Nothing
}
@@ -609,6 +661,7 @@ main = hspec $ do
(Eq (Col "u.id") (Col "o.user_id"))
, selectWhere = Nothing
, selectGroupBy = []
, selectHaving = Nothing
, selectOrderBy = []
, selectLimit = Nothing
}
@@ -637,9 +690,10 @@ main = hspec $ do
, selectFrom =
FromSubquery
(Just "d")
(Select [("name", Col "name")] (FromTable Nothing "users") Nothing [] [] Nothing)
(Select [("name", Col "name")] (FromTable Nothing "users") Nothing [] Nothing [] Nothing)
, selectWhere = Nothing
, selectGroupBy = []
, selectHaving = Nothing
, selectOrderBy = []
, selectLimit = Nothing
}
@@ -654,7 +708,7 @@ main = hspec $ do
( FromJoin
InnerJoin
(FromTable (Just "u") "users")
(FromSubquery (Just "d") (Select [("name", Col "name")] (FromTable Nothing "users") Nothing [] [] Nothing))
(FromSubquery (Just "d") (Select [("name", Col "name")] (FromTable Nothing "users") Nothing [] Nothing [] Nothing))
(Eq (Col "u.name") (Col "d.name"))
)
@@ -666,6 +720,7 @@ main = hspec $ do
(FromTable Nothing "orders")
Nothing
[]
Nothing
[]
Nothing
)
@@ -717,9 +772,10 @@ main = hspec $ do
, selectFrom =
FromSubquery
(Just "t")
(Select [("name", Col "name")] (FromTable Nothing "users") Nothing [] [] Nothing)
(Select [("name", Col "name")] (FromTable Nothing "users") Nothing [] Nothing [] Nothing)
, selectWhere = Nothing
, selectGroupBy = []
, selectHaving = Nothing
, selectOrderBy = []
, selectLimit = Nothing
}
@@ -779,11 +835,11 @@ main = hspec $ do
it "parses >= into GtE" $ do
parseStatement "SELECT name FROM users WHERE age >= 18"
`shouldBe` Right (Select [("name", Col "name")] (FromTable Nothing "users") (Just (GtE (Col "age") (LitInt 18))) [] [] Nothing)
`shouldBe` Right (Select [("name", Col "name")] (FromTable Nothing "users") (Just (GtE (Col "age") (LitInt 18))) [] Nothing [] Nothing)
it "parses <= into LtE" $ do
parseStatement "SELECT name FROM users WHERE age <= 30"
`shouldBe` Right (Select [("name", Col "name")] (FromTable Nothing "users") (Just (LtE (Col "age") (LitInt 30))) [] [] Nothing)
`shouldBe` Right (Select [("name", Col "name")] (FromTable Nothing "users") (Just (LtE (Col "age") (LitInt 30))) [] Nothing [] Nothing)
it "parses <> and != into the same node" $ do
sql "SELECT name FROM users WHERE age <> 17"
@@ -804,7 +860,8 @@ main = hspec $ do
executeOperator OpNe [VInt 1, VFloat 1.0] `shouldBe` Right (VBool False)
it "rewrites >= and <= into an inclusive index range" $ do
let stat rows distinct indexes = TableMeta rows [(c, d, False) | (c, d) <- distinct] [] indexes
let stat rows distinct
= TableMeta rows [(c, d, False) | (c, d) <- distinct] []
dbWith m = [("users", Table "users" [("id", TInt), ("name", TStr)] [] (Just m) Nothing Nothing)]
indexed = dbWith (stat 10000 [("id", 10000)] ["id"])
low = Filter (GtE (Col "id") (LitInt 2)) (Scan Nothing "users" Nothing)
@@ -863,11 +920,11 @@ main = hspec $ do
it "parses > ANY into a quantified comparison" $ do
parseStatement "SELECT name FROM users WHERE age > ANY (SELECT age FROM orders)"
`shouldBe` Right (Select [("name", Col "name")] (FromTable Nothing "users") (Just (QuantCmp CmpGt (Col "age") (Subquery (Select [("age", Col "age")] (FromTable Nothing "orders") Nothing [] [] Nothing) []) AnyQ)) [] [] Nothing)
`shouldBe` Right (Select [("name", Col "name")] (FromTable Nothing "users") (Just (QuantCmp CmpGt (Col "age") (Subquery (Select [("age", Col "age")] (FromTable Nothing "orders") Nothing [] Nothing [] Nothing) []) AnyQ)) [] Nothing [] Nothing)
it "parses <> ALL into a quantified comparison" $ do
parseStatement "SELECT name FROM users WHERE age <> ALL (SELECT age FROM orders)"
`shouldBe` Right (Select [("name", Col "name")] (FromTable Nothing "users") (Just (QuantCmp CmpNe (Col "age") (Subquery (Select [("age", Col "age")] (FromTable Nothing "orders") Nothing [] [] Nothing) []) AllQ)) [] [] Nothing)
`shouldBe` Right (Select [("name", Col "name")] (FromTable Nothing "users") (Just (QuantCmp CmpNe (Col "age") (Subquery (Select [("age", Col "age")] (FromTable Nothing "orders") Nothing [] Nothing [] Nothing) []) AllQ)) [] Nothing [] Nothing)
it "still reads plain comparisons" $ do
values "SELECT name FROM users WHERE age > 20 ORDER BY name"
@@ -1080,9 +1137,9 @@ main = hspec $ do
Left err -> expectationFailure err
Right (_, _) -> do
rowsOf (runStatement testDB (makeSelect ["name"] "users" Nothing))
`shouldSatisfy` \r -> case r of
Right rows -> length rows == 3
Left _ -> False
`shouldSatisfy` \case
Right rows -> length rows == 3
Left _ -> False
it "returns Left when column count does not match value count" $ do
runStatement testDB (Insert "users" ["name", "age"] [[LitStr "Dave"]])
@@ -1277,7 +1334,7 @@ main = hspec $ do
it "user is reserved as an alias but still usable inside a longer name" $ do
parseStatement "SELECT * FROM users user" `shouldSatisfy` isLeft
parseStatement "SELECT user1 FROM users" `shouldBe` Right (Select [("user1", Col "user1")] (FromTable Nothing "users") Nothing [] [] Nothing)
parseStatement "SELECT user1 FROM users" `shouldBe` Right (Select [("user1", Col "user1")] (FromTable Nothing "users") Nothing [] Nothing [] Nothing)
describe "ChuSQL.Core.Engine (DELETE)" $ do
it "parses DELETE with WHERE" $ do
@@ -1399,17 +1456,17 @@ main = hspec $ do
`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)]
Right q -> selectOrderBy q `shouldBe` [(OrderColumn "age", Desc)]
Left err -> expectationFailure err
it "defaults to ASC" $ do
case parseStatement "SELECT name FROM users ORDER BY age" of
Right q -> selectOrderBy q `shouldBe` [("age", Asc)]
Right q -> selectOrderBy q `shouldBe` [(OrderColumn "age", Asc)]
Left err -> expectationFailure err
it "parses multiple ORDER BY columns" $ do
case parseStatement "SELECT name FROM users ORDER BY age DESC, name ASC" of
Right q -> selectOrderBy q `shouldBe` [("age", Desc), ("name", Asc)]
Right q -> selectOrderBy q `shouldBe` [(OrderColumn "age", Desc), (OrderColumn "name", Asc)]
Left err -> expectationFailure err
it "executes ORDER BY age ASC" $ do
@@ -1419,7 +1476,8 @@ main = hspec $ do
, selectFrom = FromTable Nothing "users"
, selectWhere = Nothing
, selectGroupBy = []
, selectOrderBy = [("age", Asc)]
, selectHaving = Nothing
, selectOrderBy = [(OrderColumn "age", Asc)]
, selectLimit = Nothing
}
rowsOf (runStatement testDB q)
@@ -1436,7 +1494,8 @@ main = hspec $ do
, selectFrom = FromTable Nothing "users"
, selectWhere = Nothing
, selectGroupBy = []
, selectOrderBy = [("age", Desc)]
, selectHaving = Nothing
, selectOrderBy = [(OrderColumn "age", Desc)]
, selectLimit = Nothing
}
rowsOf (runStatement testDB q)
@@ -1455,7 +1514,7 @@ main = hspec $ do
it "parses LIMIT after ORDER BY" $ do
case parseStatement "SELECT * FROM users ORDER BY age DESC LIMIT 1" of
Right q -> do
selectOrderBy q `shouldBe` [("age", Desc)]
selectOrderBy q `shouldBe` [(OrderColumn "age", Desc)]
selectLimit q `shouldBe` Just 1
Left err -> expectationFailure err
@@ -1466,6 +1525,7 @@ main = hspec $ do
, selectFrom = FromTable Nothing "users"
, selectWhere = Nothing
, selectGroupBy = []
, selectHaving = Nothing
, selectOrderBy = []
, selectLimit = Just 2
}
@@ -1482,7 +1542,8 @@ main = hspec $ do
, selectFrom = FromTable Nothing "users"
, selectWhere = Nothing
, selectGroupBy = []
, selectOrderBy = [("age", Desc)]
, selectHaving = Nothing
, selectOrderBy = [(OrderColumn "age", Desc)]
, selectLimit = Just 2
}
rowsOf (runStatement testDB q)
@@ -1498,6 +1559,7 @@ main = hspec $ do
, selectFrom = FromTable Nothing "users"
, selectWhere = Nothing
, selectGroupBy = []
, selectHaving = Nothing
, selectOrderBy = []
, selectLimit = Just 0
}
@@ -1552,6 +1614,7 @@ main = hspec $ do
(Eq (Col "u.id") (Col "x.id"))
, selectWhere = Nothing
, selectGroupBy = []
, selectHaving = Nothing
, selectOrderBy = []
, selectLimit = Nothing
}
@@ -1726,18 +1789,233 @@ main = hspec $ do
fmap (map (map snd)) result `shouldBe` Right [[VStr "Alice"], [VStr "Bob"]]
scanTimes "orders" scans `shouldBe` 1
it "runs a correlated subquery once per distinct binding" $ do
it "scans simple correlated equality once through a semi join" $ do
let (result, scans) =
countedRun "SELECT o.product FROM orders o WHERE EXISTS (SELECT * FROM users u WHERE u.id = o.user_id)"
fmap (map (map snd)) result `shouldBe` Right [[VStr "Book"], [VStr "Pen"], [VStr "Cup"]]
scanTimes "users" scans `shouldBe` 2
scanTimes "users" scans `shouldBe` 1
scanTimes "orders" scans `shouldBe` 1
it "runs a non-correlated subquery in a computed column only once" $ do
let (result, scans) = countedRun "SELECT name, (SELECT COUNT(*) FROM orders) FROM users"
length (either (const []) id result) `shouldBe` 3
length (fromRight [] result) `shouldBe` 3
scanTimes "orders" scans `shouldBe` 1
describe "semi joins" $ do
let keysDB =
[ ("left_keys", users {tableName = "left_keys", tableCols = [("k", TInt)],
tableRows = [[("k", value)] | value <- [VInt 1, VInt 1, VInt 2, VNull, VInt 3]]})
, ("right_keys", users {tableName = "right_keys", tableCols = [("k", TInt)],
tableRows = [[("k", value)] | value <- [VInt 1, VInt 1, VNull]]})
]
-- | 在键边界数据上执行查询
sql input = fmap (map (map snd)) (rowsOf (parseStatement input >>= runStatement keysDB))
-- | 检查经过语义解析的优化计划
plan input = renderPlan . optimize testDB <$> (parseStatement input >>= prepare testDB >>= translate)
it "keeps left duplicates without multiplying right matches" $ do
sql "SELECT k FROM left_keys WHERE k IN (SELECT k FROM right_keys)"
`shouldBe` Right [[VInt 1], [VInt 1]]
sql "SELECT l.k FROM left_keys l WHERE EXISTS (SELECT 1 FROM right_keys r WHERE r.k = l.k)"
`shouldBe` Right [[VInt 1], [VInt 1]]
it "distinguishes NOT EXISTS from NULL-aware NOT IN" $ do
sql "SELECT l.k FROM left_keys l WHERE NOT EXISTS (SELECT 1 FROM right_keys r WHERE l.k = r.k)"
`shouldBe` Right [[VInt 2], [VNull], [VInt 3]]
sql "SELECT k FROM left_keys WHERE k NOT IN (SELECT k FROM right_keys)" `shouldBe` Right []
sql "SELECT k FROM left_keys WHERE k NOT IN (SELECT k FROM right_keys WHERE k = 1)"
`shouldBe` Right [[VInt 2], [VInt 3]]
it "applies empty-set rules even to NULL left values" $ do
sql "SELECT k FROM left_keys WHERE k IN (SELECT k FROM right_keys WHERE k < 0)" `shouldBe` Right []
sql "SELECT k FROM left_keys WHERE k NOT IN (SELECT k FROM right_keys WHERE k < 0)"
`shouldBe` Right [[VInt 1], [VInt 1], [VInt 2], [VNull], [VInt 3]]
sql "SELECT l.k FROM left_keys l WHERE NOT EXISTS (SELECT r.k FROM right_keys r WHERE r.k = l.k AND r.k < 0)"
`shouldBe` Right [[VInt 1], [VInt 1], [VInt 2], [VNull], [VInt 3]]
it "plans eligible predicates as semi joins and scans the right once" $ do
mapM_ (\query -> do
plan query `shouldSatisfy` either (const False) (isInfixOf "SemiJoin")
sameResultAsUnoptimized query)
[ "SELECT name FROM users WHERE id IN (SELECT user_id FROM orders)"
, "SELECT name FROM users WHERE id NOT IN (SELECT user_id FROM orders)"
, "SELECT o.product FROM orders o WHERE EXISTS (SELECT 1 FROM users u WHERE u.id = o.user_id)"
, "SELECT o.product FROM orders o WHERE NOT EXISTS (SELECT 1 FROM users u WHERE o.user_id = u.id)"
]
let (_, scans) = countedRun "SELECT o.product FROM orders o WHERE EXISTS (SELECT 1 FROM users u WHERE u.id = o.user_id)"
scanTimes "users" scans `shouldBe` 1
it "keeps complex correlation and risky left keys on the original path" $ do
mapM_ (\query -> plan query `shouldSatisfy` either (const False) (not . isInfixOf "SemiJoin"))
[ "SELECT name FROM users WHERE 1 / (id - 1) IN (SELECT id FROM orders)"
, "SELECT u.name FROM users u WHERE EXISTS (SELECT 1 / 0 FROM orders o WHERE o.user_id = u.id)"
, "SELECT u.name FROM users u WHERE EXISTS (SELECT 1 FROM orders o WHERE o.user_id > u.id)"
, "SELECT u.name FROM users u WHERE EXISTS (SELECT COUNT(*) FROM orders o WHERE o.user_id = u.id)"
]
sameResultAsUnoptimized "SELECT u.name FROM users u WHERE EXISTS (SELECT COUNT(*) FROM orders o WHERE o.user_id = u.id)"
it "skips the right side for empty left input and preserves right errors" $ do
let (empty, scans) = countedRun "SELECT d.id FROM (SELECT id FROM users WHERE id < 0) d WHERE d.id IN (SELECT 1 / 0 FROM orders)"
empty `shouldBe` Right []
scanTimes "orders" scans `shouldBe` 0
fst (countedRun "SELECT id FROM users WHERE id IN (SELECT 1 / (id - 2) FROM orders)")
`shouldBe` Left "division by zero"
fst (countedRun "SELECT u.id FROM users u WHERE EXISTS (SELECT 1 / 0 FROM orders o WHERE o.user_id = u.id)")
`shouldBe` Left "division by zero"
it "retains mixed numeric comparison at the floating precision boundary" $ do
let db =
[ ("big", users {tableName = "big", tableCols = [("id", TInt)],
tableRows = [[("id", VInt value)] | value <- [9007199254740995, 9007199254740996, 9007199254740997, 9007199254740998]]})
, ("floats", users {tableName = "floats", tableCols = [("value", plainColumn CFloat)],
tableRows = [[("value", VFloat 9007199254740996)]]})
]
result = do
statement <- parseStatement "SELECT id FROM big WHERE id IN (SELECT value FROM floats)"
original <- prepare db statement >>= translate
unoptimized <- evalRelOp db original
optimized <- rowsOf (runStatement db statement)
Right (unoptimized, optimized)
expected = [[("id", VInt 9007199254740995)], [("id", VInt 9007199254740996)], [("id", VInt 9007199254740997)]]
result `shouldBe` Right (expected, expected)
it "keeps nested enclosing scopes and repeated bindings distinct" $ do
sameResultAsUnoptimized "SELECT u.id FROM users u WHERE EXISTS (SELECT o.id FROM orders o WHERE EXISTS (SELECT x.id FROM users x WHERE x.id = u.id))"
sameResultAsUnoptimized "SELECT u.id FROM users u WHERE EXISTS (SELECT o.id FROM orders o WHERE EXISTS (SELECT x.id FROM users x WHERE x.id = o.user_id))"
it "shares independent IN results with other subquery consumers" $ do
let (result, scans) = countedRun "SELECT name, (SELECT COUNT(*) FROM orders) AS n FROM users WHERE id IN (SELECT COUNT(*) FROM orders)"
result `shouldBe` Right [[("name", VStr "Carol"), ("n", VInt 3)]]
scanTimes "orders" scans `shouldBe` 1
it "preserves grouping, DISTINCT, ordering and LIMIT around semi joins" $ do
mapM_ sameResultAsUnoptimized
[ "SELECT DISTINCT user_id FROM orders WHERE user_id IN (SELECT id FROM users) ORDER BY user_id DESC LIMIT 1"
, "SELECT user_id, COUNT(*) FROM orders WHERE user_id IN (SELECT id FROM users) GROUP BY user_id HAVING COUNT(*) > 1 ORDER BY COUNT(*) DESC"
, "SELECT name FROM users WHERE id IN (SELECT user_id FROM orders ORDER BY id LIMIT 1) ORDER BY age + 1"
]
case parseStatement "SELECT name FROM users WHERE id IN (SELECT user_id FROM orders)" >>= prepare testDB >>= translate of
Left err -> expectationFailure err
Right original -> optimize testDB (optimize testDB original) `shouldBe` optimize testDB original
it "executes semi and anti joins with NULL through storage IPC" $
withTestSession $ \srv -> withServerEnv srv $ do
-- | 在真实存储执行半连接查询
let query input = case parseStatement input of
Left err -> pure (Left err)
Right statement -> runIPCStorage (runStatementM statement)
mapM_ (\input -> query input `shouldReturn` Right [])
[ "CREATE TABLE semi_left (k int)"
, "CREATE TABLE semi_right (k int)"
, "INSERT INTO semi_left (k) VALUES (1), (1), (2), (NULL)"
, "INSERT INTO semi_right (k) VALUES (1), (1), (NULL)"
]
query "SELECT l.k FROM semi_left l WHERE EXISTS (SELECT 1 FROM semi_right r WHERE r.k = l.k)"
`shouldReturn` Right [[("l.k", VInt 1)], [("l.k", VInt 1)]]
query "SELECT l.k FROM semi_left l WHERE NOT EXISTS (SELECT 1 FROM semi_right r WHERE r.k = l.k)"
`shouldReturn` Right [[("l.k", VInt 2)], [("l.k", VNull)]]
query "SELECT k FROM semi_left WHERE k NOT IN (SELECT k FROM semi_right)" `shouldReturn` Right []
query "SELECT k FROM semi_left WHERE k NOT IN (SELECT k FROM semi_right WHERE k < 0)"
`shouldReturn` Right [[("k", VInt 1)], [("k", VInt 1)], [("k", VInt 2)], [("k", VNull)]]
describe "NULL membership in empty subqueries" $ do
-- | 在测试库运行并取值
let values input = fmap (map (map snd)) (rowsOf (parseStatement input >>= runStatement testDB))
it "uses the same empty-set rule for membership and quantified comparison" $ do
inValues VNull [] `shouldBe` Right (VBool False)
values "SELECT NULL IN (SELECT id FROM orders WHERE id < 0), NULL NOT IN (SELECT id FROM orders WHERE id < 0), NULL = ANY (SELECT id FROM orders WHERE id < 0), NULL <> ALL (SELECT id FROM orders WHERE id < 0)"
`shouldBe` Right [[VBool False, VBool True, VBool False, VBool True]]
it "retains unknown results for nonempty sets" $ do
values "SELECT NULL IN (SELECT id FROM orders), NULL NOT IN (SELECT id FROM orders), NULL IN (NULL), NULL NOT IN (NULL)"
`shouldBe` Right [[VNull, VNull, VNull, VNull]]
it "keeps optimized filtering identical to the original plan" $ do
mapM_ sameResultAsUnoptimized
[ "SELECT name FROM users WHERE NULL IN (SELECT id FROM orders WHERE id < 0)"
, "SELECT name FROM users WHERE NULL NOT IN (SELECT id FROM orders WHERE id < 0)"
]
describe "query materialization" $ do
it "shares one subquery across predicates, ordering and output" $ do
let query = "SELECT name, (SELECT COUNT(*) FROM orders) AS n FROM users WHERE (SELECT COUNT(*) FROM orders) > 0 ORDER BY (SELECT COUNT(*) FROM orders) + age DESC"
(result, scans) = countedRun query
fmap (map (map snd)) result `shouldBe` Right [[VStr "Carol", VInt 3], [VStr "Alice", VInt 3], [VStr "Bob", VInt 3]]
scanTimes "orders" scans `shouldBe` 1
sameResultAsUnoptimized query
it "shares correlated results by referenced values across operators" $ do
let query = "SELECT o.product, (SELECT COUNT(*) FROM users u WHERE u.id = o.user_id) AS n FROM orders o WHERE (SELECT COUNT(*) FROM users u WHERE u.id = o.user_id) > 0 ORDER BY o.product"
(result, scans) = countedRun query
fmap (map (map snd)) result `shouldBe` Right [[VStr "Book", VInt 1], [VStr "Cup", VInt 1], [VStr "Pen", VInt 1]]
scanTimes "users" scans `shouldBe` 2
sameResultAsUnoptimized query
it "shares rows while preserving each subquery consumer's semantics" $ do
let (result, scans) = countedRun "SELECT EXISTS (SELECT id FROM orders) AS found, 1 IN (SELECT id FROM orders) AS member, 0 < ALL (SELECT id FROM orders) AS positive"
fmap (map (map snd)) result `shouldBe` Right [[VBool True, VBool True, VBool True]]
scanTimes "orders" scans `shouldBe` 1
fst (countedRun "SELECT EXISTS (SELECT id FROM orders), (SELECT id FROM orders)")
`shouldBe` Left "scalar subquery returned more than one row"
it "shares empty results without confusing NULL and existence" $ do
let (result, scans) = countedRun "SELECT (SELECT id FROM orders WHERE id < 0) AS empty, EXISTS (SELECT id FROM orders WHERE id < 0) AS found, 1 IN (SELECT id FROM orders WHERE id < 0) AS member"
fmap (map (map snd)) result `shouldBe` Right [[VNull, VBool False, VBool False]]
scanTimes "orders" scans `shouldBe` 1
it "materializes repeated CTE bodies before applying source aliases" $ do
let query = "WITH t AS (SELECT id, name FROM users) SELECT a.name, b.name FROM t a JOIN t b ON a.id = b.id ORDER BY a.name"
(result, scans) = countedRun query
fmap (map (map snd)) result `shouldBe` Right [[VStr "Alice", VStr "Alice"], [VStr "Bob", VStr "Bob"], [VStr "Carol", VStr "Carol"]]
scanTimes "users" scans `shouldBe` 1
sameResultAsUnoptimized query
it "materializes repeated derived bodies and preserves duplicate rows" $ do
let query = "SELECT a.user_id, b.user_id FROM (SELECT user_id FROM orders) a JOIN (SELECT user_id FROM orders) b ON a.user_id = b.user_id"
(result, scans) = countedRun query
fmap (map (map snd)) result `shouldBe` Right [[VInt 1, VInt 1], [VInt 1, VInt 1], [VInt 2, VInt 2], [VInt 1, VInt 1], [VInt 1, VInt 1]]
scanTimes "orders" scans `shouldBe` 1
sameResultAsUnoptimized query
it "does not materialize unused subqueries or hide execution errors" $ do
let (result, scans) = countedRun "SELECT (SELECT 1 / 0 FROM orders) FROM users WHERE id < 0"
result `shouldBe` Right []
scanTimes "orders" scans `shouldBe` 0
fst (countedRun "WITH t AS (SELECT 1 / 0 AS bad FROM users) SELECT a.bad FROM t a JOIN t b ON a.bad = b.bad")
`shouldBe` Left "division by zero"
it "clears materialization between executions of the same bound query" $ do
case parseStatement "SELECT (SELECT COUNT(*) FROM orders) AS n" >>= Bound.bindQuery testDB of
Left err -> expectationFailure err
Right bound -> do
-- | 两次执行之间修改来源数据
let action = do
first <- Bound.executeQueryM bound
changed <- replaceAll "orders" []
second <- Bound.executeQueryM bound
pure (first, changed, second)
case runCounting action testDB of
Left err -> expectationFailure err
Right ((first, changed, second), _, scans) -> do
first `shouldBe` Right [[("n", VInt 3)]]
changed `shouldBe` Right ()
second `shouldBe` Right [[("n", VInt 0)]]
scanTimes "orders" scans `shouldBe` 2
it "keeps enclosing rows distinct for raw name-based subquery calls" $ do
let statement = Select [("value", Col "id")] FromUnit Nothing [] Nothing [] Nothing
plan = Compute [("value", ScalarSub (Subquery statement ["id"]))] (Scan Nothing "users" Nothing)
evalRelOp testDB plan `shouldBe` Right [[("value", VInt 1)], [("value", VInt 2)], [("value", VInt 3)]]
it "executes repeated CTE references through real storage" $
withTestSession $ \srv -> withServerEnv srv $ do
-- | 在实际存储执行数据和查询语句
let query input = case parseStatement input of
Left err -> pure (Left err)
Right statement -> runIPCStorage (runStatementM statement)
query "CREATE TABLE materialized (id int, amount int)" `shouldReturn` Right []
query "INSERT INTO materialized (id, amount) VALUES (1, 10), (2, 20)" `shouldReturn` Right []
query "WITH t AS (SELECT id, amount FROM materialized) SELECT a.id, a.amount + b.amount AS total FROM t a JOIN t b ON a.id = b.id ORDER BY a.id"
`shouldReturn` Right [[("a.id", VInt 1), ("total", VInt 20)], [("a.id", VInt 2), ("total", VInt 40)]]
describe "ChuSQL.Core.Engine (聚合与 GROUP BY)" $ do
-- sql：在默认库上跑 SQL 取结果行
let sql input = parseStatement input >>= rowsOf . runStatement testDB
@@ -1831,6 +2109,85 @@ main = hspec $ do
evalRelOp testDB plan `shouldBe` Right [[("user_id", VInt 1), ("COUNT(*)", VInt 2)], [("user_id", VInt 2), ("COUNT(*)", VInt 1)]]
evalRelOp testDB (optimize testDB plan) `shouldBe` evalRelOp testDB plan
describe "HAVING and expression ordering" $ do
-- | 在固定测试库执行查询
let sql text = rowsOf (parseStatement text >>= runStatement testDB)
it "filters groups using aggregates absent from the projection" $ do
sql "SELECT user_id FROM orders GROUP BY user_id HAVING COUNT(*) > 1 ORDER BY SUM(id) DESC"
`shouldBe` Right [[("user_id", VInt 1)]]
it "creates one implicit group, including an empty input" $ do
sql "SELECT 7 AS n FROM users HAVING COUNT(*) = 3" `shouldBe` Right [[("n", VInt 7)]]
sql "SELECT COUNT(*) AS n FROM users WHERE id < 0 HAVING COUNT(*) = 0"
`shouldBe` Right [[("n", VInt 0)]]
sql "SELECT 7 AS n FROM users WHERE id < 0 HAVING TRUE" `shouldBe` Right [[("n", VInt 7)]]
sql "SELECT COUNT(*) FROM users HAVING NULL" `shouldBe` Right []
sql "SELECT COUNT(*) FROM users HAVING FALSE" `shouldBe` Right []
it "checks grouping, boolean predicates and nested aggregates" $ do
mapM_ (\query -> sql query `shouldSatisfy` isLeft)
[ "SELECT name FROM users HAVING TRUE"
, "SELECT COUNT(*) FROM users HAVING age > 20"
, "SELECT COUNT(*) FROM users HAVING 1"
, "SELECT COUNT(*) FROM users HAVING SUM(COUNT(*)) > 0"
, "SELECT name FROM users ORDER BY COUNT(*)"
, "SELECT COUNT(*) AS n FROM users HAVING n > 0"
]
it "rewrites aggregate calls inside IN predicates" $ do
sql "SELECT user_id FROM orders GROUP BY user_id HAVING COUNT(*) IN (1, 2) ORDER BY COUNT(*) DESC"
`shouldBe` Right [[("user_id", VInt 1)], [("user_id", VInt 2)]]
sql "SELECT COUNT(*) AS n FROM users HAVING 3 IN (COUNT(*), SUM(age))"
`shouldBe` Right [[("n", VInt 3)]]
it "combines expressions, aliases and output positions" $ do
sql "SELECT name AS n, age FROM users ORDER BY age - 25, 1 DESC LIMIT 2"
`shouldBe` Right [[("n", VStr "Bob"), ("age", VInt 17)], [("n", VStr "Alice"), ("age", VInt 25)]]
sql "SELECT name FROM users ORDER BY length(name), name DESC"
`shouldBe` Right [[("name", VStr "Bob")], [("name", VStr "Carol")], [("name", VStr "Alice")]]
sql "SELECT name AS n FROM users ORDER BY n + 1" `shouldSatisfy` isLeft
it "keeps projection errors deferred until after LIMIT" $ do
sql "SELECT 1 / (age - 17) AS n FROM users ORDER BY age + 0 DESC LIMIT 1"
`shouldSatisfy` either (const False) ((== 1) . length)
sql "SELECT name FROM users ORDER BY 1 / (age - 17) LIMIT 0"
`shouldBe` Left "division by zero"
it "sorts DISTINCT only by expressions present in its output" $ do
sql "SELECT DISTINCT age + 1 AS n FROM users ORDER BY age + 1 DESC LIMIT 1"
`shouldBe` Right [[("n", VInt 31)]]
sql "SELECT DISTINCT name FROM users ORDER BY age + 1" `shouldSatisfy` isLeft
it "expands CTEs inside HAVING and ORDER BY subqueries" $ do
sql "WITH x AS (SELECT id FROM users) SELECT name FROM users ORDER BY (SELECT MAX(id) FROM x) - age"
`shouldBe` Right [[("name", VStr "Carol")], [("name", VStr "Alice")], [("name", VStr "Bob")]]
sql "WITH x AS (SELECT id FROM users) SELECT COUNT(*) AS n FROM users HAVING COUNT(*) = (SELECT COUNT(*) FROM x)"
`shouldBe` Right [[("n", VInt 3)]]
it "binds correlated HAVING and ordering to their enclosing rows" $ do
sql "SELECT u.id FROM users u WHERE EXISTS (SELECT COUNT(*) FROM orders o HAVING COUNT(*) >= u.id) ORDER BY u.id"
`shouldBe` Right [[("u.id", VInt 1)], [("u.id", VInt 2)], [("u.id", VInt 3)]]
sql "SELECT u.name FROM users u ORDER BY (SELECT COUNT(*) FROM orders o WHERE o.user_id = u.id) DESC, u.name"
`shouldBe` Right [[("u.name", VStr "Alice")], [("u.name", VStr "Bob")], [("u.name", VStr "Carol")]]
it "preserves semantics through optimizer rewrites" $ do
mapM_ sameResultAsUnoptimized
[ "SELECT user_id FROM orders GROUP BY user_id HAVING COUNT(*) > 1 ORDER BY SUM(id) + 1 LIMIT 1"
, "SELECT name FROM users ORDER BY age + 1 DESC, name LIMIT 2"
, "SELECT DISTINCT age + 1 FROM users ORDER BY age + 1"
]
it "executes grouped HAVING and expression sorting through storage IPC" $
withTestSession $ \srv -> withServerEnv srv $ do
-- | 通过真实存储执行 SQL
let query text = case parseStatement text of
Left err -> pure (Left err)
Right statement -> runIPCStorage (runStatementM statement)
query "CREATE TABLE grouped (agg1 int, amount int)" `shouldReturn` Right []
query "INSERT INTO grouped (agg1, amount) VALUES (1, 10), (1, 20), (2, 5)" `shouldReturn` Right []
query "SELECT agg1, SUM(amount) AS total FROM grouped GROUP BY agg1 HAVING SUM(amount) > 5 ORDER BY SUM(amount) + agg1 DESC LIMIT 1"
`shouldReturn` Right [[("agg1", VInt 1), ("total", VInt 30)]]
describe "ChuSQL end-to-end" $ do
it "parses and executes a complex query" $ do
rowsOf
@@ -1959,7 +2316,8 @@ main = hspec $ do
`shouldBe` Right (Just (LitBool False))
it "picks the index only when the statistics make it cheaper" $ do
let stat rows distinct indexes = TableMeta rows [(c, d, False) | (c, d) <- distinct] [] indexes
let stat rows distinct
= TableMeta rows [(c, d, False) | (c, d) <- distinct] []
dbWith m = [("users", Table "users" [("id", TInt), ("name", TStr)] [] (Just m) Nothing Nothing)]
unknown = [("users", Table "users" [("id", TInt), ("name", TStr)] [] Nothing Nothing Nothing)]
point = Filter (Eq (Col "id") (LitInt 1)) (Scan Nothing "users" Nothing)
@@ -2282,7 +2640,7 @@ main = hspec $ do
err `shouldContain` "config file not found"
err `shouldContain` path
Right handle -> closeStorage handle >> expectationFailure "expected missing config error"
poolRun pool (map checkOpen paths) >> pure ()
void (poolRun pool (map checkOpen paths))
it "returns FFI input errors from workers and remains usable" $ do
withTestSession $ \srv -> do
@@ -2293,10 +2651,48 @@ main = hspec $ do
requested `shouldSatisfy` either (isInfixOf "request is not valid UTF-8") (const False)
maintained <- maintainStorage (dataDir srv ++ ".toml") (BS.pack [255])
maintained `shouldSatisfy` either (isInfixOf "invalid utf-8") (const False)
poolRun pool (replicate 16 checkErrors) >> pure ()
void (poolRun pool (replicate 16 checkErrors))
sendRawRequest (BSC.pack "{\"method\":\"ping\"}")
`shouldReturn` Right (BSC.pack "{\"status\":\"pong\"}")
it "executes bound writes and CHECKs through real storage" $ do
withTestSession $ \srv -> withServerEnv srv $ do
-- | 解析并通过真实存储执行写语句
let query source = case parseStatement source of
Left err -> expectationFailure err >> pure (Left err)
Right statement -> runIPCStorage (runStatementM statement)
query "CREATE DOMAIN quantity AS INT" `shouldReturn` Right []
query "CREATE TABLE bound_writes (qty quantity DEFAULT 2, id INT, name TEXT CHECK (length(name) > 1))"
`shouldReturn` Right []
query "INSERT INTO bound_writes (id, name) VALUES (1, 'abc'), (2, 'def')" `shouldReturn` Right []
rejectedInsert <- query "INSERT INTO bound_writes (id, qty, qty, name) VALUES (99, 1, 9, 'ok')"
rejectedInsert `shouldSatisfy` either (isInfixOf "INSERT: duplicate target column: qty") (const False)
query "SELECT id, qty FROM bound_writes" `shouldReturn` Right
[[("id", VInt 1), ("qty", VInt 2)], [("id", VInt 2), ("qty", VInt 2)]]
query "UPDATE bound_writes SET qty = qty + (SELECT MIN(id) FROM bound_writes) WHERE id = 1"
`shouldReturn` Right []
query "UPDATE bound_writes SET qty = qty + 1, qty = qty + id WHERE id = 1"
`shouldReturn` Right []
rejected <- query "UPDATE bound_writes SET qty = qty + 10, name = 'x' WHERE id = 1"
rejected `shouldSatisfy` either (isInfixOf "CHECK on name failed") (const False)
query "DELETE FROM bound_writes WHERE qty = 2" `shouldReturn` Right []
query "SELECT id, qty, name FROM bound_writes" `shouldReturn` Right
[[("id", VInt 1), ("qty", VInt 5), ("name", VStr "abc")]]
it "keeps enclosing scopes distinct through real storage" $ do
withTestSession $ \srv -> withServerEnv srv $ do
-- | 解析并通过真实存储执行相关查询
let query source = case parseStatement source of
Left err -> expectationFailure err >> pure (Left err)
Right statement -> runIPCStorage (runStatementM statement)
query "CREATE TABLE scope_far (id INT)" `shouldReturn` Right []
query "CREATE TABLE scope_near (id INT)" `shouldReturn` Right []
query "INSERT INTO scope_far (id) VALUES (1), (2)" `shouldReturn` Right []
query "INSERT INTO scope_near (id) VALUES (10), (11)" `shouldReturn` Right []
query "SELECT o.id, (SELECT (SELECT id) FROM scope_near n WHERE n.id = o.id + 9) AS nearest FROM scope_far o"
`shouldReturn` Right [[("o.id", VInt 1), ("nearest", VInt 10)]
, [("o.id", VInt 2), ("nearest", VInt 11)]]
it "persists runtime type identities and nested values across restart" $ do
withTestSession $ \srv -> do
-- | 解析并通过真实存储执行 SQL
@@ -2442,11 +2838,13 @@ main = hspec $ do
closeConnection
Right link <- localStorageLink (Just (dataDir srv ++ ".toml"))
setStorageLink link {slRequest = \payload -> do
if BSC.pack "schema_guard" `BS.isInfixOf` payload
then do
changed <- slRequest link (BSC.pack "{\"method\":\"replace_schema\",\"database\":\"ipctest\",\"table\":\"raced\",\"columns\":[{\"name\":\"id\",\"ty\":\"int\"},{\"name\":\"extra\",\"ty\":\"str\"}],\"rows\":[]}")
changed `shouldSatisfy` either (const False) (BS.isInfixOf (BSC.pack "ok"))
else pure ()
when (BSC.pack "schema_guard" `BS.isInfixOf` payload)
$ do changed <- slRequest
link
(BSC.pack
"{\"method\":\"replace_schema\",\"database\":\"ipctest\",\"table\":\"raced\",\"columns\":[{\"name\":\"id\",\"ty\":\"int\"},{\"name\":\"extra\",\"ty\":\"str\"}],\"rows\":[]}")
changed
`shouldSatisfy` either (const False) (BS.isInfixOf (BSC.pack "ok"))
slRequest link payload}
case parseStatement "SELECT id FROM raced" >>= Bound.bindQuery catalog of
Left err -> expectationFailure err
@@ -2454,6 +2852,74 @@ main = hspec $ do
result <- runIPCStorage (Bound.executeQueryM query)
result `shouldSatisfy` either (isInfixOf "bound query schema changed") (const False)
it "rejects restored-schema races at the actual INSERT UPDATE DELETE and ALTER write" $ do
mapM_ (\(method, sql) -> withTestSession $ \srv -> withServerEnv srv $ do
runIPCStorage (createTable "write_race" [("id", TInt), ("qty", TInt)]) `shouldReturn` Right ()
runIPCStorage (insert "write_race" [("id", VInt 1), ("qty", VInt 5)]) `shouldReturn` Right ()
closeConnection
Right link <- localStorageLink (Just (dataDir srv ++ ".toml"))
setStorageLink link {slRequest = \payload -> do
when (BSC.pack "schema_guard" `BS.isInfixOf` payload
&& BSC.pack ("\"method\":\"" ++ method ++ "\"") `BS.isInfixOf` payload) $ do
added <- slRequest link (BSC.pack "{\"method\":\"replace_schema\",\"database\":\"ipctest\",\"table\":\"write_race\",\"columns\":[{\"name\":\"id\",\"ty\":\"int\"},{\"name\":\"qty\",\"ty\":\"int\"},{\"name\":\"extra\",\"ty\":\"str\"}],\"rows\":[{\"id\":1,\"qty\":5,\"extra\":\"x\"}]}")
added `shouldSatisfy` either (const False) (BS.isInfixOf (BSC.pack "ok"))
restored <- slRequest link (BSC.pack "{\"method\":\"replace_schema\",\"database\":\"ipctest\",\"table\":\"write_race\",\"columns\":[{\"name\":\"id\",\"ty\":\"int\"},{\"name\":\"qty\",\"ty\":\"int\"}],\"rows\":[{\"id\":1,\"qty\":5}]}")
restored `shouldSatisfy` either (const False) (BS.isInfixOf (BSC.pack "ok"))
slRequest link payload}
case parseStatement sql of
Left err -> expectationFailure err
Right statement -> do
result <- runIPCStorage (runStatementM statement)
result `shouldSatisfy` either (isInfixOf "bound query schema changed") (const False)
runIPCStorage (scan "write_race") `shouldReturn` Right [[("id", VInt 1), ("qty", VInt 5)]])
[ ("insert_batch", "INSERT INTO write_race (id, qty) VALUES (2, 9)")
, ("replace_all", "UPDATE write_race SET qty = qty + 1")
, ("delete_keys", "DELETE FROM write_race WHERE id = 1")
, ("replace_schema", "ALTER TABLE write_race ADD COLUMN note TEXT")
]
it "rechecks cross-database subquery dependencies before publishing a write" $ do
withTestSession $ \srv -> withServerEnv srv $ do
runIPCStorage (createTable "write_target" [("id", TInt)]) `shouldReturn` Right ()
runIPCStorage (insert "write_target" [("id", VInt 1)]) `shouldReturn` Right ()
runIPCStorage (createDatabase "write_source") `shouldReturn` Right ()
runIPCStorage (createTable "write_source.source" [("id", TInt)]) `shouldReturn` Right ()
runIPCStorage (insert "write_source.source" [("id", VInt 2)]) `shouldReturn` Right ()
closeConnection
Right link <- localStorageLink (Just (dataDir srv ++ ".toml"))
setStorageLink link {slRequest = \payload -> do
when (BSC.pack "schema_guard" `BS.isInfixOf` payload
&& BSC.pack "\"method\":\"replace_all\"" `BS.isInfixOf` payload) $ do
changed <- slRequest link (BSC.pack "{\"method\":\"replace_schema\",\"database\":\"write_source\",\"table\":\"source\",\"columns\":[{\"name\":\"id\",\"ty\":\"bigint\"}],\"rows\":[{\"id\":2}]}")
changed `shouldSatisfy` either (const False) (BS.isInfixOf (BSC.pack "ok"))
slRequest link payload}
case parseStatement "UPDATE ipctest.write_target SET id = (SELECT id FROM write_source.source)" of
Left err -> expectationFailure err
Right statement -> do
result <- runIPCStorageIn (runStatementM statement) (envForDatabase Nothing)
result `shouldSatisfy` either (isInfixOf "bound query schema changed") (const False)
runIPCStorage (scan "write_target") `shouldReturn` Right [[("id", VInt 1)]]
it "guards newly referenced DOMAIN definitions during ALTER" $ do
withTestSession $ \srv -> withServerEnv srv $ do
runIPCStorage (runStatementM (CreateDomain "new_quantity" CInt)) `shouldReturn` Right []
runIPCStorage (createTable "domain_target" [("id", TInt)]) `shouldReturn` Right ()
closeConnection
Right link <- localStorageLink (Just (dataDir srv ++ ".toml"))
setStorageLink link {slRequest = \payload -> do
when (BSC.pack "schema_guard" `BS.isInfixOf` payload
&& BSC.pack "\"method\":\"replace_schema\"" `BS.isInfixOf` payload) $ do
changed <- slRequest link (BSC.pack "{\"method\":\"replace_schema\",\"database\":\"ipctest\",\"table\":\"__system_domain_new_quantity\",\"columns\":[{\"name\":\"base\",\"ty\":\"bigint\"}],\"rows\":[]}")
changed `shouldSatisfy` either (const False) (BS.isInfixOf (BSC.pack "ok"))
slRequest link payload}
case parseStatement "ALTER TABLE domain_target ADD COLUMN qty new_quantity" of
Left err -> expectationFailure err
Right statement -> do
result <- runIPCStorage (runStatementM statement)
result `shouldSatisfy` either (isInfixOf "bound query schema changed") (const False)
Right catalog <- runIPCStorage schema
fmap (map fst . tableCols) (lookup "domain_target" catalog) `shouldBe` Just ["id"]
it "doListTables returns the tables that exist" $ do
withTestSession $ \srv -> withServerEnv srv $ do
runIPCStorage (insert "t1" [("id", VInt 1)]) `shouldReturn` Right ()
@@ -2524,6 +2990,7 @@ main = hspec $ do
, selectFrom = FromTable Nothing "ipc_idx"
, selectWhere = Just (Eq (Col "id") (LitInt 42))
, selectGroupBy = []
, selectHaving = Nothing
, selectOrderBy = []
, selectLimit = Nothing
}
@@ -2840,6 +3307,31 @@ main = hspec $ do
`shouldSatisfy` either (isInfixOf "CHECK") (const False)
vals (step db "INSERT INTO ck (age) VALUES (5)") "SELECT age FROM ck" `shouldBe` Right [[VInt 5]]
it "validates CHECK types and row-only expressions before creating an empty table" $ do
mapM_ (\ddl -> (parseStatement ddl >>= runStatement testDB) `shouldSatisfy` isLeft)
[ "CREATE TABLE invalid_ck (age int CHECK (age + 1))"
, "CREATE TABLE invalid_ck (age int CHECK (length(age) > 0))"
, "CREATE TABLE invalid_ck (age int CHECK (missing(age) > 0))"
, "CREATE TABLE invalid_ck (age int CHECK (COUNT(*) > 0))"
, "CREATE TABLE invalid_ck (age int CHECK (EXISTS (SELECT 1)))"
, "CREATE TABLE invalid_ck (age int CHECK (unknown > 0))"
]
it "validates added CHECKs against existing and new column types" $ do
let db = withTable "CREATE TABLE add_ck (name text)"
run input = parseStatement input >>= runStatement db
run "ALTER TABLE add_ck ADD COLUMN age int CHECK (length(age) > 0)"
`shouldSatisfy` isLeft
run "ALTER TABLE add_ck ADD COLUMN age int CHECK (name > 0)"
`shouldSatisfy` isLeft
case run "ALTER TABLE add_ck ADD COLUMN age int CHECK (age > length(name))" of
Left err -> expectationFailure err
Right (updated, _) -> do
vals (step updated "INSERT INTO add_ck (name, age) VALUES ('ab', 3)") "SELECT age FROM add_ck"
`shouldBe` Right [[VInt 3]]
(parseStatement "INSERT INTO add_ck (name, age) VALUES ('ab', 1)" >>= runStatement updated)
`shouldSatisfy` either (isInfixOf "CHECK") (const False)
describe "ChuSQL.Core.Engine (ALTER TABLE)" $ do
-- vals：在给定库上跑 SQL 只取值
let vals db input = fmap (map (map snd)) (parseStatement input >>= rowsOf . runStatement db)
@@ -2876,6 +3368,27 @@ main = hspec $ do
let texty = step (withTable "CREATE TABLE ty2 (name str)") "INSERT INTO ty2 (name) VALUES ('x')"
run texty "ALTER TABLE ty2 ALTER COLUMN name TYPE int" `shouldSatisfy` isLeft
it "rejects structural changes that invalidate CHECKs even on empty tables" $ do
let empty = withTable "CREATE TABLE checked_ddl (name text, qty int CHECK (qty > length(name)))"
filled = step empty "INSERT INTO checked_ddl (name, qty) VALUES ('ab', 3)"
mapM_ (\(db, expected) -> do
run db "ALTER TABLE checked_ddl DROP COLUMN name" `shouldSatisfy` isLeft
run db "ALTER TABLE checked_ddl RENAME COLUMN name TO label" `shouldSatisfy` isLeft
run db "ALTER TABLE checked_ddl ALTER COLUMN name TYPE int" `shouldSatisfy` isLeft
run db "ALTER TABLE checked_ddl ALTER COLUMN qty TYPE text" `shouldSatisfy` isLeft
vals db "SELECT name, qty FROM checked_ddl"
`shouldBe` Right expected) [(empty, []), (filled, [[VStr "ab", VInt 3]])]
case run filled "ALTER TABLE checked_ddl DROP COLUMN qty" of
Left err -> expectationFailure err
Right (remaining, _) -> vals remaining "SELECT name FROM checked_ddl" `shouldBe` Right [[VStr "ab"]]
run filled "ALTER TABLE checked_ddl ALTER COLUMN qty TYPE bigint" `shouldSatisfy` isRight
it "rejects type changes that invalidate defaults or key capabilities" $ do
let defaults = withTable "CREATE TABLE default_ddl (name text DEFAULT 'hello')"
keys = withTable "CREATE TABLE key_ddl (qty int UNIQUE)"
run defaults "ALTER TABLE default_ddl ALTER COLUMN name TYPE int" `shouldSatisfy` isLeft
run keys "ALTER TABLE key_ddl ALTER COLUMN qty TYPE LIST<Int>" `shouldSatisfy` isLeft
it "ALTER COLUMN SET/DROP DEFAULT changes what omitted columns get" $ do
let base = withTable "CREATE TABLE df (id int, tag str)"
withDefault = step base "ALTER TABLE df ALTER COLUMN tag SET DEFAULT 'y'"
@@ -3277,6 +3790,8 @@ instance Monad ProbeStorage where
instance MonadStorage ProbeStorage where
-- \| 测试视图不支持并发结构变更
withSchemaGuard _ action = action
-- | 测试视图不支持并发结构变更
withWriteSchemaGuard _ action = action
scan table = ProbeStorage $ \probe -> do
recordCall probe ("scan:" ++ table)
pure (Right (tableRows (probeTable probe)))
@@ -3324,7 +3839,7 @@ filterPushedIntoLeft _ = False
-- | 左侧子树里出现了下推下来的谓词（点查 / 范围 / 过滤）
pushedIntoLeft :: RelOp -> Bool
pushedIntoLeft (Filter _ _) = True
pushedIntoLeft (Range _ _ _ _ _) = True
pushedIntoLeft (Range {}) = True
pushedIntoLeft (Project _ x) = pushedIntoLeft x
pushedIntoLeft _ = False
@@ -3389,9 +3904,9 @@ firstFilterCond (Limit _ x) = firstFilterCond x
firstFilterCond (Join _ l r _) = case firstFilterCond l of
Just p -> Just p
Nothing -> firstFilterCond r
firstFilterCond (Scan _ _ _) = Nothing
firstFilterCond (Lookup _ _ _ _) = Nothing
firstFilterCond (Range _ _ _ _ _) = Nothing
firstFilterCond (Scan {}) = Nothing
firstFilterCond (Lookup {}) = Nothing
firstFilterCond (Range {}) = Nothing
firstFilterCond (Derived _ x) = firstFilterCond x
-- | 判断计划里是否还有过滤节点
@@ -3407,9 +3922,9 @@ anyFilter (Sort _ x) = anyFilter x
anyFilter (BoundSort _ x) = anyFilter x
anyFilter (Limit _ x) = anyFilter x
anyFilter (Join _ l r _) = anyFilter l || anyFilter r
anyFilter (Scan _ _ _) = False
anyFilter (Lookup _ _ _ _) = False
anyFilter (Range _ _ _ _ _) = False
anyFilter (Scan {}) = False
anyFilter (Lookup {}) = False
anyFilter (Range {}) = False
anyFilter (Derived _ x) = anyFilter x
-- | 去掉计划里的投影节点
@@ -3519,6 +4034,8 @@ memReplaceSchema = replaceSchema
instance MonadStorage Counting where
-- \| 纯测试状态在求值期间保持稳定
withSchemaGuard _ action = action
-- | 纯测试状态不受外部结构变更影响
withWriteSchemaGuard _ action = action
-- \| 扫描：记一笔表名，其余走内存实现
scan t = Counting $ \db -> case runMemoryStorage (memScan t) db of
Left e -> Left e
chusql-core/model/src/ChuSQL/Core/Protocol.hs
+70 -25
View File
@@ -15,16 +15,17 @@ module ChuSQL.Core.Protocol (
queryResultJson,
) where
import ChuSQL.Core.Model (Histogram (..), Row, Value (..), TableIdentity (..))
import ChuSQL.Core.Runtime (builtinTypes, runtimeToJSON, runtimeFromJSON)
import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.!=), (.=))
import ChuSQL.Core.Model (Histogram (..), Row, TableIdentity (..), Value (..))
import ChuSQL.Core.Runtime (builtinTypes, runtimeFromJSON, runtimeToJSON)
import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.!=), (.:), (.:?), (.=))
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import Data.Aeson.Types (Parser)
import Data.Scientific (floatingOrInteger, fromFloatDigits, base10Exponent)
import qualified Data.Text as T
import Data.Char (isDigit)
import Data.Scientific (base10Exponent, floatingOrInteger, fromFloatDigits)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Word (Word64)
import Text.Read (readMaybe)
@@ -97,6 +98,7 @@ data Request
| ReqLookupByColumn String String Value
| ReqRangeByIndex String String (Maybe (Value, Bool)) (Maybe (Value, Bool))
| ReqDescribeTable String
| ReqValidateWrite String
| ReqCreateTable String [SchemaColumn]
| ReqDropTable String
| ReqCreateIndex String String
@@ -136,6 +138,7 @@ instance ToJSON TxnOp where
-- | 请求编码成 JSON
instance ToJSON Request where
toJSON (ReqValidateWrite t) = object ["method" .= ("validate_write" :: T.Text), "table" .= t]
toJSON (ReqDatabase method name) = object ["method" .= method, "database" .= name]
toJSON ReqAllCatalog = object ["method" .= ("all_catalogs" :: T.Text)]
toJSON (ReqInDatabase name req) = case toJSON req of
@@ -145,8 +148,16 @@ instance ToJSON Request where
toJSON ReqAccountsList = object ["method" .= ("accounts_list" :: T.Text)]
toJSON (ReqIdentityInitialize u) = object ["method" .= ("identity_initialize" :: T.Text), "administrator" .= u]
toJSON (ReqRoleCreate u) = object ["method" .= ("role_create" :: T.Text), "user" .= u]
toJSON (ReqIdentityAlter u login super enabled manager sudo) = object ["method" .= ("identity_alter" :: T.Text), "user" .= u,
"can_login" .= login, "is_superuser" .= super, "enabled" .= enabled, "system_catalog_manager" .= manager, "allow_sudo_auth" .= sudo]
toJSON (ReqIdentityAlter u login super enabled manager sudo) =
object
[ "method" .= ("identity_alter" :: T.Text)
, "user" .= u
, "can_login" .= login
, "is_superuser" .= super
, "enabled" .= enabled
, "system_catalog_manager" .= manager
, "allow_sudo_auth" .= sudo
]
toJSON (ReqAccountCreate u h) = object ["method" .= ("account_create" :: T.Text), "user" .= u, "password_hash" .= h]
toJSON (ReqAccountReset u h) = object ["method" .= ("account_reset" :: T.Text), "user" .= u, "password_hash" .= h]
toJSON (ReqAccountLogin u at) = object ["method" .= ("account_login" :: T.Text), "user" .= u, "at" .= at]
@@ -286,9 +297,12 @@ instance ToJSON TableInfo where
-- | 解码精确且有界的对象编号
parseObjectNumber :: A.Value -> Parser Word64
parseObjectNumber (A.String value)
| not (T.null value), T.length value <= 20, T.all (\c -> c >= '0' && c <= '9') value
, Just number <- (readMaybe (T.unpack value) :: Maybe Integer)
, number <= toInteger (maxBound :: Word64) = pure (fromInteger number)
| not (T.null value)
, T.length value <= 20
, T.all isDigit value
, Just number <- readMaybe (T.unpack value) :: Maybe Integer
, number <= toInteger (maxBound :: Word64) =
pure (fromInteger number)
parseObjectNumber value@(A.Number number)
| base10Exponent number >= -20, base10Exponent number <= 20 = A.parseJSON value
parseObjectNumber _ = fail "invalid table object identity"
@@ -307,7 +321,7 @@ instance FromJSON TableInfo where
count <- o .: "row_count"
indexes <- o .:? "indexes" .!= []
stats <- o .:? "stats" .!= []
indexColumns <- mapM (\v -> withObject "IndexWire" (.: "column") v) (indexes :: [A.Value])
indexColumns <- mapM (withObject "IndexWire" (.: "column")) (indexes :: [A.Value])
parsed <- mapM parseStat (stats :: [A.Value])
database <- o .:? "database_id" >>= traverse parseObjectNumber
tableId <- o .:? "object_id" >>= traverse parseObjectNumber
@@ -319,8 +333,17 @@ instance FromJSON TableInfo where
_ -> fail ("incomplete table object identity: " ++ show (database, tableId))
let parsedStats = [(name, distinct, capped) | (name, distinct, capped, _) <- parsed]
parsedHistograms = [(name, h) | (name, _, _, Just h) <- parsed]
pure (TableInfo table columns count indexColumns parsedStats parsedHistograms identity
(version >>= \v -> if v == 0 then Nothing else Just v))
pure
( TableInfo
table
columns
count
indexColumns
parsedStats
parsedHistograms
identity
(version >>= \v -> if v == 0 then Nothing else Just v)
)
where
parseStat = withObject "ColumnStat" $ \o -> do
name <- o .: "name"
@@ -344,7 +367,8 @@ data Account = Account
, accountEnabled :: Bool
, accountSystemCatalogManager :: Bool
, accountAllowSudoAuth :: Bool
} deriving (Eq)
}
deriving (Eq)
-- | 账号的展示：只露账号名与版本号
instance Show Account where
@@ -352,17 +376,36 @@ instance Show Account where
-- | JSON 解回账号
instance FromJSON Account where
parseJSON = withObject "Account" $ \o -> Account <$> o .: "id" <*> o .: "user"
<*> o .: "password_hash" <*> o .: "revision"
<*> o .:? "registered_at" .!= "" <*> o .:? "last_login_at"
<*> o .:? "can_login" .!= True <*> o .:? "is_superuser" .!= False <*> o .:? "enabled" .!= True <*> o .:? "system_catalog_manager" .!= False <*> o .:? "allow_sudo_auth" .!= False
parseJSON = withObject "Account" $ \o ->
Account
<$> o .: "id"
<*> o .: "user"
<*> o .: "password_hash"
<*> o .: "revision"
<*> o .:? "registered_at" .!= ""
<*> o .:? "last_login_at"
<*> o .:? "can_login" .!= True
<*> o .:? "is_superuser" .!= False
<*> o .:? "enabled" .!= True
<*> o .:? "system_catalog_manager" .!= False
<*> o .:? "allow_sudo_auth" .!= False
-- | 账号编码成 JSON
instance ToJSON Account where
toJSON a = object ["id" .= accountId a, "user" .= accountUser a,
"password_hash" .= accountHash a, "revision" .= accountRevision a,
"registered_at" .= accountRegisteredAt a, "last_login_at" .= accountLastLoginAt a,
"can_login" .= accountCanLogin a, "is_superuser" .= accountIsSuperuser a, "enabled" .= accountEnabled a, "system_catalog_manager" .= accountSystemCatalogManager a, "allow_sudo_auth" .= accountAllowSudoAuth a]
toJSON a =
object
[ "id" .= accountId a
, "user" .= accountUser a
, "password_hash" .= accountHash a
, "revision" .= accountRevision a
, "registered_at" .= accountRegisteredAt a
, "last_login_at" .= accountLastLoginAt a
, "can_login" .= accountCanLogin a
, "is_superuser" .= accountIsSuperuser a
, "enabled" .= accountEnabled a
, "system_catalog_manager" .= accountSystemCatalogManager a
, "allow_sudo_auth" .= accountAllowSudoAuth a
]
-- | 存储层响应
data Response
@@ -413,7 +456,8 @@ valueFromJSON (A.Number n) =
valueFromJSON (A.String s) = pure (VStr (T.unpack s))
valueFromJSON (A.Bool b) = pure (VBool b)
valueFromJSON (A.Object fields)
| KM.size fields == 1, Just payload <- KM.lookup "__chusql_runtime_v1" fields =
| KM.size fields == 1
, Just payload <- KM.lookup "__chusql_runtime_v1" fields =
either fail (pure . uncurry VRuntime) (runtimeFromJSON builtinTypes payload)
valueFromJSON _ = fail "unsupported value type"
@@ -426,7 +470,7 @@ rowToJSON r =
rowFromJSON :: A.Value -> Parser Row
rowFromJSON (A.Object o) = mapM toPair (KM.toList o)
where
-- | 键值对解成一个字段
-- \| 键值对解成一个字段
toPair (k, v) = do
val <- valueFromJSON v
pure (K.toString k, val)
@@ -447,7 +491,8 @@ instance FromJSON QueryResult where
parseJSON = withObject "QueryResult" $ \o -> do
cols <- o .: "columns"
rows <- o .: "rows"
QueryResult cols <$> mapM (mapM valueFromJSON) rows
QueryResult cols
<$> mapM (mapM valueFromJSON) rows
<*> o .:? "rowCount" .!= 0
<*> o .:? "truncated" .!= False
<*> o .:? "database"
chusql-core/model/src/ChuSQL/Core/Runtime.hs
+4 -3
View File
@@ -6,6 +6,7 @@ module ChuSQL.Core.Runtime
, validateValue, encodeValue, decodeValue, encodeType, decodeType, runtimeToJSON, runtimeFromJSON
) where
import Control.Monad (zipWithM, zipWithM_)
import Data.Aeson (Value (..), eitherDecode, encode)
import Data.Aeson.Types (Parser, parseEither)
import qualified Data.ByteString.Lazy as BS
@@ -115,7 +116,7 @@ parseTypeExpr source = case P.readP_to_S (P.skipSpaces *> expression <* P.skipSp
P.<++ (tupleType <$> between "(" ")" (P.sepBy expression (symbol ",")))
-- | 解析具有名称边界的类型关键字
token word = do
_ <- mapM character word
mapM_ character word
rest <- P.look
case rest of
c : _ | isAlphaNum c || c == '_' -> P.pfail
@@ -187,7 +188,7 @@ validatePhysical (Sequence child) (RList values) = mapM_ (validatePhysical child
validatePhysical (Optional _) (RMaybe Nothing) = Right ()
validatePhysical (Optional child) (RMaybe (Just value)) = validatePhysical child value
validatePhysical (Product fields) (RTuple values)
| length fields == length values = sequence_ (zipWith validatePhysical fields values)
| length fields == length values = zipWithM_ validatePhysical fields values
validatePhysical physical _ = Left ("value does not fit physical type: " ++ show physical)
-- | 编码带版本与类型身份的值
@@ -289,5 +290,5 @@ parseValue (Optional child) (Array values) = case V.toList values of
[value] -> RMaybe . Just <$> parseValue child value
_ -> fail "invalid optional value"
parseValue (Product fields) (Array values)
| length fields == V.length values = RTuple <$> sequence (zipWith parseValue fields (V.toList values))
| length fields == V.length values = RTuple <$> zipWithM parseValue fields (V.toList values)
parseValue _ _ = fail "invalid physical value"
chusql-core/storage/src/protocol.rs
+2 -1
View File
@@ -122,6 +122,7 @@ pub enum Request {
#[serde(default)]
columns: Option<Vec<String>>,
},
ValidateWrite { table: String },
/// 分片扫描：第 shard 片只读总页数按 shards 均分后的那一段
ScanShard {
table: String,
@@ -231,7 +232,7 @@ impl Request {
/// 普通表操作的统一访问边界
pub fn table(&self) -> Option<&str> {
match self {
Self::Scan { table, .. } | Self::ScanShard { table, .. }
Self::Scan { table, .. } | Self::ScanShard { table, .. } | Self::ValidateWrite { table }
| Self::Insert { table, .. }
| Self::InsertBatch { table, .. } | Self::DeleteKeys { table, .. }
| Self::LookupByIndex { table, .. } | Self::ReplaceAll { table, .. }
chusql-core/storage/src/runtime.rs
+24 -8
View File
@@ -1335,7 +1335,7 @@ impl Server {
}
}
/// 持读门时复查绑定身份、版本和列定义
/// 持库门时复查绑定身份、版本和列定义
fn validate_bound_schema(&self, table: &str, expected: &crate::protocol::BoundSchema) -> std::io::Result<()> {
use std::io::Error;
if self.recovery_required.load(Ordering::Acquire) { return Err(Error::other("storage recovery required")); }
@@ -1378,6 +1378,7 @@ impl Server {
}
}
match req {
Request::ValidateWrite { .. } => Response::Ok,
Request::BootstrapTypes { types } => match self.bootstrap_types(types) {
Ok(rows) => Response::Rows { rows },
Err(e) => Response::Error { message: e.to_string() },
@@ -2190,10 +2191,17 @@ impl Databases {
fn request(&self, mut value: serde_json::Value) -> std::io::Result<Response> {
use std::io::Error;
let method = value.get("method").and_then(|v| v.as_str()).unwrap_or("").to_string();
if value.get("schema_guard").is_some()
&& !matches!(method.as_str(), "scan" | "scan_shard" | "lookup_by_index" | "range_by_index") {
return Err(Error::other("schema guard requires a table read"));
if method == "validate_write" && value.get("schema_guard").is_none() {
return Err(Error::other("write validation requires a schema guard"));
}
let guarded_write = if value.get("schema_guard").is_some() {
match method.as_str() {
"scan" | "scan_shard" | "lookup_by_index" | "range_by_index" | "validate_write" => false,
"insert" | "insert_batch" | "delete_keys" | "replace_all" | "replace_schema"
| "drop_column" | "drop_table" | "create_index" | "drop_index" => true,
_ => return Err(Error::other("schema guard requires a supported table operation")),
}
} else { false };
let name = match value.get("database") {
None => String::new(),
Some(serde_json::Value::String(s)) => s.to_ascii_lowercase(),
@@ -2328,7 +2336,6 @@ impl Databases {
let server = if global || selected == SYSTEM_DATABASE { Arc::clone(&self.system) }
else { Arc::clone(named.get(&selected).ok_or_else(|| Error::other("unknown database"))?) };
if let Some(bindings) = guard {
if !concurrent_read(&request) { return Err(Error::other("schema guard requires a table read")); }
let mut servers = std::collections::BTreeMap::from([(selected.clone(), Arc::clone(&server))]);
let mut dependencies = Vec::new();
for binding in bindings {
@@ -2341,11 +2348,19 @@ impl Databases {
dependencies.push((database, table.to_owned(), binding));
}
if !dependencies.iter().any(|(database, table, _)| database == &selected && Some(table.as_str()) == request.table()) {
return Err(Error::other("bound read table has no schema guard"));
return Err(Error::other("bound table operation has no schema guard"));
}
drop(named);
let _gates = servers.values().map(|server| server.gate.read()
.map_err(|_| Error::other("storage read gate poisoned"))).collect::<std::io::Result<Vec<_>>>()?;
// 全部库按名称取门；写入目标独占，其他依赖共享。
let _gates = servers.iter().map(|(database, server)| {
if guarded_write && database == &selected {
server.gate.write().map(|gate| (None, Some(gate)))
.map_err(|_| Error::other("storage write gate poisoned"))
} else {
server.gate.read().map(|gate| (Some(gate), None))
.map_err(|_| Error::other("storage read gate poisoned"))
}
}).collect::<std::io::Result<Vec<_>>>()?;
for (database, table, binding) in &dependencies {
servers[database].validate_bound_schema(table, binding)?;
}
@@ -2369,6 +2384,7 @@ fn concurrent_read(req: &Request) -> bool {
matches!(
req,
Request::Scan { .. }
| Request::ValidateWrite { .. }
| Request::ScanShard { .. }
| Request::LookupByIndex { .. }
| Request::RangeByIndex { .. }
chusql-core/storage/tests/runtime_test.rs
+88 -1
View File
@@ -198,7 +198,7 @@ fn bound_reads_recheck_dependencies_in_other_databases() -> Result<(), Box<dyn s
Ok(())
}
/// 每种读取都复查守卫，拒绝旧版本和写入
/// 每种读取都复查守卫，拒绝旧版本与库管理
#[test]
fn bound_reads_validate_dependencies_and_acknowledge_guards() -> Result<(), Box<dyn std::error::Error>> {
let (_server, _data) = start_server();
@@ -235,6 +235,93 @@ fn bound_reads_validate_dependencies_and_acknowledge_guards() -> Result<(), Box<
Ok(())
}
/// 写入持独占门并拒绝过期或不含目标的守卫
#[test]
fn bound_writes_validate_before_publishing() -> Result<(), Box<dyn std::error::Error>> {
let (_server, _data) = start_server();
let mut c = connect()?;
request_ok(&mut c, serde_json::json!({"method":"create_table","table":"writes","columns":[{"name":"id","ty":"int"}]}))?;
let catalog: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"list_catalog"}"#))?;
let mut binding = catalog["schemas"][0].clone();
binding["database_id"] = binding["database_id"].as_u64().unwrap().to_string().into();
binding["object_id"] = binding["object_id"].as_u64().unwrap().to_string().into();
let ready: serde_json::Value = serde_json::from_str(&send(&mut c, &serde_json::json!({"method":"validate_write","table":"writes","schema_guard":[binding]}).to_string()))?;
assert_eq!(ready["status"], "guarded");
assert_eq!(ready["response"]["status"], "ok");
let unguarded: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"validate_write","table":"writes"}"#))?;
assert_eq!(unguarded["status"], "error");
for mut request in [
serde_json::json!({"method":"insert","table":"writes","row":{"id":1}}),
serde_json::json!({"method":"insert_batch","table":"writes","rows":[{"id":2}]}),
serde_json::json!({"method":"replace_all","table":"writes","rows":[{"id":3}]}),
serde_json::json!({"method":"delete_keys","table":"writes","keys":[3]}),
] {
request["schema_guard"] = serde_json::json!([binding]);
let response: serde_json::Value = serde_json::from_str(&send(&mut c, &request.to_string()))?;
assert_eq!(response["status"], "guarded", "{response}");
assert_eq!(response["response"]["status"], "ok", "{response}");
}
let missing: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"insert","table":"writes","row":{"id":9},"schema_guard":[]}"#))?;
assert_eq!(missing["status"], "error");
request_ok(&mut c, serde_json::json!({"method":"drop_table","table":"writes"}))?;
request_ok(&mut c, serde_json::json!({"method":"create_table","table":"writes","columns":[{"name":"id","ty":"int"}]}))?;
let stale: serde_json::Value = serde_json::from_str(&send(&mut c, &serde_json::json!({"method":"insert","table":"writes","row":{"id":9},"schema_guard":[binding]}).to_string()))?;
assert_eq!(stale["status"], "error");
assert!(stale["message"].as_str().unwrap().contains("bound query object changed"));
let rows: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"scan","table":"writes"}"#))?;
assert_eq!(rows["rows"], serde_json::json!([]));
Ok(())
}
/// 互相依赖的跨库写入按统一顺序取门
#[test]
fn guarded_cross_database_writes_do_not_deadlock() -> Result<(), Box<dyn std::error::Error>> {
let (_server, _data) = start_server();
let mut c = connect()?;
for database in ["guard_a", "guard_b"] {
request_ok(&mut c, serde_json::json!({"method":"create_database","database":database}))?;
request_ok(&mut c, serde_json::json!({"method":"create_table","database":database,"table":"items","columns":[{"name":"id","ty":"int"}]}))?;
}
let catalog: serde_json::Value = serde_json::from_str(&send_raw(&mut c, r#"{"method":"all_catalogs"}"#))?;
let bindings: Vec<_> = catalog["schemas"].as_array().unwrap().iter().filter(|entry|
entry["table"] == "guard_a.items" || entry["table"] == "guard_b.items").map(|entry| {
let mut binding = entry.clone();
binding["database_id"] = binding["database_id"].as_u64().unwrap().to_string().into();
binding["object_id"] = binding["object_id"].as_u64().unwrap().to_string().into();
binding
}).collect();
assert_eq!(bindings.len(), 2);
let barrier = Arc::new(std::sync::Barrier::new(2));
let (sender, receiver) = std::sync::mpsc::channel();
let workers: Vec<_> = ["guard_a", "guard_b"].into_iter().map(|database| {
let storage = Arc::clone(&c.0);
let barrier = Arc::clone(&barrier);
let sender = sender.clone();
let bindings = bindings.clone();
std::thread::spawn(move || {
for id in 0..16 {
barrier.wait();
let response = storage.request_line(&serde_json::json!({
"method":"insert","database":database,"table":"items","row":{"id":id},"schema_guard":bindings
}).to_string());
sender.send(response).unwrap();
}
})
}).collect();
drop(sender);
for _ in 0..32 {
let response: serde_json::Value = serde_json::from_str(&receiver.recv_timeout(std::time::Duration::from_secs(10))?)?;
assert_eq!(response["status"], "guarded", "{response}");
assert_eq!(response["response"]["status"], "ok", "{response}");
}
for worker in workers { worker.join().unwrap(); }
for database in ["guard_a", "guard_b"] {
let rows: serde_json::Value = serde_json::from_str(&send_raw(&mut c, &serde_json::json!({"method":"scan","database":database,"table":"items"}).to_string()))?;
assert_eq!(rows["rows"].as_array().unwrap().len(), 16);
}
Ok(())
}
/// 描述与目录均透传精确版本字符串
#[test]
fn catalog_schema_versions_are_exact_and_validated() -> Result<(), Box<dyn std::error::Error>> {