推进
This commit is contained in:
1 parent
a45e33f94b
commit
4b8c9d9e78
67 files changed
+2492
-817
No files matched your search
@@ -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 原文写入日志,外部代理和采集需自行配置。
|
||||
|
||||
@@ -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 时在线安装无法取得预编译资源。
|
||||
|
||||
@@ -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。局部改动验证受影响模块,较大改动执行全量门禁;当前工作区改动未提交。
|
||||
@@ -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。
|
||||
@@ -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
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
-- | 记录请求并返回指定响应
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
@@ -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
|
||||
|
||||
@@ -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"
|
||||
|
||||
@@ -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"
|
||||
@@ -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, .. }
|
||||
|
||||
@@ -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 { .. }
|
||||
|
||||
@@ -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
@@ -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)
|
||||
|
||||
@@ -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"))
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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,4 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
|
||||
module ChuSQL.Server.Policy (
|
||||
configurePasswordPolicy,
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
-- 独占执行权限或对象变更。
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
-- 展示当前登录身份自己的有效权限。
|
||||
|
||||
@@ -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
@@ -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]
|
||||
|
||||
@@ -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 ()
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
+19
-21
@@ -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
|
||||
res <- liftIO $ bracket_
|
||||
(setPayloadPolicy (aeSessions env) (SessionPolicy (- 1) 86400))
|
||||
(const (setPayloadPolicy (aeSessions env) defaultSessionPolicy))
|
||||
(const (editFromApp app hs "expires" []))
|
||||
(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
@@ -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
@@ -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` 有权限。
|
||||
|
||||
### 事务与保存点
|
||||
|
||||
@@ -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` 为准。
|
||||
@@ -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'
|
||||
|
||||
Reference in new issue
Block a user