事务模型
This commit is contained in:
LIm1tZz7 committed
1 parent
274b7fcdcc
commit
045ccc2dc0
20 files changed
+1519
-294
No files matched your search
@@ -134,6 +134,9 @@ runStatementUncheckedM _ q@CreateDatabase{} = runStatementM q
|
||||
runStatementUncheckedM _ q@DropDatabase{} = runStatementM q
|
||||
runStatementUncheckedM _ q@UseDatabase{} = runStatementM q
|
||||
runStatementUncheckedM _ ShowDatabases = runStatementM ShowDatabases
|
||||
runStatementUncheckedM _ BeginTransaction = pure (Left "BEGIN is executed by the session")
|
||||
runStatementUncheckedM _ CommitTransaction = pure (Left "COMMIT is executed by the session")
|
||||
runStatementUncheckedM _ RollbackTransaction = pure (Left "ROLLBACK is executed by the session")
|
||||
|
||||
-- | 只有需要读全表才能判断约束时才扫表
|
||||
existingRows :: (MonadStorage m) => String -> Table -> m (Either String [Row])
|
||||
|
||||
@@ -51,6 +51,8 @@ errorRules =
|
||||
, ErrorRule "storage" StorageError "query_error"
|
||||
, ErrorRule "storage library call failed" StorageError "query_error"
|
||||
, ErrorRule "unsupported protocol" ProtocolError "query_error"
|
||||
, ErrorRule "executed by the session" ProtocolError "query_error"
|
||||
, ErrorRule "transaction" ProtocolError "query_error"
|
||||
]
|
||||
|
||||
-- | 命中的第一条规则
|
||||
|
||||
@@ -38,16 +38,16 @@ scopeAt place scope c
|
||||
| "ambiguous column:" `isInfixOf` err -> Left err
|
||||
| otherwise -> columnAt place (scopeOuter scope) c
|
||||
|
||||
-- | 收集 FROM 能提供的列，含外层作用域
|
||||
-- | 收集 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))
|
||||
(key, t) <- resolveTable db tbl
|
||||
Right (prefixColumns (Just (deriveQualifier mAlias key)) (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)
|
||||
(key, t) <- resolveTable db tbl
|
||||
let env = lcols ++ prefixColumns (Just (deriveQualifier mAlias key)) (tableCols t)
|
||||
checkBool db "ON" (Scope env outer) cond
|
||||
Right env
|
||||
|
||||
@@ -433,6 +433,10 @@ checkResolvedWith db outer q = case q of
|
||||
DropDatabase name -> checkDatabaseName name
|
||||
UseDatabase name -> checkDatabaseName name
|
||||
ShowDatabases -> Right ()
|
||||
-- | 事务控制由会话层执行，语义层不做列检查
|
||||
BeginTransaction -> Right ()
|
||||
CommitTransaction -> Right ()
|
||||
RollbackTransaction -> Right ()
|
||||
where
|
||||
tableCols' = map fst . tableCols
|
||||
|
||||
@@ -650,21 +654,21 @@ resolveStatement db q = case q of
|
||||
Select{} -> resolveSelect db q
|
||||
SelectExpr{} -> resolveSelect db q
|
||||
Update tbl assigns mWhere -> do
|
||||
t <- lookupTable db tbl
|
||||
(key, t) <- resolveTable 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)
|
||||
pure (Update key assigns' w)
|
||||
Delete tbl mWhere -> do
|
||||
t <- lookupTable db tbl
|
||||
(key, t) <- resolveTable db tbl
|
||||
w <- mapM (resolveExpr db (tableCols t) [] (nameIn (tableCols t) "WHERE")) mWhere
|
||||
pure (Delete tbl w)
|
||||
pure (Delete key w)
|
||||
Insert tbl cols rows -> do
|
||||
t <- lookupTable db tbl
|
||||
(key, t) <- resolveTable db tbl
|
||||
let env = tableCols t
|
||||
rows' <- mapM (mapM (resolveExpr db env [] (nameIn env "INSERT"))) rows
|
||||
pure (Insert tbl cols rows')
|
||||
pure (Insert key cols rows')
|
||||
other -> Right other
|
||||
|
||||
-- | 查一列的物理名
|
||||
@@ -685,9 +689,9 @@ 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
|
||||
FromTable Nothing tbl -> unqualify (Just (deriveQualifier Nothing tbl)) c
|
||||
_ -> c
|
||||
-- | 查一列并换算成物理名
|
||||
name place c = physical . fst <$> scopedColumnAt place env outer c
|
||||
@@ -707,18 +711,23 @@ resolveQuery db outer q items = do
|
||||
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
|
||||
FromTable mAlias tbl -> do
|
||||
(key, _) <- resolveTable db tbl
|
||||
Right (FromTable mAlias key)
|
||||
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 里的子查询也能引用外层列
|
||||
-- | 连接两侧取表名末段作别名；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 _ (FromTable alias tbl) = do
|
||||
(key, _) <- resolveTable db tbl
|
||||
Right (FromTable (Just (deriveQualifier alias key)) key)
|
||||
resolveFrom db outer fromC@(FromJoin kind left alias tbl cond) = do
|
||||
env <- checkFrom db outer fromC
|
||||
l <- resolveFrom db outer left
|
||||
(key, _) <- resolveTable db tbl
|
||||
c <- resolveExpr db env outer (fmap fst . columnAt "ON" env) cond
|
||||
pure (FromJoin kind l (Just (fromMaybe tbl alias)) tbl c)
|
||||
pure (FromJoin kind l (Just (deriveQualifier alias key)) key c)
|
||||
@@ -3,6 +3,10 @@
|
||||
|
||||
module ChuSQL.Core.Engine.Storage.IPC (
|
||||
IPCStorage (..),
|
||||
Env (..),
|
||||
envForDatabase,
|
||||
defaultEnv,
|
||||
runIPCStorage,
|
||||
Request (..),
|
||||
Response (..),
|
||||
Account (..),
|
||||
@@ -41,21 +45,38 @@ import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
-- IPC 存储实现：把 MonadStorage 的操作变成发给存储库的 JSON 请求。
|
||||
|
||||
newtype IPCStorage a = IPCStorage
|
||||
{ runIPCStorage :: IO a
|
||||
-- | 一条会话的存储环境：当前库名随会话走，不共享
|
||||
data Env = Env
|
||||
{ envDatabase :: Maybe String
|
||||
}
|
||||
|
||||
newtype IPCStorage a = IPCStorage
|
||||
{ runIPCStorageIn :: Env -> IO a
|
||||
}
|
||||
|
||||
-- | 按库名造一个会话环境
|
||||
envForDatabase :: Maybe String -> Env
|
||||
envForDatabase = Env
|
||||
|
||||
-- | 进程默认环境：读全局库名，给测试与 CLI 用
|
||||
defaultEnv :: IO Env
|
||||
defaultEnv = Env <$> readMVar databaseRef
|
||||
|
||||
-- | 用进程默认环境跑（兼容既有调用点）
|
||||
runIPCStorage :: IPCStorage a -> IO a
|
||||
runIPCStorage action = defaultEnv >>= runIPCStorageIn action
|
||||
|
||||
instance Functor IPCStorage where
|
||||
fmap f (IPCStorage m) = IPCStorage (fmap f m)
|
||||
fmap f (IPCStorage m) = IPCStorage (fmap f . m)
|
||||
|
||||
instance Applicative IPCStorage where
|
||||
pure = IPCStorage . pure
|
||||
IPCStorage mf <*> IPCStorage ma = IPCStorage (mf <*> ma)
|
||||
pure = IPCStorage . const . pure
|
||||
IPCStorage mf <*> IPCStorage ma = IPCStorage $ \env -> mf env <*> ma env
|
||||
|
||||
instance Monad IPCStorage where
|
||||
IPCStorage m >>= k = IPCStorage $ do
|
||||
a <- m
|
||||
runIPCStorage (k a)
|
||||
IPCStorage m >>= k = IPCStorage $ \env -> do
|
||||
a <- m env
|
||||
runIPCStorageIn (k a) env
|
||||
|
||||
-- | 一条到存储库的链路：管请求与关闭
|
||||
data StorageLink = StorageLink
|
||||
@@ -147,10 +168,9 @@ 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)
|
||||
ask :: Env -> String -> Request -> (Response -> Maybe a) -> IO (Either String a)
|
||||
ask env what req recognize = do
|
||||
resp <- sendRequest (stampDatabase (envDatabase env) req)
|
||||
pure $ case resp of
|
||||
RespError e -> Left e
|
||||
other -> case recognize other of
|
||||
@@ -163,99 +183,100 @@ okOnly RespOk = Just ()
|
||||
okOnly _ = Nothing
|
||||
|
||||
-- | 发 Scan
|
||||
doScan :: String -> IO (Either String [Row])
|
||||
doScan t = ask "scan" (ReqScan t) $ \resp -> case resp of
|
||||
doScan :: Env -> String -> IO (Either String [Row])
|
||||
doScan env t = ask env "scan" (ReqScan t) $ \resp -> case resp of
|
||||
RespRows rows -> Just rows
|
||||
_ -> Nothing
|
||||
|
||||
-- | 发带投影的 Scan
|
||||
doScanColumns :: String -> [String] -> IO (Either String [Row])
|
||||
doScanColumns t cols = ask "scan" (ReqScanColumns t cols) $ \resp -> case resp of
|
||||
doScanColumns :: Env -> String -> [String] -> IO (Either String [Row])
|
||||
doScanColumns env t cols = ask env "scan" (ReqScanColumns t cols) $ \resp -> case resp of
|
||||
RespRows rows -> Just [[(c, v) | c <- cols, Just v <- [lookup c row]] | row <- rows]
|
||||
_ -> Nothing
|
||||
|
||||
-- | 发分片 Scan：只取第 shard 片
|
||||
doScanShard :: String -> Maybe [String] -> Int -> Int -> IO (Either String [Row])
|
||||
doScanShard t cols shard shards = ask "scan_shard" (ReqScanShard t cols shard shards) $ \resp -> case resp of
|
||||
doScanShard :: Env -> String -> Maybe [String] -> Int -> Int -> IO (Either String [Row])
|
||||
doScanShard env t cols shard shards = ask env "scan_shard" (ReqScanShard t cols shard shards) $ \resp -> case resp of
|
||||
RespRows rows -> Just rows
|
||||
_ -> Nothing
|
||||
|
||||
-- | 发 Insert（索引由存储层维护）
|
||||
doInsert :: String -> Row -> IO (Either String ())
|
||||
doInsert t r = ask "insert" (ReqInsert t r) okOnly
|
||||
doInsert :: Env -> String -> Row -> IO (Either String ())
|
||||
doInsert env t r = ask env "insert" (ReqInsert t r) okOnly
|
||||
|
||||
-- | 发 InsertBatch：一批行一次请求
|
||||
doInsertMany :: String -> [Row] -> IO (Either String ())
|
||||
doInsertMany t rs = ask "insert_batch" (ReqInsertBatch t rs) okOnly
|
||||
doInsertMany :: Env -> String -> [Row] -> IO (Either String ())
|
||||
doInsertMany env t rs = ask env "insert_batch" (ReqInsertBatch t rs) okOnly
|
||||
|
||||
-- | 发 DeleteKeys
|
||||
doDeleteKeys :: String -> [Int] -> IO (Either String ())
|
||||
doDeleteKeys t ks = ask "delete_keys" (ReqDeleteKeys t ks) okOnly
|
||||
doDeleteKeys :: Env -> String -> [Int] -> IO (Either String ())
|
||||
doDeleteKeys env t ks = ask env "delete_keys" (ReqDeleteKeys t ks) okOnly
|
||||
|
||||
-- | 发 ReplaceAll
|
||||
doReplaceAll :: String -> [Row] -> IO (Either String ())
|
||||
doReplaceAll t rs = ask "replace_all" (ReqReplaceAll t rs) okOnly
|
||||
doReplaceAll :: Env -> String -> [Row] -> IO (Either String ())
|
||||
doReplaceAll env t rs = ask env "replace_all" (ReqReplaceAll t rs) okOnly
|
||||
|
||||
-- | 发 ListTables
|
||||
doListTables :: IO (Either String [String])
|
||||
doListTables = ask "list_tables" ReqListTables $ \resp -> case resp of
|
||||
doListTables :: Env -> IO (Either String [String])
|
||||
doListTables env = ask env "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
|
||||
doListCatalog :: Env -> IO (Either String [TableInfo])
|
||||
doListCatalog env = ask env "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
|
||||
doLookupByColumn :: Env -> String -> String -> Value -> IO (Either String IndexResult)
|
||||
doLookupByColumn env t c k = ask env "lookup_by_index" (ReqLookupByColumn t c k) $ \resp -> case resp of
|
||||
RespRows rows -> Just (IndexRows rows)
|
||||
RespNoIndex -> Just NoIndex
|
||||
_ -> Nothing
|
||||
|
||||
-- | 范围扫描：没有可用索引就回 Nothing，让上层退回扫描
|
||||
doScanRange ::
|
||||
Env ->
|
||||
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
|
||||
doScanRange env t c lo hi = ask env "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
|
||||
doDescribeTable :: Env -> String -> IO (Either String TableInfo)
|
||||
doDescribeTable env t = ask env "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
|
||||
doCreateIndex :: Env -> String -> String -> IO (Either String ())
|
||||
doCreateIndex env t c = ask env "create_index" (ReqCreateIndex t c) okOnly
|
||||
|
||||
-- | 去掉某一列的索引
|
||||
doDropIndex :: String -> String -> IO (Either String ())
|
||||
doDropIndex t c = ask "drop_index" (ReqDropIndex t c) okOnly
|
||||
doDropIndex :: Env -> String -> String -> IO (Either String ())
|
||||
doDropIndex env t c = ask env "drop_index" (ReqDropIndex t c) okOnly
|
||||
|
||||
-- | 删一列（列定义、这一列上的索引、每行里的那一格一起没）
|
||||
doDropColumn :: String -> String -> IO (Either String ())
|
||||
doDropColumn t c = ask "drop_column" (ReqDropColumn t c) okOnly
|
||||
doDropColumn :: Env -> String -> String -> IO (Either String ())
|
||||
doDropColumn env t c = ask env "drop_column" (ReqDropColumn t c) okOnly
|
||||
|
||||
-- | 发 ReplaceSchema（ALTER 用）
|
||||
doReplaceSchema :: String -> [SchemaColumn] -> [Row] -> IO (Either String ())
|
||||
doReplaceSchema t cols rs = ask "replace_schema" (ReqReplaceSchema t cols rs) okOnly
|
||||
doReplaceSchema :: Env -> String -> [SchemaColumn] -> [Row] -> IO (Either String ())
|
||||
doReplaceSchema env t cols rs = ask env "replace_schema" (ReqReplaceSchema t cols rs) okOnly
|
||||
|
||||
-- | 发 CreateTable
|
||||
doCreateTable :: String -> [SchemaColumn] -> IO (Either String ())
|
||||
doCreateTable t cols = ask "create_table" (ReqCreateTable t cols) okOnly
|
||||
doCreateTable :: Env -> String -> [SchemaColumn] -> IO (Either String ())
|
||||
doCreateTable env t cols = ask env "create_table" (ReqCreateTable t cols) okOnly
|
||||
|
||||
-- | 发 DropTable
|
||||
doDropTable :: String -> IO (Either String ())
|
||||
doDropTable t = ask "drop_table" (ReqDropTable t) okOnly
|
||||
doDropTable :: Env -> String -> IO (Either String ())
|
||||
doDropTable env t = ask env "drop_table" (ReqDropTable t) okOnly
|
||||
|
||||
-- | 线上 schema 转本地列
|
||||
schemaToColumns :: [SchemaColumn] -> [(String, Column)]
|
||||
@@ -292,92 +313,91 @@ toWire (n, c) =
|
||||
|
||||
instance MonadStorage IPCStorage where
|
||||
-- \| 建一个库
|
||||
createDatabase name = IPCStorage (ask "create_database" (ReqDatabase "create_database" name) okOnly)
|
||||
createDatabase name = IPCStorage $ \env -> ask env "create_database" (ReqDatabase "create_database" name) okOnly
|
||||
-- \| 删一个库
|
||||
dropDatabase name = IPCStorage (ask "drop_database" (ReqDatabase "drop_database" name) okOnly)
|
||||
dropDatabase name = IPCStorage $ \env -> ask env "drop_database" (ReqDatabase "drop_database" name) okOnly
|
||||
-- \| 切当前库
|
||||
useDatabase name = IPCStorage (ask "use_database" (ReqDatabase "use_database" name) okOnly)
|
||||
useDatabase name = IPCStorage $ \env -> ask env "use_database" (ReqDatabase "use_database" name) okOnly
|
||||
-- \| 列出现有库
|
||||
listDatabases = IPCStorage $ ask "list_databases" (ReqDatabase "list_databases" "") $ \resp -> case resp of
|
||||
listDatabases = IPCStorage $ \env -> ask env "list_databases" (ReqDatabase "list_databases" "") $ \resp -> case resp of
|
||||
RespTables names -> Just names
|
||||
_ -> Nothing
|
||||
-- \| 发 Scan
|
||||
scan t = IPCStorage (doScan t)
|
||||
scan t = IPCStorage (\env -> doScan env t)
|
||||
-- \| 只取指定列
|
||||
scanColumns t cols = IPCStorage (doScanColumns t cols)
|
||||
scanColumns t cols = IPCStorage (\env -> doScanColumns env t cols)
|
||||
|
||||
-- \| 并行分片数：按 RTS 能力数，封顶在 parallelShardLimit
|
||||
parallelShards = IPCStorage $ do
|
||||
parallelShards = IPCStorage $ \_ -> do
|
||||
caps <- getNumCapabilities
|
||||
pure (max 1 (min parallelShardLimit caps))
|
||||
|
||||
-- \| 分片并行扫，再按分片序拼接
|
||||
scanShards width t cols
|
||||
| width <= 1 = IPCStorage (maybe (doScan t) (doScanColumns t) cols)
|
||||
| otherwise = IPCStorage $ do
|
||||
| width <= 1 = IPCStorage (\env -> maybe (doScan env t) (doScanColumns env t) cols)
|
||||
| otherwise = IPCStorage $ \env -> do
|
||||
pool <- workerPool width
|
||||
parts <- poolRun pool [doScanShard t cols shard width | shard <- [0 .. width - 1]]
|
||||
parts <- poolRun pool [doScanShard env t cols shard width | shard <- [0 .. width - 1]]
|
||||
pure (fmap concat (sequence parts))
|
||||
|
||||
-- \| 发 Insert（索引由存储层自己维护）
|
||||
insert t r = IPCStorage (doInsert t r)
|
||||
insert t r = IPCStorage (\env -> doInsert env t r)
|
||||
|
||||
-- \| 一批行一次请求：N 行只落一次盘
|
||||
insertMany t rs = IPCStorage (doInsertMany t rs)
|
||||
insertMany t rs = IPCStorage (\env -> doInsertMany env t rs)
|
||||
|
||||
-- \| 按 id 批量删行
|
||||
deleteKeys t ks = IPCStorage (doDeleteKeys t ks)
|
||||
deleteKeys t ks = IPCStorage (\env -> doDeleteKeys env t ks)
|
||||
|
||||
-- \| 发 ReplaceAll
|
||||
replaceAll t rs = IPCStorage (doReplaceAll t rs)
|
||||
replaceAll t rs = IPCStorage (\env -> doReplaceAll env t rs)
|
||||
|
||||
-- \| 按某一列的索引取一行（没有索引就回 NoIndex）
|
||||
lookupByColumn t c k = IPCStorage (doLookupByColumn t c k)
|
||||
lookupByColumn t c k = IPCStorage (\env -> doLookupByColumn env t c k)
|
||||
|
||||
-- \| 范围扫描（没有索引就回 Nothing）
|
||||
scanRange t c lo hi = IPCStorage (doScanRange t c lo hi)
|
||||
scanRange t c lo hi = IPCStorage (\env -> doScanRange env t c lo hi)
|
||||
|
||||
-- \| 发 CreateTable
|
||||
createTable name cols = IPCStorage (doCreateTable name (map toWire cols))
|
||||
createTable name cols = IPCStorage (\env -> doCreateTable env name (map toWire cols))
|
||||
|
||||
-- \| ALTER：整表换列定义与全部行
|
||||
replaceSchema name cols rows = IPCStorage (doReplaceSchema name (map toWire cols) rows)
|
||||
replaceSchema name cols rows = IPCStorage (\env -> doReplaceSchema env name (map toWire cols) rows)
|
||||
|
||||
-- \| 发 DropTable
|
||||
dropTable name = IPCStorage (doDropTable name)
|
||||
dropTable name = IPCStorage (\env -> doDropTable env name)
|
||||
|
||||
-- \| 建索引
|
||||
createIndex t c = IPCStorage (doCreateIndex t c)
|
||||
createIndex t c = IPCStorage (\env -> doCreateIndex env t c)
|
||||
|
||||
-- \| 删索引
|
||||
dropIndex t c = IPCStorage (doDropIndex t c)
|
||||
dropIndex t c = IPCStorage (\env -> doDropIndex env t c)
|
||||
|
||||
-- \| 删一列
|
||||
dropColumn t c = IPCStorage (doDropColumn t c)
|
||||
dropColumn t c = IPCStorage (\env -> doDropColumn env t c)
|
||||
|
||||
-- \| 列表 + 逐表扫描拼库
|
||||
snapshot = IPCStorage $ do
|
||||
result <- doListCatalog
|
||||
snapshot = IPCStorage $ \env -> do
|
||||
result <- doListCatalog env
|
||||
case result of
|
||||
Left _ -> pure []
|
||||
Right xs -> mapM loadEntry xs
|
||||
Right xs -> mapM (loadEntry env) xs
|
||||
where
|
||||
loadEntry info = do
|
||||
rows <- doScan (tiTable info)
|
||||
loadEntry env info = do
|
||||
rows <- doScan env (tiTable info)
|
||||
pure
|
||||
( tiTable info
|
||||
, Table (tiTable info) (schemaToColumns (tiColumns info)) (either (const []) id rows) (Just (metaOf info))
|
||||
)
|
||||
|
||||
-- \| 只问数据字典要结构，设了当前库只留它的表
|
||||
schema = IPCStorage $ do
|
||||
current <- getDatabaseName
|
||||
result <- ask "all_catalogs" ReqAllCatalog $ \resp -> case resp of
|
||||
schema = IPCStorage $ \env -> do
|
||||
result <- ask env "all_catalogs" ReqAllCatalog $ \resp -> case resp of
|
||||
RespCatalog infos -> Just infos
|
||||
_ -> Nothing
|
||||
pure $ case result of
|
||||
Left _ -> []
|
||||
Right xs -> concatMap (visibleTables current) xs
|
||||
Right xs -> concatMap (visibleTables (envDatabase env)) xs
|
||||
|
||||
-- | 线上表信息转引擎侧统计
|
||||
metaOf :: TableInfo -> TableMeta
|
||||
|
||||
@@ -53,6 +53,12 @@ data Statement
|
||||
| DropDatabase String
|
||||
| UseDatabase String
|
||||
| ShowDatabases
|
||||
-- | 开事务：BEGIN / START TRANSACTION
|
||||
| BeginTransaction
|
||||
-- | 提交事务
|
||||
| CommitTransaction
|
||||
-- | 回滚事务
|
||||
| RollbackTransaction
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 连接类型：内连接与左外连接
|
||||
|
||||
@@ -613,6 +613,14 @@ updateStatement = do
|
||||
mWhere <- optional (keyword "where" *> expr)
|
||||
return (Update tbl assigns mWhere)
|
||||
|
||||
-- | 事务控制语句
|
||||
transactionStatement :: Parser Statement
|
||||
transactionStatement =
|
||||
try (BeginTransaction <$ (keyword "start" *> keyword "transaction"))
|
||||
<|> (BeginTransaction <$ (keyword "begin" *> optional (keyword "transaction")))
|
||||
<|> (CommitTransaction <$ (keyword "commit" *> optional (keyword "transaction")))
|
||||
<|> (RollbackTransaction <$ (keyword "rollback" *> optional (keyword "transaction")))
|
||||
|
||||
-- | 解析总入口
|
||||
parseStatement :: String -> Either String Statement
|
||||
parseStatement input =
|
||||
@@ -622,7 +630,8 @@ parseStatement input =
|
||||
where
|
||||
-- | 按关键字分派到各语句解析器
|
||||
statementP =
|
||||
selectStatement
|
||||
transactionStatement
|
||||
<|> selectStatement
|
||||
<|> try (CreateDatabase <$> (keyword "create" *> keyword "database" *> identifier))
|
||||
<|> try (DropDatabase <$> (keyword "drop" *> keyword "database" *> identifier))
|
||||
<|> (UseDatabase <$> (keyword "use" *> identifier))
|
||||
|
||||
@@ -15,7 +15,7 @@ import ChuSQL.Core.Engine.Parallel (poolRun, workerPool)
|
||||
import ChuSQL.Core.Model
|
||||
import ChuSQL.Core.Engine.Semantic (prepare)
|
||||
import ChuSQL.Core.Engine.Storage (IndexResult (..), MonadStorage (..))
|
||||
import ChuSQL.Core.Engine.Storage.IPC (IPCStorage (runIPCStorage), closeConnection, doListTables, getDatabaseName, localStorageLink, setDatabaseName, setStorageLink)
|
||||
import ChuSQL.Core.Engine.Storage.IPC (IPCStorage (..), closeConnection, defaultEnv, doListTables, envForDatabase, getDatabaseName, localStorageLink, runIPCStorage, setDatabaseName, setStorageLink)
|
||||
import ChuSQL.Core.Engine.Syntax.AST
|
||||
import ChuSQL.Core.Engine.Syntax.Parser
|
||||
import Control.Concurrent (threadDelay)
|
||||
@@ -113,6 +113,40 @@ main = hspec $ do
|
||||
rowsOf (parseStatement "SELECT sales.users.name FROM sales.users WHERE sales.users.id = 1" >>= runStatement db)
|
||||
`shouldBe` Right [[("name", VStr "Alice")]]
|
||||
|
||||
it "derives the column prefix when the session schema is scoped to one database" $ do
|
||||
let scoped = [("users", users)]
|
||||
rowsOf (parseStatement "SELECT sales.users.name FROM sales.users WHERE sales.users.id = 1" >>= runStatement scoped)
|
||||
`shouldBe` Right [[("name", VStr "Alice")]]
|
||||
rowsOf (parseStatement "SELECT users.name FROM users WHERE users.id = 1" >>= runStatement scoped)
|
||||
`shouldBe` Right [[("name", VStr "Alice")]]
|
||||
|
||||
it "derives the database prefix for a bare table name" $ do
|
||||
let catalog = [("sales.users", users)]
|
||||
rowsOf (parseStatement "SELECT name FROM users WHERE users.id = 1" >>= runStatement catalog)
|
||||
`shouldBe` Right [[("name", VStr "Alice")]]
|
||||
rowsOf (parseStatement "SELECT users.name FROM sales.users WHERE users.id = 1" >>= runStatement catalog)
|
||||
`shouldBe` Right [[("name", VStr "Alice")]]
|
||||
|
||||
it "keeps derived prefixes short in joins" $ do
|
||||
let catalog = [("sales.users", users), ("sales.orders", orders)]
|
||||
fmap
|
||||
(map (map snd))
|
||||
(parseStatement "SELECT users.name, orders.product FROM sales.users JOIN sales.orders ON users.id = orders.user_id" >>= rowsOf . runStatement catalog)
|
||||
`shouldBe` Right [[VStr "Alice", VStr "Book"], [VStr "Alice", VStr "Cup"], [VStr "Bob", VStr "Pen"]]
|
||||
|
||||
it "writes through the derived table key" $ do
|
||||
let scoped = [("users", users)]
|
||||
case parseStatement "UPDATE sales.users SET age = 26 WHERE id = 1" >>= runStatement scoped of
|
||||
Left err -> expectationFailure err
|
||||
Right (db', _) ->
|
||||
rowsOf (runStatement db' (makeSelect ["age"] "users" (Just (Eq (Col "id") (LitInt 1)))))
|
||||
`shouldBe` Right [[("age", VInt 26)]]
|
||||
|
||||
it "rejects an ambiguous derived table name" $ do
|
||||
let catalog = [("sales.users", users), ("other.users", users)]
|
||||
(parseStatement "SELECT name FROM users" >>= rowsOf . runStatement catalog)
|
||||
`shouldSatisfy` either (isInfixOf "ambiguous table") (const False)
|
||||
|
||||
it "parses database lifecycle statements" $ do
|
||||
map (fmap show . parseStatement) ["CREATE DATABASE sales", "DROP DATABASE sales", "USE sales", "SHOW DATABASES"]
|
||||
`shouldBe` map Right ["CreateDatabase \"sales\"", "DropDatabase \"sales\"", "UseDatabase \"sales\"", "ShowDatabases"]
|
||||
@@ -242,6 +276,33 @@ main = hspec $ do
|
||||
parseStatement "SELECT name FROM"
|
||||
`shouldSatisfy` isLeft
|
||||
|
||||
describe "ChuSQL.Core.Engine (事务)" $ do
|
||||
it "parses transaction control statements" $ do
|
||||
parseStatement "BEGIN" `shouldBe` Right BeginTransaction
|
||||
parseStatement "BEGIN TRANSACTION" `shouldBe` Right BeginTransaction
|
||||
parseStatement "START TRANSACTION" `shouldBe` Right BeginTransaction
|
||||
parseStatement "begin transaction" `shouldBe` Right BeginTransaction
|
||||
parseStatement "COMMIT" `shouldBe` Right CommitTransaction
|
||||
parseStatement "COMMIT TRANSACTION" `shouldBe` Right CommitTransaction
|
||||
parseStatement "ROLLBACK" `shouldBe` Right RollbackTransaction
|
||||
parseStatement "rollback transaction" `shouldBe` Right RollbackTransaction
|
||||
|
||||
it "parses the bare words only as whole words" $ do
|
||||
parseStatement "BEGINNER" `shouldSatisfy` isLeft
|
||||
parseStatement "COMMITTED" `shouldSatisfy` isLeft
|
||||
|
||||
it "reports transaction control as session work" $ do
|
||||
mapM_
|
||||
( \sql ->
|
||||
(runStatement [("users", users)] =<< parseStatement sql)
|
||||
`shouldSatisfy` either (isInfixOf "executed by the session") (const False)
|
||||
)
|
||||
["BEGIN", "COMMIT", "ROLLBACK"]
|
||||
|
||||
it "puts transaction errors under the protocol category" $ do
|
||||
errorCode "BEGIN is executed by the session" `shouldBe` "query_error"
|
||||
errorCategory "BEGIN is executed by the session" `shouldBe` ProtocolError
|
||||
|
||||
describe "ChuSQL.Core.Engine.Syntax.Parser (JOIN)" $ do
|
||||
it "parses a simple JOIN without aliases" $ do
|
||||
parseStatement "SELECT name FROM users JOIN orders ON id = user_id"
|
||||
@@ -1613,7 +1674,19 @@ main = hspec $ do
|
||||
withTestSession $ \srv -> withServerEnv srv $ do
|
||||
runIPCStorage (insert "t1" [("id", VInt 1)]) `shouldReturn` Right ()
|
||||
runIPCStorage (insert "t2" [("id", VInt 2)]) `shouldReturn` Right ()
|
||||
doListTables `shouldReturn` Right ["t1", "t2"]
|
||||
env <- defaultEnv
|
||||
doListTables env `shouldReturn` Right ["t1", "t2"]
|
||||
|
||||
it "two sessions keep their own database" $ do
|
||||
withTestSession $ \_ -> do
|
||||
let alpha = envForDatabase (Just "alpha")
|
||||
beta = envForDatabase (Just "beta")
|
||||
runIPCStorageIn (createDatabase "alpha") alpha `shouldReturn` Right ()
|
||||
runIPCStorageIn (createDatabase "beta") beta `shouldReturn` Right ()
|
||||
runIPCStorageIn (insert "iso" [("id", VInt 1)]) alpha `shouldReturn` Right ()
|
||||
runIPCStorageIn (insert "iso" [("id", VInt 2)]) beta `shouldReturn` Right ()
|
||||
runIPCStorageIn (scan "iso") alpha `shouldReturn` Right [[("id", VInt 1)]]
|
||||
runIPCStorageIn (scan "iso") beta `shouldReturn` Right [[("id", VInt 2)]]
|
||||
|
||||
it "rows survive a restart on the same data directory" $ do
|
||||
withTestSession $ \srv -> do
|
||||
|
||||
Reference in new issue
Block a user