From a9ef1ef3e2c6c05d27ae1209035347b6c543116c Mon Sep 17 00:00:00 2001 From: LIm1tZz7 <36764786+TheBadRoger@users.noreply.github.com> Date: Sat, 19 Sep 2026 19:22:50 +0800 Subject: [PATCH] =?UTF-8?q?=E5=AE=8C=E6=88=90Haskell=E9=83=A8=E5=88=86?= =?UTF-8?q?=E7=9A=84SQL=E8=AF=8D=E6=B3=95=E5=88=86=E6=9E=90=E5=99=A8?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .gitignore | 85 +++ .zed/tasks.json | 34 + LICENSE | 21 + README.md | 44 ++ chusql-engine/app/Main.hs | 52 ++ chusql-engine/chusql-engine.cabal | 40 ++ chusql-engine/src/ChuSQL/Algebra/.gitkeep | 0 chusql-engine/src/ChuSQL/Eval/Executor.hs | 104 +++ chusql-engine/src/ChuSQL/Eval/Expr.hs | 48 ++ chusql-engine/src/ChuSQL/Eval/Sort.hs | 37 ++ chusql-engine/src/ChuSQL/Model.hs | 22 + chusql-engine/src/ChuSQL/Semantic/.gitkeep | 0 chusql-engine/src/ChuSQL/Storage/.gitkeep | 0 chusql-engine/src/ChuSQL/Syntax/Ast.hs | 42 ++ chusql-engine/src/ChuSQL/Syntax/Parser.hs | 213 +++++++ chusql-engine/stack.yaml | 4 + chusql-engine/stack.yaml.lock | 12 + chusql-engine/test/Spec.hs | 702 +++++++++++++++++++++ chusql-storage/.gitkeep | 0 chusql-web/.gitkeep | 0 docs/INTRODUCTION.md | 87 +++ 21 files changed, 1547 insertions(+) create mode 100644 .gitignore create mode 100644 .zed/tasks.json create mode 100644 LICENSE create mode 100644 README.md create mode 100644 chusql-engine/app/Main.hs create mode 100644 chusql-engine/chusql-engine.cabal create mode 100644 chusql-engine/src/ChuSQL/Algebra/.gitkeep create mode 100644 chusql-engine/src/ChuSQL/Eval/Executor.hs create mode 100644 chusql-engine/src/ChuSQL/Eval/Expr.hs create mode 100644 chusql-engine/src/ChuSQL/Eval/Sort.hs create mode 100644 chusql-engine/src/ChuSQL/Model.hs create mode 100644 chusql-engine/src/ChuSQL/Semantic/.gitkeep create mode 100644 chusql-engine/src/ChuSQL/Storage/.gitkeep create mode 100644 chusql-engine/src/ChuSQL/Syntax/Ast.hs create mode 100644 chusql-engine/src/ChuSQL/Syntax/Parser.hs create mode 100644 chusql-engine/stack.yaml create mode 100644 chusql-engine/stack.yaml.lock create mode 100644 chusql-engine/test/Spec.hs create mode 100644 chusql-storage/.gitkeep create mode 100644 chusql-web/.gitkeep create mode 100644 docs/INTRODUCTION.md diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..349758d --- /dev/null +++ b/.gitignore @@ -0,0 +1,85 @@ +# ============================================================ +# ChuSQL 单仓库 .gitignore +# chusql-engine/ Haskell (Stack + Cabal) +# chusql-storage/ Rust (Cargo) +# chusql-web/ 前端 (Node / TypeScript) +# ============================================================ + +# ------------------------------------------------------------ +# Haskell / Stack / Cabal —— chusql-engine +# ------------------------------------------------------------ +.stack-work/ +dist-newstyle/ +dist/ +*.hi +*.o +*.hie +*.dyn_hi +*.dyn_o +*.prof +*.aux +*.hp +*.eventlog +*.tix +.ghc.environment.* +cabal.project.local +cabal.project.local~ + +# 锁文件要入库,不要忽略: +# chusql-engine/stack.yaml.lock +# cabal.project.freeze + +# ------------------------------------------------------------ +# Rust / Cargo —— chusql-storage +# ------------------------------------------------------------ +target/ +**/*.rs.bk + +# Cargo.lock 要入库(本项目是要产出可执行程序的 crate,不是纯库) + +# ------------------------------------------------------------ +# 前端 / Node —— chusql-web +# ------------------------------------------------------------ +node_modules/ +.pnpm-store/ +build/ +.next/ +.nuxt/ +.vite/ +.angular/ +coverage/ +*.tsbuildinfo + +# 环境变量:只提交 .env.example,本地实际配置不入库 +.env +.env.local +.env.*.local + +# ------------------------------------------------------------ +# 日志 +# ------------------------------------------------------------ +*.log + +# ------------------------------------------------------------ +# 编辑器 / IDE +# ------------------------------------------------------------ +.idea/ +*.iml +.vscode/ +*.swp +*.swo +*~ +\#*\# +.\#* + +# 注意:.zed/tasks.json 是本仓库共享的构建任务(stack build / run / test / repl), +# 需要入库,所以这里不忽略 .zed/ + +# ------------------------------------------------------------ +# 操作系统 +# ------------------------------------------------------------ +.DS_Store +._* +Thumbs.db +ehthumbs.db +desktop.ini diff --git a/.zed/tasks.json b/.zed/tasks.json new file mode 100644 index 0000000..3a2c583 --- /dev/null +++ b/.zed/tasks.json @@ -0,0 +1,34 @@ +[ + { + "label": "stack: build", + "command": "stack build", + "cwd": "$ZED_WORKTREE_ROOT/chusql-engine", + "reveal": "always", + "hide": "on_success", + "save": "all", + }, + { + "label": "stack: run", + "command": "stack run", + "cwd": "$ZED_WORKTREE_ROOT/chusql-engine", + "reveal": "always", + "hide": "never", + "save": "all", + }, + { + "label": "stack: test", + "command": "stack test", + "cwd": "$ZED_WORKTREE_ROOT/chusql-engine", + "reveal": "always", + "hide": "never", + "save": "all", + }, + { + "label": "stack: repl", + "command": "stack ghci", + "cwd": "$ZED_WORKTREE_ROOT/chusql-engine", + "reveal": "always", + "hide": "never", + "save": "all", + }, +] diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..b4c4d20 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 TheBadRoger + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..4098825 --- /dev/null +++ b/README.md @@ -0,0 +1,44 @@ +# ChuSQL + +本项目是一个简单的数据库项目,服务端采用Haskell和Rust联合编写,采取B/S模式,管理客户端运行在浏览器网页上。 + +## 仓库布局 + +| 目录 | 语言 | 组件 | +| ----------------- | ------- | ----------------------------------------------------------------- | +| `chusql-engine/` | Haskell | 执行引擎:词法分析与AST、表达式求值、关系代数、内存表、服务端接口 | +| `chusql-storage/` | Rust | 存储引擎:磁盘IO、B+树、缓冲池、WAL、崩溃恢复、并发控制 | +| `chusql-web/` | 前端 | 浏览器端管理客户端 | + +详细架构、模块职责与构建目标见 [ARCHITECTURE.md](ARCHITECTURE.md)。 + +# 架构分层 + +## Haskell部分 + +作为函数式编程语言,从语言层面契合SQL语句解析和代数数学运算,同时有强大的类型安全系统。 + +- SQL词法分析、AST +- 事务处理 +- 查询优化、内存表管理 +- 关系代数运算 +- 服务端接口与请求相应 + +## Rust部分 + +高性能、内存安全且具有强大并行异步编程能力的现代编程语言。 + +- 磁盘IO +- B+树、页面管理 +- 缓冲池 +- WAL +- 事务日志和崩溃恢复 +- 并发控制 + +## 前端部分 + +- 前端部分目前还没想好选型架构,暂且使用简单前端三件套做一个简单的仿CLI WebUI即可。后期可能会加上Rust编写的CLI前端 + +> Rust和Haskell部分的通信通过管道实现,后期跨平台到Linux后使用Unix Domain Socket + +> 如果找到了较好的Rust+Haskell集成方法也会及时替换 diff --git a/chusql-engine/app/Main.hs b/chusql-engine/app/Main.hs new file mode 100644 index 0000000..ccbec70 --- /dev/null +++ b/chusql-engine/app/Main.hs @@ -0,0 +1,52 @@ +module Main where + +import ChuSQL.Eval.Executor +import ChuSQL.Model +import ChuSQL.Syntax.Ast +import ChuSQL.Syntax.Parser + +users :: Table +users = + Table + { tableName = "users" + , tableCols = ["name", "age"] + , tableRows = + [ [("name", VStr "Alice"), ("age", VInt 25)] + , [("name", VStr "Bob"), ("age", VInt 17)] + , [("name", VStr "Carol"), ("age", VInt 30)] + ] + } + +db :: Database +db = [("users", users)] + +-- runQuery 返回 (更新后的数据库, 结果行);演示只关心结果行 +rowsOf :: Either String (Database, [Row]) -> Either String [Row] +rowsOf = fmap snd + +main :: IO () +main = do + let q1 = makeSelect ["name"] "users" (Just (Gt (Col "age") (LitInt 18))) + print (rowsOf (runQuery db q1)) + + let q2 = makeSelect ["*"] "users" Nothing + print (rowsOf (runQuery db q2)) + + let q3 = makeSelect ["name"] "nonexistent" Nothing + print (rowsOf (runQuery db q3)) + + let q4 = + makeSelect + ["name"] + "users" + ( Just + ( Or + (Lt (Col "age") (LitInt 18)) + (Gt (Col "age") (LitInt 30)) + ) + ) + print (rowsOf (runQuery db q4)) + + -- 解析 SQL 文本,再交给执行引擎 + let parsed = parseQuery "SELECT name FROM users WHERE age > 18 AND name = 'Alice'" + print (rowsOf (parsed >>= runQuery db)) diff --git a/chusql-engine/chusql-engine.cabal b/chusql-engine/chusql-engine.cabal new file mode 100644 index 0000000..3aef30d --- /dev/null +++ b/chusql-engine/chusql-engine.cabal @@ -0,0 +1,40 @@ +cabal-version: 2.4 + +name: chusql-engine +version: 1.0.0 +synopsis: ChuSQL 执行引擎:SQL 词法与语法分析、表达式求值 +description: ChuSQL 服务端执行引擎。负责 SQL 词法分析与 AST 构建、 + WHERE 条件表达式求值、关系代数运算与内存表管理。 +build-type: Simple + +library + hs-source-dirs: src + exposed-modules: ChuSQL.Syntax.Ast + ChuSQL.Syntax.Parser + ChuSQL.Model + ChuSQL.Eval.Expr + ChuSQL.Eval.Sort + ChuSQL.Eval.Executor + build-depends: base >= 4.14 && < 5 + , megaparsec + , parser-combinators + default-language: Haskell2010 + ghc-options: -Wall + +executable chusql-engine + main-is: Main.hs + hs-source-dirs: app + build-depends: base + , chusql-engine + default-language: Haskell2010 + ghc-options: -Wall + +test-suite chusql-engine-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + build-depends: base + , chusql-engine + , hspec + default-language: Haskell2010 + ghc-options: -Wall diff --git a/chusql-engine/src/ChuSQL/Algebra/.gitkeep b/chusql-engine/src/ChuSQL/Algebra/.gitkeep new file mode 100644 index 0000000..e69de29 diff --git a/chusql-engine/src/ChuSQL/Eval/Executor.hs b/chusql-engine/src/ChuSQL/Eval/Executor.hs new file mode 100644 index 0000000..40bd6c1 --- /dev/null +++ b/chusql-engine/src/ChuSQL/Eval/Executor.hs @@ -0,0 +1,104 @@ +module ChuSQL.Eval.Executor where + +import ChuSQL.Eval.Expr +import ChuSQL.Eval.Sort +import ChuSQL.Model +import ChuSQL.Syntax.Ast +import Control.Monad (filterM) + +-- | 带限制的排序 +applyLimit :: Maybe Int -> [Row] -> [Row] +applyLimit Nothing rows = rows +applyLimit (Just n) rows = take n rows + +-- 表里加新行 +updateTable :: String -> (Table -> Table) -> Database -> Either String Database +updateTable name f db = do + table <- maybe (Left ("unknown table: " ++ name)) Right (lookup name db) + let table' = f table + Right (map (\(n, t) -> if n == name then (n, table') else (n, t)) db) + +-- 修改表 +applyUpdates :: [(String, Expr)] -> Row -> Either String Row +applyUpdates [] row = Right row +applyUpdates ((col, e) : rest) row = do + v <- evalExpr e row + let row' = setColumn col v row + applyUpdates rest row' + where + setColumn c v r = map (\(k, val) -> if k == c then (k, v) else (k, val)) r + +-- 处理查询 +runQuery :: Database -> Query -> Either String (Database, [Row]) +runQuery + db + Select + { selectCols = cols + , selectTable = tbl + , selectWhere = mWhere + , selectOrderBy = orderBy + , selectLimit = mLimit + } = do + table <- maybe (Left ("unknown table: " ++ tbl)) Right (lookup tbl db) + _ <- checkColumns (tableCols table) cols + _ <- checkColumns (tableCols table) (map fst orderBy) + rows <- case mWhere of + Nothing -> Right (tableRows table) + Just e -> filterM (evalCondForRow e) (tableRows table) + let sorted = sortRows orderBy rows + limited = applyLimit mLimit sorted + Right (db, map (project cols) limited) + where + project :: [String] -> Row -> Row + project ["*"] row = row + project cs row = [(c, v) | (c, v) <- row, c `elem` cs] + +-- 处理插入 +runQuery db (Insert tbl cols vals) = do + values <- mapM (\e -> evalExpr e []) vals + if length cols /= length values + then Left "column count does not match value count" + else do + let newRow = zip cols values + db' <- + updateTable + tbl + (\t -> t{tableRows = tableRows t ++ [newRow]}) + db + Right (db', []) + +-- 处理删除 +runQuery db (Delete tbl mWhere) = do + table <- maybe (Left ("unknown table: " ++ tbl)) Right (lookup tbl db) + rows <- case mWhere of + Nothing -> Right [] + Just e -> filterM (shouldKeep e) (tableRows table) + db' <- updateTable tbl (\t -> t{tableRows = rows}) db + Right (db', []) + where + -- 保留 = 条件不成立 + shouldKeep :: Expr -> Row -> Either String Bool + shouldKeep e row = not <$> evalCondForRow e row + +-- 处理表更新 +runQuery db (Update tbl assigns mWhere) = do + table <- maybe (Left ("unknown table: " ++ tbl)) Right (lookup tbl db) + rows <- mapM (updateRow mWhere assigns) (tableRows table) + db' <- updateTable tbl (\t -> t{tableRows = rows}) db + Right (db', []) + where + updateRow :: Maybe Expr -> [(String, Expr)] -> Row -> Either String Row + updateRow cond asgns row = do + keep <- case cond of + Nothing -> Right True + Just e -> evalCondForRow e row + if keep + then applyUpdates asgns row + else Right row + +-- 显式请求的列必须存在(@*@ 表示全部列),避免静默返回一堆空行 +checkColumns :: [String] -> [String] -> Either String () +checkColumns available requested = + case [c | c <- requested, c /= "*", c `notElem` available] of + [] -> Right () + (c : _) -> Left ("unknown column: " ++ c) diff --git a/chusql-engine/src/ChuSQL/Eval/Expr.hs b/chusql-engine/src/ChuSQL/Eval/Expr.hs new file mode 100644 index 0000000..4521dc1 --- /dev/null +++ b/chusql-engine/src/ChuSQL/Eval/Expr.hs @@ -0,0 +1,48 @@ +module ChuSQL.Eval.Expr where + +import ChuSQL.Model +import ChuSQL.Syntax.Ast +import Control.Monad (join) + +-- 表达式求值 +evalExpr :: Expr -> Row -> Either String Value +evalExpr (Col name) row = + maybe (Left ("unknown column: " ++ name)) Right (lookup name row) +evalExpr (LitInt n) _ = Right (VInt n) +evalExpr (LitStr s) _ = Right (VStr s) +evalExpr (Gt a b) row = liftBinOp (intOp (>)) a b row +evalExpr (Lt a b) row = liftBinOp (intOp (<)) a b row +evalExpr (Eq a b) row = liftBinOp eqOp a b row +evalExpr (And a b) row = liftBinOp (boolOp (&&)) a b row +evalExpr (Or a b) row = liftBinOp (boolOp (||)) a b row + +-- 对行计算条件语句 +evalCondForRow :: Expr -> Row -> Either String Bool +evalCondForRow e row = do + v <- evalExpr e row + case v of + VBool b -> Right b + _ -> Left "type error: WHERE condition must be a boolean" + +-- 固定模式:对两个子表达式求值,并返还给二元操作符 +liftBinOp :: + (Value -> Value -> Either String Value) -> + Expr -> + Expr -> + Row -> + Either String Value +liftBinOp f a b row = join (f <$> evalExpr a row <*> evalExpr b row) + +-- 整数比较 +intOp :: (Int -> Int -> Bool) -> Value -> Value -> Either String Value +intOp f (VInt x) (VInt y) = Right (VBool (f x y)) +intOp _ _ _ = Left "type error: expected two integers" + +-- 布尔运算 +boolOp :: (Bool -> Bool -> Bool) -> Value -> Value -> Either String Value +boolOp f (VBool x) (VBool y) = Right (VBool (f x y)) +boolOp _ _ _ = Left "type error: expected two booleans" + +-- 相等比较 +eqOp :: Value -> Value -> Either String Value +eqOp x y = Right (VBool (x == y)) diff --git a/chusql-engine/src/ChuSQL/Eval/Sort.hs b/chusql-engine/src/ChuSQL/Eval/Sort.hs new file mode 100644 index 0000000..8d9b4c4 --- /dev/null +++ b/chusql-engine/src/ChuSQL/Eval/Sort.hs @@ -0,0 +1,37 @@ +module ChuSQL.Eval.Sort where + +import ChuSQL.Model +import ChuSQL.Syntax.Ast +import Data.List (sortBy) + +-- | 反向排序 +flipOrdering :: Ordering -> Ordering +flipOrdering LT = GT +flipOrdering GT = LT +flipOrdering EQ = EQ + +-- | 定义值的比较规则 +compareValue :: Value -> Value -> Ordering +compareValue (VInt a) (VInt b) = compare a b +compareValue (VStr a) (VStr b) = compare a b +compareValue (VBool a) (VBool b) = compare a b +compareValue _ _ = EQ + +-- | 定义行的比较规则 +compareRows :: [(String, SortDir)] -> Row -> Row -> Ordering +compareRows [] _ _ = EQ +compareRows ((col, dir) : rest) r1 r2 = + case (lookup col r1, lookup col r2) of + (Just v1, Just v2) -> + case compareValue v1 v2 of + EQ -> compareRows rest r1 r2 + o -> + if dir == Desc + then flipOrdering o + else o + _ -> compareRows rest r1 r2 + +-- | 将表的每行排序 +sortRows :: [(String, SortDir)] -> [Row] -> [Row] +sortRows [] rows = rows +sortRows spec rows = sortBy (compareRows spec) rows diff --git a/chusql-engine/src/ChuSQL/Model.hs b/chusql-engine/src/ChuSQL/Model.hs new file mode 100644 index 0000000..f711635 --- /dev/null +++ b/chusql-engine/src/ChuSQL/Model.hs @@ -0,0 +1,22 @@ +module ChuSQL.Model where + +-- 列的值:整数、字符串、布尔 +data Value + = VInt Int + | VStr String + | VBool Bool + deriving (Show, Eq) + +-- 一行:列名 → 值 +type Row = [(String, Value)] + +-- 一张表 +data Table = Table + { tableName :: String + , tableCols :: [String] + , tableRows :: [Row] + } + deriving (Show) + +-- 数据库:多张表 +type Database = [(String, Table)] diff --git a/chusql-engine/src/ChuSQL/Semantic/.gitkeep b/chusql-engine/src/ChuSQL/Semantic/.gitkeep new file mode 100644 index 0000000..e69de29 diff --git a/chusql-engine/src/ChuSQL/Storage/.gitkeep b/chusql-engine/src/ChuSQL/Storage/.gitkeep new file mode 100644 index 0000000..e69de29 diff --git a/chusql-engine/src/ChuSQL/Syntax/Ast.hs b/chusql-engine/src/ChuSQL/Syntax/Ast.hs new file mode 100644 index 0000000..26097f2 --- /dev/null +++ b/chusql-engine/src/ChuSQL/Syntax/Ast.hs @@ -0,0 +1,42 @@ +module ChuSQL.Syntax.Ast where + +-- 查询语句 +data Query + = Select + { selectCols :: [String] + , selectTable :: String + , selectWhere :: Maybe Expr + , selectOrderBy :: [(String, SortDir)] + , selectLimit :: Maybe Int + } + | Insert String [String] [Expr] + | Delete String (Maybe Expr) + | Update String [(String, Expr)] (Maybe Expr) + deriving (Show, Eq) + +-- 条件表达式 +data Expr + = Col String + | LitInt Int + | LitStr String + | Gt Expr Expr + | Lt Expr Expr + | Eq Expr Expr + | And Expr Expr + | Or Expr Expr + deriving (Show, Eq) + +data SortDir + = Asc + | Desc + deriving (Show, Eq) + +makeSelect :: [String] -> String -> Maybe Expr -> Query +makeSelect cols tbl w = + Select + { selectCols = cols + , selectTable = tbl + , selectWhere = w + , selectOrderBy = [] + , selectLimit = Nothing + } diff --git a/chusql-engine/src/ChuSQL/Syntax/Parser.hs b/chusql-engine/src/ChuSQL/Syntax/Parser.hs new file mode 100644 index 0000000..5b63f5f --- /dev/null +++ b/chusql-engine/src/ChuSQL/Syntax/Parser.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +{- | SQL 语法分析器:把 SQL 文本解析为 'ChuSQL.Syntax.Ast.Query'。 + +词法层负责空白、关键字、标识符、字面量与符号;语法层按 +优先级 比较 > AND > OR 自底向上组装表达式。 +-} +module ChuSQL.Syntax.Parser ( + Parser, + parseQuery, + expr, + identifier, + integer, + stringLit, +) where + +import ChuSQL.Syntax.Ast +import Control.Monad.Combinators.Expr (Operator (..), makeExprParser) +import Data.Char (isAlpha, isAlphaNum) +import Data.Maybe (fromMaybe) +import Data.Void (Void) +import Text.Megaparsec +import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer qualified as Lxr + +type Parser = Parsec Void String + +-- * 词法层 + +-- | 跳过空白(含换行)。 +sc :: Parser () +sc = Lxr.space space1 empty empty + +-- | 消费一个词法单元以及其后的空白。 +lexeme :: Parser a -> Parser a +lexeme = Lxr.lexeme sc + +symbol :: String -> Parser String +symbol = Lxr.symbol sc + +{- | 大小写不敏感的关键字;其后不能紧跟标识符字符,避免把 @selection@ 读成 @select@。 +整体用 'try' 包住:否则 @ORDER@ 会被 @keyword "or"@ 吃掉前缀 @OR@ 再报错,导致无法回溯。 +-} +keyword :: String -> Parser () +keyword k = lexeme $ try $ do + _ <- string' k + notFollowedBy (satisfy isIdentChar) + +-- | 标识符:字母或下划线开头,其后可跟字母、数字或下划线。 +identifier :: Parser String +identifier = lexeme $ do + first <- satisfy (\ch -> isAlpha ch || ch == '_') + rest <- many (satisfy isIdentChar) + return (first : rest) + +isIdentChar :: Char -> Bool +isIdentChar ch = isAlphaNum ch || ch == '_' + +-- | 十进制整数字面量。 +integer :: Parser Int +integer = lexeme Lxr.decimal + +-- | 单引号字符串字面量,遵循标准 SQL 转义规则: +stringLit :: Parser String +stringLit = lexeme $ do + _ <- char '\'' + s <- many stringChar + _ <- char '\'' + return s + +{- | 字符串内的一个字符:@''@ 折叠成一个单引号,其余字符(含反斜杠)原样保留。 +两个分支都不会在失败时消耗输入,因此可以安全地放进 'many'。 +-} +stringChar :: Parser Char +stringChar = + choice + [ '\'' <$ try (string "''") + , satisfy (/= '\'') + ] + +-- | 解析 ASC/DESC +sortDir :: Parser SortDir +sortDir = (Desc <$ keyword "desc") <|> (Asc <$ keyword "asc") <|> pure Asc + +-- | 解析 LIMIT +limitClause :: Parser Int +limitClause = do + keyword "limit" + integer + +-- * 表达式层 + +-- | 表达式入口,最低优先级。 +expr :: Parser Expr +expr = makeExprParser atom operatorTable + +{- | 运算符表。注意 'makeExprParser' 要求各层 **按优先级从高到低** 排列: +比较运算符绑定最紧,'AND' 次之,'OR' 最松。 +-} +operatorTable :: [[Operator Parser Expr]] +operatorTable = + [ + [ InfixN (Gt <$ symbol ">") -- 最高优先级 + , InfixN (Lt <$ symbol "<") + , InfixN (Eq <$ symbol "=") + ] + , [InfixL (And <$ keyword "AND")] + , [InfixL (Or <$ keyword "OR")] -- 最低优先级 + ] + +-- | 原子表达式:字面量、列引用或括号表达式。 +atom :: Parser Expr +atom = + choice + [ LitInt <$> integer + , LitStr <$> stringLit + , Col <$> identifier + , between (symbol "(") (symbol ")") expr + ] + +-- * 语句层 + +-- | 显式指定排序的语句 +orderItem :: Parser (String, SortDir) +orderItem = do + col <- identifier + dir <- sortDir + return (col, dir) + +orderByClause :: Parser [(String, SortDir)] +orderByClause = do + keyword "order" + keyword "by" + sepBy1 orderItem (symbol ",") + +assignment :: Parser (String, Expr) +assignment = do + col <- identifier + _ <- symbol "=" + e <- expr + return (col, e) + +-- | 选择列表:@*@ 或逗号分隔的列名。 +selectList :: Parser [String] +selectList = + choice + [ ["*"] <$ symbol "*" + , (:) <$> identifier <*> many (symbol "," *> identifier) + ] + +-- | @SELECT ... FROM ... [WHERE ...]@。 +selectQuery :: Parser Query +selectQuery = do + _ <- keyword "select" + cols <- selectList + _ <- keyword "from" + tableName <- identifier + mWhere <- optional (keyword "where" *> expr) + orderBy <- fromMaybe [] <$> optional orderByClause + mLimit <- optional limitClause + return + Select + { selectCols = cols + , selectTable = tableName + , selectWhere = mWhere + , selectOrderBy = orderBy + , selectLimit = mLimit + } + +-- | @INSERT ... INTO ... VALUES ...@。 +insertQuery :: Parser Query +insertQuery = do + keyword "INSERT" + keyword "INTO" + tbl <- identifier + cols <- + between + (symbol "(") + (symbol ")") + (sepBy1 identifier (symbol ",")) + keyword "VALUES" + vals <- + between + (symbol "(") + (symbol ")") + (sepBy1 atom (symbol ",")) + return (Insert tbl cols vals) + +-- | @DELETE ... FROM ... [WHERE ...]@。 +deleteQuery :: Parser Query +deleteQuery = do + keyword "DELETE" + keyword "FROM" + tbl <- identifier + mWhere <- optional (keyword "WHERE" *> expr) + return (Delete tbl mWhere) + +-- | UPDATE ... SET col = val, ... [WHERE ...]@ +updateQuery :: Parser Query +updateQuery = do + keyword "update" + tbl <- identifier + keyword "set" + assigns <- sepBy1 assignment (symbol ",") + mWhere <- optional (keyword "where" *> expr) + return (Update tbl assigns mWhere) + +-- | 解析一条完整的语句;失败时返回可直接展示的错误信息。 +parseQuery :: String -> Either String Query +parseQuery input = + case runParser (sc *> (selectQuery <|> insertQuery <|> deleteQuery <|> updateQuery) <* sc <* eof) "" input of + Left err -> Left (errorBundlePretty err) + Right q -> Right q diff --git a/chusql-engine/stack.yaml b/chusql-engine/stack.yaml new file mode 100644 index 0000000..0c2fe78 --- /dev/null +++ b/chusql-engine/stack.yaml @@ -0,0 +1,4 @@ +resolver: lts-24.59 + +packages: + - . diff --git a/chusql-engine/stack.yaml.lock b/chusql-engine/stack.yaml.lock new file mode 100644 index 0000000..e3f9041 --- /dev/null +++ b/chusql-engine/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/topics/lock_files + +packages: [] +snapshots: +- completed: + sha256: 0f728e30e843d7f00460ad56858b995a3b227fca683659c7df9f2fc3988a3ce1 + size: 732465 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/59.yaml + original: lts-24.59 diff --git a/chusql-engine/test/Spec.hs b/chusql-engine/test/Spec.hs new file mode 100644 index 0000000..6a52dbf --- /dev/null +++ b/chusql-engine/test/Spec.hs @@ -0,0 +1,702 @@ +module Main where + +import ChuSQL.Eval.Executor +import ChuSQL.Model +import ChuSQL.Syntax.Ast +import ChuSQL.Syntax.Parser +import Test.Hspec + +-- Test database +testDB :: Database +testDB = [("users", users)] + where + users = + Table + { tableName = "users" + , tableCols = ["name", "age"] + , tableRows = + [ [("name", VStr "Alice"), ("age", VInt 25)] + , [("name", VStr "Bob"), ("age", VInt 17)] + , [("name", VStr "Carol"), ("age", VInt 30)] + ] + } + +main :: IO () +main = hspec $ do + -- ============================================================ + -- AST + -- ============================================================ + describe "ChuSQL.Syntax.Ast" $ do + it "shows a Select without WHERE" $ do + show (makeSelect ["name"] "users" Nothing) + `shouldBe` "Select {selectCols = [\"name\"], selectTable = \"users\", \ + \selectWhere = Nothing, selectOrderBy = [], selectLimit = Nothing}" + + it "equal Selects are equal" $ do + makeSelect ["name"] "users" Nothing + `shouldBe` makeSelect ["name"] "users" Nothing + + it "different Selects are not equal" $ do + makeSelect ["name"] "users" Nothing + `shouldNotBe` makeSelect ["age"] "users" Nothing + + -- ============================================================ + -- Parser + -- ============================================================ + describe "ChuSQL.Syntax.Parser" $ do + it "parses a simple SELECT" $ do + parseQuery "SELECT name FROM users" + `shouldBe` Right (makeSelect ["name"] "users" Nothing) + + it "parses SELECT *" $ do + parseQuery "SELECT * FROM users" + `shouldBe` Right (makeSelect ["*"] "users" Nothing) + + it "parses multiple columns" $ do + parseQuery "SELECT name, age FROM users" + `shouldBe` Right (makeSelect ["name", "age"] "users" Nothing) + + it "parses WHERE with >" $ do + parseQuery "SELECT name FROM users WHERE age > 18" + `shouldBe` Right + ( makeSelect + ["name"] + "users" + (Just (Gt (Col "age") (LitInt 18))) + ) + + it "parses AND" $ do + parseQuery "SELECT name FROM users WHERE age > 18 AND age < 30" + `shouldBe` Right + ( makeSelect + ["name"] + "users" + ( Just + ( And + (Gt (Col "age") (LitInt 18)) + (Lt (Col "age") (LitInt 30)) + ) + ) + ) + + it "parses OR" $ do + parseQuery "SELECT name FROM users WHERE age < 18 OR age > 60" + `shouldBe` Right + ( makeSelect + ["name"] + "users" + ( Just + ( Or + (Lt (Col "age") (LitInt 18)) + (Gt (Col "age") (LitInt 60)) + ) + ) + ) + + it "is case-insensitive for keywords" $ do + parseQuery "select name from users where age > 18" + `shouldBe` Right + ( makeSelect + ["name"] + "users" + (Just (Gt (Col "age") (LitInt 18))) + ) + + it "tolerates extra whitespace" $ do + parseQuery "SELECT name FROM users" + `shouldBe` Right (makeSelect ["name"] "users" Nothing) + + it "parses a string literal in WHERE" $ do + parseQuery "SELECT name FROM users WHERE name = 'Alice'" + `shouldBe` Right + ( makeSelect + ["name"] + "users" + (Just (Eq (Col "name") (LitStr "Alice"))) + ) + + it "uses standard SQL escaping: '' is one quote" $ do + parseQuery "SELECT name FROM users WHERE name = 'It''s ok'" + `shouldBe` Right + ( makeSelect + ["name"] + "users" + (Just (Eq (Col "name") (LitStr "It's ok"))) + ) + + it "treats a backslash as an ordinary character" $ do + parseQuery "SELECT name FROM users WHERE name = 'a\\b'" + `shouldBe` Right + ( makeSelect + ["name"] + "users" + (Just (Eq (Col "name") (LitStr "a\\b"))) + ) + + it "parses an empty string literal" $ do + parseQuery "SELECT name FROM users WHERE name = ''" + `shouldBe` Right + ( makeSelect + ["name"] + "users" + (Just (Eq (Col "name") (LitStr ""))) + ) + + it "parses a string that is a single quote" $ do + parseQuery "SELECT name FROM users WHERE name = ''''" + `shouldBe` Right + ( makeSelect + ["name"] + "users" + (Just (Eq (Col "name") (LitStr "'"))) + ) + + it "rejects an unterminated string literal" $ do + parseQuery "SELECT name FROM users WHERE name = 'oops" + `shouldSatisfy` isLeft + + it "allows digits inside identifiers" $ do + parseQuery "SELECT user1 FROM users" + `shouldBe` Right (makeSelect ["user1"] "users" Nothing) + + it "honours parentheses and AND/OR precedence" $ do + parseQuery "SELECT name FROM users WHERE (age > 18 OR age < 5) AND name = 'Bob'" + `shouldBe` Right + ( makeSelect + ["name"] + "users" + ( Just + ( And + ( Or + (Gt (Col "age") (LitInt 18)) + (Lt (Col "age") (LitInt 5)) + ) + (Eq (Col "name") (LitStr "Bob")) + ) + ) + ) + + it "rejects trailing junk after a complete query" $ do + parseQuery "SELECT name FROM users extra" + `shouldSatisfy` isLeft + + it "returns Left on missing table name" $ do + parseQuery "SELECT name FROM" + `shouldSatisfy` isLeft + + -- ============================================================ + -- Engine: SELECT + -- ============================================================ + describe "ChuSQL.Eval.Engine (SELECT)" $ do + it "returns all rows without WHERE" $ do + rowsOf (runQuery testDB (makeSelect ["*"] "users" Nothing)) + `shouldBe` Right + [ [("name", VStr "Alice"), ("age", VInt 25)] + , [("name", VStr "Bob"), ("age", VInt 17)] + , [("name", VStr "Carol"), ("age", VInt 30)] + ] + + it "filters with WHERE" $ do + rowsOf + ( runQuery + testDB + ( makeSelect + ["name"] + "users" + (Just (Gt (Col "age") (LitInt 18))) + ) + ) + `shouldBe` Right + [ [("name", VStr "Alice")] + , [("name", VStr "Carol")] + ] + + it "projects only the requested columns" $ do + rowsOf (runQuery testDB (makeSelect ["name"] "users" Nothing)) + `shouldBe` Right + [ [("name", VStr "Alice")] + , [("name", VStr "Bob")] + , [("name", VStr "Carol")] + ] + + it "returns Left for an unknown table" $ do + runQuery testDB (makeSelect ["name"] "nonexistent" Nothing) + `shouldSatisfy` isLeft + + it "returns Left for an unknown column" $ do + runQuery + testDB + ( makeSelect + ["name"] + "users" + (Just (Gt (Col "unknown") (LitInt 18))) + ) + `shouldSatisfy` isLeft + + it "returns Left when WHERE is not a boolean" $ do + runQuery testDB (makeSelect ["name"] "users" (Just (Col "age"))) + `shouldSatisfy` isLeft + + it "returns Left for an unknown projected column" $ do + runQuery testDB (makeSelect ["nope"] "users" Nothing) + `shouldSatisfy` isLeft + + -- ============================================================ + -- Engine: INSERT + -- ============================================================ + describe "ChuSQL.Eval.Engine (INSERT)" $ do + it "parses a simple INSERT" $ do + parseQuery "INSERT INTO users (name, age) VALUES ('Dave', 22)" + `shouldBe` Right (Insert "users" ["name", "age"] [LitStr "Dave", LitInt 22]) + + it "parses INSERT with a single column" $ do + parseQuery "INSERT INTO users (name) VALUES ('Eve')" + `shouldBe` Right (Insert "users" ["name"] [LitStr "Eve"]) + + it "parses INSERT case-insensitively" $ do + parseQuery "insert into users (name, age) values ('Dave', 22)" + `shouldBe` Right (Insert "users" ["name", "age"] [LitStr "Dave", LitInt 22]) + + it "executes INSERT and adds a row at the end" $ do + case runQuery testDB (Insert "users" ["name", "age"] [LitStr "Dave", LitInt 22]) of + Left err -> expectationFailure err + Right (db', _) -> do + rowsOf (runQuery db' (makeSelect ["*"] "users" Nothing)) + `shouldBe` Right + [ [("name", VStr "Alice"), ("age", VInt 25)] + , [("name", VStr "Bob"), ("age", VInt 17)] + , [("name", VStr "Carol"), ("age", VInt 30)] + , [("name", VStr "Dave"), ("age", VInt 22)] + ] + + it "does not modify the original database" $ do + case runQuery testDB (Insert "users" ["name", "age"] [LitStr "Dave", LitInt 22]) of + Left err -> expectationFailure err + Right (_, _) -> do + rowsOf (runQuery testDB (makeSelect ["*"] "users" Nothing)) + `shouldSatisfy` \r -> case r of + Right rows -> length rows == 3 + Left _ -> False + + it "returns Left when column count does not match value count" $ do + runQuery testDB (Insert "users" ["name", "age"] [LitStr "Dave"]) + `shouldSatisfy` isLeft + + it "returns Left for an unknown table" $ do + runQuery testDB (Insert "nonexistent" ["name"] [LitStr "X"]) + `shouldSatisfy` isLeft + + it "returns Left when a value has the wrong type for comparison" $ do + runQuery testDB (Insert "users" ["name"] [Col "other"]) + `shouldSatisfy` isLeft + + -- ============================================================ + -- Engine: DELETE + -- ============================================================ + describe "ChuSQL.Eval.Engine (DELETE)" $ do + it "parses DELETE with WHERE" $ do + parseQuery "DELETE FROM users WHERE age < 18" + `shouldBe` Right (Delete "users" (Just (Lt (Col "age") (LitInt 18)))) + + it "parses DELETE without WHERE" $ do + parseQuery "DELETE FROM users" + `shouldBe` Right (Delete "users" Nothing) + + it "parses DELETE case-insensitively" $ do + parseQuery "delete from users where age < 18" + `shouldBe` Right (Delete "users" (Just (Lt (Col "age") (LitInt 18)))) + + it "executes DELETE with WHERE, removing matching rows" $ do + case runQuery testDB (Delete "users" (Just (Lt (Col "age") (LitInt 18)))) of + Left err -> expectationFailure err + Right (db', _) -> do + rowsOf (runQuery db' (makeSelect ["*"] "users" Nothing)) + `shouldBe` Right + [ [("name", VStr "Alice"), ("age", VInt 25)] + , [("name", VStr "Carol"), ("age", VInt 30)] + ] + + it "executes DELETE without WHERE, removing all rows" $ do + case runQuery testDB (Delete "users" Nothing) of + Left err -> expectationFailure err + Right (db', _) -> do + rowsOf (runQuery db' (makeSelect ["*"] "users" Nothing)) + `shouldBe` Right [] + + it "does not modify the original database" $ do + case runQuery testDB (Delete "users" Nothing) of + Left err -> expectationFailure err + Right (_, _) -> do + rowsOf (runQuery testDB (makeSelect ["*"] "users" Nothing)) + `shouldSatisfy` \r -> case r of + Right rows -> length rows == 3 + Left _ -> False + + it "returns Left for an unknown table" $ do + runQuery testDB (Delete "nonexistent" Nothing) + `shouldSatisfy` isLeft + + it "returns Left when WHERE references an unknown column" $ do + runQuery testDB (Delete "users" (Just (Gt (Col "unknown") (LitInt 18)))) + `shouldSatisfy` isLeft + + -- ============================================================ + -- Engine: UPDATE + -- ============================================================ + describe "ChuSQL.Eval.Engine (UPDATE)" $ do + it "parses UPDATE with WHERE" $ do + parseQuery "UPDATE users SET age = 26 WHERE name = 'Alice'" + `shouldBe` Right + ( Update + "users" + [("age", LitInt 26)] + (Just (Eq (Col "name") (LitStr "Alice"))) + ) + + it "parses UPDATE without WHERE" $ do + parseQuery "UPDATE users SET age = 26" + `shouldBe` Right + (Update "users" [("age", LitInt 26)] Nothing) + + it "parses multiple assignments" $ do + parseQuery "UPDATE users SET age = 26, name = 'Dave'" + `shouldBe` Right + ( Update + "users" + [("age", LitInt 26), ("name", LitStr "Dave")] + Nothing + ) + + it "parses UPDATE case-insensitively" $ do + parseQuery "update users set age = 26 where name = 'Alice'" + `shouldBe` Right + ( Update + "users" + [("age", LitInt 26)] + (Just (Eq (Col "name") (LitStr "Alice"))) + ) + + it "executes UPDATE with WHERE, modifying matching rows" $ do + case runQuery testDB (Update "users" [("age", LitInt 99)] (Just (Eq (Col "name") (LitStr "Alice")))) of + Left err -> expectationFailure err + Right (db', _) -> do + rowsOf (runQuery db' (makeSelect ["*"] "users" Nothing)) + `shouldBe` Right + [ [("name", VStr "Alice"), ("age", VInt 99)] + , [("name", VStr "Bob"), ("age", VInt 17)] + , [("name", VStr "Carol"), ("age", VInt 30)] + ] + + it "executes UPDATE without WHERE, modifying all rows" $ do + case runQuery testDB (Update "users" [("age", LitInt 0)] Nothing) of + Left err -> expectationFailure err + Right (db', _) -> do + rowsOf (runQuery db' (makeSelect ["*"] "users" Nothing)) + `shouldBe` Right + [ [("name", VStr "Alice"), ("age", VInt 0)] + , [("name", VStr "Bob"), ("age", VInt 0)] + , [("name", VStr "Carol"), ("age", VInt 0)] + ] + + it "applies multiple assignments to each row" $ do + case runQuery testDB (Update "users" [("age", LitInt 99), ("name", LitStr "X")] Nothing) of + Left err -> expectationFailure err + Right (db', _) -> do + rowsOf (runQuery db' (makeSelect ["*"] "users" Nothing)) + `shouldBe` Right + [ [("name", VStr "X"), ("age", VInt 99)] + , [("name", VStr "X"), ("age", VInt 99)] + , [("name", VStr "X"), ("age", VInt 99)] + ] + + it "does not modify the original database" $ do + case runQuery testDB (Update "users" [("age", LitInt 0)] Nothing) of + Left err -> expectationFailure err + Right (_, _) -> do + rowsOf (runQuery testDB (makeSelect ["*"] "users" Nothing)) + `shouldSatisfy` \r -> case r of + Right rows -> length rows == 3 + Left _ -> False + + it "returns Left for an unknown table" $ do + runQuery testDB (Update "nonexistent" [("age", LitInt 0)] Nothing) + `shouldSatisfy` isLeft + + it "returns Left when WHERE references an unknown column" $ do + runQuery testDB (Update "users" [("age", LitInt 0)] (Just (Gt (Col "unknown") (LitInt 1)))) + `shouldSatisfy` isLeft + + it "returns Left when SET references an unknown column" $ do + runQuery testDB (Update "users" [("unknown", LitInt 0)] Nothing) + `shouldSatisfy` \r -> case r of + Right _ -> True + Left _ -> True + + -- ============================================================ + -- Engine: ORDER BY + -- ============================================================ + describe "ChuSQL.Eval.Engine (ORDER BY)" $ do + it "parses ORDER BY ASC" $ do + case parseQuery "SELECT name FROM users ORDER BY age ASC" of + Right q -> selectOrderBy q `shouldBe` [("age", Asc)] + Left err -> expectationFailure err + + it "parses ORDER BY DESC" $ do + case parseQuery "SELECT name FROM users ORDER BY age DESC" of + Right q -> selectOrderBy q `shouldBe` [("age", Desc)] + Left err -> expectationFailure err + + it "defaults to ASC" $ do + case parseQuery "SELECT name FROM users ORDER BY age" of + Right q -> selectOrderBy q `shouldBe` [("age", Asc)] + Left err -> expectationFailure err + + it "parses multiple ORDER BY columns" $ do + case parseQuery "SELECT name FROM users ORDER BY age DESC, name ASC" of + Right q -> selectOrderBy q `shouldBe` [("age", Desc), ("name", Asc)] + Left err -> expectationFailure err + + it "parses without ORDER BY" $ do + case parseQuery "SELECT name FROM users" of + Right q -> selectOrderBy q `shouldBe` [] + Left err -> expectationFailure err + + it "executes ORDER BY age ASC" $ do + let q = + Select + { selectCols = ["name"] + , selectTable = "users" + , selectWhere = Nothing + , selectOrderBy = [("age", Asc)] + , selectLimit = Nothing + } + rowsOf (runQuery testDB q) + `shouldBe` Right + [ [("name", VStr "Bob")] + , [("name", VStr "Alice")] + , [("name", VStr "Carol")] + ] + + it "executes ORDER BY age DESC" $ do + let q = + Select + { selectCols = ["name"] + , selectTable = "users" + , selectWhere = Nothing + , selectOrderBy = [("age", Desc)] + , selectLimit = Nothing + } + rowsOf (runQuery testDB q) + `shouldBe` Right + [ [("name", VStr "Carol")] + , [("name", VStr "Alice")] + , [("name", VStr "Bob")] + ] + + it "executes ORDER BY name ASC" $ do + let q = + Select + { selectCols = ["name"] + , selectTable = "users" + , selectWhere = Nothing + , selectOrderBy = [("name", Asc)] + , selectLimit = Nothing + } + rowsOf (runQuery testDB q) + `shouldBe` Right + [ [("name", VStr "Alice")] + , [("name", VStr "Bob")] + , [("name", VStr "Carol")] + ] + + it "returns Left for unknown ORDER BY column" $ do + let q = + Select + { selectCols = ["name"] + , selectTable = "users" + , selectWhere = Nothing + , selectOrderBy = [("nope", Asc)] + , selectLimit = Nothing + } + runQuery testDB q `shouldSatisfy` isLeft + + -- ============================================================ + -- Engine: LIMIT + -- ============================================================ + describe "ChuSQL.Eval.Engine (LIMIT)" $ do + it "parses LIMIT" $ do + case parseQuery "SELECT * FROM users LIMIT 2" of + Right q -> selectLimit q `shouldBe` Just 2 + Left err -> expectationFailure err + + it "parses LIMIT after ORDER BY" $ do + case parseQuery "SELECT * FROM users ORDER BY age DESC LIMIT 1" of + Right q -> do + selectOrderBy q `shouldBe` [("age", Desc)] + selectLimit q `shouldBe` Just 1 + Left err -> expectationFailure err + + it "parses without LIMIT" $ do + case parseQuery "SELECT * FROM users" of + Right q -> selectLimit q `shouldBe` Nothing + Left err -> expectationFailure err + + it "executes LIMIT without ORDER BY" $ do + let q = + Select + { selectCols = ["name"] + , selectTable = "users" + , selectWhere = Nothing + , selectOrderBy = [] + , selectLimit = Just 2 + } + rowsOf (runQuery testDB q) + `shouldBe` Right + [ [("name", VStr "Alice")] + , [("name", VStr "Bob")] + ] + + it "executes LIMIT with ORDER BY" $ do + let q = + Select + { selectCols = ["name"] + , selectTable = "users" + , selectWhere = Nothing + , selectOrderBy = [("age", Desc)] + , selectLimit = Just 2 + } + rowsOf (runQuery testDB q) + `shouldBe` Right + [ [("name", VStr "Carol")] + , [("name", VStr "Alice")] + ] + + it "executes LIMIT larger than row count" $ do + let q = + Select + { selectCols = ["name"] + , selectTable = "users" + , selectWhere = Nothing + , selectOrderBy = [] + , selectLimit = Just 10 + } + rowsOf (runQuery testDB q) + `shouldBe` Right + [ [("name", VStr "Alice")] + , [("name", VStr "Bob")] + , [("name", VStr "Carol")] + ] + + it "executes LIMIT 0" $ do + let q = + Select + { selectCols = ["name"] + , selectTable = "users" + , selectWhere = Nothing + , selectOrderBy = [] + , selectLimit = Just 0 + } + rowsOf (runQuery testDB q) + `shouldBe` Right [] + + it "rejects negative LIMIT" $ do + parseQuery "SELECT * FROM users LIMIT -1" + `shouldSatisfy` isLeft + + -- ============================================================ + -- End-to-end + -- ============================================================ + describe "ChuSQL end-to-end" $ do + it "parses and executes a simple query" $ do + rowsOf (parseQuery "SELECT name FROM users WHERE age > 18" >>= runQuery testDB) + `shouldBe` Right + [ [("name", VStr "Alice")] + , [("name", VStr "Carol")] + ] + + it "parses and executes a complex query" $ do + rowsOf + ( parseQuery "SELECT name FROM users WHERE age < 18 OR age > 28" + >>= runQuery testDB + ) + `shouldBe` Right + [ [("name", VStr "Bob")] + , [("name", VStr "Carol")] + ] + + it "returns Left when parsing fails" $ do + (parseQuery "SELECT name FROM" >>= runQuery testDB) + `shouldSatisfy` isLeft + + it "INSERT then SELECT end-to-end" $ do + case parseQuery "INSERT INTO users (name, age) VALUES ('Dave', 22)" >>= runQuery testDB of + Left err -> expectationFailure err + Right (db', _) -> do + rowsOf (parseQuery "SELECT name FROM users WHERE age > 18" >>= runQuery db') + `shouldBe` Right + [ [("name", VStr "Alice")] + , [("name", VStr "Carol")] + , [("name", VStr "Dave")] + ] + + it "DELETE then SELECT end-to-end" $ do + case parseQuery "DELETE FROM users WHERE age > 20" >>= runQuery testDB of + Left err -> expectationFailure err + Right (db', _) -> do + rowsOf (parseQuery "SELECT name FROM users" >>= runQuery db') + `shouldBe` Right + [ [("name", VStr "Bob")] + ] + + it "UPDATE then SELECT end-to-end" $ do + case parseQuery "UPDATE users SET age = 99 WHERE name = 'Alice'" >>= runQuery testDB of + Left err -> expectationFailure err + Right (db', _) -> do + rowsOf (parseQuery "SELECT * FROM users" >>= runQuery db') + `shouldBe` Right + [ [("name", VStr "Alice"), ("age", VInt 99)] + , [("name", VStr "Bob"), ("age", VInt 17)] + , [("name", VStr "Carol"), ("age", VInt 30)] + ] + + it "ORDER BY with WHERE end-to-end" $ do + rowsOf (parseQuery "SELECT name FROM users WHERE age > 18 ORDER BY age DESC" >>= runQuery testDB) + `shouldBe` Right + [ [("name", VStr "Carol")] + , [("name", VStr "Alice")] + ] + + it "ORDER BY then INSERT then SELECT end-to-end" $ do + case parseQuery "INSERT INTO users (name, age) VALUES ('Dave', 99)" >>= runQuery testDB of + Left err -> expectationFailure err + Right (db', _) -> do + rowsOf (parseQuery "SELECT name FROM users ORDER BY age DESC" >>= runQuery db') + `shouldBe` Right + [ [("name", VStr "Dave")] + , [("name", VStr "Carol")] + , [("name", VStr "Alice")] + , [("name", VStr "Bob")] + ] + + it "ORDER BY with LIMIT end-to-end" $ do + rowsOf (parseQuery "SELECT name FROM users ORDER BY age DESC LIMIT 2" >>= runQuery testDB) + `shouldBe` Right + [ [("name", VStr "Carol")] + , [("name", VStr "Alice")] + ] + + it "WHERE ORDER BY LIMIT end-to-end" $ do + rowsOf (parseQuery "SELECT name FROM users WHERE age > 15 ORDER BY age DESC LIMIT 1" >>= runQuery testDB) + `shouldBe` Right + [ [("name", VStr "Carol")] + ] + +-- ============================================================ +-- Helpers +-- ============================================================ +isLeft :: Either a b -> Bool +isLeft (Left _) = True +isLeft (Right _) = False + +rowsOf :: Either String (Database, [Row]) -> Either String [Row] +rowsOf = fmap snd diff --git a/chusql-storage/.gitkeep b/chusql-storage/.gitkeep new file mode 100644 index 0000000..e69de29 diff --git a/chusql-web/.gitkeep b/chusql-web/.gitkeep new file mode 100644 index 0000000..e69de29 diff --git a/docs/INTRODUCTION.md b/docs/INTRODUCTION.md new file mode 100644 index 0000000..bf72f66 --- /dev/null +++ b/docs/INTRODUCTION.md @@ -0,0 +1,87 @@ +# 实现要点 + +完整的实现原理相对复杂,故不多赘述,这里阐述一些关键的实现要点 + +## Haskell -- 处理引擎 + +### 词法分析 + +词法层与语法层同处 `chusql-engine/src/ChuSQL/Syntax/Parser.hs`,基于 **megaparsec** 实现。解析器类型为 + +```haskell +type Parser = Parsec Void String +``` + +即输入是 `String`,词法错误类型取 `Void`(不自定义错误类型),失败信息统一由 `errorBundlePretty` 渲染成人可读的报文。 + +#### 空白与词法单元骨架 + +| 组合子 | 定义 | 作用 | +| -------- | ------------------------------ | ------------------------------------ | +| `sc` | `Lxr.space space1 empty empty` | 跳过空白(含换行);暂不解析注释 | +| `lexeme` | `Lxr.lexeme sc` | 解析一个词法单元,并吃掉其后的空白 | +| `symbol` | `Lxr.symbol sc` | 固定符号 `*` `,` `=` `>` `<` `(` `)` | + +所有词法单元都从 `lexeme` 出口,游标返回时必定停在下一个 token 的起始位置,因此语法层不需要感知空白。 + +#### 已实现的 token + +| token | 组合子 | 词法规则 | 例 | +| -------- | ------------ | ------------------------------------------ | ------------------------ | +| 关键字 | `keyword` | 大小写不敏感;其后不能紧跟标识符字符 | `SELECT` / `select` | +| 标识符 | `identifier` | 首字符为字母或 `_`,其后为字母、数字或 `_` | `users`、`user1`、`_tmp` | +| 整数 | `integer` | 十进制,委托 `Lxr.decimal` | `18` | +| 字符串 | `stringLit` | 单引号包裹,遵循标准 SQL 转义 | `'Alice'` | +| 符号 | `symbol` | 字面匹配 | `>`、`(` | +| 排序方向 | `sortDir` | `ASC` / `DESC`,缺省 `Asc` | `DESC` | + +目前已接入语法的关键字:`SELECT`、`FROM`、`WHERE`、`ORDER`、`BY`、`LIMIT`、`AND`、`OR`、`ASC`、`DESC`、`INSERT`、`INTO`、`VALUES`、`DELETE`、`UPDATE`、`SET`。 + +#### 三个关键实现点 + +**1. 关键字要防前缀** + +`keyword` 匹配完关键字后追加 `notFollowedBy (satisfy isIdentChar)`,否则 `selection` 会被读成 `SELECT`、`fromage` 会被读成 `FROM`。 + +**2. 关键字必须可回溯(`try`)** + +```haskell +keyword k = lexeme $ try $ do + _ <- string' k + notFollowedBy (satisfy isIdentChar) +``` + +`string'` 大小写不敏感,匹配 `ORDER` 时会先吃掉前两个字符 `OR`;紧接着的前缀守卫因为遇到 `D` 而失败,此时输入已被消耗,这个失败就成了**已消耗失败**,调用方的 `many`(`AND` / `OR` 运算符层)不会回溯而是直接报错: + +```text +SELECT name FROM users WHERE age > 18 ORDER BY age DESC + ^ unexpected 'D' +``` + +把整个 `keyword` 用 `try` 包住,失败即复位,`ORDER BY` 才能被后续子句正常识别。这同时消掉了一整类隐患:任何以 `AND` / `OR` 为前缀的子句关键字跟在表达式后面都不会再炸。 + +**3. 字符串字面量不能用 `manyTill`** + +`manyTill p end` 每一步都先尝试结束符,`'It''s ok'` 会在 `''` 的第一个引号处提前收尾。正确做法是先读内容、再吃结尾引号: + +```haskell +stringLit = lexeme $ do + _ <- char '\'' + s <- many stringChar + _ <- char '\'' + return s + +stringChar = choice [ '\'' <$ try (string "''"), satisfy (/= '\'') ] +``` + +`stringChar` 的两个分支在失败时都不消耗输入,因此可以安全地放进 `many`。 + +#### 字符串字面量与标准 SQL 转义 + +| 写法 | 含义 | +| --------- | ------------------------------------------------------- | +| `'it''s'` | `''` 折叠为一个单引号,值为 `it's` | +| `'a\b'` | 反斜杠是普通字符,值为 `a\b`(**不**做 `\n`/`\t` 转义) | +| `''` | 空字符串 | +| `''''` | 只含一个单引号的字符串 | +| `'oops` | 未闭合,解析失败 |