ChuBlog/chusql-server/test/Spec.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}

module Main (main) where

import ChuSQL.Core.Engine.Storage.IPC (
    Account (..),
    Request (ReqAccountReset, ReqAccountsList),
    TableInfo (..),
    closeConnection,
    localStorageLink,
    setStorageLink,
 )
import ChuSQL.Core.Engine.Syntax.AST (Statement)
import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
import ChuSQL.Core.Model (Database, Histogram (..), Row, Table (..), Value (..), pattern TInt, pattern TStr)
import ChuSQL.Interface.Auth (hashPasswordWith)
import ChuSQL.Interface.Protocol (ClientRequest (..), Grant (..), RoleView (..), ServerResponse (..), decodeRequest, encodeResponse)
import ChuSQL.Interface.RateLimit (newRateLimiter)
import ChuSQL.Server.Accounts (Principal (..), ensureRootAccount)
import ChuSQL.Server.Backend (Backend (..), StatementResult (..), ipcBackend, memoryBackend)
import ChuSQL.Server.Privileges (
    PrivilegeCommand (..),
    PrivilegeError (..),
    Privileges,
    affectedAccounts,
    authorize,
    listRoleViews,
    newPrivileges,
    runPrivilegeCommand,
 )
import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), newSession, runStatementCoded)
import ChuSQL.Server.TCP (
    ServerConfig (..),
    ServerEnv,
    ServerHandle (..),
    defaultServerConfig,
    loadServerConfigAt,
    newServerEnv,
    startServer,
 )
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
import Control.Exception (IOException, bracket, finally, try)
import Control.Monad (void)
import Data.Aeson (decode)
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BL
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Time.Clock (getCurrentTime)
import Network.Socket (
    AddrInfo (..),
    SocketType (Stream),
    addrAddress,
    addrFamily,
    connect,
    defaultHints,
    defaultProtocol,
    getAddrInfo,
    socket,
    socketToHandle,
    withSocketsDo,
 )
import System.Directory (createDirectoryIfMissing, doesFileExist, getTemporaryDirectory, removeFile, removePathForcibly)
import System.FilePath ((</>))
import System.IO (
    BufferMode (LineBuffering),
    Handle,
    IOMode (ReadWriteMode),
    hClose,
    hFlush,
    hIsEOF,
    hSetBuffering,
    hSetNewlineMode,
    noNewlineTranslation,
 )
import System.Timeout (timeout)
import Test.Hspec hiding (after, before)

-- TCP 服务器测试：协议编解码、配置读取与真连服务器的端到端用例。

-- | 测试入口
main :: IO ()
main = hspec spec

-- | 全部用例
spec :: Spec
spec = do
    tcpSpec
    tcpServerSpec
    privilegeSpec
    transactionSpec
    ipcConcurrencySpec
    identitySpec

-- | 身份属性与权限边界的端到端测试
identitySpec :: Spec
identitySpec = describe "unified identities" $ do
    it "lets catalog managers manage ordinary identities without gaining superuser" $ withTcpServer defaultServerConfig $ \_ handle ->
        withConnection handle $ \admin -> withConnection handle $ \manager -> do
            _ <- tcpLogin admin "admin" "s3cret"
            _ <- tcpQuery admin "create user manager identified by 'Worker-Pass123!'"
            changed <- tcpQuery admin "alter user manager system_catalog_manager"
            asText (at "status" changed) `shouldBe` "result"
            signed <- tcpLogin manager "manager" "Worker-Pass123!"
            asBool (at "admin" signed) `shouldBe` False
            created <- tcpQuery manager "create user managed identified by 'Worker-Pass123!'"
            asText (at "status" created) `shouldBe` "result"
            shown <- tcpQuery manager "show roles"
            asText (at "status" shown) `shouldBe` "result"
            switched <- tcpQuery manager "use system"
            asText (at "status" switched) `shouldBe` "result"
            mapM_ (\sql -> tcpQuery manager sql >>= \reply -> asText (at "code" reply) `shouldBe` "forbidden")
                ["alter user manager superuser", "alter user managed system_catalog_manager", "alter user admin identified by 'Another-Pass123!'", "create database forbidden"]
    it "does not inherit catalog management through role membership" $ withTcpServer defaultServerConfig $ \_ handle ->
        withConnection handle $ \admin -> withConnection handle $ \worker -> do
            _ <- tcpLogin admin "admin" "s3cret"
            _ <- tcpQuery admin "create user worker identified by 'Worker-Pass123!'"
            _ <- tcpQuery admin "create role catalog_admin"
            _ <- tcpQuery admin "alter role catalog_admin system_catalog_manager"
            _ <- tcpQuery admin "grant catalog_admin to worker"
            _ <- tcpLogin worker "worker" "Worker-Pass123!"
            denied <- tcpQuery worker "create user elevated identified by 'Worker-Pass123!'"
            asText (at "code" denied) `shouldBe` "forbidden"
    it "shares names and shows safe identity attributes" $ withTcpServer defaultServerConfig $ \_ handle ->
        withConnection handle $ \h -> do
            _ <- tcpLogin h "admin" "s3cret"
            _ <- tcpQuery h "create role reader"
            conflict <- tcpQuery h "create user reader identified by 'Worker-Pass123!'"
            asText (at "code" conflict) `shouldBe` "conflict"
            _ <- tcpQuery h "create user alice identified by 'Worker-Pass123!'"
            other <- tcpQuery h "create role alice"
            asText (at "code" other) `shouldBe` "conflict"
            shown <- tcpQuery h "show roles"
            map asText (items (at "columns" shown)) `shouldBe` ["id", "name", "can_login", "is_superuser", "enabled", "system_catalog_manager", "created_at"]
            asInt (at "rowCount" shown) `shouldBe` 3
            reader <- tcpQuery h "alter role reader login nologin"
            asText (at "code" reader) `shouldBe` "bad_request"
    it "turns a role into a login identity and promotes by attribute" $ withTcpServer defaultServerConfig $ \_ handle ->
        withConnection handle $ \admin -> withConnection handle $ \worker -> do
            _ <- tcpLogin admin "admin" "s3cret"
            _ <- tcpQuery admin "create role worker"
            _ <- tcpQuery admin "alter role worker identified by 'Worker-Pass123!'"
            denied <- tcpLogin worker "worker" "Worker-Pass123!"
            asText (at "status" denied) `shouldBe` "error"
            changed <- tcpQuery admin "alter role worker login superuser"
            asText (at "status" changed) `shouldBe` "result"
            allowed <- tcpLogin worker "worker" "Worker-Pass123!"
            asBool (at "admin" allowed) `shouldBe` True
            created <- tcpQuery worker "create role managed"
            asText (at "status" created) `shouldBe` "result"
    it "does not inherit the superuser attribute through membership" $ withTcpServer defaultServerConfig $ \_ handle ->
        withConnection handle $ \admin -> withConnection handle $ \alice -> do
            _ <- tcpLogin admin "admin" "s3cret"
            _ <- tcpQuery admin "create user alice identified by 'Worker-Pass123!'"
            _ <- tcpQuery admin "create role powerful"
            _ <- tcpQuery admin "alter role powerful superuser"
            _ <- tcpQuery admin "grant powerful to alice"
            signed <- tcpLogin alice "alice" "Worker-Pass123!"
            asBool (at "admin" signed) `shouldBe` False
            denied <- tcpQuery alice "create role elevated"
            asText (at "code" denied) `shouldBe` "forbidden"
    it "treats a demoted configured administrator as ordinary" $ withTcpServer defaultServerConfig $ \_ handle ->
        withConnection handle $ \admin -> do
            _ <- tcpLogin admin "admin" "s3cret"
            _ <- tcpQuery admin "create user owner identified by 'Worker-Pass123!'"
            _ <- tcpQuery admin "alter user owner superuser"
            demoted <- tcpQuery admin "alter user admin nosuperuser"
            asText (at "status" demoted) `shouldBe` "result"
            withConnection handle $ \fresh -> do
                signed <- tcpLogin fresh "admin" "s3cret"
                asBool (at "admin" signed) `shouldBe` False
                denied <- tcpQuery fresh "show roles"
                asText (at "code" denied) `shouldBe` "forbidden"
    it "protects the last enabled login superuser" $ withTcpServer defaultServerConfig $ \_ handle ->
        withConnection handle $ \h -> do
            _ <- tcpLogin h "admin" "s3cret"
            mapM_ (\sql -> tcpQuery h sql >>= \reply -> asText (at "code" reply) `shouldBe` "bad_request")
                ["alter user admin disabled", "alter role admin nologin", "alter user admin nosuperuser", "drop user admin", "drop role admin"]
            shown <- tcpQuery h "show roles"
            asText (at "status" shown) `shouldBe` "result"
    it "stops disabled role inheritance and disconnects its members" $ withTcpServer defaultServerConfig $ \_ handle ->
        withConnection handle $ \admin -> withConnection handle $ \alice -> do
            _ <- tcpLogin admin "admin" "s3cret"
            _ <- tcpQuery admin "use test"
            _ <- tcpQuery admin "create user alice identified by 'Worker-Pass123!'"
            _ <- tcpQuery admin "create role reader"
            _ <- tcpQuery admin "grant select on users to reader"
            _ <- tcpQuery admin "grant reader to alice"
            _ <- tcpLogin alice "alice" "Worker-Pass123!"
            _ <- tcpQuery alice "use test"
            before <- tcpQuery alice "select * from users"
            asText (at "status" before) `shouldBe` "result"
            changed <- tcpQuery admin "alter role reader disabled"
            asText (at "status" changed) `shouldBe` "result"
            refused <- tcpQuery alice "use test"
            asText (at "code" refused) `shouldBe` "unauthorized"
            tcpClosed alice
            withConnection handle $ \fresh -> do
                _ <- tcpLogin fresh "alice" "Worker-Pass123!"
                _ <- tcpQuery fresh "use test"
                after <- tcpQuery fresh "select * from users"
                asText (at "code" after) `shouldBe` "forbidden"
                escalation <- tcpQuery fresh "alter user alice superuser"
                asText (at "code" escalation) `shouldBe` "forbidden"
    it "disables login identities and invalidates their connections" $ withTcpServer defaultServerConfig $ \_ handle ->
        withConnection handle $ \admin -> withConnection handle $ \alice -> do
            _ <- tcpLogin admin "admin" "s3cret"
            _ <- tcpQuery admin "create user alice identified by 'Worker-Pass123!'"
            _ <- tcpLogin alice "alice" "Worker-Pass123!"
            _ <- tcpQuery admin "alter user alice disabled"
            refused <- tcpQuery alice "use test"
            asText (at "code" refused) `shouldBe` "unauthorized"
            tcpClosed alice
            withConnection handle $ \fresh -> do
                denied <- tcpLogin fresh "alice" "Worker-Pass123!"
                asText (at "status" denied) `shouldBe` "error"
                _ <- tcpQuery admin "alter user alice enabled"
                allowed <- tcpLogin fresh "alice" "Worker-Pass123!"
                asText (at "status" allowed) `shouldBe` "ok"
    it "does not reuse dropped identity ids or permissions" $ withTcpServer defaultServerConfig $ \_ handle ->
        withConnection handle $ \admin -> do
            _ <- tcpLogin admin "admin" "s3cret"
            _ <- tcpQuery admin "use test"
            _ <- tcpQuery admin "create user alice identified by 'Worker-Pass123!'"
            _ <- tcpQuery admin "grant select on users to alice"
            before <- tcpQuery admin "show roles"
            _ <- tcpQuery admin "drop user alice"
            _ <- tcpQuery admin "create user alice identified by 'Worker-Pass123!'"
            after <- tcpQuery admin "show roles"
            at "rows" after `shouldNotBe` at "rows" before
            withConnection handle $ \alice -> do
                _ <- tcpLogin alice "alice" "Worker-Pass123!"
                _ <- tcpQuery alice "use test"
                denied <- tcpQuery alice "select * from users"
                asText (at "code" denied) `shouldBe` "forbidden"

-- 夹具：内存后端装在 MVar 里，跟 Web 测试同一套表

-- | 夹具库名
testDatabaseName :: String
testDatabaseName = "test"

-- | users 5 行 + orders 1 行
testDb :: Database
testDb =
    [ ( "users"
      , Table
            "users"
            [("id", TInt), ("name", TStr), ("age", TInt)]
            [ [("id", VInt i), ("name", VStr ("user" ++ show i)), ("age", VInt (20 + i))]
            | i <- [1 .. 5]
            ]
            Nothing
      )
    , ( "orders"
      , Table
            "orders"
            [("id", TInt), ("user_id", TInt)]
            [[("id", VInt 1), ("user_id", VInt 1)]]
            Nothing
      )
    ]

-- | 测试管理员名字
testRootName :: Text
testRootName = "admin"

-- | 测试管理员口令
testRootPassword :: Text
testRootPassword = "s3cret"

-- | 口令哈希：迭代次数压低，跑得快
testPasswordHash :: Text -> Text
testPasswordHash raw = hashPasswordWith 1000 (BS.replicate 16 7) raw

-- 小工具

-- | 取字段
field :: Text -> A.Value -> Maybe A.Value
field name (A.Object o) = KM.lookup (K.fromText name) o
field _ _ = Nothing

-- | 取字段（没有给 Null）
at :: Text -> A.Value -> A.Value
at name value = fromMaybe A.Null (field name value)

-- | 当数组看
items :: A.Value -> [A.Value]
items (A.Array xs) = V.toList xs
items _ = []

-- | 当文本看
asText :: A.Value -> Text
asText (A.String t) = t
asText _ = ""

-- | 当整数看
asInt :: A.Value -> Int
asInt (A.Number n) = round n
asInt _ = -1

-- | JSON 当布尔看
asBool :: A.Value -> Bool
asBool (A.Bool b) = b
asBool _ = False

-- | 第 i 个元素（越界给 Nothing，不用 `!!`）
nth :: Int -> [a] -> Maybe a
nth i xs = case drop i xs of
    (x : _) -> Just x
    [] -> Nothing

-- | 临时 TOML
tcpConfigPath :: String -> IO FilePath
tcpConfigPath name = do
    tmp <- getTemporaryDirectory
    pure (tmp </> ("chusql-server-test-" ++ name ++ ".toml"))

-- | 临时设置文件（新会话读口令策略用）
tempSettingsPath :: String -> IO FilePath
tempSettingsPath name = do
    tmp <- getTemporaryDirectory
    pure (tmp </> ("chusql-server-test-" ++ name ++ "-settings.json"))

-- | 文件不存在也算成功
removeIfExists :: FilePath -> IO ()
removeIfExists path = do
    there <- doesFileExist path
    if there then void (try (removeFile path) :: IO (Either IOException ())) else pure ()

-- | 起一台内存后端的测试服务器：管理员已设口令 `s3cret`
withTcpServer :: ServerConfig -> (ServerEnv -> ServerHandle -> IO a) -> IO a
withTcpServer = withTcpServerAs (Just testRootPassword)

-- | 起内存后端测试服务器；Nothing 表示首启未设口令
withTcpServerAs :: Maybe Text -> ServerConfig -> (ServerEnv -> ServerHandle -> IO a) -> IO a
withTcpServerAs password config body = do
    db <- newMVar testDb
    limiter <- newRateLimiter getCurrentTime 50 300
    path <- tempSettingsPath "tcp-server"
    removeIfExists path
    let backend = memoryBackend testDatabaseName db
    _ <- ensureRootAccount backend testRootName
    case password of
        Nothing -> pure ()
        Just raw -> void (beAccounts backend (ReqAccountReset testRootName (testPasswordHash raw)))
    env <- newServerEnv backend testRootName path config{scPort = 0} limiter
    handle <- startServer env
    body env handle `finally` shStop handle

-- | 连上服务器并配成行缓冲句柄
withConnection :: ServerHandle -> (Handle -> IO a) -> IO a
withConnection handle body = bracket open closeQuietly body
  where
    -- | 关连接，忽略异常
    closeQuietly h = do
        _ <- try (hClose h) :: IO (Either IOException ())
        pure ()
    -- | 建连接并配成行缓冲句柄
    open = withSocketsDo $ do
        infos <- getAddrInfo (Just defaultHints{addrSocketType = Stream}) (Just "127.0.0.1") (Just (show (shPort handle)))
        info <- case infos of
            (i : _) -> pure i
            [] -> ioError (userError "cannot resolve the test server address")
        sock <- socket (addrFamily info) Stream defaultProtocol
        connect sock (addrAddress info)
        h <- socketToHandle sock ReadWriteMode
        hSetBuffering h LineBuffering
        hSetNewlineMode h noNewlineTranslation
        pure h

-- | 发一行收一行；服务器不回话就判失败，别把用例挂死
tcpTalk :: Handle -> BS.ByteString -> IO A.Value
tcpTalk h raw = do
    BSC.hPutStr h raw
    BSC.hPutStr h "\n"
    hFlush h
    line <- timeout (5 * 1000000) (BSC.hGetLine h)
    case line of
        Just got -> pure (fromMaybe A.Null (decode (BL.fromStrict got)))
        Nothing -> do
            expectationFailure "the TCP server did not answer in time"
            pure A.Null

-- | 登录一行
tcpLogin :: Handle -> Text -> Text -> IO A.Value
tcpLogin h user password =
    tcpTalk h (BSC.pack ("{\"method\":\"login\",\"user\":\"" ++ T.unpack user ++ "\",\"password\":\"" ++ T.unpack password ++ "\"}"))

-- | 查询一行
tcpQuery :: Handle -> Text -> IO A.Value
tcpQuery h sql = tcpTalk h (BSC.pack ("{\"method\":\"query\",\"sql\":\"" ++ T.unpack sql ++ "\"}"))

-- | 断言对端已经收工（读到 EOF）
tcpClosed :: Handle -> IO ()
tcpClosed h = do
    done <- timeout (5 * 1000000) (hIsEOF h)
    done `shouldBe` Just True

-- 用例

-- | 协议与配置的用例
tcpSpec :: Spec
tcpSpec = do
    describe "TCP protocol: decoding a request line" $ do
        it "hello without a protocol number takes the current version" $
            decodeRequest "{\"method\":\"hello\"}" `shouldBe` Right (ReqHello 1)
        it "hello keeps the protocol number the client asked for" $
            decodeRequest "{\"method\":\"hello\",\"protocol\":2}" `shouldBe` Right (ReqHello 2)
        it "method names are case-insensitive" $
            decodeRequest "{\"method\":\"PING\"}" `shouldBe` Right ReqPing
        it "unknown extra fields are ignored" $
            decodeRequest "{\"method\":\"quit\",\"line\":7}" `shouldBe` Right ReqQuit
        it "login without a password is refused" $
            decodeRequest "{\"method\":\"login\",\"user\":\"admin\"}" `shouldBe` Left "login needs both user and password"
        it "query without sql is refused" $
            decodeRequest "{\"method\":\"query\"}" `shouldBe` Left "query needs sql"
        it "an unknown method is named in the error" $
            decodeRequest "{\"method\":\"frobnicate\"}" `shouldBe` Left "unknown method: frobnicate"
        it "a line that is not JSON is a bad request, not a crash" $
            decodeRequest "not json" `shouldBe` Left "request is not valid JSON"

    describe "TCP protocol: encoding a response" $ do
        it "hello carries the protocol version and the server name" $ do
            let value = fromMaybe A.Null (decode (encodeResponse (RespHello 1)))
            asText (at "status" value) `shouldBe` "hello"
            asText (at "server" value) `shouldBe` "chusql-server"
            asInt (at "protocol" value) `shouldBe` 1
        it "login reports the account and whether it is the administrator" $ do
            let value = fromMaybe A.Null (decode (encodeResponse (RespLogin "admin" True)))
            asText (at "user" value) `shouldBe` "admin"
            asBool (at "admin" value) `shouldBe` True
        it "an error carries a code and a message" $ do
            let value = fromMaybe A.Null (decode (encodeResponse (RespError "no_database" "no database selected")))
            asText (at "status" value) `shouldBe` "error"
            asText (at "code" value) `shouldBe` "no_database"
            asText (at "message" value) `shouldBe` "no database selected"
        it "a result set is the command line JSON with a status field added" $ do
            let sample = QueryResult ["id"] [[VInt 1]] 1 False (Just "test")
                value = fromMaybe A.Null (decode (encodeResponse (RespResult sample)))
            asText (at "status" value) `shouldBe` "result"
            map asText (items (at "columns" value)) `shouldBe` ["id"]
            asInt (at "rowCount" value) `shouldBe` 1
            asBool (at "truncated" value) `shouldBe` False
            asText (at "database" value) `shouldBe` "test"

    describe "memory backend: catalog statistics" $ do
        it "reports a histogram for a numeric column" $ do
            db <- newMVar testDb
            let backend = memoryBackend testDatabaseName db
            infos <- beCatalog backend
            case infos of
                Left err -> expectationFailure err
                Right tables -> case [i | i <- tables, tiTable i == "users"] of
                    [] -> expectationFailure "the catalog is missing the users table"
                    (info : _) -> do
                        fmap histLow (lookup "id" (tiHistograms info)) `shouldBe` Just 1
                        fmap histHigh (lookup "id" (tiHistograms info)) `shouldBe` Just 5
                        fmap (sum . histBuckets) (lookup "id" (tiHistograms info)) `shouldBe` Just 5
                        lookup "name" (tiHistograms info) `shouldBe` Nothing

    describe "server config ([server] in settings.toml)" $ do
        it "falls back to the defaults when the file has no server section" $ do
            path <- tcpConfigPath "server-default"
            removeIfExists path
            loadServerConfigAt path `shouldReturn` defaultServerConfig
        it "reads listen_host, port, max_message and max_rows" $ do
            path <- tcpConfigPath "server-keys"
            BS.writeFile path "[server]\nlisten_host = \"0.0.0.0\"\nport = 7777\nmax_message = 4096\nmax_rows = 7\n"
            config <- loadServerConfigAt path
            scHost config `shouldBe` "0.0.0.0"
            scPort config `shouldBe` 7777
            scMaxMessage config `shouldBe` 4096
            scMaxRows config `shouldBe` 7
        it "keeps the HTTP, storage and page keys out of the server config" $ do
            path <- tcpConfigPath "server-other-keys"
            BS.writeFile path "[web]\nport = 8888\n\n[storage]\ndata_dir = \"/tmp/chusql\"\n\n[page]\nsize = 8192\n"
            config <- loadServerConfigAt path
            scPort config `shouldBe` scPort defaultServerConfig
            scMaxRows config `shouldBe` scMaxRows defaultServerConfig

-- | 真连 TCP 服务器的用例
tcpServerSpec :: Spec
tcpServerSpec = do
    describe "TCP server: handshake and login" $ do
        it "binds a real port when asked for port 0" $
            withTcpServer defaultServerConfig $ \_ handle ->
                shPort handle `shouldSatisfy` (> 0)
        it "answers hello with the same protocol version" $
            withTcpServer defaultServerConfig $ \_ handle ->
                withConnection handle $ \h -> do
                    reply <- tcpTalk h "{\"method\":\"hello\",\"protocol\":1}"
                    asText (at "status" reply) `shouldBe` "hello"
                    asInt (at "protocol" reply) `shouldBe` 1
        it "still answers a client that connects long after startup" $
            -- 回归点：早先 accept 外面套 timeout 轮询，超时异常会在 accept
            -- 返回后把刚拿到的连接丢掉，只有延迟连接的客户端能撞上
            withTcpServer defaultServerConfig $ \_ handle -> do
                threadDelay 400000
                withConnection handle $ \h -> do
                    reply <- tcpTalk h "{\"method\":\"hello\",\"protocol\":1}"
                    asText (at "status" reply) `shouldBe` "hello"
                    asText (at "server" reply) `shouldBe` "chusql-server"
        it "refuses a protocol version it does not speak" $
            withTcpServer defaultServerConfig $ \_ handle ->
                withConnection handle $ \h -> do
                    reply <- tcpTalk h "{\"method\":\"hello\",\"protocol\":9}"
                    asText (at "code" reply) `shouldBe` "bad_request"
                    asText (at "message" reply) `shouldBe` "unsupported protocol version: 9"
        it "refuses a query before login" $
            withTcpServer defaultServerConfig $ \_ handle ->
                withConnection handle $ \h -> do
                    reply <- tcpQuery h "select * from users"
                    asText (at "status" reply) `shouldBe` "error"
                    asText (at "code" reply) `shouldBe` "unauthorized"
                    asText (at "message" reply) `shouldBe` "sign in first"
        it "signs the administrator in with an empty password until one is set" $
            withTcpServerAs Nothing defaultServerConfig $ \_ handle ->
                withConnection handle $ \h -> do
                    wrong <- tcpLogin h "admin" "nope"
                    asText (at "code" wrong) `shouldBe` "unauthorized"
                    good <- tcpLogin h "admin" ""
                    asText (at "status" good) `shouldBe` "ok"
                    asBool (at "admin" good) `shouldBe` True
        it "refuses a wrong password and then accepts the right one" $
            withTcpServer defaultServerConfig $ \_ handle ->
                withConnection handle $ \h -> do
                    bad <- tcpLogin h "admin" "wrong"
                    asText (at "status" bad) `shouldBe` "error"
                    asText (at "code" bad) `shouldBe` "unauthorized"
                    good <- tcpLogin h "admin" "s3cret"
                    asText (at "status" good) `shouldBe` "ok"
                    asText (at "user" good) `shouldBe` "admin"
                    asBool (at "admin" good) `shouldBe` True

    describe "TCP server: SQL over the wire" $ do
        it "USE picks a database and the result reports it" $
            withTcpServer defaultServerConfig $ \_ handle ->
                withConnection handle $ \h -> do
                    _ <- tcpLogin h "admin" "s3cret"
                    reply <- tcpQuery h "use test"
                    asText (at "status" reply) `shouldBe` "result"
                    asText (at "database" reply) `shouldBe` "test"
        it "SELECT returns the fixture rows" $
            withTcpServer defaultServerConfig $ \_ handle ->
                withConnection handle $ \h -> do
                    _ <- tcpLogin h "admin" "s3cret"
                    _ <- tcpQuery h "use test"
                    reply <- tcpQuery h "select * from users"
                    asText (at "status" reply) `shouldBe` "result"
                    map asText (items (at "columns" reply)) `shouldBe` ["id", "name", "age"]
                    asInt (at "rowCount" reply) `shouldBe` 5
                    let first = case map items (items (at "rows" reply)) of
                            (r : _) -> r
                            [] -> []
                    length first `shouldBe` 3
                    asInt (fromMaybe A.Null (nth 0 first)) `shouldBe` 1
                    asText (fromMaybe A.Null (nth 1 first)) `shouldBe` "user1"
        it "an unknown table maps to not_found" $
            withTcpServer defaultServerConfig $ \_ handle ->
                withConnection handle $ \h -> do
                    _ <- tcpLogin h "admin" "s3cret"
                    _ <- tcpQuery h "use test"
                    reply <- tcpQuery h "select * from nope"
                    asText (at "code" reply) `shouldBe` "not_found"
        it "a query without a selected database maps to no_database" $
            withTcpServer defaultServerConfig $ \_ handle ->
                withConnection handle $ \h -> do
                    _ <- tcpLogin h "admin" "s3cret"
                    reply <- tcpQuery h "select * from users"
                    asText (at "code" reply) `shouldBe` "no_database"
        it "an empty sql is a bad request" $
            withTcpServer defaultServerConfig $ \_ handle ->
                withConnection handle $ \h -> do
                    _ <- tcpLogin h "admin" "s3cret"
                    reply <- tcpTalk h "{\"method\":\"query\",\"sql\":\"  \"}"
                    asText (at "code" reply) `shouldBe` "bad_request"
                    asText (at "message" reply) `shouldBe` "sql must not be empty"
        it "the row limit truncates the rows but keeps the total count" $
            withTcpServer defaultServerConfig{scMaxRows = 2} $ \_ handle ->
                withConnection handle $ \h -> do
                    _ <- tcpLogin h "admin" "s3cret"
                    _ <- tcpQuery h "use test"
                    reply <- tcpQuery h "select * from users"
                    length (items (at "rows" reply)) `shouldBe` 2
                    asInt (at "rowCount" reply) `shouldBe` 5
                    asBool (at "truncated" reply) `shouldBe` True

    describe "TCP server: framing and lifecycle" $ do
        it "a bad JSON line does not kill the connection" $
            withTcpServer defaultServerConfig $ \_ handle ->
                withConnection handle $ \h -> do
                    bad <- tcpTalk h "not json"
                    asText (at "code" bad) `shouldBe` "bad_request"
                    pong <- tcpTalk h "{\"method\":\"ping\"}"
                    asText (at "status" pong) `shouldBe` "pong"
        it "a line over the message limit is refused as too_large" $
            withTcpServer defaultServerConfig{scMaxMessage = 32} $ \_ handle ->
                withConnection handle $ \h -> do
                    reply <- tcpTalk h (BSC.pack ("{\"method\":\"query\",\"sql\":\"" ++ replicate 40 'a' ++ "\"}"))
                    asText (at "code" reply) `shouldBe` "too_large"
        it "ping answers pong and quit closes the connection" $
            withTcpServer defaultServerConfig $ \_ handle ->
                withConnection handle $ \h -> do
                    pong <- tcpTalk h "{\"method\":\"ping\"}"
                    asText (at "status" pong) `shouldBe` "pong"
                    bye <- tcpTalk h "{\"method\":\"quit\"}"
                    asText (at "status" bye) `shouldBe` "bye"
                    tcpClosed h
        it "one connection is one session" $
            withTcpServer defaultServerConfig $ \_ handle ->
                withConnection handle $ \h -> do
                    reply <- tcpLogin h "admin" "s3cret"
                    asText (at "status" reply) `shouldBe` "ok"
                    withConnection handle $ \other -> do
                        blocked <- tcpQuery other "select * from users"
                        asText (at "code" blocked) `shouldBe` "unauthorized"

    describe "TCP server: account changes drop live sessions" $ do
        it "disconnects a member whose role was revoked" $
            withTcpServer defaultServerConfig $ \_ handle ->
                withConnection handle $ \admin -> do
                    _ <- tcpLogin admin "admin" "s3cret"
                    _ <- tcpQuery admin "create user bob identified by 'bob-password-1'"
                    _ <- tcpQuery admin "create role reader"
                    _ <- tcpQuery admin "use test"
                    _ <- tcpQuery admin "grant select on users to reader"
                    _ <- tcpQuery admin "grant reader to bob"
                    withConnection handle $ \bob -> do
                        _ <- tcpLogin bob "bob" "bob-password-1"
                        _ <- tcpQuery bob "use test"
                        allowed <- tcpQuery bob "select name from users"
                        asText (at "status" allowed) `shouldBe` "result"
                        _ <- tcpQuery admin "revoke reader from bob"
                        refused <- tcpQuery bob "select name from users"
                        asText (at "code" refused) `shouldBe` "unauthorized"
                        tcpClosed bob
        it "disconnects every member of a role that was dropped" $
            withTcpServer defaultServerConfig $ \_ handle ->
                withConnection handle $ \admin -> do
                    _ <- tcpLogin admin "admin" "s3cret"
                    _ <- tcpQuery admin "create user bob identified by 'bob-password-1'"
                    _ <- tcpQuery admin "create role reader"
                    _ <- tcpQuery admin "grant reader to bob"
                    withConnection handle $ \bob -> do
                        _ <- tcpLogin bob "bob" "bob-password-1"
                        _ <- tcpQuery admin "drop role reader"
                        refused <- tcpQuery bob "use test"
                        asText (at "code" refused) `shouldBe` "unauthorized"
                        tcpClosed bob
        it "disconnects an account whose password was reset" $
            withTcpServer defaultServerConfig $ \_ handle ->
                withConnection handle $ \admin -> do
                    _ <- tcpLogin admin "admin" "s3cret"
                    _ <- tcpQuery admin "create user bob identified by 'bob-password-1'"
                    withConnection handle $ \bob -> do
                        _ <- tcpLogin bob "bob" "bob-password-1"
                        _ <- tcpQuery admin "alter user bob identified by 'bob-password-2'"
                        refused <- tcpQuery bob "use test"
                        asText (at "code" refused) `shouldBe` "unauthorized"
                        tcpClosed bob
                    withConnection handle $ \again -> do
                        relogin <- tcpLogin again "bob" "bob-password-2"
                        asText (at "status" relogin) `shouldBe` "ok"
        it "disconnects an account that was dropped" $
            withTcpServer defaultServerConfig $ \_ handle ->
                withConnection handle $ \admin -> do
                    _ <- tcpLogin admin "admin" "s3cret"
                    _ <- tcpQuery admin "create user bob identified by 'bob-password-1'"
                    withConnection handle $ \bob -> do
                        _ <- tcpLogin bob "bob" "bob-password-1"
                        _ <- tcpQuery admin "drop user bob"
                        refused <- tcpQuery bob "use test"
                        asText (at "code" refused) `shouldBe` "unauthorized"
                        tcpClosed bob
        it "leaves the connections of untouched accounts alone" $
            withTcpServer defaultServerConfig $ \_ handle ->
                withConnection handle $ \admin -> do
                    _ <- tcpLogin admin "admin" "s3cret"
                    _ <- tcpQuery admin "create user bob identified by 'bob-password-1'"
                    withConnection handle $ \bob -> do
                        _ <- tcpLogin bob "bob" "bob-password-1"
                        _ <- tcpQuery admin "create user carol identified by 'carol-password-1'"
                        _ <- tcpQuery admin "alter user carol identified by 'carol-password-2'"
                        still <- tcpQuery bob "use test"
                        asText (at "status" still) `shouldBe` "result"

-- 权限服务夹具：内存后端上的系统库视角

-- | 一个普通账号
testAccount :: Account
testAccount = Account 0 "alice" "" 0 "" Nothing True False True False

-- | 权限用例传的当前库名
testDatabase :: Text
testDatabase = T.pack testDatabaseName

-- | 一个空的权限服务加管理员身份
withPrivileges :: (Privileges -> Principal -> IO a) -> IO a
withPrivileges body = do
    db <- newMVar testDb
    service <- newPrivileges (memoryBackend testDatabaseName db)
    body service (Root testRootName)

-- | 解析一条 SQL，失败就丢掉用例
parseOrFail :: String -> IO Statement
parseOrFail sql = case parseStatement sql of
    Left err -> expectationFailure err >> fail "statement did not parse"
    Right stmt -> pure stmt

-- | 用某个身份鉴权一条 SQL
authorizeSql :: Privileges -> Principal -> String -> IO (Either PrivilegeError ())
authorizeSql service principal sql = parseOrFail sql >>= authorize service principal testDatabase

-- | 权限与目录 API 用例
privilegeSpec :: Spec
privilegeSpec = describe "server privileges" $ do
    it "creates a role and lists it" $ withPrivileges $ \service root -> do
        created <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        created `shouldBe` Right ()
        views <- listRoleViews service
        fmap (map roleName) views `shouldBe` Right ["reader"]

    it "refuses a role that already exists" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        again <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        again `shouldBe` Left (PrivilegeError "conflict" "role already exists: reader")

    it "grants a privilege on a table and shows it in the role view" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        granted <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" False)
        granted `shouldBe` Right ()
        views <- listRoleViews service
        fmap (map roleGrants) views `shouldBe` Right [[Grant "reader" "select" "test.users" False]]

    it "expands ALL and keeps a star object as is" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["all"] "*" "reader" False)
        views <- listRoleViews service
        fmap (concatMap (map grantPrivilege) . map roleGrants) views
            `shouldBe` Right ["select", "insert", "update", "delete"]
        fmap (concatMap (map grantObject) . map roleGrants) views `shouldBe` Right (replicate 4 "*")

    it "revokes a privilege again" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" False)
        _ <- runPrivilegeCommand service root testDatabase (RevokePrivilegesCommand ["select"] "users" "reader")
        views <- listRoleViews service
        fmap (map roleGrants) views `shouldBe` Right [[]]

    it "marks a grant that carries the grant option" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" True)
        views <- listRoleViews service
        fmap (map roleGrants) views `shouldBe` Right [[Grant "reader" "select" "test.users" True]]

    it "refuses a non-administrator without the grant option" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "writer")
        _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" False)
        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
        refused <- runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "writer" False)
        refused `shouldBe` Left (PrivilegeError "forbidden" "grant option required: SELECT ON users")

    it "lets a grant option holder pass the privilege on" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "writer")
        _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" True)
        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
        passed <- runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "writer" False)
        passed `shouldBe` Right ()
        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "writer" ["bob"])
        views <- listRoleViews service
        fmap (map roleGrants) views `shouldBe` Right [[Grant "reader" "select" "test.users" True], [Grant "writer" "select" "test.users" False]]

    it "stops the pass-on once the grant option is revoked" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "writer")
        _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" True)
        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
        _ <- runPrivilegeCommand service root testDatabase (RevokePrivilegesCommand ["select"] "users" "reader")
        refused <- runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "writer" False)
        refused `shouldBe` Left (PrivilegeError "forbidden" "grant option required: SELECT ON users")
        views <- listRoleViews service
        fmap (map roleGrants) views `shouldBe` Right [[], []]

    it "adds and removes members" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice", "bob"])
        views <- listRoleViews service
        fmap (map roleMembers) views `shouldBe` Right [["alice", "bob"]]
        _ <- runPrivilegeCommand service root testDatabase (RevokeRoleCommand "reader" ["alice"])
        remaining <- listRoleViews service
        fmap (map roleMembers) remaining `shouldBe` Right [["bob"]]

    it "drops a role together with its grants and members" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" False)
        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
        dropped <- runPrivilegeCommand service root testDatabase (DropRoleCommand "reader")
        dropped `shouldBe` Right ()
        views <- listRoleViews service
        views `shouldBe` Right []

    it "inherits the grants of another role" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "writer")
        _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" False)
        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["writer"])
        linked <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "writer" ["alice"])
        linked `shouldBe` Right ()
        -- 继承链上的授权跟着成员传上来
        authorizeSql service (Ordinary testAccount) "SELECT * FROM users" `shouldReturn` Right ()
        views <- listRoleViews service
        case views of
            Left err -> expectationFailure (show err)
            Right known -> do
                let membersOf name = concat [ms | view <- known, roleName view == name, ms <- [roleMembers view]]
                membersOf "reader" `shouldMatchList` ["writer"]
                membersOf "writer" `shouldMatchList` ["alice"]
        revoked <- runPrivilegeCommand service root testDatabase (RevokeRoleCommand "reader" ["writer"])
        revoked `shouldBe` Right ()
        authorizeSql service (Ordinary testAccount) "SELECT * FROM users"
            `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")

    it "refuses a role membership that would create a cycle" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "writer")
        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["writer"])
        loop <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "writer" ["reader"])
        loop `shouldBe` Left (PrivilegeError "conflict" "role membership would create a cycle: writer and reader")
        self <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["reader"])
        self `shouldBe` Left (PrivilegeError "conflict" "role membership would create a cycle: reader and reader")

    it "drops the inherited edge together with the role" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "writer")
        _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" False)
        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["writer"])
        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "writer" ["alice"])
        dropped <- runPrivilegeCommand service root testDatabase (DropRoleCommand "reader")
        dropped `shouldBe` Right ()
        authorizeSql service (Ordinary testAccount) "SELECT * FROM users"
            `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON users")
        views <- listRoleViews service
        fmap (map roleMembers) views `shouldBe` Right [["alice"]]

    it "refuses a command on a role that does not exist" $ withPrivileges $ \service root -> do
        missing <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "ghost" False)
        missing `shouldBe` Left (PrivilegeError "not_found" "unknown role: ghost")

    it "refuses a table grant without a selected database" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        refused <- runPrivilegeCommand service root "" (GrantPrivilegesCommand ["select"] "users" "reader" False)
        refused `shouldBe` Left (PrivilegeError "no_database" "no database selected")

    it "refuses a non-administrator" $ withPrivileges $ \service _ -> do
        refused <- runPrivilegeCommand service (Ordinary testAccount) testDatabase (CreateRoleCommand "reader")
        refused `shouldBe` Left (PrivilegeError "forbidden" "administrator required")

    it "requires administrator privileges for domain commands" $ withPrivileges $ \service root -> do
        authorizeSql service root "CREATE DOMAIN code AS INT" `shouldReturn` Right ()
        authorizeSql service (Ordinary testAccount) "CREATE DOMAIN code AS INT"
            `shouldReturn` Left (PrivilegeError "forbidden" "administrator required")

    it "authorizes the administrator on any statement" $ withPrivileges $ \service root ->
        case parseStatement "SELECT * FROM users" of
            Left err -> expectationFailure err
            Right stmt -> authorize service root testDatabase stmt `shouldReturn` Right ()

    it "requires the privilege on the table inside a derived table" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" False)
        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
        authorizeSql service (Ordinary testAccount) "SELECT d.name FROM (SELECT name FROM users) d"
            `shouldReturn` Right ()
        authorizeSql service (Ordinary testAccount) "SELECT d.name FROM (SELECT product FROM orders) d"
            `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON orders")

    it "requires the privilege on the table inside a CTE" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" False)
        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
        authorizeSql service (Ordinary testAccount) "WITH d AS (SELECT name FROM users) SELECT d.name FROM d"
            `shouldReturn` Right ()
        authorizeSql service (Ordinary testAccount) "WITH d AS (SELECT product FROM orders) SELECT d.product FROM d"
            `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON orders")

    it "requires the privilege on the table inside a comparison subquery" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" False)
        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
        authorizeSql service (Ordinary testAccount) "SELECT name FROM users WHERE id >= (SELECT id FROM users)"
            `shouldReturn` Right ()
        authorizeSql service (Ordinary testAccount) "SELECT name FROM users WHERE id >= (SELECT id FROM orders)"
            `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON orders")

    it "requires the privilege on the table inside a quantifier subquery" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" False)
        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
        authorizeSql service (Ordinary testAccount) "SELECT name FROM users WHERE id > ANY (SELECT id FROM users)"
            `shouldReturn` Right ()
        authorizeSql service (Ordinary testAccount) "SELECT name FROM users WHERE id > ANY (SELECT id FROM orders)"
            `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON orders")

    it "lists the accounts a role change touches, members included" $ withPrivileges $ \service root -> do
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "inner")
        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "inner" ["reader"])
        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
        directly <- affectedAccounts service (RevokeRoleCommand "inner" ["bob"])
        directly `shouldMatchList` ["bob"]
        granted <- affectedAccounts service (GrantRoleCommand "writer" ["inner"])
        granted `shouldMatchList` ["inner", "reader", "alice"]
        dropped <- affectedAccounts service (DropRoleCommand "inner")
        dropped `shouldMatchList` ["inner", "reader", "alice"]
        affectedAccounts service (CreateRoleCommand "other") `shouldReturn` []

    it "keeps the role tables on the real storage" $ withIpcStorage $ do
        base <- ipcBackend
        service <- newPrivileges base
        created <- runPrivilegeCommand service (Root testRootName) testDatabase (CreateRoleCommand "reader")
        created `shouldBe` Right ()
        views <- listRoleViews service
        fmap (map roleName) views `shouldBe` Right ["reader"]
        stored <- beAccounts base ReqAccountsList
        fmap (map (\a -> (accountUser a, accountCanLogin a))) stored `shouldBe` Right [("root", True), ("reader", False)]
        let system = beWithDatabase base "system"
        -- 账号表不给语句通道看到
        denied <- beStatement system "SELECT * FROM __system_users"
        case denied of
            Left _ -> pure ()
            Right result -> expectationFailure ("account table must stay hidden: " ++ show (srRows result))

    it "inherits a role on the real storage" $ withIpcStorage $ do
        base <- ipcBackend
        service <- newPrivileges base
        _ <- runPrivilegeCommand service (Root testRootName) testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service (Root testRootName) testDatabase (CreateRoleCommand "writer")
        _ <- runPrivilegeCommand service (Root testRootName) testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" False)
        _ <- runPrivilegeCommand service (Root testRootName) testDatabase (GrantRoleCommand "reader" ["writer"])
        linked <- runPrivilegeCommand service (Root testRootName) testDatabase (GrantRoleCommand "writer" ["alice"])
        linked `shouldBe` Right ()
        authorizeSql service (Ordinary testAccount) "SELECT * FROM users" `shouldReturn` Right ()

    it "keeps a grant option on the real storage" $ withIpcStorage $ do
        base <- ipcBackend
        service <- newPrivileges base
        _ <- runPrivilegeCommand service (Root testRootName) testDatabase (CreateRoleCommand "reader")
        _ <- runPrivilegeCommand service (Root testRootName) testDatabase (CreateRoleCommand "writer")
        _ <- runPrivilegeCommand service (Root testRootName) testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" True)
        _ <- runPrivilegeCommand service (Root testRootName) testDatabase (GrantRoleCommand "reader" ["alice"])
        views <- listRoleViews service
        fmap (map roleGrants) views `shouldBe` Right [[Grant "reader" "select" "test.users" True], []]
        passed <- runPrivilegeCommand service (Ordinary testAccount) testDatabase (GrantPrivilegesCommand ["select"] "users" "writer" False)
        passed `shouldBe` Right ()
        after <- listRoleViews service
        fmap (map roleGrants) after `shouldBe` Right [[Grant "reader" "select" "test.users" True], [Grant "writer" "select" "test.users" False]]

-- 真存储夹具：一个用例一份数据目录，跑完关链路删干净

-- | 本次用例的数据目录（用例串行跑，固定名够用）
ipcDataDir :: IO FilePath
ipcDataDir = do
    tmp <- getTemporaryDirectory
    pure (tmp </> "chusql-server-test-ipc")

-- | 写一份只属于这次用例的存储配置：数据目录与日志级别都从文件走
writeIpcConfig :: FilePath -> IO FilePath
writeIpcConfig dir = do
    let cfgPath = dir ++ ".toml"
        -- TOML 的普通字符串会吃反斜杠，路径统一用正斜杠
        slashed = map (\c -> if c == '\\' then '/' else c) dir
    writeFile
        cfgPath
        ( unlines
            [ "[storage]"
            , "data_dir = \"" ++ slashed ++ "\""
            , "[log]"
            , "level = \"error\""
            ]
        )
    pure cfgPath

-- | 删掉这次用例的数据目录与配置，删不掉也不算错
cleanIpc :: FilePath -> IO ()
cleanIpc dir = do
    _ <- try (removePathForcibly dir) :: IO (Either IOException ())
    _ <- try (removePathForcibly (dir ++ ".toml")) :: IO (Either IOException ())
    pure ()

-- 事务用例：内存后端跑得快，真存储的提交再在 IPC 用例里验一遍

-- | 起一个内存后端会话，当前库已切到 test
withMemorySession :: (Session -> IO a) -> IO a
withMemorySession body = do
    db <- newMVar testDb
    settings <- tempSettingsPath "transaction"
    removeIfExists settings
    session <- newSession (memoryBackend testDatabaseName db) (T.pack testDatabaseName) settings
    _ <- runStatementCoded session "use test"
    body session

-- | 两个会话共用一份内存库，用来验会话隔离
withTwoSessions :: (Session -> Session -> IO a) -> IO a
withTwoSessions body = do
    db <- newMVar testDb
    settings <- tempSettingsPath "transaction-pair"
    removeIfExists settings
    let backend = memoryBackend testDatabaseName db
    first <- newSession backend (T.pack testDatabaseName) settings
    second <- newSession backend (T.pack testDatabaseName) settings
    _ <- runStatementCoded first "use test"
    _ <- runStatementCoded second "use test"
    body first second

-- | 跑一条语句；出错就算用例失败
mustSql :: Session -> Text -> IO QueryResult
mustSql session sql = runStatementCoded session sql >>= either failed pure
  where
    failed err = expectationFailure (T.unpack (sessMessage err)) >> pure (QueryResult [] [] 0 False Nothing)

-- | 取 users 的 id 列
sessionIds :: Session -> IO [Int]
sessionIds session = do
    result <- mustSql session "select * from users"
    pure [n | row <- qrRows result, Just (VInt n) <- [nth 0 row]]

-- | 取某个 id 的 age
sessionAge :: Session -> Int -> IO (Maybe Int)
sessionAge session wanted = do
    result <- mustSql session "select * from users"
    let ages = [(n, a) | row <- qrRows result, Just (VInt n) <- [nth 0 row], Just (VInt a) <- [nth 2 row]]
    pure (lookup wanted ages)

-- | 取失败里的文案
failureMessage :: Either SessionError QueryResult -> Text
failureMessage outcome = either sessMessage (const "") outcome

-- | 取失败里的错误码
failureCode :: Either SessionError QueryResult -> Text
failureCode outcome = either sessCode (const "") outcome

-- | 取结果第一列的整数
intValues :: [[Value]] -> [Int]
intValues rows = [n | row <- rows, Just (VInt n) <- [nth 0 row]]

-- | 显式事务用例
transactionSpec :: Spec
transactionSpec = describe "server transactions" $ do
    it "filters qualified memory tables and preserves other databases on writes" $ do
        let local = Table "users" [("id", TInt)] [[("id", VInt 1)]] Nothing
            otherTable = Table "users" [("id", TInt)] [[("id", VInt 2)]] Nothing
        ref <- newMVar [("test.users", local), ("other.users", otherTable)]
        let backend = memoryBackend "test" ref
        selected <- beStatement backend "SELECT id FROM users"
        fmap srRows selected `shouldBe` Right [[("id", VInt 1)]]
        tables <- beCatalog backend
        fmap (map tiTable) tables `shouldBe` Right ["users"]
        updated <- beStatement backend "UPDATE users SET id = 3"
        fmap (const ()) updated `shouldBe` Right ()
        snapshot <- beSnapshot (memoryBackend "other" ref)
        fmap (map (tableRows . snd)) snapshot `shouldBe` Right [[[ ("id", VInt 2) ]]]
    it "rejects cross-database reads and writes including nested queries" $ withMemorySession $ \session -> do
        mapM_ (\query -> do
            result <- runStatementCoded session query
            failureMessage result `shouldSatisfy` T.isInfixOf "outside the current database")
            [ "SELECT * FROM other.users"
            , "UPDATE other.users SET age = 1"
            , "DELETE FROM other.users"
            , "INSERT INTO other.users (id) VALUES (99)"
            , "SELECT * FROM users WHERE id IN (SELECT id FROM other.users)"
            , "SELECT other.users.id FROM users"
            ]
        void (mustSql session "BEGIN")
        result <- runStatementCoded session "SELECT * FROM other.users"
        failureMessage result `shouldSatisfy` T.isInfixOf "outside the current database"
        void (mustSql session "ROLLBACK")
    it "redacts malformed password statements through the session" $ withMemorySession $ \session -> do
        result <- runStatementCoded session "ALTER USER alice IDENTIFIED BY 'private-secret' trailing"
        failureMessage result `shouldSatisfy` T.isInfixOf "syntax"
        failureMessage result `shouldSatisfy` (not . T.isInfixOf "private-secret")
    it "resolves current database qualifiers for memory DDL" $ withMemorySession $ \session -> do
        _ <- mustSql session "CREATE TABLE test.qualified (id INT)"
        _ <- mustSql session "ALTER TABLE test.qualified ADD COLUMN value INT DEFAULT 8"
        _ <- mustSql session "INSERT INTO qualified (id) VALUES (1)"
        rows <- mustSql session "SELECT value FROM test.qualified"
        intValues (qrRows rows) `shouldBe` [8]
        void (mustSql session "DROP TABLE test.qualified")

    it "uses domain columns in snapshot transactions and rejects domain DDL" $ withMemorySession $ \session -> do
        _ <- mustSql session "create domain code as int"
        _ <- mustSql session "create table typed (id code)"
        _ <- mustSql session "begin"
        denied <- runStatementCoded session "drop domain code"
        failureMessage denied `shouldBe` "DDL is not allowed in a transaction"
        _ <- mustSql session "insert into typed (id) values (7)"
        _ <- mustSql session "commit"
        rows <- mustSql session "select id from typed"
        intValues (qrRows rows) `shouldBe` [7]

    it "keeps uncommitted rows invisible to other sessions until COMMIT" $ withTwoSessions $ \writer reader -> do
        _ <- mustSql writer "begin"
        _ <- mustSql writer "insert into users (id, name, age) values (6, 'six', 26)"
        sessionIds writer `shouldReturn` [1, 2, 3, 4, 5, 6]
        sessionIds reader `shouldReturn` [1, 2, 3, 4, 5]
        _ <- mustSql writer "commit"
        ids <- sessionIds writer
        ids `shouldMatchList` [1, 2, 3, 4, 5, 6]
        seen <- sessionIds reader
        seen `shouldMatchList` [1, 2, 3, 4, 5, 6]

    it "drops every change on ROLLBACK" $ withMemorySession $ \session -> do
        _ <- mustSql session "begin"
        _ <- mustSql session "insert into users (id, name, age) values (6, 'six', 26)"
        _ <- mustSql session "update users set age = 99 where id = 1"
        _ <- mustSql session "delete from users where id = 2"
        rollback <- mustSql session "rollback"
        qrRowCount rollback `shouldBe` 0
        kept <- sessionIds session
        kept `shouldMatchList` [1, 2, 3, 4, 5]

    it "commits the whole write set at once" $ withMemorySession $ \session -> do
        _ <- mustSql session "begin"
        _ <- mustSql session "insert into users (id, name, age) values (6, 'six', 26)"
        _ <- mustSql session "update users set age = 99 where id = 1"
        _ <- mustSql session "delete from users where id = 2"
        _ <- mustSql session "commit"
        ids <- sessionIds session
        ids `shouldMatchList` [1, 3, 4, 5, 6]
        sessionAge session 1 `shouldReturn` Just 99

    it "rejects DDL inside a transaction and takes it after ROLLBACK" $ withMemorySession $ \session -> do
        _ <- mustSql session "begin"
        denied <- runStatementCoded session "create table blocked (id int)"
        failureMessage denied `shouldBe` "DDL is not allowed in a transaction"
        _ <- mustSql session "rollback"
        _ <- mustSql session "create table fresh (id int)"
        _ <- mustSql session "insert into fresh (id) values (1)"
        rows <- mustSql session "select * from fresh"
        qrRowCount rows `shouldBe` 1

    it "refuses nested BEGIN and COMMIT outside a transaction" $ withMemorySession $ \session -> do
        _ <- mustSql session "begin"
        nested <- runStatementCoded session "begin"
        failureMessage nested `shouldBe` "already in a transaction"
        _ <- mustSql session "rollback"
        late <- runStatementCoded session "commit"
        failureMessage late `shouldBe` "no transaction in progress"

    it "does not switch database inside a transaction" $ withMemorySession $ \session -> do
        _ <- mustSql session "begin"
        denied <- runStatementCoded session "use other"
        failureMessage denied `shouldBe` "cannot switch database inside a transaction"

    it "refuses COMMIT when another session changed the same row" $ withTwoSessions $ \first second -> do
        _ <- mustSql first "begin"
        _ <- mustSql second "begin"
        _ <- mustSql first "update users set age = 31 where id = 1"
        _ <- mustSql second "update users set age = 42 where id = 1"
        _ <- mustSql first "commit"
        denied <- runStatementCoded second "commit"
        failureCode denied `shouldBe` "serialization_failure"
        failureMessage denied `shouldBe` "write conflict on table users, id 1"
        -- 事务保留：回滚之后看到的还是先提交的那个值
        _ <- mustSql second "rollback"
        sessionAge second 1 `shouldReturn` Just 31

    it "refuses COMMIT when the row was deleted meanwhile" $ withTwoSessions $ \first second -> do
        _ <- mustSql first "begin"
        _ <- mustSql second "begin"
        _ <- mustSql first "delete from users where id = 2"
        _ <- mustSql second "update users set age = 42 where id = 2"
        _ <- mustSql first "commit"
        denied <- runStatementCoded second "commit"
        failureMessage denied `shouldBe` "write conflict on table users, id 2"
        _ <- mustSql second "rollback"
        ids <- sessionIds second
        ids `shouldMatchList` [1, 3, 4, 5]

    it "refuses COMMIT when deleting a row that changed meanwhile" $ withTwoSessions $ \first second -> do
        _ <- mustSql first "begin"
        _ <- mustSql second "begin"
        _ <- mustSql first "update users set age = 31 where id = 3"
        _ <- mustSql second "delete from users where id = 3"
        _ <- mustSql first "commit"
        denied <- runStatementCoded second "commit"
        failureMessage denied `shouldBe` "write conflict on table users, id 3"
        _ <- mustSql second "rollback"
        sessionAge second 3 `shouldReturn` Just 31

    it "refuses COMMIT when another session inserted the same id" $ withTwoSessions $ \first second -> do
        _ <- mustSql first "begin"
        _ <- mustSql second "begin"
        _ <- mustSql first "insert into users (id, name, age) values (7, 'seven', 27)"
        _ <- mustSql second "insert into users (id, name, age) values (7, 'other', 70)"
        _ <- mustSql first "commit"
        denied <- runStatementCoded second "commit"
        failureMessage denied `shouldBe` "write conflict on table users, id 7"
        _ <- mustSql second "rollback"
        ids <- sessionIds second
        ids `shouldMatchList` [1, 2, 3, 4, 5, 7]

    it "keeps other sessions' rows untouched when the write sets do not overlap" $ withTwoSessions $ \first second -> do
        _ <- mustSql first "begin"
        _ <- mustSql second "begin"
        _ <- mustSql first "insert into users (id, name, age) values (6, 'six', 26)"
        _ <- mustSql first "update users set age = 31 where id = 1"
        _ <- mustSql second "update users set age = 42 where id = 2"
        _ <- mustSql first "commit"
        _ <- mustSql second "commit"
        sessionAge second 1 `shouldReturn` Just 31
        sessionAge second 2 `shouldReturn` Just 42
        ids <- sessionIds second
        ids `shouldMatchList` [1, 2, 3, 4, 5, 6]

    it "lets both sessions delete the same row" $ withTwoSessions $ \first second -> do
        _ <- mustSql first "begin"
        _ <- mustSql second "begin"
        _ <- mustSql first "delete from users where id = 4"
        _ <- mustSql second "delete from users where id = 4"
        _ <- mustSql first "commit"
        _ <- mustSql second "commit"
        ids <- sessionIds second
        ids `shouldMatchList` [1, 2, 3, 5]

    it "keeps the work before a savepoint and drops the work after it" $ withMemorySession $ \session -> do
        _ <- mustSql session "begin"
        _ <- mustSql session "update users set age = 31 where id = 1"
        _ <- mustSql session "savepoint spot"
        _ <- mustSql session "insert into users (id, name, age) values (6, 'six', 26)"
        _ <- mustSql session "delete from users where id = 2"
        _ <- mustSql session "rollback to spot"
        inside <- sessionIds session
        inside `shouldMatchList` [1, 2, 3, 4, 5]
        sessionAge session 1 `shouldReturn` Just 31
        _ <- mustSql session "commit"
        ids <- sessionIds session
        ids `shouldMatchList` [1, 2, 3, 4, 5]
        sessionAge session 1 `shouldReturn` Just 31

    it "lets a savepoint be used again after rolling back to it" $ withMemorySession $ \session -> do
        _ <- mustSql session "begin"
        _ <- mustSql session "insert into users (id, name, age) values (6, 'six', 26)"
        _ <- mustSql session "savepoint spot"
        _ <- mustSql session "insert into users (id, name, age) values (7, 'seven', 27)"
        _ <- mustSql session "rollback to spot"
        _ <- mustSql session "insert into users (id, name, age) values (8, 'eight', 28)"
        ids <- sessionIds session
        ids `shouldMatchList` [1, 2, 3, 4, 5, 6, 8]

    it "drops the savepoints above the one rolled back to" $ withMemorySession $ \session -> do
        _ <- mustSql session "begin"
        _ <- mustSql session "savepoint one"
        _ <- mustSql session "savepoint two"
        _ <- mustSql session "rollback to one"
        missing <- runStatementCoded session "rollback to two"
        failureMessage missing `shouldBe` "no such savepoint: two"

    it "drops a released savepoint and the ones after it" $ withMemorySession $ \session -> do
        _ <- mustSql session "begin"
        _ <- mustSql session "savepoint one"
        _ <- mustSql session "savepoint two"
        released <- mustSql session "release one"
        qrRowCount released `shouldBe` 0
        first <- runStatementCoded session "rollback to one"
        failureMessage first `shouldBe` "no such savepoint: one"
        second <- runStatementCoded session "rollback to two"
        failureMessage second `shouldBe` "no such savepoint: two"

    it "clears the savepoints on COMMIT" $ withMemorySession $ \session -> do
        _ <- mustSql session "begin"
        _ <- mustSql session "savepoint spot"
        _ <- mustSql session "commit"
        missing <- runStatementCoded session "rollback to spot"
        failureMessage missing `shouldBe` "no transaction in progress"

    it "needs a transaction and a known name for savepoints" $ withMemorySession $ \session -> do
        outside <- runStatementCoded session "savepoint spot"
        failureMessage outside `shouldBe` "no transaction in progress"
        _ <- mustSql session "begin"
        unknown <- runStatementCoded session "rollback to nowhere"
        failureMessage unknown `shouldBe` "no such savepoint: nowhere"
        gone <- runStatementCoded session "release nowhere"
        failureMessage gone `shouldBe` "no such savepoint: nowhere"

    it "needs a current database to start" $ do
        db <- newMVar testDb
        settings <- tempSettingsPath "transaction-bare"
        removeIfExists settings
        session <- newSession (memoryBackend testDatabaseName db) (T.pack testDatabaseName) settings
        result <- runStatementCoded session "begin"
        failureMessage result `shouldBe` "no database selected"

-- | 起一份真存储并装成当前链路；动态库打不开就当用例待定
withIpcStorage :: IO () -> IO ()
withIpcStorage body = do
    dir <- ipcDataDir
    cleanIpc dir
    createDirectoryIfMissing True dir
    cfgPath <- writeIpcConfig dir
    opened <- localStorageLink (Just cfgPath)
    case opened of
        Left err -> cleanIpc dir >> pendingWith ("cannot open the storage library: " ++ err)
        Right link -> do
            setStorageLink link
            base <- ipcBackend
            seeded <- beStorage base (A.object ["method" A..= ("bootstrap_system" :: Text), "user" A..= ("root" :: Text), "password_hash" A..= ("hash" :: Text)])
            case seeded of
                Left err -> expectationFailure err
                Right value -> case value of
                    A.Object fields -> KM.lookup "initialized" fields `shouldBe` Just (A.Bool True)
                    _ -> expectationFailure "invalid bootstrap response"
            body `finally` (closeConnection >> cleanIpc dir)

-- | 跑一条语句，出错就算用例失败
mustRun :: IO (Either String StatementResult) -> IO ()
mustRun action = action >>= either expectationFailure (const (pure ()))

-- | 取结果行，出错就算用例失败
rowsOf :: IO (Either String StatementResult) -> IO [Row]
rowsOf action = action >>= either (\err -> expectationFailure err >> pure []) (pure . srRows)

-- | 取结果里某一列的整数
intColumn :: String -> [Row] -> [Int]
intColumn name rows = [n | row <- rows, Just (VInt n) <- [lookup name row]]

-- | 往 p 表连插一批行，结果放 MVar 交回主线程
writeRows :: Backend -> [Int] -> MVar [Either String StatementResult] -> IO ()
writeRows session ids done = do
    outs <- mapM (\i -> beStatement session ("INSERT INTO p (id) VALUES (" ++ show i ++ ")")) ids
    putMVar done outs

-- | 同一进程里开两个库：会话之间不串数据，也不互相挡路
ipcConcurrencySpec :: Spec
ipcConcurrencySpec = describe "server backend on the real storage" $ do
    it "resolves DDL qualifiers without crossing database boundaries" $ withIpcStorage $ do
        base <- ipcBackend
        mustRun (beStatement base "CREATE DATABASE alpha")
        mustRun (beStatement base "CREATE DATABASE beta")
        let alpha = beWithDatabase base "alpha"
            beta = beWithDatabase base "beta"
        unselected <- beStatement base "CREATE TABLE alpha.t (id INT)"
        fmap (const ()) unselected `shouldBe` Left "no database selected"
        mustRun (beStatement alpha "CREATE TABLE alpha.t (id INT, value INT)")
        duplicate <- beStatement alpha "CREATE TABLE t (id INT)"
        fmap (const ()) duplicate `shouldSatisfy` either (const True) (const False)
        mustRun (beStatement alpha "INSERT INTO t (id, value) VALUES (1, 7)")
        mustRun (beStatement alpha "CREATE INDEX ON alpha.t (value)")
        mustRun (beStatement alpha "DROP INDEX ON alpha.t (value)")
        mustRun (beStatement alpha "ALTER TABLE alpha.t RENAME COLUMN value TO score")
        mustRun (beStatement alpha "ALTER TABLE alpha.t ALTER COLUMN score TYPE BIGINT")
        mustRun (beStatement alpha "ALTER TABLE alpha.t ALTER COLUMN score SET DEFAULT 9")
        mustRun (beStatement alpha "ALTER TABLE alpha.t ALTER COLUMN score SET NOT NULL")
        rows <- rowsOf (beStatement alpha "SELECT score FROM t")
        intColumn "score" rows `shouldBe` [7]
        crossed <- beStatement beta "DROP TABLE alpha.t"
        fmap (const ()) crossed `shouldBe` Left "DDL target is outside the current database: alpha.t"
        mustRun (beStatement alpha "ALTER TABLE alpha.t DROP COLUMN score")
        mustRun (beStatement alpha "DROP TABLE alpha.t")
        catalog <- beCatalog alpha >>= either fail pure
        map tiTable catalog `shouldBe` []

    it "isolates domain catalogs by database and hides them from table lists" $ withIpcStorage $ do
        base <- ipcBackend
        unselected <- beStatement base "SHOW DOMAINS"
        fmap (const ()) unselected `shouldBe` Left "no database selected"
        mustRun (beStatement base "CREATE DATABASE alpha")
        mustRun (beStatement base "CREATE DATABASE beta")
        let alpha = beWithDatabase base "alpha"
            beta = beWithDatabase base "beta"
        mustRun (beStatement alpha "CREATE DOMAIN code AS INT")
        mustRun (beStatement beta "CREATE DOMAIN code AS VARCHAR(3)")
        mustRun (beStatement alpha "CREATE TABLE typed (id code)")
        mustRun (beStatement beta "CREATE TABLE typed (id code)")
        mustRun (beStatement alpha "INSERT INTO typed (id) VALUES (1)")
        mustRun (beStatement beta "INSERT INTO typed (id) VALUES ('abc')")
        catalog <- beCatalog alpha >>= either fail pure
        map tiTable catalog `shouldBe` ["typed"]
        domains <- rowsOf (beStatement beta "SHOW DOMAINS")
        domains `shouldBe` [[("domain", VStr "code"), ("base_type", VStr "varchar(3)")]]
        refused <- beStatement beta "INSERT INTO typed (id) VALUES (1)"
        fmap (const ()) refused `shouldSatisfy` either (const True) (const False)

    it "resolves nested domains only inside their own database" $ withIpcStorage $ do
        base <- ipcBackend
        mustRun (beStatement base "CREATE DATABASE alpha")
        mustRun (beStatement base "CREATE DATABASE beta")
        let alpha = beWithDatabase base "alpha"
            beta = beWithDatabase base "beta"
        mustRun (beStatement alpha "CREATE DOMAIN label AS VARCHAR(3)")
        mustRun (beStatement alpha "CREATE DOMAIN product_label AS label")
        absent <- beStatement beta "CREATE DOMAIN product_label AS label"
        fmap (const ()) absent `shouldBe` Left "unknown domain: label"
        mustRun (beStatement alpha "CREATE TABLE products (name product_label)")
        mustRun (beStatement alpha "INSERT INTO products (name) VALUES ('abc')")
        rowsOf (beStatement alpha "SELECT name FROM products") `shouldReturn` [[("name", VStr "abc")]]
        dependency <- beStatement alpha "DROP DOMAIN label"
        fmap (const ()) dependency `shouldSatisfy` either (const True) (const False)

    it "keeps two databases apart" $ withIpcStorage $ do
        base <- ipcBackend
        mustRun (beStatement base "CREATE DATABASE alpha")
        mustRun (beStatement base "CREATE DATABASE beta")
        let alpha = beWithDatabase base "alpha"
            beta = beWithDatabase base "beta"
        mustRun (beStatement alpha "CREATE TABLE t (id int)")
        mustRun (beStatement beta "CREATE TABLE t (id int)")
        mustRun (beStatement alpha "INSERT INTO t (id) VALUES (1)")
        mustRun (beStatement beta "INSERT INTO t (id) VALUES (2)")
        rowsA <- rowsOf (beStatement alpha "SELECT id FROM t")
        rowsB <- rowsOf (beStatement beta "SELECT id FROM t")
        intColumn "id" rowsA `shouldBe` [1]
        intColumn "id" rowsB `shouldBe` [2]

    it "runs two sessions at once without mixing their rows" $ withIpcStorage $ do
        base <- ipcBackend
        mustRun (beStatement base "CREATE DATABASE alpha")
        mustRun (beStatement base "CREATE DATABASE beta")
        let alpha = beWithDatabase base "alpha"
            beta = beWithDatabase base "beta"
        mustRun (beStatement alpha "CREATE TABLE p (id int)")
        mustRun (beStatement beta "CREATE TABLE p (id int)")
        doneA <- newEmptyMVar
        doneB <- newEmptyMVar
        _ <- forkIO (writeRows alpha [1 .. 20] doneA)
        _ <- forkIO (writeRows beta [101 .. 120] doneB)
        outs <- sequence [takeMVar doneA, takeMVar doneB]
        [err | Left err <- concat outs] `shouldBe` []
        rowsA <- rowsOf (beStatement alpha "SELECT id FROM p")
        rowsB <- rowsOf (beStatement beta "SELECT id FROM p")
        intColumn "id" rowsA `shouldMatchList` [1 .. 20]
        intColumn "id" rowsB `shouldMatchList` [101 .. 120]

    it "commits an explicit transaction to the real storage" $ withIpcStorage $ do
        base <- ipcBackend
        mustRun (beStatement base "CREATE DATABASE alpha")
        let alpha = beWithDatabase base "alpha"
        settings <- tempSettingsPath "transaction-ipc"
        removeIfExists settings
        session <- newSession alpha (T.pack testDatabaseName) settings
        _ <- mustSql session "use alpha"
        _ <- mustSql session "create table t (id int)"
        _ <- mustSql session "begin"
        _ <- mustSql session "insert into t (id) values (1)"
        inside <- mustSql session "select * from t"
        intValues (qrRows inside) `shouldBe` [1]
        _ <- mustSql session "commit"
        rows <- rowsOf (beStatement alpha "SELECT id FROM t")
        intColumn "id" rows `shouldBe` [1]

    it "rolls back to a savepoint on the real storage" $ withIpcStorage $ do
        base <- ipcBackend
        mustRun (beStatement base "CREATE DATABASE alpha")
        let alpha = beWithDatabase base "alpha"
        settings <- tempSettingsPath "transaction-ipc-savepoint"
        removeIfExists settings
        session <- newSession alpha (T.pack testDatabaseName) settings
        _ <- mustSql session "use alpha"
        _ <- mustSql session "create table t (id int)"
        _ <- mustSql session "begin"
        _ <- mustSql session "insert into t (id) values (1)"
        _ <- mustSql session "savepoint spot"
        _ <- mustSql session "insert into t (id) values (2)"
        _ <- mustSql session "rollback to spot"
        inside <- mustSql session "select * from t"
        intValues (qrRows inside) `shouldBe` [1]
        _ <- mustSql session "commit"
        rows <- rowsOf (beStatement alpha "SELECT id FROM t")
        intColumn "id" rows `shouldBe` [1]

    it "refuses the second COMMIT on the real storage" $ withIpcStorage $ do
        base <- ipcBackend
        mustRun (beStatement base "CREATE DATABASE alpha")
        let alpha = beWithDatabase base "alpha"
        mustRun (beStatement alpha "CREATE TABLE users (id int, name text, age int)")
        mustRun (beStatement alpha "INSERT INTO users (id, name, age) VALUES (1, 'a', 21)")
        settings <- tempSettingsPath "transaction-ipc-conflict"
        removeIfExists settings
        first <- newSession alpha (T.pack testDatabaseName) settings
        second <- newSession alpha (T.pack testDatabaseName) settings
        _ <- mustSql first "use alpha"
        _ <- mustSql second "use alpha"
        _ <- mustSql first "begin"
        _ <- mustSql second "begin"
        _ <- mustSql first "update users set age = 31 where id = 1"
        _ <- mustSql second "update users set age = 42 where id = 1"
        _ <- mustSql first "commit"
        denied <- runStatementCoded second "commit"
        failureCode denied `shouldBe` "serialization_failure"
        failureMessage denied `shouldBe` "write conflict on table users, id 1"
        _ <- mustSql second "rollback"
        rows <- rowsOf (beStatement alpha "SELECT id, age FROM users")
        intColumn "id" rows `shouldBe` [1]
        intColumn "age" rows `shouldBe` [31]