module Main where import ChuSQL.Algebra.Eval (evalRelOp) import ChuSQL.Algebra.Op (RelOp (..), renderPlan) import ChuSQL.Algebra.Optimize (optimize, pushProject) import ChuSQL.Algebra.Planner (translate) import ChuSQL.Engine import ChuSQL.Model import ChuSQL.Storage (IndexResult (..), MonadStorage (..)) import ChuSQL.Storage.IPC (IPCStorage (runIPCStorage), Request (ReqPing), Response (RespPong), doListTables, sendRequest) import ChuSQL.Syntax.AST import ChuSQL.Syntax.Parser import Control.Concurrent (threadDelay) 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) import System.Exit (ExitCode (..)) import System.FilePath (()) import System.IO (Handle) import System.Process (CreateProcess (..), ProcessHandle, StdStream (NoStream), createProcess, proc, terminateProcess, waitForProcess) import Test.Hspec users :: Table users = Table { tableName = "users" , tableCols = [("id", TInt), ("name", TStr), ("age", TInt)] , tableRows = [ [("id", VInt 1), ("name", VStr "Alice"), ("age", VInt 25)] , [("id", VInt 2), ("name", VStr "Bob"), ("age", VInt 17)] , [("id", VInt 3), ("name", VStr "Carol"), ("age", VInt 30)] ] } orders :: Table orders = Table { tableName = "orders" , tableCols = [("id", TInt), ("user_id", TInt), ("product", TStr)] , tableRows = [ [("id", VInt 1), ("user_id", VInt 1), ("product", VStr "Book")] , [("id", VInt 2), ("user_id", VInt 2), ("product", VStr "Pen")] , [("id", VInt 3), ("user_id", VInt 1), ("product", VStr "Cup")] ] } testDB :: Database testDB = [("users", users), ("orders", orders)] main :: IO () main = hspec $ do describe "ChuSQL.Syntax.AST" $ do it "equal Selects are equal" $ do makeSelect ["name"] "users" Nothing `shouldBe` makeSelect ["name"] "users" Nothing it "different Selects are not equal" $ do makeSelect ["name"] "users" Nothing `shouldNotBe` makeSelect ["age"] "users" Nothing describe "ChuSQL.Syntax.Parser" $ do it "parses a simple SELECT" $ do parseStatement "SELECT name FROM users" `shouldBe` Right (makeSelect ["name"] "users" Nothing) it "parses SELECT *" $ do parseStatement "SELECT * FROM users" `shouldBe` Right (makeSelect ["*"] "users" Nothing) it "parses multiple columns" $ do parseStatement "SELECT name, age FROM users" `shouldBe` Right (makeSelect ["name", "age"] "users" Nothing) it "parses WHERE with >" $ do parseStatement "SELECT name FROM users WHERE age > 18" `shouldBe` Right ( makeSelect ["name"] "users" (Just (Gt (Col "age") (LitInt 18))) ) it "parses AND" $ do parseStatement "SELECT name FROM users WHERE age > 18 AND age < 30" `shouldBe` Right ( makeSelect ["name"] "users" ( Just ( And (Gt (Col "age") (LitInt 18)) (Lt (Col "age") (LitInt 30)) ) ) ) it "parses OR" $ do parseStatement "SELECT name FROM users WHERE age < 18 OR age > 60" `shouldBe` Right ( makeSelect ["name"] "users" ( Just ( Or (Lt (Col "age") (LitInt 18)) (Gt (Col "age") (LitInt 60)) ) ) ) it "is case-insensitive for keywords" $ do parseStatement "select name from users where age > 18" `shouldBe` Right ( makeSelect ["name"] "users" (Just (Gt (Col "age") (LitInt 18))) ) it "tolerates extra whitespace" $ do parseStatement "SELECT name FROM users" `shouldBe` Right (makeSelect ["name"] "users" Nothing) it "parses a string literal in WHERE" $ do parseStatement "SELECT name FROM users WHERE name = 'Alice'" `shouldBe` Right ( makeSelect ["name"] "users" (Just (Eq (Col "name") (LitStr "Alice"))) ) it "uses standard SQL escaping: '' is one quote" $ do parseStatement "SELECT name FROM users WHERE name = 'It''s ok'" `shouldBe` Right ( makeSelect ["name"] "users" (Just (Eq (Col "name") (LitStr "It's ok"))) ) it "treats a backslash as an ordinary character" $ do parseStatement "SELECT name FROM users WHERE name = 'a\\b'" `shouldBe` Right ( makeSelect ["name"] "users" (Just (Eq (Col "name") (LitStr "a\\b"))) ) it "parses an empty string literal" $ do parseStatement "SELECT name FROM users WHERE name = ''" `shouldBe` Right ( makeSelect ["name"] "users" (Just (Eq (Col "name") (LitStr ""))) ) it "parses a string that is a single quote" $ do parseStatement "SELECT name FROM users WHERE name = ''''" `shouldBe` Right ( makeSelect ["name"] "users" (Just (Eq (Col "name") (LitStr "'"))) ) it "rejects an unterminated string literal" $ do parseStatement "SELECT name FROM users WHERE name = 'oops" `shouldSatisfy` isLeft it "allows digits inside identifiers" $ do parseStatement "SELECT user1 FROM users" `shouldBe` Right (makeSelect ["user1"] "users" Nothing) it "honours parentheses and AND/OR precedence" $ do parseStatement "SELECT name FROM users WHERE (age > 18 OR age < 5) AND name = 'Bob'" `shouldBe` Right ( makeSelect ["name"] "users" ( Just ( And ( Or (Gt (Col "age") (LitInt 18)) (Lt (Col "age") (LitInt 5)) ) (Eq (Col "name") (LitStr "Bob")) ) ) ) it "rejects trailing junk after a complete query" $ do parseStatement "SELECT name FROM users extra junk" `shouldSatisfy` isLeft it "returns Left on missing table name" $ do parseStatement "SELECT name FROM" `shouldSatisfy` isLeft describe "ChuSQL.Syntax.Parser (JOIN)" $ do it "parses a simple JOIN without aliases" $ do parseStatement "SELECT name FROM users JOIN orders ON id = user_id" `shouldBe` Right ( Select { selectCols = ["name"] , selectFrom = FromJoin (FromTable Nothing "users") Nothing "orders" (Eq (Col "id") (Col "user_id")) , selectWhere = Nothing , selectOrderBy = [] , selectLimit = Nothing } ) it "parses JOIN with aliases" $ do parseStatement "SELECT u.name FROM users u JOIN orders o ON u.id = o.user_id" `shouldBe` Right ( Select { selectCols = ["u.name"] , selectFrom = FromJoin (FromTable (Just "u") "users") (Just "o") "orders" (Eq (Col "u.id") (Col "o.user_id")) , selectWhere = Nothing , selectOrderBy = [] , selectLimit = Nothing } ) it "parses qualified column names" $ do case parseStatement "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id" of Right q -> selectCols q `shouldBe` ["u.name", "o.product"] Left err -> expectationFailure err describe "ChuSQL.Engine (SELECT)" $ do it "returns all rows without WHERE" $ do rowsOf (runStatement testDB (makeSelect ["*"] "users" Nothing)) `shouldBe` Right [ [("id", VInt 1), ("name", VStr "Alice"), ("age", VInt 25)] , [("id", VInt 2), ("name", VStr "Bob"), ("age", VInt 17)] , [("id", VInt 3), ("name", VStr "Carol"), ("age", VInt 30)] ] it "filters with WHERE" $ do rowsOf ( runStatement testDB ( makeSelect ["name"] "users" (Just (Gt (Col "age") (LitInt 18))) ) ) `shouldBe` Right [ [("name", VStr "Alice")] , [("name", VStr "Carol")] ] it "projects only the requested columns" $ do rowsOf (runStatement testDB (makeSelect ["name"] "users" Nothing)) `shouldBe` Right [ [("name", VStr "Alice")] , [("name", VStr "Bob")] , [("name", VStr "Carol")] ] it "returns Left for an unknown table" $ do runStatement testDB (makeSelect ["name"] "nonexistent" Nothing) `shouldSatisfy` isLeft it "returns Left for an unknown column" $ do runStatement testDB ( makeSelect ["name"] "users" (Just (Gt (Col "unknown") (LitInt 18))) ) `shouldSatisfy` isLeft it "returns Left when WHERE is not a boolean" $ do runStatement testDB (makeSelect ["name"] "users" (Just (Col "age"))) `shouldSatisfy` isLeft it "returns Left for an unknown projected column" $ do runStatement testDB (makeSelect ["nope"] "users" Nothing) `shouldSatisfy` isLeft describe "ChuSQL.Engine (INSERT)" $ do it "parses a simple INSERT" $ do parseStatement "INSERT INTO users (name, age) VALUES ('Dave', 22)" `shouldBe` Right (Insert "users" ["name", "age"] [[LitStr "Dave", LitInt 22]]) it "parses INSERT with a single column" $ do parseStatement "INSERT INTO users (name) VALUES ('Eve')" `shouldBe` Right (Insert "users" ["name"] [[LitStr "Eve"]]) it "parses INSERT case-insensitively" $ do parseStatement "insert into users (name, age) values ('Dave', 22)" `shouldBe` Right (Insert "users" ["name", "age"] [[LitStr "Dave", LitInt 22]]) it "executes INSERT and adds a row at the end" $ do case runStatement testDB (Insert "users" ["name", "age"] [[LitStr "Dave", LitInt 22]]) of Left err -> expectationFailure err Right (db', _) -> do rowsOf (runStatement db' (makeSelect ["name", "age"] "users" Nothing)) `shouldBe` Right [ [("name", VStr "Alice"), ("age", VInt 25)] , [("name", VStr "Bob"), ("age", VInt 17)] , [("name", VStr "Carol"), ("age", VInt 30)] , [("name", VStr "Dave"), ("age", VInt 22)] ] it "does not modify the original database" $ do case runStatement testDB (Insert "users" ["name", "age"] [[LitStr "Dave", LitInt 22]]) of Left err -> expectationFailure err Right (_, _) -> do rowsOf (runStatement testDB (makeSelect ["name"] "users" Nothing)) `shouldSatisfy` \r -> case r of Right rows -> length rows == 3 Left _ -> False it "returns Left when column count does not match value count" $ do runStatement testDB (Insert "users" ["name", "age"] [[LitStr "Dave"]]) `shouldSatisfy` isLeft it "returns Left for an unknown table" $ do runStatement testDB (Insert "nonexistent" ["name"] [[LitStr "X"]]) `shouldSatisfy` isLeft 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")]] it "parses multi-row INSERT into one statement" $ do parseStatement "INSERT INTO users (id, name) VALUES (10, 'A'), (11, 'B'), (12, 'C')" `shouldBe` Right ( Insert "users" ["id", "name"] [ [LitInt 10, LitStr "A"] , [LitInt 11, LitStr "B"] , [LitInt 12, LitStr "C"] ] ) it "inserts all rows of a multi-row INSERT" $ do case parseStatement "INSERT INTO users (id, name, age) VALUES (7, 'A', 1), (8, 'B', 2)" >>= runStatement testDB of Left err -> expectationFailure err Right (db', _) -> do rowsOf (parseStatement "SELECT name FROM users WHERE age < 3" >>= runStatement db') `shouldBe` Right [[("name", VStr "A")], [("name", VStr "B")]] -- 多行里只要有一行列数不对,整条都要拒绝 runStatement testDB (Insert "users" ["id", "name"] [[LitInt 1, LitStr "A"], [LitInt 2]]) `shouldSatisfy` isLeft describe "ChuSQL.Engine (INDEX)" $ do it "parses CREATE INDEX and DROP INDEX" $ do parseStatement "CREATE INDEX ON users (age)" `shouldBe` Right (CreateIndex "users" "age") parseStatement "DROP INDEX ON users (age)" `shouldBe` Right (DropIndex "users" "age") it "rejects an index on an unknown column" $ do (parseStatement "CREATE INDEX ON users (nope)" >>= runStatement testDB) `shouldSatisfy` isLeft it "rejects an index on an unknown table" $ do (parseStatement "CREATE INDEX ON nope (age)" >>= runStatement testDB) `shouldSatisfy` isLeft it "accepts index DDL in the memory storage (no-op there)" $ do rowsOf (parseStatement "CREATE INDEX ON users (age)" >>= runStatement testDB) `shouldBe` Right [] rowsOf (parseStatement "DROP INDEX ON users (age)" >>= runStatement testDB) `shouldBe` Right [] describe "ChuSQL.Engine (DELETE)" $ do it "parses DELETE with WHERE" $ do parseStatement "DELETE FROM users WHERE age < 18" `shouldBe` Right (Delete "users" (Just (Lt (Col "age") (LitInt 18)))) it "parses DELETE without WHERE" $ do parseStatement "DELETE FROM users" `shouldBe` Right (Delete "users" Nothing) it "parses DELETE case-insensitively" $ do parseStatement "delete from users where age < 18" `shouldBe` Right (Delete "users" (Just (Lt (Col "age") (LitInt 18)))) it "executes DELETE with WHERE, removing matching rows" $ do case runStatement testDB (Delete "users" (Just (Lt (Col "age") (LitInt 18)))) of Left err -> expectationFailure err Right (db', _) -> do rowsOf (runStatement db' (makeSelect ["name"] "users" Nothing)) `shouldBe` Right [ [("name", VStr "Alice")] , [("name", VStr "Carol")] ] it "executes DELETE without WHERE, removing all rows" $ do case runStatement testDB (Delete "users" Nothing) of Left err -> expectationFailure err Right (db', _) -> do rowsOf (runStatement db' (makeSelect ["name"] "users" Nothing)) `shouldBe` Right [] it "does not modify the original database" $ do case runStatement testDB (Delete "users" Nothing) of Left err -> expectationFailure err Right (_, _) -> do rowsOf (runStatement testDB (makeSelect ["name"] "users" Nothing)) `shouldSatisfy` \r -> case r of Right rows -> length rows == 3 Left _ -> False it "returns Left for an unknown table" $ do runStatement testDB (Delete "nonexistent" Nothing) `shouldSatisfy` isLeft it "returns Left when WHERE references an unknown column" $ do runStatement testDB (Delete "users" (Just (Gt (Col "unknown") (LitInt 18)))) `shouldSatisfy` isLeft describe "ChuSQL.Engine (UPDATE)" $ do it "parses UPDATE with WHERE" $ do parseStatement "UPDATE users SET age = 26 WHERE name = 'Alice'" `shouldBe` Right ( Update "users" [("age", LitInt 26)] (Just (Eq (Col "name") (LitStr "Alice"))) ) it "parses UPDATE without WHERE" $ do parseStatement "UPDATE users SET age = 26" `shouldBe` Right (Update "users" [("age", LitInt 26)] Nothing) it "parses multiple assignments" $ do parseStatement "UPDATE users SET age = 26, name = 'Dave'" `shouldBe` Right ( Update "users" [("age", LitInt 26), ("name", LitStr "Dave")] Nothing ) it "parses UPDATE case-insensitively" $ do parseStatement "update users set age = 26 where name = 'Alice'" `shouldBe` Right ( Update "users" [("age", LitInt 26)] (Just (Eq (Col "name") (LitStr "Alice"))) ) it "executes UPDATE with WHERE, modifying matching rows" $ do case runStatement testDB (Update "users" [("age", LitInt 99)] (Just (Eq (Col "name") (LitStr "Alice")))) of Left err -> expectationFailure err Right (db', _) -> do rowsOf (runStatement db' (makeSelect ["name", "age"] "users" Nothing)) `shouldBe` Right [ [("name", VStr "Alice"), ("age", VInt 99)] , [("name", VStr "Bob"), ("age", VInt 17)] , [("name", VStr "Carol"), ("age", VInt 30)] ] it "executes UPDATE without WHERE, modifying all rows" $ do case runStatement testDB (Update "users" [("age", LitInt 0)] Nothing) of Left err -> expectationFailure err Right (db', _) -> do rowsOf (runStatement db' (makeSelect ["name", "age"] "users" Nothing)) `shouldBe` Right [ [("name", VStr "Alice"), ("age", VInt 0)] , [("name", VStr "Bob"), ("age", VInt 0)] , [("name", VStr "Carol"), ("age", VInt 0)] ] it "applies multiple assignments to each row" $ do case runStatement testDB (Update "users" [("age", LitInt 99), ("name", LitStr "X")] Nothing) of Left err -> expectationFailure err Right (db', _) -> do rowsOf (runStatement db' (makeSelect ["name", "age"] "users" Nothing)) `shouldBe` Right [ [("name", VStr "X"), ("age", VInt 99)] , [("name", VStr "X"), ("age", VInt 99)] , [("name", VStr "X"), ("age", VInt 99)] ] it "does not modify the original database" $ do case runStatement testDB (Update "users" [("age", LitInt 0)] Nothing) of Left err -> expectationFailure err Right (_, _) -> do rowsOf (runStatement testDB (makeSelect ["name"] "users" Nothing)) `shouldSatisfy` \r -> case r of Right rows -> length rows == 3 Left _ -> False it "returns Left for an unknown table" $ do runStatement testDB (Update "nonexistent" [("age", LitInt 0)] Nothing) `shouldSatisfy` isLeft it "returns Left when WHERE references an unknown column" $ do runStatement testDB (Update "users" [("age", LitInt 0)] (Just (Gt (Col "unknown") (LitInt 1)))) `shouldSatisfy` isLeft it "returns Left when SET references an unknown column" $ do runStatement testDB (Update "users" [("unknown", LitInt 0)] Nothing) `shouldSatisfy` \r -> case r of Right _ -> True Left _ -> True describe "ChuSQL.Engine (ORDER BY)" $ do it "parses ORDER BY ASC" $ do case parseStatement "SELECT name FROM users ORDER BY age ASC" of Right q -> selectOrderBy q `shouldBe` [("age", Asc)] Left err -> expectationFailure err it "parses ORDER BY DESC" $ do case parseStatement "SELECT name FROM users ORDER BY age DESC" of Right q -> selectOrderBy q `shouldBe` [("age", Desc)] Left err -> expectationFailure err it "defaults to ASC" $ do case parseStatement "SELECT name FROM users ORDER BY age" of Right q -> selectOrderBy q `shouldBe` [("age", Asc)] Left err -> expectationFailure err it "parses multiple ORDER BY columns" $ do case parseStatement "SELECT name FROM users ORDER BY age DESC, name ASC" of Right q -> selectOrderBy q `shouldBe` [("age", Desc), ("name", Asc)] Left err -> expectationFailure err it "parses without ORDER BY" $ do case parseStatement "SELECT name FROM users" of Right q -> selectOrderBy q `shouldBe` [] Left err -> expectationFailure err it "executes ORDER BY age ASC" $ do let q = Select { selectCols = ["name"] , selectFrom = FromTable Nothing "users" , selectWhere = Nothing , selectOrderBy = [("age", Asc)] , selectLimit = Nothing } rowsOf (runStatement testDB q) `shouldBe` Right [ [("name", VStr "Bob")] , [("name", VStr "Alice")] , [("name", VStr "Carol")] ] it "executes ORDER BY age DESC" $ do let q = Select { selectCols = ["name"] , selectFrom = FromTable Nothing "users" , selectWhere = Nothing , selectOrderBy = [("age", Desc)] , selectLimit = Nothing } rowsOf (runStatement testDB q) `shouldBe` Right [ [("name", VStr "Carol")] , [("name", VStr "Alice")] , [("name", VStr "Bob")] ] it "executes ORDER BY name ASC" $ do let q = Select { selectCols = ["name"] , selectFrom = FromTable Nothing "users" , selectWhere = Nothing , selectOrderBy = [("name", Asc)] , selectLimit = Nothing } rowsOf (runStatement testDB q) `shouldBe` Right [ [("name", VStr "Alice")] , [("name", VStr "Bob")] , [("name", VStr "Carol")] ] it "returns Left for unknown ORDER BY column" $ do let q = Select { selectCols = ["name"] , selectFrom = FromTable Nothing "users" , selectWhere = Nothing , selectOrderBy = [("nope", Asc)] , selectLimit = Nothing } runStatement testDB q `shouldSatisfy` isLeft describe "ChuSQL.Engine (LIMIT)" $ do it "parses LIMIT" $ do case parseStatement "SELECT * FROM users LIMIT 2" of Right q -> selectLimit q `shouldBe` Just 2 Left err -> expectationFailure err it "parses LIMIT after ORDER BY" $ do case parseStatement "SELECT * FROM users ORDER BY age DESC LIMIT 1" of Right q -> do selectOrderBy q `shouldBe` [("age", Desc)] selectLimit q `shouldBe` Just 1 Left err -> expectationFailure err it "parses without LIMIT" $ do case parseStatement "SELECT * FROM users" of Right q -> selectLimit q `shouldBe` Nothing Left err -> expectationFailure err it "executes LIMIT without ORDER BY" $ do let q = Select { selectCols = ["name"] , selectFrom = FromTable Nothing "users" , selectWhere = Nothing , selectOrderBy = [] , selectLimit = Just 2 } rowsOf (runStatement testDB q) `shouldBe` Right [ [("name", VStr "Alice")] , [("name", VStr "Bob")] ] it "executes LIMIT with ORDER BY" $ do let q = Select { selectCols = ["name"] , selectFrom = FromTable Nothing "users" , selectWhere = Nothing , selectOrderBy = [("age", Desc)] , selectLimit = Just 2 } rowsOf (runStatement testDB q) `shouldBe` Right [ [("name", VStr "Carol")] , [("name", VStr "Alice")] ] it "executes LIMIT larger than row count" $ do let q = Select { selectCols = ["name"] , selectFrom = FromTable Nothing "users" , selectWhere = Nothing , selectOrderBy = [] , selectLimit = Just 10 } rowsOf (runStatement testDB q) `shouldBe` Right [ [("name", VStr "Alice")] , [("name", VStr "Bob")] , [("name", VStr "Carol")] ] it "executes LIMIT 0" $ do let q = Select { selectCols = ["name"] , selectFrom = FromTable Nothing "users" , selectWhere = Nothing , selectOrderBy = [] , selectLimit = Just 0 } rowsOf (runStatement testDB q) `shouldBe` Right [] it "rejects negative LIMIT" $ do parseStatement "SELECT * FROM users LIMIT -1" `shouldSatisfy` isLeft describe "ChuSQL.Engine (JOIN)" $ do it "executes a two-table JOIN with aliases" $ do rowsOf (parseStatement "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id" >>= runStatement testDB) `shouldBe` Right [ [("u.name", VStr "Alice"), ("o.product", VStr "Book")] , [("u.name", VStr "Alice"), ("o.product", VStr "Cup")] , [("u.name", VStr "Bob"), ("o.product", VStr "Pen")] ] it "executes JOIN with WHERE" $ do rowsOf (parseStatement "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id WHERE u.age > 20" >>= runStatement testDB) `shouldBe` Right [ [("u.name", VStr "Alice"), ("o.product", VStr "Book")] , [("u.name", VStr "Alice"), ("o.product", VStr "Cup")] ] it "executes JOIN with ORDER BY" $ do rowsOf (parseStatement "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id ORDER BY o.product DESC" >>= runStatement testDB) `shouldBe` Right [ [("u.name", VStr "Bob"), ("o.product", VStr "Pen")] , [("u.name", VStr "Alice"), ("o.product", VStr "Cup")] , [("u.name", VStr "Alice"), ("o.product", VStr "Book")] ] it "executes JOIN with LIMIT" $ do rowsOf (parseStatement "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id LIMIT 2" >>= runStatement testDB) `shouldBe` Right [ [("u.name", VStr "Alice"), ("o.product", VStr "Book")] , [("u.name", VStr "Alice"), ("o.product", VStr "Cup")] ] it "returns Left when JOIN table not found" $ do runStatement testDB ( Select { selectCols = ["u.name"] , selectFrom = FromJoin (FromTable (Just "u") "users") (Just "x") "nonexistent" (Eq (Col "u.id") (Col "x.id")) , selectWhere = Nothing , selectOrderBy = [] , selectLimit = Nothing } ) `shouldSatisfy` isLeft it "returns Left when ON references an unknown column" $ do runStatement testDB ( Select { selectCols = ["u.name"] , selectFrom = FromJoin (FromTable (Just "u") "users") (Just "o") "orders" (Eq (Col "u.nope") (Col "o.user_id")) , selectWhere = Nothing , selectOrderBy = [] , selectLimit = Nothing } ) `shouldSatisfy` isLeft describe "ChuSQL end-to-end" $ do it "parses and executes a simple query" $ do rowsOf (parseStatement "SELECT name FROM users WHERE age > 18" >>= runStatement testDB) `shouldBe` Right [ [("name", VStr "Alice")] , [("name", VStr "Carol")] ] it "parses and executes a complex query" $ do rowsOf ( parseStatement "SELECT name FROM users WHERE age < 18 OR age > 28" >>= runStatement testDB ) `shouldBe` Right [ [("name", VStr "Bob")] , [("name", VStr "Carol")] ] it "returns Left when parsing fails" $ do (parseStatement "SELECT name FROM" >>= runStatement testDB) `shouldSatisfy` isLeft it "INSERT then SELECT end-to-end" $ do case parseStatement "INSERT INTO users (name, age) VALUES ('Dave', 22)" >>= runStatement testDB of Left err -> expectationFailure err Right (db', _) -> do rowsOf (parseStatement "SELECT name FROM users WHERE age > 18" >>= runStatement db') `shouldBe` Right [ [("name", VStr "Alice")] , [("name", VStr "Carol")] , [("name", VStr "Dave")] ] it "DELETE then SELECT end-to-end" $ do case parseStatement "DELETE FROM users WHERE age > 20" >>= runStatement testDB of Left err -> expectationFailure err Right (db', _) -> do rowsOf (parseStatement "SELECT name FROM users" >>= runStatement db') `shouldBe` Right [ [("name", VStr "Bob")] ] it "UPDATE then SELECT end-to-end" $ do case parseStatement "UPDATE users SET age = 99 WHERE name = 'Alice'" >>= runStatement testDB of Left err -> expectationFailure err Right (db', _) -> do rowsOf (parseStatement "SELECT name, age FROM users" >>= runStatement db') `shouldBe` Right [ [("name", VStr "Alice"), ("age", VInt 99)] , [("name", VStr "Bob"), ("age", VInt 17)] , [("name", VStr "Carol"), ("age", VInt 30)] ] it "ORDER BY with WHERE end-to-end" $ do rowsOf (parseStatement "SELECT name FROM users WHERE age > 18 ORDER BY age DESC" >>= runStatement testDB) `shouldBe` Right [ [("name", VStr "Carol")] , [("name", VStr "Alice")] ] it "ORDER BY with LIMIT end-to-end" $ do rowsOf (parseStatement "SELECT name FROM users ORDER BY age DESC LIMIT 2" >>= runStatement testDB) `shouldBe` Right [ [("name", VStr "Carol")] , [("name", VStr "Alice")] ] it "WHERE ORDER BY LIMIT end-to-end" $ do rowsOf (parseStatement "SELECT name FROM users WHERE age > 15 ORDER BY age DESC LIMIT 1" >>= runStatement testDB) `shouldBe` Right [ [("name", VStr "Carol")] ] it "JOIN with WHERE and ORDER BY end-to-end" $ do rowsOf (parseStatement "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id WHERE u.age > 15 ORDER BY o.product" >>= runStatement testDB) `shouldBe` Right [ [("u.name", VStr "Alice"), ("o.product", VStr "Book")] , [("u.name", VStr "Alice"), ("o.product", VStr "Cup")] , [("u.name", VStr "Bob"), ("o.product", VStr "Pen")] ] describe "ChuSQL.Algebra.Optimize" $ do it "keeps single-table WHERE results identical" $ do sameResultAsUnoptimized "SELECT name FROM users WHERE age > 18" it "keeps JOIN with WHERE results identical" $ do sameResultAsUnoptimized "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id WHERE u.age > 20" it "keeps JOIN with WHERE, ORDER BY and LIMIT results identical" $ do sameResultAsUnoptimized "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id WHERE u.age > 15 ORDER BY o.product DESC LIMIT 2" it "keeps SELECT * results identical" $ do sameResultAsUnoptimized "SELECT * FROM users" it "pushes a single-side predicate into the left side of a JOIN" $ do case parseStatement "SELECT u.name FROM users u JOIN orders o ON u.id = o.user_id WHERE u.age > 20" of Left err -> expectationFailure err Right q -> case translate q of Left err -> expectationFailure err Right relOp -> filterPushedIntoLeft (optimize testDB relOp) `shouldBe` True it "removes a redundant SELECT * projection" $ do case parseStatement "SELECT * FROM users" of Left err -> expectationFailure err Right q -> case translate q of Left err -> expectationFailure err Right relOp -> optimize testDB relOp `shouldBe` Scan Nothing "users" it "does not push a filter through LIMIT" $ do let cond = Gt (Col "age") (LitInt 18) relOp = Filter cond (Limit 2 (Scan Nothing "users")) optimize testDB relOp `shouldBe` relOp it "is idempotent after reaching a fixed point" $ do case parseStatement "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id WHERE u.age > 20" of Left err -> expectationFailure err Right q -> case translate q of Left err -> expectationFailure err Right relOp -> optimize testDB (optimize testDB relOp) `shouldBe` optimize testDB relOp it "folds a constant-false predicate into LitBool False" $ do fmap firstFilterCond (optimizedPlan "SELECT name FROM users WHERE 1 > 2") `shouldBe` Right (Just (LitBool False)) it "removes a filter whose predicate folds to true" $ do fmap anyFilter (optimizedPlan "SELECT name FROM users WHERE 1 = 1") `shouldBe` Right False it "removes a constant-true filter sitting above a join" $ do fmap anyFilter (optimizedPlan "SELECT u.name FROM users u JOIN orders o ON u.id = o.user_id WHERE 1 = 1") `shouldBe` Right False it "leaves a predicate that mentions a column untouched" $ do fmap firstFilterCond (optimizedPlan "SELECT name FROM users WHERE age > 18") `shouldBe` Right (Just (Gt (Col "age") (LitInt 18))) it "folds the constant part of a predicate that cannot fold as a whole" $ do fmap firstFilterCond (optimizedPlan "SELECT name FROM users WHERE age > 18 AND 1 = 1") `shouldBe` Right (Just (And (Gt (Col "age") (LitInt 18)) (LitBool True))) it "keeps a constant predicate that fails to evaluate" $ do fmap firstFilterCond (optimizedPlan "SELECT name FROM users WHERE 'abc' > 1") `shouldBe` Right (Just (Gt (LitStr "abc") (LitInt 1))) it "keeps constant-false results identical" $ do sameResultAsUnoptimized "SELECT name FROM users WHERE 1 > 2" it "keeps constant-true results identical" $ do sameResultAsUnoptimized "SELECT name FROM users WHERE 1 = 1" it "keeps mixed constant and column predicates identical" $ do sameResultAsUnoptimized "SELECT name FROM users WHERE age > 18 AND 1 = 1" it "keeps a failing constant predicate identical" $ do sameResultAsUnoptimized "SELECT name FROM users WHERE 'abc' > 1" it "returns no rows for a constant-false predicate" $ do rowsOf (parseStatement "SELECT name FROM users WHERE 1 > 2" >>= runStatement testDB) `shouldBe` Right [] it "returns every row for a constant-true predicate" $ do rowsOf (parseStatement "SELECT name FROM users WHERE 1 = 1" >>= runStatement testDB) `shouldBe` Right [ [("name", VStr "Alice")] , [("name", VStr "Bob")] , [("name", VStr "Carol")] ] it "keeps the LIMIT node while pushing projection past it" $ do let plan = Project ["name"] (Limit 2 (Scan Nothing "users")) stripProjects (pushProject testDB ["*"] plan) `shouldBe` stripProjects plan it "keeps the sort keys while pushing projection past a sort" $ do let plan = Project ["name"] (Sort [("age", Desc)] (Scan Nothing "users")) stripProjects (pushProject testDB ["*"] plan) `shouldBe` stripProjects plan it "keeps both sides of a join" $ do let plan = Project ["u.name"] ( Join (Scan (Just "u") "users") (Scan (Just "o") "orders") (Eq (Col "u.id") (Col "o.user_id")) ) stripProjects (pushProject testDB ["*"] plan) `shouldBe` stripProjects plan it "keeps nested projections in place" $ do let plan = Project ["name"] (Project ["name", "age"] (Scan Nothing "users")) stripProjects (pushProject testDB ["*"] plan) `shouldBe` stripProjects plan it "keeps the whole spine of a full pipeline" $ do let plan = Project ["name"] ( Limit 2 ( Sort [("age", Desc)] (Filter (Gt (Col "age") (LitInt 18)) (Scan Nothing "users")) ) ) stripProjects (pushProject testDB ["*"] plan) `shouldBe` stripProjects plan it "merges two predicates pushed into the same side into one filter" $ do fmap leftSideFilters (optimizedPlan "SELECT u.name FROM users u JOIN orders o ON u.id = o.user_id WHERE u.age > 20 AND u.name = 'Alice'") `shouldBe` Right (Just 1) it "pushes projection into a single-table scan as one layer" $ do optimizedPlan "SELECT name FROM users" `shouldBe` Right (Project ["name"] (Scan Nothing "users")) it "does not add a projection when the scan already supplies every column" $ do optimizedPlan "SELECT id, name, age FROM users" `shouldBe` Right (Project ["id", "name", "age"] (Scan Nothing "users")) it "prunes the columns nobody needs on each side of a join" $ do fmap joinSideCols (projectedPlan "SELECT u.name FROM users u JOIN orders o ON u.id = o.user_id") `shouldBe` Right (Just ["u.name", "u.id"], Just ["o.user_id"]) it "does not prune anything when every column is taken" $ do fmap joinSideCols (projectedPlan "SELECT * FROM users u JOIN orders o ON u.id = o.user_id") `shouldBe` Right (Nothing, Nothing) it "activates projection pushdown inside optimize" $ do fmap joinSideCols (optimizedPlan "SELECT u.name FROM users u JOIN orders o ON u.id = o.user_id") `shouldBe` Right (Just ["u.name", "u.id"], Just ["o.user_id"]) it "keeps projection pushdown idempotent" $ do case projectedPlan "SELECT u.name FROM users u JOIN orders o ON u.id = o.user_id" of Left err -> expectationFailure err Right plan -> pushProject testDB ["*"] plan `shouldBe` plan it "keeps a join without WHERE results identical" $ do sameResultAsUnoptimized "SELECT u.name, o.product FROM users u JOIN orders o ON u.id = o.user_id" it "keeps projection with ORDER BY and LIMIT results identical" $ do sameResultAsUnoptimized "SELECT u.name FROM users u JOIN orders o ON u.id = o.user_id ORDER BY o.product DESC LIMIT 2" it "rewrites Filter id = k into Lookup" $ do fmap planRoot (optimizedPlan "SELECT name FROM users WHERE id = 2") `shouldBe` Right (Lookup Nothing "users" "id" 2) it "keeps Lookup result identical to unoptimized" $ do sameResultAsUnoptimized "SELECT name FROM users WHERE id = 2" it "rewrites an equality on any column into Lookup" $ do -- 能不能真走索引由存储层回答;优化器只负责说"这里可以点查" fmap planRoot (optimizedPlan "SELECT name FROM users WHERE age = 25") `shouldBe` Right (Lookup Nothing "users" "age" 25) it "keeps a point lookup on a non-indexed column identical to unoptimized" $ do -- 内存实现没有索引,这条会走"退回扫描"的分支 sameResultAsUnoptimized "SELECT name FROM users WHERE age = 25" it "keeps an aliased point lookup identical to unoptimized" $ do -- 别名要留住:回来的一行必须和 Scan 别名 表 长得一样,不然投影取不到列 sameResultAsUnoptimized "SELECT u.name FROM users u WHERE u.id = 1" it "returns the row for an aliased point lookup" $ do rowsOf (parseStatement "SELECT u.name FROM users u WHERE u.id = 1" >>= runStatement testDB) `shouldBe` Right [[("u.name", VStr "Alice")]] describe "ChuSQL.Semantic" $ do it "rejects an unknown column in WHERE" $ do (parseStatement "SELECT name FROM users WHERE nope > 18" >>= runStatement testDB) `shouldSatisfy` isLeft it "rejects an unknown column in WHERE even when the table is empty" $ do (parseStatement "SELECT name FROM users WHERE nope > 18" >>= runStatement emptyDB) `shouldSatisfy` isLeft it "rejects an unknown column in an ON condition" $ do (parseStatement "SELECT u.name FROM users u JOIN orders o ON u.nope = o.user_id" >>= runStatement testDB) `shouldSatisfy` isLeft it "rejects a type mismatch inside a comparison" $ do (parseStatement "SELECT name FROM users WHERE name > 18" >>= runStatement testDB) `shouldSatisfy` isLeft it "rejects a type mismatch even when the table is empty" $ do (parseStatement "SELECT name FROM users WHERE name > 18" >>= runStatement emptyDB) `shouldSatisfy` isLeft it "rejects a WHERE clause that is not a condition" $ do (parseStatement "SELECT name FROM users WHERE age" >>= runStatement testDB) `shouldSatisfy` isLeft it "rejects a non-boolean WHERE even when the table is empty" $ do (parseStatement "SELECT name FROM users WHERE age" >>= runStatement emptyDB) `shouldSatisfy` isLeft it "rejects comparing two different types with =" $ do (parseStatement "SELECT name FROM users WHERE name = 18" >>= runStatement testDB) `shouldSatisfy` isLeft it "rejects an unknown column in INSERT" $ do (parseStatement "INSERT INTO users (nickname) VALUES (1)" >>= runStatement testDB) `shouldSatisfy` isLeft it "rejects a value whose type does not match the column" $ do (parseStatement "INSERT INTO users (name, age) VALUES ('Dave', 'abc')" >>= runStatement testDB) `shouldSatisfy` isLeft it "rejects an unknown column in UPDATE SET" $ do (parseStatement "UPDATE users SET nope = 1" >>= runStatement testDB) `shouldSatisfy` isLeft it "rejects an unknown column in DELETE WHERE" $ do (parseStatement "DELETE FROM users WHERE nope > 1" >>= runStatement testDB) `shouldSatisfy` isLeft it "still accepts a valid query" $ do rowsOf (parseStatement "SELECT name FROM users WHERE age > 18" >>= runStatement testDB) `shouldBe` Right [ [("name", VStr "Alice")] , [("name", VStr "Carol")] ] it "rejects an UPDATE whose value has the wrong type" $ do (parseStatement "UPDATE users SET age = 'abc'" >>= runStatement testDB) `shouldSatisfy` isLeft it "rejects a type mismatch in an ON condition" $ do (parseStatement "SELECT u.name FROM users u JOIN orders o ON u.name = o.user_id" >>= runStatement testDB) `shouldSatisfy` isLeft it "rejects an unknown column in DELETE WHERE even when the table is empty" $ do (parseStatement "DELETE FROM users WHERE nope > 1" >>= runStatement emptyDB) `shouldSatisfy` isLeft it "rejects an unknown column in UPDATE SET even when the table is empty" $ do (parseStatement "UPDATE users SET nope = 1" >>= runStatement emptyDB) `shouldSatisfy` isLeft it "currently allows an INSERT that leaves a column out (known gap)" $ do (parseStatement "INSERT INTO users (name) VALUES ('Eve')" >>= runStatement testDB) `shouldSatisfy` isRight it "says which clause is wrong and which columns are available" $ do case parseStatement "SELECT name FROM users WHERE nope > 18" >>= runStatement testDB of Right _ -> expectationFailure "expected a Left" Left err -> do err `shouldContain` "unknown column in WHERE" err `shouldContain` "available: id, name, age" it "names INSERT when a target column does not exist" $ do case parseStatement "INSERT INTO users (nickname) VALUES (1)" >>= runStatement testDB of Right _ -> expectationFailure "expected a Left" Left err -> err `shouldContain` "unknown column in INSERT" it "names ORDER BY when a sort key does not exist" $ do case parseStatement "SELECT name FROM users ORDER BY nope" >>= runStatement testDB of Right _ -> expectationFailure "expected a Left" Left err -> err `shouldContain` "unknown column in ORDER BY" it "names ON and both types when a join condition mismatches" $ do case parseStatement "SELECT u.name FROM users u JOIN orders o ON u.name = o.user_id" >>= runStatement testDB of Right _ -> expectationFailure "expected a Left" Left err -> do err `shouldContain` "ON: both sides of =" err `shouldContain` "TStr and TInt" it "names the column and the expected type when an assignment has the wrong type" $ do case parseStatement "UPDATE users SET age = 'abc'" >>= runStatement testDB of Right _ -> expectationFailure "expected a Left" Left err -> err `shouldContain` "UPDATE: column age needs TInt, got TStr" it "accepts SELECT * across a join (the sentinel is not a column)" $ do (parseStatement "SELECT * FROM users u JOIN orders o ON u.id = o.user_id" >>= runStatement testDB) `shouldSatisfy` isRight describe "ChuSQL.Algebra.Op" $ do it "renders a plan as indented text" $ do case parseStatement "SELECT name FROM users WHERE age > 18" >>= translate of Left err -> expectationFailure err Right plan -> renderPlan plan `shouldBe` "Project [\"name\"]\n Filter Gt (Col \"age\") (LitInt 18)\n Scan Nothing \"users\"" it "renders a join plan with indentation" $ do case parseStatement "SELECT u.name FROM users u JOIN orders o ON u.id = o.user_id" >>= translate of Left err -> expectationFailure err Right plan -> lines (renderPlan plan) `shouldBe` [ "Project [\"u.name\"]" , " Join on Eq (Col \"u.id\") (Col \"o.user_id\")" , " Scan Just \"u\" \"users\"" , " Scan Just \"o\" \"orders\"" ] it "renders a sort and limit plan" $ do case parseStatement "SELECT name FROM users ORDER BY age DESC LIMIT 2" >>= translate of Left err -> expectationFailure err Right plan -> lines (renderPlan plan) `shouldBe` [ "Project [\"name\"]" , " Limit 2" , " Sort [(\"age\",Desc)]" , " Scan Nothing \"users\"" ] describe "ChuSQL.Storage.IPC" $ 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 () rows <- runIPCStorage (scan "users") (map sortRow <$> rows) `shouldBe` Right [sortRow row] it "scan on a missing table returns Left" $ do withTestServer $ \srv -> withServerEnv srv $ do result <- runIPCStorage (scan "no_such_table") result `shouldSatisfy` isLeft 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] rows <- runIPCStorage (scan "many") fmap length rows `shouldBe` Right 20 fmap (sortOn show . map (lookup "id")) rows `shouldBe` Right (sortOn show (map (Just . VInt) [1 .. 20])) it "replaceAll leaves only the new rows" $ do withTestServer $ \srv -> withServerEnv srv $ do runIPCStorage (insert "t" [("id", VInt 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 `shouldBe` Right (sortOn show [Just (VInt 9), Just (VInt 8)]) it "lookupByColumn 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 () found <- runIPCStorage (lookupByColumn "keyed" "id" 7) fmap sortRow (indexRow found) `shouldBe` Just (sortRow row) missing <- runIPCStorage (lookupByColumn "keyed" "id" 8) missing `shouldBe` Right (IndexRow Nothing) it "replaceAll rebuilds the index over the pipe" $ do withTestServer $ \srv -> withServerEnv srv $ do runIPCStorage (insert "rb" [("id", VInt 1)]) `shouldReturn` Right () runIPCStorage (replaceAll "rb" [[("id", VInt 9), ("name", VStr "Zoe")]]) `shouldReturn` Right () old <- runIPCStorage (lookupByColumn "rb" "id" 1) old `shouldBe` Right (IndexRow Nothing) new <- runIPCStorage (lookupByColumn "rb" "id" 9) fmap sortRow (indexRow new) `shouldBe` Just (sortRow [("id", VInt 9), ("name", VStr "Zoe")]) 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 () db <- runIPCStorage snapshot map fst db `shouldBe` ["a", "b"] map (length . tableRows . snd) db `shouldBe` [1, 1] map (map (lookup "id") . tableRows . snd) db `shouldBe` [[Just (VInt 1)], [Just (VInt 2)]] 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 () doListTables `shouldReturn` Right ["t1", "t2"] it "rows survive a restart on the same data directory" $ do located <- locateServer case located of Left err -> pendingWith err Right bin -> do srv1 <- startServer bin let dir = dataDir srv1 withServerEnv srv1 $ runIPCStorage (insert "persist" [("id", VInt 42)]) `shouldReturn` Right () stopServer srv1 srv2 <- startServerAt bin dir rows <- withServerEnv srv2 $ runIPCStorage (scan "persist") stopServer srv2 cleanServerDir srv1 (map sortRow <$> rows) `shouldBe` Right [sortRow [("id", VInt 42)]] it "a missing server yields Left without throwing" $ 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 "CREATE INDEX makes a query on that column use the index" $ do withTestServer $ \srv -> withServerEnv srv $ do _ <- runIPCStorage (runStatementM (CreateTable "ix_t" [("id", TInt), ("code", TInt)])) _ <- runIPCStorage ( runStatementM (Insert "ix_t" ["id", "code"] [[LitInt 1, LitInt 500], [LitInt 2, LitInt 501]]) ) -- 还没建索引:存储层明确回"我帮不上忙",上层会退回扫描 withoutIndex <- runIPCStorage (lookupByColumn "ix_t" "code" 501) withoutIndex `shouldBe` Right NoIndex scanned <- runIPCStorage (runStatementM (makeSelect ["code"] "ix_t" (Just (Eq (Col "code") (LitInt 501))))) scanned `shouldBe` Right [[("code", VInt 501)]] -- 建索引之后就真的走索引了 created <- runIPCStorage (runStatementM (CreateIndex "ix_t" "code")) created `shouldBe` Right [] withIndex <- runIPCStorage (lookupByColumn "ix_t" "code" 501) fmap sortRow (indexRow withIndex) `shouldBe` Just (sortRow [("id", VInt 2), ("code", VInt 501)]) indexed <- runIPCStorage (runStatementM (makeSelect ["code"] "ix_t" (Just (Eq (Col "code") (LitInt 501))))) indexed `shouldBe` Right [[("code", VInt 501)]] -- 建完索引之后插入的行也要进索引 _ <- runIPCStorage (runStatementM (Insert "ix_t" ["id", "code"] [[LitInt 3, LitInt 502]])) fresh <- runIPCStorage (lookupByColumn "ix_t" "code" 502) fmap sortRow (indexRow fresh) `shouldBe` Just (sortRow [("id", VInt 3), ("code", VInt 502)]) it "CREATE INDEX over the pipe rejects a column with duplicates" $ do withTestServer $ \srv -> withServerEnv srv $ do _ <- runIPCStorage (runStatementM (CreateTable "dup_ix" [("id", TInt), ("age", TInt)])) _ <- runIPCStorage ( runStatementM (Insert "dup_ix" ["id", "age"] [[LitInt 1, LitInt 30], [LitInt 2, LitInt 30]]) ) res <- runIPCStorage (runStatementM (CreateIndex "dup_ix" "age")) res `shouldSatisfy` isLeft it "DELETE removes only the matching rows over the pipe" $ do withTestServer $ \srv -> withServerEnv srv $ do _ <- runIPCStorage (runStatementM (CreateTable "del_t" [("id", TInt), ("name", TStr)])) _ <- runIPCStorage ( runStatementM ( Insert "del_t" ["id", "name"] [[LitInt 1, LitStr "A"], [LitInt 2, LitStr "B"], [LitInt 3, LitStr "C"]] ) ) _ <- runIPCStorage (runStatementM (Delete "del_t" (Just (Eq (Col "id") (LitInt 2))))) rows <- runIPCStorage (runStatementM (makeSelect ["name"] "del_t" Nothing)) rows `shouldBe` Right [[("name", VStr "A")], [("name", VStr "C")]] gone <- runIPCStorage (lookupByColumn "del_t" "id" 2) gone `shouldBe` Right (IndexRow Nothing) it "multi-row INSERT goes over the pipe in one statement" $ do withTestServer $ \srv -> withServerEnv srv $ do _ <- runIPCStorage (runStatementM (CreateTable "many_t" [("id", TInt)])) _ <- runIPCStorage ( runStatementM (Insert "many_t" ["id"] [[LitInt i] | i <- [1 .. 50]]) ) rows <- runIPCStorage (runStatementM (makeSelect ["id"] "many_t" Nothing)) fmap length rows `shouldBe` Right 50 it "parses CREATE TABLE with two columns" $ do parseStatement "CREATE TABLE users (id INT, name TEXT)" `shouldBe` Right (CreateTable "users" [("id", TInt), ("name", TStr)]) it "parses CREATE TABLE case-insensitively" $ do parseStatement "create table users (id int, name text)" `shouldBe` Right (CreateTable "users" [("id", TInt), ("name", TStr)]) it "parses CREATE TABLE with BOOL column" $ do parseStatement "CREATE TABLE t (flag BOOL)" `shouldBe` Right (CreateTable "t" [("flag", TBool)]) it "parses CREATE TABLE with VARCHAR as TStr" $ do parseStatement "CREATE TABLE t (name VARCHAR)" `shouldBe` Right (CreateTable "t" [("name", TStr)]) it "parses CREATE TABLE with INTEGER" $ do parseStatement "CREATE TABLE t (id INTEGER)" `shouldBe` Right (CreateTable "t" [("id", TInt)]) it "rejects CREATE TABLE without columns" $ do parseStatement "CREATE TABLE t ()" `shouldSatisfy` isLeft it "rejects CREATE TABLE with missing type" $ do parseStatement "CREATE TABLE t (id)" `shouldSatisfy` isLeft describe "ChuSQL.Engine (CREATE TABLE)" $ do it "creates a table in memory" $ do case runStatement testDB (CreateTable "newt" [("id", TInt), ("name", TStr)]) of Left err -> expectationFailure err Right (db', _) -> do rowsOf (runStatement db' (makeSelect ["*"] "newt" Nothing)) `shouldBe` Right [] it "rejects creating an existing table" $ do runStatement testDB (CreateTable "users" [("id", TInt)]) `shouldSatisfy` isLeft it "rejects duplicate column names" $ do runStatement testDB (CreateTable "dup" [("id", TInt), ("id", TStr)]) `shouldSatisfy` isLeft it "rejects empty column list at parse time" $ do parseStatement "CREATE TABLE t ()" `shouldSatisfy` isLeft it "parses DROP TABLE" $ do parseStatement "DROP TABLE users" `shouldBe` Right (DropTable "users") it "drops a table in memory" $ do case runStatement testDB (DropTable "users") of Left e -> expectationFailure e Right (db', _) -> do runStatement db' (makeSelect ["*"] "users" Nothing) `shouldSatisfy` isLeft it "rejects dropping a nonexistent table" $ do runStatement testDB (DropTable "nope") `shouldSatisfy` isLeft emptyDB :: Database emptyDB = [(n, t{tableRows = []}) | (n, t) <- testDB] data IPCServer = IPCServer { pipeName :: String , dataDir :: FilePath , processHandle :: ProcessHandle } locateServer :: IO (Either String FilePath) locateServer = do mdir <- firstDir [".." "chusql-storage", "chusql-storage"] case mdir of Nothing -> pure (Left "chusql-storage directory not found (run these tests inside the repository)") Just dir -> do built <- try (createProcess (proc "cargo" ["build", "--bin", "server"]){cwd = Just dir, std_out = NoStream, std_err = NoStream}) :: IO (Either IOException (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)) case built of Left e -> pure (Left ("cannot run cargo (Rust is required for the IPC tests): " ++ show e)) Right (_, _, _, ph) -> do ec <- waitForProcess ph case ec of ExitFailure n -> pure (Left ("cargo build --bin server failed with exit code " ++ show n)) ExitSuccess -> do found <- firstExisting [dir "target" "debug" "server.exe", dir "target" "debug" "server"] pure (maybe (Left "cargo build finished but no server executable was found") Right found) where firstDir [] = pure Nothing firstDir (d : ds) = do ok <- doesDirectoryExist d if ok then pure (Just d) else firstDir ds firstExisting [] = pure Nothing firstExisting (p : ps) = do ok <- doesFileExist p if ok then pure (Just p) else firstExisting ps startServer :: FilePath -> IO IPCServer startServer bin = do stamp <- uniqueStamp tmp <- getTemporaryDirectory let dir = tmp "chusql-hs-IPC" stamp createDirectoryIfMissing True dir startServerAt bin dir startServerAt :: FilePath -> FilePath -> IO IPCServer startServerAt bin dir = do stamp <- uniqueStamp let name = "chusql-hs-test-" ++ stamp parentEnv <- getEnvironment (_, _, _, ph) <- createProcess (proc bin []) { env = Just (("CHUSQL_PIPE", name) : ("CHUSQL_DATA_DIR", dir) : parentEnv) , std_out = NoStream , std_err = NoStream } let srv = IPCServer name dir ph 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) case probe of Right RespPong -> pure () _ | tries > 0 -> threadDelay 50000 >> waitUntilReady srv (tries - 1) Right _ -> ioError (userError "server is up but ping did not answer pong") Left e -> ioError e stopServer :: IPCServer -> IO () stopServer srv = do _ <- try (terminateProcess (processHandle srv)) :: IO (Either IOException ()) _ <- try (waitForProcess (processHandle srv)) :: IO (Either IOException ExitCode) pure () cleanServerDir :: IPCServer -> IO () cleanServerDir srv = do _ <- try (removePathForcibly (dataDir srv)) :: IO (Either IOException ()) pure () withTestServer :: (IPCServer -> IO ()) -> IO () withTestServer act = do located <- locateServer case located of Left err | "cannot run cargo" `isInfixOf` err -> pendingWith err | otherwise -> expectationFailure err Right bin -> bracket (startServer bin) (\s -> stopServer s >> cleanServerDir s) act withServerEnv :: IPCServer -> IO a -> IO a withServerEnv srv act = do oldPipe <- lookupEnv "CHUSQL_PIPE" oldDir <- lookupEnv "CHUSQL_DATA_DIR" setEnv "CHUSQL_PIPE" (pipeName srv) setEnv "CHUSQL_DATA_DIR" (dataDir srv) act `finally` do restore "CHUSQL_PIPE" oldPipe restore "CHUSQL_DATA_DIR" oldDir where restore k = maybe (unsetEnv k) (setEnv k) withPipeName :: String -> IO a -> IO a withPipeName name act = do old <- lookupEnv "CHUSQL_PIPE" setEnv "CHUSQL_PIPE" name r <- act maybe (unsetEnv "CHUSQL_PIPE") (setEnv "CHUSQL_PIPE") old pure r sortRow :: Row -> Row sortRow = sortOn fst -- | 从一次索引点查的结果里取出那一行(没索引、没查到都给 Nothing) indexRow :: Either String IndexResult -> Maybe Row indexRow (Right (IndexRow r)) = r indexRow _ = Nothing isLeft :: Either a b -> Bool isLeft (Left _) = True isLeft (Right _) = False isRight :: Either a b -> Bool isRight (Right _) = True isRight (Left _) = False sameResultAsUnoptimized :: String -> Expectation sameResultAsUnoptimized sql = case parseStatement sql of Left err -> expectationFailure err Right q -> case translate q of Left err -> expectationFailure err Right relOp -> evalRelOp testDB (optimize testDB relOp) `shouldBe` evalRelOp testDB relOp filterPushedIntoLeft :: RelOp -> Bool filterPushedIntoLeft (Project _ (Join (Filter _ _) _ _)) = True filterPushedIntoLeft _ = False optimizedPlan :: String -> Either String RelOp optimizedPlan sql = do q <- parseStatement sql optimize testDB <$> translate q firstFilterCond :: RelOp -> Maybe Expr firstFilterCond (Filter p _) = Just p firstFilterCond (Project _ x) = firstFilterCond x firstFilterCond (Sort _ x) = firstFilterCond x firstFilterCond (Limit _ x) = firstFilterCond x firstFilterCond (Join l r _) = case firstFilterCond l of Just p -> Just p Nothing -> firstFilterCond r firstFilterCond (Scan _ _) = Nothing firstFilterCond (Lookup _ _ _ _) = Nothing anyFilter :: RelOp -> Bool anyFilter (Filter _ _) = True anyFilter (Project _ x) = anyFilter x anyFilter (Sort _ x) = anyFilter x anyFilter (Limit _ x) = anyFilter x anyFilter (Join l r _) = anyFilter l || anyFilter r anyFilter (Scan _ _) = False anyFilter (Lookup _ _ _ _) = False stripProjects :: RelOp -> RelOp stripProjects (Project _ x) = stripProjects x stripProjects (Filter p x) = Filter p (stripProjects x) stripProjects (Sort spec x) = Sort spec (stripProjects x) stripProjects (Limit n x) = Limit n (stripProjects x) stripProjects (Join l r c) = Join (stripProjects l) (stripProjects r) c stripProjects (Scan a t) = Scan a t stripProjects (Lookup a t c k) = Lookup a t c k projectedPlan :: String -> Either String RelOp projectedPlan sql = do q <- parseStatement sql plan <- translate q Right (pushProject testDB ["*"] plan) sideCols :: RelOp -> Maybe [String] sideCols (Project cols _) = Just cols sideCols _ = Nothing joinSideCols :: RelOp -> (Maybe [String], Maybe [String]) joinSideCols (Project _ (Join l r _)) = (sideCols l, sideCols r) joinSideCols _ = (Nothing, Nothing) countFilters :: RelOp -> Int countFilters (Filter _ x) = 1 + countFilters x countFilters _ = 0 leftSideFilters :: RelOp -> Maybe Int leftSideFilters (Project _ (Join l _ _)) = Just (countFilters l) leftSideFilters _ = Nothing planRoot :: RelOp -> RelOp planRoot (Project _ x) = planRoot x planRoot x = x