大更新：

1、完善SQL语法
2、移除node前端，只保留静态资源
3、写好安装脚本
4、做好linux适配

chusql-cli/app/Main.hs

@@ -0,0 +1,206 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (main) where
+
+import ChuSQL.CLI.Format (OutputFormat (..), formatName, parseFormat)
+import ChuSQL.CLI.Script (stripTerminator)
+import ChuSQL.CLI.Session (
+    Session,
+    authenticateSession,
+    isPlainIdentifier,
+    newSession,
+    switchDatabase,
+ )
+import ChuSQL.Web.Auth (Credential (..))
+import ChuSQL.Web.Backend (ipcBackend)
+import ChuSQL.Web.Config (WebConfig (..), defaultPassword, loadWebConfigAt, resolveCredential, resolvePipeName)
+import ChuSQL.Web.Settings (readSettingsFile)
+import ChuSQL.Web.TOML (resolveConfigPath)
+import ChuSQL.Web.StorageProcess (
+    StorageProcess,
+    findStorageServer,
+    startStorageProcessAt,
+    stopStorageProcess,
+    waitForStorage,
+ )
+import ChuSQL.Storage.IPC (setPipeName)
+import Control.Exception (finally)
+import Control.Monad (unless)
+import Data.IORef (newIORef)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Options.Applicative
+import Repl (reportError, runRepl, runStatementOnce)
+import System.Console.Haskeline (defaultSettings, getPassword, runInputT)
+import System.Directory (getHomeDirectory)
+import System.Exit (exitFailure)
+import System.FilePath ((</>))
+import System.IO (hSetEncoding, stderr, stdout, utf8)
+
+-- chusql-cli：与 Web 管理端并列的前端，直连存储与引擎，账号与 Web 共用。
+
+data Options = Options
+    { optUser :: Maybe Text
+    , optPromptPassword :: Bool
+    , optDatabase :: Text
+    , optFormat :: OutputFormat
+    , optExecute :: Maybe Text
+    , optHistory :: Maybe FilePath
+    , optPipe :: Maybe String
+    , optStorage :: Maybe FilePath
+    , optConfig :: Maybe FilePath
+    }
+
+optionsParser :: Parser Options
+optionsParser =
+    Options
+        <$> optional (T.pack <$> strOption (long "user" <> short 'u' <> metavar "USER" <> help "Sign in as this account (default: the configured administrator)"))
+        <*> switch (long "password" <> short 'p' <> help "Always ask for the password, ignoring the configured one")
+        <*> ( T.pack
+                <$> strOption
+                    ( long "database"
+                        <> short 'd'
+                        <> metavar "DB"
+                        <> value ""
+                        <> help "Database to use (default: none, select one with USE)"
+                    )
+            )
+        <*> option
+            (eitherReader formatReader)
+            ( long "format"
+                <> short 'f'
+                <> metavar "FORMAT"
+                <> value FormatTable
+                <> showDefaultWith (T.unpack . formatName)
+                <> help "Output format: table, json or csv"
+            )
+        <*> optional (T.pack <$> strOption (long "execute" <> short 'e' <> metavar "SQL" <> help "Run one statement and exit"))
+        <*> optional (strOption (long "history" <> metavar "FILE" <> help "SQL history file (default ~/.chusql_history)"))
+        <*> optional (strOption (long "pipe" <> metavar "NAME" <> help "Endpoint name of the storage process (Windows named pipe, Unix socket file; default: [server] pipe_name in chusql.toml)"))
+        <*> optional (strOption (long "storage" <> metavar "SERVER" <> help "Rust storage executable to spawn when nothing answers the endpoint"))
+        <*> optional (strOption (long "config" <> metavar "FILE" <> help "Config file to read (default: the fixed chusql.toml under the system config directory)"))
+
+formatReader :: String -> Either String OutputFormat
+formatReader raw = maybe (Left "format must be table, json or csv") Right (parseFormat (T.pack raw))
+
+parserInfo :: ParserInfo Options
+parserInfo =
+    info
+        (optionsParser <**> helper)
+        ( fullDesc
+            <> progDesc "Run SQL against the ChuSQL storage engine"
+            <> header "csql - the ChuSQL command line client"
+        )
+
+main :: IO ()
+main = do
+    hSetEncoding stdout utf8
+    hSetEncoding stderr utf8
+    options <- execParser parserInfo
+    configPath <- resolveConfigPath (optConfig options)
+    base <- loadWebConfigAt configPath
+    let settingsFile = configPath
+    saved <- readSettingsFile settingsFile
+    credential <- resolveCredential base saved
+    let rootName = credUser credential
+        userName = fromMaybe rootName (optUser options)
+        pipeName = resolvePipe options base
+    setPipeName pipeName
+    password <- resolvePassword (optPromptPassword options) userName rootName saved
+    storage <- acquireStorage options pipeName settingsFile
+    case storage of
+        Left message -> reportError message >> exitFailure
+        Right spawned ->
+            connect options credential settingsFile userName password
+                `finally` maybe (pure ()) stopStorageProcess spawned
+
+-- | 接上存储，登录，然后进交互或跑单条语句
+connect :: Options -> Credential -> FilePath -> Text -> Text -> IO ()
+connect options credential settingsFile userName password = do
+    backend <- ipcBackend
+    session <- newSession backend credential settingsFile
+    signedIn <- authenticateSession session userName password
+    case signedIn of
+        Left message -> reportError message >> exitFailure
+        Right () -> runSession options session
+
+runSession :: Options -> Session -> IO ()
+runSession options session = do
+    formatRef <- newIORef (optFormat options)
+    ready <- selectDatabase session (T.strip (optDatabase options))
+    if not ready
+        then exitFailure
+        else case optExecute options of
+            Just sql -> do
+                ok <- runStatementOnce session (optFormat options) (stripTerminator sql)
+                unless ok exitFailure
+            Nothing -> do
+                historyFile <- resolveHistory (optHistory options)
+                runRepl session formatRef historyFile
+
+-- | 只有 -d 明确给了一个库才切；没给就保持"未选库"（服务没有默认库）
+selectDatabase :: Session -> Text -> IO Bool
+selectDatabase _ wanted | T.null wanted = pure True
+selectDatabase session wanted
+    | not (isPlainIdentifier wanted) = reportError ("not a plain database name: " <> wanted) >> pure False
+    | otherwise = do
+        switched <- switchDatabase session wanted
+        case switched of
+            Left message -> reportError message >> pure False
+            Right () -> pure True
+
+-- | 口令：-p 强制交互输入；否则配置里的 root 明文（同 Web）> 交互输入
+resolvePassword :: Bool -> Text -> Text -> Map.Map Text Text -> IO Text
+resolvePassword forcePrompt userName rootName saved
+    | forcePrompt = promptPassword userName
+    | T.toLower userName == T.toLower rootName = pure (configuredPassword saved)
+    | otherwise = promptPassword userName
+  where
+    configuredPassword values = case nonEmpty (Map.lookup "password" values) of
+        Just plain -> plain
+        Nothing -> defaultPassword
+
+promptPassword :: Text -> IO Text
+promptPassword user = do
+    entered <- runInputT defaultSettings (getPassword (Just '*') (T.unpack user <> "'s password: "))
+    pure (maybe "" T.pack entered)
+
+-- | 先找已经在跑的存储；--storage 给了可执行文件才自己拉一个
+acquireStorage :: Options -> String -> FilePath -> IO (Either Text (Maybe StorageProcess))
+acquireStorage options pipeName configPath = do
+    up <- waitForStorage 4
+    case optStorage options of
+        Nothing
+            | up -> pure (Right Nothing)
+            | otherwise ->
+                pure
+                    ( Left
+                        ( "no storage process answered on pipe "
+                            <> T.pack pipeName
+                            <> "; start the server first, or pass --storage <path>"
+                        )
+                    )
+        Just given
+            | up -> pure (Right Nothing)
+            | otherwise -> do
+                found <- findStorageServer (Just given)
+                case found of
+                    Left err -> pure (Left (T.pack err))
+                    Right binary -> fmap (either (Left . T.pack) (Right . Just)) (startStorageProcessAt binary pipeName configPath)
+
+-- | 管名：--pipe > chusql.toml 的 [server] pipe_name（缺省 chusql-joint）
+resolvePipe :: Options -> WebConfig -> String
+resolvePipe options base = fromMaybe (resolvePipeName base) (optPipe options)
+
+nonEmpty :: Maybe Text -> Maybe Text
+nonEmpty given = case T.strip <$> given of
+    Just text | not (T.null text) -> Just text
+    _ -> Nothing
+
+resolveHistory :: Maybe FilePath -> IO (Maybe FilePath)
+resolveHistory (Just path) = pure (Just path)
+resolveHistory Nothing = do
+    home <- getHomeDirectory
+    pure (Just (home </> ".chusql_history"))

chusql-cli/app/Repl.hs

@@ -0,0 +1,192 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Repl
+    ( runRepl
+    , runStatementOnce
+    , reportError
+    ) where
+
+import ChuSQL.CLI.Format (OutputFormat, formatName, renderResult, renderRows)
+import ChuSQL.CLI.Script (Meta (..), errorHint, metaHelp, parseMeta, takeStatement)
+import ChuSQL.CLI.Session (Session, accountTable, catalog, databases, roleViews, runStatement, sessionDatabase, switchDatabase)
+import ChuSQL.Storage.IPC (SchemaColumn (..), TableInfo (..))
+import ChuSQL.Web.Privileges (Grant (..), RoleView (..))
+import Control.Monad (forM_, when)
+import Control.Monad.IO.Class (liftIO)
+import Data.IORef (IORef, readIORef, writeIORef)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+import System.Console.Haskeline
+import System.IO (hIsTerminalDevice, stderr, stdin)
+
+-- 交互层：提示符、多行输入、历史、元命令与错误提示。
+
+-- | 交互循环；historyPath 为 Nothing 就不落盘历史
+runRepl :: Session -> IORef OutputFormat -> Maybe FilePath -> IO ()
+runRepl session formatRef historyPath =
+    runInputT (defaultSettings{historyFile = historyPath}) (loop session formatRef T.empty)
+
+-- | 入口处直接报错（-e 与启动阶段用）
+reportError :: Text -> IO ()
+reportError message = do
+    TIO.hPutStrLn stderr ("chusql: error: " <> message)
+    forM_ (errorHint message) (\hint -> TIO.hPutStrLn stderr ("hint: " <> hint))
+
+-- | 跑一条语句并按格式打印；成功与否当退出码
+runStatementOnce :: Session -> OutputFormat -> Text -> IO Bool
+runStatementOnce session format sql = do
+    result <- runStatement session sql
+    case result of
+        Left message -> reportError message >> pure False
+        Right answer -> TIO.putStrLn (renderResult format answer) >> pure True
+
+loop :: Session -> IORef OutputFormat -> Text -> InputT IO ()
+loop session formatRef buffer = do
+    prompt <- liftIO (promptFor session buffer)
+    entered <- getInputLine (T.unpack prompt)
+    case entered of
+        Nothing -> do
+            interactive <- liftIO (hIsTerminalDevice stdin)
+            when interactive (outputStrLn "")
+        Just raw -> do
+            let line = T.strip (T.pack raw)
+            if T.null line
+                then loop session formatRef buffer
+                else case (T.null buffer, parseMeta line) of
+                    (True, Just meta) -> do
+                        again <- runMeta session formatRef meta
+                        when again (loop session formatRef T.empty)
+                    _ -> do
+                        let extended = if T.null buffer then line else buffer <> "\n" <> line
+                        remaining <- drain session formatRef extended
+                        loop session formatRef remaining
+
+-- | 提示符带上当前库；续行换个样子，方便看出语句还没写完；管道输入时不出提示符
+promptFor :: Session -> Text -> IO Text
+promptFor session buffer = do
+    interactive <- hIsTerminalDevice stdin
+    if not interactive
+        then pure ""
+        else
+            if not (T.null (T.strip buffer))
+                then pure "     -> "
+                else do
+                    current <- sessionDatabase session
+                    pure (if T.null current then "chusql> " else "chusql [" <> current <> "]> ")
+
+-- | 把攒下来的内容里所有完整语句依次执行，返回没写完的残余
+drain :: Session -> IORef OutputFormat -> Text -> InputT IO Text
+drain session formatRef buffer = case takeStatement buffer of
+    Nothing -> pure (T.strip buffer)
+    Just (statement, rest) -> do
+        when (not (T.null statement)) (runOne session formatRef statement)
+        drain session formatRef rest
+
+runOne :: Session -> IORef OutputFormat -> Text -> InputT IO ()
+runOne session formatRef statement = do
+    result <- liftIO (runStatement session statement)
+    case result of
+        Left message -> liftIO (reportError message)
+        Right answer -> do
+            format <- liftIO (readIORef formatRef)
+            outputStrLn (T.unpack (renderResult format answer))
+
+runMeta :: Session -> IORef OutputFormat -> Meta -> InputT IO Bool
+runMeta session formatRef meta = case meta of
+    MetaQuit -> pure False
+    MetaHelp -> outputStrLn (T.unpack metaHelp) >> pure True
+    MetaDatabases -> listDatabases session >> pure True
+    MetaTables -> listTables session >> pure True
+    MetaDescribe name -> describeTable session name >> pure True
+    MetaRoles -> listRoles session >> pure True
+    MetaConnect name -> do
+        switched <- liftIO (switchDatabase session name)
+        case switched of
+            Left message -> liftIO (reportError message)
+            Right () -> outputStrLn ("database is now " <> T.unpack name)
+        pure True
+    MetaSetFormat format -> do
+        liftIO (writeIORef formatRef format)
+        outputStrLn ("output format is now " <> T.unpack (formatName format))
+        pure True
+    MetaUnknown name -> outputStrLn ("unknown command: \\" <> T.unpack name <> " (try \\?)") >> pure True
+
+-- | \l：库清单
+listDatabases :: Session -> InputT IO ()
+listDatabases session = do
+    answer <- liftIO (databases session)
+    case answer of
+        Left message -> liftIO (reportError message)
+        Right names -> outputStrLn (T.unpack (renderRows ["database"] (map (: []) names)))
+
+-- | \dt：表清单（base 里补上账号表）
+listTables :: Session -> InputT IO ()
+listTables session = do
+    answer <- liftIO (catalog session)
+    case answer of
+        Left message -> liftIO (reportError message)
+        Right tables -> do
+            allTables <- liftIO (withAccountTable session tables)
+            outputStrLn (T.unpack (renderRows headers (map tableRow allTables)))
+  where
+    headers = ["table", "columns", "rows", "indexes"]
+    tableRow info =
+        [ T.pack (tiTable info)
+        , tshow (length (tiColumns info))
+        , tshow (tiRows info)
+        , if null (tiIndexes info) then "-" else T.intercalate ", " (map T.pack (tiIndexes info))
+        ]
+
+-- | \d <table>：列结构
+describeTable :: Session -> Text -> InputT IO ()
+describeTable session name = do
+    answer <- liftIO (catalog session)
+    case answer of
+        Left message -> liftIO (reportError message)
+        Right tables -> do
+            allTables <- liftIO (withAccountTable session tables)
+            case filter (matches name) allTables of
+                [] -> liftIO (reportError ("unknown table: " <> name))
+                (info : _) -> outputStrLn (T.unpack (renderRows headers (map columnRow (tiColumns info))))
+  where
+    headers = ["column", "type", "primary", "unique", "nullable", "auto"]
+    matches wanted info = T.toLower (T.pack (tiTable info)) == T.toLower wanted
+    columnRow column =
+        [ T.pack (scName column)
+        , T.pack (scType column)
+        , yesNo (scPrimaryKey column)
+        , yesNo (scUnique column)
+        , yesNo (scNullable column)
+        , yesNo (scAutoIncrement column)
+        ]
+    yesNo True = "yes"
+    yesNo False = "no"
+
+-- | \dr：角色清单（授权对象与成员）
+listRoles :: Session -> InputT IO ()
+listRoles session = do
+    answer <- liftIO (roleViews session)
+    case answer of
+        Left message -> liftIO (reportError message)
+        Right roles -> outputStrLn (T.unpack (renderRows ["role", "grants", "members"] (map roleRow roles)))
+  where
+    roleRow view =
+        [ roleName view
+        , if null (roleGrants view) then "-" else T.intercalate ", " (map grantText (roleGrants view))
+        , if null (roleMembers view) then "-" else T.intercalate ", " (roleMembers view)
+        ]
+    grantText grant = grantPrivilege grant <> " on " <> grantObject grant
+
+-- | 当前库是 system 时，把账号表也列出来（与 Web 端一致）
+withAccountTable :: Session -> [TableInfo] -> IO [TableInfo]
+withAccountTable session tables = do
+    current <- sessionDatabase session
+    if current /= "system"
+        then pure tables
+        else do
+            extra <- accountTable session
+            pure (maybe tables (: tables) extra)
+
+tshow :: Show a => a -> Text
+tshow = T.pack . show

chusql-cli/chusql-cli.cabal

@@ -0,0 +1,57 @@
+cabal-version: 2.4
+
+name:           chusql-cli
+version:        1.0.0
+synopsis:       ChuSQL 命令行客户端：直连引擎与存储，与 Web 管理端共用账号
+description:    ChuSQL 的命令行前端。直接走命名管道接 Rust 存储进程与 Haskell 引擎，
+                不经过 Web REST；root 凭据与 __chusql_users 表与 Web 管理端完全共用。
+build-type:     Simple
+
+library
+    hs-source-dirs:   src
+    exposed-modules:  ChuSQL.CLI.Format
+                      ChuSQL.CLI.Script
+                      ChuSQL.CLI.Session
+    build-depends:    base >= 4.14 && < 5
+                    , aeson
+                    , bytestring
+                    , chusql-engine
+                    , chusql-web
+                    , scientific
+                    , text
+                    , time
+    default-language: Haskell2010
+    ghc-options:      -Wall
+
+executable csql
+    main-is:          Main.hs
+    other-modules:    Repl
+    hs-source-dirs:   app
+    build-depends:    base
+                    , aeson
+                    , chusql-cli
+                    , chusql-engine
+                    , chusql-web
+                    , containers
+                    , directory
+                    , filepath
+                    , haskeline
+                    , optparse-applicative
+                    , text
+    default-language: Haskell2010
+    ghc-options:      -Wall
+
+test-suite chusql-cli-test
+    type:             exitcode-stdio-1.0
+    main-is:          Spec.hs
+    hs-source-dirs:   test
+    build-depends:    base
+                    , aeson
+                    , bytestring
+                    , chusql-cli
+                    , chusql-engine
+                    , chusql-web
+                    , hspec
+                    , text
+    default-language: Haskell2010
+    ghc-options:      -Wall

chusql-cli/src/ChuSQL/CLI/Format.hs

@@ -0,0 +1,102 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.CLI.Format
+    ( OutputFormat (..)
+    , parseFormat
+    , formatName
+    , renderResult
+    , renderTable
+    , renderRows
+    , renderCsv
+    , renderJson
+    , displayValue
+    ) where
+
+import ChuSQL.CLI.Session (QueryResult (..), queryResultJson)
+import ChuSQL.Model (Value (..))
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Lazy as BL
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8)
+
+-- 结果输出：表格、JSON、CSV 三种格式。
+
+data OutputFormat = FormatTable | FormatJson | FormatCsv
+    deriving (Eq, Show)
+
+formatName :: OutputFormat -> Text
+formatName FormatTable = "table"
+formatName FormatJson = "json"
+formatName FormatCsv = "csv"
+
+-- | 认一个格式名
+parseFormat :: Text -> Maybe OutputFormat
+parseFormat raw = case T.toLower (T.strip raw) of
+    "table" -> Just FormatTable
+    "json" -> Just FormatJson
+    "csv" -> Just FormatCsv
+    _ -> Nothing
+
+renderResult :: OutputFormat -> QueryResult -> Text
+renderResult FormatTable = renderTable
+renderResult FormatJson = renderJson
+renderResult FormatCsv = renderCsv
+
+-- | 紧凑 JSON，方便管道里再用
+renderJson :: QueryResult -> Text
+renderJson = decodeUtf8 . BL.toStrict . A.encode . queryResultJson
+
+renderCsv :: QueryResult -> Text
+renderCsv result = T.unlines (header : map rowLine (qrRows result))
+  where
+    header = T.intercalate "," (map csvField (qrColumns result))
+    rowLine row = T.intercalate "," (map (csvField . csvCell) row)
+
+-- | CSV 里的空值就是空字段
+csvCell :: Value -> Text
+csvCell VNull = ""
+csvCell value = displayValue value
+
+-- | 按 RFC 4180 给需要的字段加引号
+csvField :: Text -> Text
+csvField field
+    | T.any (`elem` (",\"\n\r" :: String)) field = "\"" <> T.replace "\"" "\"\"" field <> "\""
+    | otherwise = field
+
+renderTable :: QueryResult -> Text
+renderTable result
+    | null (qrColumns result) = "OK"
+    | otherwise = renderRows (qrColumns result) (map (map displayValue) (qrRows result))
+
+-- | 画一张等宽表，列太宽就截断
+renderRows :: [Text] -> [[Text]] -> Text
+renderRows columns rawRows = T.unlines (border : headerLine : border : body ++ [border, summary])
+  where
+    widths = [columnWidth index | index <- [0 .. length columns - 1]]
+    columnWidth index =
+        min maxColumnWidth (maximum (T.length (columns !! index) : [T.length (cellAt row index) | row <- rawRows]))
+    maxColumnWidth = 64
+    cellAt row index = if index < length row then row !! index else ""
+    cellLine cells = "| " <> T.intercalate " | " (zipWith pad widths (cells ++ repeat "")) <> " |"
+    headerLine = cellLine columns
+    body = map cellLine rawRows
+    border = "+" <> T.intercalate "+" ["-" <> T.replicate (width + 2) "-" | width <- widths] <> "+"
+    summary = "(" <> T.pack (show (length rawRows)) <> " row" <> (if length rawRows == 1 then "" else "s") <> ")"
+
+-- | 补到指定宽度，超出的按 ... 截断
+pad :: Int -> Text -> Text
+pad width text = clipped <> T.replicate (width - T.length clipped) " "
+  where
+    clipped
+        | T.length text <= width = text
+        | width <= 3 = T.take width text
+        | otherwise = T.take (width - 3) text <> "..."
+
+displayValue :: Value -> Text
+displayValue VNull = "NULL"
+displayValue (VInt n) = T.pack (show n)
+displayValue (VFloat d) = T.pack (show d)
+displayValue (VStr s) = T.pack s
+displayValue (VBool True) = "true"
+displayValue (VBool False) = "false"

chusql-cli/src/ChuSQL/CLI/Script.hs

@@ -0,0 +1,123 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.CLI.Script
+    ( Meta (..)
+    , parseMeta
+    , takeStatement
+    , statementComplete
+    , stripTerminator
+    , errorHint
+    , metaHelp
+    ) where
+
+import ChuSQL.CLI.Format (OutputFormat (..), formatName, parseFormat)
+import Data.Char (isSpace)
+import Data.Text (Text)
+import qualified Data.Text as T
+
+-- 交互层的纯逻辑：元命令、多行语句切分、错误提示。
+
+data Meta
+    = MetaQuit
+    | MetaHelp
+    | MetaDatabases
+    | MetaTables
+    | MetaDescribe Text
+    | MetaRoles
+    | MetaConnect Text
+    | MetaSetFormat OutputFormat
+    | MetaUnknown Text
+    deriving (Eq, Show)
+
+-- | 反斜杠开头的行是元命令，其余交给 SQL
+parseMeta :: Text -> Maybe Meta
+parseMeta raw = do
+    body <- T.stripPrefix "\\" (T.strip raw)
+    let (command, rest) = T.break isSpace body
+        argument = T.strip rest
+    pure $ case T.toLower command of
+        "q" -> MetaQuit
+        "quit" -> MetaQuit
+        "exit" -> MetaQuit
+        "?" -> MetaHelp
+        "h" -> MetaHelp
+        "help" -> MetaHelp
+        "l" -> MetaDatabases
+        "list" -> MetaDatabases
+        "dt" -> MetaTables
+        "tables" -> MetaTables
+        "d" | T.null argument -> MetaTables
+            | otherwise -> MetaDescribe argument
+        "dr" -> MetaRoles
+        "roles" -> MetaRoles
+        "c" -> connectTo argument
+        "connect" -> connectTo argument
+        "use" -> connectTo argument
+        "f" -> selectFormat argument
+        "format" -> selectFormat argument
+        other -> MetaUnknown other
+  where
+    connectTo argument
+        | T.null argument = MetaUnknown "c"
+        | otherwise = MetaConnect argument
+    selectFormat argument = maybe (MetaUnknown "format") MetaSetFormat (parseFormat argument)
+
+-- | 取出第一条以分号结束的语句与后面的残余；字符串与注释里的分号不算
+takeStatement :: Text -> Maybe (Text, Text)
+takeStatement = go ScanNormal [] . T.unpack
+  where
+    go _ _ [] = Nothing
+    go ScanNormal acc (';' : rest) = Just (T.strip (T.pack (reverse acc)), T.pack rest)
+    go ScanNormal acc ('-' : '-' : rest) = go ScanLineComment ('-' : '-' : acc) rest
+    go ScanNormal acc ('/' : '*' : rest) = go ScanBlockComment ('*' : '/' : acc) rest
+    go ScanNormal acc ('\'' : rest) = go ScanString ('\'' : acc) rest
+    go ScanNormal acc (ch : rest) = go ScanNormal (ch : acc) rest
+    go ScanString acc ('\'' : '\'' : rest) = go ScanString ('\'' : '\'' : acc) rest
+    go ScanString acc ('\'' : rest) = go ScanNormal ('\'' : acc) rest
+    go ScanString acc (ch : rest) = go ScanString (ch : acc) rest
+    go ScanLineComment acc ('\n' : rest) = go ScanNormal ('\n' : acc) rest
+    go ScanLineComment acc (ch : rest) = go ScanLineComment (ch : acc) rest
+    go ScanBlockComment acc ('*' : '/' : rest) = go ScanNormal ('/' : '*' : acc) rest
+    go ScanBlockComment acc (ch : rest) = go ScanBlockComment (ch : acc) rest
+
+data ScanState = ScanNormal | ScanString | ScanLineComment | ScanBlockComment
+
+-- | 攒下来的内容里有没有一条以分号结束的语句
+statementComplete :: Text -> Bool
+statementComplete = maybe False (const True) . takeStatement
+
+-- | 去掉结尾的空白与分号（-e 直接执行时用）
+stripTerminator :: Text -> Text
+stripTerminator raw = T.stripEnd (T.dropWhileEnd (== ';') (T.stripEnd raw))
+
+-- | 常见错误给一句怎么查
+errorHint :: Text -> Maybe Text
+errorHint message
+    | "unknown table" `T.isInfixOf` lowered = Just "run \\dt to list the tables of the current database"
+    | "unknown column" `T.isInfixOf` lowered = Just "run \\d <table> to see the columns of a table"
+    | "unknown database" `T.isInfixOf` lowered = Just "run \\l to list the databases"
+    | "syntax" `T.isInfixOf` lowered = Just "one statement at a time, and every statement ends with a semicolon"
+    | "invalid user name or password" `T.isInfixOf` lowered = Just "check --user and the password"
+    | "sign in first" `T.isInfixOf` lowered = Just "the session expired, restart the CLI"
+    | "too many failed sign-in attempts" `T.isInfixOf` lowered = Just "wait a few minutes before trying again"
+    | otherwise = Nothing
+  where
+    lowered = T.toLower message
+
+-- | \? 的帮助文本
+metaHelp :: Text
+metaHelp =
+    T.unlines
+        [ "SQL statements end with a semicolon; a statement may span several lines."
+        , ""
+        , "  \\q, \\quit          leave the CLI"
+        , "  \\?, \\h, \\help       show this help"
+        , "  \\l, \\list           list databases"
+        , "  \\dt, \\d             list tables"
+        , "  \\d <table>          describe a table"
+        , "  \\dr, \\roles         list roles with their grants and members"
+        , "  \\c <database>       switch database"
+        , "  \\f, \\format <fmt>   output format: " <> T.intercalate ", " (map formatName [FormatTable, FormatJson, FormatCsv])
+        , ""
+        , "At the chusql> prompt the arrow keys walk the SQL history."
+        ]

chusql-cli/src/ChuSQL/CLI/Session.hs

@@ -0,0 +1,270 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.CLI.Session
+    ( QueryResult (..)
+    , Session
+    , newSession
+    , sessionUser
+    , sessionIsAdmin
+    , sessionDatabase
+    , isPlainIdentifier
+    , authenticateSession
+    , switchDatabase
+    , runStatement
+    , catalog
+    , accountTable
+    , roleViews
+    , databases
+    , queryResultJson
+    ) where
+
+import ChuSQL.Model (Value (..))
+import ChuSQL.Storage.IPC (TableInfo (..))
+import ChuSQL.Syntax.AST (Statement (..))
+import ChuSQL.Syntax.Parser (parseStatement)
+import ChuSQL.Web.Accounts
+import ChuSQL.Web.API (configurePasswordPolicy, systemTableInfo)
+import ChuSQL.Web.Auth (Credential, defaultSessionPolicy, newSessionStore)
+import ChuSQL.Web.Backend (Backend (..), StatementResult (..))
+import ChuSQL.Web.Privileges (PrivilegeCommand, PrivilegeError (..), Privileges, RoleView, authorize, filterTables, listRoleViews, newPrivileges, privilegeCommand, runPrivilegeCommand)
+import Data.Aeson (object, (.=))
+import qualified Data.Aeson as A
+import Data.Char (isAlpha, isAlphaNum)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Data.Scientific (fromFloatDigits)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (getCurrentTime)
+
+-- CLI 会话：直接连存储与引擎，但账号服务与 Web 管理端是同一套
+-- （同一个 root 凭据，同一张 __chusql_users）。
+
+data QueryResult = QueryResult
+    { qrColumns :: [Text]
+    , qrRows :: [[Value]]
+    , qrRowCount :: Int
+    , qrTruncated :: Bool
+    , qrDatabase :: Maybe Text
+    }
+    deriving (Eq, Show)
+
+data Session = Session
+    { ssBackend :: Backend
+    , ssAccounts :: Accounts
+    , ssPrivileges :: Privileges
+    , ssCurrent :: IORef Text
+    , ssPrincipal :: IORef (Maybe Principal)
+    }
+
+-- | 开一个会话：账号与角色服务、配置策略都和 Web 端一致
+newSession :: Backend -> Credential -> FilePath -> IO Session
+newSession backend credential settingsFile = do
+    sessions <- newSessionStore getCurrentTime defaultSessionPolicy
+    accounts <- newAccounts backend sessions credential
+    privileges <- newPrivileges backend
+    configurePasswordPolicy accounts settingsFile
+    -- 服务启动后只有系统库：没 USE 之前不预设任何工作库
+    current <- newIORef ""
+    principal <- newIORef Nothing
+    pure (Session backend accounts privileges current principal)
+
+-- | 当前登录的账号名
+sessionUser :: Session -> IO (Maybe Text)
+sessionUser session = fmap principalName <$> readIORef (ssPrincipal session)
+
+-- | 是不是配置里的 root
+sessionIsAdmin :: Session -> IO Bool
+sessionIsAdmin session = maybe False principalIsRoot <$> readIORef (ssPrincipal session)
+
+-- | 当前库
+sessionDatabase :: Session -> IO Text
+sessionDatabase = readIORef . ssCurrent
+
+-- | 与解析器一致的裸标识符判断
+isPlainIdentifier :: Text -> Bool
+isPlainIdentifier name =
+    not (T.null name)
+        && T.length name <= 64
+        && (isAlpha (T.head name) || T.head name == '_')
+        && T.all (\ch -> isAlphaNum ch || ch == '_') name
+
+-- | 登录：root 比配置里的凭据，普通账号查 __chusql_users
+authenticateSession :: Session -> Text -> Text -> IO (Either Text ())
+authenticateSession session user password = do
+    result <- authenticate (ssAccounts session) user password
+    case result of
+        Left err -> pure (Left (accountMessage err))
+        Right token -> do
+            who <- currentPrincipal (ssAccounts session) token
+            case who of
+                Left err -> pure (Left (accountMessage err))
+                Right principal -> do
+                    writeIORef (ssPrincipal session) (Just principal)
+                    pure (Right ())
+
+-- | 换库；系统库只有 root 能进
+switchDatabase :: Session -> Text -> IO (Either Text ())
+switchDatabase session rawName
+    | not (isPlainIdentifier name) = pure (Left ("not a plain database name: " <> name))
+    | name == "system" = do
+        admin <- sessionIsAdmin session
+        if admin then go else pure (Left "the system database is only available to the administrator")
+    | otherwise = go
+  where
+    name = T.toLower (T.strip rawName)
+    go = do
+        backend <- currentBackend session
+        result <- beStatement backend ("USE " ++ T.unpack name)
+        case result of
+            Left err -> pure (Left (T.pack err))
+            Right _ -> writeIORef (ssCurrent session) name >> pure (Right ())
+
+-- | 跑一条语句：USE、账号语句与角色语句在这里分流，其余交给引擎
+-- （普通身份先过一遍权限判定，管理员与未登录直接放行）
+runStatement :: Session -> Text -> IO (Either Text QueryResult)
+runStatement session sql = case parseStatement (T.unpack sql) of
+    Right (UseDatabase name) -> do
+        switched <- switchDatabase session (T.pack name)
+        case switched of
+            Left err -> pure (Left err)
+            Right () -> do
+                current <- readIORef (ssCurrent session)
+                pure (Right (emptyResult (Just current)))
+    Right statement
+        | Just command <- accountCommand statement -> runAccount session command
+        | Just command <- privilegeCommand statement -> runPrivilege session command
+        | otherwise -> do
+            allowed <- authorized session statement
+            case allowed of
+                Left err -> pure (Left err)
+                Right () -> runPlain session sql
+    Left _ -> runPlain session sql
+
+-- | 普通身份跑语句前的权限判定；管理员与未登录放行
+authorized :: Session -> Statement -> IO (Either Text ())
+authorized session statement = do
+    who <- readIORef (ssPrincipal session)
+    case who of
+        Just principal | not (principalIsRoot principal) -> do
+            database <- readIORef (ssCurrent session)
+            result <- authorize (ssPrivileges session) principal database statement
+            pure (either (Left . privilegeMessage) (const (Right ())) result)
+        _ -> pure (Right ())
+
+-- | 落到引擎/存储层的一条语句
+runPlain :: Session -> Text -> IO (Either Text QueryResult)
+runPlain session sql = do
+    backend <- currentBackend session
+    result <- beStatement backend (T.unpack sql)
+    pure (either (Left . T.pack) (Right . resultOf) result)
+
+-- | 数据字典（\dt 与 \d 用）；普通身份只看得到自己有 SELECT 的表
+catalog :: Session -> IO (Either Text [TableInfo])
+catalog session = do
+    current <- readIORef (ssCurrent session)
+    if T.null current
+        then pure (Left "no database selected")
+        else do
+            backend <- currentBackend session
+            result <- beCatalog backend
+            case result of
+                Left e -> pure (Left (T.pack e))
+                Right infos -> do
+                    who <- readIORef (ssPrincipal session)
+                    case who of
+                        Just principal | not (principalIsRoot principal) -> do
+                            allowed <- filterTables (ssPrivileges session) principal current (map (T.pack . tiTable) infos)
+                            pure (either (Left . privilegeMessage) (\names -> Right (filter (\info -> T.pack (tiTable info) `elem` names) infos)) allowed)
+                        _ -> pure (Right infos)
+
+-- | 库清单（\l 用）
+databases :: Session -> IO (Either Text [Text])
+databases session = do
+    result <- beDatabases (ssBackend session)
+    pure (either (Left . T.pack) (Right . map T.pack) result)
+
+-- | 系统库里的账号表：列定义与 Web 端共用一份，行数从同一套账号服务来
+accountTable :: Session -> IO (Maybe TableInfo)
+accountTable session = do
+    admin <- sessionIsAdmin session
+    if not admin
+        then pure Nothing
+        else do
+            result <- listAccounts (ssAccounts session)
+            pure (either (const Nothing) (\accounts -> Just systemTableInfo{tiRows = length accounts}) result)
+
+-- | 角色总览（\dr 用）；与 Web 的 /api/roles 一样只给管理员
+roleViews :: Session -> IO (Either Text [RoleView])
+roleViews session = do
+    admin <- sessionIsAdmin session
+    if not admin
+        then pure (Left "administrator required")
+        else do
+            result <- listRoleViews (ssPrivileges session)
+            pure (either (Left . privilegeMessage) Right result)
+
+-- | 当前库对应的后端
+currentBackend :: Session -> IO Backend
+currentBackend session = do
+    name <- readIORef (ssCurrent session)
+    pure (beWithDatabase (ssBackend session) (T.unpack name))
+
+-- | 账号语句走账号服务，普通账号一律拒绝
+runAccount :: Session -> AccountCommand -> IO (Either Text QueryResult)
+runAccount session command = do
+    who <- readIORef (ssPrincipal session)
+    case who of
+        Nothing -> pure (Left "sign in first")
+        Just principal -> do
+            result <- runAccountCommand (ssAccounts session) principal command
+            pure (either (Left . accountMessage) (const (Right (emptyResult Nothing))) result)
+
+-- | 角色语句走权限服务，普通账号一律拒绝；当前库决定授权对象的落库口径
+runPrivilege :: Session -> PrivilegeCommand -> IO (Either Text QueryResult)
+runPrivilege session command = do
+    who <- readIORef (ssPrincipal session)
+    case who of
+        Nothing -> pure (Left "sign in first")
+        Just principal -> do
+            database <- readIORef (ssCurrent session)
+            result <- runPrivilegeCommand (ssPrivileges session) principal database command
+            pure (either (Left . privilegeMessage) (const (Right (emptyResult Nothing))) result)
+
+accountMessage :: AccountError -> Text
+accountMessage (AccountError _ message) = message
+
+privilegeMessage :: PrivilegeError -> Text
+privilegeMessage (PrivilegeError _ message) = message
+
+emptyResult :: Maybe Text -> QueryResult
+emptyResult database = QueryResult [] [] 0 False database
+
+resultOf :: StatementResult -> QueryResult
+resultOf result =
+    QueryResult
+        { qrColumns = map T.pack (srColumns result)
+        , qrRows = [map (cellOf row) (srColumns result) | row <- srRows result]
+        , qrRowCount = length (srRows result)
+        , qrTruncated = False
+        , qrDatabase = Nothing
+        }
+  where
+    cellOf row name = maybe VNull id (lookup name row)
+
+-- | 结果还原成 JSON（JSON 输出用）
+queryResultJson :: QueryResult -> A.Value
+queryResultJson result =
+    object
+        [ "columns" .= qrColumns result
+        , "rows" .= map (map valueToJson) (qrRows result)
+        , "rowCount" .= qrRowCount result
+        , "truncated" .= qrTruncated result
+        , "database" .= qrDatabase result
+        ]
+
+valueToJson :: Value -> A.Value
+valueToJson VNull = A.Null
+valueToJson (VInt n) = A.Number (fromIntegral n)
+valueToJson (VFloat d) = A.Number (fromFloatDigits d)
+valueToJson (VStr s) = A.String (T.pack s)
+valueToJson (VBool b) = A.Bool b

chusql-cli/stack.yaml

@@ -0,0 +1,6 @@
+resolver: lts-24.59
+
+packages:
+    - .
+    - ../chusql-engine
+    - ../chusql-web

chusql-cli/stack.yaml.lock

@@ -0,0 +1,12 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/topics/lock_files
+
+packages: []
+snapshots:
+- completed:
+    sha256: 0f728e30e843d7f00460ad56858b995a3b227fca683659c7df9f2fc3988a3ce1
+    size: 732465
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/59.yaml
+  original: lts-24.59

chusql-cli/test/Spec.hs

@@ -0,0 +1,251 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module Main (main) where
+
+import ChuSQL.CLI.Format (OutputFormat (..), parseFormat, renderCsv, renderJson, renderTable)
+import ChuSQL.CLI.Script (Meta (..), errorHint, parseMeta, statementComplete, stripTerminator, takeStatement)
+import ChuSQL.CLI.Session (
+    QueryResult (..),
+    Session,
+    authenticateSession,
+    catalog,
+    databases,
+    newSession,
+    queryResultJson,
+    roleViews,
+    runStatement,
+    sessionDatabase,
+    sessionIsAdmin,
+    switchDatabase,
+ )
+import ChuSQL.Model (Database, Table (..), Value (..), pattern TInt, pattern TStr)
+import ChuSQL.Storage.IPC (TableInfo (..))
+import ChuSQL.Web.Auth (Credential (..), hashPasswordWith)
+import ChuSQL.Web.Backend (memoryBackend)
+import ChuSQL.Web.Privileges (Grant (..), RoleView (..))
+import Control.Concurrent.MVar (newMVar)
+import Data.Aeson (decode)
+import qualified Data.Aeson as A
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import Data.Either (isLeft, isRight)
+import Data.List (nub, sort)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Test.Hspec
+
+-- chusql-cli 测试：输出格式、交互层纯逻辑与共享账号会话。
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+    formatSpec
+    scriptSpec
+    sessionSpec
+    roleSpec
+
+formatSpec :: Spec
+formatSpec = describe "CLI: output formats" $ do
+    it "renders a boxed table and marks NULL" $
+        renderTable sampleResult
+            `shouldBe` T.unlines
+                [ "+-----+--------+"
+                , "| id | name  |"
+                , "+-----+--------+"
+                , "| 1  | Alice |"
+                , "| 2  | NULL  |"
+                , "+-----+--------+"
+                , "(2 rows)"
+                ]
+    it "renders CSV with RFC 4180 quoting and empty NULL fields" $
+        renderCsv
+            QueryResult
+                { qrColumns = ["id", "name"]
+                , qrRows = [[VInt 1, VStr "a,b"], [VNull, VStr "say \"hi\""]]
+                , qrRowCount = 2
+                , qrTruncated = False
+                , qrDatabase = Nothing
+                }
+            `shouldBe` "id,name\n1,\"a,b\"\n,\"say \"\"hi\"\"\"\n"
+    it "renders JSON that parses back to the same result" $
+        (decode (BL.fromStrict (encodeUtf8 (renderJson sampleResult))) :: Maybe A.Value)
+            `shouldBe` Just (queryResultJson sampleResult)
+    it "accepts table/json/csv in any case and rejects anything else" $ do
+        parseFormat "TABLE" `shouldBe` Just FormatTable
+        parseFormat " json " `shouldBe` Just FormatJson
+        parseFormat "csv" `shouldBe` Just FormatCsv
+        parseFormat "xml" `shouldBe` Nothing
+
+scriptSpec :: Spec
+scriptSpec = do
+    describe "CLI: statement buffering" $ do
+        it "a statement is complete only at an unquoted semicolon" $ do
+            statementComplete "SELECT 1;" `shouldBe` True
+            statementComplete "SELECT 1" `shouldBe` False
+            statementComplete "SELECT ';'" `shouldBe` False
+            statementComplete "SELECT 'a''b'" `shouldBe` False
+            statementComplete "SELECT 1 -- ;" `shouldBe` False
+            statementComplete "SELECT /* ; */ 1" `shouldBe` False
+            statementComplete "SELECT /* ; */ 1;" `shouldBe` True
+        it "splits the first statement off and keeps the rest" $
+            takeStatement "SELECT 1; SELECT 2;"
+                `shouldBe` Just ("SELECT 1", " SELECT 2;")
+        it "drops the terminator before sending SQL to the server" $ do
+            stripTerminator "SELECT 1 ; " `shouldBe` "SELECT 1"
+            stripTerminator "SELECT 1" `shouldBe` "SELECT 1"
+        it "suggests how to look around after a common error" $ do
+            errorHint "unknown table: nope" `shouldBe` Just "run \\dt to list the tables of the current database"
+            errorHint "unknown column: nope" `shouldBe` Just "run \\d <table> to see the columns of a table"
+            errorHint "something else" `shouldBe` Nothing
+    describe "CLI: meta commands" $ do
+        it "parses the backslash commands" $ do
+            parseMeta "\\q" `shouldBe` Just MetaQuit
+            parseMeta "\\?" `shouldBe` Just MetaHelp
+            parseMeta "\\l" `shouldBe` Just MetaDatabases
+            parseMeta "\\dt" `shouldBe` Just MetaTables
+            parseMeta "\\d" `shouldBe` Just MetaTables
+            parseMeta "\\d users" `shouldBe` Just (MetaDescribe "users")
+            parseMeta "\\dr" `shouldBe` Just MetaRoles
+            parseMeta "\\roles" `shouldBe` Just MetaRoles
+            parseMeta "\\c sales" `shouldBe` Just (MetaConnect "sales")
+            parseMeta "\\format CSV" `shouldBe` Just (MetaSetFormat FormatCsv)
+        it "leaves ordinary SQL alone" $ do
+            parseMeta "SELECT 1" `shouldBe` Nothing
+            parseMeta "\\nope" `shouldBe` Just (MetaUnknown "nope")
+            parseMeta "\\f xml" `shouldBe` Just (MetaUnknown "format")
+
+sessionSpec :: Spec
+sessionSpec = describe "CLI: session over the shared account service" $ do
+    it "signs in as the configured administrator and refuses a wrong password" $ do
+        session <- cliSession
+        authenticateSession session "admin" "wrong-password" >>= \answer -> isLeft answer `shouldBe` True
+        authenticateSession session "admin" "s3cret" >>= \answer -> isRight answer `shouldBe` True
+    it "runs SQL straight through the engine" $ do
+        session <- cliSession
+        signInRoot session
+        result <- runStatement session "SELECT id, name FROM users ORDER BY id LIMIT 1"
+        fmap qrColumns result `shouldBe` Right ["id", "name"]
+        fmap qrRowCount result `shouldBe` Right 1
+    it "starts with nothing selected, lists what exists and refuses an unknown USE" $ do
+        session <- cliSession
+        authenticateSession session "admin" "s3cret" >>= (`shouldBe` Right ())
+        sessionDatabase session >>= (`shouldBe` "")
+        runStatement session "SELECT id FROM users" >>= \answer -> answer `shouldBe` Left "no database selected"
+        listed <- databases session
+        listed `shouldBe` Right ["test", "system"]
+        runStatement session "USE missing" >>= \answer -> isLeft answer `shouldBe` True
+        sessionDatabase session >>= (`shouldBe` "")
+        runStatement session "USE test" >>= \answer -> isRight answer `shouldBe` True
+        sessionDatabase session >>= (`shouldBe` "test")
+    it "keeps accounts on the same store and system administrator-only" $ do
+        session <- cliSession
+        signInRoot session
+        runStatement session "CREATE USER alice IDENTIFIED BY 'alice-password-1'" >>= \answer -> isRight answer `shouldBe` True
+        authenticateSession session "alice" "alice-password-1" >>= \answer -> isRight answer `shouldBe` True
+        sessionIsAdmin session >>= (`shouldBe` False)
+        switchDatabase session "system" >>= \answer -> isLeft answer `shouldBe` True
+        runStatement session "DROP USER admin" >>= \answer -> isLeft answer `shouldBe` True
+
+roleSpec :: Spec
+roleSpec = describe "CLI: roles and grants over the shared privilege service" $ do
+    it "runs role statements as the administrator and refuses them for anyone else" $ do
+        session <- cliSession
+        signInRoot session
+        created <- runStatement session "CREATE ROLE analyst"
+        isRight created `shouldBe` True
+        duplicate <- runStatement session "CREATE ROLE analyst"
+        duplicate `shouldBe` Left "role already exists: analyst"
+        granted <- runStatement session "GRANT SELECT ON users TO analyst"
+        isRight granted `shouldBe` True
+        tallied <- runStatement session "GRANT SELECT, INSERT, UPDATE, DELETE ON users TO analyst"
+        isRight tallied `shouldBe` True
+        views <- roleViews session
+        fmap (map roleName) views `shouldBe` Right ["analyst"]
+        fmap (sort . nub . concatMap (map grantPrivilege . roleGrants)) views `shouldBe` Right ["delete", "insert", "select", "update"]
+        fmap (sort . nub . concatMap (map grantObject . roleGrants)) views `shouldBe` Right ["test.users"]
+        unknown <- runStatement session "GRANT SELECT ON users TO nobody"
+        unknown `shouldBe` Left "unknown role: nobody"
+        dropped <- runStatement session "DROP ROLE analyst"
+        isRight dropped `shouldBe` True
+        missing <- runStatement session "GRANT SELECT ON users TO analyst"
+        missing `shouldBe` Left "unknown role: analyst"
+    it "an ordinary account only gets what a grant allows" $ do
+        session <- cliSession
+        signInRoot session
+        runStatement session "CREATE TABLE secrets (id INT)" >>= \answer -> isRight answer `shouldBe` True
+        runStatement session "CREATE ROLE reader" >>= \answer -> isRight answer `shouldBe` True
+        runStatement session "GRANT SELECT ON users TO reader" >>= \answer -> isRight answer `shouldBe` True
+        runStatement session "CREATE USER bob IDENTIFIED BY 'bob-password-1'" >>= \answer -> isRight answer `shouldBe` True
+        runStatement session "GRANT reader TO bob" >>= \answer -> isRight answer `shouldBe` True
+        authenticateSession session "bob" "bob-password-1" >>= \answer -> isRight answer `shouldBe` True
+        granted <- runStatement session "SELECT id, name FROM users"
+        fmap qrRowCount granted `shouldBe` Right 3
+        refused <- runStatement session "SELECT id FROM secrets"
+        refused `shouldBe` Left "permission denied: SELECT ON secrets"
+        write <- runStatement session "INSERT INTO users (id, name) VALUES (4, 'four')"
+        write `shouldBe` Left "permission denied: INSERT ON users"
+        admin <- runStatement session "CREATE ROLE other"
+        admin `shouldBe` Left "administrator required"
+        listed <- catalog session
+        fmap (map tiTable) listed `shouldBe` Right ["users"]
+        hidden <- roleViews session
+        hidden `shouldBe` Left "administrator required"
+    it "revoking the membership closes the door again" $ do
+        session <- cliSession
+        signInRoot session
+        runStatement session "CREATE ROLE guest" >>= \answer -> isRight answer `shouldBe` True
+        runStatement session "GRANT SELECT ON users TO guest" >>= \answer -> isRight answer `shouldBe` True
+        runStatement session "CREATE USER carol IDENTIFIED BY 'carol-password-1'" >>= \answer -> isRight answer `shouldBe` True
+        runStatement session "GRANT guest TO carol" >>= \answer -> isRight answer `shouldBe` True
+        roster <- roleViews session
+        fmap (concatMap roleMembers) roster `shouldBe` Right ["carol"]
+        authenticateSession session "carol" "carol-password-1" >>= \answer -> isRight answer `shouldBe` True
+        runStatement session "SELECT id FROM users" >>= \answer -> isRight answer `shouldBe` True
+        signInRoot session
+        runStatement session "REVOKE guest FROM carol" >>= \answer -> isRight answer `shouldBe` True
+        authenticateSession session "carol" "carol-password-1" >>= \answer -> isRight answer `shouldBe` True
+        refused <- runStatement session "SELECT id FROM users"
+        refused `shouldBe` Left "permission denied: SELECT ON users"
+
+cliSession :: IO Session
+cliSession = do
+    db <- newMVar testDb
+    newSession (memoryBackend testDatabaseName db) testCredential "chusql-test-missing.settings.json"
+
+-- | 夹具库名：服务不再有默认库，这个库要显式选
+testDatabaseName :: String
+testDatabaseName = "test"
+
+-- | 登录管理员并选中夹具库（未选库时连表名都解析不了）
+signInRoot :: Session -> Expectation
+signInRoot session = do
+    authenticateSession session "admin" "s3cret" >>= (`shouldBe` Right ())
+    switchDatabase session (T.pack testDatabaseName) >>= (`shouldBe` Right ())
+
+sampleResult :: QueryResult
+sampleResult =
+    QueryResult
+        { qrColumns = ["id", "name"]
+        , qrRows = [[VInt 1, VStr "Alice"], [VInt 2, VNull]]
+        , qrRowCount = 2
+        , qrTruncated = False
+        , qrDatabase = Nothing
+        }
+
+-- | 测试库：三行 users
+testDb :: Database
+testDb =
+    [ ( "users"
+      , Table
+            "users"
+            [("id", TInt), ("name", TStr)]
+            [[("id", VInt i), ("name", VStr ("user" ++ show i))] | i <- [1 .. 3]]
+      )
+    ]
+
+-- | 测试账号：迭代次数压低（跑得快），口令 `s3cret`
+testCredential :: Credential
+testCredential = Credential "admin" (hashPasswordWith 1000 (BS.replicate 16 7) "s3cret")