ChuSQL/chusql-web/test/Spec.hs

{-# LANGUAGE OverloadedStrings #-}

module Main (main) where

import ChuSQL.Interface.Link (closeClient, connectClient)
import ChuSQL.Interface.RateLimit (newRateLimiter)
import ChuSQL.Interface.Session (authenticateSession, newSession, runStatement)
import ChuSQL.Interface.Settings (
    applySettings,
    defaultOf,
    isLockedSetting,
    liveKeys,
    readSettingsFile,
    settingCatalogue,
    writeSettingsFile,
 )
import ChuSQL.Web.API (
    AppEnv (..),
    Live (..),
    defaultLive,
    isIdentifier,
    newAppEnvAt,
    parseCookieHeader,
    sessionCookieName,
    webApp,
 )
import ChuSQL.Web.Static (contentTypeOf, safeRelative)
import ChuSQL.Web.UISettings (validateUISettings)
import Control.Concurrent (forkIO)
import Control.Exception (IOException, bracket, try)
import Control.Monad (when)
import Data.Aeson (encode, object, (.=))
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.Char (isDigit)
import Data.List (isInfixOf)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Time.Clock (getCurrentTime)
import Data.Unique (hashUnique, newUnique)
import qualified Data.Vector as V
import Gates (gateSpec)
import Network.HTTP.Client (
    Manager,
    Request (method, requestBody, requestHeaders),
    RequestBody (RequestBodyLBS),
    Response (responseBody, responseHeaders, responseStatus),
    defaultManagerSettings,
    httpLbs,
    newManager,
    parseRequest,
 )
import Network.HTTP.Types (Header, Method, methodGet, methodPost, statusCode)
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Test as WT
import System.Directory (
    createDirectoryIfMissing,
    findExecutable,
    getTemporaryDirectory,
    removeFile,
    removePathForcibly,
 )
import System.Environment (lookupEnv)
import System.Exit (ExitCode (..))
import System.FilePath ((</>))
import System.Info (os)
import System.IO (Handle, hGetLine)
import System.Process (
    CreateProcess (std_err, std_out),
    ProcessHandle,
    StdStream (CreatePipe, NoStream),
    createProcess,
    proc,
    readProcessWithExitCode,
    terminateProcess,
    waitForProcess,
 )
import Test.Hspec
import Test.Hspec.Wai hiding (pendingWith)

-- ChuSQL Web 测试：纯函数、静态交付、门禁，以及打到真 server 的 HTTP 与 socket 用例。

-- | 夹具库名：测试默认选中的库
testDatabaseName :: Text
testDatabaseName = "test"

-- | 夹具管理员
adminUser :: Text
adminUser = "admin"

-- | 夹具管理员口令
adminPassword :: Text
adminPassword = "s3cret"

-- | 换成别的库（同名的旧头去掉）
withDb :: Text -> [Header] -> [Header]
withDb name hs = ("X-ChuSQL-Database", TE.encodeUtf8 name) : filter ((/= "X-ChuSQL-Database") . fst) hs

-- | with 块的会话别名，状态放 Application
type TestSession a = WaiSession Wai.Application a

-- | with 的变体：把 Application 放进会话状态
withApp :: IO Wai.Application -> SpecWith (Arg (WaiExpectation Wai.Application)) -> Spec
withApp mkApp = withState ((\app -> (app, app)) <$> mkApp)

-- | 纯断言抬进 WaiSession
check :: IO () -> TestSession ()
check = liftIO

-- | 加上 JSON 内容类型头
jsonHeaders :: [Header] -> [Header]
jsonHeaders hs = ("Content-Type", "application/json") : hs

-- | 拼出会话 Cookie 头
cookieHeader :: Text -> Header
cookieHeader token = ("Cookie", TE.encodeUtf8 (sessionCookieName <> "=" <> token))

-- | 发独立会话的 WAI 请求，不共享 cookie jar
requestAs :: Method -> BS.ByteString -> [Header] -> BL.ByteString -> TestSession WT.SResponse
requestAs verb path hs payload = do
    app <- getState
    liftIO $ WT.runSession send app
  where
    -- | 清空 cookie jar 后发出请求
    send = do
        WT.modifyClientCookies (const Map.empty)
        WT.srequest $
            WT.SRequest
                ( WT.setPath
                    ( WT.defaultRequest
                        { Wai.requestMethod = verb
                        , Wai.requestHeaders = hs
                        , Wai.requestBodyLength = Wai.KnownLength (fromIntegral (BL.length payload))
                        }
                    )
                    path
                )
                payload

-- | 带头发 GET 请求
getAs :: [Header] -> BS.ByteString -> TestSession WT.SResponse
getAs hs path = requestAs methodGet path hs BL.empty

-- | 带 JSON 头发 POST 请求
postAs :: [Header] -> BS.ByteString -> BL.ByteString -> TestSession WT.SResponse
postAs hs path payload = requestAs methodPost path (jsonHeaders hs) payload

-- | 带 JSON 头发 PUT 请求
putAs :: [Header] -> BS.ByteString -> BL.ByteString -> TestSession WT.SResponse
putAs hs path payload = requestAs "PUT" path (jsonHeaders hs) payload

-- | 带 JSON 头发 PATCH 请求
patchAs :: [Header] -> BS.ByteString -> BL.ByteString -> TestSession WT.SResponse
patchAs hs path payload = requestAs "PATCH" path (jsonHeaders hs) payload

-- | 带头发 DELETE 请求
deleteAs :: [Header] -> BS.ByteString -> TestSession WT.SResponse
deleteAs hs path = requestAs "DELETE" path hs BL.empty

-- | 用账号口令登录
loginAs :: Text -> Text -> TestSession WT.SResponse
loginAs user password =
    requestAs
        methodPost
        "/api/login"
        (jsonHeaders [])
        (encode (object ["user" .= user, "password" .= password]))

-- | 登录并返回会话 Cookie 请求头
signIn :: Text -> Text -> TestSession [Header]
signIn user password = do
    res <- loginAs user password
    expectStatusWith "sign-in" res 204
    case sessionCookieOf res of
        Just token -> pure [cookieHeader token]
        Nothing -> do
            check (expectationFailure "sign-in succeeded without a session cookie")
            pure []

-- | 以管理员登录并取请求头
adminHeaders :: TestSession [Header]
adminHeaders = signIn adminUser adminPassword

-- | 已登录的普通账号
ordinaryHeaders :: Text -> Text -> TestSession [Header]
ordinaryHeaders user password = do
    res <- loginAs user password
    expectStatusWith "ordinary sign-in" res 204
    case sessionCookieOf res of
        Just token -> pure [cookieHeader token]
        Nothing -> do
            check (expectationFailure "ordinary sign-in without a session cookie")
            pure []

-- | 建库，已存在就算就位
ensureDatabase :: [Header] -> Text -> TestSession ()
ensureDatabase hs name = do
    listed <- getAs hs "/api/databases"
    expectStatusWith "list databases" listed 200
    let names = map asText (items (jsonBody listed))
    when (name `notElem` names) $ do
        created <- postAs hs "/api/databases" (encode (object ["name" .= name]))
        expectStatusWith ("create database " <> T.unpack name) created 200

-- | 建表：已存在就当就位
ensureTable :: [Header] -> Text -> BL.ByteString -> TestSession ()
ensureTable hs name body = do
    listed <- getAs (withDb testDatabaseName hs) "/api/tables"
    expectStatusWith "list tables" listed 200
    let names = map (asText . at "table") (items (jsonBody listed))
    when (name `notElem` names) $ do
        created <- postAs (withDb testDatabaseName hs) "/api/tables" body
        expectStatusWith ("create table " <> T.unpack name) created 200

-- | 建账号：重名（409）也算就位
ensureAccount :: [Header] -> Text -> Text -> TestSession ()
ensureAccount hs user password = do
    created <-
        postAs
            (withDb "system" hs)
            "/api/tables/__system_users/rows"
            (encode (object ["values" .= object ["user" .= user, "password" .= password]]))
    check (statusCode (WT.simpleStatus created) `shouldSatisfy` (`elem` [200, 409]))

-- | 列定义
column :: Text -> Text -> A.Value
column name ty = object ["name" .= name, "type" .= ty]

-- | 响应体重解成 JSON
jsonBody :: WT.SResponse -> A.Value
jsonBody res = fromMaybe A.Null (A.decode (WT.simpleBody res))

-- | 取字段
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

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

-- | 数组字段的长度
arrayLen :: A.Value -> Int
arrayLen = length . items

-- | 第一行（位置化数组）
firstRow :: WT.SResponse -> [A.Value]
firstRow res = case items (at "rows" (jsonBody res)) of
    (A.Array xs : _) -> V.toList xs
    _ -> []

-- | items 数组里按键找一项（找不到给 Null）
headEntry :: Text -> [A.Value] -> A.Value
headEntry key entries = case [e | e <- entries, asText (at "key" e) == key] of
    (e : _) -> e
    [] -> A.Null

-- | 响应头
responseHeader :: Header -> WT.SResponse -> Maybe BS.ByteString
responseHeader (name, _) res = lookup name (WT.simpleHeaders res)

-- | 取 Set-Cookie 里的会话令牌
sessionCookieOf :: WT.SResponse -> Maybe Text
sessionCookieOf res = do
    raw <- lookup "Set-Cookie" (WT.simpleHeaders res)
    parseCookieHeader sessionCookieName (TE.decodeUtf8 raw)

-- | 状态码断言，失败时把响应体和状态码一起报出来（定位用）
expectStatusWith :: String -> WT.SResponse -> Int -> TestSession ()
expectStatusWith label res code =
    check $
        if statusCode (WT.simpleStatus res) == code
            then pure ()
            else
                expectationFailure
                    ( label
                        ++ ": expected "
                        ++ show code
                        ++ " but got "
                        ++ show (statusCode (WT.simpleStatus res))
                        ++ " body="
                        ++ show (WT.simpleBody res)
                    )

-- | Either 判成
isRightE :: Either a b -> Bool
isRightE = either (const False) (const True)

-- | Either 判错
isLeftE :: Either a b -> Bool
isLeftE = either (const True) (const False)

-- | 临时文件
tempFilePath :: String -> IO FilePath
tempFilePath name = do
    tmp <- getTemporaryDirectory
    uniq <- uniqueSuffix
    pure (tmp </> ("chusql-web-test-" ++ name ++ "-" ++ uniq ++ ".toml"))

-- | 非重复后缀
uniqueSuffix :: IO String
uniqueSuffix = do
    u <- newUnique
    pure (show (hashUnique u))

-- | 文件不存在也算成功
removeIfExists :: FilePath -> IO ()
removeIfExists path = do
    _ <- try (removeFile path) :: IO (Either IOException ())
    pure ()

-- | 临时静态目录，内容固定便于断言
makeStaticDir :: IO FilePath
makeStaticDir = do
    tmp <- getTemporaryDirectory
    uniq <- uniqueSuffix
    let dir = tmp </> ("chusql-web-static-" ++ uniq)
    createDirectoryIfMissing True dir
    BS.writeFile (dir </> "index.html") "<!DOCTYPE html><html lang=\"zh-CN\"><head></head><body>ChuSQL Console</body></html>"
    BS.writeFile (dir </> "app.js") "// test bundle\n"
    BS.writeFile (dir </> "style.css") "body{}\n"
    BS.writeFile (dir </> "secret.token") "do-not-serve\n"
    pure dir

-- | 只做静态交付的环境，不连 server
staticOnlyEnv :: FilePath -> IO AppEnv
staticOnlyEnv staticDir = do
    limiter <- newRateLimiter getCurrentTime 5 (5 * 60)
    settings <- tempFilePath "static"
    removeIfExists settings
    newAppEnvAt settings "127.0.0.1" 1 limiter staticDir

-- 真 server 世界 --------------------------------------------------------------

-- | 一个真 server 进程及其端口、配置和数据目录
data LiveWorld = LiveWorld
    { lwProcess :: ProcessHandle
    , lwPort :: Int
    , lwConfig :: FilePath
    , lwDataDir :: FilePath
    }

-- | 起 server 进程并从横幅读回端口
startLiveWorld :: String -> IO LiveWorld
startLiveWorld label = do
    bin <- locateServerExe
    tmp <- getTemporaryDirectory
    uniq <- uniqueSuffix
    let root = tmp </> ("chusql-web-live-" ++ label ++ "-" ++ uniq)
        dataDir = root </> "data"
        config = root </> "chusql.toml"
    createDirectoryIfMissing True dataDir
    writeFile config (serverConfigText dataDir)
    seedSystemCatalog config
    (_, Just out, _, process) <-
        createProcess (proc bin ["--config", config]){std_out = CreatePipe, std_err = NoStream}
    port <- readListeningPort out
    _ <- forkIO (drainHandle out)
    setAdminPassword port
    pure (LiveWorld process port config dataDir)

-- | 首启的管理员还没有口令：先用空口令登录，再按业务流程设一个
setAdminPassword :: Int -> IO ()
setAdminPassword port = do
    opened <- connectClient "127.0.0.1" port
    case opened of
        Left err -> fail ("fixture server refused the connection: " ++ T.unpack err)
        Right client -> do
            session <- newSession client
            signed <- authenticateSession session adminUser ""
            case signed of
                Left err -> fail ("fixture administrator cannot sign in: " ++ T.unpack err)
                Right () -> do
                    changed <- runStatement session ("ALTER USER " <> adminUser <> " IDENTIFIED BY '" <> adminPassword <> "'")
                    case changed of
                        Left err -> fail ("fixture administrator keeps no password: " ++ T.unpack err)
                        Right _ -> pure ()
            closeClient client

-- | 生成夹具 server 的配置文本
serverConfigText :: FilePath -> String
serverConfigText dataDir =
    unlines
        [ "[web]"
        , "user = \"" ++ T.unpack adminUser ++ "\""
        , "password-min-length = 8"
        , "password-classes = 2"
        , ""
        , "[server]"
        , "host = \"127.0.0.1\""
        , "port = 0"
        , ""
        , "[storage]"
        , "data_dir = \"" ++ slashed dataDir ++ "\""
        ]
  where
    -- | 反斜杠换成正斜杠
    slashed = map (\c -> if c == '\\' then '/' else c)

-- | 逐行读 stdout 直到读出端口
readListeningPort :: Handle -> IO Int
readListeningPort handle = do
    line <- hGetLine handle
    case portFromBanner line of
        Just port -> pure port
        Nothing -> readListeningPort handle

-- | 取一行里最后一串数字
portFromBanner :: String -> Maybe Int
portFromBanner line
    | not ("listening:" `isInfixOf` line) = Nothing
    | otherwise = case span isDigit (dropWhile (not . isDigit) (reverse line)) of
        ([], _) -> Nothing
        (digits, _) -> Just (read (reverse digits))

-- | 抽干 server 的 stdout
drainHandle :: Handle -> IO ()
drainHandle handle = do
    result <- try (hGetLine handle) :: IO (Either IOException String)
    case result of
        Left _ -> pure ()
        Right _ -> drainHandle handle

-- | 按平台补上 .exe 后缀
binaryName :: String -> String
binaryName stem = if os == "mingw32" then stem ++ ".exe" else stem

-- | 在 PATH 上查找 chusql-server
locateServerExe :: IO FilePath
locateServerExe = do
    found <- findExecutable (binaryName "chusql-server")
    case found of
        Just path -> pure path
        Nothing -> fail "chusql-server was not found on PATH: run `stack build` first"

-- | 全新的数据目录还没有系统目录：先跑引导程序建表并补一个免密管理员，
-- server 才肯启动（未引导的目录会被它拒绝）。
seedSystemCatalog :: FilePath -> IO ()
seedSystemCatalog config = do
    bootstrap <- locateBootstrapExe
    (code, out, errOut) <- readProcessWithExitCode bootstrap ["--config", config, "--passwordless"] ""
    case code of
        ExitSuccess -> pure ()
        _ -> fail ("the fixture bootstrap program failed (exit " ++ show code ++ "): " ++ out ++ errOut)

-- | 找引导程序：先环境变量，再 PATH
locateBootstrapExe :: IO FilePath
locateBootstrapExe = do
    fromEnv <- lookupEnv "CHUSQL_BOOTSTRAP_EXE"
    case fromEnv of
        Just path -> pure path
        Nothing -> do
            found <- findExecutable (binaryName "csql-bootstrap")
            case found of
                Just path -> pure path
                Nothing -> fail "csql-bootstrap was not found on PATH: run `stack build` first"

-- | 构造指向真 server 的 Web 环境
liveEnv :: LiveWorld -> FilePath -> Int -> IO AppEnv
liveEnv world staticDir attempts = do
    limiter <- newRateLimiter getCurrentTime attempts (5 * 60)
    uiPath <- tempFilePath "ui-settings"
    removeIfExists uiPath
    base <- newAppEnvAt (lwConfig world) "127.0.0.1" (lwPort world) limiter staticDir
    pure base{aeUISettingsFile = uiPath}

-- | 收摊：杀进程、清数据目录
stopServer :: LiveWorld -> IO ()
stopServer world = do
    terminateProcess (lwProcess world)
    _ <- try (waitForProcess (lwProcess world)) :: IO (Either IOException ExitCode)
    _ <- try (removePathForcibly (lwDataDir world)) :: IO (Either IOException ())
    pure ()

-- 纯函数 ---------------------------------------------------------------------

-- | 纯函数用例
unitSpec :: Spec
unitSpec = describe "pure helpers" $ do
    it "parses the session cookie out of a Cookie header" $ do
        parseCookieHeader sessionCookieName "a=1; chusql_session=abc123; b=2" `shouldBe` Just "abc123"
        parseCookieHeader sessionCookieName "other=1" `shouldBe` Nothing
        parseCookieHeader sessionCookieName "" `shouldBe` Nothing
    it "accepts plain identifiers and rejects everything else" $ do
        isIdentifier "users" `shouldBe` True
        isIdentifier "_9" `shouldBe` True
        isIdentifier "" `shouldBe` False
        isIdentifier "1users" `shouldBe` False
        isIdentifier "user-name" `shouldBe` False
        isIdentifier (T.replicate 65 "a") `shouldBe` False
    it "keeps static delivery inside the asset whitelist" $ do
        safeRelative "index.html" `shouldBe` Just "index.html"
        safeRelative "app.js" `shouldBe` Just "app.js"
        safeRelative "../secret.html" `shouldBe` Nothing
        safeRelative "asset/app.js" `shouldBe` Nothing
        safeRelative "secret.token" `shouldBe` Nothing
        safeRelative "index.htmlx" `shouldBe` Nothing
    it "maps extensions to content types" $ do
        contentTypeOf "index.html" `shouldBe` "text/html; charset=utf-8"
        contentTypeOf "app.js" `shouldBe` "text/javascript; charset=utf-8"
        contentTypeOf "x.woff2" `shouldBe` "font/woff2"
        contentTypeOf "x.bin" `shouldBe` "application/octet-stream"
    it "ships the documented live defaults" $ do
        lvMaxRows defaultLive `shouldBe` 1000
        lvPageSize defaultLive `shouldBe` 25
        lvBodyLimit defaultLive `shouldBe` 65536
    it "round-trips settings through a real TOML file" $ do
        path <- tempFilePath "settings"
        removeIfExists path
        writeSettingsFile path (Map.fromList [("rows-per-page", "50"), ("user", "admin")])
            >>= (`shouldSatisfy` isRightE)
        values <- readSettingsFile path
        Map.lookup "rows-per-page" values `shouldBe` Just "50"
        Map.lookup "user" values `shouldBe` Just "admin"
    it "rejects unknown settings and out-of-range limits" $ do
        applySettings Map.empty (Map.fromList [("nope", "1")]) `shouldSatisfy` isLeftE
        applySettings Map.empty (Map.fromList [("password-min-length", "3")]) `shouldSatisfy` isLeftE
        applySettings Map.empty (Map.fromList [("password-min-length", "12")]) `shouldSatisfy` isRightE
    it "marks the administrator name as locked and lists the live keys" $ do
        isLockedSetting "user" `shouldBe` True
        isLockedSetting "rows-per-page" `shouldBe` False
        ("rows-per-page" `elem` liveKeys) `shouldBe` True
        length settingCatalogue `shouldSatisfy` (> 20)
        defaultOf "rows-per-page" `shouldBe` "25"
    it "validates IDE settings" $ do
        validateUISettings (object ["sqlFontSize" .= (13 :: Int), "minimap" .= False])
            `shouldSatisfy` isRightE
        validateUISettings (object ["nope" .= (1 :: Int)]) `shouldSatisfy` isLeftE
        validateUISettings (A.String "nope") `shouldSatisfy` isLeftE

-- 静态交付 -------------------------------------------------------------------

-- | 静态交付用例
staticSpec :: FilePath -> Spec
staticSpec staticDir = describe "static delivery" $ do
    env <- runIO (staticOnlyEnv staticDir)
    withApp (webApp env) $ do
        it "serves the console page with a content-security-policy" $ do
            res <- requestAs methodGet "/" [] BL.empty
            expectStatusWith "index" res 200
            check (responseHeader ("Content-Type", "") res `shouldBe` Just "text/html; charset=utf-8")
            check (responseHeader ("Content-Security-Policy", "") res `shouldSatisfy` (/= Nothing))
            check (BSC.isInfixOf "chusql-style-nonce" (BL.toStrict (WT.simpleBody res)) `shouldBe` True)
        it "serves an asset inside the whitelist" $ do
            res <- requestAs methodGet "/static/app.js" [] BL.empty
            expectStatusWith "app.js" res 200
            check (responseHeader ("Content-Type", "") res `shouldBe` Just "text/javascript; charset=utf-8")
        it "refuses assets outside the whitelist" $ do
            res <- requestAs methodGet "/static/secret.token" [] BL.empty
            expectStatusWith "secret.token" res 404
        it "answers unknown routes with a JSON 404" $ do
            res <- requestAs methodGet "/api/nope" [] BL.empty
            expectStatusWith "unknown route" res 404
            check (asText (at "error" (jsonBody res)) `shouldBe` "not_found")
        it "reports the process is alive without touching the storage link" $ do
            res <- requestAs methodGet "/api/health" [] BL.empty
            expectStatusWith "health" res 200
            check (at "status" (jsonBody res) `shouldBe` A.String "ok")

-- 会话 -----------------------------------------------------------------------

-- | 登录与会话用例
sessionSpec :: AppEnv -> Spec
sessionSpec env = describe "sign-in and sessions (web -> TCP -> server)" $ do
    withApp (webApp env) $ do
        it "refuses protected endpoints without a cookie" $ do
            res <- requestAs methodGet "/api/databases" [] BL.empty
            expectStatusWith "no cookie" res 401
            check (asText (at "error" (jsonBody res)) `shouldBe` "unauthorized")
        it "refuses a wrong password" $ do
            res <- loginAs adminUser "not-the-password"
            expectStatusWith "wrong password" res 401
        it "signs in, reports the session policy from the server, and signs out" $ do
            res <- loginAs adminUser adminPassword
            expectStatusWith "sign-in" res 204
            token <- case sessionCookieOf res of
                Just t -> pure t
                Nothing -> do
                    check (expectationFailure "no session cookie after sign-in")
                    pure ""
            me <- getAs [cookieHeader token] "/api/session"
            expectStatusWith "session" me 200
            check (at "user" (jsonBody me) `shouldBe` A.String adminUser)
            check (at "administrator" (jsonBody me) `shouldBe` A.Bool True)
            check (asInt (at "minLength" (at "policy" (jsonBody me))) `shouldSatisfy` (>= 8))
            out <- requestAs "POST" "/api/logout" [cookieHeader token] BL.empty
            expectStatusWith "sign-out" out 204
            afterSignOut <- getAs [cookieHeader token] "/api/session"
            expectStatusWith "session after sign-out" afterSignOut 401
        it "reports the storage link through a fresh connection" $ do
            res <- requestAs methodGet "/api/status" [] BL.empty
            expectStatusWith "status" res 200
            check (at "storage" (jsonBody res) `shouldBe` A.String "up")

-- 门禁 -----------------------------------------------------------------------

-- | 门禁用例
gatingSpec :: AppEnv -> Spec
gatingSpec env = describe "gate keeping" $ do
    withApp (webApp env) $ do
        it "rejects an illegal database name in the request header" $ do
            hs <- adminHeaders
            res <- requestAs methodGet "/api/tables" (withDb "bad-name" hs) BL.empty
            expectStatusWith "illegal database" res 400
        it "rejects the account table outside the system database" $ do
            hs <- adminHeaders
            ensureDatabase hs testDatabaseName
            res <- getAs (withDb testDatabaseName hs) "/api/tables/__system_users/rows"
            expectStatusWith "account table outside system" res 400
        it "rejects role management without a cookie" $ do
            res <- getAs [] "/api/roles"
            expectStatusWith "roles without a cookie" res 401

-- 库、表、行 -----------------------------------------------------------------

-- | 库、表、行用例
catalogSpec :: AppEnv -> Spec
catalogSpec env = describe "databases, tables and rows" $ do
    withApp (webApp env) $ do
        it "creates a database, lists it and drops it" $ do
            hs <- adminHeaders
            created <- postAs hs "/api/databases" (encode (object ["name" .= ("shop" :: Text)]))
            expectStatusWith "create shop" created 200
            listed <- getAs hs "/api/databases"
            expectStatusWith "list databases" listed 200
            check (("shop" `elem` map asText (items (jsonBody listed))) `shouldBe` True)
            dropped <- deleteAs hs "/api/databases/shop"
            expectStatusWith "drop shop" dropped 200
        it "refuses to drop the system database" $ do
            hs <- adminHeaders
            res <- deleteAs hs "/api/databases/system"
            expectStatusWith "drop system" res 400
        it "creates a table, inserts a row, reads it back and updates it" $ do
            hs <- adminHeaders
            ensureDatabase hs testDatabaseName
            ensureTable
                hs
                "people"
                ( encode
                    ( object
                        [ "name" .= ("people" :: Text)
                        , "columns"
                            .= [ column "id" "int"
                               , column "name" "varchar(64)"
                               , column "note" "varchar(64)"
                               ]
                        ]
                    )
                )
            inserted <-
                postAs
                    (withDb testDatabaseName hs)
                    "/api/tables/people/rows"
                    ( encode
                        ( object
                            [ "values"
                                .= object
                                    [ "id" .= (1 :: Int)
                                    , "name" .= ("alice" :: Text)
                                    , "note" .= ("first" :: Text)
                                    ]
                            ]
                        )
                    )
            expectStatusWith "insert row" inserted 200
            rows <- getAs (withDb testDatabaseName hs) "/api/tables/people/rows?limit=10"
            expectStatusWith "read rows" rows 200
            check (asText (at "table" (jsonBody rows)) `shouldBe` "people")
            check (arrayLen (at "columns" (jsonBody rows)) `shouldBe` 3)
            check (arrayLen (at "rows" (jsonBody rows)) `shouldBe` 1)
            check (asInt (at "total" (jsonBody rows)) `shouldBe` 1)
            check (asInt (maybe A.Null id (nth 0 (firstRow rows))) `shouldBe` 1)
            check (asText (maybe A.Null id (nth 1 (firstRow rows))) `shouldBe` "alice")
            updated <-
                patchAs
                    (withDb testDatabaseName hs)
                    "/api/tables/people/rows/1"
                    (encode (object ["values" .= object ["note" .= ("changed" :: Text)]]))
            expectStatusWith "update row" updated 200
            again <- getAs (withDb testDatabaseName hs) "/api/tables/people/rows?limit=10"
            check (asText (maybe A.Null id (nth 2 (firstRow again))) `shouldBe` "changed")
        it "deletes the row and then the table" $ do
            hs <- adminHeaders
            ensureDatabase hs testDatabaseName
            ensureTable hs "scratch" (encode (object ["name" .= ("scratch" :: Text), "columns" .= [column "id" "int", column "label" "varchar(64)"]]))
            inserted <- postAs (withDb testDatabaseName hs) "/api/tables/scratch/rows" (encode (object ["values" .= object ["id" .= (2 :: Int), "label" .= ("x" :: Text)]]))
            expectStatusWith "insert scratch row" inserted 200
            deleted <- deleteAs (withDb testDatabaseName hs) "/api/tables/scratch/rows/2"
            expectStatusWith "delete row" deleted 200
            rows <- getAs (withDb testDatabaseName hs) "/api/tables/scratch/rows"
            check (asInt (at "total" (jsonBody rows)) `shouldBe` 0)
            dropped <- deleteAs (withDb testDatabaseName hs) "/api/tables/scratch"
            expectStatusWith "drop table" dropped 200
        it "manages indexes and columns of a table" $ do
            hs <- adminHeaders
            ensureDatabase hs testDatabaseName
            ensureTable hs "metrics" (encode (object ["name" .= ("metrics" :: Text), "columns" .= [column "id" "int", column "score" "int", column "tag" "varchar(64)"]]))
            made <- postAs (withDb testDatabaseName hs) "/api/tables/metrics/indexes" (encode (object ["column" .= ("score" :: Text)]))
            expectStatusWith "create index" made 200
            builtIn <- deleteAs (withDb testDatabaseName hs) "/api/tables/metrics/indexes/id"
            expectStatusWith "built-in index is refused" builtIn 400
            dropped <- deleteAs (withDb testDatabaseName hs) "/api/tables/metrics/indexes/score"
            expectStatusWith "drop index" dropped 200
            idColumn <- deleteAs (withDb testDatabaseName hs) "/api/tables/metrics/columns/id"
            expectStatusWith "built-in column is refused" idColumn 400
            columnDropped <- deleteAs (withDb testDatabaseName hs) "/api/tables/metrics/columns/tag"
            expectStatusWith "drop column" columnDropped 200

-- 设置与口令策略 -------------------------------------------------------------

-- | 设置与口令策略用例
settingsSpec :: AppEnv -> Spec
settingsSpec env = describe "settings and password policy" $ do
    withApp (webApp env) $ do
        it "shows the catalogue to the administrator" $ do
            hs <- adminHeaders
            res <- getAs hs "/api/settings"
            expectStatusWith "settings" res 200
            let entries = items (at "items" (jsonBody res))
            check (length entries `shouldSatisfy` (> 20))
            check (asText (at "value" (headEntry "rows-per-page" entries)) `shouldBe` "25")
            check (at "locked" (headEntry "user" entries) `shouldBe` A.Bool True)
        it "writes a setting, makes the server reload the policy, and reports it applied" $ do
            hs <- adminHeaders
            res <-
                putAs
                    hs
                    "/api/settings"
                    ( encode
                        ( object
                            [ "values"
                                .= object
                                    [ "password-min-length" .= ("16" :: Text)
                                    , "password-classes" .= ("3" :: Text)
                                    ]
                            ]
                        )
                    )
            expectStatusWith "write settings" res 200
            let applied = map asText (items (at "applied" (jsonBody res)))
            check (("password-min-length" `elem` applied) `shouldBe` True)
            me <- getAs hs "/api/session"
            check (asInt (at "minLength" (at "policy" (jsonBody me))) `shouldBe` 16)
            values <- liftIO (readSettingsFile (aeSettingsFile env))
            check (Map.lookup "password-min-length" values `shouldBe` Just "16")
            check (Map.lookup "user" values `shouldBe` Just adminUser)
        it "refuses unknown settings and the locked administrator name" $ do
            hs <- adminHeaders
            unknown <- putAs hs "/api/settings" (encode (object ["values" .= object ["nope" .= ("1" :: Text)]]))
            expectStatusWith "unknown setting" unknown 400
            locked <- putAs hs "/api/settings" (encode (object ["values" .= object ["user" .= ("hacked" :: Text)]]))
            expectStatusWith "locked administrator name" locked 403

-- 账号表 ---------------------------------------------------------------------

-- | 账号表用例
accountSpec :: AppEnv -> Spec
accountSpec env = describe "the account table (system database, admin only)" $ do
    withApp (webApp env) $ do
        it "lists the account table in the system database" $ do
            hs <- adminHeaders
            res <- getAs (withDb "system" hs) "/api/tables"
            expectStatusWith "system tables" res 200
            check (("__system_users" `elem` map (asText . at "table") (items (jsonBody res))) `shouldBe` True)
        it "creates an account, changes its password, signs in as it and drops it" $ do
            hs <- adminHeaders
            ensureAccount hs "alice" "alice-Secret-1234"
            duplicate <-
                postAs
                    (withDb "system" hs)
                    "/api/tables/__system_users/rows"
                    (encode (object ["values" .= object ["user" .= ("alice" :: Text), "password" .= ("alice-Secret-9999" :: Text)]]))
            expectStatusWith "duplicate account" duplicate 409
            alice <- ordinaryHeaders "alice" "alice-Secret-1234"
            forbidden <- getAs (withDb "system" alice) "/api/tables"
            expectStatusWith "ordinary account cannot enter system" forbidden 403
            visible <- getAs alice "/api/databases"
            expectStatusWith "ordinary account lists databases" visible 200
            check (("system" `elem` map asText (items (jsonBody visible))) `shouldBe` False)
            changed <-
                patchAs
                    (withDb "system" hs)
                    "/api/tables/__system_users/rows/alice"
                    (encode (object ["values" .= object ["password" .= ("alice-Secret-5678" :: Text)]]))
            expectStatusWith "change password" changed 200
            _ <- ordinaryHeaders "alice" "alice-Secret-5678"
            dropped <- deleteAs (withDb "system" hs) "/api/tables/__system_users/rows/alice"
            expectStatusWith "drop account" dropped 200
        it "refuses account writes without a cookie" $ do
            res <- getAs (withDb "system" []) "/api/tables/__system_users/rows"
            expectStatusWith "account rows without a cookie" res 401

-- 角色 -----------------------------------------------------------------------

-- | 角色与授权用例
roleSpec :: AppEnv -> Spec
roleSpec env = describe "roles and grants" $ do
    withApp (webApp env) $ do
        it "creates a role, grants a privilege, adds a member and drops it" $ do
            hs <- adminHeaders
            ensureDatabase hs testDatabaseName
            ensureAccount hs "bob" "bob-Secret-123456"
            created <- postAs hs "/api/roles" (encode (object ["name" .= ("analyst" :: Text)]))
            expectStatusWith "create role" created 200
            granted <-
                postAs
                    hs
                    "/api/roles/analyst/grants"
                    (encode (object ["object" .= testDatabaseName, "privileges" .= (["select"] :: [Text])]))
            expectStatusWith "grant privilege" granted 200
            member <- postAs hs "/api/roles/analyst/members" (encode (object ["user" .= ("bob" :: Text)]))
            expectStatusWith "add member" member 200
            listed <- getAs hs "/api/roles"
            expectStatusWith "list roles" listed 200
            check (("analyst" `elem` map (asText . at "name") (items (jsonBody listed))) `shouldBe` True)
            removed <- deleteAs hs "/api/roles/analyst/members/bob"
            expectStatusWith "remove member" removed 200
            revoked <-
                deleteAs
                    hs
                    "/api/roles/analyst/grants"
            expectStatusWith "revoke without a body" revoked 400
            dropped <- deleteAs hs "/api/roles/analyst"
            expectStatusWith "drop role" dropped 200

-- SQL 控制台 -----------------------------------------------------------------

-- | SQL 控制台用例
querySpec :: AppEnv -> Spec
querySpec env = describe "the SQL console" $ do
    withApp (webApp env) $ do
        it "runs DDL and DML and returns positional rows" $ do
            hs <- adminHeaders
            ensureDatabase hs testDatabaseName
            made <- postAs (withDb testDatabaseName hs) "/api/query" (encode (object ["sql" .= ("CREATE TABLE console_probe (id int, label varchar(64))" :: Text)]))
            expectStatusWith "create table by SQL" made 200
            inserted <- postAs (withDb testDatabaseName hs) "/api/query" (encode (object ["sql" .= ("INSERT INTO console_probe (id, label) VALUES (7, 'seven')" :: Text)]))
            expectStatusWith "insert by SQL" inserted 200
            res <- postAs (withDb testDatabaseName hs) "/api/query" (encode (object ["sql" .= ("SELECT * FROM console_probe" :: Text)]))
            expectStatusWith "select by SQL" res 200
            check (asInt (at "rowCount" (jsonBody res)) `shouldBe` 1)
            check (arrayLen (at "columns" (jsonBody res)) `shouldBe` 2)
            check (asText (maybe A.Null id (nth 1 (firstRow res))) `shouldBe` "seven")
        it "refuses an empty statement" $ do
            hs <- adminHeaders
            ensureDatabase hs testDatabaseName
            res <- postAs (withDb testDatabaseName hs) "/api/query" (encode (object ["sql" .= ("" :: Text)]))
            expectStatusWith "empty sql" res 400
        it "refuses an oversized body" $ do
            hs <- adminHeaders
            res <- postAs (withDb testDatabaseName hs) "/api/query" (BL.replicate 70000 32)
            expectStatusWith "oversized body" res 413
        it "reports a syntax error as a bad request" $ do
            hs <- adminHeaders
            ensureDatabase hs testDatabaseName
            res <- postAs (withDb testDatabaseName hs) "/api/query" (encode (object ["sql" .= ("SELEC nonsense" :: Text)]))
            expectStatusWith "syntax error" res 400

-- IDE 设置 -------------------------------------------------------------------

-- | IDE 设置用例
uiSettingsSpec :: AppEnv -> Spec
uiSettingsSpec env = describe "IDE settings" $ do
    withApp (webApp env) $ do
        it "round-trips a valid payload" $ do
            hs <- adminHeaders
            initialUi <- getAs hs "/api/ui-settings"
            expectStatusWith "read IDE settings" initialUi 200
            saved <- putAs hs "/api/ui-settings" (encode (object ["sqlFontSize" .= (13 :: Int), "minimap" .= False]))
            expectStatusWith "write IDE settings" saved 204
            updatedUi <- getAs hs "/api/ui-settings"
            check (at "sqlFontSize" (jsonBody updatedUi) `shouldBe` A.Number 13)
        it "refuses an unknown key" $ do
            hs <- adminHeaders
            bad <- putAs hs "/api/ui-settings" (encode (object ["nope" .= (1 :: Int)]))
            expectStatusWith "unknown IDE setting" bad 400
        it "needs a session" $ do
            res <- getAs [] "/api/ui-settings"
            expectStatusWith "IDE settings without a cookie" res 401

-- 限流 -----------------------------------------------------------------------

-- | 登录限流用例
rateLimitSpec :: AppEnv -> Spec
rateLimitSpec env = describe "sign-in rate limiting" $ do
    withApp (webApp env) $ do
        it "locks the account after the configured failures" $ do
            first <- loginAs adminUser "wrong-one"
            expectStatusWith "first failure" first 401
            second <- loginAs adminUser "wrong-two"
            expectStatusWith "locked out" second 429
            third <- loginAs adminUser adminPassword
            expectStatusWith "still locked out" third 429

-- 真 socket 端到端 -----------------------------------------------------------

-- | 真 socket 端到端用例
e2eSpec :: AppEnv -> Spec
e2eSpec env = describe "end to end (HTTP socket -> web -> TCP -> server -> storage)" $ do
    it "signs in over a real socket and lists databases" $ do
        Warp.testWithApplication (webApp env) $ \port -> do
            manager <- newManager defaultManagerSettings
            login <- httpJson manager port methodPost "/api/login" [] (encode (object ["user" .= adminUser, "password" .= adminPassword]))
            statusCode (responseStatus login) `shouldBe` 204
            let cookie = case cookieOf login of
                    Just token -> [cookieHeader token]
                    Nothing -> []
            listed <- httpJson manager port methodGet "/api/databases" cookie BL.empty
            statusCode (responseStatus listed) `shouldBe` 200
            let body = fromMaybe A.Null (A.decode (responseBody listed))
            ("system" `elem` map asText (items body)) `shouldBe` True

-- | 走真 HTTP 客户端打出去的一个请求
httpJson :: Manager -> Int -> Method -> BS.ByteString -> [Header] -> BL.ByteString -> IO (Response BL.ByteString)
httpJson manager port httpMethod path headers payload = do
    baseRequest <- parseRequest ("http://127.0.0.1:" ++ show port ++ BSC.unpack path)
    httpLbs
        baseRequest
            { method = httpMethod
            , requestHeaders = jsonHeaders headers
            , requestBody = RequestBodyLBS payload
            }
        manager

-- | 从响应里取会话令牌
cookieOf :: Response BL.ByteString -> Maybe Text
cookieOf res = do
    raw <- lookup "Set-Cookie" (responseHeaders res)
    parseCookieHeader sessionCookieName (TE.decodeUtf8 raw)

-- | 入口：起夹具并跑全部用例
main :: IO ()
main = do
    staticDir <- makeStaticDir
    -- server 用 bracket 兜底收摊：断言抛异常、用例被过滤器全跳过，都不会留下孤儿进程占着 exe
    bracket (startLiveWorld "main") stopServer $ \world ->
        bracket (startLiveWorld "limited") stopServer $ \limitedWorld -> do
            env <- liveEnv world staticDir 5
            limitedEnv <- liveEnv limitedWorld staticDir 1
            hspec (spec staticDir env limitedEnv)

-- | 汇总挂载全部用例组
spec :: FilePath -> AppEnv -> AppEnv -> Spec
spec staticDir env limitedEnv = do
    unitSpec
    staticSpec staticDir
    gateSpec
    sessionSpec env
    gatingSpec env
    catalogSpec env
    settingsSpec env
    accountSpec env
    roleSpec env
    querySpec env
    uiSettingsSpec env
    e2eSpec env
    rateLimitSpec limitedEnv