Compare commits

..
6 Commits
Author SHA1 Message Date
ChuNa7a 30364b1c4b fix: fall back to ChuRepo for release installation and updates
build / build (push) Blocked by required conditions
tests / build (push) Waiting to run
tests / tests (push) Waiting to run
2026-10-15 23:05:00 +08:00
ChuNa7a 44766755d8 docs: add ChuRepo download and source installation alternatives
build / build (push) Blocked by required conditions
tests / build (push) Waiting to run
tests / tests (push) Canceled after 0s
2026-10-15 22:58:13 +08:00
ChuNa7a 4b8c9d9e78 推进
build / build (push) Blocked by required conditions
tests / build (push) Waiting to run
tests / tests (push) Canceled after 0s
2026-10-15 22:21:57 +08:00
LIm1tZz7 a45e33f94b 整理代码 2026-10-13 14:09:36 +08:00
LIm1tZz7 e87c4ee6a8 修复bug 2026-10-11 17:32:12 +08:00
LIm1tZz7 fc9bbc20e4 v26.10.2 修复bug,简化项目 2026-10-09 09:27:44 +08:00
127 changed files with 7187 additions and 2204 deletions

No files matched your search

+13
View File
@@ -0,0 +1,13 @@
# AI agent 协作资料
按任务读取,不将全部资料作为每次工作的上下文。
- 根目录 `AGENTS.md`:开发规则和测试入口。
- `context/progress.txt`:唯一进度、测试计数和验收来源。
- `context/known-issues.txt`:未解决限制;`design-decisions.txt`:现有设计约束。
- `context/main-roadmap.txt`:长期阶段;`side-branch-plan.txt`:近期任务及依赖。
- `skills/chusql-*/`:类型、存储、跨组件边界三个项目专用技能。
通用技能、安装锁文件及技能生成提示词仅保留在本地,不纳入版本控制。
`gate-check/` 为开发者和 CI 共用的门禁工具;`logs/` 为忽略的本地产物。
这些协作资料不参与应用构建、运行或发行打包。
+113
View File
@@ -0,0 +1,113 @@
# ChuSQL 当前设计决策
进度见 progress.txt,限制见 known-issues.txt,用户操作见 docs/。
## 架构与接口
- 用户文档按主题记录于 docs/commands.md、docs/types.md、docs/architecture.md 和 docs/install.md;只读范式入口已提供。后续实施 bound IR / DOMAIN,再推进物化、递归、MVCC、compact 和并行写;规划不代表现有能力。
- 范式迁移首版保留来源,拒绝 NULL、重复行与依赖不保持;发布目标须验证约束、完整重建并使用独立原子结构 WAL 组,不能复用禁止 DDL 的会话事务拼接执行。
- 发布真实性采用 TUF 元数据链与 Ed25519,初始 root 必须可信取得;离线验证不证明最新版本,操作系统原生代码签名另行接入。
- Web / CLI → server TCP → Haskell 引擎 → FFI → Rust 存储;server 独占数据目录,Haskell 库静态链接,存储为 cdylib。
- 引擎按 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 比较走三值逻辑;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,不物化;多次引用重复执行,以减少实现改动面。
- 比较及 ANY / ALL 使用独立 AST 节点,量词复用三值逻辑,空集 ANY=false、ALL=true。
- 子查询在 Filter / Compute 中按外层绑定分组复用,暂不引入半连接;扫描按页分片,至少 1000 行、最多 8 线程,结果保序,safe FFI 释放执行能力。
## 会话、事务与存储
- 每连接独立会话及工作库;短锁取得库句柄后执行,每库读写门控制可见性,表锁保护页,在用库不强行删除。
- BEGIN 物化当前库快照,事务内走内存执行,COMMIT 提交相对基线差分,ROLLBACK 丢弃快照。
- COMMIT 先跳过数据未修改的表,整数 id 用 IntMap / IntSet 查找差异与冲突;保留原行顺序及重复 id 的首行查找语义,冲突检查和提交操作共享一次差分。
- 有整数 id 时按键提交及检查写写冲突,无整数 id 时整表比对;未修改表不回写,冲突保留事务并返回 serialization_failure。
- 保存点保存不可变快照引用,同名取最近一层,回退 / 释放丢弃之后的点,结束清空;事务命令由会话层执行。
- WAL 先记录操作及提交标记,再应用、刷数据与 catalog、写检查点、截断;仅重放已提交且超过检查点的记录。
- WAL 帧保留长度、LSN、类型码、表名及 JSON payload,兼容旧记录;恢复按内容、schema 和文件存在性判断幂等。
- 检查点按库 LSN,前缀截断用同目录临时文件原子替换,未提交尾部直接截短;失败保留 WAL 并进入 recovery_required。
- 检查点采用同目录临时文件替换,长度必须为 8 字节;完整 WAL 帧损坏明确报错,尾部不完整帧保留撕裂处理。刷盘或检查点失败后封闭请求,重启重放已提交组。
- distinct 在封顶前按值引用计数维护,列封顶不清除其他列状态;直方图独立累计与递减,桶重映射导致删除目标为空时扣最近非空桶以保持总量。rebuild_stats 先扫描数值范围,再按固定边界计数,消除重建过程的桶重映射偏差并保持输入顺序无关。
- 表 / 索引 DDL 进 WAL,删表不重取已移除句柄;库建删不进 WAL,删除以墓碑目录收敛。
- 页内 compact 保持槽号及索引位置,死空间达到四分之一时自动整理;无隐藏列逐页整理,有隐藏列整表重写,不跨页填空以保留行序。
## 身份、权限与引导
- 对象标识使用数据库编号与库内表编号组合;数据库编号从 system catalog 的对象高水位分配,表编号从本库高水位分配,删除不降低计数器。对象解析只读取 catalog。
- 建表编号在 WAL 组写入前分配,随建表记录提交;目录应用时推进高水位,恢复使用日志编号。只有建表组复制操作列表,普通数据提交沿用借用列表。
- 用户是可登录角色,共用名称空间;identities 保存属性、时间、稳定编号及版本,users 只存编号和口令哈希,编号不复用。
- 最高权限按身份属性判断,不按名称、不继承;默认用户 LOGIN、角色 NOLOGIN,两者 NOSUPERUSER / ENABLED。保护最后一个启用的登录管理员。
- 仅旧格式迁移按管理员参数识别初始最高权限;旧账号保留信息,角色补编号,重名拒绝;身份、凭据及删除清理用同一 Accounts WAL。
- server 判定权限,目录封装于 Server.Catalog;角色成员取向上闭包,写入拒绝环。GRANT role TO member 表示 member 继承 role 权限。
- members 保持身份成员目录;对象授权存于受保护 __system_object_acl,使用稳定对象与身份编号,保存所有者、授予者和 grant option。CONNECT / CREATE 限数据库,四项数据权限限表或单库表范围;ALL 按作用域展开。
- PUBLIC 默认只提供业务数据库 CONNECT,可逐库撤销;CREATE 建表登记创建者所有权,数据库所有权不隐含他人表的数据权限。启用角色可继承所有权,不继承 SUPERUSER。
- 授权链从独立管理来源及所有权展开固定点;撤销清理无来源下游,保留独立来源,循环不能自持。禁用保留所有权和管理来源授权,停止权限贡献并清理失效下游。
- 旧名称授权仅迁移一次到现存稳定对象;旧全局 * 固定为当时现存表,缺失对象或身份清理,旧记录无授予者时使用管理来源。
- 权限快照按字符分块存储,比较旧快照后以同一 WAL 组替换;跨页及 Unicode 不受单行上限限制。普通存储入口隐藏并拒绝访问权限快照表。
- 服务端共享公平读写锁排序查询与权限变更;事务提交复查身份、权限和稳定对象。建表前写入创建者声明,启动时依据现存对象恢复所有权或清理未完成声明。
- 口令 / 属性推进 revision,权限变更预先展开受影响身份;TCP 只标记连接失效,下一请求回 unauthorized 后关闭,避免 Windows 阻塞句柄异步中断;登记在 finally 清理。
- 系统表统一 __system_ 前缀并分层保护,内部目录按白名单访问;旧名按文件先、catalog 后迁移,崩溃后可重复收敛。
- 安装先 bootstrap:建立 system、默认 root(LOGIN / SUPERUSER / ENABLED)、18 个内置名称,再起服务;引导请求不开放 TCP。
- 清单编入引导并与解析器测试比对;system.__system_types 保存名称、基础表示、参数能力、编号。重复引导保留口令并补齐类型,冲突或身份降权失败;类型建表与写入用同组 WAL。
- sudo 认证用独立 allow_sudo_auth 属性和显式 sudo_auth_user 映射;默认关闭,只有 SUPERUSER 能管理,不继承、不隐含权限。目录管理者不得管理启用该属性的身份。
- 选择操作系统保护的随机本机凭据与 TCP 一次性 HMAC 挑战,以复用三平台既有会话协议;Unix 只信任有效 UID 0,Windows 只信任提升 Administrators 令牌。双方校验内核回环地址,不接受客户端自报 OS 用户或 SUDO_USER。
- 本机凭据只存放于系统保护的端口专属目录,原生入口校验提升身份;实例重启重新生成,现存目录拒绝覆盖。此方案要求服务端也提升运行,以保证创建凭据时的操作系统保护边界。
- 挑战绑定账号、连接及实例,60 秒过期并在每次尝试时消费;证明常量时间比对,凭据不经网络发送。成功登录复用身份版本、登录时间及连接失效机制,审计不含凭据或证明。
- sudo 属性由 Accounts WAL 持久化,旧目录缺列触发身份快照重写,旧记录缺属性默认 false,已有的错误类型明确拒绝。
## 自定义类型
- 范式检查采用阿姆斯特朗属性闭包与子集枚举,候选键声明转为决定全关系的依赖;完整覆盖声明与领域原子性分别控制可证明结论,不从样本推断。二元 BCNF 建议按违反依赖无损拆分,投影依赖之并用于验证依赖保持。
- DOMAIN 命名基础类型,列编码 domain(名称,基础类型) 保留引用,值及索引沿用底层语义。
- 各库 __system_domain_<名称> 空目录表的 base 列保存定义,复用 catalog / DDL WAL;普通 SQL 隐藏并保护目录。
- 嵌套只引用当前库已有类型,语义层从 schema 递归解析并拒绝循环,存储写锁内逐层校验;删除检查类型间及间接列依赖。
- 类型 DDL 要求管理员、事务内禁止;约束与默认值后续扩展,暂不引入自定义函数 / 运算符。
- 运行时类型使用稳定构造器编号与结构化 TypeId,逻辑类型与 PhysicalType 分离;递归值使用版本 1 标签编码,读取时校验类型、形状及载荷。
- TypedExpression / TypedPlan 仅使用 schema 绑定,SQL BoundQuery 通过既有 RelOp 执行并按输出位置验证;输出类型保留嵌套 DOMAIN 名称,基础日期、时间戳及 Blob 保留兼容类型,函数结果不继承参数领域。
- TypedExpression 列引用保存输入 schema 槽位与诊断名称;独立求值要求行顺序匹配,TypedPlan 扫描边界校验并按 schema 排序,每层投影绑定到子计划输出。SQL RelOp 在优化后绑定表达式列槽位,投影单向转为 Compute,排序/分组转为 BoundSort/BoundAggregate,存储结果按算子布局排列;子查询局部列在前、外层绑定在后。绑定算子不参与后续投影下推;独立作用域身份仍待迁移。
- SQL 局部引用使用 ColumnSlot,外层引用使用 OuterColumnSlot 的相对位置及局部布局宽度。重新绑定外层引用只查询外层布局,避免同名局部捕获;语义输入拒绝执行槽位。外层行仍扁平化,多级词法作用域/来源编号另行迁移。
- BoundQuery 执行前重新取得 schema 并比较依赖对象身份、schema 版本及列定义,依赖覆盖全部嵌套子查询及来源列的传递 DOMAIN 定义。IPC 将依赖守卫限定在本次执行环境;扫描、分片、点查及范围读均在相关库读锁内复查全部依赖后读取,跨库读锁按库名排序,持有库引用防止删除。数据、统计和无关对象不参与比较;旧目录缺失版本时仍比较列定义,已知身份或版本丢失则拒绝。守卫响应必须明确确认,旧二进制忽略字段时拒绝;未实现守卫的后端明确报错,纯内存视图可直接执行。守卫不改变既有多请求查询的数据隔离语义。
- 内建函数先解析为稳定 FunctionId 并验证签名,再执行;SQL NULL 保留三值语义。缺少能力字典的运行时类型拒绝比较、排序、分组、极值、索引及唯一键声明。
- SQL 字面量生成返回明确错误,先验证运行时值与有限浮点;复合值在 Web 使用 SQL 修改。
## 配置、构建与发行
- Web 编辑在首个业务表加载时建立快照,在提交 / 回退时结束;既有大库基准 BEGIN 269.806 ms、COMMIT 376.345 ms,不按每次单元格编辑重建整库快照。
- Web 登录分别建立普通 API / SQL 和编辑连接,页面 / 数据库标识绑定编辑事务,SQL 事务另绑定查询标签;同 Cookie 请求串行执行。
- 编辑集保留在浏览器,提交从固定保存点重放;失败回退整个编辑集,冲突回滚并重新加载,成功回执去重;系统身份修改不进入数据事务。
- system_catalog_manager 只管理普通身份,不继承、不隐含业务访问权限;存储写锁内再次拒绝特权目标及特权属性修改。
- bootstrap 维护使用独占数据目录锁,在副本中修复并验证后保留原目录备份再发布;repair 不重放 WAL、不补初始化数据,原有数据文件必须字节一致。
- listen_host 是监听配置,static 固定为静态目录,管理员名由 --user 指定;data_dir 存数据,log_files 存日志,相对路径以启动目录解释。
- resources/chusql.toml 入库并打包,UI 设置样本不入库、不进包,运行时按 resources、上一级 resources、工作目录候选查找。
- 预编译包优先,server / 存储必装,Web / CLI 可选;Windows zip、Linux/macOS tar.gz。包内模板也放 resources/,按确切产物名打包并拒绝未知工件。
- 本地解包安装不联网,管理员名同时传 bootstrap 和 server;安装冒烟隔离配置并恢复用户 PATH,卸载可保留数据 / 配置。
- 门禁先刷新 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 原文写入日志,外部代理和采集需自行配置。
- BoundQuery 保存来源对象身份及列定义;DOMAIN 依赖从来源列递归展开,执行前复查。库 / 对象编号在 TableInfo 中输出十进制字符串,读取兼容旧数值,零对象编号表示无有效身份。
- 表级 schema_version 由 catalog 持久化,新表从 1 开始,旧目录缺失版本保留 0;结构变化递增,新增结构 WAL 记录保存确定目标版本,恢复不重新分配。线上使用精确十进制字符串并兼容数值输入,0 或缺失表示未知版本;IPC schema / 快照与内存 Server 保留版本,内存 DDL 同样递增并拒绝耗尽。
- 注释以 AGENTS.md 为准;原因写本文件,限制写 known-issues.txt,进度及计数只以 progress.txt 为准。
+56
View File
@@ -0,0 +1,56 @@
# ChuSQL 当前限制与风险
进度见 progress.txt,设计见 design-decisions.txt;仅记录未解决的限制。
## 事务、恢复与并发
- 事务是整库内存快照,不是行版本 MVCC;每会话一个事务,无嵌套事务,事务内禁止 DDL / USE。
- BEGIN / COMMIT 仍有整库快照传输与修改表比较成本,复测见 docs/performance.md。
- Web 首次加载业务表即固定编辑快照,同一登录会话只允许一个页面持有编辑事务;系统身份表只读,通过 SQL 管理。
- 页面关闭的回滚请求可能因断线未送达;此时按会话空闲 / 最长寿命过期清理,后台每分钟检查一次。编辑连接失效后必须重新登录,不能恢复旧快照。
- COMMIT 按整数 id 校验写写冲突,缺少整数 id 时整表比对及替换;冲突返回 serialization_failure,调用方回滚或重试,无自动重试或死锁检测。
- WAL 只有 redo,检查点按库 LSN 而非页 LSN,幂等恢复代价随数据量增长;库目录建删不走 WAL,删库用墓碑目录处理。
- recovery_required 期间除 Ping / SystemStatus 外请求被拒绝,需恢复后继续。
- 每库读共享、写独占,写入会阻塞同库跨表读取,尚无并行写。
- 权限变更只标记 TCP 连接失效,客户端下一次请求收到 unauthorized 后关闭,空闲连接不会立即断开;并发测试不证明性能提升。
## 查询与性能
- 基础成本及贪心连接重排,无动态规划或跨外连接重排;只在行序不可观察处重排。
- catalog 行数可能滞后,distinct 有上限;16 桶等宽直方图只统计数值并按闭区间估算,增量维护可能偏差,桶内分布仍为估算。
- 内存统计去重上限为 4096,暂不提供直方图或索引成本;派生表可从透明算子估计行数,含聚合或可能报错表达式时仍保守。投影下推保留所有计算项,不消除潜在错误。
- 查询内物化只在内存保存结果,尚无容量预算或磁盘溢出;既有按绑定分组求值可能更早报告同一错误。
- CTE 解析期展开,不支持递归、写语句或 MATERIALIZED / NOT MATERIALIZED 指定;不同优化子树不能共享物化。只能引用前面定义的 CTE,前向引用按普通表名解析。
- 半连接重写尚未覆盖组合谓词、复杂相关条件、多键、相关聚合或排序截断;可能报错的相关投影继续走原执行路径。
- 并行只覆盖页区间扫描:schema 至少 1000 行、最多 8 线程,无页内并行,统计滞后可退回顺序扫描。
- compact 不填跨页空洞,含隐藏列时仍需整表重写。
## 权限与兼容性
- 对象权限快照整体写入,鉴权会读取身份、成员和对象元数据;尚未针对大规模权限目录做性能基准。
- 对象高水位损坏或回退后无法恢复已删除对象的编号上限;旧二进制会丢弃新增目录字段,不应降级使用已升级的数据目录。
- 无列级权限、所有权转移或角色 ADMIN OPTION。
- 旧授权缺少授予来源,迁移为管理来源;旧全局 * 只绑定迁移时现存表。没有身份改名命令;已有同名 public 身份在删除前不会解析为虚拟 PUBLIC。
- 尚无 CREATEDB / CREATEROLE、继承开关、口令到期、连接上限或 Web 专门的身份属性编辑界面。
- 旧账号与角色重名会阻止迁移;迁移后的身份目录与 DOMAIN 编码不支持旧二进制。更早的 __chusql_users 无自动迁移。
- 旧配置 host 不读取,web.static_dir / web.user 被忽略,升级需按 docs/config.md 调整。
- 引导不重设已有口令、不提升已降权身份;类型定义冲突需人工解决。
## 类型与语义
- 范式分析最多 12 列;领域原子性和依赖完整性由用户声明,信息不足时不认证高阶范式。分解建议仅一轮,不保证子关系已达 BCNF;尚无自动迁移。
- DOMAIN 无自身 CHECK / NOT NULL / DEFAULT、ALTER DOMAIN、CASCADE;尚无 ENUM 或用户定义复合类型。内置目录不能靠增加行扩展基础类型。
- DECIMAL 仍使用浮点表示,不是精确十进制存储;整数类型共用整数表示,CHAR 不补空格。
- 少量接口设置仍用字符串类型名;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 仅用于查询类型推导,不可声明为存储列类型。
## 构建、发行与安全
- 离线 recover 依赖完整可用 WAL,不能保证修复损坏数据页或已截断的历史;未知系统表缺少结构时需备份或 reset。目录计数器损坏后无法还原已删除身份编号上限。
- 旧版进程不支持数据目录独占锁;维护前必须停止所有相关进程。
- sudo 本机认证需提升身份启动 server;当前只映射 Unix root / Windows 提升 Administrators 到一个显式配置身份,无任意 OS 用户映射或自动提权。异常退出留下的端口凭据目录须在确认停止后手工清理。
- sudo 的 Windows 提升成功路径、macOS 编译运行及 Linux 完整提升 server/CLI 链路仍待目标平台实机验收;Debian/WSL 已验证原生凭据安全边界。
- 直接构建独立 Stack 工程时可能复用旧注册库,必要时使用 --force-dirty 或全量门禁 -Full;Haskell 构建须串行。
- 存储协议变化后必须重建实际 cdylib,开发环境须配置 PATH / LD_LIBRARY_PATH;旧命名构建工件仍可能残留。
- 真实 server 测试须先引导并能找到 bootstrap;注释检查对部分多行语法可能误报。
- GitHub 在线安装、Linux $ORIGIN 与 macOS 发布仍需实机验证;无 Release 时在线安装无法取得预编译资源。
- SHA256 只能检测损坏,无发布签名;外部采集仍可能记录 SQL 原文。旧 CLI 历史不自动清理,任意业务字符串中的敏感数据不自动识别。
+22
View File
@@ -0,0 +1,22 @@
ChuSQL 长期路线图
交付状态和验收只以 progress.txt 为准;近期顺序见 side-branch-plan.txt。
本文件描述目标,不代表现有实现或功能承诺。
目标链路:SQL → Parser / Binder → Typed IR → Planner / Optimizer → Executor → Rust Storage。
类型能力与权限保持独立;catalog 保存对象、依赖和语义,内核保留必要基础机制。
阶段
- A 类型与函数基础:稳定 TypeId / FunctionId、注册表、逻辑/物理类型分离、版本化值;验收见 progress.txt。
- B 能力与运算(2–6):Capability、Operator、Cast、Aggregate、参数多态与约束解析。
- C 复合与自定义类型(7–12):ADT、Record/Composite、Newtype/Domain、参数化类型、Range、用户类型。
- D 函数与效果(13–16):用户函数、Effect、纯 Generated Column、有副作用的 Trigger。
- E 权限与类型化查询(17–19):权限 Capability、Query a、Rewrite / Optimizer 函数化。
- F 扩展:对象体系统一后实现 Extension 的版本、依赖、安装/升级/移除;其他访问方法按真实需求推进。
贯穿约束
- 现有 ColumnType / Expr / RelOp 有真实消费者;迁移时逐步收拢,不提前删除兼容桥。
- 每阶段验证持久化、升级、依赖和恢复,不能靠重新初始化掩盖不兼容。
- 内建对象可由可信 bootstrap 元数据恢复;用户对象依赖 WAL / 备份。
- catalog 版本与 bootstrap / recovery 匹配,系统目录索引可重建。
- 不提前增加孤立扩展或绕过事务、权限及依赖管理。
+41
View File
@@ -0,0 +1,41 @@
ChuSQL 已完成事项
更新:2026-10-13
本文件是当前完成状态及最新验收的唯一来源,等价于 project-plan.txt;不保留历史批次、提交记录或修改流水。
设计见 design-decisions.txt,未解决限制见 known-issues.txt,后续计划见 side-branch-plan.txt。
## SQL 与查询执行
- 实现 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 使用哈希半连接 / 反连接。
## 类型与绑定
- 建立固定类型 / 函数编号、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 定义与执行共用类型及槽位绑定;建表、加列和结构变更校验条件、默认值与键能力,空表不跳过,失效引用明确拒绝。
## 存储与事务
- 实现页、堆表、B+Tree、catalog、WAL、LSN 检查点、已提交组幂等恢复及页内 compact;持久化对象编号、高水位和 schema 版本,失败进入 recovery_required。
- 实现按连接隔离工作库、整库快照事务、写写冲突检查、保存点和差分提交;权限及对象身份在事务提交时复查。
- Web 编辑使用独立连接与页面绑定,支持跨表原子提交、保存点重放、提交去重、冲突重载、SQL 标签隔离及退出清理。
## 身份、工具与发行
- 用户与角色统一名称空间,支持 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。
## 最新验证
- 全量门禁通过: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。局部改动验证受影响模块,较大改动执行全量门禁;当前工作区改动未提交。
+16
View File
@@ -0,0 +1,16 @@
ChuSQL 近期任务与依赖
实现、测试及门禁状态只以 progress.txt 为准;设计见 design-decisions.txt,限制见 known-issues.txt。
下列顺序是规划,不是已完成能力;每批按实际进度选择任务。
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 用户映射。
- Haskell 构建串行,存储协议变化重建实际动态库;门禁入口为 gate-check/run-gate.ps1。
@@ -0,0 +1,64 @@
---
name: chusql-boundary-contracts
description: 修改 ChuSQL Rust/Haskell FFI、客户端与 Server 协议、跨组件序列化契约或公开接口时使用;核对调用链、线程与所有权。单模块内部算法且接口未变时不加载。
---
# ChuSQL 边界契约
## Scope
负责组件间表示、调用与生命周期。类型内容使用 chusql-type-system,落盘与恢复使用 chusql-storage-integrity,通用 unsafe 检查使用 rust-c-ffi-safety。路径相对仓库根目录,按变更读相关消费者。
## Architecture
- CLI / Web 后端通过 `chusql-interface/src/ChuSQL/Interface/Link.hs` 连接 Server TCP;`Protocol.hs` 定义网络消息,`Session.hs` 提供客户端会话操作。
- `chusql-server/src/ChuSQL/Server/TCP.hs` 分派消息,`Session.hs` 管登录 / 鉴权,`Backend.hs` 调引擎。浏览器通过 `chusql-web/src/ChuSQL/Web/API.hs` 的 HTTP API 访问 Web 后端,不直接访问 Rust。
- `chusql-core/engine/src/ChuSQL/Core/Engine/Storage/IPC.hs` 将 MonadStorage 操作编码为 JSON,经 localStorageLink 调 FFI;IPC 名称不表示当前另起存储进程或 Socket 服务。
- FFI 两端是 `chusql-core/engine/src/ChuSQL/Core/Engine/Storage/FFI.hs` 与 `chusql-core/storage/src/ffi.rs`,方向 Haskell → Rust,没有回调 ABI。
- 存储 JSON 定义于 `chusql-core/model/src/ChuSQL/Core/Protocol.hs` 与 `chusql-core/storage/src/protocol.rs`;它与 Interface TCP 属于不同协议。
## ABI 与所有权
下表符号均带 chusql_storage_ 前缀;Rust usize 对 Haskell CSize、i32 对 CInt,句柄使用 Ptr ()。不直接跨语言传 Rust struct、enum、Vec 或 Haskell 对象布局。
| 符号 | C ABI 形状 | 契约 |
| --- | --- | --- |
| version | () → const char* | 静态 NUL 字符串,不释放 |
| open | const char* → Storage* | NULL 路径用默认;失败 NULL,成功由 close 归还 |
| close | Storage* → void | NULL 安全;非空句柄只关闭一次 |
| request | const Storage*, const u8*, usize, u8**, usize* → i32 | 输入借用;输出由 Rust 分配;0 / -1 |
| maintenance | const char*, const u8*, usize, u8**, usize* → i32 | 离线操作;响应 ownership 同 request |
| free | u8*, usize → void | 归还原始指针 / 长度对,不跨分配器、不重复释放 |
| last_error | usize* → const u8* | 借用线程局部错误,立即复制、不释放 |
## Invariants
- 路径为 NUL 结尾 UTF-8;请求 / 响应为显式长度 UTF-8 JSON,响应不保证 NUL 结尾,不能用 C 字符串函数读取。
- Haskell request 使用 Ptr CChar、CSize、Ptr (Ptr CChar)、Ptr CSize 并返回 CInt,maintenance 以 CString 替代句柄。改签名同步两端与实际动态库。
- 借用指针整个调用中有效,输出可写且不与输入或其他输出重叠。Rust 拒绝 NULL / 超过 isize::MAX 的请求长度,但不能验证非空指针的分配范围 / provenance;catch_unwind 不是非法指针保护。
- 成功输出是 Box<[u8]> 转出的所有权;Haskell callStorage 复制后 finally 调 free,失败清空输出。保留取消屏蔽,避免复制 / 释放窗口泄漏。
- open / request / maintenance 捕获 Rust panic,经 NULL / -1 和 last_error 返回;业务错误也可能是 ABI 成功响应中的 JSON error,两层失败都要处理。
- close / free 捕获析构 panic 但没有状态返回,当前忽略捕获结果;不能依靠析构保证提交或宣称它报告落盘失败。
- onStorageThread 在支持 bound threads 的 RTS 中绑定调用和错误读取到同一 OS 线程;last_error 缓冲只到本线程下次设置错误前有效。
- Haskell open / close / request / maintenance 是 safe ccall,version / free / last_error 是 unsafe ccall;长 I/O 不改为 unsafe。请求期间不得关闭句柄。
- IPC 的 withStorageLink 计数在途请求,closeConnection 等空闲再关闭;不绕过它更换 / 释放链路。Env 保存会话工作库,不把全局默认库当多连接状态。
- Interface TCP 是一行 UTF-8 JSON,Hello 校验 protocolVersion=1;同一 Client 的 MVar 串行化请求 / 响应。Server 每连接建 Session 并限制行长度,客户端锁不是全局数据库锁。
- SchemaColumn 字段、method / status 标签、缺省字段、错误码及 QueryResult columns / rows 的位置关系是消费者契约,不用自动派生构造器名替代稳定标签。
- 复合值标签为 __chusql_runtime_v1,由 Core.Runtime 编解码;Rust 行仍是通用 JSON。封装变化检查 CLI / Web / 存储重载,Web 数值受 JavaScript 安全整数限制。
- 原始存储透传仍经过 Server 会话鉴权;新入口核对 TCP 分派、会话策略与 Web 消费者,不绕过对象权限或业务错误。
## Engineering Decisions
优先扩展共享协议与真实调用者,不增加无用途适配层;确认无人依赖的内部接口可直接调整。新增类型化值沿 JSON 载荷传递,只有实际需要才扩展 ABI。
Rust panic、Haskell IO 失败与业务错误按边界转成明确失败;当前没有自动 ABI 兼容协商或后台回调生命周期管理。
## Validation
- ABI / ownership 变更验证 `chusql-core/storage/tests/ffi_test.rs` 的成功、错误、长度、编码和释放路径;必要时用可用 Miri,不为普通消息变更强制安装工具。
- 存储协议变化测试相关 Rust 模块并重建实际 cdylib,再串行验证受影响 Haskell 模块;rlib 或 mock 不能证明实际 FFI 可用。
- TCP 改动验证 Hello、错误响应和真实消费者,复用 `chusql-server/test/Spec.hs`、`chusql-web/test/Spec.hs`、`chusql-cli/test/Spec.hs` 中相关行为。
- 入口见 `gate-check/run-step.ps1`,测试范围按风险决定,不自动运行所有者全量门禁。
## References
Web 值展示 / SQL 生成消费者见 `chusql-web/static/core.js`;总体路径见 `docs/architecture.md`。核对协议时读两端编码 / 解码和调用者,不依赖绝对行号。
@@ -0,0 +1,53 @@
---
name: chusql-storage-integrity
description: 修改 ChuSQL 存储页、索引、序列化、catalog、系统元数据、初始化、持久化事务或恢复时使用;维护实际落盘顺序与恢复约束。普通 SQL 表达式或界面任务不加载。
---
# ChuSQL 存储完整性
## Scope
负责持久化状态及其与服务端事务的关系。类型语义使用 chusql-type-system,接口生命周期使用 chusql-boundary-contracts;不照搬 PostgreSQL 内核设计。路径相对仓库根目录,只读受影响模块。
## Architecture
- `chusql-core/storage/src/runtime.rs`:Storage 持有数据目录文件锁、管理数据库;Server 管每库 catalog、WAL、表缓存和读写门。
- 数据根目录中 system/ 保存系统库,databases/<name>/ 保存业务库。每库有 catalog.json、<table>.db、内建 <table>.idx、其他 <table>.<column>.idx、wal.log 与 wal.checkpoint;诊断日志由 log_files 单独配置。
- `chusql-core/storage/src/page.rs` 管定长页与缓存刷盘;`heap.rs` 管页内槽位、JSON 行、隐藏列和 compact;`btree.rs` 管变长字节键、重复键与叶子链范围扫描。
- `chusql-core/storage/src/catalog.rs` 管 schema、索引、统计、隐藏列、对象编号 / 高水位;`protocol.rs` 定义线上 schema 和系统表常量。
- `chusql-core/storage/src/wal.rs` 管 LSN、提交组、日志扫描与检查点;runtime.rs 的 group_via_wal、recover_wal、replay_op 连接记录与应用。
- `chusql-server/src/ChuSQL/Server/Session.hs` 管会话快照、保存点、差分与冲突;`Backend.hs` 向存储提交操作。`chusql-bootstrap/` 调用 Storage::maintenance 与 maintenance_candidate 做离线维护。
## Invariants
- 表存在性以 catalog 为准,文件存在不表示已登记;不能靠打开文件创建逻辑表。语义与优化只读取 schema。
- Catalog::save 写 pending 文件、同步后替换;单文件替换不等于 catalog、页与索引已整体原子提交。
- 普通组先 append_group 落盘,再设置 recovery_required,然后应用、刷表、推进检查点、截断日志,全部成功才解除恢复状态。
- 应用 / 刷盘 / 检查点 / 截断失败必须保持恢复状态并报错。普通业务请求被阻断;Ping / SystemStatus 例外由各自分派层处理,新增入口不得绕过状态。
- 恢复仅重放检查点之后已提交组,保持 replay_op 幂等;不应用未提交组。现有 WAL 是 redo,检查点是库级 LSN,不是 undo 或页级恢复。
- 账号引导 / 变更存在独立 WAL 路径,不能假定所有写入都走普通组函数。
- 库 / 表对象和身份编号依赖持久化高水位,删除后不复用;迁移不能降低计数器,不能从现存对象推断已删除编号上限。
- 系统身份 / 凭据、角色、授权、类型与 DOMAIN 元数据保持对应关系。引导保留已有口令和降权状态,拒绝定义 / 保留文件冲突;类型目录不是可动态扩展基础类型的机制。
- 数据目录锁覆盖存储和维护生命周期;维护前停止占用进程。每库读共享 / 写独占、表句柄加锁,不假定同库跨表并行写。
- 会话事务是整库内存快照,无嵌套事务,事务内禁止 DDL / USE。提交跳过未修改表,整数 id 按键差分,否则整表比较 / 替换;对象身份和权限需复查,冲突返回 serialization_failure 并保留事务。
- 页内 compact 保留槽位编号与索引位置;隐藏列 compact 可能整表重写。布局、键编码、行序和隐藏列改动须检查真实消费者。
- 页大小、B+Tree magic / 布局、槽位小端字段、JSON 行、WAL 标签 / 帧和 catalog 字段是格式契约。改变前明确加载、迁移或拒绝策略,不以重新初始化掩盖不兼容。
## Engineering Decisions
- 优化可减少分配或重复读取,但保留验证、刷盘顺序、错误传播与可观察行序。结构变更同时核对 WAL、应用、幂等恢复与 catalog 保存。
- 数据库目录建删不走普通表 WAL,删库使用墓碑目录;不能承诺表提交组相同的崩溃原子性。
- 离线维护在候选目录操作并保留备份;repair 不改既有表数据,recover 依赖可用 WAL,reset 重建系统目录且保留业务库。失败保留原目录 / 恢复材料。
- 当前 Catalog::load 对不存在或空文件返回空目录,JSON 损坏报错;不能宣称所有损坏都会拒绝。rename_table_files 和部分析构 / 清理路径仍忽略 I/O 错误,不作为成功持久化保证。
- 尚无行版本 MVCC、页级恢复、跨页填洞、并行写或通用结构迁移事务,不据此放松校验。
## Validation
- 按影响选择 `chusql-core/storage/tests/` 的 page / heap / btree / catalog / wal / runtime 测试;说明修正核对源码即可。
- 格式 / 元数据 / WAL 改动验证重开、提交前后中断、重复恢复、缺失 / 截断 / 损坏输入与失败后状态;断言须检测实际不一致。
- 会话差分 / 冲突变更还验证 `chusql-server/test/Spec.hs`;并发压力测试不是正确性证明。
- 规定入口为 `gate-check/run-step.ps1 -Kind cargo`,动态库构建为 -Kind build;受影响 Haskell 模块按脚本命令串行构建,全量门禁遵守 AGENTS.md。
## References
恢复操作按需读 `docs/bootstrap.md`,配置见 `docs/config.md`,限制见 `.agents/context/known-issues.txt`;涉及拟议能力时仍以源码为准。
@@ -0,0 +1,48 @@
---
name: chusql-type-system
description: 修改 ChuSQL SQL 类型、值表示、赋值转换、类型推导、函数或表达式语义时使用;提供类型模块职责与一致性约束。仅调整界面样式或无关存储性能时不加载。
---
# ChuSQL 类型系统
## Scope
负责类型语义;落盘顺序交给 chusql-storage-integrity,传输契约交给 chusql-boundary-contracts。通用语言与测试规范使用已有 Skills,不重复加载。下列路径相对仓库根目录,只读本次相关模块。
## Architecture
- `chusql-core/model/src/ChuSQL/Core/Model.hs`:`ColumnType`、列约束、`Value`;集中提供 `assignable`、`comparableTypes`、`valueFits`、`coerceValue`、相等与哈希语义。
- `chusql-core/model/src/ChuSQL/Core/Runtime.hs`:`TypeExpr` / `TypeId`、`Kind`、独立 `PhysicalType`、`RuntimeValue`、注册表和版本化编码;Engine 的 `Runtime/Types.hs` 只是重新导出。
- `chusql-core/engine/src/ChuSQL/Core/Engine/Syntax/Parser.hs` 与 `Syntax/AST.hs` 解析声明和构造表达式;`Semantic.hs` 根据 schema 解析 DOMAIN、推导表达式并绑定身份。
- `chusql-core/engine/src/ChuSQL/Core/Engine/Runtime/Functions.hs` 定义固定 FunctionId 与签名,现有函数 length / not;`Runtime/SQL.hs` 连接 SQL 标量和运行时值。
- `chusql-core/engine/src/ChuSQL/Core/Engine/Runtime/Query.hs` 的 BoundQuery 保存 schema、输出类型和优化后的 RelOp,执行后按位置校验。`Runtime/Binding.hs` 另提供类型化表达式与基础计划,尚未替代完整 SQL 关系代数。
- `chusql-core/model/src/ChuSQL/Core/Protocol.hs` 共享值的 JSON 转换;Rust 的 `chusql-core/storage/src/protocol.rs` 使用 `HashMap<String, serde_json::Value>` 保存行。
## Invariants
- 构造器编号固定:Int=1、Double=2、Bool=3、String=4、List=5、Maybe=6、Tuple=7。使用 resolveType 检查参数 / kind,不把显示名当身份,不再维护第二份注册表。
- CRuntime / VRuntime 身份必须匹配;递归检查列表元素、Maybe 内容与元组字段数,Double 必须有限。保留逻辑类型与物理表示的区别。
- SQL VNull 与 RMaybe Nothing 不同;CNull 是查询推导类型,不能声明为存储列。保留三值逻辑与函数 NULL 传播。
- 赋值兼容和比较兼容分别使用 Model 入口。coerceValue 负责值收敛;整值浮点转整数、字符串长度、日期格式、DECIMAL 舍入沿现有规则处理,不在 Parser / Eval / Web 重复实现转换。
- 整数与可规范化整值浮点保持相等 / 哈希一致。底层 compareValue 的实现不表示 SQL 已开放该类型的比较、排序、分组或索引。
- DOMAIN 使用 domainTableName 与目录定义解析基础类型、依赖及循环;不能拿解析器占位基础类型直接执行。系统内建类型目录也不是通过增加行即可扩展的插件注册表。
- Date / Timestamp / Blob 在 QueryType 保留 CompatibilityType;ColumnType 与 RelOp 仍有真实消费者,不能作为无用兼容层删除。
- 类型 / 值编码版本为 1;身份、类型名、封装或值结构变化可能影响 catalog、WAL、FFI、TCP 和 Web,组合相关 Skills 核对消费者。
- Rust 当前保存通用 JSON,只做局部校验(隐藏列、DOMAIN 依赖、DECIMAL 规范化),没有 Haskell validateValue 的完整等价检查;不要依赖原始存储请求完成所有 SQL 类型校验。
- 错误沿 Either String 返回;`chusql-core/engine/src/ChuSQL/Core/Engine/Error.hs` 用消息规则映射类别 / 协议码。修改错误文字须检查分类,不用默认值或 NULL 掩盖错误。
## Engineering Decisions
复用 Model / Runtime 的语义入口,在现有类型桥上做最小修改。尚无完整 capability / operator / cast 注册机制、通用显式 CAST、用户 ADT 或 Extension;DOMAIN 自身 CHECK / NOT NULL / DEFAULT 尚未实现。不要将规划当现有契约。
DECIMAL 是有限浮点表示,采用 ties-to-even 舍入与舍入后溢出检查,并非精确十进制存储。运行时复合类型尚无 SQL Eq / Ord / Hash capability 字典。
## Validation
- 语义改动验证解析 → schema 绑定 → 执行,关注 NULL、边界值、明确错误与输出位置;说明修正只需核对源码。
- 复用 `chusql-core/engine/test/RuntimeSpec.hs`、`chusql-core/engine/test/Spec.hs`,按需覆盖固定编码、错误身份和嵌套值。
- 持久化类型变更验证 Rust 写入 / 重载与实际协议消费者;Web 值展示 / SQL 生成参考 `chusql-web/test/runtime-values.mjs`。
- 测试入口见 `gate-check/run-step.ps1`,不因加载 Skill 自动执行全量门禁或追求覆盖率。
## References
按需读 `docs/types.md`,区分当前类型用法与未来约束设计。以上源码模块是契约核对入口。
+3
View File
@@ -31,6 +31,9 @@ jobs:
steps: steps:
- uses: actions/checkout@v4 - uses: actions/checkout@v4
- name: installer release fallback tests
run: python3 scripts/test-release-fallback.py
# ---------- Rust 存储 ---------- # ---------- Rust 存储 ----------
- name: Rust toolchain - name: Rust toolchain
uses: dtolnay/rust-toolchain@stable uses: dtolnay/rust-toolchain@stable
+4
View File
@@ -9,6 +9,10 @@
# 装的人拿到的就是编好的二进制,不需要 GHC / Rust: # 装的人拿到的就是编好的二进制,不需要 GHC / Rust:
# curl -fsSL https://raw.githubusercontent.com/TheBadRoger/ChuSQL/main/scripts/install.sh \ # curl -fsSL https://raw.githubusercontent.com/TheBadRoger/ChuSQL/main/scripts/install.sh \
# | sh -s -- --component web # | sh -s -- --component web
# 也可下载 ChuRepo 脚本(发行包下载失败时自动回退):
# curl -fsSL https://repo.chunana.cn/ChuNa7a/ChuSQL/raw/branch/main/scripts/install.sh -o install.sh
# sh install.sh --component web
# 两站发行包与源码安装入口见 docs/install.md。
# 没有对应平台的资源时,同一个脚本可以退回本地编译: # 没有对应平台的资源时,同一个脚本可以退回本地编译:
# sh scripts/install.sh --component web --from-source # sh scripts/install.sh --component web --from-source
# #
+10 -2
View File
@@ -76,8 +76,6 @@ resources/chusql.ui.settings.json
*~ *~
\#*\# \#*\#
.\#* .\#*
AGENTS.md
agent-credientials
.dsh .dsh
# 注意:.zed/tasks.json 是本仓库共享的构建任务(stack build / run / test / repl), # 注意:.zed/tasks.json 是本仓库共享的构建任务(stack build / run / test / repl),
# 需要入库,所以这里不忽略 .zed/ # 需要入库,所以这里不忽略 .zed/
@@ -95,3 +93,13 @@ plandocs/
Thumbs.db Thumbs.db
ehthumbs.db ehthumbs.db
desktop.ini desktop.ini
learning
# 通用技能和安装状态仅供本机;只跟踪项目专用技能
/.agents/skills/*
!/.agents/skills/chusql-boundary-contracts/
!/.agents/skills/chusql-storage-integrity/
!/.agents/skills/chusql-type-system/
/.agents/context/prompt.txt
/skills-lock.json
+41
View File
@@ -0,0 +1,41 @@
# AGENTS.md — ChuSQL 开发契约
参考:
- 唯一进度与验收来源:`.agents/context/progress.txt`(等价于 project-plan.txt)。
- 限制与设计:`.agents/context/known-issues.txt`、`.agents/context/design-decisions.txt`。
## 核心约束
- 测试必须通过,禁止绕过检查。
- 不吞错误,使用明确错误返回。
- FFI 响应由 Rust 分配并通过配套 free 归还;句柄关闭不得与请求并发。
- 表存在性以 catalog 为准。
- 语义检查和优化只使用 schema。
- 索引由存储层管理,优化器只判断可点查条件。
- 优化不能改变结果语义。
- 持久化、事务、并发、类型及 FFI 改动优先维护不变量、内存所有权与错误传播;保留必要的迁移和恢复约束。
## 开发方式
- 按任务选择已安装 Skills:编码用 ponytail / karpathy-guidelines,审查与简化按需用 ponytail-review;Rust、FFI、测试及覆盖率分别使用对应项目技能。
- 类型、值、转换或表达式语义用 `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 历史。
## 注释规范
- 文件级:外部引用语句(Haskell `import`、Rust `use`、JS `import`、HTML 的 `<link>`/`<script>`、
CSS `@import`、脚本的依赖/参数区)之后写一段注释,概括本文件的功能;没有引用语句的文件写在
文件开头。长度不超过 3 行、合计不超过 90 字。
- 函数级:每个函数(含 Haskell 的 `where`/`let` 内函数、Rust 的私有 `fn`)前用一行不超过
30 字的注释说明它做什么。
- 摘要说明做什么;仅在必要处补充不直观的不变量、所有权与安全约束,不记录历史和被删实现。
## 协作规则
- 全量门禁入口:`gate-check/run-gate.ps1`(三条车道并行,日志写仓库根的 `logs/`)。
- 局部改动运行受影响模块的规定测试;较大改动由 agent 执行全量门禁,通过后再提交。
- engine / web / storage 使用规定测试入口。
- 规定入口见 `gate-check/run-step.ps1`;Haskell 构建串行,存储协议改动须重建实际动态库。
- 改动说明只在交流中记录。
+30 -2
View File
@@ -11,6 +11,8 @@
ChuSQL 是采用 Haskell SQL 引擎与 Rust 存储层的数据库项目,提供 TCP 服务、CLI 和 Web 管理端。支持查询优化、快照事务、WAL 崩溃恢复、DOMAIN 自定义类型及用户与角色管理。 ChuSQL 是采用 Haskell SQL 引擎与 Rust 存储层的数据库项目,提供 TCP 服务、CLI 和 Web 管理端。支持查询优化、快照事务、WAL 崩溃恢复、DOMAIN 自定义类型及用户与角色管理。
项目仓库:[GitHub](https://github.com/TheBadRoger/ChuSQL) · [ChuRepo](https://repo.chunana.cn/ChuNa7a/ChuSQL)。两处均可获取源码,按网络情况选择。
## 快速开始 ## 快速开始
### 安装 ### 安装
@@ -18,16 +20,42 @@ ChuSQL 是采用 Haskell SQL 引擎与 Rust 存储层的数据库项目,提供
Linux / macOS: Linux / macOS:
```sh ```sh
curl -fsSL https://raw.githubusercontent.com/TheBadRoger/ChuSQL/main/scripts/install.sh | sh -s -- --component web (curl -fsSL --connect-timeout 10 \
https://raw.githubusercontent.com/TheBadRoger/ChuSQL/main/scripts/install.sh -o install.sh ||
curl -fsSL --connect-timeout 10 \
https://repo.chunana.cn/ChuNa7a/ChuSQL/raw/branch/main/scripts/install.sh -o install.sh) &&
sh install.sh --component web
```
也可从 ChuRepo 下载后执行:
```sh
curl -fsSL \
https://repo.chunana.cn/ChuNa7a/ChuSQL/raw/branch/main/scripts/install.sh \
-o install.sh
sh install.sh --component web
``` ```
Windows(PowerShell 里下下来再跑;也有下载 zip 解压的包内安装): Windows(PowerShell 里下下来再跑;也有下载 zip 解压的包内安装):
```powershell ```powershell
irm https://raw.githubusercontent.com/TheBadRoger/ChuSQL/main/scripts/install.ps1 -OutFile "$env:TEMP\install.ps1" try {
irm https://raw.githubusercontent.com/TheBadRoger/ChuSQL/main/scripts/install.ps1 -OutFile "$env:TEMP\install.ps1" -TimeoutSec 60 -ErrorAction Stop
} catch {
irm https://repo.chunana.cn/ChuNa7a/ChuSQL/raw/branch/main/scripts/install.ps1 -OutFile "$env:TEMP\install.ps1" -TimeoutSec 60 -ErrorAction Stop
}
& "$env:TEMP\install.ps1" -Component web & "$env:TEMP\install.ps1" -Component web
``` ```
ChuRepo 下载方式:
```powershell
irm https://repo.chunana.cn/ChuNa7a/ChuSQL/raw/branch/main/scripts/install.ps1 -OutFile "$env:TEMP\install.ps1"
& "$env:TEMP\install.ps1" -Component web
```
上述命令下载脚本时优先 GitHub,失败后尝试 ChuRepo。脚本安装和更新时也会自动回退:版本查询或发行包下载失败时尝试 ChuRepo;已选定的版本保持不变,校验失败直接报错。两站均无对应发行包时需使用包内安装或源码安装。显式指定其他仓库或归档 URL 时不会回退到官方仓库。
### 启动 ### 启动
```sh ```sh
+33 -16
View File
@@ -2,6 +2,7 @@
module Main where module Main where
import Data.Either (lefts)
import ChuSQL.Core.Protocol (QueryResult (..), TableInfo (..)) import ChuSQL.Core.Protocol (QueryResult (..), TableInfo (..))
import ChuSQL.Interface.Link (Client, clientPing, closeClient, connectClient) import ChuSQL.Interface.Link (Client, clientPing, closeClient, connectClient)
import ChuSQL.Interface.Session ( import ChuSQL.Interface.Session (
@@ -15,7 +16,7 @@ import ChuSQL.Interface.Session (
import Control.Concurrent (forkIO, forkFinally, threadDelay) import Control.Concurrent (forkIO, forkFinally, threadDelay)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import Control.Exception (IOException, bracket, evaluate, throwIO, try) 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 Data.List (intercalate, sort)
import ChuSQL.Core.Model (Value (..)) import ChuSQL.Core.Model (Value (..))
import Data.Text (Text) import Data.Text (Text)
@@ -77,7 +78,7 @@ timedQuery bench sql = do
Left _ -> pure (-1) Left _ -> pure (-1)
Right result -> evaluate (qrRowCount result) Right result -> evaluate (qrRowCount result)
t1 <- getMonotonicTime 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 () report :: String -> Either Text Int -> Double -> IO ()
@@ -107,7 +108,7 @@ batchInsert bench label n mkSql = do
results <- mapM (runSql bench . mkSql) [1 .. n] results <- mapM (runSql bench . mkSql) [1 .. n]
t1 <- getMonotonicTime t1 <- getMonotonicTime
let total = t1 - t0 let total = t1 - t0
errs = [e | Left e <- results] errs = lefts results
case errs of case errs of
[] -> do [] -> do
printf printf
@@ -181,7 +182,7 @@ runBatch bench sqls = do
t0 <- getMonotonicTime t0 <- getMonotonicTime
results <- mapM (runSql bench) sqls results <- mapM (runSql bench) sqls
t1 <- getMonotonicTime t1 <- getMonotonicTime
pure (t1 - t0, [e | Left e <- results]) pure (t1 - t0, lefts results)
-- | 把 1..n 按 size 切成一段段 -- | 把 1..n 按 size 切成一段段
chunked :: Int -> Int -> [[Int]] 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) _ <- 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 (milliseconds, ()) <- measure $ do
(beginMs, _) <- measure (runSql bench "BEGIN") (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") (commitMs, _) <- measure (runSql bench "COMMIT")
printf "TXN_PHASE begin_ms=%.3f staged_ms=%.3f commit_ms=%.3f\n" beginMs stagedMs commitMs printf "TXN_PHASE begin_ms=%.3f staged_ms=%.3f commit_ms=%.3f\n" beginMs stagedMs commitMs
pure () pure ()
@@ -609,17 +610,33 @@ pressureScenarios bench u o = do
-- | 用多条独立会话同步开始点查 -- | 用多条独立会话同步开始点查
concurrentLookup :: Bench -> Int -> IO () concurrentLookup :: Bench -> Int -> IO ()
concurrentLookup bench workers = do concurrentLookup bench workers = do
completions <- forM [1 .. workers] $ \_ -> do completions <- replicateM
start <- newEmptyMVar workers
done <- newEmptyMVar (do start <- newEmptyMVar
client <- connectClient "127.0.0.1" (bPort bench) >>= either (ioError . userError . T.unpack) pure done <- newEmptyMVar
session <- newSession client client <- connectClient "127.0.0.1" (bPort bench)
authenticateSession session "admin" "" >>= either (ioError . userError . T.unpack) pure >>= either (ioError . userError . T.unpack) pure
switchDatabase session "bench" >>= either (ioError . userError . T.unpack) pure session <- newSession client
_ <- forkFinally (takeMVar start >> bracket (pure client) closeClient (\_ -> replicateM 100 (fst <$> measure (do authenticateSession session "admin" ""
result <- runStatement session "SELECT id FROM users WHERE id = 1" >>= either (ioError . userError . T.unpack) pure
unless (fmap qrRows result == Right [[VInt 1]]) (ioError (userError "concurrent lookup mismatch")))))) (putMVar done) switchDatabase session "bench"
pure (start, done) >>= 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 (milliseconds, results) <- measure $ do
mapM_ (\(start, _) -> putMVar start ()) completions mapM_ (\(start, _) -> putMVar start ()) completions
mapM (takeMVar . snd) completions mapM (takeMVar . snd) completions
+4 -4
View File
@@ -2,6 +2,7 @@
module Main (main) where module Main (main) where
import Data.Maybe (fromMaybe)
import ChuSQL.Core.Engine.Storage.IPC (closeConnection, localStorageLink, sendRawRequest, setStorageLink) import ChuSQL.Core.Engine.Storage.IPC (closeConnection, localStorageLink, sendRawRequest, setStorageLink)
import ChuSQL.Bootstrap (preinstalledTypes, runBootstrap) import ChuSQL.Bootstrap (preinstalledTypes, runBootstrap)
import ChuSQL.Core.Engine.Storage.FFI (maintainStorage) import ChuSQL.Core.Engine.Storage.FFI (maintainStorage)
@@ -139,7 +140,7 @@ runMaintenance opts mode = do
Left err -> failWith err Left err -> failWith err
Right plain -> do Right plain -> do
encoded <- if T.null plain then pure "" else hashPassword plain 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)) reply <- maintainStorage path (BL.toStrict (A.encode request))
case reply of case reply of
Left err -> failWith err Left err -> failWith err
@@ -155,9 +156,8 @@ send request = do
readPassword :: Options -> IO (Either String Text) readPassword :: Options -> IO (Either String Text)
readPassword opts readPassword opts
| optPasswordless opts = pure (Right "") | optPasswordless opts = pure (Right "")
| optPasswordStdin opts = do | optPasswordStdin opts = do Right . T.dropWhileEnd (\ c -> c == '\r' || c == '\n')
line <- TIO.getLine <$> TIO.getLine
pure (Right (T.dropWhileEnd (\c -> c == '\r' || c == '\n') line))
| otherwise = pure (Left "pass --password-stdin or --passwordless") | otherwise = pure (Left "pass --password-stdin or --passwordless")
-- | 打印错误并退出 1 -- | 打印错误并退出 1
+4
View File
@@ -28,6 +28,10 @@ executable csql-bootstrap
, text , text
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall
if os(linux)
ld-options: -Wl,-rpath,$ORIGIN
if os(osx)
ld-options: -Wl,-rpath,@loader_path
test-suite chusql-bootstrap-test test-suite chusql-bootstrap-test
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
+3 -2
View File
@@ -2,6 +2,7 @@
module Main (main) where module Main (main) where
import Data.Maybe (fromMaybe)
import ChuSQL.Bootstrap (preinstalledTypes, runBootstrap) import ChuSQL.Bootstrap (preinstalledTypes, runBootstrap)
import ChuSQL.Core.Protocol (Account (..)) import ChuSQL.Core.Protocol (Account (..))
import ChuSQL.Core.Model (columnType, typeName) 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.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 where
-- | 给预装定义添加持久化编号 -- | 给预装定义添加持久化编号
numbered (n, A.Object fields) = A.Object (KM.insert "id" (A.toJSON n) fields) 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 :: 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 field _ _ = A.Null
-- | 记录请求并返回指定响应 -- | 记录请求并返回指定响应
+29 -12
View File
@@ -2,6 +2,7 @@
module Main (main) where module Main (main) where
import ChuSQL.CLI.Normalization (runNormalizationOnce)
import ChuSQL.CLI.Format (OutputFormat (..), formatName, parseFormat) import ChuSQL.CLI.Format (OutputFormat (..), formatName, parseFormat)
import ChuSQL.CLI.Password (readPasswordInput) import ChuSQL.CLI.Password (readPasswordInput)
import ChuSQL.CLI.Script (stripTerminator) import ChuSQL.CLI.Script (stripTerminator)
@@ -18,8 +19,8 @@ import ChuSQL.Interface.Link (Client, closeClient, connectClient)
import ChuSQL.Interface.Sudo (SudoCredential, readSudoCredential) import ChuSQL.Interface.Sudo (SudoCredential, readSudoCredential)
import ChuSQL.Interface.TOML (resolveConfigPath) import ChuSQL.Interface.TOML (resolveConfigPath)
import Control.Exception (finally) import Control.Exception (finally)
import Control.Monad (unless) import Control.Monad (unless, when)
import Data.IORef (newIORef) import Data.IORef (IORef, newIORef)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
@@ -40,6 +41,8 @@ data Options = Options
, optExecute :: Maybe Text , optExecute :: Maybe Text
, optHistory :: Maybe FilePath , optHistory :: Maybe FilePath
, optConfig :: Maybe FilePath , optConfig :: Maybe FilePath
, optNormalize :: Maybe Text
, optDeclaration :: Maybe FilePath
, optSudo :: Bool , optSudo :: Bool
} }
@@ -64,16 +67,19 @@ optionsParser =
<> metavar "FORMAT" <> metavar "FORMAT"
<> value FormatTable <> value FormatTable
<> showDefaultWith (T.unpack . formatName) <> showDefaultWith (T.unpack . formatName)
<> help "Output format: table, json or csv" <> help "Output format: table (or text), json or csv"
) )
<*> optional (T.pack <$> strOption (long "execute" <> short 'e' <> metavar "SQL" <> help "Run one statement and exit")) <*> optional (T.pack <$> strOption (long "execute" <> short 'e' <> metavar "SQL" <> help "Run one statement and exit"))
<*> optional (strOption (long "history" <> metavar "FILE" <> help "SQL history file (default ~/.chusql_history)")) <*> optional (strOption (long "history" <> metavar "FILE" <> help "SQL history file (default ~/.chusql_history)"))
<*> optional (strOption (long "config" <> metavar "FILE" <> help "Config file to read (default: the fixed settings.toml under the system config directory)")) <*> optional (strOption (long "config" <> metavar "FILE" <> help "Config file to read (default: the fixed settings.toml under the system config directory)"))
<*> optional (T.pack <$> strOption (long "normalize" <> metavar "TABLE" <> help "Analyze normalization using explicit declarations"))
<*> optional (strOption (long "declaration" <> metavar "FILE" <> help "UTF-8 JSON normalization declaration"))
<*> switch (long "sudo" <> help "Authenticate using the local root or elevated administrator identity") <*> switch (long "sudo" <> help "Authenticate using the local root or elevated administrator identity")
-- | 把 --format 的取值解析成格式 -- | 把 --format 的取值解析成格式
formatReader :: String -> Either String OutputFormat formatReader :: String -> Either String OutputFormat
formatReader raw = maybe (Left "format must be table, json or csv") Right (parseFormat (T.pack raw)) formatReader "text" = Right FormatTable
formatReader raw = maybe (Left "format must be table, text, json or csv") Right (parseFormat (T.pack raw))
-- | 命令行界面与帮助 -- | 命令行界面与帮助
parserInfo :: ParserInfo Options parserInfo :: ParserInfo Options
@@ -91,13 +97,18 @@ main = do
hSetEncoding stdout utf8 hSetEncoding stdout utf8
hSetEncoding stderr utf8 hSetEncoding stderr utf8
options <- execParser parserInfo options <- execParser parserInfo
case (optNormalize options, optDeclaration options, optExecute options, optFormat options) of
(Nothing, Nothing, _, _) -> pure ()
(Just _, Just _, Nothing, format) | format /= FormatCsv -> pure ()
_ -> reportError "--normalize requires --declaration, text/json format and cannot be combined with --execute" >> exitFailure
configPath <- resolveConfigPath (optConfig options) configPath <- resolveConfigPath (optConfig options)
base <- loadWebConfigAt configPath base <- loadWebConfigAt configPath
config <- loadServerConfigAt configPath config <- loadServerConfigAt configPath
let rootName = rootUserName base let rootName = rootUserName base
userName = fromMaybe (if optSudo options then scSudoUser config else rootName) (optUser options) userName = fromMaybe (if optSudo options then scSudoUser config else rootName) (optUser options)
credential <- if optSudo options then do 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) local <- readSudoCredential (scPort config)
case local of case local of
Left message -> reportError message >> exitFailure Left message -> reportError message >> exitFailure
@@ -129,13 +140,19 @@ runSession options session = do
ready <- selectDatabase session (T.strip (optDatabase options)) ready <- selectDatabase session (T.strip (optDatabase options))
if not ready if not ready
then exitFailure then exitFailure
else case optExecute options of else case (optNormalize options, optDeclaration options) of
Just sql -> do (Just table, Just file) -> runNormalizationOnce session table file (optFormat options == FormatJson) >>= \ok -> unless ok exitFailure
ok <- runStatementOnce session (optFormat options) (stripTerminator sql) _ -> runSqlSession options session formatRef
unless ok exitFailure
Nothing -> do -- 执行 SQL 或进入交互循环。
historyFile <- resolveHistory (optHistory options) runSqlSession :: Options -> Session -> IORef OutputFormat -> IO ()
runRepl session formatRef historyFile runSqlSession options session formatRef = case optExecute options of
Just sql -> do
ok <- runStatementOnce session (optFormat options) (stripTerminator sql)
unless ok exitFailure
Nothing -> do
historyFile <- resolveHistory (optHistory options)
runRepl session formatRef historyFile
-- | -d 指定了库才切,否则保持未选库 -- | -d 指定了库才切,否则保持未选库
selectDatabase :: Session -> Text -> IO Bool selectDatabase :: Session -> Text -> IO Bool
+4 -2
View File
@@ -6,13 +6,14 @@ module Repl
, reportError , reportError
) where ) where
import ChuSQL.CLI.Normalization (runNormalizationOnce)
import ChuSQL.CLI.Format (OutputFormat, formatName, renderResult, renderRows) import ChuSQL.CLI.Format (OutputFormat, formatName, renderResult, renderRows)
import ChuSQL.CLI.History (historySettings, rememberStatement) import ChuSQL.CLI.History (historySettings, rememberStatement)
import ChuSQL.CLI.Script (Meta (..), errorHint, metaHelp, parseMeta, takeStatement) import ChuSQL.CLI.Script (Meta (..), errorHint, metaHelp, parseMeta, takeStatement)
import ChuSQL.Interface.Session (Session, catalog, databases, roleViews, runStatement, sessionDatabase, switchDatabase) import ChuSQL.Interface.Session (Session, catalog, databases, roleViews, runStatement, sessionDatabase, switchDatabase)
import ChuSQL.Core.Protocol (SchemaColumn (..), TableInfo (..)) import ChuSQL.Core.Protocol (SchemaColumn (..), TableInfo (..))
import ChuSQL.Interface.Protocol (Grant (..), RoleView (..)) import ChuSQL.Interface.Protocol (Grant (..), RoleView (..))
import Control.Monad (forM_, when) import Control.Monad (forM_, when, unless)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.IORef (IORef, readIORef, writeIORef) import Data.IORef (IORef, readIORef, writeIORef)
import Data.Text (Text) import Data.Text (Text)
@@ -83,7 +84,7 @@ drain :: Session -> IORef OutputFormat -> Text -> InputT IO Text
drain session formatRef buffer = case takeStatement buffer of drain session formatRef buffer = case takeStatement buffer of
Nothing -> pure (T.strip buffer) Nothing -> pure (T.strip buffer)
Just (statement, rest) -> do Just (statement, rest) -> do
when (not (T.null statement)) $ do unless (T.null statement) $ do
rememberStatement (statement <> ";") rememberStatement (statement <> ";")
runOne session formatRef statement runOne session formatRef statement
drain session formatRef rest drain session formatRef rest
@@ -106,6 +107,7 @@ runMeta session formatRef meta = case meta of
MetaDatabases -> listDatabases session >> pure True MetaDatabases -> listDatabases session >> pure True
MetaTables -> listTables session >> pure True MetaTables -> listTables session >> pure True
MetaDescribe name -> describeTable session name >> pure True MetaDescribe name -> describeTable session name >> pure True
MetaNormalize table file jsonOutput -> liftIO (runNormalizationOnce session table file jsonOutput) >> pure True
MetaRoles -> listRoles session >> pure True MetaRoles -> listRoles session >> pure True
MetaConnect name -> do MetaConnect name -> do
switched <- liftIO (switchDatabase session name) switched <- liftIO (switchDatabase session name)
+2
View File
@@ -12,6 +12,7 @@ build-type: Simple
library library
hs-source-dirs: src hs-source-dirs: src
exposed-modules: ChuSQL.CLI.Format exposed-modules: ChuSQL.CLI.Format
ChuSQL.CLI.Normalization
ChuSQL.CLI.History ChuSQL.CLI.History
ChuSQL.CLI.Password ChuSQL.CLI.Password
ChuSQL.CLI.Script ChuSQL.CLI.Script
@@ -55,6 +56,7 @@ test-suite chusql-cli-test
, directory , directory
, aeson , aeson
, bytestring , bytestring
, chusql-interface
, chusql-cli , chusql-cli
, chusql-core-model , chusql-core-model
, hspec , hspec
@@ -0,0 +1,75 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.CLI.Normalization (normalizationArguments, loadNormalizationDeclaration, renderNormalization, runNormalizationOnce) where
import ChuSQL.Interface.Normalization
import ChuSQL.Interface.Session (Session, sessionDatabase, analyzeNormalization)
import Control.Exception (IOException, try)
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.IO as TIO
import System.IO (IOMode (ReadMode), stderr, withBinaryFile)
import Text.ParserCombinators.ReadP
-- CLI 范式入口:读取严格声明文件、发送专用请求并显示报告。
-- 解析表、声明路径和独立显示格式。
normalizationArguments :: Text -> Either Text (Text, FilePath, Bool)
normalizationArguments input = case readP_to_S (skipSpaces *> sepBy token skipSpaces <* skipSpaces <* eof) (T.unpack input) of
[(parts, "")] -> case parts of
[table, "--declaration", file] -> Right (T.pack table, file, False)
[table, "--declaration", file, "--format", "text"] -> Right (T.pack table, file, False)
[table, "--declaration", file, "--format", "json"] -> Right (T.pack table, file, True)
_ -> Left usage
_ -> Left usage
where
usage = "usage: \\normalize TABLE --declaration FILE [--format text|json]"
-- 保留引号内的 Windows 路径及空格。
token = quoted '"' <++ quoted '\'' <++ munch1 (\c -> c /= ' ' && c /= '\t' && c /= '\n' && c /= '"' && c /= '\'')
-- 读取不带转义解释的引号参数。
quoted quote = char quote *> munch (/= quote) <* char quote
-- 有界读取 UTF-8 声明并拒绝重复字段。
loadNormalizationDeclaration :: FilePath -> IO (Either Text NormalizationDeclaration)
loadNormalizationDeclaration path = do
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
value <- decodeNormalizationJSON (BL.fromStrict raw)
case A.fromJSON value of
A.Error message -> Left (T.pack message)
A.Success declaration -> Right declaration
-- 保留报告字段并选择文本或 JSON 显示。
renderNormalization :: Bool -> A.Value -> Text
renderNormalization True = jsonText
renderNormalization False = pretty 0
-- 将 JSON 编码为 UTF-8 文本。
jsonText :: A.Value -> Text
jsonText = TE.decodeUtf8 . BL.toStrict . A.encode
-- 缩进展示完整报告且保留所有证据。
pretty :: Int -> A.Value -> Text
pretty depth (A.Object fields) = T.intercalate "\n" [indent <> K.toText key <> ":\n" <> pretty (depth + 1) value | (key, value) <- KM.toList fields]
where indent = T.replicate depth " "
pretty depth value = T.replicate depth " " <> jsonText value
-- 发送声明并让失败决定 CLI 退出码。
runNormalizationOnce :: Session -> Text -> FilePath -> Bool -> IO Bool
runNormalizationOnce session table path jsonOutput = do
declaration <- loadNormalizationDeclaration path
database <- sessionDatabase session
result <- case declaration of
Left message -> pure (Left message)
Right d -> analyzeNormalization session (NormalizationRequest 1 database table d Nothing Nothing)
case result of
Left message -> TIO.hPutStrLn stderr ("chusql: error: " <> message) >> pure False
Right analysis -> TIO.putStrLn (renderNormalization jsonOutput analysis) >> pure True
+6 -1
View File
@@ -10,6 +10,8 @@ module ChuSQL.CLI.Script
, metaHelp , metaHelp
) where ) where
import Data.Maybe (isJust)
import ChuSQL.CLI.Normalization (normalizationArguments)
import ChuSQL.CLI.Format (OutputFormat (..), formatName, parseFormat) import ChuSQL.CLI.Format (OutputFormat (..), formatName, parseFormat)
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.Text (Text) import Data.Text (Text)
@@ -23,6 +25,7 @@ data Meta
| MetaDatabases | MetaDatabases
| MetaTables | MetaTables
| MetaDescribe Text | MetaDescribe Text
| MetaNormalize Text FilePath Bool
| MetaRoles | MetaRoles
| MetaConnect Text | MetaConnect Text
| MetaSetFormat OutputFormat | MetaSetFormat OutputFormat
@@ -50,6 +53,7 @@ parseMeta raw = do
| otherwise -> MetaDescribe argument | otherwise -> MetaDescribe argument
"dr" -> MetaRoles "dr" -> MetaRoles
"roles" -> MetaRoles "roles" -> MetaRoles
"normalize" -> either (const (MetaUnknown "normalize")) (\(table, file, jsonOutput) -> MetaNormalize table file jsonOutput) (normalizationArguments argument)
"c" -> connectTo argument "c" -> connectTo argument
"connect" -> connectTo argument "connect" -> connectTo argument
"use" -> connectTo argument "use" -> connectTo argument
@@ -87,7 +91,7 @@ data ScanState = ScanNormal | ScanString | ScanLineComment | ScanBlockComment
-- | 攒下来的内容里有没有一条以分号结束的语句 -- | 攒下来的内容里有没有一条以分号结束的语句
statementComplete :: Text -> Bool statementComplete :: Text -> Bool
statementComplete = maybe False (const True) . takeStatement statementComplete = isJust . takeStatement
-- | 去掉结尾的空白与分号(-e 直接执行时用) -- | 去掉结尾的空白与分号(-e 直接执行时用)
stripTerminator :: Text -> Text stripTerminator :: Text -> Text
@@ -118,6 +122,7 @@ metaHelp =
, " \\l, \\list list databases" , " \\l, \\list list databases"
, " \\dt, \\d list tables" , " \\dt, \\d list tables"
, " \\d <table> describe a table" , " \\d <table> describe a table"
, " \\normalize TABLE --declaration FILE [--format text|json]"
, " \\dr, \\roles list roles with their grants and members" , " \\dr, \\roles list roles with their grants and members"
, " \\c <database> switch database" , " \\c <database> switch database"
, " \\f, \\format <fmt> output format: " <> T.intercalate ", " (map formatName [FormatTable, FormatJson, FormatCsv]) , " \\f, \\format <fmt> output format: " <> T.intercalate ", " (map formatName [FormatTable, FormatJson, FormatCsv])
+26
View File
@@ -2,6 +2,8 @@
module Main (main) where module Main (main) where
import ChuSQL.CLI.Normalization
import ChuSQL.Interface.Normalization
import ChuSQL.CLI.Format (OutputFormat (..), parseFormat, renderCsv, renderJson, renderTable, displayValue) import ChuSQL.CLI.Format (OutputFormat (..), parseFormat, renderCsv, renderJson, renderTable, displayValue)
import ChuSQL.CLI.History (historySettings, rememberStatement) import ChuSQL.CLI.History (historySettings, rememberStatement)
import ChuSQL.CLI.Password (readPasswordInput) import ChuSQL.CLI.Password (readPasswordInput)
@@ -31,6 +33,7 @@ main = hspec spec
-- | 全部测试用例 -- | 全部测试用例
spec :: Spec spec :: Spec
spec = do spec = do
normalizationSpec
it "renders typed compound values without losing their wire identity" $ do it "renders typed compound values without losing their wire identity" $ do
case resolveType builtinTypes (listType intType) of case resolveType builtinTypes (listType intType) of
Left err -> expectationFailure err Left err -> expectationFailure err
@@ -188,3 +191,26 @@ sampleResult =
, qrTruncated = False , qrTruncated = False
, qrDatabase = Nothing , qrDatabase = Nothing
} }
-- 范式元命令、严格文件与显示格式回归。
normalizationSpec :: Spec
normalizationSpec = describe "CLI: normalization" $ do
it "parses quoted paths without interpreting Windows backslashes" $ do
normalizationArguments "users --declaration \"C:\\My Data\\fd.json\" --format json" `shouldBe` Right ("users", "C:\\My Data\\fd.json", True)
parseMeta "\\normalize users --declaration deps.json --format text" `shouldBe` Just (MetaNormalize "users" "deps.json" False)
normalizationArguments "users --declaration deps.json --format csv" `shouldSatisfy` either (const True) (const False)
it "keeps the same report fields in text and JSON output" $ do
let report = A.object ["candidate_keys" A..= ([["id"]] :: [[T.Text]]), "conditional" A..= True, "findings" A..= [A.object ["normal_form" A..= ("bcnf" :: T.Text), "verdict" A..= ("insufficient" :: T.Text)]]]
A.eitherDecodeStrict (encodeUtf8 (renderNormalization True report)) `shouldBe` Right report
renderNormalization False report `shouldSatisfy` T.isInfixOf "candidate_keys"
renderNormalization False report `shouldSatisfy` T.isInfixOf "insufficient"
it "loads defaults and refuses duplicate JSON fields in declaration files" $ do
directory <- getTemporaryDirectory
bracket (openTempFile directory "normalization-declaration") (\(path, _) -> removeFile path) $ \(path, handle) -> do
hPutStr handle "{}"
hClose handle
loadNormalizationDeclaration path `shouldReturn` Right (NormalizationDeclaration [] [] False Nothing)
BL.writeFile path "{\"atomic_attributes\":true,\"atomic_attributes\":false}"
result <- loadNormalizationDeclaration path
result `shouldSatisfy` either (T.isInfixOf "duplicate") (const False)
@@ -28,6 +28,8 @@ library
ChuSQL.Core.Engine.Runtime.Binding ChuSQL.Core.Engine.Runtime.Binding
ChuSQL.Core.Engine.Runtime.SQL ChuSQL.Core.Engine.Runtime.SQL
ChuSQL.Core.Engine.Runtime.Query ChuSQL.Core.Engine.Runtime.Query
ChuSQL.Core.Engine.Runtime.Relation
ChuSQL.Core.Engine.Runtime.Dependencies
ChuSQL.Core.Engine.Semantic ChuSQL.Core.Engine.Semantic
ChuSQL.Core.Engine.Storage ChuSQL.Core.Engine.Storage
ChuSQL.Core.Engine.Storage.FFI ChuSQL.Core.Engine.Storage.FFI
@@ -44,6 +46,7 @@ library
, parser-combinators , parser-combinators
, scientific , scientific
, text , text
, transformers
, unordered-containers , unordered-containers
, vector , vector
extra-libraries: chusql_core_storage extra-libraries: chusql_core_storage
@@ -53,6 +56,7 @@ library
if os(osx) if os(osx)
ld-options: -Wl,-rpath,@loader_path ld-options: -Wl,-rpath,@loader_path
default-language: Haskell2010 default-language: Haskell2010
default-extensions: ImportQualifiedPost
ghc-options: -Wall ghc-options: -Wall
test-suite chusql-core-engine-test test-suite chusql-core-engine-test
+270 -149
View File
@@ -1,16 +1,19 @@
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.Eval (evalCondForRowM, evalExprM)
import ChuSQL.Core.Engine.Algebra.Expr (evalCondForRow, evalExpr) import ChuSQL.Core.Engine.Algebra.Expr (evalCondForRow, evalExpr)
import ChuSQL.Core.Engine.Runtime.Query (bindQuery, executeQueryM) import ChuSQL.Core.Engine.Runtime.Query (bindQuery, executeQueryM)
import ChuSQL.Core.Model import ChuSQL.Core.Engine.Runtime.Relation (bindWriteColumns, orderRow)
import ChuSQL.Core.Engine.Semantic (prepare, prepareRowExpression) 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 (MonadStorage (..))
import ChuSQL.Core.Engine.Storage.Memory (MemoryStorage (runMemoryStorage)) import ChuSQL.Core.Engine.Storage.Memory (MemoryStorage (runMemoryStorage))
import ChuSQL.Core.Engine.Syntax.AST import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Engine.Syntax.Parser (parseExpression) 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) import Data.Maybe (mapMaybe)
import qualified Data.HashSet as HS
-- 引擎入口:检查语义、按语句分发执行,另有内存实现与泛型版本。 -- 引擎入口:检查语义、按语句分发执行,另有内存实现与泛型版本。
@@ -32,69 +35,141 @@ runStatementM (DropDatabase name) = fmap (fmap (const [])) (dropDatabase name)
runStatementM (UseDatabase name) = fmap (fmap (const [])) (useDatabase name) runStatementM (UseDatabase name) = fmap (fmap (const [])) (useDatabase name)
runStatementM ShowDatabases = fmap (fmap (map (\name -> [("database", VStr name)]))) listDatabases runStatementM ShowDatabases = fmap (fmap (map (\name -> [("database", VStr name)]))) listDatabases
runStatementM q = do runStatementM q = do
db <- schema result <- schema
case prepare db q of case result of
Left err -> pure (Left err) Left err -> pure (Left err)
Right resolved -> runStatementUncheckedM db resolved Right db
| SelectDistinct{} <- q -> runStatementUncheckedM db q
-- | 按语句类型分发(已检查过) | Select{} <- q -> runStatementUncheckedM db q
runStatementUncheckedM :: (MonadStorage m) => Database -> Statement -> m (Either String [Row]) | null (queryTables q) -> case prepare db q >>= bindWriteColumns db of
runStatementUncheckedM db q@Select{} =
case bindQuery db q of
Left e -> pure (Left e)
Right bound -> executeQueryM bound
runStatementUncheckedM db q@SelectExpr{} =
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
Left err -> pure (Left err) Left err -> pure (Left err)
Right rs -> do Right resolved -> runStatementUncheckedM db resolved
result <- insertMany tbl rs | otherwise -> case bindWrite db q of
pure (result >> Right []) Left err -> pure (Left err)
runStatementUncheckedM db (Delete tbl mWhere) = do Right bound -> executeWriteM bound
rowsResult <- scan tbl
case rowsResult 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 () -> withWriteSchemaGuard dependencies (executeWriteActionM catalog action)
-- | 在绑定阶段固定目标槽位与行约束
bindWriteAction :: Database -> Statement -> Either String WriteAction
bindWriteAction catalog statement = case statement of
Insert target columns rows -> do
table <- lookupTable catalog target
checks <- checkPlan table
let plan = InsertPlan (bindInsertTargets (tableCols table) columns) (length columns)
(autoColumn table) checks (constraintPlan (tableCols table))
Right (InsertAction target plan rows)
Update target assignments condition -> do
table <- lookupTable catalog target
bound <- bindUpdateTargets (tableCols table) assignments
checks <- checkPlan table
let plan = UpdatePlan (map fst (tableCols table)) bound condition checks (constraintPlan (tableCols table))
Right (UpdateAction target plan)
Delete target condition -> do
table <- lookupTable catalog target
Right (DeleteAction target (map fst (tableCols table)) condition)
_ -> Right (StructureAction statement)
-- | 直接执行已绑定的数据修改或结构动作
executeWriteActionM :: MonadStorage m => Database -> WriteAction -> m (Either String [Row])
executeWriteActionM _ (InsertAction target plan rows) = do
current <- existingRows target plan
case current >>= \current' -> buildRows plan current' rows of
Left err -> pure (Left err)
Right built -> do
result <- insertMany target built
pure (result >> Right [])
executeWriteActionM catalog (UpdateAction target (UpdatePlan columns assignments condition checks constraints)) = do
current <- scan target
case current >>= mapM (orderRow columns) of
Left err -> pure (Left err) Left err -> pure (Left err)
Right rows -> do 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 case split of
Left err -> pure (Left err) Left err -> pure (Left err)
Right (doomed, kept) -> Right (doomed, kept) -> case mapM rowId doomed of
case mapM rowId doomed of Right ids -> do
Right ids -> do result <- deleteKeys target ids
result <- deleteKeys tbl ids pure (result >> Right [])
pure (result >> Right []) Left _ -> do
Left _ -> do result <- replaceAll target kept
result <- replaceAll tbl kept pure (result >> Right [])
pure (result >> Right [])
where where
-- | 取行里的整数 id,取不到就报错 -- | 取整数主键,否则使用原有整表删除路径
rowId :: Row -> Either String Int rowId row = case lookup "id" row of
rowId r = case lookup "id" r of Just (VInt key) -> Right key
Just (VInt k) -> Right k
_ -> Left "row has no integer id" _ -> Left "row has no integer id"
runStatementUncheckedM db (Update tbl assigns mWhere) = executeWriteActionM catalog (StructureAction statement) = runStatementUncheckedM catalog statement
case lookupTable db tbl of
Left e -> pure (Left e) -- | 绑定并执行查询语句
Right table -> do runQueryM :: MonadStorage m => Database -> Statement -> m (Either String [Row])
rowsResult <- scan tbl runQueryM db q = case bindQuery db q of
case rowsResult of Left e -> pure (Left e)
Left err -> pure (Left err) Right bound -> executeQueryM bound
Right rows -> case checkPlan table of
Left err -> pure (Left err) -- | 分发语句,查询由 BoundQuery 绑定
Right plan -> do runStatementUncheckedM :: (MonadStorage m) => Database -> Statement -> m (Either String [Row])
newRows <- mapM (updateRowM db table plan mWhere assigns) rows runStatementUncheckedM db q@SelectDistinct{} = runQueryM db q
case sequence newRows of runStatementUncheckedM db q@Select{} = runQueryM db q
Left err -> pure (Left err) runStatementUncheckedM _ Insert{} = pure (Left "INSERT requires a bound write plan")
Right rs -> do runStatementUncheckedM _ Update{} = pure (Left "UPDATE requires a bound write plan")
result <- replaceAll tbl rs runStatementUncheckedM _ Delete{} = pure (Left "DELETE requires a bound write plan")
pure (result >> Right [])
runStatementUncheckedM _ (CreateTable name cols) = do runStatementUncheckedM _ (CreateTable name cols) = do
result <- createTable name cols result <- createTable name cols
pure (result >> Right []) pure (result >> Right [])
@@ -104,9 +179,15 @@ runStatementUncheckedM _ (CreateDomain name base) = do
runStatementUncheckedM _ (DropDomain name) = do runStatementUncheckedM _ (DropDomain name) = do
result <- dropTable (domainTableName name) result <- dropTable (domainTableName name)
pure (result >> Right []) pure (result >> Right [])
runStatementUncheckedM db ShowDomains = pure (Right runStatementUncheckedM db ShowDomains =
[[("domain", VStr (drop (length (domainTableName "")) name)), ("base_type", VStr (typeName (columnType base)))] pure
| (name, table) <- db, isDomainTable name, Just base <- [lookup "base" (tableCols table)]]) ( Right
[ [("domain", VStr (drop (length (domainTableName "")) name)), ("base_type", VStr (typeName (columnType base)))]
| (name, table) <- db
, isDomainTable name
, Just base <- [lookup "base" (tableCols table)]
]
)
runStatementUncheckedM _ (DropTable name) = do runStatementUncheckedM _ (DropTable name) = do
result <- dropTable name result <- dropTable name
pure (result >> Right []) pure (result >> Right [])
@@ -132,11 +213,13 @@ runStatementUncheckedM db (AlterColumnNull tbl col nullable) =
runStatementUncheckedM _ CreateUser{} = pure (Left "CREATE USER is executed by the account service") runStatementUncheckedM _ CreateUser{} = pure (Left "CREATE USER is executed by the account service")
runStatementUncheckedM _ AlterUser{} = pure (Left "ALTER USER is executed by the account service") runStatementUncheckedM _ AlterUser{} = pure (Left "ALTER USER is executed by the account service")
runStatementUncheckedM _ AlterIdentity{} = pure (Left "ALTER ROLE is executed by the account service") runStatementUncheckedM _ AlterIdentity{} = pure (Left "ALTER ROLE is executed by the account service")
runStatementUncheckedM _ ShowGrants = pure (Left "SHOW GRANTS is executed by the account service")
runStatementUncheckedM _ ShowRoles = pure (Left "SHOW ROLES is executed by the account service") runStatementUncheckedM _ ShowRoles = pure (Left "SHOW ROLES is executed by the account service")
runStatementUncheckedM _ DropUser{} = pure (Left "DROP USER is executed by the account service") runStatementUncheckedM _ DropUser{} = pure (Left "DROP USER is executed by the account service")
runStatementUncheckedM _ CreateRole{} = pure (Left "CREATE ROLE is executed by the privilege service") runStatementUncheckedM _ CreateRole{} = pure (Left "CREATE ROLE is executed by the privilege service")
runStatementUncheckedM _ DropRole{} = pure (Left "DROP ROLE is executed by the privilege service") runStatementUncheckedM _ DropRole{} = pure (Left "DROP ROLE is executed by the privilege service")
runStatementUncheckedM _ GrantPrivileges{} = pure (Left "GRANT is executed by the privilege service") runStatementUncheckedM _ GrantPrivileges{} = pure (Left "GRANT is executed by the privilege service")
runStatementUncheckedM _ RevokeGrantOption{} = pure (Left "REVOKE is executed by the privilege service")
runStatementUncheckedM _ RevokePrivileges{} = pure (Left "REVOKE is executed by the privilege service") runStatementUncheckedM _ RevokePrivileges{} = pure (Left "REVOKE is executed by the privilege service")
runStatementUncheckedM _ GrantRole{} = pure (Left "GRANT is executed by the privilege service") runStatementUncheckedM _ GrantRole{} = pure (Left "GRANT is executed by the privilege service")
runStatementUncheckedM _ RevokeRole{} = pure (Left "REVOKE is executed by the privilege service") runStatementUncheckedM _ RevokeRole{} = pure (Left "REVOKE is executed by the privilege service")
@@ -152,62 +235,67 @@ runStatementUncheckedM _ RollbackToSavepoint{} = pure (Left "ROLLBACK TO is exec
runStatementUncheckedM _ ReleaseSavepoint{} = pure (Left "RELEASE is executed by the session") runStatementUncheckedM _ ReleaseSavepoint{} = pure (Left "RELEASE is executed by the session")
-- | 只有需要读全表才能判断约束时才扫表 -- | 只有需要读全表才能判断约束时才扫表
existingRows :: (MonadStorage m) => String -> Table -> m (Either String [Row]) existingRows :: (MonadStorage m) => String -> InsertPlan -> m (Either String [Row])
existingRows tbl table existingRows tbl (InsertPlan _ _ auto _ (ConstraintPlan _ _ unique))
| needsRows table = scan tbl | Just _ <- auto = scan tbl
| not (null unique) = scan tbl
| otherwise = pure (Right []) | 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 :: InsertPlan -> [Row] -> [[Expr]] -> Either String [Row]
buildRows table current cols rows = do buildRows (InsertPlan layout width auto checks constraints) current rows = do
values <- mapM (mapM (\e -> evalExpr e [])) rows values <- mapM (mapM (`evalExpr` [])) rows
if any (\vals -> length vals /= length cols) values if any (\vals -> length vals /= width) values
then Left "column count does not match value count" then Left "column count does not match value count"
else do else go (autoStart auto current) values []
let auto = autoColumn table
go auto (autoStart auto current) values []
where where
-- | 逐行构造,最后统一查一遍约束 -- \| 逐行构造,最后统一查一遍约束
go _ _ [] acc = do go _ [] acc = do
let built = reverse acc let built = reverse acc
plan <- checkPlan table mapM_ (runChecks checks) built
mapM_ (runChecks plan) built enforceConstraints constraints current built
enforceNotNull (tableCols table) built
enforceUnique (tableCols table) (current ++ built)
Right built Right built
go auto counter (vals : rest) acc = do go counter (vals : rest) acc = do
(row, counter') <- buildRow table auto cols counter vals (row, counter') <- buildRow layout auto counter vals
go auto counter' rest (row : acc) go counter' rest (row : acc)
-- | 按列定义补出一行 -- | 保存输出列定义及可选 VALUES 槽位
buildRow :: Table -> Maybe (String, Column) -> [String] -> Int -> [Value] -> Either String (Row, Int) data BoundInsertColumn = BoundInsertColumn String Column (Maybe Int)
buildRow table auto cols counter vals = go (tableCols table) counter []
-- | 把已校验的目标清单绑定为输入槽位
bindInsertTargets :: [(String, Column)] -> [String] -> [BoundInsertColumn]
bindInsertTargets columns targets =
[BoundInsertColumn name column (lookup name positions) | (name, column) <- columns]
where 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 [] c acc = Right (reverse acc, c)
go ((name, col) : rest) c acc = do go (BoundInsertColumn name col position : rest) c acc = do
(v, c') <- pick name col c 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 v' <- coerceValue (columnType col) v
go rest c' ((name, v') : acc) go rest c' ((name, v') : acc)
-- | 决定这一列取什么值 -- \| 决定这一列取什么值
pick name col c pick name col supplied c
| Just (autoName, _) <- auto | Just (autoName, _) <- auto
, name == autoName , name == autoName
, maybe True (== VNull) (lookup name provided) = Right (VInt c, c + 1) , maybe True (== VNull) supplied =
| Just v <- lookup name provided = Right (v, bump name col c v) Right (VInt c, c + 1)
| Just v <- supplied = Right (v, bump name c v)
| Just d <- columnDefault col = Right (d, c) | Just d <- columnDefault col = Right (d, c)
| columnNullable col = Right (VNull, c) | columnNullable col = Right (VNull, c)
| otherwise = Left ("INSERT: column " ++ name ++ " is NOT NULL and has no default") | otherwise = Left ("INSERT: column " ++ name ++ " is NOT NULL and has no default")
-- | 自增值跟着已有的值往前推 -- \| 自增值跟着已有的值往前推
bump name _ c v bump name c v
| Just (autoName, _) <- auto | Just (autoName, _) <- auto
, name == autoName = max (c + 1) (valueInt v + 1) , name == autoName =
max (c + 1) (valueInt v + 1)
| otherwise = c | otherwise = c
-- | 取自增值,不是整数就当 0 -- | 取自增值,不是整数就当 0
@@ -229,27 +317,29 @@ autoStart (Just (name, _)) rows = case [n | r <- rows, Just (VInt n) <- [lookup
ns -> maximum ns + 1 ns -> maximum ns + 1
-- | 一次解析出来的 CHECK 条件 -- | 一次解析出来的 CHECK 条件
type CheckPlan = [(String, Expr)] data CheckPlan = CheckPlan [String] [(String, Expr)]
-- | 把表上的 CHECK 文本解析成条件,每语句只解析一次 -- | 按 schema 解析并绑定表上全部 CHECK
checkPlan :: Table -> Either String CheckPlan 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 where
-- | 只挑出带 CHECK 文本的列 -- \| 只挑出带 CHECK 文本的列
checked (name, col) = (,) name <$> columnCheck col checked (name, col) = (,) name <$> columnCheck col
-- | 解析一列的 CHECK 文本 -- \| 解析一列的 CHECK 文本
parse (name, text) = case parseExpression text of parse (name, text) = case parseExpression text of
Left err -> Left ("CHECK on " ++ name ++ ": " ++ firstLine err) Left err -> Left ("CHECK on " ++ name ++ ": " ++ firstLine err)
Right e -> do Right e -> do
bound <- prepareRowExpression (tableCols table) e bound <- prepareCheckExpression (tableCols table) e
Right (name, bound) Right (name, bound)
-- | 执行解析好的 CHECK 条件 -- | 执行解析好的 CHECK 条件
runChecks :: CheckPlan -> Row -> Either String () 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 where
-- | 跑一条 CHECK -- \| 跑一条 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) Left err -> Left ("CHECK on " ++ name ++ ": " ++ err)
Right True -> Right () Right True -> Right ()
Right False -> Left ("CHECK on " ++ name ++ " failed") Right False -> Left ("CHECK on " ++ name ++ " failed")
@@ -258,34 +348,52 @@ runChecks plan row = mapM_ check plan
firstLine :: String -> String firstLine :: String -> String
firstLine = takeWhile (/= '\n') firstLine = takeWhile (/= '\n')
-- | NOT NULL 检查 -- | 保存非空及唯一键的固定列槽位
enforceNotNull :: [(String, Column)] -> [Row] -> Either String () data ConstraintPlan = ConstraintPlan [String] [(String, Expr)] [(String, Expr)]
enforceNotNull cols rows = mapM_ check cols
-- | 按 schema 一次绑定行集约束目标
constraintPlan :: [(String, Column)] -> ConstraintPlan
constraintPlan columns = ConstraintPlan (map fst columns) required unique
where where
-- | 查这一列的 NOT NULL slots = [(name, column, ColumnSlot slot name) | (slot, (name, column)) <- zip [0 ..] columns]
check (name, col) required = [(name, reference) | (name, column, reference) <- slots, not (columnNullable column)]
| columnNullable col = Right () unique = [(name, reference) | (name, column, reference) <- slots, columnUnique column || columnPrimaryKey column]
| any (\r -> lookup name r == Just VNull) rows = Left ("NOT NULL: column " ++ name ++ " cannot be null")
| otherwise = Right () -- | 检查新行非空及合并旧行后的唯一性
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 之间不算冲突) -- | 唯一性检查(NULL 之间不算冲突)
enforceUnique :: [(String, Column)] -> [Row] -> Either String () enforceUnique :: [(String, Expr)] -> [Row] -> Either String ()
enforceUnique cols rows = mapM_ check targets enforceUnique targets rows = mapM_ check targets
where where
targets = [(n, c) | (n, c) <- cols, columnUnique c || columnPrimaryKey c] -- \| 查这一列有没有重复值
-- | 查这一列有没有重复值 check (name, reference) = mapM (evalExpr reference) rows >>= go name HS.empty
check (name, _) = go name HS.empty (mapMaybe (lookup name) rows) -- \| 逐个值比过去
-- | 逐个值比过去
go _ _ [] = Right () go _ _ [] = Right ()
-- | NULL 不算冲突,跳过 -- \| NULL 不算冲突,跳过
go name seen (VNull : rest) = go name seen rest go name seen (VNull : rest) = go name seen rest
go name seen (v : rest) go name seen (v : rest)
| HS.member (canonicalValue v) seen = Left ("UNIQUE: duplicate value in column " ++ name) | HS.member (canonicalValue v) seen = Left ("UNIQUE: duplicate value in column " ++ name)
| otherwise = go name (HS.insert (canonicalValue v) seen) rest | otherwise = go name (HS.insert (canonicalValue v) seen) rest
-- | UPDATE 的一行(条件与赋值都可能带子查询) -- | UPDATE 的一行(条件与赋值都可能带子查询)
updateRowM :: (MonadStorage m) => Database -> Table -> CheckPlan -> Maybe Expr -> [(String, Expr)] -> Row -> m (Either String Row) updateRowM :: (MonadStorage m) => Database -> CheckPlan -> Maybe Expr -> [BoundAssignment] -> Row -> m (Either String Row)
updateRowM db table plan cond asgns row = do updateRowM db plan cond asgns row = do
keep <- case cond of keep <- case cond of
Nothing -> pure (Right True) Nothing -> pure (Right True)
Just e -> evalCondForRowM db e row Just e -> evalCondForRowM db e row
@@ -293,31 +401,45 @@ updateRowM db table plan cond asgns row = do
Left err -> pure (Left err) Left err -> pure (Left err)
Right False -> pure (Right row) Right False -> pure (Right row)
Right True -> do Right True -> do
row' <- applyUpdatesM db table asgns row row' <- applyUpdatesM db asgns row
pure (row' >>= \r -> runChecks plan r >> Right r) pure (row' >>= \r -> runChecks plan r >> Right r)
-- | 依次求值、收类型并覆盖列(表达式可以带子查询) -- | 保存赋值目标槽位、列定义和右侧表达式
applyUpdatesM :: (MonadStorage m) => Database -> Table -> [(String, Expr)] -> Row -> m (Either String Row) data BoundAssignment = BoundAssignment Int String Column Expr
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)
-- | 覆盖一列 -- | 按 schema 一次绑定全部赋值目标
setColumn :: String -> Value -> Row -> Row bindUpdateTargets :: [(String, Column)] -> [(String, Expr)] -> Either String [BoundAssignment]
setColumn col v = map (\(k, val) -> if k == col then (k, v) else (k, val)) 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])) splitByConditionM :: (MonadStorage m) => Database -> Maybe Expr -> [Row] -> m (Either String ([Row], [Row]))
splitByConditionM db cond = go [] [] splitByConditionM db cond = go [] []
where where
-- | 逐行分流 -- \| 逐行分流
go doomed kept [] = pure (Right (reverse doomed, reverse kept)) go doomed kept [] = pure (Right (reverse doomed, reverse kept))
go doomed kept (r : rs) = do go doomed kept (r : rs) = do
hit <- case cond of hit <- case cond of
@@ -338,7 +460,7 @@ alterTable db tbl change = case lookupTable db tbl of
Left e -> pure (Left e) Left e -> pure (Left e)
Right table -> do Right table -> do
rowsResult <- scan tbl rowsResult <- scan tbl
case rowsResult of case rowsResult >>= mapM (orderRow (map fst (tableCols table))) of
Left e -> pure (Left e) Left e -> pure (Left e)
Right rows -> case change table{tableRows = rows} >>= checkAltered of Right rows -> case change table{tableRows = rows} >>= checkAltered of
Left e -> pure (Left e) Left e -> pure (Left e)
@@ -346,13 +468,12 @@ alterTable db tbl change = case lookupTable db tbl of
result <- replaceSchema tbl cols newRows result <- replaceSchema tbl cols newRows
pure (result >> Right []) pure (result >> Right [])
where where
-- | 改完再统一查一遍约束 -- \| 改完再统一查一遍约束
checkAltered (cols, rows) = do checkAltered (cols, rows) = do
let table = Table tbl cols rows Nothing let table = Table tbl cols rows Nothing Nothing Nothing
plan <- checkPlan table plan <- checkPlan table
mapM_ (runChecks plan) rows mapM_ (runChecks plan) rows
enforceNotNull cols rows enforceConstraints (constraintPlan cols) [] rows
enforceUnique cols rows
Right (cols, rows) Right (cols, rows)
-- | ADD COLUMN:老行补默认值或 NULL -- | ADD COLUMN:老行补默认值或 NULL
@@ -387,7 +508,7 @@ retypeColumn col ty cols rows
rows' <- mapM convert rows rows' <- mapM convert rows
Right (map (\entry@(n, c) -> if n == col then (n, c{columnType = ty}) else entry) cols, rows') Right (map (\entry@(n, c) -> if n == col then (n, c{columnType = ty}) else entry) cols, rows')
where where
-- | 把这一列的老值收进新类型 -- \| 把这一列的老值收进新类型
convert row = case lookup col row of convert row = case lookup col row of
Nothing -> Right row Nothing -> Right row
Just v -> do Just v -> do
@@ -1,5 +1,6 @@
module ChuSQL.Core.Engine.Algebra.Cost (tableMetaOf, probeCost, pointRows, rangeRows, selectivityOf, indexCheaper) where module ChuSQL.Core.Engine.Algebra.Cost (tableMetaOf, probeCost, pointRows, rangeRows, selectivityOf, indexCheaper) where
import Data.Maybe (fromMaybe)
import ChuSQL.Core.Model import ChuSQL.Core.Model
-- 统计与成本估算:行数、不同值数、列直方图与索引探路页数。 -- 统计与成本估算:行数、不同值数、列直方图与索引探路页数。
@@ -32,8 +33,8 @@ estimateRows h lo hi = max 0 (min total (round (sum (zipWith overlap [0 ..] (his
where where
total = sum (histBuckets h) total = sum (histBuckets h)
width = if histHigh h > histLow h then (histHigh h - histLow h) / fromIntegral (length (histBuckets h)) else 0 width = if histHigh h > histLow h then (histHigh h - histLow h) / fromIntegral (length (histBuckets h)) else 0
lower = maybe (-1 / 0) id (boundOf lo) lower = fromMaybe (- (1 / 0)) (boundOf lo)
upper = maybe (1 / 0) id (boundOf hi) upper = fromMaybe (1 / 0) (boundOf hi)
-- | 第 i 个桶与区间重叠的行数 -- | 第 i 个桶与区间重叠的行数
overlap :: Int -> Int -> Double overlap :: Int -> Int -> Double
overlap i count overlap i count
@@ -1,22 +1,44 @@
{-# LANGUAGE TupleSections #-}
module ChuSQL.Core.Engine.Algebra.Eval (evalRelOp, evalRelOpM, evalExprM, evalCondForRowM) where module ChuSQL.Core.Engine.Algebra.Eval (evalRelOp, evalRelOpM, evalExprM, evalCondForRowM) where
import ChuSQL.Core.Engine.Algebra.Cost (tableMetaOf) 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.Optimize (optimize)
import ChuSQL.Core.Engine.Algebra.Op import ChuSQL.Core.Engine.Algebra.Op
import ChuSQL.Core.Engine.Algebra.Planner (translate) import ChuSQL.Core.Engine.Algebra.Planner (translate)
import ChuSQL.Core.Engine.Algebra.Sort (sortRows) import ChuSQL.Core.Engine.Algebra.Sort (sortRows, sortBoundRows)
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.Model
import ChuSQL.Core.Engine.Storage (IndexResult (..), MonadStorage (..)) import ChuSQL.Core.Engine.Storage (IndexResult (..), MonadStorage (..))
import ChuSQL.Core.Engine.Storage.Memory (runMemoryStorage) import ChuSQL.Core.Engine.Storage.Memory (runMemoryStorage)
import ChuSQL.Core.Engine.Syntax.AST (Expr (..), JoinKind (..), Subquery (..)) import ChuSQL.Core.Engine.Syntax.AST (Expr (..), JoinKind (..), Subquery (..))
import Control.Monad (filterM) 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 Data.List (nub)
import qualified Data.HashMap.Strict as HM 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 :: [String] -> Row -> Row
project ["*"] row = row project ["*"] row = row
@@ -79,11 +101,23 @@ data EquiKeys = EquiKeys
-- | 认出 a = b 这种两列等值条件,并且能分清谁在左谁在右 -- | 认出 a = b 这种两列等值条件,并且能分清谁在左谁在右
equiKeys :: [String] -> [String] -> Expr -> Maybe EquiKeys equiKeys :: [String] -> [String] -> Expr -> Maybe EquiKeys
equiKeys lcols rcols (Eq (Col a) (Col b)) equiKeys lcols rcols (Eq left right)
| a /= b, a `elem` lcols, b `elem` rcols = Just (EquiKeys a b) | Just a <- columnName left, Just b <- columnName right
| a /= b, b `elem` lcols, a `elem` rcols = Just (EquiKeys b a) , a /= b, a `elem` lcols, b `elem` rcols = Just (EquiKeys a b)
| Just a <- columnName left, Just b <- columnName right
, a /= b, b `elem` lcols, a `elem` rcols = Just (EquiKeys b a)
equiKeys _ _ _ = Nothing equiKeys _ _ _ = Nothing
-- | 提取执行列的诊断名称
columnName :: Expr -> Maybe String
columnName (Col name) = Just name
columnName (ColumnSlot _ name) = Just name
columnName _ = Nothing
-- | 在存储边界按输入布局排列行
orderedRows :: [String] -> [Row] -> Either String [Row]
orderedRows columns = mapM (orderRow columns)
-- | 连接两批行:等值键走哈希,否则嵌套循环 -- | 连接两批行:等值键走哈希,否则嵌套循环
joinRowsIn :: joinRowsIn ::
(MonadStorage m) => (MonadStorage m) =>
@@ -94,7 +128,7 @@ joinRowsIn ::
Expr -> Expr ->
[Row] -> [Row] ->
[Row] -> [Row] ->
m (Either String [Row]) Execution m (Either String [Row])
joinRowsIn db outer kind rcols cond lrows rrows = joinRowsIn db outer kind rcols cond lrows rrows =
case equiKeys (rowsCols lrows) rcols cond of case equiKeys (rowsCols lrows) rcols cond of
Just ks -> pure (Right (hashJoin kind ks ncols lrows rrows)) Just ks -> pure (Right (hashJoin kind ks ncols lrows rrows))
@@ -103,6 +137,37 @@ joinRowsIn db outer kind rcols cond lrows rrows =
-- 右表为空时行上没有列名,用算子推导出来的列名补 NULL -- 右表为空时行上没有列名,用算子推导出来的列名补 NULL
ncols = if null rrows then rcols else rowsCols rrows 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,内连接丢弃 -- | 左连接配不上的左行补 NULL,内连接丢弃
unmatched :: JoinKind -> Row -> [String] -> [Row] unmatched :: JoinKind -> Row -> [String] -> [Row]
unmatched InnerJoin _ _ = [] unmatched InnerJoin _ _ = []
@@ -135,10 +200,10 @@ filterPairsM ::
Expr -> Expr ->
[Row] -> [Row] ->
[Row] -> [Row] ->
m (Either String [Row]) Execution m (Either String [Row])
filterPairsM db outer kind ncols cond lrows rrows = go lrows [] HM.empty filterPairsM db outer kind ncols cond lrows rrows = go lrows [] HM.empty
where where
refs = subqueryRefsIn cond refs = subquerySlotsIn cond
-- | 逐左行配对,左连接没配上就补 NULL -- | 逐左行配对,左连接没配上就补 NULL
go [] acc _ = pure (Right (reverse acc)) go [] acc _ = pure (Right (reverse acc))
go (l : ls) acc cache = do go (l : ls) acc cache = do
@@ -154,15 +219,17 @@ filterPairsM db outer kind ncols cond lrows rrows = go lrows [] HM.empty
keep _ [] acc cache = pure (Right (reverse acc, cache)) keep _ [] acc cache = pure (Right (reverse acc, cache))
keep l (r : rs) acc cache = do keep l (r : rs) acc cache = do
let env = l ++ r ++ outer let env = l ++ r ++ outer
key = bindingKey refs env case bindingKey refs env of
resolved <- case HM.lookup key cache of Left err -> pure (Left err)
Just expression -> pure (Right expression) Right key -> do
Nothing -> substSubqueries db cond env resolved <- case HM.lookup key cache of
case resolved of Just expression -> pure (Right expression)
Left e -> pure (Left e) Nothing -> substSubqueries db cond env
Right expression -> case evalCondForRow expression env of case resolved of
Left e -> pure (Left e) Left e -> pure (Left e)
Right matches -> keep l rs (if matches then (l ++ r) : acc else acc) (HM.insert key expression cache) Right expression -> case evalCondForRow expression env of
Left e -> pure (Left e)
Right matches -> keep l rs (if matches then (l ++ r) : acc else acc) (HM.insert key expression cache)
nullRow = [(c, VNull) | c <- ncols] nullRow = [(c, VNull) | c <- ncols]
-- | 索引连接:右表是裸 Scan 时逐左行点查 -- | 索引连接:右表是裸 Scan 时逐左行点查
@@ -177,19 +244,20 @@ probeIndexJoin ::
[String] -> [String] ->
Expr -> Expr ->
Row -> 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 probeIndexJoin db outer kind mAlias t ks rcols cond l = case lookup (ekLeft ks) l of
Nothing -> pure (Right (Just (unmatched kind l rcols))) Nothing -> pure (Right (Just (unmatched kind l rcols)))
Just k Just k
| not (indexSafe db t (unqualify mAlias (ekRight ks)) k) -> pure (Right Nothing) | not (indexSafe db t (unqualify mAlias (ekRight ks)) k) -> pure (Right Nothing)
| otherwise -> do | otherwise -> do
res <- lookupByColumn t (unqualify mAlias (ekRight ks)) k res <- lift (lookupByColumn t (unqualify mAlias (ekRight ks)) k)
case res of case res of
Left e -> pure (Left e) Left e -> pure (Left e)
Right NoIndex -> pure (Right Nothing) Right NoIndex -> pure (Right Nothing)
Right (IndexRows rows) -> do Right (IndexRows rows) -> do
pairs <- joinRowsIn db outer kind rcols cond [l] (prefixRows mAlias rows) case orderedRows rcols (prefixRows mAlias rows) of
pure (fmap Just pairs) Left err -> pure (Left err)
Right ordered -> fmap (fmap Just) (joinRowsIn db outer kind rcols cond [l] ordered)
-- | 列与键都不是浮点时才敢用索引 -- | 列与键都不是浮点时才敢用索引
indexSafe :: Database -> String -> String -> Value -> Bool indexSafe :: Database -> String -> String -> Value -> Bool
@@ -213,26 +281,23 @@ floatValue (VFloat _) = True
floatValue _ = False floatValue _ = False
-- | 分组键的值 -- | 分组键的值
groupKey :: [String] -> Row -> Either String [Value] groupKey :: Row -> [Expr] -> Row -> Either String [Value]
groupKey keys row = mapM get keys groupKey outer keys row = mapM (\key -> evalExpr key (row ++ outer)) keys
where
-- | 取这一列的分组值
get c = maybe (Left ("unknown column: " ++ c)) Right (lookup c row)
-- | 按分组键把行分组,保留分组首次出现的顺序 -- | 按分组键把行分组,保留分组首次出现的顺序
groupRows :: [String] -> [Row] -> Either String [([Value], [Row])] groupRows :: Row -> [Expr] -> [Row] -> Either String [([Value], [Row])]
groupRows keys rows = go rows (HM.empty, []) groupRows outer keys rows = go rows (HM.empty, [])
where where
-- | 逐行塞进对应分组,并记住分组首次出现的顺序 -- | 逐行塞进对应分组,并记住分组首次出现的顺序
go [] (acc, order) = Right [(k, reverse (HM.lookupDefault [] k acc)) | k <- reverse order] go [] (acc, order) = Right [(k, reverse (HM.lookupDefault [] k acc)) | k <- reverse order]
go (r : rs) (acc, order) = do go (r : rs) (acc, order) = do
k <- groupKey keys r k <- groupKey outer keys r
let order' = if HM.member k acc then order else k : order let order' = if HM.member k acc then order else k : order
go rs (HM.insertWith (++) k [r] acc, order') go rs (HM.insertWith (++) k [r] acc, order')
-- | 一组行上求同一个表达式(外层列从 outer 取) -- | 一组行上求同一个表达式(外层列从 outer 取)
valuesOf :: Row -> Expr -> [Row] -> Either String [Value] 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 evalAgg :: Row -> Expr -> [Row] -> Either String Value
@@ -249,15 +314,22 @@ oneGroup outer keys aggs (keyValues, rows) = do
Right (zip keys keyValues ++ zip (map fst aggs) values) Right (zip keys keyValues ++ zip (map fst aggs) values)
-- | 分组求值:没有分组列时,即使没有行也要出一行 -- | 分组求值:没有分组列时,即使没有行也要出一行
evalAggregate :: Row -> [String] -> [(String, Expr)] -> [Row] -> Either String [Row] evalAggregate :: Row -> [(String, Expr)] -> [(String, Expr)] -> [Row] -> Either String [Row]
evalAggregate outer keys aggs rows = do evalAggregate outer keys aggs rows = do
groups <- groupRows keys rows groups <- groupRows outer (map snd keys) rows
let top = if null keys && null groups then [([], [])] else groups let top = if null keys && null groups then [([], [])] else groups
mapM (oneGroup outer keys aggs) top mapM (oneGroup outer (map fst keys) aggs) top
-- | 绑定键:子查询引用的外层列在这一行上的取值 -- | 绑定键:子查询引用的外层列在这一行上的取值
bindingKey :: [String] -> Row -> String bindingKey :: [Expr] -> Row -> Either String String
bindingKey refs env = show [(c, bindingValue c env) | c <- refs] 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 bindingValue :: String -> Row -> Maybe Value
@@ -267,15 +339,15 @@ bindingValue column env = case lookup column env of
Nothing -> Nothing Nothing -> Nothing
-- | 每个绑定留第一行当样本,去掉重复绑定 -- | 每个绑定留第一行当样本,去掉重复绑定
bindingSamples :: [String] -> Row -> [Row] -> [(String, Row)] bindingSamples :: [Expr] -> Row -> [Row] -> Either String [(String, Row)]
bindingSamples refs outer rows = go rows HM.empty [] bindingSamples refs outer rows = go rows HM.empty []
where where
-- | 逐行按绑定键去重 -- | 逐行按绑定键去重
go [] _ acc = reverse acc go [] _ acc = Right (reverse acc)
go (r : rs) seen acc = go (r : rs) seen acc = do
let env = r ++ outer let env = r ++ outer
k = bindingKey refs env k <- bindingKey refs env
in case HM.lookup k seen of case HM.lookup k seen of
Just _ -> go rs seen acc Just _ -> go rs seen acc
Nothing -> go rs (HM.insert k () seen) ((k, env) : acc) Nothing -> go rs (HM.insert k () seen) ((k, env) : acc)
@@ -286,28 +358,34 @@ bindingsTableM ::
Row -> Row ->
[Expr] -> [Expr] ->
[Row] -> [Row] ->
m (Either String (HM.HashMap String [Expr])) Execution m (Either String (HM.HashMap String [Expr]))
bindingsTableM db outer exprs rows = do bindingsTableM db outer exprs rows = case bindingSamples refs outer rows of
built <- mapM swap (bindingSamples refs outer rows) Left err -> pure (Left err)
pure (fmap HM.fromList (sequence built)) Right samples -> do
built <- mapM swap samples
pure (fmap HM.fromList (sequence built))
where where
refs = nub (concatMap subqueryRefsIn exprs) refs = nub (concatMap subquerySlotsIn exprs)
-- | 一个绑定样本上把子查询全换成字面量 -- | 一个绑定样本上把子查询全换成字面量
swap (key, env) = do swap (key, env) = do
es <- mapM (\e -> substSubqueries db e env) exprs 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 :: [Expr] -> Row -> HM.HashMap String [Expr] -> Either String [Expr]
boundExprs refs env table = case HM.lookup (bindingKey refs env) table of boundExprs refs env table = do
Just es -> Right es key <- bindingKey refs env
Nothing -> Left "subquery binding is missing" 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 :: [Expr] -> Row -> HM.HashMap String [Expr] -> Either String Expr
boundExpr refs env table = case boundExprs refs env table of boundExpr refs env table = do
Right [x] -> Right x expressions <- boundExprs refs env table
_ -> Left "subquery binding is missing" case expressions of
[x] -> Right x
_ -> Left "subquery binding is missing"
-- | 单子过滤:条件本身是单子求值的 -- | 单子过滤:条件本身是单子求值的
filterRowsM :: (Monad m) => (Row -> m (Either String Bool)) -> [Row] -> m (Either String [Row]) filterRowsM :: (Monad m) => (Row -> m (Either String Bool)) -> [Row] -> m (Either String [Row])
@@ -323,26 +401,34 @@ filterRowsM p = go []
Right False -> go acc rs 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 [] computeM db outer items row = go items []
where where
-- | 逐项求值并攒成一行 -- | 逐项求值并攒成一行
go [] acc = pure (Right (reverse acc)) go [] acc = pure (Right (reverse acc))
go ((label, e) : rest) acc = do go ((label, e) : rest) acc = do
v <- evalExprM db e (row ++ outer) v <- evalExprIn db e (row ++ outer)
case v of case v of
Left err -> pure (Left err) Left err -> pure (Left err)
Right val -> go rest ((label, val) : acc) Right val -> go rest ((label, val) : acc)
-- | 表达式求值(先把子查询求成字面量) -- | 表达式求值(先把子查询求成字面量)
evalExprM :: (MonadStorage m) => Database -> Expr -> Row -> m (Either String Value) 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 e' <- substSubqueries db e env
pure (e' >>= \x -> evalExpr x env) pure (e' >>= \x -> evalExpr x env)
-- | 条件求值(先把子查询求成字面量) -- | 条件求值(先把子查询求成字面量)
evalCondForRowM :: (MonadStorage m) => Database -> Expr -> Row -> m (Either String Bool) 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 e' <- substSubqueries db e env
pure (e' >>= \x -> evalCondForRow x env) pure (e' >>= \x -> evalCondForRow x env)
@@ -361,7 +447,7 @@ scalarResult rows = do
_ -> Left "scalar subquery returned more than one row" _ -> 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 substSubqueries db e env = case e of
Construct tid arguments -> do Construct tid arguments -> do
bound <- mapM (\argument -> substSubqueries db argument env) arguments bound <- mapM (\argument -> substSubqueries db argument env) arguments
@@ -431,37 +517,42 @@ substSubqueries db e env = case e of
Left err -> pure (Left err) Left err -> pure (Left err)
Right a' -> do Right a' -> do
rb <- substSubqueries db b env rb <- substSubqueries db b env
pure ((ctor a') <$> rb) pure (ctor a' <$> rb)
-- | 递归处理一个子表达式 -- | 递归处理一个子表达式
un ctor a = do un ctor a = do
ra <- substSubqueries db a env ra <- substSubqueries db a env
pure (ctor <$> ra) 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 runSubqueryRows db sq outer = case translate (subqueryStatement sq) of
Left e -> pure (Left e) 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) Left err -> pure (Left err)
Right bindings -> evalRelOpIn db (bindings ++ outer) (optimize db op) Right bindings -> case bindRelOpColumns db (map fst (bindings ++ outer)) (optimize db op) of
Left err -> pure (Left err)
Right bound -> materialize (show ("subquery", subqueryStatement sq, bindings, fallback))
(evalRelOpIn db (bindings ++ outer) bound)
where where
-- | 原始调用未证明依赖完整,保留整个外层行
fallback = case sq of
Subquery{} -> Just outer
BoundSubquery{} -> Nothing
-- | 给外层物理列补回已解析的限定名 -- | 给外层物理列补回已解析的限定名
bind column = case bindingValue column outer of bind (column, expression) = (,) column <$> bindingReferenceValue expression outer
Just value -> Right (column, value)
Nothing -> Left ("unknown outer column: " ++ column)
-- | 单子求值:Scan/点查/范围查都问存储 -- | 单子求值:Scan/点查/范围查都问存储
evalRelOpM :: (MonadStorage m) => Database -> RelOp -> m (Either String [Row]) 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 :: Database -> RelOp -> Either String [Row]
evalRelOp db op = do evalRelOp db op = do
(result, _) <- runMemoryStorage (evalRelOpIn db [] op) db (result, _) <- runMemoryStorage (evalRelOpM db op) db
result 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 _ _ Unit = pure (Right [[]])
evalRelOpIn db outer (Compute items op) = do evalRelOpIn db outer (Compute items op) = do
rows <- evalRelOpIn db outer op rows <- evalRelOpIn db outer op
@@ -475,40 +566,43 @@ evalRelOpIn db outer (Compute items op) = do
table <- bindingsTableM db outer (map snd items) rs table <- bindingsTableM db outer (map snd items) rs
pure (table >>= \t -> traverse (computeBound t) rs) pure (table >>= \t -> traverse (computeBound t) rs)
where where
refs = nub (concatMap (subqueryRefsIn . snd) items) refs = nub (concatMap (subquerySlotsIn . snd) items)
-- | 用这一行绑定换好的表达式算出一行 -- | 用这一行绑定换好的表达式算出一行
computeBound table r = do computeBound table r = do
es <- boundExprs refs (r ++ outer) table es <- boundExprs refs (r ++ outer) table
mapM (\(label, e) -> (,) label <$> evalExpr e (r ++ outer)) (zip (map fst items) es) mapM (\(label, e) -> (,) label <$> evalExpr e (r ++ outer)) (zip (map fst items) es)
evalRelOpIn db outer (Aggregate keys aggs op) = do evalRelOpIn db outer (Aggregate keys aggs op) = do
rows <- evalRelOpIn db outer op
pure (rows >>= evalAggregate outer [(name, Col name) | name <- keys] aggs)
evalRelOpIn db outer (BoundAggregate keys aggs op) = do
rows <- evalRelOpIn db outer op rows <- evalRelOpIn db outer op
pure (rows >>= evalAggregate outer keys aggs) pure (rows >>= evalAggregate outer keys aggs)
evalRelOpIn db _ (Scan mAlias tbl cols) = do evalRelOpIn db _ (Scan mAlias tbl cols) = do
res <- scanTable db tbl cols res <- scanTable db tbl cols
pure (fmap (prefixRows mAlias) res) pure (res >>= orderedRows (relOpCols db (Scan mAlias tbl cols)) . prefixRows mAlias)
evalRelOpIn db outer (Lookup mAlias tbl col k) = do evalRelOpIn db outer (Lookup mAlias tbl col k) = do
res <- lookupByColumn tbl col k res <- lift (lookupByColumn tbl col k)
case res of case res of
Left e -> pure (Left e) Left e -> pure (Left e)
Right NoIndex -> scanFiltered db outer mAlias tbl (lookupCondition mAlias col k) Right NoIndex -> scanFiltered db outer mAlias tbl (lookupCondition mAlias col k)
Right (IndexRows rows) -> pure (Right (prefixRows mAlias rows)) 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 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 case res of
Left e -> pure (Left e) Left e -> pure (Left e)
Right Nothing -> scanFiltered db outer mAlias tbl (rangeCondition mAlias col lo hi) Right Nothing -> scanFiltered db outer mAlias tbl (rangeCondition mAlias col lo hi)
Right (Just rows) -> pure (Right (prefixRows mAlias rows)) Right (Just rows) -> pure (orderedRows (relOpCols db (Range mAlias tbl col lo hi)) (prefixRows mAlias rows))
evalRelOpIn db outer (Filter e op) = do evalRelOpIn db outer (Filter e op) = do
rows <- evalRelOpIn db outer op rows <- evalRelOpIn db outer op
case rows of case rows of
Left err -> pure (Left err) Left err -> pure (Left err)
Right rs 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 | otherwise -> do
table <- bindingsTableM db outer [e] rs table <- bindingsTableM db outer [e] rs
pure (table >>= \t -> filterM (keepBound t) rs) pure (table >>= \t -> filterM (keepBound t) rs)
where where
refs = nub (subqueryRefsIn e) refs = nub (subquerySlotsIn e)
-- | 用这一行绑定换好的条件判定 -- | 用这一行绑定换好的条件判定
keepBound table r = do keepBound table r = do
e' <- boundExpr refs (r ++ outer) table e' <- boundExpr refs (r ++ outer) table
@@ -516,15 +610,33 @@ evalRelOpIn db outer (Filter e op) = do
evalRelOpIn db outer (Project cols op) = do evalRelOpIn db outer (Project cols op) = do
rows <- evalRelOpIn db outer op rows <- evalRelOpIn db outer op
pure (fmap (map (project cols)) rows) pure (fmap (map (project cols)) rows)
evalRelOpIn db outer (Distinct op) = do
rows <- evalRelOpIn db outer op
pure (distinctRows <$> rows)
evalRelOpIn db outer (Sort spec op) = do evalRelOpIn db outer (Sort spec op) = do
rows <- evalRelOpIn db outer op rows <- evalRelOpIn db outer op
pure (fmap (sortRows spec) rows) pure (fmap (sortRows spec) rows)
evalRelOpIn db outer (BoundSort spec op) = do
rows <- evalRelOpIn db outer op
pure (rows >>= sortBoundRows spec outer)
evalRelOpIn db outer (Limit n op) = do evalRelOpIn db outer (Limit n op) = do
rows <- evalRelOpIn db outer op rows <- evalRelOpIn db outer op
pure (fmap (take n) rows) pure (fmap (take n) rows)
evalRelOpIn db outer (Derived mAlias op) = do 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) 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 evalRelOpIn db outer (Join kind l r c) = do
lres <- evalRelOpIn db outer l lres <- evalRelOpIn db outer l
case lres of case lres of
@@ -553,24 +665,36 @@ scanFiltered ::
Maybe String -> Maybe String ->
String -> String ->
Expr -> Expr ->
m (Either String [Row]) Execution m (Either String [Row])
scanFiltered db outer mAlias tbl cond = do scanFiltered db outer mAlias tbl cond = do
res <- scanTable db tbl Nothing res <- scanTable db tbl Nothing
pure $ do pure $ do
rows <- res rows <- res >>= orderedRows (relOpCols db (Scan mAlias tbl Nothing)) . prefixRows mAlias
filterM (evalCondForRow cond . (++ outer)) (prefixRows mAlias rows) filterM (evalCondForRow cond . (++ outer)) rows
-- | 行数到阈值才值得并行分片 -- | 行数到阈值才值得并行分片
parallelRowThreshold :: Int parallelRowThreshold :: Int
parallelRowThreshold = 1000 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 scanTable db tbl cols = do
width <- parallelShards width <- lift parallelShards
if width > 1 && rows >= parallelRowThreshold if width > 1 && rows >= parallelRowThreshold
then scanShards width tbl cols then lift (scanShards width tbl cols)
else maybe (scan tbl) (scanColumns tbl) cols else lift (maybe (scan tbl) (scanColumns tbl) cols)
where where
-- | 统计里的行数,没有统计算 0 -- | 统计里的行数,没有统计算 0
rows = maybe 0 metaRowCount (tableMetaOf db tbl) rows = maybe 0 metaRowCount (tableMetaOf db tbl)
-- | 按输出值去重并保留首次行序
distinctRows :: [Row] -> [Row]
distinctRows = go HS.empty
where
-- | 只输出尚未遇到的值组合
go _ [] = []
go seen (row : rows)
| HS.member key seen = go seen rows
| otherwise = row : go (HS.insert key seen) rows
where
key = map (canonicalValue . snd) row
@@ -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.Model
import ChuSQL.Core.Engine.Syntax.AST import ChuSQL.Core.Engine.Syntax.AST
@@ -11,12 +11,19 @@ import ChuSQL.Core.Engine.Runtime.SQL (invokeSQLFunction, constructSQLValue)
evalExpr :: Expr -> Row -> Either String Value evalExpr :: Expr -> Row -> Either String Value
evalExpr (Col name) row = evalExpr (Col name) row =
maybe (Left ("unknown column: " ++ name)) Right (lookup name row) maybe (Left ("unknown column: " ++ name)) Right (lookup name row)
evalExpr (ColumnSlot slot name) row = case drop slot row of
(key, value) : _ | slot >= 0, key == name -> Right value
[] -> Left ("missing bound column: " ++ name)
_ -> Left ("bound column position mismatch: " ++ name)
evalExpr (OuterColumnSlot localWidth slot name) row
| localWidth < 0 || slot < 0 = Left ("bound column position mismatch: " ++ name)
| otherwise = evalExpr (ColumnSlot slot name) (drop localWidth row)
evalExpr (FunctionCall name _) _ = Left ("unbound function call: " ++ name) evalExpr (FunctionCall name _) _ = Left ("unbound function call: " ++ name)
evalExpr (Construct _ _) _ = Left "unbound runtime constructor" 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 (RuntimeLiteral tid value) _ = coerceValue (CRuntime tid) (VRuntime tid value)
evalExpr (BoundFunction fid tid arguments) row = 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 LitNull _ = Right VNull
evalExpr (LitInt n) _ = Right (VInt n) evalExpr (LitInt n) _ = Right (VInt n)
evalExpr (LitFloat d) _ = Right (VFloat d) evalExpr (LitFloat d) _ = Right (VFloat d)
@@ -48,13 +55,13 @@ evalExpr (IsNotNull a) row = do
Right (VBool (v /= VNull)) Right (VBool (v /= VNull))
evalExpr (InList a es negated) row = do evalExpr (InList a es negated) row = do
v <- evalExpr a row v <- evalExpr a row
vs <- mapM (\e -> evalExpr e row) es vs <- mapM (`evalExpr` row) es
r <- inValues v vs r <- inValues v vs
Right (if negated then threeValuedNot r else r) Right (if negated then threeValuedNot r else r)
evalExpr (ScalarSub _) _ = Left subqueryNeedsDatabase evalExpr (ScalarSub _) _ = Left subqueryNeedsDatabase
evalExpr (InSub _ _ _) _ = Left subqueryNeedsDatabase evalExpr (InSub {}) _ = Left subqueryNeedsDatabase
evalExpr (ExistsSub _ _) _ = 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) evalExpr agg _ = Left ("aggregate functions are not allowed here: " ++ show agg)
-- | 子查询要连上存储才能跑 -- | 子查询要连上存储才能跑
@@ -70,6 +77,8 @@ quantifiedCompare op lhs vs q = case vs of
-- | 表达式用到了哪些列 -- | 表达式用到了哪些列
colsInExpr :: Expr -> [String] colsInExpr :: Expr -> [String]
colsInExpr (Col c) = [c] colsInExpr (Col c) = [c]
colsInExpr (ColumnSlot _ c) = [c]
colsInExpr (OuterColumnSlot _ _ c) = [c]
colsInExpr (Construct _ arguments) = concatMap colsInExpr arguments colsInExpr (Construct _ arguments) = concatMap colsInExpr arguments
colsInExpr (BoundConstruct _ arguments) = concatMap colsInExpr arguments colsInExpr (BoundConstruct _ arguments) = concatMap colsInExpr arguments
colsInExpr (FunctionCall _ arguments) = concatMap colsInExpr arguments colsInExpr (FunctionCall _ arguments) = concatMap colsInExpr arguments
@@ -103,21 +112,34 @@ colsInExpr _ = []
-- | 表达式里子查询引用的外层列 -- | 表达式里子查询引用的外层列
subqueryRefsIn :: Expr -> [String] subqueryRefsIn :: Expr -> [String]
subqueryRefsIn e = case e of subqueryRefsIn = subqueryReferences subqueryRefs
Construct _ arguments -> concatMap subqueryRefsIn arguments
BoundConstruct _ arguments -> concatMap subqueryRefsIn arguments -- | 提取子查询依赖的父布局表达式
FunctionCall _ arguments -> concatMap subqueryRefsIn arguments subquerySlotsIn :: Expr -> [Expr]
BoundFunction _ _ arguments -> concatMap subqueryRefsIn arguments subquerySlotsIn = subqueryReferences (map snd . subqueryColumns)
ScalarSub sq -> subqueryRefs sq
InSub a sq _ -> subqueryRefsIn a ++ subqueryRefs sq -- | 取得原始或已绑定的外部列
InList a es _ -> concatMap subqueryRefsIn (a : es) subqueryColumns :: Subquery -> [(String, Expr)]
ExistsSub sq _ -> subqueryRefs sq subqueryColumns (Subquery _ names) = [(name, Col name) | name <- names]
QuantCmp _ a sq _ -> subqueryRefsIn a ++ subqueryRefs sq 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 Add a b -> both a b
Sub a b -> both a b Sub a b -> both a b
Mul a b -> both a b Mul a b -> both a b
Div 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 Gt a b -> both a b
Lt a b -> both a b Lt a b -> both a b
Eq a b -> both a b Eq a b -> both a b
@@ -126,17 +148,19 @@ subqueryRefsIn e = case e of
NotEq a b -> both a b NotEq a b -> both a b
And a b -> both a b And a b -> both a b
Or a b -> both a b Or a b -> both a b
IsNull a -> subqueryRefsIn a IsNull a -> collect a
IsNotNull a -> subqueryRefsIn a IsNotNull a -> collect a
CountOf a -> subqueryRefsIn a CountOf a -> collect a
SumOf a -> subqueryRefsIn a SumOf a -> collect a
AvgOf a -> subqueryRefsIn a AvgOf a -> collect a
MinOf a -> subqueryRefsIn a MinOf a -> collect a
MaxOf a -> subqueryRefsIn a MaxOf a -> collect a
_ -> [] _ -> []
where where
-- | 递归收集当前提取器的引用
collect = subqueryReferences references
-- | 两个子表达式的外层列拼起来 -- | 两个子表达式的外层列拼起来
both a b = subqueryRefsIn a ++ subqueryRefsIn b both a b = collect a ++ collect b
-- | 表达式里有没有除法(除法可能报错,不能提前或延后求值) -- | 表达式里有没有除法(除法可能报错,不能提前或延后求值)
hasDivision :: Expr -> Bool hasDivision :: Expr -> Bool
@@ -172,10 +196,10 @@ hasSubquery e = case e of
FunctionCall _ arguments -> any hasSubquery arguments FunctionCall _ arguments -> any hasSubquery arguments
BoundFunction _ _ arguments -> any hasSubquery arguments BoundFunction _ _ arguments -> any hasSubquery arguments
ScalarSub _ -> True ScalarSub _ -> True
InSub _ _ _ -> True InSub {} -> True
InList a es _ -> any hasSubquery (a : es) InList a es _ -> any hasSubquery (a : es)
ExistsSub _ _ -> True ExistsSub _ _ -> True
QuantCmp _ _ _ _ -> True QuantCmp {} -> True
Add a b -> both a b Add a b -> both a b
Sub a b -> both a b Sub a b -> both a b
Mul a b -> both a b Mul a b -> both a b
@@ -215,6 +239,8 @@ aggregatesIn e = case e of
a@(MinOf _) -> [a] a@(MinOf _) -> [a]
a@(MaxOf _) -> [a] a@(MaxOf _) -> [a]
QuantCmp _ a _ _ -> aggregatesIn a QuantCmp _ a _ _ -> aggregatesIn a
InSub a _ _ -> aggregatesIn a
InList a values _ -> aggregatesIn a ++ concatMap aggregatesIn values
Add a b -> both a b Add a b -> both a b
Sub a b -> both a b Sub a b -> both a b
Mul a b -> both a b Mul a b -> both a b
@@ -247,6 +273,8 @@ bareColumns e = case e of
FunctionCall _ arguments -> concatMap bareColumns arguments FunctionCall _ arguments -> concatMap bareColumns arguments
BoundFunction _ _ arguments -> concatMap bareColumns arguments BoundFunction _ _ arguments -> concatMap bareColumns arguments
Col c -> [c] Col c -> [c]
ColumnSlot _ c -> [c]
OuterColumnSlot _ _ c -> [c]
Add a b -> both a b Add a b -> both a b
Sub a b -> both a b Sub a b -> both a b
Mul a b -> both a b Mul a b -> both a b
@@ -1,5 +1,6 @@
module ChuSQL.Core.Engine.Algebra.JoinOrder (reorderJoins) where 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.Cost (pointRows, rangeRows, selectivityOf, tableMetaOf)
import ChuSQL.Core.Engine.Algebra.Expr (colsInExpr, hasDivision, hasSubquery) import ChuSQL.Core.Engine.Algebra.Expr (colsInExpr, hasDivision, hasSubquery)
import ChuSQL.Core.Engine.Algebra.Op (RelOp (..), relOpCols) import ChuSQL.Core.Engine.Algebra.Op (RelOp (..), relOpCols)
@@ -15,6 +16,7 @@ reorderJoins db = pass db False
-- | 往下带“行序是否不可观察”,可观察时不动内连接 -- | 往下带“行序是否不可观察”,可观察时不动内连接
pass :: Database -> Bool -> RelOp -> RelOp pass :: Database -> Bool -> RelOp -> RelOp
pass db free (Distinct x) = Distinct (pass db free x)
pass db _ (Sort spec x) = Sort spec (pass db True x) pass db _ (Sort spec x) = Sort spec (pass db True x)
pass db _ (Limit n x) = Limit n (pass db False x) pass db _ (Limit n x) = Limit n (pass db False x)
pass db _ (Aggregate keys aggs x) = Aggregate keys aggs (pass db False x) pass db _ (Aggregate keys aggs x) = Aggregate keys aggs (pass db False x)
@@ -22,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 (Compute items x) = Compute items (pass db free x)
pass db free (Filter p x) = Filter p (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 (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) pass db free (Join kind l r c)
| free | free
, Just (leaves, conds) <- innerChain (Join kind l r c) , Just (leaves, conds) <- innerChain (Join kind l r c)
@@ -37,7 +40,7 @@ innerChain (Join InnerJoin l r c) = do
(ls, lcs) <- innerChain l (ls, lcs) <- innerChain l
(rs, rcs) <- innerChain r (rs, rcs) <- innerChain r
pure (ls ++ rs, lcs ++ rcs ++ [c]) pure (ls ++ rs, lcs ++ rcs ++ [c])
innerChain (Join _ _ _ _) = Nothing innerChain (Join {}) = Nothing
innerChain op = Just ([op], []) innerChain op = Just ([op], [])
-- | 叶子算子的估算行数,拿不到统计就是 Nothing -- | 叶子算子的估算行数,拿不到统计就是 Nothing
@@ -78,7 +81,7 @@ scaleRows db p x rows = case p of
GtE _ _ -> quarter GtE _ _ -> quarter
LtE _ _ -> quarter LtE _ _ -> quarter
NotEq _ _ -> quarter NotEq _ _ -> quarter
QuantCmp _ _ _ _ -> quarter QuantCmp {} -> quarter
And a b -> max 1 (min (scaleRows db a x rows) (scaleRows db b x rows)) And a b -> max 1 (min (scaleRows db a x rows) (scaleRows db b x rows))
_ -> quarter _ -> quarter
where where
@@ -100,11 +103,9 @@ leafSource _ = Nothing
-- | 某列在叶子统计里的不同值数 -- | 某列在叶子统计里的不同值数
distinctOf :: Database -> RelOp -> String -> Maybe Int distinctOf :: Database -> RelOp -> String -> Maybe Int
distinctOf db leaf col = do distinctOf db leaf col = do (alias, t) <- leafSource leaf
(alias, t) <- leafSource leaf m <- tableMetaOf db t
m <- tableMetaOf db t lookup (unqualify alias col) [(c, n) | (c, n, _) <- metaDistinct m]
num <- lookup (unqualify alias col) [(c, n) | (c, n, _) <- metaDistinct m]
pure num
-- | 若干叶子里某列最大的不同值数 -- | 若干叶子里某列最大的不同值数
distinctOn :: Database -> [RelOp] -> String -> Maybe Int distinctOn :: Database -> [RelOp] -> String -> Maybe Int
@@ -137,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) Just v | v > 1 -> max 1 (acc * rows `div` v)
_ -> acc * rows _ -> acc * rows
where where
rows = maybe 1 id (leafRows db x) rows = fromMaybe 1 (leafRows db x)
-- | 一批叶子按给定顺序连接,累加每一步的中间结果 -- | 一批叶子按给定顺序连接,累加每一步的中间结果
chainCost :: Database -> [RelOp] -> [Expr] -> Int 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 where
-- | 逐步接上后面的叶子 -- | 逐步接上后面的叶子
go _ _ [] = 0 go _ _ [] = 0
@@ -212,8 +213,7 @@ rebuildChain _ [] _ = Unit
-- | 挂不上去的条件套成 Filter -- | 挂不上去的条件套成 Filter
applyConds :: [Expr] -> RelOp -> RelOp applyConds :: [Expr] -> RelOp -> RelOp
applyConds [] op = op applyConds cs op = foldr Filter op cs
applyConds (c : cs) op = Filter c (applyConds cs op)
-- | 条件的列是不是都在可用列里 -- | 条件的列是不是都在可用列里
subsetOf :: [String] -> [String] -> Bool 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.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 data RelOp
= Scan (Maybe String) String (Maybe [String]) = Scan (Maybe String) String (Maybe [String])
| Lookup (Maybe String) String String Value | Lookup (Maybe String) String String Value
@@ -13,10 +16,15 @@ data RelOp
| Project [String] RelOp | Project [String] RelOp
| Compute [(String, Expr)] RelOp | Compute [(String, Expr)] RelOp
| Aggregate [String] [(String, Expr)] RelOp | Aggregate [String] [(String, Expr)] RelOp
| BoundAggregate [(String, Expr)] [(String, Expr)] RelOp
| Distinct RelOp
| Unit | Unit
| Sort [(String, SortDir)] RelOp | Sort [(String, SortDir)] RelOp
| BoundSort [(Expr, SortDir)] RelOp
| Limit Int RelOp | Limit Int RelOp
| Join JoinKind RelOp RelOp Expr | Join JoinKind RelOp RelOp Expr
-- | 末项仅保存独立 IN 的物化身份
| SemiJoin SemiKind Expr Expr RelOp RelOp (Maybe Statement)
| Derived (Maybe String) RelOp | Derived (Maybe String) RelOp
deriving (Show, Eq) deriving (Show, Eq)
@@ -25,6 +33,7 @@ relOpCols :: Database -> RelOp -> [String]
relOpCols _ Unit = [] relOpCols _ Unit = []
relOpCols _ (Compute items _) = map fst items relOpCols _ (Compute items _) = map fst items
relOpCols _ (Aggregate keys aggs _) = keys ++ map fst aggs relOpCols _ (Aggregate keys aggs _) = keys ++ map fst aggs
relOpCols _ (BoundAggregate keys aggs _) = map fst keys ++ map fst aggs
relOpCols _ (Scan mAlias _ (Just cols)) = map (qualify mAlias) cols relOpCols _ (Scan mAlias _ (Just cols)) = map (qualify mAlias) cols
relOpCols db (Scan mAlias tbl Nothing) = relOpCols db (Scan mAlias tbl Nothing) =
case lookup tbl db of case lookup tbl db of
@@ -37,9 +46,12 @@ relOpCols db (Range mAlias tbl _ _ _) = relOpCols db (Scan mAlias tbl Nothing)
relOpCols db (Filter _ x) = relOpCols db x relOpCols db (Filter _ x) = relOpCols db x
relOpCols _ (Project ["*"] _) = ["*"] relOpCols _ (Project ["*"] _) = ["*"]
relOpCols _ (Project cols _) = cols relOpCols _ (Project cols _) = cols
relOpCols db (Distinct x) = relOpCols db x
relOpCols db (Sort _ x) = relOpCols db x relOpCols db (Sort _ x) = relOpCols db x
relOpCols db (BoundSort _ x) = relOpCols db x
relOpCols db (Limit _ x) = relOpCols db x relOpCols db (Limit _ x) = relOpCols db x
relOpCols db (Join _ l r _) = relOpCols db l ++ relOpCols db r 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) relOpCols db (Derived mAlias x) = map (qualify mAlias) (relOpCols db x)
-- | 连接的显示名 -- | 连接的显示名
@@ -67,10 +79,16 @@ renderPlan = go 0
++ show [label ++ " <- " ++ show e | (label, e) <- aggs] ++ show [label ++ " <- " ++ show e | (label, e) <- aggs]
++ "\n" ++ "\n"
++ go (ind + 1) x ++ go (ind + 1) x
Distinct x -> pad ++ "Distinct\n" ++ go (ind + 1) x
BoundAggregate keys aggs x -> pad ++ "BoundAggregate keys=" ++ show keys
++ " aggs=" ++ show aggs ++ "\n" ++ go (ind + 1) x
Unit -> pad ++ "Unit" Unit -> pad ++ "Unit"
Sort s x -> pad ++ "Sort " ++ show s ++ "\n" ++ go (ind + 1) x Sort s x -> pad ++ "Sort " ++ show s ++ "\n" ++ go (ind + 1) x
BoundSort s x -> pad ++ "BoundSort " ++ show s ++ "\n" ++ go (ind + 1) x
Limit n x -> pad ++ "Limit " ++ show n ++ "\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 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 Derived a x -> pad ++ "Derived " ++ show a ++ "\n" ++ go (ind + 1) x
where where
pad = replicate (ind * 2) ' ' 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.Cost (indexCheaper, pointRows, rangeRows, tableMetaOf)
import ChuSQL.Core.Engine.Algebra.Expr (colsInExpr, evalExpr, hasDivision) import ChuSQL.Core.Engine.Algebra.Expr (colsInExpr, evalExpr, hasDivision)
import ChuSQL.Core.Engine.Algebra.JoinOrder (reorderJoins) 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.Model
import ChuSQL.Core.Engine.Syntax.AST (Expr (..), JoinKind (..)) import ChuSQL.Core.Engine.Syntax.AST (Expr (..), JoinKind (..), Statement (..), FromClause (..), Subquery (..))
import Data.List (nub) import Data.List (nub)
-- 查询优化:谓词下推、投影下推、常量折叠、扫描方式与连接顺序选择。 -- 查询优化:谓词下推、投影下推、常量折叠、扫描方式与连接顺序选择。
@@ -36,8 +37,7 @@ partitionPred have = foldr pick ([], [])
-- | 依次套上若干 Filter -- | 依次套上若干 Filter
applyFilters :: [Expr] -> RelOp -> RelOp applyFilters :: [Expr] -> RelOp -> RelOp
applyFilters [] op = op applyFilters es op = foldl (flip Filter) op es
applyFilters (e : es) op = applyFilters es (Filter e op)
-- | Filter 压在内连接上时下推 -- | Filter 压在内连接上时下推
pushJoin :: Database -> Expr -> RelOp -> RelOp -> Expr -> RelOp pushJoin :: Database -> Expr -> RelOp -> RelOp -> Expr -> RelOp
@@ -75,8 +75,10 @@ pushOne _ op = op
planHasDivision :: RelOp -> Bool planHasDivision :: RelOp -> Bool
planHasDivision (Filter p x) = hasDivision p || planHasDivision x planHasDivision (Filter p x) = hasDivision p || planHasDivision x
planHasDivision (Join _ l r c) = hasDivision c || planHasDivision l || planHasDivision r 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 (Compute items x) = any (hasDivision . snd) items || planHasDivision x
planHasDivision (Project _ x) = planHasDivision x planHasDivision (Project _ x) = planHasDivision x
planHasDivision (Distinct x) = planHasDivision x
planHasDivision (Sort _ x) = planHasDivision x planHasDivision (Sort _ x) = planHasDivision x
planHasDivision (Limit _ x) = planHasDivision x planHasDivision (Limit _ x) = planHasDivision x
planHasDivision (Derived _ x) = planHasDivision x planHasDivision (Derived _ x) = planHasDivision x
@@ -96,6 +98,8 @@ pushProjectLeaf db need leaf
-- | 把需要哪些列往下传 -- | 把需要哪些列往下传
pushProject :: Database -> [String] -> RelOp -> RelOp pushProject :: Database -> [String] -> RelOp -> RelOp
pushProject _ _ Unit = Unit pushProject _ _ Unit = Unit
pushProject _ _ op@BoundSort{} = op
pushProject _ _ op@BoundAggregate{} = op
pushProject db _ (Compute items x) = Compute items (pushProject db (concatMap (colsInExpr . snd) items) x) pushProject db _ (Compute items x) = Compute items (pushProject db (concatMap (colsInExpr . snd) items) x)
pushProject db _ (Aggregate keys aggs x) = pushProject db _ (Aggregate keys aggs x) =
Aggregate keys aggs (pushProject db (keys ++ concatMap (colsInExpr . snd) aggs) x) Aggregate keys aggs (pushProject db (keys ++ concatMap (colsInExpr . snd) aggs) x)
@@ -103,8 +107,12 @@ pushProject db _ (Project cols x) = case pushProject db cols x of
Project cols' y | cols' == cols -> Project cols y Project cols' y | cols' == cols -> Project cols y
other -> Project cols other other -> Project cols other
pushProject db need (Filter p x) = Filter p (pushProject db (need ++ colsInExpr p) x) pushProject db need (Filter p x) = Filter p (pushProject db (need ++ colsInExpr p) x)
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 (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 (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) pushProject db need (Join kind l r c)
| needsAll need = Join kind (pushProject db need l) (pushProject db need r) c | needsAll need = Join kind (pushProject db need l) (pushProject db need r) c
| otherwise = | otherwise =
@@ -127,8 +135,8 @@ pushProject db need (Derived a x)
| otherwise = Derived a (Project wanted (pushProject db wanted x)) | otherwise = Derived a (Project wanted (pushProject db wanted x))
where where
wanted = nub (map (unqualify a) need) wanted = nub (map (unqualify a) need)
pushProject db need leaf@(Lookup _ _ _ _) = pushProjectLeaf db need leaf pushProject db need leaf@(Lookup {}) = pushProjectLeaf db need leaf
pushProject db need leaf@(Range _ _ _ _ _) = pushProjectLeaf db need leaf pushProject db need leaf@(Range {}) = pushProjectLeaf db need leaf
-- | 折一个表达式节点 -- | 折一个表达式节点
foldNode :: Expr -> Expr foldNode :: Expr -> Expr
@@ -175,8 +183,52 @@ worthRange db t col lo hi = case tableMetaOf db t of
Nothing -> True Nothing -> True
Just m -> indexCheaper m col (rangeRows m col lo hi) 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 :: 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)) 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) | 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)) rewriteNode db (Filter (Eq (Col k) (LitStr v)) (Scan mAlias t Nothing))
@@ -250,9 +302,11 @@ optimizeRelOp db = rewriteNode db . descend
descend (Project cols x) = Project cols (optimizeRelOp db x) descend (Project cols x) = Project cols (optimizeRelOp db x)
descend (Compute items x) = Compute items (optimizeRelOp db x) descend (Compute items x) = Compute items (optimizeRelOp db x)
descend (Aggregate keys aggs x) = Aggregate keys aggs (optimizeRelOp db x) descend (Aggregate keys aggs x) = Aggregate keys aggs (optimizeRelOp db x)
descend (Distinct x) = Distinct (optimizeRelOp db x)
descend (Sort spec x) = Sort spec (optimizeRelOp db x) descend (Sort spec x) = Sort spec (optimizeRelOp db x)
descend (Limit n x) = Limit n (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 (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 (Derived a x) = Derived a (optimizeRelOp db x)
descend x = x descend x = x
@@ -1,3 +1,5 @@
{-# LANGUAGE TupleSections #-}
module ChuSQL.Core.Engine.Algebra.Planner (translate) where module ChuSQL.Core.Engine.Algebra.Planner (translate) where
import ChuSQL.Core.Engine.Algebra.Expr (aggregatesIn, colsInExpr) 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 _ acc [] = reverse acc
go n acc (e : es) go n acc (e : es)
| any ((== e) . snd) acc = go n acc 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 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) LtE a b -> LtE (go a) (go b)
NotEq a b -> NotEq (go a) (go b) NotEq a b -> NotEq (go a) (go b)
QuantCmp op a sq q -> QuantCmp op (go a) sq q 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) And a b -> And (go a) (go b)
Or a b -> Or (go a) (go b) Or a b -> Or (go a) (go b)
IsNull a -> IsNull (go a) IsNull a -> IsNull (go a)
IsNotNull a -> IsNotNull (go a) IsNotNull a -> IsNotNull (go a)
other -> other other -> other
where where
-- | 递归替换当前查询层的聚合引用
go = rewriteAggs aggs 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 :: [(String, SortDir)] -> Maybe Int -> RelOp -> RelOp
limited orderBy mLimit op = case mLimit of limited orderBy mLimit op = case mLimit of
@@ -79,33 +76,64 @@ limited orderBy mLimit op = case mLimit of
[] -> op [] -> op
spec -> Sort spec op spec -> Sort spec op
-- | 翻成:过滤 -> 分组 -> 排序 -> 截断 -> 取列 -- | 生成过滤、聚合、HAVING、排序和投影计划
translate :: Statement -> Either String RelOp translate :: Statement -> Either String RelOp
translate q = case q of translate q = case q of
Select SelectDistinct inner -> do
{ selectCols = cols ordering <- distinctOrdering inner
, selectFrom = fromC plan <- case inner of
, selectWhere = mWhere s@Select{} -> translate s { selectOrderBy = [], selectLimit = Nothing }
, selectGroupBy = groupBy _ -> Left "DISTINCT requires SELECT"
, selectOrderBy = orderBy let labels = case inner of
, selectLimit = mLimit Select { selectItems = items } -> map fst items
} -> do _ -> []
plan0 <- source fromC mWhere keys <- mapM (distinctKey labels) ordering
let (plan, _) = grouped groupBy [] plan0 namedOrdering <- mapM (columnKey labels) ordering
Right (Project cols (limited orderBy mLimit plan)) let sorted
SelectExpr items fromC mWhere groupBy orderBy mLimit -> do | 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 plan0 <- source fromC mWhere
let (plan, items') = grouped groupBy items plan0 expressions <- mapM (orderExpression items . fst) orderBy
Right $ if any (\(c, _) -> c `elem` map fst items') orderBy let aggs = nameAggs (items ++ [("having", expression) | expression <- maybe [] pure having]
then orderedProjection items' orderBy mLimit plan ++ map ("order",) expressions)
else Compute items' (limited orderBy mLimit plan) 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" _ -> 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 = orderedProjection items orderBy mLimit plan =
Compute items (limited ordering mLimit (Compute (carried ++ keys) plan)) Compute items (limited ordering mLimit (Compute (carried ++ keys) plan))
where where
carried = [(column, Col column) | column <- nub (concatMap (colsInExpr . snd) items)] keys = [("$order" ++ show n, expression) | (n, (expression, _)) <- zip [1 :: Int ..] orderBy]
keys = [("$order" ++ show n, maybe (Col c) id (lookup c items)) | (n, (c, _)) <- zip [1 :: Int ..] orderBy]
ordering = [(key, direction) | ((key, _), (_, direction)) <- zip keys orderBy] ordering = [(key, direction) | ((key, _), (_, direction)) <- zip keys orderBy]
carried = [(column, Col column) | column <- nub (concatMap (colsInExpr . snd) items)]
@@ -1,7 +1,8 @@
module ChuSQL.Core.Engine.Algebra.Sort (sortRows, compareValue) where module ChuSQL.Core.Engine.Algebra.Sort (sortRows, sortBoundRows, compareValue) where
import ChuSQL.Core.Model import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Syntax.AST import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Engine.Algebra.Expr (evalExpr)
import Data.List (sortBy) import Data.List (sortBy)
-- 排序:按多列规格排出结果行,每列可升可降。 -- 排序:按多列规格排出结果行,每列可升可降。
@@ -17,9 +18,9 @@ sortKey :: [(String, SortDir)] -> Row -> [Maybe Value]
sortKey spec row = [lookup col row | (col, _) <- spec] sortKey spec row = [lookup col row | (col, _) <- spec]
-- | 比较两个排序键 -- | 比较两个排序键
compareKeys :: [(String, SortDir)] -> [Maybe Value] -> [Maybe Value] -> Ordering compareKeys :: [SortDir] -> [Maybe Value] -> [Maybe Value] -> Ordering
compareKeys [] _ _ = EQ compareKeys [] _ _ = EQ
compareKeys ((_, dir) : rest) (a : as) (b : bs) = compareKeys (dir : rest) (a : as) (b : bs) =
case (a, b) of case (a, b) of
(Just v1, Just v2) -> (Just v1, Just v2) ->
case compareValue v1 v2 of case compareValue v1 v2 of
@@ -36,4 +37,19 @@ sortRows spec rows = map snd (sortBy cmp (map decorate rows))
-- | 取键并带上原行 -- | 取键并带上原行
decorate row = (sortKey spec row, row) decorate row = (sortKey spec row, row)
-- | 比较两个带键的行 -- | 比较两个带键的行
cmp (k1, _) (k2, _) = compareKeys spec k1 k2 cmp (k1, _) (k2, _) = compareKeys (map snd spec) k1 k2
-- | 用绑定槽位取键并稳定排序
sortBoundRows :: [(Expr, SortDir)] -> Row -> [Row] -> Either String [Row]
sortBoundRows [] _ rows = Right rows
sortBoundRows spec outer rows = do
decorated <- mapM decorate rows
Right (map snd (sortBy compareRows decorated))
where
directions = map snd spec
-- | 每行只计算一次绑定排序键
decorate row = do
keys <- mapM (\(expression, _) -> evalExpr expression (row ++ outer)) spec
Right (map Just keys, row)
-- | 比较排序键并保留同键行序
compareRows (left, _) (right, _) = compareKeys directions left right
@@ -1,25 +1,25 @@
module ChuSQL.Core.Engine.Builtin module ChuSQL.Core.Engine.Builtin (
( Builtin (..) Builtin (..),
, builtinNames builtinNames,
, resolveBuiltin resolveBuiltin,
, builtinName builtinName,
, invokeBuiltin invokeBuiltin,
, builtinOfExpr builtinOfExpr,
, builtinNode builtinNode,
, aggregateArg aggregateArg,
, unsupportedAggregate unsupportedAggregate,
, Operator (..) Operator (..),
, operatorOfExpr operatorOfExpr,
, operatorSymbol operatorSymbol,
, operatorOfCompare operatorOfCompare,
, compareNode compareNode,
, executeOperator executeOperator,
, threeValuedNot threeValuedNot,
, inValues inValues,
) where ) where
import ChuSQL.Core.Model (Value (..), compareValue)
import ChuSQL.Core.Engine.Syntax.AST (CompareOp (..), Expr (..)) import ChuSQL.Core.Engine.Syntax.AST (CompareOp (..), Expr (..))
import ChuSQL.Core.Model (Value (..), compareValue)
import Control.Monad (foldM) import Control.Monad (foldM)
import Data.Char (toLower) import Data.Char (toLower)
@@ -246,12 +246,12 @@ evalArith ops x y = case (asDouble x, asDouble y) of
divArith :: Arith divArith :: Arith
divArith = Arith intDiv floatDiv divArith = Arith intDiv floatDiv
where where
-- | 整数除法:除零与溢出都报错 -- \| 整数除法:除零与溢出都报错
intDiv _ 0 = Left "division by zero" intDiv _ 0 = Left "division by zero"
intDiv x y intDiv x y
| x == minBound && y == -1 = Left "integer division overflow" | x == minBound && y == -1 = Left "integer division overflow"
| otherwise = Right (x `quot` y) | otherwise = Right (x `quot` y)
-- | 浮点除法:不能除以零 -- \| 浮点除法:不能除以零
floatDiv _ 0 = Left "division by zero" floatDiv _ 0 = Left "division by zero"
floatDiv x y = Right (x / y) floatDiv x y = Right (x / y)
@@ -303,8 +303,9 @@ threeValuedNot :: Value -> Value
threeValuedNot (VBool b) = VBool (not b) threeValuedNot (VBool b) = VBool (not b)
threeValuedNot _ = VNull threeValuedNot _ = VNull
-- | IN 三值逻辑:命中为真,碰 NULL 得 NULL -- | IN 空集为假,非空集按三值逻辑比较
inValues :: Value -> [Value] -> Either String Value inValues :: Value -> [Value] -> Either String Value
inValues _ [] = Right (VBool False)
inValues VNull _ = Right VNull inValues VNull _ = Right VNull
inValues v vs = do inValues v vs = do
results <- mapM (\x -> executeOperator OpEq [v, x]) vs results <- mapM (\x -> executeOperator OpEq [v, x]) vs
@@ -1,12 +1,12 @@
module ChuSQL.Core.Engine.Error module ChuSQL.Core.Engine.Error (
( ErrorCategory (..) ErrorCategory (..),
, ErrorRule (..) ErrorRule (..),
, errorRules errorRules,
, errorCategory errorCategory,
, errorCode errorCode,
, errorLike errorLike,
, accountErrorCode accountErrorCode,
) where ) where
import Data.List (isInfixOf) import Data.List (isInfixOf)
@@ -35,6 +35,8 @@ errorRules :: [ErrorRule]
errorRules = errorRules =
[ ErrorRule "no database selected" NoDatabaseError "no_database" [ ErrorRule "no database selected" NoDatabaseError "no_database"
, ErrorRule "administrator required" PermissionError "forbidden" , ErrorRule "administrator required" PermissionError "forbidden"
, ErrorRule "bound query object changed" CatalogError "serialization_failure"
, ErrorRule "bound query schema changed" CatalogError "serialization_failure"
, ErrorRule "unknown table" CatalogError "not_found" , ErrorRule "unknown table" CatalogError "not_found"
, ErrorRule "unknown domain" CatalogError "not_found" , ErrorRule "unknown domain" CatalogError "not_found"
, ErrorRule "domain is still used" CatalogError "query_error" , ErrorRule "domain is still used" CatalogError "query_error"
@@ -14,23 +14,27 @@ data Declaration = Declaration
, dependencies :: [Dependency] , dependencies :: [Dependency]
, dependenciesComplete :: Bool , dependenciesComplete :: Bool
, atomicAttributes :: Maybe Bool , atomicAttributes :: Maybe Bool
} deriving (Eq, Show) }
deriving (Eq, Show)
data Finding = Finding data Finding = Finding
{ normalForm :: NormalForm { normalForm :: NormalForm
, verdict :: Verdict , verdict :: Verdict
, witnesses :: [Dependency] , witnesses :: [Dependency]
, condition :: String , condition :: String
} deriving (Eq, Show) }
deriving (Eq, Show)
data Decomposition = Decomposition data Decomposition = Decomposition
{ relations :: [Attributes] { relations :: [Attributes]
, losslessJoin :: Verdict , losslessJoin :: Verdict
, dependencyPreserving :: Verdict , dependencyPreserving :: Verdict
} deriving (Eq, Show) }
deriving (Eq, Show)
data Analysis = Analysis data Analysis = Analysis
{ candidateKeys :: [Attributes] { candidateKeys :: [Attributes]
, findings :: [Finding] , findings :: [Finding]
, suggestions :: [Decomposition] , suggestions :: [Decomposition]
} deriving (Eq, Show) }
deriving (Eq, Show)
-- 规范化属性集合。 -- 规范化属性集合。
canonical :: Attributes -> Attributes canonical :: Attributes -> Attributes
@@ -45,8 +49,9 @@ attributeClosure :: [Dependency] -> Attributes -> Attributes
attributeClosure f seed = fixed (canonical seed) attributeClosure f seed = fixed (canonical seed)
where where
-- 迭代加入已蕴含的属性。 -- 迭代加入已蕴含的属性。
fixed xs = let ys = canonical (xs ++ concat [b | Dependency a b <- f, subset a xs]) fixed xs =
in if xs == ys then xs else fixed ys let ys = canonical (xs ++ concat [b | Dependency a b <- f, subset a xs])
in if xs == ys then xs else fixed ys
-- 判断声明是否蕴含依赖。 -- 判断声明是否蕴含依赖。
implies :: [Dependency] -> Dependency -> Bool implies :: [Dependency] -> Dependency -> Bool
@@ -54,8 +59,12 @@ implies f (Dependency a b) = subset b (attributeClosure f a)
-- 枚举最小超键。 -- 枚举最小超键。
keysOf :: Attributes -> [Dependency] -> [Attributes] keysOf :: Attributes -> [Dependency] -> [Attributes]
keysOf attrs f = [x | x <- subsequences attrs, super x, keysOf attrs f =
all (not . super) [x \\ [a] | a <- x]] [ x
| x <- subsequences attrs
, super x
, (not . any super) [x \\ [a] | a <- x]
]
where where
-- 判断闭包是否覆盖关系。 -- 判断闭包是否覆盖关系。
super x = subset attrs (attributeClosure f x) super x = subset attrs (attributeClosure f x)
@@ -63,8 +72,12 @@ keysOf attrs f = [x | x <- subsequences attrs, super x,
-- 投影关系上的全部非平凡依赖。 -- 投影关系上的全部非平凡依赖。
projectDependencies :: [Dependency] -> Attributes -> [Dependency] projectDependencies :: [Dependency] -> Attributes -> [Dependency]
projectDependencies f attrs = projectDependencies f attrs =
[Dependency x [a] | x <- subsequences attrs, [ Dependency x [a]
a <- attributeClosure f x, a `elem` attrs, a `notElem` x] | x <- subsequences attrs
, a <- attributeClosure f x
, a `elem` attrs
, a `notElem` x
]
-- 验证声明并生成只读范式报告。 -- 验证声明并生成只读范式报告。
analyzeNormalization :: [(String, Column)] -> Declaration -> Either String Analysis analyzeNormalization :: [(String, Column)] -> Declaration -> Either String Analysis
@@ -90,15 +103,27 @@ analyzeNormalization schema declaration
Just False -> Violated Just False -> Violated
Nothing -> Insufficient Nothing -> Insufficient
allFDs = projectDependencies f attrs allFDs = projectDependencies f attrs
partial = [d | d@(Dependency x [a]) <- allFDs, a `notElem` prime, partial =
any (\k -> x /= k && subset x k) keys] [ d
third = [d | d@(Dependency x [a]) <- allFDs, a `notElem` prime, | d@(Dependency x [a]) <- allFDs
not (subset attrs (attributeClosure f x))] , a `notElem` prime
boyce = [d | d@(Dependency x _) <- allFDs, , any (\k -> x /= k && subset x k) keys
not (subset attrs (attributeClosure f x))] ]
results = Finding NF1 atomic [] "attributes must have atomic domains; requires an explicit declaration" : third =
[classify NF2 partial, classify NF3 third, classify BCNF boyce] [ d
decompositions = [split d | d <- take 1 boyce, complete, atomic == Satisfied] | d@(Dependency x [a]) <- allFDs
, a `notElem` prime
, not (subset attrs (attributeClosure f x))
]
boyce =
[ d
| d@(Dependency x _) <- allFDs
, not (subset attrs (attributeClosure f x))
]
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 | complete, atomic == Satisfied, d <- take 1 boyce]
-- 校验字段集合。 -- 校验字段集合。
valid xs = length xs == length (canonical xs) && subset xs attrs valid xs = length xs == length (canonical xs) && subset xs attrs
-- 校验依赖声明。 -- 校验依赖声明。
@@ -108,10 +133,11 @@ analyzeNormalization schema declaration
-- 结合声明完整性判定范式。 -- 结合声明完整性判定范式。
classify nf ds = Finding nf status (if complete then ds else []) (rule nf) classify nf ds = Finding nf status (if complete then ds else []) (rule nf)
where where
status | atomic == Violated = Violated status
| atomic == Insufficient || not complete = Insufficient | atomic == Violated = Violated
| null ds = Satisfied | atomic == Insufficient || not complete = Insufficient
| otherwise = Violated | null ds = Satisfied
| otherwise = Violated
-- 说明各范式的必要条件。 -- 说明各范式的必要条件。
rule NF1 = "attributes must have atomic domains" rule NF1 = "attributes must have atomic domains"
rule NF2 = "no nonprime attribute depends on a proper subset of any candidate key" rule NF2 = "no nonprime attribute depends on a proper subset of any candidate key"
@@ -6,8 +6,10 @@ module ChuSQL.Core.Engine.Parallel (
) where ) where
import Control.Concurrent (forkIO) import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, takeMVar) 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.Exception (SomeException, throwIO, try)
import Control.Monad (forever, join)
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
-- 并行执行:常驻工作线程池,结果按提交顺序收回。 -- 并行执行:常驻工作线程池,结果按提交顺序收回。
@@ -16,13 +18,11 @@ import System.IO.Unsafe (unsafePerformIO)
parallelShardLimit :: Int parallelShardLimit :: Int
parallelShardLimit = 8 parallelShardLimit = 8
-- | 池:待办队列与唤醒信号 -- | 池:工作线程共享的待办队列
data Pool = Pool newtype Pool = Pool (Chan (IO ()))
{ poolJobs :: MVar [IO ()]
, poolReady :: MVar ()
}
{-# NOINLINE poolRef #-} {-# NOINLINE poolRef #-}
-- | 进程全局的池,按容量复用 -- | 进程全局的池,按容量复用
poolRef :: MVar (Maybe (Int, Pool)) poolRef :: MVar (Maybe (Int, Pool))
poolRef = unsafePerformIO (newMVar Nothing) poolRef = unsafePerformIO (newMVar Nothing)
@@ -31,42 +31,33 @@ poolRef = unsafePerformIO (newMVar Nothing)
workerPool :: Int -> IO Pool workerPool :: Int -> IO Pool
workerPool size = modifyMVar poolRef reuse workerPool size = modifyMVar poolRef reuse
where where
-- | 现有池够大就留着,否则换新的 -- \| 复用队列并按需补充工作线程
reuse current = case current of reuse current = case current of
Just (capacity, pool) Just (capacity, pool@(Pool jobs))
| capacity >= wanted -> pure (current, pool) | capacity >= wanted -> pure (current, pool)
_ -> do | otherwise -> do
sequence_ [forkIO (worker jobs) | _ <- [capacity + 1 .. wanted]]
pure (Just (wanted, pool), pool)
Nothing -> do
pool <- startPool wanted pool <- startPool wanted
pure (Just (wanted, pool), pool) pure (Just (wanted, pool), pool)
-- | 池的线程数至少一个 -- \| 池的线程数至少一个
wanted = max 1 size wanted = max 1 size
-- | 起 wanted 个常驻线程吃队列 -- \| 起 wanted 个常驻线程吃队列
startPool n = do startPool n = do
jobs <- newMVar [] jobs <- newChan
ready <- newMVar () sequence_ [forkIO (worker jobs) | _ <- [1 .. n]]
sequence_ [forkIO (worker jobs ready) | _ <- [1 .. n]] pure (Pool jobs)
pure (Pool jobs ready)
-- | 一个工作线程:被唤醒一次就取一个待办 -- | 一个工作线程:等待并执行队首待办
worker :: MVar [IO ()] -> MVar () -> IO () worker :: Chan (IO ()) -> IO ()
worker jobs ready = do worker jobs = forever (join (readChan jobs))
takeMVar ready
job <- modifyMVar jobs pick
case job of
Nothing -> worker jobs ready
Just act -> act >> worker jobs ready
where
-- | 取队首,空队列就回 Nothing
pick [] = pure ([], Nothing)
pick (j : js) = pure (js, Just j)
-- | 往池里丢一个待办 -- | 往池里丢一个待办
submit :: Pool -> IO () -> IO () submit :: Pool -> IO () -> IO ()
submit pool job = do submit (Pool jobs) = writeChan jobs
modifyMVar_ (poolJobs pool) (pure . (++ [job]))
putMVar (poolReady pool) ()
-- | 跑一个动作,结果或异常都填进格子 -- | 跑一个动作,结果或异常都填进格子
fillCell :: MVar (Either SomeException a) -> IO a -> IO () fillCell :: MVar (Either SomeException a) -> IO a -> IO ()
@@ -16,7 +16,7 @@ data Expression = Literal TypeExpr RuntimeValue | Reference String | Apply Strin
| TupleLiteral [Expression] deriving (Show, Eq) | TupleLiteral [Expression] deriving (Show, Eq)
-- | 保存绑定后的表达式节点 -- | 保存绑定后的表达式节点
data ExpressionNode = Constant RuntimeValue | BoundReference String | BoundApply FunctionId [TypedExpression] data ExpressionNode = Constant RuntimeValue | BoundReference Int String | BoundApply FunctionId [TypedExpression]
| BoundList [TypedExpression] | BoundNothing | BoundJust TypedExpression | BoundTuple [TypedExpression] | BoundList [TypedExpression] | BoundNothing | BoundJust TypedExpression | BoundTuple [TypedExpression]
deriving (Show, Eq) deriving (Show, Eq)
@@ -34,8 +34,8 @@ bindExpression types functions env expression = case expression of
tid <- descriptorId <$> resolveType types ty tid <- descriptorId <$> resolveType types ty
validateValue types tid value validateValue types tid value
Right (TypedExpression tid (Constant value)) Right (TypedExpression tid (Constant value))
Reference name -> case [tid | (key, tid) <- env, key == name] of Reference name -> case [(slot, tid) | (slot, (key, tid)) <- zip [0 ..] env, key == name] of
[tid] -> describeType types tid >> Right (TypedExpression tid (BoundReference name)) [(slot, tid)] -> describeType types tid >> Right (TypedExpression tid (BoundReference slot name))
[] -> Left ("unknown column: " ++ name) [] -> Left ("unknown column: " ++ name)
_ -> Left ("ambiguous column: " ++ name) _ -> Left ("ambiguous column: " ++ name)
Apply name arguments -> do Apply name arguments -> do
@@ -68,10 +68,10 @@ evaluateExpression :: TypeRegistry -> FunctionRegistry -> [(String, RuntimeValue
evaluateExpression types functions row (TypedExpression tid node) = do evaluateExpression types functions row (TypedExpression tid node) = do
value <- case node of value <- case node of
Constant v -> Right v Constant v -> Right v
BoundReference name -> case [v | (key, v) <- row, key == name] of BoundReference slot name -> case drop slot row of
[v] -> Right v (key, value) : _ | key == name -> Right value
[] -> Left ("missing bound column: " ++ name) [] -> Left ("missing bound column: " ++ name)
_ -> Left ("duplicate bound column: " ++ name) _ -> Left ("bound column position mismatch: " ++ name)
BoundApply fid arguments -> mapM evaluate arguments >>= invokeFunction types functions fid BoundApply fid arguments -> mapM evaluate arguments >>= invokeFunction types functions fid
BoundList arguments -> RList <$> mapM evaluate arguments BoundList arguments -> RList <$> mapM evaluate arguments
BoundNothing -> Right (RMaybe Nothing) BoundNothing -> Right (RMaybe Nothing)
@@ -0,0 +1,111 @@
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, 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 _ 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 = 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
collect seen (domain : remaining) =
let definitions = [(name, table) | (name, table) <- catalog
, lastTablePart name == domainTableName domain, name `notElem` seen]
names = map fst definitions
nested = [child | (_, table) <- definitions, (_, column) <- tableCols table
, child <- typeDomains (columnType column)]
in collect (seen ++ names) (remaining ++ nested)
-- | 保留嵌套领域的每层依赖
typeDomains (CDomain name base) = name : typeDomains base
typeDomains _ = []
-- | 收集来源树与连接条件依赖
sourceTables :: FromClause -> [String]
sourceTables source = case source of
FromTable _ name -> [name]
FromSubquery _ statement -> queryTables statement
FromJoin _ left right condition -> sourceTables left ++ sourceTables right ++ expressionTables condition
FromUnit -> []
-- | 收集表达式内嵌套子查询依赖
expressionTables :: Expr -> [String]
expressionTables expression = case expression of
ScalarSub query -> queryTables (subqueryStatement query)
ExistsSub query _ -> queryTables (subqueryStatement query)
InSub value query _ -> expressionTables value ++ queryTables (subqueryStatement query)
QuantCmp _ value query _ -> expressionTables value ++ queryTables (subqueryStatement query)
_ -> concatMap expressionTables (children expression)
-- | 列出当前表达式的直接子节点
children :: Expr -> [Expr]
children expression = case expression of
FunctionCall _ arguments -> arguments
BoundFunction _ _ arguments -> arguments
Construct _ arguments -> arguments
BoundConstruct _ arguments -> arguments
InList value arguments _ -> value : arguments
Add a b -> [a, b]
Sub a b -> [a, b]
Mul a b -> [a, b]
Div a b -> [a, b]
Gt a b -> [a, b]
Lt a b -> [a, b]
Eq a b -> [a, b]
GtE a b -> [a, b]
LtE a b -> [a, b]
NotEq a b -> [a, b]
And a b -> [a, b]
Or a b -> [a, b]
Neg a -> [a]
IsNull a -> [a]
IsNotNull a -> [a]
CountOf a -> [a]
SumOf a -> [a]
AvgOf a -> [a]
MinOf a -> [a]
MaxOf a -> [a]
_ -> []
@@ -3,6 +3,7 @@ module ChuSQL.Core.Engine.Runtime.Functions
, builtinFunctions, resolveFunction, resolveNullableFunction, functionSignature, invokeFunction , builtinFunctions, resolveFunction, resolveNullableFunction, functionSignature, invokeFunction
) where ) where
import Control.Monad (zipWithM_)
import ChuSQL.Core.Engine.Runtime.Types import ChuSQL.Core.Engine.Runtime.Types
import Data.Char (toLower) import Data.Char (toLower)
@@ -32,12 +33,7 @@ builtinFunctions types = do
-- | 按名称和完整参数类型解析函数 -- | 按名称和完整参数类型解析函数
resolveFunction :: FunctionRegistry -> String -> [TypeId] -> Either String FunctionSignature resolveFunction :: FunctionRegistry -> String -> [TypeId] -> Either String FunctionSignature
resolveFunction (FunctionRegistry functions) name arguments = resolveFunction registry name arguments = resolveNullableFunction registry name (map Just arguments)
case [sig | (sig, _) <- functions, map toLower (signatureName sig) == map toLower name
, signatureArguments sig == arguments] of
[sig] -> Right sig
[] -> Left ("no matching function signature: " ++ name)
_ -> Left ("ambiguous function signature: " ++ name)
-- | 按可空 SQL 参数解析确定签名 -- | 按可空 SQL 参数解析确定签名
resolveNullableFunction :: FunctionRegistry -> String -> [Maybe TypeId] -> Either String FunctionSignature resolveNullableFunction :: FunctionRegistry -> String -> [Maybe TypeId] -> Either String FunctionSignature
@@ -65,7 +61,8 @@ invokeFunction types (FunctionRegistry functions) fid values =
case [(sig, implementation) | (sig, implementation) <- functions, signatureId sig == fid] of case [(sig, implementation) | (sig, implementation) <- functions, signatureId sig == fid] of
[(sig, implementation)] [(sig, implementation)]
| length values == length (signatureArguments sig) -> do | length values == length (signatureArguments sig) -> do
sequence_ (zipWith (validateValue types) (signatureArguments sig) values) zipWithM_
(validateValue types) (signatureArguments sig) values
result <- implementation values result <- implementation values
validateValue types (signatureResult sig) result validateValue types (signatureResult sig) result
Right result Right result
@@ -8,22 +8,25 @@ import ChuSQL.Core.Engine.Algebra.Optimize (optimize)
import ChuSQL.Core.Engine.Algebra.Planner (translate) import ChuSQL.Core.Engine.Algebra.Planner (translate)
import ChuSQL.Core.Engine.Semantic (prepare, querySchema) import ChuSQL.Core.Engine.Semantic (prepare, querySchema)
import ChuSQL.Core.Engine.Syntax.AST (Statement) import ChuSQL.Core.Engine.Syntax.AST (Statement)
import ChuSQL.Core.Engine.Storage (MonadStorage) import ChuSQL.Core.Engine.Storage (MonadStorage (schema, withSchemaGuard))
import ChuSQL.Core.Engine.Runtime.SQL (sqlType) import ChuSQL.Core.Engine.Runtime.SQL (sqlType)
import ChuSQL.Core.Engine.Runtime.Types (TypeId) import ChuSQL.Core.Engine.Runtime.Types (TypeId)
import ChuSQL.Core.Engine.Runtime.Relation (bindRelOpColumns)
import ChuSQL.Core.Engine.Runtime.Dependencies (queryTables, domainDependencies, validateDependencies)
import ChuSQL.Core.Model import ChuSQL.Core.Model
-- SQL 查询绑定边界:保存解析后的类型、函数身份及输出 schema。 -- SQL 查询绑定边界:保存解析后的类型、函数身份及输出 schema。
-- | 保存运行时或兼容列类型 -- | 保存运行时或兼容列类型
data QueryType = RuntimeType TypeId | CompatibilityType ColumnType | NullType deriving (Show, Eq) data QueryType = RuntimeType TypeId | CompatibilityType ColumnType
| DomainType String QueryType | NullType deriving (Show, Eq)
-- | 保存仅由 schema 绑定的执行计划 -- | 保存仅由 schema 绑定的执行计划
data BoundQuery = BoundQuery Database [(String, Column)] [(String, QueryType)] RelOp data BoundQuery = BoundQuery Database [String] [(String, Column)] [(String, QueryType)] RelOp
-- | 查询绑定计划的输出类型身份 -- | 查询绑定计划的输出类型身份
queryTypes :: BoundQuery -> [(String, QueryType)] queryTypes :: BoundQuery -> [(String, QueryType)]
queryTypes (BoundQuery _ _ types _) = types queryTypes (BoundQuery _ _ _ types _) = types
-- | 绑定 SQL 查询并优化确定的计划 -- | 绑定 SQL 查询并优化确定的计划
bindQuery :: Database -> Statement -> Either String BoundQuery bindQuery :: Database -> Statement -> Either String BoundQuery
@@ -33,7 +36,10 @@ bindQuery catalog statement = do
columns <- querySchema schemaOnly resolved columns <- querySchema schemaOnly resolved
plan <- translate resolved plan <- translate resolved
types <- mapM typeOf columns types <- mapM typeOf columns
Right (BoundQuery schemaOnly columns types (optimize schemaOnly plan)) bound <- bindRelOpColumns schemaOnly [] (optimize schemaOnly plan)
let sources = queryTables resolved
dependencies = sources ++ domainDependencies schemaOnly sources
Right (BoundQuery schemaOnly dependencies columns types bound)
where where
-- | 解析输出列的运行时身份 -- | 解析输出列的运行时身份
typeOf (name, column) = do typeOf (name, column) = do
@@ -41,19 +47,24 @@ bindQuery catalog statement = do
Right (name, ty) Right (name, ty)
-- | 保留阶段外类型的兼容表示 -- | 保留阶段外类型的兼容表示
bindingType CNull = Right NullType bindingType CNull = Right NullType
bindingType (CDomain name base) = DomainType name <$> bindingType base
bindingType CDate = Right (CompatibilityType CDate) bindingType CDate = Right (CompatibilityType CDate)
bindingType CTimestamp = Right (CompatibilityType CTimestamp) bindingType CTimestamp = Right (CompatibilityType CTimestamp)
bindingType CBlob = Right (CompatibilityType CBlob) bindingType CBlob = Right (CompatibilityType CBlob)
bindingType ty@(CDomain _ base)
| typeClassOf base == TemporalClass || base == CBlob = Right (CompatibilityType ty)
bindingType ty = RuntimeType <$> sqlType ty bindingType ty = RuntimeType <$> sqlType ty
-- | 执行绑定查询并校验输出类型 -- | 执行绑定查询并校验输出类型
executeQueryM :: MonadStorage m => BoundQuery -> m (Either String [Row]) executeQueryM :: MonadStorage m => BoundQuery -> m (Either String [Row])
executeQueryM (BoundQuery catalog columns _ plan) = do executeQueryM (BoundQuery catalog dependencies columns _ plan) = do
result <- evalRelOpM catalog plan current <- schema
pure (result >>= mapM validateRow) case current >>= validateDependencies guardedTables of
Left err -> pure (Left err)
Right () -> do
result <- withSchemaGuard guardedTables
(evalRelOpM catalog plan)
pure (result >>= mapM validateRow)
where where
guardedTables = [(name, table) | (name, table) <- catalog, name `elem` dependencies]
-- | 校验完整输出行而不重新解析函数 -- | 校验完整输出行而不重新解析函数
validateRow row validateRow row
| map fst row /= map fst columns = Left "bound query output schema mismatch" | map fst row /= map fst columns = Left "bound query output schema mismatch"
@@ -0,0 +1,152 @@
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, 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
bindRelOpColumns db outer = bind
where
-- \| 递归绑定每个算子的输入布局
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 -> bind (BoundAggregate [(name, Col name) | name <- keys] items child)
BoundAggregate keys items child ->
BoundAggregate
<$> mapM (itemIn child) keys
<*> mapM (itemIn child) items
<*> bind child
Join kind left right condition ->
Join kind
<$> 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 -> 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
_ -> Right op
-- \| 使用子计划输出布局绑定表达式
expressionIn child = bindSlots (relOpCols db child) outer
-- \| 保留输出标签并绑定计算项
itemIn child (name, expression) = (,) name <$> expressionIn child expression
-- \| 绑定排序键并保留方向
sortIn child (expression, direction) = (,) <$> expressionIn child expression <*> pure direction
-- | 绑定当前表达式的列引用
bindSlots :: [String] -> [String] -> Expr -> Either String Expr
bindSlots columns outer expression = case expression of
Col name -> case slots columns name of
slot : _ -> Right (ColumnSlot slot 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
BoundConstruct tid arguments -> BoundConstruct tid <$> mapM bind arguments
Add a b -> binary Add a b
Sub a b -> binary Sub a b
Mul a b -> binary Mul a b
Div a b -> binary Div a b
Neg a -> Neg <$> bind a
Gt a b -> binary Gt a b
Lt a b -> binary Lt a b
Eq a b -> binary Eq a b
GtE a b -> binary GtE a b
LtE a b -> binary LtE a b
NotEq a b -> binary NotEq a b
And a b -> binary And a b
Or a b -> binary Or a b
IsNull a -> IsNull <$> bind a
IsNotNull a -> IsNotNull <$> bind a
CountOf a -> CountOf <$> bind a
SumOf a -> SumOf <$> bind a
AvgOf a -> AvgOf <$> bind a
MinOf a -> MinOf <$> bind a
MaxOf a -> MaxOf <$> bind a
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
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,7 +1,8 @@
module ChuSQL.Core.Engine.Runtime.SQL (resolveSQLFunction, sqlResultType, invokeSQLFunction, sqlType, constructSQLValue) where module ChuSQL.Core.Engine.Runtime.SQL (resolveSQLFunction, sqlResultType, invokeSQLFunction, sqlType, constructSQLValue) where
import ChuSQL.Core.Engine.Runtime.Types import Control.Monad (zipWithM_)
import ChuSQL.Core.Engine.Runtime.Functions import ChuSQL.Core.Engine.Runtime.Functions
import ChuSQL.Core.Engine.Runtime.Types
import ChuSQL.Core.Model (ColumnType (..), Value (..)) import ChuSQL.Core.Model (ColumnType (..), Value (..))
-- SQL 现有标量表示与已解析运行时函数之间的类型边界。 -- SQL 现有标量表示与已解析运行时函数之间的类型边界。
@@ -46,16 +47,22 @@ invokeSQLFunction :: FunctionId -> TypeId -> [Value] -> Either String Value
invokeSQLFunction fid expected values = do invokeSQLFunction fid expected values = do
functions <- builtinFunctions builtinTypes functions <- builtinFunctions builtinTypes
sig <- functionSignature functions fid sig <- functionSignature functions fid
if signatureResult sig /= expected then Left "bound function result identity mismatch" if signatureResult sig /= expected
else if length values /= length (signatureArguments sig) then Left "function argument count mismatch" then Left "bound function result identity mismatch"
else do else
sequence_ (zipWith validateArgument (signatureArguments sig) values) if length values /= length (signatureArguments sig)
if VNull `elem` values then Right VNull else do then Left "function argument count mismatch"
arguments <- mapM runtimeValue values else do
result <- invokeFunction builtinTypes functions fid arguments zipWithM_
sqlValue result validateArgument (signatureArguments sig) values
if VNull `elem` values
then Right VNull
else do
arguments <- mapM runtimeValue values
result <- invokeFunction builtinTypes functions fid arguments
sqlValue result
where where
-- | 校验具体参数并保留 SQL NULL -- \| 校验具体参数并保留 SQL NULL
validateArgument _ VNull = Right () validateArgument _ VNull = Right ()
validateArgument tid value = runtimeValue value >>= validateValue builtinTypes tid validateArgument tid value = runtimeValue value >>= validateValue builtinTypes tid
@@ -1,12 +1,15 @@
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.Model import ChuSQL.Core.Engine.Algebra.Expr (bareColumns, colsInExpr, hasAggregate, hasSubquery)
import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Engine.Syntax.Parser (parseExpression)
import ChuSQL.Core.Engine.Runtime.Functions (FunctionSignature (..), builtinFunctions, functionSignature) import ChuSQL.Core.Engine.Runtime.Functions (FunctionSignature (..), builtinFunctions, functionSignature)
import ChuSQL.Core.Engine.Runtime.SQL (resolveSQLFunction, sqlResultType, sqlType) 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.Runtime.Types
import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Engine.Syntax.Parser (parseExpression)
import ChuSQL.Core.Model
import Data.Char (isAlphaNum, isAscii, toLower) import Data.Char (isAlphaNum, isAscii, toLower)
import Data.List (intercalate, isInfixOf, isPrefixOf, isSuffixOf, nub) import Data.List (intercalate, isInfixOf, isPrefixOf, isSuffixOf, nub)
@@ -30,24 +33,29 @@ querySchema db statement = do
columns <- inferSubqueryOutput db (Scope [] []) (Subquery statement []) columns <- inferSubqueryOutput db (Scope [] []) (Subquery statement [])
Right [(name, plainColumn (derivedType ty)) | (name, ty) <- columns] Right [(name, plainColumn (derivedType ty)) | (name, ty) <- columns]
-- | 检查期的作用域:本层优先,外层兜底 -- | 从最近层到最远层保存外部作用域
type EnclosingScopes = [[(String, Column)]]
-- | 保存本层与各层外部列
data Scope = Scope data Scope = Scope
{ scopeInner :: [(String, Column)] { scopeInner :: [(String, Column)]
, scopeOuter :: [(String, Column)] , scopeOuter :: EnclosingScopes
} }
-- | 本层先查,查不到再落外层;本层同名引起歧义时不往外层让 -- | 逐层解析列,本层歧义不向外层回退
scopeAt :: String -> Scope -> String -> Either String (String, Column) scopeAt :: String -> Scope -> String -> Either String (String, Column)
scopeAt place scope c scopeAt place scope c = search (scopeFrames scope)
| null (scopeOuter scope) = columnAt place (scopeInner scope) c where
| otherwise = case columnAt place (scopeInner scope) c of -- | 在最近的可见列层停止查找
search [] = Left (missingColumn place c (concat (scopeFrames scope)))
search (columns : rest) = case columnAt place columns c of
Right entry -> Right entry Right entry -> Right entry
Left err Left err
| "ambiguous column:" `isInfixOf` err -> Left err | "ambiguous column:" `isInfixOf` err -> Left err
| otherwise -> columnAt place (scopeOuter scope) c | otherwise -> search rest
-- | 收集 FROM 的列,列前缀由表名推导 -- | 收集 FROM 的列,列前缀由表名推导
checkFrom :: Database -> [(String, Column)] -> FromClause -> Either String [(String, Column)] checkFrom :: Database -> EnclosingScopes -> FromClause -> Either String [(String, Column)]
checkFrom _ _ FromUnit = Right [] checkFrom _ _ FromUnit = Right []
checkFrom db _ (FromTable mAlias tbl) = do checkFrom db _ (FromTable mAlias tbl) = do
(key, t) <- resolveTable db tbl (key, t) <- resolveTable db tbl
@@ -72,13 +80,9 @@ inferredColumnType :: ColumnType -> InferredType
inferredColumnType CNull = InferNull inferredColumnType CNull = InferNull
inferredColumnType ty = InferType ty inferredColumnType ty = InferType ty
-- | 合并两层列,本层优先且不重复 -- | 进入子查询时保留每层的列边界
scopedEnv :: [(String, Column)] -> [(String, Column)] -> [(String, Column)] scopeFrames :: Scope -> EnclosingScopes
scopedEnv env outer = env ++ [o | o <- outer, o `notElem` env] scopeFrames scope = scopeInner scope : scopeOuter scope
-- | 把作用域摊平成一层的列清单
scopeFlat :: Scope -> [(String, Column)]
scopeFlat scope = scopedEnv (scopeInner scope) (scopeOuter scope)
-- | 拼“列不存在”的报错 -- | 拼“列不存在”的报错
missingColumn :: String -> String -> [(String, Column)] -> String missingColumn :: String -> String -> [(String, Column)] -> String
@@ -91,7 +95,7 @@ missingColumn place c env =
-- | 检查列是否都在环境里 -- | 检查列是否都在环境里
checkColumns :: String -> Scope -> [String] -> Either String () 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) columnAt :: String -> [(String, Column)] -> String -> Either String (String, Column)
@@ -107,18 +111,19 @@ checkNoAggregate place e
| otherwise = Right () | otherwise = Right ()
-- | 分组查询里,没被聚合的列必须出现在 GROUP BY 里 -- | 分组查询里,没被聚合的列必须出现在 GROUP BY 里
checkGrouping :: Scope -> [String] -> [(String, Expr)] -> Either String () checkGrouping :: Scope -> [String] -> [(String, Expr)] -> Maybe Expr -> Either String ()
checkGrouping env keys items checkGrouping env keys items having
| null keys && not (any (hasAggregate . snd) items) = Right () | null keys && null having && not (any (hasAggregate . snd) items) = Right ()
| otherwise = do | otherwise = do
checkColumns "GROUP BY" env keys checkColumns "GROUP BY" env keys
mapM_ (checkRuntimeColumn "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 where
-- | 这一列能不能出现在分组查询里 -- \| 这一列能不能出现在分组查询里
okCol c okCol c
| c == allColumns = Left "SELECT: * cannot be selected together with GROUP BY" | c == allColumns = Left "SELECT: * cannot be selected together with GROUP BY"
| c `elem` keys = Right () | c `elem` keys = Right ()
| Left _ <- resolveColumn c (scopeInner env) = Right ()
| otherwise = Left ("SELECT: column " ++ c ++ " must appear in GROUP BY or be aggregated") | otherwise = Left ("SELECT: column " ++ c ++ " must appear in GROUP BY or be aggregated")
-- | 渲染一个推导类型 -- | 渲染一个推导类型
@@ -129,6 +134,8 @@ renderType (InferType t) = typeLabel t
-- | 推导表达式的类型(子查询也在这里整条查一遍) -- | 推导表达式的类型(子查询也在这里整条查一遍)
inferExpr :: Database -> String -> Scope -> Expr -> Either String InferredType inferExpr :: Database -> String -> Scope -> Expr -> Either String InferredType
inferExpr _ place env (Col c) = inferredColumnType . columnType . snd <$> scopeAt place env c inferExpr _ place env (Col c) = inferredColumnType . columnType . snd <$> scopeAt place env c
inferExpr _ _ _ ColumnSlot{} = Left "execution column cannot be used in semantic input"
inferExpr _ _ _ OuterColumnSlot{} = Left "execution column cannot be used in semantic input"
inferExpr _ _ _ LitNull = Right InferNull inferExpr _ _ _ LitNull = Right InferNull
inferExpr _ _ _ (LitInt _) = Right (InferType CInt) inferExpr _ _ _ (LitInt _) = Right (InferType CInt)
inferExpr _ _ _ (LitFloat _) = Right (InferType CFloat) inferExpr _ _ _ (LitFloat _) = Right (InferType CFloat)
@@ -230,22 +237,20 @@ itemType place want got
-- | 推导子查询的输出列与类型 -- | 推导子查询的输出列与类型
inferSubqueryOutput :: Database -> Scope -> Subquery -> Either String [(String, InferredType)] 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 inferSubqueryOutput db outerScope sq = case subqueryStatement sq of
q@Select { selectCols = cols } -> do SelectDistinct q -> do
columns <- inferSubqueryOutput db outerScope sq{subqueryStatement = q}
mapM_ (requireOrdering "DISTINCT" . snd) columns
_ <- distinctOrdering q
Right columns
q@Select{selectItems = items} -> do
env <- checkFrom db enclosing (selectFrom q) env <- checkFrom db enclosing (selectFrom q)
checkResolvedWith db enclosing q checkResolvedWith db enclosing q
mapM (columnTypeOf env) cols mapM (\(l, e) -> (l,) <$> inferExpr db "SELECT" (Scope env enclosing) e) items
q@SelectExpr { 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
_ -> Left "subquery must be a SELECT" _ -> Left "subquery must be a SELECT"
where where
enclosing = scopeFlat outerScope enclosing = scopeFrames outerScope
-- | 查这一列的推导类型
columnTypeOf env c = do
(_, col) <- scopeAt "SELECT" (Scope env enclosing) c
Right (c, inferredColumnType (columnType col))
-- | 聚合的参数:列要在,且不能嵌套聚合 -- | 聚合的参数:列要在,且不能嵌套聚合
aggregateArg :: Database -> String -> Scope -> Expr -> Either String InferredType aggregateArg :: Database -> String -> Scope -> Expr -> Either String InferredType
@@ -278,7 +283,7 @@ arithmetic db place env a b = do
mapM_ (numericOperand place (InferType want) (InferType want)) [ta, tb] mapM_ (numericOperand place (InferType want) (InferType want)) [ta, tb]
Right (arithResult ta tb) Right (arithResult ta tb)
where where
-- | 是不是浮点类型 -- \| 是不是浮点类型
isFloatSide (InferType x) = numericType x && not (integerType x) isFloatSide (InferType x) = numericType x && not (integerType x)
isFloatSide _ = False isFloatSide _ = False
@@ -312,7 +317,7 @@ boolean db place env a b = do
mapM_ (boolOperand place ta) [ta, tb] mapM_ (boolOperand place ta) [ta, tb]
Right (InferType CBool) Right (InferType CBool)
where where
-- | 挨个查操作数是不是布尔 -- \| 挨个查操作数是不是布尔
boolOperand _ _ InferNull = Right () boolOperand _ _ InferNull = Right ()
boolOperand _ _ (InferType ty) | typeClassOf ty == BooleanClass = Right () boolOperand _ _ (InferType ty) | typeClassOf ty == BooleanClass = Right ()
boolOperand p other t = Left (p ++ ": operator needs TBool on both sides, got " ++ renderType other ++ " and " ++ renderType t) boolOperand p other t = Left (p ++ ": operator needs TBool on both sides, got " ++ renderType other ++ " and " ++ renderType t)
@@ -348,7 +353,7 @@ checkAssign db t = checkTyped db "UPDATE" (Scope (tableCols t) []) t
-- | 按语句类型分派检查 -- | 按语句类型分派检查
check :: Database -> Statement -> Either String () check :: Database -> Statement -> Either String ()
check db q = () <$ prepare db q check db q = void (prepare db q)
-- | 执行前解析列名并检查类型 -- | 执行前解析列名并检查类型
prepare :: Database -> Statement -> Either String Statement prepare :: Database -> Statement -> Either String Statement
@@ -419,13 +424,13 @@ resolveDomainTypes db statement = case statement of
AlterColumnType name col ty -> AlterColumnType name col <$> resolveDomainType ty AlterColumnType name col ty -> AlterColumnType name col <$> resolveDomainType ty
_ -> Right statement _ -> Right statement
where where
-- | 解析一列的类型 -- \| 解析一列的类型
resolveColumnType (name, col) = do resolveColumnType (name, col) = do
ty <- resolveDomainType (columnType col) ty <- resolveDomainType (columnType col)
Right (name, col {columnType = ty}) Right (name, col{columnType = ty})
-- | 从类型目录取基础类型 -- \| 从类型目录取基础类型
resolveDomainType = resolveWith [] resolveDomainType = resolveWith []
-- | 递归解析类型并拒绝循环定义 -- \| 递归解析类型并拒绝循环定义
resolveWith seen (CDomain name _) resolveWith seen (CDomain name _)
| map toLower name `elem` seen = Left ("cyclic domain definition: " ++ name) | map toLower name `elem` seen = Left ("cyclic domain definition: " ++ name)
| otherwise = do | otherwise = do
@@ -440,34 +445,25 @@ checkResolved :: Database -> Statement -> Either String ()
checkResolved db = checkResolvedWith db [] checkResolved db = checkResolvedWith db []
-- | 检查已解析的语句;outer 是相关子查询能看见的外层列 -- | 检查已解析的语句;outer 是相关子查询能看见的外层列
checkResolvedWith :: Database -> [(String, Column)] -> Statement -> Either String () checkResolvedWith :: Database -> EnclosingScopes -> Statement -> Either String ()
checkResolvedWith db outer q = case q of checkResolvedWith db outer q = case q of
Select SelectDistinct inner -> void (inferSubqueryOutput db (Scope [] outer) (Subquery (SelectDistinct inner) []))
{ selectCols = cols Select items fromC mWhere groupBy having orderBy _ -> do
, selectFrom = fromC
, selectWhere = mWhere
, selectGroupBy = groupBy
, selectOrderBy = orderBy
} -> do
env <- checkFrom db outer fromC
let full = Scope env outer
checkColumns "SELECT" full cols
checkGrouping full groupBy (map (\c -> (c, Col c)) cols)
checkColumns "ORDER BY" full (map fst orderBy)
mapM_ (checkRuntimeColumn "ORDER BY" full . fst) orderBy
mapM_ (checkNoAggregate "WHERE") mWhere
mapM_ (checkBool db "WHERE" full) mWhere
SelectExpr items fromC mWhere groupBy orderBy _ -> do
env <- checkFrom db outer fromC env <- checkFrom db outer fromC
let full = Scope env outer let full = Scope env outer
mapM_ (\item -> () <$ inferExpr db "SELECT" full (snd item)) items mapM_ (inferExpr db "SELECT" full . snd) items
checkGrouping full groupBy (items ++ [(c, Col c) | (c, _) <- orderBy, c `notElem` map fst 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_ (checkOrder db full items . fst) orderBy
mapM_ (checkNoAggregate "WHERE") mWhere mapM_ (checkNoAggregate "WHERE") mWhere
mapM_ (checkBool db "WHERE" full) mWhere mapM_ (checkBool db "WHERE" full) mWhere
Insert tbl cols rows -> do Insert tbl cols rows -> do
t <- lookupTable db tbl t <- lookupTable db tbl
checkColumns "INSERT" (Scope (tableCols t) []) cols 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 if null rows
then Left "INSERT: no values" then Left "INSERT: no values"
else mapM_ (mapM_ (checkValue db t) . zip cols) rows else mapM_ (mapM_ (checkValue db t) . zip cols) rows
@@ -488,7 +484,7 @@ checkResolvedWith db outer q = case q of
if length names /= length (nub names) if length names /= length (nub names)
then Left ("CREATE TABLE: duplicate column names in " ++ name) then Left ("CREATE TABLE: duplicate column names in " ++ name)
else Right () else Right ()
checkColumnDefs (map fst cols) cols checkColumnDefs cols cols
DropTable name -> DropTable name ->
if null name if null name
then Left "DROP TABLE: empty table name" then Left "DROP TABLE: empty table name"
@@ -511,12 +507,14 @@ checkResolvedWith db outer q = case q of
if col == idColumn if col == idColumn
then Left "DROP COLUMN: the built-in id column cannot be dropped" then Left "DROP COLUMN: the built-in id column cannot be dropped"
else Right () else Right ()
let remaining = filter ((/= col) . fst) (tableCols t)
checkChecks remaining remaining
AddColumn tbl def -> do AddColumn tbl def -> do
t <- lookupTable db tbl t <- lookupTable db tbl
if fst def `elem` tableCols' t if fst def `elem` tableCols' t
then Left ("ADD COLUMN: column already exists: " ++ fst def) then Left ("ADD COLUMN: column already exists: " ++ fst def)
else Right () else Right ()
checkColumnDefs (tableCols' t ++ [fst def]) [def] checkColumnDefs (tableCols t ++ [def]) [def]
RenameColumn tbl old new -> do RenameColumn tbl old new -> do
t <- lookupTable db tbl t <- lookupTable db tbl
if old `notElem` tableCols' t if old `notElem` tableCols' t
@@ -528,6 +526,8 @@ checkResolvedWith db outer q = case q of
if new `elem` tableCols' t if new `elem` tableCols' t
then Left ("RENAME COLUMN: column already exists: " ++ new) then Left ("RENAME COLUMN: column already exists: " ++ new)
else Right () else Right ()
let renamed = [(if name == old then new else name, column) | (name, column) <- tableCols t]
checkChecks renamed renamed
AlterColumnType tbl col ty -> do AlterColumnType tbl col ty -> do
t <- lookupTable db tbl t <- lookupTable db tbl
c <- requireColumn "ALTER COLUMN" t col c <- requireColumn "ALTER COLUMN" t col
@@ -535,10 +535,12 @@ checkResolvedWith db outer q = case q of
if columnAutoIncrement c && not (integerType ty) if columnAutoIncrement c && not (integerType ty)
then Left "ALTER COLUMN: AUTO_INCREMENT column must stay an integer type" then Left "ALTER COLUMN: AUTO_INCREMENT column must stay an integer type"
else Right () 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 AlterColumnDefault tbl col def -> do
t <- lookupTable db tbl t <- lookupTable db tbl
c <- requireColumn "ALTER COLUMN" t col c <- requireColumn "ALTER COLUMN" t col
mapM_ (\v -> checkDefault c v) def mapM_ (checkDefault c) def
AlterColumnNull tbl col nullable -> do AlterColumnNull tbl col nullable -> do
t <- lookupTable db tbl t <- lookupTable db tbl
c <- requireColumn "ALTER COLUMN" t col c <- requireColumn "ALTER COLUMN" t col
@@ -552,6 +554,7 @@ checkResolvedWith db outer q = case q of
if length (nub (map fst attributes)) == length attributes if length (nub (map fst attributes)) == length attributes
then Right () then Right ()
else Left "duplicate identity attribute" else Left "duplicate identity attribute"
ShowGrants -> Right ()
ShowRoles -> Right () ShowRoles -> Right ()
DropUser name -> checkUserName name DropUser name -> checkUserName name
CreateRole name -> checkRoleName name CreateRole name -> checkRoleName name
@@ -560,6 +563,7 @@ checkResolvedWith db outer q = case q of
mapM_ checkPrivilege privs mapM_ checkPrivilege privs
checkGrantObject obj checkGrantObject obj
checkRoleName role checkRoleName role
RevokeGrantOption privs obj role -> checkResolvedWith db outer (RevokePrivileges privs obj role)
RevokePrivileges privs obj role -> do RevokePrivileges privs obj role -> do
mapM_ checkPrivilege privs mapM_ checkPrivilege privs
checkGrantObject obj checkGrantObject obj
@@ -577,11 +581,11 @@ checkResolvedWith db outer q = case q of
CreateDomain{} -> Right () CreateDomain{} -> Right ()
DropDomain{} -> Right () DropDomain{} -> Right ()
ShowDomains -> Right () ShowDomains -> Right ()
-- | 事务控制由会话层执行,语义层不做列检查 -- \| 事务控制由会话层执行,语义层不做列检查
BeginTransaction -> Right () BeginTransaction -> Right ()
CommitTransaction -> Right () CommitTransaction -> Right ()
RollbackTransaction -> Right () RollbackTransaction -> Right ()
-- | 保存点名字只是会话层的记号,不做列检查 -- \| 保存点名字只是会话层的记号,不做列检查
Savepoint _ -> Right () Savepoint _ -> Right ()
RollbackToSavepoint _ -> Right () RollbackToSavepoint _ -> Right ()
ReleaseSavepoint _ -> Right () ReleaseSavepoint _ -> Right ()
@@ -603,9 +607,9 @@ checkInsertTargets t cols = mapM_ checkTarget (tableCols t)
| Just _ <- columnDefault c = Right () | Just _ <- columnDefault c = Right ()
| otherwise = Left ("INSERT: column " ++ name ++ " is NOT NULL and has no default") | otherwise = Left ("INSERT: column " ++ name ++ " is NOT NULL and has no default")
-- | 检查一列定义是否合法(names 给 CHECK 用) -- | 依据完整 schema 校验新增列定义
checkColumnDefs :: [String] -> [(String, Column)] -> Either String () checkColumnDefs :: [(String, Column)] -> [(String, Column)] -> Either String ()
checkColumnDefs names cols = do checkColumnDefs schemaColumns cols = do
mapM_ (checkTypeParameters . columnType . snd) cols mapM_ (checkTypeParameters . columnType . snd) cols
mapM_ (\(_, c) -> mapM_ (checkDefault c) (columnDefault c)) cols mapM_ (\(_, c) -> mapM_ (checkDefault c) (columnDefault c)) cols
mapM_ (\(_, c) -> checkAutoIncrement c) cols mapM_ (\(_, c) -> checkAutoIncrement c) cols
@@ -613,18 +617,19 @@ checkColumnDefs names cols = do
if length [() | (_, c) <- cols, columnAutoIncrement c] > 1 if length [() | (_, c) <- cols, columnAutoIncrement c] > 1
then Left "CREATE TABLE: at most one AUTO_INCREMENT column is allowed" then Left "CREATE TABLE: at most one AUTO_INCREMENT column is allowed"
else Right () else Right ()
checkChecks names cols checkChecks schemaColumns cols
where where
-- | 拒绝缺少能力实现的运行时键 -- \| 拒绝缺少能力实现的运行时键
checkRuntimeKey (_, column) checkRuntimeKey (_, column)
| typeClassOf (columnType column) == RuntimeClass | typeClassOf (columnType column) == RuntimeClass
, columnUnique column || columnPrimaryKey column = Left "runtime type key capability is not registered" , columnUnique column || columnPrimaryKey column =
Left "runtime type key capability is not registered"
| otherwise = Right () | otherwise = Right ()
-- | 校验列类型的长度和精度参数 -- | 校验列类型的长度和精度参数
checkTypeParameters :: ColumnType -> Either String () checkTypeParameters :: ColumnType -> Either String ()
checkTypeParameters (CDomain _ base) = checkTypeParameters base 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 CNull = Left "NULL is only valid as an inferred query output"
checkTypeParameters (CDecimal p s) checkTypeParameters (CDecimal p s)
| p <= 0 || p > 308 || s < 0 || s > p = Left "invalid decimal precision or scale" | p <= 0 || p > 308 || s < 0 || s > p = Left "invalid decimal precision or scale"
@@ -642,23 +647,20 @@ checkAutoIncrement c
checkDefault :: Column -> Value -> Either String () checkDefault :: Column -> Value -> Either String ()
checkDefault c v checkDefault c v
| VNull <- v = Right () | 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)) | otherwise = Left ("DEFAULT: value does not fit column type " ++ typeLabel (columnType c))
-- | CHECK 里的列必须存在 -- | 按完整 schema 校验 CHECK 条件
checkChecks :: [String] -> [(String, Column)] -> Either String () checkChecks :: [(String, Column)] -> [(String, Column)] -> Either String ()
checkChecks names = mapM_ checkOne checkChecks columns = mapM_ checkOne
where where
-- | 查这一列的 CHECK -- \| 查这一列的 CHECK
checkOne (_, c) = case columnCheck c of checkOne (_, c) = case columnCheck c of
Nothing -> Right () Nothing -> Right ()
Just text -> case parseExpression text of Just text -> case parseExpression text of
Left err -> Left ("CHECK: " ++ firstLine err) Left err -> Left ("CHECK: " ++ firstLine err)
Right e -> mapM_ (known e) (colsInExpr e) Right e -> void (prepareCheckExpression columns e)
-- | 这个列名在不在定义里 -- | 只保留解析错误的第一行
known _ col
| col `elem` names = Right ()
| otherwise = Left ("CHECK: unknown column: " ++ col)
firstLine = takeWhile (/= '\n') firstLine = takeWhile (/= '\n')
-- | 账号名上限 -- | 账号名上限
@@ -683,7 +685,7 @@ checkUserName name
| not (all allowed name) = Left "USER: account name may only contain ASCII letters, digits, dot, dash or underscore" | not (all allowed name) = Left "USER: account name may only contain ASCII letters, digits, dot, dash or underscore"
| otherwise = Right () | otherwise = Right ()
where where
-- | 账号名字符规则 -- \| 账号名字符规则
allowed c = isAscii c && (isAlphaNum c || c `elem` ("_.-" :: String)) allowed c = isAscii c && (isAlphaNum c || c `elem` ("_.-" :: String))
-- | 建号 / 改口令:名字合法且口令不空 -- | 建号 / 改口令:名字合法且口令不空
@@ -706,7 +708,7 @@ checkRoleName name
| map toLower name `elem` privilegeNames = Left "ROLE: role name must not be a privilege keyword" | map toLower name `elem` privilegeNames = Left "ROLE: role name must not be a privilege keyword"
| otherwise = Right () | otherwise = Right ()
where where
-- | 角色名字符规则 -- \| 角色名字符规则
allowed c = isAscii c && (isAlphaNum c || c `elem` ("_.-" :: String)) allowed c = isAscii c && (isAlphaNum c || c `elem` ("_.-" :: String))
-- | 权限关键字(小写,只用于比较) -- | 权限关键字(小写,只用于比较)
@@ -728,17 +730,18 @@ checkGrantObject obj
| not (all allowed obj) = Left "GRANT: object name may only contain ASCII letters, digits, dot, dash or underscore" | not (all allowed obj) = Left "GRANT: object name may only contain ASCII letters, digits, dot, dash or underscore"
| otherwise = Right () | otherwise = Right ()
where where
-- | 授权对象字符规则 -- \| 授权对象字符规则
allowed c = isAscii c && (isAlphaNum c || c `elem` ("_.-" :: String)) allowed c = isAscii c && (isAlphaNum c || c `elem` ("_.-" :: String))
-- | 内置 id 列名 -- | 内置 id 列名
idColumn :: String idColumn :: String
idColumn = "id" idColumn = "id"
-- | 把列引用统一为执行期名字(子查询一起解析) -- | 把列引用统一为执行期名字(子查询一起解析)
resolveExpr :: resolveExpr ::
Database -> Database ->
[(String, Column)] -> [(String, Column)] ->
[(String, Column)] -> EnclosingScopes ->
(String -> Either String String) -> (String -> Either String String) ->
Expr -> Expr ->
Either String Expr Either String Expr
@@ -776,14 +779,14 @@ resolveExpr db env outer f e = case e of
AvgOf a -> AvgOf <$> resolveExpr db env outer f a AvgOf a -> AvgOf <$> resolveExpr db env outer f a
MinOf a -> MinOf <$> resolveExpr db env outer f a MinOf a -> MinOf <$> resolveExpr db env outer f a
MaxOf a -> MaxOf <$> resolveExpr db env outer f a MaxOf a -> MaxOf <$> resolveExpr db env outer f a
ScalarSub sq -> ScalarSub <$> resolveSubquery db (env ++ outer) sq 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 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 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 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 QuantCmp op a sq q -> QuantCmp op <$> resolveExpr db env outer f a <*> resolveSubquery db (env : outer) sq <*> pure q
_ -> Right e _ -> Right e
where where
-- | 递归处理两个子表达式 -- \| 递归处理两个子表达式
binary ctor a b = ctor <$> resolveExpr db env outer f a <*> resolveExpr db env outer f b binary ctor a b = ctor <$> resolveExpr db env outer f a <*> resolveExpr db env outer f b
-- | 校验具体构造器和参数逻辑类型 -- | 校验具体构造器和参数逻辑类型
@@ -800,7 +803,7 @@ inferConstruction db place env ty@(TypeApply cid parameters) arguments = do
required <- mapM (fmap descriptorId . resolveType builtinTypes) expected required <- mapM (fmap descriptorId . resolveType builtinTypes) expected
if supplied == required then Right (descriptorId descriptor) else Left "composite constructor argument type mismatch" if supplied == required then Right (descriptorId descriptor) else Left "composite constructor argument type mismatch"
where where
-- | 解析非空参数的逻辑类型身份 -- \| 解析非空参数的逻辑类型身份
argumentIdentity InferNull = Left "SQL NULL needs Maybe construction inside a runtime value" argumentIdentity InferNull = Left "SQL NULL needs Maybe construction inside a runtime value"
argumentIdentity (InferType column) = sqlType column argumentIdentity (InferType column) = sqlType column
@@ -809,7 +812,18 @@ prepareRowExpression :: [(String, Column)] -> Expr -> Either String Expr
prepareRowExpression columns expression = do prepareRowExpression columns expression = do
bound <- resolveExpr [] columns [] (nameIn columns "expression") expression bound <- resolveExpr [] columns [] (nameIn columns "expression") expression
_ <- inferExpr [] "expression" (Scope columns []) bound _ <- 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 inferredArgument :: InferredType -> Maybe ColumnType
@@ -817,33 +831,36 @@ inferredArgument InferNull = Nothing
inferredArgument (InferType ty) = Just ty 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 resolveSubquery db outer sq = do
stmt <- resolveSubqueryStatement db outer (subqueryStatement sq) 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 :: Database -> EnclosingScopes -> Statement -> Either String [String]
outerRefsOf db stmt = nub [c | c <- statementColumns stmt, not (inInner c)] outerRefsOf db outer stmt = do
inner <- checkFrom db outer (statementFrom stmt)
columns <- statementColumns stmt
Right (nub [c | c <- columns, not (inInner inner c)])
where where
inner = case checkFrom db [] (statementFrom stmt) of -- \| 这一列能不能在内层解析到
Right env -> env inInner inner c = case resolveColumn c inner of
Left _ -> []
-- | 这一列能不能在内层解析到
inInner c = case resolveColumn c inner of
Right _ -> True Right _ -> True
Left _ -> False Left _ -> False
-- | 一条语句里出现的所有列引用 -- | 一条语句里出现的所有列引用
statementColumns :: Statement -> [String] statementColumns :: Statement -> Either String [String]
statementColumns stmt = case stmt of statementColumns stmt = case stmt of
Select cols fromC mWhere groupBy orderBy _ -> SelectDistinct q -> statementColumns q
cols ++ fromColumns fromC ++ concatMap colsInExpr mWhere ++ groupBy ++ map fst orderBy Select items fromC mWhere groupBy having orderBy _ -> do
SelectExpr items fromC mWhere groupBy orderBy _ -> ordering <- mapM (orderExpression items . fst) orderBy
concatMap (colsInExpr . snd) items ++ fromColumns fromC ++ concatMap colsInExpr mWhere ++ groupBy ++ map fst orderBy Right (concatMap (colsInExpr . snd) items ++ fromColumns fromC
_ -> [] ++ concatMap colsInExpr mWhere ++ groupBy ++ concatMap colsInExpr having ++ concatMap colsInExpr ordering)
_ -> Right []
where where
-- | 取 FROM 里出现的列 -- \| 取 FROM 里出现的列
fromColumns FromUnit = [] fromColumns FromUnit = []
fromColumns (FromTable _ _) = [] fromColumns (FromTable _ _) = []
fromColumns (FromSubquery _ _) = [] fromColumns (FromSubquery _ _) = []
@@ -851,26 +868,26 @@ statementColumns stmt = case stmt of
-- | 取语句的 FROM 子句,没有就是 FromUnit -- | 取语句的 FROM 子句,没有就是 FromUnit
statementFrom :: Statement -> FromClause statementFrom :: Statement -> FromClause
statementFrom Select { selectFrom = fromC } = fromC statementFrom (SelectDistinct q) = statementFrom q
statementFrom SelectExpr { selectFrom = fromC } = fromC statementFrom Select{selectFrom = fromC} = fromC
statementFrom _ = FromUnit statementFrom _ = FromUnit
-- | 解析子查询里的 SELECT -- | 解析子查询里的 SELECT
resolveSubqueryStatement :: Database -> [(String, Column)] -> Statement -> Either String Statement resolveSubqueryStatement :: Database -> EnclosingScopes -> Statement -> Either String Statement
resolveSubqueryStatement db outer q@Select{} = resolveQuery db outer q (map (\c -> (c, Col c)) (selectCols q)) resolveSubqueryStatement db outer (SelectDistinct q) = SelectDistinct <$> resolveSubqueryStatement db outer q
resolveSubqueryStatement db outer q@SelectExpr{} = resolveQuery db outer q (selectItems q) resolveSubqueryStatement db outer q@Select{} = resolveQuery db outer q (selectItems q)
resolveSubqueryStatement _ _ _ = Left "subquery must be a SELECT" resolveSubqueryStatement _ _ _ = Left "subquery must be a SELECT"
-- | 列名解析入口:查询走连接解析,改数据的语句按本表列解析 -- | 列名解析入口:查询走连接解析,改数据的语句按本表列解析
resolveStatement :: Database -> Statement -> Either String Statement resolveStatement :: Database -> Statement -> Either String Statement
resolveStatement db q = case q of resolveStatement db q = case q of
SelectDistinct inner -> SelectDistinct <$> resolveStatement db inner
Select{} -> resolveSelect db q Select{} -> resolveSelect db q
SelectExpr{} -> resolveSelect db q
Update tbl assigns mWhere -> do Update tbl assigns mWhere -> do
(key, t) <- resolveTable db tbl (key, t) <- resolveTable db tbl
let env = tableCols t let env = tableCols t
name = nameIn env "UPDATE" 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 w <- mapM (resolveExpr db env [] (nameIn env "WHERE")) mWhere
pure (Update key assigns' w) pure (Update key assigns' w)
Delete tbl mWhere -> do Delete tbl mWhere -> do
@@ -888,28 +905,33 @@ resolveStatement db q = case q of
nameIn :: [(String, Column)] -> String -> String -> Either String String nameIn :: [(String, Column)] -> String -> String -> Either String String
nameIn env place c = fst <$> columnAt place env c nameIn env place c = fst <$> columnAt place env c
-- | 内层先查,查不到再落到外层;内层同名引起的歧义不往外层让 -- | 解析原始引用,最近来源限定名遮蔽远层
scopedColumnAt :: String -> [(String, Column)] -> [(String, Column)] -> String -> Either String (String, Column) scopedColumnAt :: String -> [(String, Column)] -> EnclosingScopes -> String -> Either String (String, Column)
scopedColumnAt place inner outer c = scopeAt place (Scope inner outer) c 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 :: Database -> Statement -> Either String Statement
resolveSelect db q@Select{} = resolveQuery db [] q (map (\c -> (c, Col c)) (selectCols q)) resolveSelect db q@Select{} = resolveQuery db [] q (selectItems q)
resolveSelect db q@SelectExpr{} = resolveQuery db [] q (selectItems q)
resolveSelect _ q = Right q resolveSelect _ q = Right q
-- | 检查排序输出别名或来源列 -- | 检查排序表达式的类型能力
checkOrder :: Database -> Scope -> [(String, Expr)] -> String -> Either String () checkOrder :: Database -> Scope -> [(String, Expr)] -> OrderKey -> Either String ()
checkOrder db env items column = case [e | (label, e) <- items, label == column] of checkOrder db env items column = do
[] -> checkRuntimeColumn "ORDER BY" env column expression <- orderExpression items column
[expression] -> () <$ (inferExpr db "ORDER BY" env expression >>= requireOrdering "ORDER BY") void (inferExpr db "ORDER BY" env expression >>= requireOrdering "ORDER BY")
_ -> Left ("ORDER BY: ambiguous projection alias: " ++ column)
-- | 校验列已有排序能力 -- | 校验列已有排序能力
checkRuntimeColumn :: String -> Scope -> String -> Either String () checkRuntimeColumn :: String -> Scope -> String -> Either String ()
checkRuntimeColumn place env column = do checkRuntimeColumn place env column = do
(_, definition) <- scopeAt place env column (_, definition) <- scopeAt place env column
() <$ requireOrdering place (InferType (columnType definition)) void (requireOrdering place (InferType (columnType definition)))
-- | 拒绝尚未注册能力的复合类型 -- | 拒绝尚未注册能力的复合类型
requireOrdering :: String -> InferredType -> Either String InferredType requireOrdering :: String -> InferredType -> Either String InferredType
@@ -919,46 +941,54 @@ requireOrdering place inferred@(InferType ty)
requireOrdering _ inferred = Right inferred 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 resolveQuery db outer q items = do
source <- resolveSource db outer (selectFrom q) source <- resolveSource db outer (selectFrom q)
env <- checkFrom db outer source env <- checkFrom db outer source
-- | 单表无别名时把裸列名换成物理列名;带别名时表头保留别名限定名 -- \| 单表无别名时把裸列名换成物理列名;带别名时表头保留别名限定名
let physical c = case selectFrom q of let physical c = case selectFrom q of
FromTable Nothing tbl -> unqualify (Just (deriveQualifier Nothing tbl)) c FromTable Nothing tbl -> unqualify (Just (deriveQualifier Nothing tbl)) c
_ -> c _ -> c
-- | 查一列并换算成物理名 -- \| 查一列并换算成物理名
name place c name place c
| length (filter (== '.') c) == 2, not (qualifiedReference c) = Left (missingColumn place c env) | length (filter (== '.') c) == 2, not (qualifiedReference c) = Left (missingColumn place c env)
| otherwise = physical . fst <$> scopedColumnAt place env outer c | otherwise = physical . fst <$> scopedColumnAt place env outer c
-- | 库限定列只引用来源中的真实表名 -- \| 库限定列只引用来源中的真实表名
qualifiedReference c = qualifiedReferenceIn db (selectFrom q) c qualifiedReference c =
|| (any (\(key, _) -> length (filter (== '.') key) == 1 && ("." ++ key) `isSuffixOf` c) outer qualifiedReferenceIn db (selectFrom q) c
&& (not (any (elem '.' . fst) db) || any (\(table, _) -> (table ++ ".") `isPrefixOf` c) db)) || ( any
-- | 换算一个投影项:带别名时保留别名做输出列名 (any
(\ (key, _)
-> length (filter (== '.') key) == 1
&& ("." ++ key) `isSuffixOf` c))
outer
&& (not (any (elem '.' . fst) db) || any (\(table, _) -> (table ++ ".") `isPrefixOf` c) db)
)
-- \| 换算一个投影项:带别名时保留别名做输出列名
output (label, Col c) = do output (label, Col c) = do
k <- name "SELECT" c k <- name "SELECT" c
pure (if label == c then (k, Col k) else (label, Col k)) pure (if label == c then (k, Col k) else (label, Col k))
output (label, e) = do output (label, e) = do
e' <- resolveExpr db env outer (name "SELECT") e e' <- resolveExpr db env outer (name "SELECT") e
pure (label, e') pure (label, e')
projected <- if items == [("*", Col "*")] projected <-
then if null env && selectFrom q == FromUnit if items == [("*", Col "*")]
then Left "SELECT: * requires FROM" then
else Right [(physical c, Col (physical c)) | (c, _) <- env] if null env && selectFrom q == FromUnit
else mapM output items then Left "SELECT: * requires FROM"
else Right [(physical c, Col (physical c)) | (c, _) <- env]
else mapM output items
condition <- mapM (resolveExpr db env outer (name "WHERE")) (selectWhere q) condition <- mapM (resolveExpr db env outer (name "WHERE")) (selectWhere q)
grouping <- mapM (name "GROUP BY") (selectGroupBy q) grouping <- mapM (name "GROUP BY") (selectGroupBy q)
-- | 优先解析唯一投影别名,再查来源列 having <- mapM (resolveExpr db env outer (name "HAVING")) (selectHaving q)
let orderName c = case [label | (label, _) <- projected, label == c, qIsExpression] of -- | 整项名称可用输出别名,复合表达式只查来源
[] -> name "ORDER BY" c let orderKey key@(OrderColumn column)
[label] -> Right label | column `elem` map fst projected = key <$ orderExpression projected key
_ -> Left ("ORDER BY: ambiguous projection alias: " ++ c) | otherwise = OrderColumn <$> name "ORDER BY" column
qIsExpression = case q of SelectExpr{} -> True; _ -> False orderKey key@(OrderPosition _) = key <$ orderPosition (length projected) key
ordering <- mapM (\(c, d) -> (\k -> (k, d)) <$> orderName c) (selectOrderBy q) orderKey (OrderExpression expression) = OrderExpression <$> resolveExpr db env outer (name "ORDER BY") expression
pure $ case q of ordering <- mapM (\(key, direction) -> (, direction) <$> orderKey key) (selectOrderBy q)
Select{} -> Select (map fst projected) source condition grouping ordering (selectLimit q) pure (Select projected source condition grouping having ordering (selectLimit q))
_ -> SelectExpr projected source condition grouping ordering (selectLimit q)
-- | 收集没有别名遮蔽的来源表名 -- | 收集没有别名遮蔽的来源表名
sourceTableNames :: FromClause -> [String] sourceTableNames :: FromClause -> [String]
@@ -973,7 +1003,7 @@ qualifiedReferenceIn db source c = any (\table -> (table ++ ".") `isPrefixOf` c)
tables = sourceTableNames source ++ [key | table <- sourceTableNames source, Right (key, _) <- [resolveTable db table]] tables = sourceTableNames source ++ [key | table <- sourceTableNames source, Right (key, _) <- [resolveTable db table]]
-- | 单表不加限定名,其余来源交给 resolveFrom -- | 单表不加限定名,其余来源交给 resolveFrom
resolveSource :: Database -> [(String, Column)] -> FromClause -> Either String FromClause resolveSource :: Database -> EnclosingScopes -> FromClause -> Either String FromClause
resolveSource db outer fromC = case fromC of resolveSource db outer fromC = case fromC of
FromTable mAlias tbl -> do FromTable mAlias tbl -> do
(key, _) <- resolveTable db tbl (key, _) <- resolveTable db tbl
@@ -981,7 +1011,7 @@ resolveSource db outer fromC = case fromC of
other -> resolveFrom db outer other other -> resolveFrom db outer other
-- | 连接两侧与派生表都要先解析,再取环境解析 ON -- | 连接两侧与派生表都要先解析,再取环境解析 ON
resolveFrom :: Database -> [(String, Column)] -> FromClause -> Either String FromClause resolveFrom :: Database -> EnclosingScopes -> FromClause -> Either String FromClause
resolveFrom _ _ FromUnit = Right FromUnit resolveFrom _ _ FromUnit = Right FromUnit
resolveFrom db _ (FromTable alias tbl) = do resolveFrom db _ (FromTable alias tbl) = do
(key, _) <- resolveTable db tbl (key, _) <- resolveTable db tbl
@@ -994,31 +1024,20 @@ resolveFrom db outer (FromJoin kind left right cond) = do
l <- resolveFrom db outer left l <- resolveFrom db outer left
r <- resolveFrom db outer right r <- resolveFrom db outer right
env <- checkFrom db outer (FromJoin kind l r cond) env <- checkFrom db outer (FromJoin kind l r cond)
-- | 连接条件也拒绝不存在的库前缀 -- \| 连接条件也拒绝不存在的库前缀
let joinName column let joinName column
| length (filter (== '.') column) == 2, not (qualifiedReferenceIn db (FromJoin kind left right cond) column) = Left (missingColumn "ON" column env) | 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 c <- resolveExpr db env outer joinName cond
pure (FromJoin kind l r c) pure (FromJoin kind l r c)
-- | 派生表的输出列名:列取裸名,表达式保留原标签 -- | 派生表的输出列名:列取裸名,表达式保留原标签
nameDerivedColumns :: Statement -> Either String Statement nameDerivedColumns :: Statement -> Either String Statement
nameDerivedColumns q@Select { selectCols = cols, selectFrom = fromC } = do nameDerivedColumns (SelectDistinct q) = SelectDistinct <$> nameDerivedColumns q
let names = map lastTablePart cols nameDerivedColumns q@Select{selectItems = items} = do
checkDerivedNames names
Right
( SelectExpr
[(n, Col c) | (n, c) <- zip names cols]
fromC
(selectWhere q)
(selectGroupBy q)
(selectOrderBy q)
(selectLimit q)
)
nameDerivedColumns q@SelectExpr { selectItems = items } = do
let names = map derivedItemName items let names = map derivedItemName items
checkDerivedNames names checkDerivedNames names
Right q { selectItems = zip names (map snd items) } Right q{selectItems = zip names (map snd items)}
nameDerivedColumns _ = Left "FROM: subquery must be a SELECT" nameDerivedColumns _ = Left "FROM: subquery must be a SELECT"
-- | 派生表里一个投影项的输出名:没写别名的列取裸名 -- | 派生表里一个投影项的输出名:没写别名的列取裸名
@@ -1032,7 +1051,7 @@ derivedItemName (label, _) = label
checkDerivedNames :: [String] -> Either String () checkDerivedNames :: [String] -> Either String ()
checkDerivedNames = go [] checkDerivedNames = go []
where where
-- | 逐个查有没有见过 -- \| 逐个查有没有见过
go _ [] = Right () go _ [] = Right ()
go seen (n : ns) go seen (n : ns)
| n `elem` seen = Left ("FROM: duplicate column name in subquery: " ++ n) | n `elem` seen = Left ("FROM: duplicate column name in subquery: " ++ n)
@@ -13,15 +13,26 @@ data IndexResult
deriving (Show, Eq) deriving (Show, Eq)
class (Monad m) => MonadStorage m where 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 :: String -> m (Either String ())
createDatabase _ = pure (Left "database management is unavailable in this storage") createDatabase _ = pure (Left "database management is unavailable in this storage")
-- \| 删一个库 -- \| 删一个库
dropDatabase :: String -> m (Either String ()) dropDatabase :: String -> m (Either String ())
dropDatabase _ = pure (Left "database management is unavailable in this storage") dropDatabase _ = pure (Left "database management is unavailable in this storage")
-- \| 切当前库 -- \| 切当前库
useDatabase :: String -> m (Either String ()) useDatabase :: String -> m (Either String ())
useDatabase _ = pure (Left "database selection is unavailable in this storage") useDatabase _ = pure (Left "database selection is unavailable in this storage")
-- \| 列出现有库 -- \| 列出现有库
listDatabases :: m (Either String [String]) listDatabases :: m (Either String [String])
listDatabases = pure (Right []) listDatabases = pure (Right [])
@@ -41,7 +52,7 @@ class (Monad m) => MonadStorage m where
-- \| 按分片并行扫描并按分片序拼接;默认退回顺序扫描 -- \| 按分片并行扫描并按分片序拼接;默认退回顺序扫描
scanShards :: Int -> String -> Maybe [String] -> m (Either String [Row]) 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 ()) insert :: String -> Row -> m (Either String ())
@@ -50,7 +61,7 @@ class (Monad m) => MonadStorage m where
insertMany :: String -> [Row] -> m (Either String ()) insertMany :: String -> [Row] -> m (Either String ())
insertMany t = go insertMany t = go
where where
-- | 逐行插入,出错就停 -- \| 逐行插入,出错就停
go [] = pure (Right ()) go [] = pure (Right ())
go (r : rs) = do go (r : rs) = do
x <- insert t r x <- insert t r
@@ -66,7 +77,7 @@ class (Monad m) => MonadStorage m where
Left e -> pure (Left e) Left e -> pure (Left e)
Right rs -> replaceAll t [r | r <- rs, not (doomed r)] Right rs -> replaceAll t [r | r <- rs, not (doomed r)]
where where
-- | 这一行要不要删 -- \| 这一行要不要删
doomed r = case lookup "id" r of doomed r = case lookup "id" r of
Just (VInt k) -> k `elem` ks Just (VInt k) -> k `elem` ks
_ -> False _ -> False
@@ -108,11 +119,11 @@ class (Monad m) => MonadStorage m where
replaceSchema :: String -> [(String, Column)] -> [Row] -> m (Either String ()) replaceSchema :: String -> [(String, Column)] -> [Row] -> m (Either String ())
-- \| 取全库快照(表名 + 列 + 全部行) -- \| 取全库快照(表名 + 列 + 全部行)
snapshot :: m Database snapshot :: m (Either String Database)
-- \| 取全库结构:只要表名和列,不要行 -- \| 取全库结构:只要表名和列,不要行
schema :: m Database schema :: m (Either String Database)
schema = fmap (map withoutRows) snapshot schema = fmap (fmap (map withoutRows)) snapshot
where where
-- | 表定义去掉所有行 -- \| 表定义去掉所有行
withoutRows (name, t) = (name, t {tableRows = []}) withoutRows (name, t) = (name, t{tableRows = []})
@@ -10,7 +10,8 @@ module ChuSQL.Core.Engine.Storage.FFI (
maintainStorage, maintainStorage,
) where ) where
import Control.Exception (SomeException, try) import Control.Concurrent (rtsSupportsBoundThreads, runInBoundThread)
import Control.Exception (SomeException, finally, mask_, try)
import Data.ByteString qualified as BS import Data.ByteString qualified as BS
import Data.Text qualified as T import Data.Text qualified as T
import Data.Text.Encoding qualified as TE import Data.Text.Encoding qualified as TE
@@ -19,6 +20,7 @@ import Foreign
import Foreign.C import Foreign.C
-- Rust 存储库 cdylib 的 C ABI 绑定(ffi.rs),收发单行 JSON。 -- Rust 存储库 cdylib 的 C ABI 绑定(ffi.rs),收发单行 JSON。
-- 错误读取绑定同一 OS 线程;响应复制期间屏蔽取消并归还缓冲。
-- | 存储实例句柄(Rust 侧的 *mut Storage) -- | 存储实例句柄(Rust 侧的 *mut Storage)
newtype StorageHandle = StorageHandle (Ptr ()) newtype StorageHandle = StorageHandle (Ptr ())
@@ -46,15 +48,8 @@ foreign import ccall safe "chusql_storage_maintenance"
-- | 离线修复系统目录并返回结果 -- | 离线修复系统目录并返回结果
maintainStorage :: FilePath -> BS.ByteString -> IO (Either String BS.ByteString) maintainStorage :: FilePath -> BS.ByteString -> IO (Either String BS.ByteString)
maintainStorage path payload = withCString path $ \config -> maintainStorage path payload = BS.useAsCString (TE.encodeUtf8 (T.pack path)) $ \config ->
BS.useAsCStringLen payload $ \(input, size) -> alloca $ \outRef -> alloca $ \lenRef -> do callStorage (cStorageMaintenance config) payload
code <- cStorageMaintenance config input (fromIntegral size) outRef lenRef
if code /= 0 then Left <$> lastError else do
output <- peek outRef
len <- peek lenRef
bytes <- BS.packCStringLen (output, fromIntegral len)
cStorageFree output len
pure (Right bytes)
-- | 库版本(Rust 侧的 CARGO_PKG_VERSION) -- | 库版本(Rust 侧的 CARGO_PKG_VERSION)
storageVersion :: IO String storageVersion :: IO String
@@ -62,7 +57,7 @@ storageVersion = cStorageVersion >>= peekCString
-- | 打开存储实例,失败给错误文本 -- | 打开存储实例,失败给错误文本
openStorage :: Maybe FilePath -> IO (Either String StorageHandle) openStorage :: Maybe FilePath -> IO (Either String StorageHandle)
openStorage path = do openStorage path = onStorageThread $ mask_ $ do
result <- try (withCStringOrNull path cStorageOpen) :: IO (Either SomeException (Ptr ())) result <- try (withCStringOrNull path cStorageOpen) :: IO (Either SomeException (Ptr ()))
case result of case result of
Left e -> pure (Left ("storage library call failed: " ++ show e)) Left e -> pure (Left ("storage library call failed: " ++ show e))
@@ -70,9 +65,9 @@ openStorage path = do
| ptr == nullPtr -> Left <$> lastError | ptr == nullPtr -> Left <$> lastError
| otherwise -> pure (Right (StorageHandle ptr)) | otherwise -> pure (Right (StorageHandle ptr))
where where
-- | 没有路径就传空指针,否则转成 C 字符串 -- \| 没有路径就传空指针,否则转成 C 字符串
withCStringOrNull Nothing f = f nullPtr withCStringOrNull Nothing f = f nullPtr
withCStringOrNull (Just s) f = withCString s f withCStringOrNull (Just s) f = BS.useAsCString (TE.encodeUtf8 (T.pack s)) f
-- | 关掉存储实例 -- | 关掉存储实例
closeStorage :: StorageHandle -> IO () closeStorage :: StorageHandle -> IO ()
@@ -80,20 +75,32 @@ closeStorage (StorageHandle handle) = cStorageClose handle
-- | 一条 JSON 请求换一条 JSON 响应 -- | 一条 JSON 请求换一条 JSON 响应
storageRequest :: StorageHandle -> BS.ByteString -> IO (Either String BS.ByteString) storageRequest :: StorageHandle -> BS.ByteString -> IO (Either String BS.ByteString)
storageRequest (StorageHandle handle) payload = storageRequest (StorageHandle handle) = callStorage (cStorageRequest handle)
BS.useAsCStringLen payload $ \(inPtr, inLen) ->
alloca $ \outPtrRef -> -- | 调用存储并复制和归还响应缓冲
alloca $ \outLenRef -> do callStorage ::
code <- cStorageRequest handle (castPtr inPtr) (fromIntegral inLen) outPtrRef outLenRef (Ptr CChar -> CSize -> Ptr (Ptr CChar) -> Ptr CSize -> IO CInt) ->
BS.ByteString ->
IO (Either String BS.ByteString)
callStorage call payload = onStorageThread $
mask_ $
BS.useAsCStringLen payload $ \(input, size) ->
alloca $ \outRef -> alloca $ \lenRef -> do
code <- call input (fromIntegral size) outRef lenRef
if code /= 0 if code /= 0
then Left <$> lastError then Left <$> lastError
else do else do
outPtr <- peek outPtrRef output <- peek outRef
outLen <- peek outLenRef len <- peek lenRef
bytes <- BS.packCStringLen (castPtr outPtr, fromIntegral outLen) bytes <-
cStorageFree outPtr outLen BS.packCStringLen (output, fromIntegral len)
`finally` cStorageFree output len
pure (Right bytes) pure (Right bytes)
-- | 多线程运行时绑定存储调用线程
onStorageThread :: IO a -> IO a
onStorageThread = if rtsSupportsBoundThreads then runInBoundThread else id
-- | 当前线程最近一次失败的文本 -- | 当前线程最近一次失败的文本
lastError :: IO String lastError :: IO String
lastError = alloca $ \lenRef -> do lastError = alloca $ \lenRef -> do
@@ -1,3 +1,4 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
@@ -30,14 +31,19 @@ module ChuSQL.Core.Engine.Storage.IPC (
doListCatalog, doListCatalog,
) where ) where
import ChuSQL.Core.Model import Data.Foldable (for_)
import ChuSQL.Core.Protocol (Account (..), Request (..), Response (..), SchemaColumn (..), TableInfo (..)) import Control.Monad (when)
import ChuSQL.Core.Engine.Parallel (parallelShardLimit, poolRun, workerPool) import ChuSQL.Core.Engine.Parallel (parallelShardLimit, poolRun, workerPool)
import ChuSQL.Core.Engine.Storage import ChuSQL.Core.Engine.Storage
import ChuSQL.Core.Engine.Storage.FFI (closeStorage, openStorage, storageRequest) import ChuSQL.Core.Engine.Storage.FFI (closeStorage, openStorage, storageRequest)
import ChuSQL.Core.Model
import ChuSQL.Core.Protocol (Account (..), Request (..), Response (..), SchemaColumn (..), TableInfo (..))
import Control.Concurrent (getNumCapabilities) import Control.Concurrent (getNumCapabilities)
import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar) import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, putMVar, readMVar, takeMVar, withMVar)
import Control.Exception (bracket, mask_)
import Data.Aeson (eitherDecodeStrict, encode) import Data.Aeson (eitherDecodeStrict, encode)
import Data.Aeson qualified as A
import Data.Aeson.KeyMap qualified as KM
import Data.ByteString qualified as BS import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL import Data.ByteString.Lazy qualified as BL
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
@@ -48,6 +54,7 @@ import System.IO.Unsafe (unsafePerformIO)
-- | 一条会话的存储环境:当前库名随会话走,不共享 -- | 一条会话的存储环境:当前库名随会话走,不共享
data Env = Env data Env = Env
{ envDatabase :: Maybe String { envDatabase :: Maybe String
, envSchemaGuard :: Maybe Database
} }
newtype IPCStorage a = IPCStorage newtype IPCStorage a = IPCStorage
@@ -56,11 +63,11 @@ newtype IPCStorage a = IPCStorage
-- | 按库名造一个会话环境 -- | 按库名造一个会话环境
envForDatabase :: Maybe String -> Env envForDatabase :: Maybe String -> Env
envForDatabase = Env envForDatabase name = Env name Nothing
-- | 进程默认环境:读全局库名,给测试与 CLI 用 -- | 进程默认环境:读全局库名,给测试与 CLI 用
defaultEnv :: IO Env defaultEnv :: IO Env
defaultEnv = Env <$> readMVar databaseRef defaultEnv = envForDatabase <$> readMVar databaseRef
-- | 用进程默认环境跑(兼容既有调用点) -- | 用进程默认环境跑(兼容既有调用点)
runIPCStorage :: IPCStorage a -> IO a runIPCStorage :: IPCStorage a -> IO a
@@ -85,19 +92,45 @@ data StorageLink = StorageLink
} }
{-# NOINLINE linkRef #-} {-# NOINLINE linkRef #-}
-- | 进程全局的存储链路 -- | 进程全局的存储链路
linkRef :: MVar (Maybe StorageLink) linkRef :: MVar (Maybe StorageLink)
linkRef = unsafePerformIO (newMVar Nothing) linkRef = unsafePerformIO (newMVar Nothing)
{-# NOINLINE linkUsers #-}
-- | 在途请求计数与空闲信号
linkUsers :: (MVar Int, MVar ())
linkUsers = unsafePerformIO $ (,) <$> newMVar 0 <*> newMVar ()
-- | 登记请求并在结束时释放链路占用
withStorageLink :: (Maybe StorageLink -> IO a) -> IO a
withStorageLink = bracket enter leave
where
(users, idle) = linkUsers
-- \| 登记当前链路的在途请求
enter = withMVar linkRef $ \current -> do
case current of
Nothing -> pure ()
Just _ -> modifyMVar_ users $ \count -> do
when (count == 0) $ takeMVar idle
pure (count + 1)
pure current
-- \| 最后一个请求结束后发出空闲信号
leave Nothing = pure ()
leave (Just _) = mask_ $ modifyMVar_ users $ \count -> do
when (count == 1) $ putMVar idle ()
pure (count - 1)
-- | 装入一条链路;一个进程只装一次 -- | 装入一条链路;一个进程只装一次
setStorageLink :: StorageLink -> IO () setStorageLink :: StorageLink -> IO ()
setStorageLink link = modifyMVar_ linkRef (const (pure (Just link))) setStorageLink link = modifyMVar_ linkRef $ \_ -> withMVar (snd linkUsers) (const (pure (Just link)))
-- | 打开本地的存储动态库,得到一条链路 -- | 打开本地的存储动态库,得到一条链路
localStorageLink :: Maybe FilePath -> IO (Either String StorageLink) localStorageLink :: Maybe FilePath -> IO (Either String StorageLink)
localStorageLink path = fmap (fmap toLink) (openStorage path) localStorageLink path = fmap (fmap toLink) (openStorage path)
where where
-- | 把句柄包成一条链路 -- \| 把句柄包成一条链路
toLink handle = toLink handle =
StorageLink StorageLink
{ slRequest = storageRequest handle { slRequest = storageRequest handle
@@ -106,35 +139,32 @@ localStorageLink path = fmap (fmap toLink) (openStorage path)
-- | 关掉当前链路(进程退出前调用);没有链路就什么都不做 -- | 关掉当前链路(进程退出前调用);没有链路就什么都不做
closeConnection :: IO () closeConnection :: IO ()
closeConnection = modifyMVar_ linkRef $ \current -> do closeConnection = modifyMVar_ linkRef $ \current -> withMVar (snd linkUsers) $ \_ -> do
case current of for_ current slClose
Nothing -> pure ()
Just link -> slClose link
pure Nothing pure Nothing
-- | 发一条请求并解码应答;链路没装就报错,不崩 -- | 发一条请求并解码应答;链路没装就报错,不崩
sendRequest :: Request -> IO Response sendRequest :: Request -> IO Response
sendRequest req = do sendRequest req = withStorageLink $ \case
current <- readMVar linkRef Nothing -> pure (RespError "storage not configured")
case current of Just link
Nothing -> pure (RespError "storage not configured") -> do raw <- slRequest link (BL.toStrict (encode req))
Just link -> do case raw of
raw <- slRequest link (BL.toStrict (encode req)) Left e -> pure (RespError ("storage error: " ++ e))
case raw of Right bytes
Left e -> pure (RespError ("storage error: " ++ e)) -> case eitherDecodeStrict (BS.dropWhileEnd (== 13) bytes) of
Right bytes -> case eitherDecodeStrict (BS.dropWhileEnd (== 13) bytes) of Left e -> pure (RespError ("decode error: " ++ e))
Left e -> pure (RespError ("decode error: " ++ e)) Right resp -> pure resp
Right resp -> pure resp
-- | 原样转发一条载荷给存储库 -- | 原样转发一条载荷给存储库
sendRawRequest :: BS.ByteString -> IO (Either String BS.ByteString) sendRawRequest :: BS.ByteString -> IO (Either String BS.ByteString)
sendRawRequest payload = do sendRawRequest payload = withStorageLink $ \current -> do
current <- readMVar linkRef
case current of case current of
Nothing -> pure (Left "storage not configured") Nothing -> pure (Left "storage not configured")
Just link -> slRequest link payload Just link -> slRequest link payload
{-# NOINLINE databaseRef #-} {-# NOINLINE databaseRef #-}
-- | 进程全局的当前库名 -- | 进程全局的当前库名
databaseRef :: MVar (Maybe String) databaseRef :: MVar (Maybe String)
databaseRef = unsafePerformIO (newMVar Nothing) databaseRef = unsafePerformIO (newMVar Nothing)
@@ -147,7 +177,6 @@ setDatabaseName name = modifyMVar_ databaseRef (const (pure name))
getDatabaseName :: IO (Maybe String) getDatabaseName :: IO (Maybe String)
getDatabaseName = readMVar databaseRef getDatabaseName = readMVar databaseRef
-- | 给语句类请求盖上当前库名 -- | 给语句类请求盖上当前库名
stampDatabase :: Maybe String -> Request -> Request stampDatabase :: Maybe String -> Request -> Request
stampDatabase Nothing req = req stampDatabase Nothing req = req
@@ -170,13 +199,43 @@ globalRequest _ = False
-- | 发请求并把响应翻成 Either -- | 发请求并把响应翻成 Either
ask :: Env -> String -> Request -> (Response -> Maybe a) -> IO (Either String a) ask :: Env -> String -> Request -> (Response -> Maybe a) -> IO (Either String a)
ask env what req recognize = do ask env what req recognize = do
resp <- sendRequest (stampDatabase (envDatabase env) req) resp <- case envSchemaGuard env of
Nothing -> sendRequest (stampDatabase (envDatabase env) req)
Just dependencies -> guardedRequest env dependencies req
pure $ case resp of pure $ case resp of
RespError e -> Left e RespError e -> Left e
other -> case recognize other of other -> case recognize other of
Just a -> Right a Just a -> Right a
Nothing -> Left ("unexpected response to " ++ what) Nothing -> Left ("unexpected response to " ++ what)
-- | 发送依赖守卫并要求存储确认执行
guardedRequest :: Env -> Database -> Request -> IO Response
guardedRequest env dependencies req = do
let payload = case A.toJSON (stampDatabase (envDatabase env) req) of
A.Object fields -> A.Object (KM.insert "schema_guard" (A.toJSON (map guardOf dependencies)) fields)
other -> other
result <- sendRawRequest (BL.toStrict (encode payload))
pure $ case result >>= eitherDecodeStrict of
Left err -> RespError err
Right (A.Object fields)
| KM.lookup "status" fields == Just (A.String "guarded")
, Just response <- KM.lookup "response" fields -> case A.fromJSON response of
A.Success decoded -> decoded
A.Error err -> RespError ("decode error: " ++ err)
Right value -> case A.fromJSON value of
A.Success (RespError err) -> RespError err
_ -> RespError "storage did not confirm bound schema guard"
where
-- \| 编码依赖身份、版本与完整列定义
guardOf (name, table) =
A.object
[ "table" A..= name
, "database_id" A..= fmap (\(TableIdentity database _) -> show database) (tableIdentity table)
, "object_id" A..= fmap (\(TableIdentity _ object) -> show object) (tableIdentity table)
, "schema_version" A..= fmap show (tableSchemaVersion table)
, "columns" A..= map toWire (tableCols table)
]
-- | 只认"成了"(多数写操作都这样) -- | 只认"成了"(多数写操作都这样)
okOnly :: Response -> Maybe () okOnly :: Response -> Maybe ()
okOnly RespOk = Just () okOnly RespOk = Just ()
@@ -184,21 +243,23 @@ okOnly _ = Nothing
-- | 发 Scan -- | 发 Scan
doScan :: Env -> String -> IO (Either String [Row]) 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 RespRows rows -> Just rows
_ -> Nothing _ -> Nothing
-- | 发带投影的 Scan -- | 发带投影的 Scan
doScanColumns :: Env -> String -> [String] -> IO (Either String [Row]) doScanColumns :: Env -> String -> [String] -> IO (Either String [Row])
doScanColumns env t cols = ask env "scan" (ReqScanColumns t cols) $ \resp -> case resp of 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] RespRows rows
_ -> Nothing -> Just
[[(c, v) | c <- cols, Just v <- [lookup c row]] | row <- rows]
_ -> Nothing
-- | 发分片 Scan:只取第 shard 片 -- | 发分片 Scan:只取第 shard 片
doScanShard :: Env -> String -> Maybe [String] -> Int -> Int -> IO (Either String [Row]) 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 RespRows rows -> Just rows
_ -> Nothing _ -> Nothing
-- | 发 Insert(索引由存储层维护) -- | 发 Insert(索引由存储层维护)
doInsert :: Env -> String -> Row -> IO (Either String ()) doInsert :: Env -> String -> Row -> IO (Either String ())
@@ -212,28 +273,24 @@ doInsertMany env t rs = ask env "insert_batch" (ReqInsertBatch t rs) okOnly
doDeleteKeys :: Env -> String -> [Int] -> IO (Either String ()) doDeleteKeys :: Env -> String -> [Int] -> IO (Either String ())
doDeleteKeys env t ks = ask env "delete_keys" (ReqDeleteKeys t ks) okOnly doDeleteKeys env t ks = ask env "delete_keys" (ReqDeleteKeys t ks) okOnly
-- | 发 ReplaceAll
doReplaceAll :: Env -> String -> [Row] -> IO (Either String ())
doReplaceAll env t rs = ask env "replace_all" (ReqReplaceAll t rs) okOnly
-- | 发 ListTables -- | 发 ListTables
doListTables :: Env -> IO (Either String [String]) 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 RespTables ts -> Just ts
_ -> Nothing _ -> Nothing
-- | 一次拿全库 schema -- | 一次拿全库 schema
doListCatalog :: Env -> IO (Either String [TableInfo]) 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 RespCatalog xs -> Just xs
_ -> Nothing _ -> Nothing
-- | 按某一列的索引取一行(键可以是整数或字符串) -- | 按某一列的索引取一行(键可以是整数或字符串)
doLookupByColumn :: Env -> String -> String -> Value -> IO (Either String IndexResult) 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) RespRows rows -> Just (IndexRows rows)
RespNoIndex -> Just NoIndex RespNoIndex -> Just NoIndex
_ -> Nothing _ -> Nothing
-- | 范围扫描:没有可用索引就回 Nothing,让上层退回扫描 -- | 范围扫描:没有可用索引就回 Nothing,让上层退回扫描
doScanRange :: doScanRange ::
@@ -243,36 +300,16 @@ doScanRange ::
Maybe (Value, Bool) -> Maybe (Value, Bool) ->
Maybe (Value, Bool) -> Maybe (Value, Bool) ->
IO (Either String (Maybe [Row])) 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) RespRows rows -> Just (Just rows)
RespNoIndex -> Just Nothing RespNoIndex -> Just Nothing
_ -> Nothing _ -> Nothing
-- | 发 DescribeTable -- | 发 DescribeTable
doDescribeTable :: Env -> String -> IO (Either String TableInfo) 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 RespSchema info -> Just info
_ -> Nothing _ -> Nothing
-- | 给某一列建索引
doCreateIndex :: Env -> String -> String -> IO (Either String ())
doCreateIndex env t c = ask env "create_index" (ReqCreateIndex t c) okOnly
-- | 去掉某一列的索引
doDropIndex :: Env -> String -> String -> IO (Either String ())
doDropIndex env t c = ask env "drop_index" (ReqDropIndex t c) okOnly
-- | 删一列(列定义、这一列上的索引、每行里的那一格一起没)
doDropColumn :: Env -> String -> String -> IO (Either String ())
doDropColumn env t c = ask env "drop_column" (ReqDropColumn t c) okOnly
-- | 发 ReplaceSchema(ALTER 用)
doReplaceSchema :: Env -> String -> [SchemaColumn] -> [Row] -> IO (Either String ())
doReplaceSchema env t cols rs = ask env "replace_schema" (ReqReplaceSchema t cols rs) okOnly
-- | 发 CreateTable
doCreateTable :: Env -> String -> [SchemaColumn] -> IO (Either String ())
doCreateTable env t cols = ask env "create_table" (ReqCreateTable t cols) okOnly
-- | 发 DropTable -- | 发 DropTable
doDropTable :: Env -> String -> IO (Either String ()) doDropTable :: Env -> String -> IO (Either String ())
@@ -312,25 +349,42 @@ toWire (n, c) =
} }
instance MonadStorage IPCStorage where 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 createDatabase name = IPCStorage $ \env -> ask env "create_database" (ReqDatabase "create_database" name) okOnly
-- \| 删一个库 -- \| 删一个库
dropDatabase name = IPCStorage $ \env -> ask env "drop_database" (ReqDatabase "drop_database" name) okOnly dropDatabase name = IPCStorage $ \env -> ask env "drop_database" (ReqDatabase "drop_database" name) okOnly
-- \| 切当前库 -- \| 切当前库
useDatabase name = IPCStorage $ \env -> ask env "use_database" (ReqDatabase "use_database" name) okOnly 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 RespTables names -> Just names
_ -> Nothing _ -> Nothing
-- \| 发 Scan -- \| 发 Scan
scan t = IPCStorage (\env -> doScan env t) scan t = IPCStorage (`doScan` t)
-- \| 只取指定列 -- \| 只取指定列
scanColumns t cols = IPCStorage (\env -> doScanColumns env t cols) scanColumns t cols = IPCStorage (\env -> doScanColumns env t cols)
-- \| 并行分片数:按 RTS 能力数,封顶在 parallelShardLimit -- \| 并行分片数:按 RTS 能力数,封顶在 parallelShardLimit
parallelShards = IPCStorage $ \_ -> do parallelShards = IPCStorage $ \_ -> do max 1 . min parallelShardLimit <$> getNumCapabilities
caps <- getNumCapabilities
pure (max 1 (min parallelShardLimit caps))
-- \| 分片并行扫,再按分片序拼接 -- \| 分片并行扫,再按分片序拼接
scanShards width t cols scanShards width t cols
@@ -350,7 +404,7 @@ instance MonadStorage IPCStorage where
deleteKeys t ks = IPCStorage (\env -> doDeleteKeys env t ks) deleteKeys t ks = IPCStorage (\env -> doDeleteKeys env t ks)
-- \| 发 ReplaceAll -- \| 发 ReplaceAll
replaceAll t rs = IPCStorage (\env -> doReplaceAll env t rs) replaceAll t rs = IPCStorage $ \env -> ask env "replace_all" (ReqReplaceAll t rs) okOnly
-- \| 按某一列的索引取一行(没有索引就回 NoIndex) -- \| 按某一列的索引取一行(没有索引就回 NoIndex)
lookupByColumn t c k = IPCStorage (\env -> doLookupByColumn env t c k) lookupByColumn t c k = IPCStorage (\env -> doLookupByColumn env t c k)
@@ -359,45 +413,48 @@ instance MonadStorage IPCStorage where
scanRange t c lo hi = IPCStorage (\env -> doScanRange env t c lo hi) scanRange t c lo hi = IPCStorage (\env -> doScanRange env t c lo hi)
-- \| 发 CreateTable -- \| 发 CreateTable
createTable name cols = IPCStorage (\env -> doCreateTable env name (map toWire cols)) createTable name cols = IPCStorage $ \env -> ask env "create_table" (ReqCreateTable name (map toWire cols)) okOnly
-- \| ALTER:整表换列定义与全部行 -- \| ALTER:整表换列定义与全部行
replaceSchema name cols rows = IPCStorage (\env -> doReplaceSchema env name (map toWire cols) rows) replaceSchema name cols rows = IPCStorage $ \env -> ask env "replace_schema" (ReqReplaceSchema name (map toWire cols) rows) okOnly
-- \| 发 DropTable -- \| 发 DropTable
dropTable name = IPCStorage (\env -> doDropTable env name) dropTable name = IPCStorage (`doDropTable` name)
-- \| 建索引 -- \| 建索引
createIndex t c = IPCStorage (\env -> doCreateIndex env t c) createIndex t c = IPCStorage $ \env -> ask env "create_index" (ReqCreateIndex t c) okOnly
-- \| 删索引 -- \| 删索引
dropIndex t c = IPCStorage (\env -> doDropIndex env t c) dropIndex t c = IPCStorage $ \env -> ask env "drop_index" (ReqDropIndex t c) okOnly
-- \| 删一列 -- \| 删一列
dropColumn t c = IPCStorage (\env -> doDropColumn env t c) dropColumn t c = IPCStorage $ \env -> ask env "drop_column" (ReqDropColumn t c) okOnly
-- \| 列表 + 逐表扫描拼库 -- \| 列表 + 逐表扫描拼库
snapshot = IPCStorage $ \env -> do snapshot = IPCStorage $ \env -> do
result <- doListCatalog env result <- doListCatalog env
case result of case result of
Left _ -> pure [] Left err -> pure (Left err)
Right xs -> mapM (loadEntry env) xs Right xs -> fmap sequence (mapM (loadEntry env) xs)
where where
-- \| 读取表数据并保留扫描错误
loadEntry env info = do loadEntry env info = do
rows <- doScan env (tiTable info) rows <- doScan env (tiTable info)
pure pure $
( tiTable info fmap
, Table (tiTable info) (schemaToColumns (tiColumns info)) (either (const []) id rows) (Just (metaOf info)) ( \rs ->
) ( tiTable info
, Table (tiTable info) (schemaToColumns (tiColumns info)) rs (Just (metaOf info)) (tiIdentity info) (tiSchemaVersion info)
)
)
rows
-- \| 只问数据字典要结构,设了当前库只留它的表 -- \| 只问数据字典要结构,设了当前库只留它的表
schema = IPCStorage $ \env -> do 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 RespCatalog infos -> Just infos
_ -> Nothing _ -> Nothing
pure $ case result of pure (fmap (concatMap (visibleTables (envDatabase env))) result)
Left _ -> []
Right xs -> concatMap (visibleTables (envDatabase env)) xs
-- | 线上表信息转引擎侧统计 -- | 线上表信息转引擎侧统计
metaOf :: TableInfo -> TableMeta metaOf :: TableInfo -> TableMeta
@@ -407,11 +464,9 @@ metaOf info = TableMeta (tiRows info) (tiStats info) (tiHistograms info) (tiInde
visibleTables :: Maybe String -> TableInfo -> [(String, Table)] visibleTables :: Maybe String -> TableInfo -> [(String, Table)]
visibleTables current info visibleTables current info
| Just db <- current = | Just db <- current =
if unqualify (Just db) (tiTable info) /= tiTable info [bare named | unqualify (Just db) (tiTable info) /= tiTable info]
then [bare named]
else []
| otherwise = [bare info] | otherwise = [bare info]
where where
named = info {tiTable = unqualify current (tiTable info)} named = info{tiTable = unqualify current (tiTable info)}
-- | 组装成不带行的表 -- \| 组装成不带行的表
bare i = (tiTable i, Table (tiTable i) (schemaToColumns (tiColumns i)) [] (Just (metaOf i))) bare i = (tiTable i, Table (tiTable i) (schemaToColumns (tiColumns i)) [] (Just (metaOf i)) (tiIdentity i) (tiSchemaVersion i))
@@ -1,8 +1,9 @@
module ChuSQL.Core.Engine.Storage.Memory (MemoryStorage (runMemoryStorage)) where module ChuSQL.Core.Engine.Storage.Memory (MemoryStorage (runMemoryStorage)) where
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Storage import ChuSQL.Core.Engine.Storage
import qualified Data.HashSet as HS import ChuSQL.Core.Model
import Data.HashSet qualified as HS
import Data.Word (Word64)
-- 内存实现:Database 上的状态,错误通道是 Either String。 -- 内存实现:Database 上的状态,错误通道是 Either String。
@@ -26,6 +27,12 @@ instance Monad MemoryStorage where
runMemoryStorage (k a) db' runMemoryStorage (k a) db'
instance MonadStorage MemoryStorage where instance MonadStorage MemoryStorage where
-- \| 纯状态视图在求值期间不受外部修改
withSchemaGuard _ action = action
-- | 纯状态写入不受外部结构变更影响
withWriteSchemaGuard _ action = action
-- \| 全表扫描 -- \| 全表扫描
scan t = MemoryStorage $ \db -> do scan t = MemoryStorage $ \db -> do
tbl <- lookupTable db t tbl <- lookupTable db t
@@ -45,7 +52,7 @@ instance MonadStorage MemoryStorage where
createTable name cols = MemoryStorage $ \db -> createTable name cols = MemoryStorage $ \db ->
if any ((== name) . fst) db if any ((== name) . fst) db
then Right (Left ("table already exists: " ++ name), db) then Right (Left ("table already exists: " ++ name), db)
else Right (Right (), db ++ [(name, Table name cols [] Nothing)]) else Right (Right (), db ++ [(name, Table name cols [] Nothing Nothing (Just 1))])
-- \| 删表;不存在报错 -- \| 删表;不存在报错
dropTable name = MemoryStorage $ \db -> dropTable name = MemoryStorage $ \db ->
@@ -60,7 +67,8 @@ instance MonadStorage MemoryStorage where
Just tbl -> Just tbl ->
if col `notElem` map fst (tableCols tbl) if col `notElem` map fst (tableCols tbl)
then Right (Left ("unknown column: " ++ col), db) then Right (Left ("unknown column: " ++ col), db)
else else do
version <- nextSchemaVersion tbl
Right Right
( Right () ( Right ()
, replaceTable , replaceTable
@@ -68,19 +76,20 @@ instance MonadStorage MemoryStorage where
tbl tbl
{ tableCols = filter ((/= col) . fst) (tableCols tbl) { tableCols = filter ((/= col) . fst) (tableCols tbl)
, tableRows = map (filter ((/= col) . fst)) (tableRows tbl) , tableRows = map (filter ((/= col) . fst)) (tableRows tbl)
, tableSchemaVersion = Just version
} }
db db
) )
-- \| 原样返回当前库 -- \| 原样返回当前库
snapshot = MemoryStorage $ \db -> Right (db, db) snapshot = MemoryStorage $ \db -> Right (Right db, db)
-- \| 返回实时行数与去重统计的无数据结构 -- \| 返回实时行数与去重统计的无数据结构
schema = MemoryStorage $ \db -> Right (map describe db, db) schema = MemoryStorage $ \db -> Right (Right (map describe db), db)
where where
-- | 将存储数据汇总为结构统计 -- \| 将存储数据汇总为结构统计
describe (name, table) = describe (name, table) =
(name, table {tableRows = [], tableMeta = Just metadata}) (name, table{tableRows = [], tableMeta = Just metadata})
where where
metadata = TableMeta (length (tableRows table)) distinct [] [] metadata = TableMeta (length (tableRows table)) distinct [] []
distinct = [columnStatistics column (tableRows table) | (column, _) <- tableCols table] distinct = [columnStatistics column (tableRows table) | (column, _) <- tableCols table]
@@ -88,13 +97,25 @@ instance MonadStorage MemoryStorage where
-- \| 改表结构:列定义与行一起换 -- \| 改表结构:列定义与行一起换
replaceSchema name cols rows = MemoryStorage $ \db -> case lookup name db of replaceSchema name cols rows = MemoryStorage $ \db -> case lookup name db of
Nothing -> Right (Left ("unknown table: " ++ name), db) Nothing -> Right (Left ("unknown table: " ++ name), db)
Just tbl -> Right (Right (), replaceTable name tbl{tableCols = cols, tableRows = rows} db) Just tbl -> do
version <-
if tableCols tbl == cols
then Right (tableSchemaVersion tbl)
else Just <$> nextSchemaVersion tbl
Right (Right (), replaceTable name tbl{tableCols = cols, tableRows = rows, tableSchemaVersion = version} db)
-- | 递增结构版本并拒绝耗尽
nextSchemaVersion :: Table -> Either String Word64
nextSchemaVersion table = case tableSchemaVersion table of
Just version | version == maxBound -> Left "catalog schema version exhausted"
Just version -> Right (version + 1)
Nothing -> Right 1
-- | 对列值去重并限制统计内存 -- | 对列值去重并限制统计内存
columnStatistics :: String -> [Row] -> (String, Int, Bool) columnStatistics :: String -> [Row] -> (String, Int, Bool)
columnStatistics column rows = go rows HS.empty columnStatistics column rows = go rows HS.empty
where where
-- | 累积规范化值,达到上限后停止 -- \| 累积规范化值,达到上限后停止
go remaining values go remaining values
| HS.size values >= 4096 = (column, 4096, True) | HS.size values >= 4096 = (column, 4096, True)
| otherwise = case remaining of | otherwise = case remaining of
@@ -105,4 +126,3 @@ columnStatistics column rows = go rows HS.empty
replaceTable :: String -> Table -> Database -> Database replaceTable :: String -> Table -> Database -> Database
replaceTable name table = replaceTable name table =
map (\(n, t) -> if n == name then (n, table) else (n, t)) map (\(n, t) -> if n == name then (n, table) else (n, t))
@@ -1,4 +1,4 @@
module ChuSQL.Core.Engine.Syntax.AST (Statement (..), FromClause (..), JoinKind (..), Expr (..), Subquery (..), Quantifier (..), CompareOp (..), SortDir (..), makeSelect) 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.Model (Column (..), ColumnType, Value (..))
import ChuSQL.Core.Engine.Runtime.Types (TypeId, TypeExpr, RuntimeValue) import ChuSQL.Core.Engine.Runtime.Types (TypeId, TypeExpr, RuntimeValue)
@@ -8,21 +8,16 @@ import ChuSQL.Core.Engine.Runtime.Functions (FunctionId)
data Statement data Statement
= Select = Select
{ selectCols :: [String] -- | 输出名称与投影表达式,普通列用 Col
, selectFrom :: FromClause
, selectWhere :: Maybe Expr
, selectGroupBy :: [String]
, selectOrderBy :: [(String, SortDir)]
, selectLimit :: Maybe Int
}
| SelectExpr
{ selectItems :: [(String, Expr)] { selectItems :: [(String, Expr)]
, selectFrom :: FromClause , selectFrom :: FromClause
, selectWhere :: Maybe Expr , selectWhere :: Maybe Expr
, selectGroupBy :: [String] , selectGroupBy :: [String]
, selectOrderBy :: [(String, SortDir)] , selectHaving :: Maybe Expr
, selectOrderBy :: [(OrderKey, SortDir)]
, selectLimit :: Maybe Int , selectLimit :: Maybe Int
} }
| SelectDistinct Statement
| Insert String [String] [[Expr]] | Insert String [String] [[Expr]]
| Delete String (Maybe Expr) | Delete String (Maybe Expr)
| Update String [(String, Expr)] (Maybe Expr) | Update String [(String, Expr)] (Maybe Expr)
@@ -42,6 +37,7 @@ data Statement
| CreateUser String String | CreateUser String String
| AlterUser String String | AlterUser String String
| AlterIdentity String [(String, Bool)] | AlterIdentity String [(String, Bool)]
| ShowGrants
| ShowRoles | ShowRoles
| DropUser String | DropUser String
-- | 新角色:权限的载体,用户靠成员资格继承它的权限 -- | 新角色:权限的载体,用户靠成员资格继承它的权限
@@ -52,6 +48,7 @@ data Statement
| GrantPrivileges [String] String String Bool | GrantPrivileges [String] String String Bool
-- | REVOKE 权限 ON 表 FROM 角色 -- | REVOKE 权限 ON 表 FROM 角色
| RevokePrivileges [String] String String | RevokePrivileges [String] String String
| RevokeGrantOption [String] String String
-- | GRANT 角色 TO 用户:给用户加角色 -- | GRANT 角色 TO 用户:给用户加角色
| GrantRole String [String] | GrantRole String [String]
-- | REVOKE <角色> FROM <用户>[, ...] -- | REVOKE <角色> FROM <用户>[, ...]
@@ -93,6 +90,11 @@ data Subquery = Subquery
{ subqueryStatement :: Statement { subqueryStatement :: Statement
, subqueryRefs :: [String] , subqueryRefs :: [String]
} }
| BoundSubquery
{ subqueryStatement :: Statement
, subqueryRefs :: [String]
, subquerySlots :: [(String, Expr)]
}
deriving (Show, Eq) deriving (Show, Eq)
-- | 量词:ANY 至少一行成立,ALL 每一行都成立 -- | 量词:ANY 至少一行成立,ALL 每一行都成立
@@ -114,6 +116,8 @@ data CompareOp
-- | 条件表达式:列、字面量、算术、比较、逻辑、聚合与子查询 -- | 条件表达式:列、字面量、算术、比较、逻辑、聚合与子查询
data Expr data Expr
= Col String = Col String
| ColumnSlot Int String
| OuterColumnSlot Int Int String
| FunctionCall String [Expr] | FunctionCall String [Expr]
| BoundFunction FunctionId TypeId [Expr] | BoundFunction FunctionId TypeId [Expr]
| Construct TypeExpr [Expr] | Construct TypeExpr [Expr]
@@ -161,14 +165,72 @@ data SortDir
| Desc | Desc
deriving (Show, Eq) deriving (Show, Eq)
-- | 区分排序列、输出序号与来源表达式
data OrderKey = OrderColumn String | OrderPosition Int | OrderExpression Expr
deriving (Show, Eq)
-- | 造一个最简单的 SELECT -- | 造一个最简单的 SELECT
makeSelect :: [String] -> String -> Maybe Expr -> Statement makeSelect :: [String] -> String -> Maybe Expr -> Statement
makeSelect cols tbl w = makeSelect cols tbl w =
Select Select
{ selectCols = cols { selectItems = [(c, Col c) | c <- cols]
, selectFrom = FromTable Nothing tbl , selectFrom = FromTable Nothing tbl
, selectWhere = w , selectWhere = w
, selectGroupBy = [] , selectGroupBy = []
, selectHaving = Nothing
, selectOrderBy = [] , selectOrderBy = []
, selectLimit = Nothing , selectLimit = Nothing
} }
-- | 将去重排序映射到输出列
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 [(OrderKey, SortDir)]
resolveDistinctOrdering q = mapM resolve (selectOrderBy q)
where
items = case q of
Select { selectItems = projected } -> projected
_ -> []
-- | 排序键必须出现在去重结果中
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 #-} {-# LANGUAGE ImportQualifiedPost #-}
module ChuSQL.Core.Engine.Syntax.Parser (parseStatement, parseExpression) where module ChuSQL.Core.Engine.Syntax.Parser (parseStatement, parseExpression) where
import Data.Functor (($>))
import ChuSQL.Core.Model (Column (..), ColumnType (..), Value (..), plainColumn) import ChuSQL.Core.Model (Column (..), ColumnType (..), Value (..), plainColumn)
import ChuSQL.Core.Engine.Builtin (Builtin (..), builtinName, builtinNames, builtinNode, compareNode) import ChuSQL.Core.Engine.Builtin (Builtin (..), builtinName, builtinNames, builtinNode, compareNode)
import ChuSQL.Core.Engine.Syntax.AST import ChuSQL.Core.Engine.Syntax.AST
@@ -259,15 +261,19 @@ literalValue =
-- | 负浮点字面量 -- | 负浮点字面量
negateLit d = VFloat (negate d) negateLit d = VFloat (negate d)
-- | 一个排序列 -- | 一个排序键:输出序号、列名或表达式
orderItem :: Parser (String, SortDir) orderItem :: Parser (OrderKey, SortDir)
orderItem = do orderItem = do
col <- qualifiedName expression <- expr
dir <- sortDir 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 的列表 -- | ORDER BY 的列表
orderByClause :: Parser [(String, SortDir)] orderByClause :: Parser [(OrderKey, SortDir)]
orderByClause = do orderByClause = do
keyword "order" keyword "order"
keyword "by" keyword "by"
@@ -337,6 +343,7 @@ reservedWords =
, "auto_increment" , "auto_increment"
, "type" , "type"
, "group" , "group"
, "having"
, "with" , "with"
, "any" , "any"
, "all" , "all"
@@ -358,9 +365,10 @@ tableRef = do
-- | 连接类型:内连接 / 左外连接 -- | 连接类型:内连接 / 左外连接
joinKind :: Parser JoinKind joinKind :: Parser JoinKind
joinKind = joinKind =
try (keyword "left" *> optional (keyword "outer") *> keyword "join" *> return LeftJoin) try ((keyword "left" *> optional (keyword "outer") *> keyword "join")
<|> try (keyword "inner" *> keyword "join" *> return InnerJoin) $> LeftJoin)
<|> (keyword "join" *> return InnerJoin) <|> try ((keyword "inner" *> keyword "join") $> InnerJoin)
<|> (keyword "join" $> InnerJoin)
-- | FROM 里的一个来源:表或派生表 -- | FROM 里的一个来源:表或派生表
fromSource :: Parser FromClause fromSource :: Parser FromClause
@@ -422,11 +430,9 @@ createTableStatement = do
-- | 读 DROP TABLE -- | 读 DROP TABLE
dropTableStatement :: Parser Statement dropTableStatement :: Parser Statement
dropTableStatement = do dropTableStatement = do keyword "drop"
keyword "drop" keyword "table"
keyword "table" DropTable <$> tableName
name <- tableName
return (DropTable name)
-- | 读 CREATE INDEX(列名即索引名) -- | 读 CREATE INDEX(列名即索引名)
createIndexStatement :: Parser Statement createIndexStatement :: Parser Statement
@@ -485,12 +491,10 @@ alterTableStatement = do
-- | 读 CREATE USER,口令是明文 -- | 读 CREATE USER,口令是明文
createUserStatement :: Parser Statement createUserStatement :: Parser Statement
createUserStatement = do createUserStatement = do keyword "create"
keyword "create" keyword "user"
keyword "user" name <- userName
name <- userName CreateUser name <$> identifiedBy
pw <- identifiedBy
return (CreateUser name pw)
-- | 读 IDENTIFIED BY '口令' -- | 读 IDENTIFIED BY '口令'
identifiedBy :: Parser String identifiedBy :: Parser String
@@ -529,11 +533,9 @@ alterRoleStatement = do
-- | 读 DROP USER -- | 读 DROP USER
dropUserStatement :: Parser Statement dropUserStatement :: Parser Statement
dropUserStatement = do dropUserStatement = do keyword "drop"
keyword "drop" keyword "user"
keyword "user" DropUser <$> userName
name <- userName
return (DropUser name)
-- | 读 CREATE ROLE -- | 读 CREATE ROLE
createRoleStatement :: Parser Statement createRoleStatement :: Parser Statement
@@ -590,14 +592,15 @@ grantStatement = do
revokeStatement :: Parser Statement revokeStatement :: Parser Statement
revokeStatement = do revokeStatement = do
keyword "revoke" keyword "revoke"
optionOnly <- fromMaybe False <$> optional (True <$ (keyword "grant" *> keyword "option" *> keyword "for"))
choice choice
[ try $ do [ try $ do
privs <- sepBy1 privilegeName (symbol ",") privs <- sepBy1 privilegeName (symbol ",")
keyword "on" keyword "on"
obj <- grantObject obj <- grantObject
keyword "from" keyword "from"
RevokePrivileges privs obj <$> userName (if optionOnly then RevokeGrantOption else RevokePrivileges) privs obj <$> userName
, RevokeRole <$> userName <*> (keyword "from" *> sepBy1 userName (symbol ",")) , if optionOnly then fail "GRANT OPTION FOR requires object privileges" else RevokeRole <$> userName <*> (keyword "from" *> sepBy1 userName (symbol ","))
] ]
-- | 建表时的一列:类型后面跟若干约束 -- | 建表时的一列:类型后面跟若干约束
@@ -612,11 +615,18 @@ columnDef = do
columnConstraint :: Parser (Column -> Column) columnConstraint :: Parser (Column -> Column)
columnConstraint = columnConstraint =
choice choice
[ try (keyword "not" *> keyword "null" *> pure (\c -> c{columnNullable = False})) [ try ((keyword "not" *> keyword "null")
, keyword "null" *> pure (\c -> c{columnNullable = True}) $> (\ c -> c {columnNullable = False}))
, keyword "auto_increment" *> pure (\c -> c{columnAutoIncrement = True, columnNullable = False}) , keyword "null" $> (\ c -> c {columnNullable = True})
, try (keyword "primary" *> keyword "key" *> pure (\c -> c{columnPrimaryKey = True, columnUnique = True, columnNullable = False})) , keyword "auto_increment"
, keyword "unique" *> pure (\c -> c{columnUnique = True}) $>
(\ 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 "default" *> ((\v c -> c{columnDefault = Just v}) <$> literalValue)
, keyword "check" *> ((\s c -> c{columnCheck = Just s}) <$> checkText) , keyword "check" *> ((\s c -> c{columnCheck = Just s}) <$> checkText)
] ]
@@ -638,18 +648,18 @@ columnTypeP =
, keyword "int" >> pure CInt , keyword "int" >> pure CInt
, keyword "bigint" >> pure CBigInt , keyword "bigint" >> pure CBigInt
, keyword "smallint" >> pure CSmallInt , keyword "smallint" >> pure CSmallInt
, (keyword "varchar" >>) (maybe CStr CVarchar <$> optional sizeParen) , keyword "varchar" >> (maybe CStr CVarchar <$> optional sizeParen)
, (keyword "char" >>) (maybe (CChar 1) CChar <$> optional sizeParen) , keyword "char" >> (maybe (CChar 1) CChar <$> optional sizeParen)
, keyword "text" >> pure CStr , keyword "text" >> pure CStr
, keyword "str" >> pure CStr , keyword "str" >> pure CStr
, keyword "boolean" >> pure CBool , keyword "boolean" >> pure CBool
, keyword "bool" >> pure CBool , keyword "bool" >> pure CBool
, keyword "float" >> pure CFloat , keyword "float" >> pure CFloat
, keyword "real" >> pure CFloat , keyword "real" >> pure CFloat
, try (keyword "double" *> keyword "precision" *> pure CDouble) , try ((keyword "double" *> keyword "precision") $> CDouble)
, keyword "double" >> pure CDouble , keyword "double" >> pure CDouble
, (keyword "decimal" >>) decimalType , keyword "decimal" >> decimalType
, (keyword "numeric" >>) decimalType , keyword "numeric" >> decimalType
, keyword "date" >> pure CDate , keyword "date" >> pure CDate
, keyword "timestamp" >> pure CTimestamp , keyword "timestamp" >> pure CTimestamp
, keyword "blob" >> pure CBlob , keyword "blob" >> pure CBlob
@@ -689,15 +699,15 @@ decimalArgs = do
selectStatement :: Parser Statement selectStatement :: Parser Statement
selectStatement = do selectStatement = do
keyword "select" keyword "select"
distinct <- fromMaybe False <$> optional ((True <$ keyword "distinct") <|> (False <$ keyword "all"))
cols <- selectList cols <- selectList
fromC <- fromMaybe FromUnit <$> optional (keyword "from" *> fromClause) fromC <- fromMaybe FromUnit <$> optional (keyword "from" *> fromClause)
mWhere <- optional (keyword "where" *> expr) mWhere <- optional (keyword "where" *> expr)
groupBy <- fromMaybe [] <$> optional groupByClause groupBy <- fromMaybe [] <$> optional groupByClause
having <- optional (keyword "having" *> expr)
orderBy <- fromMaybe [] <$> optional orderByClause orderBy <- fromMaybe [] <$> optional orderByClause
mLimit <- optional limitClause mLimit <- optional limitClause
pure $ if all (\(name, e) -> e == Col name) cols pure $ (if distinct then SelectDistinct else id) (Select cols fromC mWhere groupBy having orderBy mLimit)
then Select (map fst cols) fromC mWhere groupBy orderBy mLimit
else SelectExpr cols fromC mWhere groupBy orderBy mLimit
-- | 读 WITH:展开每个 CTE 再读主查询 -- | 读 WITH:展开每个 CTE 再读主查询
withStatement :: Parser Statement withStatement :: Parser Statement
@@ -738,27 +748,20 @@ cteKey = map toLower
-- | CTE 带列清单时改本体的输出名 -- | CTE 带列清单时改本体的输出名
renameColumns :: String -> [String] -> Statement -> Either String Statement renameColumns :: String -> [String] -> Statement -> Either String Statement
renameColumns _ [] q = Right q renameColumns _ [] q = Right q
renameColumns name cols q@Select { selectCols = names } = do renameColumns name cols (SelectDistinct q) = SelectDistinct <$> renameColumns name cols q
checkCteArity name cols names renameColumns name cols q@Select { selectItems = items } = do
Right
( SelectExpr
[(c, Col n) | (c, n) <- zip cols names]
(selectFrom q)
(selectWhere q)
(selectGroupBy q)
(selectOrderBy q)
(selectLimit q)
)
renameColumns name cols q@SelectExpr { selectItems = items } = do
checkCteArity name cols (map snd items) checkCteArity name cols (map snd items)
ordering <- mapM renameOrder (selectOrderBy q) ordering <- if all (\(label, expression) -> expression == Col label) items
then Right (selectOrderBy q)
else mapM renameOrder (selectOrderBy q)
Right q { selectItems = zip cols (map snd items), selectOrderBy = ordering } Right q { selectItems = zip cols (map snd items), selectOrderBy = ordering }
where where
-- | 列清单同步改写内层排序输出别名 -- | 列清单同步改写内层排序输出别名
renameOrder (column, direction) = case [new | ((old, _), new) <- zip items cols, old == column] of renameOrder (OrderColumn column, direction) = case [new | ((old, _), new) <- zip items cols, old == column] of
[] -> Right (column, direction) [] -> Right (OrderColumn column, direction)
[new] -> Right (new, direction) [new] -> Right (OrderColumn new, direction)
_ -> Left ("WITH: ambiguous ORDER BY alias: " ++ column) _ -> Left ("WITH: ambiguous ORDER BY alias: " ++ column)
renameOrder ordering = Right ordering
renameColumns _ _ _ = Left "WITH: a CTE must be a SELECT" renameColumns _ _ _ = Left "WITH: a CTE must be a SELECT"
-- | 列清单个数必须和本体输出一致 -- | 列清单个数必须和本体输出一致
@@ -770,16 +773,19 @@ checkCteArity name cols out
-- | 把语句里对 CTE 的引用换成派生表 -- | 把语句里对 CTE 的引用换成派生表
expandStatement :: [(String, Statement)] -> Statement -> Either String Statement expandStatement :: [(String, Statement)] -> Statement -> Either String Statement
expandStatement env stmt = case stmt of expandStatement env stmt = case stmt of
q@Select { selectFrom = fromC, selectWhere = mWhere } -> do SelectDistinct q -> SelectDistinct <$> expandStatement env q
q@Select { selectFrom = fromC, selectItems = items, selectWhere = mWhere } -> do
fromC' <- expandClause env fromC fromC' <- expandClause env fromC
items' <- traverse (\(name, e) -> fmap (name,) (expandExpr env e)) items
w <- traverse (expandExpr env) mWhere w <- traverse (expandExpr env) mWhere
Right q { selectFrom = fromC', selectWhere = w } having <- traverse (expandExpr env) (selectHaving q)
q@SelectExpr { selectFrom = fromC, selectItems = items, selectWhere = mWhere } -> do ordering <- mapM expandOrder (selectOrderBy q)
fromC' <- expandClause env fromC Right q { selectFrom = fromC', selectItems = items', selectWhere = w, selectHaving = having, selectOrderBy = ordering }
items' <- traverse (\(name, e) -> fmap ((,) name) (expandExpr env e)) items
w <- traverse (expandExpr env) mWhere
Right q { selectFrom = fromC', selectItems = items', selectWhere = w }
_ -> Right stmt _ -> Right stmt
where
-- | 展开排序表达式中的 CTE 子查询
expandOrder (OrderExpression expression, direction) = (,) . OrderExpression <$> expandExpr env expression <*> pure direction
expandOrder ordering = Right ordering
-- | 来源树里的 CTE 引用换成派生表 -- | 来源树里的 CTE 引用换成派生表
expandClause :: [(String, Statement)] -> FromClause -> Either String FromClause expandClause :: [(String, Statement)] -> FromClause -> Either String FromClause
@@ -822,7 +828,7 @@ expandExpr env e = case e of
ScalarSub sq -> ScalarSub <$> goSub sq ScalarSub sq -> ScalarSub <$> goSub sq
InSub x sq neg -> (\x' sq' -> InSub x' sq' neg) <$> go x <*> 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 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 QuantCmp op x sq q -> (\x' sq' -> QuantCmp op x' sq' q) <$> go x <*> goSub sq
_ -> Right e _ -> Right e
where where
@@ -909,6 +915,7 @@ parseStatement input =
<|> try createUserStatement <|> try createUserStatement
<|> try alterUserStatement <|> try alterUserStatement
<|> try alterRoleStatement <|> try alterRoleStatement
<|> try (ShowGrants <$ (keyword "show" *> keyword "grants"))
<|> try (ShowRoles <$ (keyword "show" *> keyword "roles")) <|> try (ShowRoles <$ (keyword "show" *> keyword "roles"))
<|> try dropUserStatement <|> try dropUserStatement
<|> try createRoleStatement <|> try createRoleStatement
+12 -14
View File
@@ -26,22 +26,20 @@ spec = do
fmap (map verdict . findings) (analyzeNormalization schema fmap (map verdict . findings) (analyzeNormalization schema
(Declaration [["a", "b"]] [Dependency ["a"] ["c"]] True (Just True))) (Declaration [["a", "b"]] [Dependency ["a"] ["c"]] True (Just True)))
`shouldBe` Right [Satisfied, Violated, Violated, Violated] `shouldBe` Right [Satisfied, Violated, Violated, Violated]
it "detects transitive dependencies" $ do it "detects transitive dependencies and a preserving split" $ do
fmap (map verdict . findings) (analyzeNormalization schema let analysis = analyzeNormalization schema
(Declaration [["a"]] [Dependency ["b"] ["c"]] True (Just True))) (Declaration [["a"]] [Dependency ["b"] ["c"]] True (Just True))
fmap (map verdict . findings) analysis
`shouldBe` Right [Satisfied, Satisfied, Violated, Violated] `shouldBe` Right [Satisfied, Satisfied, Violated, Violated]
it "distinguishes 3NF from BCNF using all candidate keys" $ do fmap suggestions analysis
fmap (map verdict . findings) (analyzeNormalization schema
(Declaration [["a", "b"]] [Dependency ["c"] ["b"]] True (Just True)))
`shouldBe` Right [Satisfied, Satisfied, Satisfied, Violated]
it "reports lossless decomposition that loses dependencies" $ do
fmap suggestions (analyzeNormalization schema
(Declaration [["a", "b"]] [Dependency ["c"] ["b"]] True (Just True)))
`shouldBe` Right [Decomposition [["b", "c"], ["a", "c"]] Satisfied Violated]
it "reports dependency preserving transitive split" $ do
fmap suggestions (analyzeNormalization schema
(Declaration [["a"]] [Dependency ["b"] ["c"]] True (Just True)))
`shouldBe` Right [Decomposition [["b", "c"], ["a", "b"]] Satisfied Satisfied] `shouldBe` Right [Decomposition [["b", "c"], ["a", "b"]] Satisfied Satisfied]
it "distinguishes 3NF from BCNF and detects dependency loss" $ do
let analysis = analyzeNormalization schema
(Declaration [["a", "b"]] [Dependency ["c"] ["b"]] True (Just True))
fmap (map verdict . findings) analysis
`shouldBe` Right [Satisfied, Satisfied, Satisfied, Violated]
fmap suggestions analysis
`shouldBe` Right [Decomposition [["b", "c"], ["a", "c"]] Satisfied Violated]
it "does not certify incomplete dependencies" $ do it "does not certify incomplete dependencies" $ do
fmap (map verdict . findings) (analyzeNormalization schema fmap (map verdict . findings) (analyzeNormalization schema
(Declaration [["a"]] [] False (Just True))) (Declaration [["a"]] [] False (Just True)))
+655 -7
View File
@@ -3,23 +3,127 @@ module RuntimeSpec (spec) where
import ChuSQL.Core.Engine.Runtime.Types import ChuSQL.Core.Engine.Runtime.Types
import ChuSQL.Core.Engine.Runtime.Functions import ChuSQL.Core.Engine.Runtime.Functions
import ChuSQL.Core.Engine.Runtime.Binding import ChuSQL.Core.Engine.Runtime.Binding
import ChuSQL.Core.Engine.Runtime.Relation (bindRelOpColumns, bindWriteColumns)
import qualified ChuSQL.Core.Engine.Algebra.Op as Rel
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 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) import ChuSQL.Core.Engine.Semantic (prepare, prepareRowExpression)
import ChuSQL.Core.Engine.Syntax.Parser (parseStatement) import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
import ChuSQL.Core.Engine.Syntax.AST (Expr (..), Statement (..)) import ChuSQL.Core.Engine.Syntax.AST (Expr (..), Statement (..), Subquery (..), FromClause (..), SortDir (..))
import qualified ChuSQL.Core.Model as SQL import qualified ChuSQL.Core.Model as SQL
import ChuSQL.Core.Protocol (valueToJSON, valueFromJSON) import ChuSQL.Core.Protocol (valueToJSON, valueFromJSON, TableInfo (..))
import qualified Data.Aeson as A
import Data.Word (Word64)
import Data.Aeson.Types (parseEither) import Data.Aeson.Types (parseEither)
import Data.Hashable (hash) import Data.Hashable (hash)
import Control.Monad (foldM)
import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BS
import Data.List (isInfixOf)
import Data.Bifunctor (second)
import Test.Hspec import Test.Hspec
-- 运行时类型、函数绑定、物理编码和类型化查询测试。 -- 运行时类型、函数绑定、物理编码和类型化查询测试。
-- | 执行语句建立测试目录
sqlCatalog :: [String] -> Either String SQL.Database
sqlCatalog = foldM apply []
where
-- | 更新当前测试数据库
apply db source = do
statement <- parseStatement source
fst <$> runStatement db statement
-- | 检查运行时类型基础契约 -- | 检查运行时类型基础契约
spec :: Spec spec :: Spec
spec = do 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 describe "runtime type registry" $ do
it "keeps a fixed identity encoding across releases" $ withType (listType intType) $ \tid -> it "keeps a fixed identity encoding across releases" $ withType (listType intType) $ \tid ->
encodeType tid `shouldBe` BS.pack "[1,[5,[[1,[]]]]]" encodeType tid `shouldBe` BS.pack "[1,[5,[[1,[]]]]]"
@@ -29,7 +133,6 @@ spec = do
parseTypeExpr "MaybeInt" `shouldSatisfy` isFailure parseTypeExpr "MaybeInt" `shouldSatisfy` isFailure
it "restores stable nested identities from bootstrap metadata" $ do it "restores stable nested identities from bootstrap metadata" $ do
let ty = tupleType [listType intType, maybeType stringType] let ty = tupleType [listType intType, maybeType stringType]
resolveType builtinTypes ty `shouldBe` resolveType builtinTypes ty
fmap descriptorPhysical (resolveType builtinTypes ty) fmap descriptorPhysical (resolveType builtinTypes ty)
`shouldBe` Right (Product [Sequence SignedInteger, Optional Utf8]) `shouldBe` Right (Product [Sequence SignedInteger, Optional Utf8])
it "distinguishes logical String from List Int" $ it "distinguishes logical String from List Int" $
@@ -41,6 +144,173 @@ spec = do
resolveType builtinTypes (TypeApply (TypeConstructorId 5) []) `shouldSatisfy` isFailure resolveType builtinTypes (TypeApply (TypeConstructorId 5) []) `shouldSatisfy` isFailure
it "rejects arguments to Int" $ it "rejects arguments to Int" $
resolveType builtinTypes (TypeApply (TypeConstructorId 1) [intType]) `shouldSatisfy` isFailure 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 describe "runtime encoding" $ do
it "round trips nested lists, optional values and tuples" $ do it "round trips nested lists, optional values and tuples" $ do
let ty = tupleType [listType (maybeType intType), stringType, doubleType, boolType] let ty = tupleType [listType (maybeType intType), stringType, doubleType, boolType]
@@ -73,6 +343,35 @@ spec = do
let expression = Apply "not" [Apply "not" [Literal boolType (RBool True)]] let expression = Apply "not" [Apply "not" [Literal boolType (RBool True)]]
(bindExpression builtinTypes functions [] expression >>= evaluateExpression builtinTypes functions []) (bindExpression builtinTypes functions [] expression >>= evaluateExpression builtinTypes functions [])
`shouldBe` Right (RBool True) `shouldBe` Right (RBool True)
it "uses the bound column slot and rejects reordered expression input" $ withFunctions $ \functions ->
withType intType $ \int -> withType stringType $ \string -> do
let bound = bindExpression builtinTypes functions [("count", int), ("name", string)]
(Apply "length" [Reference "name"])
(bound >>= evaluateExpression builtinTypes functions [("count", RInt 1), ("name", RString "abc")])
`shouldBe` Right (RInt 3)
(bound >>= evaluateExpression builtinTypes functions [("name", RString "abc"), ("count", RInt 1)])
`shouldBe` Left "bound column position mismatch: name"
(bound >>= evaluateExpression builtinTypes functions [("count", RInt 1)])
`shouldBe` Left "missing bound column: name"
it "rejects ambiguous references before binding a slot" $ withFunctions $ \functions ->
withType intType $ \int ->
bindExpression builtinTypes functions [("id", int), ("id", int)] (Reference "id")
`shouldSatisfy` isFailure
it "normalizes storage order at scan boundaries before evaluating slots" $ withFunctions $ \functions -> do
let catalog = [("items", [("name", stringType), ("enabled", boolType)])]
query = Projection [("size", Apply "length" [Reference "name"])]
(Selection (Reference "enabled") (TableScan "items"))
scan _ = Right [[("enabled", RBool True), ("name", RString "abc")]]
(bindPlan builtinTypes functions catalog query >>= executePlan builtinTypes functions scan)
`shouldBe` Right [[("size", RInt 3)]]
it "rebinds slots to each projection output schema" $ withFunctions $ \functions -> do
let catalog = [("items", [("name", stringType), ("enabled", boolType)])]
source = Projection [("enabled", Reference "enabled"), ("label", Reference "name")]
(TableScan "items")
query = Projection [("size", Apply "length" [Reference "label"])] source
scan _ = Right [[("name", RString "abc"), ("enabled", RBool True)]]
(bindPlan builtinTypes functions catalog query >>= executePlan builtinTypes functions scan)
`shouldBe` Right [[("size", RInt 3)]]
it "rejects a wrong function argument type during binding" $ withFunctions $ \functions -> it "rejects a wrong function argument type during binding" $ withFunctions $ \functions ->
bindExpression builtinTypes functions [] (Apply "length" [Literal intType (RInt 1)]) `shouldSatisfy` isFailure bindExpression builtinTypes functions [] (Apply "length" [Literal intType (RInt 1)]) `shouldSatisfy` isFailure
it "rejects unknown function identities" $ withFunctions $ \functions -> it "rejects unknown function identities" $ withFunctions $ \functions ->
@@ -105,12 +404,361 @@ spec = do
(bindPlan builtinTypes functions [("t", [])] (TableScan "t") (bindPlan builtinTypes functions [("t", [])] (TableScan "t")
>>= executePlan builtinTypes functions (const (Left "storage unavailable"))) `shouldBe` Left "storage unavailable" >>= executePlan builtinTypes functions (const (Left "storage unavailable"))) `shouldBe` Left "storage unavailable"
describe "SQL runtime functions" $ do describe "SQL runtime functions" $ do
it "validates transitive DOMAIN dependencies and ignores unrelated definitions" $ do
let result = do
db <- sqlCatalog ["CREATE DOMAIN amount AS INT", "CREATE DOMAIN total AS amount"
, "CREATE DOMAIN unrelated AS TEXT", "CREATE TABLE amounts (value total)"]
statement <- parseStatement "SELECT value FROM amounts"
bound <- Query.bindQuery db statement
let change target = [(name, if name == target then table {SQL.tableCols = [("base", SQL.plainColumn SQL.CBool)]}
else table) | (name, table) <- db]
accepted <- fst <$> runMemoryStorage (Query.executeQueryM bound) (change "__system_domain_unrelated")
rejected <- fst <$> runMemoryStorage (Query.executeQueryM bound) (change "__system_domain_amount")
Right (accepted, rejected)
result `shouldBe` Right (Right [], Left "bound query schema changed: __system_domain_amount")
it "preserves exact catalog identities and rejects malformed identifiers" $ do
let identity = SQL.TableIdentity (maxBound :: Word64) (maxBound :: Word64)
info = TableInfo "items" [] 0 [] [] [] (Just identity) Nothing
decode text = A.eitherDecode (BS.pack text) :: Either String TableInfo
A.fromJSON (A.toJSON info) `shouldBe` A.Success info
fmap tiIdentity (decode "{\"table\":\"items\",\"columns\":[],\"row_count\":0}") `shouldBe` Right Nothing
fmap tiIdentity (decode "{\"table\":\"items\",\"columns\":[],\"row_count\":0,\"database_id\":0,\"object_id\":1}")
`shouldBe` Right (Just (SQL.TableIdentity 0 1))
mapM_ (\fields -> decode ("{\"table\":\"items\",\"columns\":[],\"row_count\":0," ++ fields ++ "}")
`shouldSatisfy` isFailure)
["\"database_id\":1", "\"database_id\":1,\"object_id\":-1"
, "\"database_id\":1,\"object_id\":1.5", "\"database_id\":1,\"object_id\":\"18446744073709551616\""
, "\"database_id\":1,\"object_id\":1e99999999"]
it "rejects a same-schema replacement or loss of object identity" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE bound_items (id INT)"]
let identified = [(name, table {SQL.tableIdentity = Just (SQL.TableIdentity 1 1)}) | (name, table) <- db]
statement <- parseStatement "SELECT id FROM bound_items"
bound <- Query.bindQuery identified statement
let replaced = [(name, table {SQL.tableIdentity = Just (SQL.TableIdentity 1 2)}) | (name, table) <- db]
changed <- fst <$> runMemoryStorage (Query.executeQueryM bound) replaced
lost <- fst <$> runMemoryStorage (Query.executeQueryM bound) db
Right (changed, lost)
result `shouldBe` Right (Left "bound query object changed: bound_items", Left "bound query object changed: bound_items")
it "preserves exact schema versions and rejects malformed versions" $ do
let info = TableInfo "items" [] 0 [] [] [] Nothing (Just maxBound)
decode version = A.eitherDecode (BS.pack ("{\"table\":\"items\",\"columns\":[],\"row_count\":0,\"schema_version\":" ++ version ++ "}")) :: Either String TableInfo
A.fromJSON (A.toJSON info) `shouldBe` A.Success info
fmap tiSchemaVersion (decode "0") `shouldBe` Right Nothing
fmap tiSchemaVersion (decode "7") `shouldBe` Right (Just 7)
mapM_ (\version -> decode version `shouldSatisfy` isFailure)
["-1", "1.5", "\"18446744073709551616\"", "\"+1\"", "1e99999999"]
it "invalidates a bound query after restoring its original columns" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE versioned (id INT)"]
statement <- parseStatement "SELECT id FROM versioned"
bound <- Query.bindQuery db statement
added <- parseStatement "ALTER TABLE versioned ADD COLUMN extra TEXT" >>= runStatement db
restored <- parseStatement "ALTER TABLE versioned DROP COLUMN extra" >>= runStatement (fst added)
fst <$> runMemoryStorage (Query.executeQueryM bound) (fst restored)
result `shouldBe` Right (Left "bound query schema changed: versioned")
it "rejects loss of a bound schema version" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE versioned (id INT)"]
statement <- parseStatement "SELECT id FROM versioned"
bound <- Query.bindQuery db statement
fst <$> runMemoryStorage (Query.executeQueryM bound)
[(name, table {SQL.tableSchemaVersion = Nothing}) | (name, table) <- db]
result `shouldBe` Right (Left "bound query schema changed: versioned")
it "ignores unrelated table changes but validates nested query dependencies" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE referenced (id INT)", "CREATE TABLE unrelated (id INT)"]
statement <- parseStatement "SELECT length((SELECT MIN(name) FROM (SELECT 'abc' AS name FROM referenced) d)) AS n"
bound <- Query.bindQuery db statement
unrelated <- parseStatement "ALTER TABLE unrelated ADD COLUMN extra TEXT" >>= runStatement db
accepted <- fst <$> runMemoryStorage (Query.executeQueryM bound) (fst unrelated)
referenced <- parseStatement "ALTER TABLE referenced ADD COLUMN extra TEXT" >>= runStatement db
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)"]
statement <- parseStatement "SELECT id FROM bound_items"
bound <- Query.bindQuery db statement
changed <- parseStatement "ALTER TABLE bound_items ADD COLUMN extra TEXT" >>= runStatement db
fst <$> runMemoryStorage (Query.executeQueryM bound) (fst changed)
result `shouldBe` Right (Left "bound query schema changed: bound_items")
it "keeps binding valid across row and statistics changes" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE bound_items (id INT)"]
statement <- parseStatement "SELECT id FROM bound_items"
bound <- Query.bindQuery db statement
changed <- parseStatement "INSERT INTO bound_items (id) VALUES (7)" >>= runStatement db
let current = [(name, table {SQL.tableMeta = Just (SQL.TableMeta 100 [] [] [])})
| (name, table) <- fst changed]
fst <$> runMemoryStorage (Query.executeQueryM bound) current
result `shouldBe` Right (Right [[("id", SQL.VInt 7)]])
it "binds grouping keys and then sorting to the grouped output" $ do
let source = Rel.Compute [("first", LitInt 1), ("key", LitInt 2)] Rel.Unit
plan = Rel.Sort [("key", Desc)] (Rel.Aggregate ["key"] [("n", CountAll)] source)
bound = Rel.BoundSort [(ColumnSlot 0 "key", Desc)]
(Rel.BoundAggregate [("key", ColumnSlot 1 "key")] [("n", CountAll)] source)
bindRelOpColumns [] [] plan `shouldBe` Right bound
evalRelOp [] bound `shouldBe` Right [[("key", SQL.VInt 2), ("n", SQL.VInt 1)]]
evalRelOp [] (Rel.BoundAggregate [("key", ColumnSlot 0 "key")] [] source)
`shouldBe` Left "bound column position mismatch: key"
it "sorts bound NULL keys stably and rejects wrong slots" $ do
let a = [("id", SQL.VInt 1), ("key", SQL.VInt 2)]
b = [("id", SQL.VInt 2), ("key", SQL.VNull)]
c = [("id", SQL.VInt 3), ("key", SQL.VInt 2)]
sortBoundRows [(ColumnSlot 1 "key", Asc)] [] [a, b, c] `shouldBe` Right [b, a, c]
sortBoundRows [(ColumnSlot 1 "key", Desc)] [] [a, b, c] `shouldBe` Right [a, c, b]
sortBoundRows [(ColumnSlot 0 "key", Asc)] [] [a]
`shouldBe` Left "bound column position mismatch: key"
it "preserves NULL group order and empty-input global aggregates" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE grouped_slots (id INT, tag TEXT)"
, "INSERT INTO grouped_slots (id, tag) VALUES (1, 'b'), (2, NULL), (3, 'b')"]
grouped <- parseStatement "SELECT tag, COUNT(*) AS n FROM grouped_slots GROUP BY tag"
groups <- rowsOf (runStatement db grouped)
empty <- parseStatement "SELECT COUNT(*) AS n, SUM(id) AS total FROM grouped_slots WHERE id < 0"
aggregates <- rowsOf (runStatement db empty)
Right (map (map snd) groups, map (map snd) aggregates)
result `shouldBe` Right ([[SQL.VStr "b", SQL.VInt 2], [SQL.VNull, SQL.VInt 1]]
, [[SQL.VInt 0, SQL.VNull]])
it "binds SQL relation expressions to the optimized input slots" $ do
let plan = Rel.Compute [("value", Col "second")]
(Rel.Compute [("first", LitInt 1), ("second", LitInt 2)] Rel.Unit)
bindRelOpColumns [] [] plan `shouldBe` Right (Rel.Compute [("value", ColumnSlot 1 "second")]
(Rel.Compute [("first", LitInt 1), ("second", LitInt 2)] Rel.Unit))
bindRelOpColumns [] [] (Rel.Filter (Col "missing") Rel.Unit)
`shouldBe` Left "unknown column: missing"
it "checks SQL slot position instead of searching another column" $ do
evalExpr (ColumnSlot 1 "name") [("name", SQL.VStr "abc"), ("id", SQL.VInt 1)]
`shouldBe` Left "bound column position mismatch: name"
evalExpr (ColumnSlot (-1) "name") [("name", SQL.VStr "abc")]
`shouldBe` Left "bound column position mismatch: name"
it "binds projections without losing repeated outputs or empty rows" $ do
let source = Rel.Compute [("first", LitInt 1), ("second", LitInt 2)] Rel.Unit
bindRelOpColumns [] [] (Rel.Project ["second", "first", "second"] source)
`shouldBe` Right (Rel.Compute [("second", ColumnSlot 1 "second")
, ("first", ColumnSlot 0 "first"), ("second", ColumnSlot 1 "second")] source)
bindRelOpColumns [] [] (Rel.Project [] source)
`shouldBe` Right (Rel.Compute [] source)
bindRelOpColumns [] [] (Rel.Project ["*"] source)
`shouldBe` Right (Rel.Compute [("first", ColumnSlot 0 "first"), ("second", ColumnSlot 1 "second")] source)
it "preserves repeated SQL outputs and correlated projection values" $ do
let result = do
db <- sqlCatalog ["CREATE TABLE slot_items (id INT)"
, "INSERT INTO slot_items (id) VALUES (1), (2)"]
repeated <- parseStatement "SELECT id, id FROM slot_items"
repeatedRows <- rowsOf (runStatement db repeated)
correlated <- parseStatement "SELECT o.id, (SELECT o.id FROM slot_items i WHERE i.id = o.id) AS echoed FROM slot_items o"
correlatedRows <- rowsOf (runStatement db correlated)
Right (map (map snd) repeatedRows, map (map snd) correlatedRows)
result `shouldBe` Right ([[SQL.VInt 1, SQL.VInt 1], [SQL.VInt 2, SQL.VInt 2]]
, [[SQL.VInt 1, SQL.VInt 1], [SQL.VInt 2, SQL.VInt 2]])
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"
bound = bindRelOpColumns [] ["id"] (Rel.Compute [("outer", expression)] source)
bound `shouldBe` Right (Rel.Compute [("outer", OuterColumnSlot 1 0 "id")] source)
evalExpr (OuterColumnSlot 1 0 "id") [("id", SQL.VInt 1), ("id", SQL.VInt 9)]
`shouldBe` Right (SQL.VInt 9)
bindRelOpColumns [] [] (Rel.Compute [("outer", expression)] source)
`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)"
, "INSERT INTO scoped_items (id) VALUES (1), (2)"]
statement <- parseStatement "SELECT o.id, (SELECT id FROM scoped_items i WHERE i.id = o.id) AS inner_id, (SELECT (SELECT o.id FROM scoped_items j WHERE j.id = i.id) FROM scoped_items i WHERE i.id = o.id) AS nested_id FROM scoped_items o"
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)"
, "INSERT INTO slot_items (id, name) VALUES (1, 'abc'), (2, 'xy')"]
let reordered = [(name, table {SQL.tableRows = map reverse (SQL.tableRows table)}) | (name, table) <- db]
statement <- parseStatement "SELECT length(name) AS size, id + 1 AS next FROM slot_items WHERE id > 0 ORDER BY size"
rowsOf (runStatement reordered statement)
fmap (map (map snd)) result `shouldBe` Right [[SQL.VInt 2, SQL.VInt 3], [SQL.VInt 3, SQL.VInt 2]]
it "binds the SQL entry point to output TypeIds" $ withType intType $ \tid -> do it "binds the SQL entry point to output TypeIds" $ withType intType $ \tid -> do
let result = parseStatement "SELECT length('abc') AS size" >>= Query.bindQuery [] let result = parseStatement "SELECT length('abc') AS size" >>= Query.bindQuery []
fmap Query.queryTypes result `shouldBe` Right [("size", Query.RuntimeType tid)] fmap Query.queryTypes result `shouldBe` Right [("size", Query.RuntimeType tid)]
it "retains compatibility for existing temporal SQL types" $ do it "retains compatibility for existing temporal SQL types" $ do
let result = parseStatement "SELECT DATE '2026-10-05' AS today" >>= Query.bindQuery [] let result = parseStatement "SELECT DATE '2026-10-05' AS today" >>= Query.bindQuery []
fmap Query.queryTypes result `shouldBe` Right [("today", Query.CompatibilityType SQL.CDate)] fmap Query.queryTypes result `shouldBe` Right [("today", Query.CompatibilityType SQL.CDate)]
it "retains nested DOMAIN identities through derived aliases and DISTINCT" $ withType intType $ \tid -> do
let result = do
db <- sqlCatalog ["CREATE DOMAIN quantity AS INT", "CREATE DOMAIN stock AS quantity"
, "CREATE TABLE inventory (qty stock)", "INSERT INTO inventory (qty) VALUES (2), (NULL)"]
statement <- parseStatement "SELECT DISTINCT d.qty AS available FROM (SELECT qty FROM inventory) d"
bound <- Query.bindQuery db statement
rows <- rowsOf (runStatement db statement)
Right (Query.queryTypes bound, map (map snd) rows)
result `shouldBe` Right ([("available", Query.DomainType "stock"
(Query.DomainType "quantity" (Query.RuntimeType tid)))], [[SQL.VInt 2], [SQL.VNull]])
it "preserves temporal and binary DOMAIN wrappers" $ do
let result = do
db <- sqlCatalog ["CREATE DOMAIN day AS DATE", "CREATE DOMAIN payload AS BLOB"
, "CREATE TABLE documents (created day, contents payload)"]
statement <- parseStatement "SELECT created, contents FROM documents"
Query.queryTypes <$> Query.bindQuery db statement
result `shouldBe` Right [("created", Query.DomainType "day" (Query.CompatibilityType SQL.CDate))
, ("contents", Query.DomainType "payload" (Query.CompatibilityType SQL.CBlob))]
it "uses base function semantics without labeling function results as DOMAIN" $ withType intType $ \tid -> do
let result = do
db <- sqlCatalog ["CREATE DOMAIN label AS VARCHAR(3)", "CREATE TABLE names (name label)"
, "INSERT INTO names (name) VALUES ('abc')"]
statement <- parseStatement "SELECT length(name) AS size FROM names"
bound <- Query.bindQuery db statement
rows <- rowsOf (runStatement db statement)
Right (Query.queryTypes bound, map (map snd) rows)
result `shouldBe` Right ([("size", Query.RuntimeType tid)], [[SQL.VInt 3]])
it "rejects composite ordering without an Ord implementation" $ it "rejects composite ordering without an Ord implementation" $
sql "SELECT LIST<Int>(1) AS xs ORDER BY xs" `shouldSatisfy` isFailure sql "SELECT LIST<Int>(1) AS xs ORDER BY xs" `shouldSatisfy` isFailure
it "rejects composite extrema without an Ord implementation" $ it "rejects composite extrema without an Ord implementation" $
@@ -167,7 +815,7 @@ spec = do
it "binds calls before execution" $ do it "binds calls before execution" $ do
let bound = parseStatement "SELECT length('abc')" >>= prepare [] let bound = parseStatement "SELECT length('abc')" >>= prepare []
case bound of case bound of
Right SelectExpr {selectItems = [(_, BoundFunction (FunctionId 1) _ [_])]} -> pure () Right Select {selectItems = [(_, BoundFunction (FunctionId 1) _ [_])]} -> pure ()
_ -> expectationFailure (show bound) _ -> expectationFailure (show bound)
it "rejects unknown SQL functions before scanning" $ it "rejects unknown SQL functions before scanning" $
sql "SELECT missing('abc')" `shouldSatisfy` isFailure sql "SELECT missing('abc')" `shouldSatisfy` isFailure
@@ -202,7 +850,7 @@ sql source = do
-- | 提供函数调用测试表 -- | 提供函数调用测试表
database = [("t", SQL.Table "t" [("name", SQL.plainColumn SQL.CStr), ("enabled", SQL.plainColumn SQL.CBool)] database = [("t", SQL.Table "t" [("name", SQL.plainColumn SQL.CStr), ("enabled", SQL.plainColumn SQL.CBool)]
[[("name", SQL.VStr "ab"), ("enabled", SQL.VBool True)] [[("name", SQL.VStr "ab"), ("enabled", SQL.VBool True)]
,[("name", SQL.VStr "xyz"), ("enabled", SQL.VBool False)]] Nothing)] ,[("name", SQL.VStr "xyz"), ("enabled", SQL.VBool False)]] Nothing Nothing Nothing)]
-- | 判断结果是否明确失败 -- | 判断结果是否明确失败
isFailure :: Either a b -> Bool isFailure :: Either a b -> Bool
File diff suppressed because it is too large. Load diff
+8 -1
View File
@@ -12,6 +12,7 @@ module ChuSQL.Core.Model
, TableMeta (..) , TableMeta (..)
, Histogram (..) , Histogram (..)
, Table (..) , Table (..)
, TableIdentity (..)
, Database , Database
, histogramOf , histogramOf
, histogramFor , histogramFor
@@ -48,6 +49,7 @@ import Data.Char (isDigit, isSpace, toLower)
import Data.Hashable (Hashable (..)) import Data.Hashable (Hashable (..))
import Data.List (isPrefixOf, isSuffixOf, stripPrefix) import Data.List (isPrefixOf, isSuffixOf, stripPrefix)
import Data.Maybe (fromMaybe, mapMaybe) import Data.Maybe (fromMaybe, mapMaybe)
import Data.Word (Word64)
import ChuSQL.Core.Runtime import ChuSQL.Core.Runtime
import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BS
@@ -556,12 +558,17 @@ data TableMeta = TableMeta
} }
deriving (Show) deriving (Show)
-- | 一张表:名字、列定义与全部行;meta 为存储层统计,拿不到是 Nothing -- | 保存持久化数据库与表编号
data TableIdentity = TableIdentity Word64 Word64 deriving (Show, Eq)
-- | 一张表:列、行、统计与独立对象身份
data Table = Table data Table = Table
{ tableName :: String { tableName :: String
, tableCols :: [(String, Column)] , tableCols :: [(String, Column)]
, tableRows :: [Row] , tableRows :: [Row]
, tableMeta :: Maybe TableMeta , tableMeta :: Maybe TableMeta
, tableIdentity :: Maybe TableIdentity
, tableSchemaVersion :: Maybe Word64
} }
deriving (Show) deriving (Show)
+92 -21
View File
@@ -15,16 +15,19 @@ module ChuSQL.Core.Protocol (
queryResultJson, queryResultJson,
) where ) where
import ChuSQL.Core.Model (Histogram (..), Row, Value (..)) import ChuSQL.Core.Model (Histogram (..), Row, TableIdentity (..), Value (..))
import ChuSQL.Core.Runtime (builtinTypes, runtimeToJSON, runtimeFromJSON) import ChuSQL.Core.Runtime (builtinTypes, runtimeFromJSON, runtimeToJSON)
import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.!=), (.=)) import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.!=), (.:), (.:?), (.=))
import qualified Data.Aeson as A import qualified Data.Aeson as A
import qualified Data.Aeson.Key as K import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM import qualified Data.Aeson.KeyMap as KM
import Data.Aeson.Types (Parser) import Data.Aeson.Types (Parser)
import Data.Scientific (floatingOrInteger, fromFloatDigits) import Data.Char (isDigit)
import qualified Data.Text as T import Data.Scientific (base10Exponent, floatingOrInteger, fromFloatDigits)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T
import Data.Word (Word64)
import Text.Read (readMaybe)
-- 线上协议类型:存储层请求/响应与查询结果集。 -- 线上协议类型:存储层请求/响应与查询结果集。
@@ -95,6 +98,7 @@ data Request
| ReqLookupByColumn String String Value | ReqLookupByColumn String String Value
| ReqRangeByIndex String String (Maybe (Value, Bool)) (Maybe (Value, Bool)) | ReqRangeByIndex String String (Maybe (Value, Bool)) (Maybe (Value, Bool))
| ReqDescribeTable String | ReqDescribeTable String
| ReqValidateWrite String
| ReqCreateTable String [SchemaColumn] | ReqCreateTable String [SchemaColumn]
| ReqDropTable String | ReqDropTable String
| ReqCreateIndex String String | ReqCreateIndex String String
@@ -134,6 +138,7 @@ instance ToJSON TxnOp where
-- | 请求编码成 JSON -- | 请求编码成 JSON
instance ToJSON Request where 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 (ReqDatabase method name) = object ["method" .= method, "database" .= name]
toJSON ReqAllCatalog = object ["method" .= ("all_catalogs" :: T.Text)] toJSON ReqAllCatalog = object ["method" .= ("all_catalogs" :: T.Text)]
toJSON (ReqInDatabase name req) = case toJSON req of toJSON (ReqInDatabase name req) = case toJSON req of
@@ -143,8 +148,16 @@ instance ToJSON Request where
toJSON ReqAccountsList = object ["method" .= ("accounts_list" :: T.Text)] toJSON ReqAccountsList = object ["method" .= ("accounts_list" :: T.Text)]
toJSON (ReqIdentityInitialize u) = object ["method" .= ("identity_initialize" :: T.Text), "administrator" .= u] toJSON (ReqIdentityInitialize u) = object ["method" .= ("identity_initialize" :: T.Text), "administrator" .= u]
toJSON (ReqRoleCreate u) = object ["method" .= ("role_create" :: T.Text), "user" .= 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, toJSON (ReqIdentityAlter u login super enabled manager sudo) =
"can_login" .= login, "is_superuser" .= super, "enabled" .= enabled, "system_catalog_manager" .= manager, "allow_sudo_auth" .= 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 (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 (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] toJSON (ReqAccountLogin u at) = object ["method" .= ("account_login" :: T.Text), "user" .= u, "at" .= at]
@@ -255,6 +268,8 @@ data TableInfo = TableInfo
, tiIndexes :: [String] , tiIndexes :: [String]
, tiStats :: [(String, Int, Bool)] , tiStats :: [(String, Int, Bool)]
, tiHistograms :: [(String, Histogram)] , tiHistograms :: [(String, Histogram)]
, tiIdentity :: Maybe TableIdentity
, tiSchemaVersion :: Maybe Word64
} }
deriving (Show, Eq) deriving (Show, Eq)
@@ -267,6 +282,9 @@ instance ToJSON TableInfo where
, "row_count" .= tiRows info , "row_count" .= tiRows info
, "indexes" .= map (\name -> object ["column" .= name]) (tiIndexes info) , "indexes" .= map (\name -> object ["column" .= name]) (tiIndexes info)
, "stats" .= map (statJson (tiHistograms info)) (tiStats info) , "stats" .= map (statJson (tiHistograms info)) (tiStats info)
, "database_id" .= fmap (\(TableIdentity database _) -> show database) (tiIdentity info)
, "object_id" .= fmap (\(TableIdentity _ table) -> show table) (tiIdentity info)
, "schema_version" .= fmap show (tiSchemaVersion info)
] ]
where where
statJson hists (name, distinct, capped) = statJson hists (name, distinct, capped) =
@@ -276,6 +294,19 @@ instance ToJSON TableInfo where
histFields Nothing = [] histFields Nothing = []
histFields (Just h) = ["lo" .= histLow h, "hi" .= histHigh h, "hist" .= histBuckets h] histFields (Just h) = ["lo" .= histLow h, "hi" .= histHigh h, "hist" .= histBuckets h]
-- | 解码精确且有界的对象编号
parseObjectNumber :: A.Value -> Parser Word64
parseObjectNumber (A.String value)
| 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"
-- | 线上直方图还原;区间或桶缺了就当作没有 -- | 线上直方图还原;区间或桶缺了就当作没有
histogramFromWire :: Maybe Double -> Maybe Double -> [Int] -> Maybe Histogram histogramFromWire :: Maybe Double -> Maybe Double -> [Int] -> Maybe Histogram
histogramFromWire (Just low) (Just high) counts histogramFromWire (Just low) (Just high) counts
@@ -290,11 +321,29 @@ instance FromJSON TableInfo where
count <- o .: "row_count" count <- o .: "row_count"
indexes <- o .:? "indexes" .!= [] indexes <- o .:? "indexes" .!= []
stats <- o .:? "stats" .!= [] 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]) parsed <- mapM parseStat (stats :: [A.Value])
database <- o .:? "database_id" >>= traverse parseObjectNumber
tableId <- o .:? "object_id" >>= traverse parseObjectNumber
version <- o .:? "schema_version" >>= traverse parseObjectNumber
identity <- case (database, tableId) of
(Nothing, Nothing) -> pure Nothing
(Just _, Just 0) -> pure Nothing
(Just databaseId, Just objectId) | objectId > 0 -> pure (Just (TableIdentity databaseId objectId))
_ -> fail ("incomplete table object identity: " ++ show (database, tableId))
let parsedStats = [(name, distinct, capped) | (name, distinct, capped, _) <- parsed] let parsedStats = [(name, distinct, capped) | (name, distinct, capped, _) <- parsed]
parsedHistograms = [(name, h) | (name, _, _, Just h) <- parsed] parsedHistograms = [(name, h) | (name, _, _, Just h) <- parsed]
pure (TableInfo table columns count indexColumns parsedStats parsedHistograms) pure
( TableInfo
table
columns
count
indexColumns
parsedStats
parsedHistograms
identity
(version >>= \v -> if v == 0 then Nothing else Just v)
)
where where
parseStat = withObject "ColumnStat" $ \o -> do parseStat = withObject "ColumnStat" $ \o -> do
name <- o .: "name" name <- o .: "name"
@@ -318,7 +367,8 @@ data Account = Account
, accountEnabled :: Bool , accountEnabled :: Bool
, accountSystemCatalogManager :: Bool , accountSystemCatalogManager :: Bool
, accountAllowSudoAuth :: Bool , accountAllowSudoAuth :: Bool
} deriving (Eq) }
deriving (Eq)
-- | 账号的展示:只露账号名与版本号 -- | 账号的展示:只露账号名与版本号
instance Show Account where instance Show Account where
@@ -326,17 +376,36 @@ instance Show Account where
-- | JSON 解回账号 -- | JSON 解回账号
instance FromJSON Account where instance FromJSON Account where
parseJSON = withObject "Account" $ \o -> Account <$> o .: "id" <*> o .: "user" parseJSON = withObject "Account" $ \o ->
<*> o .: "password_hash" <*> o .: "revision" Account
<*> o .:? "registered_at" .!= "" <*> o .:? "last_login_at" <$> o .: "id"
<*> o .:? "can_login" .!= True <*> o .:? "is_superuser" .!= False <*> o .:? "enabled" .!= True <*> o .:? "system_catalog_manager" .!= False <*> o .:? "allow_sudo_auth" .!= False <*> 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 -- | 账号编码成 JSON
instance ToJSON Account where instance ToJSON Account where
toJSON a = object ["id" .= accountId a, "user" .= accountUser a, toJSON a =
"password_hash" .= accountHash a, "revision" .= accountRevision a, object
"registered_at" .= accountRegisteredAt a, "last_login_at" .= accountLastLoginAt a, [ "id" .= accountId a
"can_login" .= accountCanLogin a, "is_superuser" .= accountIsSuperuser a, "enabled" .= accountEnabled a, "system_catalog_manager" .= accountSystemCatalogManager a, "allow_sudo_auth" .= accountAllowSudoAuth 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 data Response
@@ -387,7 +456,8 @@ valueFromJSON (A.Number n) =
valueFromJSON (A.String s) = pure (VStr (T.unpack s)) valueFromJSON (A.String s) = pure (VStr (T.unpack s))
valueFromJSON (A.Bool b) = pure (VBool b) valueFromJSON (A.Bool b) = pure (VBool b)
valueFromJSON (A.Object fields) 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) either fail (pure . uncurry VRuntime) (runtimeFromJSON builtinTypes payload)
valueFromJSON _ = fail "unsupported value type" valueFromJSON _ = fail "unsupported value type"
@@ -400,7 +470,7 @@ rowToJSON r =
rowFromJSON :: A.Value -> Parser Row rowFromJSON :: A.Value -> Parser Row
rowFromJSON (A.Object o) = mapM toPair (KM.toList o) rowFromJSON (A.Object o) = mapM toPair (KM.toList o)
where where
-- | 键值对解成一个字段 -- \| 键值对解成一个字段
toPair (k, v) = do toPair (k, v) = do
val <- valueFromJSON v val <- valueFromJSON v
pure (K.toString k, val) pure (K.toString k, val)
@@ -421,7 +491,8 @@ instance FromJSON QueryResult where
parseJSON = withObject "QueryResult" $ \o -> do parseJSON = withObject "QueryResult" $ \o -> do
cols <- o .: "columns" cols <- o .: "columns"
rows <- o .: "rows" rows <- o .: "rows"
QueryResult cols <$> mapM (mapM valueFromJSON) rows QueryResult cols
<$> mapM (mapM valueFromJSON) rows
<*> o .:? "rowCount" .!= 0 <*> o .:? "rowCount" .!= 0
<*> o .:? "truncated" .!= False <*> o .:? "truncated" .!= False
<*> o .:? "database" <*> o .:? "database"
+4 -3
View File
@@ -6,6 +6,7 @@ module ChuSQL.Core.Runtime
, validateValue, encodeValue, decodeValue, encodeType, decodeType, runtimeToJSON, runtimeFromJSON , validateValue, encodeValue, decodeValue, encodeType, decodeType, runtimeToJSON, runtimeFromJSON
) where ) where
import Control.Monad (zipWithM, zipWithM_)
import Data.Aeson (Value (..), eitherDecode, encode) import Data.Aeson (Value (..), eitherDecode, encode)
import Data.Aeson.Types (Parser, parseEither) import Data.Aeson.Types (Parser, parseEither)
import qualified Data.ByteString.Lazy as BS 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 ","))) P.<++ (tupleType <$> between "(" ")" (P.sepBy expression (symbol ",")))
-- | 解析具有名称边界的类型关键字 -- | 解析具有名称边界的类型关键字
token word = do token word = do
_ <- mapM character word mapM_ character word
rest <- P.look rest <- P.look
case rest of case rest of
c : _ | isAlphaNum c || c == '_' -> P.pfail 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 _) (RMaybe Nothing) = Right ()
validatePhysical (Optional child) (RMaybe (Just value)) = validatePhysical child value validatePhysical (Optional child) (RMaybe (Just value)) = validatePhysical child value
validatePhysical (Product fields) (RTuple values) 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) 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 [value] -> RMaybe . Just <$> parseValue child value
_ -> fail "invalid optional value" _ -> fail "invalid optional value"
parseValue (Product fields) (Array values) 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" parseValue _ _ = fail "invalid physical value"
+41 -27
View File
@@ -167,23 +167,47 @@ fn put_node(p: &mut Page, node: &Node) -> io::Result<()> {
} }
/// 从一页读出节点 /// 从一页读出节点
fn get_node(p: &Page) -> Node { fn get_node(p: &Page) -> io::Result<Node> {
if p.data.len() < HEADER {
return Err(io::Error::new(io::ErrorKind::InvalidData, "truncated index node header"));
}
let kind = read_u8(p, OFF_KIND); let kind = read_u8(p, OFF_KIND);
let count = read_u16(p, OFF_COUNT) as usize; let count = read_u16(p, OFF_COUNT) as usize;
let slots_end = HEADER + count * SLOT;
if !matches!(kind, NODE_LEAF | NODE_INTERNAL) || slots_end > p.data.len() {
return Err(io::Error::new(io::ErrorKind::InvalidData, "invalid index node kind or slot count"));
}
let trailer = read_u64(p, OFF_NEXT); let trailer = read_u64(p, OFF_NEXT);
let mut keys = Vec::with_capacity(count); let mut keys = Vec::with_capacity(count);
let mut values = Vec::with_capacity(count + 1); let mut values = Vec::with_capacity(count + 1);
let mut cell_end = p.data.len();
for i in 0..count { for i in 0..count {
let off = read_u16(p, HEADER + i * SLOT) as usize; let off = read_u16(p, HEADER + i * SLOT) as usize;
if off < slots_end || off + CELL_FIXED > p.data.len() {
return Err(io::Error::new(io::ErrorKind::InvalidData, "invalid index cell offset"));
}
let klen = read_u16(p, off) as usize; let klen = read_u16(p, off) as usize;
if klen > MAX_KEY_BYTES || off + CELL_FIXED + klen > p.data.len() {
return Err(io::Error::new(io::ErrorKind::InvalidData, "invalid index key length"));
}
if off + CELL_FIXED + klen > cell_end {
return Err(io::Error::new(io::ErrorKind::InvalidData, "overlapping index cells"));
}
cell_end = off;
keys.push(p.data[off + 2..off + 2 + klen].to_vec()); keys.push(p.data[off + 2..off + 2 + klen].to_vec());
values.push(read_u64(p, off + 2 + klen)); values.push(read_u64(p, off + 2 + klen));
} }
if keys.windows(2).any(|pair| pair[0] > pair[1]) {
return Err(io::Error::new(io::ErrorKind::InvalidData, "index keys are not sorted"));
}
if kind == NODE_INTERNAL { if kind == NODE_INTERNAL {
values.push(trailer); values.push(trailer);
Node { kind, next: 0, keys, values } if values.contains(&META_PAGE) {
return Err(io::Error::new(io::ErrorKind::InvalidData, "invalid index child page"));
}
Ok(Node { kind, next: 0, keys, values })
} else { } else {
Node { kind, next: trailer, keys, values } Ok(Node { kind, next: trailer, keys, values })
} }
} }
@@ -299,7 +323,7 @@ impl DiskBTree {
/// 按页号读节点 /// 按页号读节点
fn load(&mut self, id: PageId) -> io::Result<Node> { fn load(&mut self, id: PageId) -> io::Result<Node> {
self.file.with_page(id, get_node) self.file.with_page(id, get_node)?
} }
/// 按页号写节点 /// 按页号写节点
@@ -338,24 +362,9 @@ impl DiskBTree {
/// 按 key 取全部位置(重复键按值升序) /// 按 key 取全部位置(重复键按值升序)
pub fn get_all(&mut self, key: &[u8]) -> io::Result<Vec<u64>> { pub fn get_all(&mut self, key: &[u8]) -> io::Result<Vec<u64>> {
let Some(mut id) = self.root()? else { let mut values: Vec<_> = self.scan(Some(key), Some(key))?.into_iter().map(|(_, value)| value).collect();
return Ok(Vec::new()); values.sort_unstable();
}; Ok(values)
loop {
let node = self.load(id)?;
if node.kind == NODE_LEAF {
let start = node.keys.partition_point(|k| k.as_slice() < key);
let mut out = Vec::new();
for i in start..node.keys.len() {
if node.keys[i].as_slice() != key {
break;
}
out.push(node.values[i]);
}
return Ok(out);
}
id = node.values[child_slot(&node.keys, key)];
}
} }
/// 插入一个键值对(键可重复) /// 插入一个键值对(键可重复)
@@ -412,10 +421,9 @@ impl DiskBTree {
self.store(id, &node)?; self.store(id, &node)?;
return Ok(None); return Ok(None);
} }
let (sep, mut right) = split_node(&mut node); let (sep, right) = split_node(&mut node);
let right_id = self.alloc(&right)?; let right_id = self.alloc(&right)?;
if node.kind == NODE_LEAF { if node.kind == NODE_LEAF {
right.next = node.next;
node.next = right_id; node.next = right_id;
} }
self.store(id, &node)?; self.store(id, &node)?;
@@ -443,8 +451,14 @@ impl DiskBTree {
} }
return Ok(false); return Ok(false);
} }
let child = node.values[child_slot(&node.keys, key)]; let first = node.keys.partition_point(|k| k.as_slice() < key);
self.delete_rec(child, key, value) let last = child_slot(&node.keys, key);
for &child in &node.values[first..=last] {
if self.delete_rec(child, key, value)? {
return Ok(true);
}
}
Ok(false)
} }
/// 叶子链上按顺序取全部 (键, 值) /// 叶子链上按顺序取全部 (键, 值)
@@ -475,7 +489,7 @@ impl DiskBTree {
} }
id = match lo { id = match lo {
None => node.values[0], None => node.values[0],
Some(start) => node.values[child_slot(&node.keys, start)], Some(start) => node.values[node.keys.partition_point(|k| k.as_slice() < start)],
}; };
} }
let mut out = Vec::new(); let mut out = Vec::new();
+62 -28
View File
@@ -37,6 +37,9 @@ pub struct TableSchema {
#[serde(default)] #[serde(default)]
pub object_id: u64, pub object_id: u64,
#[serde(default)] #[serde(default)]
// 0 表示旧目录尚无可验证的结构版本。
pub schema_version: u64,
#[serde(default)]
pub system: bool, pub system: bool,
pub columns: Vec<SchemaColumn>, pub columns: Vec<SchemaColumn>,
#[serde(default)] #[serde(default)]
@@ -51,7 +54,7 @@ pub struct TableSchema {
pub stats: BTreeMap<String, ColumnStat>, pub stats: BTreeMap<String, ColumnStat>,
} }
#[derive(Debug, Default, Serialize, Deserialize)] #[derive(Debug, Clone, Default, Serialize, Deserialize)]
pub struct Catalog { pub struct Catalog {
#[serde(default)] #[serde(default)]
pub database_id: u64, pub database_id: u64,
@@ -134,9 +137,10 @@ impl Catalog {
} }
/// 按一行数据补列 /// 按一行数据补列
pub fn ensure_columns(&mut self, table: &str, row: &Row) { pub fn ensure_columns(&mut self, table: &str, row: &Row) -> io::Result<()> {
let entry = self.tables.entry(table.to_string()).or_default(); let entry = self.tables.entry(table.to_string()).or_default();
add_missing_columns(entry, row); add_missing_columns(entry, row)?;
Ok(())
} }
/// 建表;已存在报错 /// 建表;已存在报错
@@ -163,6 +167,7 @@ impl Catalog {
table.to_string(), table.to_string(),
TableSchema { TableSchema {
object_id, object_id,
schema_version: 1,
system: false, system: false,
columns, columns,
dropped_columns: BTreeSet::new(), dropped_columns: BTreeSet::new(),
@@ -184,15 +189,15 @@ impl Catalog {
} }
/// 记一次插入,返回列有没有变化 /// 记一次插入,返回列有没有变化
pub fn record_insert(&mut self, table: &str, row: &Row) -> bool { pub fn record_insert(&mut self, table: &str, row: &Row) -> io::Result<bool> {
let changed = { let changed = {
let entry = self.tables.entry(table.to_string()).or_default(); let entry = self.tables.entry(table.to_string()).or_default();
let changed = add_missing_columns(entry, row); let changed = add_missing_columns(entry, row)?;
entry.row_count += 1; entry.row_count += 1;
changed changed
}; };
self.count_values(table, row); self.count_values(table, row);
changed Ok(changed)
} }
/// 记一次删除:行数减少 + 更新列统计 /// 记一次删除:行数减少 + 更新列统计
@@ -230,7 +235,7 @@ impl Catalog {
} }
/// 重数一遍统计与行数 /// 重数一遍统计与行数
pub fn rebuild_stats(&mut self, table: &str, rows: &[Row]) -> bool { pub fn rebuild_stats(&mut self, table: &str, rows: &[Row]) -> io::Result<bool> {
self.seen.remove(table); self.seen.remove(table);
{ {
let entry = self.tables.entry(table.to_string()).or_default(); let entry = self.tables.entry(table.to_string()).or_default();
@@ -251,9 +256,9 @@ impl Catalog {
} }
let mut changed = false; let mut changed = false;
for row in rows { for row in rows {
changed = self.record_insert(table, row) || changed; changed = self.record_insert(table, row)? || changed;
} }
changed Ok(changed)
} }
/// 这一列第一次见到这个值就加一 /// 这一列第一次见到这个值就加一
@@ -291,16 +296,18 @@ impl Catalog {
/// 表改名到指定名字 /// 表改名到指定名字
pub fn rename_table(&mut self, from: &str, to: &str) -> io::Result<bool> { pub fn rename_table(&mut self, from: &str, to: &str) -> io::Result<bool> {
let Some(entry) = self.tables.remove(from) else { let Some(entry) = self.tables.get(from) else {
return Ok(false); return Ok(false);
}; };
if self.tables.contains_key(to) { if self.tables.contains_key(to) {
self.tables.insert(from.to_string(), entry);
return Err(io::Error::new( return Err(io::Error::new(
io::ErrorKind::AlreadyExists, io::ErrorKind::AlreadyExists,
format!("table already exists: {}", to), format!("table already exists: {}", to),
)); ));
} }
let version = next_schema_version(entry)?;
let mut entry = self.tables.remove(from).ok_or_else(|| io::Error::other("missing rename source"))?;
entry.schema_version = version;
self.seen.remove(from); self.seen.remove(from);
self.tables.insert(to.to_string(), entry); self.tables.insert(to.to_string(), entry);
Ok(true) Ok(true)
@@ -308,10 +315,21 @@ impl Catalog {
/// ALTER:整列定义换成新的,并清掉二级索引与统计 /// ALTER:整列定义换成新的,并清掉二级索引与统计
pub fn set_columns(&mut self, table: &str, columns: Vec<SchemaColumn>) -> io::Result<()> { pub fn set_columns(&mut self, table: &str, columns: Vec<SchemaColumn>) -> io::Result<()> {
self.set_columns_version(table, columns, None)
}
/// 用日志中的目标版本替换列定义
pub fn set_columns_version(&mut self, table: &str, columns: Vec<SchemaColumn>, version: Option<u64>) -> io::Result<()> {
let entry = self let entry = self
.tables .tables
.get_mut(table) .get_mut(table)
.ok_or_else(|| io::Error::new(io::ErrorKind::NotFound, format!("unknown table: {}", table)))?; .ok_or_else(|| io::Error::new(io::ErrorKind::NotFound, format!("unknown table: {}", table)))?;
if let Some(version) = version {
if version == 0 { return Err(io::Error::other("invalid WAL schema version")); }
entry.schema_version = version;
} else if entry.columns != columns {
entry.schema_version = next_schema_version(entry)?;
}
entry.columns = columns; entry.columns = columns;
entry.dropped_columns.clear(); entry.dropped_columns.clear();
entry.indexes.clear(); entry.indexes.clear();
@@ -321,9 +339,12 @@ impl Catalog {
} }
/// 老数据的列类型名规范化;返回有没有改动 /// 老数据的列类型名规范化;返回有没有改动
pub fn normalize_types(&mut self) -> bool { pub fn normalize_types(&mut self) -> io::Result<bool> {
let mut changed = false; let mut changed = false;
for entry in self.tables.values_mut() { for entry in self.tables.values_mut() {
if entry.columns.iter().any(|column| normalize_type(&column.ty) != column.ty) {
entry.schema_version = next_schema_version(entry)?;
}
for column in entry.columns.iter_mut() { for column in entry.columns.iter_mut() {
let fixed = normalize_type(&column.ty); let fixed = normalize_type(&column.ty);
if fixed != column.ty { if fixed != column.ty {
@@ -332,15 +353,26 @@ impl Catalog {
} }
} }
} }
changed Ok(changed)
} }
/// 删一列;之前没有也返回成功(重放幂等) /// 删一列;之前没有也返回成功(重放幂等)
pub fn remove_column(&mut self, table: &str, column: &str) -> io::Result<bool> { pub fn remove_column(&mut self, table: &str, column: &str) -> io::Result<bool> {
self.remove_column_version(table, column, None)
}
/// 用日志目标版本删除列定义
pub fn remove_column_version(&mut self, table: &str, column: &str, version: Option<u64>) -> io::Result<bool> {
let entry = self let entry = self
.tables .tables
.get_mut(table) .get_mut(table)
.ok_or_else(|| io::Error::new(io::ErrorKind::NotFound, format!("unknown table: {}", table)))?; .ok_or_else(|| io::Error::new(io::ErrorKind::NotFound, format!("unknown table: {}", table)))?;
if let Some(version) = version {
if version == 0 { return Err(io::Error::other("invalid WAL schema version")); }
entry.schema_version = version;
} else if entry.columns.iter().any(|c| c.name == column) {
entry.schema_version = next_schema_version(entry)?;
}
let had_column = { let had_column = {
let before = entry.columns.len(); let before = entry.columns.len();
entry.columns.retain(|c| c.name != column); entry.columns.retain(|c| c.name != column);
@@ -417,22 +449,24 @@ impl Catalog {
} }
/// 把行里"字典还不知道的列"补进来;返回有没有变化 /// 把行里"字典还不知道的列"补进来;返回有没有变化
fn add_missing_columns(entry: &mut TableSchema, row: &Row) -> bool { fn add_missing_columns(entry: &mut TableSchema, row: &Row) -> io::Result<bool> {
let mut changed = false; let additions: Vec<_> = row.iter().filter(|(name, _)|
for (k, v) in row { !entry.dropped_columns.contains(*name) && !entry.columns.iter().any(|c| &c.name == *name))
if entry.dropped_columns.contains(k) || entry.columns.iter().any(|c| &c.name == k) { .filter_map(|(name, value)| infer_type(value).map(|ty| SchemaColumn {
continue; name: name.clone(), ty, ..Default::default()
} })).collect();
if let Some(ty) = infer_type(v) { if additions.is_empty() {
entry.columns.push(SchemaColumn { return Ok(false);
name: k.clone(),
ty,
..Default::default()
});
changed = true;
}
} }
changed entry.schema_version = next_schema_version(entry)?;
entry.columns.extend(additions);
Ok(true)
}
/// 递增结构版本,耗尽时拒绝变更
fn next_schema_version(entry: &TableSchema) -> io::Result<u64> {
entry.schema_version.checked_add(1)
.ok_or_else(|| io::Error::other("catalog schema version exhausted"))
} }
/// 由 JSON 值猜列类型 /// 由 JSON 值猜列类型
+5 -40
View File
@@ -229,17 +229,17 @@ pub fn resolve(text: Option<&str>, path: Option<PathBuf>) -> Result<Loaded, Stri
DEFAULT_POOL_SIZE, DEFAULT_POOL_SIZE,
&file_origin, &file_origin,
); );
let storage = file.storage.unwrap_or_default();
let (data_dir, dir_origin) = pick( let (data_dir, dir_origin) = pick(
file.storage.as_ref().and_then(|s| s.data_dir.clone()), storage.data_dir,
default_data_dir().to_string_lossy().into_owned(), default_data_dir().to_string_lossy().into_owned(),
&file_origin, &file_origin,
); );
let (log_files, log_files_origin) = pick( let (log_files, log_files_origin) = pick(
file.storage.as_ref().and_then(|s| s.log_files.clone()), storage.log_files,
DEFAULT_LOG_FILES.to_string(), DEFAULT_LOG_FILES.to_string(),
&file_origin, &file_origin,
); );
// 管名已经没有了:存储不再是独立进程,管道/套接字那一层随 FFI 一起删掉
let (log_level, log_origin) = pick( let (log_level, log_origin) = pick(
file.log.and_then(|l| l.level), file.log.and_then(|l| l.level),
DEFAULT_LOG_LEVEL.to_string(), DEFAULT_LOG_LEVEL.to_string(),
@@ -248,9 +248,9 @@ pub fn resolve(text: Option<&str>, path: Option<PathBuf>) -> Result<Loaded, Stri
let data_dir = data_dir.trim().to_string(); let data_dir = data_dir.trim().to_string();
let log_files = log_files.trim().to_string(); let log_files = log_files.trim().to_string();
let log_level = log_level.trim().to_string(); let log_level = log_level.trim();
let log_level = Level::parse(&log_level) let log_level = Level::parse(log_level)
.ok_or_else(|| format!("log.level is not one of off/error/warn/info/debug: {}", log_level))?; .ok_or_else(|| format!("log.level is not one of off/error/warn/info/debug: {}", log_level))?;
if data_dir.is_empty() { if data_dir.is_empty() {
@@ -318,38 +318,3 @@ fn validate_layout(page_size: usize, btree_order: usize) -> Result<(), String> {
} }
Ok(()) Ok(())
} }
#[cfg(test)]
mod tests {
use super::*;
/// 别的层的分区不能被当成错误
#[test]
fn ignores_sections_owned_by_other_layers() {
let text = r#"
[page]
size = 8192
[storage]
data_dir = "../data"
[server]
listen_host = "127.0.0.1"
port = 7777
max_message = 1048576
[web]
port = 7778
"#;
let loaded = resolve(Some(text), Some(PathBuf::from("settings.toml"))).unwrap();
assert_eq!(loaded.config.page_size, 8192);
assert_eq!(loaded.config.data_dir, PathBuf::from("../data"));
}
/// 自己分区里的拼写错误仍然要报错
#[test]
fn still_rejects_typos_inside_its_own_sections() {
let text = "[page]\npage_size = 8192\n";
assert!(resolve(Some(text), None).is_err());
}
}
+18 -16
View File
@@ -74,14 +74,19 @@ pub unsafe extern "C" fn chusql_storage_close(handle: *mut Storage) {
/// 离线维护系统目录并返回 JSON /// 离线维护系统目录并返回 JSON
/// ///
/// # Safety /// # Safety
/// 输入为有效字符串;输出指针可写,响应使用 free 释放。 /// `config_path` 为 NULL 或有效 NUL 结尾字符串;请求字节在调用期间有效。
/// 输出指针可写且不与输入重叠;响应使用 free 释放。
#[unsafe(no_mangle)] #[unsafe(no_mangle)]
pub unsafe extern "C" fn chusql_storage_maintenance( pub unsafe extern "C" fn chusql_storage_maintenance(
config_path: *const c_char, request: *const u8, request_len: usize, config_path: *const c_char, request: *const u8, request_len: usize,
out: *mut *mut u8, out_len: *mut usize, out: *mut *mut u8, out_len: *mut usize,
) -> i32 { ) -> i32 {
if request.is_null() || out.is_null() || out_len.is_null() { set_error("invalid maintenance argument"); return ERR; } if !out.is_null() { unsafe { *out = ptr::null_mut(); } }
unsafe { *out = ptr::null_mut(); *out_len = 0; } if !out_len.is_null() { unsafe { *out_len = 0; } }
if request.is_null() || out.is_null() || out_len.is_null() || request_len > isize::MAX as usize {
set_error("invalid maintenance argument");
return ERR;
}
let result = catch_unwind(AssertUnwindSafe(|| { let result = catch_unwind(AssertUnwindSafe(|| {
let path = if config_path.is_null() { None } else { Some(unsafe { CStr::from_ptr(config_path) }.to_str().map_err(|e| e.to_string())?) }; let path = if config_path.is_null() { None } else { Some(unsafe { CStr::from_ptr(config_path) }.to_str().map_err(|e| e.to_string())?) };
let text = std::str::from_utf8(unsafe { slice::from_raw_parts(request, request_len) }).map_err(|e| e.to_string())?; let text = std::str::from_utf8(unsafe { slice::from_raw_parts(request, request_len) }).map_err(|e| e.to_string())?;
@@ -92,16 +97,16 @@ pub unsafe extern "C" fn chusql_storage_maintenance(
Ok(Err(err)) => { set_error(err); return ERR; } Ok(Err(err)) => { set_error(err); return ERR; }
Err(_) => { set_error("panic in system maintenance"); return ERR; } Err(_) => { set_error("panic in system maintenance"); return ERR; }
}; };
let mut buffer = response.into_bytes().into_boxed_slice(); let buffer = response.into_bytes().into_boxed_slice();
unsafe { *out = buffer.as_mut_ptr(); *out_len = buffer.len(); } unsafe { *out_len = buffer.len(); *out = Box::into_raw(buffer) as *mut u8; }
std::mem::forget(buffer);
OK OK
} }
/// 处理一条请求,响应缓冲须归还 /// 处理一条请求,响应缓冲须归还
/// ///
/// # Safety /// # Safety
/// `handle` 必须是有效句柄;`request` 指向 `request_len` 个字节;`out`/`out_len` 可写。 /// `handle` 在调用期间有效且不能并发关闭;请求字节在调用期间有效。
/// `out`/`out_len` 可写且不与输入重叠;响应使用 free 释放。
#[unsafe(no_mangle)] #[unsafe(no_mangle)]
pub unsafe extern "C" fn chusql_storage_request( pub unsafe extern "C" fn chusql_storage_request(
handle: *const Storage, handle: *const Storage,
@@ -116,7 +121,7 @@ pub unsafe extern "C" fn chusql_storage_request(
if !out_len.is_null() { if !out_len.is_null() {
unsafe { *out_len = 0 }; unsafe { *out_len = 0 };
} }
if handle.is_null() || request.is_null() || out.is_null() || out_len.is_null() { if handle.is_null() || request.is_null() || out.is_null() || out_len.is_null() || request_len > isize::MAX as usize {
set_error("invalid argument"); set_error("invalid argument");
return ERR; return ERR;
} }
@@ -139,13 +144,10 @@ pub unsafe extern "C" fn chusql_storage_request(
} }
}; };
let mut buffer = response.into_bytes().into_boxed_slice(); let buffer = response.into_bytes().into_boxed_slice();
let ptr = buffer.as_mut_ptr();
let len = buffer.len();
std::mem::forget(buffer);
unsafe { unsafe {
*out = ptr; *out_len = buffer.len();
*out_len = len; *out = Box::into_raw(buffer) as *mut u8;
} }
OK OK
} }
@@ -153,7 +155,7 @@ pub unsafe extern "C" fn chusql_storage_request(
/// 归还响应缓冲 /// 归还响应缓冲
/// ///
/// # Safety /// # Safety
/// `data`/`len` 必须是 chusql_storage_request 原样返回且未被释放过的一对值。 /// `data`/`len` 为 request 或 maintenance 原样返回且未释放的一对值。
#[unsafe(no_mangle)] #[unsafe(no_mangle)]
pub unsafe extern "C" fn chusql_storage_free(data: *mut u8, len: usize) { pub unsafe extern "C" fn chusql_storage_free(data: *mut u8, len: usize) {
if data.is_null() { if data.is_null() {
@@ -168,7 +170,7 @@ pub unsafe extern "C" fn chusql_storage_free(data: *mut u8, len: usize) {
/// 取本线程最近的失败信息 /// 取本线程最近的失败信息
/// ///
/// # Safety /// # Safety
/// `out_len` 可写,或为 NULL。 /// `out_len` 可写,或为 NULL;返回字节仅在本线程下次设置错误前有效,不能释放。
#[unsafe(no_mangle)] #[unsafe(no_mangle)]
pub unsafe extern "C" fn chusql_storage_last_error(out_len: *mut usize) -> *const u8 { pub unsafe extern "C" fn chusql_storage_last_error(out_len: *mut usize) -> *const u8 {
LAST_ERROR.with(|slot| { LAST_ERROR.with(|slot| {
+32 -1
View File
@@ -122,6 +122,7 @@ pub enum Request {
#[serde(default)] #[serde(default)]
columns: Option<Vec<String>>, columns: Option<Vec<String>>,
}, },
ValidateWrite { table: String },
/// 分片扫描:第 shard 片只读总页数按 shards 均分后的那一段 /// 分片扫描:第 shard 片只读总页数按 shards 均分后的那一段
ScanShard { ScanShard {
table: String, table: String,
@@ -231,7 +232,7 @@ impl Request {
/// 普通表操作的统一访问边界 /// 普通表操作的统一访问边界
pub fn table(&self) -> Option<&str> { pub fn table(&self) -> Option<&str> {
match self { match self {
Self::Scan { table, .. } | Self::ScanShard { table, .. } Self::Scan { table, .. } | Self::ScanShard { table, .. } | Self::ValidateWrite { table }
| Self::Insert { table, .. } | Self::Insert { table, .. }
| Self::InsertBatch { table, .. } | Self::DeleteKeys { table, .. } | Self::InsertBatch { table, .. } | Self::DeleteKeys { table, .. }
| Self::LookupByIndex { table, .. } | Self::ReplaceAll { table, .. } | Self::LookupByIndex { table, .. } | Self::ReplaceAll { table, .. }
@@ -283,12 +284,15 @@ fn default_id_column() -> String {
#[derive(Debug, Serialize, Deserialize)] #[derive(Debug, Serialize, Deserialize)]
#[serde(tag = "status", rename_all = "snake_case")] #[serde(tag = "status", rename_all = "snake_case")]
pub enum Response { pub enum Response {
Guarded { response: Box<Response> },
Accounts { accounts: Vec<Account> }, Accounts { accounts: Vec<Account> },
Pong, Pong,
Rows { rows: Vec<Row> }, Rows { rows: Vec<Row> },
Tables { tables: Vec<String> }, Tables { tables: Vec<String> },
Schema { Schema {
table: String, table: String,
#[serde(default, serialize_with = "serialize_version", deserialize_with = "deserialize_version")]
schema_version: u64,
columns: Vec<SchemaColumn>, columns: Vec<SchemaColumn>,
#[serde(default)] #[serde(default)]
row_count: u64, row_count: u64,
@@ -310,6 +314,15 @@ pub enum Response {
Object { database_id: u64, object_id: Option<u64> }, Object { database_id: u64, object_id: Option<u64> },
} }
#[derive(Debug, Deserialize)]
pub struct BoundSchema {
pub table: String,
pub database_id: Option<String>,
pub object_id: Option<String>,
pub schema_version: Option<String>,
pub columns: Vec<SchemaColumn>,
}
#[derive(Debug, Clone, Serialize, Deserialize)] #[derive(Debug, Clone, Serialize, Deserialize)]
pub struct TableSchemaWire { pub struct TableSchemaWire {
pub table: String, pub table: String,
@@ -317,6 +330,8 @@ pub struct TableSchemaWire {
pub database_id: u64, pub database_id: u64,
#[serde(default)] #[serde(default)]
pub object_id: u64, pub object_id: u64,
#[serde(default, serialize_with = "serialize_version", deserialize_with = "deserialize_version")]
pub schema_version: u64,
pub columns: Vec<SchemaColumn>, pub columns: Vec<SchemaColumn>,
#[serde(default)] #[serde(default)]
pub row_count: u64, pub row_count: u64,
@@ -325,3 +340,19 @@ pub struct TableSchemaWire {
#[serde(default)] #[serde(default)]
pub stats: Vec<ColumnStatWire>, pub stats: Vec<ColumnStatWire>,
} }
/// 将结构版本编码成精确十进制字符串
fn serialize_version<S: serde::Serializer>(version: &u64, serializer: S) -> Result<S::Ok, S::Error> {
serializer.serialize_str(&version.to_string())
}
/// 读取精确版本并兼容旧数值载荷
fn deserialize_version<'de, D: serde::Deserializer<'de>>(deserializer: D) -> Result<u64, D::Error> {
let value = serde_json::Value::deserialize(deserializer)?;
match value {
serde_json::Value::String(s) if !s.is_empty() && s.len() <= 20 && s.bytes().all(|c| c.is_ascii_digit()) =>
s.parse().map_err(serde::de::Error::custom),
serde_json::Value::Number(n) => n.as_u64().ok_or_else(|| serde::de::Error::custom("invalid schema version")),
_ => Err(serde::de::Error::custom("invalid schema version")),
}
}
+140 -38
View File
@@ -236,9 +236,9 @@ impl Server {
fn apply_op(&self, op: &WalOp) -> std::io::Result<()> { fn apply_op(&self, op: &WalOp) -> std::io::Result<()> {
match op { match op {
WalOp::Commit => Ok(()), WalOp::Commit => Ok(()),
WalOp::HideColumn { table, column } => { WalOp::HideColumn { table, column, schema_version } => {
let mut c = self.catalog.lock().map_err(|_| std::io::Error::other("catalog lock poisoned"))?; let mut c = self.catalog.lock().map_err(|_| std::io::Error::other("catalog lock poisoned"))?;
c.remove_column(table, column)?; c.remove_column_version(table, column, *schema_version)?;
c.save(self.catalog_path())?; c.save(self.catalog_path())?;
drop(c); drop(c);
if let Some(handle) = self.tables.lock().map_err(|_| std::io::Error::other("table lock poisoned"))?.get(table) { if let Some(handle) = self.tables.lock().map_err(|_| std::io::Error::other("table lock poisoned"))?.get(table) {
@@ -257,7 +257,7 @@ impl Server {
})?; })?;
let mut c = self.catalog.lock().unwrap(); let mut c = self.catalog.lock().unwrap();
c.mark_compacted(table)?; c.mark_compacted(table)?;
c.rebuild_stats(table, rows); c.rebuild_stats(table, rows)?;
c.save(self.catalog_path()) c.save(self.catalog_path())
} }
WalOp::Accounts { accounts, removed, migrate_roles } => { WalOp::Accounts { accounts, removed, migrate_roles } => {
@@ -287,20 +287,20 @@ impl Server {
} }
let mut c = self.catalog.lock().map_err(|_| std::io::Error::other("catalog lock poisoned"))?; let mut c = self.catalog.lock().map_err(|_| std::io::Error::other("catalog lock poisoned"))?;
declare_system_schema(&mut c, &rows)?; declare_system_schema(&mut c, &rows)?;
c.rebuild_stats(IDENTITIES_TABLE, &identities); c.rebuild_stats(IDENTITIES_TABLE, &identities)?;
c.set_columns(IDENTITIES_TABLE, identity_columns())?; c.set_columns(IDENTITIES_TABLE, identity_columns())?;
c.rebuild_stats(IDENTITIES_TABLE, &identities); c.rebuild_stats(IDENTITIES_TABLE, &identities)?;
c.mark_system(IDENTITIES_TABLE)?; c.mark_system(IDENTITIES_TABLE)?;
c.add_index(IDENTITIES_TABLE, "user")?; c.add_index(IDENTITIES_TABLE, "user")?;
c.identity_high_water = c.identity_high_water.max(accounts.iter().map(|a| a.id).max().unwrap_or(0)); c.identity_high_water = c.identity_high_water.max(accounts.iter().map(|a| a.id).max().unwrap_or(0));
if has_roles && *migrate_roles { c.rebuild_stats(legacy_roles, &[]); } if has_roles && *migrate_roles { c.rebuild_stats(legacy_roles, &[])?; }
for (table, records) in cleaned { c.rebuild_stats(table, &records); } for (table, records) in cleaned { c.rebuild_stats(table, &records)?; }
c.save(self.catalog_path()) c.save(self.catalog_path())
} }
WalOp::Insert { table, row } => { WalOp::Insert { table, row } => {
self.with_table(table, |t| t.insert_row(row))?; self.with_table(table, |t| t.insert_row(row))?;
let mut c = self.catalog.lock().unwrap(); let mut c = self.catalog.lock().unwrap();
if c.record_insert(table, row) { if c.record_insert(table, row)? {
c.save(self.catalog_path())?; c.save(self.catalog_path())?;
} }
Ok(()) Ok(())
@@ -310,7 +310,7 @@ impl Server {
let mut c = self.catalog.lock().unwrap(); let mut c = self.catalog.lock().unwrap();
let mut changed = false; let mut changed = false;
for r in rows { for r in rows {
if c.record_insert(table, r) { if c.record_insert(table, r)? {
changed = true; changed = true;
} }
} }
@@ -328,17 +328,17 @@ impl Server {
WalOp::ReplaceAll { table, rows } => { WalOp::ReplaceAll { table, rows } => {
self.with_table(table, |t| t.replace_all(rows))?; self.with_table(table, |t| t.replace_all(rows))?;
let mut c = self.catalog.lock().unwrap(); let mut c = self.catalog.lock().unwrap();
c.rebuild_stats(table, rows); c.rebuild_stats(table, rows)?;
c.save(self.catalog_path()) c.save(self.catalog_path())
} }
WalOp::DropColumn { table, column, rows } => { WalOp::DropColumn { table, column, rows, schema_version } => {
self.with_table(table, |t| { self.with_table(table, |t| {
t.detach_index(column); t.detach_index(column);
t.replace_all(rows) t.replace_all(rows)
})?; })?;
let mut c = self.catalog.lock().unwrap(); let mut c = self.catalog.lock().unwrap();
c.remove_column(table, column)?; c.remove_column_version(table, column, *schema_version)?;
c.rebuild_stats(table, rows); c.rebuild_stats(table, rows)?;
c.save(self.catalog_path())?; c.save(self.catalog_path())?;
drop(c); drop(c);
let _ = std::fs::remove_file(self.index_path(table, column)); let _ = std::fs::remove_file(self.index_path(table, column));
@@ -374,7 +374,7 @@ impl Server {
} }
WalOp::CreateIndex { table, column } => self.apply_create_index(table, column), WalOp::CreateIndex { table, column } => self.apply_create_index(table, column),
WalOp::DropIndex { table, column } => self.apply_drop_index(table, column), WalOp::DropIndex { table, column } => self.apply_drop_index(table, column),
WalOp::ReplaceSchema { table, columns, rows } => { WalOp::ReplaceSchema { table, columns, rows, schema_version } => {
let old_indexes: Vec<String> = { let old_indexes: Vec<String> = {
let c = self.catalog.lock().map_err(|_| std::io::Error::other("catalog lock poisoned"))?; let c = self.catalog.lock().map_err(|_| std::io::Error::other("catalog lock poisoned"))?;
c.describe(table) c.describe(table)
@@ -389,8 +389,8 @@ impl Server {
t.replace_all(rows) t.replace_all(rows)
})?; })?;
let mut c = self.catalog.lock().unwrap(); let mut c = self.catalog.lock().unwrap();
c.set_columns(table, columns.clone())?; c.set_columns_version(table, columns.clone(), *schema_version)?;
c.rebuild_stats(table, rows); c.rebuild_stats(table, rows)?;
c.save(self.catalog_path())?; c.save(self.catalog_path())?;
drop(c); drop(c);
for col in old_indexes { for col in old_indexes {
@@ -483,7 +483,7 @@ impl Server {
match op { match op {
WalOp::Insert { table, row } => validate(table, std::slice::from_ref(row))?, WalOp::Insert { table, row } => validate(table, std::slice::from_ref(row))?,
WalOp::InsertBatch { table, rows } | WalOp::ReplaceAll { table, rows } => validate(table, rows)?, WalOp::InsertBatch { table, rows } | WalOp::ReplaceAll { table, rows } => validate(table, rows)?,
WalOp::HideColumn { table, column } WalOp::HideColumn { table, column, .. }
if !c.describe(table).is_some_and(|s| s.columns.iter().any(|col| &col.name == column)) => if !c.describe(table).is_some_and(|s| s.columns.iter().any(|col| &col.name == column)) =>
{ {
return Err(std::io::Error::other(format!("unknown column: {column}"))); return Err(std::io::Error::other(format!("unknown column: {column}")));
@@ -554,6 +554,29 @@ impl Server {
} }
} }
} }
if ops.iter().any(|op| matches!(op, WalOp::HideColumn { .. } | WalOp::DropColumn { .. } | WalOp::ReplaceSchema { .. })) {
let mut preview = self.catalog.lock().map_err(|_| std::io::Error::other("catalog lock poisoned"))?.clone();
for op in ops.to_mut() {
match op {
WalOp::HideColumn { table, column, schema_version }
| WalOp::DropColumn { table, column, schema_version, .. } => {
preview.remove_column(table, column)?;
*schema_version = Some(preview.describe(table).ok_or_else(|| std::io::Error::other("missing schema version"))?.schema_version.max(1));
}
WalOp::ReplaceSchema { table, columns, schema_version, .. } => {
preview.set_columns(table, columns.clone())?;
*schema_version = Some(preview.describe(table).ok_or_else(|| std::io::Error::other("missing schema version"))?.schema_version.max(1));
}
WalOp::CreateTable { table, columns, object_id } => preview.create_table_with_id(table, columns.clone(), *object_id)?,
WalOp::DropTable { table } => preview.drop_table(table)?,
WalOp::Insert { table, row } => preview.ensure_columns(table, row)?,
WalOp::InsertBatch { table, rows } | WalOp::ReplaceAll { table, rows } => {
for row in rows { preview.ensure_columns(table, row)?; }
}
_ => {}
}
}
}
let commit_lsn = wal.append_group(&ops)?; let commit_lsn = wal.append_group(&ops)?;
self.recovery_required.store(true, Ordering::Release); self.recovery_required.store(true, Ordering::Release);
for op in ops.iter() { for op in ops.iter() {
@@ -683,9 +706,10 @@ impl Server {
}); });
Ok(!present) Ok(!present)
} }
WalOp::HideColumn { table, column } => { WalOp::HideColumn { table, column, schema_version } => {
let c = self.catalog.lock().unwrap(); let c = self.catalog.lock().unwrap();
Ok(c.describe(table).is_some_and(|s| !s.columns.iter().any(|col| &col.name == column))) Ok(c.describe(table).is_some_and(|s| !s.columns.iter().any(|col| &col.name == column)
&& schema_version.is_none_or(|version| s.schema_version == version)))
} }
WalOp::CreateTable { table, object_id, .. } => { WalOp::CreateTable { table, object_id, .. } => {
let catalog = self.catalog.lock().map_err(|_| std::io::Error::other("catalog lock poisoned"))?; let catalog = self.catalog.lock().map_err(|_| std::io::Error::other("catalog lock poisoned"))?;
@@ -739,7 +763,7 @@ impl Server {
} }
let rows = self.with_table(&table, |t| t.scan())?; let rows = self.with_table(&table, |t| t.scan())?;
let mut c = self.catalog.lock().unwrap(); let mut c = self.catalog.lock().unwrap();
c.rebuild_stats(&table, &rows); c.rebuild_stats(&table, &rows)?;
touched = true; touched = true;
} }
if touched { if touched {
@@ -791,7 +815,7 @@ impl Server {
.catalog .catalog
.lock() .lock()
.map_err(|_| std::io::Error::other("catalog lock poisoned"))?; .map_err(|_| std::io::Error::other("catalog lock poisoned"))?;
if catalog.normalize_types() { if catalog.normalize_types()? {
catalog.save(self.catalog_path())?; catalog.save(self.catalog_path())?;
} }
Ok(()) Ok(())
@@ -954,6 +978,7 @@ impl Server {
let op = WalOp::HideColumn { let op = WalOp::HideColumn {
table: table.to_string(), table: table.to_string(),
column: column.to_string(), column: column.to_string(),
schema_version: None,
}; };
self.write_via_wal(&op) self.write_via_wal(&op)
} }
@@ -1021,17 +1046,12 @@ impl Server {
} }
} }
/// 系统目录里账号表已登记 /// 读取系统初始化状态与检查点 LSN
fn system_initialized(&self) -> bool { fn system_status(&self) -> std::io::Result<Response> {
self.catalog let initialized = self.catalog.lock().map_err(|_| std::io::Error::other("catalog lock poisoned"))?
.lock() .describe(USERS_TABLE).is_some_and(|schema| schema.system);
.map(|c| c.describe(USERS_TABLE).is_some_and(|schema| schema.system)) let last_lsn = self.wal.read_checkpoint()?.unwrap_or(0);
.unwrap_or(false) Ok(Response::System { initialized, last_lsn })
}
/// 最近一次落盘的检查点 LSN
fn last_checkpoint(&self) -> u64 {
self.wal.read_checkpoint().ok().flatten().unwrap_or(0)
} }
/// 读账号表;表没登记或数据文件缺失都算错 /// 读账号表;表没登记或数据文件缺失都算错
@@ -1315,6 +1335,32 @@ 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")); }
if blocked_table(table) { return Err(Error::other("reserved system table")); }
let catalog = self.catalog.lock().map_err(|_| Error::other("catalog lock poisoned"))?;
let actual = catalog.describe(table).ok_or_else(|| Error::other(format!("bound query schema changed: {}", expected.table)))?;
match (&expected.database_id, &expected.object_id) {
(Some(database), Some(object)) => {
if parse_bound_number(database)? != catalog.database_id || parse_bound_number(object)? != actual.object_id {
return Err(Error::other(format!("bound query object changed: {}", expected.table)));
}
}
(None, None) => {}
_ => return Err(Error::other("incomplete bound object identity")),
}
if let Some(version) = &expected.schema_version
&& parse_bound_number(version)? != actual.schema_version {
return Err(Error::other(format!("bound query schema changed: {}", expected.table)));
}
if expected.columns != actual.columns {
return Err(Error::other(format!("bound query schema changed: {}", expected.table)));
}
Ok(())
}
/// 持门后分发一条请求 /// 持门后分发一条请求
fn dispatch(&self, req: Request) -> Response { fn dispatch(&self, req: Request) -> Response {
if self.recovery_required.load(Ordering::Acquire) && !matches!(req, Request::Ping) { if self.recovery_required.load(Ordering::Acquire) && !matches!(req, Request::Ping) {
@@ -1332,6 +1378,7 @@ impl Server {
} }
} }
match req { match req {
Request::ValidateWrite { .. } => Response::Ok,
Request::BootstrapTypes { types } => match self.bootstrap_types(types) { Request::BootstrapTypes { types } => match self.bootstrap_types(types) {
Ok(rows) => Response::Rows { rows }, Ok(rows) => Response::Rows { rows },
Err(e) => Response::Error { message: e.to_string() }, Err(e) => Response::Error { message: e.to_string() },
@@ -1346,12 +1393,12 @@ impl Server {
} }
} }
Request::BootstrapSystem { user, password_hash } => { Request::BootstrapSystem { user, password_hash } => {
match self.bootstrap_system(user.as_deref(), password_hash.as_deref()) { match self.bootstrap_system(user.as_deref(), password_hash.as_deref()).and_then(|_| self.system_status()) {
Ok(_) => Response::System { initialized: true, last_lsn: self.last_checkpoint() }, Ok(response) => response,
Err(e) => Response::Error { message: e.to_string() }, Err(e) => Response::Error { message: e.to_string() },
} }
} }
Request::SystemStatus => Response::System { initialized: self.system_initialized(), last_lsn: self.last_checkpoint() }, Request::SystemStatus => self.system_status().unwrap_or_else(|e| Response::Error { message: e.to_string() }),
Request::Ping => { Request::Ping => {
log_debug!(request, "ping"); log_debug!(request, "ping");
Response::Pong Response::Pong
@@ -1563,6 +1610,7 @@ impl Server {
table: name.to_string(), table: name.to_string(),
database_id: c.database_id, database_id: c.database_id,
object_id: ts.object_id, object_id: ts.object_id,
schema_version: ts.schema_version,
columns: ts.columns.clone(), columns: ts.columns.clone(),
row_count: ts.row_count, row_count: ts.row_count,
indexes: index_wires(ts), indexes: index_wires(ts),
@@ -1576,6 +1624,7 @@ impl Server {
log_debug!(request, "describe_table table={}", table); log_debug!(request, "describe_table table={}", table);
match self.describe_table(&table) { match self.describe_table(&table) {
Ok((cols, count, indexes, stats)) => Response::Schema { Ok((cols, count, indexes, stats)) => Response::Schema {
schema_version: self.catalog.lock().unwrap().describe(&table).map_or(0, |s| s.schema_version),
table, table,
columns: cols, columns: cols,
row_count: count, row_count: count,
@@ -1718,7 +1767,7 @@ impl Server {
Request::ReplaceSchema { table, columns, rows } => { Request::ReplaceSchema { table, columns, rows } => {
log_debug!(request, "replace_schema table={} cols={}", table, columns.len()); log_debug!(request, "replace_schema table={} cols={}", table, columns.len());
let tname = table.clone(); let tname = table.clone();
let op = WalOp::ReplaceSchema { table, columns, rows }; let op = WalOp::ReplaceSchema { table, columns, rows, schema_version: None };
match self.write_via_wal(&op) { match self.write_via_wal(&op) {
Ok(()) => Response::Ok, Ok(()) => Response::Ok,
Err(e) => { Err(e) => {
@@ -1843,9 +1892,9 @@ fn identity_columns() -> Vec<SchemaColumn> {
/// 把系统表写进字典 /// 把系统表写进字典
fn declare_system_schema(catalog: &mut Catalog, rows: &[Row]) -> std::io::Result<()> { fn declare_system_schema(catalog: &mut Catalog, rows: &[Row]) -> std::io::Result<()> {
catalog.rebuild_stats(USERS_TABLE, rows); catalog.rebuild_stats(USERS_TABLE, rows)?;
catalog.set_columns(USERS_TABLE, users_columns())?; catalog.set_columns(USERS_TABLE, users_columns())?;
catalog.rebuild_stats(USERS_TABLE, rows); catalog.rebuild_stats(USERS_TABLE, rows)?;
catalog.mark_system(USERS_TABLE)?; catalog.mark_system(USERS_TABLE)?;
Ok(()) Ok(())
} }
@@ -2142,6 +2191,17 @@ impl Databases {
fn request(&self, mut value: serde_json::Value) -> std::io::Result<Response> { fn request(&self, mut value: serde_json::Value) -> std::io::Result<Response> {
use std::io::Error; use std::io::Error;
let method = value.get("method").and_then(|v| v.as_str()).unwrap_or("").to_string(); let method = value.get("method").and_then(|v| v.as_str()).unwrap_or("").to_string();
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") { let name = match value.get("database") {
None => String::new(), None => String::new(),
Some(serde_json::Value::String(s)) => s.to_ascii_lowercase(), Some(serde_json::Value::String(s)) => s.to_ascii_lowercase(),
@@ -2263,6 +2323,8 @@ impl Databases {
selected = database.to_ascii_lowercase(); selected = database.to_ascii_lowercase();
value["table"] = serde_json::Value::String(table.to_string()); value["table"] = serde_json::Value::String(table.to_string());
} }
let guard: Option<Vec<crate::protocol::BoundSchema>> = value.get("schema_guard")
.map(|guard| serde_json::from_value(guard.clone()).map_err(Error::other)).transpose()?;
let request: Request = serde_json::from_value(value).map_err(Error::other)?; let request: Request = serde_json::from_value(value).map_err(Error::other)?;
let global = matches!(request, Request::AccountsList | Request::CatalogManage { .. } | Request::AccountCreate { .. } let global = matches!(request, Request::AccountsList | Request::CatalogManage { .. } | Request::AccountCreate { .. }
| Request::IdentityInitialize { .. } | Request::RoleCreate { .. } | Request::IdentityAlter { .. } | Request::IdentityInitialize { .. } | Request::RoleCreate { .. } | Request::IdentityAlter { .. }
@@ -2273,16 +2335,56 @@ impl Databases {
if !global && selected.is_empty() { return Err(Error::other("no database selected")); } if !global && selected.is_empty() { return Err(Error::other("no database selected")); }
let server = if global || selected == SYSTEM_DATABASE { Arc::clone(&self.system) } let server = if global || selected == SYSTEM_DATABASE { Arc::clone(&self.system) }
else { Arc::clone(named.get(&selected).ok_or_else(|| Error::other("unknown database"))?) }; else { Arc::clone(named.get(&selected).ok_or_else(|| Error::other("unknown database"))?) };
if let Some(bindings) = guard {
let mut servers = std::collections::BTreeMap::from([(selected.clone(), Arc::clone(&server))]);
let mut dependencies = Vec::new();
for binding in bindings {
let (database, table) = binding.table.split_once('.').unwrap_or((&selected, &binding.table));
let database = database.to_ascii_lowercase();
if !valid_database(&database) { return Err(Error::other("invalid bound database name")); }
let dependency = if database == SYSTEM_DATABASE { Arc::clone(&self.system) }
else { Arc::clone(named.get(&database).ok_or_else(|| Error::other("bound query database changed"))?) };
servers.insert(database.clone(), dependency);
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 table operation has no schema guard"));
}
drop(named);
// 全部库按名称取门;写入目标独占,其他依赖共享。
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)?;
}
return Ok(Response::Guarded { response: Box::new(server.dispatch(request)) });
}
drop(named); drop(named);
Ok(server.handle_request(request)) Ok(server.handle_request(request))
} }
} }
/// 读取守卫中的精确十进制编号
fn parse_bound_number(value: &str) -> std::io::Result<u64> {
if value.is_empty() || value.len() > 20 || !value.bytes().all(|c| c.is_ascii_digit()) {
return Err(std::io::Error::other("invalid bound catalog number"));
}
value.parse().map_err(std::io::Error::other)
}
/// 只读表页的请求可与其它读并发,其余独占 /// 只读表页的请求可与其它读并发,其余独占
fn concurrent_read(req: &Request) -> bool { fn concurrent_read(req: &Request) -> bool {
matches!( matches!(
req, req,
Request::Scan { .. } Request::Scan { .. }
| Request::ValidateWrite { .. }
| Request::ScanShard { .. } | Request::ScanShard { .. }
| Request::LookupByIndex { .. } | Request::LookupByIndex { .. }
| Request::RangeByIndex { .. } | Request::RangeByIndex { .. }
+31 -7
View File
@@ -29,7 +29,7 @@ const OP_DROP_INDEX: u8 = 14;
#[derive(Debug, Clone, Serialize, Deserialize, PartialEq)] #[derive(Debug, Clone, Serialize, Deserialize, PartialEq)]
pub enum WalOp { pub enum WalOp {
HideColumn { table: String, column: String }, HideColumn { table: String, column: String, schema_version: Option<u64> },
Compact { table: String, rows: Vec<Row> }, Compact { table: String, rows: Vec<Row> },
Accounts { accounts: Vec<Account>, removed: Vec<String>, migrate_roles: bool }, Accounts { accounts: Vec<Account>, removed: Vec<String>, migrate_roles: bool },
Insert { Insert {
@@ -51,11 +51,13 @@ pub enum WalOp {
DropColumn { DropColumn {
table: String, table: String,
column: String, column: String,
schema_version: Option<u64>,
rows: Vec<Row>, rows: Vec<Row>,
}, },
ReplaceSchema { ReplaceSchema {
table: String, table: String,
columns: Vec<SchemaColumn>, columns: Vec<SchemaColumn>,
schema_version: Option<u64>,
rows: Vec<Row>, rows: Vec<Row>,
}, },
CreateTable { CreateTable {
@@ -78,15 +80,26 @@ pub enum WalOp {
Commit, Commit,
} }
#[derive(Debug, Serialize, Deserialize)]
struct HideColumnPayload {
column: String,
#[serde(default)]
schema_version: Option<u64>,
}
#[derive(Debug, Serialize, Deserialize)] #[derive(Debug, Serialize, Deserialize)]
struct DropColumnPayload { struct DropColumnPayload {
column: String, column: String,
#[serde(default)]
schema_version: Option<u64>,
rows: Vec<Row>, rows: Vec<Row>,
} }
#[derive(Debug, Serialize, Deserialize)] #[derive(Debug, Serialize, Deserialize)]
struct ReplaceSchemaPayload { struct ReplaceSchemaPayload {
columns: Vec<SchemaColumn>, columns: Vec<SchemaColumn>,
#[serde(default)]
schema_version: Option<u64>,
rows: Vec<Row>, rows: Vec<Row>,
} }
@@ -379,8 +392,8 @@ fn truncate(f: &mut File) -> io::Result<()> {
/// 把操作编成字节 /// 把操作编成字节
fn encode(op: &WalOp, lsn: u64) -> io::Result<Vec<u8>> { fn encode(op: &WalOp, lsn: u64) -> io::Result<Vec<u8>> {
let (op_type, table, payload) = match op { let (op_type, table, payload) = match op {
WalOp::HideColumn { table, column } => (OP_HIDE_COLUMN, table.clone(), WalOp::HideColumn { table, column, schema_version } => (OP_HIDE_COLUMN, table.clone(),
serde_json::to_vec(column).map_err(io::Error::other)?), serde_json::to_vec(&serde_json::json!({"column":column,"schema_version":schema_version})).map_err(io::Error::other)?),
WalOp::Compact { table, rows } => { WalOp::Compact { table, rows } => {
let p = serde_json::to_vec(rows).map_err(io::Error::other)?; let p = serde_json::to_vec(rows).map_err(io::Error::other)?;
(OP_COMPACT, table.clone(), p) (OP_COMPACT, table.clone(), p)
@@ -403,17 +416,19 @@ fn encode(op: &WalOp, lsn: u64) -> io::Result<Vec<u8>> {
let p = serde_json::to_vec(rows).map_err(io::Error::other)?; let p = serde_json::to_vec(rows).map_err(io::Error::other)?;
(OP_REPLACE_ALL, table.clone(), p) (OP_REPLACE_ALL, table.clone(), p)
} }
WalOp::DropColumn { table, column, rows } => { WalOp::DropColumn { table, column, rows, schema_version } => {
let p = serde_json::to_vec(&DropColumnPayload { let p = serde_json::to_vec(&DropColumnPayload {
column: column.clone(), column: column.clone(),
schema_version: *schema_version,
rows: rows.clone(), rows: rows.clone(),
}) })
.map_err(io::Error::other)?; .map_err(io::Error::other)?;
(OP_DROP_COLUMN, table.clone(), p) (OP_DROP_COLUMN, table.clone(), p)
} }
WalOp::ReplaceSchema { table, columns, rows } => { WalOp::ReplaceSchema { table, columns, rows, schema_version } => {
let p = serde_json::to_vec(&ReplaceSchemaPayload { let p = serde_json::to_vec(&ReplaceSchemaPayload {
columns: columns.clone(), columns: columns.clone(),
schema_version: *schema_version,
rows: rows.clone(), rows: rows.clone(),
}) })
.map_err(io::Error::other)?; .map_err(io::Error::other)?;
@@ -474,9 +489,16 @@ fn decode_body(body: &[u8]) -> Result<(u64, WalOp), String> {
let op = match op_type { let op = match op_type {
OP_COMMIT => WalOp::Commit, OP_COMMIT => WalOp::Commit,
OP_HIDE_COLUMN => { OP_HIDE_COLUMN => {
let column = serde_json::from_slice(payload) let value: serde_json::Value = serde_json::from_slice(payload)
.map_err(|e| format!("bad hide_column payload: {e}"))?; .map_err(|e| format!("bad hide_column payload: {e}"))?;
WalOp::HideColumn { table, column } let (column, schema_version) = if let Some(column) = value.as_str() {
(column.to_string(), None)
} else {
let p: HideColumnPayload = serde_json::from_value(value)
.map_err(|e| format!("bad hide_column payload: {e}"))?;
(p.column, p.schema_version)
};
WalOp::HideColumn { table, column, schema_version }
} }
OP_COMPACT => { OP_COMPACT => {
let rows: Vec<Row> = serde_json::from_slice(payload) let rows: Vec<Row> = serde_json::from_slice(payload)
@@ -521,6 +543,7 @@ fn decode_body(body: &[u8]) -> Result<(u64, WalOp), String> {
WalOp::DropColumn { WalOp::DropColumn {
table, table,
column: p.column, column: p.column,
schema_version: p.schema_version,
rows: p.rows, rows: p.rows,
} }
} }
@@ -530,6 +553,7 @@ fn decode_body(body: &[u8]) -> Result<(u64, WalOp), String> {
WalOp::ReplaceSchema { WalOp::ReplaceSchema {
table, table,
columns: p.columns, columns: p.columns,
schema_version: p.schema_version,
rows: p.rows, rows: p.rows,
} }
} }
+59
View File
@@ -1,9 +1,45 @@
use chusql_core_storage::btree::{fits_in_page, DiskBTree, MAX_KEY_BYTES}; use chusql_core_storage::btree::{fits_in_page, DiskBTree, MAX_KEY_BYTES};
use chusql_core_storage::config::{DEFAULT_BTREE_ORDER, DEFAULT_PAGE_SIZE}; use chusql_core_storage::config::{DEFAULT_BTREE_ORDER, DEFAULT_PAGE_SIZE};
use chusql_core_storage::page::DEFAULT_POOL_SIZE; use chusql_core_storage::page::DEFAULT_POOL_SIZE;
use std::io::{ErrorKind, Seek, SeekFrom, Write};
// B+ 树测试:字节键、重复键、范围扫描、重开与配置校验。 // B+ 树测试:字节键、重复键、范围扫描、重开与配置校验。
/// 损坏节点返回数据错误且重复读取不 panic
#[test]
fn malformed_node_fields_return_invalid_data() {
let dir = tempfile::tempdir().unwrap();
let path = dir.path().join("corrupt.idx");
{
let mut tree = open(dir.path(), "corrupt.idx");
tree.insert(b"x", 1).unwrap();
tree.insert(b"y", 2).unwrap();
}
let original = std::fs::read(&path).unwrap();
let cell = u16::from_le_bytes([original[DEFAULT_PAGE_SIZE + 11], original[DEFAULT_PAGE_SIZE + 12]]) as usize;
for (name, offset, bytes) in [
("slot count", 1, vec![255, 255]),
("node kind", 0, vec![2]),
("cell overlaps slots", 11, vec![0, 0]),
("cell beyond page", 11, vec![255, 15]),
("overlapping cells", 13, (cell as u16).to_le_bytes().to_vec()),
("key length", cell, vec![255, 255]),
("key order", cell + 2, vec![b'z']),
("zero child", 0, vec![1]),
] {
std::fs::write(&path, &original).unwrap();
let mut file = std::fs::OpenOptions::new().write(true).open(&path).unwrap();
file.seek(SeekFrom::Start((DEFAULT_PAGE_SIZE + offset) as u64)).unwrap();
file.write_all(&bytes).unwrap();
drop(file);
let mut tree = open(dir.path(), "corrupt.idx");
for _ in 0..2 {
let error = tree.get(b"x").unwrap_err();
assert_eq!(error.kind(), ErrorKind::InvalidData, "{name}: {error}");
}
}
}
/// 按默认参数打开指定索引文件 /// 按默认参数打开指定索引文件
fn open(dir: &std::path::Path, name: &str) -> DiskBTree { fn open(dir: &std::path::Path, name: &str) -> DiskBTree {
DiskBTree::open(dir.join(name), DEFAULT_PAGE_SIZE, DEFAULT_BTREE_ORDER, DEFAULT_POOL_SIZE).unwrap() DiskBTree::open(dir.join(name), DEFAULT_PAGE_SIZE, DEFAULT_BTREE_ORDER, DEFAULT_POOL_SIZE).unwrap()
@@ -14,6 +50,29 @@ fn key(n: i64) -> [u8; 8] {
(n as u64 ^ (1u64 << 63)).to_be_bytes() (n as u64 ^ (1u64 << 63)).to_be_bytes()
} }
/// 重复键跨页后仍能完整查找和删除
#[test]
fn duplicate_keys_across_splits() {
let dir = tempfile::tempdir().unwrap();
let path = dir.path().join("split-duplicates.idx");
let mut tree = DiskBTree::open(&path, DEFAULT_PAGE_SIZE, 4, DEFAULT_POOL_SIZE).unwrap();
for value in (0..100).rev() {
tree.insert(b"same", value).unwrap();
}
drop(tree);
let mut tree = DiskBTree::open(&path, DEFAULT_PAGE_SIZE, 4, DEFAULT_POOL_SIZE).unwrap();
assert_eq!(tree.get(b"same").unwrap(), Some(0));
assert_eq!(tree.get_all(b"same").unwrap(), (0..100).collect::<Vec<_>>());
assert_eq!(tree.scan(Some(b"same"), Some(b"same")).unwrap().len(), 100);
for value in 0..100 {
assert!(tree.delete(b"same", value).unwrap());
}
assert!(!tree.delete(b"same", 0).unwrap());
drop(tree);
let mut tree = DiskBTree::open(&path, DEFAULT_PAGE_SIZE, 4, DEFAULT_POOL_SIZE).unwrap();
assert!(tree.get_all(b"same").unwrap().is_empty());
}
/// 空树查不到,遍历为空 /// 空树查不到,遍历为空
#[test] #[test]
fn empty_tree_get() { fn empty_tree_get() {
+78 -16
View File
@@ -4,6 +4,68 @@ use serde_json::json;
// 数据字典测试:补列、去重、未知表。 // 数据字典测试:补列、去重、未知表。
/// 结构变化递增版本,数据及重复应用不变
#[test]
fn schema_versions_track_structure_and_survive_reload() {
let dir = tempfile::tempdir().unwrap();
let path = dir.path().join("catalog.json");
let mut c = Catalog::default();
c.create_table("t", vec![]).unwrap();
assert_eq!(c.describe("t").unwrap().schema_version, 1);
let values = row(&[("id", json!(1)), ("name", json!("a"))]);
c.record_insert("t", &values).unwrap();
assert_eq!(c.describe("t").unwrap().schema_version, 2);
c.rebuild_stats("t", &[values]).unwrap();
let columns = c.describe("t").unwrap().columns.clone();
c.set_columns("t", columns).unwrap();
assert_eq!(c.describe("t").unwrap().schema_version, 2);
c.remove_column("t", "name").unwrap();
c.remove_column("t", "name").unwrap();
assert_eq!(c.describe("t").unwrap().schema_version, 3);
c.rename_table("t", "renamed").unwrap();
c.save(&path).unwrap();
let c = Catalog::load(&path).unwrap();
assert_eq!(c.describe("renamed").unwrap().schema_version, 4);
}
/// 旧目录版本未知,首个结构变更才递增
#[test]
fn legacy_schema_version_remains_unknown_until_change() {
let dir = tempfile::tempdir().unwrap();
let path = dir.path().join("catalog.json");
std::fs::write(&path, json!({"tables": {
"t": {"object_id": 42, "columns": []}
}}).to_string()).unwrap();
let mut c = Catalog::load(&path).unwrap();
assert_eq!(c.describe("t").unwrap().schema_version, 0);
c.save(&path).unwrap();
c = Catalog::load(&path).unwrap();
assert_eq!(c.describe("t").unwrap().schema_version, 0);
c.ensure_columns("t", &row(&[("id", json!(1))])).unwrap();
assert_eq!(c.describe("t").unwrap().schema_version, 1);
assert_eq!(c.describe("t").unwrap().object_id, 42);
}
/// 版本耗尽拒绝结构变更并保留原定义
#[test]
fn exhausted_schema_version_preserves_structure() {
let dir = tempfile::tempdir().unwrap();
let path = dir.path().join("catalog.json");
std::fs::write(&path, json!({"tables": {
"t": {"object_id": 42, "schema_version": u64::MAX,
"columns": [{"name": "id", "ty": "int"}]}
}}).to_string()).unwrap();
let mut c = Catalog::load(&path).unwrap();
assert!(c.remove_column("t", "id").is_err());
assert!(c.set_columns("t", vec![]).is_err());
assert!(c.rename_table("t", "other").is_err());
assert!(c.ensure_columns("t", &row(&[("new", json!(1))])).is_err());
assert_eq!(c.describe("t").unwrap().columns.len(), 1);
assert_eq!(c.describe("t").unwrap().schema_version, u64::MAX);
assert!(c.describe("other").is_none());
c.record_insert("t", &row(&[("id", json!(1))])).unwrap();
}
/// 表删除重建和重载均保留编号规则 /// 表删除重建和重载均保留编号规则
#[test] #[test]
fn object_ids_survive_reload_and_are_not_reused() { fn object_ids_survive_reload_and_are_not_reused() {
@@ -80,7 +142,7 @@ fn ensure_then_describe() {
let path = dir.path().join("catalog.json"); let path = dir.path().join("catalog.json");
let mut c = Catalog::load(&path).unwrap(); let mut c = Catalog::load(&path).unwrap();
c.ensure_columns("users", &row(&[("id", json!(1)), ("name", json!("Alice"))])); c.ensure_columns("users", &row(&[("id", json!(1)), ("name", json!("Alice"))])).unwrap();
c.save(&path).unwrap(); c.save(&path).unwrap();
let c2 = Catalog::load(&path).unwrap(); let c2 = Catalog::load(&path).unwrap();
@@ -102,8 +164,8 @@ fn second_insert_does_not_duplicate_columns() {
let path = dir.path().join("catalog.json"); let path = dir.path().join("catalog.json");
let mut c = Catalog::load(&path).unwrap(); let mut c = Catalog::load(&path).unwrap();
c.ensure_columns("users", &row(&[("id", json!(1))])); c.ensure_columns("users", &row(&[("id", json!(1))])).unwrap();
c.ensure_columns("users", &row(&[("id", json!(2))])); c.ensure_columns("users", &row(&[("id", json!(2))])).unwrap();
assert_eq!(c.describe("users").unwrap().columns.len(), 1); assert_eq!(c.describe("users").unwrap().columns.len(), 1);
} }
@@ -114,9 +176,9 @@ fn remove_column_drops_definition_stats_and_index() {
let path = dir.path().join("catalog.json"); let path = dir.path().join("catalog.json");
let mut c = Catalog::load(&path).unwrap(); let mut c = Catalog::load(&path).unwrap();
c.ensure_columns("t", &row(&[("id", json!(1)), ("code", json!(5))])); c.ensure_columns("t", &row(&[("id", json!(1)), ("code", json!(5))])).unwrap();
c.add_index("t", "code").unwrap(); c.add_index("t", "code").unwrap();
c.rebuild_stats("t", &[row(&[("id", json!(1)), ("code", json!(5))])]); c.rebuild_stats("t", &[row(&[("id", json!(1)), ("code", json!(5))])]).unwrap();
let removed = c.remove_column("t", "code").unwrap(); let removed = c.remove_column("t", "code").unwrap();
assert!(removed, "first remove should hit the column"); assert!(removed, "first remove should hit the column");
@@ -142,7 +204,7 @@ fn stats_track_a_histogram_for_numeric_columns() {
let rows: Vec<Row> = (0..100) let rows: Vec<Row> = (0..100)
.map(|n| row(&[("id", json!(n)), ("name", json!(format!("u{}", n)))])) .map(|n| row(&[("id", json!(n)), ("name", json!(format!("u{}", n)))]))
.collect(); .collect();
c.rebuild_stats("t", &rows); c.rebuild_stats("t", &rows).unwrap();
let s = c.describe("t").unwrap(); let s = c.describe("t").unwrap();
let id = s.stats.get("id").unwrap(); let id = s.stats.get("id").unwrap();
@@ -155,7 +217,7 @@ fn stats_track_a_histogram_for_numeric_columns() {
assert!(name.hist.is_empty(), "字符串列不进直方图"); assert!(name.hist.is_empty(), "字符串列不进直方图");
assert_eq!(name.lo, None); assert_eq!(name.lo, None);
c.record_insert("t", &row(&[("id", json!(1000)), ("name", json!("x"))])); c.record_insert("t", &row(&[("id", json!(1000)), ("name", json!("x"))])).unwrap();
let s = c.describe("t").unwrap(); let s = c.describe("t").unwrap();
let id = s.stats.get("id").unwrap(); let id = s.stats.get("id").unwrap();
assert_eq!(id.lo, Some(0.0)); assert_eq!(id.lo, Some(0.0));
@@ -178,7 +240,7 @@ fn stats_track_a_histogram_for_numeric_columns() {
fn duplicate_deletion_keeps_distinct_until_last_occurrence() { fn duplicate_deletion_keeps_distinct_until_last_occurrence() {
let mut catalog = Catalog::default(); let mut catalog = Catalog::default();
let duplicate = row(&[("id", json!(1)), ("v", json!(7))]); let duplicate = row(&[("id", json!(1)), ("v", json!(7))]);
catalog.rebuild_stats("t", &[duplicate.clone(), duplicate.clone()]); catalog.rebuild_stats("t", &[duplicate.clone(), duplicate.clone()]).unwrap();
catalog.record_delete("t", std::slice::from_ref(&duplicate)); catalog.record_delete("t", std::slice::from_ref(&duplicate));
assert_eq!(catalog.describe("t").unwrap().stats["v"].distinct, 1); assert_eq!(catalog.describe("t").unwrap().stats["v"].distinct, 1);
catalog.record_delete("t", &[duplicate]); catalog.record_delete("t", &[duplicate]);
@@ -190,7 +252,7 @@ fn duplicate_deletion_keeps_distinct_until_last_occurrence() {
fn capped_distinct_keeps_histogram_and_other_columns_accurate() { fn capped_distinct_keeps_histogram_and_other_columns_accurate() {
let mut catalog = Catalog::default(); let mut catalog = Catalog::default();
let rows: Vec<Row> = (0..5000).map(|n| row(&[("id", json!(n)), ("v", json!(n % 2))])).collect(); let rows: Vec<Row> = (0..5000).map(|n| row(&[("id", json!(n)), ("v", json!(n % 2))])).collect();
catalog.rebuild_stats("t", &rows); catalog.rebuild_stats("t", &rows).unwrap();
let schema = catalog.describe("t").unwrap(); let schema = catalog.describe("t").unwrap();
assert!(schema.stats["id"].capped); assert!(schema.stats["id"].capped);
assert_eq!(schema.stats["id"].hist.iter().sum::<u64>(), 5000); assert_eq!(schema.stats["id"].hist.iter().sum::<u64>(), 5000);
@@ -199,7 +261,7 @@ fn capped_distinct_keeps_histogram_and_other_columns_accurate() {
let schema = catalog.describe("t").unwrap(); let schema = catalog.describe("t").unwrap();
assert_eq!(schema.stats["id"].hist.iter().sum::<u64>(), 4000); assert_eq!(schema.stats["id"].hist.iter().sum::<u64>(), 4000);
assert_eq!(schema.stats["v"].distinct, 2); assert_eq!(schema.stats["v"].distinct, 2);
catalog.rebuild_stats("t", &rows[1000..]); catalog.rebuild_stats("t", &rows[1000..]).unwrap();
assert_eq!(catalog.describe("t").unwrap().stats["id"].distinct, 4000); assert_eq!(catalog.describe("t").unwrap().stats["id"].distinct, 4000);
} }
@@ -208,16 +270,16 @@ fn capped_distinct_keeps_histogram_and_other_columns_accurate() {
fn rebuilt_histogram_has_exact_buckets_in_any_order() { fn rebuilt_histogram_has_exact_buckets_in_any_order() {
let rows: Vec<Row> = (0..160).map(|n| row(&[("v", json!(n))])).collect(); let rows: Vec<Row> = (0..160).map(|n| row(&[("v", json!(n))])).collect();
let mut forward = Catalog::default(); let mut forward = Catalog::default();
forward.rebuild_stats("t", &rows); forward.rebuild_stats("t", &rows).unwrap();
let mut reverse = Catalog::default(); let mut reverse = Catalog::default();
let reversed: Vec<Row> = rows.iter().rev().cloned().collect(); let reversed: Vec<Row> = rows.iter().rev().cloned().collect();
reverse.rebuild_stats("t", &reversed); reverse.rebuild_stats("t", &reversed).unwrap();
let stat = &forward.describe("t").unwrap().stats["v"]; let stat = &forward.describe("t").unwrap().stats["v"];
assert_eq!(stat.hist, vec![10; 16]); assert_eq!(stat.hist, vec![10; 16]);
assert_eq!(stat.hist, reverse.describe("t").unwrap().stats["v"].hist); assert_eq!(stat.hist, reverse.describe("t").unwrap().stats["v"].hist);
forward.record_insert("t", &row(&[("v", json!(10000))])); forward.record_insert("t", &row(&[("v", json!(10000))])).unwrap();
forward.record_delete("t", &[row(&[("v", json!(10000))])]); forward.record_delete("t", &[row(&[("v", json!(10000))])]);
forward.rebuild_stats("t", &rows[80..]); forward.rebuild_stats("t", &rows[80..]).unwrap();
let repaired = &forward.describe("t").unwrap().stats["v"]; let repaired = &forward.describe("t").unwrap().stats["v"];
assert_eq!(repaired.lo, Some(80.0)); assert_eq!(repaired.lo, Some(80.0));
assert_eq!(repaired.hi, Some(159.0)); assert_eq!(repaired.hi, Some(159.0));
@@ -253,8 +315,8 @@ fn legacy_catalog_loads_and_normalizes() {
let s = c.describe("legacy").unwrap(); let s = c.describe("legacy").unwrap();
assert_eq!(s.columns.len(), 2); assert_eq!(s.columns.len(), 2);
assert!(s.columns[0].nullable, "老列默认可空"); assert!(s.columns[0].nullable, "老列默认可空");
assert!(c.normalize_types()); assert!(c.normalize_types().unwrap());
let types: Vec<&str> = c.describe("legacy").unwrap().columns.iter().map(|col| col.ty.as_str()).collect(); let types: Vec<&str> = c.describe("legacy").unwrap().columns.iter().map(|col| col.ty.as_str()).collect();
assert_eq!(types, vec!["int", "str"]); assert_eq!(types, vec!["int", "str"]);
assert!(!c.normalize_types(), "第二次没有可改的"); assert!(!c.normalize_types().unwrap(), "第二次没有可改的");
} }
+4 -3
View File
@@ -187,13 +187,14 @@ fn load_without_explicit_path_uses_builtin_defaults() {
} }
} }
/// [server] 分区归别的层管;本层拼写错误要报错 /// 忽略其他层分区并拒绝存储配置拼写错误
#[test] #[test]
fn server_section_belongs_to_another_layer() { fn server_section_belongs_to_another_layer() {
let _guard = env_guard(); let _guard = env_guard();
let db_server = "[server]\nlisten_host = \"0.0.0.0\"\nport = 7778\nmax_rows = 10\n"; let db_server = "[page]\nsize = 8192\n[storage]\ndata_dir = \"../data\"\n[server]\nlisten_host = \"0.0.0.0\"\nport = 7778\nmax_rows = 10\n[web]\nport = 7778\n";
let loaded = config::resolve(Some(db_server), None).unwrap(); let loaded = config::resolve(Some(db_server), None).unwrap();
assert_eq!(loaded.config.data_dir, config::default_data_dir()); assert_eq!(loaded.config.page_size, 8192);
assert_eq!(loaded.config.data_dir, PathBuf::from("../data"));
let typo = "[storage]\ndata_dirs = \"oops\"\n"; let typo = "[storage]\ndata_dirs = \"oops\"\n";
assert!(config::resolve(Some(typo), None).is_err()); assert!(config::resolve(Some(typo), None).is_err());
+91
View File
@@ -0,0 +1,91 @@
use std::ffi::CString;
use std::ptr;
use std::slice;
use chusql_core_storage::ffi::*;
use chusql_core_storage::runtime::Storage;
// 验证 FFI 错误输出、长度边界与响应所有权。
/// 读取当前线程的 FFI 错误
fn last_error() -> String {
let mut len = 0;
// SAFETY: 长度可写,返回缓冲在复制前没有被修改。
unsafe {
let data = chusql_storage_last_error(&mut len);
assert!(!data.is_null());
String::from_utf8(slice::from_raw_parts(data, len).to_vec()).unwrap()
}
}
/// 维护失败清空输出并拒绝超长请求
#[test]
fn maintenance_rejects_invalid_arguments_and_resets_outputs() {
let input = b"{}";
let mut out = input.as_ptr() as *mut u8;
let mut len = 99;
// SAFETY: 输出均可写;无效输入应在任何读取之前被拒绝。
unsafe {
assert_eq!(chusql_storage_maintenance(ptr::null(), ptr::null(), 0, &mut out, &mut len), -1);
assert!(out.is_null());
assert_eq!(len, 0);
len = 99;
assert_eq!(chusql_storage_maintenance(ptr::null(), input.as_ptr(), input.len(), ptr::null_mut(), &mut len), -1);
assert_eq!(len, 0);
out = input.as_ptr() as *mut u8;
assert_eq!(chusql_storage_maintenance(ptr::null(), input.as_ptr(), input.len(), &mut out, ptr::null_mut()), -1);
assert!(out.is_null());
assert_eq!(chusql_storage_maintenance(ptr::null(), input.as_ptr(), usize::MAX, &mut out, &mut len), -1);
}
assert!(out.is_null());
assert_eq!(len, 0);
assert_eq!(last_error(), "invalid maintenance argument");
}
/// 请求验证长度和编码并归还响应
#[test]
fn request_validates_input_and_returns_owned_response() -> Result<(), Box<dyn std::error::Error>> {
let temp = tempfile::tempdir()?;
let config = temp.path().join("settings.toml");
std::fs::write(&config, format!("[storage]\ndata_dir = '{}'\nlog_files = '{}'\n[log]\nlevel = 'off'\n", temp.path().join("data").display(), temp.path().join("logs").display()))?;
let storage = Storage::open(config.to_str())?;
let input = br#"{"method":"ping"}"#;
let mut out = ptr::null_mut();
let mut len = 0;
// SAFETY: 句柄和实际请求有效;超长长度必须在构造切片前被拒绝。
unsafe {
assert_eq!(chusql_storage_request(&storage, input.as_ptr(), usize::MAX, &mut out, &mut len), -1);
assert!(out.is_null());
assert_eq!(len, 0);
assert_eq!(last_error(), "invalid argument");
assert_eq!(chusql_storage_request(&storage, [0xff].as_ptr(), 1, &mut out, &mut len), -1);
assert!(last_error().starts_with("request is not valid UTF-8:"));
assert_eq!(chusql_storage_request(&storage, input.as_ptr(), input.len(), &mut out, &mut len), 0);
assert!(!out.is_null());
let response = slice::from_raw_parts(out, len).to_vec();
chusql_storage_free(out, len);
let response: serde_json::Value = serde_json::from_slice(&response)?;
assert_eq!(response["status"], "pong");
}
drop(storage);
let config = CString::new(config.to_str().unwrap())?;
// SAFETY: 路径与输出有效;失败不产生需要释放的缓冲。
unsafe {
assert_eq!(chusql_storage_maintenance(config.as_ptr(), [0xff].as_ptr(), 1, &mut out, &mut len), -1);
}
assert!(out.is_null());
assert_eq!(len, 0);
assert!(!last_error().is_empty());
let maintenance = br#"{"mode":"reset","user":"root","password_hash":"hash","types":[{"name":"int","base_type":"int","parameterized":false}]}"#;
// SAFETY: 维护仅使用本测试临时目录;成功响应复制后由配套函数释放。
unsafe {
assert_eq!(chusql_storage_maintenance(config.as_ptr(), maintenance.as_ptr(), maintenance.len(), &mut out, &mut len), 0, "{}", last_error());
assert!(!out.is_null());
let response = slice::from_raw_parts(out, len).to_vec();
chusql_storage_free(out, len);
let response: serde_json::Value = serde_json::from_slice(&response)?;
assert_eq!(response["status"], "maintenance");
assert_eq!(response["mode"], "reset");
}
Ok(())
}
+245 -1
View File
@@ -5,6 +5,38 @@ use chusql_core_storage::runtime::Storage;
// 进程内存储集成测试:协议请求、索引、账号与配置。 // 进程内存储集成测试:协议请求、索引、账号与配置。
/// 检查点损坏不冒充零 LSN且可恢复读取
#[test]
fn system_status_reports_checkpoint_read_errors() -> Result<(), Box<dyn std::error::Error>> {
let (_server, data) = start_server();
let mut connection = connect()?;
let checkpoint = data.path().join("system/wal.checkpoint");
let initial: serde_json::Value = serde_json::from_str(&send_raw(&mut connection, r#"{"method":"system_status"}"#))?;
assert_eq!(initial["last_lsn"], 0);
request_ok(&mut connection, serde_json::json!({"method":"object_acl_replace","expected":null,"payload":"{}"}))?;
let original = std::fs::read(&checkpoint)?;
let before: serde_json::Value = serde_json::from_str(&send_raw(&mut connection, r#"{"method":"system_status"}"#))?;
assert_eq!(before["status"], "system");
assert!(before["last_lsn"].as_u64().unwrap() > 0);
std::fs::write(&checkpoint, b"bad")?;
let broken: serde_json::Value = serde_json::from_str(&send_raw(&mut connection, r#"{"method":"system_status"}"#))?;
assert_eq!(broken["status"], "error");
assert!(broken["message"].as_str().unwrap().contains("invalid WAL checkpoint length"));
assert!(broken.get("last_lsn").is_none());
assert!(send_raw(&mut connection, r#"{"method":"ping"}"#).contains("pong"));
std::fs::write(&checkpoint, &original)?;
let restored: serde_json::Value = serde_json::from_str(&send_raw(&mut connection, r#"{"method":"system_status"}"#))?;
assert_eq!(restored, before);
std::fs::remove_file(&checkpoint)?;
std::fs::create_dir(&checkpoint)?;
let unreadable: serde_json::Value = serde_json::from_str(&send_raw(&mut connection, r#"{"method":"system_status"}"#))?;
assert_eq!(unreadable["status"], "error");
assert!(unreadable.get("last_lsn").is_none());
std::fs::remove_dir(&checkpoint)?;
std::fs::write(&checkpoint, original)?;
Ok(())
}
/// 权限快照支持跨页文本并拒绝旧版本覆盖 /// 权限快照支持跨页文本并拒绝旧版本覆盖
#[test] #[test]
fn object_acl_snapshots_are_private_and_compare_versions() -> Result<(), Box<dyn std::error::Error>> { fn object_acl_snapshots_are_private_and_compare_versions() -> Result<(), Box<dyn std::error::Error>> {
@@ -139,6 +171,218 @@ fn object_id_survives_committed_create_recovery() -> Result<(), Box<dyn std::err
Ok(()) Ok(())
} }
/// 读取复查跨库依赖而非只复查扫描表
#[test]
fn bound_reads_recheck_dependencies_in_other_databases() -> 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":"source","columns":[]}))?;
request_ok(&mut c, serde_json::json!({"method":"create_database","database":"dependency"}))?;
request_ok(&mut c, serde_json::json!({"method":"create_table","database":"dependency","table":"related","columns":[]}))?;
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"] == "main.source" || entry["table"] == "dependency.related").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 request = serde_json::json!({"method":"scan","table":"source","schema_guard":bindings});
let valid: serde_json::Value = serde_json::from_str(&send(&mut c, &request.to_string()))?;
assert_eq!(valid["status"], "guarded");
request_ok(&mut c, serde_json::json!({"method":"replace_schema","database":"dependency","table":"related","columns":[{"name":"new","ty":"int"}],"rows":[]}))?;
let invalid: serde_json::Value = serde_json::from_str(&send(&mut c, &request.to_string()))?;
assert_eq!(invalid["status"], "error");
assert!(invalid["message"].as_str().unwrap().contains("bound query schema changed: dependency.related"));
Ok(())
}
/// 每种读取都复查守卫,拒绝旧版本与库管理
#[test]
fn bound_reads_validate_dependencies_and_acknowledge_guards() -> 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":"guarded","columns":[{"name":"id","ty":"int"}]}))?;
request_ok(&mut c, serde_json::json!({"method":"insert","table":"guarded","row":{"id":7}}))?;
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();
for mut request in [
serde_json::json!({"method":"scan","table":"guarded"}),
serde_json::json!({"method":"scan_shard","table":"guarded","shard":0,"shards":1}),
serde_json::json!({"method":"lookup_by_index","table":"guarded","column":"id","key":7}),
serde_json::json!({"method":"range_by_index","table":"guarded","column":"id","lo":null,"hi":null}),
] {
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!(response["response"]["status"] == "rows" || response["response"]["status"] == "no_index", "{response}");
}
request_ok(&mut c, serde_json::json!({"method":"replace_schema","table":"guarded","columns":[{"name":"id","ty":"int"},{"name":"extra","ty":"str"}],"rows":[{"id":7,"extra":"x"}]}))?;
let stale: serde_json::Value = serde_json::from_str(&send(&mut c, &serde_json::json!({"method":"scan","table":"guarded","schema_guard":[binding]}).to_string()))?;
assert_eq!(stale["status"], "error");
assert!(stale["message"].as_str().unwrap().contains("bound query schema changed"));
let write: serde_json::Value = serde_json::from_str(&send(&mut c, &serde_json::json!({"method":"insert","table":"guarded","row":{"id":9},"schema_guard":[binding]}).to_string()))?;
assert_eq!(write["status"], "error");
let management: serde_json::Value = serde_json::from_str(&send_raw(&mut c, &serde_json::json!({"method":"create_database","database":"blocked","schema_guard":[]}).to_string()))?;
assert_eq!(management["status"], "error");
let databases: serde_json::Value = serde_json::from_str(&send_raw(&mut c, r#"{"method":"list_databases"}"#))?;
assert!(!databases["tables"].as_array().unwrap().iter().any(|database| database == "blocked"));
let rows: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"scan","table":"guarded"}"#))?;
assert_eq!(rows["rows"].as_array().unwrap().len(), 1);
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>> {
use chusql_core_storage::protocol::TableSchemaWire;
let (_server, _data) = start_server();
let mut c = connect()?;
request_ok(&mut c, serde_json::json!({"method":"create_table","table":"versioned","columns":[{"name":"id","ty":"int"}]}))?;
let describe: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"describe_table","table":"versioned"}"#))?;
assert_eq!(describe["schema_version"], "1");
let catalog: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"list_catalog"}"#))?;
assert_eq!(catalog["schemas"][0]["schema_version"], "1");
let wire: TableSchemaWire = serde_json::from_value(serde_json::json!({"table":"t","columns":[],"schema_version":u64::MAX.to_string()}))?;
assert_eq!(wire.schema_version, u64::MAX);
assert_eq!(serde_json::to_value(wire)?["schema_version"], u64::MAX.to_string());
for version in [serde_json::json!(-1), serde_json::json!(1.5), serde_json::json!("18446744073709551616"), serde_json::json!("+1")] {
assert!(serde_json::from_value::<TableSchemaWire>(serde_json::json!({"table":"t","columns":[],"schema_version":version})).is_err());
}
Ok(())
}
/// 检查点失败及反复恢复保留结构版本
#[test]
fn schema_versions_survive_checkpoint_failure_and_repeated_recovery() -> Result<(), Box<dyn std::error::Error>> {
use chusql_core_storage::catalog::Catalog;
use chusql_core_storage::wal::{Wal, WalOp};
let (server, data) = start_server();
let mut c = connect()?;
request_ok(&mut c, serde_json::json!({"method":"create_table","table":"versioned","columns":[{"name":"id","ty":"int"}]}))?;
let directory = data.path().join("databases/main");
let pending = directory.join("wal.checkpoint.pending");
std::fs::create_dir(&pending)?;
let response = send(&mut c, r#"{"method":"replace_schema","table":"versioned","columns":[{"name":"id","ty":"int"},{"name":"tag","ty":"str"}],"rows":[]}"#);
assert!(response.contains("error"), "{response}");
let catalog = Catalog::load(directory.join("catalog.json"))?;
let version = catalog.describe("versioned").unwrap().schema_version;
assert_eq!(version, 2);
let wal = Wal::new(directory.join("wal.log"));
let records = wal.read_all()?.records;
assert!(records.iter().any(|(_, op)| matches!(op, WalOp::ReplaceSchema { schema_version: Some(2), .. })));
let columns = catalog.describe("versioned").unwrap().columns.clone();
drop(wal);
drop(c);
drop(server);
std::fs::remove_dir(pending)?;
for _ in 0..2 {
let wal = Wal::new(directory.join("wal.log"));
wal.append_group(&[
WalOp::ReplaceSchema { table: "versioned".into(), columns: vec![], rows: vec![], schema_version: Some(1) },
WalOp::ReplaceSchema { table: "versioned".into(), columns: columns.clone(), rows: vec![], schema_version: Some(version) },
])?;
drop(wal);
let restarted = restart_at(data.path())?;
let catalog = Catalog::load(directory.join("catalog.json"))?;
assert_eq!(catalog.describe("versioned").unwrap().schema_version, version);
assert_eq!(catalog.describe("versioned").unwrap().columns, columns);
assert_eq!(std::fs::metadata(directory.join("wal.log"))?.len(), 0);
drop(restarted);
}
Ok(())
}
/// 并发建表分配互不重复的编号 /// 并发建表分配互不重复的编号
#[test] #[test]
fn concurrent_table_creation_allocates_distinct_object_ids() -> Result<(), Box<dyn std::error::Error>> { fn concurrent_table_creation_allocates_distinct_object_ids() -> Result<(), Box<dyn std::error::Error>> {
@@ -994,7 +1238,7 @@ fn hidden_column_wal_replays_twice_without_touching_heap() -> Result<(), Box<dyn
let mut compacted: Option<Vec<u8>> = None; let mut compacted: Option<Vec<u8>> = None;
for round in 0..2 { for round in 0..2 {
let wal = Wal::new(data.path().join("databases/main/wal.log")); let wal = Wal::new(data.path().join("databases/main/wal.log"));
let op = WalOp::HideColumn { table: "items".into(), column: "secret".into() }; let op = WalOp::HideColumn { table: "items".into(), column: "secret".into(), schema_version: None };
wal.truncate()?; wal.truncate()?;
wal.append(&op)?; wal.append(&op)?;
assert_eq!(wal.read()?, Some(op)); assert_eq!(wal.read()?, Some(op));
+28
View File
@@ -4,6 +4,33 @@ use serde_json::json;
// WAL 测试:追加、读取、清空、截断尾巴、LSN 与提交标记。 // WAL 测试:追加、读取、清空、截断尾巴、LSN 与提交标记。
/// 结构版本往返且旧隐藏列载荷可读
#[test]
fn schema_versions_round_trip_and_legacy_hide_decodes() {
let dir = tempfile::tempdir().unwrap();
let path = dir.path().join("wal.log");
let wal = Wal::new(&path);
let ops = [
WalOp::HideColumn { table: "t".into(), column: "name".into(), schema_version: Some(u64::MAX) },
WalOp::DropColumn { table: "t".into(), column: "name".into(), rows: vec![], schema_version: Some(3) },
WalOp::ReplaceSchema { table: "t".into(), columns: vec![], rows: vec![], schema_version: Some(4) },
];
wal.append_group(&ops).unwrap();
assert_eq!(committed_ops(&wal.read_all().unwrap().records).into_iter().map(|(_, op)| op).collect::<Vec<_>>(), ops);
drop(wal);
let mut body = 1_u64.to_le_bytes().to_vec();
body.push(8);
body.extend_from_slice(&1_u16.to_le_bytes());
body.extend_from_slice(b"t");
body.extend_from_slice(br#""name""#);
let mut frame = (body.len() as u32).to_le_bytes().to_vec();
frame.extend_from_slice(&body);
std::fs::write(&path, frame).unwrap();
assert_eq!(Wal::new(&path).read().unwrap(), Some(WalOp::HideColumn {
table: "t".into(), column: "name".into(), schema_version: None,
}));
}
/// 建表编号完整往返且兼容旧载荷 /// 建表编号完整往返且兼容旧载荷
#[test] #[test]
fn create_table_ids_round_trip_and_legacy_payloads_decode() { fn create_table_ids_round_trip_and_legacy_payloads_decode() {
@@ -58,6 +85,7 @@ fn append_and_read_round_trips() {
WalOp::DropColumn { WalOp::DropColumn {
table: "users".into(), table: "users".into(),
column: "age".into(), column: "age".into(),
schema_version: None,
rows: vec![ rows: vec![
row(&[("id", json!(1)), ("name", json!("Alice"))]), row(&[("id", json!(1)), ("name", json!("Alice"))]),
row(&[("id", json!(2)), ("name", json!("Bob"))]), row(&[("id", json!(2)), ("name", json!("Bob"))]),
+1
View File
@@ -16,6 +16,7 @@ library
ChuSQL.Interface.Actions ChuSQL.Interface.Actions
ChuSQL.Interface.Auth ChuSQL.Interface.Auth
ChuSQL.Interface.Config ChuSQL.Interface.Config
ChuSQL.Interface.Normalization
ChuSQL.Interface.Link ChuSQL.Interface.Link
ChuSQL.Interface.Policy ChuSQL.Interface.Policy
ChuSQL.Interface.Protocol ChuSQL.Interface.Protocol
@@ -43,4 +43,4 @@ accountColumnSpec name ty nullable autoIncrement primary unique =
-- | 账号表的结构(排序校验用) -- | 账号表的结构(排序校验用)
systemTableInfo :: TableInfo systemTableInfo :: TableInfo
systemTableInfo = TableInfo accountTableName accountColumns 0 [] [] [] systemTableInfo = TableInfo accountTableName accountColumns 0 [] [] [] Nothing Nothing
@@ -32,6 +32,7 @@ module ChuSQL.Interface.Actions (
revokeRoleSql, revokeRoleSql,
) where ) where
import Control.Monad (zipWithM)
import ChuSQL.Core.Model (Column (..), ColumnType (..), Value (..), integerType, numericType, parseColumnType, plainColumn, typeName) import ChuSQL.Core.Model (Column (..), ColumnType (..), Value (..), integerType, numericType, parseColumnType, plainColumn, typeName)
import qualified ChuSQL.Core.Model as M import qualified ChuSQL.Core.Model as M
import ChuSQL.Core.Runtime import ChuSQL.Core.Runtime
@@ -127,7 +128,7 @@ runtimeLiteral (TypeApply (TypeConstructorId 6) [child]) (RMaybe value) = do
Right ("MAYBE<" ++ renderTypeExpr child ++ ">(" ++ item ++ ")") Right ("MAYBE<" ++ renderTypeExpr child ++ ">(" ++ item ++ ")")
runtimeLiteral (TypeApply (TypeConstructorId 7) fields) (RTuple values) runtimeLiteral (TypeApply (TypeConstructorId 7) fields) (RTuple values)
| length fields == length values = do | length fields == length values = do
items <- sequence (zipWith runtimeLiteral fields values) items <- zipWithM runtimeLiteral fields values
Right ("TUPLE<" ++ intercalate ", " (map renderTypeExpr fields) ++ ">(" ++ intercalate ", " items ++ ")") Right ("TUPLE<" ++ intercalate ", " (map renderTypeExpr fields) ++ ">(" ++ intercalate ", " items ++ ")")
runtimeLiteral _ _ = Left "runtime value does not match its type expression" runtimeLiteral _ _ = Left "runtime value does not match its type expression"
@@ -49,7 +49,6 @@ data WebConfig = WebConfig
, wcMaxPageSize :: Int , wcMaxPageSize :: Int
, wcMaxRows :: Int , wcMaxRows :: Int
, wcMaxSqlLength :: Int , wcMaxSqlLength :: Int
, wcSeedDemo :: Bool
} }
deriving (Show, Eq) deriving (Show, Eq)
@@ -73,7 +72,6 @@ defaultWebConfig =
, wcMaxPageSize = 500 , wcMaxPageSize = 500
, wcMaxRows = 1000 , wcMaxRows = 1000
, wcMaxSqlLength = 20000 , wcMaxSqlLength = 20000
, wcSeedDemo = False
} }
-- | 把设置键统一成连字符写法,重名时连字符优先 -- | 把设置键统一成连字符写法,重名时连字符优先
@@ -148,7 +146,6 @@ webConfigFromSection saved =
, wcMaxPageSize = sectionInt "max-page-size" saved (wcMaxPageSize defaultWebConfig) , wcMaxPageSize = sectionInt "max-page-size" saved (wcMaxPageSize defaultWebConfig)
, wcMaxRows = sectionInt "max-rows" saved (wcMaxRows defaultWebConfig) , wcMaxRows = sectionInt "max-rows" saved (wcMaxRows defaultWebConfig)
, wcMaxSqlLength = sectionInt "max-sql-length" saved (wcMaxSqlLength defaultWebConfig) , wcMaxSqlLength = sectionInt "max-sql-length" saved (wcMaxSqlLength defaultWebConfig)
, wcSeedDemo = sectionBool "seed" saved (wcSeedDemo defaultWebConfig)
} }
-- | 分区里一个键的非空字符串值 -- | 分区里一个键的非空字符串值
@@ -203,9 +200,7 @@ loadServerConfigAt path = do
Just value | not (T.null (T.strip value)) -> T.unpack (T.strip value) Just value | not (T.null (T.strip value)) -> T.unpack (T.strip value)
_ -> fallback _ -> fallback
-- | 取一个键的整数值 -- | 取一个键的整数值
intOf key fallback = case Map.lookup key values >>= readMaybe . T.unpack . T.strip of intOf key fallback = fromMaybe fallback (Map.lookup key values >>= readMaybe . T.unpack . T.strip)
Just number -> number
Nothing -> fallback
pure pure
defaultServerConfig defaultServerConfig
{ scHost = textOf "listen_host" (scHost defaultServerConfig) { scHost = textOf "listen_host" (scHost defaultServerConfig)
@@ -6,6 +6,7 @@ module ChuSQL.Interface.Link (
closeClient, closeClient,
clientLogin, clientLogin,
clientSudoLogin, clientSudoLogin,
clientNormalization,
clientQuery, clientQuery,
clientPing, clientPing,
clientCatalog, clientCatalog,
@@ -16,6 +17,8 @@ module ChuSQL.Interface.Link (
clientReloadPolicy, clientReloadPolicy,
) where ) where
import ChuSQL.Interface.Normalization (NormalizationRequest)
import qualified Data.Aeson as A
import ChuSQL.Interface.Sudo (SudoCredential, sudoProof, isLocalPeer) import ChuSQL.Interface.Sudo (SudoCredential, sudoProof, isLocalPeer)
import ChuSQL.Core.Protocol (Account, QueryResult (..), TableInfo (..)) import ChuSQL.Core.Protocol (Account, QueryResult (..), TableInfo (..))
import ChuSQL.Interface.Protocol ( import ChuSQL.Interface.Protocol (
@@ -244,3 +247,12 @@ describe :: IOException -> String
describe err describe err
| isEOFError err = "the server closed the connection" | isEOFError err = "the server closed the connection"
| otherwise = show err | otherwise = show err
-- 请求服务端执行只读范式分析。
clientNormalization :: Client -> NormalizationRequest -> IO (Either Text A.Value)
clientNormalization client payload = do
answer <- request client (ReqNormalization payload)
pure $ case answer of
Left message -> Left message
Right (RespNormalization value) -> Right value
Right other -> failed "normalization" other
@@ -0,0 +1,188 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Interface.Normalization where
import ChuSQL.Core.Protocol (SchemaColumn)
import Control.Monad (unless, when)
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 qualified Data.Aeson.Types as AT
import qualified Data.ByteString.Lazy as BL
import Data.Char (isAlpha, isAlphaNum, isDigit, isHexDigit, isSpace)
import Data.List (nub)
import Data.Scientific (base10Exponent, toBoundedInteger)
import Data.Word (Word64)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Text.ParserCombinators.ReadP
-- 范式入口的版本化声明、对象身份与严格 JSON 校验。
data NormalizationDependency = NormalizationDependency [String] [String] deriving (Eq, Show)
data NormalizationDeclaration = NormalizationDeclaration
{ ndKeys :: [[String]], ndDependencies :: [NormalizationDependency]
, ndComplete :: Bool, ndAtomic :: Maybe Bool
} deriving (Eq, Show)
data ObjectIdentity = ObjectIdentity Integer Integer deriving (Eq, Show)
data NormalizationRequest = NormalizationRequest
{ nrVersion :: Int, nrDatabase :: Text, nrTable :: Text
, nrDeclaration :: NormalizationDeclaration
, nrExpectedObject :: Maybe ObjectIdentity, nrExpectedSchema :: Maybe Text
} deriving (Eq, Show)
-- 拒绝对象中未定义的字段。
onlyFields :: [Text] -> A.Object -> AT.Parser ()
onlyFields names fields = unless (all ((`elem` names) . K.toText) (KM.keys fields)) (fail "normalization: unknown field")
instance FromJSON NormalizationDependency where
-- 读取依赖两端的确切字段名。
parseJSON = withObject "dependency" $ \o -> do
onlyFields ["lhs", "rhs"] o
lhs <- o .: "lhs"
rhs <- o .: "rhs"
when (null rhs) (fail "normalization: empty dependency rhs")
pure (NormalizationDependency lhs rhs)
instance ToJSON NormalizationDependency where
-- 编码声明依赖。
toJSON (NormalizationDependency lhs rhs) = object ["lhs" .= lhs, "rhs" .= rhs]
instance FromJSON NormalizationDeclaration where
-- 读取显式声明并限制数量。
parseJSON = withObject "declaration" $ \o -> do
onlyFields ["declared_keys", "dependencies", "dependencies_complete", "atomic_attributes"] o
keys <- o .:? "declared_keys" .!= []
deps <- o .:? "dependencies" .!= []
when (length keys > 256 || length deps > 256) (fail "normalization: declaration exceeds 256 entries")
NormalizationDeclaration keys deps <$> o .:? "dependencies_complete" .!= False <*> o .:? "atomic_attributes"
instance ToJSON NormalizationDeclaration where
-- 编码全部声明标志。
toJSON d = object ["declared_keys" .= ndKeys d, "dependencies" .= ndDependencies d,
"dependencies_complete" .= ndComplete d, "atomic_attributes" .= ndAtomic d]
instance FromJSON ObjectIdentity where
-- 校验稳定对象的正整数编号。
parseJSON = withObject "object identity" $ \o -> do
onlyFields ["database_id", "object_id"] o
db <- o .: "database_id" >>= identityNumber
table <- o .: "object_id" >>= identityNumber
when (db <= 0 || table <= 0) (fail "normalization: invalid object identity")
pure (ObjectIdentity db table)
-- 兼容目录数值并保留浏览器中的完整编号。
identityNumber :: A.Value -> AT.Parser Integer
identityNumber (A.String text)
| not (T.null text) && T.length text <= 20 && T.all isDigit text = case reads (T.unpack text) of
[(value, "")] | value <= toInteger (maxBound :: Word64) -> pure value
_ -> fail "normalization: invalid identity number"
identityNumber (A.Number number)
| base10Exponent number >= -20 && base10Exponent number <= 20 =
maybe (fail "normalization: invalid identity number") (pure . toInteger) (toBoundedInteger number :: Maybe Word64)
identityNumber _ = fail "normalization: invalid identity number"
instance ToJSON ObjectIdentity where
-- 编码对象的库及表编号。
toJSON (ObjectIdentity db table) = object ["database_id" .= T.pack (show db), "object_id" .= T.pack (show table)]
instance FromJSON NormalizationRequest where
-- 校验版本、范围和预期身份。
parseJSON = withObject "normalization request" $ \o -> do
onlyFields ["api_version", "database", "table", "declaration", "expected_object", "expected_schema_fingerprint"] o
version <- o .: "api_version"
when (version /= (1 :: Int)) (fail "normalization: unsupported api_version")
db <- o .: "database"
table <- o .: "table"
unless (plainName db && case T.splitOn "." table of [name] -> plainName name; [scope, name] -> scope == db && plainName name; _ -> False)
(fail "normalization: invalid or cross-database table name")
NormalizationRequest version db table <$> o .: "declaration" <*> o .:? "expected_object" <*> o .:? "expected_schema_fingerprint"
instance ToJSON NormalizationRequest where
-- 编码专用分析请求。
toJSON r = object ["api_version" .= nrVersion r, "database" .= nrDatabase r, "table" .= nrTable r,
"declaration" .= nrDeclaration r, "expected_object" .= nrExpectedObject r, "expected_schema_fingerprint" .= nrExpectedSchema r]
-- 校验与 SQL 一致的裸标识符。
plainName :: Text -> Bool
plainName name = not (T.null name) && T.length name <= 64 && (isAlpha (T.head name) || T.head name == '_') && T.all (\c -> isAlphaNum c || c == '_') name
-- 检查大小、编码及重复 JSON 字段。
decodeNormalizationJSON :: BL.ByteString -> Either Text A.Value
decodeNormalizationJSON raw
| BL.length raw > 65536 = Left "normalization: request exceeds 64 KiB"
| otherwise = do
value <- either (Left . T.pack) Right (A.eitherDecode raw)
text <- either (const (Left "normalization: invalid UTF-8")) Right (TE.decodeUtf8' (BL.toStrict raw))
case readP_to_S (skipSpaces *> jsonNode 0 <* skipSpaces <* eof) (T.unpack text) of
[(True, "")] -> Right value
_ -> Left "normalization: duplicate JSON fields or nesting exceeds 64"
-- 遍历 JSON 结构并保留原始字段名。
jsonNode :: Int -> ReadP Bool
jsonNode depth
| depth > 64 = pfail
| otherwise = objectNode <++ arrayNode <++ (True <$ jsonString) <++ (True <$ munch1 (\c -> not (isSpace c) && c `notElem` (",]}" :: String)))
where
-- 验证对象及所有嵌套值。
objectNode = do
_ <- char '{'
skipSpaces
pairs <- sepBy pair (skipSpaces *> char ',' <* skipSpaces)
skipSpaces
_ <- char '}'
pure (length (map fst pairs) == length (nub (map fst pairs)) && all snd pairs)
-- 保留键名并验证对应值。
pair = do
key <- jsonString
skipSpaces
_ <- char ':'
skipSpaces
valid <- jsonNode (depth + 1)
pure (key, valid)
-- 验证数组的所有元素。
arrayNode = do
_ <- char '['
skipSpaces
values <- sepBy (jsonNode (depth + 1)) (skipSpaces *> char ',' <* skipSpaces)
skipSpaces
_ <- char ']'
pure (and values)
-- 解码字符串以识别转义后的相同键。
jsonString :: ReadP Text
jsonString = do
_ <- char '"'
pieces <- many piece
_ <- char '"'
case A.eitherDecodeStrict (TE.encodeUtf8 (T.pack ('"' : concat pieces ++ "\""))) of
Right value -> pure value
Left _ -> pfail
where
-- 保留 JSON 字符串转义。
piece = ((\c -> ['\\', c]) <$> (char '\\' *> get)) <++ munch1 (\c -> c /= '"' && c /= '\\')
-- 拒绝缺字段或未知标签的线上报告。
parseNormalizationReport :: A.Value -> AT.Parser A.Value
parseNormalizationReport value = withObject "normalization report" (\o -> do
version <- o .: "api_version"
conditional <- o .: "conditional"
unless (version == (1 :: Int) && conditional) (fail "normalization: invalid report version or condition")
_ <- (o .: "object" :: AT.Parser ObjectIdentity)
fingerprint <- o .: "schema_fingerprint"
unless (T.length fingerprint == 64 && T.all isHexDigit fingerprint) (fail "normalization: invalid schema fingerprint")
view <- o .: "view"
unless (view `elem` (["live_schema", "transaction_snapshot"] :: [Text])) (fail "normalization: unknown view")
_ <- (o .: "schema" :: AT.Parser [SchemaColumn])
_ <- (o .: "declaration" :: AT.Parser NormalizationDeclaration)
_ <- (o .: "candidate_keys" :: AT.Parser [[String]])
forms <- o .: "findings" >>= mapM parseFinding
unless (forms == (["1nf", "2nf", "3nf", "bcnf"] :: [Text])) (fail "normalization: invalid findings")
_ <- (o .: "suggestions" :: AT.Parser [A.Value])
_ <- (o .: "condition" :: AT.Parser Text)
pure value) value
where
-- 核对每项结论与证据的稳定形状。
parseFinding = withObject "normalization finding" $ \o -> do
form <- o .: "normal_form"
verdict <- o .: "verdict"
unless (verdict `elem` (["satisfied", "violated", "insufficient"] :: [Text])) (fail "normalization: unknown verdict")
_ <- (o .: "witnesses" :: AT.Parser [NormalizationDependency])
_ <- (o .: "condition" :: AT.Parser Text)
pure form
@@ -13,6 +13,8 @@ module ChuSQL.Interface.Protocol (
RoleView (..), RoleView (..),
) where ) where
import ChuSQL.Interface.Normalization
import Data.Aeson.Types (parseEither)
import ChuSQL.Core.Protocol (Account (..), QueryResult (..), TableInfo (..), queryResultJson) import ChuSQL.Core.Protocol (Account (..), QueryResult (..), TableInfo (..), queryResultJson)
import Data.Aeson (FromJSON (..), ToJSON (..), Value, object, withObject, (.:), (.:?), (.!=), (.=)) import Data.Aeson (FromJSON (..), ToJSON (..), Value, object, withObject, (.:), (.:?), (.!=), (.=))
import qualified Data.Aeson as A import qualified Data.Aeson as A
@@ -93,6 +95,7 @@ data ClientRequest
| ReqLogin Text Text | ReqLogin Text Text
| ReqSudoChallenge | ReqSudoChallenge
| ReqSudoLogin Text Text | ReqSudoLogin Text Text
| ReqNormalization NormalizationRequest
| ReqQuery Text | ReqQuery Text
| ReqPing | ReqPing
| ReqQuit | ReqQuit
@@ -141,6 +144,9 @@ decodeRequest raw = case A.eitherDecodeStrict raw of
"sudo_login" -> case (wrUser wire, wrProof wire) of "sudo_login" -> case (wrUser wire, wrProof wire) of
(Just user, Just proof) -> Right (ReqSudoLogin user proof) (Just user, Just proof) -> Right (ReqSudoLogin user proof)
_ -> Left "sudo_login needs both user and proof" _ -> Left "sudo_login needs both user and proof"
"normalization_analyze" -> do
value <- decodeNormalizationJSON (BL.fromStrict raw)
either (Left . T.pack) Right $ parseEither (withObject "normalization envelope" $ \o -> onlyFields ["method", "request"] o >> ReqNormalization <$> o .: "request") value
"query" -> maybe (Left "query needs sql") (Right . ReqQuery) (wrSql wire) "query" -> maybe (Left "query needs sql") (Right . ReqQuery) (wrSql wire)
"storage" -> maybe (Left "storage needs request") (Right . ReqStorage) (wrRequest wire) "storage" -> maybe (Left "storage needs request") (Right . ReqStorage) (wrRequest wire)
"catalog" -> Right ReqCatalog "catalog" -> Right ReqCatalog
@@ -164,6 +170,7 @@ requestJson request = case request of
ReqLogin user password -> object ["method" .= ("login" :: Text), "user" .= user, "password" .= password] ReqLogin user password -> object ["method" .= ("login" :: Text), "user" .= user, "password" .= password]
ReqSudoChallenge -> object ["method" .= ("sudo_challenge" :: Text)] ReqSudoChallenge -> object ["method" .= ("sudo_challenge" :: Text)]
ReqSudoLogin user proof -> object ["method" .= ("sudo_login" :: Text), "user" .= user, "proof" .= proof] ReqSudoLogin user proof -> object ["method" .= ("sudo_login" :: Text), "user" .= user, "proof" .= proof]
ReqNormalization payload -> object ["method" .= ("normalization_analyze" :: Text), "request" .= payload]
ReqQuery sql -> object ["method" .= ("query" :: Text), "sql" .= sql] ReqQuery sql -> object ["method" .= ("query" :: Text), "sql" .= sql]
ReqPing -> object ["method" .= ("ping" :: Text)] ReqPing -> object ["method" .= ("ping" :: Text)]
ReqQuit -> object ["method" .= ("quit" :: Text)] ReqQuit -> object ["method" .= ("quit" :: Text)]
@@ -184,6 +191,7 @@ data ServerResponse
| RespPong | RespPong
| RespBye | RespBye
| RespError Text Text | RespError Text Text
| RespNormalization Value
| RespStorage Value | RespStorage Value
| RespCatalog [TableInfo] | RespCatalog [TableInfo]
| RespDatabases [Text] | RespDatabases [Text]
@@ -205,6 +213,7 @@ responseJson response = case response of
RespPong -> object ["status" .= ("pong" :: Text)] RespPong -> object ["status" .= ("pong" :: Text)]
RespBye -> object ["status" .= ("bye" :: Text)] RespBye -> object ["status" .= ("bye" :: Text)]
RespError code message -> object ["status" .= ("error" :: Text), "code" .= code, "message" .= message] RespError code message -> object ["status" .= ("error" :: Text), "code" .= code, "message" .= message]
RespNormalization value -> object ["status" .= ("normalization" :: Text), "analysis" .= value]
RespStorage value -> object ["status" .= ("storage" :: Text), "response" .= value] RespStorage value -> object ["status" .= ("storage" :: Text), "response" .= value]
RespCatalog infos -> object ["status" .= ("catalog" :: Text), "schemas" .= infos] RespCatalog infos -> object ["status" .= ("catalog" :: Text), "schemas" .= infos]
RespDatabases names -> object ["status" .= ("databases" :: Text), "databases" .= names] RespDatabases names -> object ["status" .= ("databases" :: Text), "databases" .= names]
@@ -238,6 +247,9 @@ decodeResponse raw = case A.eitherDecode raw of
"result" -> case A.fromJSON (A.Object fields) of "result" -> case A.fromJSON (A.Object fields) of
A.Success result -> Right (RespResult result) A.Success result -> Right (RespResult result)
A.Error message -> Left (T.pack message) A.Error message -> Left (T.pack message)
"normalization" -> case KM.lookup "analysis" fields of
Nothing -> Left "normalization response is missing analysis"
Just value -> either (Left . T.pack) (Right . RespNormalization) (parseEither parseNormalizationReport value)
"catalog" -> fromField "schemas" RespCatalog fields "catalog" -> fromField "schemas" RespCatalog fields
"databases" -> fromField "databases" RespDatabases fields "databases" -> fromField "databases" RespDatabases fields
"roles" -> fromField "roles" RespRoles fields "roles" -> fromField "roles" RespRoles fields
@@ -10,15 +10,20 @@ module ChuSQL.Interface.Session (
authenticateSudoSession, authenticateSudoSession,
switchDatabase, switchDatabase,
runStatement, runStatement,
analyzeNormalization,
catalog, catalog,
databases, databases,
roleViews, roleViews,
accounts, accounts,
) where ) where
import Data.Foldable (for_)
import ChuSQL.Interface.Normalization
import qualified Data.Aeson as A
import ChuSQL.Core.Protocol (Account, QueryResult (..), TableInfo) import ChuSQL.Core.Protocol (Account, QueryResult (..), TableInfo)
import ChuSQL.Interface.Link ( import ChuSQL.Interface.Link (
Client, Client,
clientNormalization,
clientAccounts, clientAccounts,
clientCatalog, clientCatalog,
clientDatabases, clientDatabases,
@@ -99,9 +104,8 @@ runStatement session sql = do
case answer of case answer of
Left message -> pure (Left message) Left message -> pure (Left message)
Right result -> do Right result -> do
case qrDatabase result of for_
Just name -> writeIORef (ssCurrent session) name (qrDatabase result) (writeIORef (ssCurrent session))
Nothing -> pure ()
pure (Right result) pure (Right result)
-- | 数据字典(\\dt 与 \\d 用) -- | 数据字典(\\dt 与 \\d 用)
@@ -119,3 +123,10 @@ roleViews session = clientRoles (ssClient session)
-- | 账号清单(\\du 与管理页用) -- | 账号清单(\\du 与管理页用)
accounts :: Session -> IO (Either Text [Account]) accounts :: Session -> IO (Either Text [Account])
accounts session = clientAccounts (ssClient session) accounts session = clientAccounts (ssClient session)
-- 使用当前连接及工作库请求范式分析。
analyzeNormalization :: Session -> NormalizationRequest -> IO (Either Text A.Value)
analyzeNormalization session payload = do
current <- sessionDatabase session
if current /= nrDatabase payload then pure (Left "bad_request: normalization database differs from the selected database")
else clientNormalization (ssClient session) payload
@@ -61,7 +61,6 @@ settingCatalogue =
, owned "storage-btree-order" "Storage B+tree order" "storage" "int" "4" "btree" "order" , owned "storage-btree-order" "Storage B+tree order" "storage" "int" "4" "btree" "order"
, owned "storage-buffer-pool" "Storage buffer pool pages" "storage" "int" "1024" "buffer" "pool_size" , owned "storage-buffer-pool" "Storage buffer pool pages" "storage" "int" "1024" "buffer" "pool_size"
, owned "storage-log" "Storage log level" "storage" "text" "info" "log" "level" , owned "storage-log" "Storage log level" "storage" "text" "info" "log" "level"
, item "seed" "Seed demo data on start" "storage" "bool" "1" True True
, owned "tcp-listen-host" "TCP listen address" "network" "text" "127.0.0.1" "server" "listen_host" , owned "tcp-listen-host" "TCP listen address" "network" "text" "127.0.0.1" "server" "listen_host"
, owned "tcp-port" "TCP port" "network" "int" "7777" "server" "port" , owned "tcp-port" "TCP port" "network" "int" "7777" "server" "port"
, owned "tcp-max-message" "TCP max request line (bytes)" "network" "int" "1048576" "server" "max_message" , owned "tcp-max-message" "TCP max request line (bytes)" "network" "int" "1048576" "server" "max_message"
@@ -231,7 +230,6 @@ effectiveSettings cfg =
, ("max-page-size", tshow (wcMaxPageSize cfg)) , ("max-page-size", tshow (wcMaxPageSize cfg))
, ("max-rows", tshow (wcMaxRows cfg)) , ("max-rows", tshow (wcMaxRows cfg))
, ("max-sql-length", tshow (wcMaxSqlLength cfg)) , ("max-sql-length", tshow (wcMaxSqlLength cfg))
, ("seed", boolText (wcSeedDemo cfg))
, ("data-dir", maybe "" T.pack (wcDataDir cfg)) , ("data-dir", maybe "" T.pack (wcDataDir cfg))
, ("log-files", T.pack (wcLogFiles cfg)) , ("log-files", T.pack (wcLogFiles cfg))
] ]
@@ -36,12 +36,13 @@ writeSection path section values = do
prepared <- prepareDirectory prepared <- prepareDirectory
case prepared of case prepared of
Left err -> pure (Left err) Left err -> pure (Left err)
Right () -> do Right () -> do exists <- doesFileExist path
exists <- doesFileExist path raw <- if exists then
raw <- if exists then TE.decodeUtf8 <$> BS.readFile path else pure "" TE.decodeUtf8 <$> BS.readFile path
let updated = T.unlines (rewrite section values (T.lines raw)) else
written <- tryWrite (TE.encodeUtf8 updated) pure ""
pure written let updated = T.unlines (rewrite section values (T.lines raw))
tryWrite (TE.encodeUtf8 updated)
where where
-- | 目录不存在就先建 -- | 目录不存在就先建
prepareDirectory = do prepareDirectory = do
@@ -111,7 +112,7 @@ rewrite :: Text -> Map Text Text -> [Text] -> [Text]
rewrite section values = addMissing . replaceInSection . dropEmpties rewrite section values = addMissing . replaceInSection . dropEmpties
where where
-- | 删掉空值的键 -- | 删掉空值的键
dropEmpties = filter (\line -> maybe True (not . T.null . snd) (assignment line)) dropEmpties = filter (maybe True (not . T.null . snd) . assignment)
-- | 在目标分区里就地换行 -- | 在目标分区里就地换行
replaceInSection = go "" replaceInSection = go ""
-- | 走到目标分区后逐行替换 -- | 走到目标分区后逐行替换
@@ -158,7 +159,7 @@ keysOf wanted = go ""
appendSection :: Text -> [(Text, Text)] -> [Text] -> [Text] appendSection :: Text -> [(Text, Text)] -> [Text] -> [Text]
appendSection section entries lines' = appendSection section entries lines' =
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] ++ ("[" <> section <> "]") : [assignmentLine key value | (key, value) <- entries]
-- | 全局配置文件的固定路径,跟随系统惯例 -- | 全局配置文件的固定路径,跟随系统惯例
+15 -13
View File
@@ -2,6 +2,7 @@
module Main (main) where module Main (main) where
import Control.Monad (when)
import ChuSQL.Core.Engine.Storage.FFI (storageVersion) import ChuSQL.Core.Engine.Storage.FFI (storageVersion)
import ChuSQL.Core.Engine.Storage.IPC (closeConnection, localStorageLink, setStorageLink) import ChuSQL.Core.Engine.Storage.IPC (closeConnection, localStorageLink, setStorageLink)
import ChuSQL.Interface.Config ( import ChuSQL.Interface.Config (
@@ -22,7 +23,7 @@ import ChuSQL.Server.TCP (
newServerEnv, newServerEnv,
runServer, runServer,
) )
import Control.Exception (IOException, bracket, try) import Control.Exception (IOException, try, bracket_)
import qualified Data.Aeson as A import qualified Data.Aeson as A
import qualified Data.Aeson.KeyMap as KM import qualified Data.Aeson.KeyMap as KM
import Data.Text (Text) import Data.Text (Text)
@@ -177,7 +178,8 @@ run opts = do
(fromIntegral (wcLoginWindow cfg)) (fromIntegral (wcLoginWindow cfg))
env <- newServerEnv backend rootName configPath config limiter env <- newServerEnv backend rootName configPath config limiter
let announce port = putStrLn ("listening: tcp://" ++ scHost config ++ ":" ++ show port) 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 服务并处理绑定失败 -- | 起 TCP 服务并处理绑定失败
serve :: ServerEnv -> (Int -> IO ()) -> IO () serve :: ServerEnv -> (Int -> IO ()) -> IO ()
@@ -211,17 +213,17 @@ checkInitialized backend = do
reportCredential :: Backend -> Text -> Bool -> IO () reportCredential :: Backend -> Text -> Bool -> IO ()
reportCredential backend rootName legacy = do reportCredential backend rootName legacy = do
putStrLn ("administrator: " ++ T.unpack rootName) putStrLn ("administrator: " ++ T.unpack rootName)
if legacy when legacy
then do $ do putStrLn
putStrLn " !! the [web] section still carries a plaintext password key; it is ignored now" " !! 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" putStrLn
else pure () " !! remove it: the administrator password lives in the __system_users system table"
passwordless <- administratorPasswordless backend rootName passwordless <- administratorPasswordless backend rootName
if passwordless when passwordless
then do $ do putStrLn
putStrLn " !! the administrator has no password yet: sign in with an empty password, then set one" " !! 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)" putStrLn
else pure () " !! ALTER USER root IDENTIFIED BY '...' (or use the account page in the Web UI)"
-- | 探测存储是否可用,答不上 ping 就退出 -- | 探测存储是否可用,答不上 ping 就退出
checkStorage :: Backend -> IO () checkStorage :: Backend -> IO ()
@@ -239,7 +241,7 @@ printBanner cfg config configPath = do
version <- storageVersion version <- storageVersion
putStrLn "================== ChuSQL Server ===================" putStrLn "================== ChuSQL Server ==================="
putStrLn ("config file: " ++ configPath) putStrLn ("config file: " ++ configPath)
putStrLn ("protocol: chusql 1 (one JSON object per line)") putStrLn "protocol: chusql 1 (one JSON object per line)"
putStrLn putStrLn
( "limits: message " ( "limits: message "
++ show (scMaxMessage config) ++ show (scMaxMessage config)
+1
View File
@@ -14,6 +14,7 @@ library
exposed-modules: ChuSQL.Server.Accounts exposed-modules: ChuSQL.Server.Accounts
ChuSQL.Server.Backend ChuSQL.Server.Backend
ChuSQL.Server.Catalog ChuSQL.Server.Catalog
ChuSQL.Server.Normalization
ChuSQL.Server.Policy ChuSQL.Server.Policy
ChuSQL.Server.Privileges ChuSQL.Server.Privileges
ChuSQL.Server.ObjectACL ChuSQL.Server.ObjectACL
+3 -3
View File
@@ -119,7 +119,7 @@ validateUserName name
-- | 校验新身份的名称 -- | 校验新身份的名称
validateNewName :: Accounts -> Text -> Either AccountError () validateNewName :: Accounts -> Text -> Either AccountError ()
validateNewName _ name = validateUserName name validateNewName _ = validateUserName
storageFailure :: AccountError storageFailure :: AccountError
storageFailure = AccountError "storage_error" "account storage unavailable" storageFailure = AccountError "storage_error" "account storage unavailable"
@@ -300,7 +300,7 @@ accountCommand _ = Nothing
-- | 按目录管理权限执行账号命令 -- | 按目录管理权限执行账号命令
runAccountCommand :: Accounts -> Principal -> AccountCommand -> IO (Either AccountError ()) 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 where
-- | 校验并执行身份管理权限 -- | 校验并执行身份管理权限
run 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 (AlterAccountAttributes _ attributes) = any (\(key, _) -> key `elem` ["superuser", "system_catalog_manager", "allow_sudo_auth"]) attributes
privilegedChange _ = False 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 executeWith managed = case command of
CreateAccount name _ | normalize name == "public" -> pure (Left (AccountError "bad_request" "public is reserved for default privileges")) CreateAccount name _ | normalize name == "public" -> pure (Left (AccountError "bad_request" "public is reserved for default privileges"))
+52 -37
View File
@@ -21,6 +21,7 @@ module ChuSQL.Server.Backend (
tableRefsOf, tableRefsOf,
) where ) where
import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
import ChuSQL.Core.Engine (runStatement, runStatementM) import ChuSQL.Core.Engine (runStatement, runStatementM)
import ChuSQL.Core.Model import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Semantic (prepare) import ChuSQL.Core.Engine.Semantic (prepare)
@@ -40,8 +41,8 @@ import ChuSQL.Core.Engine.Storage.IPC (
import ChuSQL.Core.Engine.Syntax.AST import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Engine.Syntax.Parser (parseStatement) import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
import ChuSQL.Core.Protocol (TxnOp (..)) import ChuSQL.Core.Protocol (TxnOp (..))
import Control.Concurrent.MVar (MVar, modifyMVar, readMVar) import Control.Concurrent.MVar (MVar, modifyMVar)
import Data.List (nub) import Data.List (nub, isPrefixOf)
import Data.Text (Text) import Data.Text (Text)
import Data.Time (getCurrentTime) import Data.Time (getCurrentTime)
import Data.Time.Format (defaultTimeLocale, formatTime) import Data.Time.Format (defaultTimeLocale, formatTime)
@@ -75,16 +76,20 @@ data Backend = Backend
-- | 按给定列名取列,固定列顺序 -- | 按给定列名取列,固定列顺序
columnsFromStatement :: Database -> Statement -> [String] columnsFromStatement :: Database -> Statement -> [String]
columnsFromStatement db stmt = case prepare db stmt of columnsFromStatement db stmt = case prepare db stmt of
Right (Select cols _ _ _ _ _) -> cols Left _ -> []
Right (SelectExpr items _ _ _ _ _) -> map fst items Right resolved -> columnsOf resolved
Right ShowDomains -> ["domain", "base_type"] where
_ -> [] -- | 从已准备的语句提取输出列名
columnsOf (SelectDistinct q) = columnsOf q
columnsOf Select{selectItems = items} = map fst items
columnsOf ShowDomains = ["domain", "base_type"]
columnsOf _ = []
-- | 走本地存储链路的后端 -- | 走本地存储链路的后端
ipcBackend :: IO Backend ipcBackend :: IO Backend
ipcBackend = do ipcBackend = do
let backend current = Backend let backend current = Backend
{ beStatement = \sql -> runIpc current sql { beStatement = runIpc current
, beCatalog = do , beCatalog = do
response <- sendRequest (ReqInDatabase current ReqListCatalog) response <- sendRequest (ReqInDatabase current ReqListCatalog)
pure $ case response of pure $ case response of
@@ -107,8 +112,8 @@ ipcBackend = do
RespTables names -> Right names RespTables names -> Right names
RespError err -> Left err RespError err -> Left err
_ -> Left "unexpected database response" _ -> Left "unexpected database response"
, beStorage = \payload -> runRaw payload , beStorage = runRaw
, beSnapshot = Right <$> runIPCStorageIn (snapshot :: IPCStorage Database) (sessionEnv current) , beSnapshot = runIPCStorageIn snapshot (sessionEnv current)
, beApplyTransaction = \ops -> do , beApplyTransaction = \ops -> do
response <- sendRequest (ReqInDatabase current (ReqApplyTransaction ops)) response <- sendRequest (ReqInDatabase current (ReqApplyTransaction ops))
pure $ case response of pure $ case response of
@@ -148,10 +153,10 @@ ipcBackend = do
Right rows -> do Right rows -> do
cols <- case rows of cols <- case rows of
[] -> do [] -> do
db <- runIPCStorageIn (schema :: IPCStorage Database) env db <- runIPCStorageIn schema env
pure (columnsFromStatement db stmt) pure (fmap (`columnsFromStatement` stmt) db)
(r : _) -> pure (map fst r) (r : _) -> pure (Right (map fst r))
pure (Right (StatementResult cols rows)) pure (fmap (`StatementResult` rows) cols)
-- | 测试用内存后端,状态是一个 Database -- | 测试用内存后端,状态是一个 Database
memoryBackend :: String -> MVar Database -> Backend memoryBackend :: String -> MVar Database -> Backend
@@ -173,9 +178,9 @@ memoryBackendWith trusted name ref =
Right (db', rows) Right (db', rows)
| any (\(key, _) -> hidden key && not (domainKey key)) db' -> pure (db, Left "reserved system table") | any (\(key, _) -> hidden key && not (domainKey key)) db' -> pure (db, Left "reserved system table")
| otherwise -> pure (syncMemoryObjects name (mergeScoped db db'), Right (StatementResult (colsOf (scoped db) stmt rows) rows)) | otherwise -> pure (syncMemoryObjects name (mergeScoped db db'), Right (StatementResult (colsOf (scoped db) stmt rows) rows))
, beCatalog = do , beCatalog = modifyMVar ref $ \original -> do
db <- readMVar ref let db = syncMemoryObjects name original
pure (Right (map tableInfoOf (filter (not . internalTable . fst) (scoped db)))) pure (db, Right (map tableInfoOf (filter (not . internalTable . fst) (scoped db))))
, bePing = pure True , bePing = pure True
, beAccounts = \req -> do , beAccounts = \req -> do
stamp <- currentStamp stamp <- currentStamp
@@ -187,7 +192,9 @@ memoryBackendWith trusted name ref =
, beWithDatabase = withDatabase , beWithDatabase = withDatabase
, beDatabases = pure (Right (nub [name, systemDatabaseName])) , beDatabases = pure (Right (nub [name, systemDatabaseName]))
, beStorage = memorySecurityRequest name ref , beStorage = memorySecurityRequest name ref
, beSnapshot = Right . scoped <$> readMVar ref , beSnapshot = modifyMVar ref $ \original -> do
let db = syncMemoryObjects name original
pure (db, Right (scoped db))
, beApplyTransaction = \ops -> modifyMVar ref $ \db -> case applyTransactionMemory ops (scoped db) of , beApplyTransaction = \ops -> modifyMVar ref $ \db -> case applyTransactionMemory ops (scoped db) of
Left err -> pure (db, Left err) Left err -> pure (db, Left err)
Right db' -> pure (mergeScoped db db', Right ()) Right db' -> pure (mergeScoped db db', Right ())
@@ -226,7 +233,8 @@ memoryBackendWith trusted name ref =
-- 更新内存夹具的稳定表编号。 -- 更新内存夹具的稳定表编号。
syncMemoryObjects :: String -> Database -> Database syncMemoryObjects :: String -> Database -> Database
syncMemoryObjects database db = (registry, Table registry [("name", TStr), ("id", TInt)] records Nothing) : filter ((/= registry) . fst) db syncMemoryObjects database db = (registry, Table registry [("name", TStr), ("id", TInt)] records Nothing Nothing Nothing)
: map identify (filter ((/= registry) . fst) db)
where where
registry = "__system_object_ids" registry = "__system_object_ids"
previous = [(key, identifier) | row <- maybe [] tableRows (lookup registry db), Just (VStr key) <- [lookup "name" row], Just (VInt identifier) <- [lookup "id" row]] previous = [(key, identifier) | row <- maybe [] tableRows (lookup registry db), Just (VStr key) <- [lookup "name" row], Just (VInt identifier) <- [lookup "id" row]]
@@ -234,6 +242,11 @@ syncMemoryObjects database db = (registry, Table registry [("name", TStr), ("id"
retained = [(key, identifier) | (key, identifier) <- previous, key `elem` keys] retained = [(key, identifier) | (key, identifier) <- previous, key `elem` keys]
high = maximum (0 : map snd previous) high = maximum (0 : map snd previous)
added = zip [key | key <- keys, key `notElem` map fst retained] [high + 1 ..] added = zip [key | key <- keys, key `notElem` map fst retained] [high + 1 ..]
-- | 将稳定目录编号附到表定义
identify (key, table) = case lookup (if '.' `elem` key then key else database ++ "." ++ key) (retained ++ added) of
Just identifier -> (key, table {tableIdentity = Just (TableIdentity
(if "system." `isPrefixOf` key || ('.' `notElem` key && database == "system") then 2 else 1) (fromIntegral identifier))})
Nothing -> (key, table)
records = [[("name", VStr key), ("id", VInt identifier)] | (key, identifier) <- ("__high_water", high + length added) : retained ++ added] records = [[("name", VStr key), ("id", VInt identifier)] | (key, identifier) <- ("__high_water", high + length added) : retained ++ added]
-- 执行内存夹具的权限快照协议。 -- 执行内存夹具的权限快照协议。
@@ -266,7 +279,7 @@ memorySecurityRequest database ref payload = modifyMVar ref $ \original -> do
let previous = case lookup acl db of Nothing -> Nothing; Just table -> case tableRows table of [[("payload", VStr value)]] -> Just (T.pack value); _ -> Just "invalid ACL" let previous = case lookup acl db of Nothing -> Nothing; Just table -> case tableRows table of [[("payload", VStr value)]] -> Just (T.pack value); _ -> Just "invalid ACL"
if previous /= field "expected" then Left "object ACL changed concurrently" else do if previous /= field "expected" then Left "object ACL changed concurrently" else do
value <- maybe (Left "missing ACL payload") Right (field "payload") value <- maybe (Left "missing ACL payload") Right (field "payload")
Right ((acl, Table acl [("payload", TStr)] [[("payload", VStr (T.unpack value))]] Nothing) : filter ((/= acl) . fst) db, A.object ["status" A..= ("ok" :: Text)]) Right ((acl, Table acl [("payload", TStr)] [[("payload", VStr (T.unpack value))]] Nothing Nothing Nothing) : filter ((/= acl) . fst) db, A.object ["status" A..= ("ok" :: Text)])
_ -> Left "storage is not available in this backend" _ -> Left "storage is not available in this backend"
acl = "__system_object_acl" acl = "__system_object_acl"
@@ -320,15 +333,15 @@ applyTransactionMemory ops db = foldl step (Right db) ops
-- | 语句里出现的表 -- | 语句里出现的表
statementTables :: Statement -> [Text] statementTables :: Statement -> [Text]
statementTables stmt = nub (case stmt of statementTables stmt = nub (case stmt of
SelectDistinct q -> statementTables q
Select{} -> Select{} ->
tableRefsOf (selectFrom stmt) tableRefsOf (selectFrom stmt)
++ concatMap exprTables (maybe [] (: []) (selectWhere stmt) ++ map Col (selectCols stmt ++ selectGroupBy stmt ++ map fst (selectOrderBy stmt))) ++ concatMap exprTables (maybeToList (selectWhere stmt) ++ maybeToList (selectHaving stmt)
SelectExpr{} -> ++ map snd (selectItems stmt) ++ map Col (selectGroupBy stmt)
tableRefsOf (selectFrom stmt) ++ mapMaybe (orderKeyExpression . fst) (selectOrderBy stmt))
++ concatMap exprTables (maybe [] (: []) (selectWhere stmt) ++ map snd (selectItems stmt) ++ map Col (selectGroupBy stmt ++ map fst (selectOrderBy stmt)))
Insert table _ rows -> T.pack table : concatMap exprTables (concat rows) Insert table _ rows -> T.pack table : concatMap exprTables (concat rows)
Update table assigns cond -> T.pack table : concatMap exprTables (map snd assigns ++ maybe [] (: []) cond) Update table assigns cond -> T.pack table : concatMap exprTables (map snd assigns ++ maybeToList cond)
Delete table cond -> T.pack table : concatMap exprTables (maybe [] (: []) cond) Delete table cond -> T.pack table : concatMap exprTables (maybeToList cond)
CreateTable table _ -> [T.pack table] CreateTable table _ -> [T.pack table]
DropTable table -> [T.pack table] DropTable table -> [T.pack table]
CreateIndex table _ -> [T.pack table] CreateIndex table _ -> [T.pack table]
@@ -362,12 +375,12 @@ statementNeedsDatabase stmt = case stmt of
-- | 将当前库限定的结构目标转为裸表名 -- | 将当前库限定的结构目标转为裸表名
scopeDdl :: String -> Statement -> Either String Statement scopeDdl :: String -> Statement -> Either String Statement
scopeDdl current statement = case statement of 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 DropTable table -> DropTable <$> target table
CreateIndex table column -> (\key -> CreateIndex key column) <$> target table CreateIndex table column -> (`CreateIndex` column) <$> target table
DropIndex table column -> (\key -> DropIndex key column) <$> target table DropIndex table column -> (`DropIndex` column) <$> target table
DropColumn table column -> (\key -> DropColumn key column) <$> target table DropColumn table column -> (`DropColumn` column) <$> target table
AddColumn table column -> (\key -> AddColumn key column) <$> target table AddColumn table column -> (`AddColumn` column) <$> target table
RenameColumn table old new -> (\key -> RenameColumn key old new) <$> target table RenameColumn table old new -> (\key -> RenameColumn key old new) <$> target table
AlterColumnType table column ty -> (\key -> AlterColumnType key column ty) <$> target table AlterColumnType table column ty -> (\key -> AlterColumnType key column ty) <$> target table
AlterColumnDefault table column value -> (\key -> AlterColumnDefault key column value) <$> target table AlterColumnDefault table column value -> (\key -> AlterColumnDefault key column value) <$> target table
@@ -440,6 +453,8 @@ tableInfoOf (name, tbl) =
, tiRows = length (tableRows tbl) , tiRows = length (tableRows tbl)
, tiIndexes = [] , tiIndexes = []
, tiStats = [(c, distinctOf c, False) | (c, _) <- tableCols tbl] , tiStats = [(c, distinctOf c, False) | (c, _) <- tableCols tbl]
, tiIdentity = tableIdentity tbl
, tiSchemaVersion = tableSchemaVersion tbl
, tiHistograms = [(c, h) | (c, _) <- tableCols tbl, Just h <- [histogramOf (columnValues c)]] , tiHistograms = [(c, h) | (c, _) <- tableCols tbl, Just h <- [histogramOf (columnValues c)]]
} }
where where
@@ -546,10 +561,10 @@ memoryAccounts db stamp req = do
| any ((== T.toLower u) . accountUser) accounts -> Left "identity already exists" | 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]) | 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 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, [_] -> preserveSuper [if accountUser a == T.toLower u then a{accountCanLogin = fromMaybe (accountCanLogin a) login,
accountIsSuperuser = maybe (accountIsSuperuser a) id super, accountEnabled = maybe (accountEnabled a) id enabled, accountIsSuperuser = fromMaybe (accountIsSuperuser a) super, accountEnabled = fromMaybe (accountEnabled a) enabled,
accountSystemCatalogManager = maybe (accountSystemCatalogManager a) id manager, accountSystemCatalogManager = fromMaybe (accountSystemCatalogManager a) manager,
accountAllowSudoAuth = maybe (accountAllowSudoAuth a) id sudo, accountAllowSudoAuth = fromMaybe (accountAllowSudoAuth a) sudo,
accountRevision = accountRevision a + 1} else a | a <- accounts] accounts accountRevision = accountRevision a + 1} else a | a <- accounts] accounts
_ -> Left "unknown account" _ -> Left "unknown account"
ReqAccountCreate u h ReqAccountCreate u h
@@ -594,9 +609,9 @@ memoryAccounts db stamp req = do
-- | 分开保存内存身份与口令并清理授权 -- | 分开保存内存身份与口令并清理授权
storeMemoryIdentities :: Database -> [Account] -> [Account] -> Database storeMemoryIdentities :: Database -> [Account] -> [Account] -> Database
storeMemoryIdentities db previous accounts = storeMemoryIdentities db previous accounts =
(usersTable, Table usersTable [("id", TInt), ("password_hash", TStr)] credentials Nothing) : (usersTable, Table usersTable [("id", TInt), ("password_hash", TStr)] credentials Nothing Nothing Nothing) :
("__system_identities", Table "__system_identities" [("account", TStr)] identities Nothing) : ("__system_identities", Table "__system_identities" [("account", TStr)] identities Nothing Nothing Nothing) :
("__system_identity_sequence", Table "__system_identity_sequence" [("id", TInt)] [[("id", VInt highWater)]] Nothing) : ("__system_identity_sequence", Table "__system_identity_sequence" [("id", TInt)] [[("id", VInt highWater)]] Nothing Nothing Nothing) :
[(name, clean name table) | (name, table) <- db, name `notElem` [usersTable, "__system_identities", "__system_identity_sequence"]] [(name, clean name table) | (name, table) <- db, name `notElem` [usersTable, "__system_identities", "__system_identity_sequence"]]
where where
-- | 保存口令与身份编号 -- | 保存口令与身份编号
+3 -2
View File
@@ -23,6 +23,7 @@ module ChuSQL.Server.Catalog
, removeMember , removeMember
) where ) where
import Control.Monad (void)
import ChuSQL.Core.Model (Row, Value (..)) import ChuSQL.Core.Model (Row, Value (..))
import ChuSQL.Core.Protocol (Account (..), Request (..)) import ChuSQL.Core.Protocol (Account (..), Request (..))
import ChuSQL.Interface.Actions (escapeStringLiteral) import ChuSQL.Interface.Actions (escapeStringLiteral)
@@ -112,11 +113,11 @@ readIdentities catalog = beAccounts (catBackend catalog) ReqAccountsList
-- | 新建一个角色 -- | 新建一个角色
insertRole :: Catalog -> Text -> IO (Either String ()) 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 -> 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 -- | 全部授权,都不带 grant option
readGrants :: Catalog -> IO (Either String [Grant]) readGrants :: Catalog -> IO (Either String [Grant])
@@ -0,0 +1,101 @@
{-# LANGUAGE OverloadedStrings #-}
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)
import ChuSQL.Interface.Normalization
import Control.Concurrent.MVar
import Control.Concurrent.QSem
import Control.Exception (bracket_, evaluate, mask)
import Crypto.Hash (Digest, SHA256, hash)
import qualified Data.Aeson as A
import Data.Aeson ((.=), object)
import qualified Data.ByteString.Lazy as BL
import Data.List (nub, sort)
import Data.Text (Text)
import qualified Data.Text as T
import System.IO.Unsafe (unsafePerformIO)
import System.Timeout (timeout)
-- 范式服务:有界执行、稳定 schema 指纹与引擎报告的线上表示。
{-# NOINLINE analysisSlots #-}
-- 保存最多八个请求和两个执行槽。
analysisSlots :: (MVar Int, QSem)
analysisSlots = unsafePerformIO ((,) <$> newMVar 0 <*> newQSem 2)
-- 限制排队、执行时间及输出大小。
normalizationBudget :: IO (Either (Text, Text) A.Value) -> IO (Either (Text, Text) A.Value)
normalizationBudget action = mask $ \restore -> do
let (queued, slots) = analysisSlots
admitted <- modifyMVar queued $ \count -> pure (if count < 8 then (count + 1, True) else (count, False))
if not admitted then pure (Left ("too_busy", "normalization queue is full")) else
bracket_ (pure ()) (modifyMVar_ queued (pure . subtract 1)) $ do
result <- restore $ timeout 5000000 $ bracket_ (waitQSem slots) (signalQSem slots) $ do
outcome <- action
case outcome of
Left err -> pure (Left err)
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 (fromMaybe (Left ("timeout", "normalization exceeded its five second budget")) result)
-- 编码只影响语义的列信息。
fingerprintColumn :: SchemaColumn -> A.Value
fingerprintColumn c = A.toJSON [A.toJSON (scName c), A.toJSON (scType c), A.toJSON (scNullable c),
maybe A.Null valueToJSON (scDefault c), A.toJSON (scAutoIncrement c), A.toJSON (scPrimaryKey c), A.toJSON (scUnique c), A.toJSON (scCheck c)]
-- 将稳定编号与列结构绑定到 SHA256。
schemaFingerprint :: ObjectIdentity -> [SchemaColumn] -> Text
schemaFingerprint (ObjectIdentity database table) columns = T.pack (show (hash (BL.toStrict (A.encode (A.toJSON [A.toJSON [show database, show table], A.toJSON (map fingerprintColumn columns)]))) :: Digest SHA256))
-- 绑定 schema 并编码只读分析报告。
normalizationReport :: ObjectIdentity -> [SchemaColumn] -> Text -> NormalizationRequest -> Either (Text, Text) A.Value
normalizationReport identity columns view payload = do
let fingerprint = schemaFingerprint identity columns
if maybe False (/= identity) (nrExpectedObject payload) || maybe False (/= fingerprint) (nrExpectedSchema payload)
then Left ("conflict", "normalization object or schema has changed") else Right ()
schema <- mapM column columns
let declaration = nrDeclaration payload
axioms = N.Declaration (ndKeys declaration) [N.Dependency a b | NormalizationDependency a b <- ndDependencies declaration] (ndComplete declaration) (ndAtomic declaration)
analysis <- either (Left . (,) "bad_request" . T.pack) Right (N.analyzeNormalization schema axioms)
Right (object ["api_version" .= (1 :: Int), "database" .= nrDatabase payload, "table" .= last (T.splitOn "." (nrTable payload)),
"object" .= identity, "schema_fingerprint" .= fingerprint, "view" .= view, "schema" .= columns,
"declaration" .= canonicalDeclaration declaration, "candidate_keys" .= N.candidateKeys analysis,
"findings" .= map findingJSON (N.findings analysis), "suggestions" .= map decompositionJSON (N.suggestions analysis),
"conditional" .= True, "condition" .= ("Analysis is conditional on the declarations; SQL NULL, UNIQUE and bag semantics are not proofs of classical keys or lossless data migration." :: Text)])
where
-- 还原列类型及声明约束而不读取数据。
column c = case parseColumnType (scType c) of
Nothing -> Left ("storage_error", "normalization: invalid schema type")
Just ty -> Right (scName c, Column ty (scNullable c) (scDefault c) (scAutoIncrement c) (scUnique c) (scPrimaryKey c) (scCheck c))
-- 规范化经验证的声明属性集合。
canonicalDeclaration :: NormalizationDeclaration -> NormalizationDeclaration
canonicalDeclaration d = d {ndKeys = sort (nub (map N.canonical (ndKeys d))),
ndDependencies = [NormalizationDependency a b | (a, b) <- sort (nub [(N.canonical a, N.canonical b) | NormalizationDependency a b <- ndDependencies d])]}
-- 编码稳定范式标签及证据。
findingJSON :: N.Finding -> A.Value
findingJSON f = object ["normal_form" .= formTag (N.normalForm f), "verdict" .= verdictTag (N.verdict f),
"witnesses" .= [NormalizationDependency a b | N.Dependency a b <- N.witnesses f], "condition" .= N.condition f]
-- 编码一次分解的理论结论。
decompositionJSON :: N.Decomposition -> A.Value
decompositionJSON d = object ["relations" .= N.relations d, "lossless_join" .= verdictTag (N.losslessJoin d), "dependency_preserving" .= verdictTag (N.dependencyPreserving d)]
-- 输出稳定的范式名称。
formTag :: N.NormalForm -> Text
formTag N.NF1 = "1nf"
formTag N.NF2 = "2nf"
formTag N.NF3 = "3nf"
formTag N.BCNF = "bcnf"
-- 输出稳定的结论标签。
verdictTag :: N.Verdict -> Text
verdictTag N.Satisfied = "satisfied"
verdictTag N.Violated = "violated"
verdictTag N.Insufficient = "insufficient"
+55 -18
View File
@@ -2,10 +2,12 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Server.ObjectACL module ChuSQL.Server.ObjectACL
( objectAuthorize, objectGrant, objectRevoke, objectViews, objectClaim ( objectAuthorize, objectGrant, objectRevoke, objectRevokeGrantOption, objectViews, objectClaim
, objectReconcile, objectAffected, objectOwner, objectConnect, objectPrepareCreate, objectUsers , objectSelfViews, objectReconcile, objectAffected, objectOwner, objectConnect, objectPrepareCreate, objectUsers
) where ) where
import Data.Either (fromRight)
import Control.Monad (void)
import ChuSQL.Core.Protocol (Account (..), TableInfo (..)) import ChuSQL.Core.Protocol (Account (..), TableInfo (..))
import ChuSQL.Interface.Protocol (Grant (..)) import ChuSQL.Interface.Protocol (Grant (..))
import ChuSQL.Server.Accounts (Principal, principalIsRoot, principalName) 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 -> Text -> Text -> IO (Either String Target)
resolve backend database raw = do resolve backend database raw = do
let object = T.toLower (T.strip raw) let object = T.toLower (T.strip raw)
(selected, table, kind, label) = (selected, table, kind, label)
if "database:" `T.isPrefixOf` object then (T.drop 9 object, Nothing, "database", object) | "database:" `T.isPrefixOf` object = (T.drop 9 object, Nothing, "database", object)
else if object == "*" || ".*" `T.isSuffixOf` object then | object == "*" || ".*" `T.isSuffixOf` object =
let scope = if object == "*" then database else T.dropEnd 2 object let scope = if object == "*" then database else T.dropEnd 2 object
in (scope, Nothing, "tables", scope <> ".*") in (scope, Nothing, "tables", scope <> ".*")
else case T.splitOn "." object of | otherwise = case T.splitOn "." object of
[name] -> (database, Just name, "table", database <> "." <> name) [name] -> (database, Just name, "table", database <> "." <> name)
[db, name] -> (db, Just name, "table", object) [db, name] -> (db, Just name, "table", object)
_ -> ("", Just "", "table", object) _ -> ("", Just "", "table", object)
@@ -102,7 +104,7 @@ targets backend = do
names <- beDatabases backend names <- beDatabases backend
case names of case names of
Left err -> pure (Left err) 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 where
-- 展开一个数据库和它的表。 -- 展开一个数据库和它的表。
one name = do one name = do
@@ -150,7 +152,12 @@ knownRole env value = value `elem` ["0", "public"] || any (\account -> T.pack (s
roles :: Context -> Text -> [Text] roles :: Context -> Text -> [Text]
roles env value = nub ("public" : go [value]) roles env value = nub ("public" : go [value])
where 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] 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)) 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 -> 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) 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" if all (`elem` supported) expanded then Right expanded else Left "invalid privilege for object scope"
where where
supported = if targetKind target == "database" then ["connect", "create"] else ["select", "insert", "update", "delete"] 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 ()) 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 Right ((env, previous, acl), target) -> case do
recipient <- roleId env role recipient <- roleId env role
items <- privileges target names items <- privileges target names
grantor <- if principalIsRoot principal then Right (either (const "0") id (roleId env (principalName principal))) else roleId env (principalName principal) grantor <- if principalIsRoot principal then Right (fromRight "0" (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 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)) item : _ -> Left ("grant option required: " ++ T.unpack (T.toUpper item <> " ON " <> object))
[] -> Right (recipient, grantor, items) of [] -> Right (recipient, grantor, items) of
Left err -> pure (Left err) Left err -> pure (Left err)
@@ -315,19 +328,28 @@ objectGrant backend catalog principal database names object role option = do
-- 撤销授权并收敛失去来源的下游授权。 -- 撤销授权并收敛失去来源的下游授权。
objectRevoke :: Backend -> Catalog -> Principal -> Text -> [Text] -> Text -> Text -> IO (Either String ()) objectRevoke :: Backend -> Catalog -> Principal -> Text -> [Text] -> Text -> Text -> IO (Either String ())
objectRevoke backend catalog principal database names object role = do objectRevoke = revokeObject False
-- 仅撤销转授权能力并清理失效来源。
objectRevokeGrantOption :: Backend -> Catalog -> Principal -> Text -> [Text] -> Text -> Text -> IO (Either String ())
objectRevokeGrantOption = revokeObject True
-- 按授予来源撤销权限或转授权能力。
revokeObject :: Bool -> Backend -> Catalog -> Principal -> Text -> [Text] -> Text -> Text -> IO (Either String ())
revokeObject optionOnly backend catalog principal database names object role = do
loaded <- load backend catalog loaded <- load backend catalog
resolved <- resolve backend database object resolved <- resolve backend database object
case (,) <$> loaded <*> resolved of case (,) <$> loaded <*> resolved of
Left err -> pure (Left err) Left err -> pure (Left err)
Right ((env, previous, acl), target) -> case (,) <$> roleId env role <*> privileges target names of Right ((env, previous, acl), target) -> case (,,) <$> roleId env role <*> privileges target names <*> (if principalIsRoot principal then Right "0" else roleId env (principalName principal)) of
Left err -> pure (Left err) Left err -> pure (Left err)
Right (recipient, items) -> do Right (recipient, items, grantor) -> do
let grantor = either (const "") id (roleId env (principalName principal)) let manager = principalIsRoot principal || owns env acl grantor target
manager = principalIsRoot principal || owns env acl grantor target
-- 选择本次可撤销的授予来源。 -- 选择本次可撤销的授予来源。
matches edge = edgeRole edge == recipient && edgeTarget edge == target && edgePrivilege edge `elem` items && (manager || edgeGrantor edge == grantor) matches edge = edgeRole edge == recipient && edgeTarget edge == target && edgePrivilege edge `elem` items && (manager || edgeGrantor edge == grantor)
next = acl{aclEdges = filter (not . matches) (aclEdges acl), aclClosed = if recipient == "public" && "connect" `elem` items then nub (targetDatabase target : aclClosed acl) else aclClosed acl} next = acl{aclEdges = if optionOnly then map removeOption (aclEdges acl) else filter (not . matches) (aclEdges acl), aclClosed = if not optionOnly && recipient == "public" && "connect" `elem` items then nub (targetDatabase target : aclClosed acl) else aclClosed acl}
-- 保留基础权限并移除匹配来源的转授权。
removeOption edge = if matches edge then edge{edgeOption = False} else edge
if recipient == "public" && "connect" `elem` items && not manager then pure (Left "administrator required") if recipient == "public" && "connect" `elem` items && not manager then pure (Left "administrator required")
else writeACL backend previous (effective env next) else writeACL backend previous (effective env next)
@@ -341,6 +363,21 @@ objectViews backend catalog role = do
let mine = [edge | edge <- aclEdges acl, edgeRole edge == identity] let mine = [edge | edge <- aclEdges acl, edgeRole edge == identity]
Right (nub [Grant role (edgePrivilege edge) (targetName (edgeTarget edge)) (any (\other -> edgeTarget other == edgeTarget edge && edgePrivilege other == edgePrivilege edge && edgeOption other) mine) | edge <- mine]) Right (nub [Grant role (edgePrivilege edge) (targetName (edgeTarget edge)) (any (\other -> edgeTarget other == edgeTarget edge && edgePrivilege other == edgePrivilege edge && edgeOption other) mine) | edge <- mine])
-- 列出当前身份实际拥有的对象权限。
objectSelfViews :: Backend -> Catalog -> Principal -> IO (Either String [Grant])
objectSelfViews backend catalog principal = do
loaded <- load backend catalog
pure $ do
(env, _, acl) <- loaded
identity <- roleId env (principalName principal)
if active env identity then Right () else Left "permission denied: disabled identity"
-- 使用当前权限闭包判断普通及转授权权限。
let permitted target privilege option = principalIsRoot principal || allowed env acl identity target privilege option
Right [Grant (principalName principal) privilege (targetName target) (permitted target privilege True)
| target <- contextTargets env
, privilege <- if targetKind target == "database" then ["connect", "create"] else ["select", "insert", "update", "delete"]
, permitted target privilege False]
-- 登记新对象的创建者为所有者。 -- 登记新对象的创建者为所有者。
objectClaim :: Backend -> Catalog -> Principal -> Text -> Text -> IO (Either String ()) objectClaim :: Backend -> Catalog -> Principal -> Text -> Text -> IO (Either String ())
objectClaim backend catalog principal database object = do objectClaim backend catalog principal database object = do
+1 -1
View File
@@ -1,4 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Server.Policy ( module ChuSQL.Server.Policy (
configurePasswordPolicy, configurePasswordPolicy,
+24 -13
View File
@@ -2,15 +2,16 @@
module ChuSQL.Server.Privileges module ChuSQL.Server.Privileges
( Grant (..), Membership (..), PrivilegeCommand (..), PrivilegeError (..), Privileges, RoleView (..) ( Grant (..), Membership (..), PrivilegeCommand (..), PrivilegeError (..), Privileges, RoleView (..)
, affectedAccounts, authorize, authorizeTables, authorizeConnect, filterTables, listRoleViews , affectedAccounts, authorize, authorizeTables, authorizeConnect, filterTables, listRoleViews, listSelfGrants
, newPrivileges, normalizeObject, privilegeCommand, runPrivilegeCommand, claimObject, prepareObject, reconcileObjects, affectedObject , newPrivileges, normalizeObject, privilegeCommand, runPrivilegeCommand, claimObject, prepareObject, reconcileObjects, affectedObject
) where ) where
import Data.Maybe (maybeToList)
import ChuSQL.Core.Engine.Syntax.AST import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Protocol (Account (..)) import ChuSQL.Core.Protocol (Account (..))
import ChuSQL.Interface.Protocol (Grant (..), RoleView (..)) import ChuSQL.Interface.Protocol (Grant (..), RoleView (..))
import ChuSQL.Server.Accounts (Principal, principalIsRoot, principalIsCatalogManager) 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 ChuSQL.Server.Catalog
import qualified ChuSQL.Server.ObjectACL as OA import qualified ChuSQL.Server.ObjectACL as OA
import Data.List (nub, sort) import Data.List (nub, sort)
@@ -22,7 +23,7 @@ import qualified Data.Text as T
data PrivilegeError = PrivilegeError Text Text deriving (Show, Eq) data PrivilegeError = PrivilegeError Text Text deriving (Show, Eq)
data Membership = Membership { memberRole :: Text, memberUser :: Text } deriving (Show, Eq, Ord) data Membership = Membership { memberRole :: Text, memberUser :: Text } deriving (Show, Eq, Ord)
data PrivilegeCommand = CreateRoleCommand Text | DropRoleCommand Text data PrivilegeCommand = CreateRoleCommand Text | DropRoleCommand Text
| GrantPrivilegesCommand [Text] Text Text Bool | RevokePrivilegesCommand [Text] Text Text | GrantPrivilegesCommand [Text] Text Text Bool | RevokePrivilegesCommand [Text] Text Text | RevokeGrantOptionCommand [Text] Text Text
| GrantRoleCommand Text [Text] | RevokeRoleCommand Text [Text] deriving (Show, Eq) | GrantRoleCommand Text [Text] | RevokeRoleCommand Text [Text] deriving (Show, Eq)
data Privileges = Privileges { pvCatalog :: Catalog, pvBackend :: Backend } data Privileges = Privileges { pvCatalog :: Catalog, pvBackend :: Backend }
@@ -38,6 +39,7 @@ privilegeCommand statement = case statement of
CreateRole name -> Just (CreateRoleCommand (T.pack name)) CreateRole name -> Just (CreateRoleCommand (T.pack name))
DropRole name -> Just (DropRoleCommand (T.pack name)) DropRole name -> Just (DropRoleCommand (T.pack name))
GrantPrivileges items object role option -> Just (GrantPrivilegesCommand (map (T.toLower . T.pack) items) (T.pack object) (T.pack role) option) GrantPrivileges items object role option -> Just (GrantPrivilegesCommand (map (T.toLower . T.pack) items) (T.pack object) (T.pack role) option)
RevokeGrantOption items object role -> Just (RevokeGrantOptionCommand (map (T.toLower . T.pack) items) (T.pack object) (T.pack role))
RevokePrivileges items object role -> Just (RevokePrivilegesCommand (map (T.toLower . T.pack) items) (T.pack object) (T.pack role)) RevokePrivileges items object role -> Just (RevokePrivilegesCommand (map (T.toLower . T.pack) items) (T.pack object) (T.pack role))
GrantRole role members -> Just (GrantRoleCommand (T.pack role) (map T.pack members)) GrantRole role members -> Just (GrantRoleCommand (T.pack role) (map T.pack members))
RevokeRole role members -> Just (RevokeRoleCommand (T.pack role) (map T.pack members)) RevokeRole role members -> Just (RevokeRoleCommand (T.pack role) (map T.pack members))
@@ -47,6 +49,7 @@ privilegeCommand statement = case statement of
runPrivilegeCommand :: Privileges -> Principal -> Text -> PrivilegeCommand -> IO (Either PrivilegeError ()) runPrivilegeCommand :: Privileges -> Principal -> Text -> PrivilegeCommand -> IO (Either PrivilegeError ())
runPrivilegeCommand service principal database command = withTables service $ case command of runPrivilegeCommand service principal database command = withTables service $ case command of
GrantPrivilegesCommand items object role option -> catalog (OA.objectGrant backend directory principal database items object role option) GrantPrivilegesCommand items object role option -> catalog (OA.objectGrant backend directory principal database items object role option)
RevokeGrantOptionCommand items object role -> catalog (OA.objectRevokeGrantOption backend directory principal database items object role)
RevokePrivilegesCommand items object role -> catalog (OA.objectRevoke backend directory principal database items object role) RevokePrivilegesCommand items object role -> catalog (OA.objectRevoke backend directory principal database items object role)
CreateRoleCommand role CreateRoleCommand role
| principalIsCatalogManager principal -> do | principalIsCatalogManager principal -> do
@@ -68,7 +71,7 @@ runPrivilegeCommand service principal database command = withTables service $ ca
Left err -> pure (Left err) 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) Right () -> eachAction members $ \member -> if (normalizeRole role, normalizeUser member) `elem` pairs then pure (Right ()) else catalog (addMember directory role member)
RevokeRoleCommand role members 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) _ -> pure (Left forbidden)
where where
backend = pvBackend service backend = pvBackend service
@@ -106,6 +109,7 @@ affectedAccounts service command = withTables service (catalog (OA.objectAffecte
CreateRoleCommand _ -> [] CreateRoleCommand _ -> []
DropRoleCommand role -> [role] DropRoleCommand role -> [role]
GrantPrivilegesCommand _ _ role _ -> [role] GrantPrivilegesCommand _ _ role _ -> [role]
RevokeGrantOptionCommand _ _ role -> [role]
RevokePrivilegesCommand _ _ role -> [role] RevokePrivilegesCommand _ _ role -> [role]
GrantRoleCommand _ members -> members GrantRoleCommand _ members -> members
RevokeRoleCommand _ members -> members RevokeRoleCommand _ members -> members
@@ -143,7 +147,7 @@ authorizeConnect service principal database
authorizeTables :: Privileges -> Principal -> Text -> [(Text, Text)] -> IO (Either PrivilegeError ()) authorizeTables :: Privileges -> Principal -> Text -> [(Text, Text)] -> IO (Either PrivilegeError ())
authorizeTables service principal database needed authorizeTables service principal database needed
| principalIsRoot principal = pure (Right ()) | 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 | otherwise = withTables service $ do
connected <- if T.null database then pure (Right ()) else catalog (OA.objectConnect (pvBackend service) (pvCatalog service) principal database) 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) case connected of Left err -> pure (Left err); Right () -> catalog (OA.objectAuthorize (pvBackend service) (pvCatalog service) principal database needed)
@@ -169,7 +173,12 @@ listRoleViews service = withTables service $ do
members <- catalog (readMembers (pvCatalog service)) members <- catalog (readMembers (pvCatalog service))
case (,) <$> names <*> members of case (,) <$> names <*> members of
Left err -> pure (Left err) 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 where
-- 组装一个角色的公开权限视图。 -- 组装一个角色的公开权限视图。
view members name = do view members name = do
@@ -195,15 +204,13 @@ reconcileObjects service = withTables service (catalog (OA.objectReconcile (pvBa
-- 收集数据语句及子查询所需的表权限。 -- 收集数据语句及子查询所需的表权限。
requiredActions :: Statement -> Maybe [(Text, Text)] requiredActions :: Statement -> Maybe [(Text, Text)]
requiredActions statement = case statement of requiredActions statement = case statement of
Select{} -> Just (selectNeeds (selectFrom statement) (maybe [] (: []) (selectWhere statement))) SelectDistinct q -> requiredActions q
SelectExpr{} -> 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)) 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)) Update table assignments condition -> Just ((T.pack table, "update") : selectsOf (map snd assignments ++ maybeToList condition))
Delete table condition -> Just ((T.pack table, "delete") : selectsOf (maybe [] (: []) condition)) Delete table condition -> Just ((T.pack table, "delete") : selectsOf (maybeToList condition))
_ -> Nothing _ -> Nothing
where where
-- 收集来源树和表达式的读取权限。
selectNeeds source expressions = [(ref, "select") | ref <- nub (tableRefsOf source)] ++ selectsOf expressions
-- 收集表达式中子查询的读取权限。 -- 收集表达式中子查询的读取权限。
selectsOf expressions = [(ref, "select") | ref <- nub (concatMap exprTables expressions)] selectsOf expressions = [(ref, "select") | ref <- nub (concatMap exprTables expressions)]
@@ -215,7 +222,7 @@ withTables service action = withCatalogLock (pvCatalog service) $ do
-- 将目录结果转换为权限错误。 -- 将目录结果转换为权限错误。
catalog :: IO (Either String a) -> IO (Either PrivilegeError a) 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 storageError :: String -> PrivilegeError
@@ -231,3 +238,7 @@ storageError message = PrivilegeError code (T.pack message)
forbidden :: PrivilegeError forbidden :: PrivilegeError
forbidden = PrivilegeError "forbidden" "administrator required" forbidden = PrivilegeError "forbidden" "administrator required"
-- 查询登录身份自己的有效权限。
listSelfGrants :: Privileges -> Principal -> IO (Either PrivilegeError [Grant])
listSelfGrants service principal = withTables service (catalog (OA.objectSelfViews (pvBackend service) (pvCatalog service) principal))
+3 -2
View File
@@ -1,5 +1,6 @@
module ChuSQL.Server.Security (readSecurity, writeSecurity) where module ChuSQL.Server.Security (readSecurity, writeSecurity) where
import Control.Monad (when)
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Exception (bracket_, mask_) import Control.Exception (bracket_, mask_)
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
@@ -21,11 +22,11 @@ readSecurity = bracket_ enter leave
(turn, room, readers) = securityGate (turn, room, readers) = securityGate
-- 登记共享读取者。 -- 登记共享读取者。
enter = withMVar turn $ \_ -> modifyMVar_ readers $ \count -> do enter = withMVar turn $ \_ -> modifyMVar_ readers $ \count -> do
if count == 0 then takeMVar room else pure () when (count == 0) $ takeMVar room
pure (count + 1) pure (count + 1)
-- 释放最后一个共享读取者。 -- 释放最后一个共享读取者。
leave = mask_ $ modifyMVar_ readers $ \count -> do leave = mask_ $ modifyMVar_ readers $ \count -> do
if count == 1 then putMVar room () else pure () when (count == 1) $ putMVar room ()
pure (count - 1) pure (count - 1)
-- 独占执行权限或对象变更。 -- 独占执行权限或对象变更。
+88 -7
View File
@@ -18,6 +18,7 @@ module ChuSQL.Server.Session
, runStatement , runStatement
, runStatementCoded , runStatementCoded
, runStorageCoded , runStorageCoded
, analyzeNormalizationCoded
, catalog , catalog
, accounts , accounts
, roleViews , roleViews
@@ -27,8 +28,18 @@ module ChuSQL.Server.Session
, queryResultJson , queryResultJson
) where ) where
import ChuSQL.Core.Model (Database, Row, Table (..), Value (..)) import ChuSQL.Core.Model (Database, Row, Table (..), Value (..), Column (..), typeName)
import ChuSQL.Core.Protocol (Account (..), Request (..), QueryResult (..), TxnOp (..), queryResultJson) 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.Engine.Storage.IPC (TableInfo (..)) import ChuSQL.Core.Engine.Storage.IPC (TableInfo (..))
import qualified ChuSQL.Core.Engine as Engine import qualified ChuSQL.Core.Engine as Engine
import qualified ChuSQL.Core.Engine.Error as E import qualified ChuSQL.Core.Engine.Error as E
@@ -39,13 +50,13 @@ import ChuSQL.Interface.Auth (defaultSessionPolicy, newSessionStore)
import ChuSQL.Server.Accounts import ChuSQL.Server.Accounts
import ChuSQL.Server.Backend (Backend (..), StatementResult (..), columnsFromStatement, scopeDdl) import ChuSQL.Server.Backend (Backend (..), StatementResult (..), columnsFromStatement, scopeDdl)
import ChuSQL.Server.Policy (configurePasswordPolicy) import ChuSQL.Server.Policy (configurePasswordPolicy)
import ChuSQL.Server.Privileges (PrivilegeCommand (..), PrivilegeError (..), Privileges, RoleView, affectedAccounts, affectedObject, authorize, authorizeConnect, claimObject, prepareObject, reconcileObjects, filterTables, listRoleViews, newPrivileges, privilegeCommand, runPrivilegeCommand) import ChuSQL.Server.Privileges (PrivilegeCommand (..), PrivilegeError (..), Privileges, RoleView, Grant (..), affectedAccounts, affectedObject, authorize, authorizeTables, authorizeConnect, claimObject, prepareObject, reconcileObjects, filterTables, listRoleViews, listSelfGrants, newPrivileges, privilegeCommand, runPrivilegeCommand)
import ChuSQL.Server.Security (readSecurity, writeSecurity) import ChuSQL.Server.Security (readSecurity, writeSecurity)
import Control.Exception (IOException, try) import Control.Exception (IOException, try)
import Data.Bifunctor (first) import Data.Bifunctor (first)
import Data.Char (isAlpha, isAlphaNum) import Data.Char (isAlpha, isAlphaNum)
import Data.IORef (IORef, newIORef, readIORef, writeIORef) 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.IntMap.Strict as IM
import qualified Data.IntSet as IS import qualified Data.IntSet as IS
import Data.Text (Text) import Data.Text (Text)
@@ -280,6 +291,7 @@ runStatementUnlocked session sql = case parseStatement (T.unpack sql) of
Right (Savepoint name) -> savepointTransaction session (T.pack name) Right (Savepoint name) -> savepointTransaction session (T.pack name)
Right (RollbackToSavepoint name) -> rollbackToSavepoint session (T.pack name) Right (RollbackToSavepoint name) -> rollbackToSavepoint session (T.pack name)
Right (ReleaseSavepoint name) -> releaseSavepoint session (T.pack name) Right (ReleaseSavepoint name) -> releaseSavepoint session (T.pack name)
Right ShowGrants -> showSelfGrants session
Right ShowRoles -> showIdentities session Right ShowRoles -> showIdentities session
Right statement Right statement
| Just command <- accountCommand statement -> runAccount session command | Just command <- accountCommand statement -> runAccount session command
@@ -319,8 +331,8 @@ transactionDdl statement = case statement of
-- | 事务里只有数据语句走快照 -- | 事务里只有数据语句走快照
transactionData :: Statement -> Bool transactionData :: Statement -> Bool
transactionData statement = case statement of transactionData statement = case statement of
SelectDistinct q -> transactionData q
Select{} -> True Select{} -> True
SelectExpr{} -> True
Insert{} -> True Insert{} -> True
Update{} -> True Update{} -> True
Delete{} -> True Delete{} -> True
@@ -824,7 +836,7 @@ privilegeMessage (PrivilegeError _ message) = message
-- | 只带库名的空结果 -- | 只带库名的空结果
emptyResult :: Maybe Text -> QueryResult emptyResult :: Maybe Text -> QueryResult
emptyResult database = QueryResult [] [] 0 False database emptyResult = QueryResult [] [] 0 False
-- | 存储结果转成查询结果 -- | 存储结果转成查询结果
resultOf :: StatementResult -> QueryResult resultOf :: StatementResult -> QueryResult
@@ -838,5 +850,74 @@ resultOf result =
} }
where where
-- | 按列名取单元格 -- | 按列名取单元格
cellOf row name = maybe VNull id (lookup name row) cellOf row name = fromMaybe VNull (lookup name row)
-- 展示当前登录身份自己的有效权限。
showSelfGrants :: Session -> IO (Either SessionError QueryResult)
showSelfGrants session = do
who <- readIORef (ssPrincipal session)
case who of
Nothing -> pure (Left (SessionError "unauthorized" "sign in first"))
Just principal -> do
grants <- listSelfGrants (ssPrivileges session) principal
pure $ case grants of
Left err -> Left (privilegeErrorOf err)
Right rows -> Right (QueryResult ["identity", "privilege", "object", "grant_option"]
[[VStr (T.unpack (grantRole grant)), VStr (T.unpack (grantPrivilege grant)), VStr (T.unpack (grantObject grant)), VBool (grantable grant)] | grant <- rows]
(length rows) False Nothing)
-- 在连接视图及权限稳定期间分析范式。
analyzeNormalizationCoded :: Session -> NormalizationRequest -> IO (Either SessionError A.Value)
analyzeNormalizationCoded session payload = do
result <- normalizationBudget $ readSecurity $ do
valid <- validatePrincipal session
current <- readIORef (ssCurrent session)
who <- readIORef (ssPrincipal session)
let table = last (T.splitOn "." (nrTable payload))
case (valid, who, A.fromJSON (A.toJSON payload) :: A.Result NormalizationRequest) of
(Left err, _, _) -> pure (Left (sessCode err, sessMessage err))
(_, Nothing, _) -> pure (Left ("unauthorized", "sign in first"))
(_, _, A.Error message) -> pure (Left ("bad_request", T.pack message))
(_, Just principal, A.Success _)
| BL.length (A.encode payload) > 65000 -> pure (Left ("too_large", "normalization request exceeds transport budget"))
| current /= nrDatabase payload -> pure (Left ("bad_request", "normalization database differs from the selected database"))
| current == "system" || "__system_" `T.isPrefixOf` table -> pure (Left ("forbidden", "normalization does not expose system objects"))
| otherwise -> do
allowed <- authorizeTables (ssPrivileges session) principal current [(table, "select")]
case allowed of
Left (PrivilegeError code message) -> pure (Left (code, message))
Right () -> normalizationView session table payload
pure (either (Left . uncurry SessionError) Right result)
-- 读取目录结构或当前连接的事务 schema。
normalizationView :: Session -> Text -> NormalizationRequest -> IO (Either (Text, Text) A.Value)
normalizationView session table payload = do
live <- snapshotObjectIds session [T.unpack table]
transaction <- readIORef (ssTransaction session)
case live >>= maybe (Left (SessionError "not_found" "unknown table")) Right . lookup (T.unpack table) of
Left err -> pure (Left (sessCode err, sessMessage err))
Right object -> case objectIdentity object of
Left message -> pure (Left ("storage_error", message))
Right identity -> case transaction of
Just tx -> case (lookup (T.unpack table) (txStaged tx), lookup (T.unpack table) (txObjects tx)) of
(Just relation, Just oldObject) | objectIdentity oldObject == Right identity ->
pure (normalizationReport identity (map normalizationColumn (tableCols relation)) "transaction_snapshot" payload)
_ -> pure (Left ("conflict", "normalization snapshot object has changed"))
Nothing -> do
backend <- currentBackend session
infos <- beCatalog backend
pure $ case infos of
Left message -> Left ("storage_error", T.pack message)
Right relations -> case [tiColumns info | info <- relations, tiTable info == T.unpack table] of
[columns] -> normalizationReport identity columns "live_schema" payload
_ -> Left ("not_found", "unknown table")
-- 从目录响应中只取稳定编号。
objectIdentity :: A.Value -> Either Text ObjectIdentity
objectIdentity = first T.pack . parseEither (A.withObject "catalog object" $ \o -> ObjectIdentity <$> o A..: "database_id" <*> o A..: "object_id")
-- 将事务 schema 转成同一线上列结构。
normalizationColumn :: (String, Column) -> SchemaColumn
normalizationColumn (name, c) = SchemaColumn name (typeName (columnType c)) (columnNullable c) (columnDefault c) (columnAutoIncrement c) (columnPrimaryKey c) (columnUnique c) (columnCheck c)
+54 -24
View File
@@ -1,3 +1,5 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Server.TCP ( module ChuSQL.Server.TCP (
@@ -23,18 +25,18 @@ import ChuSQL.Interface.RateLimit (RateLimiter, rateLimitBlock, rateLimitClear,
import qualified ChuSQL.Core.Engine.Error as E import qualified ChuSQL.Core.Engine.Error as E
import ChuSQL.Core.Protocol (Account (..), Request (ReqIdentityInitialize)) import ChuSQL.Core.Protocol (Account (..), Request (ReqIdentityInitialize))
import ChuSQL.Server.Backend (Backend (..)) import ChuSQL.Server.Backend (Backend (..))
import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), accounts, authenticateSessionCoded, authenticateSudoSessionCoded, isPlainIdentifier, catalog, databases, newSessionWith, policyOf, reloadPolicy, roleViews, runStatementCoded, runStorageCoded, sessionIsAdmin, sessionUser) import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), accounts, authenticateSessionCoded, authenticateSudoSessionCoded, isPlainIdentifier, catalog, databases, newSessionWith, policyOf, reloadPolicy, roleViews, analyzeNormalizationCoded, runStatementCoded, runStorageCoded, sessionIsAdmin, sessionUser)
import ChuSQL.Server.Security (writeSecurity) import ChuSQL.Server.Security (writeSecurity)
import ChuSQL.Server.Privileges (newPrivileges, reconcileObjects) import ChuSQL.Server.Privileges (newPrivileges, reconcileObjects)
import Control.Concurrent (forkIO) import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar) import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
import Control.Exception (IOException, bracket, finally, onException, try) 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.Char8 as BSC
import qualified Data.ByteString.Lazy.Char8 as BLC import qualified Data.ByteString.Lazy.Char8 as BLC
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe, isNothing)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Network.Socket ( import Network.Socket (
@@ -59,8 +61,8 @@ import Network.Socket (
socket, socket,
socketToHandle, socketToHandle,
) )
import System.IO (BufferMode (LineBuffering), IOMode (ReadWriteMode), hClose, hFlush, hPutStrLn, hSetBuffering, hSetNewlineMode, noNewlineTranslation, stderr) import System.IO (BufferMode (LineBuffering), Handle, IOMode (ReadWriteMode), hClose, hFlush, hPutStrLn, hSetBuffering, hSetNewlineMode, noNewlineTranslation, stderr)
import System.IO.Error (isEOFError) import System.IO.Error (eofErrorType, isEOFError, mkIOError)
-- TCP 服务器:监听端口,一连接一会话,按一行一 JSON 收发协议消息。 -- TCP 服务器:监听端口,一连接一会话,按一行一 JSON 收发协议消息。
@@ -171,12 +173,15 @@ enableSudo :: ServerEnv -> Int -> IO ()
enableSudo env port enableSudo env port
| T.null user = pure () | T.null user = pure ()
| not (isPlainIdentifier user) = ioError (userError "sudo_auth_user must be a plain identity name") | not (isPlainIdentifier user) = ioError (userError "sudo_auth_user must be a plain identity name")
| otherwise = modifyMVar_ (srvSudo env) $ \current -> case current of | otherwise = modifyMVar_ (srvSudo env) $ \case
Just _ -> ioError (userError "sudo authentication is already running") Just _
Nothing -> do -> ioError (userError "sudo authentication is already running")
credential <- createSudoCredential port Nothing
hPutStrLn stderr ("sudo_auth enabled: local elevated identity -> " ++ T.unpack user) -> do credential <- createSudoCredential port
pure (Just (port, user, credential)) hPutStrLn
stderr
("sudo_auth enabled: local elevated identity -> " ++ T.unpack user)
pure (Just (port, user, credential))
where where
user = scSudoUser (srvConfig env) user = scSudoUser (srvConfig env)
@@ -254,21 +259,20 @@ serveConnection env conn = do
hSetNewlineMode h noNewlineTranslation hSetNewlineMode h noNewlineTranslation
entry <- newLiveEntry (isLocalPeer peer) entry <- newLiveEntry (isLocalPeer peer)
unregister <- registerConnection (srvLive env) entry 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 `finally` unregister) :: IO (Either IOException ()) outcome <- try (loop h session entry BSC.empty `finally` unregister) :: IO (Either IOException ())
case outcome of case outcome of
Left err | not (isEOFError err) -> hPutStrLn stderr ("connection error: " ++ show err) Left err | not (isEOFError err) -> hPutStrLn stderr ("connection error: " ++ show err)
_ -> pure () _ -> pure ()
void (try (hClose h) :: IO (Either IOException ())) void (try (hClose h) :: IO (Either IOException ()))
where where
-- | 逐行读请求并应答 -- | 逐行读请求并应答
loop h session entry = do loop h session entry pending = do
line <- BSC.hGetLine h frame <- readRequestLine h (scMaxMessage (srvConfig env)) pending
let cleaned = BSC.dropWhileEnd (== '\r') line case frame of
if BSC.length cleaned > scMaxMessage (srvConfig env) Nothing -> send h (RespError "too_large" "request line too large")
then send h (RespError "too_large" "request line too large") >> loop h session entry Just (cleaned, remaining) -> case decodeRequest cleaned of
else case decodeRequest cleaned of Left message -> send h (RespError "bad_request" message) >> loop h session entry remaining
Left message -> send h (RespError "bad_request" message) >> loop h session entry
Right request -> do Right request -> do
expired <- readIORef (leDropped entry) expired <- readIORef (leDropped entry)
if expired if expired
@@ -276,13 +280,36 @@ serveConnection env conn = do
else do else do
(response, keepGoing) <- dispatch env session entry request (response, keepGoing) <- dispatch env session entry request
send h response send h response
if keepGoing then loop h session entry else pure () when keepGoing $ loop h session entry remaining
-- | 发一条响应并冲缓冲 -- | 发一条响应并冲缓冲
send h response = do send h response = do
BLC.hPutStr h (encodeResponse response) BLC.hPutStr h (encodeResponse response)
BLC.hPutStr h "\n" BLC.hPutStr h "\n"
hFlush h hFlush h
-- | 限长读取一行并保留后续帧
readRequestLine :: Handle -> Int -> BSC.ByteString -> IO (Maybe (BSC.ByteString, BSC.ByteString))
readRequestLine handle limit = collect [] 0
where
-- | 按块读取至换行、超限或 EOF
collect parts total bytes = case BSC.elemIndex '\n' bytes of
Just offset -> finish (BSC.take offset bytes : parts) (BSC.drop (offset + 1) bytes)
Nothing
| used > limit && (used - limit > 1 || BSC.null bytes || BSC.last bytes /= '\r') -> pure Nothing
| otherwise -> do
next <- BSC.hGetSome handle (max 1 (min 4094 (limit - used) + 2))
if BSC.null next
then if used == 0
then ioError (mkIOError eofErrorType "read request" (Just handle) Nothing)
else finish (bytes : parts) BSC.empty
else collect (bytes : parts) used next
where
used = total + BSC.length bytes
-- | 合并并校验一行的有效长度
finish parts remaining = do
let line = BSC.dropWhileEnd (== '\r') (BSC.concat (reverse parts))
pure (if BSC.length line > limit then Nothing else Just (line, remaining))
-- | 一条请求一条响应,quit 后停连接 -- | 一条请求一条响应,quit 后停连接
dispatch :: ServerEnv -> Session -> LiveEntry -> ClientRequest -> IO (ServerResponse, Bool) dispatch :: ServerEnv -> Session -> LiveEntry -> ClientRequest -> IO (ServerResponse, Bool)
dispatch env session entry request = case request of dispatch env session entry request = case request of
@@ -300,7 +327,7 @@ dispatch env session entry request = case request of
configured <- readMVar (srvSudo env) configured <- readMVar (srvSudo env)
who <- sessionUser session who <- sessionUser session
case configured of case configured of
Just _ | leLocal entry && who == Nothing -> do Just _ | leLocal entry && isNothing who -> do
nonce <- sudoChallenge nonce <- sudoChallenge
now <- getCurrentTime now <- getCurrentTime
writeIORef (leChallenge entry) (Just (nonce, now)) writeIORef (leChallenge entry) (Just (nonce, now))
@@ -309,6 +336,9 @@ dispatch env session entry request = case request of
ReqSudoLogin user proof -> do ReqSudoLogin user proof -> do
response <- sudoLogin env session entry user proof response <- sudoLogin env session entry user proof
pure (response, True) pure (response, True)
ReqNormalization payload -> do
result <- analyzeNormalizationCoded session payload
pure (either (\err -> RespError (sessCode err) (sessMessage err)) RespNormalization result, True)
ReqQuery sql -> do ReqQuery sql -> do
who <- sessionUser session who <- sessionUser session
response <- case who of response <- case who of
@@ -351,13 +381,13 @@ dispatch env session entry request = case request of
-- 消费一次性证明并登录本机映射账号。 -- 消费一次性证明并登录本机映射账号。
sudoLogin :: ServerEnv -> Session -> LiveEntry -> Text -> Text -> IO ServerResponse sudoLogin :: ServerEnv -> Session -> LiveEntry -> Text -> Text -> IO ServerResponse
sudoLogin env session entry user proof = do sudoLogin env session entry user proof = do
challenge <- atomicModifyIORef' (leChallenge entry) (\value -> (Nothing, value)) challenge <- atomicModifyIORef' (leChallenge entry) (Nothing,)
configured <- readMVar (srvSudo env) configured <- readMVar (srvSudo env)
now <- getCurrentTime now <- getCurrentTime
who <- sessionUser session who <- sessionUser session
let key = T.toLower (T.strip user) let key = T.toLower (T.strip user)
mapped = maybe "" (\(_, name, _) -> name) configured mapped = maybe "" (\(_, name, _) -> name) configured
valid = leLocal entry && who == Nothing && key == mapped valid = leLocal entry && isNothing who && key == mapped
&& case configured of && case configured of
Just (_, _, credential) -> validSudoChallenge credential now challenge key proof Just (_, _, credential) -> validSudoChallenge credential now challenge key proof
Nothing -> False Nothing -> False
+330 -29
View File
@@ -3,6 +3,7 @@
module Main (main) where module Main (main) where
import Data.Either (lefts)
import ChuSQL.Core.Engine.Storage.IPC ( import ChuSQL.Core.Engine.Storage.IPC (
Account (..), Account (..),
Request (ReqAccountCreate, ReqAccountReset, ReqAccountsList, ReqIdentityAlter), Request (ReqAccountCreate, ReqAccountReset, ReqAccountsList, ReqIdentityAlter),
@@ -12,11 +13,14 @@ import ChuSQL.Core.Engine.Storage.IPC (
setStorageLink, setStorageLink,
) )
import ChuSQL.Core.Engine.Syntax.AST (Statement) import ChuSQL.Core.Engine.Syntax.AST (Statement)
import ChuSQL.Interface.Normalization
import ChuSQL.Server.Normalization (normalizationBudget, normalizationReport, schemaFingerprint)
import ChuSQL.Core.Protocol (SchemaColumn (..))
import Data.IORef (newIORef, readIORef, writeIORef) import Data.IORef (newIORef, readIORef, writeIORef)
import ChuSQL.Core.Engine.Syntax.Parser (parseStatement) import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
import ChuSQL.Core.Model (Database, Histogram (..), Row, Table (..), Value (..), pattern TInt, pattern TStr) import ChuSQL.Core.Model (Database, Histogram (..), Row, Table (..), TableIdentity (..), Value (..), pattern TInt, pattern TStr)
import ChuSQL.Interface.Auth (hashPasswordWith) import ChuSQL.Interface.Auth (hashPasswordWith)
import ChuSQL.Interface.Protocol (ClientRequest (..), Grant (..), RoleView (..), ServerResponse (..), decodeRequest, encodeResponse) import ChuSQL.Interface.Protocol (ClientRequest (..), Grant (..), RoleView (..), ServerResponse (..), decodeRequest, encodeResponse, encodeRequest, decodeResponse)
import ChuSQL.Interface.RateLimit (newRateLimiter) import ChuSQL.Interface.RateLimit (newRateLimiter)
import ChuSQL.Interface.Link (connectClient, closeClient, clientSudoLogin, clientQuery) import ChuSQL.Interface.Link (connectClient, closeClient, clientSudoLogin, clientQuery)
import ChuSQL.Interface.Sudo (SudoCredential, newSudoCredential, sudoProof, verifySudoProof, validSudoChallenge, import ChuSQL.Interface.Sudo (SudoCredential, newSudoCredential, sudoProof, verifySudoProof, validSudoChallenge,
@@ -33,6 +37,7 @@ import ChuSQL.Server.Privileges (
claimObject, claimObject,
prepareObject, prepareObject,
listRoleViews, listRoleViews,
listSelfGrants,
newPrivileges, newPrivileges,
runPrivilegeCommand, runPrivilegeCommand,
) )
@@ -47,11 +52,11 @@ import ChuSQL.Server.TCP (
startServer, startServer,
isLocalPeer, isLocalPeer,
) )
import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent (forkIO, forkFinally, killThread, threadDelay)
import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, takeMVar) import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, takeMVar)
import System.Timeout (timeout) import System.Timeout (timeout)
import Control.Exception (IOException, bracket, finally, try) import Control.Exception (IOException, bracket, finally, try)
import Control.Monad (void) import Control.Monad (replicateM_, void, (>=>), when)
import Data.List (sort) import Data.List (sort)
import Data.Aeson (decode) import Data.Aeson (decode)
import qualified Data.Aeson as A import qualified Data.Aeson as A
@@ -64,7 +69,7 @@ import Data.Maybe (fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Vector as V import qualified Data.Vector as V
import Data.Time.Clock (addUTCTime, getCurrentTime) import Data.Time.Clock (addUTCTime, diffUTCTime, getCurrentTime)
import Network.Socket ( import Network.Socket (
AddrInfo (..), AddrInfo (..),
SockAddr (..), SockAddr (..),
@@ -105,6 +110,7 @@ main = hspec spec
-- | 全部用例 -- | 全部用例
spec :: Spec spec :: Spec
spec = do spec = do
normalizationSpec
describe "sudo authentication" $ do describe "sudo authentication" $ do
it "defaults to disabled and rejects unconfigured TCP authentication" $ it "defaults to disabled and rejects unconfigured TCP authentication" $
withTcpServer defaultServerConfig $ \_ handle -> withConnection handle $ \client -> do withTcpServer defaultServerConfig $ \_ handle -> withConnection handle $ \client -> do
@@ -239,7 +245,9 @@ identitySpec = describe "unified identities" $ do
asText (at "status" shown) `shouldBe` "result" asText (at "status" shown) `shouldBe` "result"
switched <- tcpQuery manager "use system" switched <- tcpQuery manager "use system"
asText (at "status" switched) `shouldBe` "result" 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"] ["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 -> it "does not inherit catalog management through role membership" $ withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \admin -> withConnection handle $ \worker -> do withConnection handle $ \admin -> withConnection handle $ \worker -> do
@@ -304,7 +312,9 @@ identitySpec = describe "unified identities" $ do
it "protects the last enabled login superuser" $ withTcpServer defaultServerConfig $ \_ handle -> it "protects the last enabled login superuser" $ withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \h -> do withConnection handle $ \h -> do
_ <- tcpLogin h "admin" "s3cret" _ <- 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"] ["alter user admin disabled", "alter role admin nologin", "alter user admin nosuperuser", "drop user admin", "drop role admin"]
shown <- tcpQuery h "show roles" shown <- tcpQuery h "show roles"
asText (at "status" shown) `shouldBe` "result" asText (at "status" shown) `shouldBe` "result"
@@ -380,14 +390,14 @@ testDb =
[ [("id", VInt i), ("name", VStr ("user" ++ show i)), ("age", VInt (20 + i))] [ [("id", VInt i), ("name", VStr ("user" ++ show i)), ("age", VInt (20 + i))]
| i <- [1 .. 5] | i <- [1 .. 5]
] ]
Nothing Nothing Nothing Nothing
) )
, ( "orders" , ( "orders"
, Table , Table
"orders" "orders"
[("id", TInt), ("user_id", TInt)] [("id", TInt), ("user_id", TInt)]
[[("id", VInt 1), ("user_id", VInt 1)]] [[("id", VInt 1), ("user_id", VInt 1)]]
Nothing Nothing Nothing Nothing
) )
] ]
@@ -401,7 +411,7 @@ testRootPassword = "s3cret"
-- | 口令哈希:迭代次数压低,跑得快 -- | 口令哈希:迭代次数压低,跑得快
testPasswordHash :: Text -> Text testPasswordHash :: Text -> Text
testPasswordHash raw = hashPasswordWith 1000 (BS.replicate 16 7) raw testPasswordHash = hashPasswordWith 1000 (BS.replicate 16 7)
-- 小工具 -- 小工具
@@ -456,7 +466,8 @@ tempSettingsPath name = do
removeIfExists :: FilePath -> IO () removeIfExists :: FilePath -> IO ()
removeIfExists path = do removeIfExists path = do
there <- doesFileExist path 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` -- | 起一台内存后端的测试服务器:管理员已设口令 `s3cret`
withTcpServer :: ServerConfig -> (ServerEnv -> ServerHandle -> IO a) -> IO a withTcpServer :: ServerConfig -> (ServerEnv -> ServerHandle -> IO a) -> IO a
@@ -480,7 +491,7 @@ withTcpServerAs password config body = do
-- | 连上服务器并配成行缓冲句柄 -- | 连上服务器并配成行缓冲句柄
withConnection :: ServerHandle -> (Handle -> IO a) -> IO a withConnection :: ServerHandle -> (Handle -> IO a) -> IO a
withConnection handle body = bracket open closeQuietly body withConnection handle = bracket open closeQuietly
where where
-- | 关连接,忽略异常 -- | 关连接,忽略异常
closeQuietly h = do closeQuietly h = do
@@ -729,6 +740,24 @@ tcpServerSpec = do
withConnection handle $ \h -> do withConnection handle $ \h -> do
reply <- tcpTalk h (BSC.pack ("{\"method\":\"query\",\"sql\":\"" ++ replicate 40 'a' ++ "\"}")) reply <- tcpTalk h (BSC.pack ("{\"method\":\"query\",\"sql\":\"" ++ replicate 40 'a' ++ "\"}"))
asText (at "code" reply) `shouldBe` "too_large" asText (at "code" reply) `shouldBe` "too_large"
it "refuses oversized input before a newline and closes the connection" $
withTcpServer defaultServerConfig{scMaxMessage = 32} $ \_ handle ->
withConnection handle $ \h -> do
BSC.hPutStr h (BSC.replicate 33 'a')
hFlush h
line <- timeout 1000000 (BSC.hGetLine h)
case line of
Nothing -> expectationFailure "oversized input waited for a newline"
Just raw -> asText (at "code" (fromMaybe A.Null (decode (BL.fromStrict raw)))) `shouldBe` "too_large"
tcpClosed h
it "accepts exact-limit CRLF frames and preserves pipelined requests" $
withTcpServer defaultServerConfig{scMaxMessage = 17} $ \_ handle ->
withConnection handle $ \h -> do
BSC.hPutStr h "{\"method\":\"ping\"}\r\n{\"method\":\"ping\"}\n"
hFlush h
replicateM_ 2 $ do
raw <- timeout 1000000 (BSC.hGetLine h)
fmap (asText . at "status" . fromMaybe A.Null . decode . BL.fromStrict) raw `shouldBe` Just "pong"
it "ping answers pong and quit closes the connection" $ it "ping answers pong and quit closes the connection" $
withTcpServer defaultServerConfig $ \_ handle -> withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \h -> do withConnection handle $ \h -> do
@@ -870,9 +899,9 @@ privilegeSpec = describe "server privileges" $ do
_ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader") _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
_ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["all"] "*" "reader" False) _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["all"] "*" "reader" False)
views <- listRoleViews service views <- listRoleViews service
fmap (concatMap (map grantPrivilege) . map roleGrants) views fmap (concatMap (map grantPrivilege . roleGrants)) views
`shouldBe` Right ["select", "insert", "update", "delete"] `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 it "revokes a privilege again" $ withPrivileges $ \service root -> do
_ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader") _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
@@ -1038,6 +1067,16 @@ privilegeSpec = describe "server privileges" $ do
authorizeSql service (Ordinary testAccount) "SELECT name FROM users WHERE id > ANY (SELECT id FROM orders)" authorizeSql service (Ordinary testAccount) "SELECT name FROM users WHERE id > ANY (SELECT id FROM orders)"
`shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON 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 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 "reader")
_ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "inner") _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "inner")
@@ -1107,6 +1146,44 @@ withObjectPrivileges body = do
-- 验证对象作用域、授权来源和外部入口。 -- 验证对象作用域、授权来源和外部入口。
objectPrivilegeSpec :: Spec objectPrivilegeSpec :: Spec
objectPrivilegeSpec = describe "stable object privileges" $ do objectPrivilegeSpec = describe "stable object privileges" $ do
it "lists only the caller's effective grants including roles and PUBLIC" $ withObjectPrivileges $ \backend service root -> do
runPrivilegeCommand service root testDatabase (CreateRoleCommand "self_reader") `shouldReturn` Right ()
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "self_reader" True) `shouldReturn` Right ()
runPrivilegeCommand service root testDatabase (GrantRoleCommand "self_reader" ["alice"]) `shouldReturn` Right ()
grants <- listSelfGrants service (Ordinary testAccount)
grants `shouldSatisfy` either (const False) (elem (Grant "alice" "select" "test.users" True))
grants `shouldSatisfy` either (const False) (elem (Grant "alice" "connect" "database:test" False))
grants `shouldSatisfy` either (const False) (all ((== "alice") . grantRole))
runPrivilegeCommand service root testDatabase (RevokePrivilegesCommand ["select"] "users" "self_reader") `shouldReturn` Right ()
after <- listSelfGrants service (Ordinary testAccount)
after `shouldSatisfy` either (const False) (not . any ((== "test.users") . grantObject))
_ <- beAccounts backend (ReqAccountReset "alice" (testPasswordHash "Alice-Secret-1234"))
_ <- beAccounts backend (ReqAccountCreate testRootName (testPasswordHash testRootPassword))
_ <- beAccounts backend (ReqIdentityAlter testRootName Nothing (Just True) Nothing Nothing Nothing)
settings <- tempSettingsPath "self-grants"
session <- newSession backend testRootName settings
authenticateSessionCoded session "alice" "Alice-Secret-1234" `shouldReturn` Right ()
result <- mustSql session "SHOW GRANTS"
qrColumns result `shouldBe` ["identity", "privilege", "object", "grant_option"]
qrRows result `shouldSatisfy` all (\row -> take 1 row == [VStr "alice"])
rejected <- runStatementCoded session "SHOW GRANTS FOR admin"
rejected `shouldSatisfy` either (const True) (const False)
it "includes ownership permissions and excludes ungranted tables" $ withObjectPrivileges $ \backend service _ -> do
mustRun (beStatement (beWithDatabase backend "test") "CREATE TABLE personal_owned (id INT)")
claimObject service (Ordinary testAccount) testDatabase "personal_owned" `shouldReturn` Right ()
grants <- listSelfGrants service (Ordinary testAccount)
fmap (filter ((== "test.personal_owned") . grantObject)) grants `shouldBe` Right
[Grant "alice" privilege "test.personal_owned" True | privilege <- ["select", "insert", "update", "delete"]]
grants `shouldSatisfy` either (const False) (not . any ((== "test.users") . grantObject))
it "checks DISTINCT table reads and nested subqueries" $ withObjectPrivileges $ \_ service root -> do
authorizeSql service (Ordinary testAccount) "SELECT DISTINCT age FROM users"
`shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
authorizeSql service (Ordinary testAccount) "SELECT DISTINCT d.age FROM (SELECT DISTINCT age FROM users) d"
`shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" False) `shouldReturn` Right ()
authorizeSql service (Ordinary testAccount) "SELECT DISTINCT age FROM users" `shouldReturn` Right ()
it "migrates old table grants once and ignores later legacy writes" $ withObjectPrivileges $ \backend service _ -> do it "migrates old table grants once and ignores later legacy writes" $ withObjectPrivileges $ \backend service _ -> do
let system = beWithDatabase backend "system" let system = beWithDatabase backend "system"
mustRun (beStatement system "CREATE TABLE __system_grants (role VARCHAR(64), privilege VARCHAR(16), object VARCHAR(128))") mustRun (beStatement system "CREATE TABLE __system_grants (role VARCHAR(64), privilege VARCHAR(16), object VARCHAR(128))")
@@ -1141,7 +1218,8 @@ objectPrivilegeSpec = describe "stable object privileges" $ do
finished <- newEmptyMVar finished <- newEmptyMVar
revoked <- newEmptyMVar revoked <- newEmptyMVar
let slow = backend{beWithDatabase = \name -> (beWithDatabase backend name){beStatement = \sql -> do 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}} beStatement (beWithDatabase backend name) sql}}
settings <- tempSettingsPath "permission-race" settings <- tempSettingsPath "permission-race"
reader <- newSession slow testRootName settings reader <- newSession slow testRootName settings
@@ -1186,6 +1264,41 @@ objectPrivilegeSpec = describe "stable object privileges" $ do
authorizeSql service (Ordinary testAccount) "DROP DATABASE test" `shouldReturn` Left (PrivilegeError "forbidden" "object owner required") authorizeSql service (Ordinary testAccount) "DROP DATABASE test" `shouldReturn` Left (PrivilegeError "forbidden" "object owner required")
runPrivilegeCommand service root testDatabase (RevokePrivilegesCommand ["select"] "users" "alice") `shouldReturn` Right () runPrivilegeCommand service root testDatabase (RevokePrivilegesCommand ["select"] "users" "alice") `shouldReturn` Right ()
authorizeSql service (Ordinary testAccount) "SELECT * FROM users" `shouldReturn` Right () authorizeSql service (Ordinary testAccount) "SELECT * FROM users" `shouldReturn` Right ()
it "executes grant option revocation over TCP and keeps SELECT" $
withTcpServer defaultServerConfig $ \_ handle -> withConnection handle $ \admin -> do
_ <- tcpLogin admin "admin" "s3cret"
_ <- tcpQuery admin "USE test"
_ <- tcpQuery admin "CREATE USER option_reader IDENTIFIED BY 'Option-Reader-1234'"
tcpQuery admin "GRANT SELECT ON users TO option_reader WITH GRANT OPTION" >>= \reply -> at "status" reply `shouldBe` A.String "result"
tcpQuery admin "REVOKE GRANT OPTION FOR SELECT ON users FROM option_reader" >>= \reply -> at "status" reply `shouldBe` A.String "result"
withConnection handle $ \reader -> do
_ <- tcpLogin reader "option_reader" "Option-Reader-1234"
_ <- tcpQuery reader "USE test"
tcpQuery reader "SELECT DISTINCT age FROM users ORDER BY 1" >>= \reply -> at "status" reply `shouldBe` A.String "result"
tcpQuery reader "SHOW GRANTS" >>= \reply -> at "status" reply `shouldBe` A.String "result"
tcpQuery reader "GRANT SELECT ON users TO admin" >>= \reply -> at "code" reply `shouldBe` A.String "forbidden"
it "revokes grant option while preserving data access and independent sources" $ withObjectPrivileges $ \_ service root -> do
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" True) `shouldReturn` Right ()
runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" True) `shouldReturn` Right ()
runPrivilegeCommand service (Ordinary testAccount{accountUser = "bob"}) testDatabase (GrantPrivilegesCommand ["select"] "users" "carol" False) `shouldReturn` Right ()
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "carol" False) `shouldReturn` Right ()
affectedAccounts service (RevokeGrantOptionCommand ["select"] "users" "alice") `shouldReturn` Right ["alice", "bob", "carol"]
runPrivilegeCommand service root testDatabase (RevokeGrantOptionCommand ["select"] "users" "alice") `shouldReturn` Right ()
authorizeSql service (Ordinary testAccount) "SELECT * FROM users" `shouldReturn` Right ()
grants <- listSelfGrants service (Ordinary testAccount)
grants `shouldSatisfy` either (const False) (elem (Grant "alice" "select" "test.users" False))
authorizeSql service (Ordinary testAccount{accountUser = "bob"}) "SELECT * FROM users"
`shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
authorizeSql service (Ordinary testAccount{accountUser = "carol"}) "SELECT * FROM users" `shouldReturn` Right ()
runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" False)
`shouldReturn` Left (PrivilegeError "forbidden" "grant option required: SELECT ON users")
it "revokes only the caller's grant option source" $ withObjectPrivileges $ \_ service root -> do
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" True) `shouldReturn` Right ()
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" True) `shouldReturn` Right ()
runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" True) `shouldReturn` Right ()
runPrivilegeCommand service (Ordinary testAccount) testDatabase (RevokeGrantOptionCommand ["select"] "users" "bob") `shouldReturn` Right ()
grants <- listSelfGrants service (Ordinary testAccount{accountUser = "bob"})
grants `shouldSatisfy` either (const False) (elem (Grant "bob" "select" "test.users" True))
it "cascades multihop delegations after the source grant is revoked" $ withObjectPrivileges $ \_ service root -> do it "cascades multihop delegations after the source grant is revoked" $ withObjectPrivileges $ \_ service root -> do
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" True) `shouldReturn` Right () runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" True) `shouldReturn` Right ()
runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" True) `shouldReturn` Right () runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" True) `shouldReturn` Right ()
@@ -1405,11 +1518,11 @@ sessionAge session wanted = do
-- | 取失败里的文案 -- | 取失败里的文案
failureMessage :: Either SessionError QueryResult -> Text failureMessage :: Either SessionError QueryResult -> Text
failureMessage outcome = either sessMessage (const "") outcome failureMessage = either sessMessage (const "")
-- | 取失败里的错误码 -- | 取失败里的错误码
failureCode :: Either SessionError QueryResult -> Text failureCode :: Either SessionError QueryResult -> Text
failureCode outcome = either sessCode (const "") outcome failureCode = either sessCode (const "")
-- | 取结果第一列的整数 -- | 取结果第一列的整数
intValues :: [[Value]] -> [Int] intValues :: [[Value]] -> [Int]
@@ -1418,6 +1531,17 @@ intValues rows = [n | row <- rows, Just (VInt n) <- [nth 0 row]]
-- | 显式事务用例 -- | 显式事务用例
transactionSpec :: Spec transactionSpec :: Spec
transactionSpec = describe "server transactions" $ do transactionSpec = describe "server transactions" $ do
it "executes DISTINCT against the connection snapshot with output columns" $ withMemorySession $ \session -> do
_ <- mustSql session "CREATE TABLE distinct_values (id INT, value INT)"
_ <- mustSql session "INSERT INTO distinct_values (id,value) VALUES (1,7),(2,7),(3,8)"
_ <- mustSql session "BEGIN"
_ <- mustSql session "UPDATE distinct_values SET value = 9 WHERE id = 3"
result <- mustSql session "SELECT DISTINCT value FROM distinct_values ORDER BY 1"
qrColumns result `shouldBe` ["value"]
qrRows result `shouldBe` [[VInt 7], [VInt 9]]
_ <- mustSql session "ROLLBACK"
pure ()
it "preserves concurrent changes in a large untouched table" $ withTwoSessions $ \first second -> do it "preserves concurrent changes in a large untouched table" $ withTwoSessions $ \first second -> do
_ <- mustSql first "CREATE TABLE untouched (id INT, value INT)" _ <- mustSql first "CREATE TABLE untouched (id INT, value INT)"
let values = T.intercalate "," [T.pack ("(" ++ show key ++ ",0)") | key <- [1 .. 5000 :: Int]] let values = T.intercalate "," [T.pack ("(" ++ show key ++ ",0)") | key <- [1 .. 5000 :: Int]]
@@ -1440,8 +1564,8 @@ transactionSpec = describe "server transactions" $ do
qrRows result `shouldBe` [[VInt 7], [VInt (-3)], [VInt 4]] qrRows result `shouldBe` [[VInt 7], [VInt (-3)], [VInt 4]]
it "filters qualified memory tables and preserves other databases on writes" $ do it "filters qualified memory tables and preserves other databases on writes" $ do
let local = Table "users" [("id", TInt)] [[("id", VInt 1)]] Nothing let local = Table "users" [("id", TInt)] [[("id", VInt 1)]] Nothing Nothing Nothing
otherTable = Table "users" [("id", TInt)] [[("id", VInt 2)]] Nothing otherTable = Table "users" [("id", TInt)] [[("id", VInt 2)]] Nothing Nothing Nothing
ref <- newMVar [("test.users", local), ("other.users", otherTable)] ref <- newMVar [("test.users", local), ("other.users", otherTable)]
let backend = memoryBackend "test" ref let backend = memoryBackend "test" ref
selected <- beStatement backend "SELECT id FROM users" selected <- beStatement backend "SELECT id FROM users"
@@ -1449,14 +1573,39 @@ transactionSpec = describe "server transactions" $ do
tables <- beCatalog backend tables <- beCatalog backend
fmap (map tiTable) tables `shouldBe` Right ["users"] fmap (map tiTable) tables `shouldBe` Right ["users"]
updated <- beStatement backend "UPDATE users SET id = 3" updated <- beStatement backend "UPDATE users SET id = 3"
fmap (const ()) updated `shouldBe` Right () void updated `shouldBe` Right ()
snapshot <- beSnapshot (memoryBackend "other" ref) snapshot <- beSnapshot (memoryBackend "other" ref)
fmap (map (tableRows . snd)) snapshot `shouldBe` Right [[[ ("id", VInt 2) ]]] fmap (map (tableRows . snd)) snapshot `shouldBe` Right [[[ ("id", VInt 2) ]]]
it "keeps catalog and snapshot identities stable across system views and replacements" $ do
ref <- newMVar [("test.users", Table "users" [("id", TInt)] [] Nothing Nothing Nothing)]
let backend = memoryBackend "test" ref
first <- beCatalog backend
fmap (map tiIdentity) first `shouldBe` Right [Just (TableIdentity 1 1)]
_ <- beSnapshot (beWithDatabase backend "system")
saved <- beSnapshot backend
fmap (map (tableIdentity . snd)) saved `shouldBe` Right [Just (TableIdentity 1 1)]
mustRun (beStatement backend "DROP TABLE users")
mustRun (beStatement backend "CREATE TABLE users (id INT)")
replaced <- beCatalog backend
fmap (map tiIdentity) replaced `shouldBe` Right [Just (TableIdentity 1 2)]
it "preserves memory schema versions in catalogs and snapshots" $ do
ref <- newMVar []
let backend = memoryBackend "test" ref
void <$> beStatement backend "CREATE TABLE versioned (id INT)" `shouldReturn` Right ()
first <- beCatalog backend
fmap (map tiSchemaVersion) first `shouldBe` Right [Just 1]
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]
fmap (map (tableSchemaVersion . snd)) snapshot `shouldBe` Right [Just 3]
it "rejects cross-database reads and writes including nested queries" $ withMemorySession $ \session -> do it "rejects cross-database reads and writes including nested queries" $ withMemorySession $ \session -> do
mapM_ (\query -> do mapM_ (\query -> do
result <- runStatementCoded session query result <- runStatementCoded session query
failureMessage result `shouldSatisfy` T.isInfixOf "outside the current database") failureMessage result `shouldSatisfy` T.isInfixOf "outside the current database")
[ "SELECT * FROM other.users" [ "SELECT DISTINCT age FROM other.users"
, "SELECT * FROM other.users"
, "UPDATE other.users SET age = 1" , "UPDATE other.users SET age = 1"
, "DELETE FROM other.users" , "DELETE FROM other.users"
, "INSERT INTO other.users (id) VALUES (99)" , "INSERT INTO other.users (id) VALUES (99)"
@@ -1531,6 +1680,22 @@ transactionSpec = describe "server transactions" $ do
rows <- mustSql session "select * from fresh" rows <- mustSql session "select * from fresh"
qrRowCount rows `shouldBe` 1 qrRowCount rows `shouldBe` 1
it "does not start a transaction when its snapshot cannot be read" $ do
ref <- newMVar testDb
settings <- tempSettingsPath "snapshot-failure"
let base = memoryBackend testDatabaseName ref
-- | 保留测试后端并让快照读取失败
failing name = (beWithDatabase base name)
{ beSnapshot = pure (Left "data page unreadable")
, beWithDatabase = failing
}
session <- newSession (failing testDatabaseName) (T.pack testDatabaseName) settings
void (mustSql session "USE test")
result <- runStatementCoded session "BEGIN"
failureMessage result `shouldBe` "data page unreadable"
late <- runStatementCoded session "COMMIT"
failureMessage late `shouldBe` "no transaction in progress"
it "refuses nested BEGIN and COMMIT outside a transaction" $ withMemorySession $ \session -> do it "refuses nested BEGIN and COMMIT outside a transaction" $ withMemorySession $ \session -> do
_ <- mustSql session "begin" _ <- mustSql session "begin"
nested <- runStatementCoded session "begin" nested <- runStatementCoded session "begin"
@@ -1539,6 +1704,23 @@ transactionSpec = describe "server transactions" $ do
late <- runStatementCoded session "commit" late <- runStatementCoded session "commit"
failureMessage late `shouldBe` "no transaction in progress" 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 it "does not switch database inside a transaction" $ withMemorySession $ \session -> do
_ <- mustSql session "begin" _ <- mustSql session "begin"
denied <- runStatementCoded session "use other" denied <- runStatementCoded session "use other"
@@ -1732,10 +1914,10 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
let alpha = beWithDatabase base "alpha" let alpha = beWithDatabase base "alpha"
beta = beWithDatabase base "beta" beta = beWithDatabase base "beta"
unselected <- beStatement base "CREATE TABLE alpha.t (id INT)" 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)") mustRun (beStatement alpha "CREATE TABLE alpha.t (id INT, value INT)")
duplicate <- beStatement alpha "CREATE TABLE t (id 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 "INSERT INTO t (id, value) VALUES (1, 7)")
mustRun (beStatement alpha "CREATE INDEX ON alpha.t (value)") mustRun (beStatement alpha "CREATE INDEX ON alpha.t (value)")
mustRun (beStatement alpha "DROP INDEX ON alpha.t (value)") mustRun (beStatement alpha "DROP INDEX ON alpha.t (value)")
@@ -1746,7 +1928,7 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
rows <- rowsOf (beStatement alpha "SELECT score FROM t") rows <- rowsOf (beStatement alpha "SELECT score FROM t")
intColumn "score" rows `shouldBe` [7] intColumn "score" rows `shouldBe` [7]
crossed <- beStatement beta "DROP TABLE alpha.t" 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 "ALTER TABLE alpha.t DROP COLUMN score")
mustRun (beStatement alpha "DROP TABLE alpha.t") mustRun (beStatement alpha "DROP TABLE alpha.t")
catalog <- beCatalog alpha >>= either fail pure catalog <- beCatalog alpha >>= either fail pure
@@ -1755,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 it "isolates domain catalogs by database and hides them from table lists" $ withIpcStorage $ do
base <- ipcBackend base <- ipcBackend
unselected <- beStatement base "SHOW DOMAINS" 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 alpha")
mustRun (beStatement base "CREATE DATABASE beta") mustRun (beStatement base "CREATE DATABASE beta")
let alpha = beWithDatabase base "alpha" let alpha = beWithDatabase base "alpha"
@@ -1771,7 +1953,7 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
domains <- rowsOf (beStatement beta "SHOW DOMAINS") domains <- rowsOf (beStatement beta "SHOW DOMAINS")
domains `shouldBe` [[("domain", VStr "code"), ("base_type", VStr "varchar(3)")]] domains `shouldBe` [[("domain", VStr "code"), ("base_type", VStr "varchar(3)")]]
refused <- beStatement beta "INSERT INTO typed (id) VALUES (1)" 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 it "resolves nested domains only inside their own database" $ withIpcStorage $ do
base <- ipcBackend base <- ipcBackend
@@ -1782,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 label AS VARCHAR(3)")
mustRun (beStatement alpha "CREATE DOMAIN product_label AS label") mustRun (beStatement alpha "CREATE DOMAIN product_label AS label")
absent <- beStatement beta "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 "CREATE TABLE products (name product_label)")
mustRun (beStatement alpha "INSERT INTO products (name) VALUES ('abc')") mustRun (beStatement alpha "INSERT INTO products (name) VALUES ('abc')")
rowsOf (beStatement alpha "SELECT name FROM products") `shouldReturn` [[("name", VStr "abc")]] rowsOf (beStatement alpha "SELECT name FROM products") `shouldReturn` [[("name", VStr "abc")]]
dependency <- beStatement alpha "DROP DOMAIN label" 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 it "keeps two databases apart" $ withIpcStorage $ do
base <- ipcBackend base <- ipcBackend
@@ -1817,7 +1999,7 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
_ <- forkIO (writeRows alpha [1 .. 20] doneA) _ <- forkIO (writeRows alpha [1 .. 20] doneA)
_ <- forkIO (writeRows beta [101 .. 120] doneB) _ <- forkIO (writeRows beta [101 .. 120] doneB)
outs <- sequence [takeMVar doneA, takeMVar 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") rowsA <- rowsOf (beStatement alpha "SELECT id FROM p")
rowsB <- rowsOf (beStatement beta "SELECT id FROM p") rowsB <- rowsOf (beStatement beta "SELECT id FROM p")
intColumn "id" rowsA `shouldMatchList` [1 .. 20] intColumn "id" rowsA `shouldMatchList` [1 .. 20]
@@ -1928,3 +2110,122 @@ checkSudoDisabled admin handle credential sql = do
isRightResult :: Either a b -> Bool isRightResult :: Either a b -> Bool
isRightResult (Right _) = True isRightResult (Right _) = True
isRightResult _ = False isRightResult _ = False
-- 专用范式协议、权限、快照与预算回归。
normalizationSpec :: Spec
normalizationSpec = describe "normalization endpoint" $ do
it "round-trips versioned requests and rejects unknown and duplicate fields" $ do
decodeRequest (BL.toStrict (encodeRequest (ReqNormalization normalizationPayload))) `shouldBe` Right (ReqNormalization normalizationPayload)
let large = ObjectIdentity 9007199254740993 18446744073709551615
A.fromJSON (A.toJSON large) `shouldBe` A.Success large
case A.eitherDecode "{\"database_id\":1e1000000000,\"object_id\":2}" :: Either String A.Value of
Left message -> expectationFailure message
Right value -> (A.fromJSON value :: A.Result ObjectIdentity) `shouldSatisfy` isJSONFailure
report <- either (fail . show) pure (normalizationReport (ObjectIdentity 1 2) [SchemaColumn name "int" True Nothing False False False Nothing | name <- ["id", "name", "age"]] "live_schema" normalizationPayload)
let response = RespNormalization report
decodeResponse (encodeResponse response) `shouldBe` Right response
decodeResponse (encodeResponse (RespNormalization (A.object ["conditional" A..= True]))) `shouldSatisfy` either (const True) (const False)
mapM_ (\raw -> decodeNormalizationJSON raw `shouldSatisfy` either (T.isInfixOf "duplicate") (const False))
[ "{\"a\":1,\"a\":2}", "{\"a\":1,\"\\u0061\":2}", "{\"a\":[{\"b\":1,\"b\":2}]}" ]
let unknown = A.object ["api_version" A..= (1 :: Int), "database" A..= ("test" :: Text), "table" A..= ("users" :: Text), "declaration" A..= nrDeclaration normalizationPayload, "ignored" A..= True]
(A.fromJSON unknown :: A.Result NormalizationRequest) `shouldSatisfy` isJSONFailure
decodeRequest (BL.toStrict (encodeRequest (ReqNormalization normalizationPayload{nrVersion = 2}))) `shouldSatisfy` either (const True) (const False)
decodeRequest (BL.toStrict (encodeRequest (ReqNormalization normalizationPayload{nrTable = "other.users"}))) `shouldSatisfy` either (const True) (const False)
it "does not infer completeness or atomicity and validates declaration budgets" $ do
(A.fromJSON (A.object []) :: A.Result NormalizationDeclaration) `shouldBe` A.Success (NormalizationDeclaration [] [] False Nothing)
let many = NormalizationDeclaration (replicate 257 ["id"]) [] True (Just True)
(A.fromJSON (A.toJSON many) :: A.Result NormalizationDeclaration) `shouldSatisfy` isJSONFailure
decodeNormalizationJSON (BL.replicate 65537 32) `shouldSatisfy` either (const True) (const False)
(A.fromJSON (A.object ["dependencies" A..= [A.object ["lhs" A..= (["id"] :: [Text]), "rhs" A..= ([] :: [Text])]]]) :: A.Result NormalizationDeclaration) `shouldSatisfy` isJSONFailure
it "authorizes ordinary SELECT users and refuses anonymous or system requests" $
withTcpServer defaultServerConfig $ \_ handle -> withConnection handle $ \admin -> do
anonymous <- tcpTalk admin (BL.toStrict (encodeRequest (ReqNormalization normalizationPayload)))
at "code" anonymous `shouldBe` A.String "unauthorized"
_ <- tcpLogin admin "admin" "s3cret"
_ <- tcpQuery admin "USE test"
_ <- tcpQuery admin "CREATE USER normalization_reader IDENTIFIED BY 'Reader-Secret-1234'"
withConnection handle $ \reader -> do
_ <- tcpLogin reader "normalization_reader" "Reader-Secret-1234"
_ <- tcpQuery reader "USE test"
denied <- tcpTalk reader (BL.toStrict (encodeRequest (ReqNormalization normalizationPayload)))
at "code" denied `shouldBe` A.String "forbidden"
_ <- tcpQuery admin "GRANT SELECT ON users TO normalization_reader"
withConnection handle $ \reader -> do
_ <- tcpLogin reader "normalization_reader" "Reader-Secret-1234"
_ <- tcpQuery reader "USE test"
reply <- tcpTalk reader (BL.toStrict (encodeRequest (ReqNormalization normalizationPayload)))
at "status" reply `shouldBe` A.String "normalization"
at "conditional" (at "analysis" reply) `shouldBe` A.Bool True
length (items (at "findings" (at "analysis" reply))) `shouldBe` 4
denied <- tcpTalk reader (BL.toStrict (encodeRequest (ReqNormalization normalizationPayload{nrTable = "__system_domain_secret"})))
at "code" denied `shouldBe` A.String "forbidden"
it "uses only the caller snapshot and refuses stable object replacement" $
withTcpServer defaultServerConfig $ \_ handle -> withConnection handle $ \first -> withConnection handle $ \second -> do
_ <- tcpLogin first "admin" "s3cret"
_ <- tcpLogin second "admin" "s3cret"
_ <- tcpQuery first "USE test"
_ <- tcpQuery second "USE test"
_ <- tcpQuery first "CREATE TABLE normalization_snapshot (id INT, value INT)"
_ <- tcpQuery first "BEGIN"
_ <- tcpQuery second "ALTER TABLE normalization_snapshot ADD COLUMN added INT"
let payload = normalizationPayload{nrTable = "normalization_snapshot", nrDeclaration = NormalizationDeclaration [] [] False Nothing}
old <- tcpTalk first (BL.toStrict (encodeRequest (ReqNormalization payload)))
current <- tcpTalk second (BL.toStrict (encodeRequest (ReqNormalization payload)))
at "view" (at "analysis" old) `shouldBe` A.String "transaction_snapshot"
length (items (at "schema" (at "analysis" old))) `shouldBe` 2
length (items (at "schema" (at "analysis" current))) `shouldBe` 3
at "schema_fingerprint" (at "analysis" old) `shouldNotBe` at "schema_fingerprint" (at "analysis" current)
_ <- tcpQuery second "DROP TABLE normalization_snapshot"
_ <- tcpQuery second "CREATE TABLE normalization_snapshot (id INT, value INT)"
stale <- tcpTalk first (BL.toStrict (encodeRequest (ReqNormalization payload)))
at "code" stale `shouldBe` A.String "conflict"
_ <- tcpQuery first "ROLLBACK"
pure ()
it "checks expected schema fingerprints and budgets the complete output" $ do
let columns = [SchemaColumn ("c" ++ show n) "int" True Nothing False False False Nothing | n <- [0 .. 9 :: Int]]
payload = normalizationPayload{nrDeclaration = NormalizationDeclaration [] [NormalizationDependency [] ["c9"]] True (Just True)}
schemaFingerprint (ObjectIdentity 1 2) columns `shouldNotBe` schemaFingerprint (ObjectIdentity 1 3) columns
normalizationReport (ObjectIdentity 1 2) columns "live_schema" payload{nrExpectedSchema = Just "outdated"}
`shouldBe` Left ("conflict", "normalization object or schema has changed")
result <- normalizationBudget (pure (normalizationReport (ObjectIdentity 1 2) columns "live_schema" payload))
result `shouldSatisfy` either ((== "too_large") . fst) (const False)
it "bounds the largest schema with maximum declared dependencies" $ do
let columns = [SchemaColumn ("c" ++ show n) "int" True Nothing False False False Nothing | n <- [0 .. 11 :: Int]]
payload = normalizationPayload{nrDeclaration = NormalizationDeclaration [] (replicate 256 (NormalizationDependency [] ["c11"])) True (Just True)}
started <- getCurrentTime
result <- normalizationBudget (pure (normalizationReport (ObjectIdentity 1 2) columns "live_schema" payload))
ended <- getCurrentTime
putStrLn ("normalization maximum input seconds: " ++ show (ended `diffUTCTime` started))
result `shouldSatisfy` either ((`elem` ["too_large", "timeout"]) . fst) (const False)
normalizationBudget (pure (Right A.Null)) `shouldReturn` Right A.Null
it "releases admission and execution slots after cancellation" $ do
started <- newEmptyMVar
blocker <- newEmptyMVar
done <- newEmptyMVar
worker <- forkFinally (normalizationBudget (putMVar started () >> takeMVar blocker >> pure (Right A.Null))) (putMVar done)
takeMVar started
killThread worker
takeMVar done >>= either (const (pure ())) (const (expectationFailure "cancelled analysis completed"))
ready <- newEmptyMVar
release <- newEmptyMVar
finished <- newEmptyMVar
replicateM_ 2 (void (forkFinally (normalizationBudget (putMVar ready () >> takeMVar release >> pure (Right A.Null))) (putMVar finished)))
mapM_ (\_ -> timeout 1000000 (takeMVar ready) >>= (`shouldBe` Just ())) [1, 2 :: Int]
replicateM_ 2 (putMVar release ())
replicateM_ 2 (takeMVar finished >>= either (expectationFailure . show) (`shouldBe` Right A.Null))
it "times out work and leaves the service usable" $ do
result <- normalizationBudget (threadDelay 6000000 >> pure (Right A.Null))
result `shouldSatisfy` either ((== "timeout") . fst) (const False)
normalizationBudget (pure (Right A.Null)) `shouldReturn` Right A.Null
-- 共用明确声明的用户表请求。
normalizationPayload :: NormalizationRequest
normalizationPayload = NormalizationRequest 1 "test" "users"
(NormalizationDeclaration [["id"]] [NormalizationDependency ["id"] ["name", "age"]] True (Just True)) Nothing Nothing
-- 判断 JSON 类型校验失败。
isJSONFailure :: A.Result a -> Bool
isJSONFailure (A.Error _) = True
isJSONFailure _ = False
+6 -39
View File
@@ -2,6 +2,7 @@
module Main (main) where module Main (main) where
import Control.Monad (when)
import ChuSQL.Web.API (AppEnv (..), Live (..), newAppEnvAt, setLive, webApp) import ChuSQL.Web.API (AppEnv (..), Live (..), newAppEnvAt, setLive, webApp)
import ChuSQL.Interface.Auth (SessionPolicy (..), setPayloadPolicy) import ChuSQL.Interface.Auth (SessionPolicy (..), setPayloadPolicy)
import ChuSQL.Interface.Config ( import ChuSQL.Interface.Config (
@@ -17,10 +18,8 @@ import ChuSQL.Interface.Config (
) )
import ChuSQL.Interface.Link (clientPing, closeClient, connectClient) import ChuSQL.Interface.Link (clientPing, closeClient, connectClient)
import ChuSQL.Interface.RateLimit (newRateLimiter) import ChuSQL.Interface.RateLimit (newRateLimiter)
import ChuSQL.Interface.Session (authenticateSession, newSession)
import ChuSQL.Interface.Settings (effectiveSettings) import ChuSQL.Interface.Settings (effectiveSettings)
import ChuSQL.Interface.TOML (resolveConfigPath) import ChuSQL.Interface.TOML (resolveConfigPath)
import ChuSQL.Web.Demo (SeedReport (..), seedDemo)
import Control.Exception (IOException, try) import Control.Exception (IOException, try)
import Data.Char (toLower) import Data.Char (toLower)
import Data.String (fromString) import Data.String (fromString)
@@ -52,7 +51,6 @@ data Options = Options
, optMaxPageSize :: Maybe Int , optMaxPageSize :: Maybe Int
, optMaxRows :: Maybe Int , optMaxRows :: Maybe Int
, optMaxSqlLength :: Maybe Int , optMaxSqlLength :: Maybe Int
, optSeedDemo :: Maybe Bool
, optHelp :: Bool , optHelp :: Bool
} }
@@ -74,7 +72,6 @@ emptyOptions =
, optMaxPageSize = Nothing , optMaxPageSize = Nothing
, optMaxRows = Nothing , optMaxRows = Nothing
, optMaxSqlLength = Nothing , optMaxSqlLength = Nothing
, optSeedDemo = Nothing
, optHelp = False , optHelp = False
} }
@@ -99,7 +96,6 @@ parseArgs = go emptyOptions
go opts ("--max-page-size" : v : rest) = withInt "--max-page-size" v (\n -> go opts{optMaxPageSize = Just n} rest) go opts ("--max-page-size" : v : rest) = withInt "--max-page-size" v (\n -> go opts{optMaxPageSize = Just n} rest)
go opts ("--max-rows" : v : rest) = withInt "--max-rows" v (\n -> go opts{optMaxRows = Just n} rest) go opts ("--max-rows" : v : rest) = withInt "--max-rows" v (\n -> go opts{optMaxRows = Just n} rest)
go opts ("--max-sql-length" : v : rest) = withInt "--max-sql-length" v (\n -> go opts{optMaxSqlLength = Just n} rest) go opts ("--max-sql-length" : v : rest) = withInt "--max-sql-length" v (\n -> go opts{optMaxSqlLength = Just n} rest)
go opts ("--seed" : v : rest) = go opts{optSeedDemo = Just (isTrue v)} rest
go opts ("--cookie-secure" : v : rest) = go opts{optCookieSecure = Just (isTrue v)} rest go opts ("--cookie-secure" : v : rest) = go opts{optCookieSecure = Just (isTrue v)} rest
go _ (a : _) = Left ("unrecognized argument or missing value: " ++ a) go _ (a : _) = Left ("unrecognized argument or missing value: " ++ a)
@@ -136,7 +132,6 @@ usage = do
putStrLn " --max-page-size N rows per page ceiling ([web] max_page_size, default 500)" putStrLn " --max-page-size N rows per page ceiling ([web] max_page_size, default 500)"
putStrLn " --max-rows N rows returned per query ([web] max_rows, default 1000)" putStrLn " --max-rows N rows returned per query ([web] max_rows, default 1000)"
putStrLn " --max-sql-length N max SQL characters ([web] max_sql_length, default 20000)" putStrLn " --max-sql-length N max SQL characters ([web] max_sql_length, default 20000)"
putStrLn " --seed BOOL load demo data when the db is empty ([web] seed, default false)"
putStrLn "" putStrLn ""
putStrLn "administrator password: lives in the __system_users system table, never in settings.toml" putStrLn "administrator password: lives in the __system_users system table, never in settings.toml"
putStrLn " the installer always sets one; an account whose hash is still empty signs in with an empty password" putStrLn " the installer always sets one; an account whose hash is still empty signs in with an empty password"
@@ -164,7 +159,6 @@ applyOptions cfg opts =
, wcMaxPageSize = orElse (optMaxPageSize opts) (wcMaxPageSize cfg) , wcMaxPageSize = orElse (optMaxPageSize opts) (wcMaxPageSize cfg)
, wcMaxRows = orElse (optMaxRows opts) (wcMaxRows cfg) , wcMaxRows = orElse (optMaxRows opts) (wcMaxRows cfg)
, wcMaxSqlLength = orElse (optMaxSqlLength opts) (wcMaxSqlLength cfg) , wcMaxSqlLength = orElse (optMaxSqlLength opts) (wcMaxSqlLength cfg)
, wcSeedDemo = orElse (optSeedDemo opts) (wcSeedDemo cfg)
} }
where where
-- | 有就用新的,没有留旧值 -- | 有就用新的,没有留旧值
@@ -220,7 +214,6 @@ run opts = do
printBanner cfg configPath staticDir printBanner cfg configPath staticDir
reportCredential cfg legacy reportCredential cfg legacy
checkServer (aeServerHost env) (aeServerPort env) checkServer (aeServerHost env) (aeServerPort env)
seedIfWanted cfg (aeServerHost env) (aeServerPort env)
let settings = let settings =
Warp.setPort (wcPort cfg) (Warp.setHost (fromString (wcHost cfg)) Warp.defaultSettings) Warp.setPort (wcPort cfg) (Warp.setHost (fromString (wcHost cfg)) Warp.defaultSettings)
serve settings app serve settings app
@@ -256,37 +249,11 @@ serve settings app = do
reportCredential :: WebConfig -> Bool -> IO () reportCredential :: WebConfig -> Bool -> IO ()
reportCredential cfg legacy = do reportCredential cfg legacy = do
putStrLn ("administrator: " ++ T.unpack (rootUserName cfg)) putStrLn ("administrator: " ++ T.unpack (rootUserName cfg))
if legacy when legacy
then do $ do putStrLn
putStrLn " !! the [web] section still carries a plaintext password key; it is ignored now" " !! 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" putStrLn
else pure () " !! remove it: the administrator password lives in the __system_users system table"
-- | 配了 seed 就补演示数据(管理员已设口令时跳过)
seedIfWanted :: WebConfig -> Text -> Int -> IO ()
seedIfWanted cfg host port
| not (wcSeedDemo cfg) = pure ()
| otherwise = do
opened <- connectClient host port
case opened of
Left message -> TIO.putStrLn ("demo data skipped: " <> message)
Right client -> do
session <- newSession client
signed <- authenticateSession session (rootUserName cfg) ""
case signed of
Left message -> TIO.putStrLn ("demo data skipped: " <> message <> " (set the administrator password after seeding)")
Right () -> do
result <- seedDemo session
case result of
Left message -> TIO.putStrLn ("demo data skipped: " <> message)
Right report ->
TIO.putStrLn
( "demo data: "
<> (if null (srCreated report) then "already present" else "created " <> T.pack (unwords (srCreated report)))
<> (if null (srSkipped report) then "" else ", kept " <> T.pack (unwords (srSkipped report)))
<> (if null (srIndexes report) then "" else ", index on " <> T.pack (unwords (srIndexes report)))
)
closeClient client
-- | ping 一次 server,报告它通不通 -- | ping 一次 server,报告它通不通
checkServer :: Text -> Int -> IO () checkServer :: Text -> Int -> IO ()
-1
View File
@@ -12,7 +12,6 @@ build-type: Simple
library library
hs-source-dirs: src hs-source-dirs: src
exposed-modules: ChuSQL.Web.API exposed-modules: ChuSQL.Web.API
ChuSQL.Web.Demo
ChuSQL.Web.Secure ChuSQL.Web.Secure
ChuSQL.Web.Static ChuSQL.Web.Static
ChuSQL.Web.UISettings ChuSQL.Web.UISettings
+42 -37
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Web.API ( module ChuSQL.Web.API (
@@ -20,6 +21,7 @@ module ChuSQL.Web.API (
newAppEnvAt, newAppEnvAt,
) where ) where
import Data.Either (fromRight)
import ChuSQL.Core.Model (Row, Value (..)) import ChuSQL.Core.Model (Row, Value (..))
import ChuSQL.Core.Engine.Syntax.AST (Statement (BeginTransaction, CommitTransaction, RollbackTransaction)) import ChuSQL.Core.Engine.Syntax.AST (Statement (BeginTransaction, CommitTransaction, RollbackTransaction))
import ChuSQL.Core.Engine.Syntax.Parser (parseStatement) import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
@@ -72,10 +74,12 @@ import ChuSQL.Interface.Link (
closeClient, closeClient,
connectClient, connectClient,
) )
import ChuSQL.Interface.Normalization (NormalizationRequest, decodeNormalizationJSON)
import ChuSQL.Interface.Protocol (Grant (..), RoleView (..)) import ChuSQL.Interface.Protocol (Grant (..), RoleView (..))
import ChuSQL.Interface.RateLimit (RateLimiter, rateLimitBlock, rateLimitClear, rateLimitRecord, setRateLimit) import ChuSQL.Interface.RateLimit (RateLimiter, rateLimitBlock, rateLimitClear, rateLimitRecord, setRateLimit)
import ChuSQL.Interface.Session ( import ChuSQL.Interface.Session (
Session, Session,
analyzeNormalization,
authenticateSession, authenticateSession,
catalog, catalog,
databases, databases,
@@ -99,7 +103,6 @@ import ChuSQL.Interface.Settings (
writeSettingsFile, writeSettingsFile,
) )
import ChuSQL.Interface.TOML (defaultConfigFile) import ChuSQL.Interface.TOML (defaultConfigFile)
import ChuSQL.Web.Demo (SeedReport (..), seedDemo)
import ChuSQL.Web.Secure (bodyLimitDynamic, sameOriginOnly, securityHeaders, contentSecurityPolicy) import ChuSQL.Web.Secure (bodyLimitDynamic, sameOriginOnly, securityHeaders, contentSecurityPolicy)
import ChuSQL.Web.Static (contentTypeOf, readStatic, safeRelative) import ChuSQL.Web.Static (contentTypeOf, readStatic, safeRelative)
import ChuSQL.Web.UISettings ( import ChuSQL.Web.UISettings (
@@ -112,7 +115,7 @@ import ChuSQL.Web.UISettings (
import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, withMVar) import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, withMVar)
import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (IOException, try) import Control.Exception (IOException, try)
import Control.Monad (forever, when) import Control.Monad (forever, when, unless)
import Data.Aeson (FromJSON (..), eitherDecode, object, withObject, (.:), (.=)) import Data.Aeson (FromJSON (..), eitherDecode, object, withObject, (.:), (.=))
import qualified Data.Aeson as A import qualified Data.Aeson as A
import qualified Data.Aeson.Key as K import qualified Data.Aeson.Key as K
@@ -123,7 +126,7 @@ import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
import Data.List (nub, sortBy) import Data.List (nub, sortBy)
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Maybe (catMaybes, fromMaybe) import Data.Maybe (catMaybes, fromMaybe, isJust)
import Data.Scientific (fromFloatDigits) import Data.Scientific (fromFloatDigits)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
@@ -132,7 +135,7 @@ import qualified Data.Text.Encoding.Error as TEE
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Data.Time.Clock (getCurrentTime) import Data.Time.Clock (getCurrentTime)
import qualified Data.Vector as V import qualified Data.Vector as V
import Network.HTTP.Types (Status, status204, status400, status401, status403, status404, status409, status413, status429, status500) import Network.HTTP.Types (Status, status204, status400, status401, status403, status404, status409, status413, status429, status500, status503)
import Network.Wai (Application, Request (..)) import Network.Wai (Application, Request (..))
import Text.Read (readMaybe) import Text.Read (readMaybe)
import Web.Scotty import Web.Scotty
@@ -243,13 +246,13 @@ reservedDatabase name = name == systemDatabase
resolveSettingsFileSafe :: IO FilePath resolveSettingsFileSafe :: IO FilePath
resolveSettingsFileSafe = do resolveSettingsFileSafe = do
found <- try defaultConfigFile :: IO (Either IOException FilePath) found <- try defaultConfigFile :: IO (Either IOException FilePath)
pure (either (const "settings.toml") id found) pure (fromRight "settings.toml" found)
-- | 定位 IDE 设置文件,找不到就定下首个候选路径 -- | 定位 IDE 设置文件,找不到就定下首个候选路径
resolveUISettingsFileSafe :: IO FilePath resolveUISettingsFileSafe :: IO FilePath
resolveUISettingsFileSafe = do resolveUISettingsFileSafe = do
found <- try resolveUISettingsFile :: IO (Either IOException FilePath) found <- try resolveUISettingsFile :: IO (Either IOException FilePath)
pure (either (const fallbackUISettingsFile) id found) pure (fromRight fallbackUISettingsFile found)
where where
fallbackUISettingsFile = case uiSettingsFileCandidates of fallbackUISettingsFile = case uiSettingsFileCandidates of
(p : _) -> p (p : _) -> p
@@ -270,8 +273,8 @@ liveBodyLimit env = lvBodyLimit <$> readLive env
-- | 组装 WAI 应用:路由外套四层中间件 -- | 组装 WAI 应用:路由外套四层中间件
webApp :: AppEnv -> IO Application webApp :: AppEnv -> IO Application
webApp env = do webApp env = do
started <- atomicModifyIORef' (aeReaperStarted env) (\old -> (True, old)) started <- atomicModifyIORef' (aeReaperStarted env) (True,)
when (not started) $ do unless started $ do
_ <- forkIO $ forever $ do _ <- forkIO $ forever $ do
threadDelay 60000000 threadDelay 60000000
sweepWebSessions env sweepWebSessions env
@@ -329,7 +332,6 @@ routes env = do
post "/api/tables/:t/indexes" (withDatabase env createIndexH) post "/api/tables/:t/indexes" (withDatabase env createIndexH)
delete "/api/tables/:t/indexes/:col" (withDatabase env dropIndexH) delete "/api/tables/:t/indexes/:col" (withDatabase env dropIndexH)
delete "/api/tables/:t/columns/:col" (withDatabase env dropColumnH) delete "/api/tables/:t/columns/:col" (withDatabase env dropColumnH)
post "/api/demo-data" (withDatabase env demoDataH)
get "/api/roles" (withDatabase env rolesH) get "/api/roles" (withDatabase env rolesH)
post "/api/roles" (withDatabase env createRoleH) post "/api/roles" (withDatabase env createRoleH)
delete "/api/roles/:name" (withDatabase env dropRoleH) delete "/api/roles/:name" (withDatabase env dropRoleH)
@@ -337,6 +339,7 @@ routes env = do
delete "/api/roles/:name/grants" (withDatabase env revokeRoleH) delete "/api/roles/:name/grants" (withDatabase env revokeRoleH)
post "/api/roles/:name/members" (withDatabase env addRoleMemberH) post "/api/roles/:name/members" (withDatabase env addRoleMemberH)
delete "/api/roles/:name/members/:user" (withDatabase env removeRoleMemberH) delete "/api/roles/:name/members/:user" (withDatabase env removeRoleMemberH)
post "/api/normalization/analyze" (withDatabase env normalizationH)
post "/api/query" (withDatabase env queryH) post "/api/query" (withDatabase env queryH)
post "/api/query/rollback" (rollbackConsoleH env) post "/api/query/rollback" (rollbackConsoleH env)
post "/api/edit/begin" (beginEditH env) post "/api/edit/begin" (beginEditH env)
@@ -357,12 +360,13 @@ withDatabase env action = do
else do else do
editing <- header "X-ChuSQL-Edit" editing <- header "X-ChuSQL-Edit"
req <- request 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)) console <- liftIO (readIORef (wsConsole ws))
caller <- consoleOwner caller <- consoleOwner
case console of case console of
Just (owner, database) | not snapshotRead && Just (owner, database) | not snapshotRead &&
(pathInfo req /= ["api", "query"] || caller /= owner || (not (T.null chosen) && chosen /= database)) -> (pathInfo req `notElem` [["api", "query"], ["api", "normalization", "analyze"]] || caller /= owner || (not (T.null chosen) && chosen /= database)) ->
apiError "conflict" "another SQL console owns this connection transaction; commit or rollback there first" apiError "conflict" "another SQL console owns this connection transaction; commit or rollback there first"
_ -> pure () _ -> pure ()
current <- liftIO (sessionDatabase (wsSession ws)) current <- liftIO (sessionDatabase (wsSession ws))
@@ -391,7 +395,8 @@ requireSession env = do
editHeader <- fmap TL.toStrict <$> header "X-ChuSQL-Edit" editHeader <- fmap TL.toStrict <$> header "X-ChuSQL-Edit"
req <- request req <- request
case editHeader of case editHeader of
Just editId | requestMethod req == "GET" && take 2 (pathInfo req) == ["api", "tables"] -> do Just editId | (requestMethod req == "GET" && take 2 (pathInfo req) == ["api", "tables"])
|| (requestMethod req == "POST" && pathInfo req == ["api", "normalization", "analyze"]) -> do
active <- liftIO (readIORef (wsEdit ws)) active <- liftIO (readIORef (wsEdit ws))
database <- maybe "" (T.toLower . TL.toStrict) <$> header "X-ChuSQL-Database" database <- maybe "" (T.toLower . TL.toStrict) <$> header "X-ChuSQL-Database"
case active of case active of
@@ -648,11 +653,11 @@ itemJson effectiveValues fileValues owner spec =
fromProcess = Map.lookup (siKey spec) effectiveValues fromProcess = Map.lookup (siKey spec) effectiveValues
effectiveValue = fromMaybe (defaultOf (siKey spec)) fromProcess effectiveValue = fromMaybe (defaultOf (siKey spec)) fromProcess
shownValue = if secret then "" else fromMaybe effectiveValue fromFile shownValue = if secret then "" else fromMaybe effectiveValue fromFile
hasValue = fromFile /= Nothing hasValue = isJust fromFile
source :: Text source :: Text
source source
| secret = if hasValue then "configured" else "not set" | secret = if hasValue then "configured" else "not set"
| fromFile /= Nothing = "settings file" | isJust fromFile = "settings file"
| otherwise = "default" | otherwise = "default"
-- | 改设置:写配置文件并让可热改项立即生效 -- | 改设置:写配置文件并让可热改项立即生效
@@ -691,7 +696,7 @@ putSettingsH env = do
appliedNow = case reloaded of appliedNow = case reloaded of
Right _ -> nub (applied ++ [k | k <- policyKeys, Map.member k updates]) Right _ -> nub (applied ++ [k | k <- policyKeys, Map.member k updates])
Left _ -> applied 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))) liftIO (aeLog env ("settings updated by " <> user <> ": " <> T.intercalate ", " (Map.keys updates)))
json json
( object ( object
@@ -887,7 +892,7 @@ baseDeleteH _env ws target = do
-- | 取一个列值 -- | 取一个列值
lookupValue :: Text -> [(String, Value)] -> Maybe Value 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 apiError :: Text -> Text -> ActionM a
@@ -905,7 +910,7 @@ serverError message
(rawCode, rest) = T.breakOn ":" message (rawCode, rest) = T.breakOn ":" message
code = T.strip rawCode code = T.strip rawCode
detail = T.strip (T.drop 1 rest) detail = T.strip (T.drop 1 rest)
knownCodes = ["unauthorized", "forbidden", "not_found", "conflict", "bad_request", "no_database", "query_error", "storage_error", "too_large"] knownCodes = ["unauthorized", "forbidden", "not_found", "conflict", "bad_request", "no_database", "query_error", "storage_error", "too_large", "too_busy", "timeout"]
-- | 取错误消息里的错误码 -- | 取错误消息里的错误码
errorCodeOf :: Text -> Text errorCodeOf :: Text -> Text
@@ -920,6 +925,8 @@ statusOf code = case code of
"conflict" -> status409 "conflict" -> status409
"too_many_attempts" -> status429 "too_many_attempts" -> status429
"too_large" -> status413 "too_large" -> status413
"too_busy" -> status503
"timeout" -> status503
"storage_error" -> status500 "storage_error" -> status500
"internal" -> status500 "internal" -> status500
_ -> status400 _ -> status400
@@ -1234,24 +1241,6 @@ dropColumnH env = do
Left err -> reply400 "bad_request" (T.pack err) Left err -> reply400 "bad_request" (T.pack err)
Right sql -> runWrite ws sql Right sql -> runWrite ws sql
-- | 一键灌演示数据(缺什么补什么,可以反复点)
demoDataH :: AppEnv -> ActionM ()
demoDataH env = do
ws <- requireAdminSession env
_ <- requireDatabaseName ws
result <- liftIO (seedDemo (wsSession ws))
case result of
Left message -> serverError message
Right report ->
json
( object
[ "ok" .= True
, "created" .= srCreated report
, "skipped" .= srSkipped report
, "indexes" .= srIndexes report
]
)
-- | 角色总览:只有管理员能看 -- | 角色总览:只有管理员能看
rolesH :: AppEnv -> ActionM () rolesH :: AppEnv -> ActionM ()
rolesH env = do rolesH env = do
@@ -1740,7 +1729,7 @@ executeSql ws live sql = do
, "rowCount" .= qrRowCount res , "rowCount" .= qrRowCount res
, "truncated" .= (qrTruncated res || qrRowCount res > lvMaxRows live) , "truncated" .= (qrTruncated res || qrRowCount res > lvMaxRows live)
, "database" .= qrDatabase res , "database" .= qrDatabase res
, "transaction" .= (transaction /= Nothing) , "transaction" .= isJust transaction
] ]
) )
@@ -1752,7 +1741,7 @@ requireUser env = wsUser <$> requireSession env
requestSessionToken :: ActionM (Maybe Text) requestSessionToken :: ActionM (Maybe Text)
requestSessionToken = do requestSessionToken = do
rawHeader <- header "Cookie" rawHeader <- header "Cookie"
pure (fmap TL.toStrict rawHeader >>= \h -> parseCookieHeader sessionCookieName h) pure (rawHeader >>= parseCookieHeader sessionCookieName . TL.toStrict)
-- | 从 Cookie 头里取一个键(没有就给 Nothing) -- | 从 Cookie 头里取一个键(没有就给 Nothing)
parseCookieHeader :: Text -> Text -> Maybe Text parseCookieHeader :: Text -> Text -> Maybe Text
@@ -1901,3 +1890,19 @@ data QueryRequest = QueryRequest
instance FromJSON QueryRequest where instance FromJSON QueryRequest where
parseJSON = withObject "QueryRequest" $ \o -> QueryRequest <$> o .: "sql" parseJSON = withObject "QueryRequest" $ \o -> QueryRequest <$> o .: "sql"
-- 使用现有连接视图转发只读范式请求。
normalizationH :: AppEnv -> ActionM ()
normalizationH env = do
ws <- requireSession env
rawBody <- body
case decodeNormalizationJSON rawBody of
Left message | BL.length rawBody > 65536 -> reply413
| otherwise -> reply400 "bad_request" message
Right value -> case A.fromJSON value :: A.Result NormalizationRequest of
A.Error message -> reply400 "bad_request" (T.pack message)
A.Success payload -> do
result <- liftIO (analyzeNormalization (wsSession ws) payload)
case result of
Left message -> serverError message
Right report -> json report
-166
View File
@@ -1,166 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Web.Demo (
SeedReport (..),
demoTableSpecs,
demoRows,
demoIndexes,
demoNames,
demoPlan,
seedDemo,
) where
import ChuSQL.Core.Model (Value (..))
import ChuSQL.Core.Protocol (TableInfo (..))
import ChuSQL.Interface.Actions (
ColumnSpec (..),
CreateTableSpec (..),
createIndexSql,
createTableSql,
insertRowsSql,
)
import ChuSQL.Interface.Session (Session, catalog, runStatement)
import Data.Text (Text)
import qualified Data.Text as T
-- 演示数据:三张表加一个二级索引,语句与界面走同一套拼 SQL 的代码。
-- | 演示表(建表顺序即依赖顺序;没有外键约束,纯展示)
demoTableSpecs :: [CreateTableSpec]
demoTableSpecs =
[ CreateTableSpec "users" [ColumnSpec "id" "int", ColumnSpec "name" "str", ColumnSpec "age" "int"]
, CreateTableSpec "orders" [ColumnSpec "id" "int", ColumnSpec "user_id" "int", ColumnSpec "product" "str", ColumnSpec "amount" "int"]
, CreateTableSpec "products" [ColumnSpec "id" "int", ColumnSpec "name" "str", ColumnSpec "sku" "int", ColumnSpec "price" "int"]
]
-- | 每张表的演示行
demoRows :: [(T.Text, [[(String, Value)]])]
demoRows =
[ ( "users"
, [ [("id", VInt i), ("name", VStr name), ("age", VInt age)]
| (i, (name, age)) <- zip [1 :: Int ..] userRecords
]
)
, ( "orders"
, [ [("id", VInt i), ("user_id", VInt uid), ("product", VStr p), ("amount", VInt a)]
| (i, (uid, p, a)) <- zip [1 :: Int ..] orderRecords
]
)
, ( "products"
, [ [("id", VInt i), ("name", VStr n), ("sku", VInt sku), ("price", VInt price)]
| (i, (n, sku, price)) <- zip [1 :: Int ..] productRecords
]
)
]
-- | 演示索引:products.sku 取值唯一
demoIndexes :: [(T.Text, T.Text)]
demoIndexes = [("products", "sku")]
-- | 演示数据涉及的表名
demoNames :: [T.Text]
demoNames = map ctsTable demoTableSpecs
-- | 完整的一套语句(建表 + 插行 + 建索引),按顺序执行
demoPlan :: Either String [String]
demoPlan = do
creates <- mapM createTableSql demoTableSpecs
inserts <- mapM (uncurry insertRowsSql) demoRows
indexes <- mapM (uncurry createIndexSql) demoIndexes
pure (creates ++ inserts ++ indexes)
data SeedReport = SeedReport
{ srCreated :: [String]
, srSkipped :: [String]
, srIndexes :: [String]
}
deriving (Show, Eq)
-- | 按需灌演示数据:缺表补表、缺索引补索引
seedDemo :: Session -> IO (Either Text SeedReport)
seedDemo session = do
catalogResult <- catalog session
case catalogResult of
Left message -> pure (Left message)
Right infos -> do
let existingTables = map tiTable infos
missing = [spec | spec <- demoTableSpecs, T.unpack (ctsTable spec) `notElem` existingTables]
skipped = [T.unpack (ctsTable spec) | spec <- demoTableSpecs, T.unpack (ctsTable spec) `elem` existingTables]
missingNames = map ctsTable missing
wantedIndexes =
[ (t, c)
| (t, c) <- demoIndexes
, t `elem` missingNames || indexMissing infos t c
]
created <- runAll (map createTableSql missing)
case created of
Left message -> pure (Left message)
Right () -> do
rowsDone <- runAll [insertRowsSql t rs | (t, rs) <- demoRows, t `elem` missingNames]
case rowsDone of
Left message -> pure (Left message)
Right () -> do
indexes <- runAll [createIndexSql t c | (t, c) <- wantedIndexes]
pure $ fmap (const (SeedReport (map T.unpack missingNames) skipped (map (T.unpack . snd) wantedIndexes))) indexes
where
-- | 顺序跑完一串语句,首错即停
runAll :: [Either String String] -> IO (Either Text ())
runAll [] = pure (Right ())
runAll (sql : rest) = case sql of
Left e -> pure (Left (T.pack e))
Right statement -> do
result <- runStatement session (T.pack statement)
case result of
Left message -> pure (Left message)
Right _ -> runAll rest
-- | 目录里这张表缺不缺这个索引
indexMissing :: [TableInfo] -> Text -> Text -> Bool
indexMissing infos t c = case lookup (T.unpack t) [(tiTable i, tiIndexes i) | i <- infos] of
Nothing -> True
Just cols -> T.unpack c `notElem` cols
-- | 演示用户数据
userRecords :: [(String, Int)]
userRecords =
[ ("Alice", 24)
, ("Bob", 31)
, ("Carol", 45)
, ("Dave", 19)
, ("Erin", 38)
, ("Frank", 52)
, ("Grace", 27)
, ("Heidi", 33)
, ("Ivan", 41)
, ("Judy", 29)
]
-- | 演示订单数据
orderRecords :: [(Int, String, Int)]
orderRecords =
[ (1, "Laptop", 1299)
, (1, "Mouse", 25)
, (2, "Keyboard", 79)
, (3, "Monitor", 349)
, (3, "Webcam", 89)
, (4, "Headset", 119)
, (5, "SSD", 139)
, (5, "RAM", 99)
, (6, "Dock", 199)
, (7, "Cable", 12)
, (8, "Stand", 45)
, (9, "Lamp", 39)
]
-- | 演示产品数据
productRecords :: [(String, Int, Int)]
productRecords =
[ ("Laptop", 1001, 1299)
, ("Mouse", 1002, 25)
, ("Keyboard", 1003, 79)
, ("Monitor", 1004, 349)
, ("Webcam", 1005, 89)
, ("Headset", 1006, 119)
, ("SSD", 1007, 139)
, ("RAM", 1008, 99)
]
+2 -1
View File
@@ -8,6 +8,7 @@ module ChuSQL.Web.Secure (
bodyLimitDynamic, bodyLimitDynamic,
) where ) where
import Data.Maybe (isNothing)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Char8 as BSC
import Data.Text (Text) import Data.Text (Text)
@@ -28,7 +29,7 @@ import Network.Wai (Middleware, Request (..), mapResponseHeaders, responseLBS)
-- | 所有响应都带上的安全头 -- | 所有响应都带上的安全头
securityHeaders :: Middleware securityHeaders :: Middleware
securityHeaders app req respond = 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 -- | 只给编辑器样式发随机 nonce
contentSecurityPolicy :: Maybe Text -> Text contentSecurityPolicy :: Maybe Text -> Text
+2 -1
View File
@@ -8,6 +8,7 @@ module ChuSQL.Web.UISettings (
writeUISettings, writeUISettings,
) where ) where
import Data.Maybe (fromMaybe)
import Control.Exception (IOException, try) import Control.Exception (IOException, try)
import qualified Data.Aeson as A import qualified Data.Aeson as A
import qualified Data.Aeson.Key as K import qualified Data.Aeson.Key as K
@@ -40,7 +41,7 @@ resolveUISettingsFile = do
Just path -> pure path Just path -> pure path
Nothing -> do Nothing -> do
ready <- firstExistingDir uiSettingsFileCandidates ready <- firstExistingDir uiSettingsFileCandidates
pure (maybe firstCandidate id ready) pure (fromMaybe firstCandidate ready)
where where
-- | 首选候选路径 -- | 首选候选路径
firstCandidate = case uiSettingsFileCandidates of firstCandidate = case uiSettingsFileCandidates of
+30 -19
View File
@@ -11,11 +11,17 @@ function isObject(value) {
return value !== null && typeof value === 'object' && !Array.isArray(value); return value !== null && typeof value === 'object' && !Array.isArray(value);
} }
// 校验结果列名及每行的列数。
function hasValidRows(body) {
return isObject(body) && Array.isArray(body.columns) && body.columns.every((column) => typeof column === 'string')
&& Array.isArray(body.rows) && body.rows.every((row) => Array.isArray(row) && row.length === body.columns.length);
}
// 发一次请求并处理错误。 // 发一次请求并处理错误。
async function request(url, init, database) { async function request(url, init, database) {
const headers = new Headers(init && init.headers ? init.headers : undefined); const headers = new Headers(init && init.headers ? init.headers : undefined);
if (database) headers.set('X-ChuSQL-Database', database); if (database) headers.set('X-ChuSQL-Database', database);
if (editing && editing.database === database && url.startsWith('/api/tables') && (!init || init.method === 'GET')) { if (editing && editing.database === database && ((url.startsWith('/api/tables') && (!init || init.method === 'GET')) || url === '/api/normalization/analyze')) {
headers.set('X-ChuSQL-Edit', editing.id); headers.set('X-ChuSQL-Edit', editing.id);
} }
let response; let response;
@@ -114,21 +120,13 @@ export async function useDatabase(name, database) {
// ---------------------------------------------------------------- 表结构 // ---------------------------------------------------------------- 表结构
// 取类型基名(去掉参数)。
function columnKind(type) {
return String(type).split('(')[0].trim().toLowerCase();
}
const knownTypes = ['int', 'bigint', 'smallint', 'str', 'text', 'varchar', 'char', 'float', 'double', 'decimal', 'numeric', 'bool', 'date', 'timestamp', 'blob'];
// 校验并规整列描述。 // 校验并规整列描述。
function asColumns(value) { function asColumns(value) {
if (!Array.isArray(value)) throw new Error('服务器返回的列清单无法识别。'); if (!Array.isArray(value)) throw new Error('服务器返回的列清单无法识别。');
return value.map((entry) => { return value.map((entry) => {
if (!isObject(entry) || typeof entry.name !== 'string' || typeof entry.type !== 'string') { if (!isObject(entry) || typeof entry.name !== 'string' || typeof entry.type !== 'string' || !entry.type.trim()) {
throw new Error('服务器返回的列描述无法识别。'); throw new Error('服务器返回的列描述无法识别。');
} }
if (!knownTypes.includes(columnKind(entry.type))) throw new Error(`不支持的列类型:${entry.type}`);
return { ...entry, name: entry.name, type: entry.type }; return { ...entry, name: entry.name, type: entry.type };
}); });
} }
@@ -197,13 +195,11 @@ export async function fetchRows({ database, table, limit, offset, sort, dir, fil
params.set('filter', JSON.stringify(filters.map((f) => ({ column: f.column, value: f.expression })))); params.set('filter', JSON.stringify(filters.map((f) => ({ column: f.column, value: f.expression }))));
} }
const body = await request(`/api/tables/${encodeURIComponent(table)}/rows?${params}`, undefined, database); const body = await request(`/api/tables/${encodeURIComponent(table)}/rows?${params}`, undefined, database);
if (!isObject(body) || !Array.isArray(body.columns) || !body.columns.every((c) => typeof c === 'string') if (!hasValidRows(body) || !Number.isSafeInteger(body.total) || body.total < 0) {
|| !Array.isArray(body.rows) || typeof body.total !== 'number') {
throw new Error('服务器返回的分页数据无法识别。'); throw new Error('服务器返回的分页数据无法识别。');
} }
const columns = body.columns; const columns = body.columns;
const rows = body.rows.map((raw) => { const rows = body.rows.map((raw) => {
if (!Array.isArray(raw)) throw new Error('服务器返回的行数据无法识别。');
return Object.fromEntries(columns.map((column, index) => [column, raw[index]])); return Object.fromEntries(columns.map((column, index) => [column, raw[index]]));
}); });
return { columns, rows, total: body.total }; return { columns, rows, total: body.total };
@@ -281,7 +277,7 @@ export async function query(sql, database, tabId) {
const init = jsonInit('POST', { sql }); const init = jsonInit('POST', { sql });
init.headers['X-ChuSQL-Console'] = console; init.headers['X-ChuSQL-Console'] = console;
const body = await request('/api/query', init, database); const body = await request('/api/query', init, database);
if (!isObject(body) || !Array.isArray(body.columns) || !Array.isArray(body.rows)) { if (!hasValidRows(body)) {
throw new Error('服务器返回的查询结果无法识别。'); throw new Error('服务器返回的查询结果无法识别。');
} }
const durationMs = performance.now() - started; const durationMs = performance.now() - started;
@@ -301,11 +297,6 @@ export async function query(sql, database, tabId) {
} }
} }
// 灌演示数据。
export async function seedDemoData(database) {
return request('/api/demo-data', jsonInit('POST', {}), database);
}
// ---------------------------------------------------------------- 设置 // ---------------------------------------------------------------- 设置
// 读取服务器设置。 // 读取服务器设置。
@@ -330,3 +321,23 @@ export async function loadUiSettings() {
export async function saveUiSettings(settings) { export async function saveUiSettings(settings) {
await request('/api/ui-settings', jsonInit('PUT', settings)); await request('/api/ui-settings', jsonInit('PUT', settings));
} }
// 在页面已有视图上请求只读范式分析。
export async function analyzeNormalization(database, table, declaration, expected) {
const payload = { api_version: 1, database, table };
if (expected) {
payload.expected_object = expected.object;
payload.expected_schema_fingerprint = expected.schema_fingerprint;
}
const init = jsonInit('POST', payload);
if (!editing && consoleTransaction?.database === database) {
init.headers['X-ChuSQL-Console'] = consoleTransaction.console;
}
// 原始声明直接嵌入,重复字段交给服务端明确拒绝。
init.body = `${JSON.stringify(payload).slice(0, -1)},"declaration":${typeof declaration === 'string' ? declaration : JSON.stringify(declaration)}}`;
const result = await request('/api/normalization/analyze', init, database);
if (!isObject(result) || result.api_version !== 1 || !Array.isArray(result.findings) || !Array.isArray(result.schema)) {
throw new Error('服务器返回的范式报告无法识别。');
}
return result;
}
Loaded 100 of 127 files, more files were not shown because too many files have changed in this diff. Show more