事务模型

chusql-server/src/ChuSQL/Server/Backend.hs

@@ -6,7 +6,6 @@ module ChuSQL.Server.Backend (
     columnsFromStatement,
     currentStamp,
     exprTables,
-    inDatabase,
     internalTable,
     grantsTable,
     ipcBackend,
@@ -23,20 +22,23 @@ module ChuSQL.Server.Backend (
 import ChuSQL.Core.Engine (runStatement, runStatementM)
 import ChuSQL.Core.Model
 import ChuSQL.Core.Engine.Semantic (prepare)
-import ChuSQL.Core.Engine.Storage (MonadStorage (schema))
+import ChuSQL.Core.Engine.Storage (MonadStorage (schema, snapshot))
 import ChuSQL.Core.Engine.Storage.IPC (
     Account (..),
+    Env,
     IPCStorage (..),
     Request (..),
     Response (..),
     SchemaColumn (..),
     TableInfo (..),
+    envForDatabase,
     sendRawRequest,
     sendRequest,
  )
 import ChuSQL.Core.Engine.Syntax.AST
 import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
-import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, readMVar, withMVar)
+import ChuSQL.Core.Protocol (TxnOp (..))
+import Control.Concurrent.MVar (MVar, modifyMVar, readMVar)
 import Data.List (nub)
 import Data.Text (Text)
 import Data.Time (getCurrentTime)
@@ -61,6 +63,10 @@ data Backend = Backend
     , beDatabases :: IO (Either String [String])
     -- | 原样转发一条存储请求
     , beStorage :: A.Value -> IO (Either String A.Value)
+    -- | 取一份整库快照，当事务的起点
+    , beSnapshot :: IO (Either String Database)
+    -- | 事务提交：把一批写操作交给存储层应用
+    , beApplyTransaction :: [TxnOp] -> IO (Either String ())
     }
 
 -- | 按给定列名取列，固定列顺序
@@ -73,36 +79,46 @@ columnsFromStatement db stmt = case prepare db stmt of
 -- | 走本地存储链路的后端
 ipcBackend :: IO Backend
 ipcBackend = do
-    lock <- newMVar ()
     let backend current = Backend
-            { beStatement = \sql -> withMVar lock $ \_ -> runIpc current sql
-            , beCatalog = withMVar lock $ \_ -> do
+            { beStatement = \sql -> runIpc current sql
+            , beCatalog = do
                 response <- sendRequest (ReqInDatabase current ReqListCatalog)
                 pure $ case response of
                     RespCatalog infos -> Right infos
                     RespError err -> Left err
                     _ -> Left "unexpected catalog response"
-            , bePing = withMVar lock $ \_ -> do
+            , bePing = do
                 resp <- sendRequest ReqPing
                 pure (case resp of RespPong -> True; _ -> False)
-            , beAccounts = \req -> withMVar lock $ \_ -> do
+            , beAccounts = \req -> do
                 response <- sendRequest req
                 pure $ case response of
                     RespAccounts accounts -> Right accounts
                     RespError err -> Left err
                     _ -> Left "unexpected account response"
             , beWithDatabase = backend
-            , beDatabases = withMVar lock $ \_ -> do
+            , beDatabases = do
                 response <- sendRequest (ReqDatabase "list_databases" "")
                 pure $ case response of
                     RespTables names -> Right names
                     RespError err -> Left err
                     _ -> Left "unexpected database response"
-            , beStorage = \payload -> withMVar lock $ \_ -> runRaw payload
+            , beStorage = \payload -> runRaw payload
+            , beSnapshot = Right <$> runIPCStorageIn (snapshot :: IPCStorage Database) (sessionEnv current)
+            , beApplyTransaction = \ops -> do
+                response <- sendRequest (ReqInDatabase current (ReqApplyTransaction ops))
+                pure $ case response of
+                    RespOk -> Right ()
+                    RespError err -> Left err
+                    _ -> Left "unexpected transaction response"
             }
     -- 没有默认库：没选库时 current 是空串，任何请求都得先选库
     pure (backend "")
   where
+    -- | 会话的存储环境：库名跟这条连接走
+    sessionEnv :: String -> Env
+    sessionEnv current = envForDatabase (if null current then Nothing else Just current)
+
     -- | 转发一条存储请求并解析响应
     runRaw :: A.Value -> IO (Either String A.Value)
     runRaw payload = do
@@ -113,18 +129,21 @@ ipcBackend = do
                 Left err -> Left ("storage response is not valid JSON: " ++ err)
                 Right value -> Right value
 
-    -- | 走存储链路跑一条语句
+    -- | 走存储链路跑一条语句：表名不再补当前库前缀
+    -- 引擎侧的数据字典按当前库过滤之后键是裸表名，补前缀会让查表落空；
+    -- 库名由 database 字段随请求带走，存储层自己按它分发。
     runIpc :: String -> String -> IO (Either String StatementResult)
-    runIpc current sql = case fmap (inDatabase current) (parseStatement sql) of
+    runIpc current sql = case parseStatement sql of
         Left e -> pure (Left e)
         Right stmt -> do
-            result <- runIPCStorage (runStatementM stmt)
+            let env = sessionEnv current
+            result <- runIPCStorageIn (runStatementM stmt) env
             case result of
                 Left e -> pure (Left e)
                 Right rows -> do
                     cols <- case rows of
                         [] -> do
-                            db <- runIPCStorage (schema :: IPCStorage Database)
+                            db <- runIPCStorageIn (schema :: IPCStorage Database) env
                             pure (columnsFromStatement db stmt)
                         (r : _) -> pure (map fst r)
                     pure (Right (StatementResult cols rows))
@@ -162,6 +181,10 @@ memoryBackendWith trusted name ref =
         , beWithDatabase = withDatabase
         , beDatabases = pure (Right (nub [name, systemDatabaseName]))
         , beStorage = \_ -> pure (Left "storage is not available in this backend")
+        , beSnapshot = Right . scoped <$> readMVar ref
+        , beApplyTransaction = \ops -> modifyMVar ref $ \db -> case applyTransactionMemory ops db of
+            Left err -> pure (db, Left err)
+            Right db' -> pure (db', Right ())
         }
   where
     -- | 按视角过滤库里的表
@@ -185,6 +208,8 @@ unavailableDatabase :: String -> Backend -> Backend
 unavailableDatabase message backend = backend
     { beStatement = \_ -> pure (Left message)
     , beCatalog = pure (Left message)
+    , beSnapshot = pure (Left message)
+    , beApplyTransaction = \_ -> pure (Left message)
     }
 
 -- | 未选库时的视角：只放行不碰表的语句
@@ -196,76 +221,34 @@ noDatabaseBackend backend = backend
             | statementNeedsDatabase stmt -> pure (Left "no database selected")
             | otherwise -> beStatement backend sql
     , beCatalog = pure (Left "no database selected")
+    , beSnapshot = pure (Left "no database selected")
+    , beApplyTransaction = \_ -> pure (Left "no database selected")
     }
 
--- | 给语句里的裸表名补上当前库前缀，子查询里的表名也一起改
-inDatabase :: String -> Statement -> Statement
-inDatabase current = walk
+-- | 把一批事务写操作应用到内存库：先按 id 删，再按追加写
+applyTransactionMemory :: [TxnOp] -> Database -> Either String Database
+applyTransactionMemory ops db = foldl step (Right db) ops
   where
-    -- | 递归改写语句里的表名
-    walk :: Statement -> Statement
-    walk stmt = case stmt of
-        q@Select{} ->
-            q
-                { selectFrom = source (selectFrom q)
-                , selectWhere = fmap expr (selectWhere q)
-                }
-        q@SelectExpr{} ->
-            q
-                { selectItems = [(label, expr e) | (label, e) <- selectItems q]
-                , selectFrom = source (selectFrom q)
-                , selectWhere = fmap expr (selectWhere q)
-                }
-        Insert t cols rows -> Insert (table t) cols (map (map expr) rows)
-        Delete t cond -> Delete (table t) (fmap expr cond)
-        Update t assigns cond -> Update (table t) [(c, expr e) | (c, e) <- assigns] (fmap expr cond)
-        CreateTable t cols -> CreateTable (table t) cols
-        DropTable t -> DropTable (table t)
-        CreateIndex t c -> CreateIndex (table t) c
-        DropIndex t c -> DropIndex (table t) c
-        DropColumn t c -> DropColumn (table t) c
-        AddColumn t def -> AddColumn (table t) def
-        RenameColumn t old new -> RenameColumn (table t) old new
-        AlterColumnType t c ty -> AlterColumnType (table t) c ty
-        AlterColumnDefault t c v -> AlterColumnDefault (table t) c v
-        AlterColumnNull t c b -> AlterColumnNull (table t) c b
-        other -> other
+    step acc op = do
+        current <- acc
+        case op of
+            TxnDelete name keys -> do
+                table <- lookupTable current name
+                pure (put (name, table {tableRows = [r | r <- tableRows table, not (doomed keys r)]}) current)
+            TxnUpsert name rows -> do
+                table <- lookupTable current name
+                pure (put (name, table {tableRows = tableRows table ++ rows}) current)
+            TxnReplace name rows -> do
+                table <- lookupTable current name
+                pure (put (name, table {tableRows = rows}) current)
 
-    -- | 给单个表名补库前缀，已限定或没选库就原样
-    table t | '.' `elem` t || null current = t
-            | otherwise = current ++ "." ++ t
+    -- | 换掉一张表，其余保持原顺序
+    put entry = map (\one@(name, _) -> if name == fst entry then entry else one)
 
-    -- | 改写 FROM 子句
-    source FromUnit = FromUnit
-    source (FromTable a t) = FromTable a (table t)
-    source (FromJoin k l a t e) = FromJoin k (source l) a (table t) (expr e)
-
-    -- | 改写表达式里的子查询
-    expr (ScalarSub sq) = ScalarSub (sub sq)
-    expr (ExistsSub sq neg) = ExistsSub (sub sq) neg
-    expr (InSub a sq neg) = InSub (expr a) (sub sq) neg
-    expr (InList a items neg) = InList (expr a) (map expr items) neg
-    expr (Add a b) = Add (expr a) (expr b)
-    expr (Sub a b) = Sub (expr a) (expr b)
-    expr (Mul a b) = Mul (expr a) (expr b)
-    expr (Div a b) = Div (expr a) (expr b)
-    expr (Neg a) = Neg (expr a)
-    expr (Gt a b) = Gt (expr a) (expr b)
-    expr (Lt a b) = Lt (expr a) (expr b)
-    expr (Eq a b) = Eq (expr a) (expr b)
-    expr (And a b) = And (expr a) (expr b)
-    expr (Or a b) = Or (expr a) (expr b)
-    expr (IsNull a) = IsNull (expr a)
-    expr (IsNotNull a) = IsNotNull (expr a)
-    expr (CountOf a) = CountOf (expr a)
-    expr (SumOf a) = SumOf (expr a)
-    expr (AvgOf a) = AvgOf (expr a)
-    expr (MinOf a) = MinOf (expr a)
-    expr (MaxOf a) = MaxOf (expr a)
-    expr other = other
-
-    -- | 改写一个子查询
-    sub sq = sq {subqueryStatement = walk (subqueryStatement sq)}
+    -- | 这一行要不要删：按行里的 id 列比
+    doomed keys r = case lookup "id" r of
+        Just (VInt k) -> k `elem` keys
+        _ -> False
 
 -- | 语句里出现的表
 statementTables :: Statement -> [Text]

chusql-server/src/ChuSQL/Server/Session.hs

@@ -24,22 +24,24 @@ module ChuSQL.Server.Session
     , queryResultJson
     ) where
 
-import ChuSQL.Core.Model (Value (..))
-import ChuSQL.Core.Protocol (Account, QueryResult (..), queryResultJson)
+import ChuSQL.Core.Model (Database, Row, Table (..), Value (..))
+import ChuSQL.Core.Protocol (Account, QueryResult (..), TxnOp (..), queryResultJson)
 import ChuSQL.Core.Engine.Storage.IPC (TableInfo (..))
+import qualified ChuSQL.Core.Engine as Engine
 import qualified ChuSQL.Core.Engine.Error as E
 import ChuSQL.Core.Engine.Syntax.AST (Statement (..))
 import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
 import ChuSQL.Interface.AccountTable (systemTableInfo)
 import ChuSQL.Interface.Auth (defaultSessionPolicy, newSessionStore)
 import ChuSQL.Server.Accounts
-import ChuSQL.Server.Backend (Backend (..), StatementResult (..))
+import ChuSQL.Server.Backend (Backend (..), StatementResult (..), columnsFromStatement)
 import ChuSQL.Server.Policy (configurePasswordPolicy)
 import ChuSQL.Server.Privileges (PrivilegeCommand, PrivilegeError (..), Privileges, RoleView, authorize, filterTables, listRoleViews, newPrivileges, privilegeCommand, runPrivilegeCommand)
 import Control.Exception (IOException, try)
 import Data.Bifunctor (first)
 import Data.Char (isAlpha, isAlphaNum)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Data.Maybe (isJust)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
@@ -64,6 +66,13 @@ data Session = Session
     , ssCurrent :: IORef Text
     , ssPrincipal :: IORef (Maybe Principal)
     , ssSettingsFile :: FilePath
+    , ssTransaction :: IORef (Maybe Transaction)
+    }
+
+-- | 一条会话里的显式事务：开事务时的快照与事务内改到的状态
+data Transaction = Transaction
+    { txBase :: Database
+    , txStaged :: Database
     }
 
 -- | 开一个会话：账号与角色服务、配置策略都和 Web 端一致
@@ -76,7 +85,8 @@ newSession backend name settingsFile = do
     -- 服务启动后只有系统库：没 USE 之前不预设任何工作库
     current <- newIORef ""
     principal <- newIORef Nothing
-    pure (Session backend accountsService privileges current principal settingsFile)
+    transaction <- newIORef Nothing
+    pure (Session backend accountsService privileges current principal settingsFile transaction)
 
 -- | 当前生效的口令策略（只有管理员能看）
 policyOf :: Session -> IO (Either Text PasswordPolicy)
@@ -168,22 +178,183 @@ runStatement session sql = fmap (first sessMessage) (runStatementCoded session s
 runStatementCoded :: Session -> Text -> IO (Either SessionError QueryResult)
 runStatementCoded session sql = case parseStatement (T.unpack sql) of
     Right (UseDatabase name) -> do
-        switched <- switchDatabaseCoded session (T.pack name)
-        case switched of
-            Left err -> pure (Left err)
-            Right () -> do
-                current <- readIORef (ssCurrent session)
-                pure (Right (emptyResult (Just current)))
+        existing <- readIORef (ssTransaction session)
+        case existing of
+            Just _ -> pure (Left (SessionError "query_error" "cannot switch database inside a transaction"))
+            Nothing -> do
+                switched <- switchDatabaseCoded session (T.pack name)
+                case switched of
+                    Left err -> pure (Left err)
+                    Right () -> do
+                        current <- readIORef (ssCurrent session)
+                        pure (Right (emptyResult (Just current)))
+    Right BeginTransaction -> beginTransaction session
+    Right CommitTransaction -> commitTransaction session
+    Right RollbackTransaction -> rollbackTransaction session
     Right statement
         | Just command <- accountCommand statement -> runAccount session command
         | Just command <- privilegeCommand statement -> runPrivilege session command
         | otherwise -> do
-            allowed <- authorized session statement
-            case allowed of
-                Left err -> pure (Left err)
-                Right () -> runPlain session sql
+            transaction <- readIORef (ssTransaction session)
+            if isJust transaction && transactionDdl statement
+                then pure (Left (SessionError "query_error" "DDL is not allowed in a transaction"))
+                else do
+                    allowed <- authorized session statement
+                    case allowed of
+                        Left err -> pure (Left err)
+                        Right ()
+                            | isJust transaction && transactionData statement -> runInTransaction session statement
+                            | otherwise -> runPlain session sql
     Left _ -> runPlain session sql
 
+-- | 事务里不许改结构，会话层直接拦下
+transactionDdl :: Statement -> Bool
+transactionDdl statement = case statement of
+    CreateTable{} -> True
+    DropTable{} -> True
+    CreateIndex{} -> True
+    DropIndex{} -> True
+    DropColumn{} -> True
+    AddColumn{} -> True
+    RenameColumn{} -> True
+    AlterColumnType{} -> True
+    AlterColumnDefault{} -> True
+    AlterColumnNull{} -> True
+    CreateDatabase{} -> True
+    DropDatabase{} -> True
+    _ -> False
+
+-- | 事务里只有数据语句走快照
+transactionData :: Statement -> Bool
+transactionData statement = case statement of
+    Select{} -> True
+    SelectExpr{} -> True
+    Insert{} -> True
+    Update{} -> True
+    Delete{} -> True
+    _ -> False
+
+-- | 开事务：把当前库整库做一份快照当起点
+beginTransaction :: Session -> IO (Either SessionError QueryResult)
+beginTransaction session = do
+    current <- readIORef (ssCurrent session)
+    existing <- readIORef (ssTransaction session)
+    case existing of
+        Just _ -> pure (Left (SessionError "query_error" "already in a transaction"))
+        Nothing
+            | T.null current -> pure (Left (SessionError "no_database" "no database selected"))
+            | otherwise -> do
+                backend <- currentBackend session
+                snapshotResult <- beSnapshot backend
+                case snapshotResult of
+                    Left err -> pure (Left (engineErrorCode err))
+                    Right db -> do
+                        writeIORef (ssTransaction session) (Just (Transaction db db))
+                        pure (Right (emptyResult (Just current)))
+
+-- | 提交：把快照差分交给存储层应用，成功才结束事务
+commitTransaction :: Session -> IO (Either SessionError QueryResult)
+commitTransaction session = do
+    current <- readIORef (ssCurrent session)
+    existing <- readIORef (ssTransaction session)
+    case existing of
+        Nothing -> pure (Left (SessionError "query_error" "no transaction in progress"))
+        Just transaction -> do
+            backend <- currentBackend session
+            liveResult <- beSnapshot backend
+            case liveResult of
+                Left err -> pure (Left (engineErrorCode err))
+                Right live -> do
+                    applied <- beApplyTransaction backend (transactionOps (txBase transaction) (txStaged transaction) live)
+                    case applied of
+                        Left err -> pure (Left (engineErrorCode err))
+                        Right () -> do
+                            writeIORef (ssTransaction session) Nothing
+                            pure (Right (emptyResult (Just current)))
+
+-- | 回滚：快照丢掉，存储层没被改过
+rollbackTransaction :: Session -> IO (Either SessionError QueryResult)
+rollbackTransaction session = do
+    current <- readIORef (ssCurrent session)
+    existing <- readIORef (ssTransaction session)
+    case existing of
+        Nothing -> pure (Left (SessionError "query_error" "no transaction in progress"))
+        Just _ -> do
+            writeIORef (ssTransaction session) Nothing
+            pure (Right (emptyResult (Just current)))
+
+-- | 事务里跑一条数据语句：只动内存快照，不碰存储层
+runInTransaction :: Session -> Statement -> IO (Either SessionError QueryResult)
+runInTransaction session statement = do
+    existing <- readIORef (ssTransaction session)
+    case existing of
+        Nothing -> pure (Left (SessionError "query_error" "no transaction in progress"))
+        Just transaction -> case Engine.runStatement (txStaged transaction) statement of
+            Left err -> pure (Left (engineErrorCode err))
+            Right (staged, rows) -> do
+                writeIORef (ssTransaction session) (Just transaction {txStaged = staged})
+                pure (Right (resultOfStaged (txStaged transaction) statement rows))
+
+-- | 事务内的结果集：空结果回落到解析出来的列名
+resultOfStaged :: Database -> Statement -> [Row] -> QueryResult
+resultOfStaged db statement rows = resultOf (StatementResult cols rows)
+  where
+    cols = case rows of
+        [] -> columnsFromStatement db statement
+        (r : _) -> map fst r
+
+-- | 提交差分：相对快照列出要删、要写与要替换的行
+transactionOps :: Database -> Database -> Database -> [TxnOp]
+transactionOps base staged live =
+    concatMap opsFor names
+  where
+    -- | 事务里碰得着的表：数据语句不增删表
+    names = nubKeys (map fst base ++ map fst staged)
+
+    -- | 一张表的差分
+    opsFor name
+        | all (isJust . rowKey) (baseRows ++ stagedRows) = keyedOps
+        | stagedRows == baseRows = []
+        | otherwise = [TxnReplace name stagedRows]
+      where
+        baseRows = rowsOf name base
+        stagedRows = rowsOf name staged
+        liveRows = rowsOf name live
+
+        liveByKey = [(k, r) | r <- liveRows, Just k <- [rowKey r]]
+        stagedByKey = [(k, r) | r <- stagedRows, Just k <- [rowKey r]]
+        baseKeys = [k | r <- baseRows, Just k <- [rowKey r]]
+
+        -- 开事务时就存在、现在没了：删；内容变了的行也先删再写
+        gone = [k | (k, _) <- liveByKey, k `elem` baseKeys, not (any ((== k) . fst) stagedByKey)]
+        rewritten = [k | (k, r) <- stagedByKey, Just liveRow <- [lookup k liveByKey], liveRow /= r]
+        deleted = gone ++ rewritten
+
+        -- 新增的行，以及跟库里不一样的行；并发插进来的行不动
+        written =
+            [ r
+            | (k, r) <- stagedByKey
+            , case lookup k liveByKey of
+                Nothing -> True
+                Just liveRow -> liveRow /= r
+            ]
+
+        keyedOps =
+            [TxnDelete name deleted | not (null deleted)]
+                ++ [TxnUpsert name written | not (null written)]
+
+    -- | 表名去重但保持顺序
+    nubKeys = foldr (\name acc -> if name `elem` acc then acc else name : acc) []
+
+    -- | 库里某张表的行
+    rowsOf name db = maybe [] tableRows (lookup name db)
+
+-- | 行 id：只有整数 id 才认，跟存储层删行的口径一致
+rowKey :: Row -> Maybe Int
+rowKey row = case lookup "id" row of
+    Just (VInt k) -> Just k
+    _ -> Nothing
+
 -- | 普通身份跑语句前的权限判定；管理员与未登录放行
 authorized :: Session -> Statement -> IO (Either SessionError ())
 authorized session statement = do