大改，整理项目结构，完成rust ffi调用，写好tcp接口
This commit is contained in:
LIm1tZz7 committed
1 parent
df6d348995
commit
9758439b82
118 files changed
+8103
-6321
No files matched your search
@@ -0,0 +1,82 @@
|
||||
module Main where
|
||||
|
||||
import ChuSQL.Core.Engine.Algebra.Op (renderPlan)
|
||||
import ChuSQL.Core.Engine.Algebra.Optimize (optimize)
|
||||
import ChuSQL.Core.Engine.Algebra.Planner (translate)
|
||||
import ChuSQL.Core.Engine
|
||||
import ChuSQL.Core.Model
|
||||
import ChuSQL.Core.Engine.Syntax.AST
|
||||
import ChuSQL.Core.Engine.Syntax.Parser
|
||||
|
||||
-- 命令行演示入口：跑几条语句并打印结果与优化前后的计划。
|
||||
|
||||
users :: Table
|
||||
users =
|
||||
Table
|
||||
{ tableName = "users"
|
||||
, tableCols = [("id", TInt), ("name", TStr), ("age", TInt)]
|
||||
, tableRows =
|
||||
[ [("id", VInt 1), ("name", VStr "Alice"), ("age", VInt 25)]
|
||||
, [("id", VInt 2), ("name", VStr "Bob"), ("age", VInt 17)]
|
||||
, [("id", VInt 3), ("name", VStr "Carol"), ("age", VInt 30)]
|
||||
]
|
||||
}
|
||||
|
||||
orders :: Table
|
||||
orders =
|
||||
Table
|
||||
{ tableName = "orders"
|
||||
, tableCols = [("id", TInt), ("user_id", TInt), ("product", TStr)]
|
||||
, tableRows =
|
||||
[ [("id", VInt 1), ("user_id", VInt 1), ("product", VStr "Book")]
|
||||
, [("id", VInt 2), ("user_id", VInt 2), ("product", VStr "Pen")]
|
||||
, [("id", VInt 3), ("user_id", VInt 1), ("product", VStr "Cup")]
|
||||
]
|
||||
}
|
||||
|
||||
db :: Database
|
||||
db = [("users", users), ("orders", orders)]
|
||||
|
||||
-- | 跑演示语句，打印结果与优化前后的计划
|
||||
main :: IO ()
|
||||
main = do
|
||||
putStrLn "==================== Engine ====================="
|
||||
let q1 = makeSelect ["name"] "users" (Just (Gt (Col "age") (LitInt 18)))
|
||||
print (rowsOf (runStatement db q1))
|
||||
|
||||
let q2 = makeSelect ["*"] "users" Nothing
|
||||
print (rowsOf (runStatement db q2))
|
||||
|
||||
let q3 = makeSelect ["name"] "nonexistent" Nothing
|
||||
print (rowsOf (runStatement db q3))
|
||||
|
||||
let q4 =
|
||||
makeSelect
|
||||
["name"]
|
||||
"users"
|
||||
( Just
|
||||
( Or
|
||||
(Lt (Col "age") (LitInt 18))
|
||||
(Gt (Col "age") (LitInt 30))
|
||||
)
|
||||
)
|
||||
print (rowsOf (runStatement db q4))
|
||||
|
||||
let parsed = parseStatement "SELECT name FROM users WHERE age > 18 AND name = 'Alice'"
|
||||
print (rowsOf (parsed >>= runStatement db))
|
||||
|
||||
putStrLn "\n==================== Optimizer ====================="
|
||||
let planSql =
|
||||
"SELECT u.name, o.product FROM users u \
|
||||
\JOIN orders o ON u.id = o.user_id WHERE u.age > 18"
|
||||
case parseStatement planSql of
|
||||
Left err -> putStrLn err
|
||||
Right query -> case translate query of
|
||||
Left err -> putStrLn err
|
||||
Right plan -> do
|
||||
putStrLn "--- plan before optimization ---"
|
||||
putStrLn (renderPlan plan)
|
||||
putStrLn "--- plan after optimization ---"
|
||||
putStrLn (renderPlan (optimize db plan))
|
||||
putStrLn "--- rows ---"
|
||||
print (rowsOf (runStatement db query))
|
||||
@@ -0,0 +1,70 @@
|
||||
cabal-version: 2.4
|
||||
|
||||
name: chusql-core-engine
|
||||
version: 1.0.0
|
||||
synopsis: ChuSQL 执行引擎：SQL 词法与语法分析、表达式求值
|
||||
description: ChuSQL 服务端执行引擎。负责 SQL 词法分析与 AST 构建、
|
||||
WHERE 条件表达式求值、关系代数运算与内存表管理。
|
||||
build-type: Simple
|
||||
|
||||
library
|
||||
hs-source-dirs: src
|
||||
exposed-modules: ChuSQL.Core.Engine.Algebra.Eval
|
||||
ChuSQL.Core.Engine.Algebra.Expr
|
||||
ChuSQL.Core.Engine.Algebra.Op
|
||||
ChuSQL.Core.Engine.Algebra.Optimize
|
||||
ChuSQL.Core.Engine.Algebra.Planner
|
||||
ChuSQL.Core.Engine.Algebra.Sort
|
||||
ChuSQL.Core.Engine
|
||||
ChuSQL.Core.Engine.Semantic
|
||||
ChuSQL.Core.Engine.Storage
|
||||
ChuSQL.Core.Engine.Storage.FFI
|
||||
ChuSQL.Core.Engine.Storage.IPC
|
||||
ChuSQL.Core.Engine.Storage.Memory
|
||||
ChuSQL.Core.Engine.Syntax.AST
|
||||
ChuSQL.Core.Engine.Syntax.Parser
|
||||
build-depends: base >= 4.14 && < 5
|
||||
, aeson
|
||||
, bytestring
|
||||
, hashable
|
||||
, chusql-core-model
|
||||
, megaparsec
|
||||
, parser-combinators
|
||||
, scientific
|
||||
, text
|
||||
, unordered-containers
|
||||
extra-libraries: chusql_core_storage
|
||||
-- 运行期找 libchusql_core_storage.so：$ORIGIN 让二进制与动态库同目录即可
|
||||
if os(linux)
|
||||
ld-options: -Wl,-rpath,$ORIGIN
|
||||
if os(osx)
|
||||
ld-options: -Wl,-rpath,@loader_path
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
|
||||
executable chusql-core-engine
|
||||
main-is: Main.hs
|
||||
hs-source-dirs: app
|
||||
build-depends: base
|
||||
, chusql-core-engine
|
||||
, chusql-core-model
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
-- 运行期找 libchusql_core_storage.so：$ORIGIN 让二进制与动态库同目录即可
|
||||
if os(linux)
|
||||
ld-options: -Wl,-rpath,$ORIGIN
|
||||
if os(osx)
|
||||
ld-options: -Wl,-rpath,@loader_path
|
||||
|
||||
test-suite chusql-core-engine-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
hs-source-dirs: test
|
||||
build-depends: base
|
||||
, chusql-core-engine
|
||||
, chusql-core-model
|
||||
, directory
|
||||
, filepath
|
||||
, hspec
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
@@ -0,0 +1,374 @@
|
||||
module ChuSQL.Core.Engine (runStatement, runStatementM, rowsOf) where
|
||||
|
||||
import ChuSQL.Core.Engine.Algebra.Eval (evalCondForRowM, evalExprM, evalRelOpM)
|
||||
import ChuSQL.Core.Engine.Algebra.Expr (evalCondForRow, evalExpr)
|
||||
import ChuSQL.Core.Engine.Algebra.Optimize (optimize)
|
||||
import ChuSQL.Core.Engine.Algebra.Planner (translate)
|
||||
import ChuSQL.Core.Model
|
||||
import ChuSQL.Core.Engine.Semantic (prepare)
|
||||
import ChuSQL.Core.Engine.Storage (MonadStorage (..))
|
||||
import ChuSQL.Core.Engine.Storage.Memory (MemoryStorage (runMemoryStorage))
|
||||
import ChuSQL.Core.Engine.Syntax.AST
|
||||
import ChuSQL.Core.Engine.Syntax.Parser (parseExpression)
|
||||
import Data.Maybe (mapMaybe)
|
||||
|
||||
-- 引擎入口：检查语义、按语句分发执行，另有内存实现与泛型版本。
|
||||
|
||||
-- | 跑一条语句（内存实现）
|
||||
runStatement :: Database -> Statement -> Either String (Database, [Row])
|
||||
runStatement db q = do
|
||||
(result, db') <- runMemoryStorage (runStatementM q) db
|
||||
rows <- result
|
||||
Right (db', rows)
|
||||
|
||||
-- | 只要结果行
|
||||
rowsOf :: Either String (Database, [Row]) -> Either String [Row]
|
||||
rowsOf = fmap snd
|
||||
|
||||
-- | 泛型入口：先检查再执行
|
||||
runStatementM :: (MonadStorage m) => Statement -> m (Either String [Row])
|
||||
runStatementM (CreateDatabase name) = fmap (fmap (const [])) (createDatabase name)
|
||||
runStatementM (DropDatabase name) = fmap (fmap (const [])) (dropDatabase name)
|
||||
runStatementM (UseDatabase name) = fmap (fmap (const [])) (useDatabase name)
|
||||
runStatementM ShowDatabases = fmap (fmap (map (\name -> [("database", VStr name)]))) listDatabases
|
||||
runStatementM q = do
|
||||
db <- schema
|
||||
case prepare db q of
|
||||
Left err -> pure (Left err)
|
||||
Right resolved -> runStatementUncheckedM db resolved
|
||||
|
||||
-- | 按语句类型分发（已检查过）
|
||||
runStatementUncheckedM :: (MonadStorage m) => Database -> Statement -> m (Either String [Row])
|
||||
runStatementUncheckedM db q@Select{} =
|
||||
case translate q of
|
||||
Left e -> pure (Left e)
|
||||
Right relOp -> evalRelOpM db (optimize db relOp)
|
||||
runStatementUncheckedM db q@SelectExpr{} =
|
||||
case translate q of
|
||||
Left e -> pure (Left e)
|
||||
Right relOp -> evalRelOpM db (optimize db relOp)
|
||||
runStatementUncheckedM db (Insert tbl cols rows) =
|
||||
case lookupTable db tbl of
|
||||
Left e -> pure (Left e)
|
||||
Right table -> do
|
||||
current <- existingRows tbl table
|
||||
case current >>= \current' -> buildRows table current' cols rows of
|
||||
Left err -> pure (Left err)
|
||||
Right rs -> do
|
||||
result <- insertMany tbl rs
|
||||
pure (result >> Right [])
|
||||
runStatementUncheckedM db (Delete tbl mWhere) = do
|
||||
rowsResult <- scan tbl
|
||||
case rowsResult of
|
||||
Left err -> pure (Left err)
|
||||
Right rows -> do
|
||||
split <- splitByConditionM db mWhere rows
|
||||
case split of
|
||||
Left err -> pure (Left err)
|
||||
Right (doomed, kept) ->
|
||||
case mapM rowId doomed of
|
||||
Right ids -> do
|
||||
result <- deleteKeys tbl ids
|
||||
pure (result >> Right [])
|
||||
Left _ -> do
|
||||
result <- replaceAll tbl kept
|
||||
pure (result >> Right [])
|
||||
where
|
||||
-- | 取行里的整数 id，取不到就报错
|
||||
rowId :: Row -> Either String Int
|
||||
rowId r = case lookup "id" r of
|
||||
Just (VInt k) -> Right k
|
||||
_ -> Left "row has no integer id"
|
||||
runStatementUncheckedM db (Update tbl assigns mWhere) =
|
||||
case lookupTable db tbl of
|
||||
Left e -> pure (Left e)
|
||||
Right table -> do
|
||||
rowsResult <- scan tbl
|
||||
case rowsResult of
|
||||
Left err -> pure (Left err)
|
||||
Right rows -> do
|
||||
newRows <- mapM (updateRowM db table mWhere assigns) rows
|
||||
case sequence newRows of
|
||||
Left err -> pure (Left err)
|
||||
Right rs -> do
|
||||
result <- replaceAll tbl rs
|
||||
pure (result >> Right [])
|
||||
runStatementUncheckedM _ (CreateTable name cols) = do
|
||||
result <- createTable name cols
|
||||
pure (result >> Right [])
|
||||
runStatementUncheckedM _ (DropTable name) = do
|
||||
result <- dropTable name
|
||||
pure (result >> Right [])
|
||||
runStatementUncheckedM _ (CreateIndex tbl col) = do
|
||||
result <- createIndex tbl col
|
||||
pure (result >> Right [])
|
||||
runStatementUncheckedM _ (DropIndex tbl col) = do
|
||||
result <- dropIndex tbl col
|
||||
pure (result >> Right [])
|
||||
runStatementUncheckedM _ (DropColumn tbl col) = do
|
||||
result <- dropColumn tbl col
|
||||
pure (result >> Right [])
|
||||
runStatementUncheckedM db (AddColumn tbl def) =
|
||||
alterTable db tbl (\table -> addColumnTo def (tableCols table) (tableRows table))
|
||||
runStatementUncheckedM db (RenameColumn tbl old new) =
|
||||
alterTable db tbl (\table -> renameColumnIn old new (tableCols table) (tableRows table))
|
||||
runStatementUncheckedM db (AlterColumnType tbl col ty) =
|
||||
alterTable db tbl (\table -> retypeColumn col ty (tableCols table) (tableRows table))
|
||||
runStatementUncheckedM db (AlterColumnDefault tbl col def) =
|
||||
alterTable db tbl (\table -> setColumnDefault col def (tableCols table) (tableRows table))
|
||||
runStatementUncheckedM db (AlterColumnNull tbl col nullable) =
|
||||
alterTable db tbl (\table -> setColumnNullable col nullable (tableCols table) (tableRows table))
|
||||
runStatementUncheckedM _ CreateUser{} = pure (Left "CREATE USER is executed by the account service")
|
||||
runStatementUncheckedM _ AlterUser{} = pure (Left "ALTER USER is executed by the account service")
|
||||
runStatementUncheckedM _ DropUser{} = pure (Left "DROP USER is executed by the account service")
|
||||
runStatementUncheckedM _ CreateRole{} = pure (Left "CREATE ROLE is executed by the privilege service")
|
||||
runStatementUncheckedM _ DropRole{} = pure (Left "DROP ROLE is executed by the privilege service")
|
||||
runStatementUncheckedM _ GrantPrivileges{} = pure (Left "GRANT is executed by the privilege service")
|
||||
runStatementUncheckedM _ RevokePrivileges{} = pure (Left "REVOKE is executed by the privilege service")
|
||||
runStatementUncheckedM _ GrantRole{} = pure (Left "GRANT is executed by the privilege service")
|
||||
runStatementUncheckedM _ RevokeRole{} = pure (Left "REVOKE is executed by the privilege service")
|
||||
runStatementUncheckedM _ q@CreateDatabase{} = runStatementM q
|
||||
runStatementUncheckedM _ q@DropDatabase{} = runStatementM q
|
||||
runStatementUncheckedM _ q@UseDatabase{} = runStatementM q
|
||||
runStatementUncheckedM _ ShowDatabases = runStatementM ShowDatabases
|
||||
|
||||
-- | 只有需要读全表才能判断约束时才扫表
|
||||
existingRows :: (MonadStorage m) => String -> Table -> m (Either String [Row])
|
||||
existingRows tbl table
|
||||
| needsRows table = scan tbl
|
||||
| otherwise = pure (Right [])
|
||||
where
|
||||
-- | 这一表有没有要判约束的列
|
||||
needsRows t = any (constraintColumn . snd) (tableCols t)
|
||||
-- | 这一列带不带要判的约束
|
||||
constraintColumn c = columnAutoIncrement c || columnUnique c || columnPrimaryKey c
|
||||
|
||||
-- | 插一行：补齐缺列、给自增值、收类型、查约束
|
||||
buildRows :: Table -> [Row] -> [String] -> [[Expr]] -> Either String [Row]
|
||||
buildRows table current cols rows = do
|
||||
values <- mapM (mapM (\e -> evalExpr e [])) rows
|
||||
if any (\vals -> length vals /= length cols) values
|
||||
then Left "column count does not match value count"
|
||||
else do
|
||||
let auto = autoColumn table
|
||||
go auto (autoStart auto current) values []
|
||||
where
|
||||
-- | 逐行构造，最后统一查一遍约束
|
||||
go _ _ [] acc = do
|
||||
let built = reverse acc
|
||||
mapM_ (runChecks table) built
|
||||
enforceNotNull (tableCols table) built
|
||||
enforceUnique (tableCols table) (current ++ built)
|
||||
Right built
|
||||
go auto counter (vals : rest) acc = do
|
||||
(row, counter') <- buildRow table auto cols counter vals
|
||||
go auto counter' rest (row : acc)
|
||||
|
||||
-- | 按列定义补出一行
|
||||
buildRow :: Table -> Maybe (String, Column) -> [String] -> Int -> [Value] -> Either String (Row, Int)
|
||||
buildRow table auto cols counter vals = go (tableCols table) counter []
|
||||
where
|
||||
provided = zip cols vals
|
||||
-- | 按列定义逐列补值
|
||||
go [] c acc = Right (reverse acc, c)
|
||||
go ((name, col) : rest) c acc = do
|
||||
(v, c') <- pick name col c
|
||||
v' <- coerceValue (columnType col) v
|
||||
go rest c' ((name, v') : acc)
|
||||
-- | 决定这一列取什么值
|
||||
pick name col c
|
||||
| Just (autoName, _) <- auto
|
||||
, name == autoName
|
||||
, maybe True (== VNull) (lookup name provided) = Right (VInt c, c + 1)
|
||||
| Just v <- lookup name provided = Right (v, bump name col c v)
|
||||
| Just d <- columnDefault col = Right (d, c)
|
||||
| columnNullable col = Right (VNull, c)
|
||||
| otherwise = Left ("INSERT: column " ++ name ++ " is NOT NULL and has no default")
|
||||
-- | 自增值跟着已有的值往前推
|
||||
bump name _ c v
|
||||
| Just (autoName, _) <- auto
|
||||
, name == autoName = max (c + 1) (valueInt v + 1)
|
||||
| otherwise = c
|
||||
|
||||
-- | 取自增值，不是整数就当 0
|
||||
valueInt :: Value -> Int
|
||||
valueInt (VInt n) = n
|
||||
valueInt _ = 0
|
||||
|
||||
-- | 自增列（至多一个）
|
||||
autoColumn :: Table -> Maybe (String, Column)
|
||||
autoColumn table = case [(n, c) | (n, c) <- tableCols table, columnAutoIncrement c] of
|
||||
(entry : _) -> Just entry
|
||||
[] -> Nothing
|
||||
|
||||
-- | 下一个自增值
|
||||
autoStart :: Maybe (String, Column) -> [Row] -> Int
|
||||
autoStart Nothing _ = 1
|
||||
autoStart (Just (name, _)) rows = case [n | r <- rows, Just (VInt n) <- [lookup name r]] of
|
||||
[] -> 1
|
||||
ns -> maximum ns + 1
|
||||
|
||||
-- | 执行 CHECK 约束
|
||||
runChecks :: Table -> Row -> Either String ()
|
||||
runChecks table row = mapM_ check (tableCols table)
|
||||
where
|
||||
-- | 查这一列的 CHECK
|
||||
check (name, col) = case columnCheck col of
|
||||
Nothing -> Right ()
|
||||
Just text -> case parseExpression text of
|
||||
Left err -> Left ("CHECK on " ++ name ++ ": " ++ firstLine err)
|
||||
Right e -> case evalCondForRow e row of
|
||||
Left err -> Left ("CHECK on " ++ name ++ ": " ++ err)
|
||||
Right True -> Right ()
|
||||
Right False -> Left ("CHECK on " ++ name ++ " failed")
|
||||
|
||||
-- | 只取第一行（报错提示用）
|
||||
firstLine :: String -> String
|
||||
firstLine = takeWhile (/= '\n')
|
||||
|
||||
-- | NOT NULL 检查
|
||||
enforceNotNull :: [(String, Column)] -> [Row] -> Either String ()
|
||||
enforceNotNull cols rows = mapM_ check cols
|
||||
where
|
||||
-- | 查这一列的 NOT NULL
|
||||
check (name, col)
|
||||
| columnNullable col = Right ()
|
||||
| any (\r -> lookup name r == Just VNull) rows = Left ("NOT NULL: column " ++ name ++ " cannot be null")
|
||||
| otherwise = Right ()
|
||||
|
||||
-- | 唯一性检查（NULL 之间不算冲突）
|
||||
enforceUnique :: [(String, Column)] -> [Row] -> Either String ()
|
||||
enforceUnique cols rows = mapM_ check targets
|
||||
where
|
||||
targets = [(n, c) | (n, c) <- cols, columnUnique c || columnPrimaryKey c]
|
||||
-- | 查这一列有没有重复值
|
||||
check (name, _) = go name [] (mapMaybe (lookup name) rows)
|
||||
-- | 逐个值比过去
|
||||
go _ _ [] = Right ()
|
||||
-- | NULL 不算冲突，跳过
|
||||
go name seen (VNull : rest) = go name seen rest
|
||||
go name seen (v : rest)
|
||||
| v `elem` seen = Left ("UNIQUE: duplicate value in column " ++ name)
|
||||
| otherwise = go name (v : seen) rest
|
||||
|
||||
-- | UPDATE 的一行（条件与赋值都可能带子查询）
|
||||
updateRowM :: (MonadStorage m) => Database -> Table -> Maybe Expr -> [(String, Expr)] -> Row -> m (Either String Row)
|
||||
updateRowM db table cond asgns row = do
|
||||
keep <- case cond of
|
||||
Nothing -> pure (Right True)
|
||||
Just e -> evalCondForRowM db e row
|
||||
case keep of
|
||||
Left err -> pure (Left err)
|
||||
Right False -> pure (Right row)
|
||||
Right True -> do
|
||||
row' <- applyUpdatesM db table asgns row
|
||||
pure (row' >>= \r -> runChecks table r >> Right r)
|
||||
|
||||
-- | 依次求值、收类型并覆盖列（表达式可以带子查询）
|
||||
applyUpdatesM :: (MonadStorage m) => Database -> Table -> [(String, Expr)] -> Row -> m (Either String Row)
|
||||
applyUpdatesM _ _ [] row = pure (Right row)
|
||||
applyUpdatesM db table ((col, e) : rest) row = do
|
||||
v <- evalExprM db e row
|
||||
case v of
|
||||
Left err -> pure (Left err)
|
||||
Right val -> case colType table col of
|
||||
Just def -> case coerceValue (columnType def) val of
|
||||
Left err -> pure (Left err)
|
||||
Right v' -> applyUpdatesM db table rest (setColumn col v' row)
|
||||
Nothing -> applyUpdatesM db table rest (setColumn col val row)
|
||||
|
||||
-- | 覆盖一列
|
||||
setColumn :: String -> Value -> Row -> Row
|
||||
setColumn col v = map (\(k, val) -> if k == col then (k, v) else (k, val))
|
||||
|
||||
-- | 按条件把行分成待删和保留两拨（条件可以带子查询）
|
||||
splitByConditionM :: (MonadStorage m) => Database -> Maybe Expr -> [Row] -> m (Either String ([Row], [Row]))
|
||||
splitByConditionM db cond = go [] []
|
||||
where
|
||||
-- | 逐行分流
|
||||
go doomed kept [] = pure (Right (reverse doomed, reverse kept))
|
||||
go doomed kept (r : rs) = do
|
||||
hit <- case cond of
|
||||
Nothing -> pure (Right True)
|
||||
Just e -> evalCondForRowM db e r
|
||||
case hit of
|
||||
Left err -> pure (Left err)
|
||||
Right h -> go (if h then r : doomed else doomed) (if h then kept else r : kept) rs
|
||||
|
||||
-- | 表结构变更的统一入口：扫全表，改完整体回写
|
||||
alterTable ::
|
||||
(MonadStorage m) =>
|
||||
Database ->
|
||||
String ->
|
||||
(Table -> Either String ([(String, Column)], [Row])) ->
|
||||
m (Either String [Row])
|
||||
alterTable db tbl change = case lookupTable db tbl of
|
||||
Left e -> pure (Left e)
|
||||
Right table -> do
|
||||
rowsResult <- scan tbl
|
||||
case rowsResult of
|
||||
Left e -> pure (Left e)
|
||||
Right rows -> case change table{tableRows = rows} >>= checkAltered of
|
||||
Left e -> pure (Left e)
|
||||
Right (cols, newRows) -> do
|
||||
result <- replaceSchema tbl cols newRows
|
||||
pure (result >> Right [])
|
||||
where
|
||||
-- | 改完再统一查一遍约束
|
||||
checkAltered (cols, rows) = do
|
||||
let table = Table tbl cols rows
|
||||
mapM_ (runChecks table) rows
|
||||
enforceNotNull cols rows
|
||||
enforceUnique cols rows
|
||||
Right (cols, rows)
|
||||
|
||||
-- | ADD COLUMN：老行补默认值或 NULL
|
||||
addColumnTo :: (String, Column) -> [(String, Column)] -> [Row] -> Either String ([(String, Column)], [Row])
|
||||
addColumnTo (name, col) cols rows
|
||||
| name `elem` map fst cols = Left ("ADD COLUMN: column already exists: " ++ name)
|
||||
| otherwise = do
|
||||
values <- fill
|
||||
Right (cols ++ [(name, col)], [r ++ [(name, v)] | (r, v) <- zip rows values])
|
||||
where
|
||||
fill
|
||||
| columnAutoIncrement col = mapM (coerceValue (columnType col) . VInt) [1 .. length rows]
|
||||
| Just d <- columnDefault col = mapM (\_ -> coerceValue (columnType col) d) rows
|
||||
| columnNullable col = mapM (\_ -> coerceValue (columnType col) VNull) rows
|
||||
| null rows = Right []
|
||||
| otherwise = Left ("ADD COLUMN: column " ++ name ++ " is NOT NULL and has no default")
|
||||
|
||||
-- | RENAME COLUMN：列定义与每一行的键一起改
|
||||
renameColumnIn :: String -> String -> [(String, Column)] -> [Row] -> Either String ([(String, Column)], [Row])
|
||||
renameColumnIn old new cols rows
|
||||
| old `notElem` map fst cols = Left ("RENAME COLUMN: unknown column: " ++ old)
|
||||
| new `elem` map fst cols = Left ("RENAME COLUMN: column already exists: " ++ new)
|
||||
| otherwise = Right (renameKeys cols, map renameKeys rows)
|
||||
where
|
||||
renameKeys = map (\(k, v) -> if k == old then (new, v) else (k, v))
|
||||
|
||||
-- | ALTER COLUMN TYPE：老值收进新类型
|
||||
retypeColumn :: String -> ColumnType -> [(String, Column)] -> [Row] -> Either String ([(String, Column)], [Row])
|
||||
retypeColumn col ty cols rows
|
||||
| col `notElem` map fst cols = Left ("ALTER COLUMN: unknown column: " ++ col)
|
||||
| otherwise = do
|
||||
rows' <- mapM convert rows
|
||||
Right (map (\entry@(n, c) -> if n == col then (n, c{columnType = ty}) else entry) cols, rows')
|
||||
where
|
||||
-- | 把这一列的老值收进新类型
|
||||
convert row = case lookup col row of
|
||||
Nothing -> Right row
|
||||
Just v -> do
|
||||
v' <- coerceValue ty v
|
||||
Right (map (\(k, x) -> if k == col then (k, v') else (k, x)) row)
|
||||
|
||||
-- | ALTER COLUMN SET/DROP DEFAULT
|
||||
setColumnDefault :: String -> Maybe Value -> [(String, Column)] -> [Row] -> Either String ([(String, Column)], [Row])
|
||||
setColumnDefault col def cols rows
|
||||
| col `notElem` map fst cols = Left ("ALTER COLUMN: unknown column: " ++ col)
|
||||
| otherwise = Right (map (\entry@(n, c) -> if n == col then (n, c{columnDefault = def}) else entry) cols, rows)
|
||||
|
||||
-- | ALTER COLUMN SET/DROP NOT NULL
|
||||
setColumnNullable :: String -> Bool -> [(String, Column)] -> [Row] -> Either String ([(String, Column)], [Row])
|
||||
setColumnNullable col nullable cols rows
|
||||
| col `notElem` map fst cols = Left ("ALTER COLUMN: unknown column: " ++ col)
|
||||
| otherwise = Right (map (\entry@(n, c) -> if n == col then (n, c{columnNullable = nullable}) else entry) cols, rows)
|
||||
@@ -0,0 +1,494 @@
|
||||
module ChuSQL.Core.Engine.Algebra.Eval (evalRelOp, evalRelOpM, evalExprM, evalCondForRowM) where
|
||||
|
||||
import ChuSQL.Core.Engine.Algebra.Expr (evalCondForRow, evalExpr)
|
||||
import ChuSQL.Core.Engine.Algebra.Optimize (optimize, relOpCols)
|
||||
import ChuSQL.Core.Engine.Algebra.Op
|
||||
import ChuSQL.Core.Engine.Algebra.Planner (translate)
|
||||
import ChuSQL.Core.Engine.Algebra.Sort (compareValue, sortRows)
|
||||
import ChuSQL.Core.Model
|
||||
import ChuSQL.Core.Engine.Storage (IndexResult (..), MonadStorage (..))
|
||||
import ChuSQL.Core.Engine.Storage.Memory (runMemoryStorage)
|
||||
import ChuSQL.Core.Engine.Syntax.AST (Expr (..), JoinKind (..), Subquery (..))
|
||||
import Control.Monad (filterM, foldM)
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
|
||||
-- 执行：按算子树算出结果行，外层行供相关子查询引用。
|
||||
|
||||
-- | 只保留清单里的列，顺序照清单
|
||||
project :: [String] -> Row -> Row
|
||||
project ["*"] row = row
|
||||
project cs row = [(c, v) | c <- cs, Just v <- [lookup c row]]
|
||||
|
||||
-- | 给列名加别名前缀
|
||||
addPrefix :: Maybe String -> Row -> Row
|
||||
addPrefix mAlias = map (\(k, v) -> (qualify mAlias k, v))
|
||||
|
||||
-- | 给一批行加别名前缀
|
||||
prefixRows :: Maybe String -> [Row] -> [Row]
|
||||
prefixRows mAlias = map (addPrefix mAlias)
|
||||
|
||||
-- | 值 → 字面量
|
||||
valueLiteral :: Value -> Expr
|
||||
valueLiteral (VInt n) = LitInt n
|
||||
valueLiteral (VFloat d) = LitFloat d
|
||||
valueLiteral (VStr s) = LitStr s
|
||||
valueLiteral (VBool b) = LitBool b
|
||||
valueLiteral VNull = LitNull
|
||||
|
||||
-- | 点查退化成扫描时用的条件
|
||||
lookupCondition :: Maybe String -> String -> Value -> Expr
|
||||
lookupCondition mAlias col k = Eq (Col (qualify mAlias col)) (valueLiteral k)
|
||||
|
||||
-- | 范围扫描退化成扫描时用的条件（闭端写成 > 或 = 的并）
|
||||
rangeCondition :: Maybe String -> String -> Maybe (Value, Bool) -> Maybe (Value, Bool) -> Expr
|
||||
rangeCondition mAlias col lo hi = case (lo, hi) of
|
||||
(Just l, Just h) -> And (bound Gt l) (bound Lt h)
|
||||
(Just l, Nothing) -> bound Gt l
|
||||
(Nothing, Just h) -> bound Lt h
|
||||
(Nothing, Nothing) -> LitBool True
|
||||
where
|
||||
c = Col (qualify mAlias col)
|
||||
-- | 一个端点的比较，闭端再加上等号
|
||||
bound rel (v, inclusive)
|
||||
| inclusive = Or (rel c (valueLiteral v)) (Eq c (valueLiteral v))
|
||||
| otherwise = rel c (valueLiteral v)
|
||||
|
||||
-- | 一批行的列名（空批给空清单）
|
||||
rowsCols :: [Row] -> [String]
|
||||
rowsCols (r : _) = map fst r
|
||||
rowsCols [] = []
|
||||
|
||||
-- | 参与等值匹配的键：NULL 不参与，整数值的浮点归一
|
||||
joinKey :: Value -> Maybe Value
|
||||
joinKey VNull = Nothing
|
||||
joinKey (VFloat d)
|
||||
| not (isNaN d)
|
||||
, not (isInfinite d)
|
||||
, fromIntegral (rounded :: Integer) == d =
|
||||
Just (VInt (fromIntegral rounded))
|
||||
where
|
||||
rounded = round d :: Integer
|
||||
joinKey v = Just v
|
||||
|
||||
-- | 取一行的连接键
|
||||
joinKeyOf :: String -> Row -> Maybe Value
|
||||
joinKeyOf c row = lookup c row >>= joinKey
|
||||
|
||||
-- | 等值连接的两侧列名
|
||||
data EquiKeys = EquiKeys
|
||||
{ ekLeft :: String
|
||||
, ekRight :: String
|
||||
}
|
||||
|
||||
-- | 认出 a = b 这种两列等值条件，并且能分清谁在左谁在右
|
||||
equiKeys :: [String] -> [String] -> Expr -> Maybe EquiKeys
|
||||
equiKeys lcols rcols (Eq (Col a) (Col b))
|
||||
| a /= b, a `elem` lcols, b `elem` rcols = Just (EquiKeys a b)
|
||||
| a /= b, b `elem` lcols, a `elem` rcols = Just (EquiKeys b a)
|
||||
equiKeys _ _ _ = Nothing
|
||||
|
||||
-- | 连接两批行：等值键走哈希，否则嵌套循环
|
||||
joinRowsIn ::
|
||||
(MonadStorage m) =>
|
||||
Database ->
|
||||
Row ->
|
||||
JoinKind ->
|
||||
[String] ->
|
||||
Expr ->
|
||||
[Row] ->
|
||||
[Row] ->
|
||||
m (Either String [Row])
|
||||
joinRowsIn db outer kind rcols cond lrows rrows =
|
||||
case equiKeys (rowsCols lrows) rcols cond of
|
||||
Just ks -> pure (Right (hashJoin kind ks ncols lrows rrows))
|
||||
Nothing -> filterPairsM db outer kind ncols cond lrows rrows
|
||||
where
|
||||
-- 右表为空时行上没有列名，用算子推导出来的列名补 NULL
|
||||
ncols = if null rrows then rcols else rowsCols rrows
|
||||
|
||||
-- | 左连接配不上的左行补 NULL，内连接丢弃
|
||||
unmatched :: JoinKind -> Row -> [String] -> [Row]
|
||||
unmatched InnerJoin _ _ = []
|
||||
unmatched LeftJoin l cols = [l ++ [(c, VNull) | c <- cols]]
|
||||
|
||||
-- | 哈希连接，输出顺序同嵌套循环
|
||||
hashJoin :: JoinKind -> EquiKeys -> [String] -> [Row] -> [Row] -> [Row]
|
||||
hashJoin kind ks ncols lrows rrows = concatMap probe lrows
|
||||
where
|
||||
buckets = HM.fromListWith (flip (++)) [(v, [r]) | r <- rrows, Just v <- [joinKeyOf (ekRight ks) r]]
|
||||
-- | 拿左行的键去桶里找
|
||||
probe l =
|
||||
let miss = case kind of
|
||||
InnerJoin -> []
|
||||
LeftJoin -> [l ++ nullRow]
|
||||
in case joinKeyOf (ekLeft ks) l of
|
||||
Nothing -> miss
|
||||
Just v -> case HM.lookupDefault [] v buckets of
|
||||
[] -> miss
|
||||
rs -> [l ++ r | r <- rs]
|
||||
nullRow = [(c, VNull) | c <- ncols]
|
||||
|
||||
-- | 把两边的行按条件配对（边配边筛，不先建整张积表）
|
||||
filterPairsM ::
|
||||
(MonadStorage m) =>
|
||||
Database ->
|
||||
Row ->
|
||||
JoinKind ->
|
||||
[String] ->
|
||||
Expr ->
|
||||
[Row] ->
|
||||
[Row] ->
|
||||
m (Either String [Row])
|
||||
filterPairsM db outer kind ncols cond lrows rrows = go lrows []
|
||||
where
|
||||
-- | 逐左行配对，左连接没配上就补 NULL
|
||||
go [] acc = pure (Right (reverse acc))
|
||||
go (l : ls) acc = do
|
||||
hits <- keep l rrows []
|
||||
case hits of
|
||||
Left e -> pure (Left e)
|
||||
Right hs -> do
|
||||
let hs' = case (kind, hs) of
|
||||
(LeftJoin, []) -> [l ++ nullRow]
|
||||
_ -> hs
|
||||
go ls (reverse hs' ++ acc)
|
||||
-- | 拿一行右行去比条件
|
||||
keep _ [] acc = pure (Right (reverse acc))
|
||||
keep l (r : rs) acc = do
|
||||
ok <- evalCondForRowM db cond (l ++ r ++ outer)
|
||||
case ok of
|
||||
Left e -> pure (Left e)
|
||||
Right True -> keep l rs ((l ++ r) : acc)
|
||||
Right False -> keep l rs acc
|
||||
nullRow = [(c, VNull) | c <- ncols]
|
||||
|
||||
-- | 索引连接：右表是裸 Scan 时逐左行点查
|
||||
probeIndexJoin ::
|
||||
(MonadStorage m) =>
|
||||
Database ->
|
||||
Row ->
|
||||
JoinKind ->
|
||||
Maybe String ->
|
||||
String ->
|
||||
EquiKeys ->
|
||||
[String] ->
|
||||
Expr ->
|
||||
Row ->
|
||||
m (Either String (Maybe [Row]))
|
||||
probeIndexJoin db outer kind mAlias t ks rcols cond l = case lookup (ekLeft ks) l of
|
||||
Nothing -> pure (Right (Just (unmatched kind l rcols)))
|
||||
Just k
|
||||
| not (indexSafe db t (unqualify mAlias (ekRight ks)) k) -> pure (Right Nothing)
|
||||
| otherwise -> do
|
||||
res <- lookupByColumn t (unqualify mAlias (ekRight ks)) k
|
||||
case res of
|
||||
Left e -> pure (Left e)
|
||||
Right NoIndex -> pure (Right Nothing)
|
||||
Right (IndexRows rows) -> do
|
||||
pairs <- joinRowsIn db outer kind rcols cond [l] (prefixRows mAlias rows)
|
||||
pure (fmap Just pairs)
|
||||
|
||||
-- | 列与键都不是浮点时才敢用索引
|
||||
indexSafe :: Database -> String -> String -> Value -> Bool
|
||||
indexSafe db t col k = case lookupTable db t of
|
||||
Left _ -> False
|
||||
Right tbl -> case lookup col (tableCols tbl) of
|
||||
Nothing -> False
|
||||
Just c -> not (floatType (columnType c)) && not (floatValue k)
|
||||
|
||||
-- | 是不是浮点列类型
|
||||
floatType :: ColumnType -> Bool
|
||||
floatType CFloat = True
|
||||
floatType CDouble = True
|
||||
floatType (CDecimal _ _) = True
|
||||
floatType _ = False
|
||||
|
||||
-- | 是不是浮点值
|
||||
floatValue :: Value -> Bool
|
||||
floatValue (VFloat _) = True
|
||||
floatValue _ = False
|
||||
|
||||
-- | 分组键的值
|
||||
groupKey :: [String] -> Row -> Either String [Value]
|
||||
groupKey keys row = mapM get keys
|
||||
where
|
||||
-- | 取这一列的分组值
|
||||
get c = maybe (Left ("unknown column: " ++ c)) Right (lookup c row)
|
||||
|
||||
-- | 按分组键把行分组，保留分组首次出现的顺序
|
||||
groupRows :: [String] -> [Row] -> Either String [([Value], [Row])]
|
||||
groupRows keys rows = go rows (HM.empty, [])
|
||||
where
|
||||
-- | 逐行塞进对应分组，并记住分组首次出现的顺序
|
||||
go [] (acc, order) = Right [(k, reverse (HM.lookupDefault [] k acc)) | k <- reverse order]
|
||||
go (r : rs) (acc, order) = do
|
||||
k <- groupKey keys r
|
||||
let order' = if HM.member k acc then order else k : order
|
||||
go rs (HM.insertWith (++) k [r] acc, order')
|
||||
|
||||
-- | 一组行上求同一个表达式（外层列从 outer 取）
|
||||
valuesOf :: Row -> Expr -> [Row] -> Either String [Value]
|
||||
valuesOf outer e rows = mapM (evalExpr e . (++ outer)) rows
|
||||
|
||||
-- | 去掉 NULL
|
||||
nonNull :: [Value] -> [Value]
|
||||
nonNull = filter (/= VNull)
|
||||
|
||||
-- | 数值相加：整数配整数还是整数
|
||||
addValue :: Value -> Value -> Either String Value
|
||||
addValue (VInt a) (VInt b) = Right (VInt (a + b))
|
||||
addValue (VInt a) (VFloat b) = Right (VFloat (fromIntegral a + b))
|
||||
addValue (VFloat a) (VInt b) = Right (VFloat (a + fromIntegral b))
|
||||
addValue (VFloat a) (VFloat b) = Right (VFloat (a + b))
|
||||
addValue _ _ = Left "type error: expected two numbers"
|
||||
|
||||
-- | 能当数用的值
|
||||
numberOf :: Value -> Either String Double
|
||||
numberOf (VInt n) = Right (fromIntegral n)
|
||||
numberOf (VFloat d) = Right d
|
||||
numberOf _ = Left "type error: expected a number"
|
||||
|
||||
-- | 一组值里的极值（NULL 已经先剔掉）
|
||||
extremeOf :: (Value -> Value -> Value) -> [Value] -> Either String Value
|
||||
extremeOf _ [] = Right VNull
|
||||
extremeOf pick (x : xs) = Right (foldl pick x xs)
|
||||
|
||||
-- | 一个聚合算子在一组行上的结果
|
||||
evalAgg :: Row -> Expr -> [Row] -> Either String Value
|
||||
evalAgg outer agg rows = case agg of
|
||||
CountAll -> Right (VInt (length rows))
|
||||
CountOf e -> do
|
||||
vs <- valuesOf outer e rows
|
||||
Right (VInt (length (nonNull vs)))
|
||||
SumOf e -> do
|
||||
vs <- valuesOf outer e rows
|
||||
case nonNull vs of
|
||||
[] -> Right VNull
|
||||
xs -> foldM addValue (VInt 0) xs
|
||||
AvgOf e -> do
|
||||
vs <- valuesOf outer e rows
|
||||
case nonNull vs of
|
||||
[] -> Right VNull
|
||||
xs -> do
|
||||
total <- foldM addValue (VInt 0) xs
|
||||
sumOf <- numberOf total
|
||||
Right (VFloat (sumOf / fromIntegral (length xs)))
|
||||
MinOf e -> valuesOf outer e rows >>= extremeOf lower . nonNull
|
||||
MaxOf e -> valuesOf outer e rows >>= extremeOf higher . nonNull
|
||||
_ -> Left "only COUNT, SUM, AVG, MIN and MAX can be aggregated"
|
||||
where
|
||||
-- | 取更小的那个
|
||||
lower a b = if compareValue b a == LT then b else a
|
||||
-- | 取更大的那个
|
||||
higher a b = if compareValue b a == GT then b else a
|
||||
|
||||
-- | 一组的输出行：分组列 + 各聚合值
|
||||
oneGroup :: Row -> [String] -> [(String, Expr)] -> ([Value], [Row]) -> Either String Row
|
||||
oneGroup outer keys aggs (keyValues, rows) = do
|
||||
values <- mapM (\(_, e) -> evalAgg outer e rows) aggs
|
||||
Right (zip keys keyValues ++ zip (map fst aggs) values)
|
||||
|
||||
-- | 分组求值：没有分组列时，即使没有行也要出一行
|
||||
evalAggregate :: Row -> [String] -> [(String, Expr)] -> [Row] -> Either String [Row]
|
||||
evalAggregate outer keys aggs rows = do
|
||||
groups <- groupRows keys rows
|
||||
let top = if null keys && null groups then [([], [])] else groups
|
||||
mapM (oneGroup outer keys aggs) top
|
||||
|
||||
-- | 单子过滤：条件本身是单子求值的
|
||||
filterRowsM :: (Monad m) => (Row -> m (Either String Bool)) -> [Row] -> m (Either String [Row])
|
||||
filterRowsM p = go []
|
||||
where
|
||||
-- | 逐行留下通过条件的
|
||||
go acc [] = pure (Right (reverse acc))
|
||||
go acc (r : rs) = do
|
||||
keep <- p r
|
||||
case keep of
|
||||
Left e -> pure (Left e)
|
||||
Right True -> go (r : acc) rs
|
||||
Right False -> go acc rs
|
||||
|
||||
-- | 按投影顺序逐项求值（可以带子查询）
|
||||
computeM :: (MonadStorage m) => Database -> Row -> [(String, Expr)] -> Row -> m (Either String Row)
|
||||
computeM db outer items row = go items []
|
||||
where
|
||||
-- | 逐项求值并攒成一行
|
||||
go [] acc = pure (Right (reverse acc))
|
||||
go ((label, e) : rest) acc = do
|
||||
v <- evalExprM db e (row ++ outer)
|
||||
case v of
|
||||
Left err -> pure (Left err)
|
||||
Right val -> go rest ((label, val) : acc)
|
||||
|
||||
-- | 表达式求值（先把子查询求成字面量）
|
||||
evalExprM :: (MonadStorage m) => Database -> Expr -> Row -> m (Either String Value)
|
||||
evalExprM db e env = do
|
||||
e' <- substSubqueries db e env
|
||||
pure (e' >>= \x -> evalExpr x env)
|
||||
|
||||
-- | 条件求值（先把子查询求成字面量）
|
||||
evalCondForRowM :: (MonadStorage m) => Database -> Expr -> Row -> m (Either String Bool)
|
||||
evalCondForRowM db e env = do
|
||||
e' <- substSubqueries db e env
|
||||
pure (e' >>= \x -> evalCondForRow x env)
|
||||
|
||||
-- | 子查询结果里唯一那一列的值
|
||||
rowValue :: Row -> Either String Value
|
||||
rowValue [(_, v)] = Right v
|
||||
rowValue _ = Left "subquery must return exactly one column"
|
||||
|
||||
-- | 标量子查询：0 行给 NULL，多行报错
|
||||
scalarResult :: Either String [Row] -> Either String Expr
|
||||
scalarResult rows = do
|
||||
rs <- rows
|
||||
case rs of
|
||||
[] -> Right LitNull
|
||||
[r] -> valueLiteral <$> rowValue r
|
||||
_ -> Left "scalar subquery returned more than one row"
|
||||
|
||||
-- | 把子查询求值成字面量；子查询的错直接往上传
|
||||
substSubqueries :: (MonadStorage m) => Database -> Expr -> Row -> m (Either String Expr)
|
||||
substSubqueries db e env = case e of
|
||||
ScalarSub sq -> scalarResult <$> runSubqueryRows db sq env
|
||||
InSub a sq negated -> do
|
||||
lhs <- substSubqueries db a env
|
||||
rows <- runSubqueryRows db sq env
|
||||
pure (do
|
||||
a' <- lhs
|
||||
rs <- rows
|
||||
vs <- mapM rowValue rs
|
||||
Right (InList a' (map valueLiteral vs) negated))
|
||||
ExistsSub sq negated -> do
|
||||
rows <- runSubqueryRows db sq env
|
||||
pure (fmap (\rs -> LitBool (if negated then null rs else not (null rs))) rows)
|
||||
InList a es negated -> do
|
||||
lhs <- substSubqueries db a env
|
||||
es' <- mapM (\x -> substSubqueries db x env) es
|
||||
pure (do
|
||||
a' <- lhs
|
||||
items <- sequence es'
|
||||
Right (InList a' items negated))
|
||||
Add a b -> bin Add a b
|
||||
Sub a b -> bin Sub a b
|
||||
Mul a b -> bin Mul a b
|
||||
Div a b -> bin Div a b
|
||||
Neg a -> un Neg a
|
||||
Gt a b -> bin Gt a b
|
||||
Lt a b -> bin Lt a b
|
||||
Eq a b -> bin Eq a b
|
||||
And a b -> bin And a b
|
||||
Or a b -> bin Or a b
|
||||
IsNull a -> un IsNull a
|
||||
IsNotNull a -> un IsNotNull a
|
||||
CountOf a -> un CountOf a
|
||||
SumOf a -> un SumOf a
|
||||
AvgOf a -> un AvgOf a
|
||||
MinOf a -> un MinOf a
|
||||
MaxOf a -> un MaxOf a
|
||||
_ -> pure (Right e)
|
||||
where
|
||||
-- | 递归处理两个子表达式
|
||||
bin ctor a b = do
|
||||
ra <- substSubqueries db a env
|
||||
case ra of
|
||||
Left err -> pure (Left err)
|
||||
Right a' -> do
|
||||
rb <- substSubqueries db b env
|
||||
pure ((ctor a') <$> rb)
|
||||
-- | 递归处理一个子表达式
|
||||
un ctor a = do
|
||||
ra <- substSubqueries db a env
|
||||
pure (ctor <$> ra)
|
||||
|
||||
-- | 跑子查询：翻译成算子树再求值，外层行做相关子查询的绑定
|
||||
runSubqueryRows :: (MonadStorage m) => Database -> Subquery -> Row -> m (Either String [Row])
|
||||
runSubqueryRows db sq outer = case translate (subqueryStatement sq) of
|
||||
Left e -> pure (Left e)
|
||||
Right op -> evalRelOpIn db outer (optimize db op)
|
||||
|
||||
-- | 单子求值：Scan/点查/范围查都问存储
|
||||
evalRelOpM :: (MonadStorage m) => Database -> RelOp -> m (Either String [Row])
|
||||
evalRelOpM db = evalRelOpIn db []
|
||||
|
||||
-- | 纯求值（内存存储，子查询走同一条路径）
|
||||
evalRelOp :: Database -> RelOp -> Either String [Row]
|
||||
evalRelOp db op = do
|
||||
(result, _) <- runMemoryStorage (evalRelOpIn db [] op) db
|
||||
result
|
||||
|
||||
-- | 带外层行的执行器
|
||||
evalRelOpIn :: (MonadStorage m) => Database -> Row -> RelOp -> m (Either String [Row])
|
||||
evalRelOpIn _ _ Unit = pure (Right [[]])
|
||||
evalRelOpIn db outer (Compute items op) = do
|
||||
rows <- evalRelOpIn db outer op
|
||||
case rows of
|
||||
Left e -> pure (Left e)
|
||||
Right rs -> do
|
||||
computed <- mapM (computeM db outer items) rs
|
||||
pure (sequence computed)
|
||||
evalRelOpIn db outer (Aggregate keys aggs op) = do
|
||||
rows <- evalRelOpIn db outer op
|
||||
pure (rows >>= evalAggregate outer keys aggs)
|
||||
evalRelOpIn _ _ (Scan mAlias tbl cols) = do
|
||||
res <- maybe (scan tbl) (scanColumns tbl) cols
|
||||
pure (fmap (prefixRows mAlias) res)
|
||||
evalRelOpIn db outer (Lookup mAlias tbl col k) = do
|
||||
res <- lookupByColumn tbl col k
|
||||
case res of
|
||||
Left e -> pure (Left e)
|
||||
Right NoIndex -> scanFiltered db outer mAlias tbl (lookupCondition mAlias col k)
|
||||
Right (IndexRows rows) -> pure (Right (prefixRows mAlias rows))
|
||||
evalRelOpIn db outer (Range mAlias tbl col lo hi) = do
|
||||
res <- scanRange tbl col lo hi
|
||||
case res of
|
||||
Left e -> pure (Left e)
|
||||
Right Nothing -> scanFiltered db outer mAlias tbl (rangeCondition mAlias col lo hi)
|
||||
Right (Just rows) -> pure (Right (prefixRows mAlias rows))
|
||||
evalRelOpIn db outer (Filter e op) = do
|
||||
rows <- evalRelOpIn db outer op
|
||||
case rows of
|
||||
Left err -> pure (Left err)
|
||||
Right rs -> filterRowsM (\r -> evalCondForRowM db e (r ++ outer)) rs
|
||||
evalRelOpIn db outer (Project cols op) = do
|
||||
rows <- evalRelOpIn db outer op
|
||||
pure (fmap (map (project cols)) rows)
|
||||
evalRelOpIn db outer (Sort spec op) = do
|
||||
rows <- evalRelOpIn db outer op
|
||||
pure (fmap (sortRows spec) rows)
|
||||
evalRelOpIn db outer (Limit n op) = do
|
||||
rows <- evalRelOpIn db outer op
|
||||
pure (fmap (take n) rows)
|
||||
evalRelOpIn db outer (Join kind l r c) = do
|
||||
lres <- evalRelOpIn db outer l
|
||||
case lres of
|
||||
Left e -> pure (Left e)
|
||||
Right ls -> do
|
||||
let nested = do
|
||||
rres <- evalRelOpIn db outer r
|
||||
case rres of
|
||||
Left e -> pure (Left e)
|
||||
Right rs -> joinRowsIn db outer kind (relOpCols db r) c ls rs
|
||||
case (r, equiKeys (relOpCols db l) (relOpCols db r) c) of
|
||||
(Scan mAlias t _, Just ks) -> do
|
||||
probed <- mapM (probeIndexJoin db outer kind mAlias t ks (relOpCols db r) c) ls
|
||||
case sequence probed of
|
||||
Left e -> pure (Left e)
|
||||
Right ms -> case sequence ms of
|
||||
Just rows -> pure (Right (concat rows))
|
||||
Nothing -> nested
|
||||
_ -> nested
|
||||
|
||||
-- | 扫描后按条件过滤（点查/范围查退化成扫描时用）
|
||||
scanFiltered ::
|
||||
(MonadStorage m) =>
|
||||
Database ->
|
||||
Row ->
|
||||
Maybe String ->
|
||||
String ->
|
||||
Expr ->
|
||||
m (Either String [Row])
|
||||
scanFiltered _ outer mAlias tbl cond = do
|
||||
res <- scan tbl
|
||||
pure $ do
|
||||
rows <- res
|
||||
filterM (evalCondForRow cond . (++ outer)) (prefixRows mAlias rows)
|
||||
@@ -0,0 +1,294 @@
|
||||
module ChuSQL.Core.Engine.Algebra.Expr (evalExpr, evalCondForRow, colsInExpr, aggregatesIn, hasAggregate, bareColumns, hasSubquery, inValues, threeValuedNot) where
|
||||
|
||||
import ChuSQL.Core.Model
|
||||
import ChuSQL.Core.Engine.Syntax.AST
|
||||
import Control.Monad (join)
|
||||
|
||||
-- 表达式求值：三值逻辑，NULL 参与运算结果仍是 NULL。
|
||||
|
||||
-- | 在一行上求出表达式的值
|
||||
evalExpr :: Expr -> Row -> Either String Value
|
||||
evalExpr (Col name) row =
|
||||
maybe (Left ("unknown column: " ++ name)) Right (lookup name row)
|
||||
evalExpr LitNull _ = Right VNull
|
||||
evalExpr (LitInt n) _ = Right (VInt n)
|
||||
evalExpr (LitFloat d) _ = Right (VFloat d)
|
||||
evalExpr (LitStr s) _ = Right (VStr s)
|
||||
evalExpr (LitBool b) _ = Right (VBool b)
|
||||
evalExpr (LitDate s) _ = Right (VStr s)
|
||||
evalExpr (LitTimestamp s) _ = Right (VStr s)
|
||||
evalExpr (LitBlob s) _ = Right (VStr s)
|
||||
evalExpr (Add a b) row = liftArith addArith a b row
|
||||
evalExpr (Sub a b) row = liftArith subArith a b row
|
||||
evalExpr (Mul a b) row = liftArith mulArith a b row
|
||||
evalExpr (Div a b) row = liftArith divArith a b row
|
||||
evalExpr (Neg a) row = do
|
||||
v <- evalExpr a row
|
||||
case v of
|
||||
VNull -> Right VNull
|
||||
VInt n -> Right (VInt (negate n))
|
||||
VFloat d -> Right (VFloat (negate d))
|
||||
_ -> Left "type error: expected a number"
|
||||
evalExpr (Gt a b) row = liftCompare (> EQ) a b row
|
||||
evalExpr (Lt a b) row = liftCompare (< EQ) a b row
|
||||
evalExpr (Eq a b) row = liftCompare (== EQ) a b row
|
||||
evalExpr (And a b) row = liftBool andValues a b row
|
||||
evalExpr (Or a b) row = liftBool orValues a b row
|
||||
evalExpr (IsNull a) row = do
|
||||
v <- evalExpr a row
|
||||
Right (VBool (v == VNull))
|
||||
evalExpr (IsNotNull a) row = do
|
||||
v <- evalExpr a row
|
||||
Right (VBool (v /= VNull))
|
||||
evalExpr (InList a es negated) row = do
|
||||
v <- evalExpr a row
|
||||
vs <- mapM (\e -> evalExpr e row) es
|
||||
r <- inValues v vs
|
||||
Right (if negated then threeValuedNot r else r)
|
||||
evalExpr (ScalarSub _) _ = Left subqueryNeedsDatabase
|
||||
evalExpr (InSub _ _ _) _ = Left subqueryNeedsDatabase
|
||||
evalExpr (ExistsSub _ _) _ = Left subqueryNeedsDatabase
|
||||
evalExpr agg _ = Left ("aggregate functions are not allowed here: " ++ show agg)
|
||||
|
||||
-- | 子查询要连上存储才能跑
|
||||
subqueryNeedsDatabase :: String
|
||||
subqueryNeedsDatabase = "subquery needs a database to run"
|
||||
|
||||
-- | IN 三值逻辑：命中为真，碰 NULL 得 NULL
|
||||
inValues :: Value -> [Value] -> Either String Value
|
||||
inValues VNull _ = Right VNull
|
||||
inValues v vs = do
|
||||
results <- mapM (compareValues (== EQ) v) vs
|
||||
Right $
|
||||
if VBool True `elem` results
|
||||
then VBool True
|
||||
else if VNull `elem` results then VNull else VBool False
|
||||
|
||||
-- | NOT 的三值取反
|
||||
threeValuedNot :: Value -> Value
|
||||
threeValuedNot (VBool b) = VBool (not b)
|
||||
threeValuedNot _ = VNull
|
||||
|
||||
-- | 表达式用到了哪些列
|
||||
colsInExpr :: Expr -> [String]
|
||||
colsInExpr (Col c) = [c]
|
||||
colsInExpr (Add a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (Sub a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (Mul a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (Div a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (Neg a) = colsInExpr a
|
||||
colsInExpr (Gt a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (Lt a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (Eq a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (And a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (Or a b) = colsInExpr a ++ colsInExpr b
|
||||
colsInExpr (IsNull a) = colsInExpr a
|
||||
colsInExpr (IsNotNull a) = colsInExpr a
|
||||
colsInExpr (CountOf a) = colsInExpr a
|
||||
colsInExpr (SumOf a) = colsInExpr a
|
||||
colsInExpr (AvgOf a) = colsInExpr a
|
||||
colsInExpr (MinOf a) = colsInExpr a
|
||||
colsInExpr (MaxOf a) = colsInExpr a
|
||||
colsInExpr (ScalarSub sq) = subqueryRefs sq
|
||||
colsInExpr (InSub a sq _) = colsInExpr a ++ subqueryRefs sq
|
||||
colsInExpr (InList a es _) = colsInExpr a ++ concatMap colsInExpr es
|
||||
colsInExpr (ExistsSub sq _) = subqueryRefs sq
|
||||
colsInExpr _ = []
|
||||
|
||||
-- | 表达式里有没有子查询
|
||||
hasSubquery :: Expr -> Bool
|
||||
hasSubquery e = case e of
|
||||
ScalarSub _ -> True
|
||||
InSub _ _ _ -> True
|
||||
InList a es _ -> any hasSubquery (a : es)
|
||||
ExistsSub _ _ -> True
|
||||
Add a b -> both a b
|
||||
Sub a b -> both a b
|
||||
Mul a b -> both a b
|
||||
Div a b -> both a b
|
||||
Neg a -> hasSubquery a
|
||||
Gt a b -> both a b
|
||||
Lt a b -> both a b
|
||||
Eq a b -> both a b
|
||||
And a b -> both a b
|
||||
Or a b -> both a b
|
||||
IsNull a -> hasSubquery a
|
||||
IsNotNull a -> hasSubquery a
|
||||
CountOf a -> hasSubquery a
|
||||
SumOf a -> hasSubquery a
|
||||
AvgOf a -> hasSubquery a
|
||||
MinOf a -> hasSubquery a
|
||||
MaxOf a -> hasSubquery a
|
||||
_ -> False
|
||||
where
|
||||
-- | 两个子表达式里任意一个有
|
||||
both a b = hasSubquery a || hasSubquery b
|
||||
|
||||
-- | 表达式里出现的聚合调用（按出现顺序）
|
||||
aggregatesIn :: Expr -> [Expr]
|
||||
aggregatesIn e = case e of
|
||||
a@CountAll -> [a]
|
||||
a@(CountOf _) -> [a]
|
||||
a@(SumOf _) -> [a]
|
||||
a@(AvgOf _) -> [a]
|
||||
a@(MinOf _) -> [a]
|
||||
a@(MaxOf _) -> [a]
|
||||
Add a b -> both a b
|
||||
Sub a b -> both a b
|
||||
Mul a b -> both a b
|
||||
Div a b -> both a b
|
||||
Neg a -> aggregatesIn a
|
||||
Gt a b -> both a b
|
||||
Lt a b -> both a b
|
||||
Eq a b -> both a b
|
||||
And a b -> both a b
|
||||
Or a b -> both a b
|
||||
IsNull a -> aggregatesIn a
|
||||
IsNotNull a -> aggregatesIn a
|
||||
_ -> []
|
||||
where
|
||||
-- | 两个子表达式的聚合拼起来
|
||||
both a b = aggregatesIn a ++ aggregatesIn b
|
||||
|
||||
-- | 表达式里有没有聚合调用
|
||||
hasAggregate :: Expr -> Bool
|
||||
hasAggregate = not . null . aggregatesIn
|
||||
|
||||
-- | 聚合之外的列引用（聚合参数里的列不算）
|
||||
bareColumns :: Expr -> [String]
|
||||
bareColumns e = case e of
|
||||
Col c -> [c]
|
||||
Add a b -> both a b
|
||||
Sub a b -> both a b
|
||||
Mul a b -> both a b
|
||||
Div a b -> both a b
|
||||
Neg a -> bareColumns a
|
||||
Gt a b -> both a b
|
||||
Lt a b -> both a b
|
||||
Eq a b -> both a b
|
||||
And a b -> both a b
|
||||
Or a b -> both a b
|
||||
IsNull a -> bareColumns a
|
||||
IsNotNull a -> bareColumns a
|
||||
ScalarSub sq -> subqueryRefs sq
|
||||
InSub a sq _ -> bareColumns a ++ subqueryRefs sq
|
||||
InList a es _ -> bareColumns a ++ concatMap bareColumns es
|
||||
ExistsSub sq _ -> subqueryRefs sq
|
||||
_ -> []
|
||||
where
|
||||
-- | 两个子表达式的裸列拼起来
|
||||
both a b = bareColumns a ++ bareColumns b
|
||||
|
||||
-- | 判断条件真假：只有 TRUE 通过，NULL 当作不通过
|
||||
evalCondForRow :: Expr -> Row -> Either String Bool
|
||||
evalCondForRow e row = do
|
||||
v <- evalExpr e row
|
||||
case v of
|
||||
VBool b -> Right b
|
||||
VNull -> Right False
|
||||
_ -> Left "type error: WHERE condition must be a boolean"
|
||||
|
||||
-- | 把二元运算提升到 Either
|
||||
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)
|
||||
|
||||
-- | 整数算术与浮点算术成对出现
|
||||
data Arith = Arith
|
||||
{ arithInt :: Int -> Int -> Either String Int
|
||||
, arithFloat :: Double -> Double -> Either String Double
|
||||
}
|
||||
|
||||
-- | 一边是 NULL 就出 NULL，两边都是整数就出整数
|
||||
liftArith :: Arith -> Expr -> Expr -> Row -> Either String Value
|
||||
liftArith ops a b row = liftBinOp go a b row
|
||||
where
|
||||
-- | NULL 出 NULL，整数配整数走整数算术
|
||||
go VNull _ = Right VNull
|
||||
go _ VNull = Right VNull
|
||||
go (VInt x) (VInt y) = VInt <$> arithInt ops x y
|
||||
go x y = case (asDouble x, asDouble y) of
|
||||
(Just p, Just q) -> VFloat <$> arithFloat ops p q
|
||||
_ -> Left "type error: expected two numbers"
|
||||
|
||||
-- | 能当数用的值
|
||||
asDouble :: Value -> Maybe Double
|
||||
asDouble (VInt n) = Just (fromIntegral n)
|
||||
asDouble (VFloat d) = Just d
|
||||
asDouble _ = Nothing
|
||||
|
||||
-- | 加法
|
||||
addArith :: Arith
|
||||
addArith = Arith (\x y -> Right (x + y)) (\x y -> Right (x + y))
|
||||
|
||||
-- | 减法
|
||||
subArith :: Arith
|
||||
subArith = Arith (\x y -> Right (x - y)) (\x y -> Right (x - y))
|
||||
|
||||
-- | 乘法
|
||||
mulArith :: Arith
|
||||
mulArith = Arith (\x y -> Right (x * y)) (\x y -> Right (x * y))
|
||||
|
||||
-- | 整数除法向零截断，溢出返回错误；浮点除法不能除以零
|
||||
divArith :: Arith
|
||||
divArith = Arith intDiv floatDiv
|
||||
where
|
||||
-- | 整数除法：除零与溢出都报错
|
||||
intDiv _ 0 = Left "division by zero"
|
||||
intDiv x y
|
||||
| x == minBound && y == -1 = Left "integer division overflow"
|
||||
| otherwise = Right (x `quot` y)
|
||||
-- | 浮点除法：不能除以零
|
||||
floatDiv _ 0 = Left "division by zero"
|
||||
floatDiv x y = Right (x / y)
|
||||
|
||||
-- | 比较：任一侧是 NULL 就给 NULL
|
||||
liftCompare ::
|
||||
(Ordering -> Bool) ->
|
||||
Expr ->
|
||||
Expr ->
|
||||
Row ->
|
||||
Either String Value
|
||||
liftCompare rel a b row = liftBinOp (compareValues rel) a b row
|
||||
|
||||
-- | 比较两个值：NULL 给 NULL，其余按数、串、布尔比
|
||||
compareValues :: (Ordering -> Bool) -> Value -> Value -> Either String Value
|
||||
compareValues rel x y
|
||||
| x == VNull || y == VNull = Right VNull
|
||||
| Just p <- asDouble x, Just q <- asDouble y = Right (VBool (rel (compare p q)))
|
||||
| (VStr p, VStr q) <- (x, y) = Right (VBool (rel (compare p q)))
|
||||
| (VBool p, VBool q) <- (x, y) = Right (VBool (rel (compare p q)))
|
||||
| otherwise = Left "type error: cannot compare these values"
|
||||
|
||||
-- | 布尔二元运算
|
||||
liftBool ::
|
||||
(Value -> Value -> Either String Value) ->
|
||||
Expr ->
|
||||
Expr ->
|
||||
Row ->
|
||||
Either String Value
|
||||
liftBool f = liftBinOp f
|
||||
|
||||
-- | 逻辑与的三值真值表
|
||||
andValues :: Value -> Value -> Either String Value
|
||||
andValues (VBool False) _ = Right (VBool False)
|
||||
andValues _ (VBool False) = Right (VBool False)
|
||||
andValues (VBool True) (VBool True) = Right (VBool True)
|
||||
andValues VNull (VBool True) = Right VNull
|
||||
andValues (VBool True) VNull = Right VNull
|
||||
andValues VNull VNull = Right VNull
|
||||
andValues _ _ = Left "type error: expected two booleans"
|
||||
|
||||
-- | 逻辑或的三值真值表
|
||||
orValues :: Value -> Value -> Either String Value
|
||||
orValues (VBool True) _ = Right (VBool True)
|
||||
orValues _ (VBool True) = Right (VBool True)
|
||||
orValues (VBool False) (VBool False) = Right (VBool False)
|
||||
orValues VNull (VBool False) = Right VNull
|
||||
orValues (VBool False) VNull = Right VNull
|
||||
orValues VNull VNull = Right VNull
|
||||
orValues _ _ = Left "type error: expected two booleans"
|
||||
@@ -0,0 +1,52 @@
|
||||
module ChuSQL.Core.Engine.Algebra.Op (RelOp (..), renderPlan) where
|
||||
|
||||
import ChuSQL.Core.Model (Value)
|
||||
import ChuSQL.Core.Engine.Syntax.AST (Expr, JoinKind (..), SortDir)
|
||||
|
||||
-- 关系代数算子定义与算子树文本渲染。
|
||||
|
||||
data RelOp
|
||||
= Scan (Maybe String) String (Maybe [String])
|
||||
| Lookup (Maybe String) String String Value
|
||||
| Range (Maybe String) String String (Maybe (Value, Bool)) (Maybe (Value, Bool))
|
||||
| Filter Expr RelOp
|
||||
| Project [String] RelOp
|
||||
| Compute [(String, Expr)] RelOp
|
||||
| Aggregate [String] [(String, Expr)] RelOp
|
||||
| Unit
|
||||
| Sort [(String, SortDir)] RelOp
|
||||
| Limit Int RelOp
|
||||
| Join JoinKind RelOp RelOp Expr
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 连接的显示名
|
||||
kindLabel :: JoinKind -> String
|
||||
kindLabel InnerJoin = "Join"
|
||||
kindLabel LeftJoin = "LeftJoin"
|
||||
|
||||
-- | 渲染成缩进文本
|
||||
renderPlan :: RelOp -> String
|
||||
renderPlan = go 0
|
||||
where
|
||||
-- | 按缩进渲染一个算子
|
||||
go ind op = case op of
|
||||
Scan a t cols -> pad ++ "Scan " ++ show a ++ " " ++ show t ++ maybe "" ((" columns=" ++) . show) cols
|
||||
Lookup _ t c k -> pad ++ "Lookup " ++ show t ++ "." ++ show c ++ " = " ++ show k
|
||||
Range _ t c lo hi -> pad ++ "Range " ++ show t ++ "." ++ show c ++ " " ++ show lo ++ " .. " ++ show hi
|
||||
Filter e x -> pad ++ "Filter " ++ show e ++ "\n" ++ go (ind + 1) x
|
||||
Project c x -> pad ++ "Project " ++ show c ++ "\n" ++ go (ind + 1) x
|
||||
Compute c x -> pad ++ "Compute " ++ show c ++ "\n" ++ go (ind + 1) x
|
||||
Aggregate keys aggs x ->
|
||||
pad
|
||||
++ "Aggregate keys="
|
||||
++ show keys
|
||||
++ " aggs="
|
||||
++ show [label ++ " <- " ++ show e | (label, e) <- aggs]
|
||||
++ "\n"
|
||||
++ go (ind + 1) x
|
||||
Unit -> pad ++ "Unit"
|
||||
Sort s x -> pad ++ "Sort " ++ show s ++ "\n" ++ go (ind + 1) x
|
||||
Limit n x -> pad ++ "Limit " ++ show n ++ "\n" ++ go (ind + 1) x
|
||||
Join k l r c -> pad ++ kindLabel k ++ " on " ++ show c ++ "\n" ++ go (ind + 1) l ++ "\n" ++ go (ind + 1) r
|
||||
where
|
||||
pad = replicate (ind * 2) ' '
|
||||
@@ -0,0 +1,238 @@
|
||||
module ChuSQL.Core.Engine.Algebra.Optimize (optimize, pushProject, relOpCols) where
|
||||
|
||||
import ChuSQL.Core.Engine.Algebra.Expr (colsInExpr, evalExpr)
|
||||
import ChuSQL.Core.Engine.Algebra.Op (RelOp (..))
|
||||
import ChuSQL.Core.Model
|
||||
import ChuSQL.Core.Engine.Syntax.AST (Expr (..), JoinKind (..))
|
||||
import Data.List (nub)
|
||||
|
||||
-- 查询优化：谓词下推、投影下推与常量折叠。
|
||||
|
||||
-- | 算子会产出哪些列
|
||||
relOpCols :: Database -> RelOp -> [String]
|
||||
relOpCols _ Unit = []
|
||||
relOpCols _ (Compute items _) = map fst items
|
||||
relOpCols _ (Aggregate keys aggs _) = keys ++ map fst aggs
|
||||
relOpCols _ (Scan mAlias _ (Just cols)) = map (qualify mAlias) cols
|
||||
relOpCols db (Scan mAlias tbl Nothing) =
|
||||
case lookup tbl db of
|
||||
Nothing -> []
|
||||
Just t -> map (prefix ++) (colNames t)
|
||||
where
|
||||
prefix = maybe "" (++ ".") mAlias
|
||||
relOpCols db (Lookup mAlias tbl _ _) = relOpCols db (Scan mAlias tbl Nothing)
|
||||
relOpCols db (Range mAlias tbl _ _ _) = relOpCols db (Scan mAlias tbl Nothing)
|
||||
relOpCols db (Filter _ x) = relOpCols db x
|
||||
relOpCols _ (Project ["*"] _) = ["*"]
|
||||
relOpCols _ (Project cols _) = cols
|
||||
relOpCols db (Sort _ x) = relOpCols db x
|
||||
relOpCols db (Limit _ x) = relOpCols db x
|
||||
relOpCols db (Join _ l r _) = relOpCols db l ++ relOpCols db r
|
||||
|
||||
-- | need 是否都在 have 里
|
||||
isSubsetOf :: [String] -> [String] -> Bool
|
||||
isSubsetOf _ ["*"] = True
|
||||
isSubsetOf need have = all (`elem` have) need
|
||||
|
||||
-- | 把 AND 链拆成清单
|
||||
splitConj :: Expr -> [Expr]
|
||||
splitConj (And a b) = splitConj a ++ splitConj b
|
||||
splitConj e = [e]
|
||||
|
||||
-- | 把条件清单用 AND 串起来
|
||||
combineConj :: [Expr] -> Maybe Expr
|
||||
combineConj [] = Nothing
|
||||
combineConj (e : es) = Just (foldl And e es)
|
||||
|
||||
-- | 条件按列归属分两边
|
||||
partitionPred :: [String] -> [Expr] -> ([Expr], [Expr])
|
||||
partitionPred have = foldr pick ([], [])
|
||||
where
|
||||
-- | 按列归属收到左边或右边
|
||||
pick e (yes, no)
|
||||
| colsInExpr e `isSubsetOf` have = (e : yes, no)
|
||||
| otherwise = (yes, e : no)
|
||||
|
||||
-- | 依次套上若干 Filter
|
||||
applyFilters :: [Expr] -> RelOp -> RelOp
|
||||
applyFilters [] op = op
|
||||
applyFilters (e : es) op = applyFilters es (Filter e op)
|
||||
|
||||
-- | Filter 压在内连接上时下推
|
||||
pushJoin :: Database -> Expr -> RelOp -> RelOp -> Expr -> RelOp
|
||||
pushJoin db p l r c =
|
||||
let preds = splitConj p
|
||||
lCols = relOpCols db l
|
||||
rCols = relOpCols db r
|
||||
(lPs, rest1) = partitionPred lCols preds
|
||||
(rPs, bothPs) = partitionPred rCols rest1
|
||||
l' = applyFilters lPs l
|
||||
r' = applyFilters rPs r
|
||||
joined = Join InnerJoin l' r' c
|
||||
in case combineConj bothPs of
|
||||
Nothing -> joined
|
||||
Just p' -> Filter p' joined
|
||||
|
||||
-- | Filter 压在左连接上时只下推纯左表的谓词
|
||||
pushLeftJoin :: Database -> Expr -> RelOp -> RelOp -> Expr -> RelOp
|
||||
pushLeftJoin db p l r c =
|
||||
let (lPs, rest) = partitionPred (relOpCols db l) (splitConj p)
|
||||
joined = Join LeftJoin (applyFilters lPs l) r c
|
||||
in case combineConj rest of
|
||||
Nothing -> joined
|
||||
Just p' -> Filter p' joined
|
||||
|
||||
-- | 合并两层 Filter 或挪到 Sort 下
|
||||
pushOne :: Database -> RelOp -> RelOp
|
||||
pushOne _ (Filter p (Filter q x))
|
||||
| not (hasDivision p || hasDivision q) = Filter (And p q) x
|
||||
pushOne _ (Filter p (Sort spec x))
|
||||
| not (hasDivision p) = Sort spec (Filter p x)
|
||||
pushOne _ op = op
|
||||
|
||||
-- | 除法可能报错，不能提前或延后求值
|
||||
hasDivision :: Expr -> Bool
|
||||
hasDivision e = case e of
|
||||
Div _ _ -> True
|
||||
Neg a -> hasDivision a
|
||||
Add a b -> both a b
|
||||
Sub a b -> both a b
|
||||
Mul a b -> both a b
|
||||
Gt a b -> both a b
|
||||
Lt a b -> both a b
|
||||
Eq a b -> both a b
|
||||
And a b -> both a b
|
||||
Or a b -> both a b
|
||||
_ -> False
|
||||
where
|
||||
-- | 两个子表达式里任意一个有除法
|
||||
both a b = hasDivision a || hasDivision b
|
||||
|
||||
-- | 检查子计划中可能报错的除法
|
||||
planHasDivision :: RelOp -> Bool
|
||||
planHasDivision (Filter p x) = hasDivision p || planHasDivision x
|
||||
planHasDivision (Join _ l r c) = hasDivision c || planHasDivision l || planHasDivision r
|
||||
planHasDivision (Compute items x) = any (hasDivision . snd) items || planHasDivision x
|
||||
planHasDivision (Project _ x) = planHasDivision x
|
||||
planHasDivision (Sort _ x) = planHasDivision x
|
||||
planHasDivision (Limit _ x) = planHasDivision x
|
||||
planHasDivision _ = False
|
||||
|
||||
-- | 是否要全部列
|
||||
needsAll :: [String] -> Bool
|
||||
needsAll = elem allColumns
|
||||
|
||||
-- | 叶子算子的投影下推
|
||||
pushProjectLeaf :: Database -> [String] -> RelOp -> RelOp
|
||||
pushProjectLeaf db need leaf
|
||||
| needsAll need = leaf
|
||||
| all (`elem` need) (relOpCols db leaf) = leaf
|
||||
| otherwise = Project need leaf
|
||||
|
||||
-- | 把需要哪些列往下传
|
||||
pushProject :: Database -> [String] -> RelOp -> RelOp
|
||||
pushProject _ _ Unit = Unit
|
||||
pushProject db _ (Compute items x) = Compute items (pushProject db (concatMap (colsInExpr . snd) items) x)
|
||||
pushProject db _ (Aggregate keys aggs x) =
|
||||
Aggregate keys aggs (pushProject db (keys ++ concatMap (colsInExpr . snd) aggs) x)
|
||||
pushProject db _ (Project cols x) = case pushProject db cols x of
|
||||
Project cols' y | cols' == cols -> Project cols y
|
||||
other -> Project cols other
|
||||
pushProject db need (Filter p x) = Filter p (pushProject db (need ++ colsInExpr p) x)
|
||||
pushProject db need (Sort spec x) = Sort spec (pushProject db (need ++ map fst spec) x)
|
||||
pushProject db need (Limit n x) = Limit n (pushProject db need x)
|
||||
pushProject db need (Join kind l r c)
|
||||
| needsAll need = Join kind (pushProject db need l) (pushProject db need r) c
|
||||
| otherwise =
|
||||
let tot = need ++ colsInExpr c
|
||||
lCols = relOpCols db l
|
||||
rCols = relOpCols db r
|
||||
lNeed = if needsAll lCols then ["*"] else [x | x <- tot, x `elem` lCols]
|
||||
rNeed = if needsAll rCols then ["*"] else [x | x <- tot, x `elem` rCols]
|
||||
in Join kind (pushProject db lNeed l) (pushProject db rNeed r) c
|
||||
pushProject db need leaf@(Scan a t _)
|
||||
| needsAll need = leaf
|
||||
| all (`elem` need) (relOpCols db leaf) = leaf
|
||||
| otherwise = Scan a t (Just (nub (map (unqualify a) need)))
|
||||
pushProject db need leaf@(Lookup _ _ _ _) = pushProjectLeaf db need leaf
|
||||
pushProject db need leaf@(Range _ _ _ _ _) = pushProjectLeaf db need leaf
|
||||
|
||||
-- | 折一个表达式节点
|
||||
foldNode :: Expr -> Expr
|
||||
foldNode e
|
||||
| null (colsInExpr e) = case evalExpr e [] of
|
||||
Right VNull -> LitNull
|
||||
Right (VInt n) -> LitInt n
|
||||
Right (VFloat d) -> LitFloat d
|
||||
Right (VStr s) -> LitStr s
|
||||
Right (VBool b) -> LitBool b
|
||||
Left _ -> e
|
||||
| otherwise = e
|
||||
|
||||
-- | 自底向上折整棵表达式
|
||||
foldConstants :: Expr -> Expr
|
||||
foldConstants (Add a b) = foldNode (Add (foldConstants a) (foldConstants b))
|
||||
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 (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))
|
||||
foldConstants (And a b) = foldNode (And (foldConstants a) (foldConstants b))
|
||||
foldConstants (Or a b) = foldNode (Or (foldConstants a) (foldConstants b))
|
||||
foldConstants e = e
|
||||
|
||||
-- | 单节点重写
|
||||
rewriteNode :: Database -> RelOp -> RelOp
|
||||
rewriteNode _ (Filter (Eq (Col k) (LitInt v)) (Scan mAlias t Nothing)) =
|
||||
Lookup mAlias t (unqualify mAlias k) (VInt v)
|
||||
rewriteNode _ (Filter (Eq (Col k) (LitStr v)) (Scan mAlias t Nothing)) =
|
||||
Lookup mAlias t (unqualify mAlias k) (VStr v)
|
||||
rewriteNode _ (Filter (And (Gt (Col k1) (LitInt lo)) (Lt (Col k2) (LitInt hi))) (Scan mAlias t Nothing))
|
||||
| k1 == k2 = Range mAlias t (unqualify mAlias k1) (Just (VInt lo, False)) (Just (VInt hi, False))
|
||||
rewriteNode _ (Filter (And (Gt (Col k1) (LitStr lo)) (Lt (Col k2) (LitStr hi))) (Scan mAlias t Nothing))
|
||||
| k1 == k2 = Range mAlias t (unqualify mAlias k1) (Just (VStr lo, False)) (Just (VStr hi, False))
|
||||
rewriteNode _ (Filter (Gt (Col k) (LitInt v)) (Scan mAlias t Nothing)) =
|
||||
Range mAlias t (unqualify mAlias k) (Just (VInt v, False)) Nothing
|
||||
rewriteNode _ (Filter (Gt (Col k) (LitStr v)) (Scan mAlias t Nothing)) =
|
||||
Range mAlias t (unqualify mAlias k) (Just (VStr v, False)) Nothing
|
||||
rewriteNode _ (Filter (Lt (Col k) (LitInt v)) (Scan mAlias t Nothing)) =
|
||||
Range mAlias t (unqualify mAlias k) Nothing (Just (VInt v, False))
|
||||
rewriteNode _ (Filter (Lt (Col k) (LitStr v)) (Scan mAlias t Nothing)) =
|
||||
Range mAlias t (unqualify mAlias k) Nothing (Just (VStr v, False))
|
||||
rewriteNode db (Filter p (Join kind l r c))
|
||||
| not (hasDivision p || planHasDivision (Join kind l r c)) =
|
||||
case kind of
|
||||
InnerJoin -> pushJoin db p l r c
|
||||
LeftJoin -> pushLeftJoin db p l r c
|
||||
rewriteNode db (Filter p x) = case foldConstants p of
|
||||
LitBool True -> x
|
||||
p' -> pushOne db (Filter p' x)
|
||||
rewriteNode _ (Project ["*"] x) = x
|
||||
rewriteNode _ (Compute items x) = Compute [(label, foldConstants e) | (label, e) <- items] x
|
||||
rewriteNode db op = pushOne db op
|
||||
|
||||
-- | 自底向上遍历一次
|
||||
optimizeRelOp :: Database -> RelOp -> RelOp
|
||||
optimizeRelOp db = rewriteNode db . descend
|
||||
where
|
||||
-- | 先递归处理子算子
|
||||
descend (Filter p x) = Filter p (optimizeRelOp db x)
|
||||
descend (Project cols x) = Project cols (optimizeRelOp db x)
|
||||
descend (Compute items x) = Compute items (optimizeRelOp db x)
|
||||
descend (Aggregate keys aggs x) = Aggregate keys aggs (optimizeRelOp db x)
|
||||
descend (Sort spec x) = Sort spec (optimizeRelOp db x)
|
||||
descend (Limit n x) = Limit n (optimizeRelOp db x)
|
||||
descend (Join kind l r c) = Join kind (optimizeRelOp db l) (optimizeRelOp db r) c
|
||||
descend x = x
|
||||
|
||||
-- | 反复跑到不动点
|
||||
optimizePredicates :: Database -> RelOp -> RelOp
|
||||
optimizePredicates db op =
|
||||
let op' = optimizeRelOp db op
|
||||
in if op' == op then op else optimizePredicates db op'
|
||||
|
||||
-- | 优化总入口
|
||||
optimize :: Database -> RelOp -> RelOp
|
||||
optimize db op = pushProject db ["*"] (optimizePredicates db op)
|
||||
@@ -0,0 +1,88 @@
|
||||
module ChuSQL.Core.Engine.Algebra.Planner (translate) where
|
||||
|
||||
import ChuSQL.Core.Engine.Algebra.Expr (aggregatesIn)
|
||||
import ChuSQL.Core.Engine.Algebra.Op
|
||||
import ChuSQL.Core.Engine.Syntax.AST
|
||||
|
||||
-- 计划生成：把语句翻译成算子树。
|
||||
|
||||
-- | 把 FROM 子句翻成 Scan / Join
|
||||
fromToRelOp :: FromClause -> RelOp
|
||||
fromToRelOp FromUnit = Unit
|
||||
fromToRelOp (FromTable mAlias tbl) = Scan mAlias tbl Nothing
|
||||
fromToRelOp (FromJoin kind left mAlias tbl cond) =
|
||||
Join kind (fromToRelOp left) (Scan mAlias tbl Nothing) cond
|
||||
|
||||
-- | 带上 WHERE 的来源
|
||||
source :: FromClause -> Maybe Expr -> RelOp
|
||||
source fromC mWhere = case mWhere of
|
||||
Nothing -> fromToRelOp fromC
|
||||
Just w -> Filter w (fromToRelOp fromC)
|
||||
|
||||
-- | 给用到的聚合起内部列名，同一个聚合只算一次
|
||||
nameAggs :: [(String, Expr)] -> [(String, Expr)]
|
||||
nameAggs items = go (1 :: Int) [] (concatMap (aggregatesIn . snd) items)
|
||||
where
|
||||
-- | 逐个聚合起名，重复的不再起名
|
||||
go :: Int -> [(String, Expr)] -> [Expr] -> [(String, Expr)]
|
||||
go _ acc [] = reverse acc
|
||||
go n acc (e : es)
|
||||
| any ((== e) . snd) acc = go n acc es
|
||||
| otherwise = go (n + 1) (("agg" ++ show n, e) : acc) es
|
||||
|
||||
-- | 把聚合调用换成对聚合结果的引用
|
||||
rewriteAggs :: [(String, Expr)] -> Expr -> Expr
|
||||
rewriteAggs aggs e = case [label | (label, agg) <- aggs, agg == e] of
|
||||
(label : _) -> Col label
|
||||
[] -> case e of
|
||||
Add a b -> Add (go a) (go b)
|
||||
Sub a b -> Sub (go a) (go b)
|
||||
Mul a b -> Mul (go a) (go b)
|
||||
Div a b -> Div (go a) (go b)
|
||||
Neg a -> Neg (go a)
|
||||
Gt a b -> Gt (go a) (go b)
|
||||
Lt a b -> Lt (go a) (go b)
|
||||
Eq a b -> Eq (go a) (go b)
|
||||
And a b -> And (go a) (go b)
|
||||
Or a b -> Or (go a) (go b)
|
||||
IsNull a -> IsNull (go a)
|
||||
IsNotNull a -> IsNotNull (go a)
|
||||
other -> other
|
||||
where
|
||||
go = rewriteAggs aggs
|
||||
|
||||
-- | 过滤 + 分组：没有分组也没有聚合时原样返回
|
||||
grouped :: [String] -> [(String, Expr)] -> RelOp -> (RelOp, [(String, Expr)])
|
||||
grouped keys items base
|
||||
| null keys && null aggs = (base, items)
|
||||
| otherwise = (Aggregate keys aggs base, [(label, rewriteAggs aggs e) | (label, e) <- items])
|
||||
where
|
||||
aggs = nameAggs items
|
||||
|
||||
-- | 排序 + 截断
|
||||
limited :: [(String, SortDir)] -> Maybe Int -> RelOp -> RelOp
|
||||
limited orderBy mLimit op = case mLimit of
|
||||
Nothing -> sorted
|
||||
Just n -> Limit n sorted
|
||||
where
|
||||
sorted = case orderBy of
|
||||
[] -> op
|
||||
spec -> Sort spec op
|
||||
|
||||
-- | 翻成：过滤 -> 分组 -> 排序 -> 截断 -> 取列
|
||||
translate :: Statement -> Either String RelOp
|
||||
translate q = case q of
|
||||
Select
|
||||
{ selectCols = cols
|
||||
, selectFrom = fromC
|
||||
, selectWhere = mWhere
|
||||
, selectGroupBy = groupBy
|
||||
, selectOrderBy = orderBy
|
||||
, selectLimit = mLimit
|
||||
} -> do
|
||||
let (plan, _) = grouped groupBy [] (source fromC mWhere)
|
||||
Right (Project cols (limited orderBy mLimit plan))
|
||||
SelectExpr items fromC mWhere groupBy orderBy mLimit -> do
|
||||
let (plan, items') = grouped groupBy items (source fromC mWhere)
|
||||
Right (Compute items' (limited orderBy mLimit plan))
|
||||
_ -> Left "only SELECT is supported by translate"
|
||||
@@ -0,0 +1,52 @@
|
||||
module ChuSQL.Core.Engine.Algebra.Sort (sortRows, compareValue) where
|
||||
|
||||
import ChuSQL.Core.Model
|
||||
import ChuSQL.Core.Engine.Syntax.AST
|
||||
import Data.List (sortBy)
|
||||
|
||||
-- 排序：按多列规格排出结果行，每列可升可降。
|
||||
|
||||
-- | 反转比较结果
|
||||
flipOrdering :: Ordering -> Ordering
|
||||
flipOrdering LT = GT
|
||||
flipOrdering GT = LT
|
||||
flipOrdering EQ = EQ
|
||||
|
||||
-- | 比较两个值：NULL 最小，数值跨整数与小数比较
|
||||
compareValue :: Value -> Value -> Ordering
|
||||
compareValue VNull VNull = EQ
|
||||
compareValue VNull _ = LT
|
||||
compareValue _ VNull = GT
|
||||
compareValue (VInt a) (VInt b) = compare a b
|
||||
compareValue (VFloat a) (VFloat b) = compare a b
|
||||
compareValue (VInt a) (VFloat b) = compare (fromIntegral a) b
|
||||
compareValue (VFloat a) (VInt b) = compare a (fromIntegral b)
|
||||
compareValue (VStr a) (VStr b) = compare a b
|
||||
compareValue (VBool a) (VBool b) = compare a b
|
||||
compareValue _ _ = EQ
|
||||
|
||||
-- | 取出排序键（按 spec 顺序，每行只查一次）
|
||||
sortKey :: [(String, SortDir)] -> Row -> [Maybe Value]
|
||||
sortKey spec row = [lookup col row | (col, _) <- spec]
|
||||
|
||||
-- | 比较两个排序键
|
||||
compareKeys :: [(String, SortDir)] -> [Maybe Value] -> [Maybe Value] -> Ordering
|
||||
compareKeys [] _ _ = EQ
|
||||
compareKeys ((_, dir) : rest) (a : as) (b : bs) =
|
||||
case (a, b) of
|
||||
(Just v1, Just v2) ->
|
||||
case compareValue v1 v2 of
|
||||
EQ -> compareKeys rest as bs
|
||||
o -> if dir == Desc then flipOrdering o else o
|
||||
_ -> compareKeys rest as bs
|
||||
compareKeys _ _ _ = EQ
|
||||
|
||||
-- | 按排序规格排序若干行
|
||||
sortRows :: [(String, SortDir)] -> [Row] -> [Row]
|
||||
sortRows [] rows = rows
|
||||
sortRows spec rows = map snd (sortBy cmp (map decorate rows))
|
||||
where
|
||||
-- | 取键并带上原行
|
||||
decorate row = (sortKey spec row, row)
|
||||
-- | 比较两个带键的行
|
||||
cmp (k1, _) (k2, _) = compareKeys spec k1 k2
|
||||
@@ -0,0 +1,729 @@
|
||||
module ChuSQL.Core.Engine.Semantic (check, prepare) 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 Data.Char (isAlphaNum, isAscii, toLower)
|
||||
import Data.List (intercalate, isInfixOf, isPrefixOf, nub)
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
-- 语义检查：表和列在不在、类型对不对，全部在执行前查。
|
||||
|
||||
-- | 推导出来的类型：NULL 没有类型，可以放进任何列
|
||||
data InferredType
|
||||
= InferNull
|
||||
| InferType ColumnType
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 给列名加上别名前缀
|
||||
prefixColumns :: Maybe String -> [(String, Column)] -> [(String, Column)]
|
||||
prefixColumns mAlias cols = [(prefix ++ c, ty) | (c, ty) <- cols]
|
||||
where
|
||||
prefix = maybe "" (++ ".") mAlias
|
||||
|
||||
-- | 检查期的作用域：本层优先，外层兜底
|
||||
data Scope = Scope
|
||||
{ scopeInner :: [(String, Column)]
|
||||
, scopeOuter :: [(String, Column)]
|
||||
}
|
||||
|
||||
-- | 本层先查，查不到再落外层；本层同名引起歧义时不往外层让
|
||||
scopeAt :: String -> Scope -> String -> Either String (String, Column)
|
||||
scopeAt place scope c
|
||||
| null (scopeOuter scope) = columnAt place (scopeInner scope) c
|
||||
| otherwise = case columnAt place (scopeInner scope) c of
|
||||
Right entry -> Right entry
|
||||
Left err
|
||||
| "ambiguous column:" `isInfixOf` err -> Left err
|
||||
| otherwise -> columnAt place (scopeOuter scope) c
|
||||
|
||||
-- | 收集 FROM 能提供的列，含外层作用域
|
||||
checkFrom :: Database -> [(String, Column)] -> FromClause -> Either String [(String, Column)]
|
||||
checkFrom _ _ FromUnit = Right []
|
||||
checkFrom db _ (FromTable mAlias tbl) = do
|
||||
t <- lookupTable db tbl
|
||||
Right (prefixColumns (Just (fromMaybe tbl mAlias)) (tableCols t))
|
||||
checkFrom db outer (FromJoin _ left mAlias tbl cond) = do
|
||||
lcols <- checkFrom db outer left
|
||||
t <- lookupTable db tbl
|
||||
let env = lcols ++ prefixColumns (Just (fromMaybe tbl mAlias)) (tableCols t)
|
||||
checkBool db "ON" (Scope env outer) cond
|
||||
Right env
|
||||
|
||||
-- | 合并两层列，本层优先且不重复
|
||||
scopedEnv :: [(String, Column)] -> [(String, Column)] -> [(String, Column)]
|
||||
scopedEnv env outer = env ++ [o | o <- outer, o `notElem` env]
|
||||
|
||||
-- | 把作用域摊平成一层的列清单
|
||||
scopeFlat :: Scope -> [(String, Column)]
|
||||
scopeFlat scope = scopedEnv (scopeInner scope) (scopeOuter scope)
|
||||
|
||||
-- | 拼“列不存在”的报错
|
||||
missingColumn :: String -> String -> [(String, Column)] -> String
|
||||
missingColumn place c env =
|
||||
"unknown column in " ++ place ++ ": " ++ c ++ hint
|
||||
where
|
||||
hint
|
||||
| null env = ""
|
||||
| otherwise = " (available: " ++ intercalate ", " (map (reverse . takeWhile (/= '.') . reverse . fst) env) ++ "; qualified: " ++ intercalate ", " (map fst env) ++ ")"
|
||||
|
||||
-- | 检查列是否都在环境里
|
||||
checkColumns :: String -> Scope -> [String] -> Either String ()
|
||||
checkColumns place env = mapM_ (\c -> if c == allColumns then Right () else () <$ scopeAt place env c)
|
||||
|
||||
-- | 在一层里查一列，报错时带上子句名与可用列
|
||||
columnAt :: String -> [(String, Column)] -> String -> Either String (String, Column)
|
||||
columnAt place env c = case resolveColumn c env of
|
||||
Right entry -> Right entry
|
||||
Left err | "ambiguous column:" `isPrefixOf` err -> Left (place ++ ": " ++ err)
|
||||
Left _ -> Left (missingColumn place c env)
|
||||
|
||||
-- | 聚合不能出现在 WHERE 里
|
||||
checkNoAggregate :: String -> Expr -> Either String ()
|
||||
checkNoAggregate place e
|
||||
| hasAggregate e = Left (place ++ ": aggregate functions are not allowed here")
|
||||
| otherwise = Right ()
|
||||
|
||||
-- | 分组查询里，没被聚合的列必须出现在 GROUP BY 里
|
||||
checkGrouping :: Scope -> [String] -> [(String, Expr)] -> Either String ()
|
||||
checkGrouping env keys items
|
||||
| null keys && not (any (hasAggregate . snd) items) = Right ()
|
||||
| otherwise = do
|
||||
checkColumns "GROUP BY" env keys
|
||||
mapM_ okCol (nub (concatMap (bareColumns . snd) items))
|
||||
where
|
||||
-- | 这一列能不能出现在分组查询里
|
||||
okCol c
|
||||
| c == allColumns = Left "SELECT: * cannot be selected together with GROUP BY"
|
||||
| c `elem` keys = Right ()
|
||||
| otherwise = Left ("SELECT: column " ++ c ++ " must appear in GROUP BY or be aggregated")
|
||||
|
||||
-- | 渲染一个推导类型
|
||||
renderType :: InferredType -> String
|
||||
renderType InferNull = "NULL"
|
||||
renderType (InferType t) = typeLabel t
|
||||
|
||||
-- | 推导表达式的类型（子查询也在这里整条查一遍）
|
||||
inferExpr :: Database -> String -> Scope -> Expr -> Either String InferredType
|
||||
inferExpr _ place env (Col c) = InferType . columnType . snd <$> scopeAt place env c
|
||||
inferExpr _ _ _ LitNull = Right InferNull
|
||||
inferExpr _ _ _ (LitInt _) = Right (InferType CInt)
|
||||
inferExpr _ _ _ (LitFloat _) = Right (InferType CFloat)
|
||||
inferExpr _ _ _ (LitStr _) = Right (InferType CStr)
|
||||
inferExpr _ _ _ (LitBool _) = Right (InferType CBool)
|
||||
inferExpr _ _ _ (LitDate _) = Right (InferType CDate)
|
||||
inferExpr _ _ _ (LitTimestamp _) = Right (InferType CTimestamp)
|
||||
inferExpr _ _ _ (LitBlob _) = Right (InferType CBlob)
|
||||
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
|
||||
inferExpr db place env (Div a b) = arithmetic db place env a b
|
||||
inferExpr db place env (Neg a) = do
|
||||
t <- inferExpr db place env a
|
||||
case t of
|
||||
InferNull -> Right InferNull
|
||||
InferType x
|
||||
| numericType x -> Right t
|
||||
| otherwise -> Left (place ++ ": operator needs TInt on both sides, got TInt and " ++ typeLabel x)
|
||||
inferExpr db place env (Gt a b) = comparison db place env a b
|
||||
inferExpr db place env (Lt a b) = comparison db place env a b
|
||||
inferExpr db place env (Eq a b) = comparison db place env a b
|
||||
inferExpr db place env (And a b) = boolean db place env a b
|
||||
inferExpr db place env (Or a b) = boolean db place env a b
|
||||
inferExpr db place env (IsNull a) = inferExpr db place env a >> Right (InferType CBool)
|
||||
inferExpr db place env (IsNotNull a) = inferExpr db place env a >> Right (InferType CBool)
|
||||
inferExpr _ _ _ CountAll = Right (InferType CInt)
|
||||
inferExpr db place env (CountOf a) = do
|
||||
_ <- aggregateArg db place env a
|
||||
Right (InferType CInt)
|
||||
inferExpr db place env (SumOf a) = aggregateArg db place env a >>= numericResult "SUM" place
|
||||
inferExpr db place env (AvgOf a) = do
|
||||
t <- aggregateArg db place env a
|
||||
case t of
|
||||
InferNull -> Right InferNull
|
||||
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 (ScalarSub sq) = do
|
||||
cols <- inferSubqueryOutput db env sq
|
||||
case cols of
|
||||
[(_, t)] -> Right t
|
||||
_ -> Left (place ++ ": scalar subquery must return exactly one column")
|
||||
inferExpr db place env (InSub a sq _) = do
|
||||
ta <- inferExpr db place env a
|
||||
cols <- inferSubqueryOutput db env sq
|
||||
case cols of
|
||||
[(_, t)]
|
||||
| compatible ta t -> Right (InferType CBool)
|
||||
| otherwise -> Left (place ++ ": IN subquery column has type " ++ renderType t ++ ", expected " ++ renderType ta)
|
||||
_ -> Left (place ++ ": IN subquery must return exactly one column")
|
||||
inferExpr db place env (InList a es _) = do
|
||||
ta <- inferExpr db place env a
|
||||
ts <- mapM (inferExpr db place env) es
|
||||
mapM_ (itemType place ta) ts
|
||||
Right (InferType CBool)
|
||||
inferExpr _ _ _ (ExistsSub _ _) = Right (InferType CBool)
|
||||
|
||||
-- | IN 列表里的每一项都要跟左边的类型对得上
|
||||
itemType :: String -> InferredType -> InferredType -> Either String ()
|
||||
itemType place want got
|
||||
| compatible want got = Right ()
|
||||
| otherwise = Left (place ++ ": IN list item has type " ++ renderType got ++ ", expected " ++ renderType want)
|
||||
|
||||
-- | 推导子查询的输出列与类型
|
||||
inferSubqueryOutput :: Database -> Scope -> Subquery -> Either String [(String, InferredType)]
|
||||
inferSubqueryOutput db outerScope sq = case subqueryStatement sq of
|
||||
q@Select { selectCols = cols } -> do
|
||||
env <- checkFrom db enclosing (selectFrom q)
|
||||
checkResolvedWith db enclosing q
|
||||
mapM (columnTypeOf env) cols
|
||||
q@SelectExpr { selectItems = items } -> do
|
||||
env <- checkFrom db enclosing (selectFrom q)
|
||||
checkResolvedWith db enclosing q
|
||||
mapM (\(l, e) -> (\t -> (l, t)) <$> inferExpr db "SELECT" (Scope env enclosing) e) items
|
||||
_ -> Left "subquery must be a SELECT"
|
||||
where
|
||||
enclosing = scopeFlat outerScope
|
||||
-- | 查这一列的推导类型
|
||||
columnTypeOf env c = do
|
||||
(_, col) <- scopeAt "SELECT" (Scope env enclosing) c
|
||||
Right (c, InferType (columnType col))
|
||||
|
||||
-- | 聚合的参数：列要在，且不能嵌套聚合
|
||||
aggregateArg :: Database -> String -> Scope -> Expr -> Either String InferredType
|
||||
aggregateArg db place env a
|
||||
| hasAggregate a = Left (place ++ ": nested aggregates are not allowed")
|
||||
| otherwise = inferExpr db place env a
|
||||
|
||||
-- | 数值聚合的结果类型：整数进整数出，其它往浮点靠
|
||||
numericResult :: String -> String -> InferredType -> Either String InferredType
|
||||
numericResult fn place t = case t of
|
||||
InferNull -> Right InferNull
|
||||
InferType x
|
||||
| numericType x -> Right (if integerType x then InferType x else InferType CFloat)
|
||||
| otherwise -> Left (place ++ ": " ++ fn ++ " needs a number, got " ++ typeLabel x)
|
||||
|
||||
-- | 算术结果：有小数就出小数，否则是整数
|
||||
arithResult :: InferredType -> InferredType -> InferredType
|
||||
arithResult InferNull _ = InferNull
|
||||
arithResult _ InferNull = InferNull
|
||||
arithResult (InferType a) (InferType b)
|
||||
| integerType a && integerType b = InferType CInt
|
||||
| otherwise = InferType CFloat
|
||||
|
||||
-- | 算术两边的类型检查
|
||||
arithmetic :: Database -> String -> Scope -> Expr -> Expr -> Either String InferredType
|
||||
arithmetic db place env a b = do
|
||||
ta <- inferExpr db place env a
|
||||
tb <- inferExpr db place env b
|
||||
let want = if any isFloatSide [ta, tb] then CFloat else CInt
|
||||
mapM_ (numericOperand place (InferType want) (InferType want)) [ta, tb]
|
||||
Right (arithResult ta tb)
|
||||
where
|
||||
-- | 是不是浮点类型
|
||||
isFloatSide (InferType x) = numericType x && not (integerType x)
|
||||
isFloatSide _ = False
|
||||
|
||||
-- | 一侧必须是数
|
||||
numericOperand :: String -> InferredType -> InferredType -> InferredType -> Either String ()
|
||||
numericOperand place want other t = case t of
|
||||
InferNull -> Right ()
|
||||
InferType x | numericType x -> Right ()
|
||||
_ -> Left (place ++ ": operator needs " ++ renderType want ++ " on both sides, got " ++ renderType other ++ " and " ++ renderType t)
|
||||
|
||||
-- | 比较两边的类型检查
|
||||
comparison :: Database -> String -> Scope -> Expr -> Expr -> Either String InferredType
|
||||
comparison db place env a b = do
|
||||
ta <- inferExpr db place env a
|
||||
tb <- inferExpr db place env b
|
||||
if compatible ta tb
|
||||
then Right (InferType CBool)
|
||||
else Left (place ++ ": both sides of = must have the same type, got " ++ renderType ta ++ " and " ++ renderType tb)
|
||||
|
||||
-- | 两类能不能比
|
||||
compatible :: InferredType -> InferredType -> Bool
|
||||
compatible InferNull _ = True
|
||||
compatible _ InferNull = True
|
||||
compatible (InferType a) (InferType b)
|
||||
| numericType a && numericType b = True
|
||||
| typeClassOf a == typeClassOf b = True
|
||||
| typeClassOf a == TemporalClass && typeClassOf b == TextClass = True
|
||||
| typeClassOf b == TemporalClass && typeClassOf a == TextClass = True
|
||||
| otherwise = False
|
||||
|
||||
-- | 逻辑运算两边的类型检查
|
||||
boolean :: Database -> String -> Scope -> Expr -> Expr -> Either String InferredType
|
||||
boolean db place env a b = do
|
||||
ta <- inferExpr db place env a
|
||||
tb <- inferExpr db place env b
|
||||
mapM_ (boolOperand place ta) [ta, tb]
|
||||
Right (InferType CBool)
|
||||
where
|
||||
-- | 挨个查操作数是不是布尔
|
||||
boolOperand _ _ InferNull = Right ()
|
||||
boolOperand _ _ (InferType CBool) = Right ()
|
||||
boolOperand p other t = Left (p ++ ": operator needs TBool on both sides, got " ++ renderType other ++ " and " ++ renderType t)
|
||||
|
||||
-- | 要求条件能算出布尔
|
||||
checkBool :: Database -> String -> Scope -> Expr -> Either String ()
|
||||
checkBool db place env e = do
|
||||
checkColumns place env (colsInExpr e)
|
||||
t <- inferExpr db place env e
|
||||
case t of
|
||||
InferNull -> Right ()
|
||||
InferType CBool -> Right ()
|
||||
InferType x -> Left (place ++ ": condition must be a boolean, got " ++ typeLabel x)
|
||||
|
||||
-- | 检查赋值列和类型
|
||||
checkTyped :: Database -> String -> Scope -> Table -> (String, Expr) -> Either String ()
|
||||
checkTyped db place env t (c, e) = do
|
||||
want <- maybe (Left (missingColumn place c (tableCols t))) Right (colType t c)
|
||||
got <- inferExpr db place env e
|
||||
case got of
|
||||
InferNull -> Right ()
|
||||
InferType x
|
||||
| assignable (columnType want) x -> Right ()
|
||||
| otherwise -> Left (place ++ ": column " ++ c ++ " needs " ++ show want ++ ", got " ++ typeLabel x)
|
||||
|
||||
-- | 检查插入值的类型
|
||||
checkValue :: Database -> Table -> (String, Expr) -> Either String ()
|
||||
checkValue db = checkTyped db "INSERT" (Scope [] [])
|
||||
|
||||
-- | 检查 UPDATE 的赋值
|
||||
checkAssign :: Database -> Table -> (String, Expr) -> Either String ()
|
||||
checkAssign db t = checkTyped db "UPDATE" (Scope (tableCols t) []) t
|
||||
|
||||
-- | 按语句类型分派检查
|
||||
check :: Database -> Statement -> Either String ()
|
||||
check db q = () <$ prepare db q
|
||||
|
||||
-- | 执行前解析列名并检查类型
|
||||
prepare :: Database -> Statement -> Either String Statement
|
||||
prepare db q = do
|
||||
resolved <- resolveStatement db q
|
||||
checkResolved db resolved
|
||||
pure resolved
|
||||
|
||||
-- | 检查已解析的语句
|
||||
checkResolved :: Database -> Statement -> Either String ()
|
||||
checkResolved db = checkResolvedWith db []
|
||||
|
||||
-- | 检查已解析的语句；outer 是相关子查询能看见的外层列
|
||||
checkResolvedWith :: Database -> [(String, Column)] -> Statement -> Either String ()
|
||||
checkResolvedWith db outer q = case q of
|
||||
Select
|
||||
{ selectCols = cols
|
||||
, selectFrom = fromC
|
||||
, selectWhere = mWhere
|
||||
, selectGroupBy = groupBy
|
||||
, selectOrderBy = orderBy
|
||||
} -> do
|
||||
env <- checkFrom db outer fromC
|
||||
let full = Scope env outer
|
||||
checkColumns "SELECT" full cols
|
||||
checkGrouping full groupBy (map (\c -> (c, Col c)) cols)
|
||||
checkColumns "ORDER BY" full (map fst orderBy)
|
||||
mapM_ (checkNoAggregate "WHERE") mWhere
|
||||
mapM_ (checkBool db "WHERE" full) mWhere
|
||||
SelectExpr items fromC mWhere groupBy orderBy _ -> do
|
||||
env <- checkFrom db outer fromC
|
||||
let full = Scope env outer
|
||||
mapM_ (\item -> () <$ inferExpr db "SELECT" full (snd item)) items
|
||||
checkGrouping full groupBy items
|
||||
checkColumns "ORDER BY" full (map fst orderBy)
|
||||
mapM_ (checkNoAggregate "WHERE") mWhere
|
||||
mapM_ (checkBool db "WHERE" full) mWhere
|
||||
Insert tbl cols rows -> do
|
||||
t <- lookupTable db tbl
|
||||
checkColumns "INSERT" (Scope (tableCols t) []) cols
|
||||
if null rows
|
||||
then Left "INSERT: no values"
|
||||
else mapM_ (mapM_ (checkValue db t) . zip cols) rows
|
||||
checkInsertTargets t cols
|
||||
Delete tbl mWhere -> do
|
||||
t <- lookupTable db tbl
|
||||
mapM_ (checkBool db "WHERE" (Scope (tableCols t) [])) mWhere
|
||||
Update tbl assigns mWhere -> do
|
||||
t <- lookupTable db tbl
|
||||
checkColumns "UPDATE" (Scope (tableCols t) []) (map fst assigns)
|
||||
mapM_ (checkAssign db t) assigns
|
||||
mapM_ (checkBool db "WHERE" (Scope (tableCols t) [])) mWhere
|
||||
CreateTable name cols -> do
|
||||
if null name
|
||||
then Left "CREATE TABLE: empty table name"
|
||||
else do
|
||||
let names = map fst cols
|
||||
if length names /= length (nub names)
|
||||
then Left ("CREATE TABLE: duplicate column names in " ++ name)
|
||||
else Right ()
|
||||
checkColumnDefs (map fst cols) cols
|
||||
DropTable name ->
|
||||
if null name
|
||||
then Left "DROP TABLE: empty table name"
|
||||
else Right ()
|
||||
CreateIndex tbl col -> do
|
||||
t <- lookupTable db tbl
|
||||
if col `elem` tableCols' t
|
||||
then Right ()
|
||||
else Left ("CREATE INDEX: unknown column: " ++ col)
|
||||
DropIndex tbl col -> do
|
||||
t <- lookupTable db tbl
|
||||
if col `elem` tableCols' t
|
||||
then Right ()
|
||||
else Left ("DROP INDEX: unknown column: " ++ col)
|
||||
DropColumn tbl col -> do
|
||||
t <- lookupTable db tbl
|
||||
if col `notElem` tableCols' t
|
||||
then Left ("DROP COLUMN: unknown column: " ++ col)
|
||||
else
|
||||
if col == idColumn
|
||||
then Left "DROP COLUMN: the built-in id column cannot be dropped"
|
||||
else Right ()
|
||||
AddColumn tbl def -> do
|
||||
t <- lookupTable db tbl
|
||||
if fst def `elem` tableCols' t
|
||||
then Left ("ADD COLUMN: column already exists: " ++ fst def)
|
||||
else Right ()
|
||||
checkColumnDefs (tableCols' t ++ [fst def]) [def]
|
||||
RenameColumn tbl old new -> do
|
||||
t <- lookupTable db tbl
|
||||
if old `notElem` tableCols' t
|
||||
then Left ("RENAME COLUMN: unknown column: " ++ old)
|
||||
else Right ()
|
||||
if old == idColumn
|
||||
then Left "RENAME COLUMN: the built-in id column cannot be renamed"
|
||||
else
|
||||
if new `elem` tableCols' t
|
||||
then Left ("RENAME COLUMN: column already exists: " ++ new)
|
||||
else Right ()
|
||||
AlterColumnType tbl col ty -> do
|
||||
t <- lookupTable db tbl
|
||||
c <- requireColumn "ALTER COLUMN" t col
|
||||
if columnAutoIncrement c && not (integerType ty)
|
||||
then Left "ALTER COLUMN: AUTO_INCREMENT column must stay an integer type"
|
||||
else Right ()
|
||||
AlterColumnDefault tbl col def -> do
|
||||
t <- lookupTable db tbl
|
||||
c <- requireColumn "ALTER COLUMN" t col
|
||||
mapM_ (\v -> checkDefault c v) def
|
||||
AlterColumnNull tbl col nullable -> do
|
||||
t <- lookupTable db tbl
|
||||
c <- requireColumn "ALTER COLUMN" t col
|
||||
if not nullable && columnAutoIncrement c
|
||||
then Left "ALTER COLUMN: AUTO_INCREMENT column cannot be nullable"
|
||||
else Right ()
|
||||
CreateUser name password -> checkAccount name password
|
||||
AlterUser name password -> checkAccount name password
|
||||
DropUser name -> checkUserName name
|
||||
CreateRole name -> checkRoleName name
|
||||
DropRole name -> checkRoleName name
|
||||
GrantPrivileges privs obj role -> do
|
||||
mapM_ checkPrivilege privs
|
||||
checkGrantObject obj
|
||||
checkRoleName role
|
||||
RevokePrivileges privs obj role -> do
|
||||
mapM_ checkPrivilege privs
|
||||
checkGrantObject obj
|
||||
checkRoleName role
|
||||
GrantRole role members -> do
|
||||
checkRoleName role
|
||||
mapM_ checkUserName members
|
||||
RevokeRole role members -> do
|
||||
checkRoleName role
|
||||
mapM_ checkUserName members
|
||||
CreateDatabase name -> checkDatabaseName name
|
||||
DropDatabase name -> checkDatabaseName name
|
||||
UseDatabase name -> checkDatabaseName name
|
||||
ShowDatabases -> Right ()
|
||||
where
|
||||
tableCols' = map fst . tableCols
|
||||
|
||||
-- | 查一列，没有就报错
|
||||
requireColumn :: String -> Table -> String -> Either String Column
|
||||
requireColumn place t c = maybe (Left (place ++ ": unknown column: " ++ c)) Right (colType t c)
|
||||
|
||||
-- | 插入时没提到的列能不能自己补上
|
||||
checkInsertTargets :: Table -> [String] -> Either String ()
|
||||
checkInsertTargets t cols = mapM_ checkTarget (tableCols t)
|
||||
where
|
||||
checkTarget (name, c)
|
||||
| name `elem` cols = Right ()
|
||||
| columnAutoIncrement c = Right ()
|
||||
| columnNullable c = Right ()
|
||||
| Just _ <- columnDefault c = Right ()
|
||||
| otherwise = Left ("INSERT: column " ++ name ++ " is NOT NULL and has no default")
|
||||
|
||||
-- | 检查一列定义是否合法（names 给 CHECK 用）
|
||||
checkColumnDefs :: [String] -> [(String, Column)] -> Either String ()
|
||||
checkColumnDefs names cols = do
|
||||
mapM_ (\(_, c) -> mapM_ (checkDefault c) (columnDefault c)) cols
|
||||
mapM_ (\(_, c) -> checkAutoIncrement c) 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
|
||||
|
||||
-- | 自增列必须是整数列
|
||||
checkAutoIncrement :: Column -> Either String ()
|
||||
checkAutoIncrement c
|
||||
| columnAutoIncrement c && not (integerType (columnType c)) = Left "AUTO_INCREMENT: column must be an integer type"
|
||||
| otherwise = Right ()
|
||||
|
||||
-- | 默认值必须能放进这一列
|
||||
checkDefault :: Column -> Value -> Either String ()
|
||||
checkDefault c v
|
||||
| VNull <- v = Right ()
|
||||
| valueFits (columnType c) v = Right ()
|
||||
| otherwise = Left ("DEFAULT: value does not fit column type " ++ show c)
|
||||
|
||||
-- | CHECK 里的列必须存在
|
||||
checkChecks :: [String] -> [(String, Column)] -> Either String ()
|
||||
checkChecks names = mapM_ checkOne
|
||||
where
|
||||
-- | 查这一列的 CHECK
|
||||
checkOne (_, c) = case columnCheck c of
|
||||
Nothing -> Right ()
|
||||
Just text -> case parseExpression text of
|
||||
Left err -> Left ("CHECK: " ++ firstLine err)
|
||||
Right e -> mapM_ (known e) (colsInExpr e)
|
||||
-- | 这个列名在不在定义里
|
||||
known _ col
|
||||
| col `elem` names = Right ()
|
||||
| otherwise = Left ("CHECK: unknown column: " ++ col)
|
||||
firstLine = takeWhile (/= '\n')
|
||||
|
||||
-- | 账号名上限
|
||||
accountNameLimit :: Int
|
||||
accountNameLimit = 64
|
||||
|
||||
-- | 检查库名是否合法
|
||||
checkDatabaseName :: String -> Either String ()
|
||||
checkDatabaseName name
|
||||
| null name || length name > 64 || not (all (\c -> isAscii c && (isAlphaNum c || c == '_')) name) = Left "invalid database name"
|
||||
| otherwise = Right ()
|
||||
|
||||
-- | 口令上限
|
||||
passwordLimit :: Int
|
||||
passwordLimit = 256
|
||||
|
||||
-- | 账号名：ASCII 字母数字加点、短横线、下划线
|
||||
checkUserName :: String -> Either String ()
|
||||
checkUserName name
|
||||
| null name = Left "USER: empty account name"
|
||||
| length name > accountNameLimit = Left "USER: account name is too long"
|
||||
| not (all allowed name) = Left "USER: account name may only contain ASCII letters, digits, dot, dash or underscore"
|
||||
| otherwise = Right ()
|
||||
where
|
||||
-- | 账号名字符规则
|
||||
allowed c = isAscii c && (isAlphaNum c || c `elem` ("_.-" :: String))
|
||||
|
||||
-- | 建号 / 改口令：名字合法且口令不空
|
||||
checkAccount :: String -> String -> Either String ()
|
||||
checkAccount name password = do
|
||||
checkUserName name
|
||||
if null password
|
||||
then Left "USER: password must not be empty"
|
||||
else
|
||||
if length password > passwordLimit
|
||||
then Left "USER: password is too long"
|
||||
else Right ()
|
||||
|
||||
-- | 检查角色名是否合法（不许用权限关键字）
|
||||
checkRoleName :: String -> Either String ()
|
||||
checkRoleName name
|
||||
| null name = Left "ROLE: empty role name"
|
||||
| length name > accountNameLimit = Left "ROLE: role name is too long"
|
||||
| not (all allowed name) = Left "ROLE: role name may only contain ASCII letters, digits, dot, dash or underscore"
|
||||
| map toLower name `elem` privilegeNames = Left "ROLE: role name must not be a privilege keyword"
|
||||
| otherwise = Right ()
|
||||
where
|
||||
-- | 角色名字符规则
|
||||
allowed c = isAscii c && (isAlphaNum c || c `elem` ("_.-" :: String))
|
||||
|
||||
-- | 权限关键字（小写，只用于比较）
|
||||
privilegeNames :: [String]
|
||||
privilegeNames = ["select", "insert", "update", "delete", "all"]
|
||||
|
||||
-- | 权限名只能是这几个
|
||||
checkPrivilege :: String -> Either String ()
|
||||
checkPrivilege name
|
||||
| map toLower name `elem` privilegeNames = Right ()
|
||||
| otherwise = Left ("GRANT: unknown privilege: " ++ name)
|
||||
|
||||
-- | 授权对象：* 表示全部表，否则是一张表（可带一个库前缀）
|
||||
checkGrantObject :: String -> Either String ()
|
||||
checkGrantObject "*" = Right ()
|
||||
checkGrantObject obj
|
||||
| null obj = Left "GRANT: object name must not be empty"
|
||||
| length obj > 128 = Left "GRANT: object name is too long"
|
||||
| not (all allowed obj) = Left "GRANT: object name may only contain ASCII letters, digits, dot, dash or underscore"
|
||||
| otherwise = Right ()
|
||||
where
|
||||
-- | 授权对象字符规则
|
||||
allowed c = isAscii c && (isAlphaNum c || c `elem` ("_.-" :: String))
|
||||
|
||||
-- | 内置 id 列名
|
||||
idColumn :: String
|
||||
idColumn = "id"
|
||||
-- | 把列引用统一为执行期名字（子查询一起解析）
|
||||
resolveExpr ::
|
||||
Database ->
|
||||
[(String, Column)] ->
|
||||
[(String, Column)] ->
|
||||
(String -> Either String String) ->
|
||||
Expr ->
|
||||
Either String Expr
|
||||
resolveExpr db env outer f e = case e of
|
||||
Col c -> Col <$> f c
|
||||
Add a b -> binary Add a b
|
||||
Sub a b -> binary Sub a b
|
||||
Mul a b -> binary Mul a b
|
||||
Div a b -> binary Div a b
|
||||
Neg a -> Neg <$> resolveExpr db env outer f a
|
||||
Gt a b -> binary Gt a b
|
||||
Lt a b -> binary Lt a b
|
||||
Eq a b -> binary Eq a b
|
||||
And a b -> binary And a b
|
||||
Or a b -> binary Or a b
|
||||
IsNull a -> IsNull <$> resolveExpr db env outer f a
|
||||
IsNotNull a -> IsNotNull <$> resolveExpr db env outer f a
|
||||
CountAll -> Right CountAll
|
||||
CountOf a -> CountOf <$> resolveExpr db env outer f a
|
||||
SumOf a -> SumOf <$> resolveExpr db env outer f a
|
||||
AvgOf a -> AvgOf <$> resolveExpr db env outer f a
|
||||
MinOf a -> MinOf <$> resolveExpr db env outer f a
|
||||
MaxOf a -> MaxOf <$> resolveExpr db env outer f a
|
||||
ScalarSub sq -> ScalarSub <$> resolveSubquery db (env ++ outer) sq
|
||||
InSub a sq negated -> InSub <$> resolveExpr db env outer f a <*> resolveSubquery db (env ++ outer) sq <*> pure negated
|
||||
InList a es negated -> InList <$> resolveExpr db env outer f a <*> mapM (resolveExpr db env outer f) es <*> pure negated
|
||||
ExistsSub sq negated -> ExistsSub <$> resolveSubquery db (env ++ outer) sq <*> pure negated
|
||||
_ -> Right e
|
||||
where
|
||||
-- | 递归处理两个子表达式
|
||||
binary ctor a b = ctor <$> resolveExpr db env outer f a <*> resolveExpr db env outer f b
|
||||
|
||||
-- | 解析子查询，并记下它引用的外层列
|
||||
resolveSubquery :: Database -> [(String, Column)] -> Subquery -> Either String Subquery
|
||||
resolveSubquery db outer sq = do
|
||||
stmt <- resolveSubqueryStatement db outer (subqueryStatement sq)
|
||||
pure (Subquery stmt (outerRefsOf db stmt))
|
||||
|
||||
-- | 子查询里指向外层作用域的列（内层查不到的列就是外层引用）
|
||||
outerRefsOf :: Database -> Statement -> [String]
|
||||
outerRefsOf db stmt = nub [c | c <- statementColumns stmt, not (inInner c)]
|
||||
where
|
||||
inner = case checkFrom db [] (statementFrom stmt) of
|
||||
Right env -> env
|
||||
Left _ -> []
|
||||
-- | 这一列能不能在内层解析到
|
||||
inInner c = case resolveColumn c inner of
|
||||
Right _ -> True
|
||||
Left _ -> False
|
||||
|
||||
-- | 一条语句里出现的所有列引用
|
||||
statementColumns :: Statement -> [String]
|
||||
statementColumns stmt = case stmt of
|
||||
Select cols fromC mWhere groupBy orderBy _ ->
|
||||
cols ++ fromColumns fromC ++ concatMap colsInExpr mWhere ++ groupBy ++ map fst orderBy
|
||||
SelectExpr items fromC mWhere groupBy orderBy _ ->
|
||||
concatMap (colsInExpr . snd) items ++ fromColumns fromC ++ concatMap colsInExpr mWhere ++ groupBy ++ map fst orderBy
|
||||
_ -> []
|
||||
where
|
||||
-- | 取 FROM 里出现的列
|
||||
fromColumns FromUnit = []
|
||||
fromColumns (FromTable _ _) = []
|
||||
fromColumns (FromJoin _ l _ _ c) = fromColumns l ++ colsInExpr c
|
||||
|
||||
-- | 取语句的 FROM 子句，没有就是 FromUnit
|
||||
statementFrom :: Statement -> FromClause
|
||||
statementFrom Select { selectFrom = fromC } = fromC
|
||||
statementFrom SelectExpr { selectFrom = fromC } = fromC
|
||||
statementFrom _ = FromUnit
|
||||
|
||||
-- | 解析子查询里的 SELECT
|
||||
resolveSubqueryStatement :: Database -> [(String, Column)] -> Statement -> Either String Statement
|
||||
resolveSubqueryStatement db outer q@Select{} = resolveQuery db outer q (map (\c -> (c, Col c)) (selectCols q))
|
||||
resolveSubqueryStatement db outer q@SelectExpr{} = resolveQuery db outer q (selectItems q)
|
||||
resolveSubqueryStatement _ _ _ = Left "subquery must be a SELECT"
|
||||
|
||||
-- | 列名解析入口：查询走连接解析，改数据的语句按本表列解析
|
||||
resolveStatement :: Database -> Statement -> Either String Statement
|
||||
resolveStatement db q = case q of
|
||||
Select{} -> resolveSelect db q
|
||||
SelectExpr{} -> resolveSelect db q
|
||||
Update tbl assigns mWhere -> do
|
||||
t <- lookupTable db tbl
|
||||
let env = tableCols t
|
||||
name = nameIn env "UPDATE"
|
||||
assigns' <- mapM (\(c, e) -> (\e' -> (c, e')) <$> resolveExpr db env [] name e) assigns
|
||||
w <- mapM (resolveExpr db env [] (nameIn env "WHERE")) mWhere
|
||||
pure (Update tbl assigns' w)
|
||||
Delete tbl mWhere -> do
|
||||
t <- lookupTable db tbl
|
||||
w <- mapM (resolveExpr db (tableCols t) [] (nameIn (tableCols t) "WHERE")) mWhere
|
||||
pure (Delete tbl w)
|
||||
Insert tbl cols rows -> do
|
||||
t <- lookupTable db tbl
|
||||
let env = tableCols t
|
||||
rows' <- mapM (mapM (resolveExpr db env [] (nameIn env "INSERT"))) rows
|
||||
pure (Insert tbl cols rows')
|
||||
other -> Right other
|
||||
|
||||
-- | 查一列的物理名
|
||||
nameIn :: [(String, Column)] -> String -> String -> Either String String
|
||||
nameIn env place c = fst <$> columnAt place env c
|
||||
|
||||
-- | 内层先查，查不到再落到外层；内层同名引起的歧义不往外层让
|
||||
scopedColumnAt :: String -> [(String, Column)] -> [(String, Column)] -> String -> Either String (String, Column)
|
||||
scopedColumnAt place inner outer c = scopeAt place (Scope inner outer) c
|
||||
|
||||
-- | 单表保留原表头，连接使用唯一前缀
|
||||
resolveSelect :: Database -> Statement -> Either String Statement
|
||||
resolveSelect db q@Select{} = resolveQuery db [] q (map (\c -> (c, Col c)) (selectCols q))
|
||||
resolveSelect db q@SelectExpr{} = resolveQuery db [] q (selectItems q)
|
||||
resolveSelect _ q = Right q
|
||||
|
||||
-- | 解析投影、条件、排序与连接引用
|
||||
resolveQuery :: Database -> [(String, Column)] -> Statement -> [(String, Expr)] -> Either String Statement
|
||||
resolveQuery db outer q items = do
|
||||
env <- checkFrom db outer (selectFrom q)
|
||||
-- | 单表查询里把裸列名换成物理列名
|
||||
let physical c = case selectFrom q of
|
||||
FromTable Nothing tbl -> unqualify (Just tbl) c
|
||||
_ -> c
|
||||
-- | 查一列并换算成物理名
|
||||
name place c = physical . fst <$> scopedColumnAt place env outer c
|
||||
-- | 换算一个投影项
|
||||
output (_, Col c) = do
|
||||
k <- name "SELECT" c
|
||||
pure (k, Col k)
|
||||
output (label, e) = do
|
||||
e' <- resolveExpr db env outer (name "SELECT") e
|
||||
pure (label, e')
|
||||
projected <- if items == [("*", Col "*")]
|
||||
then if null env && selectFrom q == FromUnit
|
||||
then Left "SELECT: * requires FROM"
|
||||
else Right [(physical c, Col (physical c)) | (c, _) <- env]
|
||||
else mapM output items
|
||||
condition <- mapM (resolveExpr db env outer (name "WHERE")) (selectWhere q)
|
||||
grouping <- mapM (name "GROUP BY") (selectGroupBy q)
|
||||
ordering <- mapM (\(c, d) -> (\k -> (k, d)) <$> name "ORDER BY" c) (selectOrderBy q)
|
||||
source <- case selectFrom q of
|
||||
single@FromTable{} -> Right single
|
||||
other -> resolveFrom db outer other
|
||||
pure $ case q of
|
||||
Select{} -> Select (map fst projected) source condition grouping ordering (selectLimit q)
|
||||
_ -> SelectExpr projected source condition grouping ordering (selectLimit q)
|
||||
|
||||
-- | 连接两侧默认取表名作别名；ON 里的子查询也能引用外层列
|
||||
resolveFrom :: Database -> [(String, Column)] -> FromClause -> Either String FromClause
|
||||
resolveFrom _ _ FromUnit = Right FromUnit
|
||||
resolveFrom _ _ (FromTable alias tbl) = Right (FromTable (Just (fromMaybe tbl alias)) tbl)
|
||||
resolveFrom db outer fromC@(FromJoin kind left alias tbl cond) = do
|
||||
env <- checkFrom db outer fromC
|
||||
l <- resolveFrom db outer left
|
||||
c <- resolveExpr db env outer (fmap fst . columnAt "ON" env) cond
|
||||
pure (FromJoin kind l (Just (fromMaybe tbl alias)) tbl c)
|
||||
@@ -0,0 +1,110 @@
|
||||
module ChuSQL.Core.Engine.Storage (
|
||||
MonadStorage (..),
|
||||
IndexResult (..),
|
||||
) where
|
||||
|
||||
import ChuSQL.Core.Model (Column, Database, Row, Table (..), Value (..))
|
||||
|
||||
-- 存储层抽象：MonadStorage 类与 IndexResult。
|
||||
|
||||
data IndexResult
|
||||
= IndexRows [Row]
|
||||
| NoIndex
|
||||
deriving (Show, Eq)
|
||||
|
||||
class (Monad m) => MonadStorage m where
|
||||
-- \| 建一个库
|
||||
createDatabase :: String -> m (Either String ())
|
||||
createDatabase _ = pure (Left "database management is unavailable in this storage")
|
||||
-- \| 删一个库
|
||||
dropDatabase :: String -> m (Either String ())
|
||||
dropDatabase _ = pure (Left "database management is unavailable in this storage")
|
||||
-- \| 切当前库
|
||||
useDatabase :: String -> m (Either String ())
|
||||
useDatabase _ = pure (Left "database selection is unavailable in this storage")
|
||||
-- \| 列出现有库
|
||||
listDatabases :: m (Either String [String])
|
||||
listDatabases = pure (Right [])
|
||||
|
||||
-- \| 全表扫描
|
||||
scan :: String -> m (Either String [Row])
|
||||
|
||||
-- \| 只返回指定列；空清单保留每行的存在性。
|
||||
scanColumns :: String -> [String] -> m (Either String [Row])
|
||||
scanColumns t cols = do
|
||||
result <- scan t
|
||||
pure (fmap (map (\row -> [(c, v) | c <- cols, Just v <- [lookup c row]])) result)
|
||||
|
||||
-- \| 追加一行
|
||||
insert :: String -> Row -> m (Either String ())
|
||||
|
||||
-- \| 一批行一起追加
|
||||
insertMany :: String -> [Row] -> m (Either String ())
|
||||
insertMany t = go
|
||||
where
|
||||
-- | 逐行插入，出错就停
|
||||
go [] = pure (Right ())
|
||||
go (r : rs) = do
|
||||
x <- insert t r
|
||||
case x of
|
||||
Left e -> pure (Left e)
|
||||
Right _ -> go rs
|
||||
|
||||
-- \| 按 id 批量删行
|
||||
deleteKeys :: String -> [Int] -> m (Either String ())
|
||||
deleteKeys t ks = do
|
||||
rows <- scan t
|
||||
case rows of
|
||||
Left e -> pure (Left e)
|
||||
Right rs -> replaceAll t [r | r <- rs, not (doomed r)]
|
||||
where
|
||||
-- | 这一行要不要删
|
||||
doomed r = case lookup "id" r of
|
||||
Just (VInt k) -> k `elem` ks
|
||||
_ -> False
|
||||
|
||||
-- \| 整表替换
|
||||
replaceAll :: String -> [Row] -> m (Either String ())
|
||||
|
||||
-- \| 按某一列的索引取一行（键可以是整数或字符串）
|
||||
lookupByColumn :: String -> String -> Value -> m (Either String IndexResult)
|
||||
lookupByColumn _ _ _ = pure (Right NoIndex)
|
||||
|
||||
-- \| 按某一列的索引做范围扫描；没有可用索引就回 Nothing
|
||||
scanRange ::
|
||||
String ->
|
||||
String ->
|
||||
Maybe (Value, Bool) ->
|
||||
Maybe (Value, Bool) ->
|
||||
m (Either String (Maybe [Row]))
|
||||
scanRange _ _ _ _ = pure (Right Nothing)
|
||||
|
||||
-- \| 建一张空表
|
||||
createTable :: String -> [(String, Column)] -> m (Either String ())
|
||||
|
||||
-- \| 删除表
|
||||
dropTable :: String -> m (Either String ())
|
||||
|
||||
-- \| 给某一列建索引（id 列要求唯一）
|
||||
createIndex :: String -> String -> m (Either String ())
|
||||
createIndex _ _ = pure (Right ())
|
||||
|
||||
-- \| 去掉某一列的索引
|
||||
dropIndex :: String -> String -> m (Either String ())
|
||||
dropIndex _ _ = pure (Right ())
|
||||
|
||||
-- \| 删一列，连它的索引与数据一起去掉
|
||||
dropColumn :: String -> String -> m (Either String ())
|
||||
|
||||
-- \| ALTER 用：整表换列定义与全部行
|
||||
replaceSchema :: String -> [(String, Column)] -> [Row] -> m (Either String ())
|
||||
|
||||
-- \| 取全库快照（表名 + 列 + 全部行）
|
||||
snapshot :: m Database
|
||||
|
||||
-- \| 取全库结构：只要表名和列，不要行
|
||||
schema :: m Database
|
||||
schema = fmap (map withoutRows) snapshot
|
||||
where
|
||||
-- | 表定义去掉所有行
|
||||
withoutRows (name, t) = (name, t {tableRows = []})
|
||||
@@ -0,0 +1,90 @@
|
||||
{-# LANGUAGE ForeignFunctionInterface #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
|
||||
module ChuSQL.Core.Engine.Storage.FFI (
|
||||
StorageHandle,
|
||||
storageVersion,
|
||||
openStorage,
|
||||
closeStorage,
|
||||
storageRequest,
|
||||
) where
|
||||
|
||||
import Control.Exception (SomeException, try)
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.Text qualified as T
|
||||
import Data.Text.Encoding qualified as TE
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Foreign
|
||||
import Foreign.C
|
||||
|
||||
-- Rust 存储库 cdylib 的 C ABI 绑定（ffi.rs），收发单行 JSON。
|
||||
|
||||
-- | 存储实例句柄（Rust 侧的 *mut Storage）
|
||||
newtype StorageHandle = StorageHandle (Ptr ())
|
||||
|
||||
foreign import ccall unsafe "chusql_storage_version"
|
||||
cStorageVersion :: IO CString
|
||||
|
||||
foreign import ccall safe "chusql_storage_open"
|
||||
cStorageOpen :: CString -> IO (Ptr ())
|
||||
|
||||
foreign import ccall safe "chusql_storage_close"
|
||||
cStorageClose :: Ptr () -> IO ()
|
||||
|
||||
foreign import ccall safe "chusql_storage_request"
|
||||
cStorageRequest :: Ptr () -> Ptr CChar -> CSize -> Ptr (Ptr CChar) -> Ptr CSize -> IO CInt
|
||||
|
||||
foreign import ccall unsafe "chusql_storage_free"
|
||||
cStorageFree :: Ptr CChar -> CSize -> IO ()
|
||||
|
||||
foreign import ccall unsafe "chusql_storage_last_error"
|
||||
cStorageLastError :: Ptr CSize -> IO (Ptr CChar)
|
||||
|
||||
-- | 库版本（Rust 侧的 CARGO_PKG_VERSION）
|
||||
storageVersion :: IO String
|
||||
storageVersion = cStorageVersion >>= peekCString
|
||||
|
||||
-- | 打开存储实例，失败给错误文本
|
||||
openStorage :: Maybe FilePath -> IO (Either String StorageHandle)
|
||||
openStorage path = do
|
||||
result <- try (withCStringOrNull path cStorageOpen) :: IO (Either SomeException (Ptr ()))
|
||||
case result of
|
||||
Left e -> pure (Left ("storage library call failed: " ++ show e))
|
||||
Right ptr
|
||||
| ptr == nullPtr -> Left <$> lastError
|
||||
| otherwise -> pure (Right (StorageHandle ptr))
|
||||
where
|
||||
-- | 没有路径就传空指针，否则转成 C 字符串
|
||||
withCStringOrNull Nothing f = f nullPtr
|
||||
withCStringOrNull (Just s) f = withCString s f
|
||||
|
||||
-- | 关掉存储实例
|
||||
closeStorage :: StorageHandle -> IO ()
|
||||
closeStorage (StorageHandle handle) = cStorageClose handle
|
||||
|
||||
-- | 一条 JSON 请求换一条 JSON 响应
|
||||
storageRequest :: StorageHandle -> BS.ByteString -> IO (Either String BS.ByteString)
|
||||
storageRequest (StorageHandle handle) payload =
|
||||
BS.useAsCStringLen payload $ \(inPtr, inLen) ->
|
||||
alloca $ \outPtrRef ->
|
||||
alloca $ \outLenRef -> do
|
||||
code <- cStorageRequest handle (castPtr inPtr) (fromIntegral inLen) outPtrRef outLenRef
|
||||
if code /= 0
|
||||
then Left <$> lastError
|
||||
else do
|
||||
outPtr <- peek outPtrRef
|
||||
outLen <- peek outLenRef
|
||||
bytes <- BS.packCStringLen (castPtr outPtr, fromIntegral outLen)
|
||||
cStorageFree outPtr outLen
|
||||
pure (Right bytes)
|
||||
|
||||
-- | 当前线程最近一次失败的文本
|
||||
lastError :: IO String
|
||||
lastError = alloca $ \lenRef -> do
|
||||
ptr <- cStorageLastError lenRef
|
||||
if ptr == nullPtr
|
||||
then pure "storage: unknown error"
|
||||
else do
|
||||
len <- peek lenRef
|
||||
raw <- BS.packCStringLen (ptr, fromIntegral len)
|
||||
pure (T.unpack (TE.decodeUtf8With lenientDecode raw))
|
||||
@@ -0,0 +1,368 @@
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChuSQL.Core.Engine.Storage.IPC (
|
||||
IPCStorage (..),
|
||||
Request (..),
|
||||
Response (..),
|
||||
Account (..),
|
||||
SchemaColumn (..),
|
||||
TableInfo (..),
|
||||
StorageLink (..),
|
||||
setStorageLink,
|
||||
localStorageLink,
|
||||
sendRequest,
|
||||
sendRawRequest,
|
||||
closeConnection,
|
||||
setDatabaseName,
|
||||
getDatabaseName,
|
||||
doListTables,
|
||||
doLookupByColumn,
|
||||
doInsert,
|
||||
doInsertMany,
|
||||
doDeleteKeys,
|
||||
doDescribeTable,
|
||||
doDropTable,
|
||||
doListCatalog,
|
||||
) where
|
||||
|
||||
import ChuSQL.Core.Model
|
||||
import ChuSQL.Core.Protocol (Account (..), Request (..), Response (..), SchemaColumn (..), TableInfo (..))
|
||||
import ChuSQL.Core.Engine.Storage
|
||||
import ChuSQL.Core.Engine.Storage.FFI (closeStorage, openStorage, storageRequest)
|
||||
import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
|
||||
import Data.Aeson (eitherDecodeStrict, encode)
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Lazy qualified as BL
|
||||
import Data.Maybe (fromMaybe)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
-- IPC 存储实现：把 MonadStorage 的操作变成发给存储库的 JSON 请求。
|
||||
|
||||
newtype IPCStorage a = IPCStorage
|
||||
{ runIPCStorage :: IO a
|
||||
}
|
||||
|
||||
instance Functor IPCStorage where
|
||||
fmap f (IPCStorage m) = IPCStorage (fmap f m)
|
||||
|
||||
instance Applicative IPCStorage where
|
||||
pure = IPCStorage . pure
|
||||
IPCStorage mf <*> IPCStorage ma = IPCStorage (mf <*> ma)
|
||||
|
||||
instance Monad IPCStorage where
|
||||
IPCStorage m >>= k = IPCStorage $ do
|
||||
a <- m
|
||||
runIPCStorage (k a)
|
||||
|
||||
-- | 一条到存储库的链路：管请求与关闭
|
||||
data StorageLink = StorageLink
|
||||
{ slRequest :: BS.ByteString -> IO (Either String BS.ByteString)
|
||||
, slClose :: IO ()
|
||||
}
|
||||
|
||||
{-# NOINLINE linkRef #-}
|
||||
-- | 进程全局的存储链路
|
||||
linkRef :: MVar (Maybe StorageLink)
|
||||
linkRef = unsafePerformIO (newMVar Nothing)
|
||||
|
||||
-- | 装入一条链路；一个进程只装一次
|
||||
setStorageLink :: StorageLink -> IO ()
|
||||
setStorageLink link = modifyMVar_ linkRef (const (pure (Just link)))
|
||||
|
||||
-- | 打开本地的存储动态库，得到一条链路
|
||||
localStorageLink :: Maybe FilePath -> IO (Either String StorageLink)
|
||||
localStorageLink path = fmap (fmap toLink) (openStorage path)
|
||||
where
|
||||
-- | 把句柄包成一条链路
|
||||
toLink handle =
|
||||
StorageLink
|
||||
{ slRequest = storageRequest handle
|
||||
, slClose = closeStorage handle
|
||||
}
|
||||
|
||||
-- | 关掉当前链路（进程退出前调用）；没有链路就什么都不做
|
||||
closeConnection :: IO ()
|
||||
closeConnection = modifyMVar_ linkRef $ \current -> do
|
||||
case current of
|
||||
Nothing -> pure ()
|
||||
Just link -> slClose link
|
||||
pure Nothing
|
||||
|
||||
-- | 发一条请求并解码应答；链路没装就报错，不崩
|
||||
sendRequest :: Request -> IO Response
|
||||
sendRequest req = do
|
||||
current <- readMVar linkRef
|
||||
case current of
|
||||
Nothing -> pure (RespError "storage not configured")
|
||||
Just link -> do
|
||||
raw <- slRequest link (BL.toStrict (encode req))
|
||||
case raw of
|
||||
Left e -> pure (RespError ("storage error: " ++ e))
|
||||
Right bytes -> case eitherDecodeStrict (BS.dropWhileEnd (== 13) bytes) of
|
||||
Left e -> pure (RespError ("decode error: " ++ e))
|
||||
Right resp -> pure resp
|
||||
|
||||
-- | 原样转发一条载荷给存储库
|
||||
sendRawRequest :: BS.ByteString -> IO (Either String BS.ByteString)
|
||||
sendRawRequest payload = do
|
||||
current <- readMVar linkRef
|
||||
case current of
|
||||
Nothing -> pure (Left "storage not configured")
|
||||
Just link -> slRequest link payload
|
||||
|
||||
{-# NOINLINE databaseRef #-}
|
||||
-- | 进程全局的当前库名
|
||||
databaseRef :: MVar (Maybe String)
|
||||
databaseRef = unsafePerformIO (newMVar Nothing)
|
||||
|
||||
-- | 设定当前库名（会话层决定，本层只记住并发给存储）
|
||||
setDatabaseName :: Maybe String -> IO ()
|
||||
setDatabaseName name = modifyMVar_ databaseRef (const (pure name))
|
||||
|
||||
-- | 当前库名
|
||||
getDatabaseName :: IO (Maybe String)
|
||||
getDatabaseName = readMVar databaseRef
|
||||
|
||||
|
||||
-- | 给语句类请求盖上当前库名
|
||||
stampDatabase :: Maybe String -> Request -> Request
|
||||
stampDatabase Nothing req = req
|
||||
stampDatabase (Just db) req
|
||||
| globalRequest req = req
|
||||
| otherwise = ReqInDatabase db req
|
||||
|
||||
-- | 是不是不该带库名的全局请求
|
||||
globalRequest :: Request -> Bool
|
||||
globalRequest ReqDatabase{} = True
|
||||
globalRequest ReqAllCatalog = True
|
||||
globalRequest ReqAccountsList = True
|
||||
globalRequest ReqAccountCreate{} = True
|
||||
globalRequest ReqAccountReset{} = True
|
||||
globalRequest ReqAccountLogin{} = True
|
||||
globalRequest ReqAccountDrop{} = True
|
||||
globalRequest ReqPing = True
|
||||
globalRequest _ = False
|
||||
|
||||
-- | 发请求并把响应翻成 Either
|
||||
ask :: String -> Request -> (Response -> Maybe a) -> IO (Either String a)
|
||||
ask what req recognize = do
|
||||
current <- getDatabaseName
|
||||
resp <- sendRequest (stampDatabase current req)
|
||||
pure $ case resp of
|
||||
RespError e -> Left e
|
||||
other -> case recognize other of
|
||||
Just a -> Right a
|
||||
Nothing -> Left ("unexpected response to " ++ what)
|
||||
|
||||
-- | 只认"成了"（多数写操作都这样）
|
||||
okOnly :: Response -> Maybe ()
|
||||
okOnly RespOk = Just ()
|
||||
okOnly _ = Nothing
|
||||
|
||||
-- | 发 Scan
|
||||
doScan :: String -> IO (Either String [Row])
|
||||
doScan t = ask "scan" (ReqScan t) $ \resp -> case resp of
|
||||
RespRows rows -> Just rows
|
||||
_ -> Nothing
|
||||
|
||||
-- | 发 Insert（索引由存储层维护）
|
||||
doInsert :: String -> Row -> IO (Either String ())
|
||||
doInsert t r = ask "insert" (ReqInsert t r) okOnly
|
||||
|
||||
-- | 发 InsertBatch：一批行一次请求
|
||||
doInsertMany :: String -> [Row] -> IO (Either String ())
|
||||
doInsertMany t rs = ask "insert_batch" (ReqInsertBatch t rs) okOnly
|
||||
|
||||
-- | 发 DeleteKeys
|
||||
doDeleteKeys :: String -> [Int] -> IO (Either String ())
|
||||
doDeleteKeys t ks = ask "delete_keys" (ReqDeleteKeys t ks) okOnly
|
||||
|
||||
-- | 发 ReplaceAll
|
||||
doReplaceAll :: String -> [Row] -> IO (Either String ())
|
||||
doReplaceAll t rs = ask "replace_all" (ReqReplaceAll t rs) okOnly
|
||||
|
||||
-- | 发 ListTables
|
||||
doListTables :: IO (Either String [String])
|
||||
doListTables = ask "list_tables" ReqListTables $ \resp -> case resp of
|
||||
RespTables ts -> Just ts
|
||||
_ -> Nothing
|
||||
|
||||
-- | 一次拿全库 schema
|
||||
doListCatalog :: IO (Either String [TableInfo])
|
||||
doListCatalog = ask "list_catalog" ReqListCatalog $ \resp -> case resp of
|
||||
RespCatalog xs -> Just xs
|
||||
_ -> Nothing
|
||||
|
||||
-- | 按某一列的索引取一行（键可以是整数或字符串）
|
||||
doLookupByColumn :: String -> String -> Value -> IO (Either String IndexResult)
|
||||
doLookupByColumn t c k = ask "lookup_by_index" (ReqLookupByColumn t c k) $ \resp -> case resp of
|
||||
RespRows rows -> Just (IndexRows rows)
|
||||
RespNoIndex -> Just NoIndex
|
||||
_ -> Nothing
|
||||
|
||||
-- | 范围扫描：没有可用索引就回 Nothing，让上层退回扫描
|
||||
doScanRange ::
|
||||
String ->
|
||||
String ->
|
||||
Maybe (Value, Bool) ->
|
||||
Maybe (Value, Bool) ->
|
||||
IO (Either String (Maybe [Row]))
|
||||
doScanRange t c lo hi = ask "range_by_index" (ReqRangeByIndex t c lo hi) $ \resp -> case resp of
|
||||
RespRows rows -> Just (Just rows)
|
||||
RespNoIndex -> Just Nothing
|
||||
_ -> Nothing
|
||||
|
||||
-- | 发 DescribeTable
|
||||
doDescribeTable :: String -> IO (Either String TableInfo)
|
||||
doDescribeTable t = ask "describe_table" (ReqDescribeTable t) $ \resp -> case resp of
|
||||
RespSchema info -> Just info
|
||||
_ -> Nothing
|
||||
|
||||
-- | 给某一列建索引
|
||||
doCreateIndex :: String -> String -> IO (Either String ())
|
||||
doCreateIndex t c = ask "create_index" (ReqCreateIndex t c) okOnly
|
||||
|
||||
-- | 去掉某一列的索引
|
||||
doDropIndex :: String -> String -> IO (Either String ())
|
||||
doDropIndex t c = ask "drop_index" (ReqDropIndex t c) okOnly
|
||||
|
||||
-- | 删一列（列定义、这一列上的索引、每行里的那一格一起没）
|
||||
doDropColumn :: String -> String -> IO (Either String ())
|
||||
doDropColumn t c = ask "drop_column" (ReqDropColumn t c) okOnly
|
||||
|
||||
-- | 发 ReplaceSchema（ALTER 用）
|
||||
doReplaceSchema :: String -> [SchemaColumn] -> [Row] -> IO (Either String ())
|
||||
doReplaceSchema t cols rs = ask "replace_schema" (ReqReplaceSchema t cols rs) okOnly
|
||||
|
||||
-- | 发 CreateTable
|
||||
doCreateTable :: String -> [SchemaColumn] -> IO (Either String ())
|
||||
doCreateTable t cols = ask "create_table" (ReqCreateTable t cols) okOnly
|
||||
|
||||
-- | 发 DropTable
|
||||
doDropTable :: String -> IO (Either String ())
|
||||
doDropTable t = ask "drop_table" (ReqDropTable t) okOnly
|
||||
|
||||
-- | 线上 schema 转本地列
|
||||
schemaToColumns :: [SchemaColumn] -> [(String, Column)]
|
||||
schemaToColumns = map toColumn
|
||||
|
||||
-- | 线上 schema 转本地 column
|
||||
toColumn :: SchemaColumn -> (String, Column)
|
||||
toColumn sc =
|
||||
( scName sc
|
||||
, Column
|
||||
{ columnType = fromMaybe CStr (parseColumnType (scType sc))
|
||||
, columnNullable = scNullable sc
|
||||
, columnDefault = scDefault sc
|
||||
, columnAutoIncrement = scAutoIncrement sc
|
||||
, columnUnique = scUnique sc
|
||||
, columnPrimaryKey = scPrimaryKey sc
|
||||
, columnCheck = scCheck sc
|
||||
}
|
||||
)
|
||||
|
||||
-- | 本地列转线上 schema
|
||||
toWire :: (String, Column) -> SchemaColumn
|
||||
toWire (n, c) =
|
||||
SchemaColumn
|
||||
{ scName = n
|
||||
, scType = typeName (columnType c)
|
||||
, scNullable = columnNullable c
|
||||
, scDefault = columnDefault c
|
||||
, scAutoIncrement = columnAutoIncrement c
|
||||
, scPrimaryKey = columnPrimaryKey c
|
||||
, scUnique = columnUnique c
|
||||
, scCheck = columnCheck c
|
||||
}
|
||||
|
||||
instance MonadStorage IPCStorage where
|
||||
-- \| 建一个库
|
||||
createDatabase name = IPCStorage (ask "create_database" (ReqDatabase "create_database" name) okOnly)
|
||||
-- \| 删一个库
|
||||
dropDatabase name = IPCStorage (ask "drop_database" (ReqDatabase "drop_database" name) okOnly)
|
||||
-- \| 切当前库
|
||||
useDatabase name = IPCStorage (ask "use_database" (ReqDatabase "use_database" name) okOnly)
|
||||
-- \| 列出现有库
|
||||
listDatabases = IPCStorage $ ask "list_databases" (ReqDatabase "list_databases" "") $ \resp -> case resp of
|
||||
RespTables names -> Just names
|
||||
_ -> Nothing
|
||||
-- \| 发 Scan
|
||||
scan t = IPCStorage (doScan t)
|
||||
-- \| 只取指定列
|
||||
scanColumns t cols = IPCStorage $ ask "scan" (ReqScanColumns t cols) $ \resp -> case resp of
|
||||
RespRows rows -> Just [[(c, v) | c <- cols, Just v <- [lookup c row]] | row <- rows]
|
||||
_ -> Nothing
|
||||
|
||||
-- \| 发 Insert（索引由存储层自己维护）
|
||||
insert t r = IPCStorage (doInsert t r)
|
||||
|
||||
-- \| 一批行一次请求：N 行只落一次盘
|
||||
insertMany t rs = IPCStorage (doInsertMany t rs)
|
||||
|
||||
-- \| 按 id 批量删行
|
||||
deleteKeys t ks = IPCStorage (doDeleteKeys t ks)
|
||||
|
||||
-- \| 发 ReplaceAll
|
||||
replaceAll t rs = IPCStorage (doReplaceAll t rs)
|
||||
|
||||
-- \| 按某一列的索引取一行（没有索引就回 NoIndex）
|
||||
lookupByColumn t c k = IPCStorage (doLookupByColumn t c k)
|
||||
|
||||
-- \| 范围扫描（没有索引就回 Nothing）
|
||||
scanRange t c lo hi = IPCStorage (doScanRange t c lo hi)
|
||||
|
||||
-- \| 发 CreateTable
|
||||
createTable name cols = IPCStorage (doCreateTable name (map toWire cols))
|
||||
|
||||
-- \| ALTER：整表换列定义与全部行
|
||||
replaceSchema name cols rows = IPCStorage (doReplaceSchema name (map toWire cols) rows)
|
||||
|
||||
-- \| 发 DropTable
|
||||
dropTable name = IPCStorage (doDropTable name)
|
||||
|
||||
-- \| 建索引
|
||||
createIndex t c = IPCStorage (doCreateIndex t c)
|
||||
|
||||
-- \| 删索引
|
||||
dropIndex t c = IPCStorage (doDropIndex t c)
|
||||
|
||||
-- \| 删一列
|
||||
dropColumn t c = IPCStorage (doDropColumn t c)
|
||||
|
||||
-- \| 列表 + 逐表扫描拼库
|
||||
snapshot = IPCStorage $ do
|
||||
result <- doListCatalog
|
||||
case result of
|
||||
Left _ -> pure []
|
||||
Right xs -> mapM loadEntry xs
|
||||
where
|
||||
loadEntry info = do
|
||||
rows <- doScan (tiTable info)
|
||||
pure
|
||||
( tiTable info
|
||||
, Table (tiTable info) (schemaToColumns (tiColumns info)) (either (const []) id rows)
|
||||
)
|
||||
|
||||
-- \| 只问数据字典要结构，设了当前库只留它的表
|
||||
schema = IPCStorage $ do
|
||||
current <- getDatabaseName
|
||||
result <- ask "all_catalogs" ReqAllCatalog $ \resp -> case resp of
|
||||
RespCatalog infos -> Just infos
|
||||
_ -> Nothing
|
||||
pure $ case result of
|
||||
Left _ -> []
|
||||
Right xs -> concatMap (visibleTables current) xs
|
||||
|
||||
-- | 没设库名就照单全收；设了库名只收这个库的表，键名去掉库名前缀
|
||||
visibleTables :: Maybe String -> TableInfo -> [(String, Table)]
|
||||
visibleTables current info
|
||||
| Just db <- current =
|
||||
if unqualify (Just db) (tiTable info) /= tiTable info
|
||||
then [bare named]
|
||||
else []
|
||||
| otherwise = [bare info]
|
||||
where
|
||||
named = info {tiTable = unqualify current (tiTable info)}
|
||||
-- | 组装成不带行的表
|
||||
bare i = (tiTable i, Table (tiTable i) (schemaToColumns (tiColumns i)) [])
|
||||
@@ -0,0 +1,86 @@
|
||||
module ChuSQL.Core.Engine.Storage.Memory (MemoryStorage (runMemoryStorage)) where
|
||||
|
||||
import ChuSQL.Core.Model
|
||||
import ChuSQL.Core.Engine.Storage
|
||||
|
||||
-- 内存实现：Database 上的状态，错误通道是 Either String。
|
||||
|
||||
newtype MemoryStorage a = MemoryStorage {runMemoryStorage :: Database -> Either String (a, Database)}
|
||||
|
||||
instance Functor MemoryStorage where
|
||||
fmap f (MemoryStorage m) = MemoryStorage $ \db -> do
|
||||
(a, db') <- m db
|
||||
Right (f a, db')
|
||||
|
||||
instance Applicative MemoryStorage where
|
||||
pure x = MemoryStorage $ \db -> Right (x, db)
|
||||
MemoryStorage mf <*> MemoryStorage ma = MemoryStorage $ \db -> do
|
||||
(f, db1) <- mf db
|
||||
(a, db2) <- ma db1
|
||||
Right (f a, db2)
|
||||
|
||||
instance Monad MemoryStorage where
|
||||
MemoryStorage m >>= k = MemoryStorage $ \db -> do
|
||||
(a, db') <- m db
|
||||
runMemoryStorage (k a) db'
|
||||
|
||||
instance MonadStorage MemoryStorage where
|
||||
-- \| 全表扫描
|
||||
scan t = MemoryStorage $ \db -> do
|
||||
tbl <- lookupTable db t
|
||||
Right (Right (tableRows tbl), db)
|
||||
|
||||
-- \| 追加一行
|
||||
insert t r = MemoryStorage $ \db -> do
|
||||
tbl <- lookupTable db t
|
||||
Right (Right (), replaceTable t tbl{tableRows = tableRows tbl ++ [r]} db)
|
||||
|
||||
-- \| 整表替换
|
||||
replaceAll t rows = MemoryStorage $ \db -> do
|
||||
tbl <- lookupTable db t
|
||||
Right (Right (), replaceTable t tbl{tableRows = rows} db)
|
||||
|
||||
-- \| 建空表；已存在报错
|
||||
createTable name cols = MemoryStorage $ \db ->
|
||||
if any ((== name) . fst) db
|
||||
then Right (Left ("table already exists: " ++ name), db)
|
||||
else Right (Right (), db ++ [(name, Table name cols [])])
|
||||
|
||||
-- \| 删表；不存在报错
|
||||
dropTable name = MemoryStorage $ \db ->
|
||||
if any ((== name) . fst) db
|
||||
then Right (Right (), filter ((/= name) . fst) db)
|
||||
else Right (Left ("unknown table: " ++ name), db)
|
||||
|
||||
-- \| 删一列：表定义里去掉这一列，每一行里的那一格也一起去掉
|
||||
dropColumn name col = MemoryStorage $ \db ->
|
||||
case lookup name db of
|
||||
Nothing -> Right (Left ("unknown table: " ++ name), db)
|
||||
Just tbl ->
|
||||
if col `notElem` map fst (tableCols tbl)
|
||||
then Right (Left ("unknown column: " ++ col), db)
|
||||
else
|
||||
Right
|
||||
( Right ()
|
||||
, replaceTable
|
||||
name
|
||||
tbl
|
||||
{ tableCols = filter ((/= col) . fst) (tableCols tbl)
|
||||
, tableRows = map (filter ((/= col) . fst)) (tableRows tbl)
|
||||
}
|
||||
db
|
||||
)
|
||||
|
||||
-- \| 原样返回当前库
|
||||
snapshot = MemoryStorage $ \db -> Right (db, db)
|
||||
|
||||
-- \| 改表结构：列定义与行一起换
|
||||
replaceSchema name cols rows = MemoryStorage $ \db -> case lookup name db of
|
||||
Nothing -> Right (Left ("unknown table: " ++ name), db)
|
||||
Just tbl -> Right (Right (), replaceTable name tbl{tableCols = cols, tableRows = rows} db)
|
||||
|
||||
-- | 用给定表替换同名表
|
||||
replaceTable :: String -> Table -> Database -> Database
|
||||
replaceTable name table =
|
||||
map (\(n, t) -> if n == name then (n, table) else (n, t))
|
||||
|
||||
@@ -0,0 +1,129 @@
|
||||
module ChuSQL.Core.Engine.Syntax.AST (Statement (..), FromClause (..), JoinKind (..), Expr (..), Subquery (..), SortDir (..), makeSelect) where
|
||||
|
||||
import ChuSQL.Core.Model (Column (..), ColumnType, Value (..))
|
||||
|
||||
-- 语法树：语句、数据来源、条件表达式、排序方向。
|
||||
|
||||
data Statement
|
||||
= Select
|
||||
{ selectCols :: [String]
|
||||
, selectFrom :: FromClause
|
||||
, selectWhere :: Maybe Expr
|
||||
, selectGroupBy :: [String]
|
||||
, selectOrderBy :: [(String, SortDir)]
|
||||
, selectLimit :: Maybe Int
|
||||
}
|
||||
| SelectExpr
|
||||
{ selectItems :: [(String, Expr)]
|
||||
, selectFrom :: FromClause
|
||||
, selectWhere :: Maybe Expr
|
||||
, selectGroupBy :: [String]
|
||||
, selectOrderBy :: [(String, SortDir)]
|
||||
, selectLimit :: Maybe Int
|
||||
}
|
||||
| Insert String [String] [[Expr]]
|
||||
| Delete String (Maybe Expr)
|
||||
| Update String [(String, Expr)] (Maybe Expr)
|
||||
| CreateTable String [(String, Column)]
|
||||
| DropTable String
|
||||
| CreateIndex String String
|
||||
| DropIndex String String
|
||||
| DropColumn String String
|
||||
| AddColumn String (String, Column)
|
||||
| RenameColumn String String String
|
||||
| AlterColumnType String String ColumnType
|
||||
| AlterColumnDefault String String (Maybe Value)
|
||||
| AlterColumnNull String String Bool
|
||||
| CreateUser String String
|
||||
| AlterUser String String
|
||||
| DropUser String
|
||||
-- | 新角色：权限的载体，用户靠成员资格继承它的权限
|
||||
| CreateRole String
|
||||
-- | 删角色：连同它的授权与成员一起删
|
||||
| DropRole String
|
||||
-- | GRANT 权限 ON 表 TO 角色
|
||||
| GrantPrivileges [String] String String
|
||||
-- | REVOKE 权限 ON 表 FROM 角色
|
||||
| RevokePrivileges [String] String String
|
||||
-- | GRANT 角色 TO 用户：给用户加角色
|
||||
| GrantRole String [String]
|
||||
-- | REVOKE <角色> FROM <用户>[, ...]
|
||||
| RevokeRole String [String]
|
||||
| CreateDatabase String
|
||||
| DropDatabase String
|
||||
| UseDatabase String
|
||||
| ShowDatabases
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 连接类型：内连接与左外连接
|
||||
data JoinKind
|
||||
= InnerJoin
|
||||
| LeftJoin
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 数据来源：单表、带连接的来源，或空
|
||||
data FromClause
|
||||
= FromTable (Maybe String) String
|
||||
| FromJoin JoinKind FromClause (Maybe String) String Expr
|
||||
| FromUnit
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 子查询：语句，加上它对外层列的引用（自由变量，语义检查时填）
|
||||
data Subquery = Subquery
|
||||
{ subqueryStatement :: Statement
|
||||
, subqueryRefs :: [String]
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 条件表达式：列、字面量、算术、比较、逻辑、聚合与子查询
|
||||
data Expr
|
||||
= Col String
|
||||
| LitNull
|
||||
| LitInt Int
|
||||
| LitFloat Double
|
||||
| LitStr String
|
||||
| LitBool Bool
|
||||
| LitDate String
|
||||
| LitTimestamp String
|
||||
| LitBlob String
|
||||
| Add Expr Expr
|
||||
| Sub Expr Expr
|
||||
| Mul Expr Expr
|
||||
| Div Expr Expr
|
||||
| Neg Expr
|
||||
| Gt Expr Expr
|
||||
| Lt Expr Expr
|
||||
| Eq Expr Expr
|
||||
| And Expr Expr
|
||||
| Or Expr Expr
|
||||
| IsNull Expr
|
||||
| IsNotNull Expr
|
||||
| CountAll
|
||||
| CountOf Expr
|
||||
| SumOf Expr
|
||||
| AvgOf Expr
|
||||
| MinOf Expr
|
||||
| MaxOf Expr
|
||||
| ScalarSub Subquery
|
||||
| InSub Expr Subquery Bool
|
||||
| InList Expr [Expr] Bool
|
||||
| ExistsSub Subquery Bool
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 排序方向：升序或降序
|
||||
data SortDir
|
||||
= Asc
|
||||
| Desc
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 造一个最简单的 SELECT
|
||||
makeSelect :: [String] -> String -> Maybe Expr -> Statement
|
||||
makeSelect cols tbl w =
|
||||
Select
|
||||
{ selectCols = cols
|
||||
, selectFrom = FromTable Nothing tbl
|
||||
, selectWhere = w
|
||||
, selectGroupBy = []
|
||||
, selectOrderBy = []
|
||||
, selectLimit = Nothing
|
||||
}
|
||||
@@ -0,0 +1,661 @@
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
|
||||
module ChuSQL.Core.Engine.Syntax.Parser (parseStatement, parseExpression) where
|
||||
|
||||
import ChuSQL.Core.Model (Column (..), ColumnType (..), Value (..), plainColumn)
|
||||
import ChuSQL.Core.Engine.Syntax.AST
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)
|
||||
import Data.Char (isAlpha, isAlphaNum, isHexDigit, isSpace, toLower, toUpper)
|
||||
import Data.List (intercalate)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Void (Void)
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
import Text.Megaparsec.Char.Lexer qualified as Lxr
|
||||
|
||||
-- SQL 解析：词法 + 语法，把文本变成语句树。
|
||||
|
||||
type Parser = Parsec Void String
|
||||
|
||||
-- | 跳过空白
|
||||
sc :: Parser ()
|
||||
sc = Lxr.space space1 (Lxr.skipLineComment "--") (Lxr.skipBlockComment "/*" "*/")
|
||||
|
||||
-- | 词后面吃掉空白
|
||||
lexeme :: Parser a -> Parser a
|
||||
lexeme = Lxr.lexeme sc
|
||||
|
||||
-- | 读一个符号
|
||||
symbol :: String -> Parser String
|
||||
symbol = Lxr.symbol sc
|
||||
|
||||
-- | 读关键字（不分大小写）
|
||||
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)
|
||||
|
||||
-- | 账号名：裸名字或单引号字符串
|
||||
userName :: Parser String
|
||||
userName = identifier <|> stringLit
|
||||
|
||||
-- | 名字里允许的字符
|
||||
isIdentChar :: Char -> Bool
|
||||
isIdentChar ch = isAlphaNum ch || ch == '_'
|
||||
|
||||
-- | 读一个整数
|
||||
integer :: Parser Int
|
||||
integer = lexeme Lxr.decimal
|
||||
|
||||
-- | 读一个浮点数（必须有小数点或指数）
|
||||
floatLit :: Parser Double
|
||||
floatLit = lexeme Lxr.float
|
||||
|
||||
-- | 读一个字符串字面量
|
||||
stringLit :: Parser String
|
||||
stringLit = lexeme $ do
|
||||
_ <- char '\''
|
||||
s <- many stringChar
|
||||
_ <- char '\''
|
||||
return s
|
||||
|
||||
-- | 字符串里的一个字符
|
||||
stringChar :: Parser Char
|
||||
stringChar =
|
||||
choice
|
||||
[ '\'' <$ try (string "''")
|
||||
, satisfy (/= '\'')
|
||||
]
|
||||
|
||||
-- | X'ABCD' 形式的二进制字面量，统一存成大写十六进制文本
|
||||
blobLit :: Parser String
|
||||
blobLit = lexeme $ do
|
||||
_ <- char 'x' <|> char 'X'
|
||||
_ <- char '\''
|
||||
s <- many (satisfy isHexDigit)
|
||||
_ <- char '\''
|
||||
return (map toUpper s)
|
||||
|
||||
-- | 升序或降序
|
||||
sortDir :: Parser SortDir
|
||||
sortDir = (Desc <$ keyword "desc") <|> (Asc <$ keyword "asc") <|> pure Asc
|
||||
|
||||
-- | LIMIT 后面的整数
|
||||
limitClause :: Parser Int
|
||||
limitClause = do
|
||||
keyword "limit"
|
||||
integer
|
||||
|
||||
-- | 能带表名的列名
|
||||
qualifiedName :: Parser String
|
||||
qualifiedName = do
|
||||
first <- identifier
|
||||
rest <- many (symbol "." *> identifier)
|
||||
return (intercalate "." (first : rest))
|
||||
|
||||
-- | 读一个表达式
|
||||
expr :: Parser Expr
|
||||
expr = makeExprParser atom operatorTable
|
||||
|
||||
-- | 运算符优先级（从紧到松）
|
||||
operatorTable :: [[Operator Parser Expr]]
|
||||
operatorTable =
|
||||
[ [Prefix (Neg <$ symbol "-")]
|
||||
, [InfixL (Mul <$ symbol "*"), InfixL (Div <$ symbol "/")]
|
||||
, [InfixL (Add <$ symbol "+"), InfixL (Sub <$ symbol "-")]
|
||||
, [ InfixN (Gt <$ symbol ">")
|
||||
, InfixN (Lt <$ symbol "<")
|
||||
, InfixN (Eq <$ symbol "=")
|
||||
]
|
||||
, [ Postfix inPredicate
|
||||
, Postfix (IsNotNull <$ try (keyword "is" *> keyword "not" *> keyword "null"))
|
||||
, Postfix (IsNull <$ (keyword "is" *> keyword "null"))
|
||||
]
|
||||
, [InfixL (And <$ keyword "AND")]
|
||||
, [InfixL (Or <$ keyword "OR")]
|
||||
]
|
||||
|
||||
-- | 最小的表达式单位
|
||||
atom :: Parser Expr
|
||||
atom =
|
||||
choice
|
||||
[ LitNull <$ keyword "null"
|
||||
, LitBool True <$ keyword "TRUE"
|
||||
, LitBool False <$ keyword "FALSE"
|
||||
, try (LitDate <$> (keyword "date" *> stringLit))
|
||||
, try (LitTimestamp <$> (keyword "timestamp" *> stringLit))
|
||||
, try (LitBlob <$> blobLit)
|
||||
, LitFloat <$> try floatLit
|
||||
, LitInt <$> integer
|
||||
, LitStr <$> stringLit
|
||||
, try aggregateCall
|
||||
, try existsPredicate
|
||||
, Col <$> qualifiedName
|
||||
, try scalarSubquery
|
||||
, between (symbol "(") (symbol ")") expr
|
||||
]
|
||||
|
||||
-- | [NOT] EXISTS (SELECT ...)
|
||||
existsPredicate :: Parser Expr
|
||||
existsPredicate = do
|
||||
negated <- (True <$ try (keyword "not" *> keyword "exists")) <|> (False <$ keyword "exists")
|
||||
sq <- between (symbol "(") (symbol ")") subquerySelect
|
||||
return (ExistsSub sq negated)
|
||||
|
||||
-- | 标量子查询：(SELECT ...)
|
||||
scalarSubquery :: Parser Expr
|
||||
scalarSubquery = ScalarSub <$> between (symbol "(") (symbol ")") subquerySelect
|
||||
|
||||
-- | 读 [NOT] IN：子查询或值清单
|
||||
inPredicate :: Parser (Expr -> Expr)
|
||||
inPredicate = do
|
||||
negated <- (True <$ try (keyword "not" *> keyword "in")) <|> (False <$ keyword "in")
|
||||
body <-
|
||||
between (symbol "(") (symbol ")") $
|
||||
choice
|
||||
[ Left <$> try subquerySelect
|
||||
, Right <$> sepBy1 expr (symbol ",")
|
||||
]
|
||||
return $ \e -> case body of
|
||||
Left sq -> InSub e sq negated
|
||||
Right es -> InList e es negated
|
||||
|
||||
-- | 括号里的子查询；对外层列的引用留给语义检查填
|
||||
subquerySelect :: Parser Subquery
|
||||
subquerySelect = Subquery <$> selectStatement <*> pure []
|
||||
|
||||
-- | 聚合调用：COUNT/SUM/AVG/MIN/MAX
|
||||
aggregateCall :: Parser Expr
|
||||
aggregateCall =
|
||||
choice
|
||||
[ CountAll <$ try (keyword "count" *> between (symbol "(") (symbol ")") (symbol "*"))
|
||||
, CountOf <$> aggArg "count"
|
||||
, SumOf <$> aggArg "sum"
|
||||
, AvgOf <$> aggArg "avg"
|
||||
, MinOf <$> aggArg "min"
|
||||
, MaxOf <$> aggArg "max"
|
||||
]
|
||||
where
|
||||
-- | 读聚合函数的参数
|
||||
aggArg name = try (keyword name *> between (symbol "(") (symbol ")") expr)
|
||||
|
||||
-- | 只认字面量，给 DEFAULT 用
|
||||
literalValue :: Parser Value
|
||||
literalValue =
|
||||
choice
|
||||
[ VNull <$ keyword "null"
|
||||
, VBool True <$ keyword "TRUE"
|
||||
, VBool False <$ keyword "FALSE"
|
||||
, try (negateLit <$> floatLit)
|
||||
, VInt <$> integer
|
||||
, VFloat <$> try floatLit
|
||||
, VStr <$> stringLit
|
||||
]
|
||||
where
|
||||
-- | 负浮点字面量
|
||||
negateLit d = VFloat (negate d)
|
||||
|
||||
-- | 一个排序列
|
||||
orderItem :: Parser (String, SortDir)
|
||||
orderItem = do
|
||||
col <- qualifiedName
|
||||
dir <- sortDir
|
||||
return (col, dir)
|
||||
|
||||
-- | ORDER BY 的列表
|
||||
orderByClause :: Parser [(String, SortDir)]
|
||||
orderByClause = do
|
||||
keyword "order"
|
||||
keyword "by"
|
||||
sepBy1 orderItem (symbol ",")
|
||||
|
||||
-- | GROUP BY 的列表
|
||||
groupByClause :: Parser [String]
|
||||
groupByClause = do
|
||||
keyword "group"
|
||||
keyword "by"
|
||||
sepBy1 qualifiedName (symbol ",")
|
||||
|
||||
-- | SET 里的一条赋值
|
||||
assignment :: Parser (String, Expr)
|
||||
assignment = do
|
||||
col <- identifier
|
||||
_ <- symbol "="
|
||||
e <- expr
|
||||
return (col, e)
|
||||
|
||||
-- | 保留字清单，别名不许用
|
||||
reservedWords :: [String]
|
||||
reservedWords =
|
||||
[ "select"
|
||||
, "as"
|
||||
, "from"
|
||||
, "where"
|
||||
, "order"
|
||||
, "by"
|
||||
, "limit"
|
||||
, "join"
|
||||
, "left"
|
||||
, "outer"
|
||||
, "inner"
|
||||
, "exists"
|
||||
, "in"
|
||||
, "on"
|
||||
, "and"
|
||||
, "or"
|
||||
, "asc"
|
||||
, "desc"
|
||||
, "insert"
|
||||
, "into"
|
||||
, "values"
|
||||
, "delete"
|
||||
, "update"
|
||||
, "set"
|
||||
, "create"
|
||||
, "table"
|
||||
, "index"
|
||||
, "drop"
|
||||
, "alter"
|
||||
, "add"
|
||||
, "rename"
|
||||
, "to"
|
||||
, "column"
|
||||
, "user"
|
||||
, "identified"
|
||||
, "null"
|
||||
, "is"
|
||||
, "not"
|
||||
, "default"
|
||||
, "check"
|
||||
, "unique"
|
||||
, "primary"
|
||||
, "key"
|
||||
, "auto_increment"
|
||||
, "type"
|
||||
, "group"
|
||||
]
|
||||
|
||||
-- | 别名（不许用保留字）
|
||||
aliasName :: Parser String
|
||||
aliasName = try $ do
|
||||
name <- identifier
|
||||
if map toLower name `elem` reservedWords then empty else return name
|
||||
|
||||
-- | 表名 + 可选别名
|
||||
tableRef :: Parser (Maybe String, String)
|
||||
tableRef = do
|
||||
tbl <- tableName
|
||||
mAlias <- optional ((keyword "as" *> aliasName) <|> aliasName)
|
||||
return (mAlias, tbl)
|
||||
|
||||
-- | 连接类型：内连接 / 左外连接
|
||||
joinKind :: Parser JoinKind
|
||||
joinKind =
|
||||
try (keyword "left" *> optional (keyword "outer") *> keyword "join" *> return LeftJoin)
|
||||
<|> try (keyword "inner" *> keyword "join" *> return InnerJoin)
|
||||
<|> (keyword "join" *> return InnerJoin)
|
||||
|
||||
-- | 一个 JOIN ... ON
|
||||
joinClause :: Parser (JoinKind, Maybe String, String, Expr)
|
||||
joinClause = do
|
||||
kind <- joinKind
|
||||
(mAlias, tbl) <- tableRef
|
||||
keyword "on"
|
||||
cond <- expr
|
||||
return (kind, mAlias, tbl, cond)
|
||||
|
||||
-- | FROM 子句（可含多个 JOIN）
|
||||
fromClause :: Parser FromClause
|
||||
fromClause = do
|
||||
(mAlias, tbl) <- tableRef
|
||||
joins <- many joinClause
|
||||
return (foldl (\acc (k, a, t, c) -> FromJoin k acc a t c) (FromTable mAlias tbl) joins)
|
||||
|
||||
-- | SELECT 的列清单
|
||||
selectList :: Parser [(String, Expr)]
|
||||
selectList =
|
||||
choice
|
||||
[ [("*", Col "*")] <$ symbol "*"
|
||||
, sepBy1 selectItem (symbol ",")
|
||||
]
|
||||
|
||||
-- | 投影标签保留表达式原文
|
||||
selectItem :: Parser (String, Expr)
|
||||
selectItem = do
|
||||
(source, e) <- match expr
|
||||
pure (case e of Col c -> (c, e); _ -> (reverse (dropWhile isSpace (reverse source)), e))
|
||||
|
||||
-- | 读 CREATE TABLE
|
||||
createTableStatement :: Parser Statement
|
||||
createTableStatement = do
|
||||
keyword "create"
|
||||
keyword "table"
|
||||
name <- tableName
|
||||
cols <- between (symbol "(") (symbol ")") (sepBy1 columnDef (symbol ","))
|
||||
return (CreateTable name cols)
|
||||
|
||||
-- | 读 DROP TABLE
|
||||
dropTableStatement :: Parser Statement
|
||||
dropTableStatement = do
|
||||
keyword "drop"
|
||||
keyword "table"
|
||||
name <- tableName
|
||||
return (DropTable name)
|
||||
|
||||
-- | 读 CREATE INDEX（列名即索引名）
|
||||
createIndexStatement :: Parser Statement
|
||||
createIndexStatement = do
|
||||
keyword "create"
|
||||
keyword "index"
|
||||
keyword "on"
|
||||
tbl <- tableName
|
||||
col <- between (symbol "(") (symbol ")") identifier
|
||||
return (CreateIndex tbl col)
|
||||
|
||||
-- | 读 DROP INDEX
|
||||
dropIndexStatement :: Parser Statement
|
||||
dropIndexStatement = do
|
||||
keyword "drop"
|
||||
keyword "index"
|
||||
keyword "on"
|
||||
tbl <- tableName
|
||||
col <- between (symbol "(") (symbol ")") identifier
|
||||
return (DropIndex tbl col)
|
||||
|
||||
-- | 读 ALTER TABLE 的加列、删列、改名与改属性
|
||||
alterTableStatement :: Parser Statement
|
||||
alterTableStatement = do
|
||||
keyword "alter"
|
||||
keyword "table"
|
||||
tbl <- tableName
|
||||
choice
|
||||
[ do
|
||||
keyword "add"
|
||||
void (optional (keyword "column"))
|
||||
(name, col) <- columnDef
|
||||
pure (AddColumn tbl (name, col))
|
||||
, do
|
||||
keyword "drop"
|
||||
void (optional (keyword "column"))
|
||||
DropColumn tbl <$> identifier
|
||||
, do
|
||||
keyword "rename"
|
||||
void (optional (keyword "column"))
|
||||
old <- identifier
|
||||
keyword "to"
|
||||
RenameColumn tbl old <$> identifier
|
||||
, do
|
||||
keyword "alter"
|
||||
void (optional (keyword "column"))
|
||||
col <- identifier
|
||||
choice
|
||||
[ AlterColumnType tbl col <$> (keyword "type" *> columnTypeP)
|
||||
, try (AlterColumnNull tbl col False <$ (keyword "set" *> keyword "not" *> keyword "null"))
|
||||
, try (AlterColumnNull tbl col True <$ (keyword "drop" *> keyword "not" *> keyword "null"))
|
||||
, try (AlterColumnDefault tbl col . Just <$> (keyword "set" *> keyword "default" *> literalValue))
|
||||
, AlterColumnDefault tbl col Nothing <$ (keyword "drop" *> keyword "default")
|
||||
]
|
||||
]
|
||||
|
||||
-- | 读 CREATE USER，口令是明文
|
||||
createUserStatement :: Parser Statement
|
||||
createUserStatement = do
|
||||
keyword "create"
|
||||
keyword "user"
|
||||
name <- userName
|
||||
pw <- identifiedBy
|
||||
return (CreateUser name pw)
|
||||
|
||||
-- | 读 IDENTIFIED BY '口令'
|
||||
identifiedBy :: Parser String
|
||||
identifiedBy = do
|
||||
keyword "identified"
|
||||
keyword "by"
|
||||
stringLit
|
||||
|
||||
-- | 读 ALTER USER 改口令
|
||||
alterUserStatement :: Parser Statement
|
||||
alterUserStatement = do
|
||||
keyword "alter"
|
||||
keyword "user"
|
||||
name <- userName
|
||||
pw <- identifiedBy
|
||||
return (AlterUser name pw)
|
||||
|
||||
-- | 读 DROP USER
|
||||
dropUserStatement :: Parser Statement
|
||||
dropUserStatement = do
|
||||
keyword "drop"
|
||||
keyword "user"
|
||||
name <- userName
|
||||
return (DropUser name)
|
||||
|
||||
-- | 读 CREATE ROLE
|
||||
createRoleStatement :: Parser Statement
|
||||
createRoleStatement = do
|
||||
keyword "create"
|
||||
keyword "role"
|
||||
CreateRole <$> userName
|
||||
|
||||
-- | 读 DROP ROLE
|
||||
dropRoleStatement :: Parser Statement
|
||||
dropRoleStatement = do
|
||||
keyword "drop"
|
||||
keyword "role"
|
||||
DropRole <$> userName
|
||||
|
||||
-- | 权限名，统一收成大写
|
||||
privilegeName :: Parser String
|
||||
privilegeName =
|
||||
choice
|
||||
[ "SELECT" <$ keyword "select"
|
||||
, "INSERT" <$ keyword "insert"
|
||||
, "UPDATE" <$ keyword "update"
|
||||
, "DELETE" <$ keyword "delete"
|
||||
, "ALL" <$ keyword "all"
|
||||
]
|
||||
|
||||
-- | ON 后面的授权对象：* 或一张表
|
||||
grantObject :: Parser String
|
||||
grantObject = ("*" <$ symbol "*") <|> tableName
|
||||
|
||||
-- | 读 GRANT：带 ON 的授权限，不带的加角色
|
||||
grantStatement :: Parser Statement
|
||||
grantStatement = do
|
||||
keyword "grant"
|
||||
choice
|
||||
[ try $ do
|
||||
privs <- sepBy1 privilegeName (symbol ",")
|
||||
keyword "on"
|
||||
obj <- grantObject
|
||||
keyword "to"
|
||||
GrantPrivileges privs obj <$> userName
|
||||
, GrantRole <$> userName <*> (keyword "to" *> sepBy1 userName (symbol ","))
|
||||
]
|
||||
|
||||
-- | 读 REVOKE：与 GRANT 对称
|
||||
revokeStatement :: Parser Statement
|
||||
revokeStatement = do
|
||||
keyword "revoke"
|
||||
choice
|
||||
[ try $ do
|
||||
privs <- sepBy1 privilegeName (symbol ",")
|
||||
keyword "on"
|
||||
obj <- grantObject
|
||||
keyword "from"
|
||||
RevokePrivileges privs obj <$> userName
|
||||
, RevokeRole <$> userName <*> (keyword "from" *> sepBy1 userName (symbol ","))
|
||||
]
|
||||
|
||||
-- | 建表时的一列：类型后面跟若干约束
|
||||
columnDef :: Parser (String, Column)
|
||||
columnDef = do
|
||||
name <- identifier
|
||||
ty <- columnTypeP
|
||||
mods <- many columnConstraint
|
||||
return (name, foldl (\c f -> f c) (plainColumn ty) mods)
|
||||
|
||||
-- | 一条列约束
|
||||
columnConstraint :: Parser (Column -> Column)
|
||||
columnConstraint =
|
||||
choice
|
||||
[ try (keyword "not" *> keyword "null" *> pure (\c -> c{columnNullable = False}))
|
||||
, keyword "null" *> pure (\c -> c{columnNullable = True})
|
||||
, keyword "auto_increment" *> pure (\c -> c{columnAutoIncrement = True, columnNullable = False})
|
||||
, try (keyword "primary" *> keyword "key" *> pure (\c -> c{columnPrimaryKey = True, columnUnique = True, columnNullable = False}))
|
||||
, keyword "unique" *> pure (\c -> c{columnUnique = True})
|
||||
, keyword "default" *> ((\v c -> c{columnDefault = Just v}) <$> literalValue)
|
||||
, keyword "check" *> ((\s c -> c{columnCheck = Just s}) <$> checkText)
|
||||
]
|
||||
|
||||
-- | CHECK 后面括号里的表达式原文，交给执行期再解析
|
||||
checkText :: Parser String
|
||||
checkText = between (symbol "(") (symbol ")") (match expr) >>= \(source, _) -> pure source
|
||||
|
||||
-- | 括号里的长度参数
|
||||
sizeParen :: Parser Int
|
||||
sizeParen = try (between (symbol "(") (symbol ")") integer)
|
||||
|
||||
-- | 列类型关键字
|
||||
columnTypeP :: Parser ColumnType
|
||||
columnTypeP =
|
||||
choice
|
||||
[ keyword "integer" >> pure CInt
|
||||
, keyword "int" >> pure CInt
|
||||
, keyword "bigint" >> pure CBigInt
|
||||
, keyword "smallint" >> pure CSmallInt
|
||||
, (keyword "varchar" >>) (maybe CStr CVarchar <$> optional sizeParen)
|
||||
, (keyword "char" >>) (maybe (CChar 1) CChar <$> optional sizeParen)
|
||||
, keyword "text" >> pure CStr
|
||||
, keyword "str" >> pure CStr
|
||||
, keyword "boolean" >> pure CBool
|
||||
, keyword "bool" >> pure CBool
|
||||
, keyword "float" >> pure CFloat
|
||||
, keyword "real" >> pure CFloat
|
||||
, try (keyword "double" *> keyword "precision" *> pure CDouble)
|
||||
, keyword "double" >> pure CDouble
|
||||
, (keyword "decimal" >>) decimalType
|
||||
, (keyword "numeric" >>) decimalType
|
||||
, keyword "date" >> pure CDate
|
||||
, keyword "timestamp" >> pure CTimestamp
|
||||
, keyword "blob" >> pure CBlob
|
||||
]
|
||||
|
||||
-- | DECIMAL 的精度与小数位
|
||||
decimalType :: Parser ColumnType
|
||||
decimalType = do
|
||||
args <- optional (try (between (symbol "(") (symbol ")") decimalArgs))
|
||||
pure $ case args of
|
||||
Nothing -> CDecimal 10 0
|
||||
Just (p, s) -> CDecimal p s
|
||||
|
||||
-- | DECIMAL 的精度与小数位参数
|
||||
decimalArgs :: Parser (Int, Int)
|
||||
decimalArgs = do
|
||||
p <- integer
|
||||
s <- fromMaybe 0 <$> optional (symbol "," *> integer)
|
||||
pure (p, s)
|
||||
|
||||
-- | 读 SELECT
|
||||
selectStatement :: Parser Statement
|
||||
selectStatement = do
|
||||
keyword "select"
|
||||
cols <- selectList
|
||||
fromC <- fromMaybe FromUnit <$> optional (keyword "from" *> fromClause)
|
||||
mWhere <- optional (keyword "where" *> expr)
|
||||
groupBy <- fromMaybe [] <$> optional groupByClause
|
||||
orderBy <- fromMaybe [] <$> optional orderByClause
|
||||
mLimit <- optional limitClause
|
||||
pure $ if all (\(name, e) -> e == Col name) cols
|
||||
then Select (map fst cols) fromC mWhere groupBy orderBy mLimit
|
||||
else SelectExpr cols fromC mWhere groupBy orderBy mLimit
|
||||
|
||||
-- | 读 INSERT，可一次插多行
|
||||
insertStatement :: Parser Statement
|
||||
insertStatement = do
|
||||
keyword "INSERT"
|
||||
keyword "INTO"
|
||||
tbl <- tableName
|
||||
cols <-
|
||||
between
|
||||
(symbol "(")
|
||||
(symbol ")")
|
||||
(sepBy1 identifier (symbol ","))
|
||||
keyword "VALUES"
|
||||
rows <- sepBy1 valueRow (symbol ",")
|
||||
return (Insert tbl cols rows)
|
||||
|
||||
-- | 一行值：一对括号里的若干字面量
|
||||
valueRow :: Parser [Expr]
|
||||
valueRow = between (symbol "(") (symbol ")") (sepBy1 expr (symbol ","))
|
||||
|
||||
-- | 读 DELETE
|
||||
deleteStatement :: Parser Statement
|
||||
deleteStatement = do
|
||||
keyword "DELETE"
|
||||
keyword "FROM"
|
||||
tbl <- tableName
|
||||
mWhere <- optional (keyword "WHERE" *> expr)
|
||||
return (Delete tbl mWhere)
|
||||
|
||||
-- | 读 UPDATE
|
||||
updateStatement :: Parser Statement
|
||||
updateStatement = do
|
||||
keyword "update"
|
||||
tbl <- tableName
|
||||
keyword "set"
|
||||
assigns <- sepBy1 assignment (symbol ",")
|
||||
mWhere <- optional (keyword "where" *> expr)
|
||||
return (Update tbl assigns mWhere)
|
||||
|
||||
-- | 解析总入口
|
||||
parseStatement :: String -> Either String Statement
|
||||
parseStatement input =
|
||||
case runParser (sc *> statementP <* sc <* eof) "<query>" input of
|
||||
Left err -> Left (errorBundlePretty err)
|
||||
Right q -> Right q
|
||||
where
|
||||
-- | 按关键字分派到各语句解析器
|
||||
statementP =
|
||||
selectStatement
|
||||
<|> try (CreateDatabase <$> (keyword "create" *> keyword "database" *> identifier))
|
||||
<|> try (DropDatabase <$> (keyword "drop" *> keyword "database" *> identifier))
|
||||
<|> (UseDatabase <$> (keyword "use" *> identifier))
|
||||
<|> (ShowDatabases <$ (keyword "show" *> keyword "databases"))
|
||||
<|> insertStatement
|
||||
<|> deleteStatement
|
||||
<|> updateStatement
|
||||
<|> try createUserStatement
|
||||
<|> try alterUserStatement
|
||||
<|> try dropUserStatement
|
||||
<|> try createRoleStatement
|
||||
<|> try dropRoleStatement
|
||||
<|> try grantStatement
|
||||
<|> try revokeStatement
|
||||
<|> try createIndexStatement
|
||||
<|> try createTableStatement
|
||||
<|> try dropIndexStatement
|
||||
<|> try alterTableStatement
|
||||
<|> dropTableStatement
|
||||
|
||||
-- | 解析一个裸表达式（CHECK 约束原文用）
|
||||
parseExpression :: String -> Either String Expr
|
||||
parseExpression input =
|
||||
case runParser (sc *> expr <* sc <* eof) "<expr>" input of
|
||||
Left err -> Left (errorBundlePretty err)
|
||||
Right e -> Right e
|
||||
|
||||
-- | 表名至多有一个库前缀。
|
||||
tableName :: Parser String
|
||||
tableName = do
|
||||
first <- identifier
|
||||
databaseTable <- optional (symbol "." *> identifier)
|
||||
pure (maybe first (\t -> map toLower first ++ "." ++ t) databaseTable)
|
||||
@@ -0,0 +1,8 @@
|
||||
resolver: lts-24.59
|
||||
|
||||
extra-lib-dirs:
|
||||
- ../storage/target/release
|
||||
|
||||
packages:
|
||||
- .
|
||||
- ../model
|
||||
@@ -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
|
||||
File diff suppressed because it is too large.
Load diff
Reference in new issue
Block a user