大改，整理项目结构，完成rust ffi调用，写好tcp接口

chusql-interface/src/ChuSQL/Interface/AccountTable.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Interface.AccountTable (
+    accountTableName,
+    isAccountTable,
+    passwordColumn,
+    accountColumns,
+    systemTableInfo,
+) where
+
+import ChuSQL.Core.Protocol (SchemaColumn (..), TableInfo (..))
+import Data.Text (Text)
+import qualified Data.Text as T
+
+-- 账号表（系统表 __chusql_users）的结构定义，SQL 会话与 Web 管理端共用。
+
+-- | 账号表的名字：网页里像普通表一样浏览与编辑，但写入走账号命令
+accountTableName :: String
+accountTableName = "__chusql_users"
+
+-- | 这张表是不是账号表
+isAccountTable :: Text -> Bool
+isAccountTable name = T.toLower name == T.pack accountTableName
+
+-- | 口令列：密文只在服务端产生，界面不支持排序与筛选
+passwordColumn :: String
+passwordColumn = "password"
+
+-- | 账号表的列定义与约束
+accountColumns :: [SchemaColumn]
+accountColumns =
+    [ accountColumnSpec "id" "int" False True True False
+    , accountColumnSpec "user" "varchar(64)" False False False True
+    , accountColumnSpec passwordColumn "varchar(256)" False False False False
+    , accountColumnSpec "registered_at" "timestamp" False False False False
+    , accountColumnSpec "last_login_at" "timestamp" True False False False
+    ]
+
+-- | 账号表的列（约束由账号服务管）
+accountColumnSpec :: String -> String -> Bool -> Bool -> Bool -> Bool -> SchemaColumn
+accountColumnSpec name ty nullable autoIncrement primary unique =
+    SchemaColumn name ty nullable Nothing autoIncrement primary unique Nothing
+
+-- | 账号表的结构（排序校验用）
+systemTableInfo :: TableInfo
+systemTableInfo = TableInfo accountTableName accountColumns 0 [] []

chusql-interface/src/ChuSQL/Interface/Actions.hs

@@ -0,0 +1,371 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Interface.Actions (
+    ColumnSpec (..),
+    CreateTableSpec (..),
+    isIdentifier,
+    columnTypeOf,
+    columnTypeName,
+    coerceValue,
+    sqlLiteral,
+    escapeStringLiteral,
+    createDatabaseSql,
+    dropDatabaseSql,
+    createTableSql,
+    dropTableSql,
+    createIndexSql,
+    dropIndexSql,
+    dropColumnSql,
+    insertRowSql,
+    insertRowsSql,
+    updateRowSql,
+    deleteRowSql,
+    selectRowsSql,
+    createUserSql,
+    alterUserSql,
+    dropUserSql,
+    createRoleSql,
+    dropRoleSql,
+    grantPrivilegesSql,
+    revokePrivilegesSql,
+    grantRoleSql,
+    revokeRoleSql,
+) where
+
+import ChuSQL.Core.Model (Column (..), ColumnType (..), Value (..), integerType, numericType, parseColumnType, plainColumn, typeName)
+import qualified ChuSQL.Core.Model as M
+import qualified Data.Aeson as A
+import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
+import Data.List (intercalate)
+import Data.Scientific (floatingOrInteger)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Text.Read (readMaybe)
+
+-- 把界面上的一键操作翻译成安全 SQL：标识符过白名单，值一律转义。
+
+-- | 界面上传来的一列：名字与类型名
+data ColumnSpec = ColumnSpec
+    { csName :: Text
+    , csType :: Text
+    }
+    deriving (Show, Eq)
+
+-- | 建表请求：表名 + 列
+data CreateTableSpec = CreateTableSpec
+    { ctsTable :: Text
+    , ctsColumns :: [ColumnSpec]
+    }
+    deriving (Show, Eq)
+
+-- | 表名/列名的白名单
+isIdentifier :: Text -> Bool
+isIdentifier t =
+    not (T.null t)
+        && T.length t <= 64
+        && case T.unpack t of
+            (c : cs) -> (isAsciiLower c || isAsciiUpper c || c == '_') && all restChar cs
+            [] -> False
+  where
+    -- | 标识符里其余字符的合法集
+    restChar c = isAsciiLower c || isAsciiUpper c || isDigit c || c == '_'
+
+-- | 检查一个标识符，不合法就报错（带上"是表名还是列名"）
+checkIdent :: Text -> Text -> Either String Text
+checkIdent what name
+    | isIdentifier name = Right name
+    | otherwise = Left (T.unpack what ++ " name is not a plain identifier: " ++ T.unpack name)
+
+-- | 列表不能空
+requireNonEmpty :: String -> [a] -> Either String [a]
+requireNonEmpty what xs
+    | null xs = Left (what ++ " must not be empty")
+    | otherwise = Right xs
+
+-- | 线上列类型名（和数据字典里的写法一致）转本地类型
+columnTypeOf :: Text -> Maybe Column
+columnTypeOf = fmap plainColumn . parseColumnType . T.unpack . T.strip
+
+-- | 本地类型转线上名字
+columnTypeName :: Column -> Text
+columnTypeName = T.pack . typeName . columnType
+
+-- | 字符串字面量转义：单引号翻倍（引擎的词法器就是这么折回去的）
+escapeStringLiteral :: String -> String
+escapeStringLiteral = concatMap (\c -> if c == '\'' then "''" else [c])
+
+-- | 值转 SQL 字面量
+sqlLiteral :: Value -> String
+sqlLiteral VNull = "NULL"
+sqlLiteral (VInt n) = show n
+sqlLiteral (VFloat d) = show d
+sqlLiteral (VStr s) = "'" ++ escapeStringLiteral s ++ "'"
+sqlLiteral (VBool True) = "TRUE"
+sqlLiteral (VBool False) = "FALSE"
+
+-- | JSON 值按列类型转成引擎的值；类型对不上就报错
+coerceValue :: Column -> A.Value -> Either String Value
+coerceValue col v = case v of
+    A.Null -> Right VNull
+    A.Bool b -> M.coerceValue t (VBool b)
+    A.Number n -> case floatingOrInteger n :: Either Double Integer of
+        Right i -> M.coerceValue t (VInt (fromIntegral i))
+        Left d -> M.coerceValue t (VFloat d)
+    A.String s
+        | integerType t -> case readMaybe (T.unpack (T.strip s)) :: Maybe Int of
+            Just i -> M.coerceValue t (VInt i)
+            Nothing -> Left ("expected an integer, got: " ++ T.unpack s)
+        | numericType t -> case readMaybe (T.unpack (T.strip s)) :: Maybe Double of
+            Just d -> M.coerceValue t (VFloat d)
+            Nothing -> Left ("expected a number, got: " ++ T.unpack s)
+        | t == CBool -> case T.toLower (T.strip s) of
+            "true" -> Right (VBool True)
+            "false" -> Right (VBool False)
+            _ -> Left ("expected true/false, got: " ++ T.unpack s)
+        | otherwise -> M.coerceValue t (VStr (T.unpack s))
+    _ -> Left "unsupported value"
+  where
+    t = columnType col
+
+-- | 构造 CREATE DATABASE
+createDatabaseSql :: Text -> Either String String
+createDatabaseSql name = do
+    db <- checkIdent "database" name
+    pure ("CREATE DATABASE " ++ T.unpack db)
+
+-- | 构造 DROP DATABASE
+dropDatabaseSql :: Text -> Either String String
+dropDatabaseSql name = do
+    db <- checkIdent "database" name
+    pure ("DROP DATABASE " ++ T.unpack db)
+
+-- | 构造 CREATE TABLE 语句
+createTableSql :: CreateTableSpec -> Either String String
+createTableSql spec = do
+    tbl <- checkIdent "table" (ctsTable spec)
+    cols <- requireNonEmpty "columns" (ctsColumns spec)
+    defs <- mapM columnDef cols
+    pure ("CREATE TABLE " ++ T.unpack tbl ++ " (" ++ intercalate ", " defs ++ ")")
+  where
+    -- | 列类型不认时报错
+    columnDef (ColumnSpec name ty) = do
+        col <- checkIdent "column" name
+        ctype <- maybe (Left ("unknown column type: " ++ T.unpack ty)) Right (columnTypeOf ty)
+        pure (T.unpack col ++ " " ++ T.unpack (columnTypeName ctype))
+
+-- | 构造 DROP TABLE 语句
+dropTableSql :: Text -> Either String String
+dropTableSql table = do
+    tbl <- checkIdent "table" table
+    pure ("DROP TABLE " ++ T.unpack tbl)
+
+-- | 构造 CREATE INDEX 语句
+createIndexSql :: Text -> Text -> Either String String
+createIndexSql table column = do
+    tbl <- checkIdent "table" table
+    col <- checkIdent "column" column
+    pure ("CREATE INDEX ON " ++ T.unpack tbl ++ " (" ++ T.unpack col ++ ")")
+
+-- | 构造 DROP INDEX 语句
+dropIndexSql :: Text -> Text -> Either String String
+dropIndexSql table column = do
+    tbl <- checkIdent "table" table
+    col <- checkIdent "column" column
+    pure ("DROP INDEX ON " ++ T.unpack tbl ++ " (" ++ T.unpack col ++ ")")
+
+-- | 删列：列定义、索引与数据一起没
+dropColumnSql :: Text -> Text -> Either String String
+dropColumnSql table column = do
+    tbl <- checkIdent "table" table
+    col <- checkIdent "column" column
+    pure ("ALTER TABLE " ++ T.unpack tbl ++ " DROP COLUMN " ++ T.unpack col)
+
+-- | 构造单行 INSERT 语句
+insertRowSql :: Text -> [(String, Value)] -> Either String String
+insertRowSql table row = do
+    tbl <- checkIdent "table" table
+    cols <- requireNonEmpty "values" row
+    names <- mapM (checkIdent "column" . T.pack . fst) cols
+    pure
+        ( "INSERT INTO "
+            ++ T.unpack tbl
+            ++ " ("
+            ++ intercalate ", " (map T.unpack names)
+            ++ ") VALUES ("
+            ++ intercalate ", " (map (sqlLiteral . snd) cols)
+            ++ ")"
+        )
+
+-- | 一次插多行，N 行只落一次盘
+insertRowsSql :: Text -> [[(String, Value)]] -> Either String String
+insertRowsSql table rows = do
+    tbl <- checkIdent "table" table
+    rs <- requireNonEmpty "rows" rows
+    case rs of
+        [] -> Left "rows must not be empty"
+        (first : _) -> do
+            names <- mapM (checkIdent "column" . T.pack . fst) first
+            let widths = map length rs
+            if any (/= length first) widths
+                then Left "all rows must have the same columns"
+                else
+                    pure
+                        ( "INSERT INTO "
+                            ++ T.unpack tbl
+                            ++ " ("
+                            ++ intercalate ", " (map T.unpack names)
+                            ++ ") VALUES "
+                            ++ intercalate ", " ["(" ++ intercalate ", " (map (sqlLiteral . snd) r) ++ ")" | r <- rs]
+                        )
+
+-- | 构造按 id 改行的 UPDATE 语句
+updateRowSql :: Text -> Int -> [(String, Value)] -> Either String String
+updateRowSql table key assigns = do
+    tbl <- checkIdent "table" table
+    cols <- requireNonEmpty "values" assigns
+    sets <- mapM (\(n, v) -> (\c -> T.unpack c ++ " = " ++ sqlLiteral v) <$> checkIdent "column" (T.pack n)) cols
+    pure ("UPDATE " ++ T.unpack tbl ++ " SET " ++ intercalate ", " sets ++ " WHERE id = " ++ show key)
+
+-- | 按 id 删一行，存储层原地删
+deleteRowSql :: Text -> Int -> Either String String
+deleteRowSql table key = do
+    tbl <- checkIdent "table" table
+    pure ("DELETE FROM " ++ T.unpack tbl ++ " WHERE id = " ++ show key)
+
+-- | 浏览一张表的 SELECT，带排序与等值过滤
+selectRowsSql :: Text -> Maybe (Text, Bool) -> [(Text, Value)] -> Either String String
+selectRowsSql table order filters = do
+    tbl <- checkIdent "table" table
+    whereSql <- whereClause filters
+    orderSql <- orderClause order
+    pure ("SELECT * FROM " ++ T.unpack tbl ++ whereSql ++ orderSql)
+
+-- | 拼 WHERE 子句，无条件给空串
+whereClause :: [(Text, Value)] -> Either String String
+whereClause filters = case filters of
+    [] -> pure ""
+    _ -> do
+        terms <- mapM term filters
+        pure (" WHERE " ++ intercalate " AND " terms)
+  where
+    -- | 一个等值条件
+    term (column, value) = do
+        col <- checkIdent "column" column
+        pure (T.unpack col ++ " = " ++ sqlLiteral value)
+
+-- | 拼 ORDER BY 子句，无排序给空串
+orderClause :: Maybe (Text, Bool) -> Either String String
+orderClause Nothing = pure ""
+orderClause (Just (column, ascending)) = do
+    col <- checkIdent "column" column
+    pure (" ORDER BY " ++ T.unpack col ++ (if ascending then " ASC" else " DESC"))
+
+-- | 账号名：标识符规则另允许点与短横线
+accountName :: Text -> Either String Text
+accountName name
+    | T.null name || T.length name > 64 = Left "account name is empty or too long"
+    | not (T.all allowed name) = Left ("account name may only contain ASCII letters, digits, dot, dash or underscore: " ++ T.unpack name)
+    | otherwise = Right name
+  where
+    -- | 账号名允许的字符集
+    allowed c = isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("_.-" :: String)
+
+-- | 单引号字符串字面量
+quoted :: Text -> String
+quoted value = "'" ++ escapeStringLiteral (T.unpack value) ++ "'"
+
+-- | 构造 CREATE USER
+createUserSql :: Text -> Text -> Either String String
+createUserSql name password = do
+    user <- accountName name
+    if T.null password || T.length password > 256
+        then Left "password must not be empty or longer than 256 characters"
+        else pure ("CREATE USER " ++ T.unpack user ++ " IDENTIFIED BY " ++ quoted password)
+
+-- | 构造 ALTER USER（改一个普通账号的口令）
+alterUserSql :: Text -> Text -> Either String String
+alterUserSql name password = do
+    user <- accountName name
+    if T.null password || T.length password > 256
+        then Left "password must not be empty or longer than 256 characters"
+        else pure ("ALTER USER " ++ T.unpack user ++ " IDENTIFIED BY " ++ quoted password)
+
+-- | 构造 DROP USER
+dropUserSql :: Text -> Either String String
+dropUserSql name = do
+    user <- accountName name
+    pure ("DROP USER " ++ T.unpack user)
+
+-- | 角色名：与账号名同一套字符规则
+roleName :: Text -> Either String Text
+roleName name
+    | T.null name || T.length name > 64 = Left "role name is empty or too long"
+    | not (T.all allowed name) = Left ("role name may only contain ASCII letters, digits, dot, dash or underscore: " ++ T.unpack name)
+    | otherwise = Right name
+  where
+    -- | 角色名允许的字符集
+    allowed c = isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("_.-" :: String)
+
+-- | 授权对象：`*`，或长度不超过 128 的裸表名/`库.表`
+grantObject :: Text -> Either String Text
+grantObject object
+    | T.strip object == "*" = Right "*"
+    | T.null object || T.length object > 128 = Left "object name is empty or too long"
+    | not (T.all allowed object) = Left ("object name may only contain ASCII letters, digits, dot, dash or underscore: " ++ T.unpack object)
+    | otherwise = Right object
+  where
+    -- | 授权对象允许的字符集
+    allowed c = isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("_.-" :: String)
+
+-- | 权限清单：词要纯字母，认不认由 server 定
+privilegeWords :: [Text] -> Either String [Text]
+privilegeWords privileges
+    | null privileges = Left "at least one privilege is required"
+    | otherwise = mapM word privileges
+  where
+    -- | 单个权限词
+    word one
+        | T.null one || not (T.all (\c -> isAsciiLower c || isAsciiUpper c) one) = Left ("not a privilege keyword: " ++ T.unpack one)
+        | otherwise = Right one
+
+-- | 构造 CREATE ROLE
+createRoleSql :: Text -> Either String String
+createRoleSql name = do
+    role <- roleName name
+    pure ("CREATE ROLE " ++ T.unpack role)
+
+-- | 构造 DROP ROLE
+dropRoleSql :: Text -> Either String String
+dropRoleSql name = do
+    role <- roleName name
+    pure ("DROP ROLE " ++ T.unpack role)
+
+-- | 构造 GRANT 权限 ON 对象 TO 角色
+grantPrivilegesSql :: [Text] -> Text -> Text -> Either String String
+grantPrivilegesSql privileges object role = do
+    words' <- privilegeWords privileges
+    target <- grantObject object
+    who <- roleName role
+    pure ("GRANT " ++ T.unpack (T.intercalate ", " words') ++ " ON " ++ T.unpack target ++ " TO " ++ T.unpack who)
+
+-- | 构造 REVOKE 权限 ON 对象 FROM 角色
+revokePrivilegesSql :: [Text] -> Text -> Text -> Either String String
+revokePrivilegesSql privileges object role = do
+    words' <- privilegeWords privileges
+    target <- grantObject object
+    who <- roleName role
+    pure ("REVOKE " ++ T.unpack (T.intercalate ", " words') ++ " ON " ++ T.unpack target ++ " FROM " ++ T.unpack who)
+
+-- | 构造 GRANT <角色> TO <用户>[, ...]
+grantRoleSql :: Text -> [Text] -> Either String String
+grantRoleSql role users = do
+    who <- roleName role
+    members <- requireNonEmpty "users" users >>= mapM accountName
+    pure ("GRANT " ++ T.unpack who ++ " TO " ++ T.unpack (T.intercalate ", " members))
+
+-- | 构造 REVOKE 角色 FROM 用户
+revokeRoleSql :: Text -> [Text] -> Either String String
+revokeRoleSql role users = do
+    who <- roleName role
+    members <- requireNonEmpty "users" users >>= mapM accountName
+    pure ("REVOKE " ++ T.unpack who ++ " FROM " ++ T.unpack (T.intercalate ", " members))

chusql-interface/src/ChuSQL/Interface/Auth.hs

@@ -0,0 +1,305 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Interface.Auth (
+    Credential (..),
+    defaultIterations,
+    hashPassword,
+    hashPasswordWith,
+    hashLooksValid,
+    verifyPassword,
+    SessionPolicy (..),
+    defaultSessionPolicy,
+    SessionStore,
+    newSessionStore,
+    sessionPolicy,
+    setSessionPolicy,
+    createSession,
+    createVersionedSession,
+    lookupVersionedSession,
+    lookupSession,
+    deleteSession,
+    sessionToken,
+    PayloadStore,
+    newPayloadStore,
+    payloadPolicy,
+    setPayloadPolicy,
+    createPayloadSession,
+    lookupPayload,
+    putPayload,
+    dropPayload,
+    sweepPayloads,
+) where
+
+import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar)
+import Crypto.Hash (SHA256 (..))
+import qualified Crypto.KDF.PBKDF2 as PBKDF2
+import Crypto.Random (getRandomBytes)
+import qualified Data.ByteString as BS
+import Data.ByteArray (constEq)
+import Data.ByteArray.Encoding (Base (Base16), convertFromBase, convertToBase)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (isJust)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime)
+import Text.Read (readMaybe)
+
+-- 口令哈希与会话仓库，服务端与 Web 管理端共用。
+
+-- | 一条账号凭据：账号名 + 编码串
+data Credential = Credential
+    { credUser :: Text
+    , credEncoded :: Text
+    }
+    deriving (Show, Eq)
+
+-- | 默认迭代次数（10 万次）
+defaultIterations :: Int
+defaultIterations = 100000
+
+-- | 派生密钥长度（字节）
+keyLength :: Int
+keyLength = 32
+
+-- | 盐长度（字节）
+saltLength :: Int
+saltLength = 16
+
+-- | 迭代次数的上界：配置串被人改坏时不至于把自己算死
+maxIterations :: Int
+maxIterations = 10000000
+
+-- | PBKDF2-HMAC-SHA256 派生
+deriveKey :: Int -> BS.ByteString -> BS.ByteString -> BS.ByteString
+deriveKey iters salt password =
+    PBKDF2.generate (PBKDF2.prfHMAC SHA256) (PBKDF2.Parameters iters keyLength) password salt
+
+-- | 字节转十六进制
+hexEncode :: BS.ByteString -> Text
+hexEncode = TE.decodeUtf8 . convertToBase Base16
+
+-- | 十六进制转字节（长度不对/有非法字符就给 Nothing）
+hexDecode :: Text -> Maybe BS.ByteString
+hexDecode t = case convertFromBase Base16 (TE.encodeUtf8 t) of
+    Left _ -> Nothing
+    Right bs -> Just bs
+
+-- | 编码成 `pbkdf2-sha256$次数$盐$哈希`
+encodeHash :: Int -> BS.ByteString -> BS.ByteString -> Text
+encodeHash iters salt digest =
+    T.intercalate "$" ["pbkdf2-sha256", T.pack (show iters), hexEncode salt, hexEncode digest]
+
+-- | 解回 (次数, 盐, 哈希)，坏格式给 Nothing
+parseHash :: Text -> Maybe (Int, BS.ByteString, BS.ByteString)
+parseHash t = case T.splitOn "$" t of
+    [alg, itersT, saltT, digestT]
+        | alg == "pbkdf2-sha256" -> do
+            iters <- readMaybe (T.unpack itersT) :: Maybe Int
+            salt <- hexDecode saltT
+            digest <- hexDecode digestT
+            if iters < 1000 || iters > maxIterations || BS.null salt || BS.length digest /= keyLength
+                then Nothing
+                else Just (iters, salt, digest)
+    _ -> Nothing
+
+-- | 用给定盐生成编码串（给定盐是为了能写确定性测试）
+hashPasswordWith :: Int -> BS.ByteString -> Text -> Text
+hashPasswordWith iters salt password =
+    encodeHash iters salt (deriveKey iters salt (TE.encodeUtf8 password))
+
+-- | 给一个口令配随机盐，生成编码串
+hashPassword :: Text -> IO Text
+hashPassword password = do
+    salt <- getRandomBytes saltLength
+    pure (hashPasswordWith defaultIterations salt password)
+
+-- | 恒定时间校验口令是否匹配
+verifyPassword :: Text -> Text -> Bool
+verifyPassword encoded candidate = case parseHash encoded of
+    Nothing -> False
+    Just (iters, salt, digest) -> constEq digest (deriveKey iters salt (TE.encodeUtf8 candidate))
+
+-- | 编码串本身是否合法（不看口令）
+hashLooksValid :: Text -> Bool
+hashLooksValid = isJust . parseHash
+
+-- | 一条会话：账号、创建/最后活动时间与账号版本号
+data Session = Session
+    { sessUser :: Text
+    , sessCreated :: UTCTime
+    , sessSeen :: UTCTime
+    , sessRevision :: Maybe Integer
+    }
+
+-- | 会话过期策略：空闲上限与绝对上限
+data SessionPolicy = SessionPolicy
+    { spIdleSeconds :: NominalDiffTime
+    , spAbsoluteSeconds :: NominalDiffTime
+    }
+
+-- | 默认：空闲 8 小时、绝对 24 小时
+defaultSessionPolicy :: SessionPolicy
+defaultSessionPolicy = SessionPolicy (8 * 3600) (24 * 3600)
+
+-- | 会话仓库：令牌表、时钟与策略
+data SessionStore = SessionStore
+    { storeMap :: MVar (Map.Map Text Session)
+    , storeClock :: IO UTCTime
+    , storePolicy :: IORef SessionPolicy
+    }
+
+-- | 造一个空仓库
+newSessionStore :: IO UTCTime -> SessionPolicy -> IO SessionStore
+newSessionStore clock policy = do
+    ref <- newMVar Map.empty
+    policyRef <- newIORef policy
+    pure (SessionStore ref clock policyRef)
+
+-- | 现在用的是哪套过期策略
+sessionPolicy :: SessionStore -> IO SessionPolicy
+sessionPolicy = readIORef . storePolicy
+
+-- | 换一套过期策略（设置页热改）
+setSessionPolicy :: SessionStore -> SessionPolicy -> IO ()
+setSessionPolicy store = writeIORef (storePolicy store)
+
+-- | 这条会话过期了吗
+expired :: UTCTime -> SessionPolicy -> Session -> Bool
+expired now pol s =
+    diffUTCTime now (sessSeen s) > spIdleSeconds pol
+        || diffUTCTime now (sessCreated s) > spAbsoluteSeconds pol
+
+-- | 清掉过期会话
+prune :: UTCTime -> SessionPolicy -> Map.Map Text Session -> Map.Map Text Session
+prune now pol = Map.filter (not . expired now pol)
+
+-- | 随机令牌：32 字节，十六进制 64 个字符
+sessionToken :: IO Text
+sessionToken = hexEncode <$> getRandomBytes 32
+
+-- | 开一条会话，返回令牌
+createSession :: SessionStore -> Text -> IO Text
+createSession store user = createVersionedSession store user Nothing
+
+-- | 开一条会话并记下账号版本号，返回令牌
+createVersionedSession :: SessionStore -> Text -> Maybe Integer -> IO Text
+createVersionedSession store user revision = do
+    token <- sessionToken
+    now <- storeClock store
+    pol <- sessionPolicy store
+    modifyMVar_ (storeMap store) $ \m ->
+        pure (Map.insert token (Session user now now revision) (prune now pol m))
+    pure token
+
+-- | 查令牌并刷新最后活动时间
+lookupSession :: SessionStore -> Text -> IO (Maybe Text)
+lookupSession store token = fmap (fmap fst) (lookupVersionedSession store token)
+
+-- | 查令牌拿回账号名与账号版本号，并刷新最后活动时间
+lookupVersionedSession :: SessionStore -> Text -> IO (Maybe (Text, Maybe Integer))
+lookupVersionedSession store token = do
+    now <- storeClock store
+    pol <- sessionPolicy store
+    modifyMVar (storeMap store) $ \m -> do
+        let kept = prune now pol m
+        pure $ case Map.lookup token kept of
+            Nothing -> (kept, Nothing)
+            Just s -> (Map.insert token s{sessSeen = now} kept, Just (sessUser s, sessRevision s))
+
+-- | 删掉一条会话（退出登录）
+deleteSession :: SessionStore -> Text -> IO ()
+deleteSession store token = modifyMVar_ (storeMap store) (pure . Map.delete token)
+
+-- | 一条带载荷的会话：账号、时间与载荷
+data StoredSession a = StoredSession
+    { psUser :: Text
+    , psCreated :: UTCTime
+    , psSeen :: UTCTime
+    , psPayload :: a
+    }
+
+-- | 带载荷的会话仓库：令牌表、时钟与策略
+data PayloadStore a = PayloadStore
+    { psStoreMap :: MVar (Map.Map Text (StoredSession a))
+    , psClock :: IO UTCTime
+    , psPolicy :: IORef SessionPolicy
+    }
+
+-- | 造一个空的带载荷仓库
+newPayloadStore :: IO UTCTime -> SessionPolicy -> IO (PayloadStore a)
+newPayloadStore clock policy = do
+    ref <- newMVar Map.empty
+    policyRef <- newIORef policy
+    pure (PayloadStore ref clock policyRef)
+
+-- | 现在用的是哪套过期策略
+payloadPolicy :: PayloadStore a -> IO SessionPolicy
+payloadPolicy = readIORef . psPolicy
+
+-- | 换一套过期策略
+setPayloadPolicy :: PayloadStore a -> SessionPolicy -> IO ()
+setPayloadPolicy store = writeIORef (psPolicy store)
+
+-- | 这条带载荷的会话过期了吗
+payloadExpired :: UTCTime -> SessionPolicy -> StoredSession a -> Bool
+payloadExpired now pol s =
+    diffUTCTime now (psSeen s) > spIdleSeconds pol
+        || diffUTCTime now (psCreated s) > spAbsoluteSeconds pol
+
+-- | 清掉过期的带载荷会话
+prunePayloads :: UTCTime -> SessionPolicy -> Map.Map Text (StoredSession a) -> Map.Map Text (StoredSession a)
+prunePayloads now pol = Map.filter (not . payloadExpired now pol)
+
+-- | 上线一条带载荷的会话，返回令牌
+createPayloadSession :: PayloadStore a -> Text -> a -> IO Text
+createPayloadSession store user payload = do
+    token <- sessionToken
+    now <- psClock store
+    pol <- payloadPolicy store
+    modifyMVar_ (psStoreMap store) $ \m ->
+        pure (Map.insert token (StoredSession user now now payload) (prunePayloads now pol m))
+    pure token
+
+-- | 查令牌并刷新最后活动时间，拿回账号名与载荷
+lookupPayload :: PayloadStore a -> Text -> IO (Maybe (Text, a))
+lookupPayload store token = do
+    now <- psClock store
+    pol <- payloadPolicy store
+    modifyMVar (psStoreMap store) $ \m -> do
+        let kept = prunePayloads now pol m
+        pure $ case Map.lookup token kept of
+            Nothing -> (kept, Nothing)
+            Just s -> (Map.insert token s{psSeen = now} kept, Just (psUser s, psPayload s))
+
+-- | 换掉载荷；会话已没了就返回 False
+putPayload :: PayloadStore a -> Text -> a -> IO Bool
+putPayload store token payload = do
+    now <- psClock store
+    pol <- payloadPolicy store
+    modifyMVar (psStoreMap store) $ \m -> do
+        let kept = prunePayloads now pol m
+        pure $ case Map.lookup token kept of
+            Nothing -> (kept, False)
+            Just s -> (Map.insert token s{psSeen = now, psPayload = payload} kept, True)
+
+-- | 摘掉会话并把载荷交还
+dropPayload :: PayloadStore a -> Text -> IO (Maybe a)
+dropPayload store token = do
+    now <- psClock store
+    pol <- payloadPolicy store
+    modifyMVar (psStoreMap store) $ \m -> do
+        let kept = prunePayloads now pol m
+        pure $ case Map.lookup token kept of
+            Nothing -> (kept, Nothing)
+            Just s -> (Map.delete token kept, Just (psPayload s))
+
+-- | 清掉过期会话并把它们的载荷交还；调用者负责关掉这些载荷
+sweepPayloads :: PayloadStore a -> IO [a]
+sweepPayloads store = do
+    now <- psClock store
+    pol <- payloadPolicy store
+    modifyMVar (psStoreMap store) $ \m -> do
+        let (gone, kept) = Map.partition (payloadExpired now pol) m
+        pure (kept, map psPayload (Map.elems gone))

chusql-interface/src/ChuSQL/Interface/Config.hs

@@ -0,0 +1,233 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Interface.Config (
+    WebConfig (..),
+    defaultWebConfig,
+    defaultUser,
+    defaultPassword,
+    usingDefaultCredentials,
+    loadWebConfigAt,
+    resolveCredential,
+    resolveStaticDir,
+    staticDirCandidates,
+    rootUserName,
+    canonicalSettingKeys,
+    resolvePlainPassword,
+    ServerConfig (..),
+    defaultServerConfig,
+    loadServerConfigAt,
+) where
+
+import ChuSQL.Interface.Auth (Credential (..), hashPassword)
+import ChuSQL.Interface.TOML (readSection)
+import Data.Char (toLower)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import System.Directory (doesDirectoryExist)
+import Text.Read (readMaybe)
+
+-- Web 与 server 的运行参数：命令行 > chusql.toml 分区 > 内置默认。
+
+-- | 默认账号名
+defaultUser :: Text
+defaultUser = "root"
+
+-- | 默认口令（只为方便本地测试；生产/对外必须覆盖）
+defaultPassword :: Text
+defaultPassword = "chusql"
+
+-- | Web 管理端配置
+data WebConfig = WebConfig
+    { wcHost :: String
+    , wcPort :: Int
+    , wcStaticDir :: FilePath
+    , wcUser :: Text
+    , wcDataDir :: Maybe FilePath
+    , wcCookieSecure :: Bool
+    , wcBodyLimit :: Int
+    , wcSessionIdle :: Int
+    , wcSessionMax :: Int
+    , wcLoginMaxAttempts :: Int
+    , wcLoginWindow :: Int
+    , wcPageSize :: Int
+    , wcMaxPageSize :: Int
+    , wcMaxRows :: Int
+    , wcMaxSqlLength :: Int
+    , wcSeedDemo :: Bool
+    }
+    deriving (Show, Eq)
+
+-- | Web 管理端参数的内置默认值
+defaultWebConfig :: WebConfig
+defaultWebConfig =
+    WebConfig
+        { wcHost = "127.0.0.1"
+        , wcPort = 7778
+        , wcStaticDir = "static"
+        , wcUser = ""
+        , wcDataDir = Nothing
+        , wcCookieSecure = False
+        , wcBodyLimit = 65536
+        , wcSessionIdle = 8 * 3600
+        , wcSessionMax = 24 * 3600
+        , wcLoginMaxAttempts = 5
+        , wcLoginWindow = 5 * 60
+        , wcPageSize = 25
+        , wcMaxPageSize = 500
+        , wcMaxRows = 1000
+        , wcMaxSqlLength = 20000
+        , wcSeedDemo = False
+        }
+
+-- | 把设置键统一成连字符写法，重名时连字符优先
+canonicalSettingKeys :: Map.Map Text Text -> Map.Map Text Text
+canonicalSettingKeys saved =
+    foldr (\(key, value) acc -> Map.insert (canonicalKey key) value acc) Map.empty (Map.toList saved)
+  where
+    -- | 取一个键的规范名
+    canonicalKey key = fromMaybe key (lookup key keyAliases)
+
+-- | 下划线写法到连字符写法的别名
+keyAliases :: [(Text, Text)]
+keyAliases =
+    [ ("static_dir", "static-dir")
+    , ("session_idle", "session-idle")
+    , ("session_max", "session-max")
+    , ("login_max_attempts", "login-max-attempts")
+    , ("login_window", "login-window")
+    , ("body_limit", "body-limit")
+    , ("rows_per_page", "rows-per-page")
+    , ("max_page_size", "max-page-size")
+    , ("max_rows", "max-rows")
+    , ("max_sql_length", "max-sql-length")
+    , ("password_min_length", "password-min-length")
+    , ("password_classes", "password-classes")
+    ]
+
+-- | 这份配置用的还是内置默认口令吗
+usingDefaultCredentials :: Map.Map Text Text -> Bool
+usingDefaultCredentials saved = Map.notMember "password" saved
+
+-- | 设置文件里某个键的非空值
+nonEmptyValue :: Text -> Map.Map Text Text -> Maybe Text
+-- | 查一个键
+nonEmptyValue key saved = case T.strip <$> Map.lookup key saved of
+    Just value | not (T.null value) -> Just value
+    _ -> Nothing
+
+-- | root 凭据：明文就哈希，留空免密，缺省用演示口令
+resolveCredential :: WebConfig -> Map.Map Text Text -> IO Credential
+resolveCredential cfg saved = do
+    encoded <- case Map.lookup "password" saved of
+        Just plain | not (T.null (T.strip plain)) -> hashPassword (T.strip plain)
+        Just _ -> pure ""
+        Nothing -> hashPassword defaultPassword
+    pure (Credential (rootUserName cfg saved) encoded)
+
+-- | 管理员名字：命令行 > 设置文件 > 内置默认
+rootUserName :: WebConfig -> Map.Map Text Text -> Text
+rootUserName cfg saved
+    | not (T.null (T.strip (wcUser cfg))) = T.strip (wcUser cfg)
+    | otherwise = fromMaybe defaultUser (nonEmptyValue "user" saved)
+
+-- | 读配置：默认叠上 [web] 与 [storage]
+loadWebConfigAt :: FilePath -> IO WebConfig
+loadWebConfigAt path = do
+    raw <- readSection path "web"
+    storage <- readSection path "storage"
+    pure (withStorage storage (webConfigFromSection (canonicalSettingKeys raw)))
+
+-- | 数据目录取自 [storage] 段
+withStorage :: Map.Map Text Text -> WebConfig -> WebConfig
+withStorage storage cfg =
+    cfg{wcDataDir = T.unpack <$> nonEmptyValue "data_dir" storage}
+
+-- | 管理员明文口令，没配回落到演示口令，显式留空回空串
+resolvePlainPassword :: Map.Map Text Text -> Text
+resolvePlainPassword saved = case Map.lookup "password" saved of
+    Just plain -> T.strip plain
+    Nothing -> defaultPassword
+
+-- | [web] 分区里的启动参数，缺失或坏值一律回到内置默认
+webConfigFromSection :: Map.Map Text Text -> WebConfig
+webConfigFromSection saved =
+    defaultWebConfig
+        { wcHost = T.unpack (sectionText "host" saved (T.pack (wcHost defaultWebConfig)))
+        , wcPort = sectionInt "port" saved (wcPort defaultWebConfig)
+        , wcStaticDir = T.unpack (sectionText "static-dir" saved (T.pack (wcStaticDir defaultWebConfig)))
+        , wcCookieSecure = sectionBool "cookie-secure" saved (wcCookieSecure defaultWebConfig)
+        , wcBodyLimit = sectionInt "body-limit" saved (wcBodyLimit defaultWebConfig)
+        , wcSessionIdle = sectionInt "session-idle" saved (wcSessionIdle defaultWebConfig)
+        , wcSessionMax = sectionInt "session-max" saved (wcSessionMax defaultWebConfig)
+        , wcLoginMaxAttempts = sectionInt "login-max-attempts" saved (wcLoginMaxAttempts defaultWebConfig)
+        , wcLoginWindow = sectionInt "login-window" saved (wcLoginWindow defaultWebConfig)
+        , wcPageSize = sectionInt "rows-per-page" saved (wcPageSize defaultWebConfig)
+        , wcMaxPageSize = sectionInt "max-page-size" saved (wcMaxPageSize defaultWebConfig)
+        , wcMaxRows = sectionInt "max-rows" saved (wcMaxRows defaultWebConfig)
+        , wcMaxSqlLength = sectionInt "max-sql-length" saved (wcMaxSqlLength defaultWebConfig)
+        , wcSeedDemo = sectionBool "seed" saved (wcSeedDemo defaultWebConfig)
+        }
+
+-- | 分区里一个键的非空字符串值
+sectionText :: Text -> Map.Map Text Text -> Text -> Text
+sectionText key saved def = fromMaybe def (nonEmptyValue key saved)
+
+-- | 分区里的整数，解析不出来就用内置默认
+sectionInt :: Text -> Map.Map Text Text -> Int -> Int
+sectionInt key saved def = fromMaybe def (nonEmptyValue key saved >>= readMaybe . T.unpack)
+
+-- | 分区里的布尔（1/true/yes/on 都算真）
+sectionBool :: Text -> Map.Map Text Text -> Bool -> Bool
+sectionBool key saved def = case nonEmptyValue key saved of
+    Nothing -> def
+    Just value -> map toLower (T.unpack value) `elem` ["1", "true", "yes", "on"]
+
+-- | 静态目录候选位置，按顺序取第一个存在的
+staticDirCandidates :: FilePath -> [FilePath]
+staticDirCandidates given =
+    [given, "static", "chusql-web/static", "../chusql-web/static", "../static"]
+
+-- | 找出真正能用的静态目录
+resolveStaticDir :: FilePath -> IO (Maybe FilePath)
+resolveStaticDir given = go (staticDirCandidates given)
+  where
+    -- | 逐个试
+    go [] = pure Nothing
+    go (d : ds) = do
+        ok <- doesDirectoryExist d
+        if ok then pure (Just d) else go ds
+
+-- | 服务器监听参数
+data ServerConfig = ServerConfig
+    { scHost :: String
+    , scPort :: Int
+    , scMaxMessage :: Int
+    , scMaxRows :: Int
+    }
+    deriving (Eq, Show)
+
+-- | 默认本机 7777，行 1 MiB，最多 1000 行
+defaultServerConfig :: ServerConfig
+defaultServerConfig = ServerConfig "127.0.0.1" 7777 (1024 * 1024) 1000
+
+-- | 读 [server] 段键，缺的用默认
+loadServerConfigAt :: FilePath -> IO ServerConfig
+loadServerConfigAt path = do
+    values <- readSection path "server"
+    let -- | 取一个键的非空字符串值
+        textOf key fallback = case Map.lookup key values of
+            Just value | not (T.null (T.strip value)) -> T.unpack (T.strip value)
+            _ -> fallback
+        -- | 取一个键的整数值
+        intOf key fallback = case Map.lookup key values >>= readMaybe . T.unpack . T.strip of
+            Just number -> number
+            Nothing -> fallback
+    pure
+        defaultServerConfig
+            { scHost = textOf "host" (scHost defaultServerConfig)
+            , scPort = intOf "port" (scPort defaultServerConfig)
+            , scMaxMessage = intOf "max_message" (scMaxMessage defaultServerConfig)
+            , scMaxRows = intOf "max_rows" (scMaxRows defaultServerConfig)
+            }

chusql-interface/src/ChuSQL/Interface/Link.hs

@@ -0,0 +1,221 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Interface.Link (
+    Client,
+    connectClient,
+    closeClient,
+    clientLogin,
+    clientQuery,
+    clientPing,
+    clientCatalog,
+    clientDatabases,
+    clientRoles,
+    clientAccounts,
+    clientPolicy,
+    clientReloadPolicy,
+) where
+
+import ChuSQL.Core.Protocol (Account, QueryResult (..), TableInfo (..))
+import ChuSQL.Interface.Protocol (
+    ClientRequest (..),
+    RoleView,
+    ServerResponse (..),
+    decodeResponse,
+    encodeRequest,
+    protocolVersion,
+ )
+import Control.Concurrent.MVar (MVar, newMVar, withMVar)
+import Control.Exception (IOException, try)
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Lazy.Char8 as BLC
+import qualified Data.ByteString.Char8 as BSC
+import Data.Text (Text)
+import qualified Data.Text as T
+import Network.Socket (
+    AddrInfo (..),
+    SocketType (Stream),
+    addrAddress,
+    addrFamily,
+    connect,
+    defaultHints,
+    defaultProtocol,
+    getAddrInfo,
+    socket,
+    socketToHandle,
+ )
+import System.IO (BufferMode (LineBuffering), Handle, IOMode (ReadWriteMode), hClose, hFlush, hSetBuffering, hSetNewlineMode, noNewlineTranslation)
+import System.IO.Error (isEOFError)
+
+-- 前端到 server 的 TCP 链路：一行一条 JSON，命令行与 Web 端共用。
+
+-- | 一条已连上、已对过协议版本的连接
+data Client = Client
+    { clHandle :: Handle
+    , clLock :: MVar ()
+    }
+
+-- | 连上 server 并对协议版本，失败给人话错误
+connectClient :: Text -> Int -> IO (Either Text Client)
+connectClient host port = do
+    opened <- try (openConnection host port) :: IO (Either IOException Handle)
+    case opened of
+        Left err -> pure (Left ("cannot reach the server at " <> T.pack (address host port) <> ": " <> T.pack (describe err)))
+        Right handle -> do
+            lock <- newMVar ()
+            let client = Client handle lock
+            greeted <- request client (ReqHello protocolVersion)
+            case greeted of
+                Right (RespHello version)
+                    | version == protocolVersion -> pure (Right client)
+                    | otherwise ->
+                        giveUp handle
+                            ( "server "
+                                <> T.pack (address host port)
+                                <> " speaks protocol "
+                                <> T.pack (show version)
+                                <> ", this client needs "
+                                <> T.pack (show protocolVersion)
+                            )
+                Right (RespError code message) -> giveUp handle (code <> ": " <> message)
+                Right _ -> giveUp handle "unexpected response to hello"
+                Left message -> giveUp handle message
+  where
+    -- | 对不上就关连接并回错误
+    giveUp handle message = do
+        _ <- try (hClose handle) :: IO (Either IOException ())
+        pure (Left message)
+
+-- | 断开连接；重复调用不报错
+closeClient :: Client -> IO ()
+closeClient client = do
+    _ <- try (hClose (clHandle client)) :: IO (Either IOException ())
+    pure ()
+
+-- | 一行请求一行响应；同一条连接上的请求串起来发
+request :: Client -> ClientRequest -> IO (Either Text ServerResponse)
+request client message = withMVar (clLock client) $ \_ -> do
+    outcome <- try (exchange (clHandle client) message) :: IO (Either IOException (Either Text ServerResponse))
+    pure $ case outcome of
+        Left err -> Left (T.pack (describe err))
+        Right answer -> answer
+
+-- | 在句柄上发一行请求、读回一行响应
+exchange :: Handle -> ClientRequest -> IO (Either Text ServerResponse)
+exchange handle message = do
+    BLC.hPutStr handle (encodeRequest message)
+    BLC.hPutStr handle "\n"
+    hFlush handle
+    line <- BSC.hGetLine handle
+    pure (decodeResponse (BL.fromStrict line))
+
+-- | 登录；成功返回是不是管理员
+clientLogin :: Client -> Text -> Text -> IO (Either Text Bool)
+clientLogin client user password = do
+    answer <- request client (ReqLogin user password)
+    case answer of
+        Left message -> pure (Left message)
+        Right (RespLogin _ admin) -> pure (Right admin)
+        Right other -> pure (failed "login" other)
+
+-- | 跑一条语句，拿回结果集
+clientQuery :: Client -> Text -> IO (Either Text QueryResult)
+clientQuery client sql = do
+    answer <- request client (ReqQuery sql)
+    case answer of
+        Left message -> pure (Left message)
+        Right (RespResult result) -> pure (Right result)
+        Right other -> pure (failed "a query" other)
+
+-- | 探活
+clientPing :: Client -> IO (Either Text ())
+clientPing client = do
+    answer <- request client ReqPing
+    case answer of
+        Left message -> pure (Left message)
+        Right RespPong -> pure (Right ())
+        Right other -> pure (failed "a ping" other)
+
+-- | 数据字典（\\dt 与 \\d 用）
+clientCatalog :: Client -> IO (Either Text [TableInfo])
+clientCatalog client = do
+    answer <- request client ReqCatalog
+    case answer of
+        Left message -> pure (Left message)
+        Right (RespCatalog infos) -> pure (Right infos)
+        Right other -> pure (failed "a catalog" other)
+
+-- | 库清单（\\l 用）
+clientDatabases :: Client -> IO (Either Text [Text])
+clientDatabases client = do
+    answer <- request client ReqDatabases
+    case answer of
+        Left message -> pure (Left message)
+        Right (RespDatabases names) -> pure (Right names)
+        Right other -> pure (failed "a database list" other)
+
+-- | 角色总览（\\dr 用）
+clientRoles :: Client -> IO (Either Text [RoleView])
+clientRoles client = do
+    answer <- request client ReqRoles
+    case answer of
+        Left message -> pure (Left message)
+        Right (RespRoles roles) -> pure (Right roles)
+        Right other -> pure (failed "a role list" other)
+
+-- | 账号清单（\\du 与管理页用）
+clientAccounts :: Client -> IO (Either Text [Account])
+clientAccounts client = do
+    answer <- request client ReqAccounts
+    case answer of
+        Left message -> pure (Left message)
+        Right (RespAccounts accounts) -> pure (Right accounts)
+        Right other -> pure (failed "an account list" other)
+
+-- | 当前生效的口令策略（最短长度、至少几类字符）
+clientPolicy :: Client -> IO (Either Text (Int, Int))
+clientPolicy client = do
+    answer <- request client ReqPolicy
+    case answer of
+        Left message -> pure (Left message)
+        Right (RespPolicy minLength classes) -> pure (Right (minLength, classes))
+        Right other -> pure (failed "a password policy" other)
+
+-- | 让 server 重读它自己的设置文件并换上新的口令策略
+clientReloadPolicy :: Client -> IO (Either Text (Int, Int))
+clientReloadPolicy client = do
+    answer <- request client ReqReloadPolicy
+    case answer of
+        Left message -> pure (Left message)
+        Right (RespPolicy minLength classes) -> pure (Right (minLength, classes))
+        Right other -> pure (failed "a password policy reload" other)
+
+-- | 应答形状对不上时的错误，error 应答取码与说明
+failed :: Text -> ServerResponse -> Either Text a
+failed what response = case response of
+    RespError code message -> Left (code <> ": " <> message)
+    _ -> Left ("unexpected response to " <> what)
+
+-- | 建连接（套接字转成文本模式的行缓冲句柄）
+openConnection :: Text -> Int -> IO Handle
+openConnection host port = do
+    let hints = defaultHints{addrSocketType = Stream}
+    infos <- getAddrInfo (Just hints) (Just (T.unpack host)) (Just (show port))
+    case infos of
+        [] -> ioError (userError ("cannot resolve server address: " ++ address host port))
+        (info : _) -> do
+            sock <- socket (addrFamily info) Stream defaultProtocol
+            connect sock (addrAddress info)
+            handle <- socketToHandle sock ReadWriteMode
+            hSetBuffering handle LineBuffering
+            hSetNewlineMode handle noNewlineTranslation
+            pure handle
+
+-- | 把主机端口拼成地址字样
+address :: Text -> Int -> String
+address host port = T.unpack host ++ ":" ++ show port
+
+-- | 断线给人的说法：EOF 就是 server 把连接关了
+describe :: IOException -> String
+describe err
+    | isEOFError err = "the server closed the connection"
+    | otherwise = show err

chusql-interface/src/ChuSQL/Interface/Policy.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Interface.Policy (
+    PasswordPolicy (..),
+    defaultPasswordPolicy,
+    passwordKeys,
+    policyFromValues,
+) where
+
+import ChuSQL.Interface.Settings (defaultOf)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Text.Read (readMaybe)
+
+-- 口令策略值与策略计算，服务端与 Web 管理端共用。
+
+-- | 口令策略：最短长度与至少几类字符
+data PasswordPolicy = PasswordPolicy
+    { ppMinLength :: Int
+    , ppClasses :: Int
+    }
+    deriving (Show, Eq)
+
+-- | 默认：至少 12 个字符、至少两类字符
+defaultPasswordPolicy :: PasswordPolicy
+defaultPasswordPolicy = PasswordPolicy 12 2
+
+-- | 设置文件里决定口令策略的键
+passwordKeys :: [Text]
+passwordKeys = ["password-min-length", "password-classes"]
+
+-- | 策略值：缺项或空值回落到内置默认
+policyFromValues :: PasswordPolicy -> Map.Map Text Text -> PasswordPolicy
+policyFromValues before values = PasswordPolicy
+    (number "password-min-length" (ppMinLength before)) (number "password-classes" (ppClasses before))
+  where
+    -- | 取一个键的数值，缺项或空值回落到给定默认
+    number key fallback = case Map.lookup key values of
+        Nothing -> fallback
+        Just value -> fromMaybe fallback (readMaybe (T.unpack (if T.null value then defaultOf key else value)))

chusql-interface/src/ChuSQL/Interface/Protocol.hs

@@ -0,0 +1,248 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Interface.Protocol (
+    protocolVersion,
+    serverName,
+    ClientRequest (..),
+    ServerResponse (..),
+    decodeRequest,
+    encodeRequest,
+    encodeResponse,
+    decodeResponse,
+    Grant (..),
+    RoleView (..),
+) where
+
+import ChuSQL.Core.Protocol (Account (..), QueryResult (..), TableInfo (..), queryResultJson)
+import Data.Aeson (FromJSON (..), ToJSON (..), Value, object, withObject, (.:), (.:?), (.!=), (.=))
+import qualified Data.Aeson as A
+import qualified Data.Aeson.Key as AK
+import qualified Data.Aeson.KeyMap as KM
+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
+
+-- server 线上协议的编解码：一行一条 JSON（UTF-8）。
+
+-- | 一条角色授权：角色 + 具体权限 + 对象
+data Grant = Grant
+    { grantRole :: Text
+    , grantPrivilege :: Text
+    , grantObject :: Text
+    }
+    deriving (Show, Eq, Ord)
+
+-- | 一个角色的全貌
+data RoleView = RoleView
+    { roleName :: Text
+    , roleGrants :: [Grant]
+    , roleMembers :: [Text]
+    }
+    deriving (Show, Eq)
+
+-- | 一条授权转成 JSON
+instance ToJSON Grant where
+    toJSON grant =
+        object
+            [ "role" .= grantRole grant
+            , "privilege" .= grantPrivilege grant
+            , "object" .= grantObject grant
+            ]
+
+-- | 从 JSON 读一条授权
+instance FromJSON Grant where
+    parseJSON = withObject "Grant" $ \o ->
+        Grant <$> o .: "role" <*> o .: "privilege" <*> o .: "object"
+
+-- | 一个角色转成 JSON
+instance ToJSON RoleView where
+    toJSON view =
+        object
+            [ "role" .= roleName view
+            , "grants" .= roleGrants view
+            , "members" .= roleMembers view
+            ]
+
+-- | 从 JSON 读一个角色
+instance FromJSON RoleView where
+    parseJSON = withObject "RoleView" $ \o ->
+        RoleView
+            <$> o .: "role"
+            <*> o .:? "grants" .!= []
+            <*> o .:? "members" .!= []
+
+-- | 协议版本；对不上就报协议错误
+protocolVersion :: Int
+protocolVersion = 1
+
+-- | server 名字，握手时回给客户端
+serverName :: Text
+serverName = "chusql-server"
+
+-- | 客户端请求
+data ClientRequest
+    = ReqHello Int
+    | ReqLogin Text Text
+    | ReqQuery Text
+    | ReqPing
+    | ReqQuit
+    | ReqStorage Value
+    | ReqCatalog
+    | ReqDatabases
+    | ReqRoles
+    | ReqAccounts
+    | ReqPolicy
+    | ReqReloadPolicy
+    deriving (Eq, Show)
+
+-- | 线上请求的原始字段
+data WireRequest = WireRequest
+    { wrMethod :: Text
+    , wrProtocol :: Maybe Int
+    , wrUser :: Maybe Text
+    , wrPassword :: Maybe Text
+    , wrSql :: Maybe Text
+    , wrRequest :: Maybe Value
+    }
+
+-- | 从 JSON 读原始请求字段
+instance A.FromJSON WireRequest where
+    parseJSON = A.withObject "request" $ \o ->
+        WireRequest
+            <$> o A..: "method"
+            <*> o A..:? "protocol"
+            <*> o A..:? "user"
+            <*> o A..:? "password"
+            <*> o A..:? "sql"
+            <*> o A..:? "request"
+
+-- | 请求解码：方法名走 method 标签
+decodeRequest :: BSC.ByteString -> Either Text ClientRequest
+decodeRequest raw = case A.eitherDecodeStrict raw of
+    Left _ -> Left "request is not valid JSON"
+    Right wire -> case T.toLower (T.strip (wrMethod wire)) of
+        "hello" -> Right (ReqHello (fromMaybe protocolVersion (wrProtocol wire)))
+        "login" -> case (wrUser wire, wrPassword wire) of
+            (Just user, Just password) -> Right (ReqLogin user password)
+            _ -> Left "login needs both user and password"
+        "query" -> maybe (Left "query needs sql") (Right . ReqQuery) (wrSql wire)
+        "storage" -> maybe (Left "storage needs request") (Right . ReqStorage) (wrRequest wire)
+        "catalog" -> Right ReqCatalog
+        "databases" -> Right ReqDatabases
+        "roles" -> Right ReqRoles
+        "accounts" -> Right ReqAccounts
+        "policy" -> Right ReqPolicy
+        "reload-policy" -> Right ReqReloadPolicy
+        "ping" -> Right ReqPing
+        "quit" -> Right ReqQuit
+        other -> Left ("unknown method: " <> other)
+
+-- | 客户端侧的请求编码（一行一条 JSON，不带换行）
+encodeRequest :: ClientRequest -> BL.ByteString
+encodeRequest = A.encode . requestJson
+
+-- | 客户端请求转 JSON；方法名走 method 标签
+requestJson :: ClientRequest -> Value
+requestJson request = case request of
+    ReqHello version -> object ["method" .= ("hello" :: Text), "protocol" .= version]
+    ReqLogin user password -> object ["method" .= ("login" :: Text), "user" .= user, "password" .= password]
+    ReqQuery sql -> object ["method" .= ("query" :: Text), "sql" .= sql]
+    ReqPing -> object ["method" .= ("ping" :: Text)]
+    ReqQuit -> object ["method" .= ("quit" :: Text)]
+    ReqStorage payload -> object ["method" .= ("storage" :: Text), "request" .= payload]
+    ReqCatalog -> object ["method" .= ("catalog" :: Text)]
+    ReqDatabases -> object ["method" .= ("databases" :: Text)]
+    ReqRoles -> object ["method" .= ("roles" :: Text)]
+    ReqAccounts -> object ["method" .= ("accounts" :: Text)]
+    ReqPolicy -> object ["method" .= ("policy" :: Text)]
+    ReqReloadPolicy -> object ["method" .= ("reload-policy" :: Text)]
+
+-- | 服务端响应
+data ServerResponse
+    = RespHello Int
+    | RespLogin Text Bool
+    | RespResult QueryResult
+    | RespPong
+    | RespBye
+    | RespError Text Text
+    | RespStorage Value
+    | RespCatalog [TableInfo]
+    | RespDatabases [Text]
+    | RespRoles [RoleView]
+    | RespAccounts [Account]
+    | RespPolicy Int Int
+    deriving (Eq, Show)
+
+-- | 响应转 JSON；结果集只多一个 status 字段
+encodeResponse :: ServerResponse -> BL.ByteString
+encodeResponse = A.encode . responseJson
+
+-- | 服务端响应转 JSON；结果集只是多一个 status 字段
+responseJson :: ServerResponse -> Value
+responseJson response = case response of
+    RespHello version -> object ["status" .= ("hello" :: Text), "protocol" .= version, "server" .= serverName]
+    RespLogin user admin -> object ["status" .= ("ok" :: Text), "user" .= user, "admin" .= admin]
+    RespPong -> object ["status" .= ("pong" :: Text)]
+    RespBye -> object ["status" .= ("bye" :: Text)]
+    RespError code message -> object ["status" .= ("error" :: Text), "code" .= code, "message" .= message]
+    RespStorage value -> object ["status" .= ("storage" :: Text), "response" .= value]
+    RespCatalog infos -> object ["status" .= ("catalog" :: Text), "schemas" .= infos]
+    RespDatabases names -> object ["status" .= ("databases" :: Text), "databases" .= names]
+    RespRoles roleList -> object ["status" .= ("roles" :: Text), "roles" .= roleList]
+    RespAccounts accountList -> object ["status" .= ("accounts" :: Text), "accounts" .= accountList]
+    RespPolicy minLength classes -> object ["status" .= ("policy" :: Text), "minLength" .= minLength, "classes" .= classes]
+    RespResult result -> case queryResultJson result of
+        A.Object fields -> A.Object (KM.insert "status" (A.String "result") fields)
+        other -> other
+
+-- | 响应解码（客户端用）
+decodeResponse :: BL.ByteString -> Either Text ServerResponse
+decodeResponse raw = case A.eitherDecode raw of
+    Left _ -> Left "response is not valid JSON"
+    Right (A.Object fields) -> case KM.lookup "status" fields of
+        Just (A.String status) -> decodeStatus status fields
+        _ -> Left "response is missing status"
+    Right _ -> Left "response is not a JSON object"
+  where
+    -- | 按 status 字段分派
+    decodeStatus status fields = case status of
+        "hello" -> Right (RespHello (intOf "protocol" fields))
+        "ok" -> Right (RespLogin (textOf "user" fields) (boolOf "admin" fields))
+        "pong" -> Right RespPong
+        "bye" -> Right RespBye
+        "error" -> Right (RespError (textOf "code" fields) (textOf "message" fields))
+        "storage" -> case KM.lookup "response" fields of
+            Just value -> Right (RespStorage value)
+            Nothing -> Left "storage response is missing response"
+        "result" -> case A.fromJSON (A.Object fields) of
+            A.Success result -> Right (RespResult result)
+            A.Error message -> Left (T.pack message)
+        "catalog" -> fromField "schemas" RespCatalog fields
+        "databases" -> fromField "databases" RespDatabases fields
+        "roles" -> fromField "roles" RespRoles fields
+        "accounts" -> fromField "accounts" RespAccounts fields
+        "policy" -> Right (RespPolicy (intOf "minLength" fields) (intOf "classes" fields))
+        other -> Left ("unexpected status: " <> other)
+
+    -- | 取一个字段解成目标类型
+    fromField :: A.FromJSON a => Text -> (a -> ServerResponse) -> A.Object -> Either Text ServerResponse
+    fromField key wrap fields = case A.fromJSON (fromMaybe A.Null (KM.lookup (AK.fromText key) fields)) of
+        A.Success value -> Right (wrap value)
+        A.Error message -> Left (T.pack message)
+
+    -- | 取一个整数字段
+    intOf key fields = case KM.lookup key fields of
+        Just (A.Number number) -> truncate number
+        _ -> 0
+
+    -- | 取一个文本字段
+    textOf key fields = case KM.lookup key fields of
+        Just (A.String text) -> text
+        _ -> ""
+
+    -- | 取一个布尔字段
+    boolOf key fields = case KM.lookup key fields of
+        Just (A.Bool flag) -> flag
+        _ -> False

chusql-interface/src/ChuSQL/Interface/RateLimit.hs

@@ -0,0 +1,75 @@
+module ChuSQL.Interface.RateLimit (
+    RateLimiter,
+    newRateLimiter,
+    setRateLimit,
+    rateLimitBlock,
+    rateLimitRecord,
+    rateLimitClear,
+) where
+
+import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import qualified Data.Map.Strict as Map
+import Data.Text (Text)
+import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime)
+
+-- 登录失败限流：按用户名数一个滑动窗口里的失败次数。
+
+-- | 一个键的失败计数与窗口起点
+data Attempt = Attempt
+    { attCount :: Int
+    , attStart :: UTCTime
+    }
+
+-- | 限流阈值：次数上限与窗口长度
+data RateLimitPolicy = RateLimitPolicy
+    { rlpMax :: Int
+    , rlpWindow :: NominalDiffTime
+    }
+
+-- | 限流器：计数表、阈值与时钟
+data RateLimiter = RateLimiter
+    { rlMap :: MVar (Map.Map Text Attempt)
+    , rlPolicy :: IORef RateLimitPolicy
+    , rlClock :: IO UTCTime
+    }
+
+-- | 造一个限流器：多少次失败、窗口多长
+newRateLimiter :: IO UTCTime -> Int -> NominalDiffTime -> IO RateLimiter
+newRateLimiter clock maxFailures window = do
+    ref <- newMVar Map.empty
+    policyRef <- newIORef (RateLimitPolicy maxFailures window)
+    pure (RateLimiter ref policyRef clock)
+
+-- | 换一套限流阈值（设置页热改）
+setRateLimit :: RateLimiter -> Int -> NominalDiffTime -> IO ()
+setRateLimit rl maxFailures window =
+    writeIORef (rlPolicy rl) (RateLimitPolicy maxFailures window)
+
+-- | 这个键被锁住了吗？锁住就返回还要等多少秒
+rateLimitBlock :: RateLimiter -> Text -> IO (Maybe NominalDiffTime)
+rateLimitBlock rl key = do
+    now <- rlClock rl
+    pol <- readIORef (rlPolicy rl)
+    m <- readMVar (rlMap rl)
+    pure $ case Map.lookup key m of
+        Just a
+            | attCount a >= rlpMax pol ->
+                let left = rlpWindow pol - diffUTCTime now (attStart a)
+                 in if left > 0 then Just left else Nothing
+        _ -> Nothing
+
+-- | 记一次失败
+rateLimitRecord :: RateLimiter -> Text -> IO ()
+rateLimitRecord rl key = do
+    now <- rlClock rl
+    pol <- readIORef (rlPolicy rl)
+    modifyMVar_ (rlMap rl) $ \m ->
+        let kept = Map.filter (\a -> diffUTCTime now (attStart a) < rlpWindow pol) m
+            old = Map.findWithDefault (Attempt 0 now) key kept
+            fresh = if attCount old == 0 then Attempt 1 now else old{attCount = attCount old + 1}
+         in pure (Map.insert key fresh kept)
+
+-- | 登录成功就把失败记录清掉
+rateLimitClear :: RateLimiter -> Text -> IO ()
+rateLimitClear rl key = modifyMVar_ (rlMap rl) (pure . Map.delete key)

chusql-interface/src/ChuSQL/Interface/Session.hs

@@ -0,0 +1,110 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Interface.Session (
+    Session,
+    newSession,
+    sessionIsAdmin,
+    sessionDatabase,
+    isPlainIdentifier,
+    authenticateSession,
+    switchDatabase,
+    runStatement,
+    catalog,
+    databases,
+    roleViews,
+    accounts,
+) where
+
+import ChuSQL.Core.Protocol (Account, QueryResult (..), TableInfo)
+import ChuSQL.Interface.Link (
+    Client,
+    clientAccounts,
+    clientCatalog,
+    clientDatabases,
+    clientLogin,
+    clientQuery,
+    clientRoles,
+ )
+import ChuSQL.Interface.Protocol (RoleView)
+import Data.Char (isAlpha, isAlphaNum)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Data.Text (Text)
+import qualified Data.Text as T
+
+-- 前端会话：本地记登录态与当前库，语句答案全部来自 server。
+
+-- | 一个前端会话：连接、当前库与管理员标记
+data Session = Session
+    { ssClient :: Client
+    , ssCurrent :: IORef Text
+    , ssAdmin :: IORef Bool
+    }
+
+-- | 开一个前端会话：登录之前没有管理员身份，也没有选中的库
+newSession :: Client -> IO Session
+newSession client = Session client <$> newIORef "" <*> newIORef False
+
+-- | 是不是管理员（由登录结果决定）
+sessionIsAdmin :: Session -> IO Bool
+sessionIsAdmin = readIORef . ssAdmin
+
+-- | 当前库
+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
+
+-- | 登录：身份由 server 判定，这里只把管理员标记记下来
+authenticateSession :: Session -> Text -> Text -> IO (Either Text ())
+authenticateSession session user password = do
+    answer <- clientLogin (ssClient session) user password
+    case answer of
+        Left message -> pure (Left message)
+        Right admin -> writeIORef (ssAdmin session) admin >> pure (Right ())
+
+-- | 换库：名字先按解析器规矩校验，由 server 执行 USE
+switchDatabase :: Session -> Text -> IO (Either Text ())
+switchDatabase session rawName
+    | not (isPlainIdentifier name) = pure (Left ("not a plain database name: " <> name))
+    | otherwise = do
+        answer <- runStatement session ("USE " <> name)
+        case answer of
+            Left message -> pure (Left message)
+            Right _ -> pure (Right ())
+  where
+    -- | 规范化后的库名
+    name = T.toLower (T.strip rawName)
+
+-- | 跑一条语句；结果集里带回的当前库口径跟着一起更新
+runStatement :: Session -> Text -> IO (Either Text QueryResult)
+runStatement session sql = do
+    answer <- clientQuery (ssClient session) sql
+    case answer of
+        Left message -> pure (Left message)
+        Right result -> do
+            case qrDatabase result of
+                Just name -> writeIORef (ssCurrent session) name
+                Nothing -> pure ()
+            pure (Right result)
+
+-- | 数据字典（\\dt 与 \\d 用）
+catalog :: Session -> IO (Either Text [TableInfo])
+catalog session = clientCatalog (ssClient session)
+
+-- | 库清单（\\l 用）
+databases :: Session -> IO (Either Text [Text])
+databases session = clientDatabases (ssClient session)
+
+-- | 角色总览（\\dr 用）
+roleViews :: Session -> IO (Either Text [RoleView])
+roleViews session = clientRoles (ssClient session)
+
+-- | 账号清单（\\du 与管理页用）
+accounts :: Session -> IO (Either Text [Account])
+accounts session = clientAccounts (ssClient session)

chusql-interface/src/ChuSQL/Interface/Settings.hs

@@ -0,0 +1,243 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Interface.Settings (
+    SettingItem (..),
+    settingCatalogue,
+    findItem,
+    isRootOnly,
+    isLockedSetting,
+    isRestartRequired,
+    readSettingsFile,
+    writeSettingsFile,
+    applySettings,
+    liveKeys,
+    defaultOf,
+    effectiveSettings,
+) where
+
+import ChuSQL.Interface.Config (WebConfig (..), canonicalSettingKeys, defaultUser)
+import ChuSQL.Interface.TOML (readSection, writeSection)
+import Data.List (nub)
+import qualified Data.Map.Strict as Map
+import Data.Text (Text)
+import qualified Data.Text as T
+
+-- 设置目录，以及全局 chusql.toml 的读、写与校验。
+
+-- | 一个可配置项
+data SettingItem = SettingItem
+    { siKey :: Text
+    , siLabel :: Text
+    , siGroup :: Text
+    , siKind :: Text
+    , siDefault :: Text
+    , siRootOnly :: Bool
+    , siRestart :: Bool
+    , siSection :: Text
+    , siTomlKey :: Text
+    }
+    deriving (Show, Eq)
+
+-- | 全部可配置项与界面顺序
+settingCatalogue :: [SettingItem]
+settingCatalogue =
+    [ item "port" "HTTP port" "server" "int" "7778" True True
+    , item "host" "Listen address" "server" "text" "127.0.0.1" True True
+    , item "static-dir" "Static directory" "server" "text" "static" True True
+    , item "cookie-secure" "Secure cookie (behind TLS)" "server" "bool" "0" True False
+    , item "body-limit" "Max request body (bytes)" "limits" "int" "65536" False False
+    , item "session-idle" "Session idle timeout (s)" "limits" "int" "28800" False False
+    , item "session-max" "Session max age (s)" "limits" "int" "86400" False False
+    , item "login-max-attempts" "Failed logins before lockout" "limits" "int" "5" False False
+    , item "login-window" "Lockout window (s)" "limits" "int" "300" False False
+    , item "rows-per-page" "Rows per page" "limits" "int" "25" False False
+    , item "max-page-size" "Rows per page ceiling" "limits" "int" "500" False False
+    , item "max-rows" "Rows per query" "limits" "int" "1000" False False
+    , item "max-sql-length" "Max SQL characters" "limits" "int" "20000" False False
+    , item "user" "管理员账号（设置文件）" "auth" "text" "root" True True
+    , item "password" "管理员口令（设置文件，明文）" "auth" "secret" "" True True
+    , item "password-min-length" "口令最短长度" "auth" "int" "12" True False
+    , item "password-classes" "口令字符类别数" "auth" "int" "2" True False
+    , owned "data-dir" "Data directory" "storage" "text" "" "storage" "data_dir"
+    , owned "storage-page-size" "Storage page size" "storage" "int" "4096" "page" "size"
+    , owned "storage-btree-order" "Storage B+tree order" "storage" "int" "4" "btree" "order"
+    , owned "storage-buffer-pool" "Storage buffer pool pages" "storage" "int" "1024" "buffer" "pool_size"
+    , owned "storage-log" "Storage log level" "storage" "text" "info" "log" "level"
+    , item "seed" "Seed demo data on start" "storage" "bool" "1" True True
+    , owned "tcp-host" "TCP listen address" "network" "text" "127.0.0.1" "server" "host"
+    , owned "tcp-port" "TCP port" "network" "int" "7777" "server" "port"
+    , owned "tcp-max-message" "TCP max request line (bytes)" "network" "int" "1048576" "server" "max_message"
+    , owned "tcp-max-rows" "TCP rows per result" "network" "int" "1000" "server" "max_rows"
+    ]
+  where
+    -- | web 自己的键：分区写死 [web]
+    item k l g kind def rootOnly restart =
+        SettingItem
+            { siKey = k
+            , siLabel = l
+            , siGroup = g
+            , siKind = kind
+            , siDefault = def
+            , siRootOnly = rootOnly
+            , siRestart = restart
+            , siSection = webSection
+            , siTomlKey = k
+            }
+    -- 存储层的键：只读自己那段
+    owned k l g kind def section tomlKey =
+        SettingItem
+            { siKey = k
+            , siLabel = l
+            , siGroup = g
+            , siKind = kind
+            , siDefault = def
+            , siRootOnly = True
+            , siRestart = True
+            , siSection = section
+            , siTomlKey = tomlKey
+            }
+
+-- | web 自己的分区名
+webSection :: Text
+webSection = "web"
+
+-- | 目录里涉及的分区，去重
+catalogueSections :: [Text]
+catalogueSections = nub [siSection i | i <- settingCatalogue]
+
+-- | 按 key 找一项
+findItem :: Text -> Maybe SettingItem
+findItem key = case [i | i <- settingCatalogue, siKey i == key] of
+    (i : _) -> Just i
+    [] -> Nothing
+
+-- | 这项是不是重要参数（只有配置账号能改）
+isRootOnly :: Text -> Bool
+isRootOnly key = maybe False siRootOnly (findItem key)
+
+-- | 网页端不能改的键
+lockedKeys :: [Text]
+lockedKeys = ["user", "password"]
+
+-- | 这项在界面上是不是只读
+isLockedSetting :: Text -> Bool
+isLockedSetting = (`elem` lockedKeys)
+
+-- | 这项是不是要重启才生效
+isRestartRequired :: Text -> Bool
+isRestartRequired key = maybe False siRestart (findItem key)
+
+-- | 改完立刻生效的配置键
+liveKeys :: [Text]
+liveKeys =
+    [ "password-min-length", "password-classes"
+    , "body-limit"
+    , "session-idle"
+    , "session-max"
+    , "login-max-attempts"
+    , "login-window"
+    , "rows-per-page"
+    , "max-page-size"
+    , "max-rows"
+    , "max-sql-length"
+    ]
+
+-- | 读目录里用到的每个分区，摊成界面键
+readSettingsFile :: FilePath -> IO (Map.Map Text Text)
+readSettingsFile path = fmap Map.unions (mapM readSectionOf catalogueSections)
+  where
+    -- | 读一个分区，摊成界面键
+    readSectionOf section = do
+        raw <- readSection path section
+        let values = if section == webSection then canonicalSettingKeys raw else raw
+        pure
+            ( Map.fromList
+                [ (siKey i, value)
+                | i <- settingCatalogue
+                , siSection i == section
+                , Just value <- [Map.lookup (siTomlKey i) values]
+                ]
+            )
+
+-- | 按分区写回，别的分区与注释原样保留
+writeSettingsFile :: FilePath -> Map.Map Text Text -> IO (Either String ())
+writeSettingsFile path values = writeSections catalogueSections
+  where
+    -- | 各分区依次写回
+    writeSections [] = pure (Right ())
+    writeSections (section : rest) = do
+        let entries =
+                Map.fromList
+                    [ (siTomlKey i, value)
+                    | i <- settingCatalogue
+                    , siSection i == section
+                    , Just value <- [Map.lookup (siKey i) values]
+                    ]
+        if Map.null entries
+            then writeSections rest
+            else do
+                written <- writeSection path section entries
+                case written of
+                    Left err -> pure (Left err)
+                    Right () -> writeSections rest
+
+-- | 把界面传来的值合并进现有内容，只认目录里的键
+applySettings :: Map.Map Text Text -> Map.Map Text Text -> Either String (Map.Map Text Text)
+applySettings current = go (Right current) . Map.toList
+  where
+    -- | 逐项校验并合并
+    go (Left e) _ = Left e
+    go (Right acc) [] = Right acc
+    go (Right acc) ((key, value) : rest) = case findItem key of
+        Nothing -> Left ("unknown setting: " ++ T.unpack key)
+        Just spec -> case checkKind spec value of
+            Left e -> Left e
+            Right () -> go (Right (Map.insert key value acc)) rest
+
+-- | 按类型校验一个值，空串一律放行
+checkKind :: SettingItem -> Text -> Either String ()
+checkKind spec value
+    | T.null (T.strip value) = Right ()
+    | Just (lo, hi) <- lookup (siKey spec) [("password-min-length", (8, 256)), ("password-classes", (1, 4))] =
+        case reads (T.unpack (T.strip value)) :: [(Int, String)] of
+            [(n, "")] | n >= lo && n <= hi -> Right ()
+            _ -> Left (T.unpack (siKey spec) ++ " is outside the permitted range")
+    | siKind spec == "int" = case reads (T.unpack (T.strip value)) :: [(Int, String)] of
+        [(_, "")] -> Right ()
+        _ -> Left (T.unpack (siKey spec) ++ " needs an integer, got: " ++ T.unpack value)
+    | siKind spec == "bool" = case T.toLower (T.strip value) of
+        v | v `elem` ["0", "1", "true", "false", "yes", "no", "on", "off"] -> Right ()
+        _ -> Left (T.unpack (siKey spec) ++ " needs a boolean, got: " ++ T.unpack value)
+    | otherwise = Right ()
+
+-- | 一项的内置默认值
+defaultOf :: Text -> Text
+defaultOf key = maybe "" siDefault (findItem key)
+
+-- | 本进程启动时生效的配置，摊成键值对
+effectiveSettings :: WebConfig -> Map.Map Text Text
+effectiveSettings cfg =
+    Map.fromList
+        [ ("port", tshow (wcPort cfg))
+        , ("host", T.pack (wcHost cfg))
+        , ("static-dir", T.pack (wcStaticDir cfg))
+        , ("cookie-secure", boolText (wcCookieSecure cfg))
+        , ("body-limit", tshow (wcBodyLimit cfg))
+        , ("session-idle", tshow (wcSessionIdle cfg))
+        , ("session-max", tshow (wcSessionMax cfg))
+        , ("login-max-attempts", tshow (wcLoginMaxAttempts cfg))
+        , ("login-window", tshow (wcLoginWindow cfg))
+        , ("rows-per-page", tshow (wcPageSize cfg))
+        , ("max-page-size", tshow (wcMaxPageSize cfg))
+        , ("max-rows", tshow (wcMaxRows cfg))
+        , ("max-sql-length", tshow (wcMaxSqlLength cfg))
+        , ("user", if T.null (T.strip (wcUser cfg)) then defaultUser else T.strip (wcUser cfg))
+        , ("seed", boolText (wcSeedDemo cfg))
+        , ("data-dir", maybe "" T.pack (wcDataDir cfg))
+        ]
+  where
+    -- | 数值转文本
+    tshow = T.pack . show
+    -- | 布尔转 "1"/"0"
+    boolText True = "1"
+    boolText False = "0"

chusql-interface/src/ChuSQL/Interface/TOML.hs

@@ -0,0 +1,173 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Interface.TOML
+    ( readSection
+    , writeSection
+    , defaultConfigFile
+    , resolveConfigPath
+    ) where
+
+import Control.Exception (IOException, try)
+import qualified Data.ByteString as BS
+import qualified Data.Map.Strict as Map
+import Data.Map.Strict (Map)
+import qualified Data.Set as Set
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import System.Directory (XdgDirectory (XdgConfig), createDirectoryIfMissing, doesFileExist, getXdgDirectory)
+import System.FilePath (takeDirectory, (</>))
+
+-- 全局 chusql.toml 的最小读写：只认 [section] 与 key = value。
+
+-- | 读一个分区；文件不存在或没有这个分区都当空表
+readSection :: FilePath -> Text -> IO (Map Text Text)
+readSection path section = do
+    exists <- doesFileExist path
+    if not exists
+        then pure Map.empty
+        else do
+            raw <- BS.readFile path
+            pure (Map.fromList (sectionEntries section (T.lines (TE.decodeUtf8 raw))))
+
+-- | 只重写一个分区，其它行（含注释与别的层）原样保留
+writeSection :: FilePath -> Text -> Map Text Text -> IO (Either String ())
+writeSection path section values = do
+    prepared <- prepareDirectory
+    case prepared of
+        Left err -> pure (Left err)
+        Right () -> do
+            exists <- doesFileExist path
+            raw <- if exists then TE.decodeUtf8 <$> BS.readFile path else pure ""
+            let updated = T.unlines (rewrite section values (T.lines raw))
+            written <- tryWrite (TE.encodeUtf8 updated)
+            pure written
+  where
+    -- | 目录不存在就先建
+    prepareDirectory = do
+        let dir = takeDirectory path
+        if null dir
+            then pure (Right ())
+            else do
+                done <- try (createDirectoryIfMissing True dir) :: IO (Either IOException ())
+                pure (either (Left . show) (const (Right ())) done)
+    -- | 写文件，异常转成错误串
+    tryWrite bytes = do
+        done <- try (BS.writeFile path bytes) :: IO (Either IOException ())
+        pure (either (Left . show) (const (Right ())) done)
+
+-- | 分区里的键值对
+sectionEntries :: Text -> [Text] -> [(Text, Text)]
+sectionEntries wanted = go ""
+  where
+    -- | 走到目标分区后收键值对
+    go _ [] = []
+    go current (line : rest)
+        | Just name <- sectionName line = go name rest
+        | current /= wanted = go current rest
+        | otherwise = case assignment line of
+            Nothing -> go current rest
+            Just entry -> entry : go current rest
+
+-- | 是不是分区头，返回分区名
+sectionName :: Text -> Maybe Text
+sectionName line = case T.strip line of
+    stripped
+        | "[" `T.isPrefixOf` stripped && "]" `T.isSuffixOf` stripped && T.length stripped > 2 ->
+            Just (T.strip (T.drop 1 (T.dropEnd 1 stripped)))
+    _ -> Nothing
+
+-- | 是不是 key = value
+assignment :: Text -> Maybe (Text, Text)
+assignment line = case T.breakOn "=" (stripComment line) of
+    (key, rest)
+        | not (T.null rest)
+        , let name = T.strip key
+        , not (T.null name) ->
+            Just (name, unquote (T.strip (T.drop 1 rest)))
+    _ -> Nothing
+
+-- | 去掉行尾注释（引号里的 # 不算）
+stripComment :: Text -> Text
+stripComment = T.pack . go False . T.unpack
+  where
+    -- | 引号外遇到 # 就到此为止
+    go _ [] = []
+    go inString ('#' : rest)
+        | not inString = []
+        | otherwise = '#' : go inString rest
+    go inString ('"' : rest) = '"' : go (not inString) rest
+    go inString (ch : rest) = ch : go inString rest
+
+-- | 去掉包裹的引号
+unquote :: Text -> Text
+unquote value
+    | T.length value >= 2 && T.head value == '"' && T.last value == '"' = T.drop 1 (T.dropEnd 1 value)
+    | T.length value >= 2 && T.head value == '\'' && T.last value == '\'' = T.drop 1 (T.dropEnd 1 value)
+    | otherwise = value
+
+-- | 行级重写：已有键就地更新，空值删行，缺的补末尾
+rewrite :: Text -> Map Text Text -> [Text] -> [Text]
+rewrite section values = addMissing . replaceInSection . dropEmpties
+  where
+    -- | 删掉空值的键
+    dropEmpties = filter (\line -> maybe True (not . T.null . snd) (assignment line))
+    -- | 在目标分区里就地换行
+    replaceInSection = go ""
+    -- | 走到目标分区后逐行替换
+    go _ [] = []
+    go current (line : rest)
+        | Just name <- sectionName line = line : go name rest
+        | current /= section = line : go current rest
+        | otherwise = case assignment line of
+            Just (key, _) | Just value <- Map.lookup key values -> assignmentLine key value : go current rest
+            _ -> line : go current rest
+    -- | 分区里缺的键补在末尾
+    addMissing lines' =
+        let present = Set.fromList (keysOf section lines')
+            missing = [(key, value) | (key, value) <- Map.toList values, not (Set.member key present), not (T.null value)]
+         in if null missing then lines' else appendSection section missing lines'
+
+-- | 拼一行 key = value
+assignmentLine :: Text -> Text -> Text
+assignmentLine key value = key <> " = " <> quote value
+
+-- | 需要时才加引号
+quote :: Text -> Text
+quote value
+    | T.all allowed value && not (T.null value) = value
+    | otherwise = "\"" <> T.replace "\"" "\\\"" value <> "\""
+  where
+    -- | 可以裸写的字符集
+    allowed ch = ch `elem` ("0123456789.-" :: String)
+
+-- | 取某个分区里出现过的键
+keysOf :: Text -> [Text] -> [Text]
+keysOf wanted = go ""
+  where
+    -- | 走到目标分区后收键名
+    go _ [] = []
+    go current (line : rest)
+        | Just name <- sectionName line = go name rest
+        | current /= wanted = go current rest
+        | otherwise = case assignment line of
+            Just (key, _) -> key : go current rest
+            Nothing -> go current rest
+
+-- | 没有这个分区就在末尾补一个
+appendSection :: Text -> [(Text, Text)] -> [Text] -> [Text]
+appendSection section entries lines' =
+    lines'
+        ++ (if null lines' || not (T.null (last lines')) then [""] else [])
+        ++ ("[" <> section <> "]") : [assignmentLine key value | (key, value) <- entries]
+
+-- | 全局配置文件的固定路径，跟随系统惯例
+defaultConfigFile :: IO FilePath
+defaultConfigFile = do
+    dir <- getXdgDirectory XdgConfig "ChuSQL"
+    pure (dir </> "chusql.toml")
+
+-- | 定位配置文件：命令行 --config 优先，否则用固定路径
+resolveConfigPath :: Maybe FilePath -> IO FilePath
+resolveConfigPath (Just path) = pure path
+resolveConfigPath Nothing = defaultConfigFile