完成rust缓冲池，服务端部分收尾

chusql-engine/src/ChuSQL/Algebra/Eval.hs

@@ -6,11 +6,12 @@ import ChuSQL.Algebra.Sort (sortRows)
 import ChuSQL.Model
 import ChuSQL.Storage (MonadStorage (..))
 import ChuSQL.Syntax.AST (Expr (..))
-import Control.Monad (filterM)
+import Control.Monad (filterM, foldM)
 
 -- 执行：按算子树算出结果行（Scan 阶段会加别名前缀）。
 
 -- * 工具
+
 -- | 只保留清单里的列
 project :: [String] -> Row -> Row
 project ["*"] row = row
@@ -31,7 +32,21 @@ evalScan db mAlias tbl = do
     let prefix = maybe "" (++ ".") mAlias
     Right (map (addPrefix prefix) (tableRows table))
 
+-- | 把两边的行按条件配对（边配边筛，不先建整张积表）
+filterPairs :: (Row -> Either String Bool) -> [Row] -> [Row] -> Either String [Row]
+filterPairs cond lrows rrows = go lrows []
+  where
+    go [] acc = Right (reverse acc)
+    go (l : ls) acc = do
+        acc' <- foldM (keep l) acc rrows
+        go ls acc'
+    keep l acc r = do
+        let row = l ++ r
+        ok <- cond row
+        pure (if ok then row : acc else acc)
+
 -- * 求值
+
 -- | 纯求值（不需要存储）
 evalRelOp :: Database -> RelOp -> Either String [Row]
 evalRelOp db (Scan mAlias tbl) = evalScan db mAlias tbl
@@ -53,37 +68,41 @@ evalRelOp db (Limit n op) = do
 evalRelOp db (Join left right cond) = do
     lrows <- evalRelOp db left
     rrows <- evalRelOp db right
-    let cross = [l ++ r | l <- lrows, r <- rrows]
-    filterM (evalCondForRow cond) cross
+    filterPairs (evalCondForRow cond) lrows rrows
 
 -- | 单子求值：Lookup 问存储
-evalRelOpM :: (MonadStorage m) => Database -> RelOp -> m (Either String [Row])
-evalRelOpM db (Scan a t) = pure (evalScan db a t)
-evalRelOpM _ (Lookup t k) = do
+evalRelOpM :: (MonadStorage m) => RelOp -> m (Either String [Row])
+evalRelOpM (Scan mAlias t) = do
+    result <- scan t
+    pure $ do
+        rows <- result
+        case mAlias of
+            Nothing -> Right rows
+            Just a -> Right (map (addPrefix (a ++ ".")) rows)
+evalRelOpM (Lookup t k) = do
     result <- lookupByKey t k
     pure $ case result of
         Left e -> Left e
         Right Nothing -> Right []
-        Right (Just r) -> Right [r]
-evalRelOpM db (Filter p x) = do
-    result <- evalRelOpM db x
+        Right (Just row) -> Right [row]
+evalRelOpM (Filter p x) = do
+    result <- evalRelOpM x
     pure $ do
         rows <- result
         filterM (evalCondForRow p) rows
-evalRelOpM db (Project cols x) = do
-    result <- evalRelOpM db x
-    pure (map (project cols) <$> result)
-evalRelOpM db (Sort specs x) = do
-    result <- evalRelOpM db x
-    pure (sortRows specs <$> result)
-evalRelOpM db (Limit n x) = do
-    result <- evalRelOpM db x
-    pure (take n <$> result)
-evalRelOpM db (Join l r c) = do
-    ls <- evalRelOpM db l
-    rs <- evalRelOpM db r
+evalRelOpM (Project cols x) = do
+    result <- evalRelOpM x
+    pure (fmap (map (project cols)) result)
+evalRelOpM (Sort spec x) = do
+    result <- evalRelOpM x
+    pure (fmap (sortRows spec) result)
+evalRelOpM (Limit n x) = do
+    result <- evalRelOpM x
+    pure (fmap (take n) result)
+evalRelOpM (Join l r cond) = do
+    ls <- evalRelOpM l
+    rs <- evalRelOpM r
     pure $ do
-        leftRows <- ls
-        rightRows <- rs
-        let cross = [x ++ y | x <- leftRows, y <- rightRows]
-        filterM (evalCondForRow c) cross
+        left <- ls
+        right <- rs
+        filterPairs (evalCondForRow cond) left right

chusql-engine/src/ChuSQL/Algebra/Sort.hs

@@ -19,21 +19,26 @@ compareValue (VStr a) (VStr b) = compare a b
 compareValue (VBool a) (VBool b) = compare a b
 compareValue _ _ = EQ
 
--- | 按排序要求比较两行
-compareRows :: [(String, SortDir)] -> Row -> Row -> Ordering
-compareRows [] _ _ = EQ
-compareRows ((col, dir) : rest) r1 r2 =
-    case (lookup col r1, lookup col r2) of
+-- | 取出排序键（按 spec 顺序，每行只查一次）
+sortKey :: [(String, SortDir)] -> Row -> [Maybe Value]
+sortKey spec row = [lookup col row | (col, _) <- spec]
+
+-- | 比较两个排序键
+compareKeys :: [(String, SortDir)] -> [Maybe Value] -> [Maybe Value] -> Ordering
+compareKeys [] _ _ = EQ
+compareKeys ((_, dir) : rest) (a : as) (b : bs) =
+    case (a, b) of
         (Just v1, Just v2) ->
             case compareValue v1 v2 of
-                EQ -> compareRows rest r1 r2
-                o ->
-                    if dir == Desc
-                        then flipOrdering o
-                        else o
-        _ -> compareRows rest r1 r2
+                EQ -> compareKeys rest as bs
+                o -> if dir == Desc then flipOrdering o else o
+        _ -> compareKeys rest as bs
+compareKeys _ _ _ = EQ
 
--- | 排序若干行
+-- | 排序若干行（先取键再排，避免每次比较都查列）
 sortRows :: [(String, SortDir)] -> [Row] -> [Row]
 sortRows [] rows = rows
-sortRows spec rows = sortBy (compareRows spec) rows
+sortRows spec rows = map snd (sortBy cmp (map decorate rows))
+  where
+    decorate row = (sortKey spec row, row)
+    cmp (k1, _) (k2, _) = compareKeys spec k1 k2

chusql-engine/src/ChuSQL/Engine.hs

@@ -14,6 +14,7 @@ import Control.Monad (filterM)
 -- 引擎入口：语义检查 + 分发执行，以及内存实现与泛型版本。
 
 -- * 对外入口
+
 -- | 跑一条语句（内存实现）
 runStatement :: Database -> Statement -> Either String (Database, [Row])
 runStatement db q = do
@@ -25,35 +26,36 @@ runStatement db q = do
 rowsOf :: Either String (Database, [Row]) -> Either String [Row]
 rowsOf = fmap snd
 
-
 -- | 泛型入口：先检查再执行
 runStatementM :: (MonadStorage m) => Statement -> m (Either String [Row])
 runStatementM q = do
     db <- snapshot
     case check db q of
         Left err -> pure (Left err)
-        Right _ -> runStatementUncheckedM q
+        Right _ -> runStatementUncheckedM db q
 
 -- * 分发执行
+
 -- | 按语句类型分发（已检查过）
-runStatementUncheckedM :: (MonadStorage m) => Statement -> m (Either String [Row])
-runStatementUncheckedM q@Select{} = do
-    db <- snapshot
+runStatementUncheckedM :: (MonadStorage m) => Database -> Statement -> m (Either String [Row])
+runStatementUncheckedM db q@Select{} =
     case translate q of
         Left e -> pure (Left e)
-        Right relOp -> evalRelOpM db (optimize db relOp)
-
-runStatementUncheckedM (Insert tbl cols vals) =
+        Right relOp -> evalRelOpM (optimize db relOp)
+runStatementUncheckedM _ (Insert tbl cols vals) =
     case mapM (\e -> evalExpr e []) vals of
         Left err -> pure (Left err)
         Right values
             | length cols /= length values ->
                 pure (Left "column count does not match value count")
             | otherwise -> do
-                result <- insert tbl (zip cols values)
+                let row = zip cols values
+                    key = case lookup "id" row of
+                        Just (VInt k) -> Just k
+                        _ -> Nothing
+                result <- insert tbl row key
                 pure (result >> Right [])
-
-runStatementUncheckedM (Delete tbl mWhere) = do
+runStatementUncheckedM _ (Delete tbl mWhere) = do
     rowsResult <- scan tbl
     case rowsResult of
         Left err -> pure (Left err)
@@ -70,8 +72,7 @@ runStatementUncheckedM (Delete tbl mWhere) = do
     -- \| 保留 = 条件不成立
     shouldKeep :: Expr -> Row -> Either String Bool
     shouldKeep e row = not <$> evalCondForRow e row
-
-runStatementUncheckedM (Update tbl assigns mWhere) = do
+runStatementUncheckedM _ (Update tbl assigns mWhere) = do
     rowsResult <- scan tbl
     case rowsResult of
         Left err -> pure (Left err)
@@ -90,15 +91,15 @@ runStatementUncheckedM (Update tbl assigns mWhere) = do
             Nothing -> Right True
             Just e -> evalCondForRow e row
         if keep then applyUpdates asgns row else Right row
-
-runStatementUncheckedM (CreateTable name cols) = do
+runStatementUncheckedM _ (CreateTable name cols) = do
     result <- createTable name cols
     pure (result >> Right [])
-runStatementUncheckedM (DropTable name) = do
+runStatementUncheckedM _ (DropTable name) = do
     result <- dropTable name
     pure (result >> Right [])
 
 -- * 更新辅助
+
 -- | 依次求值并覆盖列
 applyUpdates :: [(String, Expr)] -> Row -> Either String Row
 applyUpdates [] row = Right row

chusql-engine/src/ChuSQL/Storage.hs

@@ -12,7 +12,7 @@ class (Monad m) => MonadStorage m where
     scan :: String -> m (Either String [Row])
 
     -- \| 追加一行
-    insert :: String -> Row -> m (Either String ())
+    insert :: String -> Row -> Maybe Int -> m (Either String ())
 
     -- \| 整表替换
     replaceAll :: String -> [Row] -> m (Either String ())

chusql-engine/src/ChuSQL/Storage/IPC.hs

@@ -7,17 +7,19 @@ module ChuSQL.Storage.IPC (
     Response (..),
     SchemaColumn (..),
     sendRequest,
+    closeConnection,
     doListTables,
     doLookupByKey,
-    doInsertKeyed,
+    doInsertWith,
     doDescribeTable,
-    doCreateTable,
     doDropTable,
+    doListCatalog,
 ) where
 
 import ChuSQL.Model
 import ChuSQL.Storage
-import Control.Exception (IOException, bracket, try)
+import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar)
+import Control.Exception (IOException, try)
 import Data.Aeson (FromJSON (..), ToJSON (..), eitherDecodeStrict, encode, object, withObject, (.:), (.=))
 import Data.Aeson qualified as A
 import Data.Aeson.Key qualified as K
@@ -25,15 +27,16 @@ import Data.Aeson.KeyMap qualified as KM
 import Data.Aeson.Types (Parser)
 import Data.ByteString.Char8 qualified as BSC
 import Data.ByteString.Lazy qualified as BL
-import Data.List (nub)
 import Data.Scientific (floatingOrInteger)
 import Data.Text qualified as T
 import System.Environment (lookupEnv)
 import System.IO
+import System.IO.Unsafe (unsafePerformIO)
 
 -- IPC 存储实现：每个存储方法翻成管道上的一条 JSON 请求。
 
 -- * 存储实现
+
 -- | 命名管道上的存储
 newtype IPCStorage a = IPCStorage
     { runIPCStorage :: IO a
@@ -54,45 +57,80 @@ instance Monad IPCStorage where
         a <- m
         runIPCStorage (k a)
 
+-- * 全局连接缓存
+
+-- | 全局句柄缓存：按管道路径缓存，路径变了就换连接。
+{-# NOINLINE connectionRef #-}
+connectionRef :: MVar (Maybe (FilePath, Handle))
+connectionRef = unsafePerformIO (newMVar Nothing)
+
+-- | 打开管道
+openPipe :: FilePath -> IO Handle
+openPipe path = do
+    h <- openFile path ReadWriteMode
+    hSetBuffering h LineBuffering
+    hSetNewlineMode h noNewlineTranslation
+    pure h
+
+-- | 关掉缓存里的句柄（没有就什么都不做）
+closeCached :: Maybe (FilePath, Handle) -> IO ()
+closeCached Nothing = pure ()
+closeCached (Just (_, h)) = hClose h
+
+-- | 拿一个可用句柄；路径没变就复用，变了就换。
+getConnection :: FilePath -> IO Handle
+getConnection path = modifyMVar connectionRef $ \cached -> case cached of
+    Just (p, h)
+        | p == path -> pure (Just (p, h), h)
+    _ -> do
+        _ <- try (closeCached cached) :: IO (Either IOException ())
+        h <- openPipe path
+        pure (Just (path, h), h)
+
+-- | 丢掉缓存的连接（出错后调用，下次会重连）
+dropConnection :: IO ()
+dropConnection = modifyMVar_ connectionRef $ \cached -> do
+    _ <- try (closeCached cached) :: IO (Either IOException ())
+    pure Nothing
+
+-- | 关闭并清空连接。可选，进程退出前调用。
+closeConnection :: IO ()
+closeConnection = dropConnection
+
 -- * 管道
+
 -- | 管道路径
 pipePath :: IO String
 pipePath = do
     name <- maybe "chusql-storage" id <$> lookupEnv "CHUSQL_PIPE"
     pure ("\\\\.\\pipe\\" ++ name)
 
--- | 开管道跑闭包
-withPipe :: (Handle -> IO a) -> IO a
-withPipe = bracket openPipe hClose
-  where
-    -- \| 打开管道句柄
-    openPipe = do
-        path <- pipePath
-        h <- openFile path ReadWriteMode
-        hSetBuffering h LineBuffering
-        hSetNewlineMode h noNewlineTranslation
-        pure h
-
--- | 发一条请求读一条响应
+-- | 发一条请求读一条响应；管道不通就回 RespError，并丢掉缓存等下次重连。
 sendRequest :: Request -> IO Response
 sendRequest req = do
-    result <- try (withPipe roundTrip) :: IO (Either IOException Response)
-    pure $ case result of
-        Left e -> RespError ("pipe error: " ++ show e)
-        Right r -> r
-  where
-    roundTrip h = do
-        BL.hPutStr h (encode req)
-        BSC.hPutStr h "\n"
-        hFlush h
-        line <- BSC.hGetLine h
-        let cleaned = BSC.dropWhileEnd (== '\r') line
-        case eitherDecodeStrict cleaned of
-            Left err -> pure (RespError ("decode: " ++ err))
-            Right r -> pure r
+    path <- pipePath
+    result <- try (roundTrip req path) :: IO (Either IOException Response)
+    case result of
+        Left e -> do
+            dropConnection
+            pure (RespError ("pipe error: " ++ show e))
+        Right r -> pure r
 
+-- | 一条请求-响应往返（复用缓存里的句柄）
+roundTrip :: Request -> FilePath -> IO Response
+roundTrip req path = do
+    h <- getConnection path
+    BL.hPutStr h (encode req)
+    BSC.hPutStr h "\n"
+    hFlush h
+    line <- BSC.hGetLine h
+    let cleaned = BSC.dropWhileEnd (== '\r') line
+    case eitherDecodeStrict cleaned of
+        Left err -> pure (RespError ("decode: " ++ err))
+        Right r -> pure r
 
 -- * 编解码
+
 -- | 一列的 schema
 data SchemaColumn = SchemaColumn
     { scName :: String
@@ -112,6 +150,7 @@ instance FromJSON SchemaColumn where
         pure (SchemaColumn n t)
 
 -- * 请求
+
 -- | 请求类型
 data Request
     = ReqPing
@@ -123,6 +162,7 @@ data Request
     | ReqDescribeTable String
     | ReqCreateTable String [SchemaColumn]
     | ReqDropTable String
+    | ReqListCatalog
 
 -- | 请求编码
 instance ToJSON Request where
@@ -163,7 +203,7 @@ instance ToJSON Request where
             ]
     toJSON (ReqDropTable t) =
         object ["method" .= ("drop_table" :: T.Text), "table" .= t]
-
+    toJSON ReqListCatalog = object ["method" .= ("list_catalog" :: T.Text)]
 
 -- | 响应类型
 data Response
@@ -173,6 +213,7 @@ data Response
     | RespSchema [SchemaColumn] Int
     | RespOk
     | RespError String
+    | RespCatalog [(String, [SchemaColumn], Int)]
 
 -- | 响应解码
 instance FromJSON Response where
@@ -188,7 +229,18 @@ instance FromJSON Response where
                 cols <- o .: "columns"
                 cnt <- o .: "row_count"
                 pure (RespSchema cols cnt)
+            "catalog" -> do
+                xs <- o .: "schemas"
+                parsed <- mapM parseTableSchema xs
+                pure (RespCatalog parsed)
             other -> fail ("unknown status: " ++ T.unpack other)
+      where
+        -- \| 解析一条 list_catalog 记录。
+        parseTableSchema = withObject "TableSchema" $ \o -> do
+            t <- o .: "table"
+            cols <- o .: "columns"
+            cnt <- o .: "row_count"
+            pure (t, cols, cnt)
 
 -- | 值编码成 JSON
 valueToJSON :: Value -> A.Value
@@ -221,8 +273,8 @@ rowFromJSON (A.Object o) = mapM toPair (KM.toList o)
         pure (K.toString k, val)
 rowFromJSON _ = fail "row must be a JSON object"
 
-
 -- * 内部封装
+
 -- | 发 Scan
 doScan :: String -> IO (Either String [Row])
 doScan t = do
@@ -232,25 +284,10 @@ doScan t = do
         RespError e -> Left e
         _ -> Left "unexpected response to scan"
 
--- | 发 Insert（带 id 键）
-doInsert :: String -> Row -> IO (Either String ())
-doInsert t r = do
-    resp <- sendRequest (ReqInsert t r (rowKey r))
-    pure $ case resp of
-        RespOk -> Right ()
-        RespError e -> Left e
-        _ -> Left "unexpected response to insert"
-
--- | 取行里的 id 作索引键
-rowKey :: Row -> Maybe Int
-rowKey r = case lookup "id" r of
-    Just (VInt k) -> Just k
-    _ -> Nothing
-
--- | 发 Insert（指定键）
-doInsertKeyed :: String -> Row -> Int -> IO (Either String ())
-doInsertKeyed t r k = do
-    resp <- sendRequest (ReqInsert t r (Just k))
+-- | 发 Insert，可带索引键。
+doInsertWith :: String -> Row -> Maybe Int -> IO (Either String ())
+doInsertWith t r mk = do
+    resp <- sendRequest (ReqInsert t r mk)
     pure $ case resp of
         RespOk -> Right ()
         RespError e -> Left e
@@ -274,6 +311,15 @@ doListTables = do
         RespError e -> Left e
         _ -> Left "unexpected response to list_tables"
 
+-- | 一次拿全库 schema（表名 + 列 + 行数）。
+doListCatalog :: IO (Either String [(String, [SchemaColumn], Int)])
+doListCatalog = do
+    resp <- sendRequest ReqListCatalog
+    pure $ case resp of
+        RespCatalog xs -> Right xs
+        RespError e -> Left e
+        _ -> Left "unexpected response to list_catalog"
+
 -- | 发 LookupByIndex
 doLookupByKey :: String -> Int -> IO (Either String (Maybe Row))
 doLookupByKey t k = do
@@ -312,6 +358,7 @@ doDropTable t = do
         _ -> Left "unexpected response to drop_table"
 
 -- * 表结构
+
 -- | 线上 schema 转本地列
 schemaToColumns :: [SchemaColumn] -> [(String, Column)]
 schemaToColumns = map go
@@ -321,45 +368,15 @@ schemaToColumns = map go
     go (SchemaColumn n "bool") = (n, TBool)
     go (SchemaColumn n _) = (n, TStr)
 
--- | 从行推断列和类型
-inferColumns :: [Row] -> [(String, Column)]
-inferColumns rows = [(n, inferType n) | n <- names]
-  where
-    -- \| 出现过的列名
-    names = nub (concatMap (map fst) rows)
-
-    -- \| 按第一个值推断类型
-    inferType n = case [v | r <- rows, Just v <- [lookup n r]] of
-        (VInt _ : _) -> TInt
-        (VStr _ : _) -> TStr
-        (VBool _ : _) -> TBool
-        [] -> TStr
-
--- | 扫一张表拼成 Table
-loadTable :: String -> IO Table
-loadTable t = do
-    schemaR <- doDescribeTable t
-    case schemaR of
-        Right (cols, _n) -> do
-            rowsR <- doScan t
-            case rowsR of
-                Right rows -> pure (Table t (schemaToColumns cols) rows)
-                Left _ -> pure (Table t (schemaToColumns cols) [])
-        Left _ -> do
-            rowsR <- doScan t
-            case rowsR of
-                Right rows -> pure (Table t (inferColumns rows) rows)
-                Left _ -> pure (Table t [] [])
-
-
 -- * MonadStorage 实例
+
 -- | 存储方法全走管道
 instance MonadStorage IPCStorage where
     -- \| 发 Scan
     scan t = IPCStorage (doScan t)
 
     -- \| 发 Insert
-    insert t r = IPCStorage (doInsert t r)
+    insert t r mk = IPCStorage (doInsertWith t r mk)
 
     -- \| 发 ReplaceAll
     replaceAll t rs = IPCStorage (doReplaceAll t rs)
@@ -380,12 +397,12 @@ instance MonadStorage IPCStorage where
 
     -- \| 列表 + 逐表扫描拼库
     snapshot = IPCStorage $ do
-        result <- doListTables
+        result <- doListCatalog
         case result of
             Left _ -> pure []
-            Right ts -> mapM loadDbEntry ts
+            Right xs -> mapM loadEntry xs
       where
-        -- \| 加载一个 (表名, 表) 对
-        loadDbEntry t = do
-            tbl <- loadTable t
-            pure (t, tbl)
+        -- \| 加载一张表（schema 来自 catalog，行来自 scan）
+        loadEntry (t, cols, _n) = do
+            rows <- doScan t
+            pure (t, Table t (schemaToColumns cols) (either (const []) id rows))

chusql-engine/src/ChuSQL/Storage/Memory.hs

@@ -2,10 +2,12 @@ module ChuSQL.Storage.Memory (MemoryStorage (runMemoryStorage)) where
 
 import ChuSQL.Model
 import ChuSQL.Storage
+import Data.List (find)
 
 -- 内存实现：状态是 Database，错误通道是 Either String。
 
 -- * 实例
+
 -- | 内存存储：Database 上的状态
 newtype MemoryStorage a = MemoryStorage {runMemoryStorage :: Database -> Either String (a, Database)}
 
@@ -37,7 +39,7 @@ instance MonadStorage MemoryStorage where
         Right (Right (tableRows tbl), db)
 
     -- \| 追加一行
-    insert t r = MemoryStorage $ \db -> do
+    insert t r _ = MemoryStorage $ \db -> do
         tbl <- lookupTable db t
         Right (Right (), replaceTable t tbl{tableRows = tableRows tbl ++ [r]} db)
 
@@ -67,11 +69,10 @@ instance MonadStorage MemoryStorage where
     snapshot = MemoryStorage $ \db -> Right (db, db)
 
 -- * 工具
+
 -- | 按 id 列找一行
 findRow :: Table -> Int -> Maybe Row
-findRow tbl k = case filter matches (tableRows tbl) of
-    (r : _) -> Just r
-    [] -> Nothing
+findRow tbl k = find matches (tableRows tbl)
   where
     -- \| 这行的 id 是否等于 k
     matches r = lookup "id" r == Just (VInt k)

chusql-engine/src/ChuSQL/Syntax/AST.hs

@@ -5,6 +5,7 @@ import ChuSQL.Model (Column (..))
 -- 语法树：语句、数据来源、条件表达式、排序方向。
 
 -- * 语句
+
 -- | 一条语句：查 / 加 / 删 / 改 / 建表 / 删表
 data Statement
     = Select
@@ -28,6 +29,7 @@ data FromClause
     deriving (Show, Eq)
 
 -- * 表达式
+
 -- | 条件表达式
 data Expr
     = Col String
@@ -42,6 +44,7 @@ data Expr
     deriving (Show, Eq)
 
 -- * 排序
+
 -- | 排序方向
 data SortDir
     = Asc
@@ -49,6 +52,7 @@ data SortDir
     deriving (Show, Eq)
 
 -- * 构造
+
 -- | 造一个最简单的 SELECT
 makeSelect :: [String] -> String -> Maybe Expr -> Statement
 makeSelect cols tbl w =