事务模型

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

chusql-server/test/Spec.hs

@@ -3,14 +3,20 @@
 
 module Main (main) where
 
-import ChuSQL.Core.Engine.Storage.IPC (Account (..), Request (ReqAccountReset))
+import ChuSQL.Core.Engine.Storage.IPC (
+    Account (..),
+    Request (ReqAccountReset),
+    closeConnection,
+    localStorageLink,
+    setStorageLink,
+ )
 import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
-import ChuSQL.Core.Model (Database, Table (..), Value (..), pattern TInt, pattern TStr)
+import ChuSQL.Core.Model (Database, Row, Table (..), Value (..), pattern TInt, pattern TStr)
 import ChuSQL.Interface.Auth (hashPasswordWith)
 import ChuSQL.Interface.Protocol (ClientRequest (..), Grant (..), RoleView (..), ServerResponse (..), decodeRequest, encodeResponse)
 import ChuSQL.Interface.RateLimit (newRateLimiter)
 import ChuSQL.Server.Accounts (Principal (..), ensureRootAccount)
-import ChuSQL.Server.Backend (Backend (..), memoryBackend)
+import ChuSQL.Server.Backend (Backend (..), StatementResult (..), ipcBackend, memoryBackend)
 import ChuSQL.Server.Privileges (
     PrivilegeCommand (..),
     PrivilegeError (..),
@@ -20,7 +26,7 @@ import ChuSQL.Server.Privileges (
     newPrivileges,
     runPrivilegeCommand,
  )
-import ChuSQL.Server.Session (QueryResult (..))
+import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), newSession, runStatementCoded)
 import ChuSQL.Server.TCP (
     ServerConfig (..),
     ServerEnv,
@@ -30,8 +36,8 @@ import ChuSQL.Server.TCP (
     newServerEnv,
     startServer,
  )
-import Control.Concurrent (threadDelay)
-import Control.Concurrent.MVar (newMVar)
+import Control.Concurrent (forkIO, threadDelay)
+import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
 import Control.Exception (IOException, bracket, finally, try)
 import Control.Monad (void)
 import Data.Aeson (decode)
@@ -59,7 +65,7 @@ import Network.Socket (
     socketToHandle,
     withSocketsDo,
  )
-import System.Directory (doesFileExist, getTemporaryDirectory, removeFile)
+import System.Directory (createDirectoryIfMissing, doesFileExist, getTemporaryDirectory, removeFile, removePathForcibly)
 import System.FilePath ((</>))
 import System.IO (
     BufferMode (LineBuffering),
@@ -87,6 +93,8 @@ spec = do
     tcpSpec
     tcpServerSpec
     privilegeSpec
+    transactionSpec
+    ipcConcurrencySpec
 
 -- 夹具：内存后端装在 MVar 里，跟 Web 测试同一套表
 
@@ -545,3 +553,238 @@ privilegeSpec = describe "server privileges" $ do
             Left err -> expectationFailure err
             Right stmt -> authorize service root testDatabase stmt `shouldReturn` Right ()
 
+-- 真存储夹具：一个用例一份数据目录，跑完关链路删干净
+
+-- | 本次用例的数据目录（用例串行跑，固定名够用）
+ipcDataDir :: IO FilePath
+ipcDataDir = do
+    tmp <- getTemporaryDirectory
+    pure (tmp </> "chusql-server-test-ipc")
+
+-- | 写一份只属于这次用例的存储配置：数据目录与日志级别都从文件走
+writeIpcConfig :: FilePath -> IO FilePath
+writeIpcConfig dir = do
+    let cfgPath = dir ++ ".toml"
+        -- TOML 的普通字符串会吃反斜杠，路径统一用正斜杠
+        slashed = map (\c -> if c == '\\' then '/' else c) dir
+    writeFile
+        cfgPath
+        ( unlines
+            [ "[storage]"
+            , "data_dir = \"" ++ slashed ++ "\""
+            , "[log]"
+            , "level = \"error\""
+            ]
+        )
+    pure cfgPath
+
+-- | 删掉这次用例的数据目录与配置，删不掉也不算错
+cleanIpc :: FilePath -> IO ()
+cleanIpc dir = do
+    _ <- try (removePathForcibly dir) :: IO (Either IOException ())
+    _ <- try (removePathForcibly (dir ++ ".toml")) :: IO (Either IOException ())
+    pure ()
+
+-- 事务用例：内存后端跑得快，真存储的提交再在 IPC 用例里验一遍
+
+-- | 起一个内存后端会话，当前库已切到 test
+withMemorySession :: (Session -> IO a) -> IO a
+withMemorySession body = do
+    db <- newMVar testDb
+    settings <- tempSettingsPath "transaction"
+    removeIfExists settings
+    session <- newSession (memoryBackend testDatabaseName db) (T.pack testDatabaseName) settings
+    _ <- runStatementCoded session "use test"
+    body session
+
+-- | 两个会话共用一份内存库，用来验会话隔离
+withTwoSessions :: (Session -> Session -> IO a) -> IO a
+withTwoSessions body = do
+    db <- newMVar testDb
+    settings <- tempSettingsPath "transaction-pair"
+    removeIfExists settings
+    let backend = memoryBackend testDatabaseName db
+    first <- newSession backend (T.pack testDatabaseName) settings
+    second <- newSession backend (T.pack testDatabaseName) settings
+    _ <- runStatementCoded first "use test"
+    _ <- runStatementCoded second "use test"
+    body first second
+
+-- | 跑一条语句；出错就算用例失败
+mustSql :: Session -> Text -> IO QueryResult
+mustSql session sql = runStatementCoded session sql >>= either failed pure
+  where
+    failed err = expectationFailure (T.unpack (sessMessage err)) >> pure (QueryResult [] [] 0 False Nothing)
+
+-- | 取 users 的 id 列
+sessionIds :: Session -> IO [Int]
+sessionIds session = do
+    result <- mustSql session "select * from users"
+    pure [n | row <- qrRows result, Just (VInt n) <- [nth 0 row]]
+
+-- | 取某个 id 的 age
+sessionAge :: Session -> Int -> IO (Maybe Int)
+sessionAge session wanted = do
+    result <- mustSql session "select * from users"
+    let ages = [(n, a) | row <- qrRows result, Just (VInt n) <- [nth 0 row], Just (VInt a) <- [nth 2 row]]
+    pure (lookup wanted ages)
+
+-- | 取失败里的文案
+failureMessage :: Either SessionError QueryResult -> Text
+failureMessage outcome = either sessMessage (const "") outcome
+
+-- | 取结果第一列的整数
+intValues :: [[Value]] -> [Int]
+intValues rows = [n | row <- rows, Just (VInt n) <- [nth 0 row]]
+
+-- | 显式事务用例
+transactionSpec :: Spec
+transactionSpec = describe "server transactions" $ do
+    it "keeps uncommitted rows invisible to other sessions until COMMIT" $ withTwoSessions $ \writer reader -> do
+        _ <- mustSql writer "begin"
+        _ <- mustSql writer "insert into users (id, name, age) values (6, 'six', 26)"
+        sessionIds writer `shouldReturn` [1, 2, 3, 4, 5, 6]
+        sessionIds reader `shouldReturn` [1, 2, 3, 4, 5]
+        _ <- mustSql writer "commit"
+        ids <- sessionIds writer
+        ids `shouldMatchList` [1, 2, 3, 4, 5, 6]
+        seen <- sessionIds reader
+        seen `shouldMatchList` [1, 2, 3, 4, 5, 6]
+
+    it "drops every change on ROLLBACK" $ withMemorySession $ \session -> do
+        _ <- mustSql session "begin"
+        _ <- mustSql session "insert into users (id, name, age) values (6, 'six', 26)"
+        _ <- mustSql session "update users set age = 99 where id = 1"
+        _ <- mustSql session "delete from users where id = 2"
+        rollback <- mustSql session "rollback"
+        qrRowCount rollback `shouldBe` 0
+        kept <- sessionIds session
+        kept `shouldMatchList` [1, 2, 3, 4, 5]
+
+    it "commits the whole write set at once" $ withMemorySession $ \session -> do
+        _ <- mustSql session "begin"
+        _ <- mustSql session "insert into users (id, name, age) values (6, 'six', 26)"
+        _ <- mustSql session "update users set age = 99 where id = 1"
+        _ <- mustSql session "delete from users where id = 2"
+        _ <- mustSql session "commit"
+        ids <- sessionIds session
+        ids `shouldMatchList` [1, 3, 4, 5, 6]
+        sessionAge session 1 `shouldReturn` Just 99
+
+    it "rejects DDL inside a transaction and takes it after ROLLBACK" $ withMemorySession $ \session -> do
+        _ <- mustSql session "begin"
+        denied <- runStatementCoded session "create table blocked (id int)"
+        failureMessage denied `shouldBe` "DDL is not allowed in a transaction"
+        _ <- mustSql session "rollback"
+        _ <- mustSql session "create table fresh (id int)"
+        _ <- mustSql session "insert into fresh (id) values (1)"
+        rows <- mustSql session "select * from fresh"
+        qrRowCount rows `shouldBe` 1
+
+    it "refuses nested BEGIN and COMMIT outside a transaction" $ withMemorySession $ \session -> do
+        _ <- mustSql session "begin"
+        nested <- runStatementCoded session "begin"
+        failureMessage nested `shouldBe` "already in a transaction"
+        _ <- mustSql session "rollback"
+        late <- runStatementCoded session "commit"
+        failureMessage late `shouldBe` "no transaction in progress"
+
+    it "does not switch database inside a transaction" $ withMemorySession $ \session -> do
+        _ <- mustSql session "begin"
+        denied <- runStatementCoded session "use other"
+        failureMessage denied `shouldBe` "cannot switch database inside a transaction"
+
+    it "needs a current database to start" $ do
+        db <- newMVar testDb
+        settings <- tempSettingsPath "transaction-bare"
+        removeIfExists settings
+        session <- newSession (memoryBackend testDatabaseName db) (T.pack testDatabaseName) settings
+        result <- runStatementCoded session "begin"
+        failureMessage result `shouldBe` "no database selected"
+
+-- | 起一份真存储并装成当前链路；动态库打不开就当用例待定
+withIpcStorage :: IO () -> IO ()
+withIpcStorage body = do
+    dir <- ipcDataDir
+    cleanIpc dir
+    createDirectoryIfMissing True dir
+    cfgPath <- writeIpcConfig dir
+    opened <- localStorageLink (Just cfgPath)
+    case opened of
+        Left err -> cleanIpc dir >> pendingWith ("cannot open the storage library: " ++ err)
+        Right link -> do
+            setStorageLink link
+            body `finally` (closeConnection >> cleanIpc dir)
+
+-- | 跑一条语句，出错就算用例失败
+mustRun :: IO (Either String StatementResult) -> IO ()
+mustRun action = action >>= either expectationFailure (const (pure ()))
+
+-- | 取结果行，出错就算用例失败
+rowsOf :: IO (Either String StatementResult) -> IO [Row]
+rowsOf action = action >>= either (\err -> expectationFailure err >> pure []) (pure . srRows)
+
+-- | 取结果里某一列的整数
+intColumn :: String -> [Row] -> [Int]
+intColumn name rows = [n | row <- rows, Just (VInt n) <- [lookup name row]]
+
+-- | 往 p 表连插一批行，结果放 MVar 交回主线程
+writeRows :: Backend -> [Int] -> MVar [Either String StatementResult] -> IO ()
+writeRows session ids done = do
+    outs <- mapM (\i -> beStatement session ("INSERT INTO p (id) VALUES (" ++ show i ++ ")")) ids
+    putMVar done outs
+
+-- | 同一进程里开两个库：会话之间不串数据，也不互相挡路
+ipcConcurrencySpec :: Spec
+ipcConcurrencySpec = describe "server backend on the real storage" $ do
+    it "keeps two databases apart" $ withIpcStorage $ do
+        base <- ipcBackend
+        mustRun (beStatement base "CREATE DATABASE alpha")
+        mustRun (beStatement base "CREATE DATABASE beta")
+        let alpha = beWithDatabase base "alpha"
+            beta = beWithDatabase base "beta"
+        mustRun (beStatement alpha "CREATE TABLE t (id int)")
+        mustRun (beStatement beta "CREATE TABLE t (id int)")
+        mustRun (beStatement alpha "INSERT INTO t (id) VALUES (1)")
+        mustRun (beStatement beta "INSERT INTO t (id) VALUES (2)")
+        rowsA <- rowsOf (beStatement alpha "SELECT id FROM t")
+        rowsB <- rowsOf (beStatement beta "SELECT id FROM t")
+        intColumn "id" rowsA `shouldBe` [1]
+        intColumn "id" rowsB `shouldBe` [2]
+
+    it "runs two sessions at once without mixing their rows" $ withIpcStorage $ do
+        base <- ipcBackend
+        mustRun (beStatement base "CREATE DATABASE alpha")
+        mustRun (beStatement base "CREATE DATABASE beta")
+        let alpha = beWithDatabase base "alpha"
+            beta = beWithDatabase base "beta"
+        mustRun (beStatement alpha "CREATE TABLE p (id int)")
+        mustRun (beStatement beta "CREATE TABLE p (id int)")
+        doneA <- newEmptyMVar
+        doneB <- newEmptyMVar
+        _ <- forkIO (writeRows alpha [1 .. 20] doneA)
+        _ <- forkIO (writeRows beta [101 .. 120] doneB)
+        outs <- sequence [takeMVar doneA, takeMVar doneB]
+        [err | Left err <- concat outs] `shouldBe` []
+        rowsA <- rowsOf (beStatement alpha "SELECT id FROM p")
+        rowsB <- rowsOf (beStatement beta "SELECT id FROM p")
+        intColumn "id" rowsA `shouldMatchList` [1 .. 20]
+        intColumn "id" rowsB `shouldMatchList` [101 .. 120]
+
+    it "commits an explicit transaction to the real storage" $ withIpcStorage $ do
+        base <- ipcBackend
+        mustRun (beStatement base "CREATE DATABASE alpha")
+        let alpha = beWithDatabase base "alpha"
+        settings <- tempSettingsPath "transaction-ipc"
+        removeIfExists settings
+        session <- newSession alpha (T.pack testDatabaseName) settings
+        _ <- mustSql session "use alpha"
+        _ <- mustSql session "create table t (id int)"
+        _ <- mustSql session "begin"
+        _ <- mustSql session "insert into t (id) values (1)"
+        inside <- mustSql session "select * from t"
+        intValues (qrRows inside) `shouldBe` [1]
+        _ <- mustSql session "commit"
+        rows <- rowsOf (beStatement alpha "SELECT id FROM t")
+        intColumn "id" rows `shouldBe` [1]
+