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

大改，整理项目结构，完成rust ffi调用，写好tcp接口

Browse Source
This commit is contained in:
LIm1tZz7 committed 2026-10-02 15:07:38 +08:00
1 parent df6d348995
commit 9758439b82
118 files changed
+7996 -6214
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

.github/workflows/linux.yml
+15 -13
View File
@@ -1,8 +1,8 @@
# Linux 流水线：Rust 存储 + Haskell 引擎/Web/CLI 的构建与测试。
#
# 这里每条命令都在 WSL Debian（cargo 1.98 / GHC 9.10.3 / stack 3.11.1）上跑通过，
# 见仓库根 README 的「构建与测试」段。IPC 用例需要 chusql-storage 可执行文件，
# 所以 Rust 先构建，Haskell 的 engine/web 用例才能真跑而不是 pending。
# 见仓库根 README 的「构建与测试」段。Haskell 这边链接并装入 libchusql_core_storage.so，
# 所以 Rust 先构建，LD_LIBRARY_PATH 指向它的输出目录，Haskell 用例才能真跑而不是 pending。
# 打包和发版资源走 .github/workflows/release.yml（tag 触发，也可手动 dispatch）。
name: linux
@@ -18,6 +18,7 @@ concurrency:
env:
CARGO_TERM_COLOR: always
LD_LIBRARY_PATH: ${{ github.workspace }}/chusql-core/storage/target/release
jobs:
linux:
@@ -39,24 +40,20 @@ jobs:
path: |
~/.cargo/registry
~/.cargo/git
chusql-storage/target
key: ${{ runner.os }}-cargo-${{ hashFiles('chusql-storage/Cargo.lock') }}
chusql-core/storage/target
key: ${{ runner.os }}-cargo-${{ hashFiles('chusql-core/storage/Cargo.lock') }}
restore-keys: ${{ runner.os }}-cargo-
- name: cargo build (release)
working-directory: chusql-storage
working-directory: chusql-core/storage
run: cargo build --release
- name: cargo build (debug, IPC 用例要它)
working-directory: chusql-storage
run: cargo build --bin chusql-storage
- name: cargo test
working-directory: chusql-storage
working-directory: chusql-core/storage
run: cargo test --release
- name: cargo clippy (-D warnings)
working-directory: chusql-storage
working-directory: chusql-core/storage
run: cargo clippy --all-targets -- -D warnings
# 故意不做 rustfmt 检查：仓库里没有 rustfmt.toml，历史代码也不是按当前 rustfmt 的
@@ -76,7 +73,8 @@ jobs:
with:
path: |
~/.stack
chusql-engine/.stack-work
chusql-core/engine/.stack-work
chusql-server/.stack-work
chusql-web/.stack-work
chusql-cli/.stack-work
key: ${{ runner.os }}-stack-${{ hashFiles('**/stack.yaml', '**/stack.yaml.lock') }}
@@ -87,7 +85,11 @@ jobs:
run: stack build --fast
- name: engine tests
working-directory: chusql-engine
working-directory: chusql-core/engine
run: stack test --fast
- name: server tests
working-directory: chusql-server
run: stack test --fast
- name: web tests
.github/workflows/release.yml
+38 -35
View File
@@ -1,10 +1,11 @@
# 发版流水线：打 tag（v*）时为四个平台各出 web / cli 两个发行包，附 sha256，挂到 Release。
# 发版流水线：打 tag（v*）时为四个平台各出一个发行包，附 sha256，挂到 Release。
#
# 资源命名（install.sh 按 <os>-<arch> 挑资源，见 scripts/install.sh）：
# chusql-web-linux-x86_64.tar.gz chusql-cli-linux-x86_64.tar.gz
# chusql-web-windows-x86_64.zip chusql-cli-windows-x86_64.zip
# chusql-web-macos-x86_64.tar.gz chusql-cli-macos-x86_64.tar.gz
# chusql-web-macos-arm64.tar.gz chusql-cli-macos-arm64.tar.gz
# 资源命名（install.sh / install.ps1 按 <os>-<arch> 挑资源，见 scripts/install.sh）：
# chusql-linux-x86_64.tar.gz chusql-windows-x86_64.zip
# chusql-macos-x86_64.tar.gz chusql-macos-arm64.tar.gz
#
# 一个平台一个包，里面 Web 前端与命令行客户端两部分都在；装哪几个由包内的安装脚本
# 当场问（非交互时用 --component / -Component 指定）。
#
# 装的人拿到的就是编好的二进制，不需要 GHC / Rust：
# curl -fsSL https://raw.githubusercontent.com/TheBadRoger/ChuSQL/main/scripts/install.sh \
@@ -33,9 +34,9 @@ env:
jobs:
build:
name: ${{ matrix.platform }} / ${{ matrix.component }}
name: ${{ matrix.platform }}
runs-on: ${{ matrix.os }}
timeout-minutes: 120
timeout-minutes: 150
strategy:
fail-fast: false
matrix:
@@ -44,7 +45,6 @@ jobs:
- { os: windows-latest, platform: windows-x86_64 }
- { os: macos-13, platform: macos-x86_64 }
- { os: macos-14, platform: macos-arm64 }
component: [web, cli]
steps:
- uses: actions/checkout@v4
@@ -58,8 +58,8 @@ jobs:
path: |
~/.cargo/registry
~/.cargo/git
chusql-storage/target
key: ${{ runner.os }}-${{ matrix.platform }}-cargo-${{ hashFiles('chusql-storage/Cargo.lock') }}
chusql-core/storage/target
key: ${{ runner.os }}-${{ matrix.platform }}-cargo-${{ hashFiles('chusql-core/storage/Cargo.lock') }}
restore-keys: ${{ runner.os }}-cargo-
- name: Haskell toolchain
@@ -74,7 +74,7 @@ jobs:
with:
path: |
~/.stack
chusql-engine/.stack-work
chusql-core/engine/.stack-work
chusql-web/.stack-work
chusql-cli/.stack-work
key: ${{ runner.os }}-${{ matrix.platform }}-stack-${{ hashFiles('**/stack.yaml', '**/stack.yaml.lock') }}
@@ -82,59 +82,62 @@ jobs:
# ---------- 构建 ----------
- name: build storage (Rust)
working-directory: chusql-storage
working-directory: chusql-core/storage
run: cargo build --release
- name: build web front end
if: matrix.component == 'web'
working-directory: chusql-cli
run: stack build --fast chusql-web:exe:chusql-web
- name: build cli
if: matrix.component == 'cli'
working-directory: chusql-cli
run: stack build --fast chusql-cli:exe:csql
# ---------- 装配 + 打归档（原来放在一个独立的打包脚本里，那个脚本已经删掉）----------
- name: build tcp server
working-directory: chusql-cli
run: stack build --fast chusql-server:exe:chusql-server
# ---------- 装配 + 打归档（CI 里直接写在这里；本机打同一个包用 scripts/package.sh）----------
# 归档里是包内容本身（bin/、scripts/、static/、install.sh 就在根上），安装脚本按这个布局找文件。
- name: package (Unix)
if: runner.os != 'Windows'
shell: bash
run: |
set -eu
component='${{ matrix.component }}'
name="chusql-$component-${{ matrix.platform }}"
name="chusql-${{ matrix.platform }}"
stage="dist/$name"
rm -rf "$stage"
mkdir -p "$stage/bin" "$stage/scripts"
cp chusql-storage/target/release/chusql-storage "$stage/bin/"
cp chusql-core/storage/target/release/libchusql_core_storage.* "$stage/bin/"
stack_root="$(cd chusql-cli && stack path --local-install-root | tail -n 1 | tr -d '\r')"
if [ "$component" = web ]; then front_name=chusql-web; else front_name=csql; fi
for front_name in chusql-web chusql-server csql; do
front="$stack_root/bin/$front_name"
if [ ! -f "$front" ]; then
front="$(find chusql-web/.stack-work chusql-cli/.stack-work -name "$front_name" -type f 2>/dev/null | head -n 1 || true)"
fi
[ -n "$front" ] && [ -f "$front" ] || { echo "front end binary not found: $front_name" >&2; exit 1; }
cp "$front" "$stage/bin/"
done
# Haskell 一般静态链接，靶目录里真有共享库就一起带上
for lib in chusql-storage/target/release/*.so chusql-storage/target/release/*.dylib; do
[ -f "$lib" ] && cp "$lib" "$stage/bin/"
# Haskell 一般静态链接，靶目录里真有共享库就一起带上；改名前的旧库（libchusql_storage.*）不能进包
for lib in chusql-core/storage/target/release/*.so chusql-core/storage/target/release/*.dylib; do
[ -f "$lib" ] || continue
case "$(basename "$lib")" in
libchusql_storage.*|libchusql_storage-*) continue ;;
esac
cp "$lib" "$stage/bin/"
done
cp scripts/chusql.toml scripts/init.sql "$stage/scripts/"
cp scripts/install.ps1 scripts/install.sh "$stage/"
if [ "$component" = web ]; then
mkdir -p "$stage/static"
cp -R chusql-web/static/. "$stage/static/"
cp scripts/csql-web.sh "$stage/"
if [ -f scripts/csql-web.ps1 ]; then cp scripts/csql-web.ps1 "$stage/"; fi
fi
chmod +x "$stage/install.sh"
if [ -f "$stage/csql-web.sh" ]; then chmod +x "$stage/csql-web.sh"; fi
chmod +x "$stage/install.sh" "$stage/csql-web.sh"
mkdir -p dist
tar -czf "dist/$name.tar.gz" -C "$stage" .
@@ -146,16 +149,15 @@ jobs:
shell: pwsh
run: |
$ErrorActionPreference = 'Stop'
$component = '${{ matrix.component }}'
$name = "chusql-$component-${{ matrix.platform }}"
$name = "chusql-${{ matrix.platform }}"
$stage = "dist/$name"
if (Test-Path $stage) { Remove-Item -Recurse -Force $stage }
New-Item -ItemType Directory -Force -Path "$stage/bin", "$stage/scripts" | Out-Null
Copy-Item 'chusql-storage/target/release/chusql-storage.exe' "$stage/bin/"
Copy-Item 'chusql-core/storage/target/release/chusql_core_storage.dll' "$stage/bin/"
$stackRoot = (& stack path --local-install-root | Select-Object -Last 1).Trim()
$frontName = if ($component -eq 'web') { 'chusql-web.exe' } else { 'csql.exe' }
foreach ($frontName in @('chusql-web.exe', 'chusql-server.exe', 'csql.exe')) {
$front = Join-Path $stackRoot "bin/$frontName"
if (-not (Test-Path $front)) {
$front = Get-ChildItem -Path 'chusql-web/.stack-work', 'chusql-cli/.stack-work' -Recurse -Filter $frontName -File -ErrorAction SilentlyContinue |
@@ -163,18 +165,19 @@ jobs:
}
if (-not $front -or -not (Test-Path $front)) { throw "front end binary not found: $frontName" }
Copy-Item $front "$stage/bin/"
}
Get-ChildItem 'chusql-storage/target/release' -Filter '*.dll' -File -ErrorAction SilentlyContinue |
# 第三方 dll 才要连带上：名字带 chusql 的是本 crate 产物或改名前的残留，上面已按名拷过
Get-ChildItem 'chusql-core/storage/target/release' -Filter '*.dll' -File -ErrorAction SilentlyContinue |
Where-Object { $_.Name -notlike 'chusql*' } |
ForEach-Object { Copy-Item $_.FullName "$stage/bin/" }
Copy-Item 'scripts/chusql.toml', 'scripts/init.sql' "$stage/scripts/"
Copy-Item 'scripts/install.ps1', 'scripts/install.sh' $stage
if ($component -eq 'web') {
New-Item -ItemType Directory -Force -Path "$stage/static" | Out-Null
Copy-Item 'chusql-web/static/*' "$stage/static" -Recurse
Copy-Item 'scripts/csql-web.sh' $stage
if (Test-Path 'scripts/csql-web.ps1') { Copy-Item 'scripts/csql-web.ps1' $stage }
}
New-Item -ItemType Directory -Force -Path dist | Out-Null
Compress-Archive -Path "$stage/*" -DestinationPath "dist/$name.zip" -Force
@@ -193,7 +196,7 @@ jobs:
- name: upload
uses: actions/upload-artifact@v4
with:
name: ${{ matrix.platform }}-${{ matrix.component }}
name: ${{ matrix.platform }}
path: |
dist/*.zip
dist/*.tar.gz
.gitignore
+10 -7
View File
@@ -1,12 +1,12 @@
# ============================================================
# ChuSQL 单仓库 .gitignore
# chusql-engine/ Haskell (Stack + Cabal)
# chusql-storage/ Rust (Cargo)
# chusql-core/engine/ Haskell (Stack + Cabal)
# chusql-core/storage/ Rust (Cargo)
# chusql-web/ 前端 (手写 HTML / CSS / JS，无 Node 工具链)
# ============================================================
# ------------------------------------------------------------
# Haskell / Stack / Cabal —— chusql-engine
# Haskell / Stack / Cabal —— chusql-core/engine
# ------------------------------------------------------------
.stack-work/
dist-newstyle/
@@ -26,21 +26,24 @@ cabal.project.local
cabal.project.local~
# 锁文件要入库，不要忽略：
# chusql-engine/stack.yaml.lock
# chusql-core/engine/stack.yaml.lock
# cabal.project.freeze
# ------------------------------------------------------------
# Rust / Cargo —— chusql-storage
# Rust / Cargo —— chusql-core/storage
# ------------------------------------------------------------
target/
**/*.rs.bk
# 运行时数据（Rust 服务默认数据目录 CHUSQL_DATA_DIR=data/），不入库
chusql-storage/data/
chusql-core/storage/data/
# 一键启动脚本的默认数据目录与日志，不入库
localdata/
# 本机打出来的发行包（scripts/package.sh / package.ps1 的产物），不入库
releases/
# 前端 IDE 设置（字体等，由 /api/ui-settings 读写），本机专用，不入库
scripts/chusql.ui.settings.json
@@ -74,7 +77,7 @@ scripts/chusql.ui.settings.json
\#*\#
.\#*
agent_credientials
.dsh
# 注意：.zed/tasks.json 是本仓库共享的构建任务（stack build / run / test / repl），
# 需要入库，所以这里不忽略 .zed/
.zed/tasks.json
+6 -15
View File
@@ -2,7 +2,7 @@
{
"label": "haskell: stack build",
"command": "stack build",
"cwd": "$ZED_WORKTREE_ROOT/chusql-engine",
"cwd": "$ZED_WORKTREE_ROOT/chusql-core/engine",
"reveal": "always",
"hide": "on_success",
"save": "all",
@@ -10,7 +10,7 @@
{
"label": "haskell: stack test",
"command": "stack test",
"cwd": "$ZED_WORKTREE_ROOT/chusql-engine",
"cwd": "$ZED_WORKTREE_ROOT/chusql-core/engine",
"reveal": "always",
"hide": "never",
"save": "all",
@@ -18,7 +18,7 @@
{
"label": "haskell: stack run",
"command": "stack run",
"cwd": "$ZED_WORKTREE_ROOT/chusql-engine",
"cwd": "$ZED_WORKTREE_ROOT/chusql-core/engine",
"reveal": "always",
"hide": "never",
"save": "all",
@@ -26,7 +26,7 @@
{
"label": "haskell: stack repl",
"command": "stack ghci",
"cwd": "$ZED_WORKTREE_ROOT/chusql-engine",
"cwd": "$ZED_WORKTREE_ROOT/chusql-core/engine",
"reveal": "always",
"hide": "never",
"save": "all",
@@ -35,7 +35,7 @@
"label": "rust: cargo check",
"command": "cargo",
"args": ["check", "--all-targets"],
"cwd": "$ZED_WORKTREE_ROOT/chusql-storage",
"cwd": "$ZED_WORKTREE_ROOT/chusql-core/storage",
"reveal": "always",
"hide": "on_success",
"save": "all",
@@ -44,16 +44,7 @@
"label": "rust: cargo test",
"command": "cargo",
"args": ["test"],
"cwd": "$ZED_WORKTREE_ROOT/chusql-storage",
"reveal": "always",
"hide": "never",
"save": "all",
},
{
"label": "rust: cargo run server",
"command": "cargo",
"args": ["run", "--bin", "server"],
"cwd": "$ZED_WORKTREE_ROOT/chusql-storage",
"cwd": "$ZED_WORKTREE_ROOT/chusql-core/storage",
"reveal": "always",
"hide": "never",
"save": "all",
AGENTS.md
+9 -1
View File
@@ -14,9 +14,17 @@
- 索引由存储层管理，优化器只判断可点查条件。
- 优化不能改变结果语义。
## 注释规范
- 文件级：外部引用语句（Haskell `import`、Rust `use`、JS `import`、HTML 的 `<link>`/`<script>`、
CSS `@import`、脚本的依赖/参数区）之后写一段注释，概括本文件的功能；没有引用语句的文件写在
文件开头。长度不超过 3 行、合计不超过 90 字。
- 函数级：每个函数（含 Haskell 的 `where`/`let` 内函数、Rust 的私有 `fn`）前用一行不超过
30 字的注释说明它做什么。
- 只写"做什么"，不写设计理由、历史与被删掉的旧实现；那些放 `design-decisions.txt` /
`known-issues.txt`。
## 协作规则
- engine / web / storage 使用规定测试入口。
- 注释、文案保持简短。
- 改动说明只在交流中记录。
## 当前重点
README.md
+7 -6
View File
@@ -4,7 +4,7 @@
优点：
- 轻量：两个可执行文件加一份静态资源，解包即用，没有 Node / Python 之类的运行时依赖
- 轻量：几个可执行文件加两个动态库、一份静态资源，解包即用，没有 Node / Python 之类的运行时依赖
- 部署容易：Linux 与 macOS 一条命令装完并启动，Windows 解压后跑一次安装脚本
- 配置统一：一个 `chusql.toml` 同时管住存储、Web 与命令行
- 账号统一：Web 管理端与命令行共用同一个管理员和同一张账号表
@@ -14,16 +14,17 @@
Linux / macOS（自动识别当前平台，取对应发行包）：
```sh
curl -fsSL https://github.com/TheBadRoger/ChuSQL/releases/latest/download/install.sh | sh -s -- --component web
curl -fsSL https://raw.githubusercontent.com/TheBadRoger/ChuSQL/main/scripts/install.sh | sh -s -- --component web
```
Windows：下载 `chusql-web-windows-x86_64.zip`，解压后在 PowerShell 里执行
Windows：下载 `chusql-windows-x86_64.zip`，解压后在 PowerShell 里执行
```powershell
.\install.ps1 -Component web
```
只装命令行客户端就把 `web` 换成 `cli`，入口变成 `csql`。安装位置、目录结构与卸载方式见
不写 `--component` 时脚本会逐个问「装 cli 吗」「装 web 吗」（默认装 `csql`、不装 Web）；只装命令行
客户端就把 `web` 换成 `cli`，两个都要用 `both`。安装位置、目录结构与卸载方式见
[doc/install.md](doc/install.md)。
## 启动
@@ -32,7 +33,7 @@ Windows：下载 `chusql-web-windows-x86_64.zip`，解压后在 PowerShell 里
csql-web
```
浏览器打开 http://127.0.0.1:7777 ，默认账号 `root`，口令是安装时给的那个。服务启动后只有系统库 `system`（里面是账号表），**没有默认工作库**：自己建一个库再用 `USE <库名>` 选中它。
浏览器打开 http://127.0.0.1:7778 ，默认账号 `root`，口令是安装时给的那个。服务启动后只有系统库 `system`（里面是账号表），**没有默认工作库**：自己建一个库再用 `USE <库名>` 选中它。
换口令、换端口、改数据目录都在安装时写好的 `chusql.toml` 里。
## 文档
@@ -40,6 +41,6 @@ csql-web
| 文档 | 内容 |
| --------------------------------- | ------------------------------------------------------------------------ |
| [安装与卸载](doc/install.md) | 三种安装方式、全部安装选项、装完的目录结构、从源码安装、卸载 |
| [配置选项](doc/config.md) | 配置位置与优先级、全部配置键与默认值、端点规则、口令与安全 |
| [配置选项](doc/config.md) | 配置位置与优先级、全部配置键与默认值、数据目录、口令与安全 |
| [命令与选项](doc/commands.md) | `csql` 与 `chusql-web` 的选项、元命令、账号与角色权限、REST 接口 |
| [架构与组件](doc/architecture.md) | 三个组件怎么分工、一次请求经过什么、数据落在哪 |
benchmark/chusql-fullchain.cabal
+8 -2
View File
@@ -2,16 +2,22 @@ cabal-version: 2.4
name: chusql-fullchain
version: 1.0.0
synopsis: ChuSQL 全链路基准：Haskell 引擎 + Rust 存储进程一起跑
synopsis: ChuSQL 全链路基准：起真 server，全部请求走 TCP
description: 以基准客户端身份起一个 chusql-server 进程（存储与引擎都在那个进程里），
再经 TCP JSON-lines 协议打登录、ping、catalog、查询等场景。
本程序不链引擎、不链 server 库，只用 TCP 客户端与协议模型。
build-type: Simple
executable chusql-fullchain
main-is: Main.hs
hs-source-dirs: src
build-tool-depends: chusql-server:chusql-server
build-depends: base >= 4.14 && < 5
, chusql-engine
, chusql-core-model
, chusql-interface
, directory
, filepath
, process
, text
default-language: Haskell2010
ghc-options: -O2 -Wall
benchmark/src/Main.hs
+286 -213
View File
@@ -1,40 +1,39 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where
import ChuSQL.Engine (runStatementM)
import ChuSQL.Model (Row, Value (..))
import ChuSQL.Storage (IndexResult (..))
import ChuSQL.Storage.IPC (
IPCStorage (..),
Request (..),
Response (..),
TableInfo (..),
closeConnection,
doInsert,
doListCatalog,
doLookupByColumn,
sendRequest,
setPipeName,
import ChuSQL.Core.Protocol (QueryResult (..), TableInfo (..))
import ChuSQL.Interface.Link (Client, clientPing, closeClient, connectClient)
import ChuSQL.Interface.Session (
Session,
authenticateSession,
catalog,
newSession,
runStatement,
switchDatabase,
)
import ChuSQL.Syntax.Parser (parseStatement)
import Control.Concurrent (threadDelay)
import Control.Exception (SomeException, bracket, evaluate, try)
import Control.Monad (filterM, unless, when)
import Data.List (intercalate, isInfixOf)
import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (IOException, bracket, evaluate, try)
import Control.Monad (unless, when)
import Data.List (intercalate)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Clock (getMonotonicTime)
import System.Directory (
createDirectoryIfMissing,
doesFileExist,
findExecutable,
getTemporaryDirectory,
removeDirectoryRecursive,
)
import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.Exit (ExitCode (..), exitFailure)
import System.FilePath ((</>))
import System.Info (os)
import System.IO (Handle, hGetLine)
import System.Process (
CreateProcess (..),
CreateProcess (std_err, std_out),
ProcessHandle,
StdStream (..),
StdStream (CreatePipe, NoStream),
createProcess,
proc,
terminateProcess,
@@ -42,103 +41,51 @@ import System.Process (
)
import Text.Printf (printf)
-- 全链路基准：Haskell 引擎与 Rust 存储进程一起跑，语句走完整链路并打印墙上耗时。
-- 全链路基准：客户端经 TCP 连 chusql-server，落盘到进程内 Rust 存储。
-- 每条语句都走完整链路：解析、语义检查、提交。
-- 对照项：ping 与 catalog。
-- | 找 Rust 存储进程：优先 release
findServer :: FilePath -> IO FilePath
findServer "" = do
let dirs =
[ "chusql-storage/target"
, "../chusql-storage/target"
]
modes = ["release", "debug"]
-- 名字跟平台走：同一个 target 目录里可能躺着一份别处交叉编译出来的 .exe，
-- 在 Linux 上误选它只会拿到 config file not found
exes = [if os == "mingw32" then "chusql-storage.exe" else "chusql-storage"]
candidates = [d </> m </> e | d <- dirs, m <- modes, e <- exes]
found <- filterM doesFileExist candidates
case found of
(p : _) -> do
unless ("release" `isInfixOf` p) $
putStrLn "!! using the debug storage binary; numbers will be slower, run: cargo build --release"
pure p
[] -> do
putStrLn "Rust storage binary not found. Build it first:"
putStrLn " cd chusql-storage && cargo build --release"
exitFailure
findServer p = do
ok <- doesFileExist p
if ok
then pure p
else do
putStrLn ("storage binary not found: " ++ p)
exitFailure
-- | 一个基准世界：真 server 进程 + 一条 TCP 会话
data Bench = Bench
{ bProcess :: ProcessHandle
, bDataDir :: FilePath
, bClient :: Client
, bSession :: Session
}
-- | 起存储进程并等管道可连：调参走 --config 指的那份配置文件，环境原样继承
startServer :: FilePath -> FilePath -> IO ProcessHandle
startServer serverPath configPath = do
(_, _, _, ph) <-
createProcess
(proc serverPath ["--config", configPath]){std_out = NoStream, std_err = Inherit}
ready <- waitReady (200 :: Int)
unless ready $ do
putStrLn "storage process was not ready within 5 s"
exitFailure
pure ph
-- | 轮询 ping，直到对面应答
waitReady :: Int -> IO Bool
waitReady 0 = pure False
waitReady n = do
r <- try (sendRequest ReqPing) :: IO (Either SomeException Response)
case r of
Right RespPong -> pure True
_ -> threadDelay 25000 >> waitReady (n - 1)
-- | 停存储进程并清掉缓存连接
stopServer :: ProcessHandle -> FilePath -> IO ()
stopServer ph dataDir = do
closeConnection
terminateProcess ph
_ <- waitForProcess ph
_ <- try (removeDirectoryRecursive dataDir) :: IO (Either SomeException ())
pure ()
-- | 跑一条 SQL 文本（整条链路）
runSql :: Bench -> String -> IO (Either Text QueryResult)
runSql bench sql = runStatement (bSession bench) (T.pack sql)
-- | 量一次墙上耗时并强制求出行数
timedRows :: IO (Either String [Row]) -> IO (Double, Either String Int)
timedRows act = do
timedQuery :: Bench -> String -> IO (Double, Either Text Int)
timedQuery bench sql = do
t0 <- getMonotonicTime
r <- act
r <- runSql bench sql
n <- case r of
Left _ -> pure (-1)
Right rows -> evaluate (length rows)
Right result -> evaluate (qrRowCount result)
t1 <- getMonotonicTime
pure (t1 - t0, either Left (const (Right n)) r)
-- | 跑一条 SQL 文本（整条链路）
runSql :: String -> IO (Either String [Row])
runSql sql = case parseStatement sql of
Left e -> pure (Left e)
Right stmt -> runIPCStorage (runStatementM stmt)
-- | 打印一行结果
report :: String -> Either String Int -> Double -> IO ()
report :: String -> Either Text Int -> Double -> IO ()
report label result dt = case result of
Left e -> printf "%-38s %10s !! %s\n" label "FAILED" e
Left e -> printf "%-38s %10s !! %s\n" label ("FAILED" :: String) (T.unpack e)
Right n -> printf "%-38s %8.1f ms %8d rows\n" label (dt * 1000) n
-- | 单独量一条可重复的 SQL（先预热）
benchSql :: String -> String -> IO (Either String Int)
benchSql label sql = do
_ <- runSql sql
(dt, r) <- timedRows (runSql sql)
benchSql :: Bench -> String -> String -> IO (Either Text Int)
benchSql bench label sql = do
_ <- runSql bench sql
(dt, r) <- timedQuery bench sql
report label r dt
pure r
-- | 只跑一次的语句（重跑会报错）
benchSqlOnce :: String -> String -> IO (Either String Int)
benchSqlOnce label sql = do
(dt, r) <- timedRows (runSql sql)
benchSqlOnce :: Bench -> String -> String -> IO (Either Text Int)
benchSqlOnce bench label sql = do
(dt, r) <- timedQuery bench sql
report label r dt
pure r
@@ -157,10 +104,10 @@ orderSql u j =
(j `mod` 50)
-- | 批量插入并报平均耗时
batchInsert :: String -> Int -> (Int -> String) -> IO (Either String ())
batchInsert label n mkSql = do
batchInsert :: Bench -> String -> Int -> (Int -> String) -> IO (Either Text ())
batchInsert bench label n mkSql = do
t0 <- getMonotonicTime
results <- mapM (runSql . mkSql) [1 .. n]
results <- mapM (runSql bench . mkSql) [1 .. n]
t1 <- getMonotonicTime
let total = t1 - t0
errs = [e | Left e <- results]
@@ -173,66 +120,66 @@ batchInsert label n mkSql = do
(total * 1000 / fromIntegral n)
pure (Right ())
(e : _) -> do
printf "%-38s %10s !! %s\n" label "FAILED" e
printf "%-38s %10s !! %s\n" label ("FAILED" :: String) (T.unpack e)
pure (Left e)
-- | 一次点查（原始 IPC，不经过引擎）
benchLookup :: String -> String -> Int -> Int -> IO ()
benchLookup table column key times = do
_ <- doLookupByColumn table column (VInt key)
-- | 纯 TCP 往返：只过协议层，不过引擎与存储
benchPing :: Bench -> Int -> IO ()
benchPing bench times = do
_ <- clientPing (bClient bench)
t0 <- getMonotonicTime
results <- mapM (const (doLookupByColumn table column (VInt key))) [1 .. times]
results <- mapM (const (clientPing (bClient bench))) [1 .. times]
t1 <- getMonotonicTime
let total = t1 - t0
hit = length [() | Right (IndexRows (_ : _)) <- results]
hits = length [() | Right _ <- results]
printf
"%-38s %8.1f ms %7.3f ms/op (hits %d/%d)\n"
"lookup_by_index (raw IPC, by id)"
"%-38s %8.1f ms %7.3f ms/op (pongs %d/%d)\n"
("tcp round trip (ping, no engine)" :: String)
(total * 1000)
(total * 1000 / fromIntegral times)
hit
hits
times
-- | 一次点查（走语句，等于把 id 索引那一支也量进去）
benchLookup :: Bench -> Int -> Int -> IO ()
benchLookup bench key times = do
let sql = printf "SELECT name FROM users WHERE id = %d" key
_ <- runSql bench sql
t0 <- getMonotonicTime
results <- mapM (const (runSql bench sql)) [1 .. times]
t1 <- getMonotonicTime
let total = t1 - t0
hits = length [() | Right result <- results, qrRowCount result > 0]
printf
"%-38s %8.1f ms %7.3f ms/op (hits %d/%d)\n"
("point lookup by id (statement, over TCP)" :: String)
(total * 1000)
(total * 1000 / fromIntegral times)
hits
times
-- | 量 list_catalog（只取结构，不取行）
benchListCatalog :: Int -> IO ()
benchListCatalog n = do
benchCatalog :: Bench -> Int -> IO ()
benchCatalog bench n = do
_ <- catalog (bSession bench)
t0 <- getMonotonicTime
_ <- mapM (const doListCatalog) [1 .. n]
results <- mapM (const (catalog (bSession bench))) [1 .. n]
t1 <- getMonotonicTime
let total = t1 - t0
hits = length [() | Right _ <- results]
printf
"%-38s %8.1f ms %7.3f ms/op\n"
"list_catalog (schema only)"
"%-38s %8.1f ms %7.3f ms/op (%d/%d ok)\n"
("list_catalog (schema only, over TCP)" :: String)
(total * 1000)
(total * 1000 / fromIntegral n)
-- | 量原始 IPC 插入（不经过引擎）
benchRawInsert :: String -> [Row] -> IO ()
benchRawInsert table rows = do
t0 <- getMonotonicTime
results <- mapM (\r -> doInsert table r) rows
t1 <- getMonotonicTime
let total = t1 - t0
n = length rows
errs = [e | Left e <- results]
case errs of
[] ->
printf
"%-38s %8.1f ms %7.3f ms/row\n"
("raw IPC insert x " ++ show n)
(total * 1000)
(total * 1000 / fromIntegral n)
(e : _) -> printf "%-38s %10s !! %s\n" "raw IPC insert" "FAILED" e
-- | 造一行 users 数据（给原始 IPC 用）
userRow :: Int -> Row
userRow i = [("id", VInt i), ("name", VStr ("user" ++ show i)), ("age", VInt (i `mod` 100))]
hits
n
-- | 依次跑一批语句，返回 (耗时秒, 错误清单)
runBatch :: [String] -> IO (Double, [String])
runBatch sqls = do
runBatch :: Bench -> [String] -> IO (Double, [Text])
runBatch bench sqls = do
t0 <- getMonotonicTime
results <- mapM runSql sqls
results <- mapM (runSql bench) sqls
t1 <- getMonotonicTime
pure (t1 - t0, [e | Left e <- results])
@@ -240,6 +187,7 @@ runBatch sqls = do
chunked :: Int -> Int -> [[Int]]
chunked size n = go [1 .. n]
where
-- | 递归切分
go [] = []
go xs = let (a, b) = splitAt size xs in a : go b
@@ -264,11 +212,11 @@ printStats i =
)
-- | 主场景
runScenarios :: Int -> Int -> IO ()
runScenarios u o = do
runScenarios :: Bench -> Int -> Int -> IO ()
runScenarios bench u o = do
putStrLn "\n[create tables]"
r1 <- benchSqlOnce "CREATE TABLE users" "CREATE TABLE users (id int, name str, age int)"
r2 <- benchSqlOnce "CREATE TABLE orders" "CREATE TABLE orders (id int, user_id int, product str)"
r1 <- benchSqlOnce bench "CREATE TABLE users" "CREATE TABLE users (id int, name str, age int)"
r2 <- benchSqlOnce bench "CREATE TABLE orders" "CREATE TABLE orders (id int, user_id int, product str)"
case (r1, r2) of
(Right _, Right _) -> pure ()
_ -> do
@@ -276,91 +224,246 @@ runScenarios u o = do
exitFailure
putStrLn "\n[write: every INSERT is a full durable commit]"
_ <- batchInsert (printf "%d INSERT INTO users" u) u userSql
_ <- batchInsert (printf "%d INSERT INTO orders" o) o (orderSql u)
_ <- batchInsert bench (printf "%d INSERT INTO users" u) u userSql
_ <- batchInsert bench (printf "%d INSERT INTO orders" o) o (orderSql u)
putStrLn "\n[breakdown: same INSERT split in two, both via raw IPC, no engine]"
_ <- benchSqlOnce "CREATE TABLE raw_users" "CREATE TABLE raw_users (id int, name str, age int)"
benchListCatalog 200
benchRawInsert "raw_users" [userRow i | i <- [1 .. u]]
putStrLn "\n[breakdown: protocol round trip vs one catalog call, both over TCP]"
benchPing bench 200
benchCatalog bench 200
putStrLn "\n[read/query: full statement, including parsing and semantic checks]"
_ <- benchSql "SELECT * FROM users" "SELECT * FROM users"
ageR <- benchSql "SELECT name FROM users WHERE age > 90" "SELECT name FROM users WHERE age > 90"
_ <- benchSql bench "SELECT * FROM users" "SELECT * FROM users"
ageR <- benchSql bench "SELECT name FROM users WHERE age > 90" "SELECT name FROM users WHERE age > 90"
putStrLn "\n[read/query: join]"
joinR <-
benchSql
bench
"JOIN + WHERE (hash join)"
"SELECT u.name FROM users u JOIN orders o ON u.id = o.user_id WHERE u.age > 90"
putStrLn "\n[point lookup]"
benchLookup "users" "id" (u `div` 2) 100
_ <- benchSql "SELECT ... WHERE id = k (via Lookup)" (printf "SELECT name FROM users WHERE id = %d" (u `div` 2))
benchLookup bench (u `div` 2) 100
putStrLn "\n[batch insert: one statement with N rows, one durable commit]"
_ <- benchSqlOnce "CREATE TABLE batch_t" "CREATE TABLE batch_t (id int, name str, age int)"
_ <- benchSqlOnce bench "CREATE TABLE batch_t" "CREATE TABLE batch_t (id int, name str, age int)"
let groups = chunked 100 u
(bt, batchErrs) <- runBatch (map multiInsertSql groups)
perStmt = maximum (0 : map length groups)
(bt, batchErrs) <- runBatch bench (map multiInsertSql groups)
case batchErrs of
[] ->
printf
"%-38s %8.1f ms %7.3f ms/row (%d rows/stmt x %d statements)\n"
"multi-row INSERT"
("multi-row INSERT" :: String)
(bt * 1000)
(bt * 1000 / fromIntegral u)
(100 :: Int)
(perStmt :: Int)
(length groups)
(e : _) -> printf "%-38s %10s !! %s\n" "multi-row INSERT" "FAILED" e
(e : _) -> printf "%-38s %10s !! %s\n" ("multi-row INSERT" :: String) ("FAILED" :: String) (T.unpack e)
putStrLn "\n[row delete: cost tracks the scan plus one commit, not the row count]"
_ <- benchSqlOnce "DELETE FROM users WHERE id = k (1 row)" (printf "DELETE FROM users WHERE id = %d" (u `div` 2))
_ <- benchSqlOnce "DELETE FROM users (all)" "DELETE FROM users"
_ <- benchSqlOnce bench "DELETE FROM users WHERE id = k (1 row)" (printf "DELETE FROM users WHERE id = %d" (u `div` 2))
_ <- benchSqlOnce bench "DELETE FROM users (all)" "DELETE FROM users"
putStrLn "\n[secondary index: falls back to scan, then uses the index once built]"
_ <- benchSqlOnce "CREATE TABLE items" "CREATE TABLE items (id int, code int)"
_ <- benchSqlOnce bench "CREATE TABLE items" "CREATE TABLE items (id int, code int)"
let itemGroups = chunked 100 o
itemSql ids =
"INSERT INTO items (id, code) VALUES "
++ intercalate ", " [printf "(%d, %d)" i (i * 7 + 1) | i <- ids]
(it, itemErrs) <- runBatch (map itemSql itemGroups)
(it, itemErrs) <- runBatch bench (map itemSql itemGroups)
case itemErrs of
[] -> pure ()
(e : _) -> printf " !! %s\n" e
(e : _) -> printf " !! %s\n" (T.unpack e)
printf " (loaded %d rows into items: %.1f ms)\n" o (it * 1000)
let targetCode = (o `div` 2) * 7 + 1
_ <-
benchSql
bench
"SELECT ... WHERE code = k (no index)"
(printf "SELECT id FROM items WHERE code = %d" targetCode)
_ <- benchSqlOnce "CREATE INDEX ON items (code)" "CREATE INDEX ON items (code)"
_ <- benchSqlOnce bench "CREATE INDEX ON items (code)" "CREATE INDEX ON items (code)"
_ <-
benchSql
bench
"SELECT ... WHERE code = k (via index)"
(printf "SELECT id FROM items WHERE code = %d" targetCode)
putStrLn "\n[catalog stats]"
cat <- doListCatalog
cat <- catalog (bSession bench)
case cat of
Left e -> printf " failed to read stats: %s\n" e
Left e -> printf " failed to read stats: %s\n" (T.unpack e)
Right infos -> mapM_ printStats infos
putStrLn "\n[checks]"
let expectAge = 9 * (u `div` 100) + max 0 (u `mod` 100 - 90)
printf
"age > 90 matched %s (expected %d rows from the data distribution)\n"
(either show show ageR)
(either T.unpack show ageR)
expectAge
when (u == o) $
printf
"JOIN matched %s (one order per user, should equal the line above = %d)\n"
(either show show joinR)
(either T.unpack show joinR)
expectAge
unless (u == o) $
putStrLn "(users and orders differ in size; no simple formula, printing only)"
printf "multi-row INSERT loaded %d rows (expected %d)\n" u u
loadedCheck <- runSql bench "SELECT id FROM batch_t"
printf
"multi-row INSERT loaded %s rows (expected %d)\n"
(either T.unpack (show . qrRowCount) loadedCheck)
u
printf "secondary index: code = %d should find id = %d\n" targetCode (o `div` 2)
-- | 基准用的库名
benchDatabase :: String
benchDatabase = "bench"
-- | 服务端没有默认库：先开一个库，再把之后的语句都落进它
prepareDatabase :: Session -> IO ()
prepareDatabase session = do
created <- runStatement session ("CREATE DATABASE " <> T.pack benchDatabase)
case created of
Left e -> die ("cannot create the benchmark database: " ++ T.unpack e)
Right _ -> do
used <- switchDatabase session (T.pack benchDatabase)
case used of
Left e -> die ("cannot select the benchmark database: " ++ T.unpack e)
Right () -> pure ()
where
-- | 报错退出
die message = do
putStrLn message
exitFailure
-- | 按平台补上 .exe 后缀
binaryName :: String -> String
binaryName stem = if os == "mingw32" then stem ++ ".exe" else stem
-- | 在 PATH 里找 server 可执行文件
locateServerExe :: IO FilePath
locateServerExe = do
found <- findExecutable (binaryName "chusql-server")
case found of
Just path -> pure path
Nothing -> do
putStrLn "chusql-server was not found on PATH: run `stack build` first"
exitFailure
-- | 从 server 输出里读出监听端口
readListeningPort :: Handle -> IO Int
readListeningPort handle = do
line <- hGetLine handle
case portFromBanner line of
Just port -> pure port
Nothing -> readListeningPort handle
-- | 取一行里最后一串数字
portFromBanner :: String -> Maybe Int
portFromBanner line
| not ("listening:" `isInfixOf` line) = Nothing
| otherwise = case span isDigit (dropWhile (not . isDigit) (reverse line)) of
([], _) -> Nothing
(digits, _) -> Just (read (reverse digits))
-- | 判断子串是否出现
isInfixOf :: String -> String -> Bool
isInfixOf needle haystack = any (prefix needle) (tails haystack)
where
-- | 前缀匹配
prefix [] _ = True
prefix _ [] = False
prefix (x : xs) (y : ys) = x == y && prefix xs ys
-- | 所有后缀
tails [] = [[]]
tails s@(_ : rest) = s : tails rest
-- | 判断是不是数字字符
isDigit :: Char -> Bool
isDigit ch = ch >= '0' && ch <= '9'
-- | 把 server 的 stdout 抽干，免得管道塞满
drainHandle :: Handle -> IO ()
drainHandle handle = do
result <- try (hGetLine handle) :: IO (Either IOException String)
case result of
Left _ -> pure ()
Right _ -> drainHandle handle
-- | 起 server、连上去、登录、开库
startBench :: IO Bench
startBench = do
bin <- locateServerExe
tmp <- getTemporaryDirectory
stamp <- getMonotonicTime
let name = "chusql-fullchain-" ++ show (round (stamp * 1e6) :: Int)
dataDir = tmp </> name
configPath = tmp </> (name ++ ".toml")
-- TOML 的普通字符串会吃反斜杠，路径统一用正斜杠
slashed = map (\c -> if c == '\\' then '/' else c) dataDir
createDirectoryIfMissing True dataDir
writeFile configPath (benchConfigText slashed)
printf "config : %s\n" configPath
printf "data dir : %s\n" dataDir
(_, Just out, _, process) <-
createProcess (proc bin ["--config", configPath]){std_out = CreatePipe, std_err = NoStream}
port <- readListeningPort out
_ <- forkIO (drainHandle out)
printf "server : pid launched, tcp port %d\n" port
linked <- connectClient "127.0.0.1" port
case linked of
Left err -> do
putStrLn ("cannot connect to the server: " ++ T.unpack err)
stopProcess process
exitFailure
Right client -> do
session <- newSession client
auth <- authenticateSession session (T.pack "admin") (T.pack "s3cret")
case auth of
Left err -> do
putStrLn ("cannot sign in: " ++ T.unpack err)
closeClient client
stopProcess process
exitFailure
Right () -> do
prepareDatabase session
pure (Bench process dataDir client session)
-- | 基准用的配置：管理员凭据、随机端口、临时数据目录
benchConfigText :: String -> String
benchConfigText dataDir =
unlines
[ "[web]"
, "user = \"admin\""
, "password = \"s3cret\""
, ""
, "[server]"
, "host = \"127.0.0.1\""
, "port = 0"
, ""
, "[storage]"
, "data_dir = \"" ++ dataDir ++ "\""
, ""
, "[log]"
, "level = \"error\""
]
-- | 收摊：关会话、停 server、清数据目录
stopBench :: Bench -> IO ()
stopBench bench = do
putStrLn "\n[teardown] closing the TCP session, stopping the server, removing the data dir"
closeClient (bClient bench)
stopProcess (bProcess bench)
_ <- try (removeDirectoryRecursive (bDataDir bench)) :: IO (Either IOException ())
pure ()
-- | 杀掉 server 进程
stopProcess :: ProcessHandle -> IO ()
stopProcess process = do
terminateProcess process
_ <- try (waitForProcess process) :: IO (Either IOException ExitCode)
pure ()
-- | 主入口
main :: IO ()
main = do
@@ -368,48 +471,18 @@ main = do
let pick i d = if length args > i then args !! i else d
u = read (pick 0 "200") :: Int
o = read (pick 1 "200") :: Int
serverArg = pick 2 ""
serverPath <- findServer serverArg
tmp <- getTemporaryDirectory
stamp <- getMonotonicTime
let pipe = "chusql-fullchain-" ++ show (round (stamp * 1e6) :: Int)
dataDir = tmp </> pipe
configPath = tmp </> (pipe ++ ".toml")
-- TOML 的普通字符串会吃反斜杠，路径统一用正斜杠
slashed = map (\c -> if c == '\\' then '/' else c) dataDir
createDirectoryIfMissing True dataDir
writeFile
configPath
( unlines
[ "[storage]"
, "data_dir = \"" ++ slashed ++ "\""
, "[server]"
, "pipe_name = \"" ++ pipe ++ "\""
, "[log]"
, "level = \"error\""
]
)
setPipeName pipe
printf "full-chain benchmark: Haskell engine <--named pipe--> Rust storage\n"
printf "storage : %s\n" serverPath
printf "config : %s\n" configPath
printf "pipe : %s\n" pipe
printf "data dir : %s\n" dataDir
printf "full-chain benchmark: TCP client --> chusql-server --> in-process Rust storage\n"
printf "dataset : users = %d rows, orders = %d rows\n" u o
printf "timing : wall clock (monotonic); every statement runs the full chain\n"
printf "timing : wall clock (monotonic); every statement runs the full chain over TCP\n"
printf "note : the client no longer links the engine or the storage library\n"
bracket
(do
t1 <- getMonotonicTime
ph <- startServer serverPath configPath
bench <- startBench
t2 <- getMonotonicTime
printf "\n[startup] storage ready in %.2f s\n" (t2 - t1)
pure ph
printf "\n[startup] server up, storage ready, signed in: %.2f s\n" (t2 - t1)
threadDelay 25000
pure bench
)
(\ph -> do
putStrLn "\n[teardown] stopping storage and removing the data dir"
stopServer ph dataDir
)
(const (runScenarios u o))
stopBench
(\bench -> runScenarios bench u o)
benchmark/stack.yaml
+7 -1
View File
@@ -1,5 +1,11 @@
resolver: lts-24.59
extra-lib-dirs:
- ../chusql-core/storage/target/release
packages:
- .
- ../chusql-engine
- ../chusql-core/engine
- ../chusql-core/model
- ../chusql-interface
- ../chusql-server
chusql-cli/app/Main.hs
+27 -71
View File
@@ -11,19 +11,11 @@ import ChuSQL.CLI.Session (
newSession,
switchDatabase,
)
import ChuSQL.Web.Auth (Credential (..))
import ChuSQL.Web.Backend (ipcBackend)
import ChuSQL.Web.Config (WebConfig (..), defaultPassword, loadWebConfigAt, resolveCredential, resolvePipeName)
import ChuSQL.Web.Settings (readSettingsFile)
import ChuSQL.Web.TOML (resolveConfigPath)
import ChuSQL.Web.StorageProcess (
StorageProcess,
findStorageServer,
startStorageProcessAt,
stopStorageProcess,
waitForStorage,
)
import ChuSQL.Storage.IPC (setPipeName)
import ChuSQL.Interface.Auth (Credential (..))
import ChuSQL.Interface.Config (ServerConfig (..), loadServerConfigAt, loadWebConfigAt, resolveCredential, resolvePlainPassword)
import ChuSQL.Interface.Link (Client, closeClient, connectClient)
import ChuSQL.Interface.Settings (readSettingsFile)
import ChuSQL.Interface.TOML (resolveConfigPath)
import Control.Exception (finally)
import Control.Monad (unless)
import Data.IORef (newIORef)
@@ -39,7 +31,7 @@ import System.Exit (exitFailure)
import System.FilePath ((</>))
import System.IO (hSetEncoding, stderr, stdout, utf8)
-- chusql-cli：与 Web 管理端并列的前端，直连存储与引擎，账号与 Web 共用。
-- chusql-cli：与 Web 管理端并列的前端，接到拥有存储的 server 上跑 SQL，账号与 Web 共用。
data Options = Options
{ optUser :: Maybe Text
@@ -48,11 +40,10 @@ data Options = Options
, optFormat :: OutputFormat
, optExecute :: Maybe Text
, optHistory :: Maybe FilePath
, optPipe :: Maybe String
, optStorage :: Maybe FilePath
, optConfig :: Maybe FilePath
}
-- | 命令行参数解析器
optionsParser :: Parser Options
optionsParser =
Options
@@ -78,13 +69,13 @@ optionsParser =
)
<*> 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 "pipe" <> metavar "NAME" <> help "Endpoint name of the storage process (Windows named pipe, Unix socket file; default: [server] pipe_name in chusql.toml)"))
<*> optional (strOption (long "storage" <> metavar "SERVER" <> help "Rust storage executable to spawn when nothing answers the endpoint"))
<*> optional (strOption (long "config" <> metavar "FILE" <> help "Config file to read (default: the fixed chusql.toml under the system config directory)"))
-- | 把 --format 的取值解析成格式
formatReader :: String -> Either String OutputFormat
formatReader raw = maybe (Left "format must be table, json or csv") Right (parseFormat (T.pack raw))
-- | 命令行界面与帮助
parserInfo :: ParserInfo Options
parserInfo =
info
@@ -94,6 +85,7 @@ parserInfo =
<> header "csql - the ChuSQL command line client"
)
-- | 解析参数、登录 server 后进入会话
main :: IO ()
main = do
hSetEncoding stdout utf8
@@ -101,31 +93,29 @@ main = do
options <- execParser parserInfo
configPath <- resolveConfigPath (optConfig options)
base <- loadWebConfigAt configPath
let settingsFile = configPath
saved <- readSettingsFile settingsFile
saved <- readSettingsFile configPath
credential <- resolveCredential base saved
config <- loadServerConfigAt configPath
let rootName = credUser credential
userName = fromMaybe rootName (optUser options)
pipeName = resolvePipe options base
setPipeName pipeName
password <- resolvePassword (optPromptPassword options) userName rootName saved
storage <- acquireStorage options pipeName settingsFile
case storage of
connected <- connectClient (T.pack (scHost config)) (scPort config)
case connected of
Left message -> reportError message >> exitFailure
Right spawned ->
connect options credential settingsFile userName password
`finally` maybe (pure ()) stopStorageProcess spawned
Right client ->
connect options client userName password
`finally` closeClient client
-- | 接上存储，登录，然后进交互或跑单条语句
connect :: Options -> Credential -> FilePath -> Text -> Text -> IO ()
connect options credential settingsFile userName password = do
backend <- ipcBackend
session <- newSession backend credential settingsFile
-- | 连 server、登录，之后转入会话
connect :: Options -> Client -> Text -> Text -> IO ()
connect options client userName password = do
session <- newSession client
signedIn <- authenticateSession session userName password
case signedIn of
Left message -> reportError message >> exitFailure
Right () -> runSession options session
-- | 执行 -e 的单条语句，否则进交互循环
runSession :: Options -> Session -> IO ()
runSession options session = do
formatRef <- newIORef (optFormat options)
@@ -140,7 +130,7 @@ runSession options session = do
historyFile <- resolveHistory (optHistory options)
runRepl session formatRef historyFile
-- | 只有 -d 明确给了一个库才切；没给就保持"未选库"（服务没有默认库）
-- | -d 指定了库才切，否则保持未选库
selectDatabase :: Session -> Text -> IO Bool
selectDatabase _ wanted | T.null wanted = pure True
selectDatabase session wanted
@@ -151,54 +141,20 @@ selectDatabase session wanted
Left message -> reportError message >> pure False
Right () -> pure True
-- | 口令：-p 强制交互输入；否则配置里的 root 明文（同 Web）> 交互输入
-- | 决定口令是交互输入还是取自配置
resolvePassword :: Bool -> Text -> Text -> Map.Map Text Text -> IO Text
resolvePassword forcePrompt userName rootName saved
| forcePrompt = promptPassword userName
| T.toLower userName == T.toLower rootName = pure (configuredPassword saved)
| T.toLower userName == T.toLower rootName = pure (resolvePlainPassword saved)
| otherwise = promptPassword userName
where
configuredPassword values = case nonEmpty (Map.lookup "password" values) of
Just plain -> plain
Nothing -> defaultPassword
-- | 交互式读取口令
promptPassword :: Text -> IO Text
promptPassword user = do
entered <- runInputT defaultSettings (getPassword (Just '*') (T.unpack user <> "'s password: "))
pure (maybe "" T.pack entered)
-- | 先找已经在跑的存储；--storage 给了可执行文件才自己拉一个
acquireStorage :: Options -> String -> FilePath -> IO (Either Text (Maybe StorageProcess))
acquireStorage options pipeName configPath = do
up <- waitForStorage 4
case optStorage options of
Nothing
| up -> pure (Right Nothing)
| otherwise ->
pure
( Left
( "no storage process answered on pipe "
<> T.pack pipeName
<> "; start the server first, or pass --storage <path>"
)
)
Just given
| up -> pure (Right Nothing)
| otherwise -> do
found <- findStorageServer (Just given)
case found of
Left err -> pure (Left (T.pack err))
Right binary -> fmap (either (Left . T.pack) (Right . Just)) (startStorageProcessAt binary pipeName configPath)
-- | 管名：--pipe > chusql.toml 的 [server] pipe_name（缺省 chusql-joint）
resolvePipe :: Options -> WebConfig -> String
resolvePipe options base = fromMaybe (resolvePipeName base) (optPipe options)
nonEmpty :: Maybe Text -> Maybe Text
nonEmpty given = case T.strip <$> given of
Just text | not (T.null text) -> Just text
_ -> Nothing
-- | 取历史文件路径，没给就用默认
resolveHistory :: Maybe FilePath -> IO (Maybe FilePath)
resolveHistory (Just path) = pure (Just path)
resolveHistory Nothing = do
chusql-cli/app/Repl.hs
+19 -22
View File
@@ -8,9 +8,9 @@ module Repl
import ChuSQL.CLI.Format (OutputFormat, formatName, renderResult, renderRows)
import ChuSQL.CLI.Script (Meta (..), errorHint, metaHelp, parseMeta, takeStatement)
import ChuSQL.CLI.Session (Session, accountTable, catalog, databases, roleViews, runStatement, sessionDatabase, switchDatabase)
import ChuSQL.Storage.IPC (SchemaColumn (..), TableInfo (..))
import ChuSQL.Web.Privileges (Grant (..), RoleView (..))
import ChuSQL.CLI.Session (Session, catalog, databases, roleViews, runStatement, sessionDatabase, switchDatabase)
import ChuSQL.Core.Protocol (SchemaColumn (..), TableInfo (..))
import ChuSQL.Interface.Protocol (Grant (..), RoleView (..))
import Control.Monad (forM_, when)
import Control.Monad.IO.Class (liftIO)
import Data.IORef (IORef, readIORef, writeIORef)
@@ -22,7 +22,7 @@ import System.IO (hIsTerminalDevice, stderr, stdin)
-- 交互层：提示符、多行输入、历史、元命令与错误提示。
-- | 交互循环；historyPath 为 Nothing 就不落盘历史
-- | 交互循环，没有历史文件就不落盘
runRepl :: Session -> IORef OutputFormat -> Maybe FilePath -> IO ()
runRepl session formatRef historyPath =
runInputT (defaultSettings{historyFile = historyPath}) (loop session formatRef T.empty)
@@ -41,6 +41,7 @@ runStatementOnce session format sql = do
Left message -> reportError message >> pure False
Right answer -> TIO.putStrLn (renderResult format answer) >> pure True
-- | 读一行输入，分派到元命令或语句缓冲
loop :: Session -> IORef OutputFormat -> Text -> InputT IO ()
loop session formatRef buffer = do
prompt <- liftIO (promptFor session buffer)
@@ -62,7 +63,7 @@ loop session formatRef buffer = do
remaining <- drain session formatRef extended
loop session formatRef remaining
-- | 提示符带上当前库；续行换个样子，方便看出语句还没写完；管道输入时不出提示符
-- | 生成提示符；续行与非终端输入另有样式
promptFor :: Session -> Text -> IO Text
promptFor session buffer = do
interactive <- hIsTerminalDevice stdin
@@ -83,6 +84,7 @@ drain session formatRef buffer = case takeStatement buffer of
when (not (T.null statement)) (runOne session formatRef statement)
drain session formatRef rest
-- | 执行一条语句并打印结果
runOne :: Session -> IORef OutputFormat -> Text -> InputT IO ()
runOne session formatRef statement = do
result <- liftIO (runStatement session statement)
@@ -92,6 +94,7 @@ runOne session formatRef statement = do
format <- liftIO (readIORef formatRef)
outputStrLn (T.unpack (renderResult format answer))
-- | 执行元命令，返回是否继续循环
runMeta :: Session -> IORef OutputFormat -> Meta -> InputT IO Bool
runMeta session formatRef meta = case meta of
MetaQuit -> pure False
@@ -120,17 +123,16 @@ listDatabases session = do
Left message -> liftIO (reportError message)
Right names -> outputStrLn (T.unpack (renderRows ["database"] (map (: []) names)))
-- | \dt：表清单（base 里补上账号表）
-- | \dt：表清单（含 server 补的账号表）
listTables :: Session -> InputT IO ()
listTables session = do
answer <- liftIO (catalog session)
case answer of
Left message -> liftIO (reportError message)
Right tables -> do
allTables <- liftIO (withAccountTable session tables)
outputStrLn (T.unpack (renderRows headers (map tableRow allTables)))
Right tables -> outputStrLn (T.unpack (renderRows headers (map tableRow tables)))
where
headers = ["table", "columns", "rows", "indexes"]
-- | 把表信息排成一行
tableRow info =
[ T.pack (tiTable info)
, tshow (length (tiColumns info))
@@ -144,14 +146,15 @@ describeTable session name = do
answer <- liftIO (catalog session)
case answer of
Left message -> liftIO (reportError message)
Right tables -> do
allTables <- liftIO (withAccountTable session tables)
case filter (matches name) allTables of
Right tables ->
case filter (matches name) tables of
[] -> liftIO (reportError ("unknown table: " <> name))
(info : _) -> outputStrLn (T.unpack (renderRows headers (map columnRow (tiColumns info))))
where
headers = ["column", "type", "primary", "unique", "nullable", "auto"]
-- | 表名忽略大小写比较
matches wanted info = T.toLower (T.pack (tiTable info)) == T.toLower wanted
-- | 把列信息排成一行
columnRow column =
[ T.pack (scName column)
, T.pack (scType column)
@@ -160,6 +163,7 @@ describeTable session name = do
, yesNo (scNullable column)
, yesNo (scAutoIncrement column)
]
-- | 布尔值转成 yes/no
yesNo True = "yes"
yesNo False = "no"
@@ -171,22 +175,15 @@ listRoles session = do
Left message -> liftIO (reportError message)
Right roles -> outputStrLn (T.unpack (renderRows ["role", "grants", "members"] (map roleRow roles)))
where
-- | 把角色信息排成一行
roleRow view =
[ roleName view
, if null (roleGrants view) then "-" else T.intercalate ", " (map grantText (roleGrants view))
, if null (roleMembers view) then "-" else T.intercalate ", " (roleMembers view)
]
-- | 拼一条授权说明
grantText grant = grantPrivilege grant <> " on " <> grantObject grant
-- | 当前库是 system 时，把账号表也列出来（与 Web 端一致）
withAccountTable :: Session -> [TableInfo] -> IO [TableInfo]
withAccountTable session tables = do
current <- sessionDatabase session
if current /= "system"
then pure tables
else do
extra <- accountTable session
pure (maybe tables (: tables) extra)
-- | 用 show 转成 Text
tshow :: Show a => a -> Text
tshow = T.pack . show
chusql-cli/chusql-cli.cabal
+13 -12
View File
@@ -2,9 +2,9 @@ cabal-version: 2.4
name: chusql-cli
version: 1.0.0
synopsis: ChuSQL 命令行客户端：直连引擎与存储，与 Web 管理端共用账号
description: ChuSQL 的命令行前端。直接走命名管道接 Rust 存储进程与 Haskell 引擎，
不经过 Web REST；root 凭据与 __chusql_users 表与 Web 管理端完全共用。
synopsis: ChuSQL 命令行客户端：直连数据库服务，与 Web 管理端共用账号
description: ChuSQL 的命令行前端。自己不开存储、不链引擎，所有 SQL 与会话
都走 chusql-server 的 TCP 端点；账号表与权限服务与 Web 管理端完全共用。
build-type: Simple
library
@@ -15,11 +15,9 @@ library
build-depends: base >= 4.14 && < 5
, aeson
, bytestring
, chusql-engine
, chusql-web
, scientific
, chusql-core-model
, chusql-interface
, text
, time
default-language: Haskell2010
ghc-options: -Wall
@@ -28,10 +26,9 @@ executable csql
other-modules: Repl
hs-source-dirs: app
build-depends: base
, aeson
, chusql-cli
, chusql-engine
, chusql-web
, chusql-core-model
, chusql-interface
, containers
, directory
, filepath
@@ -40,6 +37,11 @@ executable csql
, text
default-language: Haskell2010
ghc-options: -Wall
-- 运行期找 libchusql_core_storage.so：$ORIGIN 让二进制与动态库同目录即可
if os(linux)
ld-options: -Wl,-rpath,$ORIGIN
if os(osx)
ld-options: -Wl,-rpath,@loader_path
test-suite chusql-cli-test
type: exitcode-stdio-1.0
@@ -49,8 +51,7 @@ test-suite chusql-cli-test
, aeson
, bytestring
, chusql-cli
, chusql-engine
, chusql-web
, chusql-core-model
, hspec
, text
default-language: Haskell2010
chusql-cli/src/ChuSQL/CLI/Format.hs
+11 -2
View File
@@ -12,8 +12,8 @@ module ChuSQL.CLI.Format
, displayValue
) where
import ChuSQL.CLI.Session (QueryResult (..), queryResultJson)
import ChuSQL.Model (Value (..))
import ChuSQL.Core.Model (Value (..))
import ChuSQL.Core.Protocol (QueryResult (..), queryResultJson)
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as BL
import Data.Text (Text)
@@ -25,6 +25,7 @@ import Data.Text.Encoding (decodeUtf8)
data OutputFormat = FormatTable | FormatJson | FormatCsv
deriving (Eq, Show)
-- | 格式的对外名字
formatName :: OutputFormat -> Text
formatName FormatTable = "table"
formatName FormatJson = "json"
@@ -38,6 +39,7 @@ parseFormat raw = case T.toLower (T.strip raw) of
"csv" -> Just FormatCsv
_ -> Nothing
-- | 按格式渲染查询结果
renderResult :: OutputFormat -> QueryResult -> Text
renderResult FormatTable = renderTable
renderResult FormatJson = renderJson
@@ -47,10 +49,12 @@ renderResult FormatCsv = renderCsv
renderJson :: QueryResult -> Text
renderJson = decodeUtf8 . BL.toStrict . A.encode . queryResultJson
-- | 渲染成 CSV
renderCsv :: QueryResult -> Text
renderCsv result = T.unlines (header : map rowLine (qrRows result))
where
header = T.intercalate "," (map csvField (qrColumns result))
-- | 拼一行 CSV
rowLine row = T.intercalate "," (map (csvField . csvCell) row)
-- | CSV 里的空值就是空字段
@@ -64,6 +68,7 @@ csvField field
| T.any (`elem` (",\"\n\r" :: String)) field = "\"" <> T.replace "\"" "\"\"" field <> "\""
| otherwise = field
-- | 渲染成等宽表格
renderTable :: QueryResult -> Text
renderTable result
| null (qrColumns result) = "OK"
@@ -74,10 +79,13 @@ renderRows :: [Text] -> [[Text]] -> Text
renderRows columns rawRows = T.unlines (border : headerLine : border : body ++ [border, summary])
where
widths = [columnWidth index | index <- [0 .. length columns - 1]]
-- | 一列的显示宽度，有上限
columnWidth index =
min maxColumnWidth (maximum (T.length (columns !! index) : [T.length (cellAt row index) | row <- rawRows]))
maxColumnWidth = 64
-- | 取某行某列，缺的当空
cellAt row index = if index < length row then row !! index else ""
-- | 拼一行带竖线的表行
cellLine cells = "| " <> T.intercalate " | " (zipWith pad widths (cells ++ repeat "")) <> " |"
headerLine = cellLine columns
body = map cellLine rawRows
@@ -93,6 +101,7 @@ pad width text = clipped <> T.replicate (width - T.length clipped) " "
| width <= 3 = T.take width text
| otherwise = T.take (width - 3) text <> "..."
-- | 把值转成可显示的文本
displayValue :: Value -> Text
displayValue VNull = "NULL"
displayValue (VInt n) = T.pack (show n)
chusql-cli/src/ChuSQL/CLI/Script.hs
+4 -1
View File
@@ -57,15 +57,18 @@ parseMeta raw = do
"format" -> selectFormat argument
other -> MetaUnknown other
where
-- | 拼出切库命令
connectTo argument
| T.null argument = MetaUnknown "c"
| otherwise = MetaConnect argument
-- | 解析格式参数
selectFormat argument = maybe (MetaUnknown "format") MetaSetFormat (parseFormat argument)
-- | 取出第一条以分号结束的语句与后面的残余；字符串与注释里的分号不算
-- | 取出第一条语句，忽略引号与注释里的分号
takeStatement :: Text -> Maybe (Text, Text)
takeStatement = go ScanNormal [] . T.unpack
where
-- | 逐字符扫描语句边界
go _ _ [] = Nothing
go ScanNormal acc (';' : rest) = Just (T.strip (T.pack (reverse acc)), T.pack rest)
go ScanNormal acc ('-' : '-' : rest) = go ScanLineComment ('-' : '-' : acc) rest
chusql-cli/src/ChuSQL/CLI/Session.hs
+3 -268
View File
@@ -1,270 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.CLI.Session (module ChuSQL.Interface.Session) where
module ChuSQL.CLI.Session
( QueryResult (..)
, Session
, newSession
, sessionUser
, sessionIsAdmin
, sessionDatabase
, isPlainIdentifier
, authenticateSession
, switchDatabase
, runStatement
, catalog
, accountTable
, roleViews
, databases
, queryResultJson
) where
import ChuSQL.Interface.Session
import ChuSQL.Model (Value (..))
import ChuSQL.Storage.IPC (TableInfo (..))
import ChuSQL.Syntax.AST (Statement (..))
import ChuSQL.Syntax.Parser (parseStatement)
import ChuSQL.Web.Accounts
import ChuSQL.Web.API (configurePasswordPolicy, systemTableInfo)
import ChuSQL.Web.Auth (Credential, defaultSessionPolicy, newSessionStore)
import ChuSQL.Web.Backend (Backend (..), StatementResult (..))
import ChuSQL.Web.Privileges (PrivilegeCommand, PrivilegeError (..), Privileges, RoleView, authorize, filterTables, listRoleViews, newPrivileges, privilegeCommand, runPrivilegeCommand)
import Data.Aeson (object, (.=))
import qualified Data.Aeson as A
import Data.Char (isAlpha, isAlphaNum)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Scientific (fromFloatDigits)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (getCurrentTime)
-- CLI 会话：直接连存储与引擎，但账号服务与 Web 管理端是同一套
-- （同一个 root 凭据，同一张 __chusql_users）。
data QueryResult = QueryResult
{ qrColumns :: [Text]
, qrRows :: [[Value]]
, qrRowCount :: Int
, qrTruncated :: Bool
, qrDatabase :: Maybe Text
}
deriving (Eq, Show)
data Session = Session
{ ssBackend :: Backend
, ssAccounts :: Accounts
, ssPrivileges :: Privileges
, ssCurrent :: IORef Text
, ssPrincipal :: IORef (Maybe Principal)
}
-- | 开一个会话：账号与角色服务、配置策略都和 Web 端一致
newSession :: Backend -> Credential -> FilePath -> IO Session
newSession backend credential settingsFile = do
sessions <- newSessionStore getCurrentTime defaultSessionPolicy
accounts <- newAccounts backend sessions credential
privileges <- newPrivileges backend
configurePasswordPolicy accounts settingsFile
-- 服务启动后只有系统库：没 USE 之前不预设任何工作库
current <- newIORef ""
principal <- newIORef Nothing
pure (Session backend accounts privileges current principal)
-- | 当前登录的账号名
sessionUser :: Session -> IO (Maybe Text)
sessionUser session = fmap principalName <$> readIORef (ssPrincipal session)
-- | 是不是配置里的 root
sessionIsAdmin :: Session -> IO Bool
sessionIsAdmin session = maybe False principalIsRoot <$> readIORef (ssPrincipal session)
-- | 当前库
sessionDatabase :: Session -> IO Text
sessionDatabase = readIORef . ssCurrent
-- | 与解析器一致的裸标识符判断
isPlainIdentifier :: Text -> Bool
isPlainIdentifier name =
not (T.null name)
&& T.length name <= 64
&& (isAlpha (T.head name) || T.head name == '_')
&& T.all (\ch -> isAlphaNum ch || ch == '_') name
-- | 登录：root 比配置里的凭据，普通账号查 __chusql_users
authenticateSession :: Session -> Text -> Text -> IO (Either Text ())
authenticateSession session user password = do
result <- authenticate (ssAccounts session) user password
case result of
Left err -> pure (Left (accountMessage err))
Right token -> do
who <- currentPrincipal (ssAccounts session) token
case who of
Left err -> pure (Left (accountMessage err))
Right principal -> do
writeIORef (ssPrincipal session) (Just principal)
pure (Right ())
-- | 换库；系统库只有 root 能进
switchDatabase :: Session -> Text -> IO (Either Text ())
switchDatabase session rawName
| not (isPlainIdentifier name) = pure (Left ("not a plain database name: " <> name))
| name == "system" = do
admin <- sessionIsAdmin session
if admin then go else pure (Left "the system database is only available to the administrator")
| otherwise = go
where
name = T.toLower (T.strip rawName)
go = do
backend <- currentBackend session
result <- beStatement backend ("USE " ++ T.unpack name)
case result of
Left err -> pure (Left (T.pack err))
Right _ -> writeIORef (ssCurrent session) name >> pure (Right ())
-- | 跑一条语句：USE、账号语句与角色语句在这里分流，其余交给引擎
-- （普通身份先过一遍权限判定，管理员与未登录直接放行）
runStatement :: Session -> Text -> IO (Either Text QueryResult)
runStatement session sql = case parseStatement (T.unpack sql) of
Right (UseDatabase name) -> do
switched <- switchDatabase session (T.pack name)
case switched of
Left err -> pure (Left err)
Right () -> do
current <- readIORef (ssCurrent session)
pure (Right (emptyResult (Just current)))
Right statement
| Just command <- accountCommand statement -> runAccount session command
| Just command <- privilegeCommand statement -> runPrivilege session command
| otherwise -> do
allowed <- authorized session statement
case allowed of
Left err -> pure (Left err)
Right () -> runPlain session sql
Left _ -> runPlain session sql
-- | 普通身份跑语句前的权限判定；管理员与未登录放行
authorized :: Session -> Statement -> IO (Either Text ())
authorized session statement = do
who <- readIORef (ssPrincipal session)
case who of
Just principal | not (principalIsRoot principal) -> do
database <- readIORef (ssCurrent session)
result <- authorize (ssPrivileges session) principal database statement
pure (either (Left . privilegeMessage) (const (Right ())) result)
_ -> pure (Right ())
-- | 落到引擎/存储层的一条语句
runPlain :: Session -> Text -> IO (Either Text QueryResult)
runPlain session sql = do
backend <- currentBackend session
result <- beStatement backend (T.unpack sql)
pure (either (Left . T.pack) (Right . resultOf) result)
-- | 数据字典（\dt 与 \d 用）；普通身份只看得到自己有 SELECT 的表
catalog :: Session -> IO (Either Text [TableInfo])
catalog session = do
current <- readIORef (ssCurrent session)
if T.null current
then pure (Left "no database selected")
else do
backend <- currentBackend session
result <- beCatalog backend
case result of
Left e -> pure (Left (T.pack e))
Right infos -> do
who <- readIORef (ssPrincipal session)
case who of
Just principal | not (principalIsRoot principal) -> do
allowed <- filterTables (ssPrivileges session) principal current (map (T.pack . tiTable) infos)
pure (either (Left . privilegeMessage) (\names -> Right (filter (\info -> T.pack (tiTable info) `elem` names) infos)) allowed)
_ -> pure (Right infos)
-- | 库清单（\l 用）
databases :: Session -> IO (Either Text [Text])
databases session = do
result <- beDatabases (ssBackend session)
pure (either (Left . T.pack) (Right . map T.pack) result)
-- | 系统库里的账号表：列定义与 Web 端共用一份，行数从同一套账号服务来
accountTable :: Session -> IO (Maybe TableInfo)
accountTable session = do
admin <- sessionIsAdmin session
if not admin
then pure Nothing
else do
result <- listAccounts (ssAccounts session)
pure (either (const Nothing) (\accounts -> Just systemTableInfo{tiRows = length accounts}) result)
-- | 角色总览（\dr 用）；与 Web 的 /api/roles 一样只给管理员
roleViews :: Session -> IO (Either Text [RoleView])
roleViews session = do
admin <- sessionIsAdmin session
if not admin
then pure (Left "administrator required")
else do
result <- listRoleViews (ssPrivileges session)
pure (either (Left . privilegeMessage) Right result)
-- | 当前库对应的后端
currentBackend :: Session -> IO Backend
currentBackend session = do
name <- readIORef (ssCurrent session)
pure (beWithDatabase (ssBackend session) (T.unpack name))
-- | 账号语句走账号服务，普通账号一律拒绝
runAccount :: Session -> AccountCommand -> IO (Either Text QueryResult)
runAccount session command = do
who <- readIORef (ssPrincipal session)
case who of
Nothing -> pure (Left "sign in first")
Just principal -> do
result <- runAccountCommand (ssAccounts session) principal command
pure (either (Left . accountMessage) (const (Right (emptyResult Nothing))) result)
-- | 角色语句走权限服务，普通账号一律拒绝；当前库决定授权对象的落库口径
runPrivilege :: Session -> PrivilegeCommand -> IO (Either Text QueryResult)
runPrivilege session command = do
who <- readIORef (ssPrincipal session)
case who of
Nothing -> pure (Left "sign in first")
Just principal -> do
database <- readIORef (ssCurrent session)
result <- runPrivilegeCommand (ssPrivileges session) principal database command
pure (either (Left . privilegeMessage) (const (Right (emptyResult Nothing))) result)
accountMessage :: AccountError -> Text
accountMessage (AccountError _ message) = message
privilegeMessage :: PrivilegeError -> Text
privilegeMessage (PrivilegeError _ message) = message
emptyResult :: Maybe Text -> QueryResult
emptyResult database = QueryResult [] [] 0 False database
resultOf :: StatementResult -> QueryResult
resultOf result =
QueryResult
{ qrColumns = map T.pack (srColumns result)
, qrRows = [map (cellOf row) (srColumns result) | row <- srRows result]
, qrRowCount = length (srRows result)
, qrTruncated = False
, qrDatabase = Nothing
}
where
cellOf row name = maybe VNull id (lookup name row)
-- | 结果还原成 JSON（JSON 输出用）
queryResultJson :: QueryResult -> A.Value
queryResultJson result =
object
[ "columns" .= qrColumns result
, "rows" .= map (map valueToJson) (qrRows result)
, "rowCount" .= qrRowCount result
, "truncated" .= qrTruncated result
, "database" .= qrDatabase result
]
valueToJson :: Value -> A.Value
valueToJson VNull = A.Null
valueToJson (VInt n) = A.Number (fromIntegral n)
valueToJson (VFloat d) = A.Number (fromFloatDigits d)
valueToJson (VStr s) = A.String (T.pack s)
valueToJson (VBool b) = A.Bool b
-- 命令行会话：转出前端共享的会话接口，一切请求走 server。
chusql-cli/stack.yaml
+7 -1
View File
@@ -1,6 +1,12 @@
resolver: lts-24.59
extra-lib-dirs:
- ../chusql-core/storage/target/release
packages:
- .
- ../chusql-engine
- ../chusql-core/engine
- ../chusql-server
- ../chusql-web
- ../chusql-core/model
- ../chusql-interface
chusql-cli/test/Spec.hs
+7 -150
View File
@@ -1,52 +1,31 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
module Main (main) where
import ChuSQL.CLI.Format (OutputFormat (..), parseFormat, renderCsv, renderJson, renderTable)
import ChuSQL.CLI.Script (Meta (..), errorHint, parseMeta, statementComplete, stripTerminator, takeStatement)
import ChuSQL.CLI.Session (
QueryResult (..),
Session,
authenticateSession,
catalog,
databases,
newSession,
queryResultJson,
roleViews,
runStatement,
sessionDatabase,
sessionIsAdmin,
switchDatabase,
)
import ChuSQL.Model (Database, Table (..), Value (..), pattern TInt, pattern TStr)
import ChuSQL.Storage.IPC (TableInfo (..))
import ChuSQL.Web.Auth (Credential (..), hashPasswordWith)
import ChuSQL.Web.Backend (memoryBackend)
import ChuSQL.Web.Privileges (Grant (..), RoleView (..))
import Control.Concurrent.MVar (newMVar)
import ChuSQL.Core.Model (Value (..))
import ChuSQL.Core.Protocol (QueryResult (..), queryResultJson)
import Data.Aeson (decode)
import qualified Data.Aeson as A
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.Either (isLeft, isRight)
import Data.List (nub, sort)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Test.Hspec
-- chusql-cli 测试：输出格式、交互层纯逻辑与共享账号会话。
-- chusql-cli 测试：只覆盖本前端的纯逻辑（输出格式、语句缓冲与元命令）。
-- | 测试入口
main :: IO ()
main = hspec spec
-- | 全部测试用例
spec :: Spec
spec = do
formatSpec
scriptSpec
sessionSpec
roleSpec
-- | 输出格式的用例
formatSpec :: Spec
formatSpec = describe "CLI: output formats" $ do
it "renders a boxed table and marks NULL" $
@@ -79,6 +58,7 @@ formatSpec = describe "CLI: output formats" $ do
parseFormat "csv" `shouldBe` Just FormatCsv
parseFormat "xml" `shouldBe` Nothing
-- | 语句缓冲与元命令的用例
scriptSpec :: Spec
scriptSpec = do
describe "CLI: statement buffering" $ do
@@ -117,114 +97,6 @@ scriptSpec = do
parseMeta "\\nope" `shouldBe` Just (MetaUnknown "nope")
parseMeta "\\f xml" `shouldBe` Just (MetaUnknown "format")
sessionSpec :: Spec
sessionSpec = describe "CLI: session over the shared account service" $ do
it "signs in as the configured administrator and refuses a wrong password" $ do
session <- cliSession
authenticateSession session "admin" "wrong-password" >>= \answer -> isLeft answer `shouldBe` True
authenticateSession session "admin" "s3cret" >>= \answer -> isRight answer `shouldBe` True
it "runs SQL straight through the engine" $ do
session <- cliSession
signInRoot session
result <- runStatement session "SELECT id, name FROM users ORDER BY id LIMIT 1"
fmap qrColumns result `shouldBe` Right ["id", "name"]
fmap qrRowCount result `shouldBe` Right 1
it "starts with nothing selected, lists what exists and refuses an unknown USE" $ do
session <- cliSession
authenticateSession session "admin" "s3cret" >>= (`shouldBe` Right ())
sessionDatabase session >>= (`shouldBe` "")
runStatement session "SELECT id FROM users" >>= \answer -> answer `shouldBe` Left "no database selected"
listed <- databases session
listed `shouldBe` Right ["test", "system"]
runStatement session "USE missing" >>= \answer -> isLeft answer `shouldBe` True
sessionDatabase session >>= (`shouldBe` "")
runStatement session "USE test" >>= \answer -> isRight answer `shouldBe` True
sessionDatabase session >>= (`shouldBe` "test")
it "keeps accounts on the same store and system administrator-only" $ do
session <- cliSession
signInRoot session
runStatement session "CREATE USER alice IDENTIFIED BY 'alice-password-1'" >>= \answer -> isRight answer `shouldBe` True
authenticateSession session "alice" "alice-password-1" >>= \answer -> isRight answer `shouldBe` True
sessionIsAdmin session >>= (`shouldBe` False)
switchDatabase session "system" >>= \answer -> isLeft answer `shouldBe` True
runStatement session "DROP USER admin" >>= \answer -> isLeft answer `shouldBe` True
roleSpec :: Spec
roleSpec = describe "CLI: roles and grants over the shared privilege service" $ do
it "runs role statements as the administrator and refuses them for anyone else" $ do
session <- cliSession
signInRoot session
created <- runStatement session "CREATE ROLE analyst"
isRight created `shouldBe` True
duplicate <- runStatement session "CREATE ROLE analyst"
duplicate `shouldBe` Left "role already exists: analyst"
granted <- runStatement session "GRANT SELECT ON users TO analyst"
isRight granted `shouldBe` True
tallied <- runStatement session "GRANT SELECT, INSERT, UPDATE, DELETE ON users TO analyst"
isRight tallied `shouldBe` True
views <- roleViews session
fmap (map roleName) views `shouldBe` Right ["analyst"]
fmap (sort . nub . concatMap (map grantPrivilege . roleGrants)) views `shouldBe` Right ["delete", "insert", "select", "update"]
fmap (sort . nub . concatMap (map grantObject . roleGrants)) views `shouldBe` Right ["test.users"]
unknown <- runStatement session "GRANT SELECT ON users TO nobody"
unknown `shouldBe` Left "unknown role: nobody"
dropped <- runStatement session "DROP ROLE analyst"
isRight dropped `shouldBe` True
missing <- runStatement session "GRANT SELECT ON users TO analyst"
missing `shouldBe` Left "unknown role: analyst"
it "an ordinary account only gets what a grant allows" $ do
session <- cliSession
signInRoot session
runStatement session "CREATE TABLE secrets (id INT)" >>= \answer -> isRight answer `shouldBe` True
runStatement session "CREATE ROLE reader" >>= \answer -> isRight answer `shouldBe` True
runStatement session "GRANT SELECT ON users TO reader" >>= \answer -> isRight answer `shouldBe` True
runStatement session "CREATE USER bob IDENTIFIED BY 'bob-password-1'" >>= \answer -> isRight answer `shouldBe` True
runStatement session "GRANT reader TO bob" >>= \answer -> isRight answer `shouldBe` True
authenticateSession session "bob" "bob-password-1" >>= \answer -> isRight answer `shouldBe` True
granted <- runStatement session "SELECT id, name FROM users"
fmap qrRowCount granted `shouldBe` Right 3
refused <- runStatement session "SELECT id FROM secrets"
refused `shouldBe` Left "permission denied: SELECT ON secrets"
write <- runStatement session "INSERT INTO users (id, name) VALUES (4, 'four')"
write `shouldBe` Left "permission denied: INSERT ON users"
admin <- runStatement session "CREATE ROLE other"
admin `shouldBe` Left "administrator required"
listed <- catalog session
fmap (map tiTable) listed `shouldBe` Right ["users"]
hidden <- roleViews session
hidden `shouldBe` Left "administrator required"
it "revoking the membership closes the door again" $ do
session <- cliSession
signInRoot session
runStatement session "CREATE ROLE guest" >>= \answer -> isRight answer `shouldBe` True
runStatement session "GRANT SELECT ON users TO guest" >>= \answer -> isRight answer `shouldBe` True
runStatement session "CREATE USER carol IDENTIFIED BY 'carol-password-1'" >>= \answer -> isRight answer `shouldBe` True
runStatement session "GRANT guest TO carol" >>= \answer -> isRight answer `shouldBe` True
roster <- roleViews session
fmap (concatMap roleMembers) roster `shouldBe` Right ["carol"]
authenticateSession session "carol" "carol-password-1" >>= \answer -> isRight answer `shouldBe` True
runStatement session "SELECT id FROM users" >>= \answer -> isRight answer `shouldBe` True
signInRoot session
runStatement session "REVOKE guest FROM carol" >>= \answer -> isRight answer `shouldBe` True
authenticateSession session "carol" "carol-password-1" >>= \answer -> isRight answer `shouldBe` True
refused <- runStatement session "SELECT id FROM users"
refused `shouldBe` Left "permission denied: SELECT ON users"
cliSession :: IO Session
cliSession = do
db <- newMVar testDb
newSession (memoryBackend testDatabaseName db) testCredential "chusql-test-missing.settings.json"
-- | 夹具库名：服务不再有默认库，这个库要显式选
testDatabaseName :: String
testDatabaseName = "test"
-- | 登录管理员并选中夹具库（未选库时连表名都解析不了）
signInRoot :: Session -> Expectation
signInRoot session = do
authenticateSession session "admin" "s3cret" >>= (`shouldBe` Right ())
switchDatabase session (T.pack testDatabaseName) >>= (`shouldBe` Right ())
sampleResult :: QueryResult
sampleResult =
QueryResult
@@ -234,18 +106,3 @@ sampleResult =
, qrTruncated = False
, qrDatabase = Nothing
}
-- | 测试库：三行 users
testDb :: Database
testDb =
[ ( "users"
, Table
"users"
[("id", TInt), ("name", TStr)]
[[("id", VInt i), ("name", VStr ("user" ++ show i))] | i <- [1 .. 3]]
)
]
-- | 测试账号：迭代次数压低（跑得快），口令 `s3cret`
testCredential :: Credential
testCredential = Credential "admin" (hashPasswordWith 1000 (BS.replicate 16 7) "s3cret")
chusql-engine/app/Main.hs → chusql-core/engine/app/Main.hs
+9 -9
View File
@@ -1,14 +1,14 @@
module Main where
import ChuSQL.Algebra.Op (renderPlan)
import ChuSQL.Algebra.Optimize (optimize)
import ChuSQL.Algebra.Planner (translate)
import ChuSQL.Engine
import ChuSQL.Model
import ChuSQL.Syntax.AST
import ChuSQL.Syntax.Parser
import ChuSQL.Core.Engine.Algebra.Op (renderPlan)
import ChuSQL.Core.Engine.Algebra.Optimize (optimize)
import ChuSQL.Core.Engine.Algebra.Planner (translate)
import ChuSQL.Core.Engine
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Engine.Syntax.Parser
-- 命令行演示：跑几条语句，打印结果与优化前后的计划。
-- 命令行演示入口：跑几条语句并打印结果与优化前后的计划。
users :: Table
users =
@@ -37,7 +37,7 @@ orders =
db :: Database
db = [("users", users), ("orders", orders)]
-- | 演示入口
-- | 跑演示语句，打印结果与优化前后的计划
main :: IO ()
main = do
putStrLn "==================== Engine ====================="
chusql-core/engine/chusql-core-engine.cabal
+70
View File
@@ -0,0 +1,70 @@
cabal-version: 2.4
name: chusql-core-engine
version: 1.0.0
synopsis: ChuSQL 执行引擎：SQL 词法与语法分析、表达式求值
description: ChuSQL 服务端执行引擎。负责 SQL 词法分析与 AST 构建、
WHERE 条件表达式求值、关系代数运算与内存表管理。
build-type: Simple
library
hs-source-dirs: src
exposed-modules: ChuSQL.Core.Engine.Algebra.Eval
ChuSQL.Core.Engine.Algebra.Expr
ChuSQL.Core.Engine.Algebra.Op
ChuSQL.Core.Engine.Algebra.Optimize
ChuSQL.Core.Engine.Algebra.Planner
ChuSQL.Core.Engine.Algebra.Sort
ChuSQL.Core.Engine
ChuSQL.Core.Engine.Semantic
ChuSQL.Core.Engine.Storage
ChuSQL.Core.Engine.Storage.FFI
ChuSQL.Core.Engine.Storage.IPC
ChuSQL.Core.Engine.Storage.Memory
ChuSQL.Core.Engine.Syntax.AST
ChuSQL.Core.Engine.Syntax.Parser
build-depends: base >= 4.14 && < 5
, aeson
, bytestring
, hashable
, chusql-core-model
, megaparsec
, parser-combinators
, scientific
, text
, unordered-containers
extra-libraries: chusql_core_storage
-- 运行期找 libchusql_core_storage.so：$ORIGIN 让二进制与动态库同目录即可
if os(linux)
ld-options: -Wl,-rpath,$ORIGIN
if os(osx)
ld-options: -Wl,-rpath,@loader_path
default-language: Haskell2010
ghc-options: -Wall
executable chusql-core-engine
main-is: Main.hs
hs-source-dirs: app
build-depends: base
, chusql-core-engine
, chusql-core-model
default-language: Haskell2010
ghc-options: -Wall
-- 运行期找 libchusql_core_storage.so：$ORIGIN 让二进制与动态库同目录即可
if os(linux)
ld-options: -Wl,-rpath,$ORIGIN
if os(osx)
ld-options: -Wl,-rpath,@loader_path
test-suite chusql-core-engine-test
type: exitcode-stdio-1.0
main-is: Spec.hs
hs-source-dirs: test
build-depends: base
, chusql-core-engine
, chusql-core-model
, directory
, filepath
, hspec
default-language: Haskell2010
ghc-options: -Wall
chusql-engine/src/ChuSQL/Engine.hs → chusql-core/engine/src/ChuSQL/Core/Engine.hs
+30 -13
View File
@@ -1,18 +1,18 @@
module ChuSQL.Engine (runStatement, runStatementM, rowsOf) where
module ChuSQL.Core.Engine (runStatement, runStatementM, rowsOf) where
import ChuSQL.Algebra.Eval (evalCondForRowM, evalExprM, evalRelOpM)
import ChuSQL.Algebra.Expr (evalCondForRow, evalExpr)
import ChuSQL.Algebra.Optimize (optimize)
import ChuSQL.Algebra.Planner (translate)
import ChuSQL.Model
import ChuSQL.Semantic (prepare)
import ChuSQL.Storage (MonadStorage (..))
import ChuSQL.Storage.Memory (MemoryStorage (runMemoryStorage))
import ChuSQL.Syntax.AST
import ChuSQL.Syntax.Parser (parseExpression)
import ChuSQL.Core.Engine.Algebra.Eval (evalCondForRowM, evalExprM, evalRelOpM)
import ChuSQL.Core.Engine.Algebra.Expr (evalCondForRow, evalExpr)
import ChuSQL.Core.Engine.Algebra.Optimize (optimize)
import ChuSQL.Core.Engine.Algebra.Planner (translate)
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Semantic (prepare)
import ChuSQL.Core.Engine.Storage (MonadStorage (..))
import ChuSQL.Core.Engine.Storage.Memory (MemoryStorage (runMemoryStorage))
import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Engine.Syntax.Parser (parseExpression)
import Data.Maybe (mapMaybe)
-- 引擎入口：语义检查 + 分发执行，以及内存实现与泛型版本。
-- 引擎入口：检查语义、按语句分发执行，另有内存实现与泛型版本。
-- | 跑一条语句（内存实现）
runStatement :: Database -> Statement -> Either String (Database, [Row])
@@ -74,6 +74,7 @@ runStatementUncheckedM db (Delete tbl mWhere) = do
result <- replaceAll tbl kept
pure (result >> Right [])
where
-- | 取行里的整数 id，取不到就报错
rowId :: Row -> Either String Int
rowId r = case lookup "id" r of
Just (VInt k) -> Right k
@@ -137,7 +138,9 @@ existingRows tbl table
| needsRows table = scan tbl
| otherwise = pure (Right [])
where
-- | 这一表有没有要判约束的列
needsRows t = any (constraintColumn . snd) (tableCols t)
-- | 这一列带不带要判的约束
constraintColumn c = columnAutoIncrement c || columnUnique c || columnPrimaryKey c
-- | 插一行：补齐缺列、给自增值、收类型、查约束
@@ -150,6 +153,7 @@ buildRows table current cols rows = do
let auto = autoColumn table
go auto (autoStart auto current) values []
where
-- | 逐行构造，最后统一查一遍约束
go _ _ [] acc = do
let built = reverse acc
mapM_ (runChecks table) built
@@ -165,11 +169,13 @@ buildRow :: Table -> Maybe (String, Column) -> [String] -> Int -> [Value] -> Eit
buildRow table auto cols counter vals = go (tableCols table) counter []
where
provided = zip cols vals
-- | 按列定义逐列补值
go [] c acc = Right (reverse acc, c)
go ((name, col) : rest) c acc = do
(v, c') <- pick name col c
v' <- coerceValue (columnType col) v
go rest c' ((name, v') : acc)
-- | 决定这一列取什么值
pick name col c
| Just (autoName, _) <- auto
, name == autoName
@@ -178,11 +184,13 @@ buildRow table auto cols counter vals = go (tableCols table) counter []
| Just d <- columnDefault col = Right (d, c)
| columnNullable col = Right (VNull, c)
| otherwise = Left ("INSERT: column " ++ name ++ " is NOT NULL and has no default")
-- | 自增值跟着已有的值往前推
bump name _ c v
| Just (autoName, _) <- auto
, name == autoName = max (c + 1) (valueInt v + 1)
| otherwise = c
-- | 取自增值，不是整数就当 0
valueInt :: Value -> Int
valueInt (VInt n) = n
valueInt _ = 0
@@ -204,6 +212,7 @@ autoStart (Just (name, _)) rows = case [n | r <- rows, Just (VInt n) <- [lookup
runChecks :: Table -> Row -> Either String ()
runChecks table row = mapM_ check (tableCols table)
where
-- | 查这一列的 CHECK
check (name, col) = case columnCheck col of
Nothing -> Right ()
Just text -> case parseExpression text of
@@ -213,6 +222,7 @@ runChecks table row = mapM_ check (tableCols table)
Right True -> Right ()
Right False -> Left ("CHECK on " ++ name ++ " failed")
-- | 只取第一行（报错提示用）
firstLine :: String -> String
firstLine = takeWhile (/= '\n')
@@ -220,6 +230,7 @@ firstLine = takeWhile (/= '\n')
enforceNotNull :: [(String, Column)] -> [Row] -> Either String ()
enforceNotNull cols rows = mapM_ check cols
where
-- | 查这一列的 NOT NULL
check (name, col)
| columnNullable col = Right ()
| any (\r -> lookup name r == Just VNull) rows = Left ("NOT NULL: column " ++ name ++ " cannot be null")
@@ -230,8 +241,11 @@ enforceUnique :: [(String, Column)] -> [Row] -> Either String ()
enforceUnique cols rows = mapM_ check targets
where
targets = [(n, c) | (n, c) <- cols, columnUnique c || columnPrimaryKey c]
-- | 查这一列有没有重复值
check (name, _) = go name [] (mapMaybe (lookup name) rows)
-- | 逐个值比过去
go _ _ [] = Right ()
-- | NULL 不算冲突，跳过
go name seen (VNull : rest) = go name seen rest
go name seen (v : rest)
| v `elem` seen = Left ("UNIQUE: duplicate value in column " ++ name)
@@ -271,6 +285,7 @@ setColumn col v = map (\(k, val) -> if k == col then (k, v) else (k, val))
splitByConditionM :: (MonadStorage m) => Database -> Maybe Expr -> [Row] -> m (Either String ([Row], [Row]))
splitByConditionM db cond = go [] []
where
-- | 逐行分流
go doomed kept [] = pure (Right (reverse doomed, reverse kept))
go doomed kept (r : rs) = do
hit <- case cond of
@@ -299,6 +314,7 @@ alterTable db tbl change = case lookupTable db tbl of
result <- replaceSchema tbl cols newRows
pure (result >> Right [])
where
-- | 改完再统一查一遍约束
checkAltered (cols, rows) = do
let table = Table tbl cols rows
mapM_ (runChecks table) rows
@@ -306,7 +322,7 @@ alterTable db tbl change = case lookupTable db tbl of
enforceUnique cols rows
Right (cols, rows)
-- | ADD COLUMN：老行补默认值或 NULL，自增列从 1 开始
-- | ADD COLUMN：老行补默认值或 NULL
addColumnTo :: (String, Column) -> [(String, Column)] -> [Row] -> Either String ([(String, Column)], [Row])
addColumnTo (name, col) cols rows
| name `elem` map fst cols = Left ("ADD COLUMN: column already exists: " ++ name)
@@ -338,6 +354,7 @@ retypeColumn col ty cols rows
rows' <- mapM convert rows
Right (map (\entry@(n, c) -> if n == col then (n, c{columnType = ty}) else entry) cols, rows')
where
-- | 把这一列的老值收进新类型
convert row = case lookup col row of
Nothing -> Right row
Just v -> do
chusql-engine/src/ChuSQL/Algebra/Eval.hs → chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Eval.hs
+34 -20
View File
@@ -1,21 +1,20 @@
module ChuSQL.Algebra.Eval (evalRelOp, evalRelOpM, evalExprM, evalCondForRowM) where
module ChuSQL.Core.Engine.Algebra.Eval (evalRelOp, evalRelOpM, evalExprM, evalCondForRowM) where
import ChuSQL.Algebra.Expr (evalCondForRow, evalExpr)
import ChuSQL.Algebra.Optimize (optimize, relOpCols)
import ChuSQL.Algebra.Op
import ChuSQL.Algebra.Planner (translate)
import ChuSQL.Algebra.Sort (compareValue, sortRows)
import ChuSQL.Model
import ChuSQL.Storage (IndexResult (..), MonadStorage (..))
import ChuSQL.Storage.Memory (runMemoryStorage)
import ChuSQL.Syntax.AST (Expr (..), JoinKind (..), Subquery (..))
import ChuSQL.Core.Engine.Algebra.Expr (evalCondForRow, evalExpr)
import ChuSQL.Core.Engine.Algebra.Optimize (optimize, relOpCols)
import ChuSQL.Core.Engine.Algebra.Op
import ChuSQL.Core.Engine.Algebra.Planner (translate)
import ChuSQL.Core.Engine.Algebra.Sort (compareValue, sortRows)
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Storage (IndexResult (..), MonadStorage (..))
import ChuSQL.Core.Engine.Storage.Memory (runMemoryStorage)
import ChuSQL.Core.Engine.Syntax.AST (Expr (..), JoinKind (..), Subquery (..))
import Control.Monad (filterM, foldM)
import qualified Data.HashMap.Strict as HM
-- 执行：按算子树算出结果行（Scan 阶段会加别名前缀）。
-- 外层行 outer 给相关子查询用：子查询里的列先在本层行里找，找不到再落到外层行。
-- 执行：按算子树算出结果行，外层行供相关子查询引用。
-- | 只保留清单里的列，顺序按清单（SELECT 的列序就是结果的列序）
-- | 只保留清单里的列，顺序照清单
project :: [String] -> Row -> Row
project ["*"] row = row
project cs row = [(c, v) | c <- cs, Just v <- [lookup c row]]
@@ -24,6 +23,7 @@ project cs row = [(c, v) | c <- cs, Just v <- [lookup c row]]
addPrefix :: Maybe String -> Row -> Row
addPrefix mAlias = map (\(k, v) -> (qualify mAlias k, v))
-- | 给一批行加别名前缀
prefixRows :: Maybe String -> [Row] -> [Row]
prefixRows mAlias = map (addPrefix mAlias)
@@ -48,6 +48,7 @@ rangeCondition mAlias col lo hi = case (lo, hi) of
(Nothing, Nothing) -> LitBool True
where
c = Col (qualify mAlias col)
-- | 一个端点的比较，闭端再加上等号
bound rel (v, inclusive)
| inclusive = Or (rel c (valueLiteral v)) (Eq c (valueLiteral v))
| otherwise = rel c (valueLiteral v)
@@ -57,8 +58,7 @@ rowsCols :: [Row] -> [String]
rowsCols (r : _) = map fst r
rowsCols [] = []
-- | 参与等值匹配的键：NULL 不参与匹配，整数值的浮点归一到整数
-- （嵌套循环走 compareValues，哈希要对齐它）
-- | 参与等值匹配的键：NULL 不参与，整数值的浮点归一
joinKey :: Value -> Maybe Value
joinKey VNull = Nothing
joinKey (VFloat d)
@@ -70,9 +70,11 @@ joinKey (VFloat d)
rounded = round d :: Integer
joinKey v = Just v
-- | 取一行的连接键
joinKeyOf :: String -> Row -> Maybe Value
joinKeyOf c row = lookup c row >>= joinKey
-- | 等值连接的两侧列名
data EquiKeys = EquiKeys
{ ekLeft :: String
, ekRight :: String
@@ -85,7 +87,7 @@ equiKeys lcols rcols (Eq (Col a) (Col b))
| a /= b, b `elem` lcols, a `elem` rcols = Just (EquiKeys b a)
equiKeys _ _ _ = Nothing
-- | 连接：能认出等值键就走哈希，否则退回嵌套循环；左连接没配上的左行补 NULL
-- | 连接两批行：等值键走哈希，否则嵌套循环
joinRowsIn ::
(MonadStorage m) =>
Database ->
@@ -104,7 +106,7 @@ joinRowsIn db outer kind rcols cond lrows rrows =
-- 右表为空时行上没有列名，用算子推导出来的列名补 NULL
ncols = if null rrows then rcols else rowsCols rrows
-- | 左连接里配不上的左行补右表 NULL；内连接里没有匹配就是没行
-- | 左连接配不上的左行补 NULL，内连接丢弃
unmatched :: JoinKind -> Row -> [String] -> [Row]
unmatched InnerJoin _ _ = []
unmatched LeftJoin l cols = [l ++ [(c, VNull) | c <- cols]]
@@ -114,6 +116,7 @@ hashJoin :: JoinKind -> EquiKeys -> [String] -> [Row] -> [Row] -> [Row]
hashJoin kind ks ncols lrows rrows = concatMap probe lrows
where
buckets = HM.fromListWith (flip (++)) [(v, [r]) | r <- rrows, Just v <- [joinKeyOf (ekRight ks) r]]
-- | 拿左行的键去桶里找
probe l =
let miss = case kind of
InnerJoin -> []
@@ -138,6 +141,7 @@ filterPairsM ::
m (Either String [Row])
filterPairsM db outer kind ncols cond lrows rrows = go lrows []
where
-- | 逐左行配对，左连接没配上就补 NULL
go [] acc = pure (Right (reverse acc))
go (l : ls) acc = do
hits <- keep l rrows []
@@ -148,6 +152,7 @@ filterPairsM db outer kind ncols cond lrows rrows = go lrows []
(LeftJoin, []) -> [l ++ nullRow]
_ -> hs
go ls (reverse hs' ++ acc)
-- | 拿一行右行去比条件
keep _ [] acc = pure (Right (reverse acc))
keep l (r : rs) acc = do
ok <- evalCondForRowM db cond (l ++ r ++ outer)
@@ -157,7 +162,7 @@ filterPairsM db outer kind ncols cond lrows rrows = go lrows []
Right False -> keep l rs acc
nullRow = [(c, VNull) | c <- ncols]
-- | 索引连接：右表是裸 Scan 时逐左行点查，返回 Nothing 表示该走通用路径
-- | 索引连接：右表是裸 Scan 时逐左行点查
probeIndexJoin ::
(MonadStorage m) =>
Database ->
@@ -183,8 +188,7 @@ probeIndexJoin db outer kind mAlias t ks rcols cond l = case lookup (ekLeft ks)
pairs <- joinRowsIn db outer kind rcols cond [l] (prefixRows mAlias rows)
pure (fmap Just pairs)
-- | 索引按值的相等匹配，而数值比较会把 2 和 2.0 看成相等，
-- 所以只有非浮点列 + 非浮点键才敢用索引，保证优化不改变结果语义
-- | 列与键都不是浮点时才敢用索引
indexSafe :: Database -> String -> String -> Value -> Bool
indexSafe db t col k = case lookupTable db t of
Left _ -> False
@@ -192,12 +196,14 @@ indexSafe db t col k = case lookupTable db t of
Nothing -> False
Just c -> not (floatType (columnType c)) && not (floatValue k)
-- | 是不是浮点列类型
floatType :: ColumnType -> Bool
floatType CFloat = True
floatType CDouble = True
floatType (CDecimal _ _) = True
floatType _ = False
-- | 是不是浮点值
floatValue :: Value -> Bool
floatValue (VFloat _) = True
floatValue _ = False
@@ -206,12 +212,14 @@ floatValue _ = False
groupKey :: [String] -> Row -> Either String [Value]
groupKey keys row = mapM get keys
where
-- | 取这一列的分组值
get c = maybe (Left ("unknown column: " ++ c)) Right (lookup c row)
-- | 按分组键把行分组，保留分组首次出现的顺序
groupRows :: [String] -> [Row] -> Either String [([Value], [Row])]
groupRows keys rows = go rows (HM.empty, [])
where
-- | 逐行塞进对应分组，并记住分组首次出现的顺序
go [] (acc, order) = Right [(k, reverse (HM.lookupDefault [] k acc)) | k <- reverse order]
go (r : rs) (acc, order) = do
k <- groupKey keys r
@@ -269,7 +277,9 @@ evalAgg outer agg rows = case agg of
MaxOf e -> valuesOf outer e rows >>= extremeOf higher . nonNull
_ -> Left "only COUNT, SUM, AVG, MIN and MAX can be aggregated"
where
-- | 取更小的那个
lower a b = if compareValue b a == LT then b else a
-- | 取更大的那个
higher a b = if compareValue b a == GT then b else a
-- | 一组的输出行：分组列 + 各聚合值
@@ -289,6 +299,7 @@ evalAggregate outer keys aggs rows = do
filterRowsM :: (Monad m) => (Row -> m (Either String Bool)) -> [Row] -> m (Either String [Row])
filterRowsM p = go []
where
-- | 逐行留下通过条件的
go acc [] = pure (Right (reverse acc))
go acc (r : rs) = do
keep <- p r
@@ -301,6 +312,7 @@ filterRowsM p = go []
computeM :: (MonadStorage m) => Database -> Row -> [(String, Expr)] -> Row -> m (Either String Row)
computeM db outer items row = go items []
where
-- | 逐项求值并攒成一行
go [] acc = pure (Right (reverse acc))
go ((label, e) : rest) acc = do
v <- evalExprM db e (row ++ outer)
@@ -375,6 +387,7 @@ substSubqueries db e env = case e of
MaxOf a -> un MaxOf a
_ -> pure (Right e)
where
-- | 递归处理两个子表达式
bin ctor a b = do
ra <- substSubqueries db a env
case ra of
@@ -382,6 +395,7 @@ substSubqueries db e env = case e of
Right a' -> do
rb <- substSubqueries db b env
pure ((ctor a') <$> rb)
-- | 递归处理一个子表达式
un ctor a = do
ra <- substSubqueries db a env
pure (ctor <$> ra)
chusql-engine/src/ChuSQL/Algebra/Expr.hs → chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Expr.hs
+16 -4
View File
@@ -1,7 +1,7 @@
module ChuSQL.Algebra.Expr (evalExpr, evalCondForRow, colsInExpr, aggregatesIn, hasAggregate, bareColumns, hasSubquery, inValues, threeValuedNot) where
module ChuSQL.Core.Engine.Algebra.Expr (evalExpr, evalCondForRow, colsInExpr, aggregatesIn, hasAggregate, bareColumns, hasSubquery, inValues, threeValuedNot) where
import ChuSQL.Model
import ChuSQL.Syntax.AST
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Syntax.AST
import Control.Monad (join)
-- 表达式求值：三值逻辑，NULL 参与运算结果仍是 NULL。
@@ -54,7 +54,7 @@ evalExpr agg _ = Left ("aggregate functions are not allowed here: " ++ show agg)
subqueryNeedsDatabase :: String
subqueryNeedsDatabase = "subquery needs a database to run"
-- | IN 的三值逻辑：命中为真，没命中但碰到 NULL 就给 NULL，否则为假
-- | IN 三值逻辑：命中为真，碰 NULL 得 NULL
inValues :: Value -> [Value] -> Either String Value
inValues VNull _ = Right VNull
inValues v vs = do
@@ -121,6 +121,7 @@ hasSubquery e = case e of
MaxOf a -> hasSubquery a
_ -> False
where
-- | 两个子表达式里任意一个有
both a b = hasSubquery a || hasSubquery b
-- | 表达式里出现的聚合调用（按出现顺序）
@@ -146,6 +147,7 @@ aggregatesIn e = case e of
IsNotNull a -> aggregatesIn a
_ -> []
where
-- | 两个子表达式的聚合拼起来
both a b = aggregatesIn a ++ aggregatesIn b
-- | 表达式里有没有聚合调用
@@ -174,6 +176,7 @@ bareColumns e = case e of
ExistsSub sq _ -> subqueryRefs sq
_ -> []
where
-- | 两个子表达式的裸列拼起来
both a b = bareColumns a ++ bareColumns b
-- | 判断条件真假：只有 TRUE 通过，NULL 当作不通过
@@ -204,6 +207,7 @@ data Arith = Arith
liftArith :: Arith -> Expr -> Expr -> Row -> Either String Value
liftArith ops a b row = liftBinOp go a b row
where
-- | NULL 出 NULL，整数配整数走整数算术
go VNull _ = Right VNull
go _ VNull = Right VNull
go (VInt x) (VInt y) = VInt <$> arithInt ops x y
@@ -217,12 +221,15 @@ asDouble (VInt n) = Just (fromIntegral n)
asDouble (VFloat d) = Just d
asDouble _ = Nothing
-- | 加法
addArith :: Arith
addArith = Arith (\x y -> Right (x + y)) (\x y -> Right (x + y))
-- | 减法
subArith :: Arith
subArith = Arith (\x y -> Right (x - y)) (\x y -> Right (x - y))
-- | 乘法
mulArith :: Arith
mulArith = Arith (\x y -> Right (x * y)) (\x y -> Right (x * y))
@@ -230,10 +237,12 @@ mulArith = Arith (\x y -> Right (x * y)) (\x y -> Right (x * y))
divArith :: Arith
divArith = Arith intDiv floatDiv
where
-- | 整数除法：除零与溢出都报错
intDiv _ 0 = Left "division by zero"
intDiv x y
| x == minBound && y == -1 = Left "integer division overflow"
| otherwise = Right (x `quot` y)
-- | 浮点除法：不能除以零
floatDiv _ 0 = Left "division by zero"
floatDiv x y = Right (x / y)
@@ -246,6 +255,7 @@ liftCompare ::
Either String Value
liftCompare rel a b row = liftBinOp (compareValues rel) a b row
-- | 比较两个值：NULL 给 NULL，其余按数、串、布尔比
compareValues :: (Ordering -> Bool) -> Value -> Value -> Either String Value
compareValues rel x y
| x == VNull || y == VNull = Right VNull
@@ -263,6 +273,7 @@ liftBool ::
Either String Value
liftBool f = liftBinOp f
-- | 逻辑与的三值真值表
andValues :: Value -> Value -> Either String Value
andValues (VBool False) _ = Right (VBool False)
andValues _ (VBool False) = Right (VBool False)
@@ -272,6 +283,7 @@ andValues (VBool True) VNull = Right VNull
andValues VNull VNull = Right VNull
andValues _ _ = Left "type error: expected two booleans"
-- | 逻辑或的三值真值表
orValues :: Value -> Value -> Either String Value
orValues (VBool True) _ = Right (VBool True)
orValues _ (VBool True) = Right (VBool True)
chusql-engine/src/ChuSQL/Algebra/Op.hs → chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Op.hs
+5 -4
View File
@@ -1,9 +1,9 @@
module ChuSQL.Algebra.Op (RelOp (..), renderPlan) where
module ChuSQL.Core.Engine.Algebra.Op (RelOp (..), renderPlan) where
import ChuSQL.Model (Value)
import ChuSQL.Syntax.AST (Expr, JoinKind (..), SortDir)
import ChuSQL.Core.Model (Value)
import ChuSQL.Core.Engine.Syntax.AST (Expr, JoinKind (..), SortDir)
-- 关系代数算子，以及把算子树渲染成文本。
-- 关系代数算子定义与算子树文本渲染。
data RelOp
= Scan (Maybe String) String (Maybe [String])
@@ -28,6 +28,7 @@ kindLabel LeftJoin = "LeftJoin"
renderPlan :: RelOp -> String
renderPlan = go 0
where
-- | 按缩进渲染一个算子
go ind op = case op of
Scan a t cols -> pad ++ "Scan " ++ show a ++ " " ++ show t ++ maybe "" ((" columns=" ++) . show) cols
Lookup _ t c k -> pad ++ "Lookup " ++ show t ++ "." ++ show c ++ " = " ++ show k
chusql-engine/src/ChuSQL/Algebra/Optimize.hs → chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Optimize.hs
+10 -8
View File
@@ -1,12 +1,12 @@
module ChuSQL.Algebra.Optimize (optimize, pushProject, relOpCols) where
module ChuSQL.Core.Engine.Algebra.Optimize (optimize, pushProject, relOpCols) where
import ChuSQL.Algebra.Expr (colsInExpr, evalExpr)
import ChuSQL.Algebra.Op (RelOp (..))
import ChuSQL.Model
import ChuSQL.Syntax.AST (Expr (..), JoinKind (..))
import ChuSQL.Core.Engine.Algebra.Expr (colsInExpr, evalExpr)
import ChuSQL.Core.Engine.Algebra.Op (RelOp (..))
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Syntax.AST (Expr (..), JoinKind (..))
import Data.List (nub)
-- 查询优化：谓词下推 + 投影下推 + 常量折叠，跑到不动点。
-- 查询优化：谓词下推、投影下推与常量折叠。
-- | 算子会产出哪些列
relOpCols :: Database -> RelOp -> [String]
@@ -48,6 +48,7 @@ combineConj (e : es) = Just (foldl And e es)
partitionPred :: [String] -> [Expr] -> ([Expr], [Expr])
partitionPred have = foldr pick ([], [])
where
-- | 按列归属收到左边或右边
pick e (yes, no)
| colsInExpr e `isSubsetOf` have = (e : yes, no)
| otherwise = (yes, e : no)
@@ -72,8 +73,7 @@ pushJoin db p l r c =
Nothing -> joined
Just p' -> Filter p' joined
-- | Filter 压在左连接上时，只把纯左表的谓词下推到左表；
-- 右表没配上会补 NULL，右表谓词不能提前算。
-- | Filter 压在左连接上时只下推纯左表的谓词
pushLeftJoin :: Database -> Expr -> RelOp -> RelOp -> Expr -> RelOp
pushLeftJoin db p l r c =
let (lPs, rest) = partitionPred (relOpCols db l) (splitConj p)
@@ -105,6 +105,7 @@ hasDivision e = case e of
Or a b -> both a b
_ -> False
where
-- | 两个子表达式里任意一个有除法
both a b = hasDivision a || hasDivision b
-- | 检查子计划中可能报错的除法
@@ -216,6 +217,7 @@ rewriteNode db op = pushOne db op
optimizeRelOp :: Database -> RelOp -> RelOp
optimizeRelOp db = rewriteNode db . descend
where
-- | 先递归处理子算子
descend (Filter p x) = Filter p (optimizeRelOp db x)
descend (Project cols x) = Project cols (optimizeRelOp db x)
descend (Compute items x) = Compute items (optimizeRelOp db x)
chusql-engine/src/ChuSQL/Algebra/Planner.hs → chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Planner.hs
+5 -4
View File
@@ -1,8 +1,8 @@
module ChuSQL.Algebra.Planner (translate) where
module ChuSQL.Core.Engine.Algebra.Planner (translate) where
import ChuSQL.Algebra.Expr (aggregatesIn)
import ChuSQL.Algebra.Op
import ChuSQL.Syntax.AST
import ChuSQL.Core.Engine.Algebra.Expr (aggregatesIn)
import ChuSQL.Core.Engine.Algebra.Op
import ChuSQL.Core.Engine.Syntax.AST
-- 计划生成：把语句翻译成算子树。
@@ -23,6 +23,7 @@ source fromC mWhere = case mWhere of
nameAggs :: [(String, Expr)] -> [(String, Expr)]
nameAggs items = go (1 :: Int) [] (concatMap (aggregatesIn . snd) items)
where
-- | 逐个聚合起名，重复的不再起名
go :: Int -> [(String, Expr)] -> [Expr] -> [(String, Expr)]
go _ acc [] = reverse acc
go n acc (e : es)
chusql-engine/src/ChuSQL/Algebra/Sort.hs → chusql-core/engine/src/ChuSQL/Core/Engine/Algebra/Sort.hs
+7 -5
View File
@@ -1,10 +1,10 @@
module ChuSQL.Algebra.Sort (sortRows, compareValue) where
module ChuSQL.Core.Engine.Algebra.Sort (sortRows, compareValue) where
import ChuSQL.Model
import ChuSQL.Syntax.AST
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Syntax.AST
import Data.List (sortBy)
-- 排序：按多列排序，每列可升可降。
-- 排序：按多列规格排出结果行，每列可升可降。
-- | 反转比较结果
flipOrdering :: Ordering -> Ordering
@@ -41,10 +41,12 @@ compareKeys ((_, dir) : rest) (a : as) (b : bs) =
_ -> compareKeys rest as bs
compareKeys _ _ _ = EQ
-- | 排序若干行（先取键再排，避免每次比较都查列）
-- | 按排序规格排序若干行
sortRows :: [(String, SortDir)] -> [Row] -> [Row]
sortRows [] rows = rows
sortRows spec rows = map snd (sortBy cmp (map decorate rows))
where
-- | 取键并带上原行
decorate row = (sortKey spec row, row)
-- | 比较两个带键的行
cmp (k1, _) (k2, _) = compareKeys spec k1 k2
chusql-engine/src/ChuSQL/Semantic.hs → chusql-core/engine/src/ChuSQL/Core/Engine/Semantic.hs
+35 -18
View File
@@ -1,9 +1,9 @@
module ChuSQL.Semantic (check, prepare) where
module ChuSQL.Core.Engine.Semantic (check, prepare) where
import ChuSQL.Algebra.Expr (bareColumns, colsInExpr, hasAggregate)
import ChuSQL.Model
import ChuSQL.Syntax.AST
import ChuSQL.Syntax.Parser (parseExpression)
import ChuSQL.Core.Engine.Algebra.Expr (bareColumns, colsInExpr, hasAggregate)
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Engine.Syntax.Parser (parseExpression)
import Data.Char (isAlphaNum, isAscii, toLower)
import Data.List (intercalate, isInfixOf, isPrefixOf, nub)
import Data.Maybe (fromMaybe)
@@ -22,8 +22,7 @@ prefixColumns mAlias cols = [(prefix ++ c, ty) | (c, ty) <- cols]
where
prefix = maybe "" (++ ".") mAlias
-- | 检查期的作用域：本层优先，外层兜底。
-- 不能把两层平铺成一个列表：同名裸列会出现两次，被误报成 ambiguous。
-- | 检查期的作用域：本层优先，外层兜底
data Scope = Scope
{ scopeInner :: [(String, Column)]
, scopeOuter :: [(String, Column)]
@@ -39,7 +38,7 @@ scopeAt place scope c
| "ambiguous column:" `isInfixOf` err -> Left err
| otherwise -> columnAt place (scopeOuter scope) c
-- | 收集 FROM 能提供的列；outer 是外层作用域，给 ON 里的相关子查询用
-- | 收集 FROM 能提供的列，含外层作用域
checkFrom :: Database -> [(String, Column)] -> FromClause -> Either String [(String, Column)]
checkFrom _ _ FromUnit = Right []
checkFrom db _ (FromTable mAlias tbl) = do
@@ -52,11 +51,11 @@ checkFrom db outer (FromJoin _ left mAlias tbl cond) = do
checkBool db "ON" (Scope env outer) cond
Right env
-- | 本层作用域优先：外层已有的同名键不再重复堆进来（否则同一个键被数两次，误报 ambiguous）
-- | 合并两层列，本层优先且不重复
scopedEnv :: [(String, Column)] -> [(String, Column)] -> [(String, Column)]
scopedEnv env outer = env ++ [o | o <- outer, o `notElem` env]
-- | 作用域摊平成一层（只用于继续往外传，查找仍走 scopeAt 的本层优先）
-- | 把作用域摊平成一层的列清单
scopeFlat :: Scope -> [(String, Column)]
scopeFlat scope = scopedEnv (scopeInner scope) (scopeOuter scope)
@@ -73,7 +72,7 @@ missingColumn place c env =
checkColumns :: String -> Scope -> [String] -> Either String ()
checkColumns place env = mapM_ (\c -> if c == allColumns then Right () else () <$ scopeAt place env c)
-- | 保留子句名与可用列提示
-- | 在一层里查一列，报错时带上子句名与可用列
columnAt :: String -> [(String, Column)] -> String -> Either String (String, Column)
columnAt place env c = case resolveColumn c env of
Right entry -> Right entry
@@ -94,6 +93,7 @@ checkGrouping env keys items
checkColumns "GROUP BY" env keys
mapM_ okCol (nub (concatMap (bareColumns . snd) items))
where
-- | 这一列能不能出现在分组查询里
okCol c
| c == allColumns = Left "SELECT: * cannot be selected together with GROUP BY"
| c `elem` keys = Right ()
@@ -173,7 +173,7 @@ itemType place want got
| compatible want got = Right ()
| otherwise = Left (place ++ ": IN list item has type " ++ renderType got ++ ", expected " ++ renderType want)
-- | 子查询的输出列与类型（外层作用域 outerScope 可做相关引用，内层整条查一遍）
-- | 推导子查询的输出列与类型
inferSubqueryOutput :: Database -> Scope -> Subquery -> Either String [(String, InferredType)]
inferSubqueryOutput db outerScope sq = case subqueryStatement sq of
q@Select { selectCols = cols } -> do
@@ -187,6 +187,7 @@ inferSubqueryOutput db outerScope sq = case subqueryStatement sq of
_ -> Left "subquery must be a SELECT"
where
enclosing = scopeFlat outerScope
-- | 查这一列的推导类型
columnTypeOf env c = do
(_, col) <- scopeAt "SELECT" (Scope env enclosing) c
Right (c, InferType (columnType col))
@@ -222,6 +223,7 @@ arithmetic db place env a b = do
mapM_ (numericOperand place (InferType want) (InferType want)) [ta, tb]
Right (arithResult ta tb)
where
-- | 是不是浮点类型
isFloatSide (InferType x) = numericType x && not (integerType x)
isFloatSide _ = False
@@ -260,6 +262,7 @@ boolean db place env a b = do
mapM_ (boolOperand place ta) [ta, tb]
Right (InferType CBool)
where
-- | 挨个查操作数是不是布尔
boolOperand _ _ InferNull = Right ()
boolOperand _ _ (InferType CBool) = Right ()
boolOperand p other t = Left (p ++ ": operator needs TBool on both sides, got " ++ renderType other ++ " and " ++ renderType t)
@@ -453,7 +456,7 @@ checkInsertTargets t cols = mapM_ checkTarget (tableCols t)
| Just _ <- columnDefault c = Right ()
| otherwise = Left ("INSERT: column " ++ name ++ " is NOT NULL and has no default")
-- | 一列定义是否合法；names 是校验 CHECK 列引用时可用的全部列名
-- | 检查一列定义是否合法（names 给 CHECK 用）
checkColumnDefs :: [String] -> [(String, Column)] -> Either String ()
checkColumnDefs names cols = do
mapM_ (\(_, c) -> mapM_ (checkDefault c) (columnDefault c)) cols
@@ -480,11 +483,13 @@ checkDefault c v
checkChecks :: [String] -> [(String, Column)] -> Either String ()
checkChecks names = mapM_ checkOne
where
-- | 查这一列的 CHECK
checkOne (_, c) = case columnCheck c of
Nothing -> Right ()
Just text -> case parseExpression text of
Left err -> Left ("CHECK: " ++ firstLine err)
Right e -> mapM_ (known e) (colsInExpr e)
-- | 这个列名在不在定义里
known _ col
| col `elem` names = Right ()
| otherwise = Left ("CHECK: unknown column: " ++ col)
@@ -494,6 +499,7 @@ checkChecks names = mapM_ checkOne
accountNameLimit :: Int
accountNameLimit = 64
-- | 检查库名是否合法
checkDatabaseName :: String -> Either String ()
checkDatabaseName name
| null name || length name > 64 || not (all (\c -> isAscii c && (isAlphaNum c || c == '_')) name) = Left "invalid database name"
@@ -511,6 +517,7 @@ checkUserName name
| not (all allowed name) = Left "USER: account name may only contain ASCII letters, digits, dot, dash or underscore"
| otherwise = Right ()
where
-- | 账号名字符规则
allowed c = isAscii c && (isAlphaNum c || c `elem` ("_.-" :: String))
-- | 建号 / 改口令：名字合法且口令不空
@@ -524,7 +531,7 @@ checkAccount name password = do
then Left "USER: password is too long"
else Right ()
-- | 角色名：字符规则同账号名，另外不许拿权限关键字当名字（否则 GRANT 读不出来）
-- | 检查角色名是否合法（不许用权限关键字）
checkRoleName :: String -> Either String ()
checkRoleName name
| null name = Left "ROLE: empty role name"
@@ -533,6 +540,7 @@ checkRoleName name
| map toLower name `elem` privilegeNames = Left "ROLE: role name must not be a privilege keyword"
| otherwise = Right ()
where
-- | 角色名字符规则
allowed c = isAscii c && (isAlphaNum c || c `elem` ("_.-" :: String))
-- | 权限关键字（小写，只用于比较）
@@ -554,8 +562,10 @@ checkGrantObject obj
| not (all allowed obj) = Left "GRANT: object name may only contain ASCII letters, digits, dot, dash or underscore"
| otherwise = Right ()
where
-- | 授权对象字符规则
allowed c = isAscii c && (isAlphaNum c || c `elem` ("_.-" :: String))
-- | 内置 id 列名
idColumn :: String
idColumn = "id"
-- | 把列引用统一为执行期名字（子查询一起解析）
@@ -592,10 +602,10 @@ resolveExpr db env outer f e = case e of
ExistsSub sq negated -> ExistsSub <$> resolveSubquery db (env ++ outer) sq <*> pure negated
_ -> Right e
where
-- | 递归处理两个子表达式
binary ctor a b = ctor <$> resolveExpr db env outer f a <*> resolveExpr db env outer f b
-- | 子查询：内层整条解析一遍，外层列参与解析（相关引用）
-- 解析完把“引用了哪些外层列”记进 subqueryRefs：投影下推要靠它保住这些列
-- | 解析子查询，并记下它引用的外层列
resolveSubquery :: Database -> [(String, Column)] -> Subquery -> Either String Subquery
resolveSubquery db outer sq = do
stmt <- resolveSubqueryStatement db outer (subqueryStatement sq)
@@ -608,11 +618,12 @@ outerRefsOf db stmt = nub [c | c <- statementColumns stmt, not (inInner c)]
inner = case checkFrom db [] (statementFrom stmt) of
Right env -> env
Left _ -> []
-- | 这一列能不能在内层解析到
inInner c = case resolveColumn c inner of
Right _ -> True
Left _ -> False
-- | 一条语句里出现的所有列引用（含 JOIN 的 ON 和嵌套子查询的外层引用）
-- | 一条语句里出现的所有列引用
statementColumns :: Statement -> [String]
statementColumns stmt = case stmt of
Select cols fromC mWhere groupBy orderBy _ ->
@@ -621,15 +632,18 @@ statementColumns stmt = case stmt of
concatMap (colsInExpr . snd) items ++ fromColumns fromC ++ concatMap colsInExpr mWhere ++ groupBy ++ map fst orderBy
_ -> []
where
-- | 取 FROM 里出现的列
fromColumns FromUnit = []
fromColumns (FromTable _ _) = []
fromColumns (FromJoin _ l _ _ c) = fromColumns l ++ colsInExpr c
-- | 取语句的 FROM 子句，没有就是 FromUnit
statementFrom :: Statement -> FromClause
statementFrom Select { selectFrom = fromC } = fromC
statementFrom SelectExpr { selectFrom = fromC } = fromC
statementFrom _ = FromUnit
-- | 解析子查询里的 SELECT
resolveSubqueryStatement :: Database -> [(String, Column)] -> Statement -> Either String Statement
resolveSubqueryStatement db outer q@Select{} = resolveQuery db outer q (map (\c -> (c, Col c)) (selectCols q))
resolveSubqueryStatement db outer q@SelectExpr{} = resolveQuery db outer q (selectItems q)
@@ -672,14 +686,17 @@ resolveSelect db q@Select{} = resolveQuery db [] q (map (\c -> (c, Col c)) (sele
resolveSelect db q@SelectExpr{} = resolveQuery db [] q (selectItems q)
resolveSelect _ q = Right q
-- | 解析投影、条件、排序与连接引用；outer 是相关子查询能看见的外层列
-- | 解析投影、条件、排序与连接引用
resolveQuery :: Database -> [(String, Column)] -> Statement -> [(String, Expr)] -> Either String Statement
resolveQuery db outer q items = do
env <- checkFrom db outer (selectFrom q)
-- | 单表查询里把裸列名换成物理列名
let physical c = case selectFrom q of
FromTable Nothing tbl -> unqualify (Just tbl) c
_ -> c
-- | 查一列并换算成物理名
name place c = physical . fst <$> scopedColumnAt place env outer c
-- | 换算一个投影项
output (_, Col c) = do
k <- name "SELECT" c
pure (k, Col k)
chusql-engine/src/ChuSQL/Storage.hs → chusql-core/engine/src/ChuSQL/Core/Engine/Storage.hs
+11 -4
View File
@@ -1,11 +1,11 @@
module ChuSQL.Storage (
module ChuSQL.Core.Engine.Storage (
MonadStorage (..),
IndexResult (..),
) where
import ChuSQL.Model (Column, Database, Row, Table (..), Value (..))
import ChuSQL.Core.Model (Column, Database, Row, Table (..), Value (..))
-- 存储层抽象：上层只认 domain 类型，不关心底层实现。
-- 存储层抽象：MonadStorage 类与 IndexResult。
data IndexResult
= IndexRows [Row]
@@ -13,12 +13,16 @@ data IndexResult
deriving (Show, Eq)
class (Monad m) => MonadStorage m where
-- \| 建一个库
createDatabase :: String -> m (Either String ())
createDatabase _ = pure (Left "database management is unavailable in this storage")
-- \| 删一个库
dropDatabase :: String -> m (Either String ())
dropDatabase _ = pure (Left "database management is unavailable in this storage")
-- \| 切当前库
useDatabase :: String -> m (Either String ())
useDatabase _ = pure (Left "database selection is unavailable in this storage")
-- \| 列出现有库
listDatabases :: m (Either String [String])
listDatabases = pure (Right [])
@@ -38,6 +42,7 @@ class (Monad m) => MonadStorage m where
insertMany :: String -> [Row] -> m (Either String ())
insertMany t = go
where
-- | 逐行插入，出错就停
go [] = pure (Right ())
go (r : rs) = do
x <- insert t r
@@ -53,6 +58,7 @@ class (Monad m) => MonadStorage m where
Left e -> pure (Left e)
Right rs -> replaceAll t [r | r <- rs, not (doomed r)]
where
-- | 这一行要不要删
doomed r = case lookup "id" r of
Just (VInt k) -> k `elem` ks
_ -> False
@@ -79,7 +85,7 @@ class (Monad m) => MonadStorage m where
-- \| 删除表
dropTable :: String -> m (Either String ())
-- \| 给某一列建索引（要求这一列整数取值唯一）
-- \| 给某一列建索引（id 列要求唯一）
createIndex :: String -> String -> m (Either String ())
createIndex _ _ = pure (Right ())
@@ -100,4 +106,5 @@ class (Monad m) => MonadStorage m where
schema :: m Database
schema = fmap (map withoutRows) snapshot
where
-- | 表定义去掉所有行
withoutRows (name, t) = (name, t {tableRows = []})
chusql-core/engine/src/ChuSQL/Core/Engine/Storage/FFI.hs
+90
View File
@@ -0,0 +1,90 @@
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ImportQualifiedPost #-}
module ChuSQL.Core.Engine.Storage.FFI (
StorageHandle,
storageVersion,
openStorage,
closeStorage,
storageRequest,
) where
import Control.Exception (SomeException, try)
import Data.ByteString qualified as BS
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Text.Encoding.Error (lenientDecode)
import Foreign
import Foreign.C
-- Rust 存储库 cdylib 的 C ABI 绑定（ffi.rs），收发单行 JSON。
-- | 存储实例句柄（Rust 侧的 *mut Storage）
newtype StorageHandle = StorageHandle (Ptr ())
foreign import ccall unsafe "chusql_storage_version"
cStorageVersion :: IO CString
foreign import ccall safe "chusql_storage_open"
cStorageOpen :: CString -> IO (Ptr ())
foreign import ccall safe "chusql_storage_close"
cStorageClose :: Ptr () -> IO ()
foreign import ccall safe "chusql_storage_request"
cStorageRequest :: Ptr () -> Ptr CChar -> CSize -> Ptr (Ptr CChar) -> Ptr CSize -> IO CInt
foreign import ccall unsafe "chusql_storage_free"
cStorageFree :: Ptr CChar -> CSize -> IO ()
foreign import ccall unsafe "chusql_storage_last_error"
cStorageLastError :: Ptr CSize -> IO (Ptr CChar)
-- | 库版本（Rust 侧的 CARGO_PKG_VERSION）
storageVersion :: IO String
storageVersion = cStorageVersion >>= peekCString
-- | 打开存储实例，失败给错误文本
openStorage :: Maybe FilePath -> IO (Either String StorageHandle)
openStorage path = do
result <- try (withCStringOrNull path cStorageOpen) :: IO (Either SomeException (Ptr ()))
case result of
Left e -> pure (Left ("storage library call failed: " ++ show e))
Right ptr
| ptr == nullPtr -> Left <$> lastError
| otherwise -> pure (Right (StorageHandle ptr))
where
-- | 没有路径就传空指针，否则转成 C 字符串
withCStringOrNull Nothing f = f nullPtr
withCStringOrNull (Just s) f = withCString s f
-- | 关掉存储实例
closeStorage :: StorageHandle -> IO ()
closeStorage (StorageHandle handle) = cStorageClose handle
-- | 一条 JSON 请求换一条 JSON 响应
storageRequest :: StorageHandle -> BS.ByteString -> IO (Either String BS.ByteString)
storageRequest (StorageHandle handle) payload =
BS.useAsCStringLen payload $ \(inPtr, inLen) ->
alloca $ \outPtrRef ->
alloca $ \outLenRef -> do
code <- cStorageRequest handle (castPtr inPtr) (fromIntegral inLen) outPtrRef outLenRef
if code /= 0
then Left <$> lastError
else do
outPtr <- peek outPtrRef
outLen <- peek outLenRef
bytes <- BS.packCStringLen (castPtr outPtr, fromIntegral outLen)
cStorageFree outPtr outLen
pure (Right bytes)
-- | 当前线程最近一次失败的文本
lastError :: IO String
lastError = alloca $ \lenRef -> do
ptr <- cStorageLastError lenRef
if ptr == nullPtr
then pure "storage: unknown error"
else do
len <- peek lenRef
raw <- BS.packCStringLen (ptr, fromIntegral len)
pure (T.unpack (TE.decodeUtf8With lenientDecode raw))
chusql-core/engine/src/ChuSQL/Core/Engine/Storage/IPC.hs
+368
View File
@@ -0,0 +1,368 @@
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Core.Engine.Storage.IPC (
IPCStorage (..),
Request (..),
Response (..),
Account (..),
SchemaColumn (..),
TableInfo (..),
StorageLink (..),
setStorageLink,
localStorageLink,
sendRequest,
sendRawRequest,
closeConnection,
setDatabaseName,
getDatabaseName,
doListTables,
doLookupByColumn,
doInsert,
doInsertMany,
doDeleteKeys,
doDescribeTable,
doDropTable,
doListCatalog,
) where
import ChuSQL.Core.Model
import ChuSQL.Core.Protocol (Account (..), Request (..), Response (..), SchemaColumn (..), TableInfo (..))
import ChuSQL.Core.Engine.Storage
import ChuSQL.Core.Engine.Storage.FFI (closeStorage, openStorage, storageRequest)
import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
import Data.Aeson (eitherDecodeStrict, encode)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import Data.Maybe (fromMaybe)
import System.IO.Unsafe (unsafePerformIO)
-- IPC 存储实现：把 MonadStorage 的操作变成发给存储库的 JSON 请求。
newtype IPCStorage a = IPCStorage
{ runIPCStorage :: IO a
}
instance Functor IPCStorage where
fmap f (IPCStorage m) = IPCStorage (fmap f m)
instance Applicative IPCStorage where
pure = IPCStorage . pure
IPCStorage mf <*> IPCStorage ma = IPCStorage (mf <*> ma)
instance Monad IPCStorage where
IPCStorage m >>= k = IPCStorage $ do
a <- m
runIPCStorage (k a)
-- | 一条到存储库的链路：管请求与关闭
data StorageLink = StorageLink
{ slRequest :: BS.ByteString -> IO (Either String BS.ByteString)
, slClose :: IO ()
}
{-# NOINLINE linkRef #-}
-- | 进程全局的存储链路
linkRef :: MVar (Maybe StorageLink)
linkRef = unsafePerformIO (newMVar Nothing)
-- | 装入一条链路；一个进程只装一次
setStorageLink :: StorageLink -> IO ()
setStorageLink link = modifyMVar_ linkRef (const (pure (Just link)))
-- | 打开本地的存储动态库，得到一条链路
localStorageLink :: Maybe FilePath -> IO (Either String StorageLink)
localStorageLink path = fmap (fmap toLink) (openStorage path)
where
-- | 把句柄包成一条链路
toLink handle =
StorageLink
{ slRequest = storageRequest handle
, slClose = closeStorage handle
}
-- | 关掉当前链路（进程退出前调用）；没有链路就什么都不做
closeConnection :: IO ()
closeConnection = modifyMVar_ linkRef $ \current -> do
case current of
Nothing -> pure ()
Just link -> slClose link
pure Nothing
-- | 发一条请求并解码应答；链路没装就报错，不崩
sendRequest :: Request -> IO Response
sendRequest req = do
current <- readMVar linkRef
case current of
Nothing -> pure (RespError "storage not configured")
Just link -> do
raw <- slRequest link (BL.toStrict (encode req))
case raw of
Left e -> pure (RespError ("storage error: " ++ e))
Right bytes -> case eitherDecodeStrict (BS.dropWhileEnd (== 13) bytes) of
Left e -> pure (RespError ("decode error: " ++ e))
Right resp -> pure resp
-- | 原样转发一条载荷给存储库
sendRawRequest :: BS.ByteString -> IO (Either String BS.ByteString)
sendRawRequest payload = do
current <- readMVar linkRef
case current of
Nothing -> pure (Left "storage not configured")
Just link -> slRequest link payload
{-# NOINLINE databaseRef #-}
-- | 进程全局的当前库名
databaseRef :: MVar (Maybe String)
databaseRef = unsafePerformIO (newMVar Nothing)
-- | 设定当前库名（会话层决定，本层只记住并发给存储）
setDatabaseName :: Maybe String -> IO ()
setDatabaseName name = modifyMVar_ databaseRef (const (pure name))
-- | 当前库名
getDatabaseName :: IO (Maybe String)
getDatabaseName = readMVar databaseRef
-- | 给语句类请求盖上当前库名
stampDatabase :: Maybe String -> Request -> Request
stampDatabase Nothing req = req
stampDatabase (Just db) req
| globalRequest req = req
| otherwise = ReqInDatabase db req
-- | 是不是不该带库名的全局请求
globalRequest :: Request -> Bool
globalRequest ReqDatabase{} = True
globalRequest ReqAllCatalog = True
globalRequest ReqAccountsList = True
globalRequest ReqAccountCreate{} = True
globalRequest ReqAccountReset{} = True
globalRequest ReqAccountLogin{} = True
globalRequest ReqAccountDrop{} = True
globalRequest ReqPing = True
globalRequest _ = False
-- | 发请求并把响应翻成 Either
ask :: String -> Request -> (Response -> Maybe a) -> IO (Either String a)
ask what req recognize = do
current <- getDatabaseName
resp <- sendRequest (stampDatabase current req)
pure $ case resp of
RespError e -> Left e
other -> case recognize other of
Just a -> Right a
Nothing -> Left ("unexpected response to " ++ what)
-- | 只认"成了"（多数写操作都这样）
okOnly :: Response -> Maybe ()
okOnly RespOk = Just ()
okOnly _ = Nothing
-- | 发 Scan
doScan :: String -> IO (Either String [Row])
doScan t = ask "scan" (ReqScan t) $ \resp -> case resp of
RespRows rows -> Just rows
_ -> Nothing
-- | 发 Insert（索引由存储层维护）
doInsert :: String -> Row -> IO (Either String ())
doInsert t r = ask "insert" (ReqInsert t r) okOnly
-- | 发 InsertBatch：一批行一次请求
doInsertMany :: String -> [Row] -> IO (Either String ())
doInsertMany t rs = ask "insert_batch" (ReqInsertBatch t rs) okOnly
-- | 发 DeleteKeys
doDeleteKeys :: String -> [Int] -> IO (Either String ())
doDeleteKeys t ks = ask "delete_keys" (ReqDeleteKeys t ks) okOnly
-- | 发 ReplaceAll
doReplaceAll :: String -> [Row] -> IO (Either String ())
doReplaceAll t rs = ask "replace_all" (ReqReplaceAll t rs) okOnly
-- | 发 ListTables
doListTables :: IO (Either String [String])
doListTables = ask "list_tables" ReqListTables $ \resp -> case resp of
RespTables ts -> Just ts
_ -> Nothing
-- | 一次拿全库 schema
doListCatalog :: IO (Either String [TableInfo])
doListCatalog = ask "list_catalog" ReqListCatalog $ \resp -> case resp of
RespCatalog xs -> Just xs
_ -> Nothing
-- | 按某一列的索引取一行（键可以是整数或字符串）
doLookupByColumn :: String -> String -> Value -> IO (Either String IndexResult)
doLookupByColumn t c k = ask "lookup_by_index" (ReqLookupByColumn t c k) $ \resp -> case resp of
RespRows rows -> Just (IndexRows rows)
RespNoIndex -> Just NoIndex
_ -> Nothing
-- | 范围扫描：没有可用索引就回 Nothing，让上层退回扫描
doScanRange ::
String ->
String ->
Maybe (Value, Bool) ->
Maybe (Value, Bool) ->
IO (Either String (Maybe [Row]))
doScanRange t c lo hi = ask "range_by_index" (ReqRangeByIndex t c lo hi) $ \resp -> case resp of
RespRows rows -> Just (Just rows)
RespNoIndex -> Just Nothing
_ -> Nothing
-- | 发 DescribeTable
doDescribeTable :: String -> IO (Either String TableInfo)
doDescribeTable t = ask "describe_table" (ReqDescribeTable t) $ \resp -> case resp of
RespSchema info -> Just info
_ -> Nothing
-- | 给某一列建索引
doCreateIndex :: String -> String -> IO (Either String ())
doCreateIndex t c = ask "create_index" (ReqCreateIndex t c) okOnly
-- | 去掉某一列的索引
doDropIndex :: String -> String -> IO (Either String ())
doDropIndex t c = ask "drop_index" (ReqDropIndex t c) okOnly
-- | 删一列（列定义、这一列上的索引、每行里的那一格一起没）
doDropColumn :: String -> String -> IO (Either String ())
doDropColumn t c = ask "drop_column" (ReqDropColumn t c) okOnly
-- | 发 ReplaceSchema（ALTER 用）
doReplaceSchema :: String -> [SchemaColumn] -> [Row] -> IO (Either String ())
doReplaceSchema t cols rs = ask "replace_schema" (ReqReplaceSchema t cols rs) okOnly
-- | 发 CreateTable
doCreateTable :: String -> [SchemaColumn] -> IO (Either String ())
doCreateTable t cols = ask "create_table" (ReqCreateTable t cols) okOnly
-- | 发 DropTable
doDropTable :: String -> IO (Either String ())
doDropTable t = ask "drop_table" (ReqDropTable t) okOnly
-- | 线上 schema 转本地列
schemaToColumns :: [SchemaColumn] -> [(String, Column)]
schemaToColumns = map toColumn
-- | 线上 schema 转本地 column
toColumn :: SchemaColumn -> (String, Column)
toColumn sc =
( scName sc
, Column
{ columnType = fromMaybe CStr (parseColumnType (scType sc))
, columnNullable = scNullable sc
, columnDefault = scDefault sc
, columnAutoIncrement = scAutoIncrement sc
, columnUnique = scUnique sc
, columnPrimaryKey = scPrimaryKey sc
, columnCheck = scCheck sc
}
)
-- | 本地列转线上 schema
toWire :: (String, Column) -> SchemaColumn
toWire (n, c) =
SchemaColumn
{ scName = n
, scType = typeName (columnType c)
, scNullable = columnNullable c
, scDefault = columnDefault c
, scAutoIncrement = columnAutoIncrement c
, scPrimaryKey = columnPrimaryKey c
, scUnique = columnUnique c
, scCheck = columnCheck c
}
instance MonadStorage IPCStorage where
-- \| 建一个库
createDatabase name = IPCStorage (ask "create_database" (ReqDatabase "create_database" name) okOnly)
-- \| 删一个库
dropDatabase name = IPCStorage (ask "drop_database" (ReqDatabase "drop_database" name) okOnly)
-- \| 切当前库
useDatabase name = IPCStorage (ask "use_database" (ReqDatabase "use_database" name) okOnly)
-- \| 列出现有库
listDatabases = IPCStorage $ ask "list_databases" (ReqDatabase "list_databases" "") $ \resp -> case resp of
RespTables names -> Just names
_ -> Nothing
-- \| 发 Scan
scan t = IPCStorage (doScan t)
-- \| 只取指定列
scanColumns t cols = IPCStorage $ ask "scan" (ReqScanColumns t cols) $ \resp -> case resp of
RespRows rows -> Just [[(c, v) | c <- cols, Just v <- [lookup c row]] | row <- rows]
_ -> Nothing
-- \| 发 Insert（索引由存储层自己维护）
insert t r = IPCStorage (doInsert t r)
-- \| 一批行一次请求：N 行只落一次盘
insertMany t rs = IPCStorage (doInsertMany t rs)
-- \| 按 id 批量删行
deleteKeys t ks = IPCStorage (doDeleteKeys t ks)
-- \| 发 ReplaceAll
replaceAll t rs = IPCStorage (doReplaceAll t rs)
-- \| 按某一列的索引取一行（没有索引就回 NoIndex）
lookupByColumn t c k = IPCStorage (doLookupByColumn t c k)
-- \| 范围扫描（没有索引就回 Nothing）
scanRange t c lo hi = IPCStorage (doScanRange t c lo hi)
-- \| 发 CreateTable
createTable name cols = IPCStorage (doCreateTable name (map toWire cols))
-- \| ALTER：整表换列定义与全部行
replaceSchema name cols rows = IPCStorage (doReplaceSchema name (map toWire cols) rows)
-- \| 发 DropTable
dropTable name = IPCStorage (doDropTable name)
-- \| 建索引
createIndex t c = IPCStorage (doCreateIndex t c)
-- \| 删索引
dropIndex t c = IPCStorage (doDropIndex t c)
-- \| 删一列
dropColumn t c = IPCStorage (doDropColumn t c)
-- \| 列表 + 逐表扫描拼库
snapshot = IPCStorage $ do
result <- doListCatalog
case result of
Left _ -> pure []
Right xs -> mapM loadEntry xs
where
loadEntry info = do
rows <- doScan (tiTable info)
pure
( tiTable info
, Table (tiTable info) (schemaToColumns (tiColumns info)) (either (const []) id rows)
)
-- \| 只问数据字典要结构，设了当前库只留它的表
schema = IPCStorage $ do
current <- getDatabaseName
result <- ask "all_catalogs" ReqAllCatalog $ \resp -> case resp of
RespCatalog infos -> Just infos
_ -> Nothing
pure $ case result of
Left _ -> []
Right xs -> concatMap (visibleTables current) xs
-- | 没设库名就照单全收；设了库名只收这个库的表，键名去掉库名前缀
visibleTables :: Maybe String -> TableInfo -> [(String, Table)]
visibleTables current info
| Just db <- current =
if unqualify (Just db) (tiTable info) /= tiTable info
then [bare named]
else []
| otherwise = [bare info]
where
named = info {tiTable = unqualify current (tiTable info)}
-- | 组装成不带行的表
bare i = (tiTable i, Table (tiTable i) (schemaToColumns (tiColumns i)) [])
chusql-engine/src/ChuSQL/Storage/Memory.hs → chusql-core/engine/src/ChuSQL/Core/Engine/Storage/Memory.hs
+3 -3
View File
@@ -1,7 +1,7 @@
module ChuSQL.Storage.Memory (MemoryStorage (runMemoryStorage)) where
module ChuSQL.Core.Engine.Storage.Memory (MemoryStorage (runMemoryStorage)) where
import ChuSQL.Model
import ChuSQL.Storage
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Storage
-- 内存实现：Database 上的状态，错误通道是 Either String。
chusql-engine/src/ChuSQL/Syntax/AST.hs → chusql-core/engine/src/ChuSQL/Core/Engine/Syntax/AST.hs
+8 -5
View File
@@ -1,6 +1,6 @@
module ChuSQL.Syntax.AST (Statement (..), FromClause (..), JoinKind (..), Expr (..), Subquery (..), SortDir (..), makeSelect) where
module ChuSQL.Core.Engine.Syntax.AST (Statement (..), FromClause (..), JoinKind (..), Expr (..), Subquery (..), SortDir (..), makeSelect) where
import ChuSQL.Model (Column (..), ColumnType, Value (..))
import ChuSQL.Core.Model (Column (..), ColumnType, Value (..))
-- 语法树：语句、数据来源、条件表达式、排序方向。
@@ -41,11 +41,11 @@ data Statement
| CreateRole String
-- | 删角色：连同它的授权与成员一起删
| DropRole String
-- | GRANT <权限>[, ...] ON <表|*> TO <角色>
-- | GRANT 权限 ON 表 TO 角色
| GrantPrivileges [String] String String
-- | REVOKE <权限>[, ...] ON <表|*> FROM <角色>
-- | REVOKE 权限 ON 表 FROM 角色
| RevokePrivileges [String] String String
-- | GRANT <角色> TO <用户>[, ...]：给用户加角色
-- | GRANT 角色 TO 用户：给用户加角色
| GrantRole String [String]
-- | REVOKE <角色> FROM <用户>[, ...]
| RevokeRole String [String]
@@ -61,6 +61,7 @@ data JoinKind
| LeftJoin
deriving (Show, Eq)
-- | 数据来源：单表、带连接的来源，或空
data FromClause
= FromTable (Maybe String) String
| FromJoin JoinKind FromClause (Maybe String) String Expr
@@ -74,6 +75,7 @@ data Subquery = Subquery
}
deriving (Show, Eq)
-- | 条件表达式：列、字面量、算术、比较、逻辑、聚合与子查询
data Expr
= Col String
| LitNull
@@ -108,6 +110,7 @@ data Expr
| ExistsSub Subquery Bool
deriving (Show, Eq)
-- | 排序方向：升序或降序
data SortDir
= Asc
| Desc
chusql-engine/src/ChuSQL/Syntax/Parser.hs → chusql-core/engine/src/ChuSQL/Core/Engine/Syntax/Parser.hs
+16 -11
View File
@@ -1,9 +1,9 @@
{-# LANGUAGE ImportQualifiedPost #-}
module ChuSQL.Syntax.Parser (parseStatement, parseExpression) where
module ChuSQL.Core.Engine.Syntax.Parser (parseStatement, parseExpression) where
import ChuSQL.Model (Column (..), ColumnType (..), Value (..), plainColumn)
import ChuSQL.Syntax.AST
import ChuSQL.Core.Model (Column (..), ColumnType (..), Value (..), plainColumn)
import ChuSQL.Core.Engine.Syntax.AST
import Control.Monad (void)
import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)
import Data.Char (isAlpha, isAlphaNum, isHexDigit, isSpace, toLower, toUpper)
@@ -43,7 +43,7 @@ identifier = lexeme $ do
rest <- many (satisfy isIdentChar)
return (first : rest)
-- | 账号名：裸名字或单引号字符串（账号名允许点与短横线，字符串形式才写得出来）
-- | 账号名：裸名字或单引号字符串
userName :: Parser String
userName = identifier <|> stringLit
@@ -154,7 +154,7 @@ existsPredicate = do
scalarSubquery :: Parser Expr
scalarSubquery = ScalarSub <$> between (symbol "(") (symbol ")") subquerySelect
-- | [NOT] IN (SELECT ...) 或 [NOT] IN (值清单)
-- | 读 [NOT] IN：子查询或值清单
inPredicate :: Parser (Expr -> Expr)
inPredicate = do
negated <- (True <$ try (keyword "not" *> keyword "in")) <|> (False <$ keyword "in")
@@ -172,7 +172,7 @@ inPredicate = do
subquerySelect :: Parser Subquery
subquerySelect = Subquery <$> selectStatement <*> pure []
-- | 聚合调用：COUNT(*) / COUNT(x) / SUM(x) / AVG(x) / MIN(x) / MAX(x)
-- | 聚合调用：COUNT/SUM/AVG/MIN/MAX
aggregateCall :: Parser Expr
aggregateCall =
choice
@@ -184,6 +184,7 @@ aggregateCall =
, MaxOf <$> aggArg "max"
]
where
-- | 读聚合函数的参数
aggArg name = try (keyword name *> between (symbol "(") (symbol ")") expr)
-- | 只认字面量，给 DEFAULT 用
@@ -199,6 +200,7 @@ literalValue =
, VStr <$> stringLit
]
where
-- | 负浮点字面量
negateLit d = VFloat (negate d)
-- | 一个排序列
@@ -230,6 +232,7 @@ assignment = do
e <- expr
return (col, e)
-- | 保留字清单，别名不许用
reservedWords :: [String]
reservedWords =
[ "select"
@@ -367,7 +370,7 @@ dropIndexStatement = do
col <- between (symbol "(") (symbol ")") identifier
return (DropIndex tbl col)
-- | 读 ALTER TABLE：加列、删列、改名、改类型、改默认值、改可空
-- | 读 ALTER TABLE 的加列、删列、改名与改属性
alterTableStatement :: Parser Statement
alterTableStatement = do
keyword "alter"
@@ -402,7 +405,7 @@ alterTableStatement = do
]
]
-- | 读 CREATE USER（口令是明文，交给账号服务加盐派生）
-- | 读 CREATE USER，口令是明文
createUserStatement :: Parser Statement
createUserStatement = do
keyword "create"
@@ -418,7 +421,7 @@ identifiedBy = do
keyword "by"
stringLit
-- | 读 ALTER USER ... IDENTIFIED BY（改一个普通账号的口令）
-- | 读 ALTER USER 改口令
alterUserStatement :: Parser Statement
alterUserStatement = do
keyword "alter"
@@ -460,11 +463,11 @@ privilegeName =
, "ALL" <$ keyword "all"
]
-- | ON 后面的授权对象：* 表示全部表，否则是一张表（可带库前缀）
-- | ON 后面的授权对象：* 或一张表
grantObject :: Parser String
grantObject = ("*" <$ symbol "*") <|> tableName
-- | 读 GRANT：带 ON 的是给角色授权限，不带的是给用户加角色
-- | 读 GRANT：带 ON 的授权限，不带的加角色
grantStatement :: Parser Statement
grantStatement = do
keyword "grant"
@@ -554,6 +557,7 @@ decimalType = do
Nothing -> CDecimal 10 0
Just (p, s) -> CDecimal p s
-- | DECIMAL 的精度与小数位参数
decimalArgs :: Parser (Int, Int)
decimalArgs = do
p <- integer
@@ -619,6 +623,7 @@ parseStatement input =
Left err -> Left (errorBundlePretty err)
Right q -> Right q
where
-- | 按关键字分派到各语句解析器
statementP =
selectStatement
<|> try (CreateDatabase <$> (keyword "create" *> keyword "database" *> identifier))
chusql-core/engine/stack.yaml
+8
View File
@@ -0,0 +1,8 @@
resolver: lts-24.59
extra-lib-dirs:
- ../storage/target/release
packages:
- .
- ../model
chusql-engine/stack.yaml.lock → chusql-core/engine/stack.yaml.lock
View File
File renamed without changes.
chusql-engine/test/Spec.hs → chusql-core/engine/test/Spec.hs
+184 -202
View File
@@ -2,32 +2,29 @@
module Main where
import ChuSQL.Algebra.Eval (evalRelOp)
import ChuSQL.Algebra.Expr (colsInExpr, evalExpr)
import ChuSQL.Algebra.Op (RelOp (..), renderPlan)
import ChuSQL.Algebra.Optimize (optimize, pushProject)
import ChuSQL.Algebra.Planner (translate)
import ChuSQL.Engine
import ChuSQL.Model
import ChuSQL.Semantic (prepare)
import ChuSQL.Storage (IndexResult (..), MonadStorage (..))
import ChuSQL.Storage.IPC (IPCStorage (runIPCStorage), Request (ReqPing), Response (RespPong), doListTables, getPipeName, sendRequest, setPipeName)
import ChuSQL.Syntax.AST
import ChuSQL.Syntax.Parser
import Control.Concurrent (threadDelay)
import Control.Exception (IOException, bracket, finally, try)
import ChuSQL.Core.Engine.Algebra.Eval (evalRelOp)
import ChuSQL.Core.Engine.Algebra.Expr (colsInExpr, evalExpr)
import ChuSQL.Core.Engine.Algebra.Op (RelOp (..), renderPlan)
import ChuSQL.Core.Engine.Algebra.Optimize (optimize, pushProject)
import ChuSQL.Core.Engine.Algebra.Planner (translate)
import ChuSQL.Core.Engine
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Semantic (prepare)
import ChuSQL.Core.Engine.Storage (IndexResult (..), MonadStorage (..))
import ChuSQL.Core.Engine.Storage.IPC (IPCStorage (runIPCStorage), closeConnection, doListTables, getDatabaseName, localStorageLink, setDatabaseName, setStorageLink)
import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Engine.Syntax.Parser
import Control.Exception (IOException, finally, try)
import Data.List (isInfixOf, sortOn)
import Data.Unique (hashUnique, newUnique)
import System.CPUTime (getCPUTime)
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getTemporaryDirectory, removePathForcibly)
import System.Exit (ExitCode (..))
import System.Directory (createDirectoryIfMissing, getTemporaryDirectory, removePathForcibly)
import System.FilePath ((</>))
import System.IO (Handle, IOMode (WriteMode), withFile)
import System.Process (CreateProcess (..), ProcessHandle, StdStream (NoStream, UseHandle), createProcess, proc, terminateProcess, waitForProcess)
import Test.Hspec
-- 引擎层的 hspec 测试：语法、执行、优化器与 IPC 行为。
-- 引擎层的 hspec 测试：语法、执行、优化器与存储链路行为。
-- | 测试表 users：id / name / age
users :: Table
users =
Table
@@ -40,6 +37,7 @@ users =
]
}
-- | 测试表 orders：id/user_id/product
orders :: Table
orders =
Table
@@ -52,12 +50,14 @@ orders =
]
}
-- | 两个测试表组成的默认库
testDB :: Database
testDB = [("users", users), ("orders", orders)]
-- | 跑引擎层全部 hspec 用例
main :: IO ()
main = hspec $ do
describe "ChuSQL.Syntax.Parser" $ do
describe "ChuSQL.Core.Engine.Syntax.Parser" $ do
it "resolves table-qualified columns inside database-qualified tables" $ do
let db = [("sales.users", users)]
rowsOf (parseStatement "SELECT users.name FROM sales.users WHERE users.id = 1" >>= runStatement db)
@@ -194,7 +194,7 @@ main = hspec $ do
parseStatement "SELECT name FROM"
`shouldSatisfy` isLeft
describe "ChuSQL.Syntax.Parser (JOIN)" $ do
describe "ChuSQL.Core.Engine.Syntax.Parser (JOIN)" $ do
it "parses a simple JOIN without aliases" $ do
parseStatement "SELECT name FROM users JOIN orders ON id = user_id"
`shouldBe` Right
@@ -263,8 +263,10 @@ main = hspec $ do
(Eq (Col "u.id") (Col "o.user_id"))
)
describe "ChuSQL.Engine (SELECT)" $ do
describe "ChuSQL.Core.Engine (SELECT)" $ do
-- sql：在默认库上跑 SQL 取结果行
let sql input = parseStatement input >>= rowsOf . runStatement testDB
-- values：只取结果里的值
values input = fmap (map (map snd)) (sql input)
it "skips line comments between tokens and at EOF" $ do
sql "-- start\nSELECT name -- list\nFROM users -- end" `shouldBe` sql "SELECT name FROM users"
@@ -415,7 +417,7 @@ main = hspec $ do
runStatement testDB (makeSelect ["nope"] "users" Nothing)
`shouldSatisfy` isLeft
describe "ChuSQL.Engine (INSERT)" $ do
describe "ChuSQL.Core.Engine (INSERT)" $ do
it "parses a simple INSERT" $ do
parseStatement "INSERT INTO users (name, age) VALUES ('Dave', 22)"
`shouldBe` Right (Insert "users" ["name", "age"] [[LitStr "Dave", LitInt 22]])
@@ -464,7 +466,7 @@ main = hspec $ do
runStatement testDB (Insert "users" ["id", "name"] [[LitInt 1, LitStr "A"], [LitInt 2]])
`shouldSatisfy` isLeft
describe "ChuSQL.Engine (INDEX)" $ do
describe "ChuSQL.Core.Engine (INDEX)" $ do
it "parses CREATE INDEX and DROP INDEX" $ do
parseStatement "CREATE INDEX ON users (age)"
`shouldBe` Right (CreateIndex "users" "age")
@@ -485,7 +487,7 @@ main = hspec $ do
rowsOf (parseStatement "DROP INDEX ON users (age)" >>= runStatement testDB)
`shouldBe` Right []
describe "ChuSQL.Engine (DROP COLUMN)" $ do
describe "ChuSQL.Core.Engine (DROP COLUMN)" $ do
it "parses ALTER TABLE ... DROP COLUMN case-insensitively" $ do
parseStatement "ALTER TABLE users DROP COLUMN age"
`shouldBe` Right (DropColumn "users" "age")
@@ -514,7 +516,7 @@ main = hspec $ do
it "the built-in id column cannot be dropped (the UI locates a row by it)" $ do
(parseStatement "ALTER TABLE users DROP COLUMN id" >>= runStatement testDB)
`shouldSatisfy` isLeft
describe "ChuSQL.Engine (USER)" $ do
describe "ChuSQL.Core.Engine (USER)" $ do
it "parses CREATE USER / ALTER USER / DROP USER case-insensitively" $ do
parseStatement "CREATE USER alice IDENTIFIED BY 's3cret'"
`shouldBe` Right (CreateUser "alice" "s3cret")
@@ -552,7 +554,7 @@ main = hspec $ do
(parseStatement "DROP USER alice" >>= runStatement testDB)
`shouldSatisfy` isLeft
describe "ChuSQL.Engine (ROLE)" $ do
describe "ChuSQL.Core.Engine (ROLE)" $ do
it "parses CREATE ROLE / DROP ROLE case-insensitively" $ do
parseStatement "CREATE ROLE analyst" `shouldBe` Right (CreateRole "analyst")
parseStatement "create role analyst" `shouldBe` Right (CreateRole "analyst")
@@ -616,7 +618,7 @@ main = hspec $ do
parseStatement "SELECT * FROM users user" `shouldSatisfy` isLeft
parseStatement "SELECT user1 FROM users" `shouldBe` Right (Select ["user1"] (FromTable Nothing "users") Nothing [] [] Nothing)
describe "ChuSQL.Engine (DELETE)" $ do
describe "ChuSQL.Core.Engine (DELETE)" $ do
it "parses DELETE with WHERE" $ do
parseStatement "DELETE FROM users WHERE age < 18"
`shouldBe` Right (Delete "users" (Just (Lt (Col "age") (LitInt 18))))
@@ -646,7 +648,7 @@ main = hspec $ do
runStatement testDB (Delete "users" (Just (Gt (Col "unknown") (LitInt 18))))
`shouldSatisfy` isLeft
describe "ChuSQL.Engine (UPDATE)" $ do
describe "ChuSQL.Core.Engine (UPDATE)" $ do
it "parses UPDATE with WHERE" $ do
parseStatement "UPDATE users SET age = 26 WHERE name = 'Alice'"
`shouldBe` Right
@@ -707,7 +709,7 @@ main = hspec $ do
runStatement testDB (Update "users" [("age", LitInt 0)] (Just (Gt (Col "unknown") (LitInt 1))))
`shouldSatisfy` isLeft
describe "ChuSQL.Engine (ORDER BY)" $ do
describe "ChuSQL.Core.Engine (ORDER BY)" $ do
it "parses ORDER BY DESC" $ do
case parseStatement "SELECT name FROM users ORDER BY age DESC" of
Right q -> selectOrderBy q `shouldBe` [("age", Desc)]
@@ -757,7 +759,7 @@ main = hspec $ do
, [("name", VStr "Bob")]
]
describe "ChuSQL.Engine (LIMIT)" $ do
describe "ChuSQL.Core.Engine (LIMIT)" $ do
it "parses LIMIT" $ do
case parseStatement "SELECT * FROM users LIMIT 2" of
Right q -> selectLimit q `shouldBe` Just 2
@@ -819,7 +821,7 @@ main = hspec $ do
parseStatement "SELECT * FROM users LIMIT -1"
`shouldSatisfy` isLeft
describe "ChuSQL.Engine (JOIN)" $ do
describe "ChuSQL.Core.Engine (JOIN)" $ do
it "executes a two-table JOIN with aliases" $ do
rowsOf (parseStatement "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id" >>= runStatement testDB)
`shouldBe` Right
@@ -870,7 +872,8 @@ main = hspec $ do
)
`shouldSatisfy` isLeft
describe "ChuSQL.Engine (LEFT JOIN)" $ do
describe "ChuSQL.Core.Engine (LEFT JOIN)" $ do
-- sql：在默认库上跑 SQL 取结果行
let sql input = parseStatement input >>= rowsOf . runStatement testDB
it "keeps unmatched left rows and fills the right side with NULL" $ do
@@ -930,7 +933,8 @@ main = hspec $ do
, [("u.name", VStr "Carol"), ("o.product", VStr "Cup")]
]
describe "ChuSQL.Engine (JOIN 嵌套循环)" $ do
describe "ChuSQL.Core.Engine (JOIN 嵌套循环)" $ do
-- sql：在默认库上跑 SQL 取结果行
let sql input = parseStatement input >>= rowsOf . runStatement testDB
it "keeps columns from both sides when the ON has no equi key" $ do
@@ -943,7 +947,8 @@ main = hspec $ do
, [("u.name", VStr "Carol"), ("o.product", VStr "Cup")]
]
describe "ChuSQL.Engine (子查询)" $ do
describe "ChuSQL.Core.Engine (子查询)" $ do
-- sql：在默认库上跑 SQL 取结果行
let sql input = parseStatement input >>= rowsOf . runStatement testDB
it "IN (subquery) keeps the rows whose value the subquery returns" $ do
@@ -997,9 +1002,12 @@ main = hspec $ do
sameResultAsUnoptimized "SELECT name FROM users WHERE id IN (SELECT user_id FROM orders)"
sameResultAsUnoptimized "SELECT u.name FROM users u WHERE EXISTS (SELECT * FROM orders o WHERE o.user_id = u.id)"
describe "ChuSQL.Engine (聚合与 GROUP BY)" $ do
describe "ChuSQL.Core.Engine (聚合与 GROUP BY)" $ do
-- sql：在默认库上跑 SQL 取结果行
let sql input = parseStatement input >>= rowsOf . runStatement testDB
-- sqlDb：在指定库上跑 SQL
sqlDb db input = parseStatement input >>= rowsOf . runStatement db
-- vals：只取结果里的值
vals input = fmap (map (map snd)) (sql input)
it "counts rows without GROUP BY" $ do
@@ -1104,7 +1112,7 @@ main = hspec $ do
[ [("name", VStr "Carol")]
]
describe "ChuSQL.Algebra.Optimize" $ do
describe "ChuSQL.Core.Engine.Algebra.Optimize" $ do
it "keeps single-table WHERE results identical" $ do
sameResultAsUnoptimized "SELECT name FROM users WHERE age > 18"
@@ -1285,7 +1293,7 @@ main = hspec $ do
rowsOf (parseStatement "SELECT u.name FROM users u WHERE u.id = 1" >>= runStatement testDB)
`shouldBe` Right [[("u.name", VStr "Alice")]]
describe "ChuSQL.Semantic" $ do
describe "ChuSQL.Core.Engine.Semantic" $ do
it "rejects an unknown column in WHERE" $ do
(parseStatement "SELECT name FROM users WHERE nope > 18" >>= runStatement testDB)
`shouldSatisfy` isLeft
@@ -1386,7 +1394,7 @@ main = hspec $ do
(parseStatement "SELECT * FROM users u JOIN orders o ON u.id = o.user_id" >>= runStatement testDB)
`shouldSatisfy` isRight
describe "ChuSQL.Algebra.Op" $ do
describe "ChuSQL.Core.Engine.Algebra.Op" $ do
it "renders a plan as indented text" $ do
case parseStatement "SELECT name FROM users WHERE age > 18" >>= translate of
Left err -> expectationFailure err
@@ -1405,12 +1413,13 @@ main = hspec $ do
, " Scan Just \"o\" \"orders\""
]
describe "ChuSQL.Storage.IPC" $ do
it "projects scan columns and preserves constant rows over the pipe" $ do
withTestServer $ \srv -> withServerEnv srv $ do
describe "ChuSQL.Core.Engine.Storage.IPC" $ do
it "projects scan columns and preserves constant rows" $ do
withTestSession $ \srv -> withServerEnv srv $ do
runIPCStorage (insertMany "projected" [[("id", VInt 1), ("name", VStr "one")], [("id", VInt 2), ("name", VNull)]]) `shouldReturn` Right ()
runIPCStorage (scanColumns "projected" ["name"]) `shouldReturn` Right [[("name", VStr "one")], [("name", VNull)]]
runIPCStorage (scanColumns "projected" []) `shouldReturn` Right [[], []]
-- query：解析并执行一条 SQL
let query sql = case parseStatement sql of
Left err -> expectationFailure err >> pure (Left err)
Right stmt -> runIPCStorage (runStatementM stmt)
@@ -1418,8 +1427,9 @@ main = hspec $ do
fmap (map (map snd)) result `shouldBe` Right [[VInt 1], [VInt 1]]
query "SELECT p.name FROM projected p ORDER BY p.id DESC" `shouldReturn` Right [[("p.name", VNull)], [("p.name", VStr "one")]]
it "recreates a dropped column without resurrecting old values over the pipe" $ do
withTestServer $ \srv -> withServerEnv srv $ do
it "recreates a dropped column without resurrecting old values" $ do
withTestSession $ \srv -> withServerEnv srv $ do
-- query：解析并执行一条 SQL
let query sql = case parseStatement sql of
Left err -> expectationFailure err >> pure (Left err)
Right stmt -> runIPCStorage (runStatementM stmt)
@@ -1433,19 +1443,19 @@ main = hspec $ do
query "SELECT secret FROM reused WHERE id = 1" `shouldReturn` Right [[("secret", VStr "new")]]
it "scan returns rows with all three value types after insert" $ do
withTestServer $ \srv -> withServerEnv srv $ do
withTestSession $ \srv -> withServerEnv srv $ do
let row = [("id", VInt 7), ("name", VStr "Alice"), ("flag", VBool True)]
runIPCStorage (insert "users" row) `shouldReturn` Right ()
rows <- runIPCStorage (scan "users")
(map sortRow <$> rows) `shouldBe` Right [sortRow row]
it "scan on a missing table returns Left" $ do
withTestServer $ \srv -> withServerEnv srv $ do
withTestSession $ \srv -> withServerEnv srv $ do
result <- runIPCStorage (scan "no_such_table")
result `shouldSatisfy` isLeft
it "scan returns all 20 inserted rows in order" $ do
withTestServer $ \srv -> withServerEnv srv $ do
withTestSession $ \srv -> withServerEnv srv $ do
mapM_ (\i -> runIPCStorage (insert "many" [("id", VInt i)])) [1 .. 20 :: Int]
rows <- runIPCStorage (scan "many")
fmap length rows `shouldBe` Right 20
@@ -1453,15 +1463,15 @@ main = hspec $ do
`shouldBe` Right (sortOn show (map (Just . VInt) [1 .. 20]))
it "replaceAll leaves only the new rows" $ do
withTestServer $ \srv -> withServerEnv srv $ do
withTestSession $ \srv -> withServerEnv srv $ do
runIPCStorage (insert "t" [("id", VInt 1)]) `shouldReturn` Right ()
runIPCStorage (replaceAll "t" [[("id", VInt 9)], [("id", VInt 8)]]) `shouldReturn` Right ()
rows <- runIPCStorage (scan "t")
fmap (sortOn show . map (lookup "id")) rows
`shouldBe` Right (sortOn show [Just (VInt 9), Just (VInt 8)])
it "lookupByColumn finds a row inserted with an id over the pipe" $ do
withTestServer $ \srv -> withServerEnv srv $ do
it "lookupByColumn finds a row inserted with an id" $ do
withTestSession $ \srv -> withServerEnv srv $ do
let row = [("id", VInt 7), ("name", VStr "Zoe")]
runIPCStorage (insert "keyed" row) `shouldReturn` Right ()
found <- runIPCStorage (lookupByColumn "keyed" "id" (VInt 7))
@@ -1469,8 +1479,8 @@ main = hspec $ do
missing <- runIPCStorage (lookupByColumn "keyed" "id" (VInt 8))
missing `shouldBe` Right (IndexRows [])
it "looks up a string index over the pipe" $ do
withTestServer $ \srv -> withServerEnv srv $ do
it "looks up a string index" $ do
withTestSession $ \srv -> withServerEnv srv $ do
runIPCStorage (insert "names" [("id", VInt 1), ("name", VStr "alice")]) `shouldReturn` Right ()
runIPCStorage (insert "names" [("id", VInt 2), ("name", VStr "bob")]) `shouldReturn` Right ()
runIPCStorage (createIndex "names" "name") `shouldReturn` Right ()
@@ -1479,8 +1489,8 @@ main = hspec $ do
missing <- runIPCStorage (lookupByColumn "names" "name" (VStr "dave"))
missing `shouldBe` Right (IndexRows [])
it "range scans an indexed column over the pipe" $ do
withTestServer $ \srv -> withServerEnv srv $ do
it "range scans an indexed column" $ do
withTestSession $ \srv -> withServerEnv srv $ do
runIPCStorage (insert "rng" [("id", VInt 1), ("code", VInt 100)]) `shouldReturn` Right ()
runIPCStorage (insert "rng" [("id", VInt 2), ("code", VInt 200)]) `shouldReturn` Right ()
runIPCStorage (insert "rng" [("id", VInt 3), ("code", VInt 300)]) `shouldReturn` Right ()
@@ -1491,8 +1501,8 @@ main = hspec $ do
fmap (fmap (map (lookup "id"))) open `shouldBe` Right (Just [Just (VInt 3)])
runIPCStorage (scanRange "rng" "nope" Nothing Nothing) `shouldReturn` Right Nothing
it "replaceAll rebuilds the index over the pipe" $ do
withTestServer $ \srv -> withServerEnv srv $ do
it "replaceAll rebuilds the index" $ do
withTestSession $ \srv -> withServerEnv srv $ do
runIPCStorage (insert "rb" [("id", VInt 1)]) `shouldReturn` Right ()
runIPCStorage (replaceAll "rb" [[("id", VInt 9), ("name", VStr "Zoe")]]) `shouldReturn` Right ()
old <- runIPCStorage (lookupByColumn "rb" "id" (VInt 1))
@@ -1502,7 +1512,7 @@ main = hspec $ do
`shouldBe` Just (sortRow [("id", VInt 9), ("name", VStr "Zoe")])
it "snapshot lists tables and scans each one to build the database" $ do
withTestServer $ \srv -> withServerEnv srv $ do
withTestSession $ \srv -> withServerEnv srv $ do
runIPCStorage (insert "a" [("id", VInt 1)]) `shouldReturn` Right ()
runIPCStorage (insert "b" [("id", VInt 2)]) `shouldReturn` Right ()
db <- runIPCStorage snapshot
@@ -1511,38 +1521,31 @@ main = hspec $ do
map (map (lookup "id") . tableRows . snd) db `shouldBe` [[Just (VInt 1)], [Just (VInt 2)]]
it "doListTables returns the tables that exist" $ do
withTestServer $ \srv -> withServerEnv srv $ do
withTestSession $ \srv -> withServerEnv srv $ do
runIPCStorage (insert "t1" [("id", VInt 1)]) `shouldReturn` Right ()
runIPCStorage (insert "t2" [("id", VInt 2)]) `shouldReturn` Right ()
doListTables `shouldReturn` Right ["t1", "t2"]
it "rows survive a restart on the same data directory" $ do
located <- locateServer
case located of
Left err -> pendingWith err
Right bin -> do
srv1 <- startServer bin
let dir = dataDir srv1
withServerEnv srv1 $ runIPCStorage (insert "persist" [("id", VInt 42)]) `shouldReturn` Right ()
stopServer srv1
srv2 <- startServerAt bin dir
rows <- withServerEnv srv2 $ runIPCStorage (scan "persist")
stopServer srv2
cleanServerDir srv1
withTestSession $ \srv -> do
withServerEnv srv $ runIPCStorage (insert "persist" [("id", VInt 42)]) `shouldReturn` Right ()
closeConnection
openSessionIn (dataDir srv)
rows <- withServerEnv srv $ runIPCStorage (scan "persist")
(map sortRow <$> rows) `shouldBe` Right [sortRow [("id", VInt 42)]]
it "a missing server yields Left without throwing" $ do
withPipeName "chusql-no-such-server" $ do
it "an unusable config path yields Left without throwing" $ do
opened <- localStorageLink (Just "no/such/dir/chusql-core-storage.toml")
case opened of
Left err -> err `shouldSatisfy` (not . null)
Right _ -> expectationFailure "opening a missing config file should fail"
it "without a link the storage layer reports Left instead of throwing" $ do
closeConnection
result <- runIPCStorage (scan "users")
result `shouldSatisfy` isLeft
#if !defined(mingw32_HOST_OS)
it "an over-long socket path is reported instead of a raw connect failure" $ do
withPipeName (replicate 128 'x') $ do
result <- runIPCStorage (scan "users")
show result `shouldSatisfy` isInfixOf "socket path too long"
#endif
it "INSERT then SELECT WHERE id = k via IPC" $ do
withTestServer $ \srv -> withServerEnv srv $ do
it "INSERT then SELECT WHERE id = k" $ do
withTestSession $ \srv -> withServerEnv srv $ do
_ <-
runIPCStorage
( runStatementM
@@ -1567,13 +1570,11 @@ main = hspec $ do
)
)
result `shouldBe` Right [[("name", VStr "Zoe")]]
stopServer srv
logs <- readFile (dataDir srv </> "debug.log")
logs `shouldContain` "lookup_by_index table=ipc_idx column=id key=42"
logs `shouldNotContain` "scan table="
-- 存储层的日志现在直接打在本进程的输出里，没有单独的 debug.log 可读；
-- 「走索引而不是全表扫」由下面 CREATE INDEX 那组用例与 Rust 侧 runtime 测试覆盖。
it "CREATE INDEX makes a query on that column use the index" $ do
withTestServer $ \srv -> withServerEnv srv $ do
withTestSession $ \srv -> withServerEnv srv $ do
_ <- runIPCStorage (runStatementM (CreateTable "ix_t" [("id", TInt), ("code", TInt)]))
_ <-
runIPCStorage
@@ -1599,8 +1600,8 @@ main = hspec $ do
fmap sortRow (indexRow fresh)
`shouldBe` Just (sortRow [("id", VInt 3), ("code", VInt 502)])
it "CREATE INDEX over the pipe accepts duplicates and returns every matching row" $ do
withTestServer $ \srv -> withServerEnv srv $ do
it "CREATE INDEX accepts duplicates and returns every matching row" $ do
withTestSession $ \srv -> withServerEnv srv $ do
_ <- runIPCStorage (runStatementM (CreateTable "dup_ix" [("id", TInt), ("age", TInt)]))
_ <-
runIPCStorage
@@ -1614,8 +1615,8 @@ main = hspec $ do
Right (IndexRows rows) -> map (lookup "id") rows `shouldBe` [Just (VInt 1), Just (VInt 2)]
_ -> expectationFailure "expected an indexed lookup with rows"
it "DELETE removes only the matching rows over the pipe" $ do
withTestServer $ \srv -> withServerEnv srv $ do
it "DELETE removes only the matching rows" $ do
withTestSession $ \srv -> withServerEnv srv $ do
_ <- runIPCStorage (runStatementM (CreateTable "del_t" [("id", TInt), ("name", TStr)]))
_ <-
runIPCStorage
@@ -1632,8 +1633,8 @@ main = hspec $ do
gone <- runIPCStorage (lookupByColumn "del_t" "id" (VInt 2))
gone `shouldBe` Right (IndexRows [])
it "multi-row INSERT goes over the pipe in one statement" $ do
withTestServer $ \srv -> withServerEnv srv $ do
it "multi-row INSERT goes in one statement" $ do
withTestSession $ \srv -> withServerEnv srv $ do
_ <- runIPCStorage (runStatementM (CreateTable "many_t" [("id", TInt)]))
_ <-
runIPCStorage
@@ -1676,7 +1677,7 @@ main = hspec $ do
parseStatement "CREATE TABLE t (id)"
`shouldSatisfy` isLeft
describe "ChuSQL.Engine (CREATE TABLE)" $ do
describe "ChuSQL.Core.Engine (CREATE TABLE)" $ do
it "creates a table in memory" $ do
case runStatement testDB (CreateTable "newt" [("id", TInt), ("name", TStr)]) of
Left err -> expectationFailure err
@@ -1710,8 +1711,10 @@ main = hspec $ do
runStatement testDB (DropTable "nope")
`shouldSatisfy` isLeft
describe "ChuSQL.Engine (NULL)" $ do
describe "ChuSQL.Core.Engine (NULL)" $ do
-- rows：在给定库上跑 SQL 取结果行
let rows db input = parseStatement input >>= rowsOf . runStatement db
-- vals：只取结果里的值
vals db input = fmap (map (map snd)) (rows db input)
seeded = either (const testDB) fst (parseStatement "INSERT INTO users (id, name) VALUES (9, 'Nine')" >>= runStatement testDB)
@@ -1743,8 +1746,10 @@ main = hspec $ do
vals seeded "SELECT age + 1 FROM users WHERE name = 'Nine'" `shouldBe` Right [[VNull]]
vals seeded "SELECT age * 2 FROM users WHERE name = 'Nine'" `shouldBe` Right [[VNull]]
describe "ChuSQL.Engine (TYPES)" $ do
describe "ChuSQL.Core.Engine (TYPES)" $ do
-- vals：在给定库上跑 SQL 只取值
let vals db input = fmap (map (map snd)) (parseStatement input >>= rowsOf . runStatement db)
-- withTable：先建表，返回新库
withTable ddl = either (const testDB) fst (parseStatement ddl >>= runStatement testDB)
it "parses every column type" $ do
@@ -1788,9 +1793,12 @@ main = hspec $ do
runStatement db (Insert "sized" ["d"] [[LitInt 5]])
`shouldSatisfy` isLeft
describe "ChuSQL.Engine (CONSTRAINTS)" $ do
describe "ChuSQL.Core.Engine (CONSTRAINTS)" $ do
-- vals：在给定库上跑 SQL 只取值
let vals db input = fmap (map (map snd)) (parseStatement input >>= rowsOf . runStatement db)
-- withTable：先建表，返回新库
withTable ddl = either (const testDB) fst (parseStatement ddl >>= runStatement testDB)
-- step：执行一条语句，失败就返回原库
step db input = either (const db) fst (parseStatement input >>= runStatement db)
it "rejects omitting a NOT NULL column without a default" $ do
@@ -1819,10 +1827,14 @@ main = hspec $ do
`shouldSatisfy` either (isInfixOf "CHECK") (const False)
vals (step db "INSERT INTO ck (age) VALUES (5)") "SELECT age FROM ck" `shouldBe` Right [[VInt 5]]
describe "ChuSQL.Engine (ALTER TABLE)" $ do
describe "ChuSQL.Core.Engine (ALTER TABLE)" $ do
-- vals：在给定库上跑 SQL 只取值
let vals db input = fmap (map (map snd)) (parseStatement input >>= rowsOf . runStatement db)
-- run：在给定库上执行语句
run db input = parseStatement input >>= runStatement db
-- withTable：先建表，返回新库
withTable ddl = either (const testDB) fst (parseStatement ddl >>= runStatement testDB)
-- step：执行一条语句，失败就返回原库
step db input = either (const db) fst (run db input)
it "ADD COLUMN fills existing rows with the default or NULL" $ do
@@ -1865,77 +1877,18 @@ main = hspec $ do
run nulls "ALTER TABLE nl ALTER COLUMN tag DROP NOT NULL" `shouldSatisfy` isRight
run strict "ALTER TABLE nl2 ALTER COLUMN tag DROP NOT NULL" `shouldSatisfy` isRight
-- | 每个测试表都清空行后的库
emptyDB :: Database
emptyDB = [(n, t{tableRows = []}) | (n, t) <- testDB]
data IPCServer = IPCServer
{ pipeName :: String
, dataDir :: FilePath
, processHandle :: ProcessHandle
-- | 一次进程内存储会话：进程内直连存储动态库
data StorageSession = StorageSession
{ dataDir :: FilePath
}
locateServer :: IO (Either String FilePath)
locateServer = do
mdir <- firstDir [".." </> "chusql-storage", "chusql-storage"]
case mdir of
Nothing -> pure (Left "chusql-storage directory not found (run these tests inside the repository)")
Just dir -> do
built <-
try (createProcess (proc "cargo" ["build", "--bin", "chusql-storage"]){cwd = Just dir, std_out = NoStream, std_err = NoStream}) ::
IO (Either IOException (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
case built of
Left e -> pure (Left ("cannot run cargo (Rust is required for the IPC tests): " ++ show e))
Right (_, _, _, ph) -> do
ec <- waitForProcess ph
case ec of
ExitFailure n -> pure (Left ("cargo build --bin chusql-storage failed with exit code " ++ show n))
ExitSuccess -> do
-- 二进制名跟平台走：Linux 上没有 .exe，而 target/debug 里可能
-- 残留一份别处交叉编译出来的 .exe。误选它会以 Windows 的视角
-- 读配置（/tmp/x.toml 变成 C:\tmp\x.toml），报 config file not found。
#if defined(mingw32_HOST_OS)
let candidate = dir </> "target" </> "debug" </> "chusql-storage.exe"
#else
let candidate = dir </> "target" </> "debug" </> "chusql-storage"
#endif
ok <- doesFileExist candidate
pure
( if ok
then Right candidate
else Left ("cargo build finished but no storage executable was found at " ++ candidate)
)
where
firstDir [] = pure Nothing
firstDir (d : ds) = do
ok <- doesDirectoryExist d
if ok then pure (Just d) else firstDir ds
startServer :: FilePath -> IO IPCServer
startServer bin = do
stamp <- uniqueStamp
tmp <- getTemporaryDirectory
let dir = tmp </> "chusql-hs-IPC" </> stamp
createDirectoryIfMissing True dir
startServerAt bin dir
startServerAt :: FilePath -> FilePath -> IO IPCServer
startServerAt bin dir = do
stamp <- uniqueStamp
let name = "chusql-hs-test-" ++ stamp
cfgPath <- writeServerConfig dir name
(_, _, _, ph) <- withFile (dir </> "debug.log") WriteMode $ \logHandle ->
createProcess
(proc bin ["--config", cfgPath])
{ std_out = UseHandle logHandle
, std_err = UseHandle logHandle
}
let srv = IPCServer name dir ph
waitUntilReady srv 100
pure srv
-- | 给存储进程写一份顺手可用的配置：管名、数据目录与日志级别都从文件走
writeServerConfig :: FilePath -> String -> IO FilePath
writeServerConfig dir name = do
-- | 写一份只属于这次会话的配置：数据目录与日志级别都从文件走
writeSessionConfig :: FilePath -> IO FilePath
writeSessionConfig dir = do
let cfgPath = dir ++ ".toml"
-- TOML 的普通字符串会吃反斜杠，路径统一用正斜杠
slashed = map (\c -> if c == '\\' then '/' else c) dir
@@ -1944,14 +1897,27 @@ writeServerConfig dir name = do
( unlines
[ "[storage]"
, "data_dir = \"" ++ slashed ++ "\""
, "[server]"
, "pipe_name = \"" ++ name ++ "\""
, "[log]"
, "level = \"debug\""
]
)
pure cfgPath
-- | 打开一份存储，并把它装成引擎当前用的链路
openSessionAt :: FilePath -> IO (Either String StorageSession)
openSessionAt dir = do
cfgPath <- writeSessionConfig dir
opened <- localStorageLink (Just cfgPath)
case opened of
Left e -> pure (Left ("cannot open the chusql_core_storage library: " ++ e))
Right link -> do
setStorageLink link
pure (Right (StorageSession dir))
-- | 用同一份数据目录再开一次（模拟重启）
openSessionIn :: FilePath -> IO ()
openSessionIn dir = openSessionAt dir >>= either fail (const (pure ()))
-- | 每次调用都不同的后缀：CPU 时间加唯一编号
uniqueStamp :: IO String
uniqueStamp = do
@@ -1959,50 +1925,52 @@ uniqueStamp = do
u <- hashUnique <$> newUnique
pure (show cpu ++ "-" ++ show u)
waitUntilReady :: IPCServer -> Int -> IO ()
waitUntilReady srv tries = do
probe <- try (withServerEnv srv (sendRequest ReqPing)) :: IO (Either IOException Response)
case probe of
Right RespPong -> pure ()
_ | tries > 0 -> threadDelay 50000 >> waitUntilReady srv (tries - 1)
Right _ -> ioError (userError "server is up but the ping answer was not pong")
Left e -> ioError e
stopServer :: IPCServer -> IO ()
stopServer srv = do
_ <- try (terminateProcess (processHandle srv)) :: IO (Either IOException ())
_ <- try (waitForProcess (processHandle srv)) :: IO (Either IOException ExitCode)
-- | 删掉会话的数据目录与配置文件
cleanSessionDir :: FilePath -> IO ()
cleanSessionDir dir = do
_ <- try (removePathForcibly dir) :: IO (Either IOException ())
_ <- try (removePathForcibly (dir ++ ".toml")) :: IO (Either IOException ())
pure ()
cleanServerDir :: IPCServer -> IO ()
cleanServerDir srv = do
_ <- try (removePathForcibly (dataDir srv)) :: IO (Either IOException ())
_ <- try (removePathForcibly (dataDir srv ++ ".toml")) :: IO (Either IOException ())
pure ()
-- | 一个用例一份干净数据目录；动态库打不开则 pending
withTestSession :: (StorageSession -> IO ()) -> IO ()
withTestSession act = do
tmp <- getTemporaryDirectory
stamp <- uniqueStamp
let dir = tmp </> "chusql-hs-IPC" </> stamp
createDirectoryIfMissing True dir
opened <- openSessionAt dir
case opened of
Left err -> cleanSessionDir dir >> pendingWith err
Right session -> act session `finally` (closeConnection >> cleanSessionDir dir)
withTestServer :: (IPCServer -> IO ()) -> IO ()
withTestServer act = do
located <- locateServer
case located of
Left err
| "cannot run cargo" `isInfixOf` err -> pendingWith err
| otherwise -> expectationFailure err
Right bin -> bracket (startServer bin) (\s -> stopServer s >> cleanServerDir s) act
-- | 语句不带库名，先建好测试库再切进去
withServerEnv :: StorageSession -> IO a -> IO a
withServerEnv _srv act = do
oldDb <- getDatabaseName
ensureTestDatabase
setDatabaseName (Just testDatabase)
act `finally` setDatabaseName oldDb
withServerEnv :: IPCServer -> IO a -> IO a
withServerEnv srv act = do
old <- getPipeName
setPipeName (pipeName srv)
act `finally` setPipeName old
-- | IPC 用例使用的库名
testDatabase :: String
testDatabase = "ipctest"
withPipeName :: String -> IO a -> IO a
withPipeName name act = do
old <- getPipeName
setPipeName name
r <- act
setPipeName old
pure r
-- | 保证测试库已存在
ensureTestDatabase :: IO ()
ensureTestDatabase = do
listed <- runIPCStorage listDatabases
case listed of
Left e -> fail ("cannot list databases through the storage library: " ++ e)
Right names
| testDatabase `elem` names -> pure ()
| otherwise -> do
created <- runIPCStorage (createDatabase testDatabase)
case created of
Right () -> pure ()
Left e -> fail ("cannot create the test database: " ++ e)
-- | 按列名把一行排序
sortRow :: Row -> Row
sortRow = sortOn fst
@@ -2011,14 +1979,17 @@ indexRow :: Either String IndexResult -> Maybe Row
indexRow (Right (IndexRows (r : _))) = Just r
indexRow _ = Nothing
-- | 判断 Either 是 Left
isLeft :: Either a b -> Bool
isLeft (Left _) = True
isLeft (Right _) = False
-- | 判断 Either 是 Right
isRight :: Either a b -> Bool
isRight (Right _) = True
isRight (Left _) = False
-- | 断言优化前后执行结果一致
sameResultAsUnoptimized :: String -> Expectation
sameResultAsUnoptimized sql =
case parseStatement sql >>= prepare testDB of
@@ -2029,6 +2000,7 @@ sameResultAsUnoptimized sql =
Right relOp ->
evalRelOp testDB (optimize testDB relOp) `shouldBe` evalRelOp testDB relOp
-- | 判断谓词是否下推到 Join 左子树
filterPushedIntoLeft :: RelOp -> Bool
filterPushedIntoLeft (Project _ (Join _ l _ _)) = pushedIntoLeft l
filterPushedIntoLeft _ = False
@@ -2040,6 +2012,7 @@ pushedIntoLeft (Range _ _ _ _ _) = True
pushedIntoLeft (Project _ x) = pushedIntoLeft x
pushedIntoLeft _ = False
-- | 解析并优化 SQL，返回计划
optimizedPlan :: String -> Either String RelOp
optimizedPlan sql = do
q <- parseStatement sql
@@ -2056,6 +2029,7 @@ leftJoinKinds (Sort _ x) = leftJoinKinds x
leftJoinKinds (Limit _ x) = leftJoinKinds x
leftJoinKinds _ = []
-- | 取计划里第一个过滤条件
firstFilterCond :: RelOp -> Maybe Expr
firstFilterCond (Filter p _) = Just p
firstFilterCond (Project _ x) = firstFilterCond x
@@ -2071,6 +2045,7 @@ firstFilterCond (Scan _ _ _) = Nothing
firstFilterCond (Lookup _ _ _ _) = Nothing
firstFilterCond (Range _ _ _ _ _) = Nothing
-- | 判断计划里是否还有过滤节点
anyFilter :: RelOp -> Bool
anyFilter (Filter _ _) = True
anyFilter (Project _ x) = anyFilter x
@@ -2084,6 +2059,7 @@ anyFilter (Scan _ _ _) = False
anyFilter (Lookup _ _ _ _) = False
anyFilter (Range _ _ _ _ _) = False
-- | 去掉计划里的投影节点
stripProjects :: RelOp -> RelOp
stripProjects (Project _ x) = stripProjects x
stripProjects (Compute items x) = Compute items (stripProjects x)
@@ -2097,29 +2073,35 @@ stripProjects (Scan a t _) = Scan a t Nothing
stripProjects (Lookup a t c k) = Lookup a t c k
stripProjects (Range a t c lo hi) = Range a t c lo hi
-- | 解析并做投影下推，返回计划
projectedPlan :: String -> Either String RelOp
projectedPlan sql = do
q <- parseStatement sql
plan <- translate q
Right (pushProject testDB ["*"] plan)
-- | 取节点输出的列名
sideCols :: RelOp -> Maybe [String]
sideCols (Project cols _) = Just cols
sideCols (Scan a _ cols) = fmap (map (qualify a)) cols
sideCols _ = Nothing
-- | 取 Join 左右两侧的输出列名
joinSideCols :: RelOp -> (Maybe [String], Maybe [String])
joinSideCols (Project _ (Join _ l r _)) = (sideCols l, sideCols r)
joinSideCols _ = (Nothing, Nothing)
-- | 数左子树里过滤节点的个数
countFilters :: RelOp -> Int
countFilters (Filter _ x) = 1 + countFilters x
countFilters _ = 0
-- | 取 Join 左侧过滤节点数
leftSideFilters :: RelOp -> Maybe Int
leftSideFilters (Project _ (Join _ l _ _)) = Just (countFilters l)
leftSideFilters _ = Nothing
-- | 去掉外层投影，返回真正的根节点
planRoot :: RelOp -> RelOp
planRoot (Project _ x) = planRoot x
planRoot x = x
chusql-core/model/chusql-core-model.cabal
+21
View File
@@ -0,0 +1,21 @@
cabal-version: 2.4
name: chusql-core-model
version: 1.0.0
synopsis: ChuSQL 共用数据模型与线上协议类型
description: ChuSQL 各进程共用的纯数据类型：列与值的模型、存储层线上协议
（请求/响应/表结构与账号）以及查询结果集。这里不放任何执行
逻辑，前端只依赖这个包就不会把引擎链进自己的二进制。
build-type: Simple
library
hs-source-dirs: src
exposed-modules: ChuSQL.Core.Model
ChuSQL.Core.Protocol
build-depends: base >= 4.14 && < 5
, aeson
, hashable
, scientific
, text
default-language: Haskell2010
ghc-options: -Wall
chusql-engine/src/ChuSQL/Model.hs → chusql-core/model/src/ChuSQL/Core/Model.hs
+29 -3
View File
@@ -1,6 +1,6 @@
{-# LANGUAGE PatternSynonyms #-}
module ChuSQL.Model
module ChuSQL.Core.Model
( ColumnType (..)
, Column (..)
, pattern TInt
@@ -35,7 +35,7 @@ import Data.Hashable (Hashable (..))
import Data.List (isSuffixOf, stripPrefix)
import Data.Maybe (fromMaybe)
-- 数据模型：列类型、列约束、值、行、表、数据库，外加几个查表小工具。
-- 数据模型：列类型、列约束、值、行、表、数据库，外加查表小工具。
-- | 列的基础类型
data ColumnType
@@ -70,16 +70,19 @@ data Column = Column
plainColumn :: ColumnType -> Column
plainColumn t = Column t True Nothing False False False Nothing
-- | 普通整型列的匹配模式
pattern TInt :: Column
pattern TInt <- Column CInt _ _ _ _ _ _
where
TInt = plainColumn CInt
-- | 普通字符串列的匹配模式
pattern TStr :: Column
pattern TStr <- Column CStr _ _ _ _ _ _
where
TStr = plainColumn CStr
-- | 普通布尔列的匹配模式
pattern TBool :: Column
pattern TBool <- Column CBool _ _ _ _ _ _
where
@@ -146,8 +149,11 @@ parseColumnType raw = case (base, args) of
("blob", []) -> Just CBlob
_ -> Nothing
where
-- | 去掉空白的类型名
cleaned = map toLower (filter (not . isSpace) raw)
-- | 基础名与参数段
(base, rest) = span (/= '(') cleaned
-- | 括号里的参数表
args = case stripSuffixMaybe ")" (drop 1 rest) of
Nothing -> []
Just inner -> map (filter (not . isSpace)) (splitOn ',' inner)
@@ -193,6 +199,7 @@ data TypeClass
| BooleanClass
deriving (Show, Eq)
-- | 整型大类判断
typeClassOf :: ColumnType -> TypeClass
typeClassOf CInt = NumericClass
typeClassOf CBigInt = NumericClass
@@ -216,12 +223,14 @@ assignable target source
| typeClassOf target == TemporalClass && typeClassOf source == TextClass = True
| otherwise = False
-- | 是不是整数类型
integerType :: ColumnType -> Bool
integerType CInt = True
integerType CBigInt = True
integerType CSmallInt = True
integerType _ = False
-- | 是不是数值类型
numericType :: ColumnType -> Bool
numericType t = typeClassOf t == NumericClass
@@ -264,6 +273,7 @@ coerceValue t v = case t of
CTimestamp -> toTimestamp v
CBlob -> toText t v
-- | 整数收进整型列
toInt :: ColumnType -> Value -> Either String Value
toInt _ (VInt n) = Right (VInt n)
toInt t (VFloat d) = case properFraction d :: (Int, Double) of
@@ -272,6 +282,7 @@ toInt t (VFloat d) = case properFraction d :: (Int, Double) of
| otherwise -> Left ("cannot put a fractional number into " ++ typeLabel t)
toInt t _ = Left ("cannot put this value into " ++ typeLabel t)
-- | 数值收进浮点列
toFloat :: ColumnType -> Value -> Either String Value
toFloat _ (VInt n) = Right (VFloat (fromIntegral n))
toFloat _ (VFloat d) = Right (VFloat d)
@@ -284,29 +295,36 @@ toDecimal p s v = case v of
VFloat d -> rounded d
_ -> Left ("cannot put this value into " ++ typeLabel (CDecimal p s))
where
-- | 缩放因子
scale = (10 :: Double) ^ max 0 s
-- | 按比例四舍五入
rounded d = Right (VFloat (fromIntegral (round (d * scale) :: Integer) / scale))
-- | 字符串收进文本列
toText :: ColumnType -> Value -> Either String Value
toText _ (VStr s) = Right (VStr s)
toText t _ = Left ("cannot put this value into " ++ typeLabel t)
-- | 按列长度限制收字符串
toSized :: Int -> Value -> Either String Value
toSized n (VStr s)
| length s <= n = Right (VStr s)
| otherwise = Left ("value is longer than " ++ show n ++ " characters")
toSized _ _ = Left "cannot put this value into a character column"
-- | 布尔收进布尔列
toBool :: ColumnType -> Value -> Either String Value
toBool _ (VBool b) = Right (VBool b)
toBool t _ = Left ("cannot put this value into " ++ typeLabel t)
-- | 字符串收进日期列
toDate :: Value -> Either String Value
toDate (VStr s)
| validDateText s = Right (VStr s)
| otherwise = Left "date must look like YYYY-MM-DD"
toDate _ = Left "date must be a string"
-- | 字符串收进时间戳列
toTimestamp :: Value -> Either String Value
toTimestamp (VStr s)
| validTimestampText s = Right (VStr s)
@@ -319,7 +337,7 @@ validDateText s = case splitOn '-' s of
[y, m, d] -> allOf 4 y && allOf 2 m && allOf 2 d
_ -> False
-- | YYYY-MM-DD HH:MM:SS，日期与时间之间允许空格或 T
-- | 日期时间格式；中间允许空格或 T
validTimestampText :: String -> Bool
validTimestampText s = case break (\c -> c == ' ' || c == 'T') s of
(d, _ : tm) -> validDateText d && validTimeText tm
@@ -331,10 +349,12 @@ validTimeText t = case splitOn ':' t of
[h, m, sec] -> allOf 2 h && allOf 2 m && allOf 2 sec
_ -> False
-- | 一段字符串是不是固定长度的数字
allOf :: Int -> String -> Bool
allOf n s = length s == n && all isDigit s
-- | 引擎里的一行值
data Value
= VNull
| VInt Int
@@ -343,6 +363,7 @@ data Value
| VBool Bool
deriving (Show, Eq)
-- | 值按类型打散搅拌
instance Hashable Value where
hashWithSalt s VNull = hashWithSalt (hashWithSalt s (0 :: Int)) ()
hashWithSalt s (VInt n) = hashWithSalt (hashWithSalt s (1 :: Int)) n
@@ -350,8 +371,10 @@ instance Hashable Value where
hashWithSalt s (VStr t) = hashWithSalt (hashWithSalt s (3 :: Int)) t
hashWithSalt s (VBool b) = hashWithSalt (hashWithSalt s (4 :: Int)) b
-- | 一行数据
type Row = [(String, Value)]
-- | 一张表：名字、列定义与全部行
data Table = Table
{ tableName :: String
, tableCols :: [(String, Column)]
@@ -359,6 +382,7 @@ data Table = Table
}
deriving (Show)
-- | 库：库名到表的映射
type Database = [(String, Table)]
-- | 取表的列名
@@ -373,6 +397,7 @@ colType t c = lookup c (tableCols t)
lookupTable :: Database -> String -> Either String Table
lookupTable db t = maybe (Left ("unknown table: " ++ t)) Right (lookup t db)
-- | 通配列名
allColumns :: String
allColumns = "*"
@@ -393,4 +418,5 @@ resolveColumn name env = case [(k, v) | (k, v) <- env, matches k] of
[] -> Left ("unknown column: " ++ name)
_ -> Left ("ambiguous column: " ++ name)
where
-- | 裸名或带后缀的名称
matches k = k == name || ('.' : name) `isSuffixOf` k
chusql-core/model/src/ChuSQL/Core/Protocol.hs
+357
View File
@@ -0,0 +1,357 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Core.Protocol (
SchemaColumn (..),
Request (..),
Response (..),
TableInfo (..),
Account (..),
QueryResult (..),
valueToJSON,
valueFromJSON,
rowToJSON,
rowFromJSON,
queryResultJson,
) where
import ChuSQL.Core.Model (Row, Value (..))
import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.!=), (.=))
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import Data.Aeson.Types (Parser)
import Data.Scientific (floatingOrInteger, fromFloatDigits)
import qualified Data.Text as T
import Data.Text (Text)
-- 线上协议类型：存储层请求/响应与查询结果集。
-- | 数据字典里一列的线上形状
data SchemaColumn = SchemaColumn
{ scName :: String
, scType :: String
, scNullable :: Bool
, scDefault :: Maybe Value
, scAutoIncrement :: Bool
, scPrimaryKey :: Bool
, scUnique :: Bool
, scCheck :: Maybe String
}
deriving (Show, Eq)
-- | 列编码成 JSON
instance ToJSON SchemaColumn where
toJSON sc =
object
[ "name" .= scName sc
, "ty" .= scType sc
, "nullable" .= scNullable sc
, "default" .= fmap valueToJSON (scDefault sc)
, "auto_increment" .= scAutoIncrement sc
, "primary_key" .= scPrimaryKey sc
, "unique" .= scUnique sc
, "check" .= scCheck sc
]
-- | JSON 解回列
instance FromJSON SchemaColumn where
parseJSON = withObject "SchemaColumn" $ \o -> do
n <- o .: "name"
t <- o .: "ty"
nullable <- o .:? "nullable" .!= True
defJson <- o .:? "default"
def <- mapM valueFromJSON defJson
auto <- o .:? "auto_increment" .!= False
pk <- o .:? "primary_key" .!= False
uniq <- o .:? "unique" .!= False
chk <- o .:? "check"
pure (SchemaColumn n t nullable def auto pk uniq chk)
-- | 存储层请求
data Request
= ReqPing
| ReqDatabase String String
| ReqAllCatalog
| ReqInDatabase String Request
| ReqAccountsList
| ReqAccountCreate T.Text T.Text
| ReqAccountReset T.Text T.Text
| ReqAccountLogin T.Text (Maybe T.Text)
| ReqAccountDrop T.Text
| ReqScan String
| ReqScanColumns String [String]
| ReqInsert String Row
| ReqInsertBatch String [Row]
| ReqDeleteKeys String [Int]
| ReqReplaceAll String [Row]
| ReqListTables
| ReqLookupByColumn String String Value
| ReqRangeByIndex String String (Maybe (Value, Bool)) (Maybe (Value, Bool))
| ReqDescribeTable String
| ReqCreateTable String [SchemaColumn]
| ReqDropTable String
| ReqCreateIndex String String
| ReqDropIndex String String
| ReqDropColumn String String
| ReqReplaceSchema String [SchemaColumn] [Row]
| ReqListCatalog
-- | 请求编码成 JSON
instance ToJSON Request where
toJSON (ReqDatabase method name) = object ["method" .= method, "database" .= name]
toJSON ReqAllCatalog = object ["method" .= ("all_catalogs" :: T.Text)]
toJSON (ReqInDatabase name req) = case toJSON req of
A.Object fields -> A.Object (KM.insert "database" (A.String (T.pack name)) fields)
other -> other
toJSON ReqAccountsList = object ["method" .= ("accounts_list" :: T.Text)]
toJSON (ReqAccountCreate u h) = object ["method" .= ("account_create" :: T.Text), "user" .= u, "password_hash" .= h]
toJSON (ReqAccountReset u h) = object ["method" .= ("account_reset" :: T.Text), "user" .= u, "password_hash" .= h]
toJSON (ReqAccountLogin u at) = object ["method" .= ("account_login" :: T.Text), "user" .= u, "at" .= at]
toJSON (ReqAccountDrop u) = object ["method" .= ("account_drop" :: T.Text), "user" .= u]
toJSON ReqPing = object ["method" .= ("ping" :: T.Text)]
toJSON (ReqScan t) = object ["method" .= ("scan" :: T.Text), "table" .= t]
toJSON (ReqScanColumns t cols) = object ["method" .= ("scan" :: T.Text), "table" .= t, "columns" .= cols]
toJSON (ReqInsert t r) =
object
[ "method" .= ("insert" :: T.Text)
, "table" .= t
, "row" .= rowToJSON r
]
toJSON (ReqInsertBatch t rs) =
object
[ "method" .= ("insert_batch" :: T.Text)
, "table" .= t
, "rows" .= map rowToJSON rs
]
toJSON (ReqDeleteKeys t ks) =
object
[ "method" .= ("delete_keys" :: T.Text)
, "table" .= t
, "keys" .= ks
]
toJSON (ReqReplaceAll t rs) =
object
[ "method" .= ("replace_all" :: T.Text)
, "table" .= t
, "rows" .= map rowToJSON rs
]
toJSON ReqListTables = object ["method" .= ("list_tables" :: T.Text)]
toJSON (ReqLookupByColumn t c k) =
object
[ "method" .= ("lookup_by_index" :: T.Text)
, "table" .= t
, "column" .= c
, "key" .= valueToJSON k
]
toJSON (ReqRangeByIndex t c lo hi) =
object
[ "method" .= ("range_by_index" :: T.Text)
, "table" .= t
, "column" .= c
, "lo" .= fmap (valueToJSON . fst) lo
, "lo_inclusive" .= maybe True snd lo
, "hi" .= fmap (valueToJSON . fst) hi
, "hi_inclusive" .= maybe True snd hi
]
toJSON (ReqDescribeTable t) =
object
[ "method" .= ("describe_table" :: T.Text)
, "table" .= t
]
toJSON (ReqCreateTable t cols) =
object
[ "method" .= ("create_table" :: T.Text)
, "table" .= t
, "columns" .= cols
]
toJSON (ReqDropTable t) =
object ["method" .= ("drop_table" :: T.Text), "table" .= t]
toJSON (ReqCreateIndex t c) =
object
[ "method" .= ("create_index" :: T.Text)
, "table" .= t
, "column" .= c
]
toJSON (ReqDropIndex t c) =
object
[ "method" .= ("drop_index" :: T.Text)
, "table" .= t
, "column" .= c
]
toJSON (ReqDropColumn t c) =
object
[ "method" .= ("drop_column" :: T.Text)
, "table" .= t
, "column" .= c
]
toJSON (ReqReplaceSchema t cols rs) =
object
[ "method" .= ("replace_schema" :: T.Text)
, "table" .= t
, "columns" .= cols
, "rows" .= map rowToJSON rs
]
toJSON ReqListCatalog = object ["method" .= ("list_catalog" :: T.Text)]
-- | 一张表的梗概：列、行数、索引与列统计
data TableInfo = TableInfo
{ tiTable :: String
, tiColumns :: [SchemaColumn]
, tiRows :: Int
, tiIndexes :: [String]
, tiStats :: [(String, Int, Bool)]
}
deriving (Show, Eq)
-- | 表信息编码成 JSON
instance ToJSON TableInfo where
toJSON info =
object
[ "table" .= tiTable info
, "columns" .= tiColumns info
, "row_count" .= tiRows info
, "indexes" .= map (\name -> object ["column" .= name]) (tiIndexes info)
, "stats" .= map statJson (tiStats info)
]
where
statJson (name, distinct, capped) =
object ["name" .= name, "distinct" .= distinct, "capped" .= capped]
-- | JSON 解回表信息
instance FromJSON TableInfo where
parseJSON = withObject "TableInfo" $ \o -> do
table <- o .: "table"
columns <- o .: "columns"
count <- o .: "row_count"
indexes <- o .:? "indexes" .!= []
stats <- o .:? "stats" .!= []
indexColumns <- mapM (\v -> withObject "IndexWire" (.: "column") v) (indexes :: [A.Value])
parsedStats <- mapM parseStat (stats :: [A.Value])
pure (TableInfo table columns count indexColumns parsedStats)
where
parseStat = withObject "ColumnStat" $ \o -> do
name <- o .: "name"
distinct <- o .: "distinct"
capped <- o .:? "capped" .!= False
pure (name, distinct, capped)
-- | 一条账号记录
data Account = Account
{ accountId :: Integer
, accountUser :: T.Text
, accountHash :: T.Text
, accountRevision :: Integer
, accountRegisteredAt :: T.Text
, accountLastLoginAt :: Maybe T.Text
} deriving (Eq)
-- | 账号的展示：只露账号名与版本号
instance Show Account where
show a = "Account " ++ show (accountUser a) ++ " revision=" ++ show (accountRevision a)
-- | JSON 解回账号
instance FromJSON Account where
parseJSON = withObject "Account" $ \o -> Account <$> o .: "id" <*> o .: "user"
<*> o .: "password_hash" <*> o .: "revision"
<*> o .:? "registered_at" .!= "" <*> o .:? "last_login_at"
-- | 账号编码成 JSON
instance ToJSON Account where
toJSON a = object ["id" .= accountId a, "user" .= accountUser a,
"password_hash" .= accountHash a, "revision" .= accountRevision a,
"registered_at" .= accountRegisteredAt a, "last_login_at" .= accountLastLoginAt a]
-- | 存储层响应
data Response
= RespPong
| RespAccounts [Account]
| RespRows [Row]
| RespTables [String]
| RespSchema TableInfo
| RespNoIndex
| RespOk
| RespError String
| RespCatalog [TableInfo]
-- | JSON 解回响应
instance FromJSON Response where
parseJSON = withObject "Response" $ \o -> do
status <- o .: "status"
case status :: T.Text of
"accounts" -> RespAccounts <$> o .: "accounts"
"pong" -> pure RespPong
"ok" -> pure RespOk
"no_index" -> pure RespNoIndex
"rows" -> RespRows <$> (o .: "rows" >>= mapM rowFromJSON)
"tables" -> RespTables <$> o .: "tables"
"error" -> RespError <$> o .: "message"
"schema" -> RespSchema <$> parseJSON (A.Object o)
"catalog" -> do
xs <- o .: "schemas" :: Parser [A.Value]
RespCatalog <$> mapM parseJSON xs
other -> fail ("unknown status: " ++ T.unpack other)
-- | 值编码成 JSON
valueToJSON :: Value -> A.Value
valueToJSON VNull = A.Null
valueToJSON (VInt n) = A.Number (fromIntegral n)
valueToJSON (VFloat d) = A.Number (fromFloatDigits d)
valueToJSON (VStr s) = A.String (T.pack s)
valueToJSON (VBool b) = A.Bool b
-- | JSON 解回值
valueFromJSON :: A.Value -> Parser Value
valueFromJSON A.Null = pure VNull
valueFromJSON (A.Number n) =
case floatingOrInteger n :: Either Double Integer of
Right i -> pure (VInt (fromIntegral i))
Left d -> pure (VFloat d)
valueFromJSON (A.String s) = pure (VStr (T.unpack s))
valueFromJSON (A.Bool b) = pure (VBool b)
valueFromJSON _ = fail "unsupported value type"
-- | 一行编码成 JSON
rowToJSON :: Row -> A.Value
rowToJSON r =
A.Object (KM.fromList [(K.fromString k, valueToJSON v) | (k, v) <- r])
-- | JSON 解回一行
rowFromJSON :: A.Value -> Parser Row
rowFromJSON (A.Object o) = mapM toPair (KM.toList o)
where
-- | 键值对解成一个字段
toPair (k, v) = do
val <- valueFromJSON v
pure (K.toString k, val)
rowFromJSON _ = fail "row must be a JSON object"
-- | 一条语句的结果集：列名与排好的行
data QueryResult = QueryResult
{ qrColumns :: [Text]
, qrRows :: [[Value]]
, qrRowCount :: Int
, qrTruncated :: Bool
, qrDatabase :: Maybe Text
}
deriving (Eq, Show)
-- | JSON 解回结果集
instance FromJSON QueryResult where
parseJSON = withObject "QueryResult" $ \o -> do
cols <- o .: "columns"
rows <- o .: "rows"
QueryResult cols <$> mapM (mapM valueFromJSON) rows
<*> o .:? "rowCount" .!= 0
<*> o .:? "truncated" .!= False
<*> o .:? "database"
-- | 结果还原成 JSON（JSON 输出与 TCP 结果集共用）
queryResultJson :: QueryResult -> A.Value
queryResultJson result =
object
[ "columns" .= qrColumns result
, "rows" .= map (map valueToJSON) (qrRows result)
, "rowCount" .= qrRowCount result
, "truncated" .= qrTruncated result
, "database" .= qrDatabase result
]
chusql-engine/stack.yaml → chusql-core/model/stack.yaml
View File
File renamed without changes.
chusql-core/model/stack.yaml.lock
+12
View File
@@ -0,0 +1,12 @@
# This file was autogenerated by Stack.
# You should not edit this file by hand.
# For more information, please see the documentation at:
# https://docs.haskellstack.org/en/stable/topics/lock_files
packages: []
snapshots:
- completed:
sha256: 0f728e30e843d7f00460ad56858b995a3b227fca683659c7df9f2fc3988a3ce1
size: 732465
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/59.yaml
original: lts-24.59
chusql-storage/Cargo.lock → chusql-core/storage/Cargo.lock
Generated
+1 -33
View File
@@ -15,22 +15,15 @@ source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "4e7648175b45a9a48536d676f68d918270699102aa8dab5496df06904c914600"
[[package]]
name = "chusql-storage"
name = "chusql-core-storage"
version = "0.1.0"
dependencies = [
"interprocess",
"serde",
"serde_json",
"tempfile",
"toml",
]
[[package]]
name = "doctest-file"
version = "1.1.1"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "c2db04e74f0a9a93103b50e90b96024c9b2bdca8bce6a632ec71b88736d3d359"
[[package]]
name = "equivalent"
version = "1.0.2"
@@ -80,19 +73,6 @@ dependencies = [
"hashbrown",
]
[[package]]
name = "interprocess"
version = "2.4.4"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "6cb02ffbf25e8ef0f4a95bff054eef75f6d1bf16919474cf2caa63b21997478a"
dependencies = [
"doctest-file",
"libc",
"recvmsg",
"widestring",
"windows-sys",
]
[[package]]
name = "itoa"
version = "1.0.18"
@@ -147,12 +127,6 @@ version = "6.0.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "f8dcc9c7d52a811697d2151c701e0d08956f92b0e24136cf4cf27b57a6a0d9bf"
[[package]]
name = "recvmsg"
version = "1.0.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "d3edd4d5d42c92f0a659926464d4cce56b562761267ecf0f469d85b7de384175"
[[package]]
name = "rustix"
version = "1.1.5"
@@ -289,12 +263,6 @@ version = "1.0.26"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "d245f478577f809a851594d02313b640fb437e0bb33866753cff937863096954"
[[package]]
name = "widestring"
version = "1.2.1"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "72069c3113ab32ab29e5584db3c6ec55d416895e60715417b5b883a357c3e471"
[[package]]
name = "windows-link"
version = "0.2.1"
chusql-storage/Cargo.toml → chusql-core/storage/Cargo.toml
+5 -2
View File
@@ -1,12 +1,15 @@
[package]
name = "chusql-storage"
name = "chusql-core-storage"
version = "0.1.0"
edition = "2024"
[lib]
name = "chusql_core_storage"
crate-type = ["cdylib", "rlib"]
[dependencies]
serde = { version = "1", features = ["derive"] }
serde_json = "1"
interprocess = "2"
toml = "0.8"
[dev-dependencies]
chusql-storage/chusql-storage.toml.example → chusql-core/storage/chusql-core-storage.toml.example
+1 -5
View File
@@ -29,14 +29,10 @@ pool_size = 1024
# 要固定就写绝对路径，例如：
# data_dir = "/srv/chusql/data"
[server]
# 命名管道名（Windows 上实际是 \\.\pipe\<这个名字>）。
pipe_name = "chusql-joint"
[log]
# 日志等级：off / error / warn / info / debug。debug 会多打每个请求和连接。
level = "info"
# 颜色没有配置项也没有环境变量：要写的那条流是终端就着色，重定向到文件就不着色。
# 行格式：[等级 本地日期时间] [来源] 消息；来源 core=服务自身、pipe=由管道请求触发
# 行格式：[等级 本地日期时间] [来源] 消息；来源 core=服务自身、request=由存储请求触发
# ERROR 加粗红、WARN 加粗橙、DEBUG 加粗不变色、INFO 不加样式
chusql-storage/src/btree.rs → chusql-core/storage/src/btree.rs
+15 -1
View File
@@ -44,36 +44,44 @@ pub fn max_order(page_size: usize) -> usize {
page_size.saturating_sub(HEADER) / (SLOT + max_cell_bytes()) + 1
}
/// 读一个 u8
fn read_u8(p: &Page, off: usize) -> u8 {
p.data[off]
}
/// 写一个 u8
fn write_u8(p: &mut Page, off: usize, v: u8) {
p.data[off] = v;
}
/// 读一个小端 u16
fn read_u16(p: &Page, off: usize) -> u16 {
u16::from_le_bytes([p.data[off], p.data[off + 1]])
}
/// 写一个小端 u16
fn write_u16(p: &mut Page, off: usize, v: u16) {
p.data[off..off + 2].copy_from_slice(&v.to_le_bytes());
}
/// 读一个小端 u32
fn read_u32(p: &Page, off: usize) -> u32 {
u32::from_le_bytes([p.data[off], p.data[off + 1], p.data[off + 2], p.data[off + 3]])
}
/// 写一个小端 u32
fn write_u32(p: &mut Page, off: usize, v: u32) {
p.data[off..off + 4].copy_from_slice(&v.to_le_bytes());
}
/// 读一个小端 u64
fn read_u64(p: &Page, off: usize) -> u64 {
let mut b = [0u8; 8];
b.copy_from_slice(&p.data[off..off + 8]);
u64::from_le_bytes(b)
}
/// 写一个小端 u64
fn write_u64(p: &mut Page, off: usize, v: u64) {
p.data[off..off + 8].copy_from_slice(&v.to_le_bytes());
}
@@ -269,16 +277,19 @@ impl DiskBTree {
Ok(())
}
/// 读根页页号；空树是 None
fn root(&mut self) -> io::Result<Option<PageId>> {
let r = self.file.with_page(META_PAGE, |p| read_u64(p, OFF_ROOT))?;
Ok(if r == 0 { None } else { Some(r) })
}
/// 写根页页号
fn set_root(&mut self, r: Option<PageId>) -> io::Result<()> {
self.file
.update_page(META_PAGE, |p| write_u64(p, OFF_ROOT, r.unwrap_or(0)))
}
/// 追加一个新节点页
fn alloc(&mut self, node: &Node) -> io::Result<PageId> {
let page = self.file.append_page()?;
let id = page.id;
@@ -286,10 +297,12 @@ impl DiskBTree {
Ok(id)
}
/// 按页号读节点
fn load(&mut self, id: PageId) -> io::Result<Node> {
self.file.with_page(id, get_node)
}
/// 按页号写节点
fn store(&mut self, id: PageId, node: &Node) -> io::Result<()> {
self.file.update_page(id, |p| put_node(p, node))?
}
@@ -417,6 +430,7 @@ impl DiskBTree {
self.delete_rec(root, key, value)
}
/// 递归删一个 (key, value)
fn delete_rec(&mut self, id: PageId, key: &[u8], value: u64) -> io::Result<bool> {
let mut node = self.load(id)?;
if node.kind == NODE_LEAF {
@@ -438,7 +452,7 @@ impl DiskBTree {
self.scan(None, None)
}
/// 范围扫描：lo / hi 都是闭区间，None 表示这一侧不限
/// 范围扫描：lo / hi 都是闭区间，None 表示不限
pub fn scan(
&mut self,
lo: Option<&[u8]>,
chusql-storage/src/catalog.rs → chusql-core/storage/src/catalog.rs
+2 -2
View File
@@ -250,7 +250,7 @@ impl Catalog {
Ok(had_column)
}
/// 整理完成：记住这一版已经重写过（隐藏列名要留住，防止被重新写进来）
/// 记住这一版已整理过（隐藏列名要留住）
pub fn mark_compacted(&mut self, table: &str) -> io::Result<()> {
let entry = self
.tables
@@ -336,7 +336,7 @@ fn infer_type(v: &serde_json::Value) -> Option<String> {
}
}
/// 旧写法与新别名都并到规范名字，参数（varchar(20)）原样保留；不认识的原样返回
/// 类型别名统一成规范名，参数原样保留
pub fn normalize_type(ty: &str) -> String {
let trimmed = ty.trim();
let (base, args) = match trimmed.find('(') {
chusql-storage/src/config.rs → chusql-core/storage/src/config.rs
+16 -45
View File
@@ -4,15 +4,8 @@ use serde::Deserialize;
use crate::log::Level;
// 全局配置：只从 TOML 文件读，没写的项回退内置默认值。
//
// 这个文件是整条链路的唯一配置文件，按分区各管各的：
// 存储只看 [page]/[btree]/[buffer]/[storage]/[server]/[log]，
// 其他分区（例如 web 的 [web]）由对应的层自己读，这里既不校验也不关心。
// 位置是安装时定下的固定路径，只有命令行 --config 能覆盖；没有任何环境变量通道。
// （唯一跟环境变量有关的是路径的默认值：配置文件和默认数据目录都按平台惯例算，
// 见 default_config_path / default_data_dir，它们只是算默认位置，不是配置通道。）
// 读一次就关，不长期占着文件句柄。
// 全局配置：只从 TOML 文件读，缺项回退内置默认值；
// 存储相关分区由本模块解析校验，其它层的分区一概不碰。
/// 配置文件名
pub const CONFIG_FILE_NAME: &str = "chusql.toml";
@@ -26,15 +19,13 @@ pub const DATA_DIR_NAME: &str = "data";
pub const DEFAULT_POOL_SIZE: usize = 1024;
pub const DEFAULT_PAGE_SIZE: usize = 4096;
pub const DEFAULT_BTREE_ORDER: usize = 4;
pub const DEFAULT_PIPE_NAME: &str = "chusql-joint";
pub const DEFAULT_LOG_LEVEL: &str = "info";
const MIN_PAGE_SIZE: usize = 512;
const MAX_PAGE_SIZE: usize = 65536;
const MIN_BTREE_ORDER: usize = 3;
/// 安装后的固定配置路径：Windows 用 %APPDATA%，其它平台用 XDG 惯例。
/// 环境变量缺失时退回相对路径 ChuSQL/chusql.toml。
/// 默认配置文件路径（按平台惯例）
pub fn default_config_path() -> PathBuf {
#[cfg(windows)]
{
@@ -60,14 +51,7 @@ pub fn default_config_path() -> PathBuf {
PathBuf::from(APP_DIR_NAME).join(CONFIG_FILE_NAME)
}
/// [storage] data_dir 没写时的默认数据目录，按各平台惯例自动切换：
///
/// Windows %LOCALAPPDATA%\ChuSQL\data（没设就退 %APPDATA%）
/// Unix $XDG_DATA_HOME/chusql/data（没设就是 ~/.local/share/chusql/data）
///
/// 跟安装脚本的默认数据目录是同一处：install.ps1 默认装到 %LOCALAPPDATA%\ChuSQL、
/// 数据放它下面的 data\；install.sh 默认装到 ~/.local/share/chusql、数据放它下面的 data/。
/// 环境变量都缺时才退回相对路径（跟 default_config_path 的兜底风格一致）。
/// Windows 默认数据目录
#[cfg(windows)]
pub fn default_data_dir() -> PathBuf {
let local = std::env::var_os("LOCALAPPDATA").filter(|v| !v.is_empty());
@@ -81,7 +65,7 @@ pub fn default_data_dir() -> PathBuf {
PathBuf::from(APP_DIR_NAME).join(DATA_DIR_NAME)
}
/// 见 Windows 版本的注释：这里走 XDG 惯例。
/// Unix 默认数据目录（XDG 惯例）
#[cfg(not(windows))]
pub fn default_data_dir() -> PathBuf {
let xdg = std::env::var_os("XDG_DATA_HOME").filter(|v| !v.is_empty());
@@ -107,18 +91,17 @@ pub struct Config {
pub btree_order: usize,
pub pool_size: usize,
pub data_dir: PathBuf,
pub pipe_name: String,
pub log_level: Level,
}
impl Default for Config {
/// 内置默认配置
fn default() -> Self {
Config {
page_size: DEFAULT_PAGE_SIZE,
btree_order: DEFAULT_BTREE_ORDER,
pool_size: DEFAULT_POOL_SIZE,
data_dir: default_data_dir(),
pipe_name: DEFAULT_PIPE_NAME.to_string(),
log_level: Level::Info,
}
}
@@ -153,7 +136,6 @@ struct FileConfig {
btree: Option<FileBtree>,
buffer: Option<FileBuffer>,
storage: Option<FileStorage>,
server: Option<FileServer>,
log: Option<FileLog>,
}
@@ -181,19 +163,13 @@ struct FileStorage {
data_dir: Option<String>,
}
#[derive(Debug, Default, Deserialize)]
#[serde(deny_unknown_fields)]
struct FileServer {
pipe_name: Option<String>,
}
#[derive(Debug, Default, Deserialize)]
#[serde(deny_unknown_fields)]
struct FileLog {
level: Option<String>,
}
/// 加载配置：explicit 有值就用它（读不到要报错），否则用固定安装路径（存在才读）
/// 加载配置：显式路径优先，其次默认位置
pub fn load(explicit: Option<&str>) -> Result<Loaded, String> {
let explicit = explicit.map(str::trim).filter(|p| !p.is_empty());
let path = match explicit {
@@ -249,15 +225,11 @@ pub fn resolve(text: Option<&str>, path: Option<PathBuf>) -> Result<Loaded, Stri
&file_origin,
);
let (data_dir, dir_origin) = pick(
file.storage.and_then(|s| s.data_dir),
file.storage.as_ref().and_then(|s| s.data_dir.clone()),
default_data_dir().to_string_lossy().into_owned(),
&file_origin,
);
let (pipe_name, pipe_origin) = pick(
file.server.and_then(|s| s.pipe_name),
DEFAULT_PIPE_NAME.to_string(),
&file_origin,
);
// 管名已经没有了：存储不再是独立进程，管道/套接字那一层随 FFI 一起删掉
let (log_level, log_origin) = pick(
file.log.and_then(|l| l.level),
DEFAULT_LOG_LEVEL.to_string(),
@@ -265,7 +237,6 @@ pub fn resolve(text: Option<&str>, path: Option<PathBuf>) -> Result<Loaded, Stri
);
let data_dir = data_dir.trim().to_string();
let pipe_name = pipe_name.trim().to_string();
let log_level = log_level.trim().to_string();
let log_level = Level::parse(&log_level)
@@ -274,9 +245,6 @@ pub fn resolve(text: Option<&str>, path: Option<PathBuf>) -> Result<Loaded, Stri
if data_dir.is_empty() {
return Err("storage.data_dir must not be empty".to_string());
}
if pipe_name.is_empty() {
return Err("server.pipe_name must not be empty".to_string());
}
validate_layout(page_size, btree_order)?;
if pool_size == 0 {
return Err("buffer.pool_size must be at least 1".to_string());
@@ -286,7 +254,6 @@ pub fn resolve(text: Option<&str>, path: Option<PathBuf>) -> Result<Loaded, Stri
("btree.order", btree_order.to_string(), order_origin),
("buffer.pool_size", pool_size.to_string(), pool_origin),
("storage.data_dir", data_dir.clone(), dir_origin),
("server.pipe_name", pipe_name.clone(), pipe_origin),
("log.level", log_level.name().to_string(), log_origin),
];
@@ -296,7 +263,6 @@ pub fn resolve(text: Option<&str>, path: Option<PathBuf>) -> Result<Loaded, Stri
btree_order,
pool_size,
data_dir: PathBuf::from(data_dir),
pipe_name,
log_level,
},
config_path: if text.is_some() { path } else { None },
@@ -341,7 +307,7 @@ fn validate_layout(page_size: usize, btree_order: usize) -> Result<(), String> {
mod tests {
use super::*;
/// 全局配置里别的层（例如 web）的分区不能被存储层当成错误
/// 别的层的分区不能被当成错误
#[test]
fn ignores_sections_owned_by_other_layers() {
let text = r#"
@@ -351,8 +317,13 @@ size = 8192
[storage]
data_dir = "../data"
[web]
[server]
host = "127.0.0.1"
port = 7777
max_message = 1048576
[web]
port = 7778
user = "root"
"#;
let loaded = resolve(Some(text), Some(PathBuf::from("chusql.toml"))).unwrap();
chusql-core/storage/src/ffi.rs
+154
View File
@@ -0,0 +1,154 @@
use std::cell::RefCell;
use std::ffi::{c_char, CStr};
use std::panic::{catch_unwind, AssertUnwindSafe};
use std::ptr;
use std::slice;
use crate::runtime::Storage;
// C ABI：Haskell 侧唯一存储入口，请求与响应都是 UTF-8 JSON。
// 不 panic 穿过边界，失败走线程局部 last_error。
const OK: i32 = 0;
const ERR: i32 = -1;
thread_local! {
static LAST_ERROR: RefCell<Vec<u8>> = const { RefCell::new(Vec::new()) };
}
/// 记下本线程最近的失败信息
fn set_error(message: impl AsRef<str>) {
let text = message.as_ref().as_bytes().to_vec();
LAST_ERROR.with(|slot| *slot.borrow_mut() = text);
}
/// 版本号字符串（静态常量，调用方不要释放）。
#[unsafe(no_mangle)]
pub extern "C" fn chusql_storage_version() -> *const c_char {
const VERSION: &str = concat!(env!("CARGO_PKG_VERSION"), "\0");
VERSION.as_ptr() as *const c_char
}
/// 打开数据目录；失败返回 NULL
///
/// # Safety
/// `config_path` 要么是 NULL，要么指向以 NUL 结尾的有效字符串。
#[unsafe(no_mangle)]
pub unsafe extern "C" fn chusql_storage_open(config_path: *const c_char) -> *mut Storage {
let opened = catch_unwind(AssertUnwindSafe(|| {
let path = if config_path.is_null() {
None
} else {
let text = unsafe { CStr::from_ptr(config_path) }
.to_str()
.map_err(|_| "config path is not valid UTF-8".to_string())?;
if text.is_empty() { None } else { Some(text.to_string()) }
};
Storage::open(path.as_deref()).map(Box::new)
}));
match opened {
Ok(Ok(storage)) => Box::into_raw(storage),
Ok(Err(e)) => {
set_error(e);
ptr::null_mut()
}
Err(_) => {
set_error("panic in chusql_storage_open");
ptr::null_mut()
}
}
}
/// 关闭句柄（NULL 安全）
///
/// # Safety
/// `handle` 必须是 chusql_storage_open 返回且未被关闭过的句柄。
#[unsafe(no_mangle)]
pub unsafe extern "C" fn chusql_storage_close(handle: *mut Storage) {
if handle.is_null() {
return;
}
let _ = catch_unwind(AssertUnwindSafe(|| unsafe { drop(Box::from_raw(handle)) }));
}
/// 处理一条请求，响应缓冲须归还
///
/// # Safety
/// `handle` 必须是有效句柄；`request` 指向 `request_len` 个字节；`out`/`out_len` 可写。
#[unsafe(no_mangle)]
pub unsafe extern "C" fn chusql_storage_request(
handle: *const Storage,
request: *const u8,
request_len: usize,
out: *mut *mut u8,
out_len: *mut usize,
) -> i32 {
if !out.is_null() {
unsafe { *out = ptr::null_mut() };
}
if !out_len.is_null() {
unsafe { *out_len = 0 };
}
if handle.is_null() || request.is_null() || out.is_null() || out_len.is_null() {
set_error("invalid argument");
return ERR;
}
let storage = unsafe { &*handle };
let bytes = unsafe { slice::from_raw_parts(request, request_len) };
let text = match std::str::from_utf8(bytes) {
Ok(text) => text,
Err(e) => {
set_error(format!("request is not valid UTF-8: {}", e));
return ERR;
}
};
let response = match catch_unwind(AssertUnwindSafe(|| storage.request_line(text))) {
Ok(response) => response,
Err(_) => {
set_error("panic in chusql_storage_request");
return ERR;
}
};
let mut buffer = response.into_bytes().into_boxed_slice();
let ptr = buffer.as_mut_ptr();
let len = buffer.len();
std::mem::forget(buffer);
unsafe {
*out = ptr;
*out_len = len;
}
OK
}
/// 归还响应缓冲
///
/// # Safety
/// `data`/`len` 必须是 chusql_storage_request 原样返回且未被释放过的一对值。
#[unsafe(no_mangle)]
pub unsafe extern "C" fn chusql_storage_free(data: *mut u8, len: usize) {
if data.is_null() {
return;
}
let _ = catch_unwind(AssertUnwindSafe(|| unsafe {
let slice = ptr::slice_from_raw_parts_mut(data, len);
let _owned: Box<[u8]> = Box::from_raw(slice);
}));
}
/// 取本线程最近的失败信息
///
/// # Safety
/// `out_len` 可写，或为 NULL。
#[unsafe(no_mangle)]
pub unsafe extern "C" fn chusql_storage_last_error(out_len: *mut usize) -> *const u8 {
LAST_ERROR.with(|slot| {
let bytes = slot.borrow();
if !out_len.is_null() {
unsafe { *out_len = bytes.len() };
}
if bytes.is_empty() { ptr::null() } else { bytes.as_ptr() }
})
}
chusql-storage/src/heap.rs → chusql-core/storage/src/heap.rs
+8 -2
View File
@@ -20,9 +20,11 @@ fn decode_row(bytes: &[u8], columns: Option<&[String]>, hidden: &HashSet<String>
struct RowVisitor<'a>(Option<&'a [String]>, &'a HashSet<String>);
impl<'de> Visitor<'de> for RowVisitor<'_> {
type Value = Row;
/// 说明期望的输入形态
fn expecting(&self, f: &mut std::fmt::Formatter) -> std::fmt::Result {
f.write_str("a row object")
}
/// 逐字段解出一行
fn visit_map<M: MapAccess<'de>>(self, mut map: M) -> Result<Row, M::Error> {
let mut row = Row::new();
while let Some(key) = map.next_key::<String>()? {
@@ -284,7 +286,7 @@ impl HeapTable {
self.indexes.iter().any(|i| i.column == column)
}
/// 建索引：要求这一列取值唯一
/// 建索引：id 列必须唯一，其余列可重复
pub fn build_index(
&mut self,
column: &str,
@@ -360,10 +362,12 @@ impl HeapTable {
}
}
/// 设置隐藏列集合
pub fn set_hidden_columns(&mut self, columns: HashSet<String>) {
self.hidden_columns = columns;
}
/// 隐藏一列并摘掉它的索引
pub fn hide_column(&mut self, column: &str) {
self.detach_index(column);
self.hidden_columns.insert(column.to_string());
@@ -487,7 +491,7 @@ impl HeapTable {
Ok(rows)
}
/// 范围扫描：某一列有索引就走叶子链，没有索引返回 None（上层退回全表扫描）
/// 按索引做范围扫描；没索引返回 None
pub fn scan_range(
&mut self,
column: &str,
@@ -595,6 +599,7 @@ impl HeapTable {
self.scan_columns(None)
}
/// 全表扫描，只解码指定列
pub fn scan_columns(&mut self, columns: Option<&[String]>) -> io::Result<Vec<Row>> {
Ok(self
.scan_projected_with_positions(columns)?
@@ -608,6 +613,7 @@ impl HeapTable {
self.scan_projected_with_positions(None)
}
/// 全表扫描，带位置与列投影
fn scan_projected_with_positions(&mut self, columns: Option<&[String]>) -> io::Result<Vec<(PageId, u16, Row)>> {
let n = self.file.num_pages()?;
let mut out = Vec::new();
chusql-storage/src/initsql.rs → chusql-core/storage/src/initsql.rs
+8 -5
View File
@@ -1,8 +1,8 @@
//! `scripts/init.sql` 的最小读取：只认 CREATE TABLE 与 CREATE INDEX。
//! 系统库的 schema 由这份脚本声明，存储进程按它建系统表。
use crate::protocol::SchemaColumn;
// 读取 scripts/init.sql，只认 CREATE TABLE 与 CREATE INDEX。
// 系统库的 schema 由这份脚本声明，进程按它建系统表。
#[derive(Debug, Clone, PartialEq, Eq)]
pub struct InitColumn {
pub name: String,
@@ -68,7 +68,7 @@ pub fn parse(text: &str) -> Result<Vec<InitTable>, String> {
Ok(tables)
}
/// 一行一列：`name type [NOT NULL] [AUTO_INCREMENT] [PRIMARY KEY] [UNIQUE]`
/// 解析表定义里的列清单
fn columns(body: &str) -> Result<Vec<InitColumn>, String> {
let mut out = Vec::new();
for part in split_top_level(body) {
@@ -166,8 +166,9 @@ mod tests {
use super::*;
/// 仓库里的系统库脚本必须始终能解析
const SYSTEM_SCHEMA: &str = include_str!("../../scripts/init.sql");
const SYSTEM_SCHEMA: &str = include_str!("../../../scripts/init.sql");
/// 仓库自带脚本必须能解析出账号表
#[test]
fn parses_the_repository_init_script() {
let tables = parse(SYSTEM_SCHEMA).expect("scripts/init.sql must parse");
@@ -186,6 +187,7 @@ mod tests {
assert_eq!(users.indexes, ["user"]);
}
/// 未知语句与表级约束要报错
#[test]
fn rejects_unknown_statements_and_table_level_constraints() {
assert!(parse("DROP TABLE users;").is_err());
@@ -193,6 +195,7 @@ mod tests {
assert!(parse("CREATE INDEX missing (user);").is_err());
}
/// 注释与空语句要被跳过
#[test]
fn ignores_comments_and_blank_statements() {
let tables = parse("-- note\nCREATE TABLE t (a int NOT NULL);\n\n/* done */\n").unwrap();
chusql-storage/src/lib.rs → chusql-core/storage/src/lib.rs
+3 -2
View File
@@ -1,12 +1,13 @@
// 存储层库入口：对外暴露下面这些模块，服务与集成测试都从这里引。
pub mod btree;
pub mod catalog;
pub mod config;
pub mod endpoint;
pub mod ffi;
pub mod heap;
pub mod initsql;
pub mod log;
pub mod page;
pub mod protocol;
pub mod catalog;
pub mod runtime;
pub mod wal;
chusql-storage/src/log.rs → chusql-core/storage/src/log.rs
+21 -17
View File
@@ -22,7 +22,7 @@ pub enum Level {
#[derive(Debug, Clone, Copy, PartialEq, Eq)]
pub enum Channel {
Core,
Pipe,
Request,
}
impl Channel {
@@ -30,7 +30,7 @@ impl Channel {
fn tag(self) -> &'static str {
match self {
Channel::Core => "core",
Channel::Pipe => "pipe",
Channel::Request => "request",
}
}
}
@@ -102,7 +102,7 @@ pub fn init() {
enable_vt();
}
/// 写出一行：warn / error 走 stderr，info / debug 走 stdout。
/// 写出一行日志，按等级选流向
pub fn write(channel: Channel, level: Level, args: fmt::Arguments) {
let msg = args.to_string();
let to_stderr = streams_to_stderr(level);
@@ -116,12 +116,12 @@ pub fn write(channel: Channel, level: Level, args: fmt::Arguments) {
}
}
/// 这个等级写 stderr 吗：warn / error 是，info / debug 写 stdout
/// 这个等级是否写 stderr
fn streams_to_stderr(level: Level) -> bool {
matches!(level, Level::Error | Level::Warn)
}
/// 是否着色：只按要写的那条流是不是终端判断，没有环境变量开关
/// 按目标流是否终端决定是否着色
fn color_enabled(to_stderr: bool) -> bool {
let cached = if to_stderr { &COLOR_STDERR } else { &COLOR_STDOUT };
*cached.get_or_init(|| if to_stderr { std::io::stderr().is_terminal() } else { std::io::stdout().is_terminal() })
@@ -151,6 +151,7 @@ pub struct Stamp {
}
impl fmt::Display for Stamp {
/// 格式化成时间戳文本
fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result {
write!(
f,
@@ -266,8 +267,8 @@ macro_rules! log_debug {
(core, $($arg:tt)*) => {
$crate::log_line!($crate::log::Channel::Core, $crate::log::Level::Debug, $($arg)*)
};
(pipe, $($arg:tt)*) => {
$crate::log_line!($crate::log::Channel::Pipe, $crate::log::Level::Debug, $($arg)*)
(request, $($arg:tt)*) => {
$crate::log_line!($crate::log::Channel::Request, $crate::log::Level::Debug, $($arg)*)
};
}
@@ -276,8 +277,8 @@ macro_rules! log_info {
(core, $($arg:tt)*) => {
$crate::log_line!($crate::log::Channel::Core, $crate::log::Level::Info, $($arg)*)
};
(pipe, $($arg:tt)*) => {
$crate::log_line!($crate::log::Channel::Pipe, $crate::log::Level::Info, $($arg)*)
(request, $($arg:tt)*) => {
$crate::log_line!($crate::log::Channel::Request, $crate::log::Level::Info, $($arg)*)
};
}
@@ -286,8 +287,8 @@ macro_rules! log_warn {
(core, $($arg:tt)*) => {
$crate::log_line!($crate::log::Channel::Core, $crate::log::Level::Warn, $($arg)*)
};
(pipe, $($arg:tt)*) => {
$crate::log_line!($crate::log::Channel::Pipe, $crate::log::Level::Warn, $($arg)*)
(request, $($arg:tt)*) => {
$crate::log_line!($crate::log::Channel::Request, $crate::log::Level::Warn, $($arg)*)
};
}
@@ -296,8 +297,8 @@ macro_rules! log_error {
(core, $($arg:tt)*) => {
$crate::log_line!($crate::log::Channel::Core, $crate::log::Level::Error, $($arg)*)
};
(pipe, $($arg:tt)*) => {
$crate::log_line!($crate::log::Channel::Pipe, $crate::log::Level::Error, $($arg)*)
(request, $($arg:tt)*) => {
$crate::log_line!($crate::log::Channel::Request, $crate::log::Level::Error, $($arg)*)
};
}
@@ -315,6 +316,7 @@ macro_rules! log_line {
mod tests {
use super::*;
/// 已知日期换算要正确
#[test]
fn civil_from_days_known_dates() {
assert_eq!(civil_from_days(0), (1970, 1, 1));
@@ -324,6 +326,7 @@ mod tests {
assert_eq!(civil_from_days(19_782), (2024, 2, 29));
}
/// 行里要有等级、时间与来源
#[test]
fn render_has_time_channel_and_colors() {
let stamp = Stamp {
@@ -337,16 +340,16 @@ mod tests {
};
assert_eq!(
render(Level::Error, Channel::Pipe, true, &stamp, "boom"),
"[\u{1b}[1m\u{1b}[31mERROR\u{1b}[0m 2026-09-24 13:45:12.130] [pipe] boom"
render(Level::Error, Channel::Request, true, &stamp, "boom"),
"[\u{1b}[1m\u{1b}[31mERROR\u{1b}[0m 2026-09-24 13:45:12.130] [request] boom"
);
assert_eq!(
render(Level::Warn, Channel::Core, true, &stamp, "careful"),
"[\u{1b}[1m\u{1b}[38;5;208mWARN \u{1b}[0m 2026-09-24 13:45:12.130] [core] careful"
);
assert_eq!(
render(Level::Debug, Channel::Pipe, true, &stamp, "detail"),
"[\u{1b}[1mDEBUG\u{1b}[0m 2026-09-24 13:45:12.130] [pipe] detail"
render(Level::Debug, Channel::Request, true, &stamp, "detail"),
"[\u{1b}[1mDEBUG\u{1b}[0m 2026-09-24 13:45:12.130] [request] detail"
);
assert_eq!(
render(Level::Info, Channel::Core, true, &stamp, "hello"),
@@ -354,6 +357,7 @@ mod tests {
);
}
/// warn 与 error 走 stderr
#[test]
fn warnings_and_errors_go_to_stderr() {
assert!(streams_to_stderr(Level::Error));
chusql-storage/src/page.rs → chusql-core/storage/src/page.rs
+1
View File
@@ -282,6 +282,7 @@ impl PageFile {
}
impl Drop for PageFile {
/// 析构时把脏页写回
fn drop(&mut self) {
let _ = self.flush();
}
chusql-storage/src/protocol.rs → chusql-core/storage/src/protocol.rs
+3
View File
@@ -38,6 +38,7 @@ pub struct SchemaColumn {
}
impl Default for SchemaColumn {
/// 列定义的默认值
fn default() -> Self {
SchemaColumn {
name: String::new(),
@@ -52,6 +53,7 @@ impl Default for SchemaColumn {
}
}
/// serde 里缺省为真
fn default_true() -> bool {
true
}
@@ -188,6 +190,7 @@ impl Request {
}
}
/// 是不是保留系统表名
pub fn reserved_table(table: &str) -> bool {
table.to_ascii_lowercase().starts_with("__chusql_")
}
chusql-storage/src/bin/chusql-storage.rs → chusql-core/storage/src/runtime.rs
+92 -168
View File
@@ -1,26 +1,21 @@
use std::collections::HashMap;
use std::io::{BufRead, BufReader, Write};
use std::path::PathBuf;
use std::sync::{Arc, Mutex};
use std::sync::atomic::{AtomicBool, Ordering};
use std::thread;
use std::sync::{Arc, Mutex};
use chusql_storage::catalog::Catalog;
use chusql_storage::config::{self, Config, Loaded};
use chusql_storage::endpoint;
use chusql_storage::heap::HeapTable;
use chusql_storage::initsql::{self, InitColumn, InitTable};
use chusql_storage::log;
use chusql_storage::protocol::{
use crate::catalog::Catalog;
use crate::config::{self, Config, Loaded};
use crate::heap::HeapTable;
use crate::initsql::{self, InitColumn, InitTable};
use crate::log;
use crate::protocol::{
reserved_table, Account, ColumnStatWire, IndexWire, Request, Response, Row, SchemaColumn, TableSchemaWire, USERS_TABLE,
};
use chusql_storage::wal::{Wal, WalOp};
use chusql_storage::{log_debug, log_error, log_info, log_warn};
use interprocess::local_socket::prelude::*;
use interprocess::TryClone;
use crate::wal::{Wal, WalOp};
use crate::{log_debug, log_error, log_info, log_warn};
// 本地套接字服务：按行读写 JSON。端点地址由 endpoint 模块给出：
// Windows 是具名管道 \\.\pipe\<name>，Unix 是文件系统套接字 <dir>/<name>.sock。
// 进程内存储运行时：Haskell 侧经 ffi.rs 调进来。
// request_line 的语义等同原来的「一行 JSON 请求 → 一行 JSON 响应」套接字协议。
struct Server {
cfg: Config,
@@ -360,7 +355,7 @@ impl Server {
Ok(())
}
/// 旧类型系统留下的数据升级到新格式：列类型名规范化、缺列的行补 null
/// 老数据迁移：类型名规范、缺列补 null
fn migrate_data(&self) -> std::io::Result<()> {
let names: Vec<String> = self
.catalog
@@ -647,12 +642,12 @@ impl Server {
}
}
Request::Ping => {
log_debug!(pipe, "ping");
log_debug!(request, "ping");
Response::Pong
}
Request::Scan { table, columns } => {
log_debug!(pipe, "scan table={}", table);
log_debug!(request, "scan table={}", table);
let result = (|| {
if let Some(cols) = &columns {
@@ -670,7 +665,7 @@ impl Server {
match result {
Ok(rows) => Response::Rows { rows },
Err(e) => {
log_warn!(pipe, "scan {}: {}", table, e);
log_warn!(request, "scan {}: {}", table, e);
Response::Error {
message: format!("scan {}: {}", table, e),
}
@@ -679,13 +674,13 @@ impl Server {
}
Request::Insert { table, row } => {
log_debug!(pipe, "insert table={}", table);
log_debug!(request, "insert table={}", table);
let tname = table.clone();
let op = WalOp::Insert { table, row };
match self.write_via_wal(&op) {
Ok(()) => Response::Ok,
Err(e) => {
log_warn!(pipe, "insert {}: {}", tname, e);
log_warn!(request, "insert {}: {}", tname, e);
Response::Error {
message: format!("insert {}: {}", tname, e),
}
@@ -694,13 +689,13 @@ impl Server {
}
Request::InsertBatch { table, rows } => {
log_debug!(pipe, "insert_batch table={} rows={}", table, rows.len());
log_debug!(request, "insert_batch table={} rows={}", table, rows.len());
let tname = table.clone();
let op = WalOp::InsertBatch { table, rows };
match self.write_via_wal(&op) {
Ok(()) => Response::Ok,
Err(e) => {
log_warn!(pipe, "insert_batch {}: {}", tname, e);
log_warn!(request, "insert_batch {}: {}", tname, e);
Response::Error {
message: format!("insert_batch {}: {}", tname, e),
}
@@ -709,13 +704,13 @@ impl Server {
}
Request::DeleteKeys { table, keys } => {
log_debug!(pipe, "delete_keys table={} keys={}", table, keys.len());
log_debug!(request, "delete_keys table={} keys={}", table, keys.len());
let tname = table.clone();
let op = WalOp::DeleteKeys { table, keys };
match self.write_via_wal(&op) {
Ok(()) => Response::Ok,
Err(e) => {
log_warn!(pipe, "delete_keys {}: {}", tname, e);
log_warn!(request, "delete_keys {}: {}", tname, e);
Response::Error {
message: format!("delete_keys {}: {}", tname, e),
}
@@ -724,12 +719,12 @@ impl Server {
}
Request::LookupByIndex { table, column, key } => {
log_debug!(pipe, "lookup_by_index table={} column={} key={}", table, column, key);
log_debug!(request, "lookup_by_index table={} column={} key={}", table, column, key);
let indexed =
match self.with_existing_table(&table, |t| Ok(t.has_index(&column))) {
Ok(v) => v,
Err(e) => {
log_warn!(pipe, "lookup_by_index {}: {}", table, e);
log_warn!(request, "lookup_by_index {}: {}", table, e);
return Response::Error {
message: format!("lookup_by_index {}: {}", table, e),
};
@@ -752,7 +747,7 @@ impl Server {
match found {
Ok(rows) => Response::Rows { rows },
Err(e) => {
log_warn!(pipe, "lookup_by_index {}: {}", table, e);
log_warn!(request, "lookup_by_index {}: {}", table, e);
Response::Error {
message: format!("lookup_by_index {}: {}", table, e),
}
@@ -761,12 +756,12 @@ impl Server {
}
Request::RangeByIndex { table, column, lo, lo_inclusive, hi, hi_inclusive } => {
log_debug!(pipe, "range_by_index table={} column={}", table, column);
log_debug!(request, "range_by_index table={} column={}", table, column);
let indexed =
match self.with_existing_table(&table, |t| Ok(t.has_index(&column))) {
Ok(v) => v,
Err(e) => {
log_warn!(pipe, "range_by_index {}: {}", table, e);
log_warn!(request, "range_by_index {}: {}", table, e);
return Response::Error {
message: format!("range_by_index {}: {}", table, e),
};
@@ -781,7 +776,7 @@ impl Server {
Ok(Some(rows)) => Response::Rows { rows },
Ok(None) => Response::NoIndex,
Err(e) => {
log_warn!(pipe, "range_by_index {}: {}", table, e);
log_warn!(request, "range_by_index {}: {}", table, e);
Response::Error {
message: format!("range_by_index {}: {}", table, e),
}
@@ -790,13 +785,13 @@ impl Server {
}
Request::ReplaceAll { table, rows } => {
log_debug!(pipe, "replace_all table={} rows={}", table, rows.len());
log_debug!(request, "replace_all table={} rows={}", table, rows.len());
let tname = table.clone();
let op = WalOp::ReplaceAll { table, rows };
match self.write_via_wal(&op) {
Ok(()) => Response::Ok,
Err(e) => {
log_warn!(pipe, "replace_all {}: {}", tname, e);
log_warn!(request, "replace_all {}: {}", tname, e);
Response::Error {
message: format!("replace_all {}: {}", tname, e),
}
@@ -805,11 +800,11 @@ impl Server {
}
Request::ListTables => {
log_debug!(pipe, "list_tables");
log_debug!(request, "list_tables");
match self.list_tables() {
Ok(tables) => Response::Tables { tables },
Err(e) => {
log_warn!(pipe, "list_tables: {}", e);
log_warn!(request, "list_tables: {}", e);
Response::Error {
message: format!("list_tables: {}", e),
}
@@ -818,7 +813,7 @@ impl Server {
}
Request::ListCatalog => {
log_debug!(pipe, "list_catalog");
log_debug!(request, "list_catalog");
let c = self.catalog.lock().unwrap();
let schemas: Vec<TableSchemaWire> = c
.all_tables()
@@ -836,7 +831,7 @@ impl Server {
}
Request::DescribeTable { table } => {
log_debug!(pipe, "describe_table table={}", table);
log_debug!(request, "describe_table table={}", table);
match self.describe_table(&table) {
Ok((cols, count, indexes, stats)) => Response::Schema {
table,
@@ -846,7 +841,7 @@ impl Server {
stats,
},
Err(e) => {
log_warn!(pipe, "describe_table {}: {}", table, e);
log_warn!(request, "describe_table {}: {}", table, e);
Response::Error {
message: format!("describe_table {}: {}", table, e),
}
@@ -855,7 +850,7 @@ impl Server {
}
Request::CreateTable { table, columns } => {
log_debug!(pipe, "create_table table={} cols={}", table, columns.len());
log_debug!(request, "create_table table={} cols={}", table, columns.len());
{
let c = self.catalog.lock().unwrap();
@@ -887,7 +882,7 @@ impl Server {
}
Request::DropTable { table } => {
log_debug!(pipe, "drop_table table={}", table);
log_debug!(request, "drop_table table={}", table);
let dropped_indexes: Vec<String> = {
let mut c = self.catalog.lock().unwrap();
@@ -919,11 +914,11 @@ impl Server {
}
Request::CreateIndex { table, column } => {
log_debug!(pipe, "create_index table={} column={}", table, column);
log_debug!(request, "create_index table={} column={}", table, column);
match self.create_index(&table, &column) {
Ok(()) => Response::Ok,
Err(e) => {
log_warn!(pipe, "create_index {}({}): {}", table, column, e);
log_warn!(request, "create_index {}({}): {}", table, column, e);
Response::Error {
message: format!("create_index {}({}): {}", table, column, e),
}
@@ -932,11 +927,11 @@ impl Server {
}
Request::DropIndex { table, column } => {
log_debug!(pipe, "drop_index table={} column={}", table, column);
log_debug!(request, "drop_index table={} column={}", table, column);
match self.drop_index(&table, &column) {
Ok(()) => Response::Ok,
Err(e) => {
log_warn!(pipe, "drop_index {}({}): {}", table, column, e);
log_warn!(request, "drop_index {}({}): {}", table, column, e);
Response::Error {
message: format!("drop_index {}({}): {}", table, column, e),
}
@@ -945,11 +940,11 @@ impl Server {
}
Request::DropColumn { table, column } => {
log_debug!(pipe, "drop_column table={} column={}", table, column);
log_debug!(request, "drop_column table={} column={}", table, column);
match self.drop_column(&table, &column) {
Ok(()) => Response::Ok,
Err(e) => {
log_warn!(pipe, "drop_column {}({}): {}", table, column, e);
log_warn!(request, "drop_column {}({}): {}", table, column, e);
Response::Error {
message: format!("drop_column {}({}): {}", table, column, e),
}
@@ -958,11 +953,11 @@ impl Server {
}
Request::Compact { table } => {
log_debug!(pipe, "compact table={}", table);
log_debug!(request, "compact table={}", table);
match self.compact_table(&table) {
Ok(()) => Response::Ok,
Err(e) => {
log_warn!(pipe, "compact {}: {}", table, e);
log_warn!(request, "compact {}: {}", table, e);
Response::Error {
message: format!("compact {}: {}", table, e),
}
@@ -971,13 +966,13 @@ impl Server {
}
Request::ReplaceSchema { table, columns, rows } => {
log_debug!(pipe, "replace_schema table={} cols={}", table, columns.len());
log_debug!(request, "replace_schema table={} cols={}", table, columns.len());
let tname = table.clone();
let op = WalOp::ReplaceSchema { table, columns, rows };
match self.write_via_wal(&op) {
Ok(()) => Response::Ok,
Err(e) => {
log_warn!(pipe, "replace_schema {}: {}", tname, e);
log_warn!(request, "replace_schema {}: {}", tname, e);
Response::Error {
message: format!("replace_schema {}: {}", tname, e),
}
@@ -1015,6 +1010,7 @@ impl Server {
}
}
/// 账号列表转成行
fn account_rows(accounts: &[Account]) -> std::io::Result<Vec<Row>> {
accounts.iter().map(|a| Ok(HashMap::from([
("id".into(), serde_json::json!(a.id)),
@@ -1029,7 +1025,7 @@ fn account_rows(accounts: &[Account]) -> std::io::Result<Vec<Row>> {
]))).collect()
}
/// 系统表：列定义与索引都按 scripts/init.sql 写进数据字典
/// 按 init.sql 把系统表写进字典
fn declare_system_schema(catalog: &mut Catalog, rows: &[Row]) -> std::io::Result<()> {
for table in system_schema() {
let stats: &[Row] = if table.name == USERS_TABLE { rows } else { &[] };
@@ -1044,7 +1040,7 @@ fn declare_system_schema(catalog: &mut Catalog, rows: &[Row]) -> std::io::Result
Ok(())
}
/// 读一行账号：新格式是平铺的列，老格式是 {id, account:"<json>"}
/// 读一行账号（兼容老格式）
fn decode_account_row(row: &Row) -> std::io::Result<Account> {
if let Some(encoded) = row.get("account").and_then(serde_json::Value::as_str) {
return serde_json::from_str(encoded).map_err(|_| std::io::Error::other("invalid account record"));
@@ -1081,7 +1077,7 @@ fn now_stamp() -> String {
format_timestamp(seconds)
}
/// Unix 秒 → YYYY-MM-DD HH:MM:SS（UTC）
/// Unix 秒转时间戳文本
fn format_timestamp(seconds: i64) -> String {
let days = seconds.div_euclid(86_400);
let rest = seconds.rem_euclid(86_400);
@@ -1106,6 +1102,7 @@ fn civil_from_days(days: i64) -> (i64, u32, u32) {
(if month <= 2 { year + 1 } else { year }, month, day)
}
/// 规范化并校验账号名
fn account_name(user: &str) -> std::io::Result<String> {
if user.is_empty() || user.len() > 64 || !user.bytes().all(|c| c.is_ascii_alphanumeric() || b"_.-".contains(&c)) {
return Err(std::io::Error::other("invalid account name"));
@@ -1113,6 +1110,7 @@ fn account_name(user: &str) -> std::io::Result<String> {
Ok(user.to_ascii_lowercase())
}
/// 校验口令哈希长度
fn validate_account_hash(hash: &str) -> std::io::Result<()> {
if hash.is_empty() || hash.len() > 256 {
return Err(std::io::Error::other("invalid account credential"));
@@ -1120,6 +1118,7 @@ fn validate_account_hash(hash: &str) -> std::io::Result<()> {
Ok(())
}
/// 造一条新账号记录
fn new_account(id: i64, user: &str, password_hash: String) -> std::io::Result<Account> {
validate_account_hash(&password_hash)?;
Ok(Account {
@@ -1133,7 +1132,7 @@ fn new_account(id: i64, user: &str, password_hash: String) -> std::io::Result<Ac
}
/// 一张表的索引定义转线上格式
fn index_wires(schema: &chusql_storage::catalog::TableSchema) -> Vec<IndexWire> {
fn index_wires(schema: &crate::catalog::TableSchema) -> Vec<IndexWire> {
let mut out = vec![IndexWire {
column: "id".to_string(),
}];
@@ -1148,7 +1147,7 @@ fn index_wires(schema: &chusql_storage::catalog::TableSchema) -> Vec<IndexWire>
}
/// 一张表的列统计 -> 线上格式
fn stat_wires(schema: &chusql_storage::catalog::TableSchema) -> Vec<ColumnStatWire> {
fn stat_wires(schema: &crate::catalog::TableSchema) -> Vec<ColumnStatWire> {
schema
.stats
.iter()
@@ -1161,6 +1160,7 @@ fn stat_wires(schema: &chusql_storage::catalog::TableSchema) -> Vec<ColumnStatWi
}
impl Drop for Server {
/// 析构时保存数据字典
fn drop(&mut self) {
if let Ok(c) = self.catalog.lock() {
let _ = c.save(self.catalog_path());
@@ -1194,6 +1194,7 @@ struct Databases {
}
impl Databases {
/// 装载系统库与已有的具名库
fn new(cfg: Config) -> std::io::Result<Self> {
// 系统库按需创建：目录、字典与系统表缺失时自动补齐。
// 其余库只在 data/databases/<name>/ 下已存在时才装载，启动不会凭空建库。
@@ -1226,7 +1227,7 @@ impl Databases {
Ok(Self { root: cfg, system, named: Mutex::new(named) })
}
/// 在 data_dir/<name>/ 下开一个保留库（目录与字典、WAL 一起建起来）
/// 按名字打开或新建一个库
fn open(cfg: &Config, name: &str) -> std::io::Result<Server> {
let mut config = cfg.clone();
config.data_dir = cfg.data_dir.join(name);
@@ -1241,6 +1242,7 @@ impl Databases {
Ok(server)
}
/// 库级分发：先处理库管理，再转给选中的库
fn request(&self, mut value: serde_json::Value) -> std::io::Result<Response> {
use std::io::Error;
let method = value.get("method").and_then(|v| v.as_str()).unwrap_or("").to_string();
@@ -1329,6 +1331,7 @@ impl Databases {
}
}
/// 校验库名是否合法
fn valid_database(name: &str) -> bool {
let lower = name.to_ascii_lowercase();
let device = matches!(lower.as_str(), "con" | "prn" | "aux" | "nul")
@@ -1339,37 +1342,6 @@ fn valid_database(name: &str) -> bool {
&& name.as_bytes().first().is_some_and(|c| c.is_ascii_alphabetic() || *c == b'_')
}
/// 处理一条连接
fn handle(server: &Databases, conn: LocalSocketStream) -> std::io::Result<()> {
let mut writer = conn.try_clone()?;
let reader = BufReader::new(conn);
for line in reader.lines() {
let line = line?;
if line.trim().is_empty() {
continue;
}
let resp = match serde_json::from_str::<serde_json::Value>(&line) {
Ok(req) => match server.request(req) {
Ok(response) => response,
Err(e) => Response::Error { message: e.to_string() },
},
Err(e) => {
log_warn!(pipe, "bad request line: {}", e);
Response::Error {
message: format!("parse error: {}", e),
}
}
};
writeln!(writer, "{}", serde_json::to_string(&resp).unwrap())?;
writer.flush()?;
}
log_debug!(pipe, "connection closed");
Ok(())
}
/// 把配置来源打进日志
fn log_config(loaded: &Loaded) {
match &loaded.config_path {
@@ -1381,92 +1353,44 @@ fn log_config(loaded: &Loaded) {
}
}
/// 命令行用法
fn print_usage() {
println!("chusql-storage: ChuSQL 存储服务");
println!();
println!("用法: chusql-storage [--config <path>]");
println!();
println!("配置文件固定位置（安装时确定，按系统惯例）:");
println!(" {}", config::default_config_path().display());
println!("该文件存在才读，不存在就用内置默认值（不是错误）。");
println!("--config <path> 是唯一的显式覆盖手段；文件不存在或读不了会报错退出。");
println!("配置分区: [page] [btree] [buffer] [storage] [server] [log]");
println!("--help, -h 显示本帮助。");
/// 进程内存储句柄：一个数据目录一份状态，跨线程共享（内部各自加锁）。
pub struct Storage {
databases: Databases,
}
/// 解析命令行：只认 --config <path> / --config=<path> / --help / -h
fn parse_args(args: &[String]) -> Result<Option<String>, String> {
let mut explicit = None;
let mut i = 0;
while i < args.len() {
let arg = args[i].as_str();
if arg == "--config" {
let value = args.get(i + 1).ok_or("--config needs a path")?;
if value.trim().is_empty() {
return Err("--config needs a path".to_string());
}
explicit = Some(value.clone());
i += 2;
} else if let Some(value) = arg.strip_prefix("--config=") {
if value.trim().is_empty() {
return Err("--config needs a path".to_string());
}
explicit = Some(value.to_string());
i += 1;
} else if arg == "--help" || arg == "-h" {
print_usage();
std::process::exit(0);
} else {
return Err(format!("unknown argument: {}", arg));
}
}
Ok(explicit)
}
/// 进程入口
fn main() -> std::io::Result<()> {
let args: Vec<String> = std::env::args().skip(1).collect();
let explicit = match parse_args(&args) {
Ok(p) => p,
Err(e) => {
eprintln!("chusql-storage: {}", e);
eprintln!("用法: chusql-storage [--config <path>]，--help 看帮助");
std::process::exit(2);
}
};
let loaded = match config::load(explicit.as_deref()) {
Ok(l) => l,
Err(e) => {
log_error!(core, "config error: {}", e);
return Err(std::io::Error::new(std::io::ErrorKind::InvalidInput, e));
}
};
impl Storage {
/// 打开数据目录并初始化存储
pub fn open(config_path: Option<&str>) -> Result<Storage, String> {
let loaded = config::load(config_path)?;
log::init();
log::set_level(loaded.config.log_level);
log_info!(core, "chusql-storage {} starting", env!("CARGO_PKG_VERSION"));
log_info!(core, "chusql-core-storage {} starting", env!("CARGO_PKG_VERSION"));
log_config(&loaded);
let databases = Databases::new(loaded.config).map_err(|e| e.to_string())?;
Ok(Storage { databases })
}
let server = Arc::new(Databases::new(loaded.config)?);
let listener = endpoint::listen(&server.root.pipe_name)?;
log_info!(
core,
"listening on {}",
endpoint::display(&server.root.pipe_name)
);
for conn in listener.incoming() {
let conn = conn?;
let server = Arc::clone(&server);
thread::spawn(move || {
log_debug!(pipe, "connection accepted");
if let Err(e) = handle(&server, conn) {
log_error!(pipe, "connection error: {}", e);
/// 一行请求 JSON 换一行响应 JSON
pub fn request_line(&self, line: &str) -> String {
let response = match serde_json::from_str::<serde_json::Value>(line) {
Ok(value) => match self.databases.request(value) {
Ok(response) => response,
Err(e) => Response::Error { message: e.to_string() },
},
Err(e) => {
log_warn!(core, "bad request line: {}", e);
Response::Error {
message: format!("parse error: {}", e),
}
}
};
match serde_json::to_string(&response) {
Ok(text) => text,
Err(e) => {
log_error!(core, "response encode failed: {}", e);
"{\"status\":\"error\",\"message\":\"response encode failed\"}".to_string()
}
}
});
}
Ok(())
}
chusql-storage/src/wal.rs → chusql-core/storage/src/wal.rs
View File
File renamed without changes.
chusql-storage/tests/btree_test.rs → chusql-core/storage/tests/btree_test.rs
+4 -3
View File
@@ -1,9 +1,10 @@
use chusql_storage::btree::{fits_in_page, DiskBTree, MAX_KEY_BYTES};
use chusql_storage::config::{DEFAULT_BTREE_ORDER, DEFAULT_PAGE_SIZE};
use chusql_storage::page::DEFAULT_POOL_SIZE;
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::page::DEFAULT_POOL_SIZE;
// B+ 树测试：字节键、重复键、范围扫描、重开与配置校验。
/// 按默认参数打开指定索引文件
fn open(dir: &std::path::Path, name: &str) -> DiskBTree {
DiskBTree::open(dir.join(name), DEFAULT_PAGE_SIZE, DEFAULT_BTREE_ORDER, DEFAULT_POOL_SIZE).unwrap()
}
chusql-storage/tests/catalog_test.rs → chusql-core/storage/tests/catalog_test.rs
+4 -3
View File
@@ -1,11 +1,12 @@
use chusql_storage::catalog::Catalog;
use chusql_storage::protocol::Row;
use chusql_core_storage::catalog::Catalog;
use chusql_core_storage::protocol::Row;
use serde_json::json;
// 数据字典测试：补列、去重、未知表。
/// 用键值对构造一行
fn row(pairs: &[(&str, serde_json::Value)]) -> Row {
let mut m = Row::new();
for (k, v) in pairs {
@@ -85,7 +86,7 @@ fn remove_column_drops_definition_stats_and_index() {
/// 老类型名并到新写法，参数保留，未知类型原样
#[test]
fn normalize_type_maps_legacy_names() {
use chusql_storage::catalog::normalize_type;
use chusql_core_storage::catalog::normalize_type;
assert_eq!(normalize_type("integer"), "int");
assert_eq!(normalize_type("TEXT"), "str");
assert_eq!(normalize_type("BOOLEAN"), "bool");
chusql-storage/tests/config_test.rs → chusql-core/storage/tests/config_test.rs
+20 -13
View File
@@ -1,10 +1,8 @@
use std::path::PathBuf;
use std::sync::Mutex;
use chusql_storage::config::{
self, Config, DEFAULT_BTREE_ORDER, DEFAULT_PAGE_SIZE, DEFAULT_PIPE_NAME, Origin,
};
use chusql_storage::log::Level;
use chusql_core_storage::config::{self, Config, DEFAULT_BTREE_ORDER, DEFAULT_PAGE_SIZE, Origin};
use chusql_core_storage::log::Level;
// 配置测试：默认值、文件覆盖、环境变量彻底无效、非法值报错。
@@ -27,7 +25,6 @@ fn defaults_without_file() {
assert_eq!(loaded.config.page_size, DEFAULT_PAGE_SIZE);
assert_eq!(loaded.config.btree_order, DEFAULT_BTREE_ORDER);
assert_eq!(loaded.config.data_dir, config::default_data_dir());
assert_eq!(loaded.config.pipe_name, DEFAULT_PIPE_NAME);
assert_eq!(loaded.config.log_level, Level::Info);
}
@@ -50,11 +47,11 @@ fn file_overrides_only_written_keys() {
assert_eq!(order.2, Origin::Default);
}
/// 六项全写都生效
/// 五项全写都生效
#[test]
fn file_all_keys() {
let _guard = env_guard();
let text = "[page]\nsize = 8192\n[btree]\norder = 32\n[buffer]\npool_size = 128\n[storage]\ndata_dir = \"mydata\"\n[server]\npipe_name = \"mypipe\"\n[log]\nlevel = \"debug\"\n";
let text = "[page]\nsize = 8192\n[btree]\norder = 32\n[buffer]\npool_size = 128\n[storage]\ndata_dir = \"mydata\"\n[log]\nlevel = \"debug\"\n";
let path = PathBuf::from("t.toml");
let loaded = config::resolve(Some(text), Some(path.clone())).unwrap();
@@ -62,7 +59,6 @@ fn file_all_keys() {
assert_eq!(loaded.config.btree_order, 32);
assert_eq!(loaded.config.pool_size, 128);
assert_eq!(loaded.config.data_dir, PathBuf::from("mydata"));
assert_eq!(loaded.config.pipe_name, "mypipe");
assert_eq!(loaded.config.log_level, Level::Debug);
assert!(
loaded
@@ -72,7 +68,7 @@ fn file_all_keys() {
);
}
/// 环境变量完全无效：这条通道已经删掉，设了 CHUSQL_* 也只认文件/内置默认
/// 设了 CHUSQL_* 环境变量也不生效
#[test]
fn env_vars_are_ignored_entirely() {
let _guard = env_guard();
@@ -102,7 +98,7 @@ fn env_vars_are_ignored_entirely() {
}
}
/// 固定路径按系统惯例：<配置目录>/ChuSQL/chusql.toml
/// 固定配置路径在系统配置目录的 ChuSQL 下
#[test]
fn default_config_path_follows_system_convention() {
let _guard = env_guard();
@@ -121,7 +117,7 @@ fn default_config_path_follows_system_convention() {
}
}
/// 默认数据目录也按系统惯例：Windows 落 %LOCALAPPDATA%\ChuSQL\data，Unix 落 XDG 数据目录
/// 默认数据目录落地按系统惯例
#[test]
fn default_data_dir_follows_system_convention() {
let _guard = env_guard();
@@ -170,7 +166,7 @@ fn explicit_missing_path_is_an_error() {
assert!(err.contains("chusql-no-such-config-9f21.toml"), "got {}", err);
}
/// 不给 --config：固定路径没有文件时全用内置默认，且不报错
/// 不给 --config 且无配置文件时用内置默认
#[test]
fn load_without_explicit_path_uses_builtin_defaults() {
let _guard = env_guard();
@@ -181,12 +177,23 @@ fn load_without_explicit_path_uses_builtin_defaults() {
} else {
assert_eq!(loaded.config, Config::default());
assert_eq!(loaded.config.data_dir, config::default_data_dir());
assert_eq!(loaded.config.pipe_name, DEFAULT_PIPE_NAME);
assert!(loaded.origins.iter().all(|(_, _, o)| *o == Origin::Default));
assert!(loaded.config_path.is_none());
}
}
/// [server] 分区归别的层管；本层拼写错误要报错
#[test]
fn server_section_belongs_to_another_layer() {
let _guard = env_guard();
let db_server = "[server]\nhost = \"0.0.0.0\"\nport = 7778\nmax_rows = 10\n";
let loaded = config::resolve(Some(db_server), None).unwrap();
assert_eq!(loaded.config.data_dir, config::default_data_dir());
let typo = "[storage]\ndata_dirs = \"oops\"\n";
assert!(config::resolve(Some(typo), None).is_err());
}
/// 日志等级非法要报错
#[test]
fn rejects_bad_log_level() {
chusql-storage/tests/heap_test.rs → chusql-core/storage/tests/heap_test.rs
+12 -11
View File
@@ -1,11 +1,12 @@
use chusql_storage::config::DEFAULT_PAGE_SIZE;
use chusql_storage::heap::HeapTable;
use chusql_storage::page::DEFAULT_POOL_SIZE;
use chusql_storage::protocol::Row;
use chusql_core_storage::config::DEFAULT_PAGE_SIZE;
use chusql_core_storage::heap::HeapTable;
use chusql_core_storage::page::DEFAULT_POOL_SIZE;
use chusql_core_storage::protocol::Row;
use serde_json::json;
// 堆表测试：插查、跨页、大行、重开、索引重建。
/// 用键值对构造一行
fn row(pairs: &[(&str, serde_json::Value)]) -> Row {
let mut m = Row::new();
for (k, v) in pairs {
@@ -144,7 +145,7 @@ fn replace_all_rebuilds_index() {
dir.path().join("t.db"),
dir.path().join("t.idx"),
DEFAULT_PAGE_SIZE,
chusql_storage::config::DEFAULT_BTREE_ORDER,
chusql_core_storage::config::DEFAULT_BTREE_ORDER,
DEFAULT_POOL_SIZE,
)
.unwrap();
@@ -176,7 +177,7 @@ fn delete_by_keys_removes_rows() {
dir.path().join("t.db"),
dir.path().join("t.idx"),
DEFAULT_PAGE_SIZE,
chusql_storage::config::DEFAULT_BTREE_ORDER,
chusql_core_storage::config::DEFAULT_BTREE_ORDER,
DEFAULT_POOL_SIZE,
)
.unwrap();
@@ -214,7 +215,7 @@ fn insert_rows_batch() {
dir.path().join("t.db"),
dir.path().join("t.idx"),
DEFAULT_PAGE_SIZE,
chusql_storage::config::DEFAULT_BTREE_ORDER,
chusql_core_storage::config::DEFAULT_BTREE_ORDER,
DEFAULT_POOL_SIZE,
)
.unwrap();
@@ -234,7 +235,7 @@ fn insert_rows_batch() {
assert!(t.insert_rows(&dup).is_err());
}
/// 第二列索引：建索引时要求唯一，建完之后插入/删除都跟着维护
/// 第二列索引：建完插入/删除都跟着维护，值可重复
#[test]
fn secondary_index_is_maintained() {
let dir = tempfile::tempdir().unwrap();
@@ -242,7 +243,7 @@ fn secondary_index_is_maintained() {
dir.path().join("t.db"),
dir.path().join("t.idx"),
DEFAULT_PAGE_SIZE,
chusql_storage::config::DEFAULT_BTREE_ORDER,
chusql_core_storage::config::DEFAULT_BTREE_ORDER,
DEFAULT_POOL_SIZE,
)
.unwrap();
@@ -258,7 +259,7 @@ fn secondary_index_is_maintained() {
"code",
&dir.path().join("t.code.idx"),
DEFAULT_PAGE_SIZE,
chusql_storage::config::DEFAULT_BTREE_ORDER,
chusql_core_storage::config::DEFAULT_BTREE_ORDER,
DEFAULT_POOL_SIZE,
)
.unwrap();
@@ -292,7 +293,7 @@ fn secondary_index_is_maintained() {
"age",
&dir.path().join("d.age.idx"),
DEFAULT_PAGE_SIZE,
chusql_storage::config::DEFAULT_BTREE_ORDER,
chusql_core_storage::config::DEFAULT_BTREE_ORDER,
DEFAULT_POOL_SIZE,
)
.unwrap();
chusql-storage/tests/page_test.rs → chusql-core/storage/tests/page_test.rs
+2 -2
View File
@@ -1,5 +1,5 @@
use chusql_storage::config::DEFAULT_PAGE_SIZE;
use chusql_storage::page::{Page, PageFile};
use chusql_core_storage::config::DEFAULT_PAGE_SIZE;
use chusql_core_storage::page::{Page, PageFile};
// 页文件测试：读写、追加、覆写、页大小校验与页缓存。
chusql-storage/tests/pipe_test.rs → chusql-core/storage/tests/runtime_test.rs
+192 -294
View File
@@ -1,18 +1,23 @@
use std::io::{BufRead, BufReader, Write};
use std::process::{Child, Command, Stdio};
use std::thread;
use std::time::Duration;
use std::cell::RefCell;
use std::sync::Arc;
use interprocess::local_socket::prelude::*;
use interprocess::TryClone;
use chusql_core_storage::runtime::Storage;
// 端点集成测试：起真 server，跑协议、索引与配置（端点由 endpoint 模块统一算）。
// 进程内存储集成测试：协议请求、索引、账号与配置。
thread_local! {
/// 当前线程的存储实例：一个用例一个线程，用例内部按顺序起/停
static CURRENT: RefCell<Option<Arc<Storage>>> = const { RefCell::new(None) };
}
/// 一次会话就是当前线程的存储句柄
struct Conn(Arc<Storage>);
/// 扫描能按列投影，空列返回空行
#[test]
fn scan_projects_columns_and_preserves_empty_rows() -> Result<(), Box<dyn std::error::Error>> {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let (_srv, _data) = start_server();
let mut c = connect()?;
request_ok(&mut c, serde_json::json!({"method":"create_table","table":"items","columns":[{"name":"id","ty":"int"},{"name":"name","ty":"str"}]}))?;
request_ok(&mut c, serde_json::json!({"method":"insert_batch","table":"items","rows":[{"id":1,"name":"one"},{"id":2,"name":null}]}))?;
for (columns, expected) in [
@@ -27,11 +32,11 @@ fn scan_projects_columns_and_preserves_empty_rows() -> Result<(), Box<dyn std::e
Ok(())
}
/// 删列不改堆字节，重启后不再暴露该列
#[test]
fn drop_column_keeps_heap_bytes_and_hides_values_after_restart() -> Result<(), Box<dyn std::error::Error>> {
let pipe = unique_pipe_name();
let (server, data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let (server, data) = start_server();
let mut c = connect()?;
request_ok(&mut c, serde_json::json!({"method":"create_table","table":"items","columns":[{"name":"id","ty":"int"},{"name":"name","ty":"str"},{"name":"age","ty":"int"}]}))?;
request_ok(&mut c, serde_json::json!({"method":"insert_batch","table":"items","rows":[{"id":1,"name":"old","age":20},{"id":2,"name":"secret","age":30}]}))?;
for column in ["name", "age"] {
@@ -43,8 +48,8 @@ fn drop_column_keeps_heap_bytes_and_hides_values_after_restart() -> Result<(), B
assert_eq!(std::fs::read(&heap)?, before, "DROP COLUMN must not rewrite heap pages");
drop(c);
drop(server);
let _server = start_server_in(&pipe, data.path());
let mut c = connect(&pipe)?;
let _server = start_server_in(data.path());
let mut c = connect()?;
for request in [
serde_json::json!({"method":"scan","table":"items"}),
serde_json::json!({"method":"range_by_index","table":"items","column":"age","lo":0}),
@@ -64,12 +69,12 @@ fn drop_column_keeps_heap_bytes_and_hides_values_after_restart() -> Result<(), B
Ok(())
}
/// 各库字典与行互相隔离，删库不影响别库
#[test]
fn databases_isolate_catalog_and_rows() -> Result<(), Box<dyn std::error::Error>> {
let pipe = unique_pipe_name();
let (_srv, data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let request = |c: &mut LocalSocketStream, value: serde_json::Value| -> Result<serde_json::Value, serde_json::Error> {
let (_srv, data) = start_server();
let mut c = connect()?;
let request = |c: &mut Conn, value: serde_json::Value| -> Result<serde_json::Value, serde_json::Error> {
serde_json::from_str(&send(c, &value.to_string()))
};
for database in ["alpha", "beta"] {
@@ -90,12 +95,12 @@ fn databases_isolate_catalog_and_rows() -> Result<(), Box<dyn std::error::Error>
}
/// 隐藏列的 WAL 重放两次幂等，且不动堆文件
#[test]
fn hidden_column_wal_replays_twice_without_touching_heap() -> Result<(), Box<dyn std::error::Error>> {
use chusql_storage::wal::{Wal, WalOp};
let pipe = unique_pipe_name();
let (server, data) = start_server(&pipe);
let mut c = connect(&pipe)?;
use chusql_core_storage::wal::{Wal, WalOp};
let (server, data) = start_server();
let mut c = connect()?;
request_ok(&mut c, serde_json::json!({"method":"insert","table":"items","row":{"id":1,"secret":"old"}}))?;
drop(c);
drop(server);
@@ -109,8 +114,8 @@ fn hidden_column_wal_replays_twice_without_touching_heap() -> Result<(), Box<dyn
assert_eq!(wal.read()?, Some(op));
assert!(std::fs::metadata(wal.path())?.len() < 100);
drop(wal);
let server = start_server_in(&pipe, data.path());
let mut c = connect(&pipe)?;
let server = start_server_in(data.path());
let mut c = connect()?;
let result: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"scan","table":"items"}"#))?;
assert_eq!(result["rows"], serde_json::json!([{"id":1}]));
let after = std::fs::read(&heap)?;
@@ -129,11 +134,11 @@ fn hidden_column_wal_replays_twice_without_touching_heap() -> Result<(), Box<dyn
Ok(())
}
/// 删列失败时保留 WAL，重启后补做并放行
#[test]
fn hidden_column_failure_preserves_wal_until_recovery() -> Result<(), Box<dyn std::error::Error>> {
let pipe = unique_pipe_name();
let (server, data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let (server, data) = start_server();
let mut c = connect()?;
request_ok(&mut c, serde_json::json!({"method":"insert","table":"items","row":{"id":1,"secret":"old"}}))?;
let index = data.path().join("databases/main/items.secret.idx");
std::fs::create_dir(&index)?;
@@ -146,18 +151,18 @@ fn hidden_column_failure_preserves_wal_until_recovery() -> Result<(), Box<dyn st
drop(c);
drop(server);
std::fs::remove_dir(index)?;
let _server = start_server_in(&pipe, data.path());
let mut c = connect(&pipe)?;
let _server = start_server_in(data.path());
let mut c = connect()?;
let rows: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"scan","table":"items"}"#))?;
assert_eq!(rows["rows"], serde_json::json!([{"id":1}]));
Ok(())
}
/// 删带索引的列会连索引文件一起删掉
#[test]
fn drop_column_with_a_live_index_removes_the_index_file() -> Result<(), Box<dyn std::error::Error>> {
let pipe = unique_pipe_name();
let (_srv, data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let (_srv, data) = start_server();
let mut c = connect()?;
request_ok(&mut c, serde_json::json!({"method":"insert","table":"items","row":{"id":1,"code":7}}))?;
request_ok(&mut c, serde_json::json!({"method":"create_index","table":"items","column":"code"}))?;
let index = data.path().join("databases/main/items.code.idx");
@@ -176,11 +181,11 @@ fn drop_column_with_a_live_index_removes_the_index_file() -> Result<(), Box<dyn
Ok(())
}
/// 整理表会重写页面，清掉隐藏列字节
#[test]
fn compact_reclaims_hidden_column_bytes() -> Result<(), Box<dyn std::error::Error>> {
let pipe = unique_pipe_name();
let (server, data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let (server, data) = start_server();
let mut c = connect()?;
for id in 1..=3 {
request_ok(&mut c, serde_json::json!({"method":"insert","table":"items","row":{"id":id,"secret":"padding","note":"n"}}))?;
}
@@ -200,18 +205,18 @@ fn compact_reclaims_hidden_column_bytes() -> Result<(), Box<dyn std::error::Erro
request_ok(&mut c, serde_json::json!({"method":"insert","table":"items","row":{"id":4,"note":"x"}}))?;
drop(c);
drop(server);
let _server = start_server_in(&pipe, data.path());
let mut c = connect(&pipe)?;
let _server = start_server_in(data.path());
let mut c = connect()?;
let rows: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"scan","table":"items"}"#))?;
assert_eq!(rows["rows"].as_array().map(Vec::len), Some(4), "rows survive compaction: {}", rows);
Ok(())
}
/// 启动时自动整理带隐藏列的表
#[test]
fn startup_compaction_reclaims_dropped_columns() -> Result<(), Box<dyn std::error::Error>> {
let pipe = unique_pipe_name();
let (server, data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let (server, data) = start_server();
let mut c = connect()?;
request_ok(&mut c, serde_json::json!({"method":"insert","table":"items","row":{"id":1,"secret":"padding"}}))?;
request_ok(&mut c, serde_json::json!({"method":"drop_column","table":"items","column":"secret"}))?;
let heap = data.path().join("databases/main/items.db");
@@ -219,8 +224,8 @@ fn startup_compaction_reclaims_dropped_columns() -> Result<(), Box<dyn std::erro
drop(c);
drop(server);
let _server = start_server_in(&pipe, data.path());
let mut c = connect(&pipe)?;
let _server = start_server_in(data.path());
let mut c = connect()?;
assert!(
!std::fs::read(&heap)?.windows(6).any(|w| w == &b"secret"[..]),
"startup must compact tables that still carry hidden columns"
@@ -230,11 +235,11 @@ fn startup_compaction_reclaims_dropped_columns() -> Result<(), Box<dyn std::erro
Ok(())
}
/// 非法库名被拒；system 是唯一保留库
#[test]
fn databases_reject_unsafe_names_and_keep_only_system_reserved() -> Result<(), Box<dyn std::error::Error>> {
let pipe = unique_pipe_name();
let (_srv, data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let (_srv, data) = start_server();
let mut c = connect()?;
for database in ["", "../escape", "a/b", "a.b", "CON", "__chusql_users"] {
let response: serde_json::Value = serde_json::from_str(&send(&mut c, &serde_json::json!({"method":"create_database","database":database}).to_string()))?;
assert_eq!(response["status"], "error", "{database}: {response}");
@@ -255,11 +260,11 @@ fn databases_reject_unsafe_names_and_keep_only_system_reserved() -> Result<(), B
Ok(())
}
/// 账号只存在 system 库，默认工作库不存在
#[test]
fn system_database_owns_accounts_and_nothing_is_default() -> Result<(), Box<dyn std::error::Error>> {
let pipe = unique_pipe_name();
let (_srv, data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let (_srv, data) = start_server();
let mut c = connect()?;
// 启动只建 system，另一个是测试自己建的 main
let listed: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"list_databases"}"#))?;
assert_eq!(listed["tables"], serde_json::json!(["main", "system"]));
@@ -278,12 +283,11 @@ fn system_database_owns_accounts_and_nothing_is_default() -> Result<(), Box<dyn
Ok(())
}
/// 没选库的裸表名请求会被拒；限定名（db.table）不用选库
/// 裸表名没选库会被拒；限定名不用选库
#[test]
fn unqualified_requests_need_a_selected_database() -> Result<(), Box<dyn std::error::Error>> {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let (_srv, _data) = start_server();
let mut c = connect()?;
let response: serde_json::Value = serde_json::from_str(&send_raw(&mut c, r#"{"method":"scan","table":"items"}"#))?;
assert_eq!(response["status"], "error", "{response}");
assert!(response["message"].as_str().unwrap_or("").contains("no database selected"), "{response}");
@@ -298,85 +302,59 @@ fn unqualified_requests_need_a_selected_database() -> Result<(), Box<dyn std::er
}
/// 发一条请求并断言状态是 ok
fn request_ok(c: &mut LocalSocketStream, value: serde_json::Value) -> Result<(), Box<dyn std::error::Error>> {
fn request_ok(c: &mut Conn, value: serde_json::Value) -> Result<(), Box<dyn std::error::Error>> {
let response: serde_json::Value = serde_json::from_str(&send(c, &value.to_string()))?;
assert_eq!(response["status"], "ok", "{value}: {response}");
Ok(())
}
/// 唯一管道名，避免测试互抢
fn unique_pipe_name() -> String {
let id = std::process::id();
let ns = std::time::SystemTime::now()
.duration_since(std::time::UNIX_EPOCH)
.unwrap()
.as_nanos();
format!("chusql-test-{}-{}", id, ns)
}
struct ServerProc(Child);
/// 一次存储实例的持有者
struct ServerProc;
impl Drop for ServerProc {
/// 测试结束杀掉子进程
fn drop(&mut self) {
let _ = self.0.kill();
let _ = self.0.wait();
}
/// 实例由本线程 CURRENT 管，这里不用清理
fn drop(&mut self) {}
}
/// 起 server，等管道可连
fn start_server(pipe: &str) -> (ServerProc, tempfile::TempDir) {
/// 起存储，返回句柄与数据目录
fn start_server() -> (ServerProc, tempfile::TempDir) {
let data = tempfile::tempdir().unwrap();
let server = start_server_in(pipe, data.path());
let server = start_server_in(data.path());
(server, data)
}
fn start_server_in(pipe: &str, data: &std::path::Path) -> ServerProc {
let config = write_config(data, pipe);
let child = Command::new(env!("CARGO_BIN_EXE_chusql-storage"))
.arg("--config")
.arg(&config)
.stdout(Stdio::null())
.stderr(Stdio::null())
.spawn()
.expect("failed to spawn server");
let srv = ServerProc(child);
for _ in 0..100 {
if connect(pipe).is_ok() {
// 服务启动只建 system 库，测试库在这里显式建
create_fixture_database(pipe);
return srv;
}
thread::sleep(Duration::from_millis(50));
}
panic!("server did not start within 5s");
/// 在指定数据目录起存储并建测试库
fn start_server_in(data: &std::path::Path) -> ServerProc {
open_storage(&write_config(data));
create_fixture_database();
ServerProc
}
/// 写一份配置给子进程：管名与数据目录都走 TOML，
/// 路径用单引号字面量串，免得 Windows 反斜杠要转义。
fn write_config(data: &std::path::Path, pipe: &str) -> std::path::PathBuf {
/// 按配置文件打开存储，替换本线程上一个实例
fn open_storage(config: &std::path::Path) {
CURRENT.with(|slot| *slot.borrow_mut() = None);
let storage = Arc::new(Storage::open(Some(config.to_str().unwrap())).expect("open storage"));
CURRENT.with(|slot| *slot.borrow_mut() = Some(storage));
}
/// 生成只写数据目录的临时配置文件
fn write_config(data: &std::path::Path) -> std::path::PathBuf {
let id = std::process::id();
let ns = std::time::SystemTime::now()
.duration_since(std::time::UNIX_EPOCH)
.unwrap()
.as_nanos();
let path = data.join(format!("chusql-{}-{}.toml", id, ns));
let text = format!(
"[server]\npipe_name = '{}'\n[storage]\ndata_dir = '{}'\n",
pipe,
data.display()
);
let text = format!("[storage]\ndata_dir = '{}'\n", data.display());
std::fs::write(&path, text).unwrap();
path
}
/// 命名库重启后仍在，账号仍是全局的
#[test]
fn named_database_survives_restart_and_accounts_stay_global() -> Result<(), Box<dyn std::error::Error>> {
let pipe = unique_pipe_name();
let (server, data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let (server, data) = start_server();
let mut c = connect()?;
for request in [
serde_json::json!({"method":"create_database","database":"sales"}),
serde_json::json!({"method":"create_table","database":"sales","table":"items","columns":[{"name":"id","ty":"int"}]}),
@@ -387,8 +365,8 @@ fn named_database_survives_restart_and_accounts_stay_global() -> Result<(), Box<
}
drop(c);
drop(server);
let _restarted = start_server_in(&pipe, data.path());
let mut c = connect(&pipe)?;
let _restarted = start_server_in(data.path());
let mut c = connect()?;
let rows: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"scan","table":"sales.items"}"#))?;
assert_eq!(rows["rows"], serde_json::json!([{"id":7}]));
let accounts: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"accounts_list","database":"sales"}"#))?;
@@ -398,16 +376,17 @@ fn named_database_survives_restart_and_accounts_stay_global() -> Result<(), Box<
Ok(())
}
/// 连到指定端点的存储进程。端点规则与 server 侧共用 endpoint 模块，
/// 所以 Windows 的具名管道与 Unix 的套接字文件都由同一处决定。
fn connect(pipe: &str) -> std::io::Result<LocalSocketStream> {
chusql_storage::endpoint::connect(pipe)
/// 连到本线程当前的存储：进程内实现就是本线程当前句柄
fn connect() -> std::io::Result<Conn> {
CURRENT.with(|slot| slot.borrow().clone())
.map(Conn)
.ok_or_else(|| std::io::Error::other("storage not started"))
}
/// 测试自己的库名：服务启动只建 system 库，测试显式建这一个
/// 测试用的库名：system 之外的库由测试自建
const FIXTURE_DATABASE: &str = "main";
/// 请求里没写库名就补上测试库：服务不再自带默认库，裸表名必须先选库
/// 请求没写库名时补上测试库
fn with_default_database(line: &str) -> String {
match serde_json::from_str::<serde_json::Value>(line) {
Ok(serde_json::Value::Object(mut object)) => {
@@ -419,36 +398,28 @@ fn with_default_database(line: &str) -> String {
}
/// 连通后显式建测试库；重启时库已存在，报错忽略
fn create_fixture_database(pipe: &str) {
if let Ok(mut stream) = connect(pipe) {
let _ = send_raw(&mut stream, &format!(r#"{{"method":"create_database","database":"{FIXTURE_DATABASE}"}}"#));
fn create_fixture_database() {
if let Ok(mut c) = connect() {
let _ = send_raw(&mut c, &format!(r#"{{"method":"create_database","database":"{FIXTURE_DATABASE}"}}"#));
}
}
/// 发一行请求读一行响应（没写库名就补测试库）
fn send(stream: &mut LocalSocketStream, line: &str) -> String {
send_raw(stream, &with_default_database(line))
fn send(c: &mut Conn, line: &str) -> String {
send_raw(c, &with_default_database(line))
}
/// 原样发一行请求，不补库名——用来验证"没选库"的行为
fn send_raw(stream: &mut LocalSocketStream, line: &str) -> String {
stream.write_all(line.as_bytes()).unwrap();
stream.write_all(b"\n").unwrap();
stream.flush().unwrap();
let mut reader = BufReader::new(stream.try_clone().unwrap());
let mut buf = String::new();
reader.read_line(&mut buf).unwrap();
buf.trim().to_string()
fn send_raw(c: &mut Conn, line: &str) -> String {
c.0.request_line(line).trim().to_string()
}
/// ping 回 pong
/// 只有字典登记的表才算存在，孤儿文件不算
#[test]
fn catalog_is_the_only_table_authority() -> std::io::Result<()> {
let pipe = unique_pipe_name();
let (_srv, data) = start_server(&pipe);
let (_srv, data) = start_server();
std::fs::write(data.path().join("databases/main/orphan.db"), b"orphan")?;
let mut c = connect(&pipe)?;
let mut c = connect()?;
for method in ["scan", "describe_table"] {
let result = send(&mut c, &format!(r#"{{"method":"{method}","table":"orphan"}}"#));
assert!(result.contains("unknown table"), "{result}");
@@ -458,11 +429,11 @@ fn catalog_is_the_only_table_authority() -> std::io::Result<()> {
Ok(())
}
/// 保留系统表拒绝所有通用操作
#[test]
fn reserved_tables_reject_every_generic_operation() -> std::io::Result<()> {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let (_srv, _data) = start_server();
let mut c = connect()?;
for method in ["scan", "insert", "insert_batch", "delete_keys", "lookup_by_index",
"replace_all", "describe_table", "create_table", "drop_table", "create_index",
"drop_index", "drop_column"] {
@@ -474,11 +445,11 @@ fn reserved_tables_reject_every_generic_operation() -> std::io::Result<()> {
Ok(())
}
/// 通用接口拒绝表名与列名里的路径别名
#[test]
fn generic_ipc_rejects_path_aliases() -> std::io::Result<()> {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let (_srv, _data) = start_server();
let mut c = connect()?;
for table in ["../__chusql_users", "__CHUSQL_USERS", "__chusql_users."] {
let result = send(&mut c, &serde_json::json!({"method":"scan", "table":table}).to_string());
assert!(result.contains("error"), "{result}");
@@ -488,11 +459,11 @@ fn generic_ipc_rejects_path_aliases() -> std::io::Result<()> {
Ok(())
}
/// 账号增改删，且普通列表接口看不到账号表
#[test]
fn account_create_reset_drop_and_hidden_from_ordinary_api() -> Result<(), Box<dyn std::error::Error>> {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let (_srv, _data) = start_server();
let mut c = connect()?;
assert_eq!(serde_json::from_str::<serde_json::Value>(&send(&mut c, r#"{"method":"accounts_list"}"#))?["accounts"], serde_json::json!([]));
let create = r#"{"method":"account_create","user":"Alice","password_hash":"hash-one"}"#;
let created: serde_json::Value = serde_json::from_str(&send(&mut c, create))?;
@@ -518,28 +489,19 @@ fn account_create_reset_drop_and_hidden_from_ordinary_api() -> Result<(), Box<dy
Ok(())
}
fn restart_at(pipe: &str, data: &std::path::Path) -> std::io::Result<ServerProc> {
let child = Command::new(env!("CARGO_BIN_EXE_chusql-storage"))
.arg("--config")
.arg(write_config(data, pipe))
.stdout(Stdio::null()).stderr(Stdio::null()).spawn()?;
let server = ServerProc(child);
for _ in 0..100 {
if connect(pipe).is_ok() {
create_fixture_database(pipe);
return Ok(server);
}
thread::sleep(Duration::from_millis(50));
}
Err(std::io::Error::other("server restart timed out"))
/// 用同一份数据目录重开一次存储
fn restart_at(data: &std::path::Path) -> std::io::Result<ServerProc> {
open_storage(&write_config(data));
create_fixture_database();
Ok(ServerProc)
}
/// 账号快照 WAL 重放两次不产生重复账号
#[test]
fn account_snapshot_replays_twice_without_duplicating_accounts() -> Result<(), Box<dyn std::error::Error>> {
use chusql_storage::{protocol::Account, wal::{Wal, WalOp}};
let pipe = unique_pipe_name();
let (server, data) = start_server(&pipe);
let mut c = connect(&pipe)?;
use chusql_core_storage::{protocol::Account, wal::{Wal, WalOp}};
let (server, data) = start_server();
let mut c = connect()?;
let initial = send(&mut c, r#"{"method":"account_create","user":"alice","password_hash":"hash-one"}"#);
assert!(initial.contains("accounts"), "{initial}");
let changed: serde_json::Value = serde_json::from_str(&send(&mut c,
@@ -554,8 +516,8 @@ fn account_snapshot_replays_twice_without_duplicating_accounts() -> Result<(), B
drop(wal);
std::fs::write(data.path().join("system/__chusql_users.idx"), b"torn index")?;
std::fs::write(data.path().join("system/__chusql_users.db"), b"torn heap")?;
let restarted = restart_at(&pipe, data.path())?;
let mut connection = connect(&pipe)?;
let restarted = restart_at(data.path())?;
let mut connection = connect()?;
let actual: serde_json::Value = serde_json::from_str(&send(&mut connection, r#"{"method":"accounts_list"}"#))?;
assert_eq!(actual, changed);
assert_eq!(std::fs::metadata(data.path().join("system/wal.log"))?.len(), 0);
@@ -565,11 +527,11 @@ fn account_snapshot_replays_twice_without_duplicating_accounts() -> Result<(), B
Ok(())
}
/// 账号操作失败时保留 WAL 并挡住写入
#[test]
fn account_failure_preserves_wal_and_blocks_writes() -> Result<(), Box<dyn std::error::Error>> {
let pipe = unique_pipe_name();
let (server, data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let (server, data) = start_server();
let mut c = connect()?;
std::fs::create_dir(data.path().join("system/catalog.json.pending"))?;
let result = send(&mut c, r#"{"method":"account_create","user":"alice","password_hash":"hash-one"}"#);
assert!(result.contains("error"), "{result}");
@@ -583,30 +545,30 @@ fn account_failure_preserves_wal_and_blocks_writes() -> Result<(), Box<dyn std::
drop(c);
drop(server);
std::fs::remove_dir(data.path().join("system/catalog.json.pending"))?;
let _restarted = restart_at(&pipe, data.path())?;
let mut c = connect(&pipe)?;
let _restarted = restart_at(data.path())?;
let mut c = connect()?;
let recovered = send(&mut c, r#"{"method":"accounts_list"}"#);
assert!(recovered.contains("hash-one"), "{recovered}");
Ok(())
}
/// 账号文件已存在时拒绝建账号
#[test]
fn account_create_rejects_reserved_file_collision() -> std::io::Result<()> {
let pipe = unique_pipe_name();
let (_server, data) = start_server(&pipe);
let (_server, data) = start_server();
std::fs::write(data.path().join("system/__chusql_users.db"), b"existing")?;
let mut c = connect(&pipe)?;
let mut c = connect()?;
let result = send(&mut c, r#"{"method":"account_create","user":"alice","password_hash":"hash-one"}"#);
assert!(result.contains("collision"), "{result}");
assert_eq!(std::fs::read(data.path().join("system/__chusql_users.db"))?, b"existing");
Ok(())
}
/// 超长密码哈希在写 WAL 之前就被拒
#[test]
fn oversized_account_hash_is_rejected_before_wal() -> Result<(), Box<dyn std::error::Error>> {
let pipe = unique_pipe_name();
let (_server, data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let (_server, data) = start_server();
let mut c = connect()?;
let result = send(&mut c, &serde_json::json!({"method":"account_create", "user":"alice",
"password_hash":"a".repeat(300)}).to_string());
assert!(result.contains("invalid account credential"), "{result}");
@@ -616,16 +578,16 @@ fn oversized_account_hash_is_rejected_before_wal() -> Result<(), Box<dyn std::er
Ok(())
}
/// 字典里已有同名普通表时拒绝建账号
#[test]
fn account_create_rejects_existing_ordinary_catalog_entry() -> std::io::Result<()> {
let data = tempfile::tempdir()?;
let mut catalog = chusql_storage::catalog::Catalog::default();
let mut catalog = chusql_core_storage::catalog::Catalog::default();
catalog.create_table("__chusql_users", Vec::new())?;
std::fs::create_dir(data.path().join("system"))?;
catalog.save(data.path().join("system/catalog.json"))?;
let pipe = unique_pipe_name();
let _server = restart_at(&pipe, data.path())?;
let mut c = connect(&pipe)?;
let _server = restart_at(data.path())?;
let mut c = connect()?;
let result = send(&mut c, r#"{"method":"account_create","user":"alice","password_hash":"hash-one"}"#);
assert!(result.contains("collision"), "{result}");
Ok(())
@@ -634,9 +596,8 @@ fn account_create_rejects_existing_ordinary_catalog_entry() -> std::io::Result<(
/// 列出已建的表
#[test]
fn list_tables_returns_created_tables() {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe).unwrap();
let (_srv, _data) = start_server();
let mut c = connect().unwrap();
send(&mut c, r#"{"method":"insert","table":"users","row":{"id":1}}"#);
send(&mut c, r#"{"method":"insert","table":"orders","row":{"id":1}}"#);
@@ -649,9 +610,8 @@ fn list_tables_returns_created_tables() {
/// 整表替换只剩新行
#[test]
fn replace_all_replaces_rows() {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe).unwrap();
let (_srv, _data) = start_server();
let mut c = connect().unwrap();
send(&mut c, r#"{"method":"insert","table":"users","row":{"id":1,"name":"Alice"}}"#);
send(&mut c, r#"{"method":"insert","table":"users","row":{"id":2,"name":"Bob"}}"#);
@@ -670,9 +630,8 @@ fn replace_all_replaces_rows() {
/// 按 id 查（列名走默认值 `id`，老客户端不用改）
#[test]
fn insert_then_lookup_by_index() {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe).unwrap();
let (_srv, _data) = start_server();
let mut c = connect().unwrap();
for (id, name) in [(1, "Alice"), (2, "Bob"), (3, "Carol")] {
let req = format!(
@@ -693,9 +652,8 @@ fn insert_then_lookup_by_index() {
/// 同一个 id 插两次要报错（索引列是唯一的）
#[test]
fn duplicate_id_is_rejected() {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe).unwrap();
let (_srv, _data) = start_server();
let mut c = connect().unwrap();
let req = r#"{"method":"insert","table":"dup_id","row":{"id":1,"name":"A"}}"#;
assert!(send(&mut c, req).contains(r#""status":"ok""#));
@@ -708,9 +666,8 @@ fn duplicate_id_is_rejected() {
/// 批量插入一次全进
#[test]
fn insert_batch_writes_all_rows() {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe).unwrap();
let (_srv, _data) = start_server();
let mut c = connect().unwrap();
let r = send(
&mut c,
@@ -728,9 +685,8 @@ fn insert_batch_writes_all_rows() {
/// 行级删除：行没了、索引条目也没了、别人不受影响
#[test]
fn delete_keys_removes_row_and_index_entry() {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe).unwrap();
let (_srv, _data) = start_server();
let mut c = connect().unwrap();
for (id, name) in [(1, "Alice"), (2, "Bob"), (3, "Carol")] {
let req = format!(
@@ -757,9 +713,8 @@ fn delete_keys_removes_row_and_index_entry() {
/// 给第二列建索引后能按那一列查
#[test]
fn create_index_on_secondary_column() {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe).unwrap();
let (_srv, _data) = start_server();
let mut c = connect().unwrap();
for (id, code) in [(1, 5001), (2, 5002), (3, 5003)] {
let req = format!(
@@ -794,9 +749,8 @@ fn create_index_on_secondary_column() {
/// 删列同时摘掉索引与行内该格
#[test]
fn drop_column_removes_column_index_and_values() {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe).unwrap();
let (_srv, _data) = start_server();
let mut c = connect().unwrap();
for (id, code, note) in [(1, 5001, "a"), (2, 5002, "b")] {
let req = format!(
@@ -835,12 +789,11 @@ fn drop_column_removes_column_index_and_values() {
assert!(r.contains(r#""status":"error""#), "a missing column should error: {}", r);
}
/// 重复值列允许建索引：点查把重复的行都取回来，删一行不影响另一行；id 仍然唯一
/// 重复值列能建索引，删一行不影响另一行；id 仍唯一
#[test]
fn create_index_accepts_duplicate_values() {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe).unwrap();
let (_srv, _data) = start_server();
let mut c = connect().unwrap();
send(&mut c, r#"{"method":"insert","table":"dup_t","row":{"id":1,"age":30}}"#);
send(&mut c, r#"{"method":"insert","table":"dup_t","row":{"id":2,"age":30}}"#);
@@ -865,9 +818,8 @@ fn create_index_accepts_duplicate_values() {
/// 数据字典里的统计：不同值个数
#[test]
fn stats_report_distinct_values() {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe).unwrap();
let (_srv, _data) = start_server();
let mut c = connect().unwrap();
for (id, age) in [(1, 30), (2, 30), (3, 41)] {
let req = format!(
@@ -891,24 +843,11 @@ fn stats_report_distinct_values() {
/// 重开服务后索引仍在
#[test]
fn lookup_survives_reopen() {
let pipe = unique_pipe_name();
let data = tempfile::tempdir().unwrap();
{
let child = Command::new(env!("CARGO_BIN_EXE_chusql-storage"))
.arg("--config")
.arg(write_config(data.path(), &pipe))
.stdout(Stdio::null())
.stderr(Stdio::null())
.spawn()
.unwrap();
let srv = ServerProc(child);
for _ in 0..100 {
if connect(&pipe).is_ok() { break; }
thread::sleep(Duration::from_millis(50));
}
create_fixture_database(&pipe);
let mut c = connect(&pipe).unwrap();
let _srv = start_server_in(data.path());
let mut c = connect().unwrap();
for (id, name) in [(1, "Alice"), (2, "Bob"), (3, "Carol")] {
let req = format!(
r#"{{"method":"insert","table":"persist","row":{{"id":{},"name":"{}"}},"key":{}}}"#,
@@ -916,29 +855,11 @@ fn lookup_survives_reopen() {
);
send(&mut c, &req);
}
drop(srv);
}
thread::sleep(Duration::from_millis(200));
let _srv = start_server_in(data.path());
let (_srv, _data) = {
let child = Command::new(env!("CARGO_BIN_EXE_chusql-storage"))
.arg("--config")
.arg(write_config(data.path(), &pipe))
.stdout(Stdio::null())
.stderr(Stdio::null())
.spawn()
.unwrap();
let srv = ServerProc(child);
for _ in 0..100 {
if connect(&pipe).is_ok() { break; }
thread::sleep(Duration::from_millis(50));
}
create_fixture_database(&pipe);
(srv, data)
};
let mut c = connect(&pipe).unwrap();
let mut c = connect().unwrap();
let r = send(&mut c, r#"{"method":"lookup_by_index","table":"persist","key":2}"#);
assert!(r.contains("Bob"), "persist lookup: {}", r);
}
@@ -947,34 +868,19 @@ fn lookup_survives_reopen() {
#[test]
fn config_file_is_used() {
let dir = tempfile::tempdir().unwrap();
let pipe = unique_pipe_name();
let data_dir = dir.path().join("data");
let config_path = dir.path().join("chusql-storage.toml");
let config_path = dir.path().join("chusql-core-storage.toml");
let text = format!(
"[server]\npipe_name = \"{}\"\n[storage]\ndata_dir = \"{}\"\n[log]\nlevel = \"debug\"\n",
pipe,
"[storage]\ndata_dir = \"{}\"\n[log]\nlevel = \"debug\"\n",
data_dir.display().to_string().replace('\\', "/")
);
std::fs::write(&config_path, text).unwrap();
let child = Command::new(env!("CARGO_BIN_EXE_chusql-storage"))
.arg("--config")
.arg(&config_path)
.stdout(Stdio::null())
.stderr(Stdio::null())
.spawn()
.expect("failed to spawn server");
let _srv = ServerProc(child);
for _ in 0..100 {
if connect(&pipe).is_ok() {
break;
}
thread::sleep(Duration::from_millis(50));
}
create_fixture_database(&pipe);
open_storage(&config_path);
create_fixture_database();
let mut c = connect(&pipe).unwrap();
let mut c = connect().unwrap();
assert_eq!(send(&mut c, r#"{"method":"ping"}"#), r#"{"status":"pong"}"#);
let r = send(&mut c, r#"{"method":"insert","table":"cfg","row":{"id":1}}"#);
assert!(r.contains(r#""status":"ok""#), "insert: {}", r);
@@ -988,9 +894,8 @@ fn config_file_is_used() {
/// 重复建表报错
#[test]
fn create_table_twice_errors() {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe).unwrap();
let (_srv, _data) = start_server();
let mut c = connect().unwrap();
let req = r#"{"method":"create_table","table":"dup","columns":[{"name":"id","ty":"int"}]}"#;
let r1 = send(&mut c, req);
@@ -1004,9 +909,8 @@ fn create_table_twice_errors() {
/// 新建空表能扫描
#[test]
fn scan_empty_table_after_create() {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe).unwrap();
let (_srv, _data) = start_server();
let mut c = connect().unwrap();
let r = send(
&mut c,
@@ -1019,12 +923,11 @@ fn scan_empty_table_after_create() {
assert!(r.contains(r#""rows":[]"#), "scan: {}", r);
}
/// 建表带上约束元数据，行里能有 null；replace_schema 整表换列定义与行
/// 约束元数据落盘；replace_schema 换列与行
#[test]
fn replace_schema_rewrites_columns_and_rows() {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe).unwrap();
let (_srv, _data) = start_server();
let mut c = connect().unwrap();
let created = send(
&mut c,
@@ -1061,12 +964,11 @@ fn replace_schema_rewrites_columns_and_rows() {
assert!(r.contains(r#""tag":"a""#), "rewritten rows: {}", r);
}
/// 旧类型系统落盘的数据在启动时升级：缺的格补 null，老类型名并到新写法
/// 启动时升级旧类型字典，缺的格补 null
#[test]
fn legacy_catalog_and_partial_rows_are_migrated() -> Result<(), Box<dyn std::error::Error>> {
let pipe = unique_pipe_name();
let (server, data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let (server, data) = start_server();
let mut c = connect()?;
request_ok(&mut c, serde_json::json!({"method":"create_table","table":"legacy_t","columns":[{"name":"id","ty":"int"},{"name":"name","ty":"str"},{"name":"age","ty":"int"}]}))?;
request_ok(&mut c, serde_json::json!({"method":"insert","table":"legacy_t","row":{"id":1,"name":"a"}}))?;
drop(c);
@@ -1083,8 +985,8 @@ fn legacy_catalog_and_partial_rows_are_migrated() -> Result<(), Box<dyn std::err
}
std::fs::write(&catalog_path, serde_json::to_string_pretty(&catalog)?)?;
let _restarted = start_server_in(&pipe, data.path());
let mut c = connect(&pipe)?;
let _restarted = start_server_in(data.path());
let mut c = connect()?;
let rows: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"scan","table":"legacy_t"}"#))?;
assert_eq!(rows["rows"], serde_json::json!([{"id":1,"name":"a","age":null}]), "缺的格要补 null");
@@ -1099,12 +1001,11 @@ fn legacy_catalog_and_partial_rows_are_migrated() -> Result<(), Box<dyn std::err
Ok(())
}
/// 账号表用新类型系统落盘：id 主键、用户名索引、注册与最近登录时间
/// 账号表落盘类型与索引，登录盖时间戳
#[test]
fn account_table_uses_typed_columns_and_stamps_login() -> Result<(), Box<dyn std::error::Error>> {
let pipe = unique_pipe_name();
let (_srv, data) = start_server(&pipe);
let mut c = connect(&pipe)?;
let (_srv, data) = start_server();
let mut c = connect()?;
let created: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"account_create","user":"alice","password_hash":"hash"}"#))?;
assert_eq!(created["status"], "accounts", "{}", created);
@@ -1136,10 +1037,9 @@ fn account_table_uses_typed_columns_and_stamps_login() -> Result<(), Box<dyn std
/// 字符串列也能建索引并按键点查
#[test]
fn string_index_lookup_over_the_pipe() {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe).unwrap();
fn string_index_lookup_in_process() {
let (_srv, _data) = start_server();
let mut c = connect().unwrap();
send(&mut c, r#"{"method":"insert","table":"sidx","row":{"id":1,"name":"alice"}}"#);
send(&mut c, r#"{"method":"insert","table":"sidx","row":{"id":2,"name":"bob"}}"#);
@@ -1159,12 +1059,11 @@ fn string_index_lookup_over_the_pipe() {
assert!(r.contains(r#""id":1"#) && r.contains(r#""id":3"#), "both rows come back: {}", r);
}
/// 范围扫描走索引叶子链，两端可开可闭，没索引回 no_index
/// 范围扫描走索引，两端可开可闭，没索引回 no_index
#[test]
fn range_scan_over_the_pipe() {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe).unwrap();
fn range_scan_in_process() {
let (_srv, _data) = start_server();
let mut c = connect().unwrap();
for (id, code) in [(1, 100), (2, 200), (3, 300), (4, 400)] {
let req = format!(
@@ -1204,10 +1103,9 @@ fn range_scan_over_the_pipe() {
/// 字符串列按字节序范围扫描
#[test]
fn string_range_scan_over_the_pipe() {
let pipe = unique_pipe_name();
let (_srv, _data) = start_server(&pipe);
let mut c = connect(&pipe).unwrap();
fn string_range_scan_in_process() {
let (_srv, _data) = start_server();
let mut c = connect().unwrap();
for (id, name) in [(1, "alice"), (2, "bob"), (3, "carol"), (4, "dave")] {
let req = format!(
chusql-storage/tests/wal_test.rs → chusql-core/storage/tests/wal_test.rs
+3 -2
View File
@@ -1,10 +1,11 @@
use chusql_storage::protocol::Row;
use chusql_storage::wal::{Wal, WalOp};
use chusql_core_storage::protocol::Row;
use chusql_core_storage::wal::{Wal, WalOp};
use serde_json::json;
// WAL 测试：追加、读取、清空、截断尾巴。
/// 用键值对构造一行
fn row(pairs: &[(&str, serde_json::Value)]) -> Row {
let mut m = Row::new();
for (k, v) in pairs {
chusql-engine/chusql-engine.cabal
-58
View File
@@ -1,58 +0,0 @@
cabal-version: 2.4
name: chusql-engine
version: 1.0.0
synopsis: ChuSQL 执行引擎：SQL 词法与语法分析、表达式求值
description: ChuSQL 服务端执行引擎。负责 SQL 词法分析与 AST 构建、
WHERE 条件表达式求值、关系代数运算与内存表管理。
build-type: Simple
library
hs-source-dirs: src
exposed-modules: ChuSQL.Algebra.Eval
ChuSQL.Algebra.Expr
ChuSQL.Algebra.Op
ChuSQL.Algebra.Optimize
ChuSQL.Algebra.Planner
ChuSQL.Algebra.Sort
ChuSQL.Engine
ChuSQL.Model
ChuSQL.Semantic
ChuSQL.Storage
ChuSQL.Storage.IPC
ChuSQL.Storage.Memory
ChuSQL.Syntax.AST
ChuSQL.Syntax.Parser
build-depends: base >= 4.14 && < 5
, aeson
, bytestring
, hashable
, megaparsec
, network
, parser-combinators
, scientific
, text
, unordered-containers
default-language: Haskell2010
ghc-options: -Wall
executable chusql-engine
main-is: Main.hs
hs-source-dirs: app
build-depends: base
, chusql-engine
default-language: Haskell2010
ghc-options: -Wall
test-suite chusql-engine-test
type: exitcode-stdio-1.0
main-is: Spec.hs
hs-source-dirs: test
build-depends: base
, chusql-engine
, directory
, filepath
, hspec
, process
default-language: Haskell2010
ghc-options: -Wall
chusql-engine/src/ChuSQL/Storage/IPC.hs
-665
View File
@@ -1,665 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Storage.IPC (
IPCStorage (..),
Request (..),
Response (..),
Account (..),
SchemaColumn (..),
TableInfo (..),
sendRequest,
closeConnection,
defaultPipeName,
setPipeName,
getPipeName,
doListTables,
doLookupByColumn,
doInsert,
doInsertMany,
doDeleteKeys,
doDescribeTable,
doDropTable,
doListCatalog,
) where
import ChuSQL.Model
import ChuSQL.Storage
import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar, readMVar)
import Control.Exception (IOException, try)
#if !defined(mingw32_HOST_OS)
import Control.Exception (onException)
#endif
import Data.Aeson (FromJSON (..), ToJSON (..), eitherDecodeStrict, encode, object, withObject, (.:), (.:?), (.!=), (.=))
import Data.Aeson qualified as A
import Data.Aeson.Key qualified as K
import Data.Aeson.KeyMap qualified as KM
import Data.Aeson.Types (Parser)
import Data.ByteString.Char8 qualified as BSC
import Data.ByteString.Lazy qualified as BL
import Data.Maybe (fromMaybe)
import Data.Scientific (floatingOrInteger, fromFloatDigits)
import Data.Text qualified as T
import System.IO
import System.IO.Unsafe (unsafePerformIO)
#if !defined(mingw32_HOST_OS)
import Network.Socket (Family (AF_UNIX), SockAddr (SockAddrUnix), SocketType (Stream), close, connect, defaultProtocol, socket, socketToHandle)
import System.Environment (lookupEnv)
#endif
-- IPC 存储实现：每个存储方法翻成管道上的一条 JSON 请求。
-- 端点：Windows 是具名管道 \\.\pipe\<name>，Unix 是文件系统套接字 <dir>/<name>.sock。
#if !defined(mingw32_HOST_OS)
-- | Unix 套接字路径的最大长度（Linux 108 含结尾 NUL，BSD 104，这里留余量）
maxSocketPathLength :: Int
maxSocketPathLength = 100
#endif
newtype IPCStorage a = IPCStorage
{ runIPCStorage :: IO a
}
instance Functor IPCStorage where
fmap f (IPCStorage m) = IPCStorage (fmap f m)
instance Applicative IPCStorage where
pure = IPCStorage . pure
IPCStorage mf <*> IPCStorage ma = IPCStorage (mf <*> ma)
instance Monad IPCStorage where
IPCStorage m >>= k = IPCStorage $ do
a <- m
runIPCStorage (k a)
{-# NOINLINE connectionRef #-}
connectionRef :: MVar (Maybe (FilePath, Handle))
connectionRef = unsafePerformIO (newMVar Nothing)
-- | 打开端点连接：Windows 把管道当文件打开，Unix 连一个 AF_UNIX 套接字
openPipe :: FilePath -> IO Handle
#if defined(mingw32_HOST_OS)
openPipe path = do
h <- openFile path ReadWriteMode
hSetBuffering h LineBuffering
hSetNewlineMode h noNewlineTranslation
pure h
#else
openPipe path = do
if length path > maxSocketPathLength
then ioError (userError ("socket path too long (" ++ show (length path) ++ " bytes): " ++ path))
else pure ()
sock <- socket AF_UNIX Stream defaultProtocol
connect sock (SockAddrUnix path) `onException` close sock
h <- socketToHandle sock ReadWriteMode
hSetBuffering h LineBuffering
hSetNewlineMode h noNewlineTranslation
pure h
-- | Unix 套接字目录：$XDG_RUNTIME_DIR → $TMPDIR → /tmp（与 Rust 侧同一规则）
socketDir :: IO String
socketDir = do
runtime <- fmap nonEmpty (lookupEnv "XDG_RUNTIME_DIR")
tmp <- fmap nonEmpty (lookupEnv "TMPDIR")
pure (fromMaybe "/tmp" (runtime <> tmp))
where
nonEmpty v = case v of
Just s | not (null s) -> Just s
_ -> Nothing
#endif
-- | 关掉缓存里的句柄（没有就什么都不做）
closeCached :: Maybe (FilePath, Handle) -> IO ()
closeCached Nothing = pure ()
closeCached (Just (_, h)) = hClose h
-- | 拿一个可用句柄；路径没变就复用，变了就换。
getConnection :: FilePath -> IO Handle
getConnection path = modifyMVar connectionRef $ \cached -> case cached of
Just (p, h)
| p == path -> pure (Just (p, h), h)
_ -> do
_ <- try (closeCached cached) :: IO (Either IOException ())
h <- openPipe path
pure (Just (path, h), h)
-- | 丢掉缓存的连接（出错后调用，下次会重连）
dropConnection :: IO ()
dropConnection = modifyMVar_ connectionRef $ \cached -> do
_ <- try (closeCached cached) :: IO (Either IOException ())
pure Nothing
-- | 关闭并清空连接。可选，进程退出前调用。
closeConnection :: IO ()
closeConnection = dropConnection
-- | 没配置管名时用的端点，与 chusql.toml 的 [server] pipe_name 默认值一致
defaultPipeName :: String
defaultPipeName = "chusql-joint"
{-# NOINLINE pipeNameRef #-}
pipeNameRef :: MVar String
pipeNameRef = unsafePerformIO (newMVar defaultPipeName)
-- | 设定本进程要连的端点；配置从哪来由调用方决定（本层不读环境变量）
setPipeName :: String -> IO ()
setPipeName name = modifyMVar_ pipeNameRef (\_ -> pure name)
-- | 当前端点
getPipeName :: IO String
getPipeName = readMVar pipeNameRef
-- | 端点的完整路径
pipePath :: IO String
#if defined(mingw32_HOST_OS)
pipePath = do
name <- getPipeName
pure ("\\\\.\\pipe\\" ++ name)
#else
pipePath = do
name <- getPipeName
dir <- socketDir
pure (dir ++ "/" ++ name ++ ".sock")
#endif
-- | 发一条请求，管道不通就重连
sendRequest :: Request -> IO Response
sendRequest req = do
path <- pipePath
result <- try (roundTrip req path) :: IO (Either IOException Response)
case result of
Left e -> do
dropConnection
pure (RespError ("pipe error: " ++ show e))
Right r -> pure r
-- | 一条请求-响应往返（复用缓存里的句柄）
roundTrip :: Request -> FilePath -> IO Response
roundTrip req path = do
h <- getConnection path
BL.hPutStr h (encode req)
BSC.hPutStr h "\n"
hFlush h
line <- BSC.hGetLine h
let cleaned = BSC.dropWhileEnd (== '\r') line
case eitherDecodeStrict cleaned of
Left err -> pure (RespError ("decode: " ++ err))
Right r -> pure r
data SchemaColumn = SchemaColumn
{ scName :: String
, scType :: String
, scNullable :: Bool
, scDefault :: Maybe Value
, scAutoIncrement :: Bool
, scPrimaryKey :: Bool
, scUnique :: Bool
, scCheck :: Maybe String
}
deriving (Show, Eq)
instance ToJSON SchemaColumn where
toJSON sc =
object
[ "name" .= scName sc
, "ty" .= scType sc
, "nullable" .= scNullable sc
, "default" .= fmap valueToJSON (scDefault sc)
, "auto_increment" .= scAutoIncrement sc
, "primary_key" .= scPrimaryKey sc
, "unique" .= scUnique sc
, "check" .= scCheck sc
]
instance FromJSON SchemaColumn where
parseJSON = withObject "SchemaColumn" $ \o -> do
n <- o .: "name"
t <- o .: "ty"
nullable <- o .:? "nullable" .!= True
defJson <- o .:? "default"
def <- mapM valueFromJSON defJson
auto <- o .:? "auto_increment" .!= False
pk <- o .:? "primary_key" .!= False
uniq <- o .:? "unique" .!= False
chk <- o .:? "check"
pure (SchemaColumn n t nullable def auto pk uniq chk)
data Request
= ReqPing
| ReqDatabase String String
| ReqAllCatalog
| ReqInDatabase String Request
| ReqAccountsList
| ReqAccountCreate T.Text T.Text
| ReqAccountReset T.Text T.Text
| ReqAccountLogin T.Text (Maybe T.Text)
| ReqAccountDrop T.Text
| ReqScan String
| ReqScanColumns String [String]
| ReqInsert String Row
| ReqInsertBatch String [Row]
| ReqDeleteKeys String [Int]
| ReqReplaceAll String [Row]
| ReqListTables
| ReqLookupByColumn String String Value
| ReqRangeByIndex String String (Maybe (Value, Bool)) (Maybe (Value, Bool))
| ReqDescribeTable String
| ReqCreateTable String [SchemaColumn]
| ReqDropTable String
| ReqCreateIndex String String
| ReqDropIndex String String
| ReqDropColumn String String
| ReqReplaceSchema String [SchemaColumn] [Row]
| ReqListCatalog
instance ToJSON Request where
toJSON (ReqDatabase method name) = object ["method" .= method, "database" .= name]
toJSON ReqAllCatalog = object ["method" .= ("all_catalogs" :: T.Text)]
toJSON (ReqInDatabase name req) = case toJSON req of
A.Object fields -> A.Object (KM.insert "database" (A.String (T.pack name)) fields)
other -> other
toJSON ReqAccountsList = object ["method" .= ("accounts_list" :: T.Text)]
toJSON (ReqAccountCreate u h) = object ["method" .= ("account_create" :: T.Text), "user" .= u, "password_hash" .= h]
toJSON (ReqAccountReset u h) = object ["method" .= ("account_reset" :: T.Text), "user" .= u, "password_hash" .= h]
toJSON (ReqAccountLogin u at) = object ["method" .= ("account_login" :: T.Text), "user" .= u, "at" .= at]
toJSON (ReqAccountDrop u) = object ["method" .= ("account_drop" :: T.Text), "user" .= u]
toJSON ReqPing = object ["method" .= ("ping" :: T.Text)]
toJSON (ReqScan t) = object ["method" .= ("scan" :: T.Text), "table" .= t]
toJSON (ReqScanColumns t cols) = object ["method" .= ("scan" :: T.Text), "table" .= t, "columns" .= cols]
toJSON (ReqInsert t r) =
object
[ "method" .= ("insert" :: T.Text)
, "table" .= t
, "row" .= rowToJSON r
]
toJSON (ReqInsertBatch t rs) =
object
[ "method" .= ("insert_batch" :: T.Text)
, "table" .= t
, "rows" .= map rowToJSON rs
]
toJSON (ReqDeleteKeys t ks) =
object
[ "method" .= ("delete_keys" :: T.Text)
, "table" .= t
, "keys" .= ks
]
toJSON (ReqReplaceAll t rs) =
object
[ "method" .= ("replace_all" :: T.Text)
, "table" .= t
, "rows" .= map rowToJSON rs
]
toJSON ReqListTables = object ["method" .= ("list_tables" :: T.Text)]
toJSON (ReqLookupByColumn t c k) =
object
[ "method" .= ("lookup_by_index" :: T.Text)
, "table" .= t
, "column" .= c
, "key" .= valueToJSON k
]
toJSON (ReqRangeByIndex t c lo hi) =
object
[ "method" .= ("range_by_index" :: T.Text)
, "table" .= t
, "column" .= c
, "lo" .= fmap (valueToJSON . fst) lo
, "lo_inclusive" .= maybe True snd lo
, "hi" .= fmap (valueToJSON . fst) hi
, "hi_inclusive" .= maybe True snd hi
]
toJSON (ReqDescribeTable t) =
object
[ "method" .= ("describe_table" :: T.Text)
, "table" .= t
]
toJSON (ReqCreateTable t cols) =
object
[ "method" .= ("create_table" :: T.Text)
, "table" .= t
, "columns" .= cols
]
toJSON (ReqDropTable t) =
object ["method" .= ("drop_table" :: T.Text), "table" .= t]
toJSON (ReqCreateIndex t c) =
object
[ "method" .= ("create_index" :: T.Text)
, "table" .= t
, "column" .= c
]
toJSON (ReqDropIndex t c) =
object
[ "method" .= ("drop_index" :: T.Text)
, "table" .= t
, "column" .= c
]
toJSON (ReqDropColumn t c) =
object
[ "method" .= ("drop_column" :: T.Text)
, "table" .= t
, "column" .= c
]
toJSON (ReqReplaceSchema t cols rs) =
object
[ "method" .= ("replace_schema" :: T.Text)
, "table" .= t
, "columns" .= cols
, "rows" .= map rowToJSON rs
]
toJSON ReqListCatalog = object ["method" .= ("list_catalog" :: T.Text)]
data TableInfo = TableInfo
{ tiTable :: String
, tiColumns :: [SchemaColumn]
, tiRows :: Int
, tiIndexes :: [String]
, tiStats :: [(String, Int, Bool)]
}
deriving (Show, Eq)
data Account = Account
{ accountId :: Integer
, accountUser :: T.Text
, accountHash :: T.Text
, accountRevision :: Integer
, accountRegisteredAt :: T.Text
, accountLastLoginAt :: Maybe T.Text
} deriving (Eq)
instance Show Account where
show a = "Account " ++ show (accountUser a) ++ " revision=" ++ show (accountRevision a)
instance FromJSON Account where
parseJSON = withObject "Account" $ \o -> Account <$> o .: "id" <*> o .: "user"
<*> o .: "password_hash" <*> o .: "revision"
<*> o .:? "registered_at" .!= "" <*> o .:? "last_login_at"
instance ToJSON Account where
toJSON a = object ["id" .= accountId a, "user" .= accountUser a,
"password_hash" .= accountHash a, "revision" .= accountRevision a,
"registered_at" .= accountRegisteredAt a, "last_login_at" .= accountLastLoginAt a]
data Response
= RespPong
| RespAccounts [Account]
| RespRows [Row]
| RespTables [String]
| RespSchema TableInfo
| RespNoIndex
| RespOk
| RespError String
| RespCatalog [TableInfo]
instance FromJSON Response where
parseJSON = withObject "Response" $ \o -> do
status <- o .: "status"
case status :: T.Text of
"accounts" -> RespAccounts <$> o .: "accounts"
"pong" -> pure RespPong
"ok" -> pure RespOk
"no_index" -> pure RespNoIndex
"rows" -> RespRows <$> (o .: "rows" >>= mapM rowFromJSON)
"tables" -> RespTables <$> o .: "tables"
"error" -> RespError <$> o .: "message"
"schema" -> RespSchema <$> parseTable (A.Object o)
"catalog" -> do
xs <- o .: "schemas" :: Parser [A.Value]
RespCatalog <$> mapM parseTable xs
other -> fail ("unknown status: " ++ T.unpack other)
where
parseTable :: A.Value -> Parser TableInfo
parseTable = withObject "TableInfo" $ \o -> do
t <- o .: "table"
cols <- o .: "columns"
cnt <- o .: "row_count"
idx <- o .:? "indexes" .!= []
sts <- o .:? "stats" .!= []
idxCols <- mapM (\v -> withObject "IndexWire" (.: "column") v) (idx :: [A.Value])
stats <- mapM parseStat (sts :: [A.Value])
pure (TableInfo t cols cnt idxCols stats)
parseStat :: A.Value -> Parser (String, Int, Bool)
parseStat = withObject "ColumnStat" $ \o -> do
name <- o .: "name"
distinct <- o .: "distinct"
capped <- o .:? "capped" .!= False
pure (name, distinct, capped)
-- | 值编码成 JSON
valueToJSON :: Value -> A.Value
valueToJSON VNull = A.Null
valueToJSON (VInt n) = A.Number (fromIntegral n)
valueToJSON (VFloat d) = A.Number (fromFloatDigits d)
valueToJSON (VStr s) = A.String (T.pack s)
valueToJSON (VBool b) = A.Bool b
-- | JSON 解回值
valueFromJSON :: A.Value -> Parser Value
valueFromJSON A.Null = pure VNull
valueFromJSON (A.Number n) =
case floatingOrInteger n :: Either Double Integer of
Right i -> pure (VInt (fromIntegral i))
Left d -> pure (VFloat d)
valueFromJSON (A.String s) = pure (VStr (T.unpack s))
valueFromJSON (A.Bool b) = pure (VBool b)
valueFromJSON _ = fail "unsupported value type"
-- | 一行编码成 JSON
rowToJSON :: Row -> A.Value
rowToJSON r =
A.Object (KM.fromList [(K.fromString k, valueToJSON v) | (k, v) <- r])
-- | JSON 解回一行
rowFromJSON :: A.Value -> Parser Row
rowFromJSON (A.Object o) = mapM toPair (KM.toList o)
where
toPair (k, v) = do
val <- valueFromJSON v
pure (K.toString k, val)
rowFromJSON _ = fail "row must be a JSON object"
-- | 发请求并把响应翻成 Either
ask :: String -> Request -> (Response -> Maybe a) -> IO (Either String a)
ask what req recognize = do
resp <- sendRequest req
pure $ case resp of
RespError e -> Left e
other -> case recognize other of
Just a -> Right a
Nothing -> Left ("unexpected response to " ++ what)
-- | 只认"成了"（多数写操作都这样）
okOnly :: Response -> Maybe ()
okOnly RespOk = Just ()
okOnly _ = Nothing
-- | 发 Scan
doScan :: String -> IO (Either String [Row])
doScan t = ask "scan" (ReqScan t) $ \resp -> case resp of
RespRows rows -> Just rows
_ -> Nothing
-- | 发 Insert（索引由存储层维护）
doInsert :: String -> Row -> IO (Either String ())
doInsert t r = ask "insert" (ReqInsert t r) okOnly
-- | 发 InsertBatch：一批行一次请求
doInsertMany :: String -> [Row] -> IO (Either String ())
doInsertMany t rs = ask "insert_batch" (ReqInsertBatch t rs) okOnly
-- | 发 DeleteKeys
doDeleteKeys :: String -> [Int] -> IO (Either String ())
doDeleteKeys t ks = ask "delete_keys" (ReqDeleteKeys t ks) okOnly
-- | 发 ReplaceAll
doReplaceAll :: String -> [Row] -> IO (Either String ())
doReplaceAll t rs = ask "replace_all" (ReqReplaceAll t rs) okOnly
-- | 发 ListTables
doListTables :: IO (Either String [String])
doListTables = ask "list_tables" ReqListTables $ \resp -> case resp of
RespTables ts -> Just ts
_ -> Nothing
-- | 一次拿全库 schema
doListCatalog :: IO (Either String [TableInfo])
doListCatalog = ask "list_catalog" ReqListCatalog $ \resp -> case resp of
RespCatalog xs -> Just xs
_ -> Nothing
-- | 按某一列的索引取一行（键可以是整数或字符串）
doLookupByColumn :: String -> String -> Value -> IO (Either String IndexResult)
doLookupByColumn t c k = ask "lookup_by_index" (ReqLookupByColumn t c k) $ \resp -> case resp of
RespRows rows -> Just (IndexRows rows)
RespNoIndex -> Just NoIndex
_ -> Nothing
-- | 范围扫描：没有可用索引就回 Nothing，让上层退回扫描
doScanRange ::
String ->
String ->
Maybe (Value, Bool) ->
Maybe (Value, Bool) ->
IO (Either String (Maybe [Row]))
doScanRange t c lo hi = ask "range_by_index" (ReqRangeByIndex t c lo hi) $ \resp -> case resp of
RespRows rows -> Just (Just rows)
RespNoIndex -> Just Nothing
_ -> Nothing
-- | 发 DescribeTable
doDescribeTable :: String -> IO (Either String TableInfo)
doDescribeTable t = ask "describe_table" (ReqDescribeTable t) $ \resp -> case resp of
RespSchema info -> Just info
_ -> Nothing
-- | 给某一列建索引
doCreateIndex :: String -> String -> IO (Either String ())
doCreateIndex t c = ask "create_index" (ReqCreateIndex t c) okOnly
-- | 去掉某一列的索引
doDropIndex :: String -> String -> IO (Either String ())
doDropIndex t c = ask "drop_index" (ReqDropIndex t c) okOnly
-- | 删一列（列定义、这一列上的索引、每行里的那一格一起没）
doDropColumn :: String -> String -> IO (Either String ())
doDropColumn t c = ask "drop_column" (ReqDropColumn t c) okOnly
-- | 发 ReplaceSchema（ALTER 用）
doReplaceSchema :: String -> [SchemaColumn] -> [Row] -> IO (Either String ())
doReplaceSchema t cols rs = ask "replace_schema" (ReqReplaceSchema t cols rs) okOnly
-- | 发 CreateTable
doCreateTable :: String -> [SchemaColumn] -> IO (Either String ())
doCreateTable t cols = ask "create_table" (ReqCreateTable t cols) okOnly
-- | 发 DropTable
doDropTable :: String -> IO (Either String ())
doDropTable t = ask "drop_table" (ReqDropTable t) okOnly
-- | 线上 schema 转本地列
schemaToColumns :: [SchemaColumn] -> [(String, Column)]
schemaToColumns = map toColumn
toColumn :: SchemaColumn -> (String, Column)
toColumn sc =
( scName sc
, Column
{ columnType = fromMaybe CStr (parseColumnType (scType sc))
, columnNullable = scNullable sc
, columnDefault = scDefault sc
, columnAutoIncrement = scAutoIncrement sc
, columnUnique = scUnique sc
, columnPrimaryKey = scPrimaryKey sc
, columnCheck = scCheck sc
}
)
-- | 本地列转线上 schema
toWire :: (String, Column) -> SchemaColumn
toWire (n, c) =
SchemaColumn
{ scName = n
, scType = typeName (columnType c)
, scNullable = columnNullable c
, scDefault = columnDefault c
, scAutoIncrement = columnAutoIncrement c
, scPrimaryKey = columnPrimaryKey c
, scUnique = columnUnique c
, scCheck = columnCheck c
}
instance MonadStorage IPCStorage where
createDatabase name = IPCStorage (ask "create_database" (ReqDatabase "create_database" name) okOnly)
dropDatabase name = IPCStorage (ask "drop_database" (ReqDatabase "drop_database" name) okOnly)
useDatabase name = IPCStorage (ask "use_database" (ReqDatabase "use_database" name) okOnly)
listDatabases = IPCStorage $ ask "list_databases" (ReqDatabase "list_databases" "") $ \resp -> case resp of
RespTables names -> Just names
_ -> Nothing
-- \| 发 Scan
scan t = IPCStorage (doScan t)
scanColumns t cols = IPCStorage $ ask "scan" (ReqScanColumns t cols) $ \resp -> case resp of
RespRows rows -> Just [[(c, v) | c <- cols, Just v <- [lookup c row]] | row <- rows]
_ -> Nothing
-- \| 发 Insert（索引由存储层自己维护）
insert t r = IPCStorage (doInsert t r)
-- \| 一批行一次请求：N 行只落一次盘
insertMany t rs = IPCStorage (doInsertMany t rs)
-- \| 按 id 批量删行
deleteKeys t ks = IPCStorage (doDeleteKeys t ks)
-- \| 发 ReplaceAll
replaceAll t rs = IPCStorage (doReplaceAll t rs)
-- \| 按某一列的索引取一行（没有索引就回 NoIndex）
lookupByColumn t c k = IPCStorage (doLookupByColumn t c k)
-- \| 范围扫描（没有索引就回 Nothing）
scanRange t c lo hi = IPCStorage (doScanRange t c lo hi)
-- \| 发 CreateTable
createTable name cols = IPCStorage (doCreateTable name (map toWire cols))
-- \| ALTER：整表换列定义与全部行
replaceSchema name cols rows = IPCStorage (doReplaceSchema name (map toWire cols) rows)
-- \| 发 DropTable
dropTable name = IPCStorage (doDropTable name)
-- \| 建索引
createIndex t c = IPCStorage (doCreateIndex t c)
-- \| 删索引
dropIndex t c = IPCStorage (doDropIndex t c)
-- \| 删一列
dropColumn t c = IPCStorage (doDropColumn t c)
-- \| 列表 + 逐表扫描拼库
snapshot = IPCStorage $ do
result <- doListCatalog
case result of
Left _ -> pure []
Right xs -> mapM loadEntry xs
where
loadEntry info = do
rows <- doScan (tiTable info)
pure
( tiTable info
, Table (tiTable info) (schemaToColumns (tiColumns info)) (either (const []) id rows)
)
-- \| 只问数据字典要结构，一行数据都不拉过来
schema = IPCStorage $ do
result <- ask "all_catalogs" ReqAllCatalog $ \resp -> case resp of
RespCatalog infos -> Just infos
_ -> Nothing
pure $ case result of
Left _ -> []
Right xs ->
[ (tiTable i, Table (tiTable i) (schemaToColumns (tiColumns i)) [])
| i <- xs
]
chusql-interface/chusql-interface.cabal
+39
View File
@@ -0,0 +1,39 @@
cabal-version: 2.4
name: chusql-interface
version: 1.0.0
synopsis: ChuSQL 接口层：配置、口令、语句构造与 TCP 客户端
description: 引擎无关的接口层。Web 管理端与命令行客户端都只依赖这层：
读同一份 chusql.toml、用同一个线上协议连到拥有存储库的
chusql-server，然后在客户端会话上跑 SQL、看数据字典与角色。
存储引擎与存储动态库一概不在这层。
build-type: Simple
library
hs-source-dirs: src
exposed-modules: ChuSQL.Interface.AccountTable
ChuSQL.Interface.Actions
ChuSQL.Interface.Auth
ChuSQL.Interface.Config
ChuSQL.Interface.Link
ChuSQL.Interface.Policy
ChuSQL.Interface.Protocol
ChuSQL.Interface.RateLimit
ChuSQL.Interface.Session
ChuSQL.Interface.Settings
ChuSQL.Interface.TOML
build-depends: base >= 4.14 && < 5
, aeson
, bytestring
, chusql-core-model
, containers
, crypton
, directory
, filepath
, memory
, network
, scientific
, text
, time
default-language: Haskell2010
ghc-options: -Wall
chusql-interface/src/ChuSQL/Interface/AccountTable.hs
+46
View File
@@ -0,0 +1,46 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Interface.AccountTable (
accountTableName,
isAccountTable,
passwordColumn,
accountColumns,
systemTableInfo,
) where
import ChuSQL.Core.Protocol (SchemaColumn (..), TableInfo (..))
import Data.Text (Text)
import qualified Data.Text as T
-- 账号表（系统表 __chusql_users）的结构定义，SQL 会话与 Web 管理端共用。
-- | 账号表的名字：网页里像普通表一样浏览与编辑，但写入走账号命令
accountTableName :: String
accountTableName = "__chusql_users"
-- | 这张表是不是账号表
isAccountTable :: Text -> Bool
isAccountTable name = T.toLower name == T.pack accountTableName
-- | 口令列：密文只在服务端产生，界面不支持排序与筛选
passwordColumn :: String
passwordColumn = "password"
-- | 账号表的列定义与约束
accountColumns :: [SchemaColumn]
accountColumns =
[ accountColumnSpec "id" "int" False True True False
, accountColumnSpec "user" "varchar(64)" False False False True
, accountColumnSpec passwordColumn "varchar(256)" False False False False
, accountColumnSpec "registered_at" "timestamp" False False False False
, accountColumnSpec "last_login_at" "timestamp" True False False False
]
-- | 账号表的列（约束由账号服务管）
accountColumnSpec :: String -> String -> Bool -> Bool -> Bool -> Bool -> SchemaColumn
accountColumnSpec name ty nullable autoIncrement primary unique =
SchemaColumn name ty nullable Nothing autoIncrement primary unique Nothing
-- | 账号表的结构（排序校验用）
systemTableInfo :: TableInfo
systemTableInfo = TableInfo accountTableName accountColumns 0 [] []
chusql-web/src/ChuSQL/Web/Actions.hs → chusql-interface/src/ChuSQL/Interface/Actions.hs
+91 -5
View File
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Web.Actions (
module ChuSQL.Interface.Actions (
ColumnSpec (..),
CreateTableSpec (..),
isIdentifier,
@@ -24,10 +24,16 @@ module ChuSQL.Web.Actions (
createUserSql,
alterUserSql,
dropUserSql,
createRoleSql,
dropRoleSql,
grantPrivilegesSql,
revokePrivilegesSql,
grantRoleSql,
revokeRoleSql,
) where
import ChuSQL.Model (Column (..), ColumnType (..), Value (..), integerType, numericType, parseColumnType, plainColumn, typeName)
import qualified ChuSQL.Model as M
import ChuSQL.Core.Model (Column (..), ColumnType (..), Value (..), integerType, numericType, parseColumnType, plainColumn, typeName)
import qualified ChuSQL.Core.Model as M
import qualified Data.Aeson as A
import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
import Data.List (intercalate)
@@ -38,12 +44,14 @@ import Text.Read (readMaybe)
-- 把界面上的一键操作翻译成安全 SQL：标识符过白名单，值一律转义。
-- | 界面上传来的一列：名字与类型名
data ColumnSpec = ColumnSpec
{ csName :: Text
, csType :: Text
}
deriving (Show, Eq)
-- | 建表请求：表名 + 列
data CreateTableSpec = CreateTableSpec
{ ctsTable :: Text
, ctsColumns :: [ColumnSpec]
@@ -59,6 +67,7 @@ isIdentifier t =
(c : cs) -> (isAsciiLower c || isAsciiUpper c || c == '_') && all restChar cs
[] -> False
where
-- | 标识符里其余字符的合法集
restChar c = isAsciiLower c || isAsciiUpper c || isDigit c || c == '_'
-- | 检查一个标识符，不合法就报错（带上"是表名还是列名"）
@@ -138,6 +147,7 @@ createTableSql spec = do
defs <- mapM columnDef cols
pure ("CREATE TABLE " ++ T.unpack tbl ++ " (" ++ intercalate ", " defs ++ ")")
where
-- | 列类型不认时报错
columnDef (ColumnSpec name ty) = do
col <- checkIdent "column" name
ctype <- maybe (Left ("unknown column type: " ++ T.unpack ty)) Right (columnTypeOf ty)
@@ -238,6 +248,7 @@ whereClause filters = case filters of
terms <- mapM term filters
pure (" WHERE " ++ intercalate " AND " terms)
where
-- | 一个等值条件
term (column, value) = do
col <- checkIdent "column" column
pure (T.unpack col ++ " = " ++ sqlLiteral value)
@@ -249,20 +260,21 @@ orderClause (Just (column, ascending)) = do
col <- checkIdent "column" column
pure (" ORDER BY " ++ T.unpack col ++ (if ascending then " ASC" else " DESC"))
-- | 账号名：与普通标识符同一套规则，另允许点与短横线（写成字符串形式）
-- | 账号名：标识符规则另允许点与短横线
accountName :: Text -> Either String Text
accountName name
| T.null name || T.length name > 64 = Left "account name is empty or too long"
| not (T.all allowed name) = Left ("account name may only contain ASCII letters, digits, dot, dash or underscore: " ++ T.unpack name)
| otherwise = Right name
where
-- | 账号名允许的字符集
allowed c = isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("_.-" :: String)
-- | 单引号字符串字面量
quoted :: Text -> String
quoted value = "'" ++ escapeStringLiteral (T.unpack value) ++ "'"
-- | 构造 CREATE USER（口令是明文，账号服务负责加盐派生）
-- | 构造 CREATE USER
createUserSql :: Text -> Text -> Either String String
createUserSql name password = do
user <- accountName name
@@ -283,3 +295,77 @@ dropUserSql :: Text -> Either String String
dropUserSql name = do
user <- accountName name
pure ("DROP USER " ++ T.unpack user)
-- | 角色名：与账号名同一套字符规则
roleName :: Text -> Either String Text
roleName name
| T.null name || T.length name > 64 = Left "role name is empty or too long"
| not (T.all allowed name) = Left ("role name may only contain ASCII letters, digits, dot, dash or underscore: " ++ T.unpack name)
| otherwise = Right name
where
-- | 角色名允许的字符集
allowed c = isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("_.-" :: String)
-- | 授权对象：`*`，或长度不超过 128 的裸表名/`库.表`
grantObject :: Text -> Either String Text
grantObject object
| T.strip object == "*" = Right "*"
| T.null object || T.length object > 128 = Left "object name is empty or too long"
| not (T.all allowed object) = Left ("object name may only contain ASCII letters, digits, dot, dash or underscore: " ++ T.unpack object)
| otherwise = Right object
where
-- | 授权对象允许的字符集
allowed c = isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("_.-" :: String)
-- | 权限清单：词要纯字母，认不认由 server 定
privilegeWords :: [Text] -> Either String [Text]
privilegeWords privileges
| null privileges = Left "at least one privilege is required"
| otherwise = mapM word privileges
where
-- | 单个权限词
word one
| T.null one || not (T.all (\c -> isAsciiLower c || isAsciiUpper c) one) = Left ("not a privilege keyword: " ++ T.unpack one)
| otherwise = Right one
-- | 构造 CREATE ROLE
createRoleSql :: Text -> Either String String
createRoleSql name = do
role <- roleName name
pure ("CREATE ROLE " ++ T.unpack role)
-- | 构造 DROP ROLE
dropRoleSql :: Text -> Either String String
dropRoleSql name = do
role <- roleName name
pure ("DROP ROLE " ++ T.unpack role)
-- | 构造 GRANT 权限 ON 对象 TO 角色
grantPrivilegesSql :: [Text] -> Text -> Text -> Either String String
grantPrivilegesSql privileges object role = do
words' <- privilegeWords privileges
target <- grantObject object
who <- roleName role
pure ("GRANT " ++ T.unpack (T.intercalate ", " words') ++ " ON " ++ T.unpack target ++ " TO " ++ T.unpack who)
-- | 构造 REVOKE 权限 ON 对象 FROM 角色
revokePrivilegesSql :: [Text] -> Text -> Text -> Either String String
revokePrivilegesSql privileges object role = do
words' <- privilegeWords privileges
target <- grantObject object
who <- roleName role
pure ("REVOKE " ++ T.unpack (T.intercalate ", " words') ++ " ON " ++ T.unpack target ++ " FROM " ++ T.unpack who)
-- | 构造 GRANT <角色> TO <用户>[, ...]
grantRoleSql :: Text -> [Text] -> Either String String
grantRoleSql role users = do
who <- roleName role
members <- requireNonEmpty "users" users >>= mapM accountName
pure ("GRANT " ++ T.unpack who ++ " TO " ++ T.unpack (T.intercalate ", " members))
-- | 构造 REVOKE 角色 FROM 用户
revokeRoleSql :: Text -> [Text] -> Either String String
revokeRoleSql role users = do
who <- roleName role
members <- requireNonEmpty "users" users >>= mapM accountName
pure ("REVOKE " ++ T.unpack who ++ " FROM " ++ T.unpack (T.intercalate ", " members))
chusql-web/src/ChuSQL/Web/Auth.hs → chusql-interface/src/ChuSQL/Interface/Auth.hs
+109 -2
View File
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Web.Auth (
module ChuSQL.Interface.Auth (
Credential (..),
defaultIterations,
hashPassword,
@@ -19,6 +19,15 @@ module ChuSQL.Web.Auth (
lookupSession,
deleteSession,
sessionToken,
PayloadStore,
newPayloadStore,
payloadPolicy,
setPayloadPolicy,
createPayloadSession,
lookupPayload,
putPayload,
dropPayload,
sweepPayloads,
) where
import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar)
@@ -37,8 +46,9 @@ import qualified Data.Text.Encoding as TE
import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime)
import Text.Read (readMaybe)
-- 口令与 Session：口令只存 PBKDF2 编码串，会话是服务端内存状态。
-- 口令哈希与会话仓库，服务端与 Web 管理端共用。
-- | 一条账号凭据：账号名 + 编码串
data Credential = Credential
{ credUser :: Text
, credEncoded :: Text
@@ -115,6 +125,7 @@ verifyPassword encoded candidate = case parseHash encoded of
hashLooksValid :: Text -> Bool
hashLooksValid = isJust . parseHash
-- | 一条会话：账号、创建/最后活动时间与账号版本号
data Session = Session
{ sessUser :: Text
, sessCreated :: UTCTime
@@ -122,6 +133,7 @@ data Session = Session
, sessRevision :: Maybe Integer
}
-- | 会话过期策略：空闲上限与绝对上限
data SessionPolicy = SessionPolicy
{ spIdleSeconds :: NominalDiffTime
, spAbsoluteSeconds :: NominalDiffTime
@@ -131,6 +143,7 @@ data SessionPolicy = SessionPolicy
defaultSessionPolicy :: SessionPolicy
defaultSessionPolicy = SessionPolicy (8 * 3600) (24 * 3600)
-- | 会话仓库：令牌表、时钟与策略
data SessionStore = SessionStore
{ storeMap :: MVar (Map.Map Text Session)
, storeClock :: IO UTCTime
@@ -170,6 +183,7 @@ sessionToken = hexEncode <$> getRandomBytes 32
createSession :: SessionStore -> Text -> IO Text
createSession store user = createVersionedSession store user Nothing
-- | 开一条会话并记下账号版本号，返回令牌
createVersionedSession :: SessionStore -> Text -> Maybe Integer -> IO Text
createVersionedSession store user revision = do
token <- sessionToken
@@ -183,6 +197,7 @@ createVersionedSession store user revision = do
lookupSession :: SessionStore -> Text -> IO (Maybe Text)
lookupSession store token = fmap (fmap fst) (lookupVersionedSession store token)
-- | 查令牌拿回账号名与账号版本号，并刷新最后活动时间
lookupVersionedSession :: SessionStore -> Text -> IO (Maybe (Text, Maybe Integer))
lookupVersionedSession store token = do
now <- storeClock store
@@ -196,3 +211,95 @@ lookupVersionedSession store token = do
-- | 删掉一条会话（退出登录）
deleteSession :: SessionStore -> Text -> IO ()
deleteSession store token = modifyMVar_ (storeMap store) (pure . Map.delete token)
-- | 一条带载荷的会话：账号、时间与载荷
data StoredSession a = StoredSession
{ psUser :: Text
, psCreated :: UTCTime
, psSeen :: UTCTime
, psPayload :: a
}
-- | 带载荷的会话仓库：令牌表、时钟与策略
data PayloadStore a = PayloadStore
{ psStoreMap :: MVar (Map.Map Text (StoredSession a))
, psClock :: IO UTCTime
, psPolicy :: IORef SessionPolicy
}
-- | 造一个空的带载荷仓库
newPayloadStore :: IO UTCTime -> SessionPolicy -> IO (PayloadStore a)
newPayloadStore clock policy = do
ref <- newMVar Map.empty
policyRef <- newIORef policy
pure (PayloadStore ref clock policyRef)
-- | 现在用的是哪套过期策略
payloadPolicy :: PayloadStore a -> IO SessionPolicy
payloadPolicy = readIORef . psPolicy
-- | 换一套过期策略
setPayloadPolicy :: PayloadStore a -> SessionPolicy -> IO ()
setPayloadPolicy store = writeIORef (psPolicy store)
-- | 这条带载荷的会话过期了吗
payloadExpired :: UTCTime -> SessionPolicy -> StoredSession a -> Bool
payloadExpired now pol s =
diffUTCTime now (psSeen s) > spIdleSeconds pol
|| diffUTCTime now (psCreated s) > spAbsoluteSeconds pol
-- | 清掉过期的带载荷会话
prunePayloads :: UTCTime -> SessionPolicy -> Map.Map Text (StoredSession a) -> Map.Map Text (StoredSession a)
prunePayloads now pol = Map.filter (not . payloadExpired now pol)
-- | 上线一条带载荷的会话，返回令牌
createPayloadSession :: PayloadStore a -> Text -> a -> IO Text
createPayloadSession store user payload = do
token <- sessionToken
now <- psClock store
pol <- payloadPolicy store
modifyMVar_ (psStoreMap store) $ \m ->
pure (Map.insert token (StoredSession user now now payload) (prunePayloads now pol m))
pure token
-- | 查令牌并刷新最后活动时间，拿回账号名与载荷
lookupPayload :: PayloadStore a -> Text -> IO (Maybe (Text, a))
lookupPayload store token = do
now <- psClock store
pol <- payloadPolicy store
modifyMVar (psStoreMap store) $ \m -> do
let kept = prunePayloads now pol m
pure $ case Map.lookup token kept of
Nothing -> (kept, Nothing)
Just s -> (Map.insert token s{psSeen = now} kept, Just (psUser s, psPayload s))
-- | 换掉载荷；会话已没了就返回 False
putPayload :: PayloadStore a -> Text -> a -> IO Bool
putPayload store token payload = do
now <- psClock store
pol <- payloadPolicy store
modifyMVar (psStoreMap store) $ \m -> do
let kept = prunePayloads now pol m
pure $ case Map.lookup token kept of
Nothing -> (kept, False)
Just s -> (Map.insert token s{psSeen = now, psPayload = payload} kept, True)
-- | 摘掉会话并把载荷交还
dropPayload :: PayloadStore a -> Text -> IO (Maybe a)
dropPayload store token = do
now <- psClock store
pol <- payloadPolicy store
modifyMVar (psStoreMap store) $ \m -> do
let kept = prunePayloads now pol m
pure $ case Map.lookup token kept of
Nothing -> (kept, Nothing)
Just s -> (Map.delete token kept, Just (psPayload s))
-- | 清掉过期会话并把它们的载荷交还；调用者负责关掉这些载荷
sweepPayloads :: PayloadStore a -> IO [a]
sweepPayloads store = do
now <- psClock store
pol <- payloadPolicy store
modifyMVar (psStoreMap store) $ \m -> do
let (gone, kept) = Map.partition (payloadExpired now pol) m
pure (kept, map psPayload (Map.elems gone))
chusql-web/src/ChuSQL/Web/Config.hs → chusql-interface/src/ChuSQL/Interface/Config.hs
+62 -39
View File
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Web.Config (
module ChuSQL.Interface.Config (
WebConfig (..),
defaultWebConfig,
defaultUser,
@@ -12,12 +12,14 @@ module ChuSQL.Web.Config (
staticDirCandidates,
rootUserName,
canonicalSettingKeys,
resolvePipeName,
resolvePlainPassword,
ServerConfig (..),
defaultServerConfig,
loadServerConfigAt,
) where
import ChuSQL.Storage.IPC (defaultPipeName)
import ChuSQL.Web.Auth (Credential (..), hashPassword)
import ChuSQL.Web.TOML (readSection)
import ChuSQL.Interface.Auth (Credential (..), hashPassword)
import ChuSQL.Interface.TOML (readSection)
import Data.Char (toLower)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
@@ -26,11 +28,7 @@ import qualified Data.Text as T
import System.Directory (doesDirectoryExist)
import Text.Read (readMaybe)
-- 运行参数：命令行 > 全局 chusql.toml 的分区 > 内置默认，不看环境变量。
-- 配置文件位置是固定的（安装时定下，见 ChuSQL.Web.TOML.defaultConfigFile），
-- 想读别处的文件只能在命令行用 --config 指。
-- 自己那段是 [web]；管名与数据目录取自 [server] pipe_name / [storage] data_dir，
-- 因为它们是存储进程的事实，前端只当端点读。root 凭据只认 [web] 里的明文。
-- Web 与 server 的运行参数：命令行 > chusql.toml 分区 > 内置默认。
-- | 默认账号名
defaultUser :: Text
@@ -40,13 +38,12 @@ defaultUser = "root"
defaultPassword :: Text
defaultPassword = "chusql"
-- | Web 管理端配置
data WebConfig = WebConfig
{ wcHost :: String
, wcPort :: Int
, wcStaticDir :: FilePath
, wcUser :: Text
, wcStorageServer :: Maybe FilePath
, wcPipeName :: Maybe String
, wcDataDir :: Maybe FilePath
, wcCookieSecure :: Bool
, wcBodyLimit :: Int
@@ -62,16 +59,14 @@ data WebConfig = WebConfig
}
deriving (Show, Eq)
-- | 内置默认
-- | Web 管理端参数的内置默认值
defaultWebConfig :: WebConfig
defaultWebConfig =
WebConfig
{ wcHost = "127.0.0.1"
, wcPort = 7777
, wcPort = 7778
, wcStaticDir = "static"
, wcUser = ""
, wcStorageServer = Nothing
, wcPipeName = Nothing
, wcDataDir = Nothing
, wcCookieSecure = False
, wcBodyLimit = 65536
@@ -86,12 +81,12 @@ defaultWebConfig =
, wcSeedDemo = False
}
-- | [web] 分区里的键统一成连字符写法（scripts/chusql.toml 用的是下划线）
-- 两种写法同时出现时，连字符（设置页写的规范形式）优先。
-- | 把设置键统一成连字符写法，重名时连字符优先
canonicalSettingKeys :: Map.Map Text Text -> Map.Map Text Text
canonicalSettingKeys saved =
foldr (\(key, value) acc -> Map.insert (canonicalKey key) value acc) Map.empty (Map.toList saved)
where
-- | 取一个键的规范名
canonicalKey key = fromMaybe key (lookup key keyAliases)
-- | 下划线写法到连字符写法的别名
@@ -109,22 +104,20 @@ keyAliases =
, ("max_sql_length", "max-sql-length")
, ("password_min_length", "password-min-length")
, ("password_classes", "password-classes")
, ("storage_server", "storage-server")
]
-- | 这份配置用的还是内置默认口令吗。
-- 显式留空（password = ""）是"只允许管理员免密登录"，算已经配置过。
-- | 这份配置用的还是内置默认口令吗
usingDefaultCredentials :: Map.Map Text Text -> Bool
usingDefaultCredentials saved = Map.notMember "password" saved
-- | 设置文件里某个键的非空值
nonEmptyValue :: Text -> Map.Map Text Text -> Maybe Text
-- | 查一个键
nonEmptyValue key saved = case T.strip <$> Map.lookup key saved of
Just value | not (T.null value) -> Just value
_ -> Nothing
-- | root 凭据只认设置文件里的明文：给了明文就哈希它；显式留空就是免密（空编码串）；
-- 没配这一项才回落到内置演示口令。
-- | root 凭据：明文就哈希，留空免密，缺省用演示口令
resolveCredential :: WebConfig -> Map.Map Text Text -> IO Credential
resolveCredential cfg saved = do
encoded <- case Map.lookup "password" saved of
@@ -133,32 +126,29 @@ resolveCredential cfg saved = do
Nothing -> hashPassword defaultPassword
pure (Credential (rootUserName cfg saved) encoded)
-- | 管理员名字：命令行 --user > 设置文件 user > 内置默认
-- | 管理员名字：命令行 > 设置文件 > 内置默认
rootUserName :: WebConfig -> Map.Map Text Text -> Text
rootUserName cfg saved
| not (T.null (T.strip (wcUser cfg))) = T.strip (wcUser cfg)
| otherwise = fromMaybe defaultUser (nonEmptyValue "user" saved)
-- | 读配置：内置默认 < [web] 分区（端点取自 [server] / [storage]）。
-- user / password 不在这里读：它们由 rootUserName / resolveCredential 直接看设置文件。
-- | 读配置：默认叠上 [web] 与 [storage]
loadWebConfigAt :: FilePath -> IO WebConfig
loadWebConfigAt path = do
raw <- readSection path "web"
server <- readSection path "server"
storage <- readSection path "storage"
pure (withEndpoint server storage (webConfigFromSection (canonicalSettingKeys raw)))
pure (withStorage storage (webConfigFromSection (canonicalSettingKeys raw)))
-- | 端点：存储进程 bind 的管名与它用的数据目录，前端只读不改
withEndpoint :: Map.Map Text Text -> Map.Map Text Text -> WebConfig -> WebConfig
withEndpoint server storage cfg =
cfg
{ wcPipeName = T.unpack <$> nonEmptyValue "pipe_name" server
, wcDataDir = T.unpack <$> nonEmptyValue "data_dir" storage
}
-- | 数据目录取自 [storage] 段
withStorage :: Map.Map Text Text -> WebConfig -> WebConfig
withStorage storage cfg =
cfg{wcDataDir = T.unpack <$> nonEmptyValue "data_dir" storage}
-- | 实际要连的管名：配置里没有就用与存储层一致的默认值
resolvePipeName :: WebConfig -> String
resolvePipeName cfg = fromMaybe defaultPipeName (wcPipeName cfg)
-- | 管理员明文口令，没配回落到演示口令，显式留空回空串
resolvePlainPassword :: Map.Map Text Text -> Text
resolvePlainPassword saved = case Map.lookup "password" saved of
Just plain -> T.strip plain
Nothing -> defaultPassword
-- | [web] 分区里的启动参数，缺失或坏值一律回到内置默认
webConfigFromSection :: Map.Map Text Text -> WebConfig
@@ -178,7 +168,6 @@ webConfigFromSection saved =
, wcMaxRows = sectionInt "max-rows" saved (wcMaxRows defaultWebConfig)
, wcMaxSqlLength = sectionInt "max-sql-length" saved (wcMaxSqlLength defaultWebConfig)
, wcSeedDemo = sectionBool "seed" saved (wcSeedDemo defaultWebConfig)
, wcStorageServer = T.unpack <$> nonEmptyValue "storage-server" saved
}
-- | 分区里一个键的非空字符串值
@@ -204,7 +193,41 @@ staticDirCandidates given =
resolveStaticDir :: FilePath -> IO (Maybe FilePath)
resolveStaticDir given = go (staticDirCandidates given)
where
-- | 逐个试
go [] = pure Nothing
go (d : ds) = do
ok <- doesDirectoryExist d
if ok then pure (Just d) else go ds
-- | 服务器监听参数
data ServerConfig = ServerConfig
{ scHost :: String
, scPort :: Int
, scMaxMessage :: Int
, scMaxRows :: Int
}
deriving (Eq, Show)
-- | 默认本机 7777，行 1 MiB，最多 1000 行
defaultServerConfig :: ServerConfig
defaultServerConfig = ServerConfig "127.0.0.1" 7777 (1024 * 1024) 1000
-- | 读 [server] 段键，缺的用默认
loadServerConfigAt :: FilePath -> IO ServerConfig
loadServerConfigAt path = do
values <- readSection path "server"
let -- | 取一个键的非空字符串值
textOf key fallback = case Map.lookup key values of
Just value | not (T.null (T.strip value)) -> T.unpack (T.strip value)
_ -> fallback
-- | 取一个键的整数值
intOf key fallback = case Map.lookup key values >>= readMaybe . T.unpack . T.strip of
Just number -> number
Nothing -> fallback
pure
defaultServerConfig
{ scHost = textOf "host" (scHost defaultServerConfig)
, scPort = intOf "port" (scPort defaultServerConfig)
, scMaxMessage = intOf "max_message" (scMaxMessage defaultServerConfig)
, scMaxRows = intOf "max_rows" (scMaxRows defaultServerConfig)
}
chusql-interface/src/ChuSQL/Interface/Link.hs
+221
View File
@@ -0,0 +1,221 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Interface.Link (
Client,
connectClient,
closeClient,
clientLogin,
clientQuery,
clientPing,
clientCatalog,
clientDatabases,
clientRoles,
clientAccounts,
clientPolicy,
clientReloadPolicy,
) where
import ChuSQL.Core.Protocol (Account, QueryResult (..), TableInfo (..))
import ChuSQL.Interface.Protocol (
ClientRequest (..),
RoleView,
ServerResponse (..),
decodeResponse,
encodeRequest,
protocolVersion,
)
import Control.Concurrent.MVar (MVar, newMVar, withMVar)
import Control.Exception (IOException, try)
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Data.ByteString.Char8 as BSC
import Data.Text (Text)
import qualified Data.Text as T
import Network.Socket (
AddrInfo (..),
SocketType (Stream),
addrAddress,
addrFamily,
connect,
defaultHints,
defaultProtocol,
getAddrInfo,
socket,
socketToHandle,
)
import System.IO (BufferMode (LineBuffering), Handle, IOMode (ReadWriteMode), hClose, hFlush, hSetBuffering, hSetNewlineMode, noNewlineTranslation)
import System.IO.Error (isEOFError)
-- 前端到 server 的 TCP 链路：一行一条 JSON，命令行与 Web 端共用。
-- | 一条已连上、已对过协议版本的连接
data Client = Client
{ clHandle :: Handle
, clLock :: MVar ()
}
-- | 连上 server 并对协议版本，失败给人话错误
connectClient :: Text -> Int -> IO (Either Text Client)
connectClient host port = do
opened <- try (openConnection host port) :: IO (Either IOException Handle)
case opened of
Left err -> pure (Left ("cannot reach the server at " <> T.pack (address host port) <> ": " <> T.pack (describe err)))
Right handle -> do
lock <- newMVar ()
let client = Client handle lock
greeted <- request client (ReqHello protocolVersion)
case greeted of
Right (RespHello version)
| version == protocolVersion -> pure (Right client)
| otherwise ->
giveUp handle
( "server "
<> T.pack (address host port)
<> " speaks protocol "
<> T.pack (show version)
<> ", this client needs "
<> T.pack (show protocolVersion)
)
Right (RespError code message) -> giveUp handle (code <> ": " <> message)
Right _ -> giveUp handle "unexpected response to hello"
Left message -> giveUp handle message
where
-- | 对不上就关连接并回错误
giveUp handle message = do
_ <- try (hClose handle) :: IO (Either IOException ())
pure (Left message)
-- | 断开连接；重复调用不报错
closeClient :: Client -> IO ()
closeClient client = do
_ <- try (hClose (clHandle client)) :: IO (Either IOException ())
pure ()
-- | 一行请求一行响应；同一条连接上的请求串起来发
request :: Client -> ClientRequest -> IO (Either Text ServerResponse)
request client message = withMVar (clLock client) $ \_ -> do
outcome <- try (exchange (clHandle client) message) :: IO (Either IOException (Either Text ServerResponse))
pure $ case outcome of
Left err -> Left (T.pack (describe err))
Right answer -> answer
-- | 在句柄上发一行请求、读回一行响应
exchange :: Handle -> ClientRequest -> IO (Either Text ServerResponse)
exchange handle message = do
BLC.hPutStr handle (encodeRequest message)
BLC.hPutStr handle "\n"
hFlush handle
line <- BSC.hGetLine handle
pure (decodeResponse (BL.fromStrict line))
-- | 登录；成功返回是不是管理员
clientLogin :: Client -> Text -> Text -> IO (Either Text Bool)
clientLogin client user password = do
answer <- request client (ReqLogin user password)
case answer of
Left message -> pure (Left message)
Right (RespLogin _ admin) -> pure (Right admin)
Right other -> pure (failed "login" other)
-- | 跑一条语句，拿回结果集
clientQuery :: Client -> Text -> IO (Either Text QueryResult)
clientQuery client sql = do
answer <- request client (ReqQuery sql)
case answer of
Left message -> pure (Left message)
Right (RespResult result) -> pure (Right result)
Right other -> pure (failed "a query" other)
-- | 探活
clientPing :: Client -> IO (Either Text ())
clientPing client = do
answer <- request client ReqPing
case answer of
Left message -> pure (Left message)
Right RespPong -> pure (Right ())
Right other -> pure (failed "a ping" other)
-- | 数据字典（\\dt 与 \\d 用）
clientCatalog :: Client -> IO (Either Text [TableInfo])
clientCatalog client = do
answer <- request client ReqCatalog
case answer of
Left message -> pure (Left message)
Right (RespCatalog infos) -> pure (Right infos)
Right other -> pure (failed "a catalog" other)
-- | 库清单（\\l 用）
clientDatabases :: Client -> IO (Either Text [Text])
clientDatabases client = do
answer <- request client ReqDatabases
case answer of
Left message -> pure (Left message)
Right (RespDatabases names) -> pure (Right names)
Right other -> pure (failed "a database list" other)
-- | 角色总览（\\dr 用）
clientRoles :: Client -> IO (Either Text [RoleView])
clientRoles client = do
answer <- request client ReqRoles
case answer of
Left message -> pure (Left message)
Right (RespRoles roles) -> pure (Right roles)
Right other -> pure (failed "a role list" other)
-- | 账号清单（\\du 与管理页用）
clientAccounts :: Client -> IO (Either Text [Account])
clientAccounts client = do
answer <- request client ReqAccounts
case answer of
Left message -> pure (Left message)
Right (RespAccounts accounts) -> pure (Right accounts)
Right other -> pure (failed "an account list" other)
-- | 当前生效的口令策略（最短长度、至少几类字符）
clientPolicy :: Client -> IO (Either Text (Int, Int))
clientPolicy client = do
answer <- request client ReqPolicy
case answer of
Left message -> pure (Left message)
Right (RespPolicy minLength classes) -> pure (Right (minLength, classes))
Right other -> pure (failed "a password policy" other)
-- | 让 server 重读它自己的设置文件并换上新的口令策略
clientReloadPolicy :: Client -> IO (Either Text (Int, Int))
clientReloadPolicy client = do
answer <- request client ReqReloadPolicy
case answer of
Left message -> pure (Left message)
Right (RespPolicy minLength classes) -> pure (Right (minLength, classes))
Right other -> pure (failed "a password policy reload" other)
-- | 应答形状对不上时的错误，error 应答取码与说明
failed :: Text -> ServerResponse -> Either Text a
failed what response = case response of
RespError code message -> Left (code <> ": " <> message)
_ -> Left ("unexpected response to " <> what)
-- | 建连接（套接字转成文本模式的行缓冲句柄）
openConnection :: Text -> Int -> IO Handle
openConnection host port = do
let hints = defaultHints{addrSocketType = Stream}
infos <- getAddrInfo (Just hints) (Just (T.unpack host)) (Just (show port))
case infos of
[] -> ioError (userError ("cannot resolve server address: " ++ address host port))
(info : _) -> do
sock <- socket (addrFamily info) Stream defaultProtocol
connect sock (addrAddress info)
handle <- socketToHandle sock ReadWriteMode
hSetBuffering handle LineBuffering
hSetNewlineMode handle noNewlineTranslation
pure handle
-- | 把主机端口拼成地址字样
address :: Text -> Int -> String
address host port = T.unpack host ++ ":" ++ show port
-- | 断线给人的说法：EOF 就是 server 把连接关了
describe :: IOException -> String
describe err
| isEOFError err = "the server closed the connection"
| otherwise = show err
chusql-interface/src/ChuSQL/Interface/Policy.hs
+42
View File
@@ -0,0 +1,42 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Interface.Policy (
PasswordPolicy (..),
defaultPasswordPolicy,
passwordKeys,
policyFromValues,
) where
import ChuSQL.Interface.Settings (defaultOf)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Text.Read (readMaybe)
-- 口令策略值与策略计算，服务端与 Web 管理端共用。
-- | 口令策略：最短长度与至少几类字符
data PasswordPolicy = PasswordPolicy
{ ppMinLength :: Int
, ppClasses :: Int
}
deriving (Show, Eq)
-- | 默认：至少 12 个字符、至少两类字符
defaultPasswordPolicy :: PasswordPolicy
defaultPasswordPolicy = PasswordPolicy 12 2
-- | 设置文件里决定口令策略的键
passwordKeys :: [Text]
passwordKeys = ["password-min-length", "password-classes"]
-- | 策略值：缺项或空值回落到内置默认
policyFromValues :: PasswordPolicy -> Map.Map Text Text -> PasswordPolicy
policyFromValues before values = PasswordPolicy
(number "password-min-length" (ppMinLength before)) (number "password-classes" (ppClasses before))
where
-- | 取一个键的数值，缺项或空值回落到给定默认
number key fallback = case Map.lookup key values of
Nothing -> fallback
Just value -> fromMaybe fallback (readMaybe (T.unpack (if T.null value then defaultOf key else value)))
chusql-interface/src/ChuSQL/Interface/Protocol.hs
+248
View File
@@ -0,0 +1,248 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Interface.Protocol (
protocolVersion,
serverName,
ClientRequest (..),
ServerResponse (..),
decodeRequest,
encodeRequest,
encodeResponse,
decodeResponse,
Grant (..),
RoleView (..),
) where
import ChuSQL.Core.Protocol (Account (..), QueryResult (..), TableInfo (..), queryResultJson)
import Data.Aeson (FromJSON (..), ToJSON (..), Value, object, withObject, (.:), (.:?), (.!=), (.=))
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as AK
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BL
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
-- server 线上协议的编解码：一行一条 JSON（UTF-8）。
-- | 一条角色授权：角色 + 具体权限 + 对象
data Grant = Grant
{ grantRole :: Text
, grantPrivilege :: Text
, grantObject :: Text
}
deriving (Show, Eq, Ord)
-- | 一个角色的全貌
data RoleView = RoleView
{ roleName :: Text
, roleGrants :: [Grant]
, roleMembers :: [Text]
}
deriving (Show, Eq)
-- | 一条授权转成 JSON
instance ToJSON Grant where
toJSON grant =
object
[ "role" .= grantRole grant
, "privilege" .= grantPrivilege grant
, "object" .= grantObject grant
]
-- | 从 JSON 读一条授权
instance FromJSON Grant where
parseJSON = withObject "Grant" $ \o ->
Grant <$> o .: "role" <*> o .: "privilege" <*> o .: "object"
-- | 一个角色转成 JSON
instance ToJSON RoleView where
toJSON view =
object
[ "role" .= roleName view
, "grants" .= roleGrants view
, "members" .= roleMembers view
]
-- | 从 JSON 读一个角色
instance FromJSON RoleView where
parseJSON = withObject "RoleView" $ \o ->
RoleView
<$> o .: "role"
<*> o .:? "grants" .!= []
<*> o .:? "members" .!= []
-- | 协议版本；对不上就报协议错误
protocolVersion :: Int
protocolVersion = 1
-- | server 名字，握手时回给客户端
serverName :: Text
serverName = "chusql-server"
-- | 客户端请求
data ClientRequest
= ReqHello Int
| ReqLogin Text Text
| ReqQuery Text
| ReqPing
| ReqQuit
| ReqStorage Value
| ReqCatalog
| ReqDatabases
| ReqRoles
| ReqAccounts
| ReqPolicy
| ReqReloadPolicy
deriving (Eq, Show)
-- | 线上请求的原始字段
data WireRequest = WireRequest
{ wrMethod :: Text
, wrProtocol :: Maybe Int
, wrUser :: Maybe Text
, wrPassword :: Maybe Text
, wrSql :: Maybe Text
, wrRequest :: Maybe Value
}
-- | 从 JSON 读原始请求字段
instance A.FromJSON WireRequest where
parseJSON = A.withObject "request" $ \o ->
WireRequest
<$> o A..: "method"
<*> o A..:? "protocol"
<*> o A..:? "user"
<*> o A..:? "password"
<*> o A..:? "sql"
<*> o A..:? "request"
-- | 请求解码：方法名走 method 标签
decodeRequest :: BSC.ByteString -> Either Text ClientRequest
decodeRequest raw = case A.eitherDecodeStrict raw of
Left _ -> Left "request is not valid JSON"
Right wire -> case T.toLower (T.strip (wrMethod wire)) of
"hello" -> Right (ReqHello (fromMaybe protocolVersion (wrProtocol wire)))
"login" -> case (wrUser wire, wrPassword wire) of
(Just user, Just password) -> Right (ReqLogin user password)
_ -> Left "login needs both user and password"
"query" -> maybe (Left "query needs sql") (Right . ReqQuery) (wrSql wire)
"storage" -> maybe (Left "storage needs request") (Right . ReqStorage) (wrRequest wire)
"catalog" -> Right ReqCatalog
"databases" -> Right ReqDatabases
"roles" -> Right ReqRoles
"accounts" -> Right ReqAccounts
"policy" -> Right ReqPolicy
"reload-policy" -> Right ReqReloadPolicy
"ping" -> Right ReqPing
"quit" -> Right ReqQuit
other -> Left ("unknown method: " <> other)
-- | 客户端侧的请求编码（一行一条 JSON，不带换行）
encodeRequest :: ClientRequest -> BL.ByteString
encodeRequest = A.encode . requestJson
-- | 客户端请求转 JSON；方法名走 method 标签
requestJson :: ClientRequest -> Value
requestJson request = case request of
ReqHello version -> object ["method" .= ("hello" :: Text), "protocol" .= version]
ReqLogin user password -> object ["method" .= ("login" :: Text), "user" .= user, "password" .= password]
ReqQuery sql -> object ["method" .= ("query" :: Text), "sql" .= sql]
ReqPing -> object ["method" .= ("ping" :: Text)]
ReqQuit -> object ["method" .= ("quit" :: Text)]
ReqStorage payload -> object ["method" .= ("storage" :: Text), "request" .= payload]
ReqCatalog -> object ["method" .= ("catalog" :: Text)]
ReqDatabases -> object ["method" .= ("databases" :: Text)]
ReqRoles -> object ["method" .= ("roles" :: Text)]
ReqAccounts -> object ["method" .= ("accounts" :: Text)]
ReqPolicy -> object ["method" .= ("policy" :: Text)]
ReqReloadPolicy -> object ["method" .= ("reload-policy" :: Text)]
-- | 服务端响应
data ServerResponse
= RespHello Int
| RespLogin Text Bool
| RespResult QueryResult
| RespPong
| RespBye
| RespError Text Text
| RespStorage Value
| RespCatalog [TableInfo]
| RespDatabases [Text]
| RespRoles [RoleView]
| RespAccounts [Account]
| RespPolicy Int Int
deriving (Eq, Show)
-- | 响应转 JSON；结果集只多一个 status 字段
encodeResponse :: ServerResponse -> BL.ByteString
encodeResponse = A.encode . responseJson
-- | 服务端响应转 JSON；结果集只是多一个 status 字段
responseJson :: ServerResponse -> Value
responseJson response = case response of
RespHello version -> object ["status" .= ("hello" :: Text), "protocol" .= version, "server" .= serverName]
RespLogin user admin -> object ["status" .= ("ok" :: Text), "user" .= user, "admin" .= admin]
RespPong -> object ["status" .= ("pong" :: Text)]
RespBye -> object ["status" .= ("bye" :: Text)]
RespError code message -> object ["status" .= ("error" :: Text), "code" .= code, "message" .= message]
RespStorage value -> object ["status" .= ("storage" :: Text), "response" .= value]
RespCatalog infos -> object ["status" .= ("catalog" :: Text), "schemas" .= infos]
RespDatabases names -> object ["status" .= ("databases" :: Text), "databases" .= names]
RespRoles roleList -> object ["status" .= ("roles" :: Text), "roles" .= roleList]
RespAccounts accountList -> object ["status" .= ("accounts" :: Text), "accounts" .= accountList]
RespPolicy minLength classes -> object ["status" .= ("policy" :: Text), "minLength" .= minLength, "classes" .= classes]
RespResult result -> case queryResultJson result of
A.Object fields -> A.Object (KM.insert "status" (A.String "result") fields)
other -> other
-- | 响应解码（客户端用）
decodeResponse :: BL.ByteString -> Either Text ServerResponse
decodeResponse raw = case A.eitherDecode raw of
Left _ -> Left "response is not valid JSON"
Right (A.Object fields) -> case KM.lookup "status" fields of
Just (A.String status) -> decodeStatus status fields
_ -> Left "response is missing status"
Right _ -> Left "response is not a JSON object"
where
-- | 按 status 字段分派
decodeStatus status fields = case status of
"hello" -> Right (RespHello (intOf "protocol" fields))
"ok" -> Right (RespLogin (textOf "user" fields) (boolOf "admin" fields))
"pong" -> Right RespPong
"bye" -> Right RespBye
"error" -> Right (RespError (textOf "code" fields) (textOf "message" fields))
"storage" -> case KM.lookup "response" fields of
Just value -> Right (RespStorage value)
Nothing -> Left "storage response is missing response"
"result" -> case A.fromJSON (A.Object fields) of
A.Success result -> Right (RespResult result)
A.Error message -> Left (T.pack message)
"catalog" -> fromField "schemas" RespCatalog fields
"databases" -> fromField "databases" RespDatabases fields
"roles" -> fromField "roles" RespRoles fields
"accounts" -> fromField "accounts" RespAccounts fields
"policy" -> Right (RespPolicy (intOf "minLength" fields) (intOf "classes" fields))
other -> Left ("unexpected status: " <> other)
-- | 取一个字段解成目标类型
fromField :: A.FromJSON a => Text -> (a -> ServerResponse) -> A.Object -> Either Text ServerResponse
fromField key wrap fields = case A.fromJSON (fromMaybe A.Null (KM.lookup (AK.fromText key) fields)) of
A.Success value -> Right (wrap value)
A.Error message -> Left (T.pack message)
-- | 取一个整数字段
intOf key fields = case KM.lookup key fields of
Just (A.Number number) -> truncate number
_ -> 0
-- | 取一个文本字段
textOf key fields = case KM.lookup key fields of
Just (A.String text) -> text
_ -> ""
-- | 取一个布尔字段
boolOf key fields = case KM.lookup key fields of
Just (A.Bool flag) -> flag
_ -> False
chusql-web/src/ChuSQL/Web/RateLimit.hs → chusql-interface/src/ChuSQL/Interface/RateLimit.hs
+4 -1
View File
@@ -1,4 +1,4 @@
module ChuSQL.Web.RateLimit (
module ChuSQL.Interface.RateLimit (
RateLimiter,
newRateLimiter,
setRateLimit,
@@ -15,16 +15,19 @@ import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime)
-- 登录失败限流：按用户名数一个滑动窗口里的失败次数。
-- | 一个键的失败计数与窗口起点
data Attempt = Attempt
{ attCount :: Int
, attStart :: UTCTime
}
-- | 限流阈值：次数上限与窗口长度
data RateLimitPolicy = RateLimitPolicy
{ rlpMax :: Int
, rlpWindow :: NominalDiffTime
}
-- | 限流器：计数表、阈值与时钟
data RateLimiter = RateLimiter
{ rlMap :: MVar (Map.Map Text Attempt)
, rlPolicy :: IORef RateLimitPolicy
chusql-interface/src/ChuSQL/Interface/Session.hs
+110
View File
@@ -0,0 +1,110 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Interface.Session (
Session,
newSession,
sessionIsAdmin,
sessionDatabase,
isPlainIdentifier,
authenticateSession,
switchDatabase,
runStatement,
catalog,
databases,
roleViews,
accounts,
) where
import ChuSQL.Core.Protocol (Account, QueryResult (..), TableInfo)
import ChuSQL.Interface.Link (
Client,
clientAccounts,
clientCatalog,
clientDatabases,
clientLogin,
clientQuery,
clientRoles,
)
import ChuSQL.Interface.Protocol (RoleView)
import Data.Char (isAlpha, isAlphaNum)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Text (Text)
import qualified Data.Text as T
-- 前端会话：本地记登录态与当前库，语句答案全部来自 server。
-- | 一个前端会话：连接、当前库与管理员标记
data Session = Session
{ ssClient :: Client
, ssCurrent :: IORef Text
, ssAdmin :: IORef Bool
}
-- | 开一个前端会话：登录之前没有管理员身份，也没有选中的库
newSession :: Client -> IO Session
newSession client = Session client <$> newIORef "" <*> newIORef False
-- | 是不是管理员（由登录结果决定）
sessionIsAdmin :: Session -> IO Bool
sessionIsAdmin = readIORef . ssAdmin
-- | 当前库
sessionDatabase :: Session -> IO Text
sessionDatabase = readIORef . ssCurrent
-- | 与解析器一致的裸标识符判断
isPlainIdentifier :: Text -> Bool
isPlainIdentifier name =
not (T.null name)
&& T.length name <= 64
&& (isAlpha (T.head name) || T.head name == '_')
&& T.all (\ch -> isAlphaNum ch || ch == '_') name
-- | 登录：身份由 server 判定，这里只把管理员标记记下来
authenticateSession :: Session -> Text -> Text -> IO (Either Text ())
authenticateSession session user password = do
answer <- clientLogin (ssClient session) user password
case answer of
Left message -> pure (Left message)
Right admin -> writeIORef (ssAdmin session) admin >> pure (Right ())
-- | 换库：名字先按解析器规矩校验，由 server 执行 USE
switchDatabase :: Session -> Text -> IO (Either Text ())
switchDatabase session rawName
| not (isPlainIdentifier name) = pure (Left ("not a plain database name: " <> name))
| otherwise = do
answer <- runStatement session ("USE " <> name)
case answer of
Left message -> pure (Left message)
Right _ -> pure (Right ())
where
-- | 规范化后的库名
name = T.toLower (T.strip rawName)
-- | 跑一条语句；结果集里带回的当前库口径跟着一起更新
runStatement :: Session -> Text -> IO (Either Text QueryResult)
runStatement session sql = do
answer <- clientQuery (ssClient session) sql
case answer of
Left message -> pure (Left message)
Right result -> do
case qrDatabase result of
Just name -> writeIORef (ssCurrent session) name
Nothing -> pure ()
pure (Right result)
-- | 数据字典（\\dt 与 \\d 用）
catalog :: Session -> IO (Either Text [TableInfo])
catalog session = clientCatalog (ssClient session)
-- | 库清单（\\l 用）
databases :: Session -> IO (Either Text [Text])
databases session = clientDatabases (ssClient session)
-- | 角色总览（\\dr 用）
roleViews :: Session -> IO (Either Text [RoleView])
roleViews session = clientRoles (ssClient session)
-- | 账号清单（\\du 与管理页用）
accounts :: Session -> IO (Either Text [Account])
accounts session = clientAccounts (ssClient session)
chusql-web/src/ChuSQL/Web/Settings.hs → chusql-interface/src/ChuSQL/Interface/Settings.hs
+25 -19
View File
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Web.Settings (
module ChuSQL.Interface.Settings (
SettingItem (..),
settingCatalogue,
findItem,
@@ -15,16 +15,16 @@ module ChuSQL.Web.Settings (
effectiveSettings,
) where
import ChuSQL.Web.Config (WebConfig (..), canonicalSettingKeys, defaultUser)
import ChuSQL.Web.TOML (readSection, writeSection)
import ChuSQL.Interface.Config (WebConfig (..), canonicalSettingKeys, defaultUser)
import ChuSQL.Interface.TOML (readSection, writeSection)
import Data.List (nub)
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import qualified Data.Text as T
-- Web 配置项目录，与启动脚本共用一份全局 chusql.toml；
-- 每个键只写在它所属的那一段里，web 不再复制存储层的键。
-- 设置目录，以及全局 chusql.toml 的读、写与校验。
-- | 一个可配置项
data SettingItem = SettingItem
{ siKey :: Text
, siLabel :: Text
@@ -38,10 +38,10 @@ data SettingItem = SettingItem
}
deriving (Show, Eq)
-- | 全部可配置项（顺序即界面里的顺序）
-- | 全部可配置项与界面顺序
settingCatalogue :: [SettingItem]
settingCatalogue =
[ item "port" "HTTP port" "server" "int" "7777" True True
[ item "port" "HTTP port" "server" "int" "7778" True True
, item "host" "Listen address" "server" "text" "127.0.0.1" True True
, item "static-dir" "Static directory" "server" "text" "static" True True
, item "cookie-secure" "Secure cookie (behind TLS)" "server" "bool" "0" True False
@@ -59,16 +59,18 @@ settingCatalogue =
, item "password-min-length" "口令最短长度" "auth" "int" "12" True False
, item "password-classes" "口令字符类别数" "auth" "int" "2" True False
, owned "data-dir" "Data directory" "storage" "text" "" "storage" "data_dir"
, owned "pipe-name" "Endpoint name" "storage" "text" "" "server" "pipe_name"
, owned "storage-page-size" "Storage page size" "storage" "int" "4096" "page" "size"
, 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-log" "Storage log level" "storage" "text" "info" "log" "level"
, item "storage-server" "Storage server executable" "storage" "text" "" True True
, item "seed" "Seed demo data on start" "storage" "bool" "1" True True
, owned "tcp-host" "TCP listen address" "network" "text" "127.0.0.1" "server" "host"
, 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-rows" "TCP rows per result" "network" "int" "1000" "server" "max_rows"
]
where
-- web 自己的键：分区写死 [web]，TOML 键名就是界面键名
-- | web 自己的键：分区写死 [web]
item k l g kind def rootOnly restart =
SettingItem
{ siKey = k
@@ -95,11 +97,11 @@ settingCatalogue =
, siTomlKey = tomlKey
}
-- | web 自己那段
-- | web 自己的分区名
webSection :: Text
webSection = "web"
-- | 目录里涉及的分区（按出现顺序，去重）
-- | 目录里涉及的分区，去重
catalogueSections :: [Text]
catalogueSections = nub [siSection i | i <- settingCatalogue]
@@ -113,7 +115,7 @@ findItem key = case [i | i <- settingCatalogue, siKey i == key] of
isRootOnly :: Text -> Bool
isRootOnly key = maybe False siRootOnly (findItem key)
-- | 只读项：root 凭据只认设置文件里的明文，网页端不能改（改文件后重启生效）
-- | 网页端不能改的键
lockedKeys :: [Text]
lockedKeys = ["user", "password"]
@@ -140,10 +142,11 @@ liveKeys =
, "max-sql-length"
]
-- | 读目录里用到的每个分区，摊成界面键；只有 [web] 统一成连字符写法
-- | 读目录里用到的每个分区，摊成界面键
readSettingsFile :: FilePath -> IO (Map.Map Text Text)
readSettingsFile path = fmap Map.unions (mapM readSectionOf catalogueSections)
where
-- | 读一个分区，摊成界面键
readSectionOf section = do
raw <- readSection path section
let values = if section == webSection then canonicalSettingKeys raw else raw
@@ -156,10 +159,11 @@ readSettingsFile path = fmap Map.unions (mapM readSectionOf catalogueSections)
]
)
-- | 按分区写回：每个键落进自己的段，别的分区与注释原样保留
-- | 按分区写回，别的分区与注释原样保留
writeSettingsFile :: FilePath -> Map.Map Text Text -> IO (Either String ())
writeSettingsFile path values = writeSections catalogueSections
where
-- | 各分区依次写回
writeSections [] = pure (Right ())
writeSections (section : rest) = do
let entries =
@@ -177,10 +181,11 @@ writeSettingsFile path values = writeSections catalogueSections
Left err -> pure (Left err)
Right () -> writeSections rest
-- | 把界面上传来的值合并进现有文件内容（只接受目录里有的键）
-- | 把界面传来的值合并进现有内容，只认目录里的键
applySettings :: Map.Map Text Text -> Map.Map Text Text -> Either String (Map.Map Text Text)
applySettings current = go (Right current) . Map.toList
where
-- | 逐项校验并合并
go (Left e) _ = Left e
go (Right acc) [] = Right acc
go (Right acc) ((key, value) : rest) = case findItem key of
@@ -189,7 +194,7 @@ applySettings current = go (Right current) . Map.toList
Left e -> Left e
Right () -> go (Right (Map.insert key value acc)) rest
-- | 按类型校验一个值（空串表示"清掉"，一律放行）
-- | 按类型校验一个值，空串一律放行
checkKind :: SettingItem -> Text -> Either String ()
checkKind spec value
| T.null (T.strip value) = Right ()
@@ -205,7 +210,7 @@ checkKind spec value
_ -> Left (T.unpack (siKey spec) ++ " needs a boolean, got: " ++ T.unpack value)
| otherwise = Right ()
-- | 一项的内置默认值（设置被清掉、也没有别处给值时用它）
-- | 一项的内置默认值
defaultOf :: Text -> Text
defaultOf key = maybe "" siDefault (findItem key)
@@ -229,9 +234,10 @@ effectiveSettings cfg =
, ("user", if T.null (T.strip (wcUser cfg)) then defaultUser else T.strip (wcUser cfg))
, ("seed", boolText (wcSeedDemo cfg))
, ("data-dir", maybe "" T.pack (wcDataDir cfg))
, ("pipe-name", maybe "" T.pack (wcPipeName cfg))
]
where
-- | 数值转文本
tshow = T.pack . show
-- | 布尔转 "1"/"0"
boolText True = "1"
boolText False = "0"
chusql-web/src/ChuSQL/Web/TOML.hs → chusql-interface/src/ChuSQL/Interface/TOML.hs
+16 -6
View File
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Web.TOML
module ChuSQL.Interface.TOML
( readSection
, writeSection
, defaultConfigFile
@@ -19,7 +19,6 @@ import System.Directory (XdgDirectory (XdgConfig), createDirectoryIfMissing, doe
import System.FilePath (takeDirectory, (</>))
-- 全局 chusql.toml 的最小读写：只认 [section] 与 key = value。
-- 读写都是一次性打开就关，不长期占着文件句柄，别的层随时能读同一份文件。
-- | 读一个分区；文件不存在或没有这个分区都当空表
readSection :: FilePath -> Text -> IO (Map Text Text)
@@ -44,6 +43,7 @@ writeSection path section values = do
written <- tryWrite (TE.encodeUtf8 updated)
pure written
where
-- | 目录不存在就先建
prepareDirectory = do
let dir = takeDirectory path
if null dir
@@ -51,6 +51,7 @@ writeSection path section values = do
else do
done <- try (createDirectoryIfMissing True dir) :: IO (Either IOException ())
pure (either (Left . show) (const (Right ())) done)
-- | 写文件，异常转成错误串
tryWrite bytes = do
done <- try (BS.writeFile path bytes) :: IO (Either IOException ())
pure (either (Left . show) (const (Right ())) done)
@@ -59,6 +60,7 @@ writeSection path section values = do
sectionEntries :: Text -> [Text] -> [(Text, Text)]
sectionEntries wanted = go ""
where
-- | 走到目标分区后收键值对
go _ [] = []
go current (line : rest)
| Just name <- sectionName line = go name rest
@@ -89,6 +91,7 @@ assignment line = case T.breakOn "=" (stripComment line) of
stripComment :: Text -> Text
stripComment = T.pack . go False . T.unpack
where
-- | 引号外遇到 # 就到此为止
go _ [] = []
go inString ('#' : rest)
| not inString = []
@@ -103,12 +106,15 @@ unquote value
| T.length value >= 2 && T.head value == '\'' && T.last value == '\'' = T.drop 1 (T.dropEnd 1 value)
| otherwise = value
-- | 行级重写：本分区里已有的键就地更新，空值删行，缺的键补在分区末尾
-- | 行级重写：已有键就地更新，空值删行，缺的补末尾
rewrite :: Text -> Map Text Text -> [Text] -> [Text]
rewrite section values = addMissing . replaceInSection . dropEmpties
where
-- | 删掉空值的键
dropEmpties = filter (\line -> maybe True (not . T.null . snd) (assignment line))
-- | 在目标分区里就地换行
replaceInSection = go ""
-- | 走到目标分区后逐行替换
go _ [] = []
go current (line : rest)
| Just name <- sectionName line = line : go name rest
@@ -116,25 +122,30 @@ rewrite section values = addMissing . replaceInSection . dropEmpties
| otherwise = case assignment line of
Just (key, _) | Just value <- Map.lookup key values -> assignmentLine key value : go current rest
_ -> line : go current rest
-- | 分区里缺的键补在末尾
addMissing lines' =
let present = Set.fromList (keysOf section lines')
missing = [(key, value) | (key, value) <- Map.toList values, not (Set.member key present), not (T.null value)]
in if null missing then lines' else appendSection section missing lines'
-- | 拼一行 key = value
assignmentLine :: Text -> Text -> Text
assignmentLine key value = key <> " = " <> quote value
-- | 需要时才加引号
quote :: Text -> Text
quote value
| T.all allowed value && not (T.null value) = value
| otherwise = "\"" <> T.replace "\"" "\\\"" value <> "\""
where
-- | 可以裸写的字符集
allowed ch = ch `elem` ("0123456789.-" :: String)
-- | 取某个分区里出现过的键
keysOf :: Text -> [Text] -> [Text]
keysOf wanted = go ""
where
-- | 走到目标分区后收键名
go _ [] = []
go current (line : rest)
| Just name <- sectionName line = go name rest
@@ -150,14 +161,13 @@ appendSection section entries lines' =
++ (if null lines' || not (T.null (last lines')) then [""] else [])
++ ("[" <> section <> "]") : [assignmentLine key value | (key, value) <- entries]
-- | 全局配置文件的位置：安装时定下的固定路径，跟随系统惯例
-- （Windows: %APPDATA%\ChuSQL\chusql.toml；其它平台: $XDG_CONFIG_HOME 或 ~/.config 下的 ChuSQL/chusql.toml）
-- | 全局配置文件的固定路径，跟随系统惯例
defaultConfigFile :: IO FilePath
defaultConfigFile = do
dir <- getXdgDirectory XdgConfig "ChuSQL"
pure (dir </> "chusql.toml")
-- | 定位配置文件：命令行 --config 指的是哪份就读哪份，否则用固定路径
-- | 定位配置文件：命令行 --config 优先，否则用固定路径
resolveConfigPath :: Maybe FilePath -> IO FilePath
resolveConfigPath (Just path) = pure path
resolveConfigPath Nothing = defaultConfigFile
chusql-interface/stack.yaml
+5
View File
@@ -0,0 +1,5 @@
resolver: lts-24.59
packages:
- .
- ../chusql-core/model
chusql-interface/stack.yaml.lock
+12
View File
@@ -0,0 +1,12 @@
# This file was autogenerated by Stack.
# You should not edit this file by hand.
# For more information, please see the documentation at:
# https://docs.haskellstack.org/en/stable/topics/lock_files
packages: []
snapshots:
- completed:
sha256: 0f728e30e843d7f00460ad56858b995a3b227fca683659c7df9f2fc3988a3ce1
size: 732465
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/59.yaml
original: lts-24.59
chusql-server/app/Main.hs
+223
View File
@@ -0,0 +1,223 @@
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
import ChuSQL.Core.Engine.Storage.FFI (storageVersion)
import ChuSQL.Core.Engine.Storage.IPC (closeConnection, localStorageLink, setStorageLink)
import ChuSQL.Interface.Auth (Credential (..))
import ChuSQL.Interface.Config (
WebConfig (..),
defaultPassword,
defaultUser,
loadWebConfigAt,
resolveCredential,
usingDefaultCredentials,
)
import ChuSQL.Interface.RateLimit (newRateLimiter)
import ChuSQL.Interface.Settings (readSettingsFile)
import ChuSQL.Interface.TOML (resolveConfigPath)
import ChuSQL.Server.Backend (Backend (..), ipcBackend)
import ChuSQL.Server.TCP (
ServerConfig (..),
ServerEnv,
loadServerConfigAt,
newServerEnv,
runServer,
)
import Control.Exception (IOException, bracket, try)
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (getCurrentTime)
import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout)
import Text.Read (readMaybe)
-- TCP 服务器入口：解析命令行与配置，装入存储库并以一行一 JSON 的协议对外服务。
data Options = Options
{ optConfig :: Maybe FilePath
, optHost :: Maybe String
, optPort :: Maybe Int
, optUser :: Maybe Text
, optMaxMessage :: Maybe Int
, optMaxRows :: Maybe Int
, optHelp :: Bool
}
-- | 全部选项都取默认值
emptyOptions :: Options
emptyOptions =
Options
{ optConfig = Nothing
, optHost = Nothing
, optPort = Nothing
, optUser = Nothing
, optMaxMessage = Nothing
, optMaxRows = Nothing
, optHelp = False
}
-- | 解析参数
parseArgs :: [String] -> Either String Options
parseArgs = go emptyOptions
where
-- | 逐条消费参数列表
go opts [] = Right opts
go opts ("--help" : rest) = go opts{optHelp = True} rest
go opts ("-h" : rest) = go opts{optHelp = True} rest
go opts ("--config" : v : rest) = go opts{optConfig = Just v} rest
go opts ("--host" : v : rest) = go opts{optHost = Just v} rest
go opts ("--user" : v : rest) = go opts{optUser = Just (T.pack v)} rest
go opts ("--port" : v : rest) = withInt "--port" v (\n -> go opts{optPort = Just n} rest)
go opts ("--max-message" : v : rest) = withInt "--max-message" v (\n -> go opts{optMaxMessage = Just n} rest)
go opts ("--max-rows" : v : rest) = withInt "--max-rows" v (\n -> go opts{optMaxRows = Just n} rest)
go _ (a : _) = Left ("unrecognized argument or missing value: " ++ a)
-- | 把参数值读成整数，读不出就报错
withInt :: String -> String -> (Int -> Either String Options) -> Either String Options
withInt name v k = maybe (Left (name ++ " needs an integer, got: " ++ v)) k (readMaybe v)
-- | 打印用法说明
usage :: IO ()
usage = do
putStrLn "usage: chusql-server [options]"
putStrLn ""
putStrLn "config: chusql.toml sits at a fixed place and holds every knob;"
putStrLn " Windows: %APPDATA%\\ChuSQL\\chusql.toml"
putStrLn " other: $XDG_CONFIG_HOME/ChuSQL/chusql.toml (or ~/.config/ChuSQL/chusql.toml)"
putStrLn " [storage] data_dir; [server] host/port/max_message/max_rows;"
putStrLn " [web] user/password (administrator credentials)"
putStrLn ""
putStrLn " --config FILE read that config file instead"
putStrLn " --host H listen address ([server] host, default 127.0.0.1)"
putStrLn " --port N listen port ([server] port, default 7777)"
putStrLn " --user NAME administrator name ([web] user, default root)"
putStrLn " --max-message N max bytes per request line ([server] max_message, default 1048576)"
putStrLn " --max-rows N rows returned per query ([server] max_rows, default 1000)"
putStrLn ""
putStrLn "protocol: one JSON object per line; hello / login / query / storage / ping / quit"
putStrLn " {\"method\":\"login\",\"user\":\"root\",\"password\":\"...\"} then {\"method\":\"query\",\"sql\":\"SELECT 1\"}"
putStrLn " {\"method\":\"storage\",\"request\":{...}} forwards one storage request (Web and the CLI use this)"
putStrLn ""
putStrLn "storage: this process loads the chusql_core_storage library in-process and owns the data directory"
putStrLn ""
putStrLn "administrator password: user / password in the [web] section of chusql.toml, else the built-in demo"
putStrLn " an empty password means the administrator signs in with no password; ordinary accounts are then refused"
putStrLn ("without either the demo administrator is " ++ T.unpack defaultUser ++ " / " ++ T.unpack defaultPassword)
-- | 命令行覆盖管理员
applyWebOptions :: WebConfig -> Options -> WebConfig
applyWebOptions cfg opts =
cfg
{ wcUser = orElse (optUser opts) (wcUser cfg)
}
-- | 命令行覆盖监听配置
applyServerOptions :: ServerConfig -> Options -> ServerConfig
applyServerOptions config opts =
config
{ scHost = orElse (optHost opts) (scHost config)
, scPort = orElse (optPort opts) (scPort config)
, scMaxMessage = orElse (optMaxMessage opts) (scMaxMessage config)
, scMaxRows = orElse (optMaxRows opts) (scMaxRows config)
}
-- | 有 Just 就用它，否则用兜底值
orElse :: Maybe a -> a -> a
orElse (Just x) _ = x
orElse Nothing y = y
-- | 入口
main :: IO ()
main = do
hSetBuffering stdout LineBuffering
args <- getArgs
case parseArgs args of
Left err -> do
putStrLn ("bad arguments: " ++ err)
usage
exitFailure
Right opts
| optHelp opts -> usage
| otherwise -> run opts
-- | 起服务：装入存储库并装配各服务组件
run :: Options -> IO ()
run opts = do
configPath <- resolveConfigPath (optConfig opts)
base <- loadWebConfigAt configPath
let cfg = applyWebOptions base opts
saved <- readSettingsFile configPath
cred <- resolveCredential cfg saved
config <- applyServerOptions <$> loadServerConfigAt configPath <*> pure opts
opened <- localStorageLink (Just configPath)
case opened of
Left err -> do
putStrLn ("cannot open the storage library: " ++ err)
exitFailure
Right link -> do
setStorageLink link
backend <- ipcBackend
printBanner cfg config configPath
checkStorage backend
reportCredential cred saved
limiter <-
newRateLimiter
getCurrentTime
(wcLoginMaxAttempts cfg)
(fromIntegral (wcLoginWindow cfg))
env <- newServerEnv backend cred configPath config limiter
let announce port = putStrLn ("listening: tcp://" ++ scHost config ++ ":" ++ show port)
bracket (pure link) (const closeConnection) (const (serve env announce))
-- | 起 TCP 服务并处理绑定失败
serve :: ServerEnv -> (Int -> IO ()) -> IO ()
serve env announce = do
result <- try (runServer env announce) :: IO (Either IOException ())
case result of
Right () -> pure ()
Left e -> do
putStrLn ("failed to serve TCP: " ++ show e)
putStrLn " the port is probably taken or reserved by the system; try another one: --port 7777"
exitFailure
-- | 报告口令来源，用内置默认口令时告警
reportCredential :: Credential -> Map.Map Text Text -> IO ()
reportCredential cred saved
| usingDefaultCredentials saved = do
putStrLn ""
putStrLn " !! Administrator credentials are not configured; the built-in demo password is in use:"
putStrLn (" !! user " ++ T.unpack (credUser cred) ++ " / password " ++ T.unpack defaultPassword)
putStrLn " !! set user / password in the [web] section of chusql.toml and restart"
putStrLn ""
| T.null (credEncoded cred) =
putStrLn ("administrator: " ++ T.unpack (credUser cred) ++ " (passwordless: only the administrator may sign in)")
| otherwise = putStrLn ("administrator: " ++ T.unpack (credUser cred) ++ " (credentials come from the settings file only)")
-- | 探测存储是否可用，答不上 ping 就退出
checkStorage :: Backend -> IO ()
checkStorage backend = do
up <- bePing backend
if up
then putStrLn "storage: up (the library answered ping)"
else do
putStrLn "storage: DOWN (the storage library did not answer ping)"
exitFailure
-- | 启动横幅
printBanner :: WebConfig -> ServerConfig -> FilePath -> IO ()
printBanner cfg config configPath = do
version <- storageVersion
putStrLn "================== ChuSQL Server ==================="
putStrLn ("config file: " ++ configPath)
putStrLn ("protocol: chusql 1 (one JSON object per line)")
putStrLn
( "limits: message "
++ show (scMaxMessage config)
++ "B, query rows "
++ show (scMaxRows config)
)
putStrLn ("storage: chusql_core_storage library " ++ version)
putStrLn ("data dir: " ++ orElse (wcDataDir cfg) "(from the config file, else the default)")
chusql-server/chusql-server.cabal
+79
View File
@@ -0,0 +1,79 @@
cabal-version: 2.4
name: chusql-server
version: 1.0.0
synopsis: ChuSQL 数据库服务器：TCP 端点 + 自家协议 + SQL 会话
description: ChuSQL 的数据库服务器。负责监听 TCP、一行一条 JSON 的自家协议、
登录与限流，并把用户 SQL 转交给 chusql-core-engine（存储则由进程内
的 chusql_core_storage 动态库承担）。Web 管理端与命令行客户端都只
通过这条 TCP 连接访问数据库。
build-type: Simple
library
hs-source-dirs: src
exposed-modules: ChuSQL.Server.Accounts
ChuSQL.Server.Backend
ChuSQL.Server.Policy
ChuSQL.Server.Privileges
ChuSQL.Server.Session
ChuSQL.Server.TCP
build-depends: base >= 4.14 && < 5
, aeson
, bytestring
, chusql-core-engine
, chusql-core-model
, chusql-interface
, containers
, crypton
, directory
, filepath
, memory
, network
, scientific
, text
, time
, vector
default-language: Haskell2010
ghc-options: -Wall
executable chusql-server
main-is: Main.hs
hs-source-dirs: app
build-depends: base
, chusql-core-engine
, chusql-core-model
, chusql-interface
, chusql-server
, containers
, filepath
, text
, time
default-language: Haskell2010
ghc-options: -Wall -threaded
-- 运行期找 libchusql_core_storage.so：$ORIGIN 让二进制与动态库同目录即可
if os(linux)
ld-options: -Wl,-rpath,$ORIGIN
if os(osx)
ld-options: -Wl,-rpath,@loader_path
test-suite chusql-server-test
type: exitcode-stdio-1.0
main-is: Spec.hs
hs-source-dirs: test
build-depends: base
, aeson
, bytestring
, chusql-core-engine
, chusql-core-model
, chusql-interface
, chusql-server
, containers
, directory
, filepath
, hspec
, network
, text
, time
, vector
default-language: Haskell2010
ghc-options: -Wall -threaded
chusql-web/src/ChuSQL/Web/Accounts.hs → chusql-server/src/ChuSQL/Server/Accounts.hs
+23 -23
View File
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Web.Accounts (
module ChuSQL.Server.Accounts (
Accounts, AccountError (..), Principal (..), PasswordPolicy (..), defaultPasswordPolicy,
newAccounts, accountsPolicy, setAccountsPolicy, passwordAllowed,
rootUserName, principalName, principalIsRoot,
@@ -8,27 +8,18 @@ module ChuSQL.Web.Accounts (
listAccounts, findAccount, AccountCommand (..), accountCommand, runAccountCommand,
) where
import ChuSQL.Storage.IPC (Account (..), Request (..))
import ChuSQL.Syntax.AST (Statement (..))
import ChuSQL.Web.Auth
import ChuSQL.Web.Backend (Backend (..), currentStamp)
import ChuSQL.Core.Engine.Storage.IPC (Account (..), Request (..))
import ChuSQL.Core.Engine.Syntax.AST (Statement (..))
import ChuSQL.Interface.Auth
import ChuSQL.Interface.Policy (PasswordPolicy (..), defaultPasswordPolicy)
import ChuSQL.Server.Backend (Backend (..), currentStamp)
import Control.Concurrent.MVar (MVar, newMVar, withMVar)
import Data.Char (isAlphaNum, isAscii, isAsciiLower, isAsciiUpper, isDigit)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Text (Text)
import qualified Data.Text as T
-- 账号服务：root 来自配置，普通账号由 root 用 CREATE/ALTER/DROP USER 管，口令在这里做策略检查与 PBKDF2 派生。
data PasswordPolicy = PasswordPolicy
{ ppMinLength :: Int
, ppClasses :: Int
}
deriving (Show, Eq)
-- | 默认：至少 12 个字符、至少两类字符
defaultPasswordPolicy :: PasswordPolicy
defaultPasswordPolicy = PasswordPolicy 12 2
-- 账号服务：root 来自配置，普通账号由 root 用 CREATE/ALTER/DROP USER 管理，口令在此校验并派生哈希。
data AccountError = AccountError Text Text deriving (Show, Eq)
@@ -39,6 +30,7 @@ data Principal
deriving (Eq)
instance Show Principal where
-- | 身份的可读形式
show (Root name) = "root " ++ show name
show (Ordinary a) = "account " ++ show (accountUser a)
@@ -60,7 +52,7 @@ data Accounts = Accounts
, acRoot :: Credential
}
-- | 只记下配置根账号；root 不写系统表，所以启动时不需要任何持久化动作
-- | 建账号服务，记录配置根账号
newAccounts :: Backend -> SessionStore -> Credential -> IO Accounts
newAccounts backend sessions credential = do
lock <- newMVar ()
@@ -79,20 +71,24 @@ rootName = normalize . credUser . acRoot
rootUserName :: Accounts -> Text
rootUserName = rootName
-- | 读当前生效的口令策略
accountsPolicy :: Accounts -> IO PasswordPolicy
accountsPolicy = readIORef . acPolicy
-- | 换上一份新口令策略
setAccountsPolicy :: Accounts -> PasswordPolicy -> IO ()
setAccountsPolicy service = writeIORef (acPolicy service)
-- | 口令策略：长度 + 字符类别（历史与有效期随自助改密一起取消）
-- | 按策略检查口令长度与字符类别
passwordAllowed :: PasswordPolicy -> Text -> Either AccountError ()
passwordAllowed policy password
| T.length password < ppMinLength policy || T.length password > 256 = bad "password length does not meet policy"
| classes < ppClasses policy = bad "password needs more character classes"
| otherwise = Right ()
where
-- | 构造一条请求错误
bad = Left . AccountError "bad_request"
-- | 命中的字符类别数
classes =
length
( filter id
@@ -110,9 +106,10 @@ validateUserName name
Left (AccountError "bad_request" "invalid account name")
| otherwise = Right ()
where
-- | 该字符是否允许使用
allowed c = isAscii c && (isAlphaNum c || c `elem` ("_.-" :: String))
-- | 新建/改口令时的额外限制：管理员的名字保留给配置里的 root
-- | 校验新账号名，并挡掉管理员保留名
validateNewName :: Accounts -> Text -> Either AccountError ()
validateNewName service name = do
validateUserName name
@@ -137,7 +134,7 @@ storageResult (Left _) = Left storageFailure
readAccounts :: Accounts -> IO (Either AccountError [Account])
readAccounts service = fmap (either (const (Left storageFailure)) Right) (beAccounts (acBackend service) ReqAccountsList)
-- | 当前令牌对应的身份；会话版本与账号 revision 对不上就失效
-- | 按令牌解析当前身份，版本对不上即失效
currentUnlocked :: Accounts -> Text -> IO (Either AccountError Principal)
currentUnlocked service token = do
session <- lookupVersionedSession (acSessions service) token
@@ -156,11 +153,11 @@ currentUnlocked service token = do
then Right (Ordinary account)
else Left unauthorized
-- | 加锁解析当前身份
currentPrincipal :: Accounts -> Text -> IO (Either AccountError Principal)
currentPrincipal service token = withMVar (acLock service) $ \_ -> currentUnlocked service token
-- | 登录：先比配置里的 root，再查系统表里的普通账号（没有切换身份的入口）。
-- 配置里的口令留空即"免密"：只有管理员能用空口令进来，普通账号一律拒绝。
-- | 登录：先比 root，再查普通账号；空口令即免密
authenticate :: Accounts -> Text -> Text -> IO (Either AccountError Text)
authenticate service user password = withMVar (acLock service) $ \_ ->
if normalize user == rootName service
@@ -170,7 +167,9 @@ authenticate service user password = withMVar (acLock service) $ \_ ->
then pure (Left (AccountError "forbidden" "this server only accepts the administrator"))
else signInOrdinary
where
-- | 配置里没有口令
passwordless = T.null (credEncoded (acRoot service))
-- | 管理员登录
signInRoot
| passwordless =
if T.null password
@@ -179,6 +178,7 @@ authenticate service user password = withMVar (acLock service) $ \_ ->
| verifyPassword (credEncoded (acRoot service)) password =
Right <$> createVersionedSession (acSessions service) (rootName service) Nothing
| otherwise = pure (Left unauthorized)
-- | 普通账号登录
signInOrdinary = do
stored <- readAccounts service
case stored of
@@ -217,7 +217,7 @@ createUser service name password = withMVar (acLock service) $ \_ -> do
encoded <- hashPassword password
storageResult <$> beAccounts (acBackend service) (ReqAccountCreate (normalize name) encoded)
-- | 改一个普通账号的口令（管理员重置，不受历史/有效期限制）
-- | 管理员重置普通账号口令
resetPassword :: Accounts -> Text -> Text -> IO (Either AccountError ())
resetPassword service name password = withMVar (acLock service) $ \_ -> do
policy <- accountsPolicy service
chusql-web/src/ChuSQL/Web/Backend.hs → chusql-server/src/ChuSQL/Server/Backend.hs
+50 -24
View File
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Web.Backend (
module ChuSQL.Server.Backend (
StatementResult (..),
Backend (..),
columnsFromStatement,
@@ -20,21 +20,22 @@ module ChuSQL.Web.Backend (
tableRefsOf,
) where
import ChuSQL.Engine (runStatement, runStatementM)
import ChuSQL.Model
import ChuSQL.Semantic (prepare)
import ChuSQL.Storage (MonadStorage (schema))
import ChuSQL.Storage.IPC (
import ChuSQL.Core.Engine (runStatement, runStatementM)
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Semantic (prepare)
import ChuSQL.Core.Engine.Storage (MonadStorage (schema))
import ChuSQL.Core.Engine.Storage.IPC (
Account (..),
IPCStorage (..),
Request (..),
Response (..),
SchemaColumn (..),
TableInfo (..),
sendRawRequest,
sendRequest,
)
import ChuSQL.Syntax.AST
import ChuSQL.Syntax.Parser (parseStatement)
import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, readMVar, withMVar)
import Data.List (nub)
import Data.Text (Text)
@@ -44,7 +45,7 @@ import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.Text as T
-- 后端：跑一条语句与取数据字典，分 IPC（真存储）和内存（测试）两套。
-- 后端抽象：跑语句、取数据字典与账号，分 IPC（真存储）和内存（测试）两套实现。
data StatementResult = StatementResult
{ srColumns :: [String]
@@ -58,6 +59,8 @@ data Backend = Backend
, beAccounts :: Request -> IO (Either String [Account])
, beWithDatabase :: String -> Backend
, beDatabases :: IO (Either String [String])
-- | 原样转发一条存储请求
, beStorage :: A.Value -> IO (Either String A.Value)
}
-- | 按给定列名取列，固定列顺序
@@ -67,7 +70,7 @@ columnsFromStatement db stmt = case prepare db stmt of
Right (SelectExpr items _ _ _ _ _) -> map fst items
_ -> []
-- | 走本地端点的后端（真存储：Windows 具名管道 / Unix 套接字）
-- | 走本地存储链路的后端
ipcBackend :: IO Backend
ipcBackend = do
lock <- newMVar ()
@@ -95,10 +98,22 @@ ipcBackend = do
RespTables names -> Right names
RespError err -> Left err
_ -> Left "unexpected database response"
, beStorage = \payload -> withMVar lock $ \_ -> runRaw payload
}
-- 没有默认库：没选库时 current 是空串，任何请求都得先选库
pure (backend "")
where
-- | 转发一条存储请求并解析响应
runRaw :: A.Value -> IO (Either String A.Value)
runRaw payload = do
response <- sendRawRequest (BL.toStrict (A.encode payload))
pure $ case response of
Left err -> Left err
Right raw -> case A.eitherDecodeStrict raw of
Left err -> Left ("storage response is not valid JSON: " ++ err)
Right value -> Right value
-- | 走存储链路跑一条语句
runIpc :: String -> String -> IO (Either String StatementResult)
runIpc current sql = case fmap (inDatabase current) (parseStatement sql) of
Left e -> pure (Left e)
@@ -114,12 +129,11 @@ ipcBackend = do
(r : _) -> pure (map fst r)
pure (Right (StatementResult cols rows))
-- | 内存后端（测试）：状态就是一个 `Database`，名字是它代表的库
-- | 测试用内存后端，状态是一个 Database
memoryBackend :: String -> MVar Database -> Backend
memoryBackend = memoryBackendWith False
-- | 同一份内存状态可以按普通库（trusted=False）或系统库（trusted=True）视角跑：
-- 系统库要能读写角色/授权表，普通库连看都不许看。
-- | 构造内存后端，Bool 决定普通库还是系统库视角
memoryBackendWith :: Bool -> String -> MVar Database -> Backend
memoryBackendWith trusted name ref =
Backend
@@ -147,30 +161,33 @@ memoryBackendWith trusted name ref =
[[("account", VStr (BL.unpack (A.encode a))) ] | a <- accounts]) : filter ((/= usersTable) . fst) db, Right accounts)
, beWithDatabase = withDatabase
, beDatabases = pure (Right (nub [name, systemDatabaseName]))
, beStorage = \_ -> pure (Left "storage is not available in this backend")
}
where
-- | 按视角过滤库里的表
scoped = if trusted then filter (not . reserved . fst) else visible
-- | 该视角下要隐藏的表
hidden = if trusted then reserved else internalTable
-- | 取结果列名，空结果回落到解析
colsOf db stmt rows = case rows of
[] -> columnsFromStatement db stmt
(r : _) -> map fst r
-- 系统库视角给权限服务用；夹具自己的库走普通视角；没选库时只放行不碰表的语句
-- | 按目标库名挑视角
withDatabase target
| target == systemDatabaseName = memoryBackendWith True name ref
| target == name = memoryBackendWith False name ref
| null target = noDatabaseBackend (memoryBackendWith False name ref)
| otherwise = unavailableDatabase ("unknown database: " ++ target) (memoryBackendWith False name ref)
-- | 把后端的语句与字典都改成同一条错误
unavailableDatabase :: String -> Backend -> Backend
unavailableDatabase message backend = backend
{ beStatement = \_ -> pure (Left message)
, beCatalog = pure (Left message)
}
-- | 没选库时的视角：不碰表的语句（USE、建库、账号与角色）照跑，
-- 一旦语句里出现裸表名就报 no database selected。
-- 与存储层口径一致：`db.table` 这种限定名不需要先选库。
-- | 未选库时的视角：只放行不碰表的语句
noDatabaseBackend :: Backend -> Backend
noDatabaseBackend backend = backend
{ beStatement = \sql -> case parseStatement sql of
@@ -181,11 +198,11 @@ noDatabaseBackend backend = backend
, beCatalog = pure (Left "no database selected")
}
-- | Database context is an immutable request value, never shared connection state.
-- 子查询里出现的表名同样要带上数据库前缀，否则会落到错误的库里。
-- | 给语句里的裸表名补上当前库前缀，子查询里的表名也一起改
inDatabase :: String -> Statement -> Statement
inDatabase current = walk
where
-- | 递归改写语句里的表名
walk :: Statement -> Statement
walk stmt = case stmt of
q@Select{} ->
@@ -214,14 +231,16 @@ inDatabase current = walk
AlterColumnNull t c b -> AlterColumnNull (table t) c b
other -> other
-- | 给单个表名补库前缀，已限定或没选库就原样
table t | '.' `elem` t || null current = t
| otherwise = current ++ "." ++ t
-- | 改写 FROM 子句
source FromUnit = FromUnit
source (FromTable a t) = FromTable a (table t)
source (FromJoin k l a t e) = FromJoin k (source l) a (table t) (expr e)
-- 表达式里的子查询也要一起改写
-- | 改写表达式里的子查询
expr (ScalarSub sq) = ScalarSub (sub sq)
expr (ExistsSub sq neg) = ExistsSub (sub sq) neg
expr (InSub a sq neg) = InSub (expr a) (sub sq) neg
@@ -245,9 +264,10 @@ inDatabase current = walk
expr (MaxOf a) = MaxOf (expr a)
expr other = other
-- | 改写一个子查询
sub sq = sq {subqueryStatement = walk (subqueryStatement sq)}
-- | 语句里出现的表（含 JOIN、子查询、INSERT/UPDATE/DELETE 的目标）
-- | 语句里出现的表
statementTables :: Statement -> [Text]
statementTables stmt = nub (case stmt of
Select{} ->
@@ -307,6 +327,7 @@ exprTables expr = case expr of
MaxOf a -> exprTables a
_ -> []
where
-- | 两侧都取表名
both a b = exprTables a ++ exprTables b
-- | 一张表的线上信息（内存实现：没有索引，统计现算）
@@ -320,6 +341,7 @@ tableInfoOf (name, tbl) =
, tiStats = [(c, distinctOf c, False) | (c, _) <- tableCols tbl]
}
where
-- | 一列的不同值个数
distinctOf c = length (nub [v | r <- tableRows tbl, Just v <- [lookup c r]])
-- | 本地列类型转线上字符串（和 IPC 那边同一套写法）
@@ -340,14 +362,14 @@ wireColumn name col =
, scCheck = columnCheck col
}
-- | 系统库：账号、角色与授权表住在这里，其中的表都是系统表，只给管理员
-- | 系统库名，账号、角色与授权表住在这里
systemDatabaseName :: String
systemDatabaseName = "system"
usersTable :: String
usersTable = "__chusql_users"
-- | 角色与授权表：住在 system 库，名字不带 `__chusql_` 前缀（Rust 存储层拒收那个前缀）
-- | 角色与授权表的名字，不带内部前缀
rolesTable :: String
rolesTable = "sys_roles"
@@ -360,13 +382,15 @@ membersTable = "sys_members"
internalNames :: [String]
internalNames = [rolesTable, grantsTable, membersTable]
-- | 名字是否带内部表前缀
reserved :: String -> Bool
reserved = T.isPrefixOf "__chusql_" . T.toLower . T.pack
-- | 服务自己的内部表：目录里不出现，普通作用域读写都拒（系统作用域才放行角色/授权表）
-- | 是不是服务自己的内部表
internalTable :: String -> Bool
internalTable name = reserved name || T.unpack (T.toLower (T.pack name)) `elem` internalNames
-- | 去掉内部表
visible :: Database -> Database
visible = filter (not . internalTable . fst)
@@ -374,6 +398,7 @@ visible = filter (not . internalTable . fst)
currentStamp :: IO T.Text
currentStamp = T.pack . formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" <$> getCurrentTime
-- | 在内存账号表上执行一条账号请求
memoryAccounts :: Database -> T.Text -> Request -> Either String [Account]
memoryAccounts db stamp req = do
accounts <- case lookup usersTable db of
@@ -395,6 +420,7 @@ memoryAccounts db stamp req = do
_ -> Right [x | x <- accounts, accountUser x /= T.toLower u]
_ -> Left "invalid account request"
where
-- | 把一行解回账号
decodeAccount row = case lookup "account" row of
Just (VStr encoded) -> A.eitherDecode (BL.pack encoded)
_ -> Left "invalid account record"
chusql-server/src/ChuSQL/Server/Policy.hs
+23
View File
@@ -0,0 +1,23 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Server.Policy (
configurePasswordPolicy,
policyFromValues,
passwordKeys,
) where
import ChuSQL.Interface.Policy (defaultPasswordPolicy, passwordKeys, policyFromValues)
import ChuSQL.Interface.Settings (applySettings, defaultOf, readSettingsFile)
import ChuSQL.Server.Accounts (Accounts, setAccountsPolicy)
import qualified Data.Map.Strict as Map
-- 口令策略装配：从设置文件读 password-* 键算出生效策略，并装到账号服务上。
-- | 从设置文件装口令策略，坏值报错
configurePasswordPolicy :: Accounts -> FilePath -> IO ()
configurePasswordPolicy accounts path = do
saved <- readSettingsFile path
let values = Map.fromList [(key, Map.findWithDefault (defaultOf key) key saved) | key <- passwordKeys]
case applySettings Map.empty values of
Left err -> ioError (userError err)
Right valid -> setAccountsPolicy accounts (policyFromValues defaultPasswordPolicy valid)
chusql-web/src/ChuSQL/Web/Privileges.hs → chusql-server/src/ChuSQL/Server/Privileges.hs
+36 -38
View File
@@ -1,15 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
-- | 角色与权限服务。
--
-- 模型：权限挂在角色上，用户通过角色成员资格继承角色权限；管理员（root）隐式全权，
-- 新账号默认零权限。语句（CREATE ROLE / DROP ROLE / GRANT / REVOKE）由引擎解析并做
-- 基本校验，真正落库在这里。
--
-- 存储：system 库里的三张普通表（`sys_roles` / `sys_grants` / `sys_members`）。
-- 起普通名字是因为 Rust 存储层拒收 `__chusql_` 前缀的表名，那条路走不通；
-- 读写都借 system 作用域后端的普通 SQL，内存后端与 IPC 后端共用一套逻辑。
module ChuSQL.Web.Privileges (
module ChuSQL.Server.Privileges (
Grant (..),
Membership (..),
PrivilegeCommand (..),
@@ -26,11 +17,12 @@ module ChuSQL.Web.Privileges (
runPrivilegeCommand,
) where
import ChuSQL.Model (Row, Value (..))
import ChuSQL.Syntax.AST
import ChuSQL.Web.Accounts (Principal, principalIsRoot, principalName)
import ChuSQL.Web.Actions (sqlLiteral)
import ChuSQL.Web.Backend (
import ChuSQL.Core.Model (Row, Value (..))
import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Server.Accounts (Principal, principalIsRoot, principalName)
import ChuSQL.Interface.Actions (sqlLiteral)
import ChuSQL.Interface.Protocol (Grant (..), RoleView (..))
import ChuSQL.Server.Backend (
Backend (..),
StatementResult (..),
exprTables,
@@ -45,18 +37,13 @@ import Data.List (intercalate, isInfixOf, nub, sort)
import Data.Text (Text)
import qualified Data.Text as T
-- | 出错口径与账号服务一致，映射由 API 层统一做
-- 角色与权限服务：角色、授权与成员关系落在 system 库的表里，并据此判权限。
-- | 出错口径与账号服务一致
data PrivilegeError = PrivilegeError Text Text
deriving (Show, Eq)
-- | 一条角色授权：角色 + 具体权限 + 对象（`*` 或 `库.表`）
data Grant = Grant
{ grantRole :: Text
, grantPrivilege :: Text
, grantObject :: Text
}
deriving (Show, Eq, Ord)
-- 一条角色授权（定义在共享协议层）
-- | 角色成员资格
data Membership = Membership
{ memberRole :: Text
@@ -64,13 +51,7 @@ data Membership = Membership
}
deriving (Show, Eq, Ord)
-- | 一个角色的全貌
data RoleView = RoleView
{ roleName :: Text
, roleGrants :: [Grant]
, roleMembers :: [Text]
}
deriving (Show, Eq)
-- | 一个角色的全貌：授权与成员
data PrivilegeCommand
= CreateRoleCommand Text
@@ -86,13 +67,13 @@ data Privileges = Privileges
, pvLock :: MVar ()
}
-- | 服务固定看 system 库；构造时不碰存储，第一次用才建表
-- | 建权限服务，固定在 system 库上
newPrivileges :: Backend -> IO Privileges
newPrivileges base = do
lock <- newMVar ()
pure (Privileges (beWithDatabase base systemDatabaseName) lock)
-- | 语句 → 管理命令（引擎只解析与基本校验，不认的语句给 Nothing）
-- | 语句转管理命令，不认的给 Nothing
privilegeCommand :: Statement -> Maybe PrivilegeCommand
privilegeCommand stmt = case stmt of
CreateRole name -> Just (CreateRoleCommand (T.pack name))
@@ -112,13 +93,13 @@ runPrivilegeCommand service principal database command
| needsDatabase = pure (Left (PrivilegeError "no_database" "no database selected"))
| otherwise = withTables service (applyCommand service database command)
where
-- 授权到具体对象（不是 `*`）时要把裸表名补成 `库.表`，没选库就无从补全
-- | 授权到具体对象时需要先选库
needsDatabase = T.null database && case command of
GrantPrivilegesCommand _ object _ -> T.strip object /= "*"
RevokePrivilegesCommand _ object _ -> T.strip object /= "*"
_ -> False
-- | 语句鉴权：管理员全通；普通身份按语句需要的每一项 (表, 权限) 查
-- | 语句鉴权：管理员全通，普通身份按需查
authorize :: Privileges -> Principal -> Text -> Statement -> IO (Either PrivilegeError ())
authorize service principal database stmt
| principalIsRoot principal = pure (Right ())
@@ -134,7 +115,7 @@ authorizeTables service principal database needed
grants <- grantsOfUser service (principalName principal)
pure (grants >>= \found -> checkAll database found needed)
-- | 只留下用户有 SELECT 权限的表（管理员看全部）；表清单接口用
-- | 只留下用户有 SELECT 权的表
filterTables :: Privileges -> Principal -> Text -> [Text] -> IO (Either PrivilegeError [Text])
filterTables service principal database tables
| principalIsRoot principal = pure (Right tables)
@@ -150,6 +131,7 @@ listRoleViews service = withTables service $ do
Left err -> pure (Left err)
Right known -> sequence <$> mapM view (sort known)
where
-- | 组装一个角色的总览
view role = do
grants <- roleGrantsOf service role
members <- membersOfRole service role
@@ -162,7 +144,7 @@ normalizeObject database object
| T.any (== '.') object = T.toLower (T.strip object)
| otherwise = normalizeUser database <> "." <> normalizeUser object
-- | 一条语句需要哪些 (表, 权限)；Nothing 表示管理员专属
-- | 一条语句需要哪些 (表, 权限)
requiredActions :: Statement -> Maybe [(Text, Text)]
requiredActions stmt = case stmt of
Select{} -> Just (selectNeeds (selectFrom stmt) (maybe [] (: []) (selectWhere stmt)))
@@ -173,7 +155,9 @@ requiredActions stmt = case stmt of
Delete table cond -> Just ((T.pack table, "delete") : selectsOf (maybe [] (: []) cond))
_ -> Nothing
where
-- | FROM 子句要的 SELECT 权限
selectNeeds source exprs = [(ref, "select") | ref <- nub (tableRefsOf source)] ++ selectsOf exprs
-- | 表达式里子查询要的 SELECT 权限
selectsOf exprs = [(ref, "select") | ref <- nub (concatMap exprTables exprs)]
-- | 每项 (表, 权限) 都要被某条授权覆盖
@@ -183,6 +167,7 @@ checkAll database grants needed = case [pair | pair@(table, privilege) <- needed
((table, privilege) : _) ->
Left (PrivilegeError "forbidden" ("permission denied: " <> T.toUpper privilege <> " ON " <> table))
where
-- | 某一项是否被授权覆盖
covered table privilege =
let target = normalizeObject database table
in any
@@ -301,15 +286,18 @@ withTables service action = withMVar (pvLock service) $ \_ -> do
Left err -> pure (Left err)
Right () -> action
-- | 确保三张内部表存在
ensureTables :: Privileges -> IO (Either PrivilegeError ())
ensureTables service = each tableDefs (createTable service)
where
-- | 三张内部表的定义
tableDefs =
[ (rolesTable, "(name VARCHAR(64))")
, (grantsTable, "(role VARCHAR(64), privilege VARCHAR(16), object VARCHAR(128))")
, (membersTable, "(role VARCHAR(64), member VARCHAR(64))")
]
-- | 建一张内部表，已存在算成功
createTable :: Privileges -> (String, String) -> IO (Either PrivilegeError ())
createTable service (table, columns) = do
result <- beStatement (pvBackend service) ("CREATE TABLE " ++ table ++ " " ++ columns)
@@ -341,6 +329,7 @@ cell column row = case lookup column row of
Just (VStr value) -> T.pack value
_ -> ""
-- | 一行记录转成授权
grantOf :: Row -> Grant
grantOf row =
Grant
@@ -349,19 +338,22 @@ grantOf row =
, grantObject = T.toLower (T.strip (cell "object" row))
}
-- | 拼一条删授权的 SQL
deleteGrantSql :: Text -> Text -> Text -> String
deleteGrantSql role privilege object =
"DELETE FROM " ++ grantsTable ++ " WHERE role = " ++ roleLiteral role
++ " AND privilege = " ++ literal privilege ++ " AND object = " ++ literal object
-- | 拼一条插入的 SQL
insertSql :: String -> [String] -> [Text] -> String
insertSql table columns values =
"INSERT INTO " ++ table ++ " (" ++ intercalate ", " columns ++ ") VALUES (" ++ intercalate ", " (map literal values) ++ ")"
-- | 授权里的 ALL 展开成四种具体权限（存具体权限，鉴权不做兜底）
-- | 把 ALL 展开成四种具体权限
expandPrivileges :: [Text] -> [Text]
expandPrivileges privileges = nub (concatMap expand (map (T.toLower . T.strip) privileges))
where
-- | 展开一条权限名
expand "all" = ["select", "insert", "update", "delete"]
expand other = [other]
@@ -374,23 +366,29 @@ each (item : rest) action = do
Left err -> pure (Left err)
Right () -> each rest action
-- | 角色名的 SQL 字面量
roleLiteral :: Text -> String
roleLiteral = literal . normalizeRole
-- | 文本值的 SQL 字面量
literal :: Text -> String
literal = sqlLiteral . VStr . T.unpack
-- | 角色名统一小写去空白
normalizeRole :: Text -> Text
normalizeRole = T.toLower . T.strip
-- | 用户名统一小写去空白
normalizeUser :: Text -> Text
normalizeUser = T.toLower . T.strip
forbidden :: PrivilegeError
forbidden = PrivilegeError "forbidden" "administrator required"
-- | 未知角色的错误
unknownRole :: Text -> PrivilegeError
unknownRole role = PrivilegeError "not_found" ("unknown role: " <> role)
-- | 存储错误转成权限错误
storageError :: String -> PrivilegeError
storageError message = PrivilegeError "storage_error" ("privilege storage: " <> T.pack message)
chusql-server/src/ChuSQL/Server/Session.hs
+327
View File
@@ -0,0 +1,327 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Server.Session
( QueryResult (..)
, Session
, SessionError (..)
, engineErrorCode
, newSession
, sessionUser
, sessionIsAdmin
, sessionDatabase
, isPlainIdentifier
, authenticateSession
, authenticateSessionCoded
, switchDatabase
, runStatement
, runStatementCoded
, catalog
, accounts
, roleViews
, databases
, policyOf
, reloadPolicy
, queryResultJson
) where
import ChuSQL.Core.Model (Value (..))
import ChuSQL.Core.Protocol (Account, QueryResult (..), queryResultJson)
import ChuSQL.Core.Engine.Storage.IPC (TableInfo (..))
import ChuSQL.Core.Engine.Syntax.AST (Statement (..))
import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
import ChuSQL.Interface.AccountTable (systemTableInfo)
import ChuSQL.Interface.Auth (Credential, defaultSessionPolicy, newSessionStore)
import ChuSQL.Server.Accounts
import ChuSQL.Server.Backend (Backend (..), StatementResult (..))
import ChuSQL.Server.Policy (configurePasswordPolicy)
import ChuSQL.Server.Privileges (PrivilegeCommand, PrivilegeError (..), Privileges, RoleView, authorize, filterTables, listRoleViews, newPrivileges, privilegeCommand, runPrivilegeCommand)
import Control.Exception (IOException, try)
import Data.Bifunctor (first)
import Data.Char (isAlpha, isAlphaNum)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (getCurrentTime)
-- SQL 会话：Web、命令行与 TCP 服务器共用的账号、权限与语句执行入口。
-- | 带错误码的失败：码与 Web REST 的错误码同一个词汇表
data SessionError = SessionError
{ sessCode :: Text
, sessMessage :: Text
}
deriving (Eq, Show)
-- | 引擎报错翻成错误码
engineErrorCode :: String -> SessionError
engineErrorCode err
| "no database selected" `T.isInfixOf` message = SessionError "no_database" message
| "unknown table" `T.isInfixOf` message = SessionError "not_found" message
| otherwise = SessionError "query_error" message
where
message = T.pack err
data Session = Session
{ ssBackend :: Backend
, ssAccounts :: Accounts
, ssPrivileges :: Privileges
, ssCurrent :: IORef Text
, ssPrincipal :: IORef (Maybe Principal)
, ssSettingsFile :: FilePath
}
-- | 开一个会话：账号与角色服务、配置策略都和 Web 端一致
newSession :: Backend -> Credential -> FilePath -> IO Session
newSession backend credential settingsFile = do
sessions <- newSessionStore getCurrentTime defaultSessionPolicy
accountsService <- newAccounts backend sessions credential
privileges <- newPrivileges backend
configurePasswordPolicy accountsService settingsFile
-- 服务启动后只有系统库：没 USE 之前不预设任何工作库
current <- newIORef ""
principal <- newIORef Nothing
pure (Session backend accountsService privileges current principal settingsFile)
-- | 当前生效的口令策略（只有管理员能看）
policyOf :: Session -> IO (Either Text PasswordPolicy)
policyOf session = do
admin <- sessionIsAdmin session
if not admin
then pure (Left "administrator required")
else Right <$> accountsPolicy (ssAccounts session)
-- | 重读设置文件里的口令策略
reloadPolicy :: Session -> IO (Either Text PasswordPolicy)
reloadPolicy session = do
admin <- sessionIsAdmin session
if not admin
then pure (Left "administrator required")
else do
outcome <- try (configurePasswordPolicy (ssAccounts session) (ssSettingsFile session)) :: IO (Either IOException ())
case outcome of
Left err -> pure (Left (T.pack (show err)))
Right () -> policyOf session
-- | 当前登录的账号名
sessionUser :: Session -> IO (Maybe Text)
sessionUser session = fmap principalName <$> readIORef (ssPrincipal session)
-- | 是不是配置里的 root
sessionIsAdmin :: Session -> IO Bool
sessionIsAdmin session = maybe False principalIsRoot <$> readIORef (ssPrincipal session)
-- | 当前库
sessionDatabase :: Session -> IO Text
sessionDatabase = readIORef . ssCurrent
-- | 与解析器一致的裸标识符判断
isPlainIdentifier :: Text -> Bool
isPlainIdentifier name =
not (T.null name)
&& T.length name <= 64
&& (isAlpha (T.head name) || T.head name == '_')
&& T.all (\ch -> isAlphaNum ch || ch == '_') name
-- | 登录：root 比配置凭据，普通账号查系统表
authenticateSession :: Session -> Text -> Text -> IO (Either Text ())
authenticateSession session user password =
fmap (first sessMessage) (authenticateSessionCoded session user password)
-- | 登录（带错误码）
authenticateSessionCoded :: Session -> Text -> Text -> IO (Either SessionError ())
authenticateSessionCoded session user password = do
result <- authenticate (ssAccounts session) user password
case result of
Left err -> pure (Left (accountErrorOf err))
Right token -> do
who <- currentPrincipal (ssAccounts session) token
case who of
Left err -> pure (Left (accountErrorOf err))
Right principal -> do
writeIORef (ssPrincipal session) (Just principal)
pure (Right ())
-- | 换库；系统库只有 root 能进
switchDatabase :: Session -> Text -> IO (Either Text ())
switchDatabase session name =
fmap (first sessMessage) (switchDatabaseCoded session name)
-- | 换库（带错误码）
switchDatabaseCoded :: Session -> Text -> IO (Either SessionError ())
switchDatabaseCoded session rawName
| not (isPlainIdentifier name) = pure (Left (SessionError "bad_request" ("not a plain database name: " <> name)))
| name == "system" = do
admin <- sessionIsAdmin session
if admin then go else pure (Left (SessionError "forbidden" "the system database is only available to the administrator"))
| otherwise = go
where
name = T.toLower (T.strip rawName)
-- | 真的切库并记下当前库
go = do
backend <- currentBackend session
result <- beStatement backend ("USE " ++ T.unpack name)
case result of
Left err -> pure (Left (engineErrorCode err))
Right _ -> writeIORef (ssCurrent session) name >> pure (Right ())
-- | 跑一条语句：USE、账号与角色语句分流，其余交引擎
runStatement :: Session -> Text -> IO (Either Text QueryResult)
runStatement session sql = fmap (first sessMessage) (runStatementCoded session sql)
-- | 跑一条语句（带错误码）
runStatementCoded :: Session -> Text -> IO (Either SessionError QueryResult)
runStatementCoded session sql = case parseStatement (T.unpack sql) of
Right (UseDatabase name) -> do
switched <- switchDatabaseCoded session (T.pack name)
case switched of
Left err -> pure (Left err)
Right () -> do
current <- readIORef (ssCurrent session)
pure (Right (emptyResult (Just current)))
Right statement
| Just command <- accountCommand statement -> runAccount session command
| Just command <- privilegeCommand statement -> runPrivilege session command
| otherwise -> do
allowed <- authorized session statement
case allowed of
Left err -> pure (Left err)
Right () -> runPlain session sql
Left _ -> runPlain session sql
-- | 普通身份跑语句前的权限判定；管理员与未登录放行
authorized :: Session -> Statement -> IO (Either SessionError ())
authorized session statement = do
who <- readIORef (ssPrincipal session)
case who of
Just principal | not (principalIsRoot principal) -> do
database <- readIORef (ssCurrent session)
result <- authorize (ssPrivileges session) principal database statement
pure (either (Left . privilegeErrorOf) (const (Right ())) result)
_ -> pure (Right ())
-- | 落到引擎/存储层的一条语句
runPlain :: Session -> Text -> IO (Either SessionError QueryResult)
runPlain session sql = do
backend <- currentBackend session
result <- beStatement backend (T.unpack sql)
pure (either (Left . engineErrorCode) (Right . resultOf) result)
-- | 数据字典；普通身份只看到有 SELECT 权的表
catalog :: Session -> IO (Either Text [TableInfo])
catalog session = do
current <- readIORef (ssCurrent session)
if T.null current
then pure (Left "no database selected")
else do
backend <- currentBackend session
result <- beCatalog backend
case result of
Left e -> pure (Left (T.pack e))
Right infos -> do
who <- readIORef (ssPrincipal session)
visible <- case who of
Just principal | not (principalIsRoot principal) -> do
allowed <- filterTables (ssPrivileges session) principal current (map (T.pack . tiTable) infos)
pure (either (Left . privilegeMessage) (\names -> Right (filter (\info -> T.pack (tiTable info) `elem` names) infos)) allowed)
_ -> pure (Right infos)
case visible of
Left message -> pure (Left message)
Right tables
| current == "system" -> Right <$> withAccountInfo session tables
| otherwise -> pure (Right tables)
-- | 系统库里补上账号表
withAccountInfo :: Session -> [TableInfo] -> IO [TableInfo]
withAccountInfo session tables = do
admin <- sessionIsAdmin session
if not admin
then pure tables
else do
result <- listAccounts (ssAccounts session)
pure $ case result of
Left _ -> tables
Right rows -> systemTableInfo{tiRows = length rows} : tables
-- | 库清单（\l 用）
databases :: Session -> IO (Either Text [Text])
databases session = do
result <- beDatabases (ssBackend session)
pure (either (Left . T.pack) (Right . map T.pack) result)
-- | 角色总览，只给管理员
roleViews :: Session -> IO (Either Text [RoleView])
roleViews session = do
admin <- sessionIsAdmin session
if not admin
then pure (Left "administrator required")
else do
result <- listRoleViews (ssPrivileges session)
pure (either (Left . privilegeMessage) Right result)
-- | 账号清单（\du 与账号管理页用）；只给管理员
accounts :: Session -> IO (Either Text [Account])
accounts session = do
admin <- sessionIsAdmin session
if not admin
then pure (Left "administrator required")
else do
result <- listAccounts (ssAccounts session)
pure (either (Left . T.pack . show) Right result)
-- | 当前库对应的后端
currentBackend :: Session -> IO Backend
currentBackend session = do
name <- readIORef (ssCurrent session)
pure (beWithDatabase (ssBackend session) (T.unpack name))
-- | 账号语句走账号服务，普通账号一律拒绝
runAccount :: Session -> AccountCommand -> IO (Either SessionError QueryResult)
runAccount session command = do
who <- readIORef (ssPrincipal session)
case who of
Nothing -> pure (Left (SessionError "unauthorized" "sign in first"))
Just principal -> do
result <- runAccountCommand (ssAccounts session) principal command
pure (either (Left . accountErrorOf) (const (Right (emptyResult Nothing))) result)
-- | 角色语句走权限服务，普通账号拒绝
runPrivilege :: Session -> PrivilegeCommand -> IO (Either SessionError QueryResult)
runPrivilege session command = do
who <- readIORef (ssPrincipal session)
case who of
Nothing -> pure (Left (SessionError "unauthorized" "sign in first"))
Just principal -> do
database <- readIORef (ssCurrent session)
result <- runPrivilegeCommand (ssPrivileges session) principal database command
pure (either (Left . privilegeErrorOf) (const (Right (emptyResult Nothing))) result)
-- | 账号错误转成会话错误
accountErrorOf :: AccountError -> SessionError
accountErrorOf (AccountError code message) = SessionError code message
-- | 权限错误转成会话错误
privilegeErrorOf :: PrivilegeError -> SessionError
privilegeErrorOf (PrivilegeError code message) = SessionError code message
-- | 取权限错误的文案
privilegeMessage :: PrivilegeError -> Text
privilegeMessage (PrivilegeError _ message) = message
-- | 只带库名的空结果
emptyResult :: Maybe Text -> QueryResult
emptyResult database = QueryResult [] [] 0 False database
-- | 存储结果转成查询结果
resultOf :: StatementResult -> QueryResult
resultOf result =
QueryResult
{ qrColumns = map T.pack (srColumns result)
, qrRows = [map (cellOf row) (srColumns result) | row <- srRows result]
, qrRowCount = length (srRows result)
, qrTruncated = False
, qrDatabase = Nothing
}
where
-- | 按列名取单元格
cellOf row name = maybe VNull id (lookup name row)
chusql-server/src/ChuSQL/Server/TCP.hs
+288
View File
@@ -0,0 +1,288 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Server.TCP (
ServerConfig (..),
defaultServerConfig,
loadServerConfigAt,
ServerEnv (..),
newServerEnv,
ServerHandle (..),
startServer,
runServer,
) where
import ChuSQL.Interface.Auth (Credential)
import ChuSQL.Interface.Config (ServerConfig (..), defaultServerConfig, loadServerConfigAt)
import ChuSQL.Interface.Policy (PasswordPolicy (..))
import ChuSQL.Interface.Protocol (ClientRequest (..), ServerResponse (..), decodeRequest, encodeResponse, protocolVersion)
import ChuSQL.Interface.RateLimit (RateLimiter, rateLimitBlock, rateLimitClear, rateLimitRecord)
import ChuSQL.Server.Backend (Backend (..))
import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), accounts, authenticateSessionCoded, catalog, databases, newSession, policyOf, reloadPolicy, roleViews, runStatementCoded, sessionIsAdmin, sessionUser)
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
import Control.Exception (IOException, try)
import Control.Monad (void)
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy.Char8 as BLC
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import Network.Socket (
AddrInfo (..),
AddrInfoFlag (AI_PASSIVE),
SockAddr (SockAddrInet, SockAddrInet6),
Socket,
SocketOption (ReuseAddr),
SocketType (Stream),
accept,
addrAddress,
addrFamily,
bind,
close,
defaultHints,
defaultProtocol,
getAddrInfo,
getSocketName,
listen,
setSocketOption,
socket,
socketToHandle,
)
import System.IO (BufferMode (LineBuffering), IOMode (ReadWriteMode), hClose, hFlush, hPutStrLn, hSetBuffering, hSetNewlineMode, noNewlineTranslation, stderr)
import System.IO.Error (isEOFError)
-- TCP 服务器：监听端口，一连接一会话，按一行一 JSON 收发协议消息。
-- 服务器
data ServerEnv = ServerEnv
{ srvBackend :: Backend
, srvCredential :: Credential
, srvSettingsFile :: FilePath
, srvConfig :: ServerConfig
, srvLimiter :: RateLimiter
}
-- | 组装服务器环境：每个连接再各开一个会话
newServerEnv :: Backend -> Credential -> FilePath -> ServerConfig -> RateLimiter -> IO ServerEnv
newServerEnv backend credential settingsFile config limiter =
pure (ServerEnv backend credential settingsFile config limiter)
data ServerHandle = ServerHandle
{ shPort :: Int
, shStop :: IO ()
}
-- | 起监听并在线程里收连接（测试与嵌入用）
startServer :: ServerEnv -> IO ServerHandle
startServer env = do
sock <- listenSocket (scHost (srvConfig env)) (scPort (srvConfig env))
port <- actualPort sock
stopped <- newMVar False
_ <- forkIO (acceptLoop env sock stopped)
pure (ServerHandle port (stopListening sock stopped))
-- | 在调用线程里收连接（可执行文件用）；绑好端口先回调一次
runServer :: ServerEnv -> (Int -> IO ()) -> IO ()
runServer env announce = do
sock <- listenSocket (scHost (srvConfig env)) (scPort (srvConfig env))
port <- actualPort sock
announce port
stopped <- newMVar False
acceptLoop env sock stopped
-- | 置停止标记并关掉监听套接字
stopListening :: Socket -> MVar Bool -> IO ()
stopListening sock stopped = do
modifyMVar_ stopped (const (pure True))
void (try (close sock) :: IO (Either IOException ()))
-- | 建监听套接字；端口 0 表示由系统分配
listenSocket :: String -> Int -> IO Socket
listenSocket host port = do
let hints = defaultHints{addrSocketType = Stream, addrFlags = [AI_PASSIVE]}
node = if null host then Nothing else Just host
infos <- getAddrInfo (Just hints) node (Just (show port))
case infos of
[] -> ioError (userError ("cannot resolve listen address: " ++ host))
(info : _) -> do
sock <- socket (addrFamily info) Stream defaultProtocol
setSocketOption sock ReuseAddr 1
bind sock (addrAddress info)
listen sock 128
pure sock
-- | 系统分配端口后读回真正的端口
actualPort :: Socket -> IO Int
actualPort sock = do
address <- getSocketName sock
pure $ case address of
SockAddrInet port _ -> fromIntegral port
SockAddrInet6 port _ _ _ -> fromIntegral port
_ -> 0
-- | 循环 accept，把每个连接交给独立线程
acceptLoop :: ServerEnv -> Socket -> MVar Bool -> IO ()
acceptLoop env sock stopped = loop
where
-- | 等下一个连接
loop = do
stop <- readMVar stopped
if stop
then pure ()
else do
accepted <- try (accept sock) :: IO (Either IOException (Socket, SockAddr))
case accepted of
Left err -> do
stopping <- readMVar stopped
if stopping then pure () else hPutStrLn stderr ("accept failed: " ++ show err)
Right (conn, _) -> do
void (forkIO (reportConnection env conn))
loop
-- | 连接线程：异常写到 stderr
reportConnection :: ServerEnv -> Socket -> IO ()
reportConnection env conn = do
outcome <- try (serveConnection env conn) :: IO (Either IOException ())
case outcome of
Left err -> hPutStrLn stderr ("connection failed: " ++ show err)
Right () -> pure ()
-- | 一个连接一个会话：一行一条 JSON，读到 EOF 就收工
serveConnection :: ServerEnv -> Socket -> IO ()
serveConnection env conn = do
h <- socketToHandle conn ReadWriteMode
hSetBuffering h LineBuffering
hSetNewlineMode h noNewlineTranslation
session <- newSession (srvBackend env) (srvCredential env) (srvSettingsFile env)
outcome <- try (loop h session) :: IO (Either IOException ())
case outcome of
Left err | not (isEOFError err) -> hPutStrLn stderr ("connection error: " ++ show err)
_ -> pure ()
void (try (hClose h) :: IO (Either IOException ()))
where
-- | 逐行读请求并应答
loop h session = do
line <- BSC.hGetLine h
let cleaned = BSC.dropWhileEnd (== '\r') line
if BSC.length cleaned > scMaxMessage (srvConfig env)
then send h (RespError "too_large" "request line too large") >> loop h session
else case decodeRequest cleaned of
Left message -> send h (RespError "bad_request" message) >> loop h session
Right request -> do
(response, keepGoing) <- dispatch env session request
send h response
if keepGoing then loop h session else pure ()
-- | 发一条响应并冲缓冲
send h response = do
BLC.hPutStr h (encodeResponse response)
BLC.hPutStr h "\n"
hFlush h
-- | 一条请求一条响应，quit 后停连接
dispatch :: ServerEnv -> Session -> ClientRequest -> IO (ServerResponse, Bool)
dispatch env session request = case request of
ReqHello version
| version == protocolVersion -> pure (RespHello protocolVersion, True)
| otherwise -> pure (RespError "bad_request" ("unsupported protocol version: " <> tshow version), True)
ReqLogin user password -> do
response <- login env session user password
pure (response, True)
ReqQuery sql -> do
who <- sessionUser session
response <- case who of
Nothing -> pure (RespError "unauthorized" "sign in first")
Just _
| T.null (T.strip sql) -> pure (RespError "bad_request" "sql must not be empty")
| otherwise -> do
result <- runStatementCoded session sql
pure $ case result of
Left err -> RespError (sessCode err) (sessMessage err)
Right queryResult -> RespResult (trimResult (scMaxRows (srvConfig env)) queryResult)
pure (response, True)
ReqStorage payload -> do
who <- sessionUser session
response <- case who of
Nothing -> pure (RespError "unauthorized" "sign in first")
Just _ -> do
admin <- sessionIsAdmin session
if not admin
then pure (RespError "forbidden" "administrator required")
else do
result <- beStorage (srvBackend env) payload
pure $ case result of
Left err -> RespError "storage_error" (T.pack err)
Right value -> RespStorage value
pure (response, True)
ReqCatalog -> do
response <- overSession session (catalog session) RespCatalog
pure (response, True)
ReqDatabases -> do
response <- overSession session (databases session) RespDatabases
pure (response, True)
ReqRoles -> do
response <- overSession session (roleViews session) RespRoles
pure (response, True)
ReqAccounts -> do
response <- overSession session (accounts session) RespAccounts
pure (response, True)
ReqPolicy -> do
response <- overSession session (policyOf session) policyResponse
pure (response, True)
ReqReloadPolicy -> do
response <- overSession session (reloadPolicy session) policyResponse
pure (response, True)
ReqPing -> pure (RespPong, True)
ReqQuit -> pure (RespBye, False)
-- | 口令策略在线上只有两个数字：最短长度与至少几类字符
policyResponse :: PasswordPolicy -> ServerResponse
policyResponse (PasswordPolicy minLength classes) = RespPolicy minLength classes
-- | 会话方法统一口径：没登录先挡，其余失败按码表落到响应
overSession :: Session -> IO (Either Text a) -> (a -> ServerResponse) -> IO ServerResponse
overSession session action wrap = do
who <- sessionUser session
case who of
Nothing -> pure (RespError "unauthorized" "sign in first")
Just _ -> do
result <- action
pure $ case result of
Left message -> RespError (sessionCode message) message
Right value -> wrap value
-- | 会话层的失败文案归一到协议错误码
sessionCode :: Text -> Text
sessionCode message
| message == "no database selected" = "no_database"
| message == "administrator required" = "forbidden"
| otherwise = "query_error"
-- | 登录：按账号名限流，成功清账
login :: ServerEnv -> Session -> Text -> Text -> IO ServerResponse
login env session user password = do
let key = T.toLower (T.strip user)
blocked <- rateLimitBlock (srvLimiter env) key
case blocked of
Just seconds -> pure (RespError "too_many_attempts" ("too many failed logins, retry in " <> tshow (ceiling seconds :: Integer) <> "s"))
Nothing -> do
result <- authenticateSessionCoded session key password
case result of
Left err -> do
rateLimitRecord (srvLimiter env) key
pure (RespError (sessCode err) (sessMessage err))
Right () -> do
rateLimitClear (srvLimiter env) key
who <- sessionUser session
admin <- sessionIsAdmin session
pure (RespLogin (fromMaybe key who) admin)
-- | 按上限截行，总行数保持不变
trimResult :: Int -> QueryResult -> QueryResult
trimResult limit result
| length (qrRows result) > limit = result{qrRows = take limit (qrRows result), qrTruncated = True}
| otherwise = result
-- | show 成 Text
tshow :: Show a => a -> Text
tshow = T.pack . show
chusql-server/stack.yaml
+10
View File
@@ -0,0 +1,10 @@
resolver: lts-24.59
extra-lib-dirs:
- ../chusql-core/storage/target/release
packages:
- .
- ../chusql-core/engine
- ../chusql-core/model
- ../chusql-interface
chusql-server/stack.yaml.lock
+12
View File
@@ -0,0 +1,12 @@
# This file was autogenerated by Stack.
# You should not edit this file by hand.
# For more information, please see the documentation at:
# https://docs.haskellstack.org/en/stable/topics/lock_files
packages: []
snapshots:
- completed:
sha256: 0f728e30e843d7f00460ad56858b995a3b227fca683659c7df9f2fc3988a3ce1
size: 732465
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/59.yaml
original: lts-24.59
chusql-server/test/Spec.hs
+416
View File
@@ -0,0 +1,416 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
module Main (main) where
import ChuSQL.Core.Model (Database, Table (..), Value (..), pattern TInt, pattern TStr)
import ChuSQL.Interface.Auth (Credential (..), hashPasswordWith)
import ChuSQL.Interface.Protocol (ClientRequest (..), ServerResponse (..), decodeRequest, encodeResponse)
import ChuSQL.Interface.RateLimit (newRateLimiter)
import ChuSQL.Server.Backend (memoryBackend)
import ChuSQL.Server.Session (QueryResult (..))
import ChuSQL.Server.TCP (
ServerConfig (..),
ServerEnv,
ServerHandle (..),
defaultServerConfig,
loadServerConfigAt,
newServerEnv,
startServer,
)
import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar (newMVar)
import Control.Exception (IOException, bracket, finally, try)
import Control.Monad (void)
import Data.Aeson (decode)
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.Char8 as BSC
import qualified Data.ByteString.Lazy as BL
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Time.Clock (getCurrentTime)
import Network.Socket (
AddrInfo (..),
SocketType (Stream),
addrAddress,
addrFamily,
connect,
defaultHints,
defaultProtocol,
getAddrInfo,
socket,
socketToHandle,
withSocketsDo,
)
import System.Directory (doesFileExist, getTemporaryDirectory, removeFile)
import System.FilePath ((</>))
import System.IO (
BufferMode (LineBuffering),
Handle,
IOMode (ReadWriteMode),
hClose,
hFlush,
hIsEOF,
hSetBuffering,
hSetNewlineMode,
noNewlineTranslation,
)
import System.Timeout (timeout)
import Test.Hspec
-- TCP 服务器测试：协议编解码、配置读取与真连服务器的端到端用例。
-- | 测试入口
main :: IO ()
main = hspec spec
-- | 全部用例
spec :: Spec
spec = do
tcpSpec
tcpServerSpec
-- 夹具：内存后端装在 MVar 里，跟 Web 测试同一套表
-- | 夹具库名
testDatabaseName :: String
testDatabaseName = "test"
-- | users 5 行 + orders 1 行
testDb :: Database
testDb =
[ ( "users"
, Table
"users"
[("id", TInt), ("name", TStr), ("age", TInt)]
[ [("id", VInt i), ("name", VStr ("user" ++ show i)), ("age", VInt (20 + i))]
| i <- [1 .. 5]
]
)
, ( "orders"
, Table
"orders"
[("id", TInt), ("user_id", TInt)]
[[("id", VInt 1), ("user_id", VInt 1)]]
)
]
-- | 测试账号：迭代次数压低（跑得快），口令 `s3cret`
testCredential :: Credential
testCredential = Credential "admin" (hashPasswordWith 1000 (BS.replicate 16 7) "s3cret")
-- 小工具
-- | 取字段
field :: Text -> A.Value -> Maybe A.Value
field name (A.Object o) = KM.lookup (K.fromText name) o
field _ _ = Nothing
-- | 取字段（没有给 Null）
at :: Text -> A.Value -> A.Value
at name value = fromMaybe A.Null (field name value)
-- | 当数组看
items :: A.Value -> [A.Value]
items (A.Array xs) = V.toList xs
items _ = []
-- | 当文本看
asText :: A.Value -> Text
asText (A.String t) = t
asText _ = ""
-- | 当整数看
asInt :: A.Value -> Int
asInt (A.Number n) = round n
asInt _ = -1
-- | JSON 当布尔看
asBool :: A.Value -> Bool
asBool (A.Bool b) = b
asBool _ = False
-- | 第 i 个元素（越界给 Nothing，不用 `!!`）
nth :: Int -> [a] -> Maybe a
nth i xs = case drop i xs of
(x : _) -> Just x
[] -> Nothing
-- | 临时 TOML
tcpConfigPath :: String -> IO FilePath
tcpConfigPath name = do
tmp <- getTemporaryDirectory
pure (tmp </> ("chusql-server-test-" ++ name ++ ".toml"))
-- | 临时设置文件（新会话读口令策略用）
tempSettingsPath :: String -> IO FilePath
tempSettingsPath name = do
tmp <- getTemporaryDirectory
pure (tmp </> ("chusql-server-test-" ++ name ++ "-settings.json"))
-- | 文件不存在也算成功
removeIfExists :: FilePath -> IO ()
removeIfExists path = do
there <- doesFileExist path
if there then void (try (removeFile path) :: IO (Either IOException ())) else pure ()
-- | 起一台内存后端的测试服务器
withTcpServer :: ServerConfig -> (ServerEnv -> ServerHandle -> IO a) -> IO a
withTcpServer config body = do
db <- newMVar testDb
limiter <- newRateLimiter getCurrentTime 50 300
path <- tempSettingsPath "tcp-server"
removeIfExists path
env <- newServerEnv (memoryBackend testDatabaseName db) testCredential path config{scPort = 0} limiter
handle <- startServer env
body env handle `finally` shStop handle
-- | 连上服务器并配成行缓冲句柄
withConnection :: ServerHandle -> (Handle -> IO a) -> IO a
withConnection handle body = bracket open closeQuietly body
where
-- | 关连接，忽略异常
closeQuietly h = do
_ <- try (hClose h) :: IO (Either IOException ())
pure ()
-- | 建连接并配成行缓冲句柄
open = withSocketsDo $ do
infos <- getAddrInfo (Just defaultHints{addrSocketType = Stream}) (Just "127.0.0.1") (Just (show (shPort handle)))
info <- case infos of
(i : _) -> pure i
[] -> ioError (userError "cannot resolve the test server address")
sock <- socket (addrFamily info) Stream defaultProtocol
connect sock (addrAddress info)
h <- socketToHandle sock ReadWriteMode
hSetBuffering h LineBuffering
hSetNewlineMode h noNewlineTranslation
pure h
-- | 发一行收一行；服务器不回话就判失败，别把用例挂死
tcpTalk :: Handle -> BS.ByteString -> IO A.Value
tcpTalk h raw = do
BSC.hPutStr h raw
BSC.hPutStr h "\n"
hFlush h
line <- timeout (5 * 1000000) (BSC.hGetLine h)
case line of
Just got -> pure (fromMaybe A.Null (decode (BL.fromStrict got)))
Nothing -> do
expectationFailure "the TCP server did not answer in time"
pure A.Null
-- | 登录一行
tcpLogin :: Handle -> Text -> Text -> IO A.Value
tcpLogin h user password =
tcpTalk h (BSC.pack ("{\"method\":\"login\",\"user\":\"" ++ T.unpack user ++ "\",\"password\":\"" ++ T.unpack password ++ "\"}"))
-- | 查询一行
tcpQuery :: Handle -> Text -> IO A.Value
tcpQuery h sql = tcpTalk h (BSC.pack ("{\"method\":\"query\",\"sql\":\"" ++ T.unpack sql ++ "\"}"))
-- | 断言对端已经收工（读到 EOF）
tcpClosed :: Handle -> IO ()
tcpClosed h = do
done <- timeout (5 * 1000000) (hIsEOF h)
done `shouldBe` Just True
-- 用例
-- | 协议与配置的用例
tcpSpec :: Spec
tcpSpec = do
describe "TCP protocol: decoding a request line" $ do
it "hello without a protocol number takes the current version" $
decodeRequest "{\"method\":\"hello\"}" `shouldBe` Right (ReqHello 1)
it "hello keeps the protocol number the client asked for" $
decodeRequest "{\"method\":\"hello\",\"protocol\":2}" `shouldBe` Right (ReqHello 2)
it "method names are case-insensitive" $
decodeRequest "{\"method\":\"PING\"}" `shouldBe` Right ReqPing
it "unknown extra fields are ignored" $
decodeRequest "{\"method\":\"quit\",\"line\":7}" `shouldBe` Right ReqQuit
it "login without a password is refused" $
decodeRequest "{\"method\":\"login\",\"user\":\"admin\"}" `shouldBe` Left "login needs both user and password"
it "query without sql is refused" $
decodeRequest "{\"method\":\"query\"}" `shouldBe` Left "query needs sql"
it "an unknown method is named in the error" $
decodeRequest "{\"method\":\"frobnicate\"}" `shouldBe` Left "unknown method: frobnicate"
it "a line that is not JSON is a bad request, not a crash" $
decodeRequest "not json" `shouldBe` Left "request is not valid JSON"
describe "TCP protocol: encoding a response" $ do
it "hello carries the protocol version and the server name" $ do
let value = fromMaybe A.Null (decode (encodeResponse (RespHello 1)))
asText (at "status" value) `shouldBe` "hello"
asText (at "server" value) `shouldBe` "chusql-server"
asInt (at "protocol" value) `shouldBe` 1
it "login reports the account and whether it is the administrator" $ do
let value = fromMaybe A.Null (decode (encodeResponse (RespLogin "admin" True)))
asText (at "user" value) `shouldBe` "admin"
asBool (at "admin" value) `shouldBe` True
it "an error carries a code and a message" $ do
let value = fromMaybe A.Null (decode (encodeResponse (RespError "no_database" "no database selected")))
asText (at "status" value) `shouldBe` "error"
asText (at "code" value) `shouldBe` "no_database"
asText (at "message" value) `shouldBe` "no database selected"
it "a result set is the command line JSON with a status field added" $ do
let sample = QueryResult ["id"] [[VInt 1]] 1 False (Just "test")
value = fromMaybe A.Null (decode (encodeResponse (RespResult sample)))
asText (at "status" value) `shouldBe` "result"
map asText (items (at "columns" value)) `shouldBe` ["id"]
asInt (at "rowCount" value) `shouldBe` 1
asBool (at "truncated" value) `shouldBe` False
asText (at "database" value) `shouldBe` "test"
describe "server config ([server] in chusql.toml)" $ do
it "falls back to the defaults when the file has no server section" $ do
path <- tcpConfigPath "server-default"
removeIfExists path
loadServerConfigAt path `shouldReturn` defaultServerConfig
it "reads host, port, max_message and max_rows" $ do
path <- tcpConfigPath "server-keys"
BS.writeFile path "[server]\nhost = \"0.0.0.0\"\nport = 7777\nmax_message = 4096\nmax_rows = 7\n"
config <- loadServerConfigAt path
scHost config `shouldBe` "0.0.0.0"
scPort config `shouldBe` 7777
scMaxMessage config `shouldBe` 4096
scMaxRows config `shouldBe` 7
it "keeps the HTTP, storage and page keys out of the server config" $ do
path <- tcpConfigPath "server-other-keys"
BS.writeFile path "[web]\nport = 8888\n\n[storage]\ndata_dir = \"/tmp/chusql\"\n\n[page]\nsize = 8192\n"
config <- loadServerConfigAt path
scPort config `shouldBe` scPort defaultServerConfig
scMaxRows config `shouldBe` scMaxRows defaultServerConfig
-- | 真连 TCP 服务器的用例
tcpServerSpec :: Spec
tcpServerSpec = do
describe "TCP server: handshake and login" $ do
it "binds a real port when asked for port 0" $
withTcpServer defaultServerConfig $ \_ handle ->
shPort handle `shouldSatisfy` (> 0)
it "answers hello with the same protocol version" $
withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \h -> do
reply <- tcpTalk h "{\"method\":\"hello\",\"protocol\":1}"
asText (at "status" reply) `shouldBe` "hello"
asInt (at "protocol" reply) `shouldBe` 1
it "still answers a client that connects long after startup" $
-- 回归点：早先 accept 外面套 timeout 轮询，超时异常会在 accept
-- 返回后把刚拿到的连接丢掉，只有延迟连接的客户端能撞上
withTcpServer defaultServerConfig $ \_ handle -> do
threadDelay 400000
withConnection handle $ \h -> do
reply <- tcpTalk h "{\"method\":\"hello\",\"protocol\":1}"
asText (at "status" reply) `shouldBe` "hello"
asText (at "server" reply) `shouldBe` "chusql-server"
it "refuses a protocol version it does not speak" $
withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \h -> do
reply <- tcpTalk h "{\"method\":\"hello\",\"protocol\":9}"
asText (at "code" reply) `shouldBe` "bad_request"
asText (at "message" reply) `shouldBe` "unsupported protocol version: 9"
it "refuses a query before login" $
withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \h -> do
reply <- tcpQuery h "select * from users"
asText (at "status" reply) `shouldBe` "error"
asText (at "code" reply) `shouldBe` "unauthorized"
asText (at "message" reply) `shouldBe` "sign in first"
it "refuses a wrong password and then accepts the right one" $
withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \h -> do
bad <- tcpLogin h "admin" "wrong"
asText (at "status" bad) `shouldBe` "error"
asText (at "code" bad) `shouldBe` "unauthorized"
good <- tcpLogin h "admin" "s3cret"
asText (at "status" good) `shouldBe` "ok"
asText (at "user" good) `shouldBe` "admin"
asBool (at "admin" good) `shouldBe` True
describe "TCP server: SQL over the wire" $ do
it "USE picks a database and the result reports it" $
withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \h -> do
_ <- tcpLogin h "admin" "s3cret"
reply <- tcpQuery h "use test"
asText (at "status" reply) `shouldBe` "result"
asText (at "database" reply) `shouldBe` "test"
it "SELECT returns the fixture rows" $
withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \h -> do
_ <- tcpLogin h "admin" "s3cret"
_ <- tcpQuery h "use test"
reply <- tcpQuery h "select * from users"
asText (at "status" reply) `shouldBe` "result"
map asText (items (at "columns" reply)) `shouldBe` ["id", "name", "age"]
asInt (at "rowCount" reply) `shouldBe` 5
let first = case map items (items (at "rows" reply)) of
(r : _) -> r
[] -> []
length first `shouldBe` 3
asInt (fromMaybe A.Null (nth 0 first)) `shouldBe` 1
asText (fromMaybe A.Null (nth 1 first)) `shouldBe` "user1"
it "an unknown table maps to not_found" $
withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \h -> do
_ <- tcpLogin h "admin" "s3cret"
_ <- tcpQuery h "use test"
reply <- tcpQuery h "select * from nope"
asText (at "code" reply) `shouldBe` "not_found"
it "a query without a selected database maps to no_database" $
withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \h -> do
_ <- tcpLogin h "admin" "s3cret"
reply <- tcpQuery h "select * from users"
asText (at "code" reply) `shouldBe` "no_database"
it "an empty sql is a bad request" $
withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \h -> do
_ <- tcpLogin h "admin" "s3cret"
reply <- tcpTalk h "{\"method\":\"query\",\"sql\":\" \"}"
asText (at "code" reply) `shouldBe` "bad_request"
asText (at "message" reply) `shouldBe` "sql must not be empty"
it "the row limit truncates the rows but keeps the total count" $
withTcpServer defaultServerConfig{scMaxRows = 2} $ \_ handle ->
withConnection handle $ \h -> do
_ <- tcpLogin h "admin" "s3cret"
_ <- tcpQuery h "use test"
reply <- tcpQuery h "select * from users"
length (items (at "rows" reply)) `shouldBe` 2
asInt (at "rowCount" reply) `shouldBe` 5
asBool (at "truncated" reply) `shouldBe` True
describe "TCP server: framing and lifecycle" $ do
it "a bad JSON line does not kill the connection" $
withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \h -> do
bad <- tcpTalk h "not json"
asText (at "code" bad) `shouldBe` "bad_request"
pong <- tcpTalk h "{\"method\":\"ping\"}"
asText (at "status" pong) `shouldBe` "pong"
it "a line over the message limit is refused as too_large" $
withTcpServer defaultServerConfig{scMaxMessage = 32} $ \_ handle ->
withConnection handle $ \h -> do
reply <- tcpTalk h (BSC.pack ("{\"method\":\"query\",\"sql\":\"" ++ replicate 40 'a' ++ "\"}"))
asText (at "code" reply) `shouldBe` "too_large"
it "ping answers pong and quit closes the connection" $
withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \h -> do
pong <- tcpTalk h "{\"method\":\"ping\"}"
asText (at "status" pong) `shouldBe` "pong"
bye <- tcpTalk h "{\"method\":\"quit\"}"
asText (at "status" bye) `shouldBe` "bye"
tcpClosed h
it "one connection is one session" $
withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \h -> do
reply <- tcpLogin h "admin" "s3cret"
asText (at "status" reply) `shouldBe` "ok"
withConnection handle $ \other -> do
blocked <- tcpQuery other "select * from users"
asText (at "code" blocked) `shouldBe` "unauthorized"
chusql-storage/src/endpoint.rs
-99
View File
@@ -1,99 +0,0 @@
// 本地端点：Windows 上是具名管道 `\\.\pipe\<name>`，Unix/macOS 上是文件系统套接字
// `<socket_dir>/<name>.sock`。存储进程、Haskell 前端（见 chusql-engine 的 Storage.IPC）
// 和集成测试都用同一条规则，保证对同一个 `[server] pipe_name` 算出同一个端点。
//
// 用文件系统套接字而不是 Linux 抽象命名空间：抽象命名空间没有文件、跨平台不存在，
// 而带路径的套接字两个方向都能连，Haskell 那边也能用常规 socket 连上。
use interprocess::local_socket::{prelude::*, ListenerOptions};
#[cfg(unix)]
use interprocess::local_socket::GenericFilePath;
#[cfg(windows)]
use interprocess::local_socket::GenericNamespaced;
#[cfg(unix)]
use std::path::{Path, PathBuf};
/// 端点的可读形式：Windows 是 `\\.\pipe\<name>`，Unix 是套接字文件路径。
pub fn display(pipe_name: &str) -> String {
#[cfg(windows)]
{
format!("\\\\.\\pipe\\{}", pipe_name)
}
#[cfg(unix)]
{
socket_path(pipe_name).display().to_string()
}
}
/// Unix 端点路径：`$XDG_RUNTIME_DIR` → `$TMPDIR` → `/tmp`，文件名固定 `<pipe_name>.sock`。
#[cfg(unix)]
pub fn socket_path(pipe_name: &str) -> PathBuf {
let dir = std::env::var_os("XDG_RUNTIME_DIR")
.filter(|v| !v.is_empty())
.or_else(|| std::env::var_os("TMPDIR").filter(|v| !v.is_empty()))
.map(PathBuf::from)
.unwrap_or_else(|| PathBuf::from("/tmp"));
dir.join(format!("{}.sock", pipe_name))
}
/// 连到正在监听的存储进程。
pub fn connect(pipe_name: &str) -> std::io::Result<LocalSocketStream> {
#[cfg(windows)]
{
let name = pipe_name
.to_ns_name::<GenericNamespaced>()
.map_err(|e| std::io::Error::other(e.to_string()))?;
LocalSocketStream::connect(name)
}
#[cfg(unix)]
{
let path = socket_path(pipe_name);
let name = path
.to_fs_name::<GenericFilePath>()
.map_err(|e| std::io::Error::other(e.to_string()))?;
LocalSocketStream::connect(name)
}
}
/// 监听端点：Windows 直接建具名管道；Unix 先探活，再清掉上次崩溃留下的残留套接字文件。
pub fn listen(pipe_name: &str) -> std::io::Result<LocalSocketListener> {
#[cfg(windows)]
{
let name = pipe_name
.to_ns_name::<GenericNamespaced>()
.map_err(|e| std::io::Error::other(e.to_string()))?;
ListenerOptions::new().name(name).create_sync()
}
#[cfg(unix)]
{
let path = socket_path(pipe_name);
prepare_socket_path(&path)?;
let name = path
.to_fs_name::<GenericFilePath>()
.map_err(|e| std::io::Error::other(e.to_string()))?;
ListenerOptions::new().name(name).create_sync()
}
}
/// Unix：先探活的监听者，再清掉残留的套接字文件。
#[cfg(unix)]
fn prepare_socket_path(path: &Path) -> std::io::Result<()> {
match std::os::unix::net::UnixStream::connect(path) {
Ok(_) => Err(std::io::Error::new(
std::io::ErrorKind::AddrInUse,
format!(
"another storage server already listens on {}",
path.display()
),
)),
Err(_) => {
if path.exists() {
std::fs::remove_file(path)?;
}
if let Some(parent) = path.parent() {
std::fs::create_dir_all(parent)?;
}
Ok(())
}
}
}
chusql-web/app/Main.hs
+76 -91
View File
@@ -3,32 +3,28 @@
module Main (main) where
import ChuSQL.Web.API (AppEnv (..), Live (..), newAppEnvAt, setLive, webApp)
import ChuSQL.Web.Auth (Credential (..), SessionPolicy (..), newSessionStore)
import ChuSQL.Web.Backend (Backend, ipcBackend)
import ChuSQL.Web.Demo (SeedReport (..), seedDemo)
import ChuSQL.Web.Config (
import ChuSQL.Interface.Auth (Credential (..), SessionPolicy (..), setPayloadPolicy)
import ChuSQL.Interface.Config (
ServerConfig (..),
WebConfig (..),
defaultPassword,
defaultUser,
loadServerConfigAt,
loadWebConfigAt,
resolveCredential,
resolvePipeName,
resolvePlainPassword,
resolveStaticDir,
rootUserName,
staticDirCandidates,
usingDefaultCredentials,
)
import ChuSQL.Web.RateLimit (newRateLimiter)
import ChuSQL.Storage.IPC (setPipeName)
import ChuSQL.Web.Settings (effectiveSettings, readSettingsFile)
import ChuSQL.Web.TOML (resolveConfigPath)
import ChuSQL.Web.StorageProcess (
StorageProcess (..),
findStorageServer,
startStorageProcess,
stopStorageProcess,
waitForStorage,
)
import Control.Exception (IOException, bracket, onException, try)
import ChuSQL.Interface.Link (clientPing, closeClient, connectClient)
import ChuSQL.Interface.RateLimit (newRateLimiter)
import ChuSQL.Interface.Session (authenticateSession, newSession)
import ChuSQL.Interface.Settings (effectiveSettings, readSettingsFile)
import ChuSQL.Interface.TOML (resolveConfigPath)
import ChuSQL.Web.Demo (SeedReport (..), seedDemo)
import Control.Exception (IOException, try)
import Data.Char (toLower)
import qualified Data.Map.Strict as Map
import Data.String (fromString)
@@ -43,14 +39,13 @@ import System.Exit (exitFailure)
import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout)
import Text.Read (readMaybe)
-- Web 管理端入口：读配置、备凭据、拉起存储进程，最后起 Warp。
-- Web 管理端入口：读配置，把请求转给拥有存储的 server，最后起 Warp。
data Options = Options
{ optConfig :: Maybe FilePath
, optHost :: Maybe String
, optPort :: Maybe Int
, optStatic :: Maybe FilePath
, optStorage :: Maybe FilePath
, optUser :: Maybe Text
, optCookieSecure :: Maybe Bool
, optBodyLimit :: Maybe Int
@@ -74,7 +69,6 @@ emptyOptions =
, optHost = Nothing
, optPort = Nothing
, optStatic = Nothing
, optStorage = Nothing
, optUser = Nothing
, optCookieSecure = Nothing
, optBodyLimit = Nothing
@@ -94,13 +88,13 @@ emptyOptions =
parseArgs :: [String] -> Either String Options
parseArgs = go emptyOptions
where
-- | 逐个参数累加进 Options
go opts [] = Right opts
go opts ("--help" : rest) = go opts{optHelp = True} rest
go opts ("-h" : rest) = go opts{optHelp = True} rest
go opts ("--config" : v : rest) = go opts{optConfig = Just v} rest
go opts ("--host" : v : rest) = go opts{optHost = Just v} rest
go opts ("--static" : v : rest) = go opts{optStatic = Just v} rest
go opts ("--storage" : v : rest) = go opts{optStorage = Just v} rest
go opts ("--user" : v : rest) = go opts{optUser = Just (T.pack v)} rest
go opts ("--port" : v : rest) = withInt "--port" v (\n -> go opts{optPort = Just n} rest)
go opts ("--body-limit" : v : rest) = withInt "--body-limit" v (\n -> go opts{optBodyLimit = Just n} rest)
@@ -116,13 +110,15 @@ parseArgs = go emptyOptions
go opts ("--cookie-secure" : v : rest) = go opts{optCookieSecure = Just (isTrue v)} rest
go _ (a : _) = Left ("unrecognized argument or missing value: " ++ a)
-- | 解析一个整数参数
withInt :: String -> String -> (Int -> Either String Options) -> Either String Options
withInt name v k = maybe (Left (name ++ " needs an integer, got: " ++ v)) k (readMaybe v)
-- | 把 1/true/yes/on 认成真
isTrue :: String -> Bool
isTrue s = map toLower s `elem` ["1", "true", "yes", "on"]
-- | 帮助
-- | 打印命令行用法
usage :: IO ()
usage = do
putStrLn "usage: chusql-web [options]"
@@ -130,15 +126,14 @@ usage = do
putStrLn "config: chusql.toml sits at a fixed place and its sections hold every knob below;"
putStrLn " Windows: %APPDATA%\\ChuSQL\\chusql.toml"
putStrLn " other: $XDG_CONFIG_HOME/ChuSQL/chusql.toml (or ~/.config/ChuSQL/chusql.toml)"
putStrLn " [web] host/port/static_dir/user/password and the limits; [server] pipe_name;"
putStrLn " [web] host/port/static_dir/user/password and the limits;"
putStrLn " [storage] data_dir; [page] size; [btree] order; [buffer] pool_size; [log] level"
putStrLn ""
putStrLn " --config FILE read that config file instead ([web] host ...)"
putStrLn " --host H listen address ([web] host, default 127.0.0.1)"
putStrLn " --port N listen port ([web] port, default 7777)"
putStrLn " --port N listen port ([web] port, default 7778)"
putStrLn " --static DIR static asset directory ([web] static_dir, default static)"
putStrLn " --user NAME administrator name ([web] user, default root)"
putStrLn " --storage SERVER Rust storage exe to spawn ([web] storage_server)"
putStrLn " --cookie-secure BOOL add Secure to the cookie ([web] cookie_secure, default false)"
putStrLn " --body-limit N max request body bytes ([web] body_limit, default 65536)"
putStrLn " --session-idle N session idle timeout, sec ([web] session_idle, default 28800)"
@@ -155,8 +150,10 @@ usage = do
putStrLn " an empty password means the administrator signs in with no password; ordinary accounts are then refused"
putStrLn ("without either the demo administrator is " ++ T.unpack defaultUser ++ " / " ++ T.unpack defaultPassword)
putStrLn "ordinary accounts: CREATE USER / ALTER USER / DROP USER from the SQL console (administrator only)"
putStrLn "storage process: [server] pipe_name says where to talk and where a spawned one listens;"
putStrLn " [storage] data_dir, [page] size, [btree] order, [buffer] pool_size and [log] level are its own"
putStrLn "storage: the server owns the data directory and loads the chusql_core_storage library;"
putStrLn " this process is a plain TCP client: every statement, lookup and account request goes to it"
putStrLn " [server] host / port says where it listens; [storage] data_dir, [page] size, [btree] order,"
putStrLn " [buffer] pool_size and [log] level are the server's own"
-- | 命令行覆盖配置
applyOptions :: WebConfig -> Options -> WebConfig
@@ -165,9 +162,6 @@ applyOptions cfg opts =
{ wcHost = orElse (optHost opts) (wcHost cfg)
, wcPort = orElse (optPort opts) (wcPort cfg)
, wcStaticDir = orElse (optStatic opts) (wcStaticDir cfg)
, wcStorageServer = case optStorage opts of
Just p -> Just p
Nothing -> wcStorageServer cfg
, wcUser = orElse (optUser opts) (wcUser cfg)
, wcCookieSecure = orElse (optCookieSecure opts) (wcCookieSecure cfg)
, wcBodyLimit = orElse (optBodyLimit opts) (wcBodyLimit cfg)
@@ -182,21 +176,12 @@ applyOptions cfg opts =
, wcSeedDemo = orElse (optSeedDemo opts) (wcSeedDemo cfg)
}
where
-- | 有就用新的，没有留旧值
orElse :: Maybe a -> a -> a
orElse (Just x) _ = x
orElse Nothing y = y
-- | 配了存储进程路径就拉起来，没配就假设外面已经跑着
startStorageIfWanted :: WebConfig -> FilePath -> IO (Either String (Maybe StorageProcess))
startStorageIfWanted cfg configPath = case wcStorageServer cfg of
Nothing -> pure (Right Nothing)
Just given -> do
found <- findStorageServer (Just given)
case found of
Left e -> pure (Left e)
Right bin -> fmap (fmap Just) (startStorageProcess bin configPath)
-- | 入口
-- | 程序入口
main :: IO ()
main = do
hSetBuffering stdout LineBuffering
@@ -210,13 +195,12 @@ main = do
| optHelp opts -> usage
| otherwise -> run opts
-- | 起服务
-- | 读配置装配环境，检查 server，起 Warp
run :: Options -> IO ()
run opts = do
configPath <- resolveConfigPath (optConfig opts)
base <- loadWebConfigAt configPath
let cfg = applyOptions base opts
setPipeName (resolvePipeName cfg)
foundStatic <- resolveStaticDir (wcStaticDir cfg)
case foundStatic of
Nothing -> do
@@ -224,44 +208,31 @@ run opts = do
exitFailure
Just staticDir -> do
let settingsFile = configPath
policy = SessionPolicy (fromIntegral (wcSessionIdle cfg)) (fromIntegral (wcSessionMax cfg))
saved <- readSettingsFile settingsFile
cred <- resolveCredential cfg saved
storage <- startStorageIfWanted cfg configPath
case storage of
Left err -> do
putStrLn err
exitFailure
Right maybeStorage -> do
backend <- ipcBackend
let policy =
SessionPolicy
(fromIntegral (wcSessionIdle cfg))
(fromIntegral (wcSessionMax cfg))
sessions <- newSessionStore getCurrentTime policy
config <- loadServerConfigAt settingsFile
limiter <-
newRateLimiter
getCurrentTime
(wcLoginMaxAttempts cfg)
(fromIntegral (wcLoginWindow cfg))
env0 <- newAppEnvAt settingsFile backend sessions cred limiter staticDir
`onException` maybe (pure ()) stopStorageProcess maybeStorage
env0 <- newAppEnvAt settingsFile (T.pack (scHost config)) (scPort config) limiter staticDir
let env =
env0
{ aeCookieSecure = wcCookieSecure cfg
, aeEffective = effectiveSettings cfg
, aeLog = TIO.putStrLn
}
setPayloadPolicy (aeSessions env) policy
setLive env (liveFromConfig cfg)
app <- webApp env
printBanner cfg configPath staticDir maybeStorage
reportCredential cred saved
waitForStorageReport
seedIfWanted cfg backend
printBanner cfg configPath staticDir
reportCredential cfg saved
checkServer (aeServerHost env) (aeServerPort env)
seedIfWanted cfg saved (aeServerHost env) (aeServerPort env)
let settings =
Warp.setPort (wcPort cfg) (Warp.setHost (fromString (wcHost cfg)) Warp.defaultSettings)
case maybeStorage of
Nothing -> serve settings app
Just sp -> bracket (pure sp) stopStorageProcess (const (serve settings app))
serve settings app
-- | 本次启动的配置摊成热改参数
liveFromConfig :: WebConfig -> Live
@@ -291,26 +262,38 @@ serve settings app = do
exitFailure
-- | 口令是从哪来的（用了内置默认口令就明确警告）
reportCredential :: Credential -> Map.Map Text Text -> IO ()
reportCredential cred saved
| usingDefaultCredentials saved = do
reportCredential :: WebConfig -> Map.Map Text Text -> IO ()
reportCredential cfg saved = do
credential <- resolveCredential cfg saved
if usingDefaultCredentials saved
then do
putStrLn ""
putStrLn " !! Administrator credentials are not configured; the built-in demo password is in use:"
putStrLn (" !! user " ++ T.unpack (credUser cred) ++ " / password " ++ T.unpack defaultPassword)
putStrLn (" !! user " ++ T.unpack (credUser credential) ++ " / password " ++ T.unpack defaultPassword)
putStrLn " !! set user / password in the [web] section of chusql.toml and restart"
putStrLn ""
| T.null (credEncoded cred) =
putStrLn ("administrator: " ++ T.unpack (credUser cred) ++ " (passwordless: only the administrator may sign in)")
| otherwise = putStrLn ("administrator: " ++ T.unpack (credUser cred) ++ " (credentials come from the settings file only)")
else
if T.null (credEncoded credential)
then putStrLn ("administrator: " ++ T.unpack (rootUserName cfg saved) ++ " (passwordless: only the administrator may sign in)")
else putStrLn ("administrator: " ++ T.unpack (rootUserName cfg saved) ++ " (credentials come from the settings file only)")
-- | 配了 seed 就补一份演示数据
seedIfWanted :: WebConfig -> Backend -> IO ()
seedIfWanted cfg backend
-- | 配了 seed 就以管理员身份补演示数据
seedIfWanted :: WebConfig -> Map.Map Text Text -> Text -> Int -> IO ()
seedIfWanted cfg saved host port
| not (wcSeedDemo cfg) = pure ()
| otherwise = do
result <- seedDemo backend
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 saved) (resolvePlainPassword saved)
case signed of
Left message -> TIO.putStrLn ("demo data skipped: " <> message)
Right () -> do
result <- seedDemo session
case result of
Left e -> TIO.putStrLn ("demo data skipped: " <> T.pack e)
Left message -> TIO.putStrLn ("demo data skipped: " <> message)
Right report ->
TIO.putStrLn
( "demo data: "
@@ -318,20 +301,24 @@ seedIfWanted cfg backend
<> (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
-- | 报一下存储进程通不通
waitForStorageReport :: IO ()
waitForStorageReport = do
up <- waitForStorage 20
putStrLn
( if up
then "storage: up (endpoint answered ping)"
else "storage: DOWN (no ping reply; start the Rust storage process or pass --storage)"
)
-- | ping 一次 server，报告它通不通
checkServer :: Text -> Int -> IO ()
checkServer host port = do
opened <- connectClient host port
case opened of
Left message -> putStrLn ("storage: DOWN (" ++ T.unpack message ++ ")")
Right client -> do
probe <- clientPing client
closeClient client
case probe of
Right () -> putStrLn "storage: up (the server answered ping)"
Left message -> putStrLn ("storage: DOWN (" ++ T.unpack message ++ ")")
-- | 启动横幅
printBanner :: WebConfig -> FilePath -> FilePath -> Maybe StorageProcess -> IO ()
printBanner cfg configPath staticDir maybeStorage = do
printBanner :: WebConfig -> FilePath -> FilePath -> IO ()
printBanner cfg configPath staticDir = do
putStrLn "==================== ChuSQL Web ===================="
putStrLn ("url: http://" ++ wcHost cfg ++ ":" ++ show (wcPort cfg) ++ "/")
putStrLn ("config file: " ++ configPath)
@@ -360,6 +347,4 @@ printBanner cfg configPath staticDir maybeStorage = do
++ show (wcLoginWindow cfg)
++ "s"
)
case maybeStorage of
Just sp -> putStrLn ("storage proc: spawned, talking on pipe " ++ spPipe sp)
Nothing -> putStrLn "storage proc: assumed to run elsewhere (pipe name from [server] pipe_name)"
putStrLn "storage: through the server that owns the data directory"
chusql-web/chusql-web.cabal
+17 -25
View File
@@ -4,37 +4,27 @@ name: chusql-web
version: 1.0.0
synopsis: ChuSQL Web 管理端：Scotty + REST API + 静态页面
description: ChuSQL 的浏览器管理端。负责 HTTP 交付、鉴权、静态文件，
以及把用户 SQL 转交给 chusql-engine（再由 IPC 打到 Rust 存储进程）。
并把用户的 SQL 经 TCP 转交给 chusql-server（存储由服务器进程里的
chusql_core_storage 动态库承担）。本进程不链引擎，也不碰存储。
数据库服务器与 TCP 协议在 chusql-server 包里，这里只做 HTTP 这一面。
build-type: Simple
library
hs-source-dirs: src
exposed-modules: ChuSQL.Web.Actions
ChuSQL.Web.Accounts
ChuSQL.Web.API
ChuSQL.Web.Auth
ChuSQL.Web.Backend
ChuSQL.Web.Config
exposed-modules: ChuSQL.Web.API
ChuSQL.Web.Demo
ChuSQL.Web.Privileges
ChuSQL.Web.RateLimit
ChuSQL.Web.Secure
ChuSQL.Web.Settings
ChuSQL.Web.Static
ChuSQL.Web.StorageProcess
ChuSQL.Web.TOML
ChuSQL.Web.UISettings
build-depends: base >= 4.14 && < 5
, aeson
, bytestring
, chusql-engine
, chusql-core-model
, chusql-interface
, containers
, crypton
, directory
, filepath
, http-types
, memory
, process
, scientific
, scotty
, text
@@ -48,30 +38,32 @@ executable chusql-web
main-is: Main.hs
hs-source-dirs: app
build-depends: base
, bytestring
, chusql-engine
, chusql-interface
, chusql-web
, containers
, crypton
, directory
, filepath
, http-types
, memory
, text
, time
, wai
, warp
default-language: Haskell2010
ghc-options: -Wall
-- 运行期找 libchusql_core_storage.so：$ORIGIN 让二进制与动态库同目录即可
if os(linux)
ld-options: -Wl,-rpath,$ORIGIN
if os(osx)
ld-options: -Wl,-rpath,@loader_path
test-suite chusql-web-test
type: exitcode-stdio-1.0
main-is: Spec.hs
hs-source-dirs: test
other-modules: Gates
build-tool-depends: chusql-server:chusql-server
build-depends: base
, aeson
, bytestring
, chusql-engine
, chusql-core-model
, chusql-interface
, chusql-web
, containers
, directory
@@ -88,4 +80,4 @@ test-suite chusql-web-test
, wai-extra
, warp
default-language: Haskell2010
ghc-options: -Wall
ghc-options: -Wall -threaded
chusql-web/src/ChuSQL/Web/Api.hs → chusql-web/src/ChuSQL/Web/API.hs
+447 -440
View File
File diff suppressed because it is too large. Load diff
chusql-web/src/ChuSQL/Web/Demo.hs
+25 -23
View File
@@ -10,16 +10,17 @@ module ChuSQL.Web.Demo (
seedDemo,
) where
import ChuSQL.Model (Value (..))
import ChuSQL.Storage.IPC (TableInfo (..))
import ChuSQL.Web.Actions (
import ChuSQL.Core.Model (Value (..))
import ChuSQL.Core.Protocol (TableInfo (..))
import ChuSQL.Interface.Actions (
ColumnSpec (..),
CreateTableSpec (..),
createIndexSql,
createTableSql,
insertRowsSql,
)
import ChuSQL.Web.Backend (Backend (..))
import ChuSQL.Interface.Session (Session, catalog, runStatement)
import Data.Text (Text)
import qualified Data.Text as T
-- 演示数据：三张表加一个二级索引，语句与界面走同一套拼 SQL 的代码。
@@ -75,12 +76,12 @@ data SeedReport = SeedReport
}
deriving (Show, Eq)
-- | 缺什么补什么，可反复点不重复灌
seedDemo :: Backend -> IO (Either String SeedReport)
seedDemo backend = do
catalog <- beCatalog backend
case catalog of
Left e -> pure (Left e)
-- | 按需灌演示数据：缺表补表、缺索引补索引
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]
@@ -93,34 +94,33 @@ seedDemo backend = do
]
created <- runAll (map createTableSql missing)
case created of
Left e -> pure (Left e)
Left message -> pure (Left message)
Right () -> do
rowsDone <- runAll [insertRowsSql t rs | (t, rs) <- demoRows, t `elem` missingNames]
case rowsDone of
Left e -> pure (Left e)
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
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 String ())
-- | 顺序跑完一串语句，首错即停
runAll :: [Either String String] -> IO (Either Text ())
runAll [] = pure (Right ())
runAll (sql : rest) = case sql of
Left e -> pure (Left e)
Left e -> pure (Left (T.pack e))
Right statement -> do
result <- beStatement backend statement
result <- runStatement session (T.pack statement)
case result of
Left e -> pure (Left e)
Left message -> pure (Left message)
Right _ -> runAll rest
indexMissing :: [TableInfo] -> T.Text -> T.Text -> Bool
-- | 目录里这张表缺不缺这个索引
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)
@@ -135,6 +135,7 @@ userRecords =
, ("Judy", 29)
]
-- | 演示订单数据
orderRecords :: [(Int, String, Int)]
orderRecords =
[ (1, "Laptop", 1299)
@@ -151,6 +152,7 @@ orderRecords =
, (9, "Lamp", 39)
]
-- | 演示产品数据
productRecords :: [(String, Int, Int)]
productRecords =
[ ("Laptop", 1001, 1299)
chusql-web/src/ChuSQL/Web/Static.hs
+2 -1
View File
@@ -23,7 +23,7 @@ maxNameLength = 128
allowedExtensions :: [String]
allowedExtensions = [".html", ".css", ".js", ".svg", ".png", ".ico", ".ttf", ".woff2"]
-- | 把请求里的文件名变成安全的相对路径；不合法给 Nothing
-- | 把请求文件名校验成安全相对路径，不合法给 Nothing
safeRelative :: Text -> Maybe FilePath
safeRelative t
| T.null t = Nothing
@@ -33,6 +33,7 @@ safeRelative t
| map toLower (takeExtension (T.unpack t)) `notElem` allowedExtensions = Nothing
| otherwise = Just (T.unpack t)
where
-- | 文件名里是否出现不允许的字符
badChar c = not (isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("._-" :: String))
-- | 读一个静态文件；不存在（或是目录）给 Nothing
chusql-web/src/ChuSQL/Web/StorageProcess.hs
-113
View File
@@ -1,113 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Web.StorageProcess (
StorageProcess (..),
findStorageServer,
startStorageProcess,
startStorageProcessAt,
platformBinaryName,
storageChildArgs,
stopStorageProcess,
waitForStorage,
) where
import ChuSQL.Storage.IPC (Request (..), Response (..), closeConnection, sendRequest, setPipeName)
import ChuSQL.Web.Config (loadWebConfigAt, resolvePipeName)
import Control.Concurrent (threadDelay)
import Control.Exception (SomeException, try)
import Control.Monad (filterM)
import System.Directory (doesFileExist)
import System.Exit (ExitCode)
import System.FilePath ((</>))
import System.Info (os)
import System.IO (Handle)
import System.Process (
CreateProcess (..),
ProcessHandle,
StdStream (..),
createProcess,
proc,
terminateProcess,
waitForProcess,
)
-- 拉起并管理 Rust 存储进程，起来后等管道应答 ping 再继续。
-- 调参、管名与数据目录都在全局 chusql.toml 里，孩子自己读；这里只负责起进程、
-- 用 --config 把「读哪份配置文件」告诉它，并等就绪。
data StorageProcess = StorageProcess
{ spProcess :: ProcessHandle
, spPipe :: String
}
-- | 可执行文件名跟平台走：Windows 带 .exe，其它平台不带。同一个 target 目录里可能
-- 同时躺着一份别处交叉编译出来的 .exe（Windows PE），在 Linux 上误选它只会拿到
-- config file not found（Windows 进程看不到 /tmp/... 这样的路径）。目标平台当参数传，
-- 两个分支都能被测试直接钉住。
platformBinaryName :: String -> String -> FilePath
platformBinaryName targetOs stem = if targetOs == "mingw32" then stem ++ ".exe" else stem
-- | 找存储进程，没有就给路径提示
findStorageServer :: Maybe FilePath -> IO (Either String FilePath)
findStorageServer (Just p) = do
ok <- doesFileExist p
pure (if ok then Right p else Left ("storage server not found: " ++ p))
findStorageServer Nothing = do
let dirs =
[ "chusql-storage/target"
, "../chusql-storage/target"
, "../../chusql-storage/target"
, "target"
]
modes = ["release", "debug"]
exes = [platformBinaryName os "chusql-storage"]
candidates = [d </> m </> e | d <- dirs, m <- modes, e <- exes]
found <- filterM doesFileExist candidates
pure $ case found of
(p : _) -> Right p
[] -> Left "no Rust storage server found; run `cargo build --release` in chusql-storage, or pass --storage <path>"
-- | 按配置文件里的管名起存储进程
startStorageProcess :: FilePath -> FilePath -> IO (Either String StorageProcess)
startStorageProcess bin configPath = do
cfg <- loadWebConfigAt configPath
startStorageProcessAt bin (resolvePipeName cfg) configPath
-- | 给存储子进程的参数：配置文件位置是固定的，唯一的显式覆盖就是写进 --config
storageChildArgs :: FilePath -> [String]
storageChildArgs configPath = ["--config", configPath]
-- | 用给定的管名起存储进程，并把本进程的端点也指到它；环境原样继承
startStorageProcessAt :: FilePath -> String -> FilePath -> IO (Either String StorageProcess)
startStorageProcessAt bin pipe configPath = do
let child = (proc bin (storageChildArgs configPath)){std_out = NoStream, std_err = Inherit}
started <-
try (createProcess child) ::
IO (Either SomeException (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
case started of
Left e -> pure (Left ("failed to start the storage process: " ++ show e))
Right (_, _, _, ph) -> do
setPipeName pipe
ready <- waitForStorage (200 :: Int)
if ready
then pure (Right (StorageProcess ph pipe))
else do
_ <- try (terminateProcess ph) :: IO (Either SomeException ())
pure (Left "storage process did not become ready within 5 seconds (no ping reply on the pipe)")
-- | 停掉存储进程，保留数据目录
stopStorageProcess :: StorageProcess -> IO ()
stopStorageProcess sp = do
closeConnection
_ <- try (terminateProcess (spProcess sp)) :: IO (Either SomeException ())
_ <- try (waitForProcess (spProcess sp)) :: IO (Either SomeException ExitCode)
pure ()
-- | 轮询 ping 直到对面应答
waitForStorage :: Int -> IO Bool
waitForStorage 0 = pure False
waitForStorage n = do
r <- try (sendRequest ReqPing) :: IO (Either SomeException Response)
case r of
Right RespPong -> pure True
_ -> threadDelay 25000 >> waitForStorage (n - 1)
chusql-web/src/ChuSQL/Web/UiSettings.hs → chusql-web/src/ChuSQL/Web/UISettings.hs
+8
View File
@@ -42,15 +42,18 @@ resolveUISettingsFile = do
ready <- firstExistingDir uiSettingsFileCandidates
pure (maybe firstCandidate id ready)
where
-- | 首选候选路径
firstCandidate = case uiSettingsFileCandidates of
(p : _) -> p
[] -> "chusql.ui.settings.json"
-- | 第一个存在的候选文件
firstExistingFile [] = pure Nothing
firstExistingFile (p : ps) = do
ok <- doesFileExist p
if ok then pure (Just p) else firstExistingFile ps
-- | 目录已存在的第一个候选
firstExistingDir [] = pure Nothing
firstExistingDir (p : ps) = do
let dir = takeDirectory p
@@ -61,6 +64,7 @@ resolveUISettingsFile = do
validateUISettings :: A.Value -> Either String (Map.Map Text A.Value)
validateUISettings (A.Object o) = Map.fromList <$> mapM checkField (KM.toList o)
where
-- | 校验一个字段
checkField (rawKey, value) =
let key = K.toText rawKey
in case key of
@@ -80,16 +84,20 @@ validateUISettings (A.Object o) = Map.fromList <$> mapM checkField (KM.toList o)
"minimap" -> pair key <$> boolValue key value
_ -> Left ("unknown setting: " ++ T.unpack key)
-- | 把键和值配成一对
pair key value = (key, value)
validateUISettings _ = Left "settings must be a JSON object"
-- | 字体链最多几项
fontChainMax :: Int
fontChainMax = 10
-- | 单个字体名最长多少字
fontNameMax :: Int
fontNameMax = 64
-- | 空值占位文本最长多少字
nullTextMax :: Int
nullTextMax = 64
chusql-web/stack.yaml
+7 -1
View File
@@ -1,5 +1,11 @@
resolver: lts-24.59
extra-lib-dirs:
- ../chusql-core/storage/target/release
packages:
- .
- ../chusql-engine
- ../chusql-core/engine
- ../chusql-server
- ../chusql-core/model
- ../chusql-interface
chusql-web/static/api.js
+32 -2
View File
@@ -1,12 +1,14 @@
// REST 数据源：与 chusql-web 的 /api/* 一一对应。
// 所有请求带 X-ChuSQL-Database 头（服务端不保存 USE 状态）；401 时广播登录事件。
// 请求都带 X-ChuSQL-Database 头；401 时广播登录事件。
export const AUTH_EVENT = 'chusql-auth-required';
// 是否是普通对象。
function isObject(value) {
return value !== null && typeof value === 'object' && !Array.isArray(value);
}
// 发一次请求并处理错误。
async function request(url, init, database) {
const headers = new Headers(init && init.headers ? init.headers : undefined);
if (database) headers.set('X-ChuSQL-Database', database);
@@ -34,6 +36,7 @@ async function request(url, init, database) {
return body;
}
// 组装 JSON 请求参数。
function jsonInit(method, body) {
return {
method,
@@ -44,12 +47,14 @@ function jsonInit(method, body) {
const identifier = /^[A-Za-z_][A-Za-z0-9_]{0,63}$/;
// 校验数据库名格式。
function checkDatabaseName(name) {
if (!identifier.test(String(name))) throw new Error('数据库名只能是字母、数字与下划线，且以字母或下划线开头。');
}
// ---------------------------------------------------------------- 会话
// 读取当前会话。
export async function currentSession() {
const body = await request('/api/session');
if (!isObject(body) || typeof body.user !== 'string') throw new Error('服务器返回的会话信息无法识别。');
@@ -60,16 +65,19 @@ export async function currentSession() {
};
}
// 提交登录。
export async function login(user, password) {
await request('/api/login', jsonInit('POST', { user, password }));
}
// 退出登录。
export async function logout() {
await request('/api/logout', jsonInit('POST', {}));
}
// ---------------------------------------------------------------- 数据库
// 列出数据库。
export async function listDatabases() {
const body = await request('/api/databases');
if (!Array.isArray(body) || !body.every((name) => typeof name === 'string')) {
@@ -78,16 +86,18 @@ export async function listDatabases() {
return body;
}
// 新建数据库。
export async function createDatabase(name, database) {
checkDatabaseName(name);
await request('/api/databases', jsonInit('POST', { name }), database);
}
// 删除数据库。
export async function dropDatabase(name, database) {
await request(`/api/databases/${encodeURIComponent(name)}`, jsonInit('DELETE'), database);
}
// 切换当前库：走一条 USE 语句，服务端在响应里回带新的库名。
// 切换当前库（发 USE 语句）。
export async function useDatabase(name, database) {
checkDatabaseName(name);
return query(`USE ${name}`, database);
@@ -95,12 +105,14 @@ 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) {
if (!Array.isArray(value)) throw new Error('服务器返回的列清单无法识别。');
return value.map((entry) => {
@@ -112,6 +124,7 @@ function asColumns(value) {
});
}
// 校验并规整表描述。
function asTable(value) {
if (!isObject(value) || typeof value.table !== 'string' || typeof value.rowCount !== 'number') {
throw new Error('服务器返回的表描述无法识别。');
@@ -125,38 +138,46 @@ function asTable(value) {
};
}
// 列出表。
export async function listTables(database) {
const body = await request('/api/tables', undefined, database);
if (!Array.isArray(body)) throw new Error('服务器返回的表清单无法识别。');
return body.map(asTable);
}
// 取单表结构。
export async function getTable(database, table) {
return asTable(await request(`/api/tables/${encodeURIComponent(table)}`, undefined, database));
}
// 新建表。
export async function createTable(database, name, columns) {
await request('/api/tables', jsonInit('POST', { name, columns }), database);
}
// 删除表。
export async function dropTable(database, table) {
await request(`/api/tables/${encodeURIComponent(table)}`, jsonInit('DELETE'), database);
}
// 建索引。
export async function createIndex(database, table, column) {
await request(`/api/tables/${encodeURIComponent(table)}/indexes`, jsonInit('POST', { column }), database);
}
// 删索引。
export async function dropIndex(database, table, column) {
await request(`/api/tables/${encodeURIComponent(table)}/indexes/${encodeURIComponent(column)}`, jsonInit('DELETE'), database);
}
// 删列。
export async function dropColumn(database, table, column) {
await request(`/api/tables/${encodeURIComponent(table)}/columns/${encodeURIComponent(column)}`, jsonInit('DELETE'), database);
}
// ---------------------------------------------------------------- 行
// 分页取表数据。
export async function fetchRows({ database, table, limit, offset, sort, dir, filters }) {
const params = new URLSearchParams({ limit: String(limit), offset: String(offset) });
if (sort) {
@@ -179,14 +200,17 @@ export async function fetchRows({ database, table, limit, offset, sort, dir, fil
return { columns, rows, total: body.total };
}
// 插入一行。
export async function insertRow(database, table, values) {
await request(`/api/tables/${encodeURIComponent(table)}/rows`, jsonInit('POST', { values }), database);
}
// 更新一行。
export async function updateRow(database, table, id, values) {
await request(`/api/tables/${encodeURIComponent(table)}/rows/${encodeURIComponent(id)}`, jsonInit('PATCH', { values }), database);
}
// 删除一行。
export async function deleteRow(database, table, id) {
await request(`/api/tables/${encodeURIComponent(table)}/rows/${encodeURIComponent(id)}`, jsonInit('DELETE'), database);
}
@@ -209,6 +233,7 @@ export async function commitChanges(database, changes) {
// ---------------------------------------------------------------- 查询
// 执行 SQL 并规整结果。
export async function query(sql, database) {
const started = performance.now();
try {
@@ -231,27 +256,32 @@ export async function query(sql, database) {
}
}
// 灌演示数据。
export async function seedDemoData(database) {
return request('/api/demo-data', jsonInit('POST', {}), database);
}
// ---------------------------------------------------------------- 设置
// 读取服务器设置。
export async function loadServerSettings() {
const body = await request('/api/settings');
if (!isObject(body) || !Array.isArray(body.items)) throw new Error('服务器返回的设置清单无法识别。');
return body;
}
// 保存服务器设置。
export async function saveServerSettings(values) {
const body = await request('/api/settings', jsonInit('PUT', { values }));
return isObject(body) ? body : { ok: true };
}
// 读取 IDE 设置。
export async function loadUiSettings() {
return request('/api/ui-settings');
}
// 保存 IDE 设置。
export async function saveUiSettings(settings) {
await request('/api/ui-settings', jsonInit('PUT', settings));
}
Loaded 100 of 118 files, more files were not shown because too many files have changed in this diff. Show more