v26.10.2 修复bug，简化项目

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

@@ -108,7 +108,7 @@ ipcBackend = do
                     RespError err -> Left err
                     _ -> Left "unexpected database response"
             , beStorage = \payload -> runRaw payload
-            , beSnapshot = Right <$> runIPCStorageIn (snapshot :: IPCStorage Database) (sessionEnv current)
+            , beSnapshot = runIPCStorageIn snapshot (sessionEnv current)
             , beApplyTransaction = \ops -> do
                 response <- sendRequest (ReqInDatabase current (ReqApplyTransaction ops))
                 pure $ case response of
@@ -148,10 +148,10 @@ ipcBackend = do
                 Right rows -> do
                     cols <- case rows of
                         [] -> do
-                            db <- runIPCStorageIn (schema :: IPCStorage Database) env
-                            pure (columnsFromStatement db stmt)
-                        (r : _) -> pure (map fst r)
-                    pure (Right (StatementResult cols rows))
+                            db <- runIPCStorageIn schema env
+                            pure (fmap (\structures -> columnsFromStatement structures stmt) db)
+                        (r : _) -> pure (Right (map fst r))
+                    pure (fmap (\names -> StatementResult names rows) cols)
 
 -- | 测试用内存后端，状态是一个 Database
 memoryBackend :: String -> MVar Database -> Backend

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

@@ -59,8 +59,8 @@ import Network.Socket (
     socket,
     socketToHandle,
   )
-import System.IO (BufferMode (LineBuffering), IOMode (ReadWriteMode), hClose, hFlush, hPutStrLn, hSetBuffering, hSetNewlineMode, noNewlineTranslation, stderr)
-import System.IO.Error (isEOFError)
+import System.IO (BufferMode (LineBuffering), Handle, IOMode (ReadWriteMode), hClose, hFlush, hPutStrLn, hSetBuffering, hSetNewlineMode, noNewlineTranslation, stderr)
+import System.IO.Error (eofErrorType, isEOFError, mkIOError)
 
 -- TCP 服务器：监听端口，一连接一会话，按一行一 JSON 收发协议消息。
 
@@ -255,20 +255,19 @@ serveConnection env conn = do
     entry <- newLiveEntry (isLocalPeer peer)
     unregister <- registerConnection (srvLive env) entry
     session <- newSessionWith (srvBackend env) (srvRootName env) (srvSettingsFile env) (\names -> void (dropConnectionsOf (srvLive env) names))
-    outcome <- try (loop h session entry `finally` unregister) :: IO (Either IOException ())
+    outcome <- try (loop h session entry BSC.empty `finally` unregister) :: IO (Either IOException ())
     case outcome of
         Left err | not (isEOFError err) -> hPutStrLn stderr ("connection error: " ++ show err)
         _ -> pure ()
     void (try (hClose h) :: IO (Either IOException ()))
   where
     -- | 逐行读请求并应答
-    loop h session entry = do
-        line <- BSC.hGetLine h
-        let cleaned = BSC.dropWhileEnd (== '\r') line
-        if BSC.length cleaned > scMaxMessage (srvConfig env)
-            then send h (RespError "too_large" "request line too large") >> loop h session entry
-            else case decodeRequest cleaned of
-                Left message -> send h (RespError "bad_request" message) >> loop h session entry
+    loop h session entry pending = do
+        frame <- readRequestLine h (scMaxMessage (srvConfig env)) pending
+        case frame of
+            Nothing -> send h (RespError "too_large" "request line too large")
+            Just (cleaned, remaining) -> case decodeRequest cleaned of
+                Left message -> send h (RespError "bad_request" message) >> loop h session entry remaining
                 Right request -> do
                     expired <- readIORef (leDropped entry)
                     if expired
@@ -276,13 +275,36 @@ serveConnection env conn = do
                         else do
                             (response, keepGoing) <- dispatch env session entry request
                             send h response
-                            if keepGoing then loop h session entry else pure ()
+                            if keepGoing then loop h session entry remaining else pure ()
     -- | 发一条响应并冲缓冲
     send h response = do
         BLC.hPutStr h (encodeResponse response)
         BLC.hPutStr h "\n"
         hFlush h
 
+-- | 限长读取一行并保留后续帧
+readRequestLine :: Handle -> Int -> BSC.ByteString -> IO (Maybe (BSC.ByteString, BSC.ByteString))
+readRequestLine handle limit = collect [] 0
+  where
+    -- | 按块读取至换行、超限或 EOF
+    collect parts total bytes = case BSC.elemIndex '\n' bytes of
+        Just offset -> finish (BSC.take offset bytes : parts) (BSC.drop (offset + 1) bytes)
+        Nothing
+            | used > limit && (used - limit > 1 || BSC.null bytes || BSC.last bytes /= '\r') -> pure Nothing
+            | otherwise -> do
+                next <- BSC.hGetSome handle (max 1 (min 4094 (limit - used) + 2))
+                if BSC.null next
+                    then if used == 0
+                        then ioError (mkIOError eofErrorType "read request" (Just handle) Nothing)
+                        else finish (bytes : parts) BSC.empty
+                    else collect (bytes : parts) used next
+          where
+            used = total + BSC.length bytes
+    -- | 合并并校验一行的有效长度
+    finish parts remaining = do
+        let line = BSC.dropWhileEnd (== '\r') (BSC.concat (reverse parts))
+        pure (if BSC.length line > limit then Nothing else Just (line, remaining))
+
 -- | 一条请求一条响应，quit 后停连接
 dispatch :: ServerEnv -> Session -> LiveEntry -> ClientRequest -> IO (ServerResponse, Bool)
 dispatch env session entry request = case request of

chusql-server/test/Spec.hs

@@ -51,7 +51,7 @@ import Control.Concurrent (forkIO, threadDelay)
 import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, takeMVar)
 import System.Timeout (timeout)
 import Control.Exception (IOException, bracket, finally, try)
-import Control.Monad (void)
+import Control.Monad (replicateM_, void)
 import Data.List (sort)
 import Data.Aeson (decode)
 import qualified Data.Aeson as A
@@ -729,6 +729,24 @@ tcpServerSpec = do
                 withConnection handle $ \h -> do
                     reply <- tcpTalk h (BSC.pack ("{\"method\":\"query\",\"sql\":\"" ++ replicate 40 'a' ++ "\"}"))
                     asText (at "code" reply) `shouldBe` "too_large"
+        it "refuses oversized input before a newline and closes the connection" $
+            withTcpServer defaultServerConfig{scMaxMessage = 32} $ \_ handle ->
+                withConnection handle $ \h -> do
+                    BSC.hPutStr h (BSC.replicate 33 'a')
+                    hFlush h
+                    line <- timeout 1000000 (BSC.hGetLine h)
+                    case line of
+                        Nothing -> expectationFailure "oversized input waited for a newline"
+                        Just raw -> asText (at "code" (fromMaybe A.Null (decode (BL.fromStrict raw)))) `shouldBe` "too_large"
+                    tcpClosed h
+        it "accepts exact-limit CRLF frames and preserves pipelined requests" $
+            withTcpServer defaultServerConfig{scMaxMessage = 17} $ \_ handle ->
+                withConnection handle $ \h -> do
+                    BSC.hPutStr h "{\"method\":\"ping\"}\r\n{\"method\":\"ping\"}\n"
+                    hFlush h
+                    replicateM_ 2 $ do
+                        raw <- timeout 1000000 (BSC.hGetLine h)
+                        fmap (asText . at "status" . fromMaybe A.Null . decode . BL.fromStrict) raw `shouldBe` Just "pong"
         it "ping answers pong and quit closes the connection" $
             withTcpServer defaultServerConfig $ \_ handle ->
                 withConnection handle $ \h -> do
@@ -1531,6 +1549,22 @@ transactionSpec = describe "server transactions" $ do
         rows <- mustSql session "select * from fresh"
         qrRowCount rows `shouldBe` 1
 
+    it "does not start a transaction when its snapshot cannot be read" $ do
+        ref <- newMVar testDb
+        settings <- tempSettingsPath "snapshot-failure"
+        let base = memoryBackend testDatabaseName ref
+            -- | 保留测试后端并让快照读取失败
+            failing name = (beWithDatabase base name)
+                { beSnapshot = pure (Left "data page unreadable")
+                , beWithDatabase = failing
+                }
+        session <- newSession (failing testDatabaseName) (T.pack testDatabaseName) settings
+        void (mustSql session "USE test")
+        result <- runStatementCoded session "BEGIN"
+        failureMessage result `shouldBe` "data page unreadable"
+        late <- runStatementCoded session "COMMIT"
+        failureMessage late `shouldBe` "no transaction in progress"
+
     it "refuses nested BEGIN and COMMIT outside a transaction" $ withMemorySession $ \session -> do
         _ <- mustSql session "begin"
         nested <- runStatementCoded session "begin"