推进
build / build (push) Blocked by required conditions
tests / tests (push) Waiting to run
tests / build (push) Waiting to run

This commit is contained in:
ChuNa7a committed 2026-10-15 22:21:57 +08:00
1 parent a45e33f94b
commit 4b8c9d9e78
67 files changed
+2493 -818

No files matched your search

+17 -3
View File
@@ -9,18 +9,32 @@
- 引擎按 AST → 语义检查 → RelOp → 优化 → 执行分层;语义与优化只读 schema,表存在性以 catalog 为准,索引由存储管理。
- JSON 使用显式稳定标签,FFI 仅提供 version / open / close / request / free / last_error;Web 不本地执行 SQL。
- 兼容值与类型语义集中于 Core.Model,运行时类型与版本化编码集中于 Core.Runtime,函数注册与绑定集中于 Engine.Runtime;旧运算符保留 Engine.Builtin,错误分类集中于 Engine.Error。
- 比较与赋值兼容性分开,整数与整值浮点统一相等和哈希,SQL NULL 比较走三值逻辑;CHECK 每语句解析一次。
- 比较与赋值兼容性分开,整数与整值浮点统一相等和哈希,SQL NULL 比较走三值逻辑;DML 的 CHECK 随写计划一次绑定,结构变更对新 schema 重新绑定。
- 写表达式和 CHECK 复用查询的列槽位绑定及行布局整理,避免按物理返回顺序取错值;UPDATE 在执行前按 schema 一次绑定目标槽位及列定义,按槽位校验、转换并覆盖单个值。目标不存在或歧义明确失败,不保留缺失类型时直接写入的兜底;保留逐项赋值、全部赋值后的 CHECK 及未命中行不求值。
- INSERT 目标清单拒绝重复列,合法目标在本次执行中一次映射到 VALUES 槽位;行构造保留 schema 顺序及原输入表达式求值顺序,默认值、自增、显式 NULL 和整批校验沿用既有语义。缺少已绑定输入值明确失败,不把它作为省略列处理。
- UPDATE 在全部行求值及 CHECK 成功后、调用存储写入前,复用 INSERT 的 NOT NULL 和 UNIQUE / PRIMARY KEY 检查;唯一性以最终整表结果判断,多个 NULL 不冲突。约束失败不发布部分行修改,事务快照保留并允许修正后继续提交。
- NOT NULL 和 UNIQUE / PRIMARY KEY 检查使用 schema 位置绑定列,缺值或位置不符明确失败,不用 mapMaybe 跳过缺列。INSERT 的已有行与经引擎重写 schema 的 ALTER 输入行在约束边界按原 schema 整理;保留列级错误顺序、NULL 去重规则和数值规范化比较。
- 写语句及已有表 DDL 使用仅保存 schema 的 BoundWrite,复用查询的依赖验证规则;收集目标、嵌套查询和传递 DOMAIN,新增列或改类型包含新声明 DOMAIN。先以只读 validate_write 确认写守卫能力,再发送实际写入;存储按库名排序取门,在目标库独占门及其他依赖共享门内复查后执行,不改变单次请求之间的数据隔离语义。
- BoundWrite 的 DML 动作保存 INSERT 输入槽位、UPDATE 赋值目标、DELETE 布局和预绑定 CHECK / 非空 / 唯一性约束,执行期不再重新解析或按名称绑定目标;自动编号仍从当前行集求起点,唯一性仍按最终行集校验,保持逐项赋值及未命中行不求值。
- CHECK 定义与执行共用布尔条件、函数和槽位绑定;聚合及子查询拒绝。结构变更先按新 schema 校验保留约束、默认值及键能力,空表不跳过;CHECK 文本未采用独立列身份,改名不自动重写,失效引用明确拒绝。
## 查询与优化
- 优化保持结果语义和可观察行序;相关外层列不能被投影删除,LEFT JOIN 只下推安全的左侧谓词。
- schema 携带行数、distinct、索引和直方图,缺统计时保守退回原计划。范围成本使用 16 桶等宽直方图,无直方图时按四分之一估算。
- 内连接从各起点贪心选序,仅在严格更省且行序不可观察处重排;统计不足或不安全条件时不改写。
- 表 / 列限定名在语义层按作用域及唯一候选解析,别名优先;会话将当前库限定 DDL 转为裸名,拒绝跨库目标,库名随请求传递。
- 相关子查询的语义列环境按词法层逐层查找,保留最近层的列及类型,不把不同外层并成一张表;本层歧义不向外回退。JOIN ON 和外部引用收集使用同一外层环境,来源检查失败明确传播。执行期仍使用既有扁平外层行布局。
- SELECT 在引擎入口直接进入 BoundQuery,避免规范化引用再次作为原始来源名解析;二段限定名被最近层同名来源遮蔽,该来源缺列时不回退。裸列仍按列可见性逐层查找,已解析引用的类型推导不重新解释来源遮蔽。
- 绑定后的子查询保存父布局中的局部或外层列槽位,取值与复用缓存键共享该绑定;诊断名称相同不表示位置相同。重绑定不把外层引用转为局部引用,布局失配和引用清单失配明确返回错误;原始关系执行 API 保留未绑定 Subquery 的名称入口。
- 已绑定列重绑定时保留仍匹配名称的有效位置,原位置不匹配仅允许唯一同名列重定位;歧义或负位置拒绝。外层槽位保留相对位置并更新局部宽度;独立列身份未实现,结构改写仍须在绑定前完成,不能凭同名槽位识别重排后的不同列。
- 相关子查询保留已解析外层限定名;求值绑定补回单表物理列的限定名,绑定去重与扫描投影使用同一列值,库限定引用仍校验 schema 来源。
- JOIN 条件按子查询外层引用的值缓存替换后的表达式;首次遇到行对时才求值,每个行对仍计算普通条件,保留输出顺序、空输入和错误返回。
- 半连接仅重写独立 IN 或单表唯一等值相关 EXISTS 的单独过滤谓词;键按两侧布局分别绑定,输出只保留原左行。独立 IN 沿用物化身份,NOT IN 感知右侧 NULL,反 EXISTS 保留空值键;大数混合比较退回原比较语义。复杂条件、可能报错的相关投影和相关聚合不重写,空左侧不执行右侧,保持完整右侧求值;空集 IN 为假、NOT IN 为真(含 NULL 左值),非空集合保持三值逻辑。
- 每次查询执行用独立状态物化成功行集,子查询按已解析定义和具名外层绑定值共享,原始名称调用保守包含整个外层行;派生表按执行子树和外层行缓存,先共享再应用别名。各消费者独立处理标量基数与三值逻辑,失败仍明确返回,保持既有求值顺序;不跨执行保留,也不提供整条查询快照或磁盘溢出。
- WAL 提交组落盘后、首次应用前进入 recovery_required;任何应用、刷盘或检查点错误都保持该状态,完整落盘与截断成功后才解除。
- FROM 是来源树,派生表必须带别名且不能引用外层,输出取裸列名,重名报错;未定型 NULL 保留独立查询推导类型,不能声明为存储类型。
- ORDER BY 优先匹配唯一输出别名,再查来源列;只将排序表达式提前计算,非排序投影保持在 LIMIT 后求值。CTE 列清单同步重命名内层排序别名。
- ORDER BY 输出序号保留到计划生成,不转换为诊断名称;普通查询选定对应投影表达式,DISTINCT 按去重结果槽位排序,重复别名不丢失位置。名称排序仍拒绝歧义,序号不作为相关子查询自由列,排序键遵守类型能力、分组及 LIMIT 求值时序。
- 派生表从透明算子与 schema 统计估算行数,缺统计或表达式可能报错时不重排;投影下推保留计算项,避免删除错误。内存存储提供实时行数及封顶去重统计。
- DECIMAL(p,s) 使用有限浮点、ties-to-even 舍入和舍入后溢出检查,要求 1 <= p <= 308、0 <= s <= p;Haskell 与 Rust 写入入口统一边界,日志记录规范化值。
- CTE 解析期展开为派生表,只接受 SELECT,不物化;多次引用重复执行,以减少实现改动面。
@@ -89,8 +103,8 @@
- resources/chusql.toml 入库并打包,UI 设置样本不入库、不进包,运行时按 resources、上一级 resources、工作目录候选查找。
- 预编译包优先,server / 存储必装,Web / CLI 可选;Windows zip、Linux/macOS tar.gz。包内模板也放 resources/,按确切产物名打包并拒绝未知工件。
- 本地解包安装不联网,管理员名同时传 bootstrap 和 server;安装冒烟隔离配置并恢复用户 PATH,卸载可保留数据 / 配置。
- 门禁先刷新 release cdylib,再并行 Rust、串行 Haskell、注释三条车道;Web 先刷新依赖,任一步失败即失败。
- 所有者运行全量门禁,agent 只测试改动模块;日志 / 临时文件在 logs/,必要时 -Full;门禁及打包强制 UTF-8 以避免 GBK 编码失败。
- 门禁先刷新 release cdylib,再并行 Rust、串行 Haskell、注释三条车道;Server / Web 先刷新各工程的本地依赖,任一步失败即失败。
- 局部改动只测试受影响模块;较大改动由 agent 执行全量门禁。日志 / 临时文件在 logs/,必要时 -Full;门禁及打包强制 UTF-8 以避免 GBK 编码失败。
- CLI 终端隐藏口令,管道兼容 LF / CRLF / 无行尾,保留空格与内部回车,提示写 stderr。
- CLI 禁用逐行自动历史,只记录完整 SQL 与元命令;含 IDENTIFIED / PASSWORD(忽略大小写)的输入整体排除,避免多行口令或执行失败留下片段。解析错误也隐藏此类原文,筛选保守包含字符串和标识符中的同名文本,已有历史不自动删除。
- TCP 与 Web 使用同一解析诊断脱敏路径;Web 回归校验整个 HTTP 错误响应不含口令。内置 SQL 控制台记录结果或诊断,不将 SQL 原文写入日志,外部代理和采集需自行配置。
+11 -9
View File
@@ -16,8 +16,9 @@
- 基础成本及贪心连接重排,无动态规划或跨外连接重排;只在行序不可观察处重排。
- catalog 行数可能滞后,distinct 有上限;16 桶等宽直方图只统计数值并按闭区间估算,增量维护可能偏差,桶内分布仍为估算。
- 内存统计去重上限为 4096,暂不提供直方图或索引成本;派生表可从透明算子估计行数,含聚合或可能报错表达式时仍保守。投影下推保留所有计算项,不消除潜在错误。
- 按外层绑定复用子查询覆盖 Filter / Compute / JOIN 条件;JOIN 按首次遇到的绑定惰性求值,缓存仅限单次连接。无半连接或通用物化,分组求值可能更早报告同一错误。
- CTE 解析期展开,无物化、递归或写语句;只能引用前面定义的 CTE,前向引用按普通表名解析。
- 查询内物化只在内存保存结果,尚无容量预算或磁盘溢出;既有按绑定分组求值可能更早报告同一错误。
- CTE 解析期展开,不支持递归、写语句或 MATERIALIZED / NOT MATERIALIZED 指定;不同优化子树不能共享物化。只能引用前面定义的 CTE,前向引用按普通表名解析。
- 半连接重写尚未覆盖组合谓词、复杂相关条件、多键、相关聚合或排序截断;可能报错的相关投影继续走原执行路径。
- 并行只覆盖页区间扫描:schema 至少 1000 行、最多 8 线程,无页内并行,统计滞后可退回顺序扫描。
- compact 不填跨页空洞,含隐藏列时仍需整表重写。
@@ -32,22 +33,23 @@
- 引导不重设已有口令、不提升已降权身份;类型定义冲突需人工解决。
## 类型与语义
- 范式检查提供 Haskell / TCP / CLI / Web 只读入口,最多 12 列;领域原子性和依赖完整性由用户声明,信息不足时不认证高阶范式。分解建议仅一轮,不保证子关系已达 BCNF;尚无自动迁移。
- DOMAIN 无自身 CHECK / NOT NULL / DEFAULT、ALTER DOMAIN、CASCADE;尚无 ENUM 或用户定义复合类型,已有内建 List / Maybe / Tuple。内置目录只登记现有语义,不能靠增加行扩展基础类型。
- 范式分析最多 12 列;领域原子性和依赖完整性由用户声明,信息不足时不认证高阶范式。分解建议仅一轮,不保证子关系已达 BCNF;尚无自动迁移。
- DOMAIN 无自身 CHECK / NOT NULL / DEFAULT、ALTER DOMAIN、CASCADE;尚无 ENUM 或用户定义复合类型。内置目录不能靠增加行扩展基础类型。
- DECIMAL 仍使用浮点表示,不是精确十进制存储;整数类型共用整数表示,CHAR 不补空格。
- 少量接口设置仍用字符串类型名;Haskell 值语义和 Rust 索引键分开维护。SQL 已接入 BoundQuery,旧 ColumnType / RelOp 仍是兼容桥,完整能力、转换及关系 IR 迁移待后续阶段。
- BoundQuery 在执行前比较对象身份、schema 版本和依赖列定义,IPC 的每次读取还在相关库读锁内复查全部依赖;多请求查询仍沿用既有数据隔离语义,不提供整条查询的数据快照。旧目录缺失版本时使用列定义校验,无有效对象编号时无法证明历史对象身份;旧存储二进制未确认读守卫则拒绝执行。多级外层作用域仍使用扁平行布局。
- 运行时类型尚无 Eq / Ord / Hash 等 capability 字典,不提供比较、排序、分组、极值和索引;复合字段在 Web 通过 SQL 修改,没有结构化单元格编辑器。
- 少量接口设置仍用字符串类型名;Haskell 值语义和 Rust 索引键分开维护。旧 ColumnType / RelOp 仍是兼容桥,完整能力、转换及关系 IR 迁移待后续阶段。
- 多请求查询不提供整条查询的数据快照;旧目录无有效对象编号时无法证明历史对象身份。执行期外层行仍使用扁平布局,原始关系执行 API 仍允许名称引用;尚无独立作用域或来源编号。
- 写入的存储操作分别取门,尚无整条语句的数据快照或数据冲突检测。来源/列缺少独立身份,不能视作完整写入 bound IR;建表、库及 DOMAIN 管理不在已有表写计划范围。
- CHECK 仍以表达式文本持久化;RENAME COLUMN 不自动改写依赖 CHECK,引用旧列名时拒绝改名。普通原始存储 DDL 不具有 Haskell 的完整表达式语义校验。
- 运行时类型尚无 Eq / Ord / Hash 等 capability 字典,不提供比较、排序、分组、极值、去重和索引;复合字段在 Web 通过 SQL 修改,没有结构化单元格编辑器。
- 运行时协议使用版本 1,旧客户端不支持新增类型化值;Web 的 JSON 数值仍受 JavaScript 安全整数范围限制。
- 派生表输出取裸列名,重复名称报错;未定型 NULL 仅用于查询类型推导,不可声明为存储列类型。
- ORDER BY 不接受任意表达式;已支持输出列序号和 DISTINCT,复合类型去重仍要求后续 capability 字典。
## 构建、发行与安全
- 离线 recover 依赖完整可用 WAL,不能保证修复损坏数据页或已截断的历史;未知系统表缺少结构时需备份或 reset。目录计数器损坏后无法还原已删除身份编号上限。
- 旧版进程不支持数据目录独占锁;维护前必须停止所有相关进程。
- sudo 本机认证需提升身份启动 server;当前只映射 Unix root / Windows 提升 Administrators 到一个显式配置身份,无任意 OS 用户映射或自动提权。异常退出留下的端口凭据目录须在确认停止后手工清理。
- sudo 的 Windows 提升成功路径、macOS 编译运行及 Linux 完整提升 server/CLI 链路仍待目标平台实机验收;Debian/WSL 已验证原生凭据安全边界。
- Stack 工程应串行构建;旧注册库可能被复用,必要时 --force-dirty 或所有者门禁 -Full,Web 门禁已自动刷新依赖。
- 直接构建独立 Stack 工程时可能复用旧注册库,必要时使用 --force-dirty 或全量门禁 -Full;Haskell 构建须串行。
- 存储协议变化后必须重建实际 cdylib,开发环境须配置 PATH / LD_LIBRARY_PATH;旧命名构建工件仍可能残留。
- 真实 server 测试须先引导并能找到 bootstrap;注释检查对部分多行语法可能误报。
- GitHub 在线安装、Linux $ORIGIN 与 macOS 发布仍需实机验证;无 Release 时在线安装无法取得预编译资源。
+30 -53
View File
@@ -1,64 +1,41 @@
ChuSQL 能力与进展摘要
更新:2026-10-10
ChuSQL 已完成事项
更新:2026-10-13
本文件是状态、测试计数及验收记录的唯一来源;用户确认其等价于 project-plan.txt。
设计见 design-decisions.txt,限制见 known-issues.txt,后续支线见 side-branch-plan.txt。
本文件是当前完成状态及最新验收的唯一来源,等价于 project-plan.txt;不保留历史批次、提交记录或修改流水。
设计见 design-decisions.txt,未解决限制见 known-issues.txt,后续计划见 side-branch-plan.txt。
## 主线能力
## SQL 与查询执行
- SQL:CRUD、表列约束、索引、连接、聚合、排序、分页、子查询、派生表、投影别名、CTE、比较运算符、ANY / ALL、DISTINCT / ALL 与 ORDER BY 输出列序号。
- 优化:谓词 / 投影下推、常量折叠、点查 / 范围成本选择、贪心内连接重排、16 桶直方图、按外层绑定复用子查询与并行扫描。
- 存储:页、堆表、B+Tree、catalog、WAL、LSN 检查点、幂等恢复与页内 compact。
- 会话:按连接隔离工作库、快照事务、写写冲突检查、保存点和权限变更后的会话失效。
- 身份:用户与角色统一名称空间,LOGIN / SUPERUSER / ENABLED、稳定编号、角色继承、转授权、迁移及删除清理。
- 权限查询与撤销:当前登录身份 SHOW GRANTS、REVOKE GRANT OPTION FOR 与失效下游级联清理;工作区模块回归及 2026-10-09 所有者全量门禁通过。
- 范式入口:专用 TCP 请求、CLI --normalize / \normalize 与 Web 结构区只读分析;CONNECT / SELECT、事务视图、稳定编号和 schema 指纹、声明及运行预算;工作区模块回归及 2026-10-09 所有者全量门禁通过。
- 类型:CREATE / DROP / SHOW DOMAIN、库内嵌套定义、列引用、依赖 / 循环检查及持久化。
- 相关列绑定:局部 ColumnSlot 与外层 OuterColumnSlot 分离,外层使用相对槽位,重新绑定保留外层身份;同名遮蔽及多层相关引用回归通过;仍使用扁平化外层行,多级词法作用域/来源编号尚待实施。
- 绑定执行校验:执行前比较依赖表身份、schema 版本和列定义;IPC 每次扫描、分片、点查及范围读取在相关库读锁内复查全部依赖,再读取数据,跨库读锁按库名排序。依赖覆盖来源、连接条件、投影/过滤中的嵌套查询及递归 DOMAIN 定义,忽略数据/统计和无关对象变化。同名同结构重建或结构改变后恢复原定义使旧绑定失效;旧目录缺失编号或版本时保留列定义校验,已知身份或版本丢失则拒绝。守卫须有明确确认,未支持守卫的后端拒绝执行;纯内存视图保持稳定。多请求查询仍沿用既有数据隔离语义。本批待所有者新门禁验收。
- bound IR 基础:SQL 查询输出类型保留嵌套 DOMAIN 引用及其基础类型;TypedExpression 按输入 schema 槽位绑定列;SQL RelOp 优化后绑定投影、过滤、计算、聚合参数、连接条件及排序/分组键;投影转换为 Compute,排序/分组使用 BoundSort/BoundAggregate,保留重复列、稳定排序、首次分组顺序及空输入聚合行为;相关子查询绑定局部和外层布局,存储返回按布局排列;独立作用域/来源身份及约束绑定尚待实施;槽位绑定基础已通过 2026-10-09 所有者全量门禁。
- 引导与维护:初始化 system、默认 root 和 18 个内置类型;重复引导保留口令,冲突拒绝覆盖;system_catalog_manager 与 bootstrap repair / recover / reset。
- 配置与发行:listen_host、data_dir / log_files 分离,固定 static,管理员名由 --user 指定,模板统一 resources/chusql.toml;Windows 打包安装冒烟、管道口令兼容及构建 UTF-8。
- 实现 CRUD、表列约束、索引、INNER / LEFT JOIN、聚合、GROUP BY、HAVING、ORDER BY、LIMIT、投影别名、DISTINCT / ALL;排序支持输出序号、表达式、函数、聚合及子查询。
- 实现标量及相关子查询、派生表、非递归 CTE、IN / EXISTS、比较与 ANY / ALL;保持 NULL 三值逻辑、重复列、稳定排序、空输入聚合及空集成员比较语义;HAVING 覆盖整体组与未投影聚合,新子句参与依赖守卫和表权限检查。
- 实现谓词 / 投影下推、常量折叠、点查 / 范围成本选择、贪心内连接重排、16 桶直方图及保序并行扫描;子查询按定义和外层值在查询内物化、跨子句复用,相同 CTE / 派生执行子树共享结果;独立 IN / NOT IN 和简单等值相关 EXISTS / NOT EXISTS 使用哈希半连接 / 反连接。
## 已实现侧分支
## 类型与绑定
以下四项已通过 2026-10-05 所有者全量门禁并提交;sudo 另有平台实机验收。
- 建立固定类型 / 函数编号、TypeId / TypeExpr / Kind、逻辑与物理类型、版本化复合值编码;支持 Int / Double / Bool / String / List / Maybe / Tuple、length / not,接入 SQL、存储、CLI 和 Web。
- 实现 CREATE / DROP / SHOW DOMAIN、库内嵌套定义、列引用、依赖与循环校验及持久化;查询输出保留 DOMAIN 身份。
- 查询使用 BoundQuery;表达式、投影、连接、排序和分组按 schema 槽位绑定,存储返回行按布局整理,缺列和位置失配明确失败。
- 相关列按最近到最远的独立词法作用域解析,局部 / 外层槽位分离;重绑定保留有效位置,失配仅允许唯一同名列重定位。子查询取值与缓存共享槽位绑定。
- DML 使用可复用 BoundWrite,预绑定 INSERT 输入、UPDATE 目标、DELETE 布局及 CHECK / 非空 / 唯一性约束;保留默认值、自增、逐项赋值和未命中行不求值,唯一性按最终行集判断,失败不发布修改。
- 查询与已有表写计划保存对象身份、schema 版本、列定义及传递 DOMAIN 依赖;执行前及实际存储操作锁内复查。写前握手拒绝不支持守卫的存储,跨库按名称排序取门;数据、统计和无关结构变化不使计划失效。
- CHECK 定义与执行共用类型及槽位绑定;建表、加列和结构变更校验条件、默认值与键能力,空表不跳过,失效引用明确拒绝。
- Web 编辑事务:独立连接绑定页面与数据库,跨表原子提交;保存点回退保留编辑集,冲突要求重新加载;提交去重、SQL 标签隔离与断线 / 退出清理。
- sudo 认证:默认关闭的 allow_sudo_auth 与显式本机身份映射;操作系统保护凭据、回环对端校验及一次性 HMAC 挑战;不继承、不提权,撤销使既有会话失效。
- 对象授权:持久化且不复用的库 / 表编号,所有者与 grant option;DATABASE CONNECT / CREATE、表级数据权限及 PUBLIC;跨入口鉴权、来源追踪、级联撤销和事务提交复查。
- 范式检查器:基于 schema 与声明的阿姆斯特朗闭包,分析 1NF / 2NF / 3NF / BCNF;区分信息不足,输出违反依赖与一次无损分解并验证依赖保持;只读 API,最多 12 列。
## 存储与事务
## 阶段 A:类型与函数基础
- 实现页、堆表、B+Tree、catalog、WAL、LSN 检查点、已提交组幂等恢复及页内 compact;持久化对象编号、高水位和 schema 版本,失败进入 recovery_required。
- 实现按连接隔离工作库、整库快照事务、写写冲突检查、保存点和差分提交;权限及对象身份在事务提交时复查。
- Web 编辑使用独立连接与页面绑定,支持跨表原子提交、保存点重放、提交去重、冲突重载、SQL 标签隔离及退出清理。
- 状态:实现完成,模块测试及所有者全量门禁通过;实现提交 8ce4239,发行检查修正 0475a61,正式版 v26.10.1 发布验收进行中。
- 固定 TypeConstructorId、结构化 TypeId、TypeExpr / Kind 与内建 Type Registry;Int / Double / Bool / String / List / Maybe / Tuple。
- 独立 PhysicalType,递归复合值、kind / 参数校验、版本化类型和值编码、协议验证、catalog schema 及存储重载。
- 固定 FunctionId 与 Builtin Function Registry,length / not 的签名解析和类型化执行;SQL NULL 保持三值语义。
- schema 驱动的 TypedExpression / TypedPlan;SQL SELECT 使用 BoundQuery,函数及构造器节点携带已解析身份,输出按位置校验。
- SQL 复合列声明、LIST / MAYBE / TUPLE、嵌套构造器、INSERT / UPDATE / CHECK / 子查询接入;CLI / Web 显示及 SQL 生成。
- 兼容边界:旧 ColumnType 和 RelOp 保留,日期 / 时间戳 / Blob 明确使用 CompatibilityType;完整 capability / operator / cast / 用户 ADT / Extension 不在本阶段。
- 本批已验证:Engine 466 / Server 141 / Web 75 / CLI 17 全部通过;前端运行时值 9 条断言及事务 10 项通过,改动文件注释检查无问题,git diff --check 通过。
- 使用说明:docs/types.md;本批日志:logs/runtime-engine.log、logs/runtime-web.log、logs/runtime-web-final.log、logs/runtime-cli.log。Server 最终回归亦通过;Web 最终日志由单独重跑生成。
## 身份、工具与发行
## 既有模块验证
- 用户与角色统一名称空间,支持 LOGIN / SUPERUSER / ENABLED、稳定编号、角色继承、迁移及删除清理;权限变更使受影响会话失效。
- 实现对象所有权、grant option、DATABASE CONNECT / CREATE、表级数据权限及 PUBLIC、SHOW GRANTS、REVOKE GRANT OPTION FOR 和失效授权级联清理。
- 实现默认关闭的本机 sudo 身份映射、受保护凭据、回环校验与一次性 HMAC 挑战;已验证 Windows 非提升拒绝及 Debian/WSL root 凭据安全边界。
- 范式检查通过 Haskell / TCP / CLI / Web 提供只读分析,依据 schema 与声明检查 1NF / 2NF / 3NF / BCNF,输出违反依赖、一次无损分解及依赖保持结果。
- 引导初始化 system、默认 root 与 18 个内置类型,重复引导保留口令并拒绝冲突;实现 system_catalog_manager 及 bootstrap repair / recover / reset。
- 统一监听、数据 / 日志目录与配置模板;完成 Windows 分组件打包安装冒烟、管道口令兼容、敏感 SQL 诊断 / 历史脱敏及 UTF-8 构建。发行与平台未验收事项见 known-issues.txt。
- 2026-10-10 schema 版本与读守卫:Rust catalog 持久化表级 schema_version;新表为 1,旧目录缺失字段保留未知版本 0,补列、列定义变化、删列、改名与类型名迁移递增;数据及统计变化不递增,相同定义及重复删列不递增,耗尽明确返回错误。新增删列及列定义替换 WAL 记录在落盘前确定目标版本,应用与恢复使用该版本,覆盖检查点失败、多次结构变化及重复恢复;旧 WAL 载荷仍可读取。版本以精确十进制字符串透传到 TableInfo / Table、IPC schema / 快照及内存 Server,内存 DDL 同样递增;BoundQuery 比较依赖版本并为真实读取携带守卫,覆盖恢复原定义、版本丢失、校验与读取之间的 DDL、四种读路径、跨库依赖变化、写请求拒绝及旧存储缺少确认。
- 本批 Engine 511 / Server 161 / Web 80 / Rust 189,均零失败;clippy、release 动态库构建、相关文件注释检查及 git diff --check 通过。日志见 logs/schema-guard-engine.log、logs/schema-guard-server.log、logs/schema-guard-web.log、logs/schema-guard-storage.log、logs/schema-guard-build.log、logs/schema-guard-comments.log。上一批 CLI 20 / Bootstrap 9 零失败,日志见 logs/schema-bind-cli.log、logs/schema-bind-bootstrap.log,本批未重跑。尚待所有者全量门禁,未提交。
## 最新验证
- 2026-10-10 对象绑定批次:Table / TableInfo 保留库和表身份,IPC schema / 快照及内存 Server 目录透传;精确 64 位编号采用十进制字符串输出,兼容旧数值并拒绝非法输入。查询复查对象身份与传递 DOMAIN 依赖,覆盖同结构重建、身份丢失、跨库视角和无关领域变化。
- 本批模块验证:Engine 505 / Server 160 / Web 80 / CLI 20 / Bootstrap 9,均零失败;Web 内含前端值与事务测试,17 个相关文件注释检查及 git diff --check 通过。日志见 logs/object-bind-engine.log、logs/object-bind-server.log、logs/object-bind-web.log、logs/object-bind-cli.log、logs/object-bind-bootstrap.log。本批尚待所有者全量门禁,未提交。
- 已登记最近模块结果:Engine 501 / Server 159 / Web 80 / CLI 20 / Rust 181,均通过;2026-10-09 所有者全量门禁已验证本组结果,Bootstrap 9 项及 clippy 亦通过。
- Web 前端事务 10 项测试通过;对象授权阶段 clippy、release 构建和改动文件注释检查通过。
- sudo 原生凭据已验证 Windows 非提升拒绝路径及 Debian/WSL root 安全边界;其他平台链路验收仍待完成。
- 2026-10-09 所有者全量门禁覆盖当时工作区:cargo-test / clippy、engine / server / web / cli / bootstrap、注释检查均通过;日志见 logs/cargo.log、logs/stack.log、logs/comments.log。该结果不覆盖之后的对象绑定批次。
## 后续与验收
- 2026-10-09 所有者全量门禁通过:三条车道全部 exit=0,STEPS=0,0,0,0,GATE_EXIT=0,用时 136 秒;Engine 501 / Server 159 / Web 80 / CLI 20 / Bootstrap 9,均零失败。此结果不替代生产恢复演练、持续负载及平台实机验收。
- 2026-10-05 所有者全量门禁通过:cargo / stack / comments 全部 exit=0,STEPS=0,0,0,0,GATE_EXIT=0;bootstrap 9 项通过。Windows 正式包 CLI / Web 分组件安装验证通过。
- 正式版 v26.10.1 包含从零介绍的发行说明;按用户要求仅发布 Windows x86_64 / Linux x86_64 的 zip / tar.gz 安装包及 SHA256。要求两平台安装验证及 Linux 测试通过,XDG 验证隔离已修复。最终发布状态待登记。
- sudo 的 Windows 提升成功路径、macOS 编译运行及 Linux 完整提升链路待实机验收。
- 在线安装、Linux $ORIGIN 与 macOS 发行待目标平台验收;发布签名待设计。
- 范式自动迁移、存储查询架构扩展和 DOMAIN 自身约束等后续事项见 side-branch-plan.txt 与 known-issues.txt。
- 全量门禁通过:Rust 191 / Engine 598 / Server 163 / Web 80 / CLI 20 / Bootstrap 9,均零失败;动态库重建、Clippy、注释检查及 git diff --check 通过;受影响 HLint 仅保留既有惰性相关建议。
- 验收入口:gate-check/run-gate.ps1;最新日志:logs/empty-in-gate.log。局部改动验证受影响模块,较大改动执行全量门禁;当前工作区改动未提交。
+7 -10
View File
@@ -3,17 +3,14 @@ ChuSQL 近期任务与依赖
实现、测试及门禁状态只以 progress.txt 为准;设计见 design-decisions.txt,限制见 known-issues.txt。
下列顺序是规划,不是已完成能力;每批按实际进度选择任务。
1. 统一绑定:完成多级词法作用域、来源/列身份、写语句和约束绑定,收拢旧兼容桥;保留 nullable、错误时序、DOMAIN 及布局语义。schema 版本和读取守卫已有实现,验收见 progress.txt;旧目录身份升级仍需安全策略。
2. DOMAIN 约束:CHECK / NOT NULL / DEFAULT、ALTER DOMAIN,覆盖写入、导入及事务提交;CASCADE 依赖对象目录与原子结构事务,发布前验证旧数据和嵌套依赖。
3. 类型能力:精确 DECIMAL、复合类型 Eq / Ord / Hash,再推进 ENUM / 用户复合类型 / ADT;统一 Haskell 值与 Rust 索引语义,明确整数范围、CHAR 和数据迁移。
4. 查询:ORDER BY 表达式 → 通用物化 → 半连接 → 递归 CTE;写入型 CTE 依赖统一写入校验。保持行序、重复、NULL、错误时序及来源解析规则。
5. 结构事务:库建删、DDL、对象依赖与版本复查纳入原子发布和恢复;解决绑定失效、权限、回滚及编号高水位,不能只解除事务内 DDL 禁令。
6. 范式迁移:依赖 DOMAIN 约束、对象目录和结构事务;首版保留来源,拒绝 NULL、重复行及依赖不保持,后续再做多轮分解。
7. 存储:MVCC → 死锁检测 → 并行写;推进页 LSN、恢复、跨页整理及隐藏列重写。保留幂等、隔离、句柄生命周期、行序与资源预算,以实测决定并行扩展。
8. 其他:连接搜索/外连接变换/统计成本;列级权限、所有权转移、ADMIN OPTION、身份属性;Web 复合值编辑、大整数和多页面事务。按真实需求独立推进。
1. 统一绑定与类型系统:完成多级作用域、来源/列身份、写语句和约束绑定,收拢旧兼容桥;完善 DOMAIN 约束与 ALTER DOMAIN、精确 DECIMAL、复合类型 Eq / Ord / Hash,再推进 ENUM / 用户复合类型 / ADT。统一写入、导入、事务提交与 Rust 索引语义,保留 nullable、错误时序和布局语义;明确整数范围、CHAR、旧目录身份升级及数据迁移。已有 schema 版本和读取守卫的验收见 progress.txt。
2. 查询语言与执行优化:推进递归 CTE 和写入型 CTE,扩展复杂条件去相关,完善物化内存预算及磁盘溢出,合并连接搜索、外连接变换及统计成本改进;写入型 CTE 依赖统一写入校验。优化保持行序、重复、错误时序及来源解析规则。
3. 原子结构变更与范式迁移:将库建删、DDL、对象依赖及版本复查纳入原子发布和恢复,维护绑定失效、权限、回滚与编号高水位;在对象目录、DOMAIN 约束及结构事务基础上支持 CASCADE 和范式自动迁移,发布前验证旧数据与嵌套依赖。迁移首版保留来源,拒绝 NULL、重复行及依赖不保持,后续推进多轮分解。
4. 存储并发与恢复:推进 MVCC、死锁检测和并行写,完善页 LSN、恢复、跨页整理及隐藏列重写。保留幂等、隔离、句柄生命周期、行序与资源预算,以实测决定并行扩展。
5. 权限与客户端能力:完善列级权限、所有权转移、ADMIN OPTION 和身份属性;统一 Web 复合值编辑、大整数及多页面事务的交互与会话约束。按真实需求选择实施范围。
持续验收
- 新改动须等待所有者新全量门禁,通过后提交;模块测试不替代异常恢复、磁盘错误、持续负载及并发冲突演练。
- 局部改动通过受影响模块测试;较大改动由 agent 执行全量门禁,通过后再提交。模块测试不替代异常恢复、磁盘错误、持续负载及并发冲突演练。
- sudo、在线安装、Linux $ORIGIN、macOS 构建发行与发布签名按目标平台验证,结果登记 progress.txt。
- 升级明确账号/授权/配置迁移、禁止降级、旧历史和异常凭据清理;不承诺旧二进制兼容、损坏页自动修复或任意 OS 用户映射。
- agent 只跑改动模块规定测试;Haskell 串行,存储协议变化重建实际动态库。所有者门禁入口为 gate-check/run-gate.ps1。
- Haskell 构建串行,存储协议变化重建实际动态库;门禁入口为 gate-check/run-gate.ps1。
+3 -1
View File
@@ -19,6 +19,8 @@
- 类型、值、转换或表达式语义用 `chusql-type-system`;存储、序列化、系统目录、初始化或恢复用 `chusql-storage-integrity`;FFI、跨组件协议、序列化契约或外部接口用 `chusql-boundary-contracts`(均在 `.agents/skills/`)。
- 跨领域组合相关 Skills,无关任务不加载;Skills 不覆盖更高优先级的安全和工程约束。
- 简单任务直接执行;采用最小必要改动,允许有明确收益且能验证的局部结构优化,优先删除重复和无用代码。
- 保持代码最简:用最少且易读的代码完整解决当前需求,优先复用现有实现与标准库;相同规则只维护一份,不引入仅为缩短函数或预留未来而存在的抽象、包装、配置和依赖。简化须保持求值顺序、错误传播、边界校验及恢复约束,不以压缩行数牺牲清晰度或正确性。
- Haskell 编码后对受影响源码运行 HLint(与 nvim 的提示来源一致),修复能保持语义的建议;不通过禁用提示绕过检查。优先使用 `void`、`when/unless`、`fromMaybe`、`isJust/isNothing`、`maybeToList`、`zipWithM` 等惯用函数,避免冗余 lambda、括号、绑定、导入与 LANGUAGE pragma;涉及惰性、严格性或类型表示变化的建议须核对语义,不能机械套用。
- 测试强度与实际风险及影响范围匹配,不机械新增测试,不盲目追求覆盖率;数据库内核微改动也须验证关键行为。
- 不强制 TDD、子代理或多阶段审查;减少无关读取、重复搜索、工具调用和输出,Skills 不应增加无收益的流程。
- 文档描述当前状态;不创建整改报告、修改流水账或无用途的兼容层,不修改 Git 历史。
@@ -33,7 +35,7 @@
## 协作规则
- 全量门禁入口:`gate-check/run-gate.ps1`(三条车道并行,日志写仓库根的 `logs/`)。
- 门禁由项目所有者手动运行;agent 只跑改动模块的测试,拿到门禁结果后再提交。
- 局部改动运行受影响模块的规定测试;较大改动由 agent 执行全量门禁,通过后再提交。
- engine / web / storage 使用规定测试入口。
- 规定入口见 `gate-check/run-step.ps1`;Haskell 构建串行,存储协议改动须重建实际动态库。
- 改动说明只在交流中记录。
+31 -14
View File
@@ -2,6 +2,7 @@
module Main where
import Data.Either (lefts)
import ChuSQL.Core.Protocol (QueryResult (..), TableInfo (..))
import ChuSQL.Interface.Link (Client, clientPing, closeClient, connectClient)
import ChuSQL.Interface.Session (
@@ -15,7 +16,7 @@ import ChuSQL.Interface.Session (
import Control.Concurrent (forkIO, forkFinally, threadDelay)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import Control.Exception (IOException, bracket, evaluate, throwIO, try)
import Control.Monad (forM, forM_, replicateM, unless, when)
import Control.Monad (forM_, replicateM, unless, when, void)
import Data.List (intercalate, sort)
import ChuSQL.Core.Model (Value (..))
import Data.Text (Text)
@@ -77,7 +78,7 @@ timedQuery bench sql = do
Left _ -> pure (-1)
Right result -> evaluate (qrRowCount result)
t1 <- getMonotonicTime
pure (t1 - t0, either Left (const (Right n)) r)
pure (t1 - t0, const (Right n) =<< r)
-- | 打印一行结果
report :: String -> Either Text Int -> Double -> IO ()
@@ -107,7 +108,7 @@ batchInsert bench label n mkSql = do
results <- mapM (runSql bench . mkSql) [1 .. n]
t1 <- getMonotonicTime
let total = t1 - t0
errs = [e | Left e <- results]
errs = lefts results
case errs of
[] -> do
printf
@@ -181,7 +182,7 @@ runBatch bench sqls = do
t0 <- getMonotonicTime
results <- mapM (runSql bench) sqls
t1 <- getMonotonicTime
pure (t1 - t0, [e | Left e <- results])
pure (t1 - t0, lefts results)
-- | 把 1..n 按 size 切成一段段
chunked :: Int -> Int -> [[Int]]
@@ -590,7 +591,7 @@ pressureScenarios bench u o = do
_ <- batchInsert bench "200 individual durable INSERTs" 200 (\i -> printf "INSERT INTO writes (id,name,age) VALUES (%d,'w%d',%d)" i i i)
(milliseconds, ()) <- measure $ do
(beginMs, _) <- measure (runSql bench "BEGIN")
(stagedMs, ()) <- measure $ forM_ [201 .. 400 :: Int] $ \i -> runSql bench (printf "INSERT INTO writes (id,name,age) VALUES (%d,'w%d',%d)" i i i) >> pure ()
(stagedMs, ()) <- measure $ forM_ [201 .. 400 :: Int] $ \i -> void (runSql bench (printf "INSERT INTO writes (id,name,age) VALUES (%d,'w%d',%d)" i i i))
(commitMs, _) <- measure (runSql bench "COMMIT")
printf "TXN_PHASE begin_ms=%.3f staged_ms=%.3f commit_ms=%.3f\n" beginMs stagedMs commitMs
pure ()
@@ -609,17 +610,33 @@ pressureScenarios bench u o = do
-- | 用多条独立会话同步开始点查
concurrentLookup :: Bench -> Int -> IO ()
concurrentLookup bench workers = do
completions <- forM [1 .. workers] $ \_ -> do
start <- newEmptyMVar
completions <- replicateM
workers
(do start <- newEmptyMVar
done <- newEmptyMVar
client <- connectClient "127.0.0.1" (bPort bench) >>= either (ioError . userError . T.unpack) pure
client <- connectClient "127.0.0.1" (bPort bench)
>>= either (ioError . userError . T.unpack) pure
session <- newSession client
authenticateSession session "admin" "" >>= either (ioError . userError . T.unpack) pure
switchDatabase session "bench" >>= either (ioError . userError . T.unpack) pure
_ <- forkFinally (takeMVar start >> bracket (pure client) closeClient (\_ -> replicateM 100 (fst <$> measure (do
result <- runStatement session "SELECT id FROM users WHERE id = 1"
unless (fmap qrRows result == Right [[VInt 1]]) (ioError (userError "concurrent lookup mismatch")))))) (putMVar done)
pure (start, done)
authenticateSession session "admin" ""
>>= either (ioError . userError . T.unpack) pure
switchDatabase session "bench"
>>= either (ioError . userError . T.unpack) pure
_ <- forkFinally
(takeMVar start
>>
bracket
(pure client) closeClient
(\ _
-> replicateM
100
(fst
<$>
measure
(do result <- runStatement
session "SELECT id FROM users WHERE id = 1"
unless (fmap qrRows result == Right [[VInt 1]]) (ioError (userError "concurrent lookup mismatch"))))))
(putMVar done)
pure (start, done))
(milliseconds, results) <- measure $ do
mapM_ (\(start, _) -> putMVar start ()) completions
mapM (takeMVar . snd) completions
+4 -4
View File
@@ -2,6 +2,7 @@
module Main (main) where
import Data.Maybe (fromMaybe)
import ChuSQL.Core.Engine.Storage.IPC (closeConnection, localStorageLink, sendRawRequest, setStorageLink)
import ChuSQL.Bootstrap (preinstalledTypes, runBootstrap)
import ChuSQL.Core.Engine.Storage.FFI (maintainStorage)
@@ -139,7 +140,7 @@ runMaintenance opts mode = do
Left err -> failWith err
Right plain -> do
encoded <- if T.null plain then pure "" else hashPassword plain
let request = A.object ["mode" A..= mode, "user" A..= maybe "root" id (optUser opts), "password_hash" A..= encoded, "types" A..= preinstalledTypes]
let request = A.object ["mode" A..= mode, "user" A..= fromMaybe "root" (optUser opts), "password_hash" A..= encoded, "types" A..= preinstalledTypes]
reply <- maintainStorage path (BL.toStrict (A.encode request))
case reply of
Left err -> failWith err
@@ -155,9 +156,8 @@ send request = do
readPassword :: Options -> IO (Either String Text)
readPassword opts
| optPasswordless opts = pure (Right "")
| optPasswordStdin opts = do
line <- TIO.getLine
pure (Right (T.dropWhileEnd (\c -> c == '\r' || c == '\n') line))
| optPasswordStdin opts = do Right . T.dropWhileEnd (\ c -> c == '\r' || c == '\n')
<$> TIO.getLine
| otherwise = pure (Left "pass --password-stdin or --passwordless")
-- | 打印错误并退出 1
+3 -2
View File
@@ -2,6 +2,7 @@
module Main (main) where
import Data.Maybe (fromMaybe)
import ChuSQL.Bootstrap (preinstalledTypes, runBootstrap)
import ChuSQL.Core.Protocol (Account (..))
import ChuSQL.Core.Model (columnType, typeName)
@@ -85,7 +86,7 @@ identity super = A.object ["status" A..= ("accounts" :: Text), "accounts" A..= [
-- | 已写入编号的类型响应
installed :: A.Value
installed = A.object ["status" A..= ("rows" :: Text), "rows" A..= map numbered (zip [1 :: Int ..] preinstalledTypes)]
installed = A.object ["status" A..= ("rows" :: Text), "rows" A..= zipWith (curry numbered) [1 :: Int .. ] preinstalledTypes]
where
-- | 给预装定义添加持久化编号
numbered (n, A.Object fields) = A.Object (KM.insert "id" (A.toJSON n) fields)
@@ -93,7 +94,7 @@ installed = A.object ["status" A..= ("rows" :: Text), "rows" A..= map numbered (
-- | 读取响应中的一个字段
field :: A.Key -> A.Value -> A.Value
field key (A.Object fields) = maybe A.Null id (KM.lookup key fields)
field key (A.Object fields) = fromMaybe A.Null (KM.lookup key fields)
field _ _ = A.Null
-- | 记录请求并返回指定响应
+3 -2
View File
@@ -19,7 +19,7 @@ import ChuSQL.Interface.Link (Client, closeClient, connectClient)
import ChuSQL.Interface.Sudo (SudoCredential, readSudoCredential)
import ChuSQL.Interface.TOML (resolveConfigPath)
import Control.Exception (finally)
import Control.Monad (unless)
import Control.Monad (unless, when)
import Data.IORef (IORef, newIORef)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
@@ -107,7 +107,8 @@ main = do
let rootName = rootUserName base
userName = fromMaybe (if optSudo options then scSudoUser config else rootName) (optUser options)
credential <- if optSudo options then do
if T.null userName then reportError "sudo_auth_user is not configured" >> exitFailure else pure ()
when (T.null userName)
$ reportError "sudo_auth_user is not configured" >> exitFailure
local <- readSudoCredential (scPort config)
case local of
Left message -> reportError message >> exitFailure
+2 -2
View File
@@ -13,7 +13,7 @@ import ChuSQL.CLI.Script (Meta (..), errorHint, metaHelp, parseMeta, takeStateme
import ChuSQL.Interface.Session (Session, catalog, databases, roleViews, runStatement, sessionDatabase, switchDatabase)
import ChuSQL.Core.Protocol (SchemaColumn (..), TableInfo (..))
import ChuSQL.Interface.Protocol (Grant (..), RoleView (..))
import Control.Monad (forM_, when)
import Control.Monad (forM_, when, unless)
import Control.Monad.IO.Class (liftIO)
import Data.IORef (IORef, readIORef, writeIORef)
import Data.Text (Text)
@@ -84,7 +84,7 @@ drain :: Session -> IORef OutputFormat -> Text -> InputT IO Text
drain session formatRef buffer = case takeStatement buffer of
Nothing -> pure (T.strip buffer)
Just (statement, rest) -> do
when (not (T.null statement)) $ do
unless (T.null statement) $ do
rememberStatement (statement <> ";")
runOne session formatRef statement
drain session formatRef rest
+1 -1
View File
@@ -38,7 +38,7 @@ normalizationArguments input = case readP_to_S (skipSpaces *> sepBy token skipSp
-- 有界读取 UTF-8 声明并拒绝重复字段。
loadNormalizationDeclaration :: FilePath -> IO (Either Text NormalizationDeclaration)
loadNormalizationDeclaration path = do
loaded <- try (withBinaryFile path ReadMode (\handle -> BS.hGet handle 65537)) :: IO (Either IOException BS.ByteString)
loaded <- try (withBinaryFile path ReadMode (`BS.hGet` 65537)) :: IO (Either IOException BS.ByteString)
pure $ case loaded of
Left err -> Left (T.pack (show err))
Right raw -> do
+2 -1
View File
@@ -10,6 +10,7 @@ module ChuSQL.CLI.Script
, metaHelp
) where
import Data.Maybe (isJust)
import ChuSQL.CLI.Normalization (normalizationArguments)
import ChuSQL.CLI.Format (OutputFormat (..), formatName, parseFormat)
import Data.Char (isSpace)
@@ -90,7 +91,7 @@ data ScanState = ScanNormal | ScanString | ScanLineComment | ScanBlockComment
-- | 攒下来的内容里有没有一条以分号结束的语句
statementComplete :: Text -> Bool
statementComplete = maybe False (const True) . takeStatement
statementComplete = isJust . takeStatement
-- | 去掉结尾的空白与分号(-e 直接执行时用)
stripTerminator :: Text -> Text
@@ -46,6 +46,7 @@ library
, parser-combinators
, scientific
, text
, transformers
, unordered-containers
, vector
extra-libraries: chusql_core_storage
+232 -121
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
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 resolved -> runStatementUncheckedM db resolved
| otherwise -> case bindWrite db q of
Left err -> pure (Left err)
Right bound -> executeWriteM bound
-- | 按语句类型分发(已检查过)
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
-- | 保存已有表写入的 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 rs -> do
result <- insertMany tbl rs
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 [])
runStatementUncheckedM db (Delete tbl mWhere) = do
rowsResult <- scan tbl
case rowsResult of
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 (doomed, kept) -> case mapM rowId doomed of
Right ids -> do
result <- deleteKeys tbl ids
result <- deleteKeys target ids
pure (result >> Right [])
Left _ -> do
result <- replaceAll tbl kept
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
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 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 [])
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
@@ -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
@@ -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,7 +219,9 @@ 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
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
@@ -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,27 +358,33 @@ bindingsTableM ::
Row ->
[Expr] ->
[Row] ->
m (Either String (HM.HashMap String [Expr]))
bindingsTableM db outer exprs rows = do
built <- mapM swap (bindingSamples refs outer rows)
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
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
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"
-- | 单子过滤:条件本身是单子求值的
@@ -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)
@@ -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
@@ -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
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
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
@@ -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) ' '
@@ -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
@@ -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)]
@@ -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
@@ -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
-- 校验依赖声明。
@@ -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 ()
@@ -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
@@ -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
@@ -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"
@@ -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
@@ -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
@@ -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)
@@ -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 ())
@@ -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,20 +140,19 @@ 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
sendRequest req = withStorageLink $ \case
Nothing -> pure (RespError "storage not configured")
Just link -> do
raw <- slRequest link (BL.toStrict (encode req))
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
Right bytes
-> case eitherDecodeStrict (BS.dropWhileEnd (== 13) bytes) of
Left e -> pure (RespError ("decode error: " ++ e))
Right resp -> pure resp
@@ -241,19 +243,21 @@ okOnly _ = Nothing
-- | 发 Scan
doScan :: Env -> String -> IO (Either String [Row])
doScan env t = ask env "scan" (ReqScan t) $ \resp -> case resp of
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]
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
doScanShard env t cols shard shards = ask env "scan_shard" (ReqScanShard t cols shard shards) $ \case
RespRows rows -> Just rows
_ -> Nothing
@@ -271,19 +275,19 @@ 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
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
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
doLookupByColumn env t c k = ask env "lookup_by_index" (ReqLookupByColumn t c k) $ \case
RespRows rows -> Just (IndexRows rows)
RespNoIndex -> Just NoIndex
_ -> Nothing
@@ -296,14 +300,14 @@ 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
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
doDescribeTable env t = ask env "describe_table" (ReqDescribeTable t) $ \case
RespSchema info -> Just info
_ -> Nothing
@@ -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
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,7 +451,7 @@ instance MonadStorage IPCStorage where
-- \| 只问数据字典要结构,设了当前库只留它的表
schema = IPCStorage $ \env -> do
result <- ask env "all_catalogs" ReqAllCatalog $ \resp -> case resp of
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)}
@@ -30,6 +30,9 @@ instance MonadStorage MemoryStorage where
-- \| 纯状态视图在求值期间不受外部修改
withSchemaGuard _ action = action
-- | 纯状态写入不受外部结构变更影响
withWriteSchemaGuard _ action = action
-- \| 全表扫描
scan t = MemoryStorage $ \db -> do
tbl <- lookupTable db t
@@ -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)
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
@@ -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"
dropTableStatement = do keyword "drop"
keyword "table"
name <- tableName
return (DropTable name)
DropTable <$> tableName
-- | 读 CREATE INDEX(列名即索引名)
createIndexStatement :: Parser Statement
@@ -485,12 +491,10 @@ alterTableStatement = do
-- | 读 CREATE USER,口令是明文
createUserStatement :: Parser Statement
createUserStatement = do
keyword "create"
createUserStatement = do keyword "create"
keyword "user"
name <- userName
pw <- identifiedBy
return (CreateUser name pw)
CreateUser name <$> identifiedBy
-- | 读 IDENTIFIED BY '口令'
identifiedBy :: Parser String
@@ -529,11 +533,9 @@ alterRoleStatement = do
-- | 读 DROP USER
dropUserStatement :: Parser Statement
dropUserStatement = do
keyword "drop"
dropUserStatement = do keyword "drop"
keyword "user"
name <- userName
return (DropUser name)
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
+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)"
+553 -36
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,7 +1137,7 @@ main = hspec $ do
Left err -> expectationFailure err
Right (_, _) -> do
rowsOf (runStatement testDB (makeSelect ["name"] "users" Nothing))
`shouldSatisfy` \r -> case r of
`shouldSatisfy` \case
Right rows -> length rows == 3
Left _ -> False
@@ -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
+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"
+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"
+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, .. }
+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 { .. }
+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>> {
@@ -32,6 +32,7 @@ module ChuSQL.Interface.Actions (
revokeRoleSql,
) where
import Control.Monad (zipWithM)
import ChuSQL.Core.Model (Column (..), ColumnType (..), Value (..), integerType, numericType, parseColumnType, plainColumn, typeName)
import qualified ChuSQL.Core.Model as M
import ChuSQL.Core.Runtime
@@ -127,7 +128,7 @@ runtimeLiteral (TypeApply (TypeConstructorId 6) [child]) (RMaybe value) = do
Right ("MAYBE<" ++ renderTypeExpr child ++ ">(" ++ item ++ ")")
runtimeLiteral (TypeApply (TypeConstructorId 7) fields) (RTuple values)
| length fields == length values = do
items <- sequence (zipWith runtimeLiteral fields values)
items <- zipWithM runtimeLiteral fields values
Right ("TUPLE<" ++ intercalate ", " (map renderTypeExpr fields) ++ ">(" ++ intercalate ", " items ++ ")")
runtimeLiteral _ _ = Left "runtime value does not match its type expression"
@@ -200,9 +200,7 @@ loadServerConfigAt path = do
Just value | not (T.null (T.strip value)) -> T.unpack (T.strip value)
_ -> fallback
-- | 取一个键的整数值
intOf key fallback = case Map.lookup key values >>= readMaybe . T.unpack . T.strip of
Just number -> number
Nothing -> fallback
intOf key fallback = fromMaybe fallback (Map.lookup key values >>= readMaybe . T.unpack . T.strip)
pure
defaultServerConfig
{ scHost = textOf "listen_host" (scHost defaultServerConfig)
@@ -17,6 +17,7 @@ module ChuSQL.Interface.Session (
accounts,
) where
import Data.Foldable (for_)
import ChuSQL.Interface.Normalization
import qualified Data.Aeson as A
import ChuSQL.Core.Protocol (Account, QueryResult (..), TableInfo)
@@ -103,9 +104,8 @@ runStatement session sql = do
case answer of
Left message -> pure (Left message)
Right result -> do
case qrDatabase result of
Just name -> writeIORef (ssCurrent session) name
Nothing -> pure ()
for_
(qrDatabase result) (writeIORef (ssCurrent session))
pure (Right result)
-- | 数据字典(\\dt 与 \\d 用)
@@ -36,12 +36,13 @@ writeSection path section values = do
prepared <- prepareDirectory
case prepared of
Left err -> pure (Left err)
Right () -> do
exists <- doesFileExist path
raw <- if exists then TE.decodeUtf8 <$> BS.readFile path else pure ""
Right () -> do exists <- doesFileExist path
raw <- if exists then
TE.decodeUtf8 <$> BS.readFile path
else
pure ""
let updated = T.unlines (rewrite section values (T.lines raw))
written <- tryWrite (TE.encodeUtf8 updated)
pure written
tryWrite (TE.encodeUtf8 updated)
where
-- | 目录不存在就先建
prepareDirectory = do
@@ -111,7 +112,7 @@ rewrite :: Text -> Map Text Text -> [Text] -> [Text]
rewrite section values = addMissing . replaceInSection . dropEmpties
where
-- | 删掉空值的键
dropEmpties = filter (\line -> maybe True (not . T.null . snd) (assignment line))
dropEmpties = filter (maybe True (not . T.null . snd) . assignment)
-- | 在目标分区里就地换行
replaceInSection = go ""
-- | 走到目标分区后逐行替换
@@ -158,7 +159,7 @@ keysOf wanted = go ""
appendSection :: Text -> [(Text, Text)] -> [Text] -> [Text]
appendSection section entries lines' =
lines'
++ (if null lines' || not (T.null (last lines')) then [""] else [])
++ (["" | null lines' || not (T.null (last lines'))])
++ ("[" <> section <> "]") : [assignmentLine key value | (key, value) <- entries]
-- | 全局配置文件的固定路径,跟随系统惯例
+15 -13
View File
@@ -2,6 +2,7 @@
module Main (main) where
import Control.Monad (when)
import ChuSQL.Core.Engine.Storage.FFI (storageVersion)
import ChuSQL.Core.Engine.Storage.IPC (closeConnection, localStorageLink, setStorageLink)
import ChuSQL.Interface.Config (
@@ -22,7 +23,7 @@ import ChuSQL.Server.TCP (
newServerEnv,
runServer,
)
import Control.Exception (IOException, bracket, try)
import Control.Exception (IOException, try, bracket_)
import qualified Data.Aeson as A
import qualified Data.Aeson.KeyMap as KM
import Data.Text (Text)
@@ -177,7 +178,8 @@ run opts = do
(fromIntegral (wcLoginWindow cfg))
env <- newServerEnv backend rootName configPath config limiter
let announce port = putStrLn ("listening: tcp://" ++ scHost config ++ ":" ++ show port)
bracket (pure link) (const closeConnection) (const (serve env announce))
bracket_
(pure link) closeConnection (serve env announce)
-- | 起 TCP 服务并处理绑定失败
serve :: ServerEnv -> (Int -> IO ()) -> IO ()
@@ -211,17 +213,17 @@ checkInitialized backend = do
reportCredential :: Backend -> Text -> Bool -> IO ()
reportCredential backend rootName legacy = do
putStrLn ("administrator: " ++ T.unpack rootName)
if legacy
then do
putStrLn " !! the [web] section still carries a plaintext password key; it is ignored now"
putStrLn " !! remove it: the administrator password lives in the __system_users system table"
else pure ()
when legacy
$ do putStrLn
" !! the [web] section still carries a plaintext password key; it is ignored now"
putStrLn
" !! remove it: the administrator password lives in the __system_users system table"
passwordless <- administratorPasswordless backend rootName
if passwordless
then do
putStrLn " !! the administrator has no password yet: sign in with an empty password, then set one"
putStrLn " !! ALTER USER root IDENTIFIED BY '...' (or use the account page in the Web UI)"
else pure ()
when passwordless
$ do putStrLn
" !! the administrator has no password yet: sign in with an empty password, then set one"
putStrLn
" !! ALTER USER root IDENTIFIED BY '...' (or use the account page in the Web UI)"
-- | 探测存储是否可用,答不上 ping 就退出
checkStorage :: Backend -> IO ()
@@ -239,7 +241,7 @@ printBanner cfg config configPath = do
version <- storageVersion
putStrLn "================== ChuSQL Server ==================="
putStrLn ("config file: " ++ configPath)
putStrLn ("protocol: chusql 1 (one JSON object per line)")
putStrLn "protocol: chusql 1 (one JSON object per line)"
putStrLn
( "limits: message "
++ show (scMaxMessage config)
+3 -3
View File
@@ -119,7 +119,7 @@ validateUserName name
-- | 校验新身份的名称
validateNewName :: Accounts -> Text -> Either AccountError ()
validateNewName _ name = validateUserName name
validateNewName _ = validateUserName
storageFailure :: AccountError
storageFailure = AccountError "storage_error" "account storage unavailable"
@@ -300,7 +300,7 @@ accountCommand _ = Nothing
-- | 按目录管理权限执行账号命令
runAccountCommand :: Accounts -> Principal -> AccountCommand -> IO (Either AccountError ())
runAccountCommand service principal command = withMVar (acLock service) $ \_ -> run
runAccountCommand service principal command = withMVar (acLock service) $ const run
where
-- | 校验并执行身份管理权限
run
@@ -323,7 +323,7 @@ runAccountCommand service principal command = withMVar (acLock service) $ \_ ->
privilegedChange (AlterAccountAttributes _ attributes) = any (\(key, _) -> key `elem` ["superuser", "system_catalog_manager", "allow_sudo_auth"]) attributes
privilegedChange _ = False
-- | 执行已授权的身份命令
execute = executeWith (if principalIsRoot principal then service else service{acBackend = (acBackend service){beAccounts = \request -> beAccounts (acBackend service) (ReqCatalogManage request)}})
execute = executeWith (if principalIsRoot principal then service else service{acBackend = (acBackend service){beAccounts = beAccounts (acBackend service) . ReqCatalogManage}})
-- | 通过受限存储请求执行管理操作
executeWith managed = case command of
CreateAccount name _ | normalize name == "public" -> pure (Left (AccountError "bad_request" "public is reserved for default privileges"))
+28 -21
View File
@@ -21,6 +21,7 @@ module ChuSQL.Server.Backend (
tableRefsOf,
) where
import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
import ChuSQL.Core.Engine (runStatement, runStatementM)
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Semantic (prepare)
@@ -40,7 +41,7 @@ import ChuSQL.Core.Engine.Storage.IPC (
import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
import ChuSQL.Core.Protocol (TxnOp (..))
import Control.Concurrent.MVar (MVar, modifyMVar, readMVar)
import Control.Concurrent.MVar (MVar, modifyMVar)
import Data.List (nub, isPrefixOf)
import Data.Text (Text)
import Data.Time (getCurrentTime)
@@ -75,16 +76,20 @@ data Backend = Backend
-- | 按给定列名取列,固定列顺序
columnsFromStatement :: Database -> Statement -> [String]
columnsFromStatement db stmt = case prepare db stmt of
Right (SelectDistinct q) -> columnsFromStatement db q
Right (Select items _ _ _ _ _) -> map fst items
Right ShowDomains -> ["domain", "base_type"]
_ -> []
Left _ -> []
Right resolved -> columnsOf resolved
where
-- | 从已准备的语句提取输出列名
columnsOf (SelectDistinct q) = columnsOf q
columnsOf Select{selectItems = items} = map fst items
columnsOf ShowDomains = ["domain", "base_type"]
columnsOf _ = []
-- | 走本地存储链路的后端
ipcBackend :: IO Backend
ipcBackend = do
let backend current = Backend
{ beStatement = \sql -> runIpc current sql
{ beStatement = runIpc current
, beCatalog = do
response <- sendRequest (ReqInDatabase current ReqListCatalog)
pure $ case response of
@@ -107,7 +112,7 @@ ipcBackend = do
RespTables names -> Right names
RespError err -> Left err
_ -> Left "unexpected database response"
, beStorage = \payload -> runRaw payload
, beStorage = runRaw
, beSnapshot = runIPCStorageIn snapshot (sessionEnv current)
, beApplyTransaction = \ops -> do
response <- sendRequest (ReqInDatabase current (ReqApplyTransaction ops))
@@ -149,9 +154,9 @@ ipcBackend = do
cols <- case rows of
[] -> do
db <- runIPCStorageIn schema env
pure (fmap (\structures -> columnsFromStatement structures stmt) db)
pure (fmap (`columnsFromStatement` stmt) db)
(r : _) -> pure (Right (map fst r))
pure (fmap (\names -> StatementResult names rows) cols)
pure (fmap (`StatementResult` rows) cols)
-- | 测试用内存后端,状态是一个 Database
memoryBackend :: String -> MVar Database -> Backend
@@ -331,10 +336,12 @@ statementTables stmt = nub (case stmt of
SelectDistinct q -> statementTables q
Select{} ->
tableRefsOf (selectFrom stmt)
++ concatMap exprTables (maybe [] (: []) (selectWhere stmt) ++ map snd (selectItems stmt) ++ map Col (selectGroupBy stmt ++ map fst (selectOrderBy stmt)))
++ concatMap exprTables (maybeToList (selectWhere stmt) ++ maybeToList (selectHaving stmt)
++ map snd (selectItems stmt) ++ map Col (selectGroupBy stmt)
++ mapMaybe (orderKeyExpression . fst) (selectOrderBy stmt))
Insert table _ rows -> T.pack table : concatMap exprTables (concat rows)
Update table assigns cond -> T.pack table : concatMap exprTables (map snd assigns ++ maybe [] (: []) cond)
Delete table cond -> T.pack table : concatMap exprTables (maybe [] (: []) cond)
Update table assigns cond -> T.pack table : concatMap exprTables (map snd assigns ++ maybeToList cond)
Delete table cond -> T.pack table : concatMap exprTables (maybeToList cond)
CreateTable table _ -> [T.pack table]
DropTable table -> [T.pack table]
CreateIndex table _ -> [T.pack table]
@@ -368,12 +375,12 @@ statementNeedsDatabase stmt = case stmt of
-- | 将当前库限定的结构目标转为裸表名
scopeDdl :: String -> Statement -> Either String Statement
scopeDdl current statement = case statement of
CreateTable table columns -> (\key -> CreateTable key columns) <$> target table
CreateTable table columns -> (`CreateTable` columns) <$> target table
DropTable table -> DropTable <$> target table
CreateIndex table column -> (\key -> CreateIndex key column) <$> target table
DropIndex table column -> (\key -> DropIndex key column) <$> target table
DropColumn table column -> (\key -> DropColumn key column) <$> target table
AddColumn table column -> (\key -> AddColumn key column) <$> target table
CreateIndex table column -> (`CreateIndex` column) <$> target table
DropIndex table column -> (`DropIndex` column) <$> target table
DropColumn table column -> (`DropColumn` column) <$> target table
AddColumn table column -> (`AddColumn` column) <$> target table
RenameColumn table old new -> (\key -> RenameColumn key old new) <$> target table
AlterColumnType table column ty -> (\key -> AlterColumnType key column ty) <$> target table
AlterColumnDefault table column value -> (\key -> AlterColumnDefault key column value) <$> target table
@@ -554,10 +561,10 @@ memoryAccounts db stamp req = do
| any ((== T.toLower u) . accountUser) accounts -> Left "identity already exists"
| otherwise -> Right (accounts ++ [Account (highWater + 1) (T.toLower u) "" 1 stamp Nothing False False True False False])
ReqIdentityAlter u login super enabled manager sudo -> case filter ((== T.toLower u) . accountUser) accounts of
[_] -> preserveSuper [if accountUser a == T.toLower u then a{accountCanLogin = maybe (accountCanLogin a) id login,
accountIsSuperuser = maybe (accountIsSuperuser a) id super, accountEnabled = maybe (accountEnabled a) id enabled,
accountSystemCatalogManager = maybe (accountSystemCatalogManager a) id manager,
accountAllowSudoAuth = maybe (accountAllowSudoAuth a) id sudo,
[_] -> preserveSuper [if accountUser a == T.toLower u then a{accountCanLogin = fromMaybe (accountCanLogin a) login,
accountIsSuperuser = fromMaybe (accountIsSuperuser a) super, accountEnabled = fromMaybe (accountEnabled a) enabled,
accountSystemCatalogManager = fromMaybe (accountSystemCatalogManager a) manager,
accountAllowSudoAuth = fromMaybe (accountAllowSudoAuth a) sudo,
accountRevision = accountRevision a + 1} else a | a <- accounts] accounts
_ -> Left "unknown account"
ReqAccountCreate u h
+3 -2
View File
@@ -23,6 +23,7 @@ module ChuSQL.Server.Catalog
, removeMember
) where
import Control.Monad (void)
import ChuSQL.Core.Model (Row, Value (..))
import ChuSQL.Core.Protocol (Account (..), Request (..))
import ChuSQL.Interface.Actions (escapeStringLiteral)
@@ -112,11 +113,11 @@ readIdentities catalog = beAccounts (catBackend catalog) ReqAccountsList
-- | 新建一个角色
insertRole :: Catalog -> Text -> IO (Either String ())
insertRole catalog role = fmap (fmap (const ())) (beAccounts (catBackend catalog) (ReqRoleCreate (normalizeRole role)))
insertRole catalog role = fmap void (beAccounts (catBackend catalog) (ReqRoleCreate (normalizeRole role)))
-- | 删掉一个角色,连同它的授权与成员边
dropRole :: Catalog -> Text -> IO (Either String ())
dropRole catalog role = fmap (fmap (const ())) (beAccounts (catBackend catalog) (ReqAccountDrop (normalizeRole role)))
dropRole catalog role = fmap void (beAccounts (catBackend catalog) (ReqAccountDrop (normalizeRole role)))
-- | 全部授权,都不带 grant option
readGrants :: Catalog -> IO (Either String [Grant])
@@ -2,6 +2,7 @@
module ChuSQL.Server.Normalization (normalizationBudget, normalizationReport, schemaFingerprint) where
import Data.Maybe (fromMaybe)
import qualified ChuSQL.Core.Engine.Normalization as N
import ChuSQL.Core.Model (Column (..), parseColumnType)
import ChuSQL.Core.Protocol (SchemaColumn (..), valueToJSON)
@@ -40,7 +41,7 @@ normalizationBudget action = mask $ \restore -> do
Right value -> do
size <- evaluate (BL.length (BL.take 64001 (A.encode value)))
pure (if size > 64000 then Left ("too_large", "normalization report exceeds transport budget") else Right value)
pure (maybe (Left ("timeout", "normalization exceeded its five second budget")) id result)
pure (fromMaybe (Left ("timeout", "normalization exceeded its five second budget")) result)
-- 编码只影响语义的列信息。
fingerprintColumn :: SchemaColumn -> A.Value
+23 -10
View File
@@ -6,6 +6,8 @@ module ChuSQL.Server.ObjectACL
, objectSelfViews, objectReconcile, objectAffected, objectOwner, objectConnect, objectPrepareCreate, objectUsers
) where
import Data.Either (fromRight)
import Control.Monad (void)
import ChuSQL.Core.Protocol (Account (..), TableInfo (..))
import ChuSQL.Interface.Protocol (Grant (..))
import ChuSQL.Server.Accounts (Principal, principalIsRoot, principalName)
@@ -79,12 +81,12 @@ identifier _ = Left "invalid object identifier"
resolve :: Backend -> Text -> Text -> IO (Either String Target)
resolve backend database raw = do
let object = T.toLower (T.strip raw)
(selected, table, kind, label) =
if "database:" `T.isPrefixOf` object then (T.drop 9 object, Nothing, "database", object)
else if object == "*" || ".*" `T.isSuffixOf` object then
(selected, table, kind, label)
| "database:" `T.isPrefixOf` object = (T.drop 9 object, Nothing, "database", object)
| object == "*" || ".*" `T.isSuffixOf` object =
let scope = if object == "*" then database else T.dropEnd 2 object
in (scope, Nothing, "tables", scope <> ".*")
else case T.splitOn "." object of
| otherwise = case T.splitOn "." object of
[name] -> (database, Just name, "table", database <> "." <> name)
[db, name] -> (db, Just name, "table", object)
_ -> ("", Just "", "table", object)
@@ -102,7 +104,7 @@ targets backend = do
names <- beDatabases backend
case names of
Left err -> pure (Left err)
Right databases -> fmap (fmap concat . sequence) $ mapM one (filter (/= "system") databases)
Right databases -> fmap concat . sequence <$> mapM one (filter (/= "system") databases)
where
-- 展开一个数据库和它的表。
one name = do
@@ -150,7 +152,12 @@ knownRole env value = value `elem` ["0", "public"] || any (\account -> T.pack (s
roles :: Context -> Text -> [Text]
roles env value = nub ("public" : go [value])
where
pairs = [(parent, child) | (parentName, childName) <- contextMembers env, Right parent <- [roleId env parentName], Right child <- [roleId env childName], active env parent, active env child]
pairs = [(parent, child) |
(parentName, childName) <- contextMembers env,
Right parent <- [roleId env parentName],
active env parent,
Right child <- [roleId env childName],
active env child]
-- 展开成员关系的向上闭包。
go known = let more = [parent | (parent, child) <- pairs, child `elem` known, parent `notElem` known]
in if null more then known else go (nub (known ++ more))
@@ -208,7 +215,7 @@ readACL backend = do
-- 原子写入权限快照并检查并发版本。
writeACL :: Backend -> Maybe Text -> ACL -> IO (Either String ())
writeACL backend expected acl = fmap (fmap (const ())) $ request backend (A.object ["method" A..= ("object_acl_replace" :: Text), "expected" A..= expected, "payload" A..= TE.decodeUtf8 (BL.toStrict (A.encode acl))])
writeACL backend expected acl = void <$> request backend (A.object ["method" A..= ("object_acl_replace" :: Text), "expected" A..= expected, "payload" A..= TE.decodeUtf8 (BL.toStrict (A.encode acl))])
-- 将旧名称授权一次性绑定到现存对象。
migrate :: Backend -> Catalog -> Context -> IO (Either String ACL)
@@ -269,7 +276,10 @@ privileges target names =
if all (`elem` supported) expanded then Right expanded else Left "invalid privilege for object scope"
where
supported = if targetKind target == "database" then ["connect", "create"] else ["select", "insert", "update", "delete"]
expanded = nub (concatMap (\name -> if name == "all" then supported else [name]) (map T.toLower names))
expanded = nub (concatMap
((\ name -> if name == "all" then supported else [name])
. T.toLower)
names)
-- 检查一组稳定对象上的业务权限。
objectAuthorize :: Backend -> Catalog -> Principal -> Text -> [(Text, Text)] -> IO (Either String ())
@@ -299,8 +309,11 @@ objectGrant backend catalog principal database names object role option = do
Right ((env, previous, acl), target) -> case do
recipient <- roleId env role
items <- privileges target names
grantor <- if principalIsRoot principal then Right (either (const "0") id (roleId env (principalName principal))) else roleId env (principalName principal)
case [item | item <- items, not (principalIsRoot principal), not (allowed env acl grantor target item True)] of
grantor <- if principalIsRoot principal then Right (fromRight "0" (roleId env (principalName principal))) else roleId env (principalName principal)
case [item |
not (principalIsRoot principal),
item <- items,
not (allowed env acl grantor target item True)] of
item : _ -> Left ("grant option required: " ++ T.unpack (T.toUpper item <> " ON " <> object))
[] -> Right (recipient, grantor, items) of
Left err -> pure (Left err)
+1 -1
View File
@@ -1,4 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Server.Policy (
configurePasswordPolicy,
+14 -10
View File
@@ -6,11 +6,12 @@ module ChuSQL.Server.Privileges
, newPrivileges, normalizeObject, privilegeCommand, runPrivilegeCommand, claimObject, prepareObject, reconcileObjects, affectedObject
) where
import Data.Maybe (maybeToList)
import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Protocol (Account (..))
import ChuSQL.Interface.Protocol (Grant (..), RoleView (..))
import ChuSQL.Server.Accounts (Principal, principalIsRoot, principalIsCatalogManager)
import ChuSQL.Server.Backend (Backend (..), exprTables, tableRefsOf, systemDatabaseName)
import ChuSQL.Server.Backend (Backend (..), exprTables, statementTables, systemDatabaseName)
import ChuSQL.Server.Catalog
import qualified ChuSQL.Server.ObjectACL as OA
import Data.List (nub, sort)
@@ -70,7 +71,7 @@ runPrivilegeCommand service principal database command = withTables service $ ca
Left err -> pure (Left err)
Right () -> eachAction members $ \member -> if (normalizeRole role, normalizeUser member) `elem` pairs then pure (Right ()) else catalog (addMember directory role member)
RevokeRoleCommand role members
| principalIsRoot principal -> after (eachAction members (\member -> catalog (removeMember directory role member)))
| principalIsRoot principal -> after (eachAction members (catalog . removeMember directory role))
_ -> pure (Left forbidden)
where
backend = pvBackend service
@@ -146,7 +147,7 @@ authorizeConnect service principal database
authorizeTables :: Privileges -> Principal -> Text -> [(Text, Text)] -> IO (Either PrivilegeError ())
authorizeTables service principal database needed
| principalIsRoot principal = pure (Right ())
| T.null database && any (not . T.isPrefixOf "database:" . fst) needed = pure (Left (PrivilegeError "no_database" "no database selected"))
| T.null database && (not . all (T.isPrefixOf "database:" . fst)) needed = pure (Left (PrivilegeError "no_database" "no database selected"))
| otherwise = withTables service $ do
connected <- if T.null database then pure (Right ()) else catalog (OA.objectConnect (pvBackend service) (pvCatalog service) principal database)
case connected of Left err -> pure (Left err); Right () -> catalog (OA.objectAuthorize (pvBackend service) (pvCatalog service) principal database needed)
@@ -172,7 +173,12 @@ listRoleViews service = withTables service $ do
members <- catalog (readMembers (pvCatalog service))
case (,) <$> names <*> members of
Left err -> pure (Left err)
Right (identities, pairs) -> fmap sequence $ mapM (view pairs) (sort (map accountUser (filter (not . accountCanLogin) identities)))
Right (identities, pairs) -> sequence
<$>
mapM
(view pairs)
(sort
(map accountUser (filter (not . accountCanLogin) identities)))
where
-- 组装一个角色的公开权限视图。
view members name = do
@@ -199,14 +205,12 @@ reconcileObjects service = withTables service (catalog (OA.objectReconcile (pvBa
requiredActions :: Statement -> Maybe [(Text, Text)]
requiredActions statement = case statement of
SelectDistinct q -> requiredActions q
Select{} -> Just (selectNeeds (selectFrom statement) (maybe [] (: []) (selectWhere statement) ++ map snd (selectItems statement)))
Select{} -> Just [(ref, "select") | ref <- statementTables statement]
Insert table _ rows -> Just ((T.pack table, "insert") : selectsOf (concat rows))
Update table assignments condition -> Just ((T.pack table, "update") : selectsOf (map snd assignments ++ maybe [] (: []) condition))
Delete table condition -> Just ((T.pack table, "delete") : selectsOf (maybe [] (: []) condition))
Update table assignments condition -> Just ((T.pack table, "update") : selectsOf (map snd assignments ++ maybeToList condition))
Delete table condition -> Just ((T.pack table, "delete") : selectsOf (maybeToList condition))
_ -> Nothing
where
-- 收集来源树和表达式的读取权限。
selectNeeds source expressions = [(ref, "select") | ref <- nub (tableRefsOf source)] ++ selectsOf expressions
-- 收集表达式中子查询的读取权限。
selectsOf expressions = [(ref, "select") | ref <- nub (concatMap exprTables expressions)]
@@ -218,7 +222,7 @@ withTables service action = withCatalogLock (pvCatalog service) $ do
-- 将目录结果转换为权限错误。
catalog :: IO (Either String a) -> IO (Either PrivilegeError a)
catalog action = fmap (either (Left . storageError) Right) action
catalog = fmap (either (Left . storageError) Right)
-- 分类稳定对象目录的明确错误。
storageError :: String -> PrivilegeError
+3 -2
View File
@@ -1,5 +1,6 @@
module ChuSQL.Server.Security (readSecurity, writeSecurity) where
import Control.Monad (when)
import Control.Concurrent.MVar
import Control.Exception (bracket_, mask_)
import System.IO.Unsafe (unsafePerformIO)
@@ -21,11 +22,11 @@ readSecurity = bracket_ enter leave
(turn, room, readers) = securityGate
-- 登记共享读取者。
enter = withMVar turn $ \_ -> modifyMVar_ readers $ \count -> do
if count == 0 then takeMVar room else pure ()
when (count == 0) $ takeMVar room
pure (count + 1)
-- 释放最后一个共享读取者。
leave = mask_ $ modifyMVar_ readers $ \count -> do
if count == 1 then putMVar room () else pure ()
when (count == 1) $ putMVar room ()
pure (count - 1)
-- 独占执行权限或对象变更。
+10 -5
View File
@@ -29,12 +29,17 @@ module ChuSQL.Server.Session
) where
import ChuSQL.Core.Model (Database, Row, Table (..), Value (..), Column (..), typeName)
import ChuSQL.Core.Protocol (SchemaColumn (..))
import ChuSQL.Core.Protocol
( SchemaColumn(..),
Account(..),
Request(..),
QueryResult(..),
TxnOp(..),
queryResultJson )
import ChuSQL.Interface.Normalization
import ChuSQL.Server.Normalization (normalizationBudget, normalizationReport)
import Data.Aeson.Types (parseEither)
import qualified Data.ByteString.Lazy as BL
import ChuSQL.Core.Protocol (Account (..), Request (..), QueryResult (..), TxnOp (..), queryResultJson)
import ChuSQL.Core.Engine.Storage.IPC (TableInfo (..))
import qualified ChuSQL.Core.Engine as Engine
import qualified ChuSQL.Core.Engine.Error as E
@@ -51,7 +56,7 @@ import Control.Exception (IOException, try)
import Data.Bifunctor (first)
import Data.Char (isAlpha, isAlphaNum)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe (isJust)
import Data.Maybe (isJust, fromMaybe)
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
import Data.Text (Text)
@@ -831,7 +836,7 @@ privilegeMessage (PrivilegeError _ message) = message
-- | 只带库名的空结果
emptyResult :: Maybe Text -> QueryResult
emptyResult database = QueryResult [] [] 0 False database
emptyResult = QueryResult [] [] 0 False
-- | 存储结果转成查询结果
resultOf :: StatementResult -> QueryResult
@@ -845,7 +850,7 @@ resultOf result =
}
where
-- | 按列名取单元格
cellOf row name = maybe VNull id (lookup name row)
cellOf row name = fromMaybe VNull (lookup name row)
-- 展示当前登录身份自己的有效权限。
+17 -12
View File
@@ -1,3 +1,5 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Server.TCP (
@@ -29,12 +31,12 @@ import ChuSQL.Server.Privileges (newPrivileges, reconcileObjects)
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
import Control.Exception (IOException, bracket, finally, onException, try)
import Control.Monad (filterM, void)
import Control.Monad (filterM, void, when)
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy.Char8 as BLC
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Maybe (fromMaybe, isNothing)
import Data.Text (Text)
import qualified Data.Text as T
import Network.Socket (
@@ -171,11 +173,14 @@ enableSudo :: ServerEnv -> Int -> IO ()
enableSudo env port
| T.null user = pure ()
| not (isPlainIdentifier user) = ioError (userError "sudo_auth_user must be a plain identity name")
| otherwise = modifyMVar_ (srvSudo env) $ \current -> case current of
Just _ -> ioError (userError "sudo authentication is already running")
Nothing -> do
credential <- createSudoCredential port
hPutStrLn stderr ("sudo_auth enabled: local elevated identity -> " ++ T.unpack user)
| otherwise = modifyMVar_ (srvSudo env) $ \case
Just _
-> ioError (userError "sudo authentication is already running")
Nothing
-> do credential <- createSudoCredential port
hPutStrLn
stderr
("sudo_auth enabled: local elevated identity -> " ++ T.unpack user)
pure (Just (port, user, credential))
where
user = scSudoUser (srvConfig env)
@@ -254,7 +259,7 @@ serveConnection env conn = do
hSetNewlineMode h noNewlineTranslation
entry <- newLiveEntry (isLocalPeer peer)
unregister <- registerConnection (srvLive env) entry
session <- newSessionWith (srvBackend env) (srvRootName env) (srvSettingsFile env) (\names -> void (dropConnectionsOf (srvLive env) names))
session <- newSessionWith (srvBackend env) (srvRootName env) (srvSettingsFile env) (void . dropConnectionsOf (srvLive env))
outcome <- try (loop h session entry BSC.empty `finally` unregister) :: IO (Either IOException ())
case outcome of
Left err | not (isEOFError err) -> hPutStrLn stderr ("connection error: " ++ show err)
@@ -275,7 +280,7 @@ serveConnection env conn = do
else do
(response, keepGoing) <- dispatch env session entry request
send h response
if keepGoing then loop h session entry remaining else pure ()
when keepGoing $ loop h session entry remaining
-- | 发一条响应并冲缓冲
send h response = do
BLC.hPutStr h (encodeResponse response)
@@ -322,7 +327,7 @@ dispatch env session entry request = case request of
configured <- readMVar (srvSudo env)
who <- sessionUser session
case configured of
Just _ | leLocal entry && who == Nothing -> do
Just _ | leLocal entry && isNothing who -> do
nonce <- sudoChallenge
now <- getCurrentTime
writeIORef (leChallenge entry) (Just (nonce, now))
@@ -376,13 +381,13 @@ dispatch env session entry request = case request of
-- 消费一次性证明并登录本机映射账号。
sudoLogin :: ServerEnv -> Session -> LiveEntry -> Text -> Text -> IO ServerResponse
sudoLogin env session entry user proof = do
challenge <- atomicModifyIORef' (leChallenge entry) (\value -> (Nothing, value))
challenge <- atomicModifyIORef' (leChallenge entry) (Nothing,)
configured <- readMVar (srvSudo env)
now <- getCurrentTime
who <- sessionUser session
let key = T.toLower (T.strip user)
mapped = maybe "" (\(_, name, _) -> name) configured
valid = leLocal entry && who == Nothing && key == mapped
valid = leLocal entry && isNothing who && key == mapped
&& case configured of
Just (_, _, credential) -> validSudoChallenge credential now challenge key proof
Nothing -> False
+57 -23
View File
@@ -3,6 +3,7 @@
module Main (main) where
import Data.Either (lefts)
import ChuSQL.Core.Engine.Storage.IPC (
Account (..),
Request (ReqAccountCreate, ReqAccountReset, ReqAccountsList, ReqIdentityAlter),
@@ -55,7 +56,7 @@ import Control.Concurrent (forkIO, forkFinally, killThread, threadDelay)
import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, takeMVar)
import System.Timeout (timeout)
import Control.Exception (IOException, bracket, finally, try)
import Control.Monad (replicateM_, void)
import Control.Monad (replicateM_, void, (>=>), when)
import Data.List (sort)
import Data.Aeson (decode)
import qualified Data.Aeson as A
@@ -244,7 +245,9 @@ identitySpec = describe "unified identities" $ do
asText (at "status" shown) `shouldBe` "result"
switched <- tcpQuery manager "use system"
asText (at "status" switched) `shouldBe` "result"
mapM_ (\sql -> tcpQuery manager sql >>= \reply -> asText (at "code" reply) `shouldBe` "forbidden")
mapM_ (tcpQuery manager
>=>
(\ reply -> asText (at "code" reply) `shouldBe` "forbidden"))
["alter user manager superuser", "alter user managed system_catalog_manager", "alter user managed allow_sudo_auth", "alter user admin identified by 'Another-Pass123!'", "create database forbidden"]
it "does not inherit catalog management through role membership" $ withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \admin -> withConnection handle $ \worker -> do
@@ -309,7 +312,9 @@ identitySpec = describe "unified identities" $ do
it "protects the last enabled login superuser" $ withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \h -> do
_ <- tcpLogin h "admin" "s3cret"
mapM_ (\sql -> tcpQuery h sql >>= \reply -> asText (at "code" reply) `shouldBe` "bad_request")
mapM_ (tcpQuery h
>=>
(\ reply -> asText (at "code" reply) `shouldBe` "bad_request"))
["alter user admin disabled", "alter role admin nologin", "alter user admin nosuperuser", "drop user admin", "drop role admin"]
shown <- tcpQuery h "show roles"
asText (at "status" shown) `shouldBe` "result"
@@ -406,7 +411,7 @@ testRootPassword = "s3cret"
-- | 口令哈希:迭代次数压低,跑得快
testPasswordHash :: Text -> Text
testPasswordHash raw = hashPasswordWith 1000 (BS.replicate 16 7) raw
testPasswordHash = hashPasswordWith 1000 (BS.replicate 16 7)
-- 小工具
@@ -461,7 +466,8 @@ tempSettingsPath name = do
removeIfExists :: FilePath -> IO ()
removeIfExists path = do
there <- doesFileExist path
if there then void (try (removeFile path) :: IO (Either IOException ())) else pure ()
when there
$ void (try (removeFile path) :: IO (Either IOException ()))
-- | 起一台内存后端的测试服务器:管理员已设口令 `s3cret`
withTcpServer :: ServerConfig -> (ServerEnv -> ServerHandle -> IO a) -> IO a
@@ -485,7 +491,7 @@ withTcpServerAs password config body = do
-- | 连上服务器并配成行缓冲句柄
withConnection :: ServerHandle -> (Handle -> IO a) -> IO a
withConnection handle body = bracket open closeQuietly body
withConnection handle = bracket open closeQuietly
where
-- | 关连接,忽略异常
closeQuietly h = do
@@ -893,9 +899,9 @@ privilegeSpec = describe "server privileges" $ do
_ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
_ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["all"] "*" "reader" False)
views <- listRoleViews service
fmap (concatMap (map grantPrivilege) . map roleGrants) views
fmap (concatMap (map grantPrivilege . roleGrants)) views
`shouldBe` Right ["select", "insert", "update", "delete"]
fmap (concatMap (map grantObject) . map roleGrants) views `shouldBe` Right (replicate 4 "test.*")
fmap (concatMap (map grantObject . roleGrants)) views `shouldBe` Right (replicate 4 "test.*")
it "revokes a privilege again" $ withPrivileges $ \service root -> do
_ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
@@ -1061,6 +1067,16 @@ privilegeSpec = describe "server privileges" $ do
authorizeSql service (Ordinary testAccount) "SELECT name FROM users WHERE id > ANY (SELECT id FROM orders)"
`shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON orders")
it "requires SELECT on subqueries in HAVING and expression ordering" $ withPrivileges $ \service root -> do
_ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
_ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" False)
_ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
mapM_ (\sql -> authorizeSql service (Ordinary testAccount) sql
`shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON orders"))
[ "SELECT COUNT(*) FROM users HAVING COUNT(*) > (SELECT COUNT(*) FROM orders)"
, "SELECT name FROM users ORDER BY (SELECT COUNT(*) FROM orders) + id"
]
it "lists the accounts a role change touches, members included" $ withPrivileges $ \service root -> do
_ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
_ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "inner")
@@ -1202,7 +1218,8 @@ objectPrivilegeSpec = describe "stable object privileges" $ do
finished <- newEmptyMVar
revoked <- newEmptyMVar
let slow = backend{beWithDatabase = \name -> (beWithDatabase backend name){beStatement = \sql -> do
if sql == "SELECT * FROM users" then putMVar started () >> takeMVar release else pure ()
when (sql == "SELECT * FROM users")
$ putMVar started () >> takeMVar release
beStatement (beWithDatabase backend name) sql}}
settings <- tempSettingsPath "permission-race"
reader <- newSession slow testRootName settings
@@ -1501,11 +1518,11 @@ sessionAge session wanted = do
-- | 取失败里的文案
failureMessage :: Either SessionError QueryResult -> Text
failureMessage outcome = either sessMessage (const "") outcome
failureMessage = either sessMessage (const "")
-- | 取失败里的错误码
failureCode :: Either SessionError QueryResult -> Text
failureCode outcome = either sessCode (const "") outcome
failureCode = either sessCode (const "")
-- | 取结果第一列的整数
intValues :: [[Value]] -> [Int]
@@ -1556,7 +1573,7 @@ transactionSpec = describe "server transactions" $ do
tables <- beCatalog backend
fmap (map tiTable) tables `shouldBe` Right ["users"]
updated <- beStatement backend "UPDATE users SET id = 3"
fmap (const ()) updated `shouldBe` Right ()
void updated `shouldBe` Right ()
snapshot <- beSnapshot (memoryBackend "other" ref)
fmap (map (tableRows . snd)) snapshot `shouldBe` Right [[[ ("id", VInt 2) ]]]
it "keeps catalog and snapshot identities stable across system views and replacements" $ do
@@ -1574,11 +1591,11 @@ transactionSpec = describe "server transactions" $ do
it "preserves memory schema versions in catalogs and snapshots" $ do
ref <- newMVar []
let backend = memoryBackend "test" ref
fmap (const ()) <$> beStatement backend "CREATE TABLE versioned (id INT)" `shouldReturn` Right ()
void <$> beStatement backend "CREATE TABLE versioned (id INT)" `shouldReturn` Right ()
first <- beCatalog backend
fmap (map tiSchemaVersion) first `shouldBe` Right [Just 1]
fmap (const ()) <$> beStatement backend "ALTER TABLE versioned ADD COLUMN extra TEXT" `shouldReturn` Right ()
fmap (const ()) <$> beStatement backend "ALTER TABLE versioned DROP COLUMN extra" `shouldReturn` Right ()
void <$> beStatement backend "ALTER TABLE versioned ADD COLUMN extra TEXT" `shouldReturn` Right ()
void <$> beStatement backend "ALTER TABLE versioned DROP COLUMN extra" `shouldReturn` Right ()
current <- beCatalog backend
snapshot <- beSnapshot backend
fmap (map tiSchemaVersion) current `shouldBe` Right [Just 3]
@@ -1687,6 +1704,23 @@ transactionSpec = describe "server transactions" $ do
late <- runStatementCoded session "commit"
failureMessage late `shouldBe` "no transaction in progress"
it "rejects UPDATE constraints without changing or ending the transaction" $ withMemorySession $ \session -> do
_ <- mustSql session "CREATE TABLE constrained_updates (id INT PRIMARY KEY, qty INT NOT NULL UNIQUE)"
_ <- mustSql session "INSERT INTO constrained_updates (id, qty) VALUES (1, 2), (2, 3)"
_ <- mustSql session "BEGIN"
mapM_ (\(query, marker) -> do
result <- runStatementCoded session query
failureMessage result `shouldSatisfy` T.isInfixOf marker)
[("UPDATE constrained_updates SET qty = NULL WHERE id = 1", "NOT NULL")
, ("UPDATE constrained_updates SET qty = 3 WHERE id = 1", "UNIQUE")
, ("UPDATE constrained_updates SET id = 2 WHERE id = 1", "UNIQUE")]
unchanged <- mustSql session "SELECT qty FROM constrained_updates ORDER BY id"
intValues (qrRows unchanged) `shouldBe` [2, 3]
_ <- mustSql session "UPDATE constrained_updates SET qty = qty + 1"
_ <- mustSql session "COMMIT"
committed <- mustSql session "SELECT qty FROM constrained_updates ORDER BY id"
intValues (qrRows committed) `shouldBe` [3, 4]
it "does not switch database inside a transaction" $ withMemorySession $ \session -> do
_ <- mustSql session "begin"
denied <- runStatementCoded session "use other"
@@ -1880,10 +1914,10 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
let alpha = beWithDatabase base "alpha"
beta = beWithDatabase base "beta"
unselected <- beStatement base "CREATE TABLE alpha.t (id INT)"
fmap (const ()) unselected `shouldBe` Left "no database selected"
void unselected `shouldBe` Left "no database selected"
mustRun (beStatement alpha "CREATE TABLE alpha.t (id INT, value INT)")
duplicate <- beStatement alpha "CREATE TABLE t (id INT)"
fmap (const ()) duplicate `shouldSatisfy` either (const True) (const False)
void duplicate `shouldSatisfy` either (const True) (const False)
mustRun (beStatement alpha "INSERT INTO t (id, value) VALUES (1, 7)")
mustRun (beStatement alpha "CREATE INDEX ON alpha.t (value)")
mustRun (beStatement alpha "DROP INDEX ON alpha.t (value)")
@@ -1894,7 +1928,7 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
rows <- rowsOf (beStatement alpha "SELECT score FROM t")
intColumn "score" rows `shouldBe` [7]
crossed <- beStatement beta "DROP TABLE alpha.t"
fmap (const ()) crossed `shouldBe` Left "DDL target is outside the current database: alpha.t"
void crossed `shouldBe` Left "DDL target is outside the current database: alpha.t"
mustRun (beStatement alpha "ALTER TABLE alpha.t DROP COLUMN score")
mustRun (beStatement alpha "DROP TABLE alpha.t")
catalog <- beCatalog alpha >>= either fail pure
@@ -1903,7 +1937,7 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
it "isolates domain catalogs by database and hides them from table lists" $ withIpcStorage $ do
base <- ipcBackend
unselected <- beStatement base "SHOW DOMAINS"
fmap (const ()) unselected `shouldBe` Left "no database selected"
void unselected `shouldBe` Left "no database selected"
mustRun (beStatement base "CREATE DATABASE alpha")
mustRun (beStatement base "CREATE DATABASE beta")
let alpha = beWithDatabase base "alpha"
@@ -1919,7 +1953,7 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
domains <- rowsOf (beStatement beta "SHOW DOMAINS")
domains `shouldBe` [[("domain", VStr "code"), ("base_type", VStr "varchar(3)")]]
refused <- beStatement beta "INSERT INTO typed (id) VALUES (1)"
fmap (const ()) refused `shouldSatisfy` either (const True) (const False)
void refused `shouldSatisfy` either (const True) (const False)
it "resolves nested domains only inside their own database" $ withIpcStorage $ do
base <- ipcBackend
@@ -1930,12 +1964,12 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
mustRun (beStatement alpha "CREATE DOMAIN label AS VARCHAR(3)")
mustRun (beStatement alpha "CREATE DOMAIN product_label AS label")
absent <- beStatement beta "CREATE DOMAIN product_label AS label"
fmap (const ()) absent `shouldBe` Left "unknown domain: label"
void absent `shouldBe` Left "unknown domain: label"
mustRun (beStatement alpha "CREATE TABLE products (name product_label)")
mustRun (beStatement alpha "INSERT INTO products (name) VALUES ('abc')")
rowsOf (beStatement alpha "SELECT name FROM products") `shouldReturn` [[("name", VStr "abc")]]
dependency <- beStatement alpha "DROP DOMAIN label"
fmap (const ()) dependency `shouldSatisfy` either (const True) (const False)
void dependency `shouldSatisfy` either (const True) (const False)
it "keeps two databases apart" $ withIpcStorage $ do
base <- ipcBackend
@@ -1965,7 +1999,7 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
_ <- forkIO (writeRows alpha [1 .. 20] doneA)
_ <- forkIO (writeRows beta [101 .. 120] doneB)
outs <- sequence [takeMVar doneA, takeMVar doneB]
[err | Left err <- concat outs] `shouldBe` []
lefts (concat outs) `shouldBe` []
rowsA <- rowsOf (beStatement alpha "SELECT id FROM p")
rowsB <- rowsOf (beStatement beta "SELECT id FROM p")
intColumn "id" rowsA `shouldMatchList` [1 .. 20]
+6 -5
View File
@@ -2,6 +2,7 @@
module Main (main) where
import Control.Monad (when)
import ChuSQL.Web.API (AppEnv (..), Live (..), newAppEnvAt, setLive, webApp)
import ChuSQL.Interface.Auth (SessionPolicy (..), setPayloadPolicy)
import ChuSQL.Interface.Config (
@@ -248,11 +249,11 @@ serve settings app = do
reportCredential :: WebConfig -> Bool -> IO ()
reportCredential cfg legacy = do
putStrLn ("administrator: " ++ T.unpack (rootUserName cfg))
if legacy
then do
putStrLn " !! the [web] section still carries a plaintext password key; it is ignored now"
putStrLn " !! remove it: the administrator password lives in the __system_users system table"
else pure ()
when legacy
$ do putStrLn
" !! the [web] section still carries a plaintext password key; it is ignored now"
putStrLn
" !! remove it: the administrator password lives in the __system_users system table"
-- | ping 一次 server,报告它通不通
checkServer :: Text -> Int -> IO ()
+15 -13
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Web.API (
@@ -20,6 +21,7 @@ module ChuSQL.Web.API (
newAppEnvAt,
) where
import Data.Either (fromRight)
import ChuSQL.Core.Model (Row, Value (..))
import ChuSQL.Core.Engine.Syntax.AST (Statement (BeginTransaction, CommitTransaction, RollbackTransaction))
import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
@@ -113,7 +115,7 @@ import ChuSQL.Web.UISettings (
import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, withMVar)
import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (IOException, try)
import Control.Monad (forever, when)
import Control.Monad (forever, when, unless)
import Data.Aeson (FromJSON (..), eitherDecode, object, withObject, (.:), (.=))
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as K
@@ -124,7 +126,7 @@ import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
import Data.List (nub, sortBy)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Maybe (catMaybes, fromMaybe)
import Data.Maybe (catMaybes, fromMaybe, isJust)
import Data.Scientific (fromFloatDigits)
import Data.Text (Text)
import qualified Data.Text as T
@@ -244,13 +246,13 @@ reservedDatabase name = name == systemDatabase
resolveSettingsFileSafe :: IO FilePath
resolveSettingsFileSafe = do
found <- try defaultConfigFile :: IO (Either IOException FilePath)
pure (either (const "settings.toml") id found)
pure (fromRight "settings.toml" found)
-- | 定位 IDE 设置文件,找不到就定下首个候选路径
resolveUISettingsFileSafe :: IO FilePath
resolveUISettingsFileSafe = do
found <- try resolveUISettingsFile :: IO (Either IOException FilePath)
pure (either (const fallbackUISettingsFile) id found)
pure (fromRight fallbackUISettingsFile found)
where
fallbackUISettingsFile = case uiSettingsFileCandidates of
(p : _) -> p
@@ -271,8 +273,8 @@ liveBodyLimit env = lvBodyLimit <$> readLive env
-- | 组装 WAI 应用:路由外套四层中间件
webApp :: AppEnv -> IO Application
webApp env = do
started <- atomicModifyIORef' (aeReaperStarted env) (\old -> (True, old))
when (not started) $ do
started <- atomicModifyIORef' (aeReaperStarted env) (True,)
unless started $ do
_ <- forkIO $ forever $ do
threadDelay 60000000
sweepWebSessions env
@@ -358,7 +360,7 @@ withDatabase env action = do
else do
editing <- header "X-ChuSQL-Edit"
req <- request
let snapshotRead = editing /= Nothing && ((requestMethod req == "GET" && take 2 (pathInfo req) == ["api", "tables"])
let snapshotRead = isJust editing && ((requestMethod req == "GET" && take 2 (pathInfo req) == ["api", "tables"])
|| (requestMethod req == "POST" && pathInfo req == ["api", "normalization", "analyze"]))
console <- liftIO (readIORef (wsConsole ws))
caller <- consoleOwner
@@ -651,11 +653,11 @@ itemJson effectiveValues fileValues owner spec =
fromProcess = Map.lookup (siKey spec) effectiveValues
effectiveValue = fromMaybe (defaultOf (siKey spec)) fromProcess
shownValue = if secret then "" else fromMaybe effectiveValue fromFile
hasValue = fromFile /= Nothing
hasValue = isJust fromFile
source :: Text
source
| secret = if hasValue then "configured" else "not set"
| fromFile /= Nothing = "settings file"
| isJust fromFile = "settings file"
| otherwise = "default"
-- | 改设置:写配置文件并让可热改项立即生效
@@ -694,7 +696,7 @@ putSettingsH env = do
appliedNow = case reloaded of
Right _ -> nub (applied ++ [k | k <- policyKeys, Map.member k updates])
Left _ -> applied
needsRestart = [k | k <- Map.keys updates, not (k `elem` appliedNow), not (T.null (Map.findWithDefault "" k updates))]
needsRestart = [k | k <- Map.keys updates, k `notElem` appliedNow, not (T.null (Map.findWithDefault "" k updates))]
liftIO (aeLog env ("settings updated by " <> user <> ": " <> T.intercalate ", " (Map.keys updates)))
json
( object
@@ -890,7 +892,7 @@ baseDeleteH _env ws target = do
-- | 取一个列值
lookupValue :: Text -> [(String, Value)] -> Maybe Value
lookupValue name values = lookup (T.unpack name) values
lookupValue name = lookup (T.unpack name)
-- | 错误码 + 消息 → 状态码 + 统一错误体
apiError :: Text -> Text -> ActionM a
@@ -1727,7 +1729,7 @@ executeSql ws live sql = do
, "rowCount" .= qrRowCount res
, "truncated" .= (qrTruncated res || qrRowCount res > lvMaxRows live)
, "database" .= qrDatabase res
, "transaction" .= (transaction /= Nothing)
, "transaction" .= isJust transaction
]
)
@@ -1739,7 +1741,7 @@ requireUser env = wsUser <$> requireSession env
requestSessionToken :: ActionM (Maybe Text)
requestSessionToken = do
rawHeader <- header "Cookie"
pure (fmap TL.toStrict rawHeader >>= \h -> parseCookieHeader sessionCookieName h)
pure (rawHeader >>= parseCookieHeader sessionCookieName . TL.toStrict)
-- | 从 Cookie 头里取一个键(没有就给 Nothing)
parseCookieHeader :: Text -> Text -> Maybe Text
+2 -1
View File
@@ -8,6 +8,7 @@ module ChuSQL.Web.Secure (
bodyLimitDynamic,
) where
import Data.Maybe (isNothing)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.Text (Text)
@@ -28,7 +29,7 @@ import Network.Wai (Middleware, Request (..), mapResponseHeaders, responseLBS)
-- | 所有响应都带上的安全头
securityHeaders :: Middleware
securityHeaders app req respond =
app req (respond . mapResponseHeaders (\headers -> filter (\(name, _) -> name /= "Content-Security-Policy" || lookup name headers == Nothing) extraHeaders ++ headers))
app req (respond . mapResponseHeaders (\headers -> filter (\(name, _) -> name /= "Content-Security-Policy" || isNothing (lookup name headers)) extraHeaders ++ headers))
-- | 只给编辑器样式发随机 nonce
contentSecurityPolicy :: Maybe Text -> Text
+2 -1
View File
@@ -8,6 +8,7 @@ module ChuSQL.Web.UISettings (
writeUISettings,
) where
import Data.Maybe (fromMaybe)
import Control.Exception (IOException, try)
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as K
@@ -40,7 +41,7 @@ resolveUISettingsFile = do
Just path -> pure path
Nothing -> do
ready <- firstExistingDir uiSettingsFileCandidates
pure (maybe firstCandidate id ready)
pure (fromMaybe firstCandidate ready)
where
-- | 首选候选路径
firstCandidate = case uiSettingsFileCandidates of
+20 -22
View File
@@ -34,8 +34,8 @@ import ChuSQL.Web.Static (contentTypeOf, safeRelative)
import ChuSQL.Web.UISettings (validateUISettings)
import Control.Concurrent (forkFinally, forkIO)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import Control.Exception (IOException, bracket, throwIO, try)
import Control.Monad (when)
import Control.Exception (IOException, bracket, throwIO, try, bracket_)
import Control.Monad (when, unless)
import Data.Aeson (encode, object, (.=))
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as K
@@ -159,15 +159,15 @@ getAs hs path = requestAs methodGet path hs BL.empty
-- | 带 JSON 头发 POST 请求
postAs :: [Header] -> BS.ByteString -> BL.ByteString -> TestSession WT.SResponse
postAs hs path payload = requestAs methodPost path (jsonHeaders hs) payload
postAs hs path = requestAs methodPost path (jsonHeaders hs)
-- | 带 JSON 头发 PUT 请求
putAs :: [Header] -> BS.ByteString -> BL.ByteString -> TestSession WT.SResponse
putAs hs path payload = requestAs "PUT" path (jsonHeaders hs) payload
putAs hs path = requestAs "PUT" path (jsonHeaders hs)
-- | 带 JSON 头发 PATCH 请求
patchAs :: [Header] -> BS.ByteString -> BL.ByteString -> TestSession WT.SResponse
patchAs hs path payload = requestAs "PATCH" path (jsonHeaders hs) payload
patchAs hs path = requestAs "PATCH" path (jsonHeaders hs)
-- | 带头发 DELETE 请求
deleteAs :: [Header] -> BS.ByteString -> TestSession WT.SResponse
@@ -214,7 +214,7 @@ ensureDatabase hs name = do
listed <- getAs hs "/api/databases"
expectStatusWith "list databases" listed 200
let names = map asText (items (jsonBody listed))
when (name `notElem` names) $ do
unless (name `elem` names) $ do
created <- postAs hs "/api/databases" (encode (object ["name" .= name]))
expectStatusWith ("create database " <> T.unpack name) created 200
@@ -224,7 +224,7 @@ ensureTable hs name body = do
listed <- getAs (withDb testDatabaseName hs) "/api/tables"
expectStatusWith "list tables" listed 200
let names = map (asText . at "table") (items (jsonBody listed))
when (name `notElem` names) $ do
unless (name `elem` names) $ do
created <- postAs (withDb testDatabaseName hs) "/api/tables" body
expectStatusWith ("create table " <> T.unpack name) created 200
@@ -341,9 +341,7 @@ tempFilePath name = do
-- | 非重复后缀
uniqueSuffix :: IO String
uniqueSuffix = do
u <- newUnique
pure (show (hashUnique u))
uniqueSuffix = do show . hashUnique <$> newUnique
-- | 文件不存在也算成功
removeIfExists :: FilePath -> IO ()
@@ -723,8 +721,8 @@ catalogSpec env = describe "databases, tables and rows" $ do
check (arrayLen (at "columns" (jsonBody rows)) `shouldBe` 3)
check (arrayLen (at "rows" (jsonBody rows)) `shouldBe` 1)
check (asInt (at "total" (jsonBody rows)) `shouldBe` 1)
check (asInt (maybe A.Null id (nth 0 (firstRow rows))) `shouldBe` 1)
check (asText (maybe A.Null id (nth 1 (firstRow rows))) `shouldBe` "alice")
check (asInt (fromMaybe A.Null (nth 0 (firstRow rows))) `shouldBe` 1)
check (asText (fromMaybe A.Null (nth 1 (firstRow rows))) `shouldBe` "alice")
updated <-
patchAs
(withDb testDatabaseName hs)
@@ -732,7 +730,7 @@ catalogSpec env = describe "databases, tables and rows" $ do
(encode (object ["values" .= object ["note" .= ("changed" :: Text)]]))
expectStatusWith "update row" updated 200
again <- getAs (withDb testDatabaseName hs) "/api/tables/people/rows?limit=10"
check (asText (maybe A.Null id (nth 2 (firstRow again))) `shouldBe` "changed")
check (asText (fromMaybe A.Null (nth 2 (firstRow again))) `shouldBe` "changed")
it "deletes the row and then the table" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
@@ -932,7 +930,7 @@ roleSpec env = describe "roles and grants" $ do
listed <- getAs hs "/api/roles"
expectStatusWith "list roles" listed 200
let matching = [view | view <- items (jsonBody listed), asText (at "name" view) == "passer"]
check ((concatMap (map (asBool . at "grantable") . items . at "grants") matching) `shouldBe` [True])
check (concatMap (map (asBool . at "grantable") . items . at "grants") matching `shouldBe` [True])
refused <-
postAs
hs
@@ -1047,11 +1045,11 @@ querySpec env = describe "the SQL console" $ do
ensureDatabase hs testDatabaseName
result <- testSql hs "SELECT LIST<Int>(1, 2), length('abc')"
expectStatusWith "typed SQL values" result 200
let value = maybe A.Null id (nth 0 (firstRow result))
let value = fromMaybe A.Null (nth 0 (firstRow result))
envelope = at "__chusql_runtime_v1" value
check (arrayLen envelope `shouldBe` 3)
check (asInt (maybe A.Null id (nth 0 (items envelope))) `shouldBe` 1)
check (asInt (maybe A.Null id (nth 1 (firstRow result))) `shouldBe` 3)
check (asInt (fromMaybe A.Null (nth 0 (items envelope))) `shouldBe` 1)
check (asInt (fromMaybe A.Null (nth 1 (firstRow result))) `shouldBe` 3)
it "runs DDL and DML and returns positional rows" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
@@ -1063,7 +1061,7 @@ querySpec env = describe "the SQL console" $ do
expectStatusWith "select by SQL" res 200
check (asInt (at "rowCount" (jsonBody res)) `shouldBe` 1)
check (arrayLen (at "columns" (jsonBody res)) `shouldBe` 2)
check (asText (maybe A.Null id (nth 1 (firstRow res))) `shouldBe` "seven")
check (asText (fromMaybe A.Null (nth 1 (firstRow res))) `shouldBe` "seven")
it "refuses an empty statement" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
@@ -1267,10 +1265,10 @@ editSpec env = describe "web editing transactions" $ withApp (webApp env) $ do
let token = fromMaybe "" (lookup "Cookie" hs >>= parseCookieHeader sessionCookieName . TE.decodeUtf8)
stored <- liftIO (lookupPayload (aeSessions env) token)
app <- getState
res <- liftIO $ bracket
(setPayloadPolicy (aeSessions env) (SessionPolicy (-1) 86400))
(const (setPayloadPolicy (aeSessions env) defaultSessionPolicy))
(const (editFromApp app hs "expires" []))
res <- liftIO $ bracket_
(setPayloadPolicy (aeSessions env) (SessionPolicy (- 1) 86400))
(setPayloadPolicy (aeSessions env) defaultSessionPolicy)
(editFromApp app hs "expires" [])
expectStatusWith "expired commit" res 401
case stored of
Nothing -> check (expectationFailure "missing live web session")
+22 -5
View File
@@ -27,7 +27,7 @@ flowchart LR
| chusql-core/storage | catalog、页面、B+ 树、缓存、WAL 与持久化 |
| csql-bootstrap | 安装引导及离线系统目录修复、恢复、重置 |
查询 AST 的 `Select` 使用 `selectItems :: [(String, Expr)]` 保存输出名称与投影表达式;普通列使用 `Col`,别名、计算和聚合使用相同结构。便捷函数 `makeSelect` 接受列名列表并构造这些投影项。
查询 AST 的 `Select` 使用 `selectItems :: [(String, Expr)]` 保存输出名称与投影表达式,`selectHaving` 保存分组条件;`OrderKey` 明确区分名称、输出序号和表达式。普通列使用 `Col`,别名、计算和聚合使用相同结构。便捷函数 `makeSelect` 接受列名列表并构造这些投影项。
服务默认监听 127.0.0.1:7777,Web 默认监听 127.0.0.1:7778。配置位置和平台数据目录见 [config.md](config.md)。
@@ -57,16 +57,33 @@ flowchart LR
绑定查询保存依赖对象编号、schema 版本、列定义和传递 DOMAIN 依赖。执行前复查,真实存储的每次读取还在相关库读锁内验证全部依赖;结构改变或对象替换明确报错。守卫不提供整条多请求查询的数据快照;旧目录的未知身份/版本保留兼容校验,旧存储未确认守卫则拒绝执行。
查询由 `Runtime.Query.bindQuery` 统一准备并绑定,输出按位置校验,保留重复列名。优化完成后将表达式、排序及分组键绑定到输入布局;物理列顺序不同会在存储边界整理,缺列或位置不符明确报错。`ORDER BY` 输出序号保留到计划生成,选择对应投影表达式或 DISTINCT 输出槽位,不通过别名再次查找;非排序投影仍在 LIMIT 后求值。
聚合计划合并投影、HAVING 和排序表达式中的当前层聚合,重复调用只计算一次,内部列使用 SQL 标识符无法声明的名称。HAVING 强制形成分组(无键时为整体组),过滤位于 Aggregate 之后、去重与排序截断之前。表达式排序先计算隐藏排序键并保留投影所需列,再排序、截断和投影;DISTINCT 排序映射到已有输出槽位。HAVING 和排序子查询同样参与结构依赖守卫与 SELECT 权限检查。
相关子查询按最近到最远的独立列作用域查找,最近层歧义不向外回退;二段限定引用只在最近声明该来源的层解析,裸列可继续向外查找。`BoundSubquery` 保存父布局中的取值表达式,缓存按槽位和值区分;重绑定保留局部和外层身份,原位置失效时只允许唯一同名列重定位。执行期外层行仍扁平化,尚无独立作用域或来源编号,结构改写须在绑定前完成。
写语句按目标 schema 绑定输入表达式和赋值目标。INSERT 拒绝重复目标列,按输入顺序求值,再按 schema 顺序补默认值、NULL 和自增值;UPDATE 的重复赋值读取前一次修改结果,全部赋值后检查 CHECK,再检查最终行集的 NOT NULL、UNIQUE 和 PRIMARY KEY。唯一性检查保留整数与整值浮点的一致语义,多个 NULL 不冲突;检查通过前不发布修改。CHECK、非空和唯一性按列槽位取值,INSERT 已有行及引擎 ALTER 输入行按原 schema 整理,缺列不跳过。
INSERT、UPDATE、DELETE 和已有表的结构变更由 `Engine.bindWrite` 生成不保存数据行的 `BoundWrite`,`executeWriteM` 在执行前复查结构,允许跨数据及统计变化复用。DML 在绑定阶段固定 INSERT 输入槽位、UPDATE 目标槽位、DELETE 行布局和 CHECK / NOT NULL / UNIQUE / PRIMARY KEY 约束;复用时不重新解析或绑定这些内容,自增起点与行集约束仍取当前数据。结构变更则在执行时对变更后的 schema 绑定并检查约束。计划携带目标表、嵌套查询及传递 DOMAIN 依赖;ADD COLUMN / ALTER TYPE 还包含新声明类型的 DOMAIN。建表、建删库、DOMAIN 管理和会话命令继续走各自入口,不属于已有表写计划。
写入前先发送只读的 `validate_write` 请求,确认存储支持写守卫并校验依赖;未确认时不发送实际修改请求。实际读取在相关库共享门内复查,实际写入在目标库独占门及其他依赖库共享门内复查,跨库按库名排序取门。对象替换或结构版本变化使旧绑定失效,包括结构改变后恢复原定义。守卫保证结构校验与单次存储操作之间不发生 DDL,不提供整条写语句的数据快照或数据冲突检测。
CHECK 定义和执行共用类型、函数及列槽位绑定入口,拒绝聚合、子查询和非布尔条件。DROP COLUMN 校验保留下来的 CHECK;RENAME COLUMN 不自动改写约束文本,引用旧名称的 CHECK 会使改名被拒绝。ALTER TYPE 依据新 schema 校验 CHECK、默认值和键能力,空表也不跳过定义校验;通过定义校验后仍检查已有行,再发布结构变更。
| 能力 | 实现与边界 |
| --- | --- |
| 派生表 | 内层独立解析,必须有别名,不能引用外层列;输出列按别名暴露 |
| WITH / CTE | 解析时展开为派生表;不支持递归或物化,多次引用分别执行 |
| WITH / CTE | 解析时展开为派生表;相同执行子树在查询内物化复用,不支持递归 |
| ANY / ALL | 按 OR / AND 的三值逻辑求值;空集的 ANY 为假、ALL 为真 |
| 子查询复用 | Filter 和计算列按外层绑定分组;JOIN 条件按首次遇到的绑定惰性复用 |
| 子查询复用 | 按查询定义及外层绑定值物化结果,跨过滤、投影、排序与 JOIN 复用 |
| 半连接 / 反连接 | 独立 IN / NOT IN 与简单等值相关 EXISTS / NOT EXISTS 转为哈希存在性匹配,只输出左行 |
| 成本估算 | 使用行数、不同值数和数值列的 16 桶等宽直方图 |
| 索引选择 | 优化器判断适用条件与成本,存储层管理实际索引 |
派生表可根据 schema 和透明算子估计行数并参与安全的连接重排;缺统计或可能报错时保守处理。输出列投影可下推,但保留所有计算项的求值,避免隐藏错误。内存存储提供实时行数和封顶去重统计。JOIN 条件的子查询在首次遇到外层绑定时求值,缓存仅限当前连接;空行对不触发求值,普通条件仍逐行计算。尚无半连接或通用物化。统计信息只影响计划选择,优化不能改变查询结果语义。
派生表可根据 schema 和透明算子估计行数并参与安全的连接重排;缺统计或可能报错时保守处理。输出列投影可下推,但保留所有计算项的求值,避免隐藏错误。内存存储提供实时行数和封顶去重统计。执行器用查询内状态保存首次使用时成功求出的子查询行;键包含已解析查询定义与具名外层绑定值,跨不同父布局复用,原始名称调用保守包含整个外层行。派生表按执行子树和外层行缓存,应用来源别名前复用,优化后子树不同则分别执行。标量、IN、EXISTS 和 ANY / ALL 各自处理共享行集,保留基数错误和三值逻辑。缓存在每次执行时清空,不跨会话或数据修改保留;既有表达式分组求值顺序保持,JOIN 空行对仍不触发子查询。尚无磁盘溢出或物化内存预算,也不提供整条查询的数据快照。统计信息只影响计划选择,优化不能改变查询结果语义。
`SemiJoin` 分别绑定两侧键,只暴露左侧布局;执行左侧为空时不求右侧,其他情况完整求右侧并构建键集合,按原左行顺序过滤,右侧重复键不会放大结果。独立 IN 保存原子查询身份,继续共享其他消费者的物化结果;NOT IN 跟踪右侧 NULL,NOT EXISTS 的空值键则视作不匹配。大整数与浮点混合比较超出安全哈希范围时退回既有逐值比较。重写只覆盖单独过滤谓词:IN 左键限普通列或简单字面量;相关 EXISTS 限单表、唯一外层等值引用和普通列/简单字面量投影。组合谓词、复杂相关条件、聚合、排序截断及可能报错的相关投影继续走原路径,避免改变错误时序和词法作用域。
完整 SQL 写法及限制见 [syntax.md](syntax.md)。
@@ -138,7 +155,7 @@ TCP 连接在下一次请求时返回 unauthorized 并关闭;空闲连接不
| 方向 | 前置条件与边界 |
| --- | --- |
| 通用子查询物化 | 缓存绑定对象/schema、外层值及快照,保留惰性求值和首次错误;限制内存、执行预算及取消 |
| 物化资源控制 | 在查询内物化基础上增加内存预算、磁盘溢出及取消;与完整查询快照协调 |
| 递归 CTE | 先实现类型一致的迭代关系,明确去重、循环终止、轮次与行数预算;不隐含支持写入型 CTE |
### 存储扩展
+19 -5
View File
@@ -18,10 +18,18 @@
### SELECT 与派生表
- `SELECT` 支持 `WHERE`、`ORDER BY`、`LIMIT`、`JOIN` / `LEFT JOIN`、`GROUP BY` 与聚合,以及标量 / `IN` / `EXISTS` 子查询和量词比较(`op ANY` / `op ALL`)。
- `SELECT` 支持 `WHERE`、`GROUP BY`、`HAVING`、`ORDER BY`、`LIMIT`、`JOIN` / `LEFT JOIN` 与聚合,以及标量 / `IN` / `EXISTS` 子查询和量词比较(`op ANY` / `op ALL`)。
- 来源可以是派生表:`SELECT d.name FROM (SELECT name FROM users) d`。派生表必须带别名,内层不能引用外层列;输出列取裸列名(内层写 `u.id`,外层用 `d.id` 引用)。
- 投影列可以起别名:`SELECT count(*) AS total FROM orders ORDER BY total`,别名就是结果集的列名。`ORDER BY` 优先使用唯一的投影别名,再查来源列;重复的排序别名报歧义错误,来源列可以用限定名消除同名冲突。排序接受从 1 开始的输出列序号(例如 `ORDER BY 2 DESC`),在 `*` 展开后解析,零或越界序号报错;暂不接受任意表达式。
- 鉴权覆盖整棵来源树:查派生表时内层表也要有权限,只有外层引用的表有权限不够。
- 投影列可以起别名:`SELECT count(*) AS total FROM orders ORDER BY total`,别名就是结果集的列名。`ORDER BY` 的单独名称优先使用唯一的投影别名,再查来源列;重复的排序别名报歧义错误,来源列可以用限定名消除同名冲突。排序接受从 1 开始的输出列序号(例如 `ORDER BY 2 DESC`),在 `*` 展开后解析,零或越界序号报错。
- 排序也支持表达式、函数、聚合与子查询,例如 `ORDER BY age + 1 DESC`。复合表达式中的列名只查来源,不能引用输出别名;排序表达式在 LIMIT 前求值,其他投影在 LIMIT 后求值。NULL 升序在前、降序在后,同键保留原行序。
- `HAVING` 在聚合之后、DISTINCT / ORDER BY / LIMIT 之前过滤,只保留布尔真;支持未投影的聚合、子查询及外层相关列,不能引用投影别名。没有 GROUP BY 时 HAVING 形成一个整体组,空输入也有这个组;当前层未聚合的来源列必须出现在 GROUP BY 中。
- 鉴权覆盖整棵查询树:派生表、HAVING 与排序表达式中的子查询也要求内层表的 SELECT 权限。
```sql
SELECT user_id, SUM(amount) AS total FROM orders
GROUP BY user_id HAVING COUNT(*) > 1
ORDER BY SUM(amount) + user_id DESC LIMIT 10;
```
### DISTINCT 与 ALL
@@ -32,7 +40,7 @@ SELECT DISTINCT user_id FROM orders ORDER BY 1 LIMIT 10;
SELECT DISTINCT user_id + 1 AS next_id FROM orders ORDER BY next_id;
```
DISTINCT 的排序列必须出现在输出中;排序可使用输出别名、选出的来源列或输出列序号。缺少比较能力的 List / Maybe / Tuple 类型仍拒绝 DISTINCT。去重支持连接、聚合、子查询、CTE 和当前连接的事务快照。
DISTINCT 的排序项必须出现在输出中;排序可使用输出别名、选出的来源列、输出列序号或与投影完全相同的表达式。缺少比较能力的 List / Maybe / Tuple 类型仍拒绝 DISTINCT。去重支持连接、聚合、子查询、CTE 和当前连接的事务快照。
### 比较运算符
@@ -46,12 +54,18 @@ DISTINCT 的排序列必须出现在输出中;排序可使用输出别名、
- `ANY` 的空子查询为假、`ALL` 的空子查询为真;子查询里出现 `NULL` 时按 `AND` / `OR` 的三值规则,条件可能为 `NULL`(`WHERE` 里等同不通过)。
- 量词与运算符组合示例:`<> ALL` 与 `NOT IN` 同义,`<> ANY` 表示至少存在一个不相等的值。
### IN / EXISTS 的执行优化
独立 `IN` / `NOT IN` 过滤,以及单表等值相关 `EXISTS` / `NOT EXISTS` 过滤可使用哈希半连接/反连接:右侧只扫描一次,左侧行序和重复行保留,右侧重复值不会放大输出。复杂条件仍使用查询内物化及相关子查询路径;SQL 写法不变。
`NOT EXISTS` 保留没有匹配的行,包括空值键;`NOT IN` 的右侧出现 NULL 时,未匹配的非空键得到 NULL,过滤不通过。右侧为空时,IN 为假、NOT IN 为真,包括左值为 NULL 的情况;右侧非空时,NULL 左值按三值逻辑得到 NULL。表达式和半连接使用相同规则。
### WITH / CTE
- `WITH 名字 AS (SELECT …), 另一个 AS (SELECT …) SELECT … FROM 名字` 先定义再引用,名字可以带列清单(`WITH t(who) AS (SELECT name FROM users) …`)。
- `WITH` 在解析期就展开成派生表,所以引用处只能当普通表用:没有别名时用 CTE 名当限定名(`WITH t AS (…) SELECT t.name FROM t`)。
- 名字不分大小写;只能引用前面已经定义的 CTE,向前引用会当成普通表名去查(有同名表就用表,没有就报 `unknown table`)。
- 不支持递归 CTE,主语句与每个 CTE 都只能是 `SELECT`;同一个 CTE 被引用两次会各执行一次(不做物化)。
- 不支持递归 CTE,主语句与每个 CTE 都只能是 `SELECT`。重复引用时,相同执行子树在一次查询中物化复用;不同投影或优化后的子树仍分别执行,尚无 `MATERIALIZED` / `NOT MATERIALIZED` 语法。
- 鉴权同样覆盖 CTE 里的表:`WITH d AS (SELECT name FROM orders) …` 要求对 `orders` 有权限。
### 事务与保存点
+3 -3
View File
@@ -9,7 +9,7 @@ pwsh -NoProfile -File gate-check/run-gate.ps1 # 全量
pwsh -NoProfile -File gate-check/run-gate.ps1 -Clean # 先清各项目自己的构建工件
pwsh -NoProfile -File gate-check/run-gate.ps1 -Full # 连依赖副本一起清(最慢,怀疑旧产物复用时才用)
pwsh -NoProfile -File gate-check/run-gate.ps1 -NoLint # 跳过 cargo clippy
pwsh -NoProfile -File gate-check/run-gate.ps1 -Only server # 只跑一条车道:cargo|stack|comments
pwsh -NoProfile -File gate-check/run-gate.ps1 -Only stack # 只跑 Haskell 车道:cargo|stack|comments
```
## 车道与步骤
@@ -23,7 +23,7 @@ pwsh -NoProfile -File gate-check/run-gate.ps1 -Only server # 只跑一条车道
`build` 车道先跑完,再并行启动其余三条;这样动态库刷新与 Haskell 测试不会互相抢文件。
Web 步骤会先显式刷新该工程里的 model、engine、interface 与 server 本地依赖,再运行 Web 测试,避免构建工具依赖复用旧的注册库。刷新失败会使 Web 步骤失败,不继续测试。
Server 步骤先刷新该工程里的 model、engine 与 interface 本地依赖;Web 步骤先刷新 model、engine、interface 与 server,再运行对应模块测试,避免复用旧的注册库。刷新失败会使对应步骤失败,不继续测试。
## 退出码与日志
@@ -41,5 +41,5 @@ Web 步骤会先显式刷新该工程里的 model、engine、interface 与 serve
## 约定
- 门禁由项目所有者手动运行;agent 只跑模块级测试,不跑全量门禁。
- 局部改动运行受影响模块的规定测试;较大改动由 agent 运行全量门禁。
- 计数、验收状态与主线进度以 `.agents/context/progress.txt` 为准。
+2 -2
View File
@@ -54,10 +54,10 @@ switch ($Kind) {
}
'stack' {
Invoke-Step 'engine' $engine @('stack', 'test', 'chusql-core-engine', '--fast')
Invoke-Step 'server' (Join-Path $Root 'chusql-server') @('stack', 'test', 'chusql-server', '--fast')
Invoke-Step 'server' (Join-Path $Root 'chusql-server') @('stack', 'test', 'chusql-server', '--fast') @('chusql-core-model', 'chusql-core-engine', 'chusql-interface')
Invoke-Step 'web' (Join-Path $Root 'chusql-web') @('stack', 'test', 'chusql-web', '--fast') @('chusql-core-model', 'chusql-core-engine', 'chusql-interface', 'chusql-server')
Invoke-Step 'cli' (Join-Path $Root 'chusql-cli') @('stack', 'test', 'chusql-cli', '--fast')
Invoke-Step 'bootstrap' (Join-Path $Root 'chusql-bootstrap') @('stack', 'test', 'chusql-bootstrap', '--fast')
Invoke-Step 'bootstrap' (Join-Path $Root 'chusql-bootstrap') @('stack', 'test', 'chusql-bootstrap', '--fast') @('chusql-core-model', 'chusql-core-engine', 'chusql-interface')
}
'comments' {
$check = Join-Path $PSScriptRoot 'comment-check.ps1'