完成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 =

chusql-engine/test/Spec.hs

@@ -11,8 +11,9 @@ import ChuSQL.Storage.IPC (IPCStorage (runIPCStorage), Request (ReqPing), Respon
 import ChuSQL.Syntax.AST
 import ChuSQL.Syntax.Parser
 import Control.Concurrent (threadDelay)
-import Control.Exception (IOException, bracket, try)
+import Control.Exception (IOException, bracket, finally, try)
 import Data.List (isInfixOf, sortOn)
+import Data.Unique (hashUnique, newUnique)
 import System.CPUTime (getCPUTime)
 import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getTemporaryDirectory, removePathForcibly)
 import System.Environment (getEnvironment, lookupEnv, setEnv, unsetEnv)
@@ -340,7 +341,12 @@ main = hspec $ do
         it "returns Left when a value has the wrong type for comparison" $ do
             runStatement testDB (Insert "users" ["name"] [Col "other"])
                 `shouldSatisfy` isLeft
-
+        it "writes id column to index and queries it back" $ do
+            case parseStatement "INSERT INTO users (id, name, age) VALUES (42, 'Zoe', 20)" >>= runStatement testDB of
+                Left err -> expectationFailure err
+                Right (db', _) -> do
+                    rowsOf (parseStatement "SELECT name FROM users WHERE id = 42" >>= runStatement db')
+                        `shouldBe` Right [[("name", VStr "Zoe")]]
     describe "ChuSQL.Engine (DELETE)" $ do
         it "parses DELETE with WHERE" $ do
             parseStatement "DELETE FROM users WHERE age < 18"
@@ -1102,7 +1108,7 @@ main = hspec $ do
         it "scan returns rows with all three value types after insert" $ do
             withTestServer $ \srv -> withServerEnv srv $ do
                 let row = [("id", VInt 7), ("name", VStr "Alice"), ("flag", VBool True)]
-                runIPCStorage (insert "users" row) `shouldReturn` Right ()
+                runIPCStorage (insert "users" row (Just 7)) `shouldReturn` Right ()
                 rows <- runIPCStorage (scan "users")
                 (map sortRow <$> rows) `shouldBe` Right [sortRow row]
 
@@ -1113,7 +1119,7 @@ main = hspec $ do
 
         it "scan returns all 20 inserted rows in order" $ do
             withTestServer $ \srv -> withServerEnv srv $ do
-                mapM_ (\i -> runIPCStorage (insert "many" [("id", VInt i)])) [1 .. 20 :: Int]
+                mapM_ (\i -> runIPCStorage (insert "many" [("id", VInt i)] (Just i))) [1 .. 20 :: Int]
                 rows <- runIPCStorage (scan "many")
                 fmap length rows `shouldBe` Right 20
                 fmap (sortOn show . map (lookup "id")) rows
@@ -1121,7 +1127,7 @@ main = hspec $ do
 
         it "replaceAll leaves only the new rows" $ do
             withTestServer $ \srv -> withServerEnv srv $ do
-                runIPCStorage (insert "t" [("id", VInt 1)]) `shouldReturn` Right ()
+                runIPCStorage (insert "t" [("id", VInt 1)] (Just 1)) `shouldReturn` Right ()
                 runIPCStorage (replaceAll "t" [[("id", VInt 9)], [("id", VInt 8)]]) `shouldReturn` Right ()
                 rows <- runIPCStorage (scan "t")
                 fmap (sortOn show . map (lookup "id")) rows
@@ -1130,7 +1136,7 @@ main = hspec $ do
         it "lookupByKey finds a row inserted with an id over the pipe" $ do
             withTestServer $ \srv -> withServerEnv srv $ do
                 let row = [("id", VInt 7), ("name", VStr "Zoe")]
-                runIPCStorage (insert "keyed" row) `shouldReturn` Right ()
+                runIPCStorage (insert "keyed" row (Just 7)) `shouldReturn` Right ()
                 found <- runIPCStorage (lookupByKey "keyed" 7)
                 fmap (fmap sortRow) found `shouldBe` Right (Just (sortRow row))
                 missing <- runIPCStorage (lookupByKey "keyed" 8)
@@ -1138,7 +1144,7 @@ main = hspec $ do
 
         it "replaceAll rebuilds the index over the pipe" $ do
             withTestServer $ \srv -> withServerEnv srv $ do
-                runIPCStorage (insert "rb" [("id", VInt 1)]) `shouldReturn` Right ()
+                runIPCStorage (insert "rb" [("id", VInt 1)] (Just 1)) `shouldReturn` Right ()
                 runIPCStorage (replaceAll "rb" [[("id", VInt 9), ("name", VStr "Zoe")]]) `shouldReturn` Right ()
                 old <- runIPCStorage (lookupByKey "rb" 1)
                 old `shouldBe` Right Nothing
@@ -1148,8 +1154,8 @@ main = hspec $ do
 
         it "snapshot lists tables and scans each one to build the database" $ do
             withTestServer $ \srv -> withServerEnv srv $ do
-                runIPCStorage (insert "a" [("id", VInt 1)]) `shouldReturn` Right ()
-                runIPCStorage (insert "b" [("id", VInt 2)]) `shouldReturn` Right ()
+                runIPCStorage (insert "a" [("id", VInt 1)] (Just 1)) `shouldReturn` Right ()
+                runIPCStorage (insert "b" [("id", VInt 2)] (Just 2)) `shouldReturn` Right ()
                 db <- runIPCStorage snapshot
                 map fst db `shouldBe` ["a", "b"]
                 map (length . tableRows . snd) db `shouldBe` [1, 1]
@@ -1157,8 +1163,8 @@ main = hspec $ do
 
         it "doListTables returns the tables that exist" $ do
             withTestServer $ \srv -> withServerEnv srv $ do
-                runIPCStorage (insert "t1" [("id", VInt 1)]) `shouldReturn` Right ()
-                runIPCStorage (insert "t2" [("id", VInt 2)]) `shouldReturn` Right ()
+                runIPCStorage (insert "t1" [("id", VInt 1)] (Just 1)) `shouldReturn` Right ()
+                runIPCStorage (insert "t2" [("id", VInt 2)] (Just 2)) `shouldReturn` Right ()
                 doListTables `shouldReturn` Right ["t1", "t2"]
 
         it "rows survive a restart on the same data directory" $ do
@@ -1168,7 +1174,7 @@ main = hspec $ do
                 Right bin -> do
                     srv1 <- startServer bin
                     let dir = dataDir srv1
-                    withServerEnv srv1 $ runIPCStorage (insert "persist" [("id", VInt 42)]) `shouldReturn` Right ()
+                    withServerEnv srv1 $ runIPCStorage (insert "persist" [("id", VInt 42)] (Just 42)) `shouldReturn` Right ()
                     stopServer srv1
                     srv2 <- startServerAt bin dir
                     rows <- withServerEnv srv2 $ runIPCStorage (scan "persist")
@@ -1180,6 +1186,31 @@ main = hspec $ do
             withPipeName "chusql-no-such-server" $ do
                 result <- runIPCStorage (scan "users")
                 result `shouldSatisfy` isLeft
+        it "INSERT then SELECT WHERE id = k via IPC" $ do
+            withTestServer $ \srv -> withServerEnv srv $ do
+                _ <-
+                    runIPCStorage
+                        ( runStatementM
+                            (CreateTable "ipc_idx" [("id", TInt), ("name", TStr)])
+                        )
+                _ <-
+                    runIPCStorage
+                        ( runStatementM
+                            (Insert "ipc_idx" ["id", "name"] [LitInt 42, LitStr "Zoe"])
+                        )
+                result <-
+                    runIPCStorage
+                        ( runStatementM
+                            ( Select
+                                { selectCols = ["name"]
+                                , selectFrom = FromTable Nothing "ipc_idx"
+                                , selectWhere = Just (Eq (Col "id") (LitInt 42))
+                                , selectOrderBy = []
+                                , selectLimit = Nothing
+                                }
+                            )
+                        )
+                result `shouldBe` Right [[("name", VStr "Zoe")]]
         it "parses CREATE TABLE with two columns" $ do
             parseStatement "CREATE TABLE users (id INT, name TEXT)"
                 `shouldBe` Right (CreateTable "users" [("id", TInt), ("name", TStr)])
@@ -1280,7 +1311,7 @@ locateServer = do
 
 startServer :: FilePath -> IO IPCServer
 startServer bin = do
-    stamp <- show <$> getCPUTime
+    stamp <- uniqueStamp
     tmp <- getTemporaryDirectory
     let dir = tmp </> "chusql-hs-IPC" </> stamp
     createDirectoryIfMissing True dir
@@ -1288,7 +1319,7 @@ startServer bin = do
 
 startServerAt :: FilePath -> FilePath -> IO IPCServer
 startServerAt bin dir = do
-    stamp <- show <$> getCPUTime
+    stamp <- uniqueStamp
     let name = "chusql-hs-test-" ++ stamp
     parentEnv <- getEnvironment
     (_, _, _, ph) <-
@@ -1302,6 +1333,13 @@ startServerAt bin dir = do
     waitUntilReady srv 100
     pure srv
 
+-- | 每次调用都不同的后缀：CPU 时间精度不够，再加上一个唯一编号。
+uniqueStamp :: IO String
+uniqueStamp = do
+    cpu <- getCPUTime
+    u <- hashUnique <$> newUnique
+    pure (show cpu ++ "-" ++ show u)
+
 waitUntilReady :: IPCServer -> Int -> IO ()
 waitUntilReady srv tries = do
     probe <- try (withServerEnv srv (sendRequest ReqPing)) :: IO (Either IOException Response)
@@ -1337,10 +1375,9 @@ withServerEnv srv act = do
     oldDir <- lookupEnv "CHUSQL_DATA_DIR"
     setEnv "CHUSQL_PIPE" (pipeName srv)
     setEnv "CHUSQL_DATA_DIR" (dataDir srv)
-    r <- act
-    restore "CHUSQL_PIPE" oldPipe
-    restore "CHUSQL_DATA_DIR" oldDir
-    pure r
+    act `finally` do
+        restore "CHUSQL_PIPE" oldPipe
+        restore "CHUSQL_DATA_DIR" oldDir
   where
     restore k = maybe (unsetEnv k) (setEnv k)