Compare commits

...
6 Commits
Author SHA1 Message Date
LIm1tZz7 ff3dbddd13 Publish the first stable release for Windows and Linux only
build / build (push) Blocked by required conditions
tests / tests (push) Waiting to run
tests / build (push) Waiting to run
release / validate (push) Blocked by required conditions
release / linux-x86_64 (push) Waiting to run
release / windows-x86_64 (push) Waiting to run
tests / release (push) Waiting to run
2026-10-05 23:38:39 +08:00
LIm1tZz7 346530d5f1 Isolate XDG configuration during Unix package installation checks 2026-10-05 23:19:32 +08:00
LIm1tZz7 8d2f65ab8d Package only the platform storage shared library 2026-10-05 22:53:11 +08:00
LIm1tZz7 b51183a794 Describe ChuSQL from the beginning in the first stable release notes 2026-10-05 22:40:30 +08:00
LIm1tZz7 0475a61c66 Fix release validation and require passing Linux tests before publication 2026-10-05 22:35:42 +08:00
LIm1tZz7 8ce4239452 v26.10.1 正式版
修复部分问题,优化性能,进一步推进类型系统
2026-10-05 22:22:23 +08:00
90 changed files with 5833 additions and 877 deletions

No files matched your search

+25 -110
View File
@@ -1,8 +1,7 @@
# 发版流水线:打 tag(v*)时为四个平台各出一个发行包,附 sha256,挂到 Release。
# 发版流水线:构建 Windows 与 Linux 安装包,验证后上传 Release。
#
# 资源命名(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 指定)。
@@ -13,8 +12,6 @@
# 没有对应平台的资源时,同一个脚本可以退回本地编译:
# sh scripts/install.sh --component web --from-source
#
# 说明:macOS 两个 runner 会让总时长变长(每个 job 都要 cargo + stack 各编一遍);
# 不需要 Intel mac 的包就把 macos-13 那两行删掉。
name: release
on:
@@ -29,10 +26,19 @@ on:
permissions:
contents: write
concurrency:
group: release-${{ inputs.tag || github.ref_name }}
cancel-in-progress: true
env:
CARGO_TERM_COLOR: always
jobs:
validate:
uses: ./.github/workflows/linux.yml
with:
phase: release
build:
name: ${{ matrix.platform }}
runs-on: ${{ matrix.os }}
@@ -43,10 +49,10 @@ jobs:
include:
- { os: ubuntu-latest, platform: linux-x86_64 }
- { os: windows-latest, platform: windows-x86_64 }
- { os: macos-13, platform: macos-x86_64 }
- { os: macos-14, platform: macos-arm64 }
steps:
- uses: actions/checkout@v4
with:
ref: ${{ inputs.tag || github.ref }}
# ---------- 工具链 ----------
- name: Rust toolchain
@@ -101,113 +107,15 @@ jobs:
working-directory: chusql-bootstrap
run: stack build --fast chusql-bootstrap:exe:csql-bootstrap
# ---------- 装配 + 打归档(CI 里直接写在这里;本机打同一个包用 scripts/package.sh)----------
# 归档里是包内容本身(bin/、scripts/、static/、install.sh 就在根上),安装脚本按这个布局找文件。
- name: package (Unix)
- name: package and verify (Unix)
if: runner.os != 'Windows'
shell: bash
run: |
set -eu
name="chusql-${{ matrix.platform }}"
stage="dist/$name"
rm -rf "$stage"
mkdir -p "$stage/bin" "$stage/resources"
run: sh scripts/package.sh --out-dir "$PWD/dist" --platform '${{ matrix.platform }}' --version '${{ inputs.tag || github.ref_name }}' --no-build
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')"
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
# 引导程序住在自己的工程里,安装根也单独问它要
bootstrap_root="$(cd chusql-bootstrap && stack path --local-install-root | tail -n 1 | tr -d '\r')"
bootstrap_bin="$bootstrap_root/bin/csql-bootstrap"
if [ ! -f "$bootstrap_bin" ]; then
bootstrap_bin="$(find chusql-bootstrap/.stack-work -name csql-bootstrap -type f 2>/dev/null | head -n 1 || true)"
fi
[ -n "$bootstrap_bin" ] && [ -f "$bootstrap_bin" ] || { echo "csql-bootstrap not found" >&2; exit 1; }
cp "$bootstrap_bin" "$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 resources/settings.toml.* "$stage/resources/"
cp scripts/install.ps1 scripts/install.sh "$stage/"
cp scripts/uninstall.ps1 scripts/uninstall.sh "$stage/"
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
chmod +x "$stage/install.sh" "$stage/uninstall.sh" "$stage/csql-web.sh"
mkdir -p dist
tar -czf "dist/$name.tar.gz" -C "$stage" .
rm -rf "$stage"
ls -l "dist/$name.tar.gz"
- name: package (Windows)
- name: package and verify (Windows)
if: runner.os == 'Windows'
shell: pwsh
run: |
$ErrorActionPreference = 'Stop'
$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/resources" | Out-Null
Copy-Item 'chusql-core/storage/target/release/chusql_core_storage.dll' "$stage/bin/"
$stackRoot = (& stack path --local-install-root | Select-Object -Last 1).Trim()
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 |
Sort-Object LastWriteTime -Descending | Select-Object -First 1 -ExpandProperty FullName
}
if (-not $front -or -not (Test-Path $front)) { throw "front end binary not found: $frontName" }
Copy-Item $front "$stage/bin/"
}
$bootstrapRoot = (& stack path --local-install-root | Select-Object -Last 1).Trim()
$bootstrapExe = Join-Path $bootstrapRoot 'bin/csql-bootstrap.exe'
if (-not (Test-Path $bootstrapExe)) {
$bootstrapExe = Get-ChildItem -Path 'chusql-bootstrap/.stack-work' -Recurse -Filter 'csql-bootstrap.exe' -File -ErrorAction SilentlyContinue |
Sort-Object LastWriteTime -Descending | Select-Object -First 1 -ExpandProperty FullName
}
if (-not $bootstrapExe -or -not (Test-Path $bootstrapExe)) { throw 'csql-bootstrap.exe not found' }
Copy-Item $bootstrapExe "$stage/bin/"
# 第三方 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 'resources/settings.toml.*' "$stage/resources/"
Copy-Item 'scripts/install.ps1', 'scripts/install.sh' $stage
Copy-Item 'scripts/uninstall.ps1', 'scripts/uninstall.sh' $stage
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
Remove-Item -Recurse -Force $stage
Get-Item "dist/$name.zip" | Select-Object Name, Length | Format-Table
run: ./scripts/package.ps1 -OutDir dist -Platform '${{ matrix.platform }}' -Version '${{ inputs.tag || github.ref_name }}' -NoBuild
- name: checksum
shell: pwsh
run: |
@@ -229,9 +137,13 @@ jobs:
publish:
name: publish release
needs: build
needs: [build, validate]
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v4
with:
ref: ${{ inputs.tag || github.ref }}
- uses: actions/download-artifact@v4
with:
path: dist
@@ -244,5 +156,8 @@ jobs:
run: |
set -eu
ls -l dist
gh release view "$TAG" >/dev/null 2>&1 || gh release create "$TAG" --title "ChuSQL $TAG" --generate-notes
notes="docs/release-$TAG.md"
test -f "$notes"
gh release view "$TAG" >/dev/null 2>&1 || gh release create "$TAG" --title "ChuSQL $TAG" --notes-file "$notes" --verify-tag
gh release edit "$TAG" --notes-file "$notes"
gh release upload "$TAG" dist/* --clobber
+8 -3
View File
@@ -1,8 +1,13 @@
# ChuSQL
[![Release](docs/badges/release.svg)](https://github.com/TheBadRoger/ChuSQL/releases) [![Commit](docs/badges/commit.svg)](https://github.com/TheBadRoger/ChuSQL/commits/main) ![Haskell + Rust](docs/badges/languages.svg) [![Code lines](docs/badges/lines.svg)](scripts/update-code-lines.ps1)
[![Build](docs/badges/build.svg)](https://github.com/TheBadRoger/ChuSQL/actions/workflows/build.yml) [![Tests](docs/badges/tests.svg)](https://github.com/TheBadRoger/ChuSQL/actions/workflows/linux.yml) [![Gate](docs/badges/gate.svg)](https://github.com/TheBadRoger/ChuSQL/actions/workflows/gate.yml)
<p align="center">
<img src="https://img.shields.io/badge/Haskell-5e5086?style=flat-square" alt="Haskell">
<img src="https://img.shields.io/badge/Rust-dea584?style=flat-square" alt="Rust">
<a href="https://github.com/TheBadRoger/ChuSQL/actions/workflows/build.yml"><img src="https://img.shields.io/github/actions/workflow/status/TheBadRoger/ChuSQL/build.yml?branch=main&amp;label=build&amp;style=flat-square" alt="Build"></a>
<a href="https://github.com/TheBadRoger/ChuSQL/actions/workflows/linux.yml"><img src="https://img.shields.io/github/actions/workflow/status/TheBadRoger/ChuSQL/linux.yml?branch=main&amp;label=tests&amp;style=flat-square" alt="Tests"></a>
<a href="https://github.com/TheBadRoger/ChuSQL/releases"><img src="https://img.shields.io/github/v/release/TheBadRoger/ChuSQL?style=flat-square" alt="Release"></a>
<br>
</p>
ChuSQL 是采用 Haskell SQL 引擎与 Rust 存储层的数据库项目,提供 TCP 服务、CLI 和 Web 管理端。支持查询优化、快照事务、WAL 崩溃恢复、DOMAIN 自定义类型及用户与角色管理。
+6 -4
View File
@@ -32,7 +32,7 @@ import System.Environment (getArgs)
import System.Exit (ExitCode (..), exitFailure)
import System.FilePath ((</>))
import System.Info (os)
import System.IO (Handle, hGetLine)
import System.IO (Handle, hGetLine, hSetBuffering, BufferMode (LineBuffering), stdout)
import System.Process (
CreateProcess (std_err, std_out),
ProcessHandle,
@@ -484,6 +484,7 @@ stopProcess process = do
-- | 主入口
main :: IO ()
main = do
hSetBuffering stdout LineBuffering
args <- getArgs
unless (length args <= 2) (ioError (userError "usage: benchmark4csql [users=10000] [orders=50000]"))
let values = take 2 (args ++ drop (length args) ["10000", "50000"])
@@ -588,9 +589,10 @@ pressureScenarios bench u o = do
_ <- runSql bench "CREATE TABLE writes (id int, name str, age int)"
_ <- batchInsert bench "200 individual durable INSERTs" 200 (\i -> printf "INSERT INTO writes (id,name,age) VALUES (%d,'w%d',%d)" i i i)
(milliseconds, ()) <- measure $ do
_ <- runSql bench "BEGIN"
forM_ [201 .. 400 :: Int] $ \i -> runSql bench (printf "INSERT INTO writes (id,name,age) VALUES (%d,'w%d',%d)" i i i) >> pure ()
_ <- runSql bench "COMMIT"
(beginMs, _) <- measure (runSql bench "BEGIN")
(stagedMs, ()) <- measure $ forM_ [201 .. 400 :: Int] $ \i -> runSql bench (printf "INSERT INTO writes (id,name,age) VALUES (%d,'w%d',%d)" i i i) >> pure ()
(commitMs, _) <- measure (runSql bench "COMMIT")
printf "TXN_PHASE begin_ms=%.3f staged_ms=%.3f commit_ms=%.3f\n" beginMs stagedMs commitMs
pure ()
printf "WRITE transaction200 total_ms=%.3f rows_s=%.2f\n" milliseconds (200000 / milliseconds)
checkCount bench "writes" 400
+1 -1
View File
@@ -81,7 +81,7 @@ ready = A.object ["status" A..= ("system" :: Text), "initialized" A..= True]
-- | 带最高权限属性的身份响应
identity :: Bool -> A.Value
identity super = A.object ["status" A..= ("accounts" :: Text), "accounts" A..= [Account 1 "root" "existing-hash" 1 "" Nothing True super True False]]
identity super = A.object ["status" A..= ("accounts" :: Text), "accounts" A..= [Account 1 "root" "existing-hash" 1 "" Nothing True super True False False]]
-- | 已写入编号的类型响应
installed :: A.Value
+19 -6
View File
@@ -8,12 +8,14 @@ import ChuSQL.CLI.Script (stripTerminator)
import ChuSQL.Interface.Session (
Session,
authenticateSession,
authenticateSudoSession,
isPlainIdentifier,
newSession,
switchDatabase,
)
import ChuSQL.Interface.Config (ServerConfig (..), loadServerConfigAt, loadWebConfigAt, rootUserName)
import ChuSQL.Interface.Link (Client, closeClient, connectClient)
import ChuSQL.Interface.Sudo (SudoCredential, readSudoCredential)
import ChuSQL.Interface.TOML (resolveConfigPath)
import Control.Exception (finally)
import Control.Monad (unless)
@@ -38,6 +40,7 @@ data Options = Options
, optExecute :: Maybe Text
, optHistory :: Maybe FilePath
, optConfig :: Maybe FilePath
, optSudo :: Bool
}
-- | 命令行参数解析器
@@ -66,6 +69,7 @@ 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 "config" <> metavar "FILE" <> help "Config file to read (default: the fixed settings.toml under the system config directory)"))
<*> switch (long "sudo" <> help "Authenticate using the local root or elevated administrator identity")
-- | 把 --format 的取值解析成格式
formatReader :: String -> Either String OutputFormat
@@ -91,20 +95,29 @@ main = do
base <- loadWebConfigAt configPath
config <- loadServerConfigAt configPath
let rootName = rootUserName base
userName = fromMaybe rootName (optUser options)
password <- promptPassword userName
userName = fromMaybe (if optSudo options then scSudoUser config else rootName) (optUser options)
credential <- if optSudo options then do
if T.null userName then reportError "sudo_auth_user is not configured" >> exitFailure else pure ()
local <- readSudoCredential (scPort config)
case local of
Left message -> reportError message >> exitFailure
Right proof -> pure (Just proof)
else pure Nothing
password <- if optSudo options then pure "" else promptPassword userName
connected <- connectClient (T.pack (scHost config)) (scPort config)
case connected of
Left message -> reportError message >> exitFailure
Right client ->
connect options client userName password
connect options client userName password credential
`finally` closeClient client
-- | 连 server、登录,之后转入会话
connect :: Options -> Client -> Text -> Text -> IO ()
connect options client userName password = do
connect :: Options -> Client -> Text -> Text -> Maybe SudoCredential -> IO ()
connect options client userName password credential = do
session <- newSession client
signedIn <- authenticateSession session userName password
signedIn <- case credential of
Just proof -> authenticateSudoSession session proof userName
Nothing -> authenticateSession session userName password
case signedIn of
Left message -> reportError message >> exitFailure
Right () -> runSession options session
+2
View File
@@ -14,6 +14,7 @@ module ChuSQL.CLI.Format
import ChuSQL.Core.Model (Value (..))
import ChuSQL.Core.Protocol (QueryResult (..), queryResultJson)
import ChuSQL.Core.Runtime (renderRuntimeValue)
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as BL
import Data.Text (Text)
@@ -109,3 +110,4 @@ displayValue (VFloat d) = T.pack (show d)
displayValue (VStr s) = T.pack s
displayValue (VBool True) = "true"
displayValue (VBool False) = "false"
displayValue (VRuntime _ value) = T.pack (renderRuntimeValue value)
+6 -1
View File
@@ -2,12 +2,13 @@
module Main (main) where
import ChuSQL.CLI.Format (OutputFormat (..), parseFormat, renderCsv, renderJson, renderTable)
import ChuSQL.CLI.Format (OutputFormat (..), parseFormat, renderCsv, renderJson, renderTable, displayValue)
import ChuSQL.CLI.History (historySettings, rememberStatement)
import ChuSQL.CLI.Password (readPasswordInput)
import ChuSQL.CLI.Script (Meta (..), errorHint, parseMeta, statementComplete, stripTerminator, takeStatement)
import ChuSQL.Core.Model (Value (..))
import ChuSQL.Core.Protocol (QueryResult (..), queryResultJson)
import ChuSQL.Core.Runtime
import Data.Aeson (decode)
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as BL
@@ -30,6 +31,10 @@ main = hspec spec
-- | 全部测试用例
spec :: Spec
spec = do
it "renders typed compound values without losing their wire identity" $ do
case resolveType builtinTypes (listType intType) of
Left err -> expectationFailure err
Right descriptor -> displayValue (VRuntime (descriptorId descriptor) (RList [RInt 1, RInt 2])) `shouldBe` "[1, 2]"
formatSpec
scriptSpec
passwordSpec
@@ -22,6 +22,12 @@ library
ChuSQL.Core.Engine.Error
ChuSQL.Core.Engine
ChuSQL.Core.Engine.Parallel
ChuSQL.Core.Engine.Normalization
ChuSQL.Core.Engine.Runtime.Types
ChuSQL.Core.Engine.Runtime.Functions
ChuSQL.Core.Engine.Runtime.Binding
ChuSQL.Core.Engine.Runtime.SQL
ChuSQL.Core.Engine.Runtime.Query
ChuSQL.Core.Engine.Semantic
ChuSQL.Core.Engine.Storage
ChuSQL.Core.Engine.Storage.FFI
@@ -39,6 +45,7 @@ library
, scientific
, text
, unordered-containers
, vector
extra-libraries: chusql_core_storage
-- 运行期找 libchusql_core_storage.so:$ORIGIN 让二进制与动态库同目录即可
if os(linux)
@@ -51,6 +58,8 @@ library
test-suite chusql-core-engine-test
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules: NormalizationSpec
RuntimeSpec
hs-source-dirs: test
build-depends: base
, chusql-core-engine
@@ -59,5 +68,7 @@ test-suite chusql-core-engine-test
, filepath
, hashable
, hspec
, bytestring
, aeson
default-language: Haskell2010
ghc-options: -Wall -threaded
+10 -9
View File
@@ -1,11 +1,10 @@
module ChuSQL.Core.Engine (runStatement, runStatementM, rowsOf) where
import ChuSQL.Core.Engine.Algebra.Eval (evalCondForRowM, evalExprM, evalRelOpM)
import ChuSQL.Core.Engine.Algebra.Eval (evalCondForRowM, evalExprM)
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.Engine.Runtime.Query (bindQuery, executeQueryM)
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Semantic (prepare)
import ChuSQL.Core.Engine.Semantic (prepare, prepareRowExpression)
import ChuSQL.Core.Engine.Storage (MonadStorage (..))
import ChuSQL.Core.Engine.Storage.Memory (MemoryStorage (runMemoryStorage))
import ChuSQL.Core.Engine.Syntax.AST
@@ -41,13 +40,13 @@ runStatementM q = do
-- | 按语句类型分发(已检查过)
runStatementUncheckedM :: (MonadStorage m) => Database -> Statement -> m (Either String [Row])
runStatementUncheckedM db q@Select{} =
case translate q of
case bindQuery db q of
Left e -> pure (Left e)
Right relOp -> evalRelOpM db (optimize db relOp)
Right bound -> executeQueryM bound
runStatementUncheckedM db q@SelectExpr{} =
case translate q of
case bindQuery db q of
Left e -> pure (Left e)
Right relOp -> evalRelOpM db (optimize db relOp)
Right bound -> executeQueryM bound
runStatementUncheckedM db (Insert tbl cols rows) =
case lookupTable db tbl of
Left e -> pure (Left e)
@@ -241,7 +240,9 @@ checkPlan table = mapM parse (mapMaybe checked (tableCols table))
-- | 解析一列的 CHECK 文本
parse (name, text) = case parseExpression text of
Left err -> Left ("CHECK on " ++ name ++ ": " ++ firstLine err)
Right e -> Right (name, e)
Right e -> do
bound <- prepareRowExpression (tableCols table) e
Right (name, bound)
-- | 执行解析好的 CHECK 条件
runChecks :: CheckPlan -> Row -> Either String ()
@@ -36,6 +36,7 @@ valueLiteral (VInt n) = LitInt n
valueLiteral (VFloat d) = LitFloat d
valueLiteral (VStr s) = LitStr s
valueLiteral (VBool b) = LitBool b
valueLiteral (VRuntime tid value) = RuntimeLiteral tid value
valueLiteral VNull = LitNull
-- | 点查退化成扫描时用的条件
@@ -362,6 +363,18 @@ scalarResult rows = do
-- | 把子查询求值成字面量;子查询的错直接往上传
substSubqueries :: (MonadStorage m) => Database -> Expr -> Row -> m (Either String Expr)
substSubqueries db e env = case e of
Construct tid arguments -> do
bound <- mapM (\argument -> substSubqueries db argument env) arguments
pure (Construct tid <$> sequence bound)
BoundConstruct tid arguments -> do
bound <- mapM (\argument -> substSubqueries db argument env) arguments
pure (BoundConstruct tid <$> sequence bound)
FunctionCall name arguments -> do
bound <- mapM (\argument -> substSubqueries db argument env) arguments
pure (FunctionCall name <$> sequence bound)
BoundFunction fid tid arguments -> do
bound <- mapM (\argument -> substSubqueries db argument env) arguments
pure (BoundFunction fid tid <$> sequence bound)
ScalarSub sq -> scalarResult <$> runSubqueryRows db sq env
InSub a sq negated -> do
lhs <- substSubqueries db a env
@@ -3,6 +3,7 @@ module ChuSQL.Core.Engine.Algebra.Expr (evalExpr, evalCondForRow, colsInExpr, su
import ChuSQL.Core.Model
import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Engine.Builtin (Operator (..), compareNode, executeOperator, inValues, threeValuedNot)
import ChuSQL.Core.Engine.Runtime.SQL (invokeSQLFunction, constructSQLValue)
-- 表达式求值:三值逻辑,NULL 参与运算结果仍是 NULL。
@@ -10,6 +11,12 @@ import ChuSQL.Core.Engine.Builtin (Operator (..), compareNode, executeOperator,
evalExpr :: Expr -> Row -> Either String Value
evalExpr (Col name) row =
maybe (Left ("unknown column: " ++ name)) Right (lookup name row)
evalExpr (FunctionCall name _) _ = Left ("unbound function call: " ++ name)
evalExpr (Construct _ _) _ = Left "unbound runtime constructor"
evalExpr (BoundConstruct tid arguments) row = mapM (\argument -> evalExpr argument row) arguments >>= constructSQLValue tid
evalExpr (RuntimeLiteral tid value) _ = coerceValue (CRuntime tid) (VRuntime tid value)
evalExpr (BoundFunction fid tid arguments) row =
mapM (\argument -> evalExpr argument row) arguments >>= invokeSQLFunction fid tid
evalExpr LitNull _ = Right VNull
evalExpr (LitInt n) _ = Right (VInt n)
evalExpr (LitFloat d) _ = Right (VFloat d)
@@ -63,6 +70,10 @@ quantifiedCompare op lhs vs q = case vs of
-- | 表达式用到了哪些列
colsInExpr :: Expr -> [String]
colsInExpr (Col c) = [c]
colsInExpr (Construct _ arguments) = concatMap colsInExpr arguments
colsInExpr (BoundConstruct _ arguments) = concatMap colsInExpr arguments
colsInExpr (FunctionCall _ arguments) = concatMap colsInExpr arguments
colsInExpr (BoundFunction _ _ arguments) = concatMap colsInExpr arguments
colsInExpr (Add a b) = colsInExpr a ++ colsInExpr b
colsInExpr (Sub a b) = colsInExpr a ++ colsInExpr b
colsInExpr (Mul a b) = colsInExpr a ++ colsInExpr b
@@ -93,6 +104,10 @@ colsInExpr _ = []
-- | 表达式里子查询引用的外层列
subqueryRefsIn :: Expr -> [String]
subqueryRefsIn e = case e of
Construct _ arguments -> concatMap subqueryRefsIn arguments
BoundConstruct _ arguments -> concatMap subqueryRefsIn arguments
FunctionCall _ arguments -> concatMap subqueryRefsIn arguments
BoundFunction _ _ arguments -> concatMap subqueryRefsIn arguments
ScalarSub sq -> subqueryRefs sq
InSub a sq _ -> subqueryRefsIn a ++ subqueryRefs sq
InList a es _ -> concatMap subqueryRefsIn (a : es)
@@ -126,6 +141,10 @@ subqueryRefsIn e = case e of
-- | 表达式里有没有除法(除法可能报错,不能提前或延后求值)
hasDivision :: Expr -> Bool
hasDivision e = case e of
Construct _ arguments -> any hasDivision arguments
BoundConstruct _ arguments -> any hasDivision arguments
FunctionCall _ arguments -> any hasDivision arguments
BoundFunction _ _ arguments -> any hasDivision arguments
Div _ _ -> True
Neg a -> hasDivision a
Add a b -> both a b
@@ -148,6 +167,10 @@ hasDivision e = case e of
-- | 表达式里有没有子查询
hasSubquery :: Expr -> Bool
hasSubquery e = case e of
Construct _ arguments -> any hasSubquery arguments
BoundConstruct _ arguments -> any hasSubquery arguments
FunctionCall _ arguments -> any hasSubquery arguments
BoundFunction _ _ arguments -> any hasSubquery arguments
ScalarSub _ -> True
InSub _ _ _ -> True
InList a es _ -> any hasSubquery (a : es)
@@ -181,6 +204,10 @@ hasSubquery e = case e of
-- | 表达式里出现的聚合调用(按出现顺序)
aggregatesIn :: Expr -> [Expr]
aggregatesIn e = case e of
Construct _ arguments -> concatMap aggregatesIn arguments
BoundConstruct _ arguments -> concatMap aggregatesIn arguments
FunctionCall _ arguments -> concatMap aggregatesIn arguments
BoundFunction _ _ arguments -> concatMap aggregatesIn arguments
a@CountAll -> [a]
a@(CountOf _) -> [a]
a@(SumOf _) -> [a]
@@ -215,6 +242,10 @@ hasAggregate = not . null . aggregatesIn
-- | 聚合之外的列引用(聚合参数里的列不算)
bareColumns :: Expr -> [String]
bareColumns e = case e of
Construct _ arguments -> concatMap bareColumns arguments
BoundConstruct _ arguments -> concatMap bareColumns arguments
FunctionCall _ arguments -> concatMap bareColumns arguments
BoundFunction _ _ arguments -> concatMap bareColumns arguments
Col c -> [c]
Add a b -> both a b
Sub a b -> both a b
@@ -139,6 +139,7 @@ foldNode e
Right (VFloat d) -> LitFloat d
Right (VStr s) -> LitStr s
Right (VBool b) -> LitBool b
Right (VRuntime tid value) -> RuntimeLiteral tid value
Left _ -> e
| otherwise = e
@@ -149,6 +150,8 @@ foldConstants (Sub a b) = foldNode (Sub (foldConstants a) (foldConstants b))
foldConstants (Mul a b) = foldNode (Mul (foldConstants a) (foldConstants b))
foldConstants (Div a b) = foldNode (Div (foldConstants a) (foldConstants b))
foldConstants (Neg a) = foldNode (Neg (foldConstants a))
foldConstants (BoundConstruct tid arguments) = BoundConstruct tid (map foldConstants arguments)
foldConstants (BoundFunction fid tid arguments) = foldNode (BoundFunction fid tid (map foldConstants arguments))
foldConstants (Gt a b) = foldNode (Gt (foldConstants a) (foldConstants b))
foldConstants (Lt a b) = foldNode (Lt (foldConstants a) (foldConstants b))
foldConstants (Eq a b) = foldNode (Eq (foldConstants a) (foldConstants b))
@@ -37,6 +37,10 @@ rewriteAggs :: [(String, Expr)] -> Expr -> Expr
rewriteAggs aggs e = case [label | (label, agg) <- aggs, agg == e] of
(label : _) -> Col label
[] -> case e of
Construct tid arguments -> Construct tid (map go arguments)
BoundConstruct tid arguments -> BoundConstruct tid (map go arguments)
FunctionCall name arguments -> FunctionCall name (map go arguments)
BoundFunction fid tid arguments -> BoundFunction fid tid (map go arguments)
Add a b -> Add (go a) (go b)
Sub a b -> Sub (go a) (go b)
Mul a b -> Mul (go a) (go b)
@@ -0,0 +1,125 @@
module ChuSQL.Core.Engine.Normalization where
import ChuSQL.Core.Model (Column)
import Data.List (nub, sort, subsequences, (\\))
-- 只读范式分析:声明验证、阿姆斯特朗闭包、候选键与分解建议。
type Attributes = [String]
data Dependency = Dependency Attributes Attributes deriving (Eq, Show)
data Verdict = Satisfied | Violated | Insufficient deriving (Eq, Show)
data NormalForm = NF1 | NF2 | NF3 | BCNF deriving (Eq, Show)
data Declaration = Declaration
{ declaredKeys :: [Attributes]
, dependencies :: [Dependency]
, dependenciesComplete :: Bool
, atomicAttributes :: Maybe Bool
} deriving (Eq, Show)
data Finding = Finding
{ normalForm :: NormalForm
, verdict :: Verdict
, witnesses :: [Dependency]
, condition :: String
} deriving (Eq, Show)
data Decomposition = Decomposition
{ relations :: [Attributes]
, losslessJoin :: Verdict
, dependencyPreserving :: Verdict
} deriving (Eq, Show)
data Analysis = Analysis
{ candidateKeys :: [Attributes]
, findings :: [Finding]
, suggestions :: [Decomposition]
} deriving (Eq, Show)
-- 规范化属性集合。
canonical :: Attributes -> Attributes
canonical = sort . nub
-- 判断属性集合包含关系。
subset :: Attributes -> Attributes -> Bool
subset xs ys = all (`elem` ys) xs
-- 用自反、增广和传递规则求闭包。
attributeClosure :: [Dependency] -> Attributes -> Attributes
attributeClosure f seed = fixed (canonical seed)
where
-- 迭代加入已蕴含的属性。
fixed xs = let ys = canonical (xs ++ concat [b | Dependency a b <- f, subset a xs])
in if xs == ys then xs else fixed ys
-- 判断声明是否蕴含依赖。
implies :: [Dependency] -> Dependency -> Bool
implies f (Dependency a b) = subset b (attributeClosure f a)
-- 枚举最小超键。
keysOf :: Attributes -> [Dependency] -> [Attributes]
keysOf attrs f = [x | x <- subsequences attrs, super x,
all (not . super) [x \\ [a] | a <- x]]
where
-- 判断闭包是否覆盖关系。
super x = subset attrs (attributeClosure f x)
-- 投影关系上的全部非平凡依赖。
projectDependencies :: [Dependency] -> Attributes -> [Dependency]
projectDependencies f attrs =
[Dependency x [a] | x <- subsequences attrs,
a <- attributeClosure f x, a `elem` attrs, a `notElem` x]
-- 验证声明并生成只读范式报告。
analyzeNormalization :: [(String, Column)] -> Declaration -> Either String Analysis
analyzeNormalization schema declaration
| null attrs = Left "normalization: empty schema"
| length attrs /= length schema = Left "normalization: duplicate columns"
| length attrs > 12 = Left "normalization: exhaustive analysis supports at most 12 columns"
| any invalidDependency supplied = Left "normalization: unknown or duplicate dependency attributes"
| any invalidKey rawKeys = Left "normalization: unknown or duplicate key attributes"
| any (`notElem` keys) normalizedKeys = Left "normalization: declared candidate key is not minimal"
| otherwise = Right (Analysis keys results decompositions)
where
attrs = canonical (map fst schema)
supplied = dependencies declaration
rawKeys = declaredKeys declaration
normalizedKeys = map canonical rawKeys
f = supplied ++ [Dependency k attrs | k <- normalizedKeys]
keys = keysOf attrs f
prime = nub (concat keys)
complete = dependenciesComplete declaration
atomic = case atomicAttributes declaration of
Just True -> Satisfied
Just False -> Violated
Nothing -> Insufficient
allFDs = projectDependencies f attrs
partial = [d | d@(Dependency x [a]) <- allFDs, a `notElem` prime,
any (\k -> x /= k && subset x k) keys]
third = [d | d@(Dependency x [a]) <- allFDs, a `notElem` prime,
not (subset attrs (attributeClosure f x))]
boyce = [d | d@(Dependency x _) <- allFDs,
not (subset attrs (attributeClosure f x))]
results = Finding NF1 atomic [] "attributes must have atomic domains; requires an explicit declaration" :
[classify NF2 partial, classify NF3 third, classify BCNF boyce]
decompositions = [split d | d <- take 1 boyce, complete, atomic == Satisfied]
-- 校验字段集合。
valid xs = length xs == length (canonical xs) && subset xs attrs
-- 校验依赖声明。
invalidDependency (Dependency a b) = not (valid a && valid b) || null b
-- 校验候选键声明。
invalidKey k = not (valid k)
-- 结合声明完整性判定范式。
classify nf ds = Finding nf status (if complete then ds else []) (rule nf)
where
status | atomic == Violated = Violated
| atomic == Insufficient || not complete = Insufficient
| null ds = Satisfied
| otherwise = Violated
-- 说明各范式的必要条件。
rule NF1 = "attributes must have atomic domains"
rule NF2 = "no nonprime attribute depends on a proper subset of any candidate key"
rule NF3 = "each nontrivial dependency has a superkey determinant or a prime dependent"
rule BCNF = "each nontrivial dependency has a superkey determinant"
-- 按违反依赖生成一次无损分解。
split (Dependency x y) = Decomposition parts Satisfied preservation
where
parts = [canonical (x ++ y), attrs \\ (y \\ x)]
projected = concatMap (projectDependencies f) parts
preservation = if all (implies projected) f then Satisfied else Violated
@@ -0,0 +1,177 @@
module ChuSQL.Core.Engine.Runtime.Binding
( Expression (..), TypedExpression, expressionType, bindExpression, evaluateExpression
, Plan (..), TypedPlan, planSchema, bindPlan, executePlan
) where
import ChuSQL.Core.Engine.Runtime.Types
import ChuSQL.Core.Engine.Runtime.Functions
import Control.Monad (filterM)
import Data.List (nub, sort)
-- 仅依据 schema 绑定表达式与查询,执行已解析的类型和函数身份。
-- | 表达未绑定的类型化语言
data Expression = Literal TypeExpr RuntimeValue | Reference String | Apply String [Expression]
| ListLiteral TypeExpr [Expression] | NothingLiteral TypeExpr | JustLiteral Expression
| TupleLiteral [Expression] deriving (Show, Eq)
-- | 保存绑定后的表达式节点
data ExpressionNode = Constant RuntimeValue | BoundReference String | BoundApply FunctionId [TypedExpression]
| BoundList [TypedExpression] | BoundNothing | BoundJust TypedExpression | BoundTuple [TypedExpression]
deriving (Show, Eq)
-- | 保存表达式的确定类型
data TypedExpression = TypedExpression TypeId ExpressionNode deriving (Show, Eq)
-- | 提取表达式类型身份
expressionType :: TypedExpression -> TypeId
expressionType (TypedExpression tid _) = tid
-- | 绑定类型、列与函数身份
bindExpression :: TypeRegistry -> FunctionRegistry -> [(String, TypeId)] -> Expression -> Either String TypedExpression
bindExpression types functions env expression = case expression of
Literal ty value -> do
tid <- descriptorId <$> resolveType types ty
validateValue types tid value
Right (TypedExpression tid (Constant value))
Reference name -> case [tid | (key, tid) <- env, key == name] of
[tid] -> describeType types tid >> Right (TypedExpression tid (BoundReference name))
[] -> Left ("unknown column: " ++ name)
_ -> Left ("ambiguous column: " ++ name)
Apply name arguments -> do
bound <- mapM bind arguments
sig <- resolveFunction functions name (map expressionType bound)
Right (TypedExpression (signatureResult sig) (BoundApply (signatureId sig) bound))
ListLiteral child arguments -> do
childId <- descriptorId <$> resolveType types child
bound <- mapM bind arguments
if all ((== childId) . expressionType) bound
then compound (listType child) (BoundList bound)
else Left "list element type mismatch"
NothingLiteral child -> compound (maybeType child) BoundNothing
JustLiteral argument -> do
bound <- bind argument
compound (maybeType (typeExpression (expressionType bound))) (BoundJust bound)
TupleLiteral arguments -> do
bound <- mapM bind arguments
compound (tupleType (map (typeExpression . expressionType) bound)) (BoundTuple bound)
where
-- | 绑定当前作用域的子表达式
bind = bindExpression types functions env
-- | 校验并构造复合表达式
compound ty node = do
tid <- descriptorId <$> resolveType types ty
Right (TypedExpression tid node)
-- | 执行已绑定表达式并校验输出
evaluateExpression :: TypeRegistry -> FunctionRegistry -> [(String, RuntimeValue)] -> TypedExpression -> Either String RuntimeValue
evaluateExpression types functions row (TypedExpression tid node) = do
value <- case node of
Constant v -> Right v
BoundReference name -> case [v | (key, v) <- row, key == name] of
[v] -> Right v
[] -> Left ("missing bound column: " ++ name)
_ -> Left ("duplicate bound column: " ++ name)
BoundApply fid arguments -> mapM evaluate arguments >>= invokeFunction types functions fid
BoundList arguments -> RList <$> mapM evaluate arguments
BoundNothing -> Right (RMaybe Nothing)
BoundJust argument -> RMaybe . Just <$> evaluate argument
BoundTuple arguments -> RTuple <$> mapM evaluate arguments
validateValue types tid value
Right value
where
-- | 执行当前行的子表达式
evaluate = evaluateExpression types functions row
-- | 表达未绑定的关系计划
data Plan = TableScan String | SingleRow | Projection [(String, Expression)] Plan
| Selection Expression Plan deriving (Show, Eq)
-- | 保存绑定后的关系节点
data PlanNode = BoundScan String | BoundSingleRow | BoundProjection [(String, TypedExpression)] TypedPlan
| BoundSelection TypedExpression TypedPlan deriving (Show, Eq)
-- | 保存输出 schema 和关系节点
data TypedPlan = TypedPlan [(String, TypeId)] PlanNode deriving (Show, Eq)
-- | 提取计划的输出 schema
planSchema :: TypedPlan -> [(String, TypeId)]
planSchema (TypedPlan output _) = output
-- | 使用目录 schema 绑定查询计划
bindPlan :: TypeRegistry -> FunctionRegistry -> [(String, [(String, TypeExpr)])] -> Plan -> Either String TypedPlan
bindPlan types functions catalog plan = case plan of
TableScan name -> case [columns | (key, columns) <- catalog, key == name] of
[columns] -> do
uniqueNames (map fst columns)
bound <- mapM bindColumn columns
Right (TypedPlan bound (BoundScan name))
[] -> Left ("unknown table: " ++ name)
_ -> Left ("ambiguous table: " ++ name)
SingleRow -> Right (TypedPlan [] BoundSingleRow)
Projection items source -> do
child <- bind source
uniqueNames (map fst items)
bound <- mapM (bindItem (planSchema child)) items
Right (TypedPlan [(name, expressionType value) | (name, value) <- bound] (BoundProjection bound child))
Selection condition source -> do
child <- bind source
predicate <- bindExpression types functions (planSchema child) condition
bool <- descriptorId <$> resolveType types boolType
if expressionType predicate == bool
then Right (TypedPlan (planSchema child) (BoundSelection predicate child))
else Left "selection predicate must be Bool"
where
-- | 绑定子计划
bind = bindPlan types functions catalog
-- | 解析 schema 列的类型身份
bindColumn (name, ty) = do
tid <- descriptorId <$> resolveType types ty
Right (name, tid)
-- | 绑定投影项
bindItem env (name, value) = do
bound <- bindExpression types functions env value
Right (name, bound)
-- | 拒绝重复输出列
uniqueNames :: [String] -> Either String ()
uniqueNames names
| nub names == names = Right ()
| otherwise = Left "duplicate schema column"
-- | 执行绑定计划并校验存储返回值
executePlan :: TypeRegistry -> FunctionRegistry -> (String -> Either String [[(String, RuntimeValue)]])
-> TypedPlan -> Either String [[(String, RuntimeValue)]]
executePlan types functions scan (TypedPlan output node) = do
rows <- case node of
BoundScan name -> scan name
BoundSingleRow -> Right [[]]
BoundProjection items child -> do
input <- executePlan types functions scan child
mapM (project items) input
BoundSelection condition child -> do
input <- executePlan types functions scan child
filterM (keep condition) input
mapM_ (validateRow output) rows
Right [[(name, value) | (name, _) <- output, Just value <- [lookup name row]] | row <- rows]
where
-- | 计算一行的投影项
project items row = mapM (projectItem row) items
-- | 计算命名输出项
projectItem row (name, expression) = do
value <- evaluateExpression types functions row expression
Right (name, value)
-- | 计算选择条件
keep condition row = do
value <- evaluateExpression types functions row condition
case value of
RBool result -> Right result
_ -> Left "bound predicate returned a non-Bool value"
-- | 校验存储行的完整 schema
validateRow columns row
| sort (map fst row) /= sort (map fst columns) = Left "storage row schema mismatch"
| otherwise = mapM_ (validateColumn row) columns
-- | 按列名校验返回值的类型
validateColumn row (name, tid) = case lookup name row of
Just value -> validateValue types tid value
Nothing -> Left ("missing bound column: " ++ name)
@@ -0,0 +1,83 @@
module ChuSQL.Core.Engine.Runtime.Functions
( FunctionId (..), FunctionSignature (..), FunctionRegistry
, builtinFunctions, resolveFunction, resolveNullableFunction, functionSignature, invokeFunction
) where
import ChuSQL.Core.Engine.Runtime.Types
import Data.Char (toLower)
-- 内建函数的固定身份、签名解析和类型化调用。
-- | 标识稳定的内建函数
newtype FunctionId = FunctionId Int deriving (Show, Eq, Ord)
-- | 描述已解析的函数签名
data FunctionSignature = FunctionSignature
{ signatureId :: FunctionId, signatureName :: String
, signatureArguments :: [TypeId], signatureResult :: TypeId
} deriving (Show, Eq)
-- | 保存函数签名和实现
newtype FunctionRegistry = FunctionRegistry [(FunctionSignature, [RuntimeValue] -> Either String RuntimeValue)]
-- | 从内建元数据恢复函数注册表
builtinFunctions :: TypeRegistry -> Either String FunctionRegistry
builtinFunctions types = do
int <- descriptorId <$> resolveType types intType
bool <- descriptorId <$> resolveType types boolType
string <- descriptorId <$> resolveType types stringType
Right (FunctionRegistry
[(FunctionSignature (FunctionId 1) "length" [string] int, stringLength)
,(FunctionSignature (FunctionId 2) "not" [bool] bool, booleanNot)])
-- | 按名称和完整参数类型解析函数
resolveFunction :: FunctionRegistry -> String -> [TypeId] -> Either String FunctionSignature
resolveFunction (FunctionRegistry functions) name arguments =
case [sig | (sig, _) <- functions, map toLower (signatureName sig) == map toLower name
, signatureArguments sig == arguments] of
[sig] -> Right sig
[] -> Left ("no matching function signature: " ++ name)
_ -> Left ("ambiguous function signature: " ++ name)
-- | 按可空 SQL 参数解析确定签名
resolveNullableFunction :: FunctionRegistry -> String -> [Maybe TypeId] -> Either String FunctionSignature
resolveNullableFunction (FunctionRegistry functions) name arguments =
case [sig | (sig, _) <- functions, map toLower (signatureName sig) == map toLower name
, length arguments == length (signatureArguments sig)
, and (zipWith matches arguments (signatureArguments sig))] of
[sig] -> Right sig
[] -> Left ("no matching function signature: " ++ name)
_ -> Left ("ambiguous function signature: " ++ name)
where
-- | 匹配具体参数或未定型 NULL
matches Nothing _ = True
matches (Just supplied) expected = supplied == expected
-- | 按固定身份查找函数签名
functionSignature :: FunctionRegistry -> FunctionId -> Either String FunctionSignature
functionSignature (FunctionRegistry functions) fid = case [sig | (sig, _) <- functions, signatureId sig == fid] of
[sig] -> Right sig
_ -> Left ("unknown function identity: " ++ show fid)
-- | 校验参数并执行已解析的函数
invokeFunction :: TypeRegistry -> FunctionRegistry -> FunctionId -> [RuntimeValue] -> Either String RuntimeValue
invokeFunction types (FunctionRegistry functions) fid values =
case [(sig, implementation) | (sig, implementation) <- functions, signatureId sig == fid] of
[(sig, implementation)]
| length values == length (signatureArguments sig) -> do
sequence_ (zipWith (validateValue types) (signatureArguments sig) values)
result <- implementation values
validateValue types (signatureResult sig) result
Right result
| otherwise -> Left "function argument count mismatch"
_ -> Left ("unknown function identity: " ++ show fid)
-- | 计算字符串字符个数
stringLength :: [RuntimeValue] -> Either String RuntimeValue
stringLength [RString text] = Right (RInt (length text))
stringLength _ = Left "length expects String"
-- | 计算布尔取反
booleanNot :: [RuntimeValue] -> Either String RuntimeValue
booleanNot [RBool value] = Right (RBool (not value))
booleanNot _ = Left "not expects Bool"
@@ -0,0 +1,65 @@
module ChuSQL.Core.Engine.Runtime.Query
( BoundQuery, QueryType (..), queryTypes, bindQuery, executeQueryM
) where
import ChuSQL.Core.Engine.Algebra.Eval (evalRelOpM)
import ChuSQL.Core.Engine.Algebra.Op (RelOp)
import ChuSQL.Core.Engine.Algebra.Optimize (optimize)
import ChuSQL.Core.Engine.Algebra.Planner (translate)
import ChuSQL.Core.Engine.Semantic (prepare, querySchema)
import ChuSQL.Core.Engine.Syntax.AST (Statement)
import ChuSQL.Core.Engine.Storage (MonadStorage)
import ChuSQL.Core.Engine.Runtime.SQL (sqlType)
import ChuSQL.Core.Engine.Runtime.Types (TypeId)
import ChuSQL.Core.Model
-- SQL 查询绑定边界:保存解析后的类型、函数身份及输出 schema。
-- | 保存运行时或兼容列类型
data QueryType = RuntimeType TypeId | CompatibilityType ColumnType | NullType deriving (Show, Eq)
-- | 保存仅由 schema 绑定的执行计划
data BoundQuery = BoundQuery Database [(String, Column)] [(String, QueryType)] RelOp
-- | 查询绑定计划的输出类型身份
queryTypes :: BoundQuery -> [(String, QueryType)]
queryTypes (BoundQuery _ _ types _) = types
-- | 绑定 SQL 查询并优化确定的计划
bindQuery :: Database -> Statement -> Either String BoundQuery
bindQuery catalog statement = do
let schemaOnly = [(name, table {tableRows = []}) | (name, table) <- catalog]
resolved <- prepare schemaOnly statement
columns <- querySchema schemaOnly resolved
plan <- translate resolved
types <- mapM typeOf columns
Right (BoundQuery schemaOnly columns types (optimize schemaOnly plan))
where
-- | 解析输出列的运行时身份
typeOf (name, column) = do
ty <- bindingType (columnType column)
Right (name, ty)
-- | 保留阶段外类型的兼容表示
bindingType CNull = Right NullType
bindingType CDate = Right (CompatibilityType CDate)
bindingType CTimestamp = Right (CompatibilityType CTimestamp)
bindingType CBlob = Right (CompatibilityType CBlob)
bindingType ty@(CDomain _ base)
| typeClassOf base == TemporalClass || base == CBlob = Right (CompatibilityType ty)
bindingType ty = RuntimeType <$> sqlType ty
-- | 执行绑定查询并校验输出类型
executeQueryM :: MonadStorage m => BoundQuery -> m (Either String [Row])
executeQueryM (BoundQuery catalog columns _ plan) = do
result <- evalRelOpM catalog plan
pure (result >>= mapM validateRow)
where
-- | 校验完整输出行而不重新解析函数
validateRow row
| map fst row /= map fst columns = Left "bound query output schema mismatch"
| otherwise = mapM validateColumn (zip columns row)
-- | 校验输出列的物理值
validateColumn ((name, column), (_, value))
| columnType column == CNull, value == VNull = Right (name, value)
| valueFits (columnType column) value = Right (name, value)
| otherwise = Left ("bound query output type mismatch: " ++ name)
@@ -0,0 +1,92 @@
module ChuSQL.Core.Engine.Runtime.SQL (resolveSQLFunction, sqlResultType, invokeSQLFunction, sqlType, constructSQLValue) where
import ChuSQL.Core.Engine.Runtime.Types
import ChuSQL.Core.Engine.Runtime.Functions
import ChuSQL.Core.Model (ColumnType (..), Value (..))
-- SQL 现有标量表示与已解析运行时函数之间的类型边界。
-- | 解析 SQL 标量调用的固定签名
resolveSQLFunction :: String -> [Maybe ColumnType] -> Either String FunctionSignature
resolveSQLFunction name arguments = do
functions <- builtinFunctions builtinTypes
types <- mapM (traverse sqlType) arguments
resolveNullableFunction functions name types
-- | 解析现有标量列的逻辑类型
sqlType :: ColumnType -> Either String TypeId
sqlType (CDomain _ base) = sqlType base
sqlType (CRuntime tid) = describeType builtinTypes tid >> Right tid
sqlType ty = do
expression <- case ty of
CInt -> Right intType
CBigInt -> Right intType
CSmallInt -> Right intType
CFloat -> Right doubleType
CDouble -> Right doubleType
CDecimal{} -> Right doubleType
CBool -> Right boolType
CStr -> Right stringType
CVarchar{} -> Right stringType
CChar{} -> Right stringType
_ -> Left ("unsupported runtime function argument type: " ++ show ty)
descriptorId <$> resolveType builtinTypes expression
-- | 将函数输出类型映射为 SQL schema
sqlResultType :: TypeId -> Either String ColumnType
sqlResultType tid
| typeExpression tid == intType = Right CInt
| typeExpression tid == doubleType = Right CDouble
| typeExpression tid == boolType = Right CBool
| typeExpression tid == stringType = Right CStr
| otherwise = Left "runtime function result needs a composite SQL representation"
-- | 执行固定身份的 SQL 标量函数
invokeSQLFunction :: FunctionId -> TypeId -> [Value] -> Either String Value
invokeSQLFunction fid expected values = do
functions <- builtinFunctions builtinTypes
sig <- functionSignature functions fid
if signatureResult sig /= expected then Left "bound function result identity mismatch"
else if length values /= length (signatureArguments sig) then Left "function argument count mismatch"
else do
sequence_ (zipWith validateArgument (signatureArguments sig) values)
if VNull `elem` values then Right VNull else do
arguments <- mapM runtimeValue values
result <- invokeFunction builtinTypes functions fid arguments
sqlValue result
where
-- | 校验具体参数并保留 SQL NULL
validateArgument _ VNull = Right ()
validateArgument tid value = runtimeValue value >>= validateValue builtinTypes tid
-- | 转换现有 SQL 标量值
runtimeValue :: Value -> Either String RuntimeValue
runtimeValue (VInt n) = Right (RInt n)
runtimeValue (VFloat n) = Right (RDouble n)
runtimeValue (VBool b) = Right (RBool b)
runtimeValue (VStr text) = Right (RString text)
runtimeValue (VRuntime tid value) = validateValue builtinTypes tid value >> Right value
runtimeValue VNull = Left "untyped SQL NULL has no runtime scalar value"
-- | 转换运行时标量结果
sqlValue :: RuntimeValue -> Either String Value
sqlValue (RInt n) = Right (VInt n)
sqlValue (RDouble n) = Right (VFloat n)
sqlValue (RBool b) = Right (VBool b)
sqlValue (RString text) = Right (VStr text)
sqlValue _ = Left "composite runtime result has no SQL scalar representation"
-- | 按已解析构造器生成类型化值
constructSQLValue :: TypeId -> [Value] -> Either String Value
constructSQLValue tid values = do
arguments <- mapM runtimeValue values
value <- case typeExpression tid of
TypeApply (TypeConstructorId 5) [_] -> Right (RList arguments)
TypeApply (TypeConstructorId 6) [_] -> case arguments of
[] -> Right (RMaybe Nothing)
[argument] -> Right (RMaybe (Just argument))
_ -> Left "Maybe constructor expects zero or one argument"
TypeApply (TypeConstructorId 7) _ -> Right (RTuple arguments)
_ -> Left "type is not a composite constructor"
validateValue builtinTypes tid value
Right (VRuntime tid value)
@@ -0,0 +1,5 @@
module ChuSQL.Core.Engine.Runtime.Types (module ChuSQL.Core.Runtime) where
import ChuSQL.Core.Runtime
-- 导出共享的运行时类型身份和物理编码契约。
@@ -1,9 +1,12 @@
module ChuSQL.Core.Engine.Semantic (check, prepare) where
module ChuSQL.Core.Engine.Semantic (check, prepare, prepareRowExpression, querySchema) where
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 ChuSQL.Core.Engine.Runtime.Functions (FunctionSignature (..), builtinFunctions, functionSignature)
import ChuSQL.Core.Engine.Runtime.SQL (resolveSQLFunction, sqlResultType, sqlType)
import ChuSQL.Core.Engine.Runtime.Types
import Data.Char (isAlphaNum, isAscii, toLower)
import Data.List (intercalate, isInfixOf, isPrefixOf, isSuffixOf, nub)
@@ -21,6 +24,12 @@ prefixColumns mAlias cols = [(prefix ++ c, ty) | (c, ty) <- cols]
where
prefix = maybe "" (++ ".") mAlias
-- | 从 schema 推导查询输出列
querySchema :: Database -> Statement -> Either String [(String, Column)]
querySchema db statement = do
columns <- inferSubqueryOutput db (Scope [] []) (Subquery statement [])
Right [(name, plainColumn (derivedType ty)) | (name, ty) <- columns]
-- | 检查期的作用域:本层优先,外层兜底
data Scope = Scope
{ scopeInner :: [(String, Column)]
@@ -103,6 +112,7 @@ checkGrouping env keys items
| null keys && not (any (hasAggregate . snd) items) = Right ()
| otherwise = do
checkColumns "GROUP BY" env keys
mapM_ (checkRuntimeColumn "GROUP BY" env) keys
mapM_ okCol (nub (concatMap (bareColumns . snd) items))
where
-- | 这一列能不能出现在分组查询里
@@ -127,6 +137,23 @@ inferExpr _ _ _ (LitBool _) = Right (InferType CBool)
inferExpr _ _ _ (LitDate _) = Right (InferType CDate)
inferExpr _ _ _ (LitTimestamp _) = Right (InferType CTimestamp)
inferExpr _ _ _ (LitBlob _) = Right (InferType CBlob)
inferExpr db place env (Construct ty arguments) = InferType . CRuntime <$> inferConstruction db place env ty arguments
inferExpr db place env (BoundConstruct tid arguments) = do
inferred <- inferConstruction db place env (typeExpression tid) arguments
if inferred == tid then Right (InferType (CRuntime tid)) else Left "constructor result identity mismatch"
inferExpr _ _ _ (RuntimeLiteral tid value) = validateValue builtinTypes tid value >> Right (InferType (CRuntime tid))
inferExpr db place env (FunctionCall name arguments) = do
inferred <- mapM (inferExpr db place env) arguments
sig <- resolveSQLFunction name (map inferredArgument inferred)
InferType <$> sqlResultType (signatureResult sig)
inferExpr db place env (BoundFunction fid tid arguments) = do
functions <- builtinFunctions builtinTypes
expected <- functionSignature functions fid
inferred <- mapM (inferExpr db place env) arguments
resolved <- resolveSQLFunction (signatureName expected) (map inferredArgument inferred)
if signatureId resolved == fid && signatureResult resolved == tid
then InferType <$> sqlResultType tid
else Left "bound function signature identity mismatch"
inferExpr db place env (Add a b) = arithmetic db place env a b
inferExpr db place env (Sub a b) = arithmetic db place env a b
inferExpr db place env (Mul a b) = arithmetic db place env a b
@@ -160,8 +187,8 @@ inferExpr db place env (AvgOf a) = do
InferType x
| numericType x -> Right (InferType CFloat)
| otherwise -> Left (place ++ ": AVG needs a number, got " ++ typeLabel x)
inferExpr db place env (MinOf a) = aggregateArg db place env a
inferExpr db place env (MaxOf a) = aggregateArg db place env a
inferExpr db place env (MinOf a) = aggregateArg db place env a >>= requireOrdering "MIN"
inferExpr db place env (MaxOf a) = aggregateArg db place env a >>= requireOrdering "MAX"
inferExpr db place env (ScalarSub sq) = do
cols <- inferSubqueryOutput db env sq
case cols of
@@ -386,18 +413,18 @@ ddlTargets statement = case statement of
-- | 从 schema 解析列上的命名类型
resolveDomainTypes :: Database -> Statement -> Either String Statement
resolveDomainTypes db statement = case statement of
CreateDomain name base -> CreateDomain name <$> resolveType base
CreateDomain name base -> CreateDomain name <$> resolveDomainType base
CreateTable name cols -> CreateTable name <$> mapM resolveColumnType cols
AddColumn name col -> AddColumn name <$> resolveColumnType col
AlterColumnType name col ty -> AlterColumnType name col <$> resolveType ty
AlterColumnType name col ty -> AlterColumnType name col <$> resolveDomainType ty
_ -> Right statement
where
-- | 解析一列的类型
resolveColumnType (name, col) = do
ty <- resolveType (columnType col)
ty <- resolveDomainType (columnType col)
Right (name, col {columnType = ty})
-- | 从类型目录取基础类型
resolveType = resolveWith []
resolveDomainType = resolveWith []
-- | 递归解析类型并拒绝循环定义
resolveWith seen (CDomain name _)
| map toLower name `elem` seen = Left ("cyclic domain definition: " ++ name)
@@ -427,6 +454,7 @@ checkResolvedWith db outer q = case q of
checkColumns "SELECT" full cols
checkGrouping full groupBy (map (\c -> (c, Col c)) cols)
checkColumns "ORDER BY" full (map fst orderBy)
mapM_ (checkRuntimeColumn "ORDER BY" full . fst) orderBy
mapM_ (checkNoAggregate "WHERE") mWhere
mapM_ (checkBool db "WHERE" full) mWhere
SelectExpr items fromC mWhere groupBy orderBy _ -> do
@@ -434,7 +462,7 @@ checkResolvedWith db outer q = case q of
let full = Scope env outer
mapM_ (\item -> () <$ inferExpr db "SELECT" full (snd item)) items
checkGrouping full groupBy (items ++ [(c, Col c) | (c, _) <- orderBy, c `notElem` map fst items])
mapM_ (checkOrder full items . fst) orderBy
mapM_ (checkOrder db full items . fst) orderBy
mapM_ (checkNoAggregate "WHERE") mWhere
mapM_ (checkBool db "WHERE" full) mWhere
Insert tbl cols rows -> do
@@ -468,7 +496,7 @@ checkResolvedWith db outer q = case q of
CreateIndex tbl col -> do
t <- lookupTable db tbl
if col `elem` tableCols' t
then Right ()
then checkRuntimeColumn "CREATE INDEX" (Scope (tableCols t) []) col
else Left ("CREATE INDEX: unknown column: " ++ col)
DropIndex tbl col -> do
t <- lookupTable db tbl
@@ -581,14 +609,22 @@ checkColumnDefs names cols = do
mapM_ (checkTypeParameters . columnType . snd) cols
mapM_ (\(_, c) -> mapM_ (checkDefault c) (columnDefault c)) cols
mapM_ (\(_, c) -> checkAutoIncrement c) cols
mapM_ checkRuntimeKey cols
if length [() | (_, c) <- cols, columnAutoIncrement c] > 1
then Left "CREATE TABLE: at most one AUTO_INCREMENT column is allowed"
else Right ()
checkChecks names cols
where
-- | 拒绝缺少能力实现的运行时键
checkRuntimeKey (_, column)
| typeClassOf (columnType column) == RuntimeClass
, columnUnique column || columnPrimaryKey column = Left "runtime type key capability is not registered"
| otherwise = Right ()
-- | 校验列类型的长度和精度参数
checkTypeParameters :: ColumnType -> Either String ()
checkTypeParameters (CDomain _ base) = checkTypeParameters base
checkTypeParameters (CRuntime tid) = () <$ describeType builtinTypes tid
checkTypeParameters CNull = Left "NULL is only valid as an inferred query output"
checkTypeParameters (CDecimal p s)
| p <= 0 || p > 308 || s < 0 || s > p = Left "invalid decimal precision or scale"
@@ -707,6 +743,17 @@ resolveExpr ::
Expr ->
Either String Expr
resolveExpr db env outer f e = case e of
Construct ty arguments -> do
tid <- inferConstruction db "constructor" (Scope env outer) ty arguments
bound <- mapM (resolveExpr db env outer f) arguments
Right (BoundConstruct tid bound)
BoundConstruct tid arguments -> BoundConstruct tid <$> mapM (resolveExpr db env outer f) arguments
FunctionCall name arguments -> do
inferred <- mapM (inferExpr db "function" (Scope env outer)) arguments
sig <- resolveSQLFunction name (map inferredArgument inferred)
bound <- mapM (resolveExpr db env outer f) arguments
Right (BoundFunction (signatureId sig) (signatureResult sig) bound)
BoundFunction fid tid arguments -> BoundFunction fid tid <$> mapM (resolveExpr db env outer f) arguments
Col c -> Col <$> f c
Add a b -> binary Add a b
Sub a b -> binary Sub a b
@@ -739,6 +786,36 @@ resolveExpr db env outer f e = case e of
-- | 递归处理两个子表达式
binary ctor a b = ctor <$> resolveExpr db env outer f a <*> resolveExpr db env outer f b
-- | 校验具体构造器和参数逻辑类型
inferConstruction :: Database -> String -> Scope -> TypeExpr -> [Expr] -> Either String TypeId
inferConstruction db place env ty@(TypeApply cid parameters) arguments = do
descriptor <- resolveType builtinTypes ty
expected <- case (cid, parameters) of
(TypeConstructorId 5, [child]) -> Right (replicate (length arguments) child)
(TypeConstructorId 6, [child]) | length arguments <= 1 -> Right (replicate (length arguments) child)
(TypeConstructorId 7, fields) | length fields == length arguments -> Right fields
_ -> Left "composite constructor argument count mismatch"
inferred <- mapM (inferExpr db place env) arguments
supplied <- mapM argumentIdentity inferred
required <- mapM (fmap descriptorId . resolveType builtinTypes) expected
if supplied == required then Right (descriptorId descriptor) else Left "composite constructor argument type mismatch"
where
-- | 解析非空参数的逻辑类型身份
argumentIdentity InferNull = Left "SQL NULL needs Maybe construction inside a runtime value"
argumentIdentity (InferType column) = sqlType column
-- | 使用单行 schema 绑定表达式
prepareRowExpression :: [(String, Column)] -> Expr -> Either String Expr
prepareRowExpression columns expression = do
bound <- resolveExpr [] columns [] (nameIn columns "expression") expression
_ <- inferExpr [] "expression" (Scope columns []) bound
Right bound
-- | 将推导类型转换为可空参数类型
inferredArgument :: InferredType -> Maybe ColumnType
inferredArgument InferNull = Nothing
inferredArgument (InferType ty) = Just ty
-- | 解析子查询,并记下它引用的外层列
resolveSubquery :: Database -> [(String, Column)] -> Subquery -> Either String Subquery
resolveSubquery db outer sq = do
@@ -822,12 +899,25 @@ resolveSelect db q@SelectExpr{} = resolveQuery db [] q (selectItems q)
resolveSelect _ q = Right q
-- | 检查排序输出别名或来源列
checkOrder :: Scope -> [(String, Expr)] -> String -> Either String ()
checkOrder env items column = case [e | (label, e) <- items, label == column] of
[] -> checkColumns "ORDER BY" env [column]
[_] -> Right ()
checkOrder :: Database -> Scope -> [(String, Expr)] -> String -> Either String ()
checkOrder db env items column = case [e | (label, e) <- items, label == column] of
[] -> checkRuntimeColumn "ORDER BY" env column
[expression] -> () <$ (inferExpr db "ORDER BY" env expression >>= requireOrdering "ORDER BY")
_ -> Left ("ORDER BY: ambiguous projection alias: " ++ column)
-- | 校验列已有排序能力
checkRuntimeColumn :: String -> Scope -> String -> Either String ()
checkRuntimeColumn place env column = do
(_, definition) <- scopeAt place env column
() <$ requireOrdering place (InferType (columnType definition))
-- | 拒绝尚未注册能力的复合类型
requireOrdering :: String -> InferredType -> Either String InferredType
requireOrdering place inferred@(InferType ty)
| typeClassOf ty == RuntimeClass = Left (place ++ ": runtime type capability is not registered")
| otherwise = Right inferred
requireOrdering _ inferred = Right inferred
-- | 解析投影、条件、排序与连接引用
resolveQuery :: Database -> [(String, Column)] -> Statement -> [(String, Expr)] -> Either String Statement
resolveQuery db outer q items = do
@@ -1,6 +1,8 @@
module ChuSQL.Core.Engine.Syntax.AST (Statement (..), FromClause (..), JoinKind (..), Expr (..), Subquery (..), Quantifier (..), CompareOp (..), SortDir (..), makeSelect) where
import ChuSQL.Core.Model (Column (..), ColumnType, Value (..))
import ChuSQL.Core.Engine.Runtime.Types (TypeId, TypeExpr, RuntimeValue)
import ChuSQL.Core.Engine.Runtime.Functions (FunctionId)
-- 语法树:语句、数据来源、条件表达式、排序方向。
@@ -112,6 +114,11 @@ data CompareOp
-- | 条件表达式:列、字面量、算术、比较、逻辑、聚合与子查询
data Expr
= Col String
| FunctionCall String [Expr]
| BoundFunction FunctionId TypeId [Expr]
| Construct TypeExpr [Expr]
| BoundConstruct TypeId [Expr]
| RuntimeLiteral TypeId RuntimeValue
| LitNull
| LitInt Int
| LitFloat Double
@@ -5,6 +5,7 @@ module ChuSQL.Core.Engine.Syntax.Parser (parseStatement, parseExpression) where
import ChuSQL.Core.Model (Column (..), ColumnType (..), Value (..), plainColumn)
import ChuSQL.Core.Engine.Builtin (Builtin (..), builtinName, builtinNames, builtinNode, compareNode)
import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Engine.Runtime.Types
import Control.Monad (void)
import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)
import Data.Char (isAlpha, isAlphaNum, isHexDigit, isSpace, toLower, toUpper)
@@ -167,6 +168,8 @@ atom =
, LitInt <$> integer
, LitStr <$> stringLit
, try aggregateCall
, try constructorCall
, try scalarFunctionCall
, try existsPredicate
, Col <$> qualifiedName
, try scalarSubquery
@@ -202,6 +205,33 @@ inPredicate = do
subquerySelect :: Parser Subquery
subquerySelect = Subquery <$> queryStatement <*> pure []
-- | 读取带具体类型参数的构造器
constructorCall :: Parser Expr
constructorCall = do
cid <- (TypeConstructorId 5 <$ keyword "list") <|> (TypeConstructorId 6 <$ keyword "maybe")
<|> (TypeConstructorId 7 <$ keyword "tuple")
arguments <- between (symbol "<") (symbol ">") (sepBy runtimeTypeP (symbol ","))
values <- between (symbol "(") (symbol ")") (sepBy expr (symbol ","))
pure (Construct (TypeApply cid arguments) values)
-- | 解析运行时逻辑类型语法
runtimeTypeP :: Parser TypeExpr
runtimeTypeP = choice
[ intType <$ keyword "int", doubleType <$ keyword "double", boolType <$ keyword "bool"
, stringType <$ keyword "string", stringType <$ keyword "str", stringType <$ keyword "text"
, listType <$> between (symbol "[") (symbol "]") runtimeTypeP
, listType <$> (keyword "list" *> runtimeTypeP)
, maybeType <$> (keyword "maybe" *> runtimeTypeP)
, tupleType <$> between (symbol "(") (symbol ")") (sepBy runtimeTypeP (symbol ","))
]
-- | 读取待绑定的标量函数调用
scalarFunctionCall :: Parser Expr
scalarFunctionCall = do
name <- identifier
arguments <- between (symbol "(") (symbol ")") (sepBy expr (symbol ","))
pure (FunctionCall name arguments)
-- | 聚合调用:名称与节点都由内置函数表给出
aggregateCall :: Parser Expr
aggregateCall = choice (countAll : map named builtinNames)
@@ -480,7 +510,9 @@ alterUserStatement = do
-- | 读身份属性开关
identityAttribute :: Parser (String, Bool)
identityAttribute = choice
[ ("system_catalog_manager", True) <$ keyword "system_catalog_manager"
[ ("allow_sudo_auth", True) <$ keyword "allow_sudo_auth"
, ("allow_sudo_auth", False) <$ keyword "noallow_sudo_auth"
, ("system_catalog_manager", True) <$ keyword "system_catalog_manager"
, ("system_catalog_manager", False) <$ keyword "nosystem_catalog_manager"
, ("login", True) <$ keyword "login", ("login", False) <$ keyword "nologin"
, ("superuser", True) <$ keyword "superuser", ("superuser", False) <$ keyword "nosuperuser"
@@ -525,12 +557,16 @@ privilegeName =
, "INSERT" <$ keyword "insert"
, "UPDATE" <$ keyword "update"
, "DELETE" <$ keyword "delete"
, "CONNECT" <$ keyword "connect"
, "CREATE" <$ keyword "create"
, "ALL" <$ keyword "all"
]
-- | ON 后面的授权对象:* 或一张表
grantObject :: Parser String
grantObject = ("*" <$ symbol "*") <|> tableName
grantObject = try (("database:" ++) <$> (keyword "database" *> identifier))
<|> try ((++ ".*") <$> (identifier <* symbol "." <* symbol "*"))
<|> ("*" <$ symbol "*") <|> (optional (keyword "table") *> tableName)
-- | 可选的 WITH GRANT OPTION
grantOption :: Parser Bool
@@ -597,7 +633,8 @@ sizeParen = try (between (symbol "(") (symbol ")") integer)
columnTypeP :: Parser ColumnType
columnTypeP =
choice
[ keyword "integer" >> pure CInt
[ try runtimeColumnType
, keyword "integer" >> pure CInt
, keyword "int" >> pure CInt
, keyword "bigint" >> pure CBigInt
, keyword "smallint" >> pure CSmallInt
@@ -619,6 +656,20 @@ columnTypeP =
, (\name -> CDomain (map toLower name) CStr) <$> identifier
]
-- | 解析复合列的稳定类型身份
runtimeColumnType :: Parser ColumnType
runtimeColumnType = do
expression <- choice
[ listType <$> between (symbol "[") (symbol "]") runtimeTypeP
, listType <$> (keyword "list" *> runtimeTypeP)
, maybeType <$> (keyword "maybe" *> runtimeTypeP)
, tupleType <$> between (symbol "(") (symbol ")") (sepBy runtimeTypeP (symbol ","))
, stringType <$ keyword "string"
]
case resolveType builtinTypes expression of
Left err -> fail err
Right descriptor -> pure (CRuntime (descriptorId descriptor))
-- | DECIMAL 的精度与小数位
decimalType :: Parser ColumnType
decimalType = do
@@ -744,6 +795,10 @@ expandClause env fromC = case fromC of
-- | 表达式里的子查询也要展开
expandExpr :: [(String, Statement)] -> Expr -> Either String Expr
expandExpr env e = case e of
Construct tid arguments -> Construct tid <$> mapM go arguments
BoundConstruct tid arguments -> BoundConstruct tid <$> mapM go arguments
FunctionCall name arguments -> FunctionCall name <$> mapM go arguments
BoundFunction fid tid arguments -> BoundFunction fid tid <$> mapM go arguments
Add a b -> Add <$> go a <*> go b
Sub a b -> Sub <$> go a <*> go b
Mul a b -> Mul <$> go a <*> go b
@@ -0,0 +1,70 @@
{-# LANGUAGE PatternSynonyms #-}
module NormalizationSpec (spec) where
import ChuSQL.Core.Engine.Normalization
import ChuSQL.Core.Model (pattern TInt)
import Test.Hspec
-- 范式分析回归:公理闭包、候选键、信息不足与分解性质。
-- 执行范式检查回归。
spec :: Spec
spec = do
describe "Armstrong normalization" $ do
it "computes reflexivity, augmentation and transitivity" $ do
attributeClosure [Dependency ["a"] ["b"], Dependency ["b"] ["c"]] ["a"]
`shouldBe` ["a", "b", "c"]
implies [Dependency ["a"] ["b"]] (Dependency ["a", "c"] ["b", "c"])
`shouldBe` True
attributeClosure [] ["a"] `shouldBe` ["a"]
it "accepts BCNF with a declared key" $ do
fmap (map verdict . findings) (analyzeNormalization schema
(Declaration [["a"]] [] True (Just True)))
`shouldBe` Right (replicate 4 Satisfied)
it "detects partial dependencies of composite keys" $ do
fmap (map verdict . findings) (analyzeNormalization schema
(Declaration [["a", "b"]] [Dependency ["a"] ["c"]] True (Just True)))
`shouldBe` Right [Satisfied, Violated, Violated, Violated]
it "detects transitive dependencies" $ do
fmap (map verdict . findings) (analyzeNormalization schema
(Declaration [["a"]] [Dependency ["b"] ["c"]] True (Just True)))
`shouldBe` Right [Satisfied, Satisfied, Violated, Violated]
it "distinguishes 3NF from BCNF using all candidate keys" $ do
fmap (map verdict . findings) (analyzeNormalization schema
(Declaration [["a", "b"]] [Dependency ["c"] ["b"]] True (Just True)))
`shouldBe` Right [Satisfied, Satisfied, Satisfied, Violated]
it "reports lossless decomposition that loses dependencies" $ do
fmap suggestions (analyzeNormalization schema
(Declaration [["a", "b"]] [Dependency ["c"] ["b"]] True (Just True)))
`shouldBe` Right [Decomposition [["b", "c"], ["a", "c"]] Satisfied Violated]
it "reports dependency preserving transitive split" $ do
fmap suggestions (analyzeNormalization schema
(Declaration [["a"]] [Dependency ["b"] ["c"]] True (Just True)))
`shouldBe` Right [Decomposition [["b", "c"], ["a", "b"]] Satisfied Satisfied]
it "does not certify incomplete dependencies" $ do
fmap (map verdict . findings) (analyzeNormalization schema
(Declaration [["a"]] [] False (Just True)))
`shouldBe` Right [Satisfied, Insufficient, Insufficient, Insufficient]
it "requires an atomicity declaration" $ do
fmap (map verdict . findings) (analyzeNormalization schema
(Declaration [] [] True Nothing)) `shouldBe` Right (replicate 4 Insufficient)
it "propagates a declared 1NF violation" $ do
fmap (map verdict . findings) (analyzeNormalization schema
(Declaration [] [] True (Just False))) `shouldBe` Right (replicate 4 Violated)
it "rejects unknown attributes" $ do
analyzeNormalization schema (Declaration [] [Dependency ["z"] ["a"]] True (Just True))
`shouldBe` Left "normalization: unknown or duplicate dependency attributes"
it "rejects nonminimal declared candidate keys" $ do
analyzeNormalization schema (Declaration [["a", "b"]]
[Dependency ["a"] ["b", "c"]] True (Just True))
`shouldBe` Left "normalization: declared candidate key is not minimal"
it "includes the empty candidate key for constant relations" $ do
fmap candidateKeys (analyzeNormalization schema
(Declaration [] [Dependency [] ["a", "b", "c"]] True (Just True))) `shouldBe` Right [[]]
it "rejects excessive exhaustive searches" $ do
analyzeNormalization [(show n, TInt) | n <- [1 :: Int .. 13]]
(Declaration [] [] True (Just True))
`shouldBe` Left "normalization: exhaustive analysis supports at most 12 columns"
where
schema = [("a", TInt), ("b", TInt), ("c", TInt)]
+222
View File
@@ -0,0 +1,222 @@
module RuntimeSpec (spec) where
import ChuSQL.Core.Engine.Runtime.Types
import ChuSQL.Core.Engine.Runtime.Functions
import ChuSQL.Core.Engine.Runtime.Binding
import qualified ChuSQL.Core.Engine.Runtime.Query as Query
import ChuSQL.Core.Engine (rowsOf, runStatement)
import ChuSQL.Core.Engine.Semantic (prepare)
import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
import ChuSQL.Core.Engine.Syntax.AST (Expr (..), Statement (..))
import qualified ChuSQL.Core.Model as SQL
import ChuSQL.Core.Protocol (valueToJSON, valueFromJSON)
import Data.Aeson.Types (parseEither)
import Data.Hashable (hash)
import qualified Data.ByteString.Lazy.Char8 as BS
import Test.Hspec
-- 运行时类型、函数绑定、物理编码和类型化查询测试。
-- | 检查运行时类型基础契约
spec :: Spec
spec = do
describe "runtime type registry" $ do
it "keeps a fixed identity encoding across releases" $ withType (listType intType) $ \tid ->
encodeType tid `shouldBe` BS.pack "[1,[5,[[1,[]]]]]"
it "parses nested Haskell-style type expressions" $
parseTypeExpr "(Int, [Maybe String])" `shouldBe` Right (tupleType [intType, listType (maybeType stringType)])
it "rejects constructor names without a token boundary" $
parseTypeExpr "MaybeInt" `shouldSatisfy` isFailure
it "restores stable nested identities from bootstrap metadata" $ do
let ty = tupleType [listType intType, maybeType stringType]
resolveType builtinTypes ty `shouldBe` resolveType builtinTypes ty
fmap descriptorPhysical (resolveType builtinTypes ty)
`shouldBe` Right (Product [Sequence SignedInteger, Optional Utf8])
it "distinguishes logical String from List Int" $
fmap descriptorId (resolveType builtinTypes stringType)
`shouldNotBe` fmap descriptorId (resolveType builtinTypes (listType intType))
it "rejects unknown constructors" $
resolveType builtinTypes (TypeApply (TypeConstructorId 99) []) `shouldSatisfy` isFailure
it "rejects unapplied List" $
resolveType builtinTypes (TypeApply (TypeConstructorId 5) []) `shouldSatisfy` isFailure
it "rejects arguments to Int" $
resolveType builtinTypes (TypeApply (TypeConstructorId 1) [intType]) `shouldSatisfy` isFailure
describe "runtime encoding" $ do
it "round trips nested lists, optional values and tuples" $ do
let ty = tupleType [listType (maybeType intType), stringType, doubleType, boolType]
value = RTuple [RList [RMaybe Nothing, RMaybe (Just (RInt 42))], RString "你好", RDouble 1.25, RBool True]
withType ty $ \tid -> do
(encodeValue builtinTypes tid value >>= decodeValue builtinTypes tid) `shouldBe` Right value
decodeType builtinTypes (encodeType tid) `shouldBe` Right tid
it "round trips the empty tuple" $ withType (tupleType []) $ \tid ->
(encodeValue builtinTypes tid (RTuple []) >>= decodeValue builtinTypes tid) `shouldBe` Right (RTuple [])
it "rejects mismatched list elements" $ withType (listType intType) $ \tid ->
encodeValue builtinTypes tid (RList [RString "bad"]) `shouldSatisfy` isFailure
it "rejects tuple arity mismatch" $ withType (tupleType [intType]) $ \tid ->
encodeValue builtinTypes tid (RTuple []) `shouldSatisfy` isFailure
it "rejects non-finite floating point values" $ withType doubleType $ \tid ->
encodeValue builtinTypes tid (RDouble (1 / 0)) `shouldSatisfy` isFailure
it "rejects unsupported type encoding versions" $
decodeType builtinTypes (BS.pack "[2,[1,[]]]") `shouldSatisfy` isFailure
it "rejects overflowed constructor identities" $
decodeType builtinTypes (BS.pack "[1,[18446744073709551617,[]]]") `shouldSatisfy` isFailure
it "rejects fractional integer payloads" $ withType intType $ \tid ->
decodeValue builtinTypes tid (BS.pack "[1,[1,[]],1.5]") `shouldSatisfy` isFailure
it "rejects encoded identity mismatch" $ withType intType $ \tid ->
decodeValue builtinTypes tid (BS.pack "[1,[4,[]],\"x\"]") `shouldSatisfy` isFailure
describe "runtime binder and executor" $ do
it "resolves case-insensitive length to a stable FunctionId" $ withFunctions $ \functions ->
withType stringType $ \string -> withType intType $ \int ->
resolveFunction functions "LENGTH" [string]
`shouldBe` Right (FunctionSignature (FunctionId 1) "length" [string] int)
it "binds and executes nested calls" $ withFunctions $ \functions -> do
let expression = Apply "not" [Apply "not" [Literal boolType (RBool True)]]
(bindExpression builtinTypes functions [] expression >>= evaluateExpression builtinTypes functions [])
`shouldBe` Right (RBool True)
it "rejects a wrong function argument type during binding" $ withFunctions $ \functions ->
bindExpression builtinTypes functions [] (Apply "length" [Literal intType (RInt 1)]) `shouldSatisfy` isFailure
it "rejects unknown function identities" $ withFunctions $ \functions ->
invokeFunction builtinTypes functions (FunctionId 99) [] `shouldSatisfy` isFailure
it "rejects wrong runtime argument types" $ withFunctions $ \functions ->
invokeFunction builtinTypes functions (FunctionId 1) [RInt 1] `shouldSatisfy` isFailure
it "binds empty List and Nothing using explicit element types" $ withFunctions $ \functions -> do
let expression = TupleLiteral [ListLiteral intType [], NothingLiteral stringType]
(bindExpression builtinTypes functions [] expression >>= evaluateExpression builtinTypes functions [])
`shouldBe` Right (RTuple [RList [], RMaybe Nothing])
it "rejects mixed logical list types" $ withFunctions $ \functions ->
bindExpression builtinTypes functions [] (ListLiteral intType [Literal doubleType (RDouble 1)]) `shouldSatisfy` isFailure
it "binds queries using schema without reading storage" $ withFunctions $ \functions -> do
let catalog = [("items", [("name", stringType), ("enabled", boolType)])]
query = Projection [("size", Apply "length" [Reference "name"])]
(Selection (Reference "enabled") (TableScan "items"))
scan name = if name == "items" then Right
[[("name", RString "甲乙"), ("enabled", RBool True)]
,[("name", RString "hidden"), ("enabled", RBool False)]] else Left "unknown storage table"
(bindPlan builtinTypes functions catalog query >>= executePlan builtinTypes functions scan)
`shouldBe` Right [[("size", RInt 2)]]
it "uses catalog existence even when storage could return rows" $ withFunctions $ \functions ->
bindPlan builtinTypes functions [] (TableScan "missing") `shouldSatisfy` isFailure
it "rejects non-boolean filters" $ withFunctions $ \functions ->
bindPlan builtinTypes functions [] (Selection (Literal intType (RInt 1)) SingleRow) `shouldSatisfy` isFailure
it "rejects schema drift returned by storage" $ withFunctions $ \functions ->
(bindPlan builtinTypes functions [("t", [("x", intType)])] (TableScan "t")
>>= executePlan builtinTypes functions (const (Right [[("x", RString "wrong")]]))) `shouldSatisfy` isFailure
it "propagates storage failures" $ withFunctions $ \functions ->
(bindPlan builtinTypes functions [("t", [])] (TableScan "t")
>>= executePlan builtinTypes functions (const (Left "storage unavailable"))) `shouldBe` Left "storage unavailable"
describe "SQL runtime functions" $ do
it "binds the SQL entry point to output TypeIds" $ withType intType $ \tid -> do
let result = parseStatement "SELECT length('abc') AS size" >>= Query.bindQuery []
fmap Query.queryTypes result `shouldBe` Right [("size", Query.RuntimeType tid)]
it "retains compatibility for existing temporal SQL types" $ do
let result = parseStatement "SELECT DATE '2026-10-05' AS today" >>= Query.bindQuery []
fmap Query.queryTypes result `shouldBe` Right [("today", Query.CompatibilityType SQL.CDate)]
it "rejects composite ordering without an Ord implementation" $
sql "SELECT LIST<Int>(1) AS xs ORDER BY xs" `shouldSatisfy` isFailure
it "rejects composite extrema without an Ord implementation" $
sql "SELECT MIN(LIST<Int>(1))" `shouldSatisfy` isFailure
it "rejects unique runtime columns without a key implementation" $
(parseStatement "CREATE TABLE keyed (xs [Int] UNIQUE)" >>= runStatement []) `shouldSatisfy` isFailure
it "rejects primary runtime keys without a key implementation" $
(parseStatement "CREATE TABLE keyed (xs [Int] PRIMARY KEY)" >>= runStatement []) `shouldSatisfy` isFailure
it "constructs nested compound values in SQL" $ withType (listType (maybeType intType)) $ \tid ->
sql "SELECT LIST<Maybe Int>(MAYBE<Int>(), MAYBE<Int>(42))"
`shouldBe` Right [[SQL.VRuntime tid (RList [RMaybe Nothing, RMaybe (Just (RInt 42))])]]
it "constructs heterogeneous tuples with stable type identity" $ withType (tupleType [intType, stringType]) $ \tid ->
sql "SELECT TUPLE<Int, String>(1, 'a')" `shouldBe` Right [[SQL.VRuntime tid (RTuple [RInt 1, RString "a"])]]
it "rejects constructor argument type mismatch" $
sql "SELECT LIST<Int>('bad')" `shouldSatisfy` isFailure
it "rejects constructor arity mismatch" $
sql "SELECT MAYBE<Int>(1, 2)" `shouldSatisfy` isFailure
it "rejects SQL NULL inside a typed compound value" $
sql "SELECT LIST<Int>(NULL)" `shouldSatisfy` isFailure
it "round trips typed runtime values through the shared wire protocol" $
withType (maybeType (listType intType)) $ \tid -> do
let value = SQL.VRuntime tid (RMaybe (Just (RList [RInt 1, RInt 2])))
parseEither valueFromJSON (valueToJSON value) `shouldBe` Right value
it "round trips typed schema identities through catalog type names" $
withType (tupleType [intType, listType stringType]) $ \tid ->
SQL.parseColumnType (SQL.typeName (SQL.CRuntime tid)) `shouldBe` Just (SQL.CRuntime tid)
it "keeps hashing consistent for signed floating zero" $ withType (listType doubleType) $ \tid -> do
let positive = SQL.VRuntime tid (RList [RDouble 0])
negative = SQL.VRuntime tid (RList [RDouble (-0)])
positive `shouldBe` negative
hash positive `shouldBe` hash negative
it "creates and writes compound columns through SQL" $ do
let result = do
create <- parseStatement "CREATE TABLE composite (xs [Int], opt Maybe String, pair (Int, String))"
(db, _) <- runStatement [] create
insert <- parseStatement "INSERT INTO composite (xs, opt, pair) VALUES (LIST<Int>(1, 2), MAYBE<String>(), TUPLE<Int, String>(3, 'x'))"
(updated, _) <- runStatement db insert
select <- parseStatement "SELECT xs, opt, pair FROM composite"
rowsOf (runStatement updated select)
result `shouldSatisfy` either (const False) ((== 1) . length)
it "stores logical String with the generic runtime encoding" $ do
let result = do
create <- parseStatement "CREATE TABLE strings (text String)"
(db, _) <- runStatement [] create
insert <- parseStatement "INSERT INTO strings (text) VALUES ('abc')"
(updated, _) <- runStatement db insert
select <- parseStatement "SELECT length(text) FROM strings"
map (map snd) <$> rowsOf (runStatement updated select)
result `shouldBe` Right [[SQL.VInt 3]]
it "runs length and not through resolved identities" $
sql "SELECT length('你好'), not(TRUE)" `shouldBe` Right [[SQL.VInt 2, SQL.VBool False]]
it "preserves nullable SQL function semantics" $
sql "SELECT length(NULL), not(NULL)" `shouldBe` Right [[SQL.VNull, SQL.VNull]]
it "binds calls before execution" $ do
let bound = parseStatement "SELECT length('abc')" >>= prepare []
case bound of
Right SelectExpr {selectItems = [(_, BoundFunction (FunctionId 1) _ [_])]} -> pure ()
_ -> expectationFailure (show bound)
it "rejects unknown SQL functions before scanning" $
sql "SELECT missing('abc')" `shouldSatisfy` isFailure
it "rejects wrong argument count" $
sql "SELECT length('a', 'b')" `shouldSatisfy` isFailure
it "rejects wrong SQL argument type" $
sql "SELECT length(1)" `shouldSatisfy` isFailure
it "finds references inside calls for projection pushdown" $
sql "SELECT length(name) FROM t WHERE not(enabled)" `shouldBe` Right [[SQL.VInt 3]]
it "rewrites aggregates nested in calls" $
sql "SELECT length(MIN(name)) FROM t" `shouldBe` Right [[SQL.VInt 2]]
it "executes subqueries nested in function arguments" $
sql "SELECT length((SELECT MIN(name) FROM t))" `shouldBe` Right [[SQL.VInt 2]]
it "expands CTEs inside function arguments" $
sql "WITH names AS (SELECT name FROM t) SELECT length((SELECT MIN(name) FROM names))"
`shouldBe` Right [[SQL.VInt 2]]
it "binds CHECK functions using the row schema" $ do
let result = do
statement <- parseStatement "CREATE TABLE checked (name TEXT CHECK (length(name) > 1))"
(db, _) <- runStatement [] statement
insert <- parseStatement "INSERT INTO checked (name) VALUES ('abc')"
runStatement db insert
result `shouldSatisfy` either (const False) (const True)
-- | 通过正式入口执行测试 SQL
sql :: String -> Either String [[SQL.Value]]
sql source = do
statement <- parseStatement source
rows <- rowsOf (runStatement database statement)
Right (map (map snd) rows)
where
-- | 提供函数调用测试表
database = [("t", SQL.Table "t" [("name", SQL.plainColumn SQL.CStr), ("enabled", SQL.plainColumn SQL.CBool)]
[[("name", SQL.VStr "ab"), ("enabled", SQL.VBool True)]
,[("name", SQL.VStr "xyz"), ("enabled", SQL.VBool False)]] Nothing)]
-- | 判断结果是否明确失败
isFailure :: Either a b -> Bool
isFailure (Left _) = True
isFailure _ = False
-- | 准备已解析类型身份
withType :: TypeExpr -> (TypeId -> Expectation) -> Expectation
withType ty action = case resolveType builtinTypes ty of
Left err -> expectationFailure err
Right descriptor -> action (descriptorId descriptor)
-- | 准备内建函数注册表
withFunctions :: (FunctionRegistry -> Expectation) -> Expectation
withFunctions action = case builtinFunctions builtinTypes of
Left err -> expectationFailure err
Right functions -> action functions
+38
View File
@@ -31,6 +31,8 @@ import System.Directory (createDirectoryIfMissing, getTemporaryDirectory, remove
import System.FilePath ((</>))
import System.Timeout (timeout)
import Test.Hspec
import qualified NormalizationSpec
import qualified RuntimeSpec
-- 引擎层的 hspec 测试:语法、执行、优化器与存储链路行为。
@@ -116,7 +118,12 @@ domainSql db (sql : rest) = do
-- | 跑引擎层全部 hspec 用例
main :: IO ()
main = hspec $ do
NormalizationSpec.spec
RuntimeSpec.spec
describe "identity syntax" $ do
it "parses independent sudo authentication switches" $ do
parseStatement "ALTER USER worker ALLOW_SUDO_AUTH" `shouldBe` Right (AlterIdentity "worker" [("allow_sudo_auth", True)])
parseStatement "ALTER ROLE worker NOALLOW_SUDO_AUTH" `shouldBe` Right (AlterIdentity "worker" [("allow_sudo_auth", False)])
it "parses role and user attributes with their aliases" $ do
parseStatement "ALTER ROLE worker LOGIN SUPERUSER ENABLED" `shouldBe` Right (AlterIdentity "worker" [("login", True), ("superuser", True), ("enabled", True)])
parseStatement "ALTER USER worker NOLOGIN NOSUPERUSER DISABLED" `shouldBe` Right (AlterIdentity "worker" [("login", False), ("superuser", False), ("enabled", False)])
@@ -1056,6 +1063,16 @@ main = hspec $ do
parseStatement "GRANT SELECT ON users TO analyst WITH"
`shouldSatisfy` isLeft
it "parses database scopes, explicit tables and qualified wildcards" $ do
parseStatement "GRANT CONNECT, CREATE ON DATABASE sales TO analyst"
`shouldBe` Right (GrantPrivileges ["CONNECT", "CREATE"] "database:sales" "analyst" False)
parseStatement "REVOKE CONNECT ON DATABASE sales FROM PUBLIC"
`shouldBe` Right (RevokePrivileges ["CONNECT"] "database:sales" "PUBLIC")
parseStatement "GRANT SELECT ON TABLE sales.orders TO analyst"
`shouldBe` Right (GrantPrivileges ["SELECT"] "sales.orders" "analyst" False)
parseStatement "REVOKE ALL ON sales.* FROM analyst"
`shouldBe` Right (RevokePrivileges ["ALL"] "sales.*" "analyst")
it "parses REVOKE symmetrically" $ do
parseStatement "REVOKE SELECT ON users FROM analyst"
`shouldBe` Right (RevokePrivileges ["SELECT"] "users" "analyst")
@@ -2077,6 +2094,27 @@ main = hspec $ do
]
describe "ChuSQL.Core.Engine.Storage.IPC" $ do
it "persists runtime type identities and nested values across restart" $ do
withTestSession $ \srv -> do
-- | 解析并通过真实存储执行 SQL
let query source = case parseStatement source of
Left err -> expectationFailure err >> pure (Left err)
Right statement -> runIPCStorage (runStatementM statement)
originalRows <- withServerEnv srv $ do
query "CREATE TABLE compound (id Int, xs [Int], opt Maybe String, pair (Int, String), text String)" `shouldReturn` Right []
query "INSERT INTO compound (id, xs, opt, pair, text) VALUES (1, LIST<Int>(1, 2), MAYBE<String>('x'), TUPLE<Int, String>(3, 'y'), 'abc')" `shouldReturn` Right []
query "SELECT xs, opt, pair, length(text) FROM compound"
originalRows `shouldSatisfy` isRight
closeConnection
openSessionIn (dataDir srv)
reloadedRows <- withServerEnv srv $ query "SELECT xs, opt, pair, length(text) FROM compound"
reloadedRows `shouldBe` originalRows
withServerEnv srv $ do
query "INSERT INTO compound (xs) VALUES (LIST<String>('wrong'))" >>= (`shouldSatisfy` isLeft)
query "UPDATE compound SET xs = LIST<Int>(9) WHERE id = 1" `shouldReturn` Right []
updated <- query "SELECT xs FROM compound WHERE id = 1"
updated `shouldSatisfy` isRight
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 ()
@@ -13,10 +13,13 @@ library
hs-source-dirs: src
exposed-modules: ChuSQL.Core.Model
ChuSQL.Core.Protocol
ChuSQL.Core.Runtime
build-depends: base >= 4.14 && < 5
, aeson
, hashable
, scientific
, text
, bytestring
, vector
default-language: Haskell2010
ghc-options: -Wall
+61 -2
View File
@@ -48,6 +48,8 @@ import Data.Char (isDigit, isSpace, toLower)
import Data.Hashable (Hashable (..))
import Data.List (isPrefixOf, isSuffixOf, stripPrefix)
import Data.Maybe (fromMaybe, mapMaybe)
import ChuSQL.Core.Runtime
import qualified Data.ByteString.Lazy.Char8 as BS
-- 数据模型:列类型、列约束、值、行、表、数据库,外加查表小工具。
@@ -68,6 +70,7 @@ data ColumnType
| CBlob
| CNull
| CDomain String ColumnType
| CRuntime TypeId
deriving (Show, Eq)
-- | 列定义:类型 + 约束;约束全部取默认值就是普通可空列。
@@ -121,6 +124,7 @@ typeLabel CTimestamp = "TTimestamp"
typeLabel CBlob = "TBlob"
typeLabel CNull = "NULL"
typeLabel (CDomain name _) = name
typeLabel (CRuntime tid) = renderTypeExpr (typeExpression tid)
-- | 线上/磁盘上的类型名
typeName :: ColumnType -> String
@@ -139,6 +143,7 @@ typeName CTimestamp = "timestamp"
typeName CBlob = "blob"
typeName CNull = "null"
typeName (CDomain name base) = "domain(" ++ name ++ "," ++ typeName base ++ ")"
typeName (CRuntime tid) = "runtime(" ++ BS.unpack (encodeType tid) ++ ")"
-- | 生成类型定义的目录键
domainTableName :: String -> String
@@ -151,6 +156,9 @@ isDomainTable name = "__system_domain_" `isPrefixOf` map toLower name
-- | 解析类型名,可带长度/精度参数;不认识的给 Nothing
parseColumnType :: String -> Maybe ColumnType
parseColumnType raw
| Just inner <- stripPrefix "runtime(" raw
, Just body <- stripSuffixMaybe ")" inner =
either (const Nothing) (Just . CRuntime) (decodeType builtinTypes (BS.pack body))
| Just inner <- stripPrefix "domain(" raw
, Just body <- stripSuffixMaybe ")" inner
, (name, ',' : definition) <- break (== ',') body =
@@ -180,7 +188,7 @@ parseColumnType raw
("date", []) -> Just CDate
("timestamp", []) -> Just CTimestamp
("blob", []) -> Just CBlob
_ -> Nothing
_ -> either (const Nothing) (Just . CRuntime . descriptorId) (parseTypeExpr raw >>= resolveType builtinTypes)
where
-- | 去掉空白的类型名
cleaned = map toLower (filter (not . isSpace) raw)
@@ -231,6 +239,7 @@ data TypeClass
| TemporalClass
| BooleanClass
| NullClass
| RuntimeClass
deriving (Show, Eq)
-- | 整型大类判断
@@ -250,12 +259,15 @@ typeClassOf CTimestamp = TemporalClass
typeClassOf CBool = BooleanClass
typeClassOf CNull = NullClass
typeClassOf (CDomain _ base) = typeClassOf base
typeClassOf CRuntime{} = RuntimeClass
-- | 同大类可赋值;日期/时间列接受字符串字面量
assignable :: ColumnType -> ColumnType -> Bool
assignable target source
| source == CNull = True
| target == source = True
| CRuntime tid <- target = Just (typeExpression tid) == scalarTypeExpression source
| typeClassOf target == RuntimeClass || typeClassOf source == RuntimeClass = False
| typeClassOf target == typeClassOf source = True
| typeClassOf target == TemporalClass && typeClassOf source == TextClass = True
| otherwise = False
@@ -270,7 +282,9 @@ integerType _ = False
-- | 比较用的类型族:同大类可比,日期时间与文本互比
comparableTypes :: ColumnType -> ColumnType -> Bool
comparableTypes a b = a == CNull || b == CNull || sameClass || crossTemporal
comparableTypes a b
| typeClassOf a == RuntimeClass || typeClassOf b == RuntimeClass = False
| otherwise = a == CNull || b == CNull || sameClass || crossTemporal
where
-- | 两个类型同属一个大类
sameClass = typeClassOf a == typeClassOf b
@@ -288,6 +302,10 @@ numericType t = typeClassOf t == NumericClass
-- | 值能不能放进这一列(先不看可空)
valueFits :: ColumnType -> Value -> Bool
valueFits (CDomain _ base) value = valueFits base value
valueFits (CRuntime expected) (VRuntime supplied value) = expected == supplied && validateValue builtinTypes expected value == Right ()
valueFits (CRuntime expected) value = case scalarRuntimeValue value of
Just runtime -> validateValue builtinTypes expected runtime == Right ()
Nothing -> value == VNull
valueFits _ VNull = True
valueFits CInt (VInt _) = True
valueFits CBigInt (VInt _) = True
@@ -326,6 +344,15 @@ coerceValue t v = case t of
CBlob -> toText t v
CNull -> Left "a NULL output cannot contain a non-NULL value"
CDomain _ base -> coerceValue base v
CRuntime expected -> case v of
VRuntime supplied value | supplied == expected -> do
validateValue builtinTypes expected value
Right v
_ -> case scalarRuntimeValue v of
Just value -> do
validateValue builtinTypes expected value
Right (VRuntime expected value)
Nothing -> Left "runtime value type identity mismatch"
-- | 整数收进整型列
toInt :: ColumnType -> Value -> Either String Value
@@ -422,6 +449,7 @@ data Value
| VFloat Double
| VStr String
| VBool Bool
| VRuntime TypeId RuntimeValue
deriving (Show, Eq)
-- | 值的比较关键字:整值浮点折成整数
@@ -450,6 +478,7 @@ compareValue a b = case (canonicalValue a, canonicalValue b) of
(VFloat x, VFloat y) -> compare x y
(VStr x, VStr y) -> compare x y
(VBool x, VBool y) -> compare x y
(VRuntime tx x, VRuntime ty y) -> compare (encodeType tx, show (canonicalRuntime x)) (encodeType ty, show (canonicalRuntime y))
(x, y) -> compare (valueRank x) (valueRank y)
-- | 族的先后,只用来给异族值定序
@@ -459,6 +488,7 @@ valueRank (VInt _) = 1
valueRank (VFloat _) = 1
valueRank (VStr _) = 2
valueRank (VBool _) = 3
valueRank VRuntime{} = 4
-- | 相等语义:比较关键字相同即相等,与 hashValue 配套
valuesEqual :: Value -> Value -> Bool
@@ -472,6 +502,35 @@ hashValue v = case canonicalValue v of
VFloat d -> hashWithSalt 1 d
VStr t -> hashWithSalt 2 t
VBool b -> hashWithSalt 3 b
VRuntime tid value -> hashWithSalt 4 (BS.unpack (encodeType tid), show (canonicalRuntime value))
-- | 解析现有标量列的逻辑类型
scalarTypeExpression :: ColumnType -> Maybe TypeExpr
scalarTypeExpression (CDomain _ base) = scalarTypeExpression base
scalarTypeExpression CInt = Just intType
scalarTypeExpression CBigInt = Just intType
scalarTypeExpression CSmallInt = Just intType
scalarTypeExpression CDouble = Just doubleType
scalarTypeExpression CFloat = Just doubleType
scalarTypeExpression CBool = Just boolType
scalarTypeExpression CStr = Just stringType
scalarTypeExpression _ = Nothing
-- | 转换现有标量值
scalarRuntimeValue :: Value -> Maybe RuntimeValue
scalarRuntimeValue (VInt n) = Just (RInt n)
scalarRuntimeValue (VFloat n) = Just (RDouble n)
scalarRuntimeValue (VBool b) = Just (RBool b)
scalarRuntimeValue (VStr text) = Just (RString text)
scalarRuntimeValue _ = Nothing
-- | 统一复合值中的浮点零关键字
canonicalRuntime :: RuntimeValue -> RuntimeValue
canonicalRuntime (RDouble n) | n == 0 = RDouble 0
canonicalRuntime (RList values) = RList (map canonicalRuntime values)
canonicalRuntime (RMaybe value) = RMaybe (fmap canonicalRuntime value)
canonicalRuntime (RTuple values) = RTuple (map canonicalRuntime values)
canonicalRuntime value = value
-- | 值按类型打散搅拌
instance Hashable Value where
+11 -5
View File
@@ -16,6 +16,7 @@ module ChuSQL.Core.Protocol (
) where
import ChuSQL.Core.Model (Histogram (..), Row, Value (..))
import ChuSQL.Core.Runtime (builtinTypes, runtimeToJSON, runtimeFromJSON)
import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.!=), (.=))
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as K
@@ -78,7 +79,7 @@ data Request
| ReqIdentityInitialize T.Text
| ReqRoleCreate T.Text
| ReqCatalogManage Request
| ReqIdentityAlter T.Text (Maybe Bool) (Maybe Bool) (Maybe Bool) (Maybe Bool)
| ReqIdentityAlter T.Text (Maybe Bool) (Maybe Bool) (Maybe Bool) (Maybe Bool) (Maybe Bool)
| ReqAccountCreate T.Text T.Text
| ReqAccountReset T.Text T.Text
| ReqAccountLogin T.Text (Maybe T.Text)
@@ -142,8 +143,8 @@ instance ToJSON Request where
toJSON ReqAccountsList = object ["method" .= ("accounts_list" :: T.Text)]
toJSON (ReqIdentityInitialize u) = object ["method" .= ("identity_initialize" :: T.Text), "administrator" .= u]
toJSON (ReqRoleCreate u) = object ["method" .= ("role_create" :: T.Text), "user" .= u]
toJSON (ReqIdentityAlter u login super enabled manager) = object ["method" .= ("identity_alter" :: T.Text), "user" .= u,
"can_login" .= login, "is_superuser" .= super, "enabled" .= enabled, "system_catalog_manager" .= manager]
toJSON (ReqIdentityAlter u login super enabled manager sudo) = object ["method" .= ("identity_alter" :: T.Text), "user" .= u,
"can_login" .= login, "is_superuser" .= super, "enabled" .= enabled, "system_catalog_manager" .= manager, "allow_sudo_auth" .= sudo]
toJSON (ReqAccountCreate u h) = object ["method" .= ("account_create" :: T.Text), "user" .= u, "password_hash" .= h]
toJSON (ReqAccountReset u h) = object ["method" .= ("account_reset" :: T.Text), "user" .= u, "password_hash" .= h]
toJSON (ReqAccountLogin u at) = object ["method" .= ("account_login" :: T.Text), "user" .= u, "at" .= at]
@@ -316,6 +317,7 @@ data Account = Account
, accountIsSuperuser :: Bool
, accountEnabled :: Bool
, accountSystemCatalogManager :: Bool
, accountAllowSudoAuth :: Bool
} deriving (Eq)
-- | 账号的展示:只露账号名与版本号
@@ -327,14 +329,14 @@ instance FromJSON Account where
parseJSON = withObject "Account" $ \o -> Account <$> o .: "id" <*> o .: "user"
<*> o .: "password_hash" <*> o .: "revision"
<*> o .:? "registered_at" .!= "" <*> o .:? "last_login_at"
<*> o .:? "can_login" .!= True <*> o .:? "is_superuser" .!= False <*> o .:? "enabled" .!= True <*> o .:? "system_catalog_manager" .!= False
<*> o .:? "can_login" .!= True <*> o .:? "is_superuser" .!= False <*> o .:? "enabled" .!= True <*> o .:? "system_catalog_manager" .!= False <*> o .:? "allow_sudo_auth" .!= False
-- | 账号编码成 JSON
instance ToJSON Account where
toJSON a = object ["id" .= accountId a, "user" .= accountUser a,
"password_hash" .= accountHash a, "revision" .= accountRevision a,
"registered_at" .= accountRegisteredAt a, "last_login_at" .= accountLastLoginAt a,
"can_login" .= accountCanLogin a, "is_superuser" .= accountIsSuperuser a, "enabled" .= accountEnabled a, "system_catalog_manager" .= accountSystemCatalogManager a]
"can_login" .= accountCanLogin a, "is_superuser" .= accountIsSuperuser a, "enabled" .= accountEnabled a, "system_catalog_manager" .= accountSystemCatalogManager a, "allow_sudo_auth" .= accountAllowSudoAuth a]
-- | 存储层响应
data Response
@@ -373,6 +375,7 @@ 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
valueToJSON (VRuntime tid value) = object ["__chusql_runtime_v1" .= runtimeToJSON tid value]
-- | JSON 解回值
valueFromJSON :: A.Value -> Parser Value
@@ -383,6 +386,9 @@ valueFromJSON (A.Number n) =
Left d -> pure (VFloat d)
valueFromJSON (A.String s) = pure (VStr (T.unpack s))
valueFromJSON (A.Bool b) = pure (VBool b)
valueFromJSON (A.Object fields)
| KM.size fields == 1, Just payload <- KM.lookup "__chusql_runtime_v1" fields =
either fail (pure . uncurry VRuntime) (runtimeFromJSON builtinTypes payload)
valueFromJSON _ = fail "unsupported value type"
-- | 一行编码成 JSON
@@ -0,0 +1,293 @@
module ChuSQL.Core.Runtime
( TypeConstructorId (..), TypeId, TypeExpr (..), Kind (..)
, TypeRegistry, TypeDescriptor (..), PhysicalType (..), RuntimeValue (..)
, builtinTypes, resolveType, describeType, typeExpression
, intType, doubleType, boolType, stringType, listType, maybeType, tupleType, renderTypeExpr, parseTypeExpr, renderRuntimeValue
, validateValue, encodeValue, decodeValue, encodeType, decodeType, runtimeToJSON, runtimeFromJSON
) where
import Data.Aeson (Value (..), eitherDecode, encode)
import Data.Aeson.Types (Parser, parseEither)
import qualified Data.ByteString.Lazy as BS
import Data.Scientific (floatingOrInteger)
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Char (isAlphaNum, toLower)
import qualified Text.ParserCombinators.ReadP as P
-- 运行时类型身份、构造器注册及版本化物理编码。
-- | 标识稳定的类型构造器
newtype TypeConstructorId = TypeConstructorId Int deriving (Show, Eq, Ord)
-- | 表达逻辑类型应用
data TypeExpr = TypeApply TypeConstructorId [TypeExpr] deriving (Show, Eq, Ord)
-- | 标识完整的类型实例
newtype TypeId = TypeId TypeExpr deriving (Show, Eq, Ord)
-- | 描述构造器参数个数
data Kind = TypeKind | TypeArrow Kind Kind | ProductKind deriving (Show, Eq)
-- | 描述独立的物理表示
data PhysicalType = SignedInteger | FloatingPoint | Boolean | Utf8 | Sequence PhysicalType
| Optional PhysicalType | Product [PhysicalType] deriving (Show, Eq)
-- | 保存类型实例描述
data TypeDescriptor = TypeDescriptor
{ descriptorId :: TypeId, descriptorName :: String, descriptorPhysical :: PhysicalType
} deriving (Show, Eq)
-- | 保存构造器元数据
newtype TypeRegistry = TypeRegistry [(TypeConstructorId, String, Kind)] deriving (Show, Eq)
-- | 表达运行时值
data RuntimeValue = RInt Int | RDouble Double | RBool Bool | RString String
| RList [RuntimeValue] | RMaybe (Maybe RuntimeValue) | RTuple [RuntimeValue]
deriving (Show, Eq)
-- | 恢复固定编号的内建构造器
builtinTypes :: TypeRegistry
builtinTypes = TypeRegistry
[(TypeConstructorId 1, "Int", TypeKind), (TypeConstructorId 2, "Double", TypeKind)
,(TypeConstructorId 3, "Bool", TypeKind), (TypeConstructorId 4, "String", TypeKind)
,(TypeConstructorId 5, "List", TypeArrow TypeKind TypeKind)
,(TypeConstructorId 6, "Maybe", TypeArrow TypeKind TypeKind)
,(TypeConstructorId 7, "Tuple", ProductKind)]
-- | 构造整数类型表达式
intType :: TypeExpr
intType = TypeApply (TypeConstructorId 1) []
-- | 构造浮点类型表达式
doubleType :: TypeExpr
doubleType = TypeApply (TypeConstructorId 2) []
-- | 构造布尔类型表达式
boolType :: TypeExpr
boolType = TypeApply (TypeConstructorId 3) []
-- | 构造字符串类型表达式
stringType :: TypeExpr
stringType = TypeApply (TypeConstructorId 4) []
-- | 构造列表类型表达式
listType :: TypeExpr -> TypeExpr
listType t = TypeApply (TypeConstructorId 5) [t]
-- | 构造可选类型表达式
maybeType :: TypeExpr -> TypeExpr
maybeType t = TypeApply (TypeConstructorId 6) [t]
-- | 构造元组类型表达式
tupleType :: [TypeExpr] -> TypeExpr
tupleType = TypeApply (TypeConstructorId 7)
-- | 渲染内建逻辑类型语法
renderTypeExpr :: TypeExpr -> String
renderTypeExpr ty@(TypeApply cid arguments) = case (cid, arguments) of
(TypeConstructorId 1, []) -> "Int"
(TypeConstructorId 2, []) -> "Double"
(TypeConstructorId 3, []) -> "Bool"
(TypeConstructorId 4, []) -> "String"
(TypeConstructorId 5, [child]) -> "[" ++ renderTypeExpr child ++ "]"
(TypeConstructorId 6, [child]) -> "Maybe " ++ renderTypeExpr child
(TypeConstructorId 7, fields) -> "(" ++ joinTypes fields ++ ")"
_ -> show ty
where
-- | 连接元组字段类型
joinTypes [] = ""
joinTypes [field] = renderTypeExpr field
joinTypes (field : fields) = renderTypeExpr field ++ ", " ++ joinTypes fields
-- | 解析完整的内建逻辑类型文本
parseTypeExpr :: String -> Either String TypeExpr
parseTypeExpr source = case P.readP_to_S (P.skipSpaces *> expression <* P.skipSpaces <* P.eof) source of
[(ty, "")] -> Right ty
_ -> Left "invalid runtime type expression"
where
-- | 解析类型原子和构造器应用
expression = (intType <$ token "int") P.<++ (doubleType <$ token "double")
P.<++ (boolType <$ token "bool") P.<++ (stringType <$ token "string")
P.<++ (listType <$> between "[" "]" expression)
P.<++ (listType <$> (token "list" *> expression))
P.<++ (maybeType <$> (token "maybe" *> expression))
P.<++ (tupleType <$> between "(" ")" (P.sepBy expression (symbol ",")))
-- | 解析具有名称边界的类型关键字
token word = do
_ <- mapM character word
rest <- P.look
case rest of
c : _ | isAlphaNum c || c == '_' -> P.pfail
_ -> P.skipSpaces
-- | 不区分大小写匹配关键字字符
character c = P.satisfy ((== c) . toLower)
-- | 解析类型分隔符
symbol text = P.string text <* P.skipSpaces
-- | 解析括号包围的类型
between open close = P.between (symbol open) (symbol close)
-- | 渲染运行时值的可读文本
renderRuntimeValue :: RuntimeValue -> String
renderRuntimeValue (RInt n) = show n
renderRuntimeValue (RDouble n) = show n
renderRuntimeValue (RBool b) = show b
renderRuntimeValue (RString text) = show text
renderRuntimeValue (RList values) = "[" ++ joinValues values ++ "]"
renderRuntimeValue (RMaybe Nothing) = "Nothing"
renderRuntimeValue (RMaybe (Just value)) = "Just (" ++ renderRuntimeValue value ++ ")"
renderRuntimeValue (RTuple values) = "(" ++ joinValues values ++ ")"
-- | 连接复合值的字段文本
joinValues :: [RuntimeValue] -> String
joinValues [] = ""
joinValues [value] = renderRuntimeValue value
joinValues (value : values) = renderRuntimeValue value ++ ", " ++ joinValues values
-- | 提取身份中的逻辑类型
typeExpression :: TypeId -> TypeExpr
typeExpression (TypeId t) = t
-- | 解析类型实例并校验 kind
resolveType :: TypeRegistry -> TypeExpr -> Either String TypeDescriptor
resolveType registry@(TypeRegistry constructors) expression@(TypeApply cid args) = do
(name, kind) <- case [(n, k) | (c, n, k) <- constructors, c == cid] of
[entry] -> Right entry
_ -> Left ("unknown type constructor: " ++ show cid)
children <- mapM (resolveType registry) args
physical <- case (cid, kind, map descriptorPhysical children) of
(TypeConstructorId 1, TypeKind, []) -> Right SignedInteger
(TypeConstructorId 2, TypeKind, []) -> Right FloatingPoint
(TypeConstructorId 3, TypeKind, []) -> Right Boolean
(TypeConstructorId 4, TypeKind, []) -> Right Utf8
(TypeConstructorId 5, TypeArrow TypeKind TypeKind, [child]) -> Right (Sequence child)
(TypeConstructorId 6, TypeArrow TypeKind TypeKind, [child]) -> Right (Optional child)
(TypeConstructorId 7, ProductKind, fields) -> Right (Product fields)
_ -> Left ("invalid type constructor application: " ++ name)
Right (TypeDescriptor (TypeId expression) name physical)
-- | 按身份查询类型描述
describeType :: TypeRegistry -> TypeId -> Either String TypeDescriptor
describeType registry = resolveType registry . typeExpression
-- | 校验逻辑类型对应的值
validateValue :: TypeRegistry -> TypeId -> RuntimeValue -> Either String ()
validateValue registry tid value = do
descriptor <- describeType registry tid
validatePhysical (descriptorPhysical descriptor) value
-- | 校验值的物理结构
validatePhysical :: PhysicalType -> RuntimeValue -> Either String ()
validatePhysical SignedInteger RInt{} = Right ()
validatePhysical FloatingPoint (RDouble n)
| not (isNaN n || isInfinite n) = Right ()
validatePhysical Boolean RBool{} = Right ()
validatePhysical Utf8 RString{} = Right ()
validatePhysical (Sequence child) (RList values) = mapM_ (validatePhysical child) values
validatePhysical (Optional _) (RMaybe Nothing) = Right ()
validatePhysical (Optional child) (RMaybe (Just value)) = validatePhysical child value
validatePhysical (Product fields) (RTuple values)
| length fields == length values = sequence_ (zipWith validatePhysical fields values)
validatePhysical physical _ = Left ("value does not fit physical type: " ++ show physical)
-- | 编码带版本与类型身份的值
encodeValue :: TypeRegistry -> TypeId -> RuntimeValue -> Either String BS.ByteString
encodeValue registry tid value = do
validateValue registry tid value
Right (encode (runtimeToJSON tid value))
-- | 表达协议中的类型化值封装
runtimeToJSON :: TypeId -> RuntimeValue -> Value
runtimeToJSON tid value = array [Number 1, typeJson (typeExpression tid), valueJson value]
-- | 解析并校验协议类型化值
runtimeFromJSON :: TypeRegistry -> Value -> Either String (TypeId, RuntimeValue)
runtimeFromJSON registry json = do
(expression, payload) <- parseEither parseEnvelope json
descriptor <- resolveType registry expression
value <- parseEither (parseValue (descriptorPhysical descriptor)) payload
validateValue registry (descriptorId descriptor) value
Right (descriptorId descriptor, value)
-- | 解码并校验版本和类型身份
decodeValue :: TypeRegistry -> TypeId -> BS.ByteString -> Either String RuntimeValue
decodeValue registry expected bytes = do
json <- eitherDecode bytes
(expression, payload) <- parseEither parseEnvelope json
descriptor <- resolveType registry expression
if descriptorId descriptor /= expected then Left "encoded value type identity mismatch" else do
value <- parseEither (parseValue (descriptorPhysical descriptor)) payload
validateValue registry expected value
Right value
-- | 编码版本化类型身份
encodeType :: TypeId -> BS.ByteString
encodeType tid = encode (array [Number 1, typeJson (typeExpression tid)])
-- | 解码并解析类型身份
decodeType :: TypeRegistry -> BS.ByteString -> Either String TypeId
decodeType registry bytes = do
json <- eitherDecode bytes
expression <- parseEither parseTypeEnvelope json
descriptorId <$> resolveType registry expression
-- | 生成 JSON 数组
array :: [Value] -> Value
array = Array . V.fromList
-- | 编码构造器应用
typeJson :: TypeExpr -> Value
typeJson (TypeApply (TypeConstructorId cid) args) = array [Number (fromIntegral cid), array (map typeJson args)]
-- | 解析构造器应用
parseTypeJson :: Value -> Parser TypeExpr
parseTypeJson (Array values) = case V.toList values of
[Number n, Array args] -> case floatingOrInteger n :: Either Double Integer of
Right cid | cid > 0, cid <= fromIntegral (maxBound :: Int) -> TypeApply (TypeConstructorId (fromInteger cid)) <$> mapM parseTypeJson (V.toList args)
_ -> fail "invalid type constructor identity"
_ -> fail "invalid type expression"
parseTypeJson _ = fail "invalid type expression"
-- | 解析类型版本封装
parseTypeEnvelope :: Value -> Parser TypeExpr
parseTypeEnvelope (Array values) = case V.toList values of
[Number 1, expression] -> parseTypeJson expression
_ -> fail "unsupported type encoding version or invalid envelope"
parseTypeEnvelope _ = fail "invalid type envelope"
-- | 解析值版本封装
parseEnvelope :: Value -> Parser (TypeExpr, Value)
parseEnvelope (Array values) = case V.toList values of
[Number 1, expression, payload] -> do
ty <- parseTypeJson expression
pure (ty, payload)
_ -> fail "unsupported value encoding version or invalid envelope"
parseEnvelope _ = fail "invalid value envelope"
-- | 编码物理值
valueJson :: RuntimeValue -> Value
valueJson (RInt n) = Number (fromIntegral n)
valueJson (RDouble n) = Number (realToFrac n)
valueJson (RBool b) = Bool b
valueJson (RString s) = String (T.pack s)
valueJson (RList values) = array (map valueJson values)
valueJson (RMaybe Nothing) = array []
valueJson (RMaybe (Just value)) = array [valueJson value]
valueJson (RTuple values) = array (map valueJson values)
-- | 按物理描述解析值
parseValue :: PhysicalType -> Value -> Parser RuntimeValue
parseValue SignedInteger (Number n) = case floatingOrInteger n :: Either Double Integer of
Right i | i >= fromIntegral (minBound :: Int), i <= fromIntegral (maxBound :: Int) -> pure (RInt (fromInteger i))
_ -> fail "integer is fractional or out of range"
parseValue FloatingPoint (Number n) = pure (RDouble (realToFrac n))
parseValue Boolean (Bool b) = pure (RBool b)
parseValue Utf8 (String s) = pure (RString (T.unpack s))
parseValue (Sequence child) (Array values) = RList <$> mapM (parseValue child) (V.toList values)
parseValue (Optional child) (Array values) = case V.toList values of
[] -> pure (RMaybe Nothing)
[value] -> RMaybe . Just <$> parseValue child value
_ -> fail "invalid optional value"
parseValue (Product fields) (Array values)
| length fields == V.length values = RTuple <$> sequence (zipWith parseValue fields (V.toList values))
parseValue _ _ = fail "invalid physical value"
+61 -1
View File
@@ -34,6 +34,8 @@ pub struct ColumnStat {
#[derive(Debug, Clone, Default, Serialize, Deserialize)]
pub struct TableSchema {
#[serde(default)]
pub object_id: u64,
#[serde(default)]
pub system: bool,
pub columns: Vec<SchemaColumn>,
@@ -51,6 +53,10 @@ pub struct TableSchema {
#[derive(Debug, Default, Serialize, Deserialize)]
pub struct Catalog {
#[serde(default)]
pub database_id: u64,
#[serde(default)]
pub object_high_water: u64,
#[serde(default)]
pub identity_high_water: i64,
tables: BTreeMap<String, TableSchema>,
@@ -68,7 +74,36 @@ impl Catalog {
if bytes.is_empty() {
return Ok(Catalog::default());
}
serde_json::from_slice(&bytes).map_err(io::Error::other)
let mut catalog: Self = serde_json::from_slice(&bytes).map_err(io::Error::other)?;
catalog.upgrade_object_ids()?;
Ok(catalog)
}
/// 补齐旧目录对象编号并校验唯一性
fn upgrade_object_ids(&mut self) -> io::Result<()> {
self.object_high_water = self.object_high_water.max(self.database_id);
let mut ids = BTreeSet::new();
for schema in self.tables.values() {
if schema.object_id != 0 && !ids.insert(schema.object_id) {
return Err(io::Error::other("duplicate catalog object id"));
}
self.object_high_water = self.object_high_water.max(schema.object_id);
}
for schema in self.tables.values_mut() {
if schema.object_id == 0 {
self.object_high_water = self.object_high_water.checked_add(1)
.ok_or_else(|| io::Error::other("catalog object id exhausted"))?;
schema.object_id = self.object_high_water;
}
}
Ok(())
}
/// 分配不复用的对象编号
pub fn reserve_object_id(&mut self) -> io::Result<u64> {
self.object_high_water = self.object_high_water.checked_add(1)
.ok_or_else(|| io::Error::other("catalog object id exhausted"))?;
Ok(self.object_high_water)
}
/// 返回所有表的 (表名, schema)。
@@ -106,15 +141,28 @@ impl Catalog {
/// 建表;已存在报错
pub fn create_table(&mut self, table: &str, columns: Vec<SchemaColumn>) -> io::Result<()> {
self.create_table_with_id(table, columns, None)
}
/// 按日志中的编号建立表
pub fn create_table_with_id(&mut self, table: &str, columns: Vec<SchemaColumn>, object_id: Option<u64>) -> io::Result<()> {
if self.tables.contains_key(table) {
return Err(io::Error::new(
io::ErrorKind::AlreadyExists,
format!("table already exists: {}", table),
));
}
let object_id = match object_id {
Some(id) if id == 0 || self.tables.values().any(|schema| schema.object_id == id) => {
return Err(io::Error::other("invalid catalog object id"));
}
Some(id) => { self.object_high_water = self.object_high_water.max(id); id }
None => self.reserve_object_id()?,
};
self.tables.insert(
table.to_string(),
TableSchema {
object_id,
system: false,
columns,
dropped_columns: BTreeSet::new(),
@@ -188,6 +236,18 @@ impl Catalog {
let entry = self.tables.entry(table.to_string()).or_default();
entry.stats.clear();
entry.row_count = 0;
for row in rows {
for (name, value) in row {
if let Some(x) = value.as_f64() {
let stat = entry.stats.entry(name.clone()).or_default();
stat.lo = Some(stat.lo.map_or(x, |lo| lo.min(x)));
stat.hi = Some(stat.hi.map_or(x, |hi| hi.max(x)));
if stat.hist.is_empty() {
stat.hist = vec![0; HIST_BUCKETS];
}
}
}
}
}
let mut changed = false;
for row in rows {
+8 -1
View File
@@ -25,6 +25,8 @@ pub struct Account {
pub is_superuser: bool,
#[serde(default)]
pub system_catalog_manager: bool,
#[serde(default)]
pub allow_sudo_auth: bool,
#[serde(default = "default_true")]
pub enabled: bool,
#[serde(default)]
@@ -96,7 +98,7 @@ pub enum Request {
AccountsList,
IdentityInitialize { administrator: String },
RoleCreate { user: String },
IdentityAlter { user: String, can_login: Option<bool>, is_superuser: Option<bool>, enabled: Option<bool>, system_catalog_manager: Option<bool> },
IdentityAlter { user: String, can_login: Option<bool>, is_superuser: Option<bool>, enabled: Option<bool>, system_catalog_manager: Option<bool>, allow_sudo_auth: Option<bool> },
AccountCreate { user: String, password_hash: String },
AccountReset { user: String, password_hash: String },
AccountLogin {
@@ -305,11 +307,16 @@ pub enum Response {
},
Error { message: String },
Catalog { schemas: Vec<TableSchemaWire> },
Object { database_id: u64, object_id: Option<u64> },
}
#[derive(Debug, Clone, Serialize, Deserialize)]
pub struct TableSchemaWire {
pub table: String,
#[serde(default)]
pub database_id: u64,
#[serde(default)]
pub object_id: u64,
pub columns: Vec<SchemaColumn>,
#[serde(default)]
pub row_count: u64,
+157 -15
View File
@@ -30,10 +30,48 @@ struct Server {
type TableDescription = (Vec<SchemaColumn>, u64, Vec<IndexWire>, Vec<ColumnStatWire>);
impl Server {
/// 读取受保护的对象权限快照
fn object_acl_read(&self) -> std::io::Result<Vec<Row>> {
if !self.table_exists("__system_object_acl")? { return Ok(Vec::new()); }
let rows = self.with_existing_table("__system_object_acl", |table| table.scan())?;
let mut payload = String::new();
for (index, row) in rows.iter().enumerate() {
if row.get("id").and_then(|value| value.as_u64()) != Some(index as u64 + 1) {
return Err(std::io::Error::other("invalid object ACL chunk sequence"));
}
payload.push_str(row.get("payload").and_then(|value| value.as_str())
.ok_or_else(|| std::io::Error::other("invalid object ACL chunk"))?);
}
if rows.is_empty() { return Err(std::io::Error::other("empty object ACL snapshot")); }
Ok(vec![serde_json::from_value(serde_json::json!({"id":1,"payload":payload})).map_err(std::io::Error::other)?])
}
/// 比较并原子替换对象权限快照
fn object_acl_replace(&self, expected: Option<&str>, payload: &str) -> std::io::Result<()> {
let rows = self.object_acl_read()?;
let current = rows.first().and_then(|row| row.get("payload")).and_then(|value| value.as_str());
if current != expected { return Err(std::io::Error::other("object ACL changed concurrently")); }
let _: serde_json::Value = serde_json::from_str(payload).map_err(std::io::Error::other)?;
let mut ops = Vec::new();
if !self.table_exists("__system_object_acl")? {
ops.push(WalOp::CreateTable { table: "__system_object_acl".into(),
columns: vec![SchemaColumn { name: "id".into(), ty: "int".into(), ..Default::default() },
SchemaColumn { name: "payload".into(), ty: "str".into(), ..Default::default() }], object_id: None });
}
let chars: Vec<char> = payload.chars().collect();
let rows = chars.chunks(256).enumerate().map(|(index, chunk)| {
serde_json::from_value(serde_json::json!({"id":index + 1,"payload":chunk.iter().collect::<String>()}))
.map_err(std::io::Error::other)
}).collect::<std::io::Result<Vec<Row>>>()?;
ops.push(WalOp::ReplaceAll { table: "__system_object_acl".into(), rows });
self.group_via_wal(&ops)
}
/// 新建服务器状态
fn new(cfg: Config) -> std::io::Result<Self> {
std::fs::create_dir_all(&cfg.data_dir)?;
let catalog = Catalog::load(cfg.data_dir.join("catalog.json"))?;
catalog.save(cfg.data_dir.join("catalog.json"))?;
let wal = Wal::new(cfg.data_dir.join("wal.log"));
Ok(Server {
cfg,
@@ -306,11 +344,11 @@ impl Server {
let _ = std::fs::remove_file(self.index_path(table, column));
Ok(())
}
WalOp::CreateTable { table, columns } => {
WalOp::CreateTable { table, columns, object_id } => {
self.with_table(table, |_t| Ok(()))?;
let mut c = self.catalog.lock().map_err(|_| std::io::Error::other("catalog lock poisoned"))?;
c.create_table(table, columns.clone())?;
if table == TYPES_TABLE { c.mark_system(table)?; }
c.create_table_with_id(table, columns.clone(), *object_id)?;
if table == TYPES_TABLE || table == "__system_object_acl" { c.mark_system(table)?; }
c.save(self.catalog_path())
}
WalOp::DropTable { table } => {
@@ -506,12 +544,22 @@ impl Server {
fn group_via_wal(&self, ops: &[WalOp]) -> std::io::Result<()> {
std::fs::create_dir_all(&self.cfg.data_dir)?;
let wal = &self.wal;
let commit_lsn = wal.append_group(ops)?;
let mut ops = std::borrow::Cow::Borrowed(ops);
if ops.iter().any(|op| matches!(op, WalOp::CreateTable { object_id: None, .. })) {
let mut catalog = self.catalog.lock().map_err(|_| std::io::Error::other("catalog lock poisoned"))?;
for op in ops.to_mut() {
if let WalOp::CreateTable { object_id, .. } = op
&& object_id.is_none() {
*object_id = Some(catalog.reserve_object_id()?);
}
}
}
let commit_lsn = wal.append_group(&ops)?;
self.recovery_required.store(true, Ordering::Release);
for op in ops {
for op in ops.iter() {
self.apply_op(op)?;
}
for op in ops {
for op in ops.iter() {
self.flush_op_tables(op)?;
}
self.flush_all_tables()?;
@@ -639,7 +687,16 @@ impl Server {
let c = self.catalog.lock().unwrap();
Ok(c.describe(table).is_some_and(|s| !s.columns.iter().any(|col| &col.name == column)))
}
WalOp::CreateTable { table, .. } => self.table_exists(table),
WalOp::CreateTable { table, object_id, .. } => {
let catalog = self.catalog.lock().map_err(|_| std::io::Error::other("catalog lock poisoned"))?;
match catalog.describe(table) {
Some(schema) if object_id.is_some_and(|id| id != schema.object_id) => {
Err(std::io::Error::other("WAL catalog object id mismatch"))
}
Some(_) => Ok(true),
None => Ok(false),
}
}
WalOp::DropTable { table } => Ok(!self.table_exists(table)?
&& !self.table_path(table).exists()
&& !self.index_path(table, "id").exists()),
@@ -1063,11 +1120,11 @@ impl Server {
Request::CatalogManage { command } => {
let target = match command.as_ref() {
Request::AccountCreate { user, .. } | Request::AccountReset { user, .. } | Request::AccountDrop { user }
| Request::IdentityAlter { user, is_superuser: None, system_catalog_manager: None, .. } => Some(account_name(user)?),
| Request::IdentityAlter { user, is_superuser: None, system_catalog_manager: None, allow_sudo_auth: None, .. } => Some(account_name(user)?),
Request::AccountsList => None,
_ => return Err(Error::other("superuser required for this catalog operation")),
};
if accounts.iter().any(|a| target.as_ref() == Some(&a.user) && (a.is_superuser || a.system_catalog_manager)) {
if accounts.iter().any(|a| target.as_ref() == Some(&a.user) && (a.is_superuser || a.system_catalog_manager || a.allow_sudo_auth)) {
return Err(Error::other("superuser required to manage privileged identities"));
}
*command
@@ -1116,10 +1173,13 @@ impl Server {
}
let unified = self.catalog.lock().map_err(|_| Error::other("catalog lock poisoned"))?.describe(IDENTITIES_TABLE).is_some();
if !accounts.is_empty() { require_superuser(&accounts)?; }
if unified && previous == accounts { return Ok(accounts); }
let sudo_column = self.catalog.lock().map_err(|_| Error::other("catalog lock poisoned"))?.describe(IDENTITIES_TABLE)
.is_some_and(|schema| schema.columns.iter().any(|column| column.name == "allow_sudo_auth"));
if unified && sudo_column && previous == accounts { return Ok(accounts); }
}
Request::AccountCreate { user, password_hash } => {
let name = account_name(&user)?;
if name == "public" { return Err(Error::other("public is reserved for default privileges")); }
if accounts.iter().any(|a| a.user == name) {
return Err(Error::new(ErrorKind::AlreadyExists, "account already exists"));
}
@@ -1129,6 +1189,7 @@ impl Server {
}
Request::RoleCreate { user } => {
let name = account_name(&user)?;
if name == "public" { return Err(Error::other("public is reserved for default privileges")); }
if accounts.iter().any(|a| a.user == name) { return Err(Error::new(ErrorKind::AlreadyExists, "identity already exists")); }
let id = accounts.iter().map(|a| a.id).max().unwrap_or(0).max(self.catalog.lock().map_err(|_| Error::other("catalog lock poisoned"))?.identity_high_water)
.checked_add(1).ok_or_else(|| Error::other("account id exhausted"))?;
@@ -1136,13 +1197,14 @@ impl Server {
role.can_login = false;
accounts.push(role);
}
Request::IdentityAlter { user, can_login, is_superuser, enabled, system_catalog_manager } => {
Request::IdentityAlter { user, can_login, is_superuser, enabled, system_catalog_manager, allow_sudo_auth } => {
let name = account_name(&user)?;
let account = accounts.iter_mut().find(|a| a.user == name).ok_or_else(|| Error::new(ErrorKind::NotFound, "unknown account"))?;
account.can_login = can_login.unwrap_or(account.can_login);
account.is_superuser = is_superuser.unwrap_or(account.is_superuser);
account.enabled = enabled.unwrap_or(account.enabled);
account.system_catalog_manager = system_catalog_manager.unwrap_or(account.system_catalog_manager);
account.allow_sudo_auth = allow_sudo_auth.unwrap_or(account.allow_sudo_auth);
account.revision = account.revision.checked_add(1).ok_or_else(|| Error::other("account revision exhausted"))?;
if had_superuser { require_superuser(&accounts)?; }
}
@@ -1226,7 +1288,7 @@ impl Server {
}
if existing.is_some() && original == rows { return Ok(rows); }
let mut ops = Vec::new();
if existing.is_none() { ops.push(WalOp::CreateTable { table: TYPES_TABLE.into(), columns }); }
if existing.is_none() { ops.push(WalOp::CreateTable { table: TYPES_TABLE.into(), columns, object_id: None }); }
ops.push(WalOp::ReplaceAll { table: TYPES_TABLE.into(), rows: rows.clone() });
self.recovery_required.store(true, Ordering::Release);
self.group_via_wal(&ops)?;
@@ -1499,6 +1561,8 @@ impl Server {
.filter(|(name, _)| !blocked_table(name))
.map(|(name, ts)| TableSchemaWire {
table: name.to_string(),
database_id: c.database_id,
object_id: ts.object_id,
columns: ts.columns.clone(),
row_count: ts.row_count,
indexes: index_wires(ts),
@@ -1543,7 +1607,7 @@ impl Server {
};
}
let tname = table.clone();
let op = WalOp::CreateTable { table, columns };
let op = WalOp::CreateTable { table, columns, object_id: None };
match self.write_via_wal(&op) {
Ok(()) => Response::Ok,
Err(e) => {
@@ -1733,6 +1797,7 @@ fn identity_rows(accounts: &[Account]) -> std::io::Result<Vec<Row>> {
("can_login".into(), serde_json::json!(a.can_login)),
("is_superuser".into(), serde_json::json!(a.is_superuser)),
("system_catalog_manager".into(), serde_json::json!(a.system_catalog_manager)),
("allow_sudo_auth".into(), serde_json::json!(a.allow_sudo_auth)),
("enabled".into(), serde_json::json!(a.enabled)),
("identity_version".into(), serde_json::json!(a.identity_version)),
("registered_at".into(), serde_json::Value::String(a.registered_at.clone())),
@@ -1764,6 +1829,7 @@ fn identity_columns() -> Vec<SchemaColumn> {
SchemaColumn { name: "can_login".into(), ty: "bool".into(), nullable: false, ..Default::default() },
SchemaColumn { name: "is_superuser".into(), ty: "bool".into(), nullable: false, ..Default::default() },
SchemaColumn { name: "system_catalog_manager".into(), ty: "bool".into(), nullable: false, ..Default::default() },
SchemaColumn { name: "allow_sudo_auth".into(), ty: "bool".into(), nullable: false, ..Default::default() },
SchemaColumn { name: "enabled".into(), ty: "bool".into(), nullable: false, ..Default::default() },
SchemaColumn { name: "identity_version".into(), ty: "int".into(), nullable: false, ..Default::default() },
SchemaColumn { name: "registered_at".into(), ty: "timestamp".into(),
@@ -1805,6 +1871,10 @@ fn decode_account_row(row: &Row) -> std::io::Result<Account> {
can_login: row.get("can_login").and_then(serde_json::Value::as_bool).unwrap_or(true),
is_superuser: row.get("is_superuser").and_then(serde_json::Value::as_bool).unwrap_or(false),
system_catalog_manager: row.get("system_catalog_manager").and_then(serde_json::Value::as_bool).unwrap_or(false),
allow_sudo_auth: match row.get("allow_sudo_auth") {
None => false,
Some(value) => value.as_bool().ok_or_else(|| std::io::Error::other("invalid sudo authentication attribute"))?,
},
enabled: row.get("enabled").and_then(serde_json::Value::as_bool).unwrap_or(true),
identity_version: row.get("identity_version").and_then(serde_json::Value::as_u64).unwrap_or(0) as u8,
})
@@ -1880,6 +1950,7 @@ fn new_account(id: i64, user: &str, password_hash: String) -> std::io::Result<Ac
can_login: true,
is_superuser: false,
system_catalog_manager: false,
allow_sudo_auth: false,
enabled: true,
identity_version: 1,
})
@@ -2019,7 +2090,37 @@ impl Databases {
named.insert(name, Arc::new(server));
}
}
Ok(Self { root: cfg, system, named: Mutex::new(named) })
{
let mut catalog = system.catalog.lock().map_err(|_| std::io::Error::other("catalog lock poisoned"))?;
let mut ids = HashSet::new();
if catalog.database_id != 0 { ids.insert(catalog.database_id); }
for server in named.values() {
let id = server.catalog.lock().map_err(|_| std::io::Error::other("catalog lock poisoned"))?.database_id;
if id != 0 && !ids.insert(id) { return Err(std::io::Error::other("duplicate database object id")); }
catalog.object_high_water = catalog.object_high_water.max(id);
}
if catalog.database_id == 0 { catalog.database_id = catalog.reserve_object_id()?; }
catalog.save(system.catalog_path())?;
}
let databases = Self { root: cfg, system, named: Mutex::new(named) };
{
let named = databases.named.lock().map_err(|_| std::io::Error::other("database lock poisoned"))?;
for server in named.values() { databases.assign_database_id(server)?; }
}
Ok(databases)
}
/// 为数据库持久化不复用的编号
fn assign_database_id(&self, server: &Server) -> std::io::Result<()> {
let mut catalog = server.catalog.lock().map_err(|_| std::io::Error::other("catalog lock poisoned"))?;
if catalog.database_id == 0 {
let mut system = self.system.catalog.lock().map_err(|_| std::io::Error::other("catalog lock poisoned"))?;
let id = system.reserve_object_id()?;
system.save(self.system.catalog_path())?;
catalog.database_id = id;
catalog.save(server.catalog_path())?;
}
Ok(())
}
/// 按名字打开或新建一个库
@@ -2049,6 +2150,42 @@ impl Databases {
if !name.is_empty() && !valid_database(&name) { return Err(Error::other("invalid database name")); }
let mut named = self.named.lock().map_err(|_| Error::other("database lock poisoned"))?;
match method.as_str() {
"object_acl_read" => {
drop(named);
let _gate = self.system.gate.read().map_err(|_| Error::other("database gate poisoned"))?;
if self.system.recovery_required.load(Ordering::Acquire) { return Err(Error::other("recovery required")); }
return Ok(Response::Rows { rows: self.system.object_acl_read()? });
}
"object_acl_replace" => {
drop(named);
let _gate = self.system.gate.write().map_err(|_| Error::other("database gate poisoned"))?;
if self.system.recovery_required.load(Ordering::Acquire) { return Err(Error::other("recovery required")); }
let expected = match value.get("expected") {
None | Some(serde_json::Value::Null) => None,
Some(serde_json::Value::String(value)) => Some(value.as_str()),
_ => return Err(Error::other("invalid expected ACL payload")),
};
let payload = value.get("payload").and_then(|value| value.as_str()).ok_or_else(|| Error::other("missing ACL payload"))?;
self.system.object_acl_replace(expected, payload)?;
return Ok(Response::Ok);
}
"resolve_object" => {
let server = if name == SYSTEM_DATABASE { &self.system }
else { named.get(&name).ok_or_else(|| Error::other("unknown database"))? };
let _gate = server.gate.read().map_err(|_| Error::other("database gate poisoned"))?;
if server.recovery_required.load(Ordering::Acquire) { return Err(Error::other("recovery required")); }
let catalog = server.catalog.lock().map_err(|_| Error::other("catalog lock poisoned"))?;
let object_id = match value.get("table") {
None => None,
Some(serde_json::Value::String(table)) if !blocked_table(table) => {
let schema = catalog.describe(table).ok_or_else(|| Error::other("unknown table"))?;
if schema.object_id == 0 { return Err(Error::other("missing catalog object id")); }
Some(schema.object_id)
}
_ => return Err(Error::other("invalid object table")),
};
return Ok(Response::Object { database_id: catalog.database_id, object_id });
}
"all_catalogs" => {
let servers: Vec<(String, Arc<Server>)> =
std::iter::once((SYSTEM_DATABASE.to_string(), Arc::clone(&self.system)))
@@ -2082,6 +2219,7 @@ impl Databases {
cfg.data_dir = cfg.data_dir.join("databases").join(&name);
std::fs::create_dir(&cfg.data_dir)?;
let server = Server::new(cfg)?;
self.assign_database_id(&server)?;
server.catalog.lock().map_err(|_| Error::other("catalog lock poisoned"))?.save(server.catalog_path())?;
named.insert(name, Arc::new(server));
return Ok(Response::Ok);
@@ -2215,7 +2353,11 @@ fn maintenance_candidate(cfg: Config, mode: &str, user: &str, hash: &str, types:
}
let repair = mode == "repair";
let catalog_path = cfg.data_dir.join("catalog.json");
let schemas = maintenance_schemas();
let mut schemas = maintenance_schemas();
if cfg.data_dir.join("__system_object_acl.db").is_file() {
schemas.push(("__system_object_acl", vec![SchemaColumn { name: "id".into(), ty: "int".into(), ..Default::default() },
SchemaColumn { name: "payload".into(), ty: "str".into(), ..Default::default() }]));
}
let mut missing_data = Vec::new();
let mut catalog = match Catalog::load(&catalog_path) {
Ok(catalog) => catalog,
+6 -2
View File
@@ -61,6 +61,7 @@ pub enum WalOp {
CreateTable {
table: String,
columns: Vec<SchemaColumn>,
object_id: Option<u64>,
},
DropTable {
table: String,
@@ -92,6 +93,8 @@ struct ReplaceSchemaPayload {
#[derive(Debug, Serialize, Deserialize)]
struct CreateTablePayload {
columns: Vec<SchemaColumn>,
#[serde(default)]
object_id: Option<u64>,
}
pub struct Wal {
@@ -416,10 +419,10 @@ fn encode(op: &WalOp, lsn: u64) -> io::Result<Vec<u8>> {
.map_err(io::Error::other)?;
(OP_REPLACE_SCHEMA, table.clone(), p)
}
WalOp::CreateTable { table, columns } => (
WalOp::CreateTable { table, columns, object_id } => (
OP_CREATE_TABLE,
table.clone(),
serde_json::to_vec(&CreateTablePayload { columns: columns.clone() })
serde_json::to_vec(&CreateTablePayload { columns: columns.clone(), object_id: *object_id })
.map_err(io::Error::other)?,
),
WalOp::DropTable { table } => (OP_DROP_TABLE, table.clone(), Vec::new()),
@@ -536,6 +539,7 @@ fn decode_body(body: &[u8]) -> Result<(u64, WalOp), String> {
WalOp::CreateTable {
table,
columns: p.columns,
object_id: p.object_id,
}
}
OP_DROP_TABLE => WalOp::DropTable { table },
+71
View File
@@ -4,6 +4,55 @@ use serde_json::json;
// 数据字典测试:补列、去重、未知表。
/// 表删除重建和重载均保留编号规则
#[test]
fn object_ids_survive_reload_and_are_not_reused() {
let dir = tempfile::tempdir().unwrap();
let path = dir.path().join("catalog.json");
let mut catalog = Catalog::default();
catalog.create_table("t", vec![]).unwrap();
let old = catalog.describe("t").unwrap().object_id;
assert_ne!(old, 0);
catalog.save(&path).unwrap();
let mut catalog = Catalog::load(&path).unwrap();
assert_eq!(catalog.describe("t").unwrap().object_id, old);
catalog.drop_table("t").unwrap();
catalog.save(&path).unwrap();
let mut catalog = Catalog::load(&path).unwrap();
catalog.create_table("t", vec![]).unwrap();
assert!(catalog.describe("t").unwrap().object_id > old);
}
/// 旧目录迁移保留已有编号并拒绝重复
#[test]
fn legacy_object_ids_upgrade_without_collisions() {
let dir = tempfile::tempdir().unwrap();
let path = dir.path().join("catalog.json");
std::fs::write(&path, json!({"tables": {
"a": {"columns": [], "object_id": 42},
"b": {"columns": []}
}}).to_string()).unwrap();
let catalog = Catalog::load(&path).unwrap();
assert_eq!(catalog.describe("a").unwrap().object_id, 42);
assert_eq!(catalog.describe("b").unwrap().object_id, 43);
catalog.save(&path).unwrap();
assert_eq!(Catalog::load(&path).unwrap().describe("b").unwrap().object_id, 43);
std::fs::write(&path, json!({"tables": {
"a": {"columns": [], "object_id": 42},
"b": {"columns": [], "object_id": 42}
}}).to_string()).unwrap();
assert!(Catalog::load(&path).unwrap_err().to_string().contains("duplicate"));
}
/// 编号耗尽明确失败且不建立对象
#[test]
fn exhausted_object_ids_fail_without_creating_table() {
let mut catalog = Catalog::default();
catalog.object_high_water = u64::MAX;
assert!(catalog.create_table("t", vec![]).is_err());
assert!(catalog.describe("t").is_none());
}
/// 用键值对构造一行
@@ -154,6 +203,28 @@ fn capped_distinct_keeps_histogram_and_other_columns_accurate() {
assert_eq!(catalog.describe("t").unwrap().stats["id"].distinct, 4000);
}
/// 重建直方图不受行顺序影响
#[test]
fn rebuilt_histogram_has_exact_buckets_in_any_order() {
let rows: Vec<Row> = (0..160).map(|n| row(&[("v", json!(n))])).collect();
let mut forward = Catalog::default();
forward.rebuild_stats("t", &rows);
let mut reverse = Catalog::default();
let reversed: Vec<Row> = rows.iter().rev().cloned().collect();
reverse.rebuild_stats("t", &reversed);
let stat = &forward.describe("t").unwrap().stats["v"];
assert_eq!(stat.hist, vec![10; 16]);
assert_eq!(stat.hist, reverse.describe("t").unwrap().stats["v"].hist);
forward.record_insert("t", &row(&[("v", json!(10000))]));
forward.record_delete("t", &[row(&[("v", json!(10000))])]);
forward.rebuild_stats("t", &rows[80..]);
let repaired = &forward.describe("t").unwrap().stats["v"];
assert_eq!(repaired.lo, Some(80.0));
assert_eq!(repaired.hi, Some(159.0));
assert_eq!(repaired.hist, vec![5; 16]);
assert_eq!(forward.describe("t").unwrap().row_count, 80);
}
/// 老类型名并到新写法,参数保留,未知类型原样
#[test]
fn normalize_type_maps_legacy_names() {
+248 -2
View File
@@ -5,11 +5,165 @@ use chusql_core_storage::runtime::Storage;
// 进程内存储集成测试:协议请求、索引、账号与配置。
/// 权限快照支持跨页文本并拒绝旧版本覆盖
#[test]
fn object_acl_snapshots_are_private_and_compare_versions() -> Result<(), Box<dyn std::error::Error>> {
let (server, data) = start_server();
let mut c = connect()?;
let payload = serde_json::json!({"grants": "权限\"\\".repeat(4000)}).to_string();
request_ok(&mut c, serde_json::json!({"method":"object_acl_replace","expected":null,"payload":payload}))?;
let current: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"object_acl_read"}"#))?;
assert_eq!(current["rows"][0]["payload"], payload);
let conflict = send(&mut c, r#"{"method":"object_acl_replace","expected":null,"payload":"{}"}"#);
assert!(conflict.contains("changed concurrently"), "{conflict}");
assert!(send(&mut c, r#"{"method":"scan","database":"system","table":"__system_object_acl"}"#).contains("reserved system table"));
assert!(!send(&mut c, r#"{"method":"all_catalogs"}"#).contains("__system_object_acl"));
drop(c);
drop(server);
let _restarted = restart_at(data.path())?;
let mut c = connect()?;
let reloaded: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"object_acl_read"}"#))?;
assert_eq!(reloaded, current);
Ok(())
}
/// 权限并发替换只能有一个版本提交
#[test]
fn concurrent_object_acl_replacement_preserves_one_winner() -> Result<(), Box<dyn std::error::Error>> {
let (_server, _data) = start_server();
let mut c = connect()?;
let workers: Vec<_> = (0..8).map(|index| {
let storage = Arc::clone(&c.0);
std::thread::spawn(move || storage.request_line(&serde_json::json!({
"method":"object_acl_replace","expected":null,"payload":serde_json::json!({"winner":index}).to_string()
}).to_string()))
}).collect();
let replies: Vec<serde_json::Value> = workers.into_iter().map(|worker| serde_json::from_str(&worker.join().unwrap()).unwrap()).collect();
assert_eq!(replies.iter().filter(|reply| reply["status"] == "ok").count(), 1);
assert_eq!(replies.iter().filter(|reply| reply["message"].as_str().is_some_and(|message| message.contains("changed concurrently"))).count(), 7);
let loaded: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"object_acl_read"}"#))?;
assert!(serde_json::from_str::<serde_json::Value>(loaded["rows"][0]["payload"].as_str().unwrap())?["winner"].is_number());
Ok(())
}
/// 权限快照落盘失败后重放完整替换
#[test]
fn object_acl_commit_failure_replays_the_complete_snapshot() -> Result<(), Box<dyn std::error::Error>> {
let (server, data) = start_server();
let mut c = connect()?;
let pending = data.path().join("system/catalog.json.pending");
std::fs::create_dir(&pending)?;
let failed = send(&mut c, r#"{"method":"object_acl_replace","expected":null,"payload":"{\"version\":1}"}"#);
assert!(failed.contains("error"), "{failed}");
assert!(send(&mut c, r#"{"method":"object_acl_read"}"#).contains("recovery required"));
drop(c);
drop(server);
std::fs::remove_dir(pending)?;
let _restarted = restart_at(data.path())?;
let mut c = connect()?;
let loaded: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"object_acl_read"}"#))?;
assert_eq!(loaded["rows"][0]["payload"], "{\"version\":1}");
Ok(())
}
/// 对象编号区分跨库同名及删除重建
#[test]
fn object_identity_tracks_database_and_table_incarnations() -> Result<(), Box<dyn std::error::Error>> {
let (server, data) = start_server();
let mut c = connect()?;
request_ok(&mut c, serde_json::json!({"method":"create_database","database":"other"}))?;
for database in ["main", "other"] {
request_ok(&mut c, serde_json::json!({"method":"create_table","database":database,"table":"items","columns":[{"name":"id","ty":"int"}]}))?;
}
let old: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"resolve_object","database":"main","table":"items"}"#))?;
let other: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"resolve_object","database":"other","table":"items"}"#))?;
assert_eq!(old["status"], "object");
assert_ne!(old["database_id"], other["database_id"]);
assert!(old["object_id"].as_u64().unwrap() > 0);
let catalog: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"list_catalog","database":"main"}"#))?;
let info = catalog["schemas"].as_array().unwrap().iter().find(|entry| entry["table"] == "items").unwrap();
assert_eq!(info["database_id"], old["database_id"]);
assert_eq!(info["object_id"], old["object_id"]);
drop(c);
drop(server);
let restarted = restart_at(data.path())?;
let mut c = connect()?;
let stable: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"resolve_object","database":"main","table":"items"}"#))?;
assert_eq!(stable, old);
request_ok(&mut c, serde_json::json!({"method":"drop_table","database":"main","table":"items"}))?;
assert!(send(&mut c, r#"{"method":"resolve_object","database":"main","table":"items"}"#).contains("unknown table"));
request_ok(&mut c, serde_json::json!({"method":"create_table","database":"main","table":"items","columns":[{"name":"id","ty":"int"}]}))?;
let new: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"resolve_object","database":"main","table":"items"}"#))?;
assert_eq!(new["database_id"], old["database_id"]);
assert_ne!(new["object_id"], old["object_id"]);
request_ok(&mut c, serde_json::json!({"method":"drop_database","database":"other"}))?;
request_ok(&mut c, serde_json::json!({"method":"create_database","database":"other"}))?;
let new_database: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"resolve_object","database":"other"}"#))?;
assert_ne!(new_database["database_id"], other["database_id"]);
assert!(new_database["object_id"].is_null());
drop(c);
drop(restarted);
Ok(())
}
thread_local! {
/// 当前线程的存储实例:一个用例一个线程,用例内部按顺序起/停
static CURRENT: RefCell<Option<Arc<Storage>>> = const { RefCell::new(None) };
}
/// 建表应用失败后按日志恢复原编号
#[test]
fn object_id_survives_committed_create_recovery() -> Result<(), Box<dyn std::error::Error>> {
use chusql_core_storage::wal::{Wal, WalOp};
let (server, data) = start_server();
let mut c = connect()?;
let directory = data.path().join("databases/main");
let pending = directory.join("catalog.json.pending");
std::fs::create_dir(&pending)?;
assert!(send(&mut c, r#"{"method":"create_table","table":"recovered","columns":[{"name":"id","ty":"int"}]}"#).contains("error"));
assert!(send(&mut c, r#"{"method":"resolve_object","database":"main","table":"recovered"}"#).contains("recovery required"));
let wal = Wal::new(directory.join("wal.log"));
let scan = wal.read_all()?;
let id = scan.records.iter().find_map(|(_, op)| match op {
WalOp::CreateTable { table, object_id, .. } if table == "recovered" => *object_id,
_ => None,
}).unwrap();
drop(wal);
drop(c);
drop(server);
std::fs::remove_dir(pending)?;
let _restarted = restart_at(data.path())?;
let mut c = connect()?;
let resolved: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"resolve_object","database":"main","table":"recovered"}"#))?;
assert_eq!(resolved["object_id"], id);
Ok(())
}
/// 并发建表分配互不重复的编号
#[test]
fn concurrent_table_creation_allocates_distinct_object_ids() -> Result<(), Box<dyn std::error::Error>> {
let (_server, _data) = start_server();
let mut c = connect()?;
let workers: Vec<_> = (0..16).map(|index| {
let storage = Arc::clone(&c.0);
std::thread::spawn(move || storage.request_line(&serde_json::json!({
"method":"create_table", "database":"main", "table":format!("concurrent_{index}"),
"columns":[{"name":"id","ty":"int"}]
}).to_string()))
}).collect();
for worker in workers {
let result: serde_json::Value = serde_json::from_str(&worker.join().unwrap())?;
assert_eq!(result["status"], "ok");
}
let response: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"list_catalog","database":"main"}"#))?;
let ids: std::collections::HashSet<_> = response["schemas"].as_array().unwrap().iter()
.filter(|schema| schema["table"].as_str().unwrap().starts_with("concurrent_"))
.map(|schema| schema["object_id"].as_u64().unwrap()).collect();
assert_eq!(ids.len(), 16);
assert!(!ids.contains(&0));
Ok(())
}
/// 定点写入检查舍入和整批原子拒绝
#[test]
fn decimal_writes_enforce_precision_before_wal() -> Result<(), Box<dyn std::error::Error>> {
@@ -246,6 +400,66 @@ fn legacy_account_wal_migrates_without_promoting_other_names() -> Result<(), Box
Ok(())
}
/// 读取并校验身份命令响应
fn account_response(c: &mut Conn, request: serde_json::Value) -> Result<serde_json::Value, Box<dyn std::error::Error>> {
let response: serde_json::Value = serde_json::from_str(&send(c, &request.to_string()))?;
assert_eq!(response["status"], "accounts", "{response}");
Ok(response)
}
/// 本机认证开关独立持久化并推进会话版本
#[test]
fn sudo_auth_is_independent_revocable_and_persistent() -> Result<(), Box<dyn std::error::Error>> {
let (server, data) = start_server();
let mut c = connect()?;
let original = account_response(&mut c, serde_json::json!({"method":"account_create","user":"local_user","password_hash":"hash"}))?;
let created = original["accounts"].as_array().unwrap().iter().find(|a| a["user"] == "local_user").unwrap();
assert_eq!(created["allow_sudo_auth"], false);
let changed = account_response(&mut c, serde_json::json!({"method":"identity_alter","user":"local_user","allow_sudo_auth":true}))?;
let local = changed["accounts"].as_array().unwrap().iter().find(|a| a["user"] == "local_user").unwrap();
assert_eq!(local["allow_sudo_auth"], true);
assert_eq!(local["is_superuser"], false);
assert_eq!(local["system_catalog_manager"], false);
assert_eq!(local["revision"], 2);
for command in [
serde_json::json!({"method":"identity_alter","user":"local_user","allow_sudo_auth":false}),
serde_json::json!({"method":"account_reset","user":"local_user","password_hash":"other"}),
serde_json::json!({"method":"identity_alter","user":"root","allow_sudo_auth":true}),
] {
let denied = send(&mut c, &serde_json::json!({"method":"catalog_manage","command":command}).to_string());
assert!(denied.contains("superuser required"), "{denied}");
}
drop(c);
drop(server);
let _restarted = restart_at(data.path())?;
let mut c = connect()?;
assert_eq!(account_response(&mut c, serde_json::json!({"method":"accounts_list"}))?, changed);
let revoked = account_response(&mut c, serde_json::json!({"method":"identity_alter","user":"local_user","allow_sudo_auth":false}))?;
let local = revoked["accounts"].as_array().unwrap().iter().find(|a| a["user"] == "local_user").unwrap();
assert_eq!(local["allow_sudo_auth"], false);
assert_eq!(local["revision"], 3);
Ok(())
}
/// 升级缺失本机认证列的旧目录
#[test]
fn sudo_auth_upgrades_old_identity_schema() -> Result<(), Box<dyn std::error::Error>> {
let (server, data) = start_server();
drop(server);
CURRENT.with(|slot| *slot.borrow_mut() = None);
let path = data.path().join("system/catalog.json");
let mut catalog: serde_json::Value = serde_json::from_slice(&std::fs::read(&path)?)?;
catalog["tables"]["__system_identities"]["columns"].as_array_mut().unwrap().retain(|column| column["name"] != "allow_sudo_auth");
std::fs::write(&path, serde_json::to_vec(&catalog)?)?;
let _restarted = restart_at(data.path())?;
let mut c = connect()?;
let upgraded = account_response(&mut c, serde_json::json!({"method":"identity_initialize","administrator":"root"}))?;
assert!(upgraded["accounts"].as_array().unwrap().iter().all(|a| a["allow_sudo_auth"] == false));
let catalog: serde_json::Value = serde_json::from_slice(&std::fs::read(&path)?)?;
assert!(catalog["tables"]["__system_identities"]["columns"].as_array().unwrap().iter().any(|column| column["name"] == "allow_sudo_auth"));
Ok(())
}
/// 身份属性重启保留且禁止删除最后管理员
#[test]
fn identity_attributes_survive_restart_and_protect_superuser() -> Result<(), Box<dyn std::error::Error>> {
@@ -1691,6 +1905,7 @@ fn create_table_replays_after_restart() -> Result<(), Box<dyn std::error::Error>
drop(server);
let group = vec![WalOp::CreateTable {
object_id: None,
table: "m4_create".into(),
columns: vec![
SchemaColumn {
@@ -1835,6 +2050,7 @@ fn already_applied_create_table_is_skipped_on_restart() -> Result<(), Box<dyn st
let wal = Wal::new(data.path().join("databases/main/wal.log"));
wal.append_group(&[WalOp::CreateTable {
object_id: None,
table: "m4_done".into(),
columns: vec![SchemaColumn {
name: "id".into(),
@@ -1995,6 +2211,36 @@ fn create_index_accepts_duplicate_values() {
assert!(r.contains(r#""status":"error""#), "the id index stays unique: {}", r);
}
/// 重启修复统计并保持点查范围结果
#[test]
fn restart_rebuilds_stale_stats_without_changing_index_results() -> Result<(), Box<dyn std::error::Error>> {
let (server, data) = start_server();
let mut c = connect()?;
let rows: Vec<serde_json::Value> = (0..160).map(|id| serde_json::json!({"id":id,"v":id})).collect();
request_ok(&mut c, serde_json::json!({"method":"insert_batch","table":"rebuilt","rows":rows}))?;
request_ok(&mut c, serde_json::json!({"method":"create_index","table":"rebuilt","column":"v"}))?;
let point: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"lookup_by_index","table":"rebuilt","column":"v","key":80}"#))?;
let range: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"range_by_index","table":"rebuilt","column":"v","lo":80,"hi":89}"#))?;
let scan: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"scan","table":"rebuilt"}"#))?;
drop(c);
drop(server);
let path = data.path().join("databases/main/catalog.json");
let mut catalog: serde_json::Value = serde_json::from_slice(&std::fs::read(&path)?)?;
catalog["tables"]["rebuilt"]["row_count"] = serde_json::json!(9999);
catalog["tables"]["rebuilt"]["stats"] = serde_json::json!({});
std::fs::write(&path, serde_json::to_vec(&catalog)?)?;
let _restarted = restart_at(data.path())?;
let mut c = connect()?;
assert_eq!(serde_json::from_str::<serde_json::Value>(&send(&mut c, r#"{"method":"lookup_by_index","table":"rebuilt","column":"v","key":80}"#))?, point);
assert_eq!(serde_json::from_str::<serde_json::Value>(&send(&mut c, r#"{"method":"range_by_index","table":"rebuilt","column":"v","lo":80,"hi":89}"#))?, range);
assert_eq!(serde_json::from_str::<serde_json::Value>(&send(&mut c, r#"{"method":"scan","table":"rebuilt"}"#))?, scan);
let schema: serde_json::Value = serde_json::from_str(&send(&mut c, r#"{"method":"describe_table","table":"rebuilt"}"#))?;
assert_eq!(schema["row_count"], 160);
let stat = schema["stats"].as_array().unwrap().iter().find(|stat| stat["name"] == "v").unwrap();
assert_eq!(stat["hist"], serde_json::json!([10,10,10,10,10,10,10,10,10,10,10,10,10,10,10,10]));
Ok(())
}
/// 数据字典里的统计:不同值个数
#[test]
fn stats_report_distinct_values() {
@@ -2264,9 +2510,9 @@ fn account_table_uses_typed_columns_and_stamps_login() -> Result<(), Box<dyn std
let entry = &catalog["tables"]["__system_identities"];
let columns = entry["columns"].as_array().ok_or("missing columns")?;
let names: Vec<&str> = columns.iter().map(|col| col["name"].as_str().unwrap_or("")).collect();
assert_eq!(names, vec!["id", "user", "can_login", "is_superuser", "system_catalog_manager", "enabled", "identity_version", "registered_at", "last_login_at", "revision"]);
assert_eq!(names, vec!["id", "user", "can_login", "is_superuser", "system_catalog_manager", "allow_sudo_auth", "enabled", "identity_version", "registered_at", "last_login_at", "revision"]);
let types: Vec<&str> = columns.iter().map(|col| col["ty"].as_str().unwrap_or("")).collect();
assert_eq!(types, vec!["int", "varchar(64)", "bool", "bool", "bool", "bool", "int", "timestamp", "timestamp", "int"]);
assert_eq!(types, vec!["int", "varchar(64)", "bool", "bool", "bool", "bool", "bool", "int", "timestamp", "timestamp", "int"]);
assert_eq!(columns[0]["primary_key"], true, "id 是主键");
assert_eq!(columns[0]["nullable"], false);
assert_eq!(columns[1]["unique"], true, "用户名唯一");
+23
View File
@@ -4,6 +4,29 @@ use serde_json::json;
// WAL 测试:追加、读取、清空、截断尾巴、LSN 与提交标记。
/// 建表编号完整往返且兼容旧载荷
#[test]
fn create_table_ids_round_trip_and_legacy_payloads_decode() {
let dir = tempfile::tempdir().unwrap();
let path = dir.path().join("wal.log");
let wal = Wal::new(&path);
let op = WalOp::CreateTable { table: "t".into(), columns: vec![], object_id: Some(42) };
wal.append(&op).unwrap();
assert_eq!(wal.read_all().unwrap().records[0].1, op);
drop(wal);
let mut body = 1_u64.to_le_bytes().to_vec();
body.push(11);
body.extend_from_slice(&1_u16.to_le_bytes());
body.extend_from_slice(b"t");
body.extend_from_slice(br#"{"columns":[]}"#);
let mut frame = (body.len() as u32).to_le_bytes().to_vec();
frame.extend_from_slice(&body);
std::fs::write(&path, frame).unwrap();
let wal = Wal::new(&path);
assert_eq!(wal.read_all().unwrap().records[0].1,
WalOp::CreateTable { table: "t".into(), columns: vec![], object_id: None });
}
/// 用键值对构造一行
fn row(pairs: &[(&str, serde_json::Value)]) -> Row {
+179
View File
@@ -0,0 +1,179 @@
#ifdef _WIN32
#define _WIN32_WINNT 0x0600
#include <windows.h>
#include <sddl.h>
#include <stdio.h>
#else
#include <unistd.h>
#include <fcntl.h>
#include <sys/stat.h>
#include <errno.h>
#include <stdio.h>
#endif
#include <string.h>
/* 创建、读取和清理仅本机提升身份可访问的认证凭据。 */
#ifdef _WIN32
/* 检查当前提升令牌的管理员成员资格。 */
int chusql_sudo_privileged(void) {
SID_IDENTIFIER_AUTHORITY authority = SECURITY_NT_AUTHORITY;
PSID administrators = NULL;
BOOL member = FALSE;
if (!AllocateAndInitializeSid(&authority, 2, SECURITY_BUILTIN_DOMAIN_RID,
DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, &administrators)) return 0;
if (!CheckTokenMembership(NULL, administrators, &member)) member = FALSE;
FreeSid(administrators);
return member != FALSE;
}
/* 生成系统保护目录中的端口专属路径。 */
static int credential_path(int port, wchar_t *directory, wchar_t *file) {
wchar_t base[MAX_PATH];
UINT length = GetSystemDirectoryW(base, MAX_PATH);
if (!length || length >= MAX_PATH - 80 || port < 1 || port > 65535) return ERROR_INVALID_PARAMETER;
swprintf(directory, MAX_PATH, L"%ls\\config\\ChuSQL-Sudo-%d", base, port);
swprintf(file, MAX_PATH, L"%ls\\credential", directory);
return 0;
}
/* 排除重解析目录与凭据文件。 */
static int plain_path(const wchar_t *path, int directory) {
DWORD attributes = GetFileAttributesW(path);
return attributes != INVALID_FILE_ATTRIBUTES && !(attributes & FILE_ATTRIBUTE_REPARSE_POINT)
&& (!!(attributes & FILE_ATTRIBUTE_DIRECTORY) == directory);
}
/* 用管理员与系统专属访问列表创建凭据。 */
int chusql_sudo_create(int port, const char *secret) {
wchar_t directory[MAX_PATH], file[MAX_PATH];
PSECURITY_DESCRIPTOR descriptor = NULL;
SECURITY_ATTRIBUTES attributes = {sizeof(SECURITY_ATTRIBUTES), NULL, FALSE};
DWORD written = 0, error;
HANDLE handle;
if (!chusql_sudo_privileged()) return ERROR_ACCESS_DENIED;
error = credential_path(port, directory, file);
if (error) return (int)error;
if (!ConvertStringSecurityDescriptorToSecurityDescriptorW(
L"D:P(A;OICI;FA;;;BA)(A;OICI;FA;;;SY)", SDDL_REVISION_1, &descriptor, NULL)) return (int)GetLastError();
attributes.lpSecurityDescriptor = descriptor;
if (!CreateDirectoryW(directory, &attributes)) {
error = GetLastError(); LocalFree(descriptor); return (int)error;
}
handle = CreateFileW(file, GENERIC_WRITE, FILE_SHARE_READ, &attributes, CREATE_NEW,
FILE_ATTRIBUTE_NORMAL | FILE_FLAG_OPEN_REPARSE_POINT, NULL);
LocalFree(descriptor);
if (handle == INVALID_HANDLE_VALUE) {
error = GetLastError(); RemoveDirectoryW(directory); return (int)error;
}
error = 0;
if (!WriteFile(handle, secret, 64, &written, NULL) || written != 64 || !FlushFileBuffers(handle))
error = GetLastError() ? GetLastError() : ERROR_WRITE_FAULT;
if (!CloseHandle(handle) && !error) error = GetLastError();
if (error) { DeleteFileW(file); RemoveDirectoryW(directory); }
return (int)error;
}
/* 从系统保护目录读取本机凭据。 */
int chusql_sudo_read(int port, char *secret) {
wchar_t directory[MAX_PATH], file[MAX_PATH];
DWORD received = 0, error;
LARGE_INTEGER size;
HANDLE handle;
if (!chusql_sudo_privileged()) return ERROR_ACCESS_DENIED;
error = credential_path(port, directory, file);
if (error) return (int)error;
if (!plain_path(directory, 1) || !plain_path(file, 0)) return ERROR_ACCESS_DENIED;
handle = CreateFileW(file, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL | FILE_FLAG_OPEN_REPARSE_POINT, NULL);
if (handle == INVALID_HANDLE_VALUE) return (int)GetLastError();
error = 0;
if (!GetFileSizeEx(handle, &size) || size.QuadPart != 64
|| !ReadFile(handle, secret, 64, &received, NULL) || received != 64) error = ERROR_INVALID_DATA;
if (!CloseHandle(handle) && !error) error = GetLastError();
return (int)error;
}
/* 删除本次服务启动创建的凭据目录。 */
int chusql_sudo_remove(int port) {
wchar_t directory[MAX_PATH], file[MAX_PATH];
int error = credential_path(port, directory, file);
if (error) return error;
if (!chusql_sudo_privileged()) return ERROR_ACCESS_DENIED;
if (!DeleteFileW(file)) return (int)GetLastError();
return RemoveDirectoryW(directory) ? 0 : (int)GetLastError();
}
#else
/* 检查当前进程的有效 root 身份。 */
int chusql_sudo_privileged(void) { return geteuid() == 0; }
/* 打开 root 专属目录并验证所有权与权限。 */
static int credential_directory(int port) {
char path[96];
struct stat status;
int fd;
if (port < 1 || port > 65535) { errno = EINVAL; return -1; }
snprintf(path, sizeof(path), "/var/run/chusql-sudo-%d", port);
fd = open(path, O_RDONLY | O_DIRECTORY | O_NOFOLLOW | O_CLOEXEC);
if (fd < 0) return -1;
if (fstat(fd, &status) || status.st_uid != 0 || (status.st_mode & 0777) != 0700) {
close(fd); errno = EACCES; return -1;
}
return fd;
}
/* 在 root 专属目录中独占创建凭据。 */
int chusql_sudo_create(int port, const char *secret) {
char path[96];
int dir, fd, error = 0;
if (!chusql_sudo_privileged()) return EACCES;
if (port < 1 || port > 65535) return EINVAL;
snprintf(path, sizeof(path), "/var/run/chusql-sudo-%d", port);
if (mkdir(path, 0700)) return errno;
dir = credential_directory(port);
if (dir < 0) { error = errno; rmdir(path); return error; }
fd = openat(dir, "credential", O_WRONLY | O_CREAT | O_EXCL | O_NOFOLLOW | O_CLOEXEC, 0600);
if (fd < 0) error = errno;
else {
if (write(fd, secret, 64) != 64 || fsync(fd)) error = errno ? errno : EIO;
if (close(fd) && !error) error = errno;
}
if (error) unlinkat(dir, "credential", 0);
if (close(dir) && !error) error = errno;
if (error) rmdir(path);
return error;
}
/* 验证 root 文件所有权后读取凭据。 */
int chusql_sudo_read(int port, char *secret) {
struct stat status;
int dir, fd, error = 0;
if (!chusql_sudo_privileged()) return EACCES;
dir = credential_directory(port);
if (dir < 0) return errno;
fd = openat(dir, "credential", O_RDONLY | O_NOFOLLOW | O_CLOEXEC);
if (fd < 0) error = errno;
else {
if (fstat(fd, &status) || !S_ISREG(status.st_mode) || status.st_uid != 0
|| (status.st_mode & 0777) != 0600 || status.st_size != 64 || status.st_nlink != 1) error = EACCES;
else if (read(fd, secret, 64) != 64) error = errno ? errno : EIO;
if (close(fd) && !error) error = errno;
}
if (close(dir) && !error) error = errno;
return error;
}
/* 删除本次服务启动创建的凭据目录。 */
int chusql_sudo_remove(int port) {
char path[96];
int dir, error = 0;
if (!chusql_sudo_privileged()) return EACCES;
dir = credential_directory(port);
if (dir < 0) return errno;
if (unlinkat(dir, "credential", 0)) error = errno;
if (close(dir) && !error) error = errno;
snprintf(path, sizeof(path), "/var/run/chusql-sudo-%d", port);
if (!error && rmdir(path)) error = errno;
return error;
}
#endif
+4
View File
@@ -21,6 +21,7 @@ library
ChuSQL.Interface.Protocol
ChuSQL.Interface.RateLimit
ChuSQL.Interface.Session
ChuSQL.Interface.Sudo
ChuSQL.Interface.Settings
ChuSQL.Interface.TOML
build-depends: base >= 4.14 && < 5
@@ -36,5 +37,8 @@ library
, scientific
, text
, time
c-sources: cbits/sudo_credential.c
if os(windows)
extra-libraries: advapi32
default-language: Haskell2010
ghc-options: -Wall
@@ -34,6 +34,9 @@ module ChuSQL.Interface.Actions (
import ChuSQL.Core.Model (Column (..), ColumnType (..), Value (..), integerType, numericType, parseColumnType, plainColumn, typeName)
import qualified ChuSQL.Core.Model as M
import ChuSQL.Core.Runtime
import ChuSQL.Core.Protocol (valueFromJSON)
import Data.Aeson.Types (parseEither)
import qualified Data.Aeson as A
import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
import Data.List (intercalate)
@@ -88,24 +91,50 @@ columnTypeOf = fmap plainColumn . parseColumnType . T.unpack . T.strip
-- | 本地类型转线上名字
columnTypeName :: Column -> Text
columnTypeName = T.pack . typeName . columnType
columnTypeName column = T.pack $ case columnType column of
CRuntime tid -> renderTypeExpr (typeExpression tid)
ty -> typeName ty
-- | 字符串字面量转义:单引号翻倍(引擎的词法器就是这么折回去的)
escapeStringLiteral :: String -> String
escapeStringLiteral = concatMap (\c -> if c == '\'' then "''" else [c])
-- | 值转 SQL 字面量
sqlLiteral :: Value -> String
sqlLiteral VNull = "NULL"
sqlLiteral (VInt n) = show n
sqlLiteral (VFloat d) = show d
sqlLiteral (VStr s) = "'" ++ escapeStringLiteral s ++ "'"
sqlLiteral (VBool True) = "TRUE"
sqlLiteral (VBool False) = "FALSE"
sqlLiteral :: Value -> Either String String
sqlLiteral VNull = Right "NULL"
sqlLiteral (VInt n) = Right (show n)
sqlLiteral (VFloat d)
| isNaN d || isInfinite d = Left "SQL floating literal must be finite"
| otherwise = Right (show d)
sqlLiteral (VStr s) = Right ("'" ++ escapeStringLiteral s ++ "'")
sqlLiteral (VBool True) = Right "TRUE"
sqlLiteral (VBool False) = Right "FALSE"
sqlLiteral (VRuntime tid value) = do
validateValue builtinTypes tid value
runtimeLiteral (typeExpression tid) value
-- | 渲染类型化构造器的 SQL 字面量
runtimeLiteral :: TypeExpr -> RuntimeValue -> Either String String
runtimeLiteral _ (RInt n) = Right (show n)
runtimeLiteral _ (RDouble n) = Right (show n)
runtimeLiteral _ (RBool b) = Right (if b then "TRUE" else "FALSE")
runtimeLiteral _ (RString text) = Right ("'" ++ escapeStringLiteral text ++ "'")
runtimeLiteral (TypeApply (TypeConstructorId 5) [child]) (RList values) = do
items <- mapM (runtimeLiteral child) values
Right ("LIST<" ++ renderTypeExpr child ++ ">(" ++ intercalate ", " items ++ ")")
runtimeLiteral (TypeApply (TypeConstructorId 6) [child]) (RMaybe value) = do
item <- maybe (Right "") (runtimeLiteral child) value
Right ("MAYBE<" ++ renderTypeExpr child ++ ">(" ++ item ++ ")")
runtimeLiteral (TypeApply (TypeConstructorId 7) fields) (RTuple values)
| length fields == length values = do
items <- sequence (zipWith runtimeLiteral fields values)
Right ("TUPLE<" ++ intercalate ", " (map renderTypeExpr fields) ++ ">(" ++ intercalate ", " items ++ ")")
runtimeLiteral _ _ = Left "runtime value does not match its type expression"
-- | JSON 值按列类型转成引擎的值;类型对不上就报错
coerceValue :: Column -> A.Value -> Either String Value
coerceValue col v = case v of
A.Object _ -> parseEither valueFromJSON v >>= M.coerceValue t
A.Null -> Right VNull
A.Bool b -> M.coerceValue t (VBool b)
A.Number n -> case floatingOrInteger n :: Either Double Integer of
@@ -186,13 +215,14 @@ insertRowSql table row = do
tbl <- checkIdent "table" table
cols <- requireNonEmpty "values" row
names <- mapM (checkIdent "column" . T.pack . fst) cols
literals <- mapM (sqlLiteral . snd) cols
pure
( "INSERT INTO "
++ T.unpack tbl
++ " ("
++ intercalate ", " (map T.unpack names)
++ ") VALUES ("
++ intercalate ", " (map (sqlLiteral . snd) cols)
++ intercalate ", " literals
++ ")"
)
@@ -208,14 +238,15 @@ insertRowsSql table rows = do
let widths = map length rs
if any (/= length first) widths
then Left "all rows must have the same columns"
else
else do
literals <- mapM (mapM (sqlLiteral . snd)) rs
pure
( "INSERT INTO "
++ T.unpack tbl
++ " ("
++ intercalate ", " (map T.unpack names)
++ ") VALUES "
++ intercalate ", " ["(" ++ intercalate ", " (map (sqlLiteral . snd) r) ++ ")" | r <- rs]
++ intercalate ", " ["(" ++ intercalate ", " values ++ ")" | values <- literals]
)
-- | 构造按 id 改行的 UPDATE 语句
@@ -223,8 +254,14 @@ updateRowSql :: Text -> Int -> [(String, Value)] -> Either String String
updateRowSql table key assigns = do
tbl <- checkIdent "table" table
cols <- requireNonEmpty "values" assigns
sets <- mapM (\(n, v) -> (\c -> T.unpack c ++ " = " ++ sqlLiteral v) <$> checkIdent "column" (T.pack n)) cols
sets <- mapM assignment cols
pure ("UPDATE " ++ T.unpack tbl ++ " SET " ++ intercalate ", " sets ++ " WHERE id = " ++ show key)
where
-- | 校验列名并编码赋值
assignment (name, value) = do
column <- checkIdent "column" (T.pack name)
literal <- sqlLiteral value
Right (T.unpack column ++ " = " ++ literal)
-- | 按 id 删一行,存储层原地删
deleteRowSql :: Text -> Int -> Either String String
@@ -251,7 +288,8 @@ whereClause filters = case filters of
-- | 一个等值条件
term (column, value) = do
col <- checkIdent "column" column
pure (T.unpack col ++ " = " ++ sqlLiteral value)
literal <- sqlLiteral value
pure (T.unpack col ++ " = " ++ literal)
-- | 拼 ORDER BY 子句,无排序给空串
orderClause :: Maybe (Text, Bool) -> Either String String
@@ -309,6 +347,8 @@ roleName name
-- | 授权对象:`*`,或长度不超过 128 的裸表名/`库.表`
grantObject :: Text -> Either String Text
grantObject object
| "database:" `T.isPrefixOf` T.toLower object = ("DATABASE " <>) <$> checkIdent "database" (T.drop 9 object)
| ".*" `T.isSuffixOf` object = (<> ".*") <$> checkIdent "database" (T.dropEnd 2 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)
@@ -186,12 +186,13 @@ data ServerConfig = ServerConfig
, scPort :: Int
, scMaxMessage :: Int
, scMaxRows :: Int
, scSudoUser :: Text
}
deriving (Eq, Show)
-- | 默认本机 7777,行 1 MiB,最多 1000 行
defaultServerConfig :: ServerConfig
defaultServerConfig = ServerConfig "127.0.0.1" 7777 (1024 * 1024) 1000
defaultServerConfig = ServerConfig "127.0.0.1" 7777 (1024 * 1024) 1000 ""
-- | 读 [server] 段键,缺的用默认
loadServerConfigAt :: FilePath -> IO ServerConfig
@@ -211,4 +212,5 @@ loadServerConfigAt path = do
, scPort = intOf "port" (scPort defaultServerConfig)
, scMaxMessage = intOf "max_message" (scMaxMessage defaultServerConfig)
, scMaxRows = intOf "max_rows" (scMaxRows defaultServerConfig)
, scSudoUser = T.toLower (T.pack (textOf "sudo_auth_user" ""))
}
+30 -5
View File
@@ -5,6 +5,7 @@ module ChuSQL.Interface.Link (
connectClient,
closeClient,
clientLogin,
clientSudoLogin,
clientQuery,
clientPing,
clientCatalog,
@@ -15,6 +16,7 @@ module ChuSQL.Interface.Link (
clientReloadPolicy,
) where
import ChuSQL.Interface.Sudo (SudoCredential, sudoProof, isLocalPeer)
import ChuSQL.Core.Protocol (Account, QueryResult (..), TableInfo (..))
import ChuSQL.Interface.Protocol (
ClientRequest (..),
@@ -40,6 +42,7 @@ import Network.Socket (
defaultHints,
defaultProtocol,
getAddrInfo,
getPeerName,
socket,
socketToHandle,
)
@@ -52,17 +55,18 @@ import System.IO.Error (isEOFError)
data Client = Client
{ clHandle :: Handle
, clLock :: MVar ()
, clLocal :: Bool
}
-- | 连上 server 并对协议版本,失败给人话错误
connectClient :: Text -> Int -> IO (Either Text Client)
connectClient host port = do
opened <- try (openConnection host port) :: IO (Either IOException Handle)
opened <- try (openConnection host port) :: IO (Either IOException (Handle, Bool))
case opened of
Left err -> pure (Left ("cannot reach the server at " <> T.pack (address host port) <> ": " <> T.pack (describe err)))
Right handle -> do
Right (handle, local) -> do
lock <- newMVar ()
let client = Client handle lock
let client = Client handle lock local
greeted <- request client (ReqHello protocolVersion)
case greeted of
Right (RespHello version)
@@ -117,6 +121,26 @@ clientLogin client user password = do
Right (RespLogin _ admin) -> pure (Right admin)
Right other -> pure (failed "login" other)
-- 验证一次性挑战并用本机身份登录。
clientSudoLogin :: Client -> SudoCredential -> Text -> IO (Either Text Bool)
clientSudoLogin client _ _ | not (clLocal client) = pure (Left "sudo authentication requires a local server")
clientSudoLogin client credential user = withMVar (clLock client) $ \_ -> do
outcome <- try authenticate :: IO (Either IOException (Either Text Bool))
pure $ either (Left . T.pack . describe) id outcome
where
-- 在同一连接连续交换挑战与证明。
authenticate = do
challenge <- exchange (clHandle client) ReqSudoChallenge
case challenge of
Right (RespSudoChallenge nonce) | T.length nonce == 64 -> do
answer <- exchange (clHandle client) (ReqSudoLogin user (sudoProof credential nonce user))
pure $ case answer of
Left message -> Left message
Right (RespLogin _ admin) -> Right admin
Right other -> failed "sudo login" other
Right other -> pure (failed "sudo challenge" other)
Left message -> pure (Left message)
-- | 跑一条语句,拿回结果集
clientQuery :: Client -> Text -> IO (Either Text QueryResult)
clientQuery client sql = do
@@ -196,7 +220,7 @@ failed what response = case response of
_ -> Left ("unexpected response to " <> what)
-- | 建连接(套接字转成文本模式的行缓冲句柄)
openConnection :: Text -> Int -> IO Handle
openConnection :: Text -> Int -> IO (Handle, Bool)
openConnection host port = do
let hints = defaultHints{addrSocketType = Stream}
infos <- getAddrInfo (Just hints) (Just (T.unpack host)) (Just (show port))
@@ -205,10 +229,11 @@ openConnection host port = do
(info : _) -> do
sock <- socket (addrFamily info) Stream defaultProtocol
connect sock (addrAddress info)
peer <- getPeerName sock
handle <- socketToHandle sock ReadWriteMode
hSetBuffering handle LineBuffering
hSetNewlineMode handle noNewlineTranslation
pure handle
pure (handle, isLocalPeer peer)
-- | 把主机端口拼成地址字样
address :: Text -> Int -> String
@@ -91,6 +91,8 @@ serverName = "chusql-server"
data ClientRequest
= ReqHello Int
| ReqLogin Text Text
| ReqSudoChallenge
| ReqSudoLogin Text Text
| ReqQuery Text
| ReqPing
| ReqQuit
@@ -109,6 +111,7 @@ data WireRequest = WireRequest
, wrProtocol :: Maybe Int
, wrUser :: Maybe Text
, wrPassword :: Maybe Text
, wrProof :: Maybe Text
, wrSql :: Maybe Text
, wrRequest :: Maybe Value
}
@@ -121,6 +124,7 @@ instance A.FromJSON WireRequest where
<*> o A..:? "protocol"
<*> o A..:? "user"
<*> o A..:? "password"
<*> o A..:? "proof"
<*> o A..:? "sql"
<*> o A..:? "request"
@@ -133,6 +137,10 @@ decodeRequest raw = case A.eitherDecodeStrict raw of
"login" -> case (wrUser wire, wrPassword wire) of
(Just user, Just password) -> Right (ReqLogin user password)
_ -> Left "login needs both user and password"
"sudo_challenge" -> Right ReqSudoChallenge
"sudo_login" -> case (wrUser wire, wrProof wire) of
(Just user, Just proof) -> Right (ReqSudoLogin user proof)
_ -> Left "sudo_login needs both user and proof"
"query" -> maybe (Left "query needs sql") (Right . ReqQuery) (wrSql wire)
"storage" -> maybe (Left "storage needs request") (Right . ReqStorage) (wrRequest wire)
"catalog" -> Right ReqCatalog
@@ -154,6 +162,8 @@ 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]
ReqSudoChallenge -> object ["method" .= ("sudo_challenge" :: Text)]
ReqSudoLogin user proof -> object ["method" .= ("sudo_login" :: Text), "user" .= user, "proof" .= proof]
ReqQuery sql -> object ["method" .= ("query" :: Text), "sql" .= sql]
ReqPing -> object ["method" .= ("ping" :: Text)]
ReqQuit -> object ["method" .= ("quit" :: Text)]
@@ -169,6 +179,7 @@ requestJson request = case request of
data ServerResponse
= RespHello Int
| RespLogin Text Bool
| RespSudoChallenge Text
| RespResult QueryResult
| RespPong
| RespBye
@@ -190,6 +201,7 @@ 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]
RespSudoChallenge challenge -> object ["status" .= ("sudo_challenge" :: Text), "challenge" .= challenge]
RespPong -> object ["status" .= ("pong" :: Text)]
RespBye -> object ["status" .= ("bye" :: Text)]
RespError code message -> object ["status" .= ("error" :: Text), "code" .= code, "message" .= message]
@@ -216,6 +228,7 @@ decodeResponse raw = case A.eitherDecode raw of
decodeStatus status fields = case status of
"hello" -> Right (RespHello (intOf "protocol" fields))
"ok" -> Right (RespLogin (textOf "user" fields) (boolOf "admin" fields))
"sudo_challenge" -> fromField "challenge" RespSudoChallenge fields
"pong" -> Right RespPong
"bye" -> Right RespBye
"error" -> Right (RespError (textOf "code" fields) (textOf "message" fields))
@@ -7,6 +7,7 @@ module ChuSQL.Interface.Session (
sessionDatabase,
isPlainIdentifier,
authenticateSession,
authenticateSudoSession,
switchDatabase,
runStatement,
catalog,
@@ -22,9 +23,11 @@ import ChuSQL.Interface.Link (
clientCatalog,
clientDatabases,
clientLogin,
clientSudoLogin,
clientQuery,
clientRoles,
)
import ChuSQL.Interface.Sudo (SudoCredential)
import ChuSQL.Interface.Protocol (RoleView)
import Data.Char (isAlpha, isAlphaNum)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
@@ -68,6 +71,14 @@ authenticateSession session user password = do
Left message -> pure (Left message)
Right admin -> writeIORef (ssAdmin session) admin >> pure (Right ())
-- 用受保护本机凭据登录并记录身份。
authenticateSudoSession :: Session -> SudoCredential -> Text -> IO (Either Text ())
authenticateSudoSession session credential user = do
answer <- clientSudoLogin (ssClient session) credential user
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
@@ -0,0 +1,108 @@
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Interface.Sudo (
SudoCredential, createSudoCredential, removeSudoCredential,
readSudoCredential, sudoProof, verifySudoProof, sudoChallenge, sudoPrivileged,
newSudoCredential, isLocalPeer, validSudoChallenge,
) where
import Crypto.Hash (SHA256)
import Crypto.MAC.HMAC (HMAC, hmac)
import Crypto.Random (getRandomBytes)
import qualified Data.ByteArray as BA
import Data.ByteArray.Encoding (Base (Base16), convertToBase)
import qualified Data.ByteString as BS
import Data.Char (isHexDigit)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Time.Clock (UTCTime, diffUTCTime)
import Foreign.C.String (CString)
import Foreign.C.Types (CInt (..))
import Foreign.Marshal.Alloc (allocaBytes)
import Network.Socket (SockAddr (..), hostAddressToTuple, hostAddress6ToTuple)
-- 用系统保护凭据与一次性挑战验证本机提升身份。
newtype SudoCredential = SudoCredential BS.ByteString
-- 隐藏本机凭据的诊断内容。
instance Show SudoCredential where
show _ = "SudoCredential <redacted>"
-- 检查当前进程的操作系统提升身份。
foreign import ccall unsafe "chusql_sudo_privileged" nativePrivileged :: IO CInt
-- 创建操作系统保护的本机凭据。
foreign import ccall safe "chusql_sudo_create" nativeCreate :: CInt -> CString -> IO CInt
-- 读取操作系统保护的本机凭据。
foreign import ccall safe "chusql_sudo_read" nativeRead :: CInt -> CString -> IO CInt
-- 清理本次服务启动的凭据。
foreign import ccall safe "chusql_sudo_remove" nativeRemove :: CInt -> IO CInt
-- 判断当前进程是否以提升身份运行。
sudoPrivileged :: IO Bool
sudoPrivileged = (/= 0) <$> nativePrivileged
-- 生成随机挑战和服务实例凭据。
sudoChallenge :: IO Text
sudoChallenge = TE.decodeUtf8 . convertToBase Base16 <$> (getRandomBytes 32 :: IO BS.ByteString)
-- 创建本次服务实例的受保护凭据。
createSudoCredential :: Int -> IO SudoCredential
createSudoCredential port = do
credential@(SudoCredential secret) <- newSudoCredential
status <- BS.useAsCString secret (nativeCreate (fromIntegral port))
if status == 0 then pure credential
else ioError (userError (T.unpack (nativeError "create" status)))
-- 生成独立服务实例的随机凭据。
newSudoCredential :: IO SudoCredential
newSudoCredential = SudoCredential . TE.encodeUtf8 <$> sudoChallenge
-- 判断内核报告的连接地址是否为回环。
isLocalPeer :: SockAddr -> Bool
isLocalPeer (SockAddrInet _ host) = let (first, _, _, _) = hostAddressToTuple host in first == 127
isLocalPeer (SockAddrInet6 _ _ host _) = case hostAddress6ToTuple host of
(0, 0, 0, 0, 0, 0, 0, 1) -> True
(0, 0, 0, 0, 0, 65535, high, _) -> high >= 32512 && high <= 32767
_ -> False
isLocalPeer _ = False
-- 校验挑战有效期及其账号绑定证明。
validSudoChallenge :: SudoCredential -> UTCTime -> Maybe (Text, UTCTime) -> Text -> Text -> Bool
validSudoChallenge credential now challenge user proof = case challenge of
Just (nonce, issued) -> diffUTCTime now issued >= 0 && diffUTCTime now issued <= 60
&& verifySudoProof credential nonce user proof
Nothing -> False
-- 删除本次服务实例的受保护凭据。
removeSudoCredential :: Int -> IO ()
removeSudoCredential port = do
status <- nativeRemove (fromIntegral port)
if status == 0 then pure () else ioError (userError (T.unpack (nativeError "remove" status)))
-- 验证操作系统身份并读取本机凭据。
readSudoCredential :: Int -> IO (Either Text SudoCredential)
readSudoCredential port = allocaBytes 64 $ \buffer -> do
status <- nativeRead (fromIntegral port) buffer
if status /= 0 then pure (Left (nativeError "read" status)) else do
secret <- BS.packCStringLen (buffer, 64)
pure $ if BS.all (isHexDigit . toEnum . fromIntegral) secret
then Right (SudoCredential secret) else Left "invalid sudo credential"
-- 计算绑定挑战与目标账号的认证证明。
sudoProof :: SudoCredential -> Text -> Text -> Text
sudoProof (SudoCredential secret) challenge user = TE.decodeUtf8 (convertToBase Base16 digest)
where
digest = hmac secret (TE.encodeUtf8 ("chusql-sudo-v1:" <> challenge <> ":" <> T.toLower (T.strip user))) :: HMAC SHA256
-- 按固定长度常量时间比对认证证明。
verifySudoProof :: SudoCredential -> Text -> Text -> Text -> Bool
verifySudoProof credential challenge user proof = T.length proof == 64
&& BA.constEq (TE.encodeUtf8 (sudoProof credential challenge user)) (TE.encodeUtf8 proof)
-- 将原生错误转换为明确诊断。
nativeError :: Text -> CInt -> Text
nativeError operation status = "sudo credential " <> operation <> " failed (OS error "
<> T.pack (show status) <> "); requires root or an elevated administrator; stale credential directories must be removed after stopping the server"
+60
View File
@@ -0,0 +1,60 @@
import ctypes
import os
from pathlib import Path
import subprocess
import sys
# 验证 Unix 本机凭据的所有权、权限及符号链接拒绝。
# 执行本机凭据安全回归。
def main():
library = ctypes.CDLL(sys.argv[1])
port = int(sys.argv[2])
library.chusql_sudo_create.argtypes = [ctypes.c_int, ctypes.c_char_p]
library.chusql_sudo_read.argtypes = [ctypes.c_int, ctypes.c_void_p]
secret = b'a' * 64
buffer = ctypes.create_string_buffer(64)
if len(sys.argv) > 3:
assert library.chusql_sudo_privileged() == 0
assert library.chusql_sudo_create(port, secret) != 0
assert library.chusql_sudo_read(port, buffer) != 0
print('non-root creation and reading refused')
return
assert library.chusql_sudo_privileged() == 1
assert library.chusql_sudo_create(port, secret) == 0
directory = Path(f'/var/run/chusql-sudo-{port}')
file = directory / 'credential'
try:
assert directory.stat().st_uid == 0
assert directory.stat().st_mode & 0o777 == 0o700
assert file.stat().st_mode & 0o777 == 0o600
assert library.chusql_sudo_read(port, buffer) == 0
assert buffer.raw == secret
assert library.chusql_sudo_create(port, secret) != 0
subprocess.run([sys.executable, __file__, sys.argv[1], str(port), '--deny'],
user=65534, group=65534, check=True)
file.chmod(0o644)
assert library.chusql_sudo_read(port, buffer) != 0
file.chmod(0o600)
file.rename(directory / 'original')
file.symlink_to(directory / 'original')
assert library.chusql_sudo_read(port, buffer) != 0
file.unlink()
(directory / 'original').rename(file)
file.write_bytes(secret + b'extra')
assert library.chusql_sudo_read(port, buffer) != 0
file.write_bytes(secret)
os.chown(file, 65534, 65534)
assert library.chusql_sudo_read(port, buffer) != 0
os.chown(file, 0, 0)
directory.chmod(0o755)
assert library.chusql_sudo_read(port, buffer) != 0
directory.chmod(0o700)
finally:
assert library.chusql_sudo_remove(port) == 0
assert not directory.exists()
print('root round trip, duplicate, permissions, ownership, symlink and cleanup passed')
if __name__ == '__main__':
main()
+2
View File
@@ -16,6 +16,8 @@ library
ChuSQL.Server.Catalog
ChuSQL.Server.Policy
ChuSQL.Server.Privileges
ChuSQL.Server.ObjectACL
ChuSQL.Server.Security
ChuSQL.Server.Session
ChuSQL.Server.TCP
build-depends: base >= 4.14 && < 5
+21 -5
View File
@@ -4,7 +4,7 @@ module ChuSQL.Server.Accounts (
Accounts, AccountError (..), Principal (..), PasswordPolicy (..), defaultPasswordPolicy,
newAccounts, accountsPolicy, setAccountsPolicy, passwordAllowed,
ensureRootAccount, administratorPasswordless, rootUserName, principalName, principalIsRoot, principalIsCatalogManager,
authenticate, currentPrincipal,
authenticate, authenticateSudo, currentPrincipal,
listAccounts, findAccount, AccountCommand (..), accountCommand, runAccountCommand,
) where
@@ -153,7 +153,7 @@ ensureRootAccount backend name = do
| otherwise -> do
created <- beAccounts backend (ReqAccountCreate (normalize name) "")
case created of
Right _ -> storageResult <$> beAccounts backend (ReqIdentityAlter (normalize name) Nothing (Just True) Nothing Nothing)
Right _ -> storageResult <$> beAccounts backend (ReqIdentityAlter (normalize name) Nothing (Just True) Nothing Nothing Nothing)
Left "account already exists" -> pure (Right ())
Left _ -> pure (Left storageFailure)
@@ -219,6 +219,21 @@ authenticate service user password = withMVar (acLock service) $ \_ -> do
Left _ -> pure (Left storageFailure)
Right _ -> Right <$> createVersionedSession (acSessions service) (accountUser a) (Just (accountRevision a))
-- 为已验证的本机身份创建独立登录会话。
authenticateSudo :: Accounts -> Text -> IO (Either AccountError Text)
authenticateSudo service user = withMVar (acLock service) $ \_ -> do
stored <- readAccounts (acBackend service)
case stored of
Left err -> pure (Left err)
Right accounts -> case filter ((== normalize user) . accountUser) accounts of
[a] | accountEnabled a && accountCanLogin a && accountAllowSudoAuth a -> do
stamp <- currentStamp
written <- beAccounts (acBackend service) (ReqAccountLogin (accountUser a) (Just stamp))
case written of
Left _ -> pure (Left storageFailure)
Right _ -> Right <$> createVersionedSession (acSessions service) (accountUser a) (Just (accountRevision a))
_ -> pure (Left unauthorized)
-- | 系统表里的账号清单(含管理员)
listAccounts :: Accounts -> IO (Either AccountError [Account])
listAccounts service = withMVar (acLock service) $ \_ -> fmap (fmap (filter (\a -> accountCanLogin a || not (T.null (accountHash a))))) (readAccounts (acBackend service))
@@ -295,7 +310,7 @@ runAccountCommand service principal command = withMVar (acLock service) $ \_ ->
case identities of
Left err -> pure (Left err)
Right accounts
| any (\a -> accountUser a == normalize (target command) && (accountIsSuperuser a || accountSystemCatalogManager a)) accounts
| any (\a -> accountUser a == normalize (target command) && (accountIsSuperuser a || accountSystemCatalogManager a || accountAllowSudoAuth a)) accounts
|| privilegedChange command -> pure (Left (AccountError "forbidden" "superuser required to manage privileged identities"))
| otherwise -> execute
| otherwise = execute
@@ -305,12 +320,13 @@ runAccountCommand service principal command = withMVar (acLock service) $ \_ ->
target (DropAccount name) = name
target (AlterAccountAttributes name _) = name
-- | 判断是否修改特权属性
privilegedChange (AlterAccountAttributes _ attributes) = any (\(key, _) -> key `elem` ["superuser", "system_catalog_manager"]) attributes
privilegedChange (AlterAccountAttributes _ attributes) = any (\(key, _) -> key `elem` ["superuser", "system_catalog_manager", "allow_sudo_auth"]) attributes
privilegedChange _ = False
-- | 执行已授权的身份命令
execute = executeWith (if principalIsRoot principal then service else service{acBackend = (acBackend service){beAccounts = \request -> beAccounts (acBackend service) (ReqCatalogManage request)}})
-- | 通过受限存储请求执行管理操作
executeWith managed = case command of
CreateAccount name _ | normalize name == "public" -> pure (Left (AccountError "bad_request" "public is reserved for default privileges"))
CreateAccount name password -> createUser managed name password
ResetAccountPassword name password -> resetPassword managed name password
DropAccount name -> dropUser managed name
@@ -318,4 +334,4 @@ runAccountCommand service principal command = withMVar (acLock service) $ \_ ->
| length (nub (map fst attributes)) /= length attributes -> pure (Left (AccountError "bad_request" "duplicate identity attribute"))
| otherwise ->
storageResult <$> beAccounts (acBackend managed) (ReqIdentityAlter (normalize name)
(lookup "login" attributes) (lookup "superuser" attributes) (lookup "enabled" attributes) (lookup "system_catalog_manager" attributes))
(lookup "login" attributes) (lookup "superuser" attributes) (lookup "enabled" attributes) (lookup "system_catalog_manager" attributes) (lookup "allow_sudo_auth" attributes))
+60 -9
View File
@@ -172,7 +172,7 @@ memoryBackendWith trusted name ref =
Left e -> pure (db, Left e)
Right (db', rows)
| any (\(key, _) -> hidden key && not (domainKey key)) db' -> pure (db, Left "reserved system table")
| otherwise -> pure (mergeScoped db db', Right (StatementResult (colsOf (scoped db) stmt rows) rows))
| otherwise -> pure (syncMemoryObjects name (mergeScoped db db'), Right (StatementResult (colsOf (scoped db) stmt rows) rows))
, beCatalog = do
db <- readMVar ref
pure (Right (map tableInfoOf (filter (not . internalTable . fst) (scoped db))))
@@ -186,7 +186,7 @@ memoryBackendWith trusted name ref =
Right previous -> pure (case req of ReqAccountsList -> db; ReqCatalogManage ReqAccountsList -> db; _ -> storeMemoryIdentities db previous accounts, Right accounts)
, beWithDatabase = withDatabase
, beDatabases = pure (Right (nub [name, systemDatabaseName]))
, beStorage = \_ -> pure (Left "storage is not available in this backend")
, beStorage = memorySecurityRequest name ref
, beSnapshot = Right . scoped <$> readMVar ref
, beApplyTransaction = \ops -> modifyMVar ref $ \db -> case applyTransactionMemory ops (scoped db) of
Left err -> pure (db, Left err)
@@ -224,6 +224,52 @@ memoryBackendWith trusted name ref =
| null target = noDatabaseBackend (memoryBackendWith False name ref)
| otherwise = unavailableDatabase ("unknown database: " ++ target) (memoryBackendWith False name ref)
-- 更新内存夹具的稳定表编号。
syncMemoryObjects :: String -> Database -> Database
syncMemoryObjects database db = (registry, Table registry [("name", TStr), ("id", TInt)] records Nothing) : filter ((/= registry) . fst) db
where
registry = "__system_object_ids"
previous = [(key, identifier) | row <- maybe [] tableRows (lookup registry db), Just (VStr key) <- [lookup "name" row], Just (VInt identifier) <- [lookup "id" row]]
keys = [if '.' `elem` key then key else database ++ "." ++ key | (key, _) <- db, not (internalTable (lastTablePart key))]
retained = [(key, identifier) | (key, identifier) <- previous, key `elem` keys]
high = maximum (0 : map snd previous)
added = zip [key | key <- keys, key `notElem` map fst retained] [high + 1 ..]
records = [[("name", VStr key), ("id", VInt identifier)] | (key, identifier) <- ("__high_water", high + length added) : retained ++ added]
-- 执行内存夹具的权限快照协议。
memorySecurityRequest :: String -> MVar Database -> A.Value -> IO (Either String A.Value)
memorySecurityRequest database ref payload = modifyMVar ref $ \original -> do
let db = syncMemoryObjects database original
pure $ case operation db of
Left err -> (original, Left err)
Right (next, value) -> (next, Right value)
where
-- 读取协议文本字段。
field key = case payload of
A.Object fields -> case KM.lookup key fields of
Just (A.String value) -> Just value
_ -> Nothing
_ -> Nothing
-- 解析并执行一条权限请求。
operation db = case field "method" of
Just "resolve_object" -> do
selected <- maybe (Left "missing database") Right (field "database")
if selected `notElem` [T.pack database, "system"] then Left "unknown database" else do
identifier <- case field "table" of
Nothing -> Right A.Null
Just table -> case [number | row <- maybe [] tableRows (lookup "__system_object_ids" db), lookup "name" row == Just (VStr (T.unpack (selected <> "." <> table))), Just (VInt number) <- [lookup "id" row]] of
[number] -> Right (A.toJSON number)
_ -> Left "unknown table"
Right (db, A.object ["status" A..= ("object" :: Text), "database_id" A..= (if selected == "system" then (2 :: Int) else 1), "object_id" A..= identifier])
Just "object_acl_read" -> Right (db, A.object ["status" A..= ("rows" :: Text), "rows" A..= [A.object ["id" A..= (1 :: Int), "payload" A..= value] | row <- maybe [] tableRows (lookup acl db), Just (VStr value) <- [lookup "payload" row]]])
Just "object_acl_replace" -> do
let previous = case lookup acl db of Nothing -> Nothing; Just table -> case tableRows table of [[("payload", VStr value)]] -> Just (T.pack value); _ -> Just "invalid ACL"
if previous /= field "expected" then Left "object ACL changed concurrently" else do
value <- maybe (Left "missing ACL payload") Right (field "payload")
Right ((acl, Table acl [("payload", TStr)] [[("payload", VStr (T.unpack value))]] Nothing) : filter ((/= acl) . fst) db, A.object ["status" A..= ("ok" :: Text)])
_ -> Left "storage is not available in this backend"
acl = "__system_object_acl"
-- | 把后端的语句与字典都改成同一条错误
unavailableDatabase :: String -> Backend -> Backend
unavailableDatabase message backend = backend
@@ -468,6 +514,10 @@ currentStamp = T.pack . formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" <$> get
-- | 在内存账号表上执行一条账号请求
memoryAccounts :: Database -> T.Text -> Request -> Either String [Account]
memoryAccounts db stamp req = do
case req of
ReqAccountCreate name _ | T.toLower name == "public" -> Left "public is reserved for default privileges"
ReqRoleCreate name | T.toLower name == "public" -> Left "public is reserved for default privileges"
_ -> Right ()
stored <- case lookup "__system_identities" db of
Just table -> mapM decodeCredential (tableRows table)
Nothing -> case lookup usersTable db of
@@ -482,28 +532,29 @@ memoryAccounts db stamp req = do
ReqAccountCreate name _ -> Just name
ReqAccountReset name _ -> Just name
ReqAccountDrop name -> Just name
ReqIdentityAlter name _ Nothing _ Nothing -> Just name
ReqIdentityAlter name _ Nothing _ Nothing Nothing -> Just name
_ -> Nothing
allowed = case command of ReqAccountsList -> True; ReqAccountCreate{} -> True; ReqAccountReset{} -> True; ReqAccountDrop{} -> True; ReqIdentityAlter _ _ Nothing _ Nothing -> True; _ -> False
if not allowed || any (\a -> target == Just (accountUser a) && (accountIsSuperuser a || accountSystemCatalogManager a)) accounts
allowed = case command of ReqAccountsList -> True; ReqAccountCreate{} -> True; ReqAccountReset{} -> True; ReqAccountDrop{} -> True; ReqIdentityAlter _ _ Nothing _ Nothing Nothing -> True; _ -> False
if not allowed || any (\a -> target == Just (accountUser a) && (accountIsSuperuser a || accountSystemCatalogManager a || accountAllowSudoAuth a)) accounts
then Left "superuser required to manage privileged identities" else memoryAccounts db stamp command
ReqAccountsList -> Right accounts
ReqIdentityInitialize admin
| any (`elem` map accountUser accounts) legacyNames || length (nub legacyNames) /= length legacyNames -> Left "identity name collision"
| otherwise -> Right ([if legacyIdentity a && accountUser a == T.toLower admin then a{accountIsSuperuser = True} else a | a <- accounts] ++
[Account (highWater + offset) role "" 1 stamp Nothing False False True False | (offset, role) <- zip [1..] legacyNames])
[Account (highWater + offset) role "" 1 stamp Nothing False False True False False | (offset, role) <- zip [1..] legacyNames])
ReqRoleCreate u
| any ((== T.toLower u) . accountUser) accounts -> Left "identity already exists"
| otherwise -> Right (accounts ++ [Account (highWater + 1) (T.toLower u) "" 1 stamp Nothing False False True False])
ReqIdentityAlter u login super enabled manager -> case filter ((== T.toLower u) . accountUser) accounts of
| otherwise -> Right (accounts ++ [Account (highWater + 1) (T.toLower u) "" 1 stamp Nothing False False True False False])
ReqIdentityAlter u login super enabled manager sudo -> case filter ((== T.toLower u) . accountUser) accounts of
[_] -> preserveSuper [if accountUser a == T.toLower u then a{accountCanLogin = maybe (accountCanLogin a) id login,
accountIsSuperuser = maybe (accountIsSuperuser a) id super, accountEnabled = maybe (accountEnabled a) id enabled,
accountSystemCatalogManager = maybe (accountSystemCatalogManager a) id manager,
accountAllowSudoAuth = maybe (accountAllowSudoAuth a) id sudo,
accountRevision = accountRevision a + 1} else a | a <- accounts] accounts
_ -> Left "unknown account"
ReqAccountCreate u h
| any ((== T.toLower u) . accountUser) accounts -> Left "account already exists"
| otherwise -> Right (accounts ++ [Account (highWater + 1) (T.toLower u) h 1 stamp Nothing True False True False])
| otherwise -> Right (accounts ++ [Account (highWater + 1) (T.toLower u) h 1 stamp Nothing True False True False False])
ReqAccountReset u h -> case filter ((== T.toLower u) . accountUser) accounts of
[_] -> Right [if accountUser x == T.toLower u then x{accountHash = h, accountRevision = accountRevision x + 1} else x | x <- accounts]
_ -> Left "unknown account"
+2 -2
View File
@@ -25,7 +25,7 @@ module ChuSQL.Server.Catalog
import ChuSQL.Core.Model (Row, Value (..))
import ChuSQL.Core.Protocol (Account (..), Request (..))
import ChuSQL.Interface.Actions (sqlLiteral)
import ChuSQL.Interface.Actions (escapeStringLiteral)
import ChuSQL.Interface.Protocol (Grant (..))
import ChuSQL.Server.Backend (Backend (..), StatementResult (..), grantsTable, membersTable, optionsTable, rolesTable)
import Control.Concurrent.MVar (MVar, newMVar, withMVar)
@@ -213,4 +213,4 @@ roleLiteral = literal . normalizeRole
-- | 文本值的 SQL 字面量
literal :: Text -> String
literal = sqlLiteral . VStr . T.unpack
literal text = "'" ++ escapeStringLiteral (T.unpack text) ++ "'"
@@ -0,0 +1,410 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Server.ObjectACL
( objectAuthorize, objectGrant, objectRevoke, objectViews, objectClaim
, objectReconcile, objectAffected, objectOwner, objectConnect, objectPrepareCreate, objectUsers
) where
import ChuSQL.Core.Protocol (Account (..), TableInfo (..))
import ChuSQL.Interface.Protocol (Grant (..))
import ChuSQL.Server.Accounts (Principal, principalIsRoot, principalName)
import ChuSQL.Server.Backend (Backend (..))
import ChuSQL.Server.Catalog (Catalog, readIdentities, readMembers, readGrants, readGrantOptions)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.List (nub)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import GHC.Generics (Generic)
-- 稳定对象权限目录:保存所有者、授予来源并计算有效授权链。
data Target = Target { targetDatabase :: Text, targetTable :: Maybe Text, targetKind :: Text, targetName :: Text }
deriving (Eq, Show, Generic)
instance ToJSON Target
instance FromJSON Target
data Edge = Edge { edgeRole :: Text, edgeGrantor :: Text, edgeTarget :: Target, edgePrivilege :: Text, edgeOption :: Bool, edgeRoot :: Bool }
deriving (Eq, Show, Generic)
instance ToJSON Edge
instance FromJSON Edge
data Owner = Owner { ownerRole :: Text, ownerTarget :: Target }
deriving (Eq, Show, Generic)
instance ToJSON Owner
instance FromJSON Owner
data Pending = Pending { pendingRole :: Text, pendingDatabase :: Text, pendingName :: Text }
deriving (Eq, Show, Generic)
instance ToJSON Pending
instance FromJSON Pending
data ACL = ACL { aclVersion :: Int, aclEdges :: [Edge], aclOwners :: [Owner], aclClosed :: [Text], aclPending :: [Pending] }
deriving (Eq, Show, Generic)
instance ToJSON ACL
instance FromJSON ACL where
-- 读取权限快照并兼容无声明的旧记录。
parseJSON = A.withObject "ACL" $ \fields -> ACL <$> fields A..: "aclVersion" <*> fields A..: "aclEdges"
<*> fields A..: "aclOwners" <*> fields A..: "aclClosed" <*> (fields A..:? "aclPending" A..!= [])
data Context = Context { contextIdentities :: [Account], contextMembers :: [(Text, Text)], contextTargets :: [Target] }
-- 解析存储响应并保留明确错误。
request :: Backend -> A.Value -> IO (Either String A.Value)
request backend payload = fmap (>>= response) (beStorage backend payload)
where
-- 检查响应状态。
response value@(A.Object fields) = case KM.lookup "status" fields of
Just (A.String "error") -> case KM.lookup "message" fields of Just (A.String message) -> Left (T.unpack message); _ -> Left "invalid storage error"
Just (A.String _) -> Right value
_ -> Left "invalid storage response"
response _ = Left "invalid storage response"
-- 从响应取必需字段。
field :: Text -> A.Value -> Either String A.Value
field name (A.Object fields) = maybe (Left ("missing field: " ++ T.unpack name)) Right (KM.lookup (K.fromText name) fields)
field _ _ = Left "invalid storage object"
-- 将存储编号规范为文本。
identifier :: A.Value -> Either String Text
identifier (A.Number number) | number > 0 = Right (T.pack (BL.unpack (A.encode (A.Number number))))
identifier _ = Left "invalid object identifier"
-- 按 catalog 解析数据库或表对象。
resolve :: Backend -> Text -> Text -> IO (Either String Target)
resolve backend database raw = do
let object = T.toLower (T.strip raw)
(selected, table, kind, label) =
if "database:" `T.isPrefixOf` object then (T.drop 9 object, Nothing, "database", object)
else if object == "*" || ".*" `T.isSuffixOf` object then
let scope = if object == "*" then database else T.dropEnd 2 object
in (scope, Nothing, "tables", scope <> ".*")
else case T.splitOn "." object of
[name] -> (database, Just name, "table", database <> "." <> name)
[db, name] -> (db, Just name, "table", object)
_ -> ("", Just "", "table", object)
if T.null selected then pure (Left "no database selected") else do
result <- request backend (A.object (["method" A..= ("resolve_object" :: Text), "database" A..= selected] ++ maybe [] (\name -> ["table" A..= name]) table))
pure $ do
value <- result
dbId <- field "database_id" value >>= identifier
tableId <- case table of Nothing -> Right Nothing; Just _ -> Just <$> (field "object_id" value >>= identifier)
if selected == "system" then Left "system objects cannot be granted" else Right (Target dbId tableId kind label)
-- 展开当前 catalog 中的稳定业务对象。
targets :: Backend -> IO (Either String [Target])
targets backend = do
names <- beDatabases backend
case names of
Left err -> pure (Left err)
Right databases -> fmap (fmap concat . sequence) $ mapM one (filter (/= "system") databases)
where
-- 展开一个数据库和它的表。
one name = do
database <- resolve backend "" ("database:" <> T.pack name)
catalog <- beCatalog (beWithDatabase backend name)
case catalog of
Left err -> pure (Left err)
Right infos -> do
tables <- mapM (resolve backend (T.pack name) . T.pack . tableNameOf) infos
pure ((:) <$> database <*> sequence tables)
-- 取数据字典的表名。
tableNameOf = tiTable
-- 读取身份、成员边和对象字典。
context :: Backend -> Catalog -> IO (Either String Context)
context backend catalog = do
identities <- readIdentities catalog
members <- readMembers catalog
objects <- targets backend
pure (Context <$> identities <*> members <*> objects)
-- 查找身份的稳定编号。
roleId :: Context -> Text -> Either String Text
roleId env name = case [T.pack (show (accountId account)) | account <- contextIdentities env, accountUser account == T.toLower name] of
[value] -> Right value
[] | T.toLower (T.strip name) == "public" -> Right "public"
_ -> Left ("unknown role: " ++ T.unpack name)
-- 从编号查回公开身份名。
roleName :: Context -> Text -> Text
roleName _ "public" = "public"
roleName env value = case [accountUser account | account <- contextIdentities env, T.pack (show (accountId account)) == value] of name : _ -> name; [] -> ""
-- 判断身份当前是否贡献权限。
active :: Context -> Text -> Bool
active _ "0" = True
active _ "public" = True
active env value = any (\account -> T.pack (show (accountId account)) == value && accountEnabled account) (contextIdentities env)
-- 判断稳定身份是否仍存在。
knownRole :: Context -> Text -> Bool
knownRole env value = value `elem` ["0", "public"] || any (\account -> T.pack (show (accountId account)) == value) (contextIdentities env)
-- 展开一个身份继承的有效角色编号。
roles :: Context -> Text -> [Text]
roles env value = nub ("public" : go [value])
where
pairs = [(parent, child) | (parentName, childName) <- contextMembers env, Right parent <- [roleId env parentName], Right child <- [roleId env childName], active env parent, active env child]
-- 展开成员关系的向上闭包。
go known = let more = [parent | (parent, child) <- pairs, child `elem` known, parent `notElem` known]
in if null more then known else go (nub (known ++ more))
-- 判断一个对象范围是否覆盖目标。
covers :: Target -> Target -> Bool
covers source target = targetDatabase source == targetDatabase target &&
(targetKind source == "tables" && targetKind target `elem` ["tables", "table"] || targetKind source == targetKind target && targetTable source == targetTable target)
-- 判断稳定对象当前是否存在。
exists :: Context -> Target -> Bool
exists env target = any same (contextTargets env)
where
-- 核对数据库或表的稳定编号。
same current = targetDatabase current == targetDatabase target &&
(targetKind target == "tables" && targetKind current == "database" || targetKind current == targetKind target && targetTable current == targetTable target)
-- 判断身份是否拥有指定对象。
owns :: Context -> ACL -> Text -> Target -> Bool
owns env acl identity target = any (\owner -> ownerRole owner `elem` roles env identity && ownerTarget owner == target && active env (ownerRole owner)) (aclOwners acl)
-- 计算仍有合法授予来源的授权闭包。
effective :: Context -> ACL -> ACL
effective env acl = acl {aclOwners = owners, aclEdges = grow roots, aclClosed = [value | value <- aclClosed acl, any (\target -> targetKind target == "database" && targetDatabase target == value) (contextTargets env)]}
where
owners = [owner | owner <- aclOwners acl, knownRole env (ownerRole owner), exists env (ownerTarget owner)]
candidates = [edge | edge <- aclEdges acl, knownRole env (edgeRole edge), knownRole env (edgeGrantor edge), exists env (edgeTarget edge)]
roots = [edge | edge <- candidates, edgeRoot edge]
-- 从独立授予根展开转授权链。
grow known = let more = [edge | edge <- candidates, edge `notElem` known, supported known edge]
in if null more then known else grow (known ++ more)
-- 检查授予者的所有权或有效转授权。
supported known edge = active env (edgeGrantor edge) && (owns env acl{aclOwners = owners} (edgeGrantor edge) (edgeTarget edge) || any (\source -> active env (edgeRole source) && edgeOption source && edgeRole source `elem` roles env (edgeGrantor edge) && edgePrivilege source == edgePrivilege edge && covers (edgeTarget source) (edgeTarget edge)) known)
-- 读取并校验权限快照。
readACL :: Backend -> IO (Either String (Maybe Text, Maybe ACL))
readACL backend = do
result <- request backend (A.object ["method" A..= ("object_acl_read" :: Text)])
pure $ do
value <- result
rows <- field "rows" value
case rows of
A.Array values -> case foldr (:) [] values of
[] -> Right (Nothing, Nothing)
[row] -> do
payload <- field "payload" row
case payload of
A.String text -> case A.eitherDecodeStrict (TE.encodeUtf8 text) of
Left err -> Left ("invalid object ACL: " ++ err)
Right acl | aclVersion acl == 1 -> Right (Just text, Just acl)
Right _ -> Left "unsupported object ACL version"
_ -> Left "invalid object ACL payload"
_ -> Left "invalid object ACL rows"
_ -> Left "invalid object ACL rows"
-- 原子写入权限快照并检查并发版本。
writeACL :: Backend -> Maybe Text -> ACL -> IO (Either String ())
writeACL backend expected acl = fmap (fmap (const ())) $ request backend (A.object ["method" A..= ("object_acl_replace" :: Text), "expected" A..= expected, "payload" A..= TE.decodeUtf8 (BL.toStrict (A.encode acl))])
-- 将旧名称授权一次性绑定到现存对象。
migrate :: Backend -> Catalog -> Context -> IO (Either String ACL)
migrate backend catalog env = do
grants <- readGrants catalog
options <- readGrantOptions catalog
case (,) <$> grants <*> options of
Left err -> pure (Left err)
Right (rows, optionRows) -> fmap (fmap (\edges -> ACL 1 (concat edges) [] [] []) . sequence) (mapM (one optionRows) rows)
where
-- 转换一条旧授权记录。
one options grant = case roleId env (grantRole grant) of
Left _ -> pure (Right [])
Right identity -> do
objects <- if grantObject grant == "*" then pure (Right [target | target <- contextTargets env, targetKind target == "table"])
else fmap (fmap (: [])) (resolve backend "" (grantObject grant))
let option = any (\row -> grantRole row == grantRole grant && grantPrivilege row == grantPrivilege grant && grantObject row == grantObject grant) options
pure $ case objects of
Left "unknown table" -> Right []
Left "unknown database" -> Right []
Left err -> Left err
Right found -> Right [Edge identity "0" target (grantPrivilege grant) option True | target <- found]
-- 取得迁移完成且来源有效的权限快照。
load :: Backend -> Catalog -> IO (Either String (Context, Maybe Text, ACL))
load backend catalog = do
env <- context backend catalog
stored <- readACL backend
case (,) <$> env <*> stored of
Left err -> pure (Left err)
Right (current, (previous, Just acl)) | null (aclPending acl) -> pure (Right (current, previous, effective current acl))
Right (current, (previous, Just acl)) -> do
let recovered = [Owner (pendingRole pending) target | pending <- aclPending acl, target <- contextTargets current,
targetKind target == "table", targetDatabase target == pendingDatabase pending, targetName target == pendingName pending]
next = acl{aclPending = [], aclOwners = recovered ++ [owner | owner <- aclOwners acl, ownerTarget owner `notElem` map ownerTarget recovered]}
written <- writeACL backend previous (effective current next)
case written of Left err -> pure (Left err); Right () -> load backend catalog
Right (current, (previous, Nothing)) -> do
migrated <- migrate backend catalog current
case migrated of
Left err -> pure (Left err)
Right acl -> do
written <- writeACL backend previous acl
case written of
Left "object ACL changed concurrently" -> load backend catalog
Left err -> pure (Left err)
Right () -> load backend catalog
-- 检查作用域权限或所有权。
allowed :: Context -> ACL -> Text -> Target -> Text -> Bool -> Bool
allowed env acl identity target privilege option = owns env acl identity target ||
(not option && privilege == "connect" && targetKind target == "database" && targetDatabase target `notElem` aclClosed acl) ||
any (\edge -> active env (edgeRole edge) && edgeRole edge `elem` roles env identity && edgePrivilege edge == privilege && covers (edgeTarget edge) target && (not option || edgeOption edge)) (aclEdges acl)
-- 按对象类型展开和校验权限名称。
privileges :: Target -> [Text] -> Either String [Text]
privileges target names =
if all (`elem` supported) expanded then Right expanded else Left "invalid privilege for object scope"
where
supported = if targetKind target == "database" then ["connect", "create"] else ["select", "insert", "update", "delete"]
expanded = nub (concatMap (\name -> if name == "all" then supported else [name]) (map T.toLower names))
-- 检查一组稳定对象上的业务权限。
objectAuthorize :: Backend -> Catalog -> Principal -> Text -> [(Text, Text)] -> IO (Either String ())
objectAuthorize backend catalog principal database needed = do
loaded <- load backend catalog
objects <- mapM (resolve backend database . fst) needed
pure $ do
(env, _, acl) <- loaded
found <- sequence objects
identity <- roleId env (principalName principal)
if active env identity then Right () else Left "permission denied: disabled identity"
case [(name, privilege) | ((name, privilege), target) <- zip needed found, not (allowed env acl identity target privilege False)] of
[] -> Right ()
(name, privilege) : _ -> Left ("permission denied: " ++ T.unpack (T.toUpper privilege <> " ON " <> name))
-- 检查数据库连接权限。
objectConnect :: Backend -> Catalog -> Principal -> Text -> IO (Either String ())
objectConnect backend catalog principal database = objectAuthorize backend catalog principal "" [("database:" <> database, "connect")]
-- 授予权限并记录授予者的稳定身份。
objectGrant :: Backend -> Catalog -> Principal -> Text -> [Text] -> Text -> Text -> Bool -> IO (Either String ())
objectGrant backend catalog principal database names object role option = do
loaded <- load backend catalog
resolved <- resolve backend database object
case (,) <$> loaded <*> resolved of
Left err -> pure (Left err)
Right ((env, previous, acl), target) -> case do
recipient <- roleId env role
items <- privileges target names
grantor <- if principalIsRoot principal then Right (either (const "0") id (roleId env (principalName principal))) else roleId env (principalName principal)
case [item | item <- items, not (principalIsRoot principal), not (allowed env acl grantor target item True)] of
item : _ -> Left ("grant option required: " ++ T.unpack (T.toUpper item <> " ON " <> object))
[] -> Right (recipient, grantor, items) of
Left err -> pure (Left err)
Right (recipient, grantor, items) -> do
let edges = [Edge recipient grantor target item option (principalIsRoot principal) | item <- items]
remaining = [edge | edge <- aclEdges acl, not (any (same edge) edges)]
promoted = [edge {edgeOption = edgeOption edge || any (\old -> same old edge && edgeOption old) (aclEdges acl)} | edge <- edges]
writeACL backend previous acl{aclEdges = remaining ++ promoted, aclClosed = if recipient == "public" && "connect" `elem` items then filter (/= targetDatabase target) (aclClosed acl) else aclClosed acl}
where
-- 比较同一授予来源的授权键。
same one other = edgeRole one == edgeRole other && edgeGrantor one == edgeGrantor other && edgeTarget one == edgeTarget other && edgePrivilege one == edgePrivilege other
-- 撤销授权并收敛失去来源的下游授权。
objectRevoke :: Backend -> Catalog -> Principal -> Text -> [Text] -> Text -> Text -> IO (Either String ())
objectRevoke backend catalog principal database names object role = do
loaded <- load backend catalog
resolved <- resolve backend database object
case (,) <$> loaded <*> resolved of
Left err -> pure (Left err)
Right ((env, previous, acl), target) -> case (,) <$> roleId env role <*> privileges target names of
Left err -> pure (Left err)
Right (recipient, items) -> do
let grantor = either (const "") id (roleId env (principalName principal))
manager = principalIsRoot principal || owns env acl grantor target
-- 选择本次可撤销的授予来源。
matches edge = edgeRole edge == recipient && edgeTarget edge == target && edgePrivilege edge `elem` items && (manager || edgeGrantor edge == grantor)
next = acl{aclEdges = filter (not . matches) (aclEdges acl), aclClosed = if recipient == "public" && "connect" `elem` items then nub (targetDatabase target : aclClosed acl) else aclClosed acl}
if recipient == "public" && "connect" `elem` items && not manager then pure (Left "administrator required")
else writeACL backend previous (effective env next)
-- 返回公开名称形式的有效授权。
objectViews :: Backend -> Catalog -> Text -> IO (Either String [Grant])
objectViews backend catalog role = do
loaded <- load backend catalog
pure $ do
(env, _, acl) <- loaded
identity <- roleId env role
let mine = [edge | edge <- aclEdges acl, edgeRole edge == identity]
Right (nub [Grant role (edgePrivilege edge) (targetName (edgeTarget edge)) (any (\other -> edgeTarget other == edgeTarget edge && edgePrivilege other == edgePrivilege edge && edgeOption other) mine) | edge <- mine])
-- 登记新对象的创建者为所有者。
objectClaim :: Backend -> Catalog -> Principal -> Text -> Text -> IO (Either String ())
objectClaim backend catalog principal database object = do
loaded <- load backend catalog
resolved <- resolve backend database object
case (,) <$> loaded <*> resolved of
Left err -> pure (Left err)
Right ((env, previous, acl), target) -> case roleId env (principalName principal) of
Left err -> pure (Left err)
Right identity -> writeACL backend previous acl{aclOwners = Owner identity target : filter ((/= target) . ownerTarget) (aclOwners acl)}
-- 在建表前持久化创建者声明。
objectPrepareCreate :: Backend -> Catalog -> Principal -> Text -> Text -> IO (Either String ())
objectPrepareCreate backend catalog principal database raw = do
loaded <- load backend catalog
parent <- resolve backend "" ("database:" <> database)
case (,) <$> loaded <*> parent of
Left err -> pure (Left err)
Right ((env, previous, acl), target) -> case roleId env (principalName principal) of
Left err -> pure (Left err)
Right identity -> do
let name = if "." `T.isInfixOf` raw then T.toLower raw else database <> "." <> T.toLower raw
if any ((== name) . targetName) (contextTargets env) then pure (Right ())
else writeACL backend previous acl{aclPending = [Pending identity (targetDatabase target) name]}
-- 清理失效身份、成员来源和已删除对象。
objectReconcile :: Backend -> Catalog -> IO (Either String ())
objectReconcile backend catalog = do
loaded <- load backend catalog
case loaded of Left err -> pure (Left err); Right (_, previous, acl) -> writeACL backend previous acl
-- 列出对象权限变更需失效的身份。
objectAffected :: Backend -> Catalog -> [Text] -> IO (Either String [Text])
objectAffected backend catalog names = do
loaded <- load backend catalog
pure $ do
(env, _, acl) <- loaded
let edges = [(roleName env (edgeGrantor edge), roleName env (edgeRole edge)) | edge <- aclEdges acl] ++ contextMembers env
-- 展开成员和转授权的受影响身份。
walk seen = let more = [child | (parent, child) <- edges, parent `elem` seen, child `notElem` seen, not (T.null child)]
in if null more then seen else walk (nub (seen ++ more))
let normalized = map (T.toLower . T.strip) names
Right (if "public" `elem` normalized then nub (walk normalized ++ map accountUser (filter (not . accountIsSuperuser) (contextIdentities env))) else walk normalized)
-- 检查稳定对象的所有者权限。
objectOwner :: Backend -> Catalog -> Principal -> Text -> Text -> IO (Either String ())
objectOwner backend catalog principal database object = do
loaded <- load backend catalog
resolved <- resolve backend database object
pure $ do
(env, _, acl) <- loaded
target <- resolved
identity <- roleId env (principalName principal)
if owns env acl identity target then Right () else Left "object owner required"
-- 展开删除对象时需失效的授权身份。
objectUsers :: Backend -> Catalog -> Text -> Text -> IO (Either String [Text])
objectUsers backend catalog database object = do
loaded <- load backend catalog
resolved <- resolve backend database object
case (,) <$> loaded <*> resolved of
Left err -> pure (Left err)
Right ((env, _, acl), target) -> do
let related = [edgeRole edge | edge <- aclEdges acl, if targetKind target == "database" then targetDatabase (edgeTarget edge) == targetDatabase target else covers (edgeTarget edge) target]
++ [ownerRole owner | owner <- aclOwners acl, ownerTarget owner == target]
result <- objectAffected backend catalog (nub (map (roleName env) related))
pure (fmap (filter (\name -> not (any (\account -> accountUser account == name && accountIsSuperuser account) (contextIdentities env)))) result)
+169 -381
View File
@@ -1,445 +1,233 @@
{-# LANGUAGE OverloadedStrings #-}
module ChuSQL.Server.Privileges (
Grant (..),
Membership (..),
PrivilegeCommand (..),
PrivilegeError (..),
Privileges,
RoleView (..),
affectedAccounts,
authorize,
authorizeTables,
filterTables,
listRoleViews,
newPrivileges,
normalizeObject,
privilegeCommand,
runPrivilegeCommand,
) where
module ChuSQL.Server.Privileges
( Grant (..), Membership (..), PrivilegeCommand (..), PrivilegeError (..), Privileges, RoleView (..)
, affectedAccounts, authorize, authorizeTables, authorizeConnect, filterTables, listRoleViews
, newPrivileges, normalizeObject, privilegeCommand, runPrivilegeCommand, claimObject, prepareObject, reconcileObjects, affectedObject
) where
import ChuSQL.Core.Engine.Syntax.AST
import ChuSQL.Core.Protocol (Account (..))
import ChuSQL.Server.Accounts (Principal, principalIsRoot, principalIsCatalogManager, principalName)
import ChuSQL.Interface.Protocol (Grant (..), RoleView (..))
import ChuSQL.Server.Backend (
Backend (..),
exprTables,
systemDatabaseName,
tableRefsOf,
)
import ChuSQL.Server.Catalog (
Catalog,
addGrant,
addGrantOption,
addMember,
dropRole,
eachAction,
insertRole,
newCatalog,
normalizeObject,
normalizeRole,
normalizeUser,
readGrantOptions,
readGrants,
readMembers,
readRoleNames,
readIdentities,
removeGrant,
removeGrantOption,
removeMember,
withCatalogLock,
ensureCatalog,
)
import ChuSQL.Server.Accounts (Principal, principalIsRoot, principalIsCatalogManager)
import ChuSQL.Server.Backend (Backend (..), exprTables, tableRefsOf, systemDatabaseName)
import ChuSQL.Server.Catalog
import qualified ChuSQL.Server.ObjectACL as OA
import Data.List (nub, sort)
import Data.Text (Text)
import qualified Data.Text as T
-- 角色与权限服务:角色、授权与成员关系落在 system 库的表里,并据此判权限。
-- 权限服务:稳定对象授权、角色继承与受影响会话展开。
-- | 出错口径与账号服务一致
data PrivilegeError = PrivilegeError Text Text
deriving (Show, Eq)
data PrivilegeError = PrivilegeError Text Text deriving (Show, Eq)
data Membership = Membership { memberRole :: Text, memberUser :: Text } deriving (Show, Eq, Ord)
data PrivilegeCommand = CreateRoleCommand Text | DropRoleCommand Text
| GrantPrivilegesCommand [Text] Text Text Bool | RevokePrivilegesCommand [Text] Text Text
| GrantRoleCommand Text [Text] | RevokeRoleCommand Text [Text] deriving (Show, Eq)
data Privileges = Privileges { pvCatalog :: Catalog, pvBackend :: Backend }
-- 一条角色授权(定义在共享协议层)
-- | 角色成员资格
data Membership = Membership
{ memberRole :: Text
, memberUser :: Text
}
deriving (Show, Eq, Ord)
-- | 一个角色的全貌:授权与成员
data PrivilegeCommand
= CreateRoleCommand Text
| DropRoleCommand Text
| GrantPrivilegesCommand [Text] Text Text Bool
| RevokePrivilegesCommand [Text] Text Text
| GrantRoleCommand Text [Text]
| RevokeRoleCommand Text [Text]
deriving (Show, Eq)
data Privileges = Privileges
{ pvCatalog :: Catalog
}
-- | 建权限服务,固定在 system 库上
-- 创建权限目录服务。
newPrivileges :: Backend -> IO Privileges
newPrivileges base = Privileges <$> newCatalog (beWithDatabase base systemDatabaseName)
newPrivileges backend = do
directory <- newCatalog (beWithDatabase backend systemDatabaseName)
pure (Privileges directory backend)
-- | 语句转管理命令,不认的给 Nothing
-- 将管理语句转换为权限命令。
privilegeCommand :: Statement -> Maybe PrivilegeCommand
privilegeCommand stmt = case stmt of
privilegeCommand statement = case statement of
CreateRole name -> Just (CreateRoleCommand (T.pack name))
DropRole name -> Just (DropRoleCommand (T.pack name))
GrantPrivileges privs obj role withOption ->
Just (GrantPrivilegesCommand (map T.toLower (map T.pack privs)) (T.pack obj) (T.pack role) withOption)
RevokePrivileges privs obj role ->
Just (RevokePrivilegesCommand (map T.toLower (map T.pack privs)) (T.pack obj) (T.pack role))
GrantPrivileges items object role option -> Just (GrantPrivilegesCommand (map (T.toLower . T.pack) items) (T.pack object) (T.pack role) option)
RevokePrivileges items object role -> Just (RevokePrivilegesCommand (map (T.toLower . T.pack) items) (T.pack object) (T.pack role))
GrantRole role members -> Just (GrantRoleCommand (T.pack role) (map T.pack members))
RevokeRole role members -> Just (RevokeRoleCommand (T.pack role) (map T.pack members))
_ -> Nothing
-- | 执行管理命令:管理员全通,普通身份只能转授自己拿到的权限
-- 执行角色管理或有来源记录的对象授权。
runPrivilegeCommand :: Privileges -> Principal -> Text -> PrivilegeCommand -> IO (Either PrivilegeError ())
runPrivilegeCommand service principal database command
| needsDatabase = pure (Left (PrivilegeError "no_database" "no database selected"))
| principalIsRoot principal = withTables service (applyCommand service database command)
| principalIsCatalogManager principal = case command of
CreateRoleCommand{} -> withTables service (applyCommand service database command)
DropRoleCommand{} -> pure (Left forbidden)
_ -> withTables service (delegateCommand service principal database command)
| otherwise = withTables service (delegateCommand service principal database command)
where
-- | 授权到具体对象时需要先选库
needsDatabase = T.null database && case command of
GrantPrivilegesCommand _ object _ _ -> T.strip object /= "*"
RevokePrivilegesCommand _ object _ -> T.strip object /= "*"
_ -> False
-- | 一条命令会影响的账号:角色连它的成员一起展开,账号名原样留下
affectedAccounts :: Privileges -> PrivilegeCommand -> IO [Text]
affectedAccounts service command = do
known <- roleNames service
runPrivilegeCommand service principal database command = withTables service $ case command of
GrantPrivilegesCommand items object role option -> catalog (OA.objectGrant backend directory principal database items object role option)
RevokePrivilegesCommand items object role -> catalog (OA.objectRevoke backend directory principal database items object role)
CreateRoleCommand role
| principalIsCatalogManager principal -> do
known <- catalog (readRoleNames directory)
case known of
Left _ -> pure (direct command)
Right roles -> walk roles [] (direct command)
Left err -> pure (Left err)
Right names | normalizeRole role `elem` names -> pure (Left (PrivilegeError "conflict" ("role already exists: " <> role)))
| normalizeRole role == "public" -> pure (Left (PrivilegeError "bad_request" "public is reserved for default privileges"))
| otherwise -> catalog (insertRole directory role)
DropRoleCommand role
| principalIsRoot principal -> after (catalog (dropRole directory role))
GrantRoleCommand role members
| principalIsRoot principal -> do
known <- catalog (readRoleNames directory)
edges <- catalog (readMembers directory)
case (,) <$> known <*> edges of
Left err -> pure (Left err)
Right (names, pairs) -> case validateMembers names pairs role members of
Left err -> pure (Left err)
Right () -> eachAction members $ \member -> if (normalizeRole role, normalizeUser member) `elem` pairs then pure (Right ()) else catalog (addMember directory role member)
RevokeRoleCommand role members
| principalIsRoot principal -> after (eachAction members (\member -> catalog (removeMember directory role member)))
_ -> pure (Left forbidden)
where
-- | 命令直接点到的名字
direct cmd = case cmd of
backend = pvBackend service
directory = pvCatalog service
-- 清理成员或身份变更失效的授权链。
after action = do
result <- action
case result of Left err -> pure (Left err); Right () -> catalog (OA.objectReconcile backend directory)
-- 在写入前校验全部成员和循环依赖。
validateMembers :: [Text] -> [(Text, Text)] -> Text -> [Text] -> Either PrivilegeError ()
validateMembers names pairs role members
| parent `notElem` names = Left (PrivilegeError "not_found" ("unknown role: " <> role))
| any ((`notElem` names) . normalizeUser) members = Left (PrivilegeError "not_found" "unknown role member")
| otherwise = foldMembers pairs members
where
parent = normalizeRole role
-- 逐项加入候选成员边并检查闭包。
foldMembers _ [] = Right ()
foldMembers edges (member : rest)
| child `elem` closureUp edges [parent] = Left (PrivilegeError "conflict" ("role membership would create a cycle: " <> parent <> " and " <> child))
| otherwise = foldMembers ((parent, child) : edges) rest
where child = normalizeUser member
-- 展开角色的继承闭包。
closureUp :: [(Text, Text)] -> [Text] -> [Text]
closureUp edges known = let more = [parent | (parent, child) <- edges, child `elem` known, parent `notElem` known]
in if null more then known else closureUp edges (nub (known ++ more))
-- 展开成员和转授权变更影响的全部身份。
affectedAccounts :: Privileges -> PrivilegeCommand -> IO (Either PrivilegeError [Text])
affectedAccounts service command = withTables service (catalog (OA.objectAffected (pvBackend service) (pvCatalog service) direct))
where
direct = case command of
CreateRoleCommand _ -> []
DropRoleCommand role -> [role]
GrantPrivilegesCommand _ _ role _ -> [role]
RevokePrivilegesCommand _ _ role -> [role]
GrantRoleCommand _ members -> members
RevokeRoleCommand _ members -> members
-- | 是角色就接着往下走它的成员,走过的名字不再走第二遍
walk _ seen [] = pure (reverse seen)
walk roles seen (name : rest)
| name `elem` seen = walk roles seen rest
| normalizeRole name `elem` roles = do
members <- membersOfRole service name
case members of
Left _ -> walk roles (name : seen) rest
Right found -> walk roles (name : seen) (found ++ rest)
| otherwise = walk roles (name : seen) rest
-- | 语句鉴权:管理员全通,普通身份按需查
-- 检查 SQL 的对象作用域权限。
authorize :: Privileges -> Principal -> Text -> Statement -> IO (Either PrivilegeError ())
authorize service principal database stmt
authorize service principal database statement
| principalIsRoot principal = pure (Right ())
| otherwise = case requiredActions stmt of
Nothing -> pure (Left forbidden)
Just needed -> authorizeTables service principal database needed
| otherwise = case statement of
CreateTable{} -> authorizeTables service principal database [("database:" <> database, "create")]
DropDatabase name -> owner ("database:" <> T.pack name)
DropTable name -> owner (T.pack name)
CreateIndex name _ -> owner (T.pack name)
DropIndex name _ -> owner (T.pack name)
DropColumn name _ -> owner (T.pack name)
AddColumn name _ -> owner (T.pack name)
RenameColumn name _ _ -> owner (T.pack name)
AlterColumnType name _ _ -> owner (T.pack name)
AlterColumnDefault name _ _ -> owner (T.pack name)
AlterColumnNull name _ _ -> owner (T.pack name)
ShowDomains -> authorizeConnect service principal database
ShowDatabases -> pure (Right ())
_ -> case requiredActions statement of Nothing -> pure (Left forbidden); Just needed -> authorizeTables service principal database needed
where
-- 检查结构操作的对象所有权。
owner object = withTables service (catalog (OA.objectOwner (pvBackend service) (pvCatalog service) principal database object))
-- | 直接查一组 (表, 权限):一键接口用这个
-- 检查数据库的 CONNECT 权限。
authorizeConnect :: Privileges -> Principal -> Text -> IO (Either PrivilegeError ())
authorizeConnect service principal database
| principalIsRoot principal = pure (Right ())
| otherwise = withTables service (catalog (OA.objectConnect (pvBackend service) (pvCatalog service) principal database))
-- 检查 CONNECT 和表上的业务权限。
authorizeTables :: Privileges -> Principal -> Text -> [(Text, Text)] -> IO (Either PrivilegeError ())
authorizeTables service principal database needed
| principalIsRoot principal = pure (Right ())
| T.null database && any (not . T.isPrefixOf "database:" . fst) needed = pure (Left (PrivilegeError "no_database" "no database selected"))
| otherwise = withTables service $ do
grants <- grantsOfUser service (principalName principal)
pure (grants >>= \found -> checkAll database found needed)
connected <- if T.null database then pure (Right ()) else catalog (OA.objectConnect (pvBackend service) (pvCatalog service) principal database)
case connected of Left err -> pure (Left err); Right () -> catalog (OA.objectAuthorize (pvBackend service) (pvCatalog service) principal database needed)
-- | 只留下用户有 SELECT 权的表
-- 仅返回拥有 SELECT 权限的表名。
filterTables :: Privileges -> Principal -> Text -> [Text] -> IO (Either PrivilegeError [Text])
filterTables service principal database tables
| principalIsRoot principal = pure (Right tables)
| otherwise = withTables service $ do
grants <- grantsOfUser service (principalName principal)
pure ((\found -> [table | table <- tables, checkAll database found [(table, "select")] == Right ()]) <$> grants)
| otherwise = do
connected <- authorizeConnect service principal database
case connected of
Left err -> pure (Left err)
Right () -> do
results <- mapM (\table -> authorizeTables service principal database [(table, "select")]) tables
pure $ case [err | Left err@(PrivilegeError code _) <- results, code /= "forbidden"] of
err : _ -> Left err
[] -> Right [table | (table, Right ()) <- zip tables results]
-- | 角色总览(REST 与测试用)
-- 返回角色的有效对象授权和直接成员。
listRoleViews :: Privileges -> IO (Either PrivilegeError [RoleView])
listRoleViews service = withTables service $ do
names <- fmap (fmap (map accountUser . filter (not . accountCanLogin))) (catalog (readIdentities (pvCatalog service)))
case names of
names <- catalog (readIdentities (pvCatalog service))
members <- catalog (readMembers (pvCatalog service))
case (,) <$> names <*> members of
Left err -> pure (Left err)
Right known -> sequence <$> mapM view (sort known)
Right (identities, pairs) -> fmap sequence $ mapM (view pairs) (sort (map accountUser (filter (not . accountCanLogin) identities)))
where
-- | 组装一个角色的总览
view role = do
grants <- roleGrantsOf service role
members <- membersOfRole service role
pure (RoleView role <$> grants <*> members)
-- 组装一个角色的公开权限视图。
view members name = do
grants <- catalog (OA.objectViews (pvBackend service) (pvCatalog service) name)
pure ((\rows -> RoleView name rows [member | (role, member) <- members, role == name]) <$> grants)
-- | 一条语句需要哪些 (表, 权限)
-- 登记创建对象的所有者。
claimObject :: Privileges -> Principal -> Text -> Text -> IO (Either PrivilegeError ())
claimObject service principal database object = withTables service (catalog (OA.objectClaim (pvBackend service) (pvCatalog service) principal database object))
-- 持久化即将建表的所有者声明。
prepareObject :: Privileges -> Principal -> Text -> Text -> IO (Either PrivilegeError ())
prepareObject service principal database object = withTables service (catalog (OA.objectPrepareCreate (pvBackend service) (pvCatalog service) principal database object))
-- 获取删除对象影响的授权身份。
affectedObject :: Privileges -> Text -> Text -> IO (Either PrivilegeError [Text])
affectedObject service database object = withTables service (catalog (OA.objectUsers (pvBackend service) (pvCatalog service) database object))
-- 清理身份或对象删除后的权限记录。
reconcileObjects :: Privileges -> IO (Either PrivilegeError ())
reconcileObjects service = withTables service (catalog (OA.objectReconcile (pvBackend service) (pvCatalog service)))
-- 收集数据语句及子查询所需的表权限。
requiredActions :: Statement -> Maybe [(Text, Text)]
requiredActions stmt = case stmt of
Select{} -> Just (selectNeeds (selectFrom stmt) (maybe [] (: []) (selectWhere stmt)))
SelectExpr{} ->
Just (selectNeeds (selectFrom stmt) (maybe [] (: []) (selectWhere stmt) ++ map snd (selectItems stmt)))
requiredActions statement = case statement of
Select{} -> Just (selectNeeds (selectFrom statement) (maybe [] (: []) (selectWhere statement)))
SelectExpr{} -> Just (selectNeeds (selectFrom statement) (maybe [] (: []) (selectWhere statement) ++ map snd (selectItems statement)))
Insert table _ rows -> Just ((T.pack table, "insert") : selectsOf (concat rows))
Update table assigns cond -> Just ((T.pack table, "update") : selectsOf (map snd assigns ++ maybe [] (: []) cond))
Delete table cond -> Just ((T.pack table, "delete") : selectsOf (maybe [] (: []) cond))
Update table assignments condition -> Just ((T.pack table, "update") : selectsOf (map snd assignments ++ maybe [] (: []) condition))
Delete table condition -> Just ((T.pack table, "delete") : selectsOf (maybe [] (: []) condition))
_ -> 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)]
-- 收集来源树和表达式的读取权限。
selectNeeds source expressions = [(ref, "select") | ref <- nub (tableRefsOf source)] ++ selectsOf expressions
-- 收集表达式中子查询的读取权限。
selectsOf expressions = [(ref, "select") | ref <- nub (concatMap exprTables expressions)]
-- | 每项 (表, 权限) 都要被某条授权覆盖
checkAll :: Text -> [Grant] -> [(Text, Text)] -> Either PrivilegeError ()
checkAll database grants needed = checkCovered database grants needed "permission denied: "
-- | 转授权要查 grant option,报错口径与普通鉴权分开
checkOptions :: Text -> [Grant] -> [(Text, Text)] -> Either PrivilegeError ()
checkOptions database grants needed = checkCovered database grants needed "grant option required: "
-- | 覆盖检查的公共实现
checkCovered :: Text -> [Grant] -> [(Text, Text)] -> Text -> Either PrivilegeError ()
checkCovered database grants needed prefix = case [pair | pair@(table, privilege) <- needed, not (covered table privilege)] of
[] -> Right ()
((table, privilege) : _) ->
Left (PrivilegeError "forbidden" (prefix <> T.toUpper privilege <> " ON " <> table))
where
-- | 某一项是否被授权覆盖
covered table privilege =
let target = normalizeObject database table
in any
(\grant -> (grantObject grant == "*" || grantObject grant == target) && grantPrivilege grant == privilege)
grants
-- | 一个用户实际能用的授权:含角色继承
grantsOfUser :: Privileges -> Text -> IO (Either PrivilegeError [Grant])
grantsOfUser service user = do
members <- catalog (readMembers (pvCatalog service))
grants <- catalog (readGrants (pvCatalog service))
options <- catalog (readGrantOptions (pvCatalog service))
roles <- catalog (readIdentities (pvCatalog service))
pure $ do
memberRows <- members
grantRows <- grants
optionRows <- options
identities <- roles
let known = map accountUser (filter accountEnabled identities)
disabled = map accountUser (filter (not . accountEnabled) identities)
activeMembers = [(role, member) | (role, member) <- memberRows, role `elem` known, member `notElem` disabled]
edges = roleEdges activeMembers known
mine = if normalizeUser user `elem` disabled then [] else closureUp edges
(normalizeUser user : [role | (role, member) <- activeMembers, member == normalizeUser user])
pure [grant | grant <- grantRows ++ optionRows, grantRole grant `elem` mine]
-- | 一个用户手里的 grant option,只有这些能再转授
optionsOfUser :: Privileges -> Text -> IO (Either PrivilegeError [Grant])
optionsOfUser service user = fmap (fmap (filter grantable)) (grantsOfUser service user)
-- | 角色到角色的成员边:父角色在前
roleEdges :: [(Text, Text)] -> [Text] -> [(Text, Text)]
roleEdges members roles = [pair | pair@(_, child) <- members, child `elem` roles]
-- | 向上闭包:这群角色直接或间接所属的全部角色
closureUp :: [(Text, Text)] -> [Text] -> [Text]
closureUp edges = go
where
-- | 展开一轮,没有再新增就停
go known =
let more = [parent | (parent, child) <- edges, child `elem` known, parent `notElem` known]
in if null more then known else go (known ++ more)
-- | 一个角色挂着的授权,带 grant option 的会标出来
roleGrantsOf :: Privileges -> Text -> IO (Either PrivilegeError [Grant])
roleGrantsOf service role = do
grants <- catalog (readGrants (pvCatalog service))
options <- catalog (readGrantOptions (pvCatalog service))
pure (do
rows <- grants
optionRows <- options
let mine = filter (\grant -> grantRole grant == normalizeRole role) rows
pure (markOptions mine optionRows))
-- | 给授权标上有没有对应的 grant option
markOptions :: [Grant] -> [Grant] -> [Grant]
markOptions grants options = [grant {grantable = hasOption grant} | grant <- grants]
where
-- | 有没有一条同角色同权限同对象的 option
hasOption grant = any (same grant) options
-- | 两条授权指向同一处
same one other =
grantRole one == grantRole other
&& grantPrivilege one == grantPrivilege other
&& grantObject one == grantObject other
-- | 角色名清单(统一小写)
roleNames :: Privileges -> IO (Either PrivilegeError [Text])
roleNames service = catalog (readRoleNames (pvCatalog service))
-- | 一个角色的直接成员:用户与子角色
membersOfRole :: Privileges -> Text -> IO (Either PrivilegeError [Text])
membersOfRole service role = do
members <- catalog (readMembers (pvCatalog service))
pure (map snd . filter (\(name, _) -> name == normalizeRole role) <$> members)
-- | 角色必须存在,否则命令不落地
requireRole :: Privileges -> Text -> IO (Either PrivilegeError ())
requireRole service role = do
known <- roleNames service
pure $ case known of
Left err -> Left err
Right names
| normalizeRole role `elem` names -> Right ()
| otherwise -> Left (unknownRole role)
-- | 真正落库(表已经保证存在)
applyCommand :: Privileges -> Text -> PrivilegeCommand -> IO (Either PrivilegeError ())
applyCommand service database command = case command of
CreateRoleCommand role -> do
known <- roleNames service
case known of
Left err -> pure (Left err)
Right names
| normalizeRole role `elem` names -> pure (Left (PrivilegeError "conflict" ("role already exists: " <> role)))
| otherwise -> catalog (insertRole (pvCatalog service) role)
DropRoleCommand role -> do
allowed <- requireRole service role
case allowed of
Left err -> pure (Left err)
Right () -> catalog (dropRole (pvCatalog service) role)
GrantPrivilegesCommand privileges object role withOption -> do
allowed <- requireRole service role
case allowed of
Left err -> pure (Left err)
Right () ->
eachAction (expandPrivileges privileges) $ \privilege ->
grantOne service withOption role privilege (normalizeObject database object)
RevokePrivilegesCommand privileges object role -> do
allowed <- requireRole service role
case allowed of
Left err -> pure (Left err)
Right () ->
eachAction (expandPrivileges privileges) $ \privilege ->
revokeOne service role privilege (normalizeObject database object)
GrantRoleCommand role members -> do
allowed <- requireRole service role
case allowed of
Left err -> pure (Left err)
Right () -> do
known <- roleNames service
case known of
Left err -> pure (Left err)
Right roles -> eachAction members (grantMember service roles role)
RevokeRoleCommand role users -> do
allowed <- requireRole service role
case allowed of
Left err -> pure (Left err)
Right () -> eachAction users $ \user -> catalog (removeMember (pvCatalog service) role user)
-- | 落一条授权,带 grant option 的再落一条转授权
grantOne :: Privileges -> Bool -> Text -> Text -> Text -> IO (Either PrivilegeError ())
grantOne service withOption role privilege object = do
written <- catalog (addGrant (pvCatalog service) role privilege object)
case written of
Left err -> pure (Left err)
Right ()
| withOption -> catalog (addGrantOption (pvCatalog service) role privilege object)
| otherwise -> pure (Right ())
-- | 收一条授权,连同它的 grant option
revokeOne :: Privileges -> Text -> Text -> Text -> IO (Either PrivilegeError ())
revokeOne service role privilege object = do
dropped <- catalog (removeGrant (pvCatalog service) role privilege object)
case dropped of
Left err -> pure (Left err)
Right () -> catalog (removeGrantOption (pvCatalog service) role privilege object)
-- | 普通身份转授权:只放行 GRANT
delegateCommand :: Privileges -> Principal -> Text -> PrivilegeCommand -> IO (Either PrivilegeError ())
delegateCommand service principal database command = case command of
GrantPrivilegesCommand _ _ role _ -> do
allowed <- requireRole service role
case allowed of
Left err -> pure (Left err)
Right () -> do
owned <- optionsOfUser service (principalName principal)
case owned >>= \found -> checkOptions database found needed of
Left err -> pure (Left err)
Right () -> applyCommand service database command
_ -> pure (Left forbidden)
where
-- | 命令里每个 (对象, 权限) 都要对得上
needed = case command of
GrantPrivilegesCommand privileges object _ _ -> [(object, privilege) | privilege <- expandPrivileges privileges]
_ -> []
-- | 加一条成员边:名字是角色就查环,否则当用户加
grantMember :: Privileges -> [Text] -> Text -> Text -> IO (Either PrivilegeError ())
grantMember service roles role member = do
current <- membersOfRole service role
case current of
Left err -> pure (Left err)
Right known
| normalizeUser member `elem` known -> pure (Right ())
| normalizeRole member `notElem` roles -> catalog (addMember (pvCatalog service) role member)
| otherwise -> do
edges <- membershipEdges service
case edges of
Left err -> pure (Left err)
Right pairs
| normalizeRole member `elem` closureUp pairs [normalizeRole role] ->
pure (Left (cycleMember role member))
| otherwise -> catalog (addMember (pvCatalog service) role member)
-- | 只保留两端都是角色的成员边
membershipEdges :: Privileges -> IO (Either PrivilegeError [(Text, Text)])
membershipEdges service = do
members <- catalog (readMembers (pvCatalog service))
roles <- roleNames service
pure (roleEdges <$> members <*> roles)
-- | 全程持锁,先保证系统表存在再跑动作
-- 持目录锁并确保旧权限表存在。
withTables :: Privileges -> IO (Either PrivilegeError a) -> IO (Either PrivilegeError a)
withTables service action = withCatalogLock (pvCatalog service) $ do
ready <- ensureCatalog (pvCatalog service)
case ready of
Left err -> pure (Left (storageError err))
Right () -> action
case ready of Left err -> pure (Left (storageError err)); Right () -> action
-- | 目录操作转成权限错误
-- 将目录结果转换为权限错误。
catalog :: IO (Either String a) -> IO (Either PrivilegeError a)
catalog action = fmap (either (Left . storageError) Right) action
-- | 把 ALL 展开成四种具体权限
expandPrivileges :: [Text] -> [Text]
expandPrivileges privileges = nub (concatMap expand (map (T.toLower . T.strip) privileges))
-- 分类稳定对象目录的明确错误。
storageError :: String -> PrivilegeError
storageError message = PrivilegeError code (T.pack message)
where
-- | 展开一条权限名
expand "all" = ["select", "insert", "update", "delete"]
expand other = [other]
code | message == "no database selected" = "no_database"
| any (`T.isPrefixOf` T.pack message) ["permission denied:", "grant option required:", "object owner required", "administrator required", "system objects cannot be granted"] = "forbidden"
| any (`T.isPrefixOf` T.pack message) ["unknown role:", "unknown table", "unknown database"] = "not_found"
| message == "object ACL changed concurrently" = "conflict"
| message == "invalid privilege for object scope" = "bad_request"
| message == "the last enabled login superuser cannot be removed" = "bad_request"
| otherwise = "storage_error"
forbidden :: PrivilegeError
forbidden = PrivilegeError "forbidden" "administrator required"
-- | 未知角色的错误
unknownRole :: Text -> PrivilegeError
unknownRole role = PrivilegeError "not_found" ("unknown role: " <> role)
-- | 角色成员成环的错误
cycleMember :: Text -> Text -> PrivilegeError
cycleMember role member =
PrivilegeError "conflict" ("role membership would create a cycle: " <> normalizeRole role <> " and " <> normalizeRole member)
-- | 存储错误转成权限错误
storageError :: String -> PrivilegeError
storageError "the last enabled login superuser cannot be removed" = PrivilegeError "bad_request" "the last enabled login superuser cannot be removed"
storageError message = PrivilegeError "storage_error" ("privilege storage: " <> T.pack message)
@@ -0,0 +1,35 @@
module ChuSQL.Server.Security (readSecurity, writeSecurity) where
import Control.Concurrent.MVar
import Control.Exception (bracket_, mask_)
import System.IO.Unsafe (unsafePerformIO)
-- 共享权限门:查询并行读取,权限和对象变更独占执行。
{-# NOINLINE securityGate #-}
securityGate :: (MVar (), MVar (), MVar Int)
securityGate = unsafePerformIO $ do
turn <- newMVar ()
room <- newMVar ()
readers <- newMVar 0
pure (turn, room, readers)
-- 并行执行权限稳定期间的查询。
readSecurity :: IO a -> IO a
readSecurity = bracket_ enter leave
where
(turn, room, readers) = securityGate
-- 登记共享读取者。
enter = withMVar turn $ \_ -> modifyMVar_ readers $ \count -> do
if count == 0 then takeMVar room else pure ()
pure (count + 1)
-- 释放最后一个共享读取者。
leave = mask_ $ modifyMVar_ readers $ \count -> do
if count == 1 then putMVar room () else pure ()
pure (count - 1)
-- 独占执行权限或对象变更。
writeSecurity :: IO a -> IO a
writeSecurity action = withMVar turn $ \_ -> withMVar room (const action)
where
(turn, room, _) = securityGate
+255 -44
View File
@@ -13,9 +13,11 @@ module ChuSQL.Server.Session
, isPlainIdentifier
, authenticateSession
, authenticateSessionCoded
, authenticateSudoSessionCoded
, switchDatabase
, runStatement
, runStatementCoded
, runStorageCoded
, catalog
, accounts
, roleViews
@@ -37,14 +39,19 @@ import ChuSQL.Interface.Auth (defaultSessionPolicy, newSessionStore)
import ChuSQL.Server.Accounts
import ChuSQL.Server.Backend (Backend (..), StatementResult (..), columnsFromStatement, scopeDdl)
import ChuSQL.Server.Policy (configurePasswordPolicy)
import ChuSQL.Server.Privileges (PrivilegeCommand (..), PrivilegeError (..), Privileges, RoleView, affectedAccounts, authorize, filterTables, listRoleViews, newPrivileges, privilegeCommand, runPrivilegeCommand)
import ChuSQL.Server.Privileges (PrivilegeCommand (..), PrivilegeError (..), Privileges, RoleView, affectedAccounts, affectedObject, authorize, authorizeConnect, claimObject, prepareObject, reconcileObjects, filterTables, listRoleViews, newPrivileges, privilegeCommand, runPrivilegeCommand)
import ChuSQL.Server.Security (readSecurity, writeSecurity)
import Control.Exception (IOException, try)
import Data.Bifunctor (first)
import Data.Char (isAlpha, isAlphaNum)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe (isJust)
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Aeson as A
import qualified Data.Aeson.KeyMap as KM
import Data.Time.Clock (getCurrentTime)
-- SQL 会话:Web、命令行与 TCP 服务器共用的账号、权限与语句执行入口。
@@ -66,6 +73,7 @@ data Session = Session
, ssPrivileges :: Privileges
, ssCurrent :: IORef Text
, ssPrincipal :: IORef (Maybe Principal)
, ssIdentityStamp :: IORef (Maybe (Integer, Integer))
, ssSettingsFile :: FilePath
, ssTransaction :: IORef (Maybe Transaction)
, ssChanged :: [Text] -> IO ()
@@ -75,7 +83,9 @@ data Session = Session
data Transaction = Transaction
{ txBase :: Database
, txStaged :: Database
, txSavepoints :: [(String, Database)]
, txSavepoints :: [(String, Database, [Statement])]
, txStatements :: [Statement]
, txObjects :: [(String, A.Value)]
}
-- | 开一个会话:账号与角色服务、配置策略都和 Web 端一致
@@ -92,8 +102,9 @@ newSessionWith backend name settingsFile changed = do
-- 服务启动后只有系统库:没 USE 之前不预设任何工作库
current <- newIORef ""
principal <- newIORef Nothing
identityStamp <- newIORef Nothing
transaction <- newIORef Nothing
pure (Session backend accountsService privileges current principal settingsFile transaction changed)
pure (Session backend accountsService privileges current principal identityStamp settingsFile transaction changed)
-- | 当前生效的口令策略(只有管理员能看)
policyOf :: Session -> IO (Either Text PasswordPolicy)
@@ -142,7 +153,7 @@ authenticateSession session user password =
-- | 登录(带错误码)
authenticateSessionCoded :: Session -> Text -> Text -> IO (Either SessionError ())
authenticateSessionCoded session user password = do
authenticateSessionCoded session user password = readSecurity $ do
result <- authenticate (ssAccounts session) user password
case result of
Left err -> pure (Left (accountErrorOf err))
@@ -150,14 +161,39 @@ authenticateSessionCoded session user password = do
who <- currentPrincipal (ssAccounts session) token
case who of
Left err -> pure (Left (accountErrorOf err))
Right principal -> do
Right principal -> storePrincipal session principal
-- 登录已通过本机凭据校验的映射账号。
authenticateSudoSessionCoded :: Session -> Text -> IO (Either SessionError ())
authenticateSudoSessionCoded session user = readSecurity $ do
result <- authenticateSudo (ssAccounts session) user
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 -> storePrincipal session principal
-- 绑定身份版本并清理旧登录的事务。
storePrincipal :: Session -> Principal -> IO (Either SessionError ())
storePrincipal session principal = do
result <- findAccount (ssAccounts session) (principalName principal)
case result of
Left err -> pure (Left (accountErrorOf err))
Right account -> do
writeIORef (ssPrincipal session) (Just principal)
writeIORef (ssIdentityStamp session) (Just (accountId account, accountRevision account))
writeIORef (ssTransaction session) Nothing
writeIORef (ssCurrent session) ""
pure (Right ())
-- | 换库;系统库只有 root 能进
switchDatabase :: Session -> Text -> IO (Either Text ())
switchDatabase session name =
fmap (first sessMessage) (switchDatabaseCoded session name)
readSecurity $ do
valid <- validatePrincipal session
case valid of Left err -> pure (Left (sessMessage err)); Right () -> fmap (first sessMessage) (switchDatabaseCoded session name)
-- | 换库(带错误码)
switchDatabaseCoded :: Session -> Text -> IO (Either SessionError ())
@@ -171,6 +207,13 @@ switchDatabaseCoded session rawName
name = T.toLower (T.strip rawName)
-- | 真的切库并记下当前库
go = do
who <- readIORef (ssPrincipal session)
allowed <- case who of
Just principal | name /= "system" -> authorizeConnect (ssPrivileges session) principal name
_ -> pure (Right ())
case allowed of
Left err -> pure (Left (privilegeErrorOf err))
Right () -> do
backend <- currentBackend session
result <- beStatement backend ("USE " ++ T.unpack name)
case result of
@@ -183,7 +226,43 @@ runStatement session sql = fmap (first sessMessage) (runStatementCoded session s
-- | 跑一条语句(带错误码)
runStatementCoded :: Session -> Text -> IO (Either SessionError QueryResult)
runStatementCoded session sql = case parseStatement (T.unpack sql) of
runStatementCoded session sql = gate $ do
valid <- validatePrincipal session
case valid of Left err -> pure (Left err); Right () -> runStatementUnlocked session sql
where
gate = case parseStatement (T.unpack sql) of
Right statement | transactionDdl statement || isJust (accountCommand statement) || isJust (privilegeCommand statement) -> writeSecurity
_ -> readSecurity
-- 在权限门内检查并执行管理员存储请求。
runStorageCoded :: Session -> A.Value -> IO (Either SessionError A.Value)
runStorageCoded session payload = writeSecurity $ do
valid <- validatePrincipal session
who <- readIORef (ssPrincipal session)
case valid of
Left err -> pure (Left err)
Right () -> case who of
Nothing -> pure (Left (SessionError "unauthorized" "sign in first"))
Just principal | not (principalIsRoot principal) -> pure (Left (SessionError "forbidden" "administrator required"))
Just _ -> fmap (first (SessionError "storage_error" . T.pack)) (beStorage (ssBackend session) payload)
-- 检查登录身份的当前版本和启用状态。
validatePrincipal :: Session -> IO (Either SessionError ())
validatePrincipal session = do
who <- readIORef (ssPrincipal session)
stamp <- readIORef (ssIdentityStamp session)
case who of
Just principal -> do
result <- findAccount (ssAccounts session) (principalName principal)
pure $ case result of
Left err -> Left (accountErrorOf err)
Right current | stamp == Just (accountId current, accountRevision current) && accountEnabled current && accountCanLogin current && (not (principalIsRoot principal) || accountIsSuperuser current) -> Right ()
_ -> Left (SessionError "unauthorized" "session identity has changed")
_ -> pure (Right ())
-- 在共享权限门内分发会话语句。
runStatementUnlocked :: Session -> Text -> IO (Either SessionError QueryResult)
runStatementUnlocked session sql = case parseStatement (T.unpack sql) of
Right (UseDatabase name) -> do
existing <- readIORef (ssTransaction session)
case existing of
@@ -215,7 +294,7 @@ runStatementCoded session sql = case parseStatement (T.unpack sql) of
Left err -> pure (Left err)
Right ()
| isJust transaction && transactionData statement -> runInTransaction session statement
| otherwise -> runPlain session sql
| otherwise -> runObjectStatement session statement sql
Left _ -> runPlain session sql
-- | 事务里不许改结构,会话层直接拦下
@@ -250,6 +329,12 @@ transactionData statement = case statement of
-- | 开事务:把当前库整库做一份快照当起点
beginTransaction :: Session -> IO (Either SessionError QueryResult)
beginTransaction session = do
allowed <- sessionConnectAllowed session
case allowed of Left err -> pure (Left err); Right () -> beginAuthorized session
-- 在连接权限复核后建立事务快照。
beginAuthorized :: Session -> IO (Either SessionError QueryResult)
beginAuthorized session = do
current <- readIORef (ssCurrent session)
existing <- readIORef (ssTransaction session)
case existing of
@@ -262,7 +347,11 @@ beginTransaction session = do
case snapshotResult of
Left err -> pure (Left (engineErrorCode err))
Right db -> do
writeIORef (ssTransaction session) (Just (Transaction db db []))
objects <- snapshotObjectIds session (map fst db)
case objects of
Left err -> pure (Left err)
Right ids -> do
writeIORef (ssTransaction session) (Just (Transaction db db [] [] ids))
pure (Right (emptyResult (Just current)))
-- | 提交:把快照差分交给存储层应用,成功才结束事务
@@ -273,20 +362,56 @@ commitTransaction session = do
case existing of
Nothing -> pure (Left (SessionError "query_error" "no transaction in progress"))
Just transaction -> do
connected <- sessionConnectAllowed session
permissions <- mapM (authorized session) (txStatements transaction)
identities <- snapshotObjectIds session (map fst (txBase transaction))
case connected >> sequence permissions >> identities of
Left err -> pure (Left err)
Right ids | ids /= txObjects transaction -> pure (Left (SessionError "serialization_failure" "transaction object identity changed"))
| otherwise -> commitAuthorized session current transaction
-- 对象和权限复核后提交事务差分。
commitAuthorized :: Session -> Text -> Transaction -> IO (Either SessionError QueryResult)
commitAuthorized session current transaction = do
backend <- currentBackend session
liveResult <- beSnapshot backend
case liveResult of
Left err -> pure (Left (engineErrorCode err))
Right live -> case transactionConflict (txBase transaction) (txStaged transaction) live of
Right live -> let diffs = transactionDiffs (txBase transaction) (txStaged transaction) live in case transactionConflict diffs of
Just msg -> pure (Left (SessionError "serialization_failure" (T.pack msg)))
Nothing -> do
applied <- beApplyTransaction backend (transactionOps (txBase transaction) (txStaged transaction) live)
applied <- beApplyTransaction backend (transactionOps diffs)
case applied of
Left err -> pure (Left (engineErrorCode err))
Right () -> do
writeIORef (ssTransaction session) Nothing
pure (Right (emptyResult (Just current)))
-- 检查当前数据库连接权限。
sessionConnectAllowed :: Session -> IO (Either SessionError ())
sessionConnectAllowed session = do
database <- readIORef (ssCurrent session)
who <- readIORef (ssPrincipal session)
case who of
Just principal | not (principalIsRoot principal), not (T.null database) -> fmap (first privilegeErrorOf) (authorizeConnect (ssPrivileges session) principal database)
_ -> pure (Right ())
-- 保存事务使用的 catalog 对象编号。
snapshotObjectIds :: Session -> [String] -> IO (Either SessionError [(String, A.Value)])
snapshotObjectIds session names = do
database <- readIORef (ssCurrent session)
if database == "system" then pure (Right []) else do
results <- mapM (one database) (filter (not . T.isPrefixOf "__system_" . T.pack) names)
pure (sequence results)
where
-- 解析一个快照表的稳定对象编号。
one database name = do
result <- beStorage (ssBackend session) (A.object ["method" A..= ("resolve_object" :: Text), "database" A..= database, "table" A..= name])
pure $ case result of
Left err -> Left (SessionError "serialization_failure" (T.pack err))
Right value@(A.Object fields) | KM.lookup "status" fields == Just (A.String "object") -> Right (name, value)
Right _ -> Left (SessionError "serialization_failure" "transaction object no longer exists")
-- | 回滚:快照丢掉,存储层没被改过
rollbackTransaction :: Session -> IO (Either SessionError QueryResult)
rollbackTransaction session = do
@@ -306,7 +431,7 @@ savepointTransaction session name = do
case existing of
Nothing -> pure (Left (SessionError "query_error" "no transaction in progress"))
Just transaction -> do
let stack = txSavepoints transaction ++ [(T.unpack name, txStaged transaction)]
let stack = txSavepoints transaction ++ [(T.unpack name, txStaged transaction, txStatements transaction)]
writeIORef (ssTransaction session) (Just transaction {txSavepoints = stack})
pure (Right (emptyResult (Just current)))
@@ -320,10 +445,10 @@ rollbackToSavepoint session name = do
Just transaction -> case savepointIndex name (txSavepoints transaction) of
Nothing -> pure (Left (SessionError "query_error" ("no such savepoint: " <> name)))
Just index -> do
let (_, staged) = txSavepoints transaction !! index
let (_, staged, statements) = txSavepoints transaction !! index
writeIORef
(ssTransaction session)
(Just transaction {txStaged = staged, txSavepoints = take (index + 1) (txSavepoints transaction)})
(Just transaction {txStaged = staged, txStatements = statements, txSavepoints = take (index + 1) (txSavepoints transaction)})
pure (Right (emptyResult (Just current)))
-- | 释放保存点:该保存点与它之后的保存点一起丢掉
@@ -340,9 +465,9 @@ releaseSavepoint session name = do
pure (Right (emptyResult (Just current)))
-- | 最近一次同名保存点的下标
savepointIndex :: Text -> [(String, Database)] -> Maybe Int
savepointIndex :: Text -> [(String, Database, [Statement])] -> Maybe Int
savepointIndex name entries =
case [index | (index, (label, _)) <- zip [0 ..] entries, T.pack label == name] of
case [index | (index, (label, _, _)) <- zip [0 ..] entries, T.pack label == name] of
[] -> Nothing
hits -> Just (last hits)
@@ -356,7 +481,7 @@ runInTransaction session statement = do
Just transaction -> case scopeDdl (T.unpack current) statement >>= Engine.runStatement (txStaged transaction) of
Left err -> pure (Left (engineErrorCode err))
Right (staged, rows) -> do
writeIORef (ssTransaction session) (Just transaction {txStaged = staged})
writeIORef (ssTransaction session) (Just transaction {txStaged = staged, txStatements = statement : txStatements transaction})
pure (Right (resultOfStaged (txStaged transaction) statement rows))
-- | 事务内的结果集:空结果回落到解析出来的列名
@@ -376,8 +501,8 @@ data TableDiff = TableDiff
}
-- | 提交差分:相对快照列出要删、要写与要替换的行
transactionOps :: Database -> Database -> Database -> [TxnOp]
transactionOps base staged live = concatMap opsOf (transactionDiffs base staged live)
transactionOps :: [(String, TableDiff)] -> [TxnOp]
transactionOps = concatMap opsOf
where
-- | 一张表的请求:先删后写
opsOf (name, diff) =
@@ -386,9 +511,9 @@ transactionOps base staged live = concatMap opsOf (transactionDiffs base staged
++ [TxnReplace name rows | Just rows <- [tdReplace diff]]
-- | 提交前校验:本事务动过的行是否已被别人改掉
transactionConflict :: Database -> Database -> Database -> Maybe String
transactionConflict base staged live =
case [msg | (_, diff) <- transactionDiffs base staged live, Just msg <- [tdConflict diff]] of
transactionConflict :: [(String, TableDiff)] -> Maybe String
transactionConflict diffs =
case [msg | (_, diff) <- diffs, Just msg <- [tdConflict diff]] of
(msg : _) -> Just msg
[] -> Nothing
@@ -401,9 +526,8 @@ transactionDiffs base staged live = [(name, diffFor name) | name <- names]
-- | 一张表的差异
diffFor name
| all (isJust . rowKey) (baseRows ++ stagedRows) = keyedDiff
-- 没动过这张表:别人改成什么样都不关本事务
| stagedRows == baseRows = emptyDiff
| all (isJust . rowKey) (baseRows ++ stagedRows) = keyedDiff
-- 动过,库里还是基线:整表替换
| liveRows == baseRows = emptyDiff {tdReplace = Just stagedRows}
| otherwise = emptyDiff {tdConflict = Just ("write conflict on table " ++ name)}
@@ -412,27 +536,30 @@ transactionDiffs base staged live = [(name, diffFor name) | name <- names]
stagedRows = rowsOf name staged
liveRows = rowsOf name live
baseByKey = [(k, r) | r <- baseRows, Just k <- [rowKey r]]
liveByKey = [(k, r) | r <- liveRows, Just k <- [rowKey r]]
stagedByKey = [(k, r) | r <- stagedRows, Just k <- [rowKey r]]
baseByKey = keyedRows baseRows
liveByKey = keyedRows liveRows
stagedByKey = keyedRows stagedRows
stagedEntries = [(k, r) | r <- stagedRows, Just k <- [rowKey r]]
-- 本事务动过的键:内容改过、新增,或者删掉
written = [k | (k, r) <- stagedByKey, lookup k baseByKey /= Just r]
removed = [k | (k, _) <- baseByKey, not (any ((== k) . fst) stagedByKey)]
written = [k | (k, r) <- stagedEntries, IM.lookup k baseByKey /= Just r]
writtenSet = IS.fromList written
removed = [k | r <- baseRows, Just k <- [rowKey r], IM.notMember k stagedByKey]
removedSet = IS.fromList removed
touched = written ++ removed
-- 两边都删了算一致;其余只要跟基线不一样就是冲突
victims =
[ k
| k <- touched
, lookup k liveByKey /= lookup k baseByKey
, not (k `elem` removed && lookup k liveByKey == Nothing)
, IM.lookup k liveByKey /= IM.lookup k baseByKey
, not (IS.member k removedSet && IM.notMember k liveByKey)
]
keyedDiff =
emptyDiff
{ tdDeletes = [k | k <- touched, isJust (lookup k liveByKey)]
, tdWrites = [r | (k, r) <- stagedByKey, k `elem` written]
{ tdDeletes = [k | k <- touched, IM.member k liveByKey]
, tdWrites = [r | (k, r) <- stagedEntries, IS.member k writtenSet]
, tdConflict = case victims of
(k : _) -> Just ("write conflict on table " ++ name ++ ", id " ++ show k)
[] -> Nothing
@@ -447,6 +574,10 @@ transactionDiffs base staged live = [(name, diffFor name) | name <- names]
-- | 库里某张表的行
rowsOf name db = maybe [] tableRows (lookup name db)
-- | 按整数 id 建立保留首行的查找表
keyedRows :: [Row] -> IM.IntMap Row
keyedRows rows = IM.fromListWith (\_ earlier -> earlier) [(key, row) | row <- rows, Just key <- [rowKey row]]
-- | 行 id:只有整数 id 才认,跟存储层删行的口径一致
rowKey :: Row -> Maybe Int
rowKey row = case lookup "id" row of
@@ -471,9 +602,64 @@ runPlain session sql = do
result <- beStatement backend (T.unpack sql)
pure (either (Left . engineErrorCode) (Right . resultOf) result)
-- 执行对象结构变更并维护所有者和授权。
runObjectStatement :: Session -> Statement -> Text -> IO (Either SessionError QueryResult)
runObjectStatement session statement sql = do
who <- readIORef (ssPrincipal session)
database <- readIORef (ssCurrent session)
prepared <- case (who, statement) of
(Just principal, CreateTable name _) | database /= "system" -> prepareObject (ssPrivileges session) principal database (T.pack name)
_ -> pure (Right ())
affected <- case statement of
DropTable name | database /= "system" -> affectedObject (ssPrivileges session) database (T.pack name)
DropDatabase name | name /= "system" -> affectedObject (ssPrivileges session) "" ("database:" <> T.pack name)
_ -> pure (Right [])
case prepared >> affected of
Left err -> pure (Left (privilegeErrorOf err))
Right names -> do
result <- runPreparedObject session statement sql
notifyChanged session names
pure result
-- 执行已登记创建声明的对象变更。
runPreparedObject :: Session -> Statement -> Text -> IO (Either SessionError QueryResult)
runPreparedObject session statement sql = do
result <- runPlain session sql
case result of
Left err -> case statement of
CreateTable{} -> do
cleaned <- reconcileObjects (ssPrivileges session)
pure $ case cleaned of
Left failure -> Left (SessionError "storage_error" (sessMessage err <> "; creator intent cleanup failed: " <> privilegeMessage failure))
Right () -> Left err
_ -> pure (Left err)
Right value -> do
who <- readIORef (ssPrincipal session)
database <- readIORef (ssCurrent session)
maintained <- case (who, statement) of
(Just principal, CreateTable name _) | database /= "system" -> claimObject (ssPrivileges session) principal database (T.pack name)
(Just principal, CreateDatabase name) -> claimObject (ssPrivileges session) principal "" ("database:" <> T.pack name)
(_, DropTable{}) -> reconcileObjects (ssPrivileges session)
(_, DropDatabase{}) -> reconcileObjects (ssPrivileges session)
_ -> pure (Right ())
case maintained of
Right () -> pure (Right value)
Left err -> do
cleanup <- case statement of
CreateTable name _ -> runPlain session ("DROP TABLE " <> T.pack name)
CreateDatabase name -> runPlain session ("DROP DATABASE " <> T.pack name)
_ -> pure (Right value)
pure $ case cleanup of
Left failure -> Left (SessionError "storage_error" (privilegeMessage err <> "; object cleanup failed: " <> sessMessage failure))
Right _ -> Left (privilegeErrorOf err)
-- | 数据字典;普通身份只看到有 SELECT 权的表
catalog :: Session -> IO (Either Text [TableInfo])
catalog session = do
catalog session = withReadSession session (catalogUnlocked session)
-- 在权限共享门内读取可见表目录。
catalogUnlocked :: Session -> IO (Either Text [TableInfo])
catalogUnlocked session = do
current <- readIORef (ssCurrent session)
if T.null current
then pure (Left "no database selected")
@@ -509,13 +695,31 @@ withAccountInfo session tables = do
-- | 库清单(\l 用)
databases :: Session -> IO (Either Text [Text])
databases session = do
databases session = withReadSession session $ do
result <- beDatabases (ssBackend session)
pure (either (Left . T.pack) (Right . map T.pack) result)
who <- readIORef (ssPrincipal session)
case (result, who) of
(Left err, _) -> pure (Left (T.pack err))
(Right names, Just principal) | not (principalIsRoot principal) -> do
checks <- mapM (check principal . T.pack) names
pure $ case [err | Left err@(PrivilegeError code _) <- checks, code /= "forbidden"] of
err : _ -> Left (privilegeMessage err)
[] -> Right [T.pack name | (name, Right ()) <- zip names checks]
(Right names, _) -> pure (Right (map T.pack names))
where
-- 检查业务库连接或系统目录管理权限。
check principal "system" = pure (if principalIsCatalogManager principal then Right () else Left (PrivilegeError "forbidden" "system catalog manager required"))
check principal name = authorizeConnect (ssPrivileges session) principal name
-- 在共享权限门内复核会话并读取接口。
withReadSession :: Session -> IO (Either Text a) -> IO (Either Text a)
withReadSession session action = readSecurity $ do
valid <- validatePrincipal session
case valid of Left err -> pure (Left (sessMessage err)); Right () -> action
-- | 角色总览,只给管理员
roleViews :: Session -> IO (Either Text [RoleView])
roleViews session = do
roleViews session = withReadSession session $ do
admin <- sessionIsAdmin session
if not admin
then pure (Left "administrator required")
@@ -525,7 +729,7 @@ roleViews session = do
-- | 账号清单(\du 与账号管理页用);只给管理员
accounts :: Session -> IO (Either Text [Account])
accounts session = do
accounts session = withReadSession session $ do
admin <- sessionIsAdmin session
if not admin
then pure (Left "administrator required")
@@ -547,9 +751,9 @@ showIdentities session = do
result <- beAccounts (ssBackend session) ReqAccountsList
pure $ case result of
Left err -> Left (SessionError "storage_error" (T.pack err))
Right identities -> Right (QueryResult ["id", "name", "can_login", "is_superuser", "enabled", "system_catalog_manager", "created_at"]
Right identities -> Right (QueryResult ["id", "name", "can_login", "is_superuser", "enabled", "system_catalog_manager", "allow_sudo_auth", "created_at"]
[[VInt (fromInteger (accountId a)), VStr (T.unpack (accountUser a)), VBool (accountCanLogin a),
VBool (accountIsSuperuser a), VBool (accountEnabled a), VBool (accountSystemCatalogManager a), VStr (T.unpack (accountRegisteredAt a))] | a <- identities]
VBool (accountIsSuperuser a), VBool (accountEnabled a), VBool (accountSystemCatalogManager a), VBool (accountAllowSudoAuth a), VStr (T.unpack (accountRegisteredAt a))] | a <- identities]
(length identities) False Nothing)
-- | 执行身份管理并通知受影响会话
@@ -562,13 +766,17 @@ runAccount session command = do
affected <- case command of
AlterAccountAttributes name _ -> affectedAccounts (ssPrivileges session) (DropRoleCommand name)
DropAccount name -> affectedAccounts (ssPrivileges session) (DropRoleCommand name)
_ -> pure (accountCommandUsers command)
_ -> pure (Right (accountCommandUsers command))
case affected of
Left err -> pure (Left (privilegeErrorOf err))
Right names -> do
result <- runAccountCommand (ssAccounts session) principal command
case result of
Left err -> pure (Left (accountErrorOf err))
Right () -> do
notifyChanged session affected
pure (Right (emptyResult Nothing))
cleaned <- reconcileObjects (ssPrivileges session)
notifyChanged session names
pure (either (Left . privilegeErrorOf) (const (Right (emptyResult Nothing))) cleaned)
-- | 一条账号命令影响的账号
accountCommandUsers :: AccountCommand -> [Text]
@@ -588,11 +796,14 @@ runPrivilege session command = do
database <- readIORef (ssCurrent session)
-- 受影响账号要趁命令落地之前算:删角色之后成员就查不到了
affected <- affectedAccounts (ssPrivileges session) command
case affected of
Left err -> pure (Left (privilegeErrorOf err))
Right names -> do
result <- runPrivilegeCommand (ssPrivileges session) principal database command
case result of
Left err -> pure (Left (privilegeErrorOf err))
Right () -> do
notifyChanged session affected
notifyChanged session names
pure (Right (emptyResult Nothing))
-- | 通知变更:把受影响的账号交给会话的变更钩子
+106 -21
View File
@@ -11,19 +11,24 @@ module ChuSQL.Server.TCP (
ServerHandle (..),
startServer,
runServer,
isLocalPeer,
) where
import ChuSQL.Interface.Config (ServerConfig (..), defaultServerConfig, loadServerConfigAt)
import ChuSQL.Interface.Sudo (SudoCredential, createSudoCredential, removeSudoCredential, sudoChallenge, validSudoChallenge, isLocalPeer)
import Data.Time.Clock (UTCTime, getCurrentTime)
import ChuSQL.Interface.Policy (PasswordPolicy (..))
import ChuSQL.Interface.Protocol (ClientRequest (..), ServerResponse (..), decodeRequest, encodeResponse, protocolVersion)
import ChuSQL.Interface.RateLimit (RateLimiter, rateLimitBlock, rateLimitClear, rateLimitRecord)
import qualified ChuSQL.Core.Engine.Error as E
import ChuSQL.Core.Protocol (Account (..), Request (ReqIdentityInitialize))
import ChuSQL.Server.Backend (Backend (..))
import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), accounts, authenticateSessionCoded, catalog, databases, newSessionWith, policyOf, reloadPolicy, roleViews, runStatementCoded, sessionIsAdmin, sessionUser)
import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), accounts, authenticateSessionCoded, authenticateSudoSessionCoded, isPlainIdentifier, catalog, databases, newSessionWith, policyOf, reloadPolicy, roleViews, runStatementCoded, runStorageCoded, sessionIsAdmin, sessionUser)
import ChuSQL.Server.Security (writeSecurity)
import ChuSQL.Server.Privileges (newPrivileges, reconcileObjects)
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
import Control.Exception (IOException, finally, try)
import Control.Exception (IOException, bracket, finally, onException, try)
import Control.Monad (filterM, void)
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy.Char8 as BLC
@@ -48,6 +53,7 @@ import Network.Socket (
defaultProtocol,
getAddrInfo,
getSocketName,
getPeerName,
listen,
setSocketOption,
socket,
@@ -64,6 +70,8 @@ import System.IO.Error (isEOFError)
data LiveEntry = LiveEntry
{ leWho :: IORef (Maybe Text)
, leDropped :: IORef Bool
, leLocal :: Bool
, leChallenge :: IORef (Maybe (Text, UTCTime))
}
-- | 在线连接登记:自增编号到连接条目
@@ -77,8 +85,8 @@ newLiveConnections :: IO LiveConnections
newLiveConnections = LiveConnections <$> newIORef 0 <*> newMVar Map.empty
-- | 新建一条连接条目
newLiveEntry :: IO LiveEntry
newLiveEntry = LiveEntry <$> newIORef Nothing <*> newIORef False
newLiveEntry :: Bool -> IO LiveEntry
newLiveEntry local = LiveEntry <$> newIORef Nothing <*> newIORef False <*> pure local <*> newIORef Nothing
-- | 登记一条连接,返回注销动作
registerConnection :: LiveConnections -> LiveEntry -> IO (IO ())
@@ -112,6 +120,7 @@ data ServerEnv = ServerEnv
, srvConfig :: ServerConfig
, srvLimiter :: RateLimiter
, srvLive :: LiveConnections
, srvSudo :: MVar (Maybe (Int, Text, SudoCredential))
}
-- | 组装服务器环境:每个连接再各开一个会话
@@ -124,7 +133,13 @@ newServerEnv backend rootName settingsFile config limiter = do
| any (\a -> accountEnabled a && accountCanLogin a && accountIsSuperuser a) identities -> pure ()
| otherwise -> ioError (userError "identity migration failed: no enabled login superuser; stop all processes and try csql-bootstrap recover --config <settings.toml>; reset replaces system identities and grants")
live <- newLiveConnections
pure (ServerEnv backend rootName settingsFile config limiter live)
privileges <- newPrivileges backend
recovered <- writeSecurity (reconcileObjects privileges)
case recovered of
Left err -> ioError (userError ("object privilege recovery failed: " ++ show err))
Right () -> pure ()
sudo <- newMVar Nothing
pure (ServerEnv backend rootName settingsFile config limiter live sudo)
data ServerHandle = ServerHandle
{ shPort :: Int
@@ -136,18 +151,42 @@ startServer :: ServerEnv -> IO ServerHandle
startServer env = do
sock <- listenSocket (scHost (srvConfig env)) (scPort (srvConfig env))
port <- actualPort sock
enableSudo env port `onException` close sock
stopped <- newMVar False
_ <- forkIO (acceptLoop env sock stopped)
pure (ServerHandle port (stopListening sock stopped))
pure (ServerHandle port (stopListening sock stopped `finally` disableSudo env))
-- | 在调用线程里收连接(可执行文件用);绑好端口先回调一次
runServer :: ServerEnv -> (Int -> IO ()) -> IO ()
runServer env announce = do
sock <- listenSocket (scHost (srvConfig env)) (scPort (srvConfig env))
runServer env announce = bracket (listenSocket (scHost (srvConfig env)) (scPort (srvConfig env))) close $ \sock -> do
port <- actualPort sock
enableSudo env port
(do
announce port
stopped <- newMVar False
acceptLoop env sock stopped
acceptLoop env sock stopped) `finally` disableSudo env
-- 为显式配置的本机身份映射创建凭据。
enableSudo :: ServerEnv -> Int -> IO ()
enableSudo env port
| T.null user = pure ()
| not (isPlainIdentifier user) = ioError (userError "sudo_auth_user must be a plain identity name")
| otherwise = modifyMVar_ (srvSudo env) $ \current -> case current of
Just _ -> ioError (userError "sudo authentication is already running")
Nothing -> do
credential <- createSudoCredential port
hPutStrLn stderr ("sudo_auth enabled: local elevated identity -> " ++ T.unpack user)
pure (Just (port, user, credential))
where
user = scSudoUser (srvConfig env)
-- 清理本次服务实例的本机认证凭据。
disableSudo :: ServerEnv -> IO ()
disableSudo env = modifyMVar_ (srvSudo env) $ \current -> do
case current of
Nothing -> pure ()
Just (port, _, _) -> removeSudoCredential port
pure Nothing
-- | 置停止标记并关掉监听套接字
stopListening :: Socket -> MVar Bool -> IO ()
@@ -209,10 +248,11 @@ reportConnection env conn = do
-- | 一个连接一个会话:一行一条 JSON,读到 EOF 就收工
serveConnection :: ServerEnv -> Socket -> IO ()
serveConnection env conn = do
peer <- getPeerName conn
h <- socketToHandle conn ReadWriteMode
hSetBuffering h LineBuffering
hSetNewlineMode h noNewlineTranslation
entry <- newLiveEntry
entry <- newLiveEntry (isLocalPeer peer)
unregister <- registerConnection (srvLive env) entry
session <- newSessionWith (srvBackend env) (srvRootName env) (srvSettingsFile env) (\names -> void (dropConnectionsOf (srvLive env) names))
outcome <- try (loop h session entry `finally` unregister) :: IO (Either IOException ())
@@ -250,11 +290,25 @@ dispatch env session entry request = case request of
| version == protocolVersion -> pure (RespHello protocolVersion, True)
| otherwise -> pure (RespError "bad_request" ("unsupported protocol version: " <> tshow version), True)
ReqLogin user password -> do
writeIORef (leChallenge entry) Nothing
response <- login env session user password
case response of
RespLogin who _ -> writeIORef (leWho entry) (Just who)
_ -> pure ()
pure (response, True)
ReqSudoChallenge -> do
configured <- readMVar (srvSudo env)
who <- sessionUser session
case configured of
Just _ | leLocal entry && who == Nothing -> do
nonce <- sudoChallenge
now <- getCurrentTime
writeIORef (leChallenge entry) (Just (nonce, now))
pure (RespSudoChallenge nonce, True)
_ -> pure (RespError "forbidden" "local sudo authentication is unavailable", True)
ReqSudoLogin user proof -> do
response <- sudoLogin env session entry user proof
pure (response, True)
ReqQuery sql -> do
who <- sessionUser session
response <- case who of
@@ -268,17 +322,9 @@ dispatch env session entry request = case request of
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)
result <- runStorageCoded session payload
let response = case result of
Left err -> RespError (sessCode err) (sessMessage err)
Right value -> RespStorage value
pure (response, True)
ReqCatalog -> do
@@ -302,6 +348,45 @@ dispatch env session entry request = case request of
ReqPing -> pure (RespPong, True)
ReqQuit -> pure (RespBye, False)
-- 消费一次性证明并登录本机映射账号。
sudoLogin :: ServerEnv -> Session -> LiveEntry -> Text -> Text -> IO ServerResponse
sudoLogin env session entry user proof = do
challenge <- atomicModifyIORef' (leChallenge entry) (\value -> (Nothing, value))
configured <- readMVar (srvSudo env)
now <- getCurrentTime
who <- sessionUser session
let key = T.toLower (T.strip user)
mapped = maybe "" (\(_, name, _) -> name) configured
valid = leLocal entry && who == Nothing && key == mapped
&& case configured of
Just (_, _, credential) -> validSudoChallenge credential now challenge key proof
Nothing -> False
blocked <- rateLimitBlock (srvLimiter env) key
response <- case blocked of
Just _ -> pure (RespError "too_many_attempts" "too many failed sudo logins")
Nothing | not valid -> do
rateLimitRecord (srvLimiter env) key
pure (RespError "unauthorized" "sudo authentication refused")
Nothing -> do
result <- authenticateSudoSessionCoded session key
case result of
Left err -> do
rateLimitRecord (srvLimiter env) key
pure (RespError (sessCode err) (sessMessage err))
Right () -> do
rateLimitClear (srvLimiter env) key
writeIORef (leWho entry) (Just key)
admin <- sessionIsAdmin session
pure (RespLogin key admin)
hPutStrLn stderr ("sudo_auth attempt: mapped_user=" ++ T.unpack mapped
++ " local=" ++ show (leLocal entry) ++ " result=" ++ auditResult response)
pure response
where
-- 提取不包含凭据的认证审计结果。
auditResult RespLogin{} = "accepted"
auditResult (RespError code _) = T.unpack code
auditResult _ = "refused"
-- | 口令策略在线上只有两个数字:最短长度与至少几类字符
policyResponse :: PasswordPolicy -> ServerResponse
policyResponse (PasswordPolicy minLength classes) = RespPolicy minLength classes
+439 -15
View File
@@ -5,18 +5,22 @@ module Main (main) where
import ChuSQL.Core.Engine.Storage.IPC (
Account (..),
Request (ReqAccountReset, ReqAccountsList),
Request (ReqAccountCreate, ReqAccountReset, ReqAccountsList, ReqIdentityAlter),
TableInfo (..),
closeConnection,
localStorageLink,
setStorageLink,
)
import ChuSQL.Core.Engine.Syntax.AST (Statement)
import Data.IORef (newIORef, readIORef, writeIORef)
import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
import ChuSQL.Core.Model (Database, Histogram (..), Row, Table (..), Value (..), pattern TInt, pattern TStr)
import ChuSQL.Interface.Auth (hashPasswordWith)
import ChuSQL.Interface.Protocol (ClientRequest (..), Grant (..), RoleView (..), ServerResponse (..), decodeRequest, encodeResponse)
import ChuSQL.Interface.RateLimit (newRateLimiter)
import ChuSQL.Interface.Link (connectClient, closeClient, clientSudoLogin, clientQuery)
import ChuSQL.Interface.Sudo (SudoCredential, newSudoCredential, sudoProof, verifySudoProof, validSudoChallenge,
createSudoCredential, removeSudoCredential, readSudoCredential, sudoPrivileged)
import ChuSQL.Server.Accounts (Principal (..), ensureRootAccount)
import ChuSQL.Server.Backend (Backend (..), StatementResult (..), ipcBackend, memoryBackend)
import ChuSQL.Server.Privileges (
@@ -25,24 +29,30 @@ import ChuSQL.Server.Privileges (
Privileges,
affectedAccounts,
authorize,
authorizeConnect,
claimObject,
prepareObject,
listRoleViews,
newPrivileges,
runPrivilegeCommand,
)
import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), newSession, runStatementCoded)
import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), newSession, runStatementCoded, runStorageCoded, authenticateSessionCoded)
import ChuSQL.Server.TCP (
ServerConfig (..),
ServerEnv,
ServerEnv (..),
ServerHandle (..),
defaultServerConfig,
loadServerConfigAt,
newServerEnv,
startServer,
isLocalPeer,
)
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, takeMVar)
import System.Timeout (timeout)
import Control.Exception (IOException, bracket, finally, try)
import Control.Monad (void)
import Data.List (sort)
import Data.Aeson (decode)
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as K
@@ -54,9 +64,12 @@ 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 Data.Time.Clock (addUTCTime, getCurrentTime)
import Network.Socket (
AddrInfo (..),
SockAddr (..),
tupleToHostAddress,
tupleToHostAddress6,
SocketType (Stream),
addrAddress,
addrFamily,
@@ -81,7 +94,6 @@ import System.IO (
hSetNewlineMode,
noNewlineTranslation,
)
import System.Timeout (timeout)
import Test.Hspec hiding (after, before)
-- TCP 服务器测试:协议编解码、配置读取与真连服务器的端到端用例。
@@ -93,9 +105,119 @@ main = hspec spec
-- | 全部用例
spec :: Spec
spec = do
describe "sudo authentication" $ do
it "defaults to disabled and rejects unconfigured TCP authentication" $
withTcpServer defaultServerConfig $ \_ handle -> withConnection handle $ \client -> do
scSudoUser defaultServerConfig `shouldBe` ""
challenge <- tcpTalk client "{\"method\":\"sudo_challenge\"}"
at "code" challenge `shouldBe` A.String "forbidden"
denied <- tcpTalk client "{\"method\":\"sudo_login\",\"user\":\"admin\",\"proof\":\"fake\"}"
at "code" denied `shouldBe` A.String "unauthorized"
it "loads an explicit normalized local identity mapping" $ do
path <- tempSettingsPath "sudo-config"
writeFile path (unlines ["[server]", "sudo_auth_user = " ++ show ("Local_User" :: String)])
config <- loadServerConfigAt path `finally` removeIfExists path
scSudoUser config `shouldBe` "local_user"
it "supports the client challenge and login exchange" $
withTestSudo $ \_ handle credential -> do
connected <- connectClient "127.0.0.1" (shPort handle)
case connected of
Left message -> expectationFailure (T.unpack message)
Right client -> (do
clientSudoLogin client credential "local_user" >>= (`shouldBe` Right False)
result <- clientQuery client "select 1"
result `shouldSatisfy` isRightResult) `finally` closeClient client
it "only treats kernel loopback addresses as local" $ do
isLocalPeer (SockAddrInet 7777 (tupleToHostAddress (127, 0, 0, 1))) `shouldBe` True
isLocalPeer (SockAddrInet 7777 (tupleToHostAddress (192, 168, 1, 2))) `shouldBe` False
isLocalPeer (SockAddrInet6 7777 0 (tupleToHostAddress6 (0,0,0,0,0,0,0,1)) 0) `shouldBe` True
isLocalPeer (SockAddrInet6 7777 0 (tupleToHostAddress6 (0,0,0,0,0,65535,32512,1)) 0) `shouldBe` True
isLocalPeer (SockAddrInet6 7777 0 (tupleToHostAddress6 (0,0,0,0,0,65535,49320,1)) 0) `shouldBe` False
it "binds proofs to the instance, challenge, account and expiration" $ do
credential <- newSudoCredential
other <- newSudoCredential
now <- getCurrentTime
let proof = sudoProof credential "nonce" "local_user"
verifySudoProof credential "nonce" "LOCAL_USER" proof `shouldBe` True
verifySudoProof other "nonce" "local_user" proof `shouldBe` False
verifySudoProof credential "other" "local_user" proof `shouldBe` False
verifySudoProof credential "nonce" "admin" proof `shouldBe` False
validSudoChallenge credential now (Just ("nonce", addUTCTime (-61) now)) "local_user" proof `shouldBe` False
validSudoChallenge credential now (Just ("nonce", addUTCTime 1 now)) "local_user" proof `shouldBe` False
validSudoChallenge credential now Nothing "local_user" proof `shouldBe` False
it "requires an OS elevated identity to provision or read credentials" $ do
privileged <- sudoPrivileged
if privileged then do
bracket (createSudoCredential 65534) (const (removeSudoCredential 65534)) $ \credential -> do
stored <- readSudoCredential 65534
case stored of
Left message -> expectationFailure (T.unpack message)
Right restored -> sudoProof restored "native" "local_user" `shouldBe` sudoProof credential "native" "local_user"
duplicate <- try (createSudoCredential 65534) :: IO (Either IOException SudoCredential)
duplicate `shouldSatisfy` isLeftResult
else do
created <- try (createSudoCredential 65534) :: IO (Either IOException SudoCredential)
created `shouldSatisfy` isLeftResult
readSudoCredential 65534 >>= (`shouldSatisfy` isLeftResult)
it "logs in an ordinary mapped identity without elevating its privileges" $
withTestSudo $ \_ handle credential -> withConnection handle $ \client -> do
answer <- tcpSudo client credential "local_user"
at "status" answer `shouldBe` A.String "ok"
at "admin" answer `shouldBe` A.Bool False
denied <- tcpQuery client "create database forbidden"
at "code" denied `shouldBe` A.String "forbidden"
it "rejects a forged proof and consumes its challenge" $
withTestSudo $ \_ handle credential -> withConnection handle $ \client -> do
nonce <- tcpTalk client "{\"method\":\"sudo_challenge\"}"
denied <- tcpTalk client "{\"method\":\"sudo_login\",\"user\":\"local_user\",\"proof\":\"forged\"}"
at "code" denied `shouldBe` A.String "unauthorized"
replay <- tcpSudoProof client "local_user" (sudoProof credential (asText (at "challenge" nonce)) "local_user")
at "code" replay `shouldBe` A.String "unauthorized"
it "rejects proof reuse on another connection and account mapping" $
withTestSudo $ \_ handle credential -> withConnection handle $ \first -> withConnection handle $ \second -> do
nonce <- tcpTalk first "{\"method\":\"sudo_challenge\"}"
let proof = sudoProof credential (asText (at "challenge" nonce)) "local_user"
replay <- tcpSudoProof second "local_user" proof
at "code" replay `shouldBe` A.String "unauthorized"
mismatch <- tcpSudo first credential "admin"
at "code" mismatch `shouldBe` A.String "unauthorized"
it "revokes the attribute and drops existing sudo sessions" $
withTestSudo $ \_ handle credential -> withConnection handle $ \admin -> withConnection handle $ \client -> do
_ <- tcpLogin admin testRootName testRootPassword
_ <- tcpSudo client credential "local_user"
changed <- tcpQuery admin "alter user local_user noallow_sudo_auth"
at "status" changed `shouldBe` A.String "result"
expired <- tcpQuery client "select 1"
at "code" expired `shouldBe` A.String "unauthorized"
tcpClosed client
withConnection handle $ \fresh -> do
denied <- tcpSudo fresh credential "local_user"
at "code" denied `shouldBe` A.String "unauthorized"
it "rejects disabled and NOLOGIN identities" $
withTestSudo $ \_ handle credential -> withConnection handle $ \admin -> do
_ <- tcpLogin admin testRootName testRootPassword
mapM_ (checkSudoDisabled admin handle credential)
["alter user local_user disabled", "alter user local_user enabled nologin"]
it "does not inherit sudo authentication from a role" $
withTestSudo $ \_ handle credential -> withConnection handle $ \admin -> do
_ <- tcpLogin admin testRootName testRootPassword
_ <- tcpQuery admin "create role sudo_role"
_ <- tcpQuery admin "alter role sudo_role allow_sudo_auth"
_ <- tcpQuery admin "grant sudo_role to local_user"
_ <- tcpQuery admin "alter user local_user noallow_sudo_auth"
withConnection handle $ \client -> do
denied <- tcpSudo client credential "local_user"
at "code" denied `shouldBe` A.String "unauthorized"
it "keeps password login independent of the sudo attribute" $
withTestSudo $ \_ handle _ -> withConnection handle $ \client -> do
denied <- tcpLogin client "local_user" ""
at "code" denied `shouldBe` A.String "unauthorized"
accepted <- tcpLogin client "local_user" "Local-Pass123!"
at "status" accepted `shouldBe` A.String "ok"
tcpSpec
tcpServerSpec
privilegeSpec
objectPrivilegeSpec
transactionSpec
ipcConcurrencySpec
identitySpec
@@ -118,7 +240,7 @@ identitySpec = describe "unified identities" $ do
switched <- tcpQuery manager "use system"
asText (at "status" switched) `shouldBe` "result"
mapM_ (\sql -> tcpQuery manager sql >>= \reply -> asText (at "code" reply) `shouldBe` "forbidden")
["alter user manager superuser", "alter user managed system_catalog_manager", "alter user admin identified by 'Another-Pass123!'", "create database forbidden"]
["alter user manager superuser", "alter user managed system_catalog_manager", "alter user managed allow_sudo_auth", "alter user admin identified by 'Another-Pass123!'", "create database forbidden"]
it "does not inherit catalog management through role membership" $ withTcpServer defaultServerConfig $ \_ handle ->
withConnection handle $ \admin -> withConnection handle $ \worker -> do
_ <- tcpLogin admin "admin" "s3cret"
@@ -139,7 +261,7 @@ identitySpec = describe "unified identities" $ do
other <- tcpQuery h "create role alice"
asText (at "code" other) `shouldBe` "conflict"
shown <- tcpQuery h "show roles"
map asText (items (at "columns" shown)) `shouldBe` ["id", "name", "can_login", "is_superuser", "enabled", "system_catalog_manager", "created_at"]
map asText (items (at "columns" shown)) `shouldBe` ["id", "name", "can_login", "is_superuser", "enabled", "system_catalog_manager", "allow_sudo_auth", "created_at"]
asInt (at "rowCount" shown) `shouldBe` 3
reader <- tcpQuery h "alter role reader login nologin"
asText (at "code" reader) `shouldBe` "bad_request"
@@ -697,7 +819,7 @@ tcpServerSpec = do
-- | 一个普通账号
testAccount :: Account
testAccount = Account 0 "alice" "" 0 "" Nothing True False True False
testAccount = Account 0 "alice" "" 0 "" Nothing True False True False False
-- | 权限用例传的当前库名
testDatabase :: Text
@@ -707,7 +829,10 @@ testDatabase = T.pack testDatabaseName
withPrivileges :: (Privileges -> Principal -> IO a) -> IO a
withPrivileges body = do
db <- newMVar testDb
service <- newPrivileges (memoryBackend testDatabaseName db)
let backend = memoryBackend testDatabaseName db
_ <- beAccounts backend (ReqAccountCreate "alice" "hash")
_ <- beAccounts backend (ReqAccountCreate "bob" "hash")
service <- newPrivileges backend
body service (Root testRootName)
-- | 解析一条 SQL,失败就丢掉用例
@@ -747,7 +872,7 @@ privilegeSpec = describe "server privileges" $ do
views <- listRoleViews service
fmap (concatMap (map grantPrivilege) . map roleGrants) views
`shouldBe` Right ["select", "insert", "update", "delete"]
fmap (concatMap (map grantObject) . map roleGrants) views `shouldBe` Right (replicate 4 "*")
fmap (concatMap (map grantObject) . map roleGrants) views `shouldBe` Right (replicate 4 "test.*")
it "revokes a privilege again" $ withPrivileges $ \service root -> do
_ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
@@ -919,12 +1044,12 @@ privilegeSpec = describe "server privileges" $ do
_ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "inner" ["reader"])
_ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
directly <- affectedAccounts service (RevokeRoleCommand "inner" ["bob"])
directly `shouldMatchList` ["bob"]
fmap sort directly `shouldBe` Right ["bob"]
granted <- affectedAccounts service (GrantRoleCommand "writer" ["inner"])
granted `shouldMatchList` ["inner", "reader", "alice"]
fmap sort granted `shouldBe` Right (sort ["inner", "reader", "alice"])
dropped <- affectedAccounts service (DropRoleCommand "inner")
dropped `shouldMatchList` ["inner", "reader", "alice"]
affectedAccounts service (CreateRoleCommand "other") `shouldReturn` []
fmap sort dropped `shouldBe` Right (sort ["inner", "reader", "alice"])
affectedAccounts service (CreateRoleCommand "other") `shouldReturn` Right []
it "keeps the role tables on the real storage" $ withIpcStorage $ do
base <- ipcBackend
@@ -944,6 +1069,7 @@ privilegeSpec = describe "server privileges" $ do
it "inherits a role on the real storage" $ withIpcStorage $ do
base <- ipcBackend
seedPrivilegeObjects base
service <- newPrivileges base
_ <- runPrivilegeCommand service (Root testRootName) testDatabase (CreateRoleCommand "reader")
_ <- runPrivilegeCommand service (Root testRootName) testDatabase (CreateRoleCommand "writer")
@@ -955,6 +1081,7 @@ privilegeSpec = describe "server privileges" $ do
it "keeps a grant option on the real storage" $ withIpcStorage $ do
base <- ipcBackend
seedPrivilegeObjects base
service <- newPrivileges base
_ <- runPrivilegeCommand service (Root testRootName) testDatabase (CreateRoleCommand "reader")
_ <- runPrivilegeCommand service (Root testRootName) testDatabase (CreateRoleCommand "writer")
@@ -968,6 +1095,239 @@ privilegeSpec = describe "server privileges" $ do
fmap (map roleGrants) after `shouldBe` Right [[Grant "reader" "select" "test.users" True], [Grant "writer" "select" "test.users" False]]
-- 真存储夹具:一个用例一份数据目录,跑完关链路删干净
-- 创建独立的对象授权内存夹具。
withObjectPrivileges :: (Backend -> Privileges -> Principal -> IO ()) -> IO ()
withObjectPrivileges body = do
db <- newMVar testDb
let backend = memoryBackend testDatabaseName db
mapM_ (\name -> beAccounts backend (ReqAccountCreate name "hash") >>= either (fail . show) (const (pure ()))) ["alice", "bob", "carol"]
service <- newPrivileges backend
body backend service (Root testRootName)
-- 验证对象作用域、授权来源和外部入口。
objectPrivilegeSpec :: Spec
objectPrivilegeSpec = describe "stable object privileges" $ do
it "migrates old table grants once and ignores later legacy writes" $ withObjectPrivileges $ \backend service _ -> do
let system = beWithDatabase backend "system"
mustRun (beStatement system "CREATE TABLE __system_grants (role VARCHAR(64), privilege VARCHAR(16), object VARCHAR(128))")
mustRun (beStatement system "INSERT INTO __system_grants (role, privilege, object) VALUES ('alice', 'select', 'test.users')")
authorizeSql service (Ordinary testAccount) "SELECT * FROM users" `shouldReturn` Right ()
mustRun (beStatement system "INSERT INTO __system_grants (role, privilege, object) VALUES ('bob', 'select', 'test.users')")
authorizeSql service (Ordinary testAccount{accountUser = "bob"}) "SELECT * FROM users" `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
it "recovers a durable creator intent after table creation and cancels absent objects" $ withIpcStorage $ do
backend <- ipcBackend
seedPrivilegeObjects backend
service <- newPrivileges backend
prepareObject service (Ordinary testAccount) "test" "recovered_owned" `shouldReturn` Right ()
mustRun (beStatement (beWithDatabase backend "test") "CREATE TABLE recovered_owned (id INT)")
closeConnection
dir <- ipcDataDir
opened <- localStorageLink (Just (dir ++ ".toml"))
link <- either fail pure opened
setStorageLink link
fresh <- ipcBackend >>= newPrivileges
authorizeSql fresh (Ordinary testAccount) "SELECT * FROM recovered_owned" `shouldReturn` Right ()
prepareObject fresh (Ordinary testAccount) "test" "never_created" `shouldReturn` Right ()
authorizeSql fresh (Ordinary testAccount) "SELECT * FROM recovered_owned" `shouldReturn` Right ()
mustRun (beStatement (beWithDatabase backend "test") "CREATE TABLE never_created (id INT)")
authorizeSql fresh (Ordinary testAccount) "SELECT * FROM never_created" `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON never_created")
it "holds authorization through a concurrent query and orders revocation after it" $ withObjectPrivileges $ \backend service root -> do
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" False) `shouldReturn` Right ()
_ <- beAccounts backend (ReqAccountCreate testRootName (testPasswordHash testRootPassword))
_ <- beAccounts backend (ReqIdentityAlter testRootName Nothing (Just True) Nothing Nothing Nothing)
_ <- beAccounts backend (ReqAccountReset "alice" (testPasswordHash "Alice-Secret-1234"))
started <- newEmptyMVar
release <- newEmptyMVar
finished <- newEmptyMVar
revoked <- newEmptyMVar
let slow = backend{beWithDatabase = \name -> (beWithDatabase backend name){beStatement = \sql -> do
if sql == "SELECT * FROM users" then putMVar started () >> takeMVar release else pure ()
beStatement (beWithDatabase backend name) sql}}
settings <- tempSettingsPath "permission-race"
reader <- newSession slow testRootName settings
admin <- newSession backend testRootName settings
authenticateSessionCoded reader "alice" "Alice-Secret-1234" `shouldReturn` Right ()
authenticateSessionCoded admin testRootName testRootPassword `shouldReturn` Right ()
_ <- mustSql reader "USE test"
_ <- mustSql admin "USE test"
_ <- forkIO (runStatementCoded reader "SELECT * FROM users" >>= putMVar finished)
takeMVar started
_ <- forkIO (runStatementCoded admin "REVOKE SELECT ON users FROM alice" >>= putMVar revoked)
blocked <- timeout 100000 (takeMVar revoked)
case blocked of Nothing -> pure (); Just _ -> expectationFailure "revocation raced past an authorized query"
putMVar release ()
takeMVar finished >>= either (expectationFailure . show) (const (pure ()))
takeMVar revoked >>= either (expectationFailure . show) (const (pure ()))
result <- runStatementCoded reader "SELECT * FROM users"
case result of Left err -> sessCode err `shouldBe` "forbidden"; Right _ -> expectationFailure "revoked privilege remained active"
it "requires existing objects and validates database privilege scope" $ withObjectPrivileges $ \_ service root -> do
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "missing" "alice" False)
`shouldReturn` Left (PrivilegeError "not_found" "unknown table")
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "database:test" "alice" False)
`shouldReturn` Left (PrivilegeError "bad_request" "invalid privilege for object scope")
it "applies PUBLIC CONNECT defaults and explicit inherited connections" $ withObjectPrivileges $ \_ service root -> do
authorizeConnect service (Ordinary testAccount) "test" `shouldReturn` Right ()
runPrivilegeCommand service root "" (RevokePrivilegesCommand ["connect"] "database:test" "public") `shouldReturn` Right ()
authorizeConnect service (Ordinary testAccount) "test" `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: CONNECT ON database:test")
runPrivilegeCommand service root "" (CreateRoleCommand "connector") `shouldReturn` Right ()
runPrivilegeCommand service root "" (GrantPrivilegesCommand ["connect"] "database:test" "connector" False) `shouldReturn` Right ()
runPrivilegeCommand service root "" (GrantRoleCommand "connector" ["alice"]) `shouldReturn` Right ()
authorizeConnect service (Ordinary testAccount) "test" `shouldReturn` Right ()
runPrivilegeCommand service root "" (GrantPrivilegesCommand ["connect"] "database:test" "public" False) `shouldReturn` Right ()
it "grants CREATE without granting existing table access" $ withObjectPrivileges $ \_ service root -> do
runPrivilegeCommand service root "" (GrantPrivilegesCommand ["create"] "database:test" "alice" False) `shouldReturn` Right ()
authorizeSql service (Ordinary testAccount) "CREATE TABLE owned (id INT)" `shouldReturn` Right ()
authorizeSql service (Ordinary testAccount) "SELECT * FROM users" `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
it "gives table owners management and delegation without giving database management" $ withObjectPrivileges $ \_ service root -> do
claimObject service (Ordinary testAccount) testDatabase "users" `shouldReturn` Right ()
authorizeSql service (Ordinary testAccount) "DROP TABLE users" `shouldReturn` Right ()
authorizeSql service (Ordinary testAccount) "INSERT INTO users (id) VALUES (10)" `shouldReturn` Right ()
runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" False) `shouldReturn` Right ()
authorizeSql service (Ordinary testAccount) "DROP DATABASE test" `shouldReturn` Left (PrivilegeError "forbidden" "object owner required")
runPrivilegeCommand service root testDatabase (RevokePrivilegesCommand ["select"] "users" "alice") `shouldReturn` Right ()
authorizeSql service (Ordinary testAccount) "SELECT * FROM users" `shouldReturn` Right ()
it "cascades multihop delegations after the source grant is revoked" $ withObjectPrivileges $ \_ service root -> do
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" True) `shouldReturn` Right ()
runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" True) `shouldReturn` Right ()
let bob = Ordinary testAccount{accountUser = "bob"}
runPrivilegeCommand service bob testDatabase (GrantPrivilegesCommand ["select"] "users" "carol" False) `shouldReturn` Right ()
affectedAccounts service (RevokePrivilegesCommand ["select"] "users" "alice") `shouldReturn` Right ["alice", "bob", "carol"]
runPrivilegeCommand service root testDatabase (RevokePrivilegesCommand ["select"] "users" "alice") `shouldReturn` Right ()
authorizeSql service (Ordinary testAccount{accountUser = "carol"}) "SELECT * FROM users"
`shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
it "keeps an independent source when another delegation chain is revoked" $ withObjectPrivileges $ \_ service root -> do
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" True) `shouldReturn` Right ()
runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" False) `shouldReturn` Right ()
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" False) `shouldReturn` Right ()
runPrivilegeCommand service root testDatabase (RevokePrivilegesCommand ["select"] "users" "alice") `shouldReturn` Right ()
authorizeSql service (Ordinary testAccount{accountUser = "bob"}) "SELECT * FROM users" `shouldReturn` Right ()
it "removes delegations whose grantor loses an inherited source" $ withObjectPrivileges $ \_ service root -> do
runPrivilegeCommand service root testDatabase (CreateRoleCommand "delegator") `shouldReturn` Right ()
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "delegator" True) `shouldReturn` Right ()
runPrivilegeCommand service root testDatabase (GrantRoleCommand "delegator" ["alice"]) `shouldReturn` Right ()
runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" False) `shouldReturn` Right ()
runPrivilegeCommand service root testDatabase (RevokeRoleCommand "delegator" ["alice"]) `shouldReturn` Right ()
authorizeSql service (Ordinary testAccount{accountUser = "bob"}) "SELECT * FROM users" `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
it "does not preserve circular delegation after its last independent root is revoked" $ withObjectPrivileges $ \_ service root -> do
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" True) `shouldReturn` Right ()
runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" True) `shouldReturn` Right ()
runPrivilegeCommand service (Ordinary testAccount{accountUser = "bob"}) testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" True) `shouldReturn` Right ()
runPrivilegeCommand service root testDatabase (RevokePrivilegesCommand ["select"] "users" "alice") `shouldReturn` Right ()
authorizeSql service (Ordinary testAccount{accountUser = "bob"}) "SELECT * FROM users" `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
it "never transfers a dropped table's grant to a same-name replacement" $ withObjectPrivileges $ \backend service root -> do
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" False) `shouldReturn` Right ()
mustRun (beStatement backend "DROP TABLE users")
mustRun (beStatement backend "CREATE TABLE users (id INT)")
authorizeSql service (Ordinary testAccount) "SELECT * FROM users" `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
it "does not let disabled grantors keep downstream grants alive" $ withObjectPrivileges $ \backend service root -> do
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" True) `shouldReturn` Right ()
runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" False) `shouldReturn` Right ()
changed <- beAccounts backend (ReqIdentityAlter "alice" Nothing Nothing (Just False) Nothing Nothing)
either expectationFailure (const (pure ())) changed
authorizeSql service (Ordinary testAccount{accountUser = "bob"}) "SELECT * FROM users" `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
it "preserves dormant direct grants and ownership across unrelated ACL writes" $ withObjectPrivileges $ \backend service root -> do
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "alice" False) `shouldReturn` Right ()
mustRun (beStatement backend "CREATE TABLE owned (id INT)")
claimObject service (Ordinary testAccount) testDatabase "owned" `shouldReturn` Right ()
changed <- beAccounts backend (ReqIdentityAlter "alice" Nothing Nothing (Just False) Nothing Nothing)
either expectationFailure (const (pure ())) changed
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "bob" False) `shouldReturn` Right ()
enabled <- beAccounts backend (ReqIdentityAlter "alice" Nothing Nothing (Just True) Nothing Nothing)
either expectationFailure (const (pure ())) enabled
authorizeSql service (Ordinary testAccount) "SELECT * FROM users" `shouldReturn` Right ()
authorizeSql service (Ordinary testAccount) "DROP TABLE owned" `shouldReturn` Right ()
it "keeps same-name tables in separate database scopes and persists the ACL" $ withIpcStorage $ do
backend <- ipcBackend
seedPrivilegeObjects backend
mustRun (beStatement backend "CREATE DATABASE other")
mustRun (beStatement (beWithDatabase backend "other") "CREATE TABLE users (id INT)")
service <- newPrivileges backend
runPrivilegeCommand service (Root testRootName) "test" (GrantPrivilegesCommand ["select"] "users" "alice" False) `shouldReturn` Right ()
statement <- parseOrFail "SELECT * FROM users"
authorize service (Ordinary testAccount) "other" statement `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
closeConnection
dir <- ipcDataDir
opened <- localStorageLink (Just (dir ++ ".toml"))
link <- either fail pure opened
setStorageLink link
fresh <- ipcBackend >>= newPrivileges
authorize fresh (Ordinary testAccount) "test" statement `shouldReturn` Right ()
authorize fresh (Ordinary testAccount) "other" statement `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
it "checks CONNECT and CREATE through TCP and assigns ownership to the creator" $
withTcpServer defaultServerConfig $ \_ handle -> withConnection handle $ \admin -> do
_ <- tcpLogin admin "admin" "s3cret"
_ <- tcpQuery admin "CREATE USER object_owner IDENTIFIED BY 'Owner-Secret-1234'"
tcpQuery admin "REVOKE CONNECT ON DATABASE test FROM PUBLIC" >>= \reply -> at "status" reply `shouldBe` A.String "result"
withConnection handle $ \client -> do
_ <- tcpLogin client "object_owner" "Owner-Secret-1234"
tcpQuery client "USE test" >>= \reply -> at "code" reply `shouldBe` A.String "forbidden"
_ <- tcpQuery admin "GRANT CONNECT, CREATE ON DATABASE test TO object_owner"
withConnection handle $ \client -> do
_ <- tcpLogin client "object_owner" "Owner-Secret-1234"
tcpQuery client "USE test" >>= \reply -> at "status" reply `shouldBe` A.String "result"
tcpQuery client "CREATE TABLE owned_probe (id INT)" >>= \reply -> at "status" reply `shouldBe` A.String "result"
tcpQuery client "INSERT INTO owned_probe (id) VALUES (1)" >>= \reply -> at "status" reply `shouldBe` A.String "result"
tcpQuery client "SELECT * FROM users" >>= \reply -> at "code" reply `shouldBe` A.String "forbidden"
tcpTalk client "{\"method\":\"storage\",\"request\":{\"method\":\"scan\",\"database\":\"test\",\"table\":\"users\"}}" >>= \reply -> at "code" reply `shouldBe` A.String "forbidden"
it "disconnects downstream TCP grantees and protects staged commits after revocation" $
withTcpServer defaultServerConfig $ \_ handle -> withConnection handle $ \admin -> do
_ <- tcpLogin admin "admin" "s3cret"
_ <- tcpQuery admin "USE test"
_ <- tcpQuery admin "CREATE USER source_user IDENTIFIED BY 'Source-Secret-1234'"
_ <- tcpQuery admin "CREATE USER target_user IDENTIFIED BY 'Target-Secret-1234'"
_ <- tcpQuery admin "GRANT SELECT, UPDATE ON users TO source_user WITH GRANT OPTION"
withConnection handle $ \source -> do
_ <- tcpLogin source "source_user" "Source-Secret-1234"
_ <- tcpQuery source "USE test"
_ <- tcpQuery source "GRANT SELECT, UPDATE ON users TO target_user"
withConnection handle $ \target -> do
_ <- tcpLogin target "target_user" "Target-Secret-1234"
_ <- tcpQuery target "USE test"
_ <- tcpQuery target "BEGIN"
_ <- tcpQuery target "UPDATE users SET age = 90 WHERE id = 1"
_ <- tcpQuery admin "REVOKE UPDATE ON users FROM source_user"
tcpQuery target "COMMIT" >>= \reply -> at "code" reply `shouldBe` A.String "unauthorized"
tcpClosed target
reply <- tcpQuery admin "SELECT age FROM users WHERE id = 1"
map items (items (at "rows" reply)) `shouldBe` [[A.Number 21]]
it "rejects a stale local transaction after a granted object is replaced" $ withObjectPrivileges $ \backend service root -> do
runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["all"] "users" "alice" False) `shouldReturn` Right ()
_ <- beAccounts backend (ReqAccountReset "alice" (testPasswordHash "Alice-Secret-1234"))
settings <- tempSettingsPath "object-transaction"
_ <- beAccounts backend (ReqAccountCreate testRootName (testPasswordHash testRootPassword))
_ <- beAccounts backend (ReqIdentityAlter testRootName Nothing (Just True) Nothing Nothing Nothing)
session <- newSession backend testRootName settings
authenticateSessionCoded session "alice" "Alice-Secret-1234" `shouldReturn` Right ()
_ <- mustSql session "USE test"
_ <- mustSql session "BEGIN"
_ <- mustSql session "UPDATE users SET age = 90 WHERE id = 1"
mustRun (beStatement backend "DROP TABLE users")
mustRun (beStatement backend "CREATE TABLE users (id INT, name VARCHAR(32), age INT)")
result <- runStatementCoded session "COMMIT"
case result of Left err -> sessCode err `shouldBe` "forbidden"; Right _ -> expectationFailure "stale transaction committed"
it "checks the current administrator identity before executing a raw storage request" $ withObjectPrivileges $ \backend _ _ -> do
_ <- beAccounts backend (ReqAccountCreate testRootName (testPasswordHash testRootPassword))
_ <- beAccounts backend (ReqIdentityAlter testRootName Nothing (Just True) Nothing Nothing Nothing)
_ <- beAccounts backend (ReqAccountCreate "spare_admin" "hash")
_ <- beAccounts backend (ReqIdentityAlter "spare_admin" Nothing (Just True) Nothing Nothing Nothing)
executed <- newIORef False
let guarded = backend{beStorage = \_ -> writeIORef executed True >> pure (Right A.Null)}
settings <- tempSettingsPath "raw-storage-identity"
session <- newSession guarded testRootName settings
authenticateSessionCoded session testRootName testRootPassword `shouldReturn` Right ()
changed <- beAccounts backend (ReqIdentityAlter testRootName Nothing (Just False) Nothing Nothing Nothing)
either expectationFailure (const (pure ())) changed
result <- runStorageCoded session (A.object ["method" A..= ("ping" :: Text)])
case result of Left err -> sessCode err `shouldBe` "unauthorized"; Right _ -> expectationFailure "stale administrator executed storage request"
readIORef executed `shouldReturn` False
-- 为权限测试创建真实对象和登录身份。
seedPrivilegeObjects :: Backend -> IO ()
seedPrivilegeObjects backend = do
mustRun (beStatement backend "CREATE DATABASE test")
mustRun (beStatement (beWithDatabase backend "test") "CREATE TABLE users (id INT)")
result <- beAccounts backend (ReqAccountCreate "alice" "hash")
case result of Left err -> expectationFailure err; Right _ -> pure ()
-- | 本次用例的数据目录(用例串行跑,固定名够用)
ipcDataDir :: IO FilePath
@@ -1058,6 +1418,27 @@ intValues rows = [n | row <- rows, Just (VInt n) <- [nth 0 row]]
-- | 显式事务用例
transactionSpec :: Spec
transactionSpec = describe "server transactions" $ do
it "preserves concurrent changes in a large untouched table" $ withTwoSessions $ \first second -> do
_ <- mustSql first "CREATE TABLE untouched (id INT, value INT)"
let values = T.intercalate "," [T.pack ("(" ++ show key ++ ",0)") | key <- [1 .. 5000 :: Int]]
_ <- mustSql first ("INSERT INTO untouched (id,value) VALUES " <> values)
_ <- mustSql first "BEGIN"
_ <- mustSql first "UPDATE users SET age = 77 WHERE id = 1"
_ <- mustSql second "UPDATE untouched SET value = 9 WHERE id = 5000"
_ <- mustSql first "COMMIT"
sessionAge first 1 `shouldReturn` Just 77
result <- mustSql first "SELECT value FROM untouched WHERE id = 5000"
qrRows result `shouldBe` [[VInt 9]]
it "preserves staged row order for unsorted integer ids" $ withMemorySession $ \session -> do
_ <- mustSql session "CREATE TABLE keys (id INT, value INT)"
_ <- mustSql session "INSERT INTO keys (id,value) VALUES (7,0),(-3,0),(4,0)"
_ <- mustSql session "BEGIN"
_ <- mustSql session "UPDATE keys SET value = 1"
_ <- mustSql session "COMMIT"
result <- mustSql session "SELECT id FROM keys"
qrRows result `shouldBe` [[VInt 7], [VInt (-3)], [VInt 4]]
it "filters qualified memory tables and preserves other databases on writes" $ do
let local = Table "users" [("id", TInt)] [[("id", VInt 1)]] Nothing
otherTable = Table "users" [("id", TInt)] [[("id", VInt 2)]] Nothing
@@ -1504,3 +1885,46 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
intColumn "id" rows `shouldBe` [1]
intColumn "age" rows `shouldBe` [31]
-- 判断明确错误返回。
isLeftResult :: Either a b -> Bool
isLeftResult (Left _) = True
isLeftResult _ = False
-- 启动带独立本机认证凭据的测试会话。
withTestSudo :: (ServerEnv -> ServerHandle -> SudoCredential -> IO a) -> IO a
withTestSudo body = withTcpServer defaultServerConfig $ \env handle -> do
credential <- newSudoCredential
withConnection handle $ \admin -> do
_ <- tcpLogin admin testRootName testRootPassword
created <- tcpQuery admin "create user local_user identified by 'Local-Pass123!'"
at "status" created `shouldBe` A.String "result"
enabled <- tcpQuery admin "alter user local_user allow_sudo_auth"
at "status" enabled `shouldBe` A.String "result"
modifyMVar_ (srvSudo env) (const (pure (Just (0, "local_user", credential))))
body env handle credential `finally` modifyMVar_ (srvSudo env) (const (pure Nothing))
-- 交换本机挑战并提交账号绑定证明。
tcpSudo :: Handle -> SudoCredential -> Text -> IO A.Value
tcpSudo client credential user = do
challenge <- tcpTalk client "{\"method\":\"sudo_challenge\"}"
tcpSudoProof client user (sudoProof credential (asText (at "challenge" challenge)) user)
-- 发送本机认证证明。
tcpSudoProof :: Handle -> Text -> Text -> IO A.Value
tcpSudoProof client user proof = tcpTalk client (BL.toStrict (A.encode (A.object
["method" A..= ("sudo_login" :: Text), "user" A..= user, "proof" A..= proof])))
-- 验证身份禁用或取消登录后拒绝本机认证。
checkSudoDisabled :: Handle -> ServerHandle -> SudoCredential -> Text -> IO ()
checkSudoDisabled admin handle credential sql = do
changed <- tcpQuery admin sql
at "status" changed `shouldBe` A.String "result"
withConnection handle $ \client -> do
denied <- tcpSudo client credential "local_user"
at "code" denied `shouldBe` A.String "unauthorized"
-- 判断明确成功返回。
isRightResult :: Either a b -> Bool
isRightResult (Right _) = True
isRightResult _ = False
+1
View File
@@ -20,6 +20,7 @@ library
, aeson
, bytestring
, chusql-core-model
, chusql-core-engine
, chusql-interface
, containers
, directory
+304 -17
View File
@@ -21,7 +21,9 @@ module ChuSQL.Web.API (
) where
import ChuSQL.Core.Model (Row, Value (..))
import ChuSQL.Core.Protocol (Account (..), QueryResult (..), SchemaColumn (..), TableInfo (..))
import ChuSQL.Core.Engine.Syntax.AST (Statement (BeginTransaction, CommitTransaction, RollbackTransaction))
import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
import ChuSQL.Core.Protocol (Account (..), QueryResult (..), SchemaColumn (..), TableInfo (..), valueToJSON)
import ChuSQL.Interface.AccountTable (accountColumns, accountTableName, isAccountTable, passwordColumn, systemTableInfo)
import ChuSQL.Interface.Actions (
ColumnSpec (..),
@@ -108,16 +110,19 @@ import ChuSQL.Web.UISettings (
writeUISettings,
)
import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, withMVar)
import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (IOException, try)
import Control.Monad (forever, when)
import Data.Aeson (FromJSON (..), eitherDecode, object, withObject, (.:), (.=))
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
import Data.List (nub, sortBy)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Maybe (catMaybes, fromMaybe)
import Data.Scientific (fromFloatDigits)
import Data.Text (Text)
@@ -176,6 +181,7 @@ data AppEnv = AppEnv
, aeUISettingsFile :: FilePath
, aeEffective :: Map.Map Text Text
, aeLog :: Text -> IO ()
, aeReaperStarted :: IORef Bool
}
-- | 一条网页会话:TCP 连接、登录状态与账号名
@@ -184,6 +190,12 @@ data WebSession = WebSession
, wsSession :: Session
, wsUser :: Text
, wsAdmin :: Bool
, wsEditor :: Session
, wsEditorClient :: Client
, wsEdit :: IORef (Maybe (Text, Text))
, wsEditReceipt :: IORef (Maybe (Text, A.Value, A.Value))
, wsEditEnded :: IORef (Set.Set Text)
, wsConsole :: IORef (Maybe (Text, Text))
}
-- | 会话 Cookie 名
@@ -201,6 +213,7 @@ newAppEnvAt :: FilePath -> Text -> Int -> RateLimiter -> FilePath -> IO AppEnv
newAppEnvAt settingsFile host port limiter staticDir = do
sessions <- newPayloadStore getCurrentTime defaultSessionPolicy
liveRef <- newIORef defaultLive
reaperStarted <- newIORef False
uiSettingsFile <- resolveUISettingsFileSafe
pure
AppEnv
@@ -215,6 +228,7 @@ newAppEnvAt settingsFile host port limiter staticDir = do
, aeUISettingsFile = uiSettingsFile
, aeEffective = Map.empty
, aeLog = const (pure ())
, aeReaperStarted = reaperStarted
}
-- | 系统库:账号表住在这里,只有管理员能进
@@ -256,6 +270,12 @@ liveBodyLimit env = lvBodyLimit <$> readLive env
-- | 组装 WAI 应用:路由外套四层中间件
webApp :: AppEnv -> IO Application
webApp env = do
started <- atomicModifyIORef' (aeReaperStarted env) (\old -> (True, old))
when (not started) $ do
_ <- forkIO $ forever $ do
threadDelay 60000000
sweepWebSessions env
pure ()
inner <- scottyApp (routes env)
locks <- newMVar Map.empty
pure (securityHeaders (sameOriginOnly (bodyLimitDynamic (liveBodyLimit env) (serializeSessions locks inner))))
@@ -318,6 +338,10 @@ routes env = do
post "/api/roles/:name/members" (withDatabase env addRoleMemberH)
delete "/api/roles/:name/members/:user" (withDatabase env removeRoleMemberH)
post "/api/query" (withDatabase env queryH)
post "/api/query/rollback" (rollbackConsoleH env)
post "/api/edit/begin" (beginEditH env)
post "/api/edit/commit" (commitEditH env)
post "/api/edit/rollback" (rollbackEditH env)
notFound (notFoundH env)
-- | 先认会话,再按请求头切本会话的库
@@ -331,7 +355,18 @@ withDatabase env action = do
if chosen == systemDatabase && not (wsAdmin ws)
then reply403 "the system database is only available to the administrator"
else do
ready <- liftIO (if T.null chosen then pure (Right ()) else switchDatabase (wsSession ws) chosen)
editing <- header "X-ChuSQL-Edit"
req <- request
let snapshotRead = editing /= Nothing && requestMethod req == "GET" && take 2 (pathInfo req) == ["api", "tables"]
console <- liftIO (readIORef (wsConsole ws))
caller <- consoleOwner
case console of
Just (owner, database) | not snapshotRead &&
(pathInfo req /= ["api", "query"] || caller /= owner || (not (T.null chosen) && chosen /= database)) ->
apiError "conflict" "another SQL console owns this connection transaction; commit or rollback there first"
_ -> pure ()
current <- liftIO (sessionDatabase (wsSession ws))
ready <- liftIO (if T.null chosen || chosen == current || snapshotRead then pure (Right ()) else switchDatabase (wsSession ws) chosen)
case ready of
Left message -> serverError message
Right () -> action env
@@ -347,11 +382,31 @@ requireDatabaseName ws = do
-- | 取本请求的会话,没有令牌就 401
requireSession :: AppEnv -> ActionM WebSession
requireSession env = do
liftIO (sweepWebSessions env)
token <- requestSessionToken >>= maybe (apiError "unauthorized" "sign in first") pure
found <- liftIO (lookupPayload (aeSessions env) token)
case found of
Nothing -> apiError "unauthorized" "sign in first"
Just (_, ws) -> pure ws
Just (_, ws) -> do
editHeader <- fmap TL.toStrict <$> header "X-ChuSQL-Edit"
req <- request
case editHeader of
Just editId | requestMethod req == "GET" && take 2 (pathInfo req) == ["api", "tables"] -> do
active <- liftIO (readIORef (wsEdit ws))
database <- maybe "" (T.toLower . TL.toStrict) <$> header "X-ChuSQL-Database"
case active of
Just (owner, name) | owner == editId && name == database ->
pure ws {wsSession = wsEditor ws, wsClient = wsEditorClient ws}
_ -> apiError "conflict" "the editing snapshot is no longer available; rollback and reload"
_ -> pure ws
-- | 关闭网页会话的两个服务端连接。
closeWebSession :: WebSession -> IO ()
closeWebSession ws = endEdit ws >> writeIORef (wsConsole ws) Nothing >> closeClient (wsEditorClient ws) >> closeClient (wsClient ws)
-- | 清理过期会话与未提交快照。
sweepWebSessions :: AppEnv -> IO ()
sweepWebSessions env = sweepPayloads (aeSessions env) >>= mapM_ closeWebSession
-- | 管理员专属操作
requireAdminSession :: AppEnv -> ActionM WebSession
@@ -388,7 +443,7 @@ createDatabaseH env = do
-- | 删除数据库;系统库 system 一律拒绝。
dropDatabaseH :: AppEnv -> ActionM ()
dropDatabaseH env = do
ws <- requireAdminSession env
ws <- requireSession env
name <- pathParam "name"
if reservedDatabase name
then reply400 "bad_request" "the system database cannot be dropped"
@@ -443,8 +498,7 @@ healthH = json (object ["status" .= ("ok" :: Text)])
-- | 探活:回进程与存储状态,顺带清理过期会话
statusH :: AppEnv -> ActionM ()
statusH env = do
expired <- liftIO (sweepPayloads (aeSessions env))
liftIO (mapM_ (closeClient . wsClient) expired)
liftIO (sweepWebSessions env)
opened <- liftIO (connectClient (aeServerHost env) (aeServerPort env))
case opened of
Left message -> json (object ["status" .= ("ok" :: Text), "storage" .= ("down" :: Text), "detail" .= message])
@@ -504,7 +558,21 @@ openSession env user password = do
else serverError message
Right () -> do
admin <- liftIO (sessionIsAdmin session)
token <- liftIO (createPayloadSession (aeSessions env) user (WebSession client session user admin))
openedEditor <- liftIO (connectClient (aeServerHost env) (aeServerPort env))
editorClient <- case openedEditor of
Left message -> liftIO (closeClient client) >> serverError message
Right connected -> pure connected
editor <- liftIO (newSession editorClient)
editorSigned <- liftIO (authenticateSession editor user password)
case editorSigned of
Left message -> liftIO (closeClient editorClient >> closeClient client) >> serverError message
Right () -> pure ()
edit <- liftIO (newIORef Nothing)
receipt <- liftIO (newIORef Nothing)
ended <- liftIO (newIORef Set.empty)
console <- liftIO (newIORef Nothing)
liftIO (sweepWebSessions env)
token <- liftIO (createPayloadSession (aeSessions env) user (WebSession client session user admin editor editorClient edit receipt ended console))
liftIO (rateLimitClear (aeLimiter env) user)
setHeader "Set-Cookie" (TL.fromStrict (sessionCookie env token (Just (lvSessionMax live))))
liftIO (aeLog env ("sign-in ok user=" <> user))
@@ -513,6 +581,7 @@ openSession env user password = do
-- | 退出:收掉会话与连接,清除 Cookie
logoutH :: AppEnv -> ActionM ()
logoutH env = do
liftIO (sweepWebSessions env)
token <- requestSessionToken
case token of
Nothing -> pure ()
@@ -520,7 +589,7 @@ logoutH env = do
gone <- liftIO (dropPayload (aeSessions env) t)
case gone of
Nothing -> pure ()
Just ws -> liftIO (closeClient (wsClient ws))
Just ws -> liftIO (closeWebSession ws)
setHeader "Set-Cookie" (TL.fromStrict (sessionCookie env "" (Just 0)))
status status204
@@ -1036,7 +1105,6 @@ createTableH :: AppEnv -> ActionM ()
createTableH env = do
ws <- requireSession env
_ <- requireDatabaseName ws
adminOnly ws
withJsonObject env $ \o -> case decodeCreateTable o of
Left err -> reply400 "bad_request" err
Right spec -> case createTableSql spec of
@@ -1048,7 +1116,6 @@ dropTableH :: AppEnv -> ActionM ()
dropTableH env = do
ws <- requireSession env
_ <- requireDatabaseName ws
adminOnly ws
name <- pathParam "t"
account <- accountRoute ws name
if account
@@ -1117,7 +1184,6 @@ createIndexH :: AppEnv -> ActionM ()
createIndexH env = do
ws <- requireSession env
_ <- requireDatabaseName ws
adminOnly ws
name <- pathParam "t"
account <- accountRoute ws name
if account
@@ -1137,7 +1203,6 @@ dropIndexH :: AppEnv -> ActionM ()
dropIndexH env = do
ws <- requireSession env
_ <- requireDatabaseName ws
adminOnly ws
name <- pathParam "t"
column <- pathParam "col"
account <- accountRoute ws name
@@ -1156,7 +1221,6 @@ dropColumnH :: AppEnv -> ActionM ()
dropColumnH env = do
ws <- requireSession env
_ <- requireDatabaseName ws
adminOnly ws
name <- pathParam "t"
column <- pathParam "col"
account <- accountRoute ws name
@@ -1233,7 +1297,7 @@ dropRoleH env = do
-- | 给角色加权限
grantRoleH :: AppEnv -> ActionM ()
grantRoleH env = do
ws <- requireAdminSession env
ws <- requireSession env
role <- pathParam "name"
withJsonObject env $ \o -> case grantFields o of
Left err -> reply400 "bad_request" err
@@ -1243,7 +1307,7 @@ grantRoleH env = do
-- | 收角色的权限
revokeRoleH :: AppEnv -> ActionM ()
revokeRoleH env = do
ws <- requireAdminSession env
ws <- requireSession env
role <- pathParam "name"
withJsonObject env $ \o -> case grantFields o of
Left err -> reply400 "bad_request" err
@@ -1418,7 +1482,219 @@ columnTypeText cols name = case [c | c <- cols, scName c == T.unpack name] of
(c : _) -> T.pack (scType c)
[] -> ""
-- | 查询接口:校验请求体后执行 SQL
-- | 校验编辑事务的页面与数据库标识。
editIdentity :: A.Object -> Either Text (Text, Text)
editIdentity o = do
owner <- textField "id" o
database <- textField "database" o
if T.null owner || T.length owner > 128 || not (isPlainIdentifier database)
then Left "invalid edit identity or database"
else Right (owner, T.toLower database)
-- | 开始或确认同一页面的编辑快照。
beginEditH :: AppEnv -> ActionM ()
beginEditH env = do
ws <- requireSession env
withJsonObject env $ \o -> case editIdentity o of
Left message -> reply400 "bad_request" message
Right identity@(owner, database) -> do
when (database == systemDatabase) (apiError "bad_request" "system identities cannot be edited in a data transaction")
active <- liftIO (readIORef (wsEdit ws))
ended <- liftIO (readIORef (wsEditEnded ws))
case active of
Just existing | existing == identity -> json (object ["state" .= ("active" :: Text), "id" .= owner])
Just _ -> apiError "conflict" "another page owns the editing transaction"
Nothing | Set.member owner ended -> apiError "conflict" "this editing transaction has already ended"
Nothing -> do
switched <- liftIO (switchDatabase (wsEditor ws) database)
either serverError pure switched
begun <- liftIO (runStatement (wsEditor ws) "BEGIN")
either serverError (const (pure ())) begun
saved <- liftIO (runStatement (wsEditor ws) "SAVEPOINT web_edit_base")
case saved of
Left message -> do
liftIO (closeClient (wsEditorClient ws))
serverError message
Right _ -> do
liftIO (writeIORef (wsEdit ws) (Just identity))
json (object ["state" .= ("active" :: Text), "id" .= owner])
-- | 确认当前页面仍持有编辑事务。
requireEdit :: WebSession -> (Text, Text) -> ActionM ()
requireEdit ws identity = do
active <- liftIO (readIORef (wsEdit ws))
when (active /= Just identity) (apiError "conflict" "editing transaction is stale; rollback and reload")
-- | 结束事务并禁止旧页面标识重新使用。
endEdit :: WebSession -> IO ()
endEdit ws = do
active <- readIORef (wsEdit ws)
case active of
Nothing -> pure ()
Just (owner, _) -> atomicModifyIORef' (wsEditEnded ws) (\ended -> (Set.insert owner ended, ()))
writeIORef (wsEdit ws) Nothing
-- | 按表结构生成一条编辑语句。
editStatement :: [TableInfo] -> A.Value -> Either Text Text
editStatement infos (A.Object o) = do
name <- textField "table" o
operation <- textField "op" o
when (isAccountTable name) (Left "system identities cannot be edited in a data transaction")
info <- maybe (Left ("table not found: " <> name)) Right (findTable name infos)
sql <- case operation of
"insert" -> do
row <- valuesField o >>= readRowValues False (tiColumns info)
either (Left . T.pack) Right (insertRowSql name row)
"update" -> do
key <- editRowKey o
values <- case KM.lookup "set" o of
Just (A.Object assigns) -> Right assigns
_ -> Left "update requires a set object"
row <- readRowValues False (tiColumns info) values
either (Left . T.pack) Right (updateRowSql name key row)
"delete" -> do
key <- editRowKey o
either (Left . T.pack) Right (deleteRowSql name key)
_ -> Left "unknown edit operation"
pure (T.pack sql)
editStatement _ _ = Left "each change must be an object"
-- | 读取行编辑的整数主键。
editRowKey :: A.Object -> Either Text Int
editRowKey o = case KM.lookup "pk" o of
Just (A.String rawKey) -> maybe (Left "invalid row id") Right (readMaybe (T.unpack rawKey))
Just rawKey -> case A.fromJSON rawKey of
A.Success key -> Right key
A.Error _ -> Left "invalid row id"
Nothing -> Left "missing row id"
-- | 顺序执行编辑集并定位首个错误。
runEditStatements :: Session -> Int -> [Text] -> IO (Either (Int, Text) ())
runEditStatements _ _ [] = pure (Right ())
runEditStatements session index (sql : rest) = do
result <- runStatement session sql
case result of
Left message -> pure (Left (index, message))
Right _ -> runEditStatements session (index + 1) rest
-- | 返回明确的事务失败状态。
editFailure :: Text -> Text -> Maybe Int -> Bool -> ActionM ()
editFailure stateName message index reload = do
let code = errorCodeOf message
status (if code == "unauthorized" then status401 else if reload || code == "serialization_failure" then status409 else statusOf code)
json (object ["ok" .= False, "applied" .= (0 :: Int), "state" .= stateName,
"reloadRequired" .= reload, "error" .= code, "message" .= message,
"errors" .= [object ["index" .= index, "message" .= message]]])
-- | 回退提交失败的暂存语句并保留快照。
resetEditAfterFailure :: WebSession -> Maybe Int -> Text -> ActionM ()
resetEditAfterFailure ws index message = do
reset <- liftIO (runStatement (wsEditor ws) "ROLLBACK TO SAVEPOINT web_edit_base")
case reset of
Right _ -> editFailure "active" message index False
Left resetError -> do
liftIO (endEdit ws >> closeClient (wsEditorClient ws))
editFailure "lost" (message <> "; rollback failed: " <> resetError) index True
-- | 原子提交跨表编辑集并缓存成功回执。
commitEditH :: AppEnv -> ActionM ()
commitEditH env = do
ws <- requireSession env
withJsonObject env $ \o -> case (editIdentity o, KM.lookup "changes" o) of
(Right identity@(owner, _), Just (A.Array entries)) -> do
receipt <- liftIO (readIORef (wsEditReceipt ws))
case receipt of
Just (old, submitted, result) | old == owner && submitted == A.Object o -> json result
Just (old, _, _) | old == owner -> apiError "conflict" "transaction already committed with a different edit set"
_ -> do
requireEdit ws identity
found <- liftIO (catalog (wsEditor ws))
infos <- case found of
Left message -> do
when (errorCodeOf message == "unauthorized") (liftIO (endEdit ws >> closeWebSession ws))
serverError message
Right tables -> pure tables
case mapM (editStatement infos) (V.toList entries) of
Left message -> editFailure "active" ("bad_request: " <> message) Nothing False
Right statements -> do
reset <- liftIO (runStatement (wsEditor ws) "ROLLBACK TO SAVEPOINT web_edit_base")
case reset of
Left message -> do
liftIO (endEdit ws >> closeClient (wsEditorClient ws))
editFailure "lost" message Nothing True
finish
Right _ -> pure ()
staged <- liftIO (runEditStatements (wsEditor ws) 0 statements)
case staged of
Left (index, message) -> resetEditAfterFailure ws (Just index) message
Right () -> do
committed <- liftIO (runStatement (wsEditor ws) "COMMIT")
case committed of
Right _ -> do
let result = object ["ok" .= True, "applied" .= V.length entries, "state" .= ("committed" :: Text)]
liftIO (endEdit ws >> writeIORef (wsEditReceipt ws) (Just (owner, A.Object o, result)))
json result
Left message | errorCodeOf message == "serialization_failure" -> do
rolledBack <- liftIO (runStatement (wsEditor ws) "ROLLBACK")
liftIO (endEdit ws)
case rolledBack of
Right _ -> editFailure "rolled_back" message Nothing True
Left err -> do
liftIO (closeClient (wsEditorClient ws))
editFailure "lost" (message <> "; rollback failed: " <> err) Nothing True
Left message | errorCodeOf message `elem` ["query_error", "bad_request", "forbidden"] -> resetEditAfterFailure ws Nothing message
Left message -> do
liftIO (endEdit ws >> closeClient (wsEditorClient ws))
editFailure "lost" (message <> "; commit outcome requires reload") Nothing True
_ -> reply400 "bad_request" "expected edit identity and a changes array"
-- | 撤销页面持有的编辑事务。
rollbackEditH :: AppEnv -> ActionM ()
rollbackEditH env = do
ws <- requireSession env
withJsonObject env $ \o -> case editIdentity o of
Left message -> reply400 "bad_request" message
Right identity -> do
active <- liftIO (readIORef (wsEdit ws))
case active of
Nothing -> do
receipt <- liftIO (readIORef (wsEditReceipt ws))
let stateName = case receipt of
Just (owner, _, _) | owner == fst identity -> "committed" :: Text
_ -> "rolled_back"
json (object ["state" .= stateName])
Just _ -> do
requireEdit ws identity
result <- liftIO (runStatement (wsEditor ws) "ROLLBACK")
liftIO (endEdit ws)
case result of
Left message -> liftIO (closeClient (wsEditorClient ws)) >> serverError message
Right _ -> json (object ["state" .= ("rolled_back" :: Text)])
-- | 读取 SQL 控制台的请求所有者。
consoleOwner :: ActionM Text
consoleOwner = do
owner <- maybe "legacy" TL.toStrict <$> header "X-ChuSQL-Console"
if T.null owner || T.length owner > 128 then apiError "bad_request" "invalid console identity" else pure owner
-- | 回滚关闭页面或标签的控制台事务。
rollbackConsoleH :: AppEnv -> ActionM ()
rollbackConsoleH env = do
ws <- requireSession env
withJsonObject env $ \o -> case textField "console" o of
Left message -> reply400 "bad_request" message
Right owner -> do
active <- liftIO (readIORef (wsConsole ws))
case active of
Nothing -> status status204
Just (existing, _) | existing /= owner -> apiError "conflict" "another console owns this transaction"
Just _ -> do
result <- liftIO (runStatement (wsSession ws) "ROLLBACK")
case result of
Left message -> serverError message
Right _ -> liftIO (writeIORef (wsConsole ws) Nothing) >> status status204
-- | 查询接口:校验请求体后执行 SQL。
queryH :: AppEnv -> ActionM ()
queryH env = do
ws <- requireSession env
@@ -1447,6 +1723,15 @@ executeSql ws live sql = do
case result of
Left message -> serverError message
Right res -> do
owner <- consoleOwner
case parseStatement (T.unpack sql) of
Right BeginTransaction -> do
database <- liftIO (sessionDatabase (wsSession ws))
liftIO (writeIORef (wsConsole ws) (Just (owner, database)))
Right CommitTransaction -> liftIO (writeIORef (wsConsole ws) Nothing)
Right RollbackTransaction -> liftIO (writeIORef (wsConsole ws) Nothing)
_ -> pure ()
transaction <- liftIO (readIORef (wsConsole ws))
let shown = take (lvMaxRows live) (qrRows res)
json
( object
@@ -1455,6 +1740,7 @@ executeSql ws live sql = do
, "rowCount" .= qrRowCount res
, "truncated" .= (qrTruncated res || qrRowCount res > lvMaxRows live)
, "database" .= qrDatabase res
, "transaction" .= (transaction /= Nothing)
]
)
@@ -1516,6 +1802,7 @@ valueJson (VInt n) = A.Number (fromIntegral n)
valueJson (VFloat d) = A.Number (fromFloatDigits d)
valueJson (VStr s) = A.String (T.pack s)
valueJson (VBool b) = A.Bool b
valueJson value@VRuntime{} = valueToJSON value
-- | 一张表的线上信息:列、行数、索引与统计
tableInfoJson :: TableInfo -> A.Value
+58 -13
View File
@@ -2,6 +2,9 @@
// 请求都带 X-ChuSQL-Database 头;401 时广播登录事件。
export const AUTH_EVENT = 'chusql-auth-required';
let editing = null;
let consoleTransaction = null;
const pageOwner = [...crypto.getRandomValues(new Uint8Array(16))].map((byte) => byte.toString(16).padStart(2, '0')).join('');
// 是否是普通对象。
function isObject(value) {
@@ -12,6 +15,9 @@ function isObject(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);
if (editing && editing.database === database && url.startsWith('/api/tables') && (!init || init.method === 'GET')) {
headers.set('X-ChuSQL-Edit', editing.id);
}
let response;
try {
response = await fetch(url, { credentials: 'same-origin', ...(init ?? {}), headers });
@@ -31,7 +37,10 @@ async function request(url, init, database) {
const message = isObject(body) && typeof body.message === 'string'
? body.message
: `请求失败(HTTP ${response.status})。`;
throw new Error(message);
const error = new Error(message);
error.result = body;
error.code = body?.error;
throw error;
}
return body;
}
@@ -215,33 +224,68 @@ export async function deleteRow(database, table, id) {
await request(`/api/tables/${encodeURIComponent(table)}/rows/${encodeURIComponent(id)}`, jsonInit('DELETE'), database);
}
// 逐条提交,遇到第一条失败就停,返回已经成功了几条。
export async function commitChanges(database, changes) {
let applied = 0;
for (const [index, change] of changes.entries()) {
// 为页面开启固定数据库的编辑快照。
export async function beginEdit(id, database) {
await request('/api/edit/begin', jsonInit('POST', { id, database }));
editing = { id, database };
}
// 在服务端事务中原子提交编辑集。
export async function commitChanges(id, database, changes) {
try {
if (change.op === 'insert') await insertRow(database, change.table, change.values);
else if (change.op === 'delete') await deleteRow(database, change.table, change.pk);
else await updateRow(database, change.table, change.pk, change.set);
applied += 1;
const result = await request('/api/edit/commit', jsonInit('POST', { id, database, changes }));
if (!isObject(result) || result.ok !== true || result.state !== 'committed') throw new Error('服务器未返回可确认的提交结果。');
editing = null;
return result;
} catch (error) {
return { ok: false, applied, errors: [{ index, message: error instanceof Error ? error.message : String(error) }] };
if (isObject(error.result) && typeof error.result.state === 'string') return error.result;
return { ok: false, applied: 0, state: error.result ? 'lost' : 'unknown',
reloadRequired: Boolean(error.result), message: error.message };
}
}
// 回滚编辑快照并清除本地事务标识。
export async function rollbackEdit(id, database) {
const result = await request('/api/edit/rollback', jsonInit('POST', { id, database }));
editing = null;
return result;
}
// 忘记已失效的登录会话编辑标识。
export function forgetEdit() {
editing = null;
consoleTransaction = null;
}
// 标签关闭时回滚它持有的控制台事务。
export async function rollbackConsole(tabId) {
if (!consoleTransaction || consoleTransaction.console !== `${pageOwner}:${tabId ?? 'default'}`) return;
await request('/api/query/rollback', jsonInit('POST', { console: consoleTransaction.console }));
consoleTransaction = null;
}
// 页面离开时请求清理控制台事务。
export function closeConsoleOnPagehide() {
if (consoleTransaction) {
navigator.sendBeacon('/api/query/rollback', new Blob([JSON.stringify({ console: consoleTransaction.console })], { type: 'application/json' }));
}
return { ok: true, applied };
}
// ---------------------------------------------------------------- 查询
// 执行 SQL 并规整结果。
export async function query(sql, database) {
export async function query(sql, database, tabId) {
const started = performance.now();
try {
const body = await request('/api/query', jsonInit('POST', { sql }), database);
const console = `${pageOwner}:${tabId ?? 'default'}`;
const init = jsonInit('POST', { sql });
init.headers['X-ChuSQL-Console'] = console;
const body = await request('/api/query', init, database);
if (!isObject(body) || !Array.isArray(body.columns) || !Array.isArray(body.rows)) {
throw new Error('服务器返回的查询结果无法识别。');
}
const durationMs = performance.now() - started;
consoleTransaction = body.transaction === true ? { console, database } : null;
return {
type: body.columns.length ? 'rows' : 'affected',
columns: body.columns,
@@ -249,6 +293,7 @@ export async function query(sql, database) {
affected: typeof body.rowCount === 'number' ? body.rowCount : 0,
truncated: body.truncated === true,
database: typeof body.database === 'string' ? body.database : undefined,
transactionActive: body.transaction === true,
durationMs,
};
} catch (error) {
+181 -36
View File
@@ -46,6 +46,12 @@ const state = {
tabs: [],
activeId: undefined,
changes: createEmptyChangeSet(),
edit: null,
editStarting: null,
editAttempt: null,
editBusy: false,
editNeedsReload: false,
editUncertain: null,
insertSeq: 0,
messages: [],
tabSeq: 0,
@@ -301,8 +307,8 @@ function renderSidebar() {
<section class="side-section">
<div class="side-title">变更</div>
<div class="side-row">
<button data-action="commit"${count ? '' : ' disabled'}>提交 ${count}</button>
<button data-action="rollback"${count ? '' : ' disabled'}>撤销</button>
<button data-action="commit"${count && !state.editBusy && !state.editNeedsReload ? '' : ' disabled'}>提交 ${count}</button>
<button data-action="rollback"${(state.edit || state.editAttempt) && !state.editBusy ? '' : ' disabled'}>撤销</button>
</div>
</section>`;
}
@@ -364,7 +370,9 @@ function renderTableTab(el, tab) {
}
const columns = data.columns;
const keyColumn = columns.find((column) => column.name === 'id');
const editable = Boolean(keyColumn);
const editable = Boolean(keyColumn) && tab.table !== accountsTable && Boolean(state.edit)
&& data.editId === state.edit.id && !data.loading
&& !state.editBusy && !state.editNeedsReload && !state.editUncertain;
const filters = data.filters ?? {};
const count = changeCount(state.changes);
@@ -413,8 +421,8 @@ function renderTableTab(el, tab) {
<button data-action="insert-row"${editable ? '' : ' disabled'}>+ 新增行</button>
<button data-action="delete-selected"${editable && (tab.selected?.size ?? 0) ? '' : ' disabled'}>删除选中</button>
<span class="sep"></span>
<button class="primary" data-action="commit"${count ? '' : ' disabled'}>提交 (${count})</button>
<button data-action="rollback"${count ? '' : ' disabled'}>撤销</button>
<button class="primary" data-action="commit"${count && !state.editBusy && !state.editNeedsReload ? '' : ' disabled'}>提交 (${count})</button>
<button data-action="rollback"${(state.edit || state.editAttempt) && !state.editBusy ? '' : ' disabled'}>撤销</button>
<span class="sep"></span>
<button data-action="reload-table">刷新</button>
<span class="flex-spacer"></span>
@@ -438,7 +446,7 @@ function renderTableTab(el, tab) {
${data.rows.length || stagedInserts.length ? '' : '<p class="empty">这张表没有数据。</p>'}
</div>
${data.loading ? '<div class="grid-loading">加载中…</div>' : ''}
${editable ? '' : '<p class="notice">这张表没有 id 列,只能浏览。</p>'}
${editable ? '' : '<p class="notice">当前表或事务状态仅允许浏览;系统身份请通过 SQL 管理。</p>'}
</div>`;
}
@@ -650,8 +658,8 @@ function renderBottom() {
<button class="${state.bottomTab === 'changes' ? 'active' : ''}" data-action="bottom-tab" data-tab="changes">待提交变更 (${count})</button>
<button class="${state.bottomTab === 'messages' ? 'active' : ''}" data-action="bottom-tab" data-tab="messages">消息 (${state.messages.length})</button>
<span class="flex-spacer"></span>
<button data-action="commit"${count ? '' : ' disabled'}>提交全部</button>
<button data-action="rollback"${count ? '' : ' disabled'}>撤销全部</button>
<button data-action="commit"${count && !state.editBusy && !state.editNeedsReload ? '' : ' disabled'}>提交全部</button>
<button data-action="rollback"${(state.edit || state.editAttempt) && !state.editBusy ? '' : ' disabled'}>撤销全部</button>
<button data-action="copy-sql"${count ? '' : ' disabled'}>复制 SQL</button>
</div>
<div class="bottom-body">${state.bottomTab === 'changes' ? changeList : messages}</div>`;
@@ -694,19 +702,36 @@ async function loadWorkspace() {
// 切换当前数据库。
async function switchDatabase(name) {
if (state.editBusy || state.editStarting) return;
if (name === state.database) return;
if (changeCount(state.changes) > 0) {
log('warn', '请先提交或撤销当前库的修改,再切换数据库。');
renderSidebar();
return;
}
const previousEdit = state.edit ?? state.editAttempt;
state.editBusy = true;
afterChange();
try {
if (previousEdit) await api.rollbackEdit(previousEdit.id, previousEdit.database);
} catch (error) {
state.editBusy = false;
fail(error);
afterChange();
return;
}
state.edit = null;
state.editAttempt = null;
const result = await api.query(`USE ${name}`, state.database);
state.editBusy = false;
if (result.type === 'error') {
fail(new Error(result.message));
renderSidebar();
return;
}
state.database = result.database ?? name;
state.tabs = state.tabs.filter((entry) => entry.kind !== 'table');
state.activeId = state.tabs[0]?.id;
log('info', `已切换到数据库 ${state.database}`);
await loadWorkspace();
renderEditor();
@@ -732,10 +757,12 @@ async function openTable(database, name) {
// 加载表标签的一页数据。
async function loadTableData(tab) {
if (state.editBusy || state.editNeedsReload || state.editUncertain) return;
const data = tab.data;
data.loading = true;
renderEditor();
try {
if (tab.table !== accountsTable) await ensureEdit(tab.database);
const meta = await api.getTable(tab.database, tab.table);
const filters = Object.entries(data.filters ?? {})
.filter(([, expression]) => String(expression).trim().length > 0)
@@ -756,6 +783,7 @@ async function loadTableData(tab) {
data.offset = offset;
data.pageSize = pageSize;
data.error = null;
data.editId = state.edit?.id;
// 服务端做等值过滤,界面上的 like / 比较表达式再在本地收敛一次
data.rows = filters.length
? page.rows.filter((row) => filters.every((filter) => matchesFilter(row[filter.column], filter.expression)))
@@ -770,6 +798,28 @@ async function loadTableData(tab) {
}
}
// 在首个数据表加载时固定编辑快照。
async function ensureEdit(database) {
if (database !== state.database) throw new Error('请切换到表所属数据库后重新打开。');
if (state.edit) {
if (state.edit.database !== database) throw new Error('请先撤销当前数据库的编辑事务。');
return;
}
if (!state.editStarting) {
const edit = state.editAttempt ?? { id: [...crypto.getRandomValues(new Uint8Array(16))].map((byte) => byte.toString(16).padStart(2, '0')).join(''), database };
if (edit.database !== database) throw new Error('请先撤销之前的编辑快照,再切换数据库。');
state.editAttempt = edit;
const session = state.session;
state.editStarting = api.beginEdit(edit.id, database).then(() => {
if (state.session !== session) throw new Error('登录会话已更换,请重新加载。');
state.edit = edit;
state.editAttempt = null;
})
.finally(() => { state.editStarting = null; });
}
await state.editStarting;
}
// 重新加载所有表标签。
async function reloadOpenTables() {
for (const tab of state.tabs) {
@@ -790,6 +840,7 @@ function unstageRow(table, pk) {
// 暂存单元格修改。
function stageUpdate(table, database, pk, column, oldValue, newValue) {
if (!canEdit(database)) return;
if (oldValue === newValue) state.changes.updates.delete(changeKey(table, pk, column));
else state.changes.updates.set(changeKey(table, pk, column), { table, database, pk, column, oldValue, newValue });
afterChange();
@@ -797,6 +848,7 @@ function stageUpdate(table, database, pk, column, oldValue, newValue) {
// 暂存新增行。
function stageInsert(table, database, values) {
if (!canEdit(database)) return;
state.insertSeq += 1;
const tempId = `new-${state.insertSeq}`;
state.changes.inserts.set(insertKey(table, tempId), { table, database, tempId, values });
@@ -805,6 +857,7 @@ function stageInsert(table, database, values) {
// 暂存删除行。
function stageDelete(table, database, pk, row) {
if (!canEdit(database)) return;
unstageRow(table, pk);
state.changes.deletes.set(deleteKey(table, pk), { table, database, pk, row });
afterChange();
@@ -819,6 +872,7 @@ function afterChange() {
// 撤下一条暂存变更。
function removeStaged(key) {
if (!canEdit(state.database)) return;
if (state.changes.updates.has(key)) state.changes.updates.delete(key);
else if (state.changes.inserts.has(key)) state.changes.inserts.delete(key);
else if (state.changes.deletes.has(key)) state.changes.deletes.delete(key);
@@ -826,48 +880,70 @@ function removeStaged(key) {
}
// 撤销全部暂存变更。
function rollbackAll() {
async function rollbackAll() {
if (state.editBusy || state.editStarting) return;
state.editBusy = true;
afterChange();
try {
const edit = state.edit ?? state.editAttempt;
const result = edit ? await api.rollbackEdit(edit.id, edit.database) : null;
state.edit = null;
state.editAttempt = null;
state.editNeedsReload = false;
state.editUncertain = null;
state.changes = createEmptyChangeSet();
for (const tab of state.tabs) if (tab.selected) tab.selected.clear();
log('info', '已撤销全部待提交变更。');
log('info', result?.state === 'committed' ? '先前提交已成功,现重新加载数据。' : '已回滚编辑事务,重新加载数据。');
state.editBusy = false;
await loadWorkspace();
await reloadOpenTables();
} catch (error) {
state.editNeedsReload = true;
fail(error);
} finally {
state.editBusy = false;
afterChange();
}
}
// 检查编辑事务与页面操作状态。
function canEdit(database) {
return Boolean(state.edit) && state.edit.database === database && !state.editBusy
&& !state.editNeedsReload && !state.editUncertain;
}
// 提交全部暂存变更。
async function commitAll() {
const payload = toCommitPayload(state.changes);
if (state.editBusy || state.editStarting) return;
if (state.editNeedsReload || !state.edit) {
fail(new Error('编辑快照已失效,请撤销并重新加载后编辑。'));
return;
}
const payload = state.editUncertain ?? toCommitPayload(state.changes);
if (!payload.length) {
log('info', '没有待提交的变更。');
return;
}
const database = state.database;
const result = await api.commitChanges(database, payload);
state.editBusy = true;
afterChange();
const edit = state.edit;
const result = await api.commitChanges(edit.id, edit.database, payload);
if (state.edit !== edit) { state.editBusy = false; return; }
if (result.ok) {
state.edit = null;
state.editUncertain = null;
state.changes = createEmptyChangeSet();
for (const tab of state.tabs) if (tab.selected) tab.selected.clear();
log('info', `已提交 ${result.applied} 条变更。`);
setStatus(`已提交 ${result.applied} 条变更`);
} else {
const failed = result.errors?.[0];
// 成功的部分不再保留,失败的那条留在面板上等修正
state.changes = createEmptyChangeSet();
payload.slice(result.applied).forEach((change) => {
if (change.op === 'insert') {
state.insertSeq += 1;
const tempId = `new-${state.insertSeq}`;
state.changes.inserts.set(insertKey(change.table, tempId), { table: change.table, database, tempId, values: change.values });
} else if (change.op === 'delete') {
state.changes.deletes.set(deleteKey(change.table, change.pk), { table: change.table, database, pk: change.pk, row: {} });
} else {
for (const [column, value] of Object.entries(change.set)) {
state.changes.updates.set(changeKey(change.table, change.pk, column), {
table: change.table, database, pk: change.pk, column, oldValue: undefined, newValue: value,
});
}
}
});
log('error', `提交在第 ${(failed?.index ?? 0) + 1} 条失败:${failed?.message ?? '未知错误'}(已成功 ${result.applied} 条)`);
state.editNeedsReload = result.reloadRequired === true;
state.editUncertain = result.state === 'unknown' ? payload : null;
log('error', `${result.message ?? '提交失败'}(事务状态:${result.state})。${state.editNeedsReload
? result.state === 'lost' ? '连接已失效,请重新登录,确认数据后重新编辑。' : '请撤销并重新加载,禁止覆盖其他会话修改。' : state.editUncertain
? '结果尚未确认,编辑已冻结;再次提交仅查询同一提交结果。' : '全部修改已回退,编辑内容保留,可修正后重试。'}`);
}
state.editBusy = false;
await loadWorkspace();
await reloadOpenTables();
afterChange();
@@ -877,10 +953,31 @@ async function commitAll() {
// 运行 SQL 并展示结果。
async function runSql(tab) {
if (state.editBusy || state.editStarting || state.editUncertain || state.editNeedsReload) return;
if (changeCount(state.changes)) {
log('warn', '请先提交或撤销表格修改,再运行 SQL。');
return;
}
const sql = String(tab.sql ?? '').trim();
if (!sql) return;
state.editBusy = true;
afterChange();
const previousEdit = state.edit ?? state.editAttempt;
if (previousEdit) {
try {
await api.rollbackEdit(previousEdit.id, previousEdit.database);
state.edit = null;
state.editAttempt = null;
} catch (error) {
state.editBusy = false;
fail(error);
afterChange();
return;
}
}
setStatus('执行中…');
const result = await api.query(sql, tab.database);
const result = await api.query(sql, tab.database, tab.id);
state.editBusy = false;
tab.result = result;
if (result.type === 'error') {
log('error', result.message ?? '执行失败');
@@ -888,6 +985,7 @@ async function runSql(tab) {
} else {
if (result.database && result.database !== state.database) {
state.database = result.database;
state.tabs = state.tabs.filter((entry) => entry.kind !== 'table');
tab.database = result.database;
await loadWorkspace();
}
@@ -897,10 +995,12 @@ async function runSql(tab) {
} else {
log('info', `语句影响 ${result.affected ?? 0} 行`);
setStatus(`影响 ${result.affected ?? 0} 行`);
if (!result.transactionActive) {
await loadWorkspace();
await reloadOpenTables();
}
}
}
renderEditor();
}
@@ -912,15 +1012,22 @@ function activateTab(id) {
const tab = activeTab();
if (tab?.kind === 'sql') tab.database = state.database;
if (tab?.kind === 'settings' && !state.serverSettings) void loadServerSettings();
if (tab?.kind === 'table' && !state.edit && tab.table !== accountsTable) void loadTableData(tab);
renderTabs();
}
// 关闭指定标签。
function closeTabById(id) {
if (state.tabs.find((tab) => tab.id === id)?.kind === 'sql') {
void api.rollbackConsole(id).catch(fail);
}
const closed = closeTab(state.tabs, id, state.activeId);
state.tabs = closed.tabs;
state.activeId = closed.activeId;
renderTabs();
if (!state.tabs.some((tab) => tab.kind === 'table') && !changeCount(state.changes) && (state.edit || state.editAttempt)) {
void rollbackAll();
}
}
// 新开一个查询标签。
@@ -1066,6 +1173,10 @@ function deleteSelected(tab) {
// 就地编辑单元格:提交或放弃。
function beginCellEdit(cell, options) {
if (/^runtime\(\[1,\[[567],/.test(String(options.type))) {
setStatus('复合值请通过 SQL 控制台修改');
return;
}
if (cell.querySelector('input')) return;
const input = document.createElement('input');
input.className = 'cell-input';
@@ -1292,6 +1403,7 @@ function onClick(event) {
const target = event.target.closest('[data-action]');
if (!target) return;
const action = target.dataset.action;
if (state.editBusy || state.editStarting) return;
const tab = activeTab();
// 没有选库时,需要当前库的动作先拦下来(服务端也会拒,这里给人话)
@@ -1305,13 +1417,19 @@ function onClick(event) {
void (async () => {
try {
await api.logout();
} catch {
// 退出失败也要回到登录页
} catch (error) {
fail(error);
return;
}
state.session = null;
state.tabs = [];
state.activeId = undefined;
state.changes = createEmptyChangeSet();
state.edit = null;
state.editAttempt = null;
state.editNeedsReload = false;
state.editUncertain = null;
api.forgetEdit();
renderLogin('已退出登录。', 'info');
})();
return;
@@ -1450,7 +1568,7 @@ function onClick(event) {
void commitAll();
return;
case 'rollback':
rollbackAll();
void rollbackAll();
return;
case 'copy-sql': {
const text = changesSql(state.changes).join('\n');
@@ -1493,10 +1611,12 @@ function onClick(event) {
if (!meta || !row) return;
const staged = state.changes.updates.get(changeKey(tab.table, pk, column));
const oldValue = staged ? staged.oldValue : row[column.name];
const editId = state.edit?.id;
beginCellEdit(target, {
type: meta.type,
currentValue: staged ? staged.newValue : row[column.name],
commit: (value) => {
if (state.edit?.id !== editId) return;
if (value === undefined) renderEditor();
else stageUpdate(tab.table, tab.database, pk, column, oldValue, value);
},
@@ -1513,6 +1633,7 @@ function onClick(event) {
type: meta ? meta.type : 'str',
currentValue: insert.values[column],
commit: (value) => {
if (!canEdit(tab.database)) return;
if (value === undefined) renderEditor();
else {
insert.values[column] = value;
@@ -1617,9 +1738,33 @@ window.addEventListener(AUTH_EVENT, () => {
state.session = null;
state.tabs = [];
state.activeId = undefined;
state.changes = createEmptyChangeSet();
state.edit = null;
state.editAttempt = null;
state.editStarting = null;
state.editUncertain = null;
state.editNeedsReload = false;
api.forgetEdit();
renderLogin('会话已过期,请重新登录。', 'warn');
});
// 离开页面时请求回滚仍持有的编辑快照。
window.addEventListener('pagehide', () => {
api.closeConsoleOnPagehide();
const edit = state.edit ?? state.editAttempt;
if (edit && !state.editBusy) {
navigator.sendBeacon('/api/edit/rollback', new Blob([JSON.stringify(edit)], { type: 'application/json' }));
}
});
// 未提交或结果未知时提示页面关闭。
window.addEventListener('beforeunload', (event) => {
if (changeCount(state.changes) || state.editBusy) {
event.preventDefault();
event.returnValue = '';
}
});
root.addEventListener('click', onClick);
root.addEventListener('change', onChange);
root.addEventListener('submit', onSubmit);
+60
View File
@@ -23,6 +23,8 @@ export const accountsTable = '__system_users';
// 值转 SQL 字面量(字符串加引号转义)。
export function sqlLiteral(value) {
if (value === null || value === undefined) return 'NULL';
const runtime = runtimeEnvelope(value);
if (runtime) return runtimeValueText(runtime[1], runtime[2], true);
if (typeof value === 'number' || typeof value === 'boolean') return String(value);
return `'${String(value).replaceAll("'", "''")}'`;
}
@@ -235,6 +237,11 @@ export function isBooleanType(type) {
// 类型的显示名。
export function typeLabel(type) {
if (String(type).startsWith('runtime(') && String(type).endsWith(')')) {
const envelope = JSON.parse(String(type).slice(8, -1));
if (!Array.isArray(envelope) || envelope.length !== 2 || envelope[0] !== 1) throw new Error('Unsupported runtime type encoding');
return runtimeTypeText(envelope[1]);
}
const kind = columnKind(type);
const label = typeLabels[kind];
const args = String(type).includes('(') ? String(type).slice(String(type).indexOf('(')) : '';
@@ -247,6 +254,8 @@ export function typeLabel(type) {
// 单元格显示文本(空值用占位文本)。
export function cellText(value, nullText) {
if (value === null || value === undefined) return nullText;
const runtime = runtimeEnvelope(value);
if (runtime) return runtimeValueText(runtime[1], runtime[2], false);
if (typeof value === 'boolean') return value ? 'true' : 'false';
return String(value);
}
@@ -254,9 +263,60 @@ export function cellText(value, nullText) {
// 编辑框里回填的文本(null 给空串)。
export function editText(value) {
if (value === null || value === undefined) return '';
const runtime = runtimeEnvelope(value);
if (runtime && runtime[1][0] <= 4) return String(runtime[2]);
if (runtime) return runtimeValueText(runtime[1], runtime[2], false);
return String(value);
}
// 读取版本化运行时值封装。
function runtimeEnvelope(value) {
if (!value || typeof value !== 'object' || !Object.hasOwn(value, '__chusql_runtime_v1')) return null;
const envelope = value.__chusql_runtime_v1;
if (!Array.isArray(envelope) || envelope.length !== 3 || envelope[0] !== 1) throw new Error('Unsupported runtime value encoding');
return envelope;
}
// 渲染运行时类型的 SQL 语法。
function runtimeTypeText(type) {
if (!Array.isArray(type) || type.length !== 2 || !Array.isArray(type[1])) throw new Error('Invalid runtime type identity');
const [id, args] = type;
if (!Number.isInteger(id)) throw new Error('Invalid runtime constructor identity');
if (id >= 1 && id <= 4 && args.length === 0) return ['Int', 'Double', 'Bool', 'String'][id - 1];
if (id === 5 && args.length === 1) return `[${runtimeTypeText(args[0])}]`;
if (id === 6 && args.length === 1) return `Maybe ${runtimeTypeText(args[0])}`;
if (id === 7) return `(${args.map(runtimeTypeText).join(', ')})`;
throw new Error('Unknown runtime type identity');
}
// 渲染复合值或对应的 SQL 构造器。
function runtimeValueText(type, value, sql) {
runtimeTypeText(type);
const [id, args] = type;
if (id === 1 || id === 2) {
if (typeof value !== 'number' || !Number.isFinite(value)) throw new Error('Invalid runtime numeric value');
if (id === 1 && !Number.isInteger(value)) throw new Error('Invalid runtime integer value');
const text = String(value);
return sql && id === 2 && !/[.eE]/.test(text) ? `${text}.0` : text;
}
if (id === 3 && typeof value === 'boolean') return sql ? (value ? 'TRUE' : 'FALSE') : String(value);
if (id === 4 && typeof value === 'string') return sql ? sqlLiteral(value) : JSON.stringify(value);
if (!Array.isArray(value)) throw new Error('Invalid runtime compound value');
if (id === 5) {
const items = value.map((item) => runtimeValueText(args[0], item, sql)).join(', ');
return sql ? `LIST<${runtimeTypeText(args[0])}>(${items})` : `[${items}]`;
}
if (id === 6 && value.length <= 1) {
const item = value.length ? runtimeValueText(args[0], value[0], sql) : '';
return sql ? `MAYBE<${runtimeTypeText(args[0])}>(${item})` : (value.length ? `Just (${item})` : 'Nothing');
}
if (id === 7 && value.length === args.length) {
const items = value.map((item, index) => runtimeValueText(args[index], item, sql)).join(', ');
return sql ? `TUPLE<${args.map(runtimeTypeText).join(', ')}>(${items})` : `(${items})`;
}
throw new Error('Runtime value type mismatch');
}
// 编辑框文本转提交值(空串当 null)。
export function parseEdited(raw, type) {
const text = String(raw ?? '').trim();
+12 -11
View File
@@ -179,7 +179,8 @@ gateSpec = do
-- 静态目录与管理员名都不再写进配置:前者写死 static,后者由 --user 给(默认 root);
-- 监听地址是活的配置项([server] listen_host / [web] listen_host),模板里可以留空靠内置默认
template `shouldSatisfy` (not . T.isInfixOf "static_dir =")
template `shouldSatisfy` (not . T.isInfixOf "user =")
template `shouldSatisfy` (not . any ((== "user") . T.strip . fst . T.breakOn "=") . T.lines)
template `shouldSatisfy` T.isInfixOf ("sudo_auth_user = " <> T.pack (show ("" :: String)))
-- 管道传输退休后,两侧都不该再算套接字路径、也不该再认管名。
it "neither side computes a socket path or a pipe name any more" $ do
haskellIpc <- readUtf8 (".." </> "chusql-core" </> "engine" </> "src" </> "ChuSQL" </> "Core" </> "Engine" </> "Storage" </> "IPC.hs")
@@ -202,28 +203,28 @@ gateSpec = do
-- 仓库里没有 rustfmt.toml,历史代码不是按当前 rustfmt 排的:格式化不是门禁
pipeline `shouldSatisfy` (not . T.isInfixOf "cargo fmt")
-- 装的人不该被要求装两个工具链:发版流水线出预编译包,install.sh 按同一套平台标签去取。
-- 流水线里装配与打归档是直接写的(两个平台各一段);本机要打同一个包用 scripts/ 下的
-- package.sh 与它的 PowerShell 版,两边的布局必须一致。
-- 发布流水线调用共享打包脚本,校验归档及安装结果。
it "the release pipeline publishes one archive per platform, tagged the way install.sh looks it up" $ do
release <- readUtf8 (".." </> ".github" </> "workflows" </> "release.yml")
release `shouldSatisfy` T.isInfixOf "linux-x86_64"
release `shouldSatisfy` T.isInfixOf "macos-arm64"
release `shouldSatisfy` T.isInfixOf "macos-x86_64"
release `shouldSatisfy` (not . T.isInfixOf "platform: macos")
T.count "platform:" release `shouldBe` 2
release `shouldSatisfy` T.isInfixOf "windows-x86_64"
release `shouldSatisfy` T.isInfixOf "cargo build --release"
release `shouldSatisfy` T.isInfixOf "stack build --fast chusql-web:exe:chusql-web"
release `shouldSatisfy` T.isInfixOf "stack build --fast chusql-cli:exe:csql"
release `shouldSatisfy` T.isInfixOf "tar -czf"
release `shouldSatisfy` T.isInfixOf "Compress-Archive"
release `shouldSatisfy` T.isInfixOf "sh scripts/package.sh"
release `shouldSatisfy` T.isInfixOf "./scripts/package.ps1"
release `shouldSatisfy` (not . T.isInfixOf "--no-verify")
release `shouldSatisfy` (not . T.isInfixOf "-NoVerify")
release `shouldSatisfy` T.isInfixOf "scripts/install.sh"
release `shouldSatisfy` (not . T.isInfixOf "package.ps1")
release `shouldSatisfy` T.isInfixOf "sha256"
release `shouldSatisfy` T.isInfixOf "gh release upload"
-- 四个平台各一个包,名字里没有组件那一层:一个包里 web 与 cli 都有;
-- 两个平台各一个包,名字里没有组件那一层:一个包里 web 与 cli 都有;
-- 矩阵里也不该再出现 web / cli 这一维(那样又会产出两个按组件命名的资产)
release `shouldSatisfy` T.isInfixOf "name: ${{ matrix.platform }}"
release `shouldSatisfy` T.isInfixOf "name=\"chusql-${{ matrix.platform }}\""
release `shouldSatisfy` T.isInfixOf "name = \"chusql-${{ matrix.platform }}\""
release `shouldSatisfy` T.isInfixOf "--platform '${{ matrix.platform }}'"
release `shouldSatisfy` T.isInfixOf "-Platform '${{ matrix.platform }}'"
release `shouldSatisfy` (not . T.isInfixOf "matrix.component")
release `shouldSatisfy` (not . T.isInfixOf "component: [web, cli]")
it "no layer looks for a storage executable or a pipe name any more" $ do
+312 -5
View File
@@ -3,8 +3,12 @@
module Main (main) where
import ChuSQL.Interface.Link (closeClient, connectClient)
import ChuSQL.Interface.Auth (SessionPolicy (..), defaultSessionPolicy, lookupPayload, setPayloadPolicy)
import ChuSQL.Interface.RateLimit (newRateLimiter)
import ChuSQL.Interface.Session (authenticateSession, newSession, runStatement)
import qualified ChuSQL.Interface.Actions as Actions
import qualified ChuSQL.Core.Model as Model
import ChuSQL.Core.Runtime
import ChuSQL.Interface.Settings (
applySettings,
defaultOf,
@@ -17,6 +21,7 @@ import ChuSQL.Interface.Settings (
)
import ChuSQL.Web.API (
AppEnv (..),
WebSession (..),
Live (..),
defaultLive,
isIdentifier,
@@ -27,8 +32,9 @@ import ChuSQL.Web.API (
)
import ChuSQL.Web.Static (contentTypeOf, safeRelative)
import ChuSQL.Web.UISettings (validateUISettings)
import Control.Concurrent (forkIO)
import Control.Exception (IOException, bracket, try)
import Control.Concurrent (forkFinally, forkIO)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import Control.Exception (IOException, bracket, throwIO, try)
import Control.Monad (when)
import Data.Aeson (encode, object, (.=))
import qualified Data.Aeson as A
@@ -39,6 +45,7 @@ import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BL
import Data.Char (isDigit)
import Data.List (isInfixOf)
import Data.IORef (readIORef)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Text (Text)
@@ -511,6 +518,17 @@ stopServer world = do
-- | 纯函数用例
unitSpec :: Spec
unitSpec = describe "pure helpers" $ do
it "rejects malformed runtime values before producing write SQL" $ do
case resolveType builtinTypes (listType intType) of
Left err -> expectationFailure err
Right descriptor ->
Actions.insertRowSql "t" [("xs", Model.VRuntime (descriptorId descriptor) (RList [RString "wrong"]))]
`shouldSatisfy` either (const True) (const False)
it "escapes nested runtime string literals" $ do
case resolveType builtinTypes (listType stringType) of
Left err -> expectationFailure err
Right descriptor -> Actions.sqlLiteral (Model.VRuntime (descriptorId descriptor) (RList [RString "a'b"]))
`shouldBe` Right "LIST<String>('a''b')"
it "parses the session cookie out of a Cookie header" $ do
parseCookieHeader sessionCookieName "a=1; chusql_session=abc123; b=2" `shouldBe` Just "abc123"
parseCookieHeader sessionCookieName "other=1" `shouldBe` Nothing
@@ -835,17 +853,54 @@ accountSpec env = describe "the account table (system database, admin only)" $ d
roleSpec :: AppEnv -> Spec
roleSpec env = describe "roles and grants" $ do
withApp (webApp env) $ do
it "uses database scopes and owner permissions through REST and rejects private data" $ do
admin <- adminHeaders
ensureDatabase admin testDatabaseName
ensureAccount admin "acl_web_owner" "Owner-Secret-1234"
ensureAccount admin "acl_web_reader" "Reader-Secret-1234"
ensureTable admin "acl_private" (encode (object ["name" .= ("acl_private" :: Text), "columns" .= [column "id" "int"]]))
permission <- postAs admin "/api/roles/acl_web_owner/grants" (encode (object ["object" .= ("database:" <> testDatabaseName), "privileges" .= (["connect", "create"] :: [Text])]))
expectStatusWith "database object grant" permission 200
owner <- ordinaryHeaders "acl_web_owner" "Owner-Secret-1234"
created <- postAs (withDb testDatabaseName owner) "/api/tables" (encode (object ["name" .= ("acl_owned" :: Text), "columns" .= [column "id" "int"]]))
expectStatusWith "owner creates table" created 200
denied <- testSql owner "SELECT * FROM acl_private"
expectStatusWith "private table denied" denied 403
grantDenied <- postAs (withDb testDatabaseName owner) "/api/roles/acl_web_reader/grants" (encode (object ["object" .= (testDatabaseName <> ".acl_private"), "privileges" .= (["select"] :: [Text])]))
expectStatusWith "missing grant option" grantDenied 403
delegated <- postAs (withDb testDatabaseName owner) "/api/roles/acl_web_reader/grants" (encode (object ["object" .= (testDatabaseName <> ".acl_owned"), "privileges" .= (["select"] :: [Text])]))
expectStatusWith "owner delegates via REST" delegated 200
reader <- ordinaryHeaders "acl_web_reader" "Reader-Secret-1234"
visible <- testSql reader "SELECT * FROM acl_owned"
expectStatusWith "delegated query" visible 200
revoked <- testSql admin "REVOKE SELECT ON acl_owned FROM acl_web_reader"
expectStatusWith "root revokes owner delegation" revoked 200
invalidated <- testSql reader "SELECT * FROM acl_owned"
expectStatusWith "revoked Web session" invalidated 401
it "filters database visibility after PUBLIC CONNECT is revoked" $ do
admin <- adminHeaders
ensureDatabase admin "acl_closed"
ensureAccount admin "acl_web_guest" "Guest-Secret-1234"
closed <- postAs admin "/api/query" (encode (object ["sql" .= ("REVOKE CONNECT ON DATABASE acl_closed FROM PUBLIC" :: Text)]))
expectStatusWith "close default connection" closed 200
guest <- ordinaryHeaders "acl_web_guest" "Guest-Secret-1234"
listed <- getAs guest "/api/databases"
expectStatusWith "filtered database list" listed 200
check (("acl_closed" `elem` map asText (items (jsonBody listed))) `shouldBe` False)
refused <- getAs (withDb "acl_closed" guest) "/api/tables"
expectStatusWith "CONNECT denied through Web" refused 403
it "creates a role, grants a privilege, adds a member and drops it" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
ensureAccount hs "bob" "bob-Secret-123456"
ensureTable (withDb testDatabaseName hs) "grant_probe" (encode (object ["name" .= ("grant_probe" :: Text), "columns" .= [column "id" "int"]]))
created <- postAs hs "/api/roles" (encode (object ["name" .= ("analyst" :: Text)]))
expectStatusWith "create role" created 200
granted <-
postAs
hs
"/api/roles/analyst/grants"
(encode (object ["object" .= testDatabaseName, "privileges" .= (["select"] :: [Text])]))
(encode (object ["object" .= (testDatabaseName <> ".grant_probe"), "privileges" .= (["select"] :: [Text])]))
expectStatusWith "grant privilege" granted 200
member <- postAs hs "/api/roles/analyst/members" (encode (object ["user" .= ("bob" :: Text)]))
expectStatusWith "add member" member 200
@@ -865,13 +920,14 @@ roleSpec env = describe "roles and grants" $ do
it "carries the grant option through the API" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
ensureTable (withDb testDatabaseName hs) "grant_option_probe" (encode (object ["name" .= ("grant_option_probe" :: Text), "columns" .= [column "id" "int"]]))
created <- postAs hs "/api/roles" (encode (object ["name" .= ("passer" :: Text)]))
expectStatusWith "create passer" created 200
granted <-
postAs
(withDb testDatabaseName hs)
"/api/roles/passer/grants"
(encode (object ["object" .= testDatabaseName, "privileges" .= (["select"] :: [Text]), "grantOption" .= True]))
(encode (object ["object" .= (testDatabaseName <> ".grant_option_probe"), "privileges" .= (["select"] :: [Text]), "grantOption" .= True]))
expectStatusWith "grant with option" granted 200
listed <- getAs hs "/api/roles"
expectStatusWith "list roles" listed 200
@@ -890,6 +946,16 @@ roleSpec env = describe "roles and grants" $ do
querySpec :: AppEnv -> Spec
querySpec env = describe "the SQL console" $ do
withApp (webApp env) $ do
it "returns typed compound values through HTTP and TCP" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
result <- testSql hs "SELECT LIST<Int>(1, 2), length('abc')"
expectStatusWith "typed SQL values" result 200
let value = maybe A.Null id (nth 0 (firstRow result))
envelope = at "__chusql_runtime_v1" value
check (arrayLen envelope `shouldBe` 3)
check (asInt (maybe A.Null id (nth 0 (items envelope))) `shouldBe` 1)
check (asInt (maybe A.Null id (nth 1 (firstRow result))) `shouldBe` 3)
it "runs DDL and DML and returns positional rows" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
@@ -916,9 +982,230 @@ querySpec env = describe "the SQL console" $ do
ensureDatabase hs testDatabaseName
res <- postAs (withDb testDatabaseName hs) "/api/query" (encode (object ["sql" .= ("SELEC nonsense" :: Text)]))
expectStatusWith "syntax error" res 400
it "redacts credentials from malformed SQL responses" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
let secret = "Web-Secret-DoNotEcho123!" :: Text
res <- postAs (withDb testDatabaseName hs) "/api/query" (encode (object ["sql" .= ("CREATE USER broken IDENTIFIED BY '" <> secret <> "' trailing")]))
expectStatusWith "credential syntax error" res 400
check (BSC.isInfixOf "Web-Secret-DoNotEcho123!" (BL.toStrict (WT.simpleBody res)) `shouldBe` False)
check (BSC.isInfixOf "redacted" (BL.toStrict (WT.simpleBody res)) `shouldBe` True)
-- IDE 设置 -------------------------------------------------------------------
-- | 发出编辑事务控制请求。
editRequest :: [Header] -> BS.ByteString -> Text -> [A.Value] -> TestSession WT.SResponse
editRequest hs path owner changes = postAs hs path (encode (object
["id" .= owner, "database" .= testDatabaseName, "changes" .= changes]))
-- | 在测试库执行一条 SQL。
testSql :: [Header] -> Text -> TestSession WT.SResponse
testSql hs sql = postAs (withDb testDatabaseName hs) "/api/query" (encode (object ["sql" .= sql]))
-- | 生成整数行插入编辑。
editInsert :: Text -> Int -> A.Value
editInsert table key = object ["op" .= ("insert" :: Text), "table" .= table,
"values" .= object ["id" .= key, "value" .= key]]
-- | 验证编辑原子性、隔离与失效清理。
editSpec :: AppEnv -> Spec
editSpec env = describe "web editing transactions" $ withApp (webApp env) $ do
it "commits across tables atomically and deduplicates successful retries" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
madeA <- testSql hs "CREATE TABLE edit_atomic_a (id int PRIMARY KEY, value int)"
expectStatusWith "create first table" madeA 200
madeB <- testSql hs "CREATE TABLE edit_atomic_b (id int PRIMARY KEY, value int)"
expectStatusWith "create second table" madeB 200
begun <- editRequest hs "/api/edit/begin" "atomic" []
expectStatusWith "begin" begun 200
let changes = [editInsert "edit_atomic_a" 1, editInsert "edit_atomic_b" 2]
committed <- editRequest hs "/api/edit/commit" "atomic" changes
expectStatusWith "commit" committed 200
check (at "applied" (jsonBody committed) `shouldBe` A.Number 2)
duplicate <- editRequest hs "/api/edit/commit" "atomic" changes
expectStatusWith "duplicate commit" duplicate 200
check (jsonBody duplicate `shouldBe` jsonBody committed)
changed <- editRequest hs "/api/edit/commit" "atomic" [editInsert "edit_atomic_a" 9]
expectStatusWith "changed duplicate" changed 409
rowsA <- testSql hs "SELECT * FROM edit_atomic_a"
rowsB <- testSql hs "SELECT * FROM edit_atomic_b"
check (asInt (at "rowCount" (jsonBody rowsA)) `shouldBe` 1)
check (asInt (at "rowCount" (jsonBody rowsB)) `shouldBe` 1)
it "rolls back a mid-batch constraint error to the savepoint and permits correction" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
made <- testSql hs "CREATE TABLE edit_constraints (id int PRIMARY KEY, value int)"
expectStatusWith "create table" made 200
begun <- editRequest hs "/api/edit/begin" "constraints" []
expectStatusWith "begin" begun 200
failed <- editRequest hs "/api/edit/commit" "constraints" [editInsert "edit_constraints" 1, editInsert "edit_constraints" 1]
expectStatusWith "constraint failure" failed 400
check (at "state" (jsonBody failed) `shouldBe` A.String "active")
check (at "applied" (jsonBody failed) `shouldBe` A.Number 0)
visible <- testSql hs "SELECT * FROM edit_constraints"
check (asInt (at "rowCount" (jsonBody visible)) `shouldBe` 0)
snapshot <- getAs (("X-ChuSQL-Edit", "constraints") : withDb testDatabaseName hs) "/api/tables/edit_constraints/rows"
expectStatusWith "snapshot after failure" snapshot 200
check (asInt (at "total" (jsonBody snapshot)) `shouldBe` 0)
corrected <- editRequest hs "/api/edit/commit" "constraints" [editInsert "edit_constraints" 2]
expectStatusWith "corrected replay" corrected 200
visibleAgain <- testSql hs "SELECT id FROM edit_constraints"
check (firstRow visibleAgain `shouldBe` [A.Number 2])
it "preserves the initial snapshot and rejects a conflicting external update" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
made <- testSql hs "CREATE TABLE edit_conflicts (id int PRIMARY KEY, value int)"
expectStatusWith "create table" made 200
seeded <- testSql hs "INSERT INTO edit_conflicts (id, value) VALUES (1, 10)"
expectStatusWith "seed row" seeded 200
begun <- editRequest hs "/api/edit/begin" "conflicts" []
expectStatusWith "begin" begun 200
observer <- adminHeaders
updated <- testSql observer "UPDATE edit_conflicts SET value = 20 WHERE id = 1"
expectStatusWith "concurrent update" updated 200
snapshot <- getAs (("X-ChuSQL-Edit", "conflicts") : withDb testDatabaseName hs) "/api/tables/edit_conflicts/rows"
check (firstRow snapshot `shouldBe` [A.Number 1, A.Number 10])
let change = object ["op" .= ("update" :: Text), "table" .= ("edit_conflicts" :: Text),
"pk" .= (1 :: Int), "set" .= object ["value" .= (30 :: Int)]]
failed <- editRequest hs "/api/edit/commit" "conflicts" [change]
expectStatusWith "serialization conflict" failed 409
check (at "reloadRequired" (jsonBody failed) `shouldBe` A.Bool True)
live <- testSql observer "SELECT value FROM edit_conflicts"
check (firstRow live `shouldBe` [A.Number 20])
retried <- editRequest hs "/api/edit/commit" "conflicts" [change]
expectStatusWith "stale retry" retried 409
reopened <- editRequest hs "/api/edit/begin" "conflicts" []
expectStatusWith "stale begin" reopened 409
it "binds editing to one page and database and makes rollback idempotent" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
begun <- editRequest hs "/api/edit/begin" "owner" []
expectStatusWith "begin" begun 200
repeated <- editRequest hs "/api/edit/begin" "owner" []
expectStatusWith "repeated begin" repeated 200
otherPage <- editRequest hs "/api/edit/begin" "intruder" []
expectStatusWith "another page" otherPage 409
otherDatabase <- postAs hs "/api/edit/commit" (encode (object
["id" .= ("owner" :: Text), "database" .= ("system" :: Text), "changes" .= ([] :: [A.Value])]))
expectStatusWith "another database" otherDatabase 409
forged <- getAs (("X-ChuSQL-Edit", "intruder") : withDb testDatabaseName hs) "/api/tables"
expectStatusWith "another page snapshot" forged 409
rolled <- editRequest hs "/api/edit/rollback" "owner" []
expectStatusWith "rollback" rolled 200
duplicate <- editRequest hs "/api/edit/rollback" "owner" []
expectStatusWith "repeated rollback" duplicate 200
stale <- editRequest hs "/api/edit/begin" "owner" []
expectStatusWith "ended identity" stale 409
it "keeps SQL-console transactions separate from grid editing" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
made <- testSql hs "CREATE TABLE edit_console (id int PRIMARY KEY, value int)"
expectStatusWith "create table" made 200
consoleBegin <- testSql hs "BEGIN"
expectStatusWith "console begin" consoleBegin 200
consoleWrite <- testSql hs "INSERT INTO edit_console (id, value) VALUES (1, 1)"
expectStatusWith "console write" consoleWrite 200
begun <- editRequest hs "/api/edit/begin" "console" []
expectStatusWith "editor begin" begun 200
committed <- editRequest hs "/api/edit/commit" "console" [editInsert "edit_console" 2]
expectStatusWith "editor commit" committed 200
consoleRollback <- testSql hs "ROLLBACK"
expectStatusWith "console rollback" consoleRollback 200
live <- testSql hs "SELECT id FROM edit_console"
check (firstRow live `shouldBe` [A.Number 2])
it "drops the editing connection on logout and rejects the old transaction after login" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
begun <- editRequest hs "/api/edit/begin" "logout" []
expectStatusWith "begin" begun 200
gone <- postAs hs "/api/logout" "{}"
expectStatusWith "logout" gone 204
rejected <- editRequest hs "/api/edit/commit" "logout" []
expectStatusWith "old cookie" rejected 401
newHs <- adminHeaders
stale <- editRequest newHs "/api/edit/commit" "logout" []
expectStatusWith "old transaction on new connection" stale 409
it "rejects system identity transactions" $ do
hs <- adminHeaders
res <- postAs hs "/api/edit/begin" (encode (object ["id" .= ("identities" :: Text), "database" .= ("system" :: Text)]))
expectStatusWith "identity transaction" res 400
it "invalidates editing when the account loses its permission" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
made <- testSql hs "CREATE TABLE edit_permissions (id int PRIMARY KEY, value int)"
expectStatusWith "create table" made 200
ensureAccount hs "edit_user" "Editor-Secret-1234"
granted <- testSql hs "GRANT SELECT, INSERT ON edit_permissions TO edit_user"
expectStatusWith "grant editing" granted 200
editor <- ordinaryHeaders "edit_user" "Editor-Secret-1234"
begun <- editRequest editor "/api/edit/begin" "permissions" []
expectStatusWith "begin" begun 200
revoked <- testSql hs "REVOKE INSERT ON edit_permissions FROM edit_user"
expectStatusWith "revoke insert" revoked 200
rejected <- editRequest editor "/api/edit/commit" "permissions" [editInsert "edit_permissions" 1]
expectStatusWith "invalidated editor" rejected 401
live <- testSql hs "SELECT * FROM edit_permissions"
check (asInt (at "rowCount" (jsonBody live)) `shouldBe` 0)
it "restricts an SQL transaction to its owning console and blocks unrelated REST writes" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
let owner = ("X-ChuSQL-Console", "page:console-a") : hs
intruder = ("X-ChuSQL-Console", "page:console-b") : hs
begun <- testSql owner "/* owner */ BEGIN"
expectStatusWith "console begin" begun 200
rejected <- testSql intruder "ROLLBACK"
expectStatusWith "other console rollback" rejected 409
rest <- postAs (withDb testDatabaseName hs) "/api/tables" (encode (object
["name" .= ("edit_rest_intruder" :: Text), "columns" .= [column "id" "int"]]))
expectStatusWith "REST write inside console transaction" rest 409
closed <- postAs hs "/api/query/rollback" (encode (object ["console" .= ("page:console-a" :: Text)]))
expectStatusWith "close owning console" closed 204
next <- testSql intruder "SELECT 1"
expectStatusWith "other console after rollback" next 200
it "cleans the editing snapshot when its web session expires" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
begun <- editRequest hs "/api/edit/begin" "expires" []
expectStatusWith "begin" begun 200
let token = fromMaybe "" (lookup "Cookie" hs >>= parseCookieHeader sessionCookieName . TE.decodeUtf8)
stored <- liftIO (lookupPayload (aeSessions env) token)
app <- getState
res <- liftIO $ bracket
(setPayloadPolicy (aeSessions env) (SessionPolicy (-1) 86400))
(const (setPayloadPolicy (aeSessions env) defaultSessionPolicy))
(const (editFromApp app hs "expires" []))
expectStatusWith "expired commit" res 401
case stored of
Nothing -> check (expectationFailure "missing live web session")
Just (_, ws) -> check (readIORef (wsEdit ws) >>= (`shouldBe` Nothing))
it "serializes duplicate HTTP commits and applies the edit set once" $ do
hs <- adminHeaders
ensureDatabase hs testDatabaseName
made <- testSql hs "CREATE TABLE edit_double_click (id int PRIMARY KEY, value int)"
expectStatusWith "create table" made 200
begun <- editRequest hs "/api/edit/begin" "double-click" []
expectStatusWith "begin" begun 200
app <- getState
results <- liftIO $ do
first <- newEmptyMVar
second <- newEmptyMVar
_ <- forkFinally (editFromApp app hs "double-click" [editInsert "edit_double_click" 1]) (putMVar first)
_ <- forkFinally (editFromApp app hs "double-click" [editInsert "edit_double_click" 1]) (putMVar second)
mapM (either throwIO pure) =<< sequence [takeMVar first, takeMVar second]
mapM_ (\res -> expectStatusWith "duplicate concurrent commit" res 200) results
live <- testSql hs "SELECT * FROM edit_double_click"
check (asInt (at "rowCount" (jsonBody live)) `shouldBe` 1)
-- | 从独立请求上下文提交编辑事务。
editFromApp :: Wai.Application -> [Header] -> Text -> [A.Value] -> IO WT.SResponse
editFromApp app hs owner changes = WT.runSession send app
where
-- | 构造带 Cookie 的原子提交请求。
send = WT.srequest (WT.SRequest
(WT.setPath WT.defaultRequest {Wai.requestMethod = methodPost, Wai.requestHeaders = jsonHeaders hs} "/api/edit/commit")
(encode (object ["id" .= owner, "database" .= testDatabaseName, "changes" .= changes])))
-- | IDE 设置用例
uiSettingsSpec :: AppEnv -> Spec
uiSettingsSpec env = describe "IDE settings" $ do
@@ -1000,7 +1287,25 @@ main = do
limitedEnv <- liveEnv limitedWorld staticDir 1
hspec (spec staticDir env limitedEnv)
-- | 汇总挂载全部用例组
-- | 执行前端事务状态回归。
frontendSpec :: Spec
frontendSpec = describe "browser transaction state" $ do
it "passes the Node runtime value suite" $ do
node <- findExecutable "node"
case node of
Nothing -> expectationFailure "Node.js is required for runtime value tests"
Just executable -> do
(exitCode, output, errors) <- readProcessWithExitCode executable ["test/runtime-values.mjs"] ""
when (exitCode /= ExitSuccess) (expectationFailure (output ++ errors))
it "passes the Node frontend transaction suite" $ do
node <- findExecutable "node"
case node of
Nothing -> expectationFailure "Node.js is required for frontend transaction tests"
Just executable -> do
(exitCode, output, errors) <- readProcessWithExitCode executable ["--test", "--test-reporter=tap", "test/transactions.mjs"] ""
when (exitCode /= ExitSuccess) (expectationFailure (output ++ errors))
-- | 汇总挂载全部用例组。
spec :: FilePath -> AppEnv -> AppEnv -> Spec
spec staticDir env limitedEnv = do
unitSpec
@@ -1013,6 +1318,8 @@ spec staticDir env limitedEnv = do
accountSpec env
roleSpec env
querySpec env
editSpec env
frontendSpec
uiSettingsSpec env
e2eSpec env
rateLimitSpec limitedEnv
+20
View File
@@ -0,0 +1,20 @@
import assert from 'node:assert/strict';
import { readFile } from 'node:fs/promises';
// 检查前端复合值显示、SQL 生成和编码错误。
const source = await readFile(new URL('../static/core.js', import.meta.url), 'utf8');
const { cellText, sqlLiteral, typeLabel, editText } = await import(`data:text/javascript;base64,${Buffer.from(source).toString('base64')}`);
const typeInt = [1, []];
const typeString = [4, []];
const nested = { __chusql_runtime_v1: [1, [5, [[6, [typeInt]]]], [[], [42]]] };
assert.equal(cellText(nested, 'NULL'), '[Nothing, Just (42)]');
assert.equal(sqlLiteral(nested), 'LIST<Maybe Int>(MAYBE<Int>(), MAYBE<Int>(42))');
assert.equal(sqlLiteral({ __chusql_runtime_v1: [1, [7, [typeInt, typeString]], [1, "a'b"]] }), "TUPLE<Int, String>(1, 'a''b')");
assert.equal(sqlLiteral({ __chusql_runtime_v1: [1, [5, [[2, []]]], [1]] }), 'LIST<Double>(1.0)');
assert.throws(() => cellText({ __chusql_runtime_v1: [2, typeInt, 1] }, 'NULL'), /encoding/);
assert.throws(() => sqlLiteral({ __chusql_runtime_v1: [1, [7, [typeInt]], [1, 2]] }), /mismatch/);
assert.equal(typeLabel('runtime([1,[5,[[1,[]]]]])'), '[Int]');
assert.equal(editText({ __chusql_runtime_v1: [1, typeString, 'abc'] }), 'abc');
assert.throws(() => sqlLiteral({ __chusql_runtime_v1: [1, typeInt, 1.5] }), /integer/);
console.log('runtime values: 9 assertions passed');
+175
View File
@@ -0,0 +1,175 @@
import assert from 'node:assert/strict';
import { readFile } from 'node:fs/promises';
import { beforeEach, test } from 'node:test';
import * as api from '../static/api.js';
import { createEmptyChangeSet } from '../static/core.js';
// 验证页面编辑状态、原子请求、断线重试与关闭清理。
const listeners = new Map();
globalThis.window = { addEventListener: (name, callback) => listeners.set(name, callback), dispatchEvent: () => {} };
globalThis.document = { getElementById: (id) => id === 'root' ? { addEventListener() {} } : null };
let source = await readFile(new URL('../static/app.js', import.meta.url), 'utf8');
source = source.replaceAll("'./api.js'", JSON.stringify(new URL('../static/api.js', import.meta.url).href))
.replaceAll("'./core.js'", JSON.stringify(new URL('../static/core.js', import.meta.url).href))
.replace('void boot();', 'export { state, commitAll, rollbackAll, stageUpdate, removeStaged, ensureEdit, runSql };');
const app = await import(`data:text/javascript;base64,${Buffer.from(source).toString('base64')}`);
let calls;
let commitResponse;
// 生成 JSON HTTP 响应。
function response(body, status = 200) {
return new Response(JSON.stringify(body), { status, headers: { 'Content-Type': 'application/json' } });
}
// 重置页面与模拟服务端。
beforeEach(() => {
calls = [];
commitResponse = () => response({ ok: true, applied: 1, state: 'committed' });
api.forgetEdit();
Object.assign(app.state, { database: 'test', databases: ['test'], tabs: [], activeId: undefined,
view: 'workbench', session: { user: 'admin' }, edit: { id: 'page', database: 'test' },
editBusy: false, editStarting: null, editAttempt: null, editNeedsReload: false, editUncertain: null,
changes: createEmptyChangeSet(), messages: [] });
globalThis.fetch = async (url, init) => {
calls.push({ url, init, body: init.body ? JSON.parse(init.body) : undefined });
if (url === '/api/edit/commit') return commitResponse();
if (url === '/api/databases') return response(['test']);
if (url === '/api/tables') return response([]);
return response({ state: 'active' });
};
});
// 检查整批修改只发送一次提交请求。
test('all table edits use one atomic request and clear only after success', async () => {
app.stageUpdate('first', 'test', 1, 'value', 10, 20);
app.stageUpdate('second', 'test', 2, 'value', 20, 30);
await app.commitAll();
const committed = calls.filter((call) => call.url === '/api/edit/commit');
assert.equal(committed.length, 1);
assert.equal(committed[0].body.changes.length, 2);
assert.equal(app.state.changes.updates.size, 0);
assert.equal(app.state.edit, null);
assert.equal(calls.some((call) => call.init.method === 'PATCH'), false);
});
// 检查失败保留可修正的完整编辑集。
test('constraint failure retains all edits and permits local undo before replay', async () => {
app.stageUpdate('first', 'test', 1, 'value', 10, 20);
app.stageUpdate('second', 'test', 2, 'value', 20, 30);
commitResponse = () => response({ ok: false, applied: 0, state: 'active', message: 'constraint', reloadRequired: false }, 400);
await app.commitAll();
assert.equal(app.state.changes.updates.size, 2);
assert.equal(app.state.editNeedsReload, false);
app.removeStaged([...app.state.changes.updates.keys()][0]);
assert.equal(app.state.changes.updates.size, 1);
assert.equal(calls.some((call) => call.init.method === 'PATCH'), false);
});
// 检查冲突禁止再次提交直到回滚。
test('serialization conflict freezes edits and requires rollback and reload', async () => {
app.stageUpdate('first', 'test', 1, 'value', 10, 20);
commitResponse = () => response({ ok: false, state: 'rolled_back', reloadRequired: true, message: 'conflict' }, 409);
await app.commitAll();
await app.commitAll();
assert.equal(calls.filter((call) => call.url === '/api/edit/commit').length, 1);
assert.equal(app.state.changes.updates.size, 1);
app.stageUpdate('first', 'test', 1, 'value', 10, 40);
assert.equal([...app.state.changes.updates.values()][0].newValue, 20);
await app.rollbackAll();
assert.equal(app.state.changes.updates.size, 0);
assert.equal(app.state.editNeedsReload, false);
assert.equal(calls.some((call) => call.url === '/api/edit/rollback'), true);
});
// 检查断线后冻结载荷并使用同一提交标识。
test('an uncertain response retries the same payload without allowing edits', async () => {
app.stageUpdate('first', 'test', 1, 'value', 10, 20);
commitResponse = () => { throw new Error('connection lost'); };
await app.commitAll();
assert.ok(app.state.editUncertain);
app.stageUpdate('first', 'test', 1, 'value', 10, 99);
commitResponse = () => response({ ok: true, applied: 1, state: 'committed' });
await app.commitAll();
const committed = calls.filter((call) => call.url === '/api/edit/commit');
assert.deepEqual(committed[0].body, committed[1].body);
assert.equal(app.state.editUncertain, null);
});
// 检查并发点击只有一个正在提交的请求。
test('duplicate clicks cannot submit concurrently', async () => {
app.stageUpdate('first', 'test', 1, 'value', 10, 20);
await Promise.all([app.commitAll(), app.commitAll()]);
assert.equal(calls.filter((call) => call.url === '/api/edit/commit').length, 1);
});
// 检查快照读取带页面标识且普通 SQL 无标识。
test('snapshot headers are attached only to table reads', async () => {
await api.beginEdit('page', 'test');
await api.listTables('test');
globalThis.fetch = async (url, init) => {
calls.push({ url, init });
return response({ columns: [], rows: [], rowCount: 0 });
};
await api.query('SELECT 1', 'test');
assert.equal(calls.find((call) => call.url === '/api/tables').init.headers.get('X-ChuSQL-Edit'), 'page');
assert.equal(calls.find((call) => call.url === '/api/query').init.headers.has('X-ChuSQL-Edit'), false);
});
// 检查页面离开时发送回滚请求。
test('page close sends a rollback beacon for its own transaction', async () => {
let beacon;
Object.defineProperty(globalThis, 'navigator', { configurable: true, value: { sendBeacon: (url, body) => { beacon = { url, body }; } } });
listeners.get('pagehide')();
assert.equal(beacon.url, '/api/edit/rollback');
assert.deepEqual(JSON.parse(await beacon.body.text()), { id: 'page', database: 'test' });
});
// 检查 BEGIN 回包断线后仍使用同一标识。
test('a lost BEGIN response keeps its identity for an idempotent retry', async () => {
app.state.edit = null;
globalThis.fetch = async (url, init) => {
calls.push({ url, init, body: JSON.parse(init.body) });
if (calls.length === 1) throw new Error('begin response lost');
return response({ state: 'active' });
};
await assert.rejects(app.ensureEdit('test'));
assert.ok(app.state.editAttempt);
await app.ensureEdit('test');
assert.deepEqual(calls[0].body, calls[1].body);
assert.equal(app.state.edit.id, calls[0].body.id);
});
// 检查每个 SQL 标签使用独立所有者标识。
test('console transaction cleanup only applies to its owning tab', async () => {
globalThis.fetch = async (url, init) => {
calls.push({ url, init, body: JSON.parse(init.body) });
return response({ columns: [], rows: [], rowCount: 0, transaction: true });
};
await api.query('BEGIN', 'test', 'first');
const owner = calls[0].init.headers.get('X-ChuSQL-Console');
assert.ok(owner.endsWith(':first'));
await api.rollbackConsole('second');
assert.equal(calls.length, 1);
await api.rollbackConsole('first');
assert.equal(calls[1].url, '/api/query/rollback');
assert.equal(calls[1].body.console, owner);
});
// 检查 SQL 回滚等待期间不能继续编辑旧快照。
test('edits are locked while SQL releases the previous snapshot', async () => {
let release;
globalThis.fetch = async (url, init) => {
calls.push({ url, init });
if (url === '/api/edit/rollback') return new Promise((resolve) => { release = () => resolve(response({ state: 'rolled_back' })); });
return response({ columns: ['value'], rows: [[1]], rowCount: 1 });
};
const job = app.runSql({ id: 'query', database: 'test', sql: 'SELECT 1' });
assert.equal(app.state.editBusy, true);
app.stageUpdate('first', 'test', 1, 'value', 10, 20);
assert.equal(app.state.changes.updates.size, 0);
release();
await job;
assert.equal(app.state.editBusy, false);
assert.equal(app.state.edit, null);
});
+127 -4
View File
@@ -40,6 +40,8 @@ Web / CLI / 其他客户端
- 每条 TCP 连接拥有独立会话,当前数据库和事务互不影响。
- 读请求可并行,写请求由存储层协调。
- Web 与 CLI 共享服务端的权限和执行规则,不直接读写数据目录。
- Web 登录会话分别持有普通 API / SQL 连接与表格编辑连接,编辑事务按页面标识固定数据库。表格读取携带编辑标识时使用该事务快照;普通查询不进入编辑事务。
- 同一 Web Cookie 的请求串行执行。编辑提交以固定保存点重放本地编辑集,失败整体回退;成功回执按提交标识去重。SQL 控制台事务另按页面与标签标识限制连接访问。
## SQL 查询处理
@@ -97,15 +99,136 @@ Web / CLI / 其他客户端
| 机制 | 行为 |
| --- | --- |
| 角色继承 | 沿成员关系取得权限并集;拒绝自继承与环 |
| 表级授权 | 支持 SELECT、INSERT、UPDATE、DELETE 和 ALL |
| 对象授权 | 数据库 CONNECT / CREATE,表 SELECT / INSERT / UPDATE / DELETE;ALL 按作用域展开 |
| 转授权 | WITH GRANT OPTION 允许将持有的权限授予其他身份 |
| 撤销 | 管理员撤销权限及对应转授权能力;当前不级联撤销已转授权限 |
| 对象名称 | 授权前补全为库.表,检查与持久化使用同一名称 |
| 撤销 | 授予者撤销自身来源;所有者或最高权限身份管理对象授权,级联清理无合法来源的下游 |
| 稳定对象 | catalog 分配数据库及表编号,授权与所有者绑定对象和身份编号,删除后不复用 |
| 所有者 | 建表者获得表所有权;启用角色可继承所有权,数据库所有权不隐含他人表的数据权限 |
对象权限目录 __system_object_acl 对普通语句和存储请求隐藏。权限快照按字符分块,在系统库写锁内比较版本并通过同一 WAL 组替换;服务启动恢复建表前持久化的创建者声明,旧名称授权只迁移一次到现存稳定对象。
类型目录说明见 [types.md](types.md),身份字段与权限边界见 [users-and-roles.md](users-and-roles.md)。
## 权限变更与会话失效
账号、属性和授权变化会标记受影响的在线连接。角色变化先展开成员关系,确定涉及的登录身份。
账号、属性和授权变化会标记受影响的在线连接。角色变化先展开成员及转授权来源关系,确定涉及的登录身份。共享读写门允许查询并行,并将授权及对象结构变更与查询排序;事务提交再次验证权限和稳定对象编号。
TCP 连接在下一次请求时返回 unauthorized 并关闭;空闲连接不被强行中断。权限逐条查询,避免继续使用旧授权。Web 会话还通过账号版本校验,口令或身份变更使旧凭据失效。
## 查询引擎扩展设计(尚未实现)
按 bound IR → 子查询物化 / 递归 CTE 推进;DOMAIN 约束见[类型文档](types.md#domain-约束设计尚未实现)。以下设计尚未实施,当前能力见前文;实施状态以 project-plan.txt 为准。
### bound IR
#### 列与作用域绑定
保留语法 AST 用于解析和诊断;语义检查产出独立 `BoundStatement`,规划、优化及执行逐步只接收它。列引用绑定为作用域编号、来源编号、列编号和类型,保留原始位置用于诊断;相关列明确标记所属外层作用域,不再通过字符串补限定名辨认身份。
#### 表达式类型与错误语义
表达式节点携带结果类型、nullable、已解析运算符/函数标识和显式转换。没有证据证明安全时 `may_error` 为 true;优化不得删除或提前求值可能报错的表达式。未定型 NULL 只参与推导,最后绑定到上下文类型;不允许流入存储 schema。DOMAIN 身份保留在类型节点中,比较可以用底层语义,赋值需经过领域校验。
#### schema 与对象版本
绑定仅使用 schema,不能扫描数据或打开索引。catalog 解析对象后提供 schema 与版本;执行前再次验证稳定对象编号和 schema 版本。统计独立附着,不纳入绑定身份。内存存储使用与磁盘相同的绑定规则。
#### 实施与验收
迁移顺序为查询表达式 → RelOp 输入 → 写语句和约束;过渡适配器单向转换且仅位于边界,不维护两套优化规则。验收用现有查询全集并补同名遮蔽、相关列、别名、NULL/DOMAIN 和错误时序回归;既有可观察顺序保持。
### 通用子查询物化
#### 惰性执行与缓存身份
引入查询内 `LazyMaterialize` 算子:首次实际需要时执行,保留结果行序与重复;非相关查询每语句一次,相关查询按 bound IR 外层列绑定值缓存。缓存键沿用规范值相等、NULL 与领域底层语义,并绑定子计划和执行视图;不能跨语句、会话或权限版本复用。
#### 求值语义
首版只物化已证明确定且无副作用的子计划;可能报错的表达式保持现有首次使用和短路路径,无法证明错误时序相同的改写禁用。空输入不触发子查询,标量多行仍在实际消费时报错。ANY/ALL、IN、EXISTS 各自保留三值及空集规则,不能用集合去重替代结果。
#### 预算与回退
预算同时限制单缓存、查询总缓存和相关键数量;超过预算时在执行该次子计划前选择不缓存的原路径,不能重跑已执行一半的计划。磁盘溢写作为后续阶段,需明确临时目录、类型编码、权限及取消清理。EXPLAIN 展示物化范围与估算,运行统计不泄露缓存行值。
#### 验收条件
验收比较启用/禁用的结果多重集、行序、首次错误、空输入、NULL、重复外层绑定、多次 CTE 引用、预算及取消;不确定函数不可复用。
### 递归 CTE
#### 首版语法范围
保留现有非递归 WITH 行为;新增 WITH RECURSIVE 走绑定作用域,不在解析期无限展开。首版仅单一自引用、锚点 UNION ALL 递归项;自引用只能出现在递归项 FROM,锚点不可引用自身。互递归、多个自引用、递归项聚合/排序/LIMIT、外连接及非单调子查询明确拒绝。UNION 去重递归留后续设计,不能冒用 UNION ALL。
#### 类型绑定与迭代
锚点和递归项输出列数相同;显式列名唯一,先由锚点确定类型,再校验递归项可赋值转换,不按运行数据扩宽。无法给锚点 NULL 定型时要求显式类型。执行用 worktable,递归项仅读取上一轮 delta,按轮次和每轮既有行序追加输出,保留 UNION ALL 重复。
#### 资源预算与终止
拟定默认深度 1000、累计行数 100000、内存 64 MiB,并受服务端上限限制;达到任一预算返回 resource_limit,不返回截断结果。深度定义为递归项执行轮数;delta 为空正常终止。外层 LIMIT 首版不作为终止证明,先完整执行递归再消费,避免隐藏循环/错误。取消释放所有 worktable。
#### 验收条件
验收覆盖零轮、多轮、重复路径、循环超限、NULL/类型冲突、空锚点、名称遮蔽、非法自引用和查询取消。EXPLAIN 明确递归与预算。
## 存储与事务扩展设计(尚未实现)
先引入稳定行编号和 MVCC,再实施跨页 compact 与并行写。前置条件是新页格式、版本化 WAL、离线升级工具及恢复验收。
新格式必须标版本,旧二进制拒绝打开。旧数据在保留备份的停服副本上升级、校验后发布,不混用新旧写入路径。每阶段先运行改动模块的规定测试入口,全量门禁由所有者运行;性能数据不能代替语义、恢复或权限验收。
### 行版本 MVCC
#### 身份与可见性
引入库内单调 row_id,独立于用户 `id`、主键及物理槽号;删除不复用。每版本包含 row_id、版本编号、创建/结束提交序号与前版本定位,未提交版本只在事务私有工作集内。读视图固定 snapshot_csn,选取创建序号不大于快照且结束序号大于快照的版本,再合并自身修改。提交序号与 WAL LSN 分离,映射随提交记录持久化。
每连接仍只允许一个事务,保持快照隔离和保存点语义;不声称可串行化,写偏斜仍可能发生。写集记录读取的基线版本,提交验证该版本仍为最新;同 row_id 更新/删除冲突返回 serialization_failure。唯一键冲突在当前已提交状态和本次写集联合检查,不能仅用开始快照验证。无业务 id 的表也按 row_id 提交,不再整表替换。
索引键定位 row_id,索引查询再按快照检查版本;更新键保留旧键候选直到所有活跃快照不再需要,不能只索引最新值。扫描先保持旧格式导入的行序,更新不改 row_id 的扫描位置,新插入按持久化序号排序;不得借 MVCC 无意改变现有无 ORDER BY 输出。
#### 提交、恢复与回收
首版仍串行提交:验证 → 分配 CSN → WAL 记录版本变化及提交 → fsync → 应用 → 统一发布可见 CSN。读者仅获取已完整应用的可见序号;持久化提交后应用失败继续采用 recovery_required 封闭请求,不能把已提交组当作失败撤销。不引入未提交脏页,因此首版保持 redo-only;若将来允许提前刷未提交页,必须另行设计 undo/状态恢复。
保存点记录私有写集边界与不可变根,回退不撤销其他事务版本。活跃快照登记器包括流式扫描和物化消费者;最老快照决定旧版本回收界线。回收同时处理 heap 和索引,读定位有 pin,取消/断线可靠注销。长事务受现有寿命及新增保留空间预算限制,不能为了回收静默推进其快照。
升级在停服副本中为旧行分配 row_id、初始版本和顺序,重建索引,验证行数/值/约束后切换;不得把重复业务 id 合并。新 WAL 与页格式显式版本化,截断仍遵循已刷盘检查点,不顺带改成页 LSN 检查点。
#### 验收条件
验收包含重复/缺失业务 id、旧快照与键更新、删除重插、保存点、唯一并发冲突、写偏斜边界、长读回收、断线及提交每个持久化边界的崩溃恢复;复测 BEGIN/COMMIT 的传输和比较成本。
### 跨页 compact
#### 定位与影子页
使用 row_id 到版本位置的存储内部定位映射,索引不保存可失效的页/槽定位。首版在表维护独占锁下进行,等待该表读 pin 释放;其他表仍可运行。以快照回收界线保留所有可能可见版本,按既有逻辑扫描顺序打包到影子页和定位映射,随后 WAL 记录并原子切换文件代次。
#### 恢复与旧版本保护
旧代次直到无读引用且新代次检查点完成才删除;提交前崩溃丢弃影子文件,提交后重放切换。映射缺失、重复 row_id/版本和校验失败明确报错,不返回缺行扫描。隐藏列一并按当前 schema 改写,旧快照需要的结构不得提前删除。跨页整理不改变对象编号、行编号、值或输出顺序。
#### 验收条件
验收验证前后全量扫描和索引点/范围查一致、快照旧版本、隐藏列、页损坏、空间不足、取消与文件切换崩溃;记录回收页数及 IO,不能只比较耗时。
### 并行写
#### 实施顺序与锁范围
先允许事务私有写集准备并行,继续保留短串行 WAL/CSN 发布;第二阶段按稳定表编号与 row_id 排序取得写锁、唯一键锁。DDL/维护使用库结构锁,跨表事务必须一次取得完整锁集,禁止边执行边任意升级。权限读门在执行和最终复查期间保持现有语义;目录及 ACL 修改仍单独排序。
#### 唯一键锁与取消
唯一键锁使用与值相等一致的规范编码,缺主键也使用 row_id 锁。等待有取消与超时,超时返回明确错误且保持/回退事务遵循现有错误分类;固定锁序避免内部锁环,不承诺支持任意用户锁或死锁自动重试。
#### 提交发布顺序
允许不同表/行的验证和页面准备并行,但同一页短 latch、catalog 高水位、索引节点和 WAL 写入仍保护。发布 CSN 必须按提交顺序形成连续已应用前缀,后提交不能跨过未完成组而对读者可见。group commit 为后续性能阶段,不能改变每组原子性和持久化失败语义。
#### 验收条件
验收覆盖同表不同行、同一行、唯一键冲突、跨表相反顺序、DDL/compact/撤权竞争、超时取消和 WAL 故障;用确定同步点断言并发结果,再单独测吞吐与等待时间。
-7
View File
@@ -1,7 +0,0 @@
# README 徽章
所有徽章都是本地 SVG,采用统一的深色标签、彩色值区和圆角样式。
执行 `pwsh -File scripts/update-code-lines.ps1` 可重新生成全部徽章。代码行数包含代码、测试、注释和空行,排除 Git 忽略的构建工件;行数与提交编号是生成时的本地快照。
发布徽章链接 GitHub 版本列表。构建、测试和门禁徽章提供实时状态页面入口,本地图片显示 `view status` 或 `manual status`,不保存或宣称实时通过状态。门禁由所有者手动触发。
-6
View File
@@ -1,6 +0,0 @@
<svg xmlns="http://www.w3.org/2000/svg" width="160" height="24" viewBox="0 0 160 24" role="img" aria-label="build: view status">
<title>Open the build workflow for live status; this local badge is a navigation link.</title>
<defs><clipPath id="rounded"><rect width="160" height="24" rx="5"/></clipPath></defs>
<g clip-path="url(#rounded)"><rect width="160" height="24" fill="#1e293b"/><rect x="59" width="101" height="24" fill="#0369a1"/></g>
<g fill="#fff" text-anchor="middle" font-family="Verdana,DejaVu Sans,sans-serif" font-size="11"><text x="29.5" y="16">build</text><text x="109.5" y="16">view status</text></g>
</svg>

Before

Width:  |  Height:  |  Size: 634 B

-6
View File
@@ -1,6 +0,0 @@
<svg xmlns="http://www.w3.org/2000/svg" width="139" height="24" viewBox="0 0 139 24" role="img" aria-label="commit: fd5f320">
<title>Local HEAD snapshot when the badges were generated; open commit history for latest updates.</title>
<defs><clipPath id="rounded"><rect width="139" height="24" rx="5"/></clipPath></defs>
<g clip-path="url(#rounded)"><rect width="139" height="24" fill="#1e293b"/><rect x="66" width="73" height="24" fill="#475569"/></g>
<g fill="#fff" text-anchor="middle" font-family="Verdana,DejaVu Sans,sans-serif" font-size="11"><text x="33" y="16">commit</text><text x="102.5" y="16">fd5f320</text></g>
</svg>

Before

Width:  |  Height:  |  Size: 637 B

-6
View File
@@ -1,6 +0,0 @@
<svg xmlns="http://www.w3.org/2000/svg" width="167" height="24" viewBox="0 0 167 24" role="img" aria-label="gate: manual status">
<title>Open the owner-triggered gate workflow for status; this local badge is a navigation link.</title>
<defs><clipPath id="rounded"><rect width="167" height="24" rx="5"/></clipPath></defs>
<g clip-path="url(#rounded)"><rect width="167" height="24" fill="#1e293b"/><rect x="52" width="115" height="24" fill="#b45309"/></g>
<g fill="#fff" text-anchor="middle" font-family="Verdana,DejaVu Sans,sans-serif" font-size="11"><text x="26" y="16">gate</text><text x="109.5" y="16">manual status</text></g>
</svg>

Before

Width:  |  Height:  |  Size: 644 B

-6
View File
@@ -1,6 +0,0 @@
<svg xmlns="http://www.w3.org/2000/svg" width="209" height="24" viewBox="0 0 209 24" role="img" aria-label="languages: Haskell + Rust">
<title>ChuSQL implementation languages: Haskell and Rust.</title>
<defs><clipPath id="rounded"><rect width="209" height="24" rx="5"/></clipPath></defs>
<g clip-path="url(#rounded)"><rect width="209" height="24" fill="#1e293b"/><rect x="87" width="122" height="24" fill="#6d28d9"/></g>
<g fill="#fff" text-anchor="middle" font-family="Verdana,DejaVu Sans,sans-serif" font-size="11"><text x="43.5" y="16">languages</text><text x="148" y="16">Haskell + Rust</text></g>
</svg>

Before

Width:  |  Height:  |  Size: 617 B

-6
View File
@@ -1,6 +0,0 @@
<svg xmlns="http://www.w3.org/2000/svg" width="174" height="24" viewBox="0 0 174 24" role="img" aria-label="source lines: 37,149">
<title>Physical source lines; includes tests, comments and blank lines.</title>
<defs><clipPath id="rounded"><rect width="174" height="24" rx="5"/></clipPath></defs>
<g clip-path="url(#rounded)"><rect width="174" height="24" fill="#1e293b"/><rect x="108" width="66" height="24" fill="#0369a1"/></g>
<g fill="#fff" text-anchor="middle" font-family="Verdana,DejaVu Sans,sans-serif" font-size="11"><text x="54" y="16">source lines</text><text x="141" y="16">37,149</text></g>
</svg>

Before

Width:  |  Height:  |  Size: 619 B

-6
View File
@@ -1,6 +0,0 @@
<svg xmlns="http://www.w3.org/2000/svg" width="139" height="24" viewBox="0 0 139 24" role="img" aria-label="release: browse">
<title>Open GitHub releases to view published versions.</title>
<defs><clipPath id="rounded"><rect width="139" height="24" rx="5"/></clipPath></defs>
<g clip-path="url(#rounded)"><rect width="139" height="24" fill="#1e293b"/><rect x="73" width="66" height="24" fill="#6d28d9"/></g>
<g fill="#fff" text-anchor="middle" font-family="Verdana,DejaVu Sans,sans-serif" font-size="11"><text x="36.5" y="16">release</text><text x="106" y="16">browse</text></g>
</svg>

Before

Width:  |  Height:  |  Size: 594 B

-6
View File
@@ -1,6 +0,0 @@
<svg xmlns="http://www.w3.org/2000/svg" width="160" height="24" viewBox="0 0 160 24" role="img" aria-label="tests: view status">
<title>Open the test workflow for live status; this local badge is a navigation link.</title>
<defs><clipPath id="rounded"><rect width="160" height="24" rx="5"/></clipPath></defs>
<g clip-path="url(#rounded)"><rect width="160" height="24" fill="#1e293b"/><rect x="59" width="101" height="24" fill="#0369a1"/></g>
<g fill="#fff" text-anchor="middle" font-family="Verdana,DejaVu Sans,sans-serif" font-size="11"><text x="29.5" y="16">tests</text><text x="109.5" y="16">view status</text></g>
</svg>

Before

Width:  |  Height:  |  Size: 633 B

+13
View File
@@ -45,6 +45,7 @@ csql [options]
| `-f, --format FORMAT` | 输出格式:`table`、`json` 或 `csv` |
| `-e, --execute SQL` | 执行一条 SQL 后退出 |
| `--history FILE` | 指定历史记录文件 |
| `--sudo` | 使用本机 root / 提升管理员身份认证;需配置映射并启用身份属性,见 [用户与角色](users-and-roles.md#本机-sudo-认证) |
| `--config FILE` | 指定配置文件 |
| `-h, --help` | 显示帮助 |
@@ -99,6 +100,18 @@ chusql-web [options]
静态资源目录固定为 `static`。其余请求大小、会话、登录限制、分页等参数通常通过 `settings.toml` 配置即可。
### 表格编辑与事务
首次打开业务数据表时建立编辑快照。同一页面内、同一数据库的跨表修改统一暂存;“提交全部”在服务端事务中执行,全部成功才持久化。逐项撤销只移除本地编辑项,下次提交从原快照重放剩余编辑;“撤销全部”执行 ROLLBACK 并重新加载表和统计。
途中发生约束错误时,整批语句退回编辑保存点,完整编辑内容仍可修正。写写冲突不会覆盖其他会话,必须撤销并重新加载后重新编辑。提交响应断线时冻结编辑集;再次点击提交使用同一标识确认或重试同一批修改,已成功的提交不会重复执行。
编辑事务绑定登录会话、页面和数据库;待提交修改存在时,先提交或撤销才能换库或运行 SQL。关闭最后一个表标签且没有待提交修改时释放快照。关闭页面会请求回滚,退出登录会关闭连接并丢弃快照;若页面断线、回滚请求未送达,后台每分钟按配置的会话空闲与最长寿命清理连接。重新登录不能继续旧事务。
SQL 控制台使用另一条服务端连接;SQL 的 BEGIN / COMMIT / ROLLBACK 绑定发起它的页面与查询标签。事务尚未结束时,其他控制台和普通 REST 写操作不能占用该连接;关闭所属查询标签或页面时请求回滚。系统身份修改不支持数据事务,账号表只读,使用 SQL 用户与角色命令管理。
Web 模块测试入口为 `stack test chusql-web --fast`,其中同时运行 `node --test test/transactions.mjs`;测试环境需要 Node.js。
## chusql-server
基本用法:
+2
View File
@@ -53,6 +53,8 @@ ChuSQL 使用统一配置文件 `settings.toml`。默认位置:
| `max_message` | `1048576` | 单条请求最大大小(字节) |
| `max_rows` | `1000` | 单次查询最大返回行数 |
本机 sudo 认证额外使用 `[server] sudo_auth_user`,默认空字符串,表示关闭。设置为一个已启用 `ALLOW_SUDO_AUTH` 的数据库身份后,必须以 Unix root 或 Windows 提升后的管理员运行 `chusql-server`。这是明确的本机身份映射,与启动参数 `--user` 和最高权限属性分别设置。配置变更后重启服务生效,Web 设置页面不提供此项。操作步骤见 [用户与角色](users-and-roles.md#本机-sudo-认证)。
修改 Server 相关配置后需要重启 `chusql-server`。
## 账号与安全
+18
View File
@@ -33,6 +33,17 @@ ChuSQL 支持三种安装方式:
完成系统目录初始化后,安装程序默认会启动 `chusql-server`;如不希望自动启动,可使用 `--no-start`(Windows 为 `-NoStart`)。
Linux 默认注册 `chusql-server.service` 为当前操作系统用户的 systemd 服务,并启用 linger 和开机启动,无需登录即可运行,异常退出后自动重启。需要可用的 systemd 用户会话;若启用 linger 时权限不足,按安装提示执行 `sudo loginctl enable-linger "$(id -un)"` 后重试。数据库管理员 `--user` 与运行服务的操作系统用户是两个独立身份。
`--no-start` 仅跳过本次启动,仍启用开机启动。非 systemd 环境可使用 `--no-service` 跳过服务注册,此时保留原有后台启动方式。
```sh
systemctl --user status chusql-server.service
systemctl --user restart chusql-server.service
systemctl --user stop chusql-server.service
journalctl --user -u chusql-server.service
```
## 包内安装
解压发行包后,在包根目录执行:
@@ -56,6 +67,7 @@ Windows:
| `--data-dir DIR` | `-DataDir` | 指定数据目录 |
| `--user NAME` | `-RootUser` | 指定管理员账号名 |
| `--no-start` | `-NoStart` | 安装后不自动启动服务 |
| `--no-service` | — | 跳过 Linux 服务注册和开机启动 |
| `--version TAG` | `-Version` | 指定发行版本 |
| `--list-versions` | `-ListVersions` | 列出可安装版本 |
| `--from-source` | — | 从源码构建并安装 |
@@ -108,3 +120,9 @@ Windows:
```
如需保留数据,可使用 `--keep-data`(Windows 为 `-KeepData`);如需保留配置,可使用 `--keep-config`(Windows 为 `-KeepConfig`)。
Linux 卸载时会停止服务、取消开机启动并移除服务文件。用户的 linger 设置保留,其他用户服务仍可使用它。
## 发布真实性与后续签名方案
当前 SHA256 校验用于检测产物损坏,发布签名尚未实现。密钥管理、可信根、轮换、在线与离线验证的设计见[发布签名与验证](release-signing.md);设计中的验证器和签名安装流程目前不可用。
+143
View File
@@ -0,0 +1,143 @@
# 数据库范式分析与迁移
引擎模块 `ChuSQL.Core.Engine.Normalization` 提供只读范式分析。输入只有 schema 与用户声明,不读取样本数据,不访问或修改存储。
## 接口与示例
```haskell
analyzeNormalization
:: [(String, Column)]
-> Declaration
-> Either String Analysis
```
调用示例:
```haskell
analyzeNormalization [("student", TInt), ("course", TInt), ("name", TStr)]
(Declaration
{ declaredKeys = [["student", "course"]]
, dependencies = [Dependency ["student"] ["name"]]
, dependenciesComplete = True
, atomicAttributes = Just True
})
```
这个声明违反 2NF、3NF、BCNF:非主属性 `name` 依赖复合候选键的真子集 `student`。
报告的 `witnesses` 给出相关字段,`condition` 给出范式条件。建议分为 `(student, name)` 与 `(course, student)`,无损连接并保持声明依赖。
## 声明与输入校验
`declaredKeys` 中每个键作为决定全部字段的依赖加入公理推导;检查器验证其最小性,并枚举所有最小超键。空键允许表达只有一行的关系约束。
字段名称使用 schema 中的确切名称,不自行处理 SQL 标识符解析。以下输入返回明确错误:
- 未知字段或重复字段。
- 空依赖右部。
- 非最小候选键。
- 空 schema。
## 公理推导与范式条件
属性闭包以输入属性实现自反性,逐轮加入已满足左部的依赖右部,得到阿姆斯特朗增广和传递规则蕴含的闭包。检查器枚举字段子集及其闭包,检查完整的依赖投影。
| 范式 | 检查条件 |
| --- | --- |
| 1NF | 根据用户声明判断领域值原子性。 |
| 2NF | 检查所有候选键的部分依赖。 |
| 3NF | 检查非超键左部与非主属性右部。 |
| BCNF | 检查非超键左部。 |
理论定义可参考[数据库课程讲义](https://documents.uow.edu.au/~jrg/235/slides/03databasenormalization/03databasenormalization.html)。
## 信息完整性与判定
### 领域值原子性
`atomicAttributes` 是用户关于领域值原子性的声明:
| 声明值 | 1NF 判定 |
| --- | --- |
| `Just True` | 满足。 |
| `Just False` | 违反。 |
| `Nothing` | 信息不足。 |
schema 类型不证明业务意义上的原子性。不满足 1NF 时更高范式也判违反;原子性未知时更高范式信息不足。
### 依赖完整性
只有 `dependenciesComplete = True` 才对更高范式给出满足或违反结论。这表示用户承诺给出了完整业务依赖的一个覆盖,而非必须列出所有推导依赖。完整的空依赖集有效。
未承诺完整时,更高范式返回 `Insufficient`,不输出违反证据或分解建议。此时 `candidateKeys` 仅是相对已知声明求得的键,不能视为完整业务候选键清单。
分析始终以声明为条件,不能证明数据库实际数据满足声明。
## 分解建议
分解建议仅针对第一条 BCNF 违反依赖 `X -> Y`,输出两个子关系:
- `X ∪ Y`
- `R − (Y − X)`
该二元分解由依赖保证无损;依赖保持通过两个子关系的完整依赖投影之并是否蕴含原依赖集判定。
建议只是一轮分解,子关系可能仍需继续分析,不承诺一次达到 BCNF。依赖不保持时需跨关系检查原约束。
## 第一阶段限制
- 最多接受 12 列,超过返回错误,避免指数枚举无界增长。
- 仅提供 Haskell 只读 API。
- CLI / Web 入口和自动迁移尚未实现。
## 后续入口设计(尚未实现)
以下 TCP、CLI 和 Web 接口尚未实现,拟议命令与端点目前不可用。实施状态以 project-plan.txt 为准。
### 协议与鉴权
在 `ChuSQL.Interface.Protocol` 增加专用客户端请求 `normalization_analyze`,由 server 调用 engine API;不经最高权限专用的原始 `ReqStorage` 入口。请求包含 `api_version=1`、数据库与表标识、声明,以及可选的预期对象编号和 schema 指纹。server 在现有权限读门内以 catalog 解析现存对象,检查 CONNECT 与 SELECT;系统对象拒绝访问。事务内取该连接的 schema 快照,返回视图来源和对象编号,不能混入其他连接的快照。
声明字段固定为 `declared_keys`、`dependencies`(`lhs` / `rhs`)、`dependencies_complete`、`atomic_attributes`。完整性缺省 false,原子性缺省 null;不把 PRIMARY KEY、UNIQUE 或样本自动当作完整业务依赖。前端可以展示实际 schema 约束供用户选择,确认后才成为声明。候选键的 nullable 与 SQL UNIQUE 语义单独提示,不自动证明经典关系模型的键。
响应包含对象编号、schema 指纹、规范化声明、候选键、四项 findings 和一次分解建议。稳定标签使用 `1nf/2nf/3nf/bcnf`、`satisfied/violated/insufficient`;条件说明与机器字段分开。所有结论标明“以声明为条件”,无损连接标签不代表现有 SQL 数据或袋语义已经验证。
字段名称必须与返回 schema 的确切列名一致;对象名称使用现有标识符规则,数据库限定名必须与请求数据库一致。指纹只覆盖列名、类型和约束等语义结构,排除行数与直方图;定义确定性编码并同时绑定稳定对象编号,避免同名重建复用报告。
拒绝未知协议版本、未知字段、重复字段、空右部、非最小声明键、空 schema 和超过 12 列。拟定请求上限 64 KiB、依赖条数 256、键声明 256;预算超限返回明确错误,不截断后给出完整报告。分析在有界工作队列运行,取消或超时释放权限读门与会话资源;输出也受传输预算约束,超限返回错误。实施时用最坏 12 列声明确定默认时间预算。
### CLI 与 Web
CLI 拟议元命令为 `\normalize TABLE --declaration FILE --format text|json`,通过当前登录连接和工作库请求。声明文件为 UTF-8 JSON,错误写 stderr;成功分析退出码 0,即使结论违反或信息不足;协议、权限、输入与运行错误退出非零。批处理增加独立 `--normalize` 模式,与 `--execute` 互斥,不把元命令发给 SQL 解析器。
Web 拟议 `POST /api/normalization/analyze`,复用登录、CSRF 和 Cookie 串行规则。入口位于表结构页:展示 schema、编辑声明、提交分析、显示证据和分解字段列表。完整性与原子性不预先勾选;没有自动执行分解按钮。编辑页分析必须携带既有页面事务标识,不能自动开启另一事务。对象或 schema 改变返回冲突并要求重新分析。
### 入口验收
验收覆盖 engine 报告的协议往返、CLI 文本/JSON 同值、Web 与 TCP 越权、跨库同名、删表重建、事务快照、超限及取消。沿用现有 14 项算法回归,不复制算法到客户端。
## 数据迁移设计(尚未实现)
先实现只读入口,再在 [DOMAIN 约束](types.md#domain-约束设计尚未实现)、依赖目录和原子结构发布具备后实施迁移。
### 规划条件
迁移首版限定单业务表、二元分解、显式目标名,保留原表,不自动改名或删除。请求必须引用报告对象编号、schema 指纹及声明摘要;报告本身不是执行授权。要求来源 SELECT、数据库 CREATE;切换旧表需要来源所有权。每个目标取得新编号和执行者所有权,原 ACL 不自动复制。
经典 FD 与无损分解适用于关系集合,当前 SQL 保留重复行且有 NULL。首版只接受所有参与字段 NOT NULL、全行无重复且声明确实成立的数据;否则明确拒绝,不能通过 DISTINCT 悄悄丢行。候选键也必须验证唯一和非空,包括空键最多一行。FD 验证按引擎规范值相等规则分组,禁止使用文本序列化代替值比较。
目标数据为各字段投影的集合。验证每条声明 FD、全部候选键、目标约束及两目标连接与来源的完整多重集相等;无损性理论证明和实际重建检查均须通过。若投影依赖不能保持所有原依赖,首版拒绝迁移;后续有跨表约束执行器后再开放,不只弹提示继续。
### 结构依赖与发布
规划器枚举索引、默认值、CHECK、DOMAIN 引用、外键及其他已登记依赖,逐项生成保留或拒绝理由。单目标可表达的约束绑定后迁移;跨目标 CHECK、无法保存的索引/唯一约束及任何无法枚举的受支持依赖阻止发布。不得根据 SQL 文本替换列名。客户端保存的任意 SQL 无法枚举,保留来源表可避免静默改坏;首版不提供透明替换。
执行流程为 prepare → validate → publish:prepare 创建不对业务 catalog 可见的暂存对象;validate 固定来源视图并生成目标、验证重建;publish 在短结构锁内复查身份、权限、对象编号、schema 与数据版本,原子登记全部目标。来源变化返回 serialization_failure,不自动重试。暂存对象需要空间预算、作业编号和取消清理。
现有事务禁止 DDL,不能拼接 CREATE/INSERT 伪装成原子迁移。实施前必须加入包含 catalog、页文件、索引和所有权声明的迁移 WAL 发布组;提交前暂存文件可清理,提交后故障进入 recovery_required 并重放到完整目标组。对象编号可以跳号但不得复用。恢复仅依据作业状态与 WAL 清理暂存对象,不能按名称猜测。
后续替换来源需独立设计:稳定对象引用、授权重绑定、完整依赖图与原子交换。保留原对象及其编号直到该方案验收;当前阶段不提供多轮自动 BCNF 化。
### 迁移验收
验收包含重复/NULL/不成立 FD 的拒绝、依赖不保持、跨目标约束、并发修改、撤权、名称占用、取消、空间不足,以及每个 WAL/文件发布边界的崩溃恢复;失败不得留下部分可见目标。
+22
View File
@@ -103,6 +103,8 @@ stack exec -- benchmark4csql 10000 50000
## 性能瓶颈分析
本节描述首次基准时的实现;事务差分优化后的结果见文末复测。
### 1. 事务提交的整库差分是首要排查点
本次 200 条事务 INSERT 比 200 次独立持久化 INSERT 慢约 60 倍。事务阶段开始时,数据库已有 10,000 用户、50,000 订单及 5,000 宽行,事务只修改 writes 表。事务内一次 400 行 UPDATE 仅耗时 0.5 ms,说明不能将整个事务阶段的 67.55 秒简单归因于 SQL 更新计算或 fsync。
@@ -132,3 +134,23 @@ stack exec -- benchmark4csql 10000 50000
## 使用范围
这是单机回环、主要为热缓存、管理员身份的单次基准,不是生产容量承诺。未覆盖远程网络、鉴权角色开销、崩溃恢复耗时、并发写冲突或大型宽表。七次读采样和单次写测量不足以建立统计置信区间,后续优化应使用相同参数、多次独立运行和分阶段 profile 比较。
## 2026-10-05 事务差分优化复测
使用相同机器、优化构建及 10,000 用户、50,000 订单规模运行完整基准,所有场景及结果校验通过(`BENCHMARK_OK`)。日志为 `logs/repair-txn-performance.log`。
COMMIT 跳过未修改表,以 IntMap / IntSet 查询整数键差分,冲突检查与操作生成共享差分;保持原行顺序及重复 id 的首行查找语义。
| 指标 | 耗时(ms) |
| --- | ---: |
| 200 次独立持久化 INSERT | 1,134.7 |
| 事务 200 条 INSERT 总计 | 687.355 |
| BEGIN | 269.806 |
| 事务内 200 条 INSERT | 41.129 |
| COMMIT | 376.345 |
事务总耗时从首次的 67,549.539 ms 降至 687.355 ms,约快 98 倍,吞吐从 2.96 升至 290.97 行/秒;本次事务写入约比逐条持久化快 1.65 倍。两次独立运行未建立统计置信区间,倍数仅描述这两次测量。
BEGIN 与 COMMIT 仍获取整库快照,合计约占事务总耗时的 94%;COMMIT 计时也包含差分、冲突检查和持久化,不能全部归因于快照。整库快照传输、修改表比较及刷盘仍需进一步分阶段测量。
20 个不同绑定的相关 EXISTS 平均 2,135.218 ms(首次 2,061.770 ms),该瓶颈仍存在,本轮没有改变子查询执行方式。
+31
View File
@@ -0,0 +1,31 @@
# 发布签名与验证设计
本文定义尚未实现的发行安全方案。当前操作见[安装文档](install.md),实施状态以 project-plan.txt 为准。先实现离线验证,再接入在线安装;该工作可独立于查询和存储扩展推进。
## 选择与信任入口
采用标准 TUF root/targets/snapshot/timestamp 元数据和 Ed25519 签名,使用经过维护的实现与标准测试向量,不自行定义签名 JSON 规范。Ed25519 算法依据 [RFC 8032](https://datatracker.ietf.org/doc/rfc8032/),角色、轮换、版本及过期验证依据 [TUF 规范](https://theupdateframework.github.io/specification/v1.0.36/)。SHA256 保留为产物散列,签名覆盖其可信元数据来源。
可信初始 root 随独立取得的安装器/验证器发布,记录版本与公钥;不能从同一个未认证下载响应接受任意公钥。首次下载安装器仍依赖用户可信取得该安装器这一入口,不能宣称脚本内公钥解决首次下载脚本被替换。升级客户端保存可信元数据的版本与过期状态,拒绝回退、混配和过期;状态缺失不等同于已完成反回退验证。
targets 绑定确切文件名、长度、SHA256、平台/架构、版本、提交号、组件清单与最低数据格式要求。snapshot 固定元数据版本/散列,timestamp 指向 snapshot。禁止通配匹配产物、跨平台替代和同版本静默覆盖;签名通过后才允许解包或执行 bootstrap。
## 密钥与发布操作
root 使用离线 2-of-3 阈值密钥,分开保管及加密备份;CI 不持有 root 私钥。targets 发布密钥限定于受保护发布环境,仅受信任标签与人工发布流程可调用;PR 构建、普通日志、构建缓存和发行包均不能读取私钥。snapshot/timestamp 使用独立在线密钥,权限和有效期按角色设置;拟定 targets/snapshot 30 天、timestamp 7 天、root 1 年,并通过到期监控续签。
轮换 root 按连续版本发布,同时满足旧 root 与新 root 阈值;离线备份定期做恢复演练。在线密钥泄露时停止发布,用 root 撤销并更换受影响角色密钥,重新生成元数据;所有 root 信任丢失时需要经独立可信渠道重新引导,不能靠损坏的 root 自证恢复。
发布顺序为构建与模块/所有者门禁 → 装配确切产物 → 计算散列 → 签 targets/snapshot → 上传产物和版本化元数据 → 最后发布 timestamp。任何产物字节变化均需重新签署。签名不证明构建内容正确,平台真机验收仍单列。
## 安装与兼容性
新增小型跨平台验证器,打包随安装器提供;验证器不可作为首个未验证的临时下载再立即执行。在线安装先验证元数据链、版本、有效期与目标平台,再下载并验长度/散列,之后才解包。签名缺失、密钥未知、元数据过期、系统时间无法可信校验等均明确失败,不降级成仅 SHA256。
本地离线安装使用随包 root 链、targets 和 snapshot 验证真实性与完整性;缺少在线 timestamp 时明确说明不能证明最新版本。离线模式必须显式选择且不联网;已有可信版本仍禁止回退,元数据过期仍失败,需要重新取得有效离线元数据。历史无签名包不纳入新安装器的可信安装路径。
系统原生代码签名分别设计接入 Windows Authenticode 和 macOS Developer ID/notarization;TUF 不能替代操作系统签名,第一阶段也不声称消除 SmartScreen/Gatekeeper 提示。Linux $ORIGIN、在线下载与 macOS 发行继续按现有实机待办验收。
## 验收条件
验收覆盖合法包、字节篡改、错误平台、截断、签名替换、重复键/非法元数据、未知密钥、过期、回退、元数据混配、连续 root 轮换/阈值不足、撤销、断网离线、下载中断与私钥日志检查;三平台从干净安装目录验证拒绝路径不会执行包内程序。
+15
View File
@@ -0,0 +1,15 @@
# ChuSQL v26.10.1
ChuSQL 是一个以 SQL 为主要接口的关系数据库,由 Haskell 查询引擎和 Rust 存储层组成。服务端管理数据与用户会话,用户可通过命令行客户端或浏览器中的 Web 界面访问。
这是 ChuSQL 的第一个正式发布版,提供建表、数据增删改查、连接、聚合、子查询和 CTE,以及索引、查询优化、事务、保存点、WAL 崩溃恢复和用户/角色授权。
本版还提供运行时类型与函数基础:支持 String、List、Maybe、Tuple 等类型,以及 length、not 函数;复合值可通过 SQL 构造、查询和持久化,CLI 与 Web 均可显示。
发行包支持 Windows x86_64 和 Linux x86_64,包含数据库服务端、初始化工具、CLI、Web 界面和安装/卸载脚本。下载下方压缩包,使用包内 install.ps1(Windows)或 install.sh(Linux)安装,可选择 CLI 或 Web 组件,无需自行安装 Haskell 或 Rust 工具链。每个包附 SHA256 校验文件。
安装与操作说明:[安装指南](https://github.com/TheBadRoger/ChuSQL/blob/v26.10.1/docs/install.md)、[SQL 语法](https://github.com/TheBadRoger/ChuSQL/blob/v26.10.1/docs/syntax.md)、[运行时类型](https://github.com/TheBadRoger/ChuSQL/blob/v26.10.1/docs/runtime-types.md)。
首版适合学习、开发和小规模内部应用试点。事务采用整库内存快照,同库写入串行;DECIMAL 使用浮点表示;尚无运行时类型的完整比较/索引能力。关键业务上线前应完成真实负载测试及备份恢复演练。升级已有数据前请备份,并避免用旧二进制打开新增类型的数据。
本版已通过所有者全量门禁;发布流程要求 Linux 测试与两个平台的发行包安装验证全部成功后上传正式下载包。
+65
View File
@@ -0,0 +1,65 @@
# 运行时类型与函数基础
阶段 A 提供固定身份的内建类型、函数注册表、schema 驱动的绑定和类型化查询入口。
完整 capability、运算符注册、转换、用户 ADT 与 Extension 留在后续阶段。
## SQL 使用
```sql
CREATE TABLE typed_values (
id Int,
name String,
numbers [Int],
label Maybe String,
pair (Int, String)
);
INSERT INTO typed_values (id, name, numbers, label, pair)
VALUES (1, 'abc', LIST<Int>(1, 2), MAYBE<String>(), TUPLE<Int, String>(3, 'x'));
SELECT length(name), numbers, label, pair FROM typed_values;
UPDATE typed_values SET numbers = LIST<Int>(9), label = MAYBE<String>('ready') WHERE id = 1;
SELECT LIST<Maybe Int>(MAYBE<Int>(), MAYBE<Int>(42));
SELECT not(TRUE), length('你好');
```
类型语法支持 `Int`、`Double`、`Bool`、`String`、`[a]` / `List a`、`Maybe a` 和 `(a, b, ...)`。
构造器中的类型参数是完整逻辑类型;空列表和 Nothing 也有确定类型。
`MAYBE<a>()` 表示 Nothing,`MAYBE<a>(value)` 表示 Just;不能用 SQL NULL 代替复合值内部的 Nothing。
SQL 可空列仍接受 NULL,和 Maybe 的 Nothing 保持区别。
构造器按完整类型校验,不隐式转换 List 的元素类型。
内建签名为 `length :: String -> Int` 和 `not :: Bool -> Bool`,名称不区分大小写。
SQL 参数为 NULL 时结果为 NULL;具体非空参数仍校验类型。
尚无运行时 Eq / Ord / Hash 字典,复合类型的比较、排序、分组、极值和索引不会自动取得能力。
Web 显示复合值及 SQL 构造器预览,复合字段通过 SQL 控制台修改。
## 身份与编码
`ChuSQL.Core.Runtime` 是共享模型中的权威定义;Engine 模块导出同一组身份。
内建构造器编号固定为 Int=1、Double=2、Bool=3、String=4、List=5、Maybe=6、Tuple=7。
TypeId 包含已校验的完整构造器应用,比较和恢复不依赖注册顺序或随机哈希。
FunctionId 固定为 length=1、not=2;内建元数据可直接重建注册表。
逻辑 TypeExpr 与 PhysicalType 分开;List、Maybe、Tuple 使用递归 sequence、optional、product 表示。
schema 保存版本化的 TypeId,协议值保存版本、类型身份和 payload;包括 String 在内的运行时值共用编码。
Rust 的通用行、目录和 WAL 路径保存该表示,读取时由共享模型验证版本、类型、元素和字段个数。
未知版本、身份溢出、类型不符、非有限浮点数及损坏 payload 明确返回错误。
内建类型不可删除,复合类型的依赖完整包含在 TypeExpr 中。
旧标量 schema 和协议继续读取;包含运行时类型的数据不能交给不支持该编码的旧客户端。
## 绑定与执行
`Runtime.Binding` 提供独立的 TypedExpression 和 TypedPlan,绑定只接受 catalog schema。
表达式和计划构造器隐藏,调用者必须经过 Binder;执行使用已解析的 TypeId / FunctionId,并校验存储行。
该 API 覆盖单行、表扫描、投影和过滤,可构造嵌套复合值及函数调用。
SQL SELECT 通过 `Runtime.Query.bindQuery` 生成不可直接构造的 BoundQuery,再由 `executeQueryM` 执行。
绑定计划保存输出 schema 与类型身份;现有 RelOp 作为关系执行和优化的兼容桥,输出按位置校验,保留重复别名。
类型化函数和构造器节点也进入 INSERT、UPDATE、CHECK、聚合参数和子查询。
日期、时间戳、Blob 等阶段 A 外的类型保留明确的 CompatibilityType。
旧 ColumnType 和运算符实现尚未整体移除;统一 capability、cast 和 rewrite 将在后续阶段收拢。
测试覆盖稳定编码、kind / 参数校验、共享协议、SQL 调用和复合列、实际存储重载、HTTP/TCP 与客户端显示。
+13 -3
View File
@@ -136,13 +136,21 @@ REVOKE reviewer FROM alice;
DROP ROLE analyst;
```
当前表级权限包括:`SELECT`、`INSERT`、`UPDATE`、`DELETE` 和 `ALL`。
表级权限包括 `SELECT`、`INSERT`、`UPDATE`、`DELETE`;数据库权限包括 `CONNECT`、`CREATE`。`ALL` 按对象类型展开。未限定的表名及 `*` 使用当前数据库,`库名.表名` 和 `库名.*` 可指定其他数据库;系统对象不能通过业务 GRANT 授权。
```sql
REVOKE CONNECT ON DATABASE sales FROM PUBLIC;
GRANT CONNECT, CREATE ON DATABASE sales TO analyst;
GRANT SELECT ON TABLE sales.orders TO reviewer WITH GRANT OPTION;
GRANT SELECT ON sales.* TO analyst;
REVOKE SELECT ON sales.orders FROM reviewer;
```
角色可以互相继承:`GRANT analyst TO reviewer` 让 `reviewer` 成为 `analyst` 的成员并取得其授权;继承会沿成员关系传递,成环的授权被拒绝(报 `conflict`),自继承同样拒绝。用户也可以直接接受表级授权或作为其他角色的成员。
管理员拥有完整权限;数据库、表、索引等结构管理操作仅允许管理员执行。
最高权限身份拥有完整权限。数据库默认向 PUBLIC 开放 CONNECT,不默认授予 CREATE 或数据权限。具有数据库 CREATE 的身份可建表,并成为新表所有者;表所有者可管理表、字段及索引,并授予该表权限。数据库所有者可删除自己的数据库,创建数据库与管理 DOMAIN 仍要求最高权限。
`GRANT ... WITH GRANT OPTION` 让拿到的授权可以再转授:普通身份只有手里那条授权带 grant option 时才能执行 `GRANT`,报错是 `grant option required: <权限> ON <表>`;`REVOKE` 仍然只允许管理员,收回授权会连它的 grant option 一起收掉,且不会级联收回别人转授出去的授权。转授权随角色继承一起传递。
`GRANT ... WITH GRANT OPTION` 允许再转授;所有者也可授予自身对象的权限。普通授予者可撤销自己的授予,所有者及最高权限身份可撤销对象上的其他授予。撤销时收回相应 grant option,并级联清理失去合法来源的下游授权;仍有独立来源的授权保留。转授权能力随启用的角色继承,循环转授不能独立维持权限。REVOKE 不移除所有者的隐含权限。
系统目录访问还受目录管理属性控制,具体能力见 [用户与角色](users-and-roles.md)。
@@ -152,4 +160,6 @@ DROP ROLE analyst;
```sql
ALTER USER alice SYSTEM_CATALOG_MANAGER;
ALTER USER alice NOSYSTEM_CATALOG_MANAGER;
ALTER USER alice ALLOW_SUDO_AUTH;
ALTER USER alice NOALLOW_SUDO_AUTH;
```
+20
View File
@@ -46,3 +46,23 @@ DOMAIN 按数据库保存,保留名称并复用基础类型的校验与运算
该目录是受保护的系统元数据,普通 SQL 不直接展示或修改它。类型执行语义由引擎实现,不能通过手工增加目录行获得新的基础类型。安装登记不会创建任何预定义 DOMAIN;DOMAIN 定义另存于各工作库的 catalog。
首次安装完成管理员初始化后登记类型。重复引导保留一致的记录并补齐缺失项;同名定义冲突会报错,停止安装启动流程,不覆盖现有定义。
## DOMAIN 约束设计(尚未实现)
以下约束与 ALTER 能力是后续设计,当前 DOMAIN 仍只提供类型命名。实施依赖 [bound IR](architecture.md#bound-ir),先固化类型、列身份与表达式求值规则。
### 约束与默认值语义
定义扩展为基础类型引用、可选 DEFAULT、NOT NULL、命名 CHECK 及定义版本。CHECK 只接受绑定的单值 `VALUE` 表达式和确定性内置函数,禁止子查询、表引用和自定义副作用函数;CHECK 的 false 拒绝,unknown 允许,NOT NULL 独立拒绝 NULL。嵌套领域从底层向外校验,约束取交集;显式列默认优先,否则使用最近外层有定义的领域默认,只在省略列值时使用,不替换显式 NULL。
### 引擎与存储校验
server/engine 负责绑定;Rust 存储根据版本化约束 IR 在全部写入口再次验证,包含批写、原始请求和迁移。两层必须共享运算符标识、类型及 NULL 规则并用相同测试向量验证;不能让 Rust 重新解析 SQL 或只依赖客户端验证。解析诊断不得吞错。
### 结构变更与持久化
首版仅支持 CREATE 带约束与 ALTER 添加经全量验证的约束、修改默认;不支持 NOT VALID 或 CASCADE。ALTER 在稳定 schema/数据视图中校验所有直接和间接使用列,短锁发布前复查版本;失败不改变定义。类型定义、依赖版本和受影响 schema 同一 WAL 组提交。现有 DOMAIN 空目录表升级为明确版本元数据,旧编码读入并转换,拒绝无法解析的定义。
### 验收条件
验收覆盖嵌套默认优先级、三值 CHECK、NULL、批写全回退、领域改变并发写、循环/间接依赖、内存事务提交与 WAL 重放。新约束加入既有事务后,提交必须按最新定义重新验证或报 schema 冲突。
+66 -3
View File
@@ -10,6 +10,7 @@ ChuSQL 的用户和角色共用一套身份目录及名称空间。用户是允
| --- | --- | --- |
| `can_login` | `true` | 可以使用账号及口令登录 |
| `is_superuser` | `true` | 具有系统管理及数据访问的最高权限 |
| `allow_sudo_auth` | `false` | 允许经本机提升身份验证后免数据库口令登录;不赋予权限 |
| `system_catalog_manager` | `false` | 独立目录管理属性;SUPERUSER 本身已具有有效目录管理能力 |
| `enabled` | `true` | 身份处于启用状态 |
@@ -29,9 +30,9 @@ ChuSQL 的用户和角色共用一套身份目录及名称空间。用户是允
身份创建与修改语法见 [SQL 语法](syntax.md#账号与权限)。
`ALTER USER` 与 `ALTER ROLE` 的属性、口令修改语法通用。可使用 `LOGIN / NOLOGIN`、`SUPERUSER / NOSUPERUSER`、`ENABLED / DISABLED`、`SYSTEM_CATALOG_MANAGER / NOSYSTEM_CATALOG_MANAGER`;同一条语句不能重复指定同一属性。
`ALTER USER` 与 `ALTER ROLE` 的属性、口令修改语法通用。可使用 `LOGIN / NOLOGIN`、`SUPERUSER / NOSUPERUSER`、`ENABLED / DISABLED`、`SYSTEM_CATALOG_MANAGER / NOSYSTEM_CATALOG_MANAGER`、`ALLOW_SUDO_AUTH / NOALLOW_SUDO_AUTH`;同一条语句不能重复指定同一属性。
SUPERUSER 可设置目录管理属性。该属性默认为 false,不经成员关系继承;只有自身启用且允许登录的身份能使用它。目录管理者可以进入 system 库、查看身份目录、创建普通身份、修改普通身份属性与口令及删除普通用户身份。它不能管理 SUPERUSER 或其他目录管理者,不能授予这两个特权属性,不能执行 `DROP ROLE`,也不会因此获得创建业务数据库、直接修改系统表或读取业务数据的权限。受限身份变更在存储写锁内再次检查目标权限。
SUPERUSER 可设置目录管理属性。该属性默认为 false,不经成员关系继承;只有自身启用且允许登录的身份能使用它。目录管理者可以进入 system 库、查看身份目录、创建普通身份、修改普通身份属性与口令及删除普通用户身份。它不能管理 SUPERUSER、其他目录管理者或启用 sudo 认证的身份,不能授予这三个特权属性,不能执行 `DROP ROLE`,也不会因此获得创建业务数据库、直接修改系统表或读取业务数据的权限。受限身份变更在存储写锁内再次检查目标权限。
## 全部身份及凭据字段
@@ -44,6 +45,7 @@ SUPERUSER 可设置目录管理属性。该属性默认为 false,不经成员
| `can_login` | 是否允许直接登录;仅允许登录仍不足以保证登录成功,还需启用及正确口令 | `LOGIN / NOLOGIN` |
| `is_superuser` | 是否具有最高权限;不通过角色成员关系继承 | `SUPERUSER / NOSUPERUSER` |
| `system_catalog_manager` | 是否具有受限的系统目录管理能力;不继承、不替代数据访问授权 | `SYSTEM_CATALOG_MANAGER / NOSYSTEM_CATALOG_MANAGER`,仅 SUPERUSER 可设置 |
| `allow_sudo_auth` | 是否接受受信任本机提升身份认证;默认 false,不继承,不改变业务权限 | `ALLOW_SUDO_AUTH / NOALLOW_SUDO_AUTH`,仅 SUPERUSER 可设置 |
| `enabled` | 是否启用身份;禁用后不能登录,也不再贡献角色继承权限 | `ENABLED / DISABLED` |
| `identity_version` | 身份目录格式与旧数据迁移标记;旧记录可为 0,当前统一身份格式为 1 | 系统维护;不是会话版本 |
| `registered_at` | 身份创建时间;旧记录缺失时由迁移补齐 | 系统记录 |
@@ -55,7 +57,68 @@ SUPERUSER 可设置目录管理属性。该属性默认为 false,不经成员
| `id` | 对应身份目录中的编号 |
| `password_hash` | 口令哈希,不是明文口令;通过口令修改命令更新 |
内部账号协议可将身份字段和 `password_hash` 合并为账号对象,但哈希不属于公开的角色展示内容。`SHOW ROLES` 展示全部身份的编号、名称、登录能力、最高权限、启用状态、目录管理属性和创建时间,不返回口令哈希,也不展示全部内部字段。系统表由身份管理接口维护,不应直接修改。
内部账号协议可将身份字段和 `password_hash` 合并为账号对象,但哈希不属于公开的角色展示内容。`SHOW ROLES` 展示全部身份的编号、名称、登录能力、最高权限、启用状态、目录管理属性、sudo 认证开关和创建时间,不返回口令哈希,也不展示全部内部字段。系统表由身份管理接口维护,不应直接修改。
## 本机 sudo 认证
此入口适用于 Linux、macOS 和 Windows,默认关闭。Unix 有效 UID 0(通常通过 sudo 获得)映射到 `[server] sudo_auth_user`;Windows 提升令牌中的 Administrators 成员映射到同一配置身份。不会使用客户端上报的操作系统用户名、`SUDO_USER`、数据库用户名或角色属性作为操作系统身份凭据。
先用数据库 SUPERUSER 配置目标身份,例如:
```sql
ALTER USER local_operator ALLOW_SUDO_AUTH;
```
目标身份仍需 `LOGIN` 与 `ENABLED`;按需要另行授予业务权限。即使它是普通身份,sudo 登录也只获得该身份已有的权限。`SUPERUSER` 和 `SYSTEM_CATALOG_MANAGER` 不会隐含允许 sudo 登录。
在服务端与 CLI 使用的配置中显式设置映射:
```toml
[server]
sudo_auth_user = "local_operator"
```
停止原服务后,以 Unix root 或 Windows 提升后的管理员重启 `chusql-server`,使用受管理员保护的配置文件、数据目录和程序路径。以相同提升身份运行 CLI;Unix 示例:
```sh
sudo csql --config /absolute/path/settings.toml --sudo -e "SELECT 1"
```
Windows 在提升的终端中运行 `csql --config C:\absolute\path\settings.toml --sudo -e "SELECT 1"`。`--sudo` 不读取数据库口令,省略 `--user` 时使用配置映射。显式指定其他账号也不能绕过服务端映射。普通 TCP/CLI 口令登录与 Web 登录保持原有口令认证;远程连接无法请求此入口,CLI 也校验实际连接对端为回环地址。
服务启动时产生独立随机凭据。Unix 放在 `/var/run/chusql-sudo-<实际端口>/credential`,目录 root 所有且为 0700,文件为 0600;Windows 放在系统目录的 `config\ChuSQL-Sudo-<实际端口>\credential`,使用不继承的 Administrators / SYSTEM 专属 DACL。读取入口检查当前进程提升身份;Unix 还验证文件所有权、权限和类型,拒绝链接,Windows 拒绝重解析路径。凭据不会传输到网络,CLI 使用 HMAC-SHA256 回应绑定连接、账号和服务实例的一次性随机挑战;挑战 60 秒后过期,每次认证尝试都会消费挑战,失败按账号限流。
服务端在 stderr 记录启用映射和认证结果,不记录凭据或证明。成功登录更新身份目录的 `last_login_at`。`ALTER USER local_operator NOALLOW_SUDO_AUTH`、`DISABLED`、`NOLOGIN`、修改口令或删除身份都会使既有连接在下一次请求时失效。映射配置清空并重启服务后,本机入口关闭。
正常停止服务时清理凭据。异常退出可能留下端口专属目录;再次启用会明确报错,不读取或覆盖旧凭据。确认对应服务已停止后,由提升身份清理该目录再启动;不要把凭据复制到普通账号可访问的目录。
## 对象授权
业务授权绑定数据库编号与表编号,身份与所有者绑定身份编号。删除后重建同名数据库、表或身份会获得新编号,旧授权不会随名称恢复。对象存在性以 catalog 为准;不同数据库的同名表互不共享授权。
| 对象范围 | 权限 | 默认与所有者能力 |
| --- | --- | --- |
| DATABASE 库名 | CONNECT、CREATE | PUBLIC 默认 CONNECT;CREATE 允许建表;数据库所有者可管理该数据库 |
| TABLE 库名.表名 | SELECT、INSERT、UPDATE、DELETE | 默认无数据权限;表所有者拥有四项数据权限、结构管理及转授权能力 |
| 库名.* | 四项表级数据权限 | 覆盖该数据库内现有及未来的表;不包含数据库 CREATE |
`ALL` 按对象范围展开。未限定表名与 `*` 绑定当前数据库。数据库所有权不自动赋予其他身份所建表的数据权限;启用的所有者角色可以通过成员关系贡献所有权,最高权限属性仍不继承。创建数据库及管理 DOMAIN 仍要求 SUPERUSER;所有权不能通过 REVOKE 移除,当前没有所有权转移命令。
```sql
REVOKE CONNECT ON DATABASE sales FROM PUBLIC;
GRANT CONNECT, CREATE ON DATABASE sales TO analyst;
GRANT SELECT ON TABLE sales.orders TO reader WITH GRANT OPTION;
GRANT SELECT ON sales.* TO analyst;
REVOKE SELECT ON sales.orders FROM reader;
```
PUBLIC 是所有身份共享的虚拟角色,不能新建同名用户或角色。已有同名旧身份仍按真实身份编号解析,删除该身份后才使用虚拟 PUBLIC。撤销 PUBLIC CONNECT 会关闭数据库的默认连接权限,其他显式 CONNECT 或数据库所有权仍有效;重新授予会恢复默认连接权限。
每次授予记录授予者。普通身份须持有有效 grant option 或对象所有权,可撤销自己的授予;所有者和 SUPERUSER 可撤销对象上的其他来源。撤销、删除身份或成员变更会清理失去合法来源的转授权链;其他独立来源保留,循环转授不能维持失去根来源的权限。禁用身份暂停权限贡献,保留所有权及管理员直接授权;失去启用授予者的下游转授权会被清理。
旧名称授权在首次启动时一次性绑定现存对象和身份编号。旧记录不含授予者,迁移为管理来源;旧全局 `*` 仅转换成当时现存表的明确授权,不扩展到未来对象。已经不存在的对象和身份记录被清理。迁移后不再读取旧名称授权作为鉴权依据。
权限快照位于受保护系统目录,经 WAL 原子保存;普通存储请求不能访问该目录。SQL、TCP 和 Web 使用同一服务端检查;TCP 原始存储入口仅允许 SUPERUSER。查询与授权变更通过共享读写锁排序,建表前持久化创建者声明供重启恢复所有权。事务提交重新检查权限和稳定对象编号,权限撤销或对象替换后不能提交旧事务。
## 属性、授权与会话的关系
+3
View File
@@ -35,6 +35,9 @@ port = 7777
max_message = 1048576
# Maximum number of rows returned by a query through the database server.
max_rows = 1000
# Local elevated OS identity mapping; empty disables sudo authentication.
# Requires ALLOW_SUDO_AUTH on the identity and an elevated server process.
sudo_auth_user = ""
[log]
# Diagnostic verbosity: off, error, warn, info or debug.
+3
View File
@@ -35,6 +35,9 @@ port = 7777
max_message = 1048576
# Maximum number of rows returned by a query through the database server.
max_rows = 1000
# Local elevated OS identity mapping; empty disables sudo authentication.
# Requires ALLOW_SUDO_AUTH on the identity and an elevated server process.
sudo_auth_user = ""
[log]
# Diagnostic verbosity: off, error, warn, info or debug.
+66 -3
View File
@@ -2,7 +2,7 @@
set -eu
# ChuSQL 安装脚本(Linux/macOS):装 cli/web、写全局配置、
# 改 PATH、跑 csql-bootstrap 建系统目录、最后拉起服务。
# 改 PATH、初始化系统目录,Linux 注册开机启动服务。
default_repo='TheBadRoger/ChuSQL'
@@ -42,6 +42,7 @@ usage: ./install.sh [--component web|cli|both] [options]
there is no terminal to ask on; shows up in the shell
history, so CHUSQL_ADMIN_PASSWORD is safer)
--no-start do not start the server after installing
--no-service skip Linux systemd registration and boot autostart
where the files come from:
(default) a package next to this script, else the newest GitHub release
@@ -71,6 +72,7 @@ root_user='root'
keep_package='no'
password_arg=''
no_start='no'
no_service='no'
repo="$default_repo"
version='latest'
url_arg=''
@@ -90,6 +92,7 @@ while [ $# -gt 0 ]; do
--keep-package) keep_package='yes'; shift ;;
--password) password_arg="${2:-}"; shift 2 ;;
--no-start) no_start='yes'; shift ;;
--no-service) no_service='yes'; shift ;;
--url) url_arg="${2:-}"; shift 2 ;;
--repo) repo="${2:-}"; shift 2 ;;
--version) version="${2:-}"; shift 2 ;;
@@ -617,8 +620,23 @@ echo " root user $root_user (password asked above, kept out of settings.toml)"
# ---- 释放文件 ----
# 包是合在一起的(web 和 cli 都在),这里按这次的选择逐个释放:没选的组件不落地
service_file="${XDG_CONFIG_HOME:-$HOME/.config}/systemd/user/chusql-server.service"
use_service='no'
if [ "$(uname -s)" = 'Linux' ] && [ "$no_service" = 'no' ]; then
command -v systemctl >/dev/null 2>&1 || fail 'systemd is required; use --no-service to opt out'
command -v loginctl >/dev/null 2>&1 || fail 'loginctl is required for boot autostart'
systemctl --user show-environment >/dev/null || fail 'cannot connect to user systemd; run in a login session or use --no-service'
loginctl enable-linger "$(id -un)" || fail 'cannot enable boot autostart; run sudo loginctl enable-linger for this OS user and retry'
use_service='yes'
if [ -f "$service_file" ]; then
systemctl --user stop chusql-server.service || fail 'cannot stop the existing service'
fi
fi
step 'Installing files'
mkdir -p "$install_dir/bin" "$log_dir" "$data_dir"
install_dir=$(CDPATH= cd -- "$install_dir" && pwd)
data_dir=$(CDPATH= cd -- "$data_dir" && pwd)
log_dir=$(CDPATH= cd -- "$log_dir" && pwd)
cp "$pack/bin/chusql-server" "$install_dir/bin/"
cp "$pack/bin/csql-bootstrap" "$install_dir/bin/"
for lib in "$pack/bin/"libchusql_core_storage.*; do
@@ -646,6 +664,8 @@ step 'Writing settings.toml'
config_dir="${XDG_CONFIG_HOME:-$HOME/.config}/ChuSQL"
config_file="$config_dir/settings.toml"
mkdir -p "$config_dir"
config_dir=$(CDPATH= cd -- "$config_dir" && pwd)
config_file="$config_dir/settings.toml"
sed -e "s|@DATA_DIR@|$(printf '%s' "$data_dir" | sed 's/[\&|]/\\&/g')|g" \
-e "s|@LOG_DIR@|$(printf '%s' "$log_dir" | sed 's/[\&|]/\\&/g')|g" \
"$pack/resources/settings.toml.linux" > "$config_file"
@@ -714,7 +734,46 @@ fi
# ---- 拉起服务 ----
server_bin="$install_dir/bin/chusql-server"
server_pid=''
if [ "$no_start" = 'yes' ]; then
if [ "$use_service" = 'yes' ]; then
step 'Registering the systemd service and boot autostart'
for service_arg in "$install_dir" "$server_bin" "$config_file" "$root_user"; do
case "$service_arg" in
*"
"*) fail 'service arguments must not contain newlines' ;;
esac
done
mkdir -p "$(dirname "$service_file")"
# 转义 systemd 双引号参数与变量符号。
unit_quote() {
printf '%s' "$1" | sed 's/\\/\\\\/g; s/"/\\"/g; s/%/%%/g'
}
cat > "$service_file" <<EOF
[Unit]
Description=ChuSQL database server
[Service]
Type=simple
WorkingDirectory="$(unit_quote "$install_dir")"
ExecStart=:"$(unit_quote "$server_bin")" --config "$(unit_quote "$config_file")" --user "$(unit_quote "$root_user")"
Restart=on-failure
RestartSec=5
StandardOutput=journal
StandardError=journal
[Install]
WantedBy=default.target
EOF
systemctl --user daemon-reload || fail 'cannot reload systemd units'
systemctl --user enable chusql-server.service || fail 'cannot enable boot autostart'
if [ "$no_start" = 'yes' ]; then
note '--no-start: boot autostart enabled; the server was not started'
else
systemctl --user restart chusql-server.service || fail 'cannot start chusql-server.service'
sleep 1
systemctl --user is-active --quiet chusql-server.service || fail 'the server stopped; run journalctl --user -u chusql-server.service'
note 'server running under systemd'
fi
elif [ "$no_start" = 'yes' ]; then
note '--no-start: the server was not started'
else
step 'Starting the server'
@@ -739,7 +798,11 @@ if [ "$want_cli" = 'yes' ]; then
fi
echo " start with $start_with"
echo " tcp server $server_bin (listens on [server] listen_host/port, defaults 127.0.0.1:7777)"
if [ -n "$server_pid" ]; then
if [ "$use_service" = 'yes' ]; then
echo ' service chusql-server.service (boot autostart enabled)'
echo ' manage systemctl --user status|start|stop|restart chusql-server.service'
echo ' logs journalctl --user -u chusql-server.service'
elif [ -n "$server_pid" ]; then
echo " running pid $server_pid (stop it with: kill $server_pid)"
else
echo " start it $server_bin --config \"$config_file\" --user $root_user"
+10 -4
View File
@@ -119,10 +119,11 @@ verify_package() {
rm -rf "$vtmp"
Fail "$name: the archive does not unpack"
fi
if ! ( cd "$vtmp/pkg" && HOME="$vtmp/home" CHUSQL_ADMIN_PASSWORD='verify-package' \
if ! ( cd "$vtmp/pkg" && HOME="$vtmp/home" XDG_CONFIG_HOME="$vtmp/home/.config" \
XDG_STATE_HOME="$vtmp/home/.local/state" CHUSQL_ADMIN_PASSWORD='verify-package' \
sh install.sh --component "$comp" \
--install-dir "$vtmp/opt" --data-dir "$vtmp/data" --user root \
--no-start ) \
--no-start --no-service ) \
>"$vtmp/log" 2>&1; then
sed -n '1,120p' "$vtmp/log" >&2
rm -rf "$vtmp"
@@ -188,8 +189,13 @@ Step "Packing $name"
rm -rf "$out_dir/.stage"
mkdir -p "$stage/bin" "$stage/resources"
cp "$repo_root/chusql-core/storage/target/release/"libchusql_core_storage.* "$stage/bin/" \
|| Fail "chusql-core/storage/target/release/libchusql_core_storage.* is not built (run without --no-build)"
case "$platform" in
linux-*) storage_name=libchusql_core_storage.so ;;
macos-*) storage_name=libchusql_core_storage.dylib ;;
*) Fail "unsupported Unix platform: $platform" ;;
esac
cp "$repo_root/chusql-core/storage/target/release/$storage_name" "$stage/bin/" \
|| Fail "$storage_name is not built (run without --no-build)"
stack_root=$(cd "$repo_root/chusql-cli" && stack path --local-install-root | tail -n 1 | tr -d '\r')
for front_name in chusql-web chusql-server csql; do
+7
View File
@@ -94,6 +94,13 @@ if [ "$assume_yes" = 'no' ]; then
fi
step 'Stopping the service'
service_file="${XDG_CONFIG_HOME:-$HOME/.config}/systemd/user/chusql-server.service"
if [ "$(uname -s)" = 'Linux' ] && [ -f "$service_file" ]; then
command -v systemctl >/dev/null 2>&1 || fail 'systemctl is required to remove the service'
systemctl --user disable --now chusql-server.service || fail 'cannot stop and disable chusql-server.service'
rm -f "$service_file"
systemctl --user daemon-reload || fail 'cannot reload systemd units'
fi
stop_by_path "$install_dir/bin/chusql-server"
stop_by_path "$install_dir/bin/chusql-web"
-55
View File
@@ -1,55 +0,0 @@
param([string]$Root = (Split-Path -Parent $PSScriptRoot))
$ErrorActionPreference = 'Stop'
# 统计物理行数并生成 README 统一风格的本地 SVG 徽章。
# 生成带文字和色块的本地徽章。
function Write-Badge([string]$Directory, [string]$Name, [string]$Label, [string]$Value, [string]$Color, [string]$Description) {
$leftWidth = [int]($Label.Length * 7 + 24)
$rightWidth = [int]($Value.Length * 7 + 24)
$width = $leftWidth + $rightWidth
$leftCenter = $leftWidth / 2
$rightCenter = $leftWidth + $rightWidth / 2
$safeLabel = [Security.SecurityElement]::Escape($Label)
$safeValue = [Security.SecurityElement]::Escape($Value)
$safeDescription = [Security.SecurityElement]::Escape($Description)
$svg = @"
<svg xmlns="http://www.w3.org/2000/svg" width="$width" height="24" viewBox="0 0 $width 24" role="img" aria-label="$safeLabel`: $safeValue">
<title>$safeDescription</title>
<defs><clipPath id="rounded"><rect width="$width" height="24" rx="5"/></clipPath></defs>
<g clip-path="url(#rounded)"><rect width="$width" height="24" fill="#1e293b"/><rect x="$leftWidth" width="$rightWidth" height="24" fill="$Color"/></g>
<g fill="#fff" text-anchor="middle" font-family="Verdana,DejaVu Sans,sans-serif" font-size="11"><text x="$leftCenter" y="16">$safeLabel</text><text x="$rightCenter" y="16">$safeValue</text></g>
</svg>
"@
Set-Content -LiteralPath (Join-Path $Directory "$Name.svg") -Value $svg -Encoding utf8
}
Push-Location -LiteralPath $Root
try {
$paths = @(& git ls-files --cached --others --exclude-standard)
if ($LASTEXITCODE -ne 0) { throw 'git ls-files failed' }
$lines = 0
$files = 0
foreach ($path in ($paths | Sort-Object -Unique)) {
if ($path -notmatch '\.(hs|rs|js|css|html|ps1|sh)$') { continue }
if (-not (Test-Path -LiteralPath $path -PathType Leaf)) { continue }
$lines += @(Get-Content -LiteralPath $path).Count
$files++
}
$label = $lines.ToString('N0', [Globalization.CultureInfo]::InvariantCulture)
$badgeDir = Join-Path $Root 'docs/badges'
[IO.Directory]::CreateDirectory($badgeDir) | Out-Null
$revision = & git rev-parse --short HEAD
if ($LASTEXITCODE -ne 0) { throw 'git rev-parse failed' }
Write-Badge $badgeDir 'lines' 'source lines' $label '#0369a1' 'Physical source lines; includes tests, comments and blank lines.'
Write-Badge $badgeDir 'release' 'release' 'browse' '#6d28d9' 'Open GitHub releases to view published versions.'
Write-Badge $badgeDir 'commit' 'commit' $revision '#475569' 'Local HEAD snapshot when the badges were generated; open commit history for latest updates.'
Write-Badge $badgeDir 'languages' 'languages' 'Haskell + Rust' '#6d28d9' 'ChuSQL implementation languages: Haskell and Rust.'
Write-Badge $badgeDir 'build' 'build' 'view status' '#0369a1' 'Open the build workflow for live status; this local badge is a navigation link.'
Write-Badge $badgeDir 'tests' 'tests' 'view status' '#0369a1' 'Open the test workflow for live status; this local badge is a navigation link.'
Write-Badge $badgeDir 'gate' 'gate' 'manual status' '#b45309' 'Open the owner-triggered gate workflow for status; this local badge is a navigation link.'
Write-Output "source_lines=$lines source_files=$files"
} finally {
Pop-Location
}