使用React js完成web前端

chusql-web/src/ChuSQL/Web/Actions.hs

@@ -0,0 +1,237 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Web.Actions (
+    ColumnSpec (..),
+    CreateTableSpec (..),
+    isIdentifier,
+    columnTypeOf,
+    columnTypeName,
+    coerceValue,
+    sqlLiteral,
+    escapeStringLiteral,
+    createTableSql,
+    dropTableSql,
+    createIndexSql,
+    dropIndexSql,
+    dropColumnSql,
+    insertRowSql,
+    insertRowsSql,
+    updateRowSql,
+    deleteRowSql,
+    selectRowsSql,
+) where
+
+import ChuSQL.Model (Column (..), Value (..))
+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 t = case T.toLower (T.strip t) of
+    "int" -> Just TInt
+    "integer" -> Just TInt
+    "str" -> Just TStr
+    "text" -> Just TStr
+    "varchar" -> Just TStr
+    "bool" -> Just TBool
+    "boolean" -> Just TBool
+    _ -> Nothing
+
+-- | 本地类型转线上名字
+columnTypeName :: Column -> Text
+columnTypeName TInt = "int"
+columnTypeName TStr = "str"
+columnTypeName TBool = "bool"
+
+-- | 字符串字面量转义：单引号翻倍（引擎的词法器就是这么折回去的）
+escapeStringLiteral :: String -> String
+escapeStringLiteral = concatMap (\c -> if c == '\'' then "''" else [c])
+
+-- | 值转 SQL 字面量
+sqlLiteral :: Value -> String
+sqlLiteral (VInt n) = show n
+sqlLiteral (VStr s) = "'" ++ escapeStringLiteral s ++ "'"
+sqlLiteral (VBool True) = "TRUE"
+sqlLiteral (VBool False) = "FALSE"
+
+-- | JSON 值按列类型转成引擎的值；类型对不上就报错
+coerceValue :: Column -> A.Value -> Either String Value
+coerceValue TInt v = case v of
+    A.Number n -> case floatingOrInteger n :: Either Double Integer of
+        Right i -> Right (VInt (fromIntegral i))
+        Left _ -> Left "expected an integer"
+    A.String s -> case readMaybe (T.unpack (T.strip s)) :: Maybe Int of
+        Just i -> Right (VInt i)
+        Nothing -> Left ("expected an integer, got: " ++ T.unpack s)
+    _ -> Left "expected an integer"
+coerceValue TStr v = case v of
+    A.String s -> Right (VStr (T.unpack s))
+    _ -> Left "expected a string"
+coerceValue TBool v = case v of
+    A.Bool b -> Right (VBool b)
+    A.String s -> case T.toLower (T.strip s) of
+        "true" -> Right (VBool True)
+        "false" -> Right (VBool False)
+        _ -> Left ("expected true/false, got: " ++ T.unpack s)
+    _ -> Left "expected true/false"
+
+-- | 构造 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"))

chusql-web/src/ChuSQL/Web/Auth.hs

@@ -0,0 +1,198 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Web.Auth (
+    Credential (..),
+    defaultIterations,
+    hashPassword,
+    hashPasswordWith,
+    hashLooksValid,
+    verifyPassword,
+    SessionPolicy (..),
+    defaultSessionPolicy,
+    SessionStore,
+    newSessionStore,
+    sessionPolicy,
+    setSessionPolicy,
+    createSession,
+    lookupSession,
+    deleteSession,
+    deleteOtherSessions,
+    sessionToken,
+) 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)
+
+-- 口令与 Session：口令只存 PBKDF2 编码串，会话是服务端内存状态。
+
+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
+    }
+
+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 = do
+    token <- sessionToken
+    now <- storeClock store
+    pol <- sessionPolicy store
+    modifyMVar_ (storeMap store) $ \m ->
+        pure (Map.insert token (Session user now now) (prune now pol m))
+    pure token
+
+-- | 查令牌并刷新最后活动时间
+lookupSession :: SessionStore -> Text -> IO (Maybe Text)
+lookupSession 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))
+
+-- | 删掉一条会话（退出登录）
+deleteSession :: SessionStore -> Text -> IO ()
+deleteSession store token = modifyMVar_ (storeMap store) (pure . Map.delete token)
+
+-- | 删掉除这条外的全部会话，返回条数
+deleteOtherSessions :: SessionStore -> Text -> IO Int
+deleteOtherSessions store keep = do
+    removed <- modifyMVar (storeMap store) $ \m -> do
+        let kept = Map.filterWithKey (\k _ -> k == keep) m
+        pure (kept, Map.size m - Map.size kept)
+    pure removed

chusql-web/src/ChuSQL/Web/Backend.hs

@@ -0,0 +1,125 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Web.Backend (
+    StatementResult (..),
+    Backend (..),
+    columnsFromStatement,
+    ipcBackend,
+    memoryBackend,
+    tableInfoOf,
+) where
+
+import ChuSQL.Engine (runStatement, runStatementM)
+import ChuSQL.Model
+import ChuSQL.Storage (MonadStorage (schema))
+import ChuSQL.Storage.IPC (
+    IPCStorage (..),
+    Request (..),
+    Response (..),
+    SchemaColumn (..),
+    TableInfo (..),
+    doListCatalog,
+    sendRequest,
+ )
+import ChuSQL.Syntax.AST
+import ChuSQL.Syntax.Parser (parseStatement)
+import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, readMVar, withMVar)
+import Data.List (nub)
+
+-- 后端：跑一条语句与取数据字典，分 IPC（真存储）和内存（测试）两套。
+
+data StatementResult = StatementResult
+    { srColumns :: [String]
+    , srRows :: [Row]
+    }
+
+data Backend = Backend
+    { beStatement :: String -> IO (Either String StatementResult)
+    , beCatalog :: IO (Either String [TableInfo])
+    , bePing :: IO Bool
+    }
+
+-- | 按给定列名取列，固定列顺序
+columnsFromStatement :: Database -> Statement -> [String]
+columnsFromStatement db stmt = case stmt of
+    Select cols from _ _ _
+        | cols == [allColumns] -> wildcard from
+        | otherwise -> cols
+    _ -> []
+  where
+    -- | 展开 *：单表按列序，JOIN 左表在前
+    wildcard (FromTable mAlias tbl) = case lookup tbl db of
+        Nothing -> []
+        Just t -> [qualify mAlias c | c <- colNames t]
+    wildcard (FromJoin left mAlias tbl _) = wildcard left ++ wildcard (FromTable mAlias tbl)
+
+-- | 走命名管道的后端（真存储）
+ipcBackend :: IO Backend
+ipcBackend = do
+    lock <- newMVar ()
+    pure
+        Backend
+            { beStatement = \sql -> withMVar lock $ \_ -> runIpc sql
+            , beCatalog = withMVar lock $ \_ -> do
+                result <- doListCatalog
+                pure (either Left Right result)
+            , bePing = withMVar lock $ \_ -> do
+                resp <- sendRequest ReqPing
+                pure (case resp of RespPong -> True; _ -> False)
+            }
+  where
+    -- | 解析并执行，空结果时补一次表头
+    runIpc :: String -> IO (Either String StatementResult)
+    runIpc sql = case parseStatement sql of
+        Left e -> pure (Left e)
+        Right stmt -> do
+            result <- runIPCStorage (runStatementM stmt)
+            case result of
+                Left e -> pure (Left e)
+                Right rows -> do
+                    cols <- case rows of
+                        [] -> do
+                            db <- runIPCStorage (schema :: IPCStorage Database)
+                            pure (columnsFromStatement db stmt)
+                        (r : _) -> pure (map fst r)
+                    pure (Right (StatementResult cols rows))
+
+-- | 内存后端（测试）：状态就是一个 `Database`
+memoryBackend :: MVar Database -> Backend
+memoryBackend ref =
+    Backend
+        { beStatement = \sql -> modifyMVar ref $ \db -> case parseStatement sql of
+            Left e -> pure (db, Left e)
+            Right stmt -> case runStatement db stmt of
+                Left e -> pure (db, Left e)
+                Right (db', rows) -> pure (db', Right (StatementResult (colsOf db stmt rows) rows))
+        , beCatalog = do
+            db <- readMVar ref
+            pure (Right (map tableInfoOf db))
+        , bePing = pure True
+        }
+  where
+    -- | 有行用行上的键，空结果回退语法树
+    colsOf db stmt rows = case rows of
+        [] -> columnsFromStatement db stmt
+        (r : _) -> map fst r
+
+-- | 一张表的线上信息（内存实现：没有索引，统计现算）
+tableInfoOf :: (String, Table) -> TableInfo
+tableInfoOf (name, tbl) =
+    TableInfo
+        { tiTable = name
+        , tiColumns = [SchemaColumn c (wireType ty) | (c, ty) <- tableCols tbl]
+        , tiRows = length (tableRows tbl)
+        , tiIndexes = []
+        , tiStats = [(c, distinctOf c, False) | (c, _) <- tableCols tbl]
+        }
+  where
+    -- | 某一列有几个不同值
+    distinctOf c = length (nub [v | r <- tableRows tbl, Just v <- [lookup c r]])
+
+-- | 本地列类型转线上字符串（和 IPC 那边同一套写法）
+wireType :: Column -> String
+wireType TInt = "int"
+wireType TStr = "str"
+wireType TBool = "bool"

chusql-web/src/ChuSQL/Web/Config.hs

@@ -0,0 +1,187 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Web.Config (
+    WebConfig (..),
+    defaultWebConfig,
+    defaultUser,
+    defaultPassword,
+    usingDefaultCredentials,
+    loadWebConfig,
+    resolveCredential,
+    resolveStaticDir,
+    staticDirCandidates,
+) where
+
+import ChuSQL.Web.Auth (Credential (..), hashPassword)
+import Data.Char (toLower)
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import System.Directory (doesDirectoryExist)
+import System.Environment (lookupEnv)
+import Text.Read (readMaybe)
+
+-- 运行参数：命令行 > 环境变量 > 内置默认；默认只听本机 127.0.0.1:7777。
+
+-- | 默认账号名
+defaultUser :: Text
+defaultUser = "root"
+
+-- | 默认口令（只为方便本地测试；生产/对外必须覆盖）
+defaultPassword :: Text
+defaultPassword = "chusql"
+
+data WebConfig = WebConfig
+    { wcHost :: String
+    , wcPort :: Int
+    , wcStaticDir :: FilePath
+    , wcUser :: Text
+    , wcPasswordHash :: Maybe Text
+    , wcPassword :: Maybe Text
+    , wcStorageServer :: Maybe FilePath
+    , wcPipeName :: Maybe String
+    , 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)
+
+-- | 内置默认
+defaultWebConfig :: WebConfig
+defaultWebConfig =
+    WebConfig
+        { wcHost = "127.0.0.1"
+        , wcPort = 7777
+        , wcStaticDir = "static"
+        , wcUser = defaultUser
+        , wcPasswordHash = Nothing
+        , wcPassword = Nothing
+        , wcStorageServer = Nothing
+        , wcPipeName = Nothing
+        , 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
+        }
+
+-- | 这份配置用的还是内置默认口令吗
+usingDefaultCredentials :: WebConfig -> Bool
+usingDefaultCredentials cfg = wcPasswordHash cfg == Nothing && wcPassword cfg == Nothing
+
+-- | 备一份凭据：哈希 > 明文 > 内置默认
+resolveCredential :: WebConfig -> IO Credential
+resolveCredential cfg = case (wcPasswordHash cfg, wcPassword cfg) of
+    (Just encoded, _) -> pure (Credential (wcUser cfg) encoded)
+    (Nothing, Just plain) -> do
+        encoded <- hashPassword plain
+        pure (Credential (wcUser cfg) encoded)
+    (Nothing, Nothing) -> do
+        encoded <- hashPassword defaultPassword
+        pure (Credential (wcUser cfg) encoded)
+
+-- | 从环境变量读配置，缺省用内置默认
+loadWebConfig :: IO WebConfig
+loadWebConfig = do
+    let d = defaultWebConfig
+    host <- envOr "CHUSQL_WEB_HOST" (wcHost d)
+    port <- envInt "CHUSQL_WEB_PORT" (wcPort d)
+    staticDir <- envOr "CHUSQL_WEB_STATIC" (wcStaticDir d)
+    user <- T.pack <$> envOr "CHUSQL_WEB_USER" (T.unpack (wcUser d))
+    passwordHash <- envText "CHUSQL_WEB_PASSWORD_HASH"
+    password <- envText "CHUSQL_WEB_PASSWORD"
+    server <- envMaybe "CHUSQL_STORAGE_SERVER"
+    pipe <- envMaybe "CHUSQL_PIPE"
+    dataDir <- envMaybe "CHUSQL_DATA_DIR"
+    secure <- envBool "CHUSQL_WEB_COOKIE_SECURE" (wcCookieSecure d)
+    limit <- envInt "CHUSQL_WEB_BODY_LIMIT" (wcBodyLimit d)
+    idle <- envInt "CHUSQL_WEB_SESSION_IDLE" (wcSessionIdle d)
+    sessionMax <- envInt "CHUSQL_WEB_SESSION_MAX" (wcSessionMax d)
+    loginMax <- envInt "CHUSQL_WEB_LOGIN_MAX_ATTEMPTS" (wcLoginMaxAttempts d)
+    loginWindow <- envInt "CHUSQL_WEB_LOGIN_WINDOW" (wcLoginWindow d)
+    pageSize <- envInt "CHUSQL_WEB_PAGE_SIZE" (wcPageSize d)
+    maxPageSize <- envInt "CHUSQL_WEB_MAX_PAGE_SIZE" (wcMaxPageSize d)
+    maxRows <- envInt "CHUSQL_WEB_MAX_ROWS" (wcMaxRows d)
+    maxSqlLength <- envInt "CHUSQL_WEB_MAX_SQL_LENGTH" (wcMaxSqlLength d)
+    seedDemo <- envBool "CHUSQL_WEB_SEED" (wcSeedDemo d)
+    pure
+        WebConfig
+            { wcHost = host
+            , wcPort = port
+            , wcStaticDir = staticDir
+            , wcUser = user
+            , wcPasswordHash = passwordHash
+            , wcPassword = password
+            , wcStorageServer = server
+            , wcPipeName = pipe
+            , wcDataDir = dataDir
+            , wcCookieSecure = secure
+            , wcBodyLimit = limit
+            , wcSessionIdle = idle
+            , wcSessionMax = sessionMax
+            , wcLoginMaxAttempts = loginMax
+            , wcLoginWindow = loginWindow
+            , wcPageSize = pageSize
+            , wcMaxPageSize = maxPageSize
+            , wcMaxRows = maxRows
+            , wcMaxSqlLength = maxSqlLength
+            , wcSeedDemo = seedDemo
+            }
+
+-- | 静态目录候选位置，按顺序取第一个存在的
+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
+
+-- | 读一个字符串，缺省给默认值
+envOr :: String -> String -> IO String
+envOr name def = fromMaybe def <$> lookupEnv name
+
+-- | 读一个环境变量（空串当没设）
+envMaybe :: String -> IO (Maybe String)
+envMaybe name = do
+    v <- lookupEnv name
+    pure (case v of Just s | not (null s) -> Just s; _ -> Nothing)
+
+-- | 读成 Text
+envText :: String -> IO (Maybe Text)
+envText name = fmap (fmap T.pack) (envMaybe name)
+
+-- | 读成整数，解析不出来就用默认值
+envInt :: String -> Int -> IO Int
+envInt name def = do
+    v <- envMaybe name
+    pure (fromMaybe def (v >>= \s -> readMaybe s))
+
+-- | 读成布尔（1/true/yes/on 都算真）
+envBool :: String -> Bool -> IO Bool
+envBool name def = do
+    v <- envMaybe name
+    pure $ case v of
+        Nothing -> def
+        Just s -> map toLower s `elem` ["1", "true", "yes", "on"]

chusql-web/src/ChuSQL/Web/Demo.hs

@@ -0,0 +1,166 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Web.Demo (
+    SeedReport (..),
+    demoTableSpecs,
+    demoRows,
+    demoIndexes,
+    demoNames,
+    demoPlan,
+    seedDemo,
+) where
+
+import ChuSQL.Model (Value (..))
+import ChuSQL.Storage.IPC (TableInfo (..))
+import ChuSQL.Web.Actions (
+    ColumnSpec (..),
+    CreateTableSpec (..),
+    createIndexSql,
+    createTableSql,
+    insertRowsSql,
+ )
+import ChuSQL.Web.Backend (Backend (..))
+import qualified Data.Text as T
+
+-- 演示数据：三张表加一个二级索引，语句与界面走同一套拼 SQL 的代码。
+
+-- | 演示表（建表顺序即依赖顺序；没有外键约束，纯展示）
+demoTableSpecs :: [CreateTableSpec]
+demoTableSpecs =
+    [ CreateTableSpec "users" [ColumnSpec "id" "int", ColumnSpec "name" "str", ColumnSpec "age" "int"]
+    , CreateTableSpec "orders" [ColumnSpec "id" "int", ColumnSpec "user_id" "int", ColumnSpec "product" "str", ColumnSpec "amount" "int"]
+    , CreateTableSpec "products" [ColumnSpec "id" "int", ColumnSpec "name" "str", ColumnSpec "sku" "int", ColumnSpec "price" "int"]
+    ]
+
+-- | 每张表的演示行
+demoRows :: [(T.Text, [[(String, Value)]])]
+demoRows =
+    [ ( "users"
+      , [ [("id", VInt i), ("name", VStr name), ("age", VInt age)]
+        | (i, (name, age)) <- zip [1 :: Int ..] userRecords
+        ]
+      )
+    , ( "orders"
+      , [ [("id", VInt i), ("user_id", VInt uid), ("product", VStr p), ("amount", VInt a)]
+        | (i, (uid, p, a)) <- zip [1 :: Int ..] orderRecords
+        ]
+      )
+    , ( "products"
+      , [ [("id", VInt i), ("name", VStr n), ("sku", VInt sku), ("price", VInt price)]
+        | (i, (n, sku, price)) <- zip [1 :: Int ..] productRecords
+        ]
+      )
+    ]
+
+-- | 演示索引：products.sku 取值唯一
+demoIndexes :: [(T.Text, T.Text)]
+demoIndexes = [("products", "sku")]
+
+-- | 演示数据涉及的表名
+demoNames :: [T.Text]
+demoNames = map ctsTable demoTableSpecs
+
+-- | 完整的一套语句（建表 + 插行 + 建索引），按顺序执行
+demoPlan :: Either String [String]
+demoPlan = do
+    creates <- mapM createTableSql demoTableSpecs
+    inserts <- mapM (uncurry insertRowsSql) demoRows
+    indexes <- mapM (uncurry createIndexSql) demoIndexes
+    pure (creates ++ inserts ++ indexes)
+
+data SeedReport = SeedReport
+    { srCreated :: [String]
+    , srSkipped :: [String]
+    , srIndexes :: [String]
+    }
+    deriving (Show, Eq)
+
+-- | 缺什么补什么，可反复点不重复灌
+seedDemo :: Backend -> IO (Either String SeedReport)
+seedDemo backend = do
+    catalog <- beCatalog backend
+    case catalog of
+        Left e -> pure (Left e)
+        Right infos -> do
+            let existingTables = map tiTable infos
+                missing = [spec | spec <- demoTableSpecs, T.unpack (ctsTable spec) `notElem` existingTables]
+                skipped = [T.unpack (ctsTable spec) | spec <- demoTableSpecs, T.unpack (ctsTable spec) `elem` existingTables]
+                missingNames = map ctsTable missing
+                wantedIndexes =
+                    [ (t, c)
+                    | (t, c) <- demoIndexes
+                    , t `elem` missingNames || indexMissing infos t c
+                    ]
+            created <- runAll (map createTableSql missing)
+            case created of
+                Left e -> pure (Left e)
+                Right () -> do
+                    rowsDone <- runAll [insertRowsSql t rs | (t, rs) <- demoRows, t `elem` missingNames]
+                    case rowsDone of
+                        Left e -> pure (Left e)
+                        Right () -> do
+                            indexes <-
+                                runAll [createIndexSql t c | (t, c) <- wantedIndexes]
+                            pure $
+                                fmap
+                                    (const (SeedReport (map T.unpack missingNames) skipped (map (T.unpack . snd) wantedIndexes)))
+                                    indexes
+  where
+    -- | 逐条执行，遇到错就停
+    runAll :: [Either String String] -> IO (Either String ())
+    runAll [] = pure (Right ())
+    runAll (sql : rest) = case sql of
+        Left e -> pure (Left e)
+        Right statement -> do
+            result <- beStatement backend statement
+            case result of
+                Left e -> pure (Left e)
+                Right _ -> runAll rest
+
+    -- | 这张表上是否还没有这个索引
+    indexMissing :: [TableInfo] -> T.Text -> T.Text -> Bool
+    indexMissing infos t c = case lookup (T.unpack t) [(tiTable i, tiIndexes i) | i <- infos] of
+        Nothing -> True
+        Just cols -> T.unpack c `notElem` cols
+
+userRecords :: [(String, Int)]
+userRecords =
+    [ ("Alice", 24)
+    , ("Bob", 31)
+    , ("Carol", 45)
+    , ("Dave", 19)
+    , ("Erin", 38)
+    , ("Frank", 52)
+    , ("Grace", 27)
+    , ("Heidi", 33)
+    , ("Ivan", 41)
+    , ("Judy", 29)
+    ]
+
+orderRecords :: [(Int, String, Int)]
+orderRecords =
+    [ (1, "Laptop", 1299)
+    , (1, "Mouse", 25)
+    , (2, "Keyboard", 79)
+    , (3, "Monitor", 349)
+    , (3, "Webcam", 89)
+    , (4, "Headset", 119)
+    , (5, "SSD", 139)
+    , (5, "RAM", 99)
+    , (6, "Dock", 199)
+    , (7, "Cable", 12)
+    , (8, "Stand", 45)
+    , (9, "Lamp", 39)
+    ]
+
+productRecords :: [(String, Int, Int)]
+productRecords =
+    [ ("Laptop", 1001, 1299)
+    , ("Mouse", 1002, 25)
+    , ("Keyboard", 1003, 79)
+    , ("Monitor", 1004, 349)
+    , ("Webcam", 1005, 89)
+    , ("Headset", 1006, 119)
+    , ("SSD", 1007, 139)
+    , ("RAM", 1008, 99)
+    ]

chusql-web/src/ChuSQL/Web/RateLimit.hs

@@ -0,0 +1,72 @@
+module ChuSQL.Web.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-web/src/ChuSQL/Web/Secure.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Web.Secure (
+    securityHeaders,
+    contentSecurityPolicy,
+    sameOriginOnly,
+    bodyLimit,
+    bodyLimitDynamic,
+) where
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BSC
+import Data.Text (Text)
+import qualified Data.Text.Encoding as TE
+import Network.HTTP.Types (
+    Header,
+    Method,
+    hContentLength,
+    hOrigin,
+    methodPost,
+    status403,
+    status413,
+ )
+import Network.Wai (Middleware, Request (..), mapResponseHeaders, responseLBS)
+
+-- 三个 WAI 安全中间件：响应头、同源校验、请求体上限。
+
+-- | 所有响应都带上的安全头
+securityHeaders :: Middleware
+securityHeaders app req respond =
+    app req (respond . mapResponseHeaders (\headers -> filter (\(name, _) -> name /= "Content-Security-Policy" || lookup name headers == Nothing) extraHeaders ++ headers))
+
+-- | 只给编辑器样式发随机 nonce
+contentSecurityPolicy :: Maybe Text -> Text
+contentSecurityPolicy nonce =
+    "default-src 'self'; script-src 'self'; style-src 'self'"
+        <> maybe "" (\value -> " 'nonce-" <> value <> "'") nonce
+        <> "; font-src 'self'; worker-src 'self'; img-src 'self' data:; connect-src 'self'; base-uri 'none'; form-action 'self'; frame-ancestors 'none'"
+
+-- | 统一加的安全响应头
+extraHeaders :: [Header]
+extraHeaders =
+    [ ("Content-Security-Policy", TE.encodeUtf8 (contentSecurityPolicy Nothing))
+    , ("X-Content-Type-Options", "nosniff")
+    , ("X-Frame-Options", "DENY")
+    , ("Referrer-Policy", "no-referrer")
+    , ("Cache-Control", "no-store")
+    ]
+
+-- | 变更类请求要求同源，无 Origin 放行
+sameOriginOnly :: Middleware
+sameOriginOnly app req respond =
+    if isMutating (requestMethod req) && not (originAllowed req)
+        then respond (responseLBS status403 [] "cross-origin request rejected")
+        else app req respond
+
+-- | 这个方法算不算会改数据的
+isMutating :: Method -> Bool
+isMutating m = m `elem` [methodPost, "PUT", "PATCH", "DELETE"]
+
+-- | Origin 与 Host 是否一致
+originAllowed :: Request -> Bool
+originAllowed req = case lookup hOrigin (requestHeaders req) of
+    Nothing -> True
+    Just origin -> case lookup "Host" (requestHeaders req) of
+        Nothing -> False
+        Just host -> authorityOf origin == host || authorityOf origin == stripPort host
+
+-- | 取出 host:port，去掉 scheme 与路径
+authorityOf :: BS.ByteString -> BS.ByteString
+authorityOf raw =
+    let noScheme = case BSC.breakSubstring "//" raw of
+            (_, rest) | not (BSC.null rest) -> BSC.drop 2 rest
+            _ -> raw
+     in fst (BSC.break (== '/') noScheme)
+
+-- | 去掉端口 host:8080 -> host
+stripPort :: BS.ByteString -> BS.ByteString
+stripPort = fst . BSC.break (== ':')
+
+-- | 按 Content-Length 拦下过大的请求体
+bodyLimit :: Int -> Middleware
+bodyLimit limit = bodyLimitDynamic (pure limit)
+
+-- | 同上，但上限每次请求现取
+bodyLimitDynamic :: IO Int -> Middleware
+bodyLimitDynamic limitOf app req respond = do
+    limit <- limitOf
+    if declaredTooBig limit req
+        then respond (responseLBS status413 [] "request body too large")
+        else app req respond
+
+-- | Content-Length 是否超限
+declaredTooBig :: Int -> Request -> Bool
+declaredTooBig limit req = case lookup hContentLength (requestHeaders req) of
+    Nothing -> False
+    Just v -> case BSC.readInt v of
+        Just (n, rest) -> BSC.null rest && n > limit
+        Nothing -> False

chusql-web/src/ChuSQL/Web/Settings.hs

@@ -0,0 +1,249 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Web.Settings (
+    SettingItem (..),
+    settingCatalogue,
+    findItem,
+    isRootOnly,
+    isRestartRequired,
+    settingsFileCandidates,
+    resolveSettingsFile,
+    readSettingsFile,
+    writeSettingsFile,
+    applySettings,
+    liveKeys,
+    defaultOf,
+    effectiveSettings,
+) where
+
+import ChuSQL.Web.Config (WebConfig (..))
+import qualified Data.Aeson as A
+import qualified Data.Aeson.Key as K
+import qualified Data.Aeson.KeyMap as KM
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Map.Strict as Map
+import Data.Text (Text)
+import qualified Data.Text as T
+import Control.Exception (IOException, try)
+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
+import System.FilePath (takeDirectory, (</>))
+
+-- Web 配置项目录，与启动脚本共用一份设置文件，支持热改与重启生效。
+
+data SettingItem = SettingItem
+    { siKey :: Text
+    , siLabel :: Text
+    , siGroup :: Text
+    , siKind :: Text
+    , siEnv :: Text
+    , siDefault :: Text
+    , siRootOnly :: Bool
+    , siRestart :: Bool
+    }
+    deriving (Show, Eq)
+
+-- | 全部可配置项（顺序即界面里的顺序）
+settingCatalogue :: [SettingItem]
+settingCatalogue =
+    [ item "port" "HTTP port" "server" "int" "CHUSQL_WEB_PORT" "7777" True True
+    , item "host" "Listen address" "server" "text" "CHUSQL_WEB_HOST" "127.0.0.1" True True
+    , item "static-dir" "Static directory" "server" "text" "CHUSQL_WEB_STATIC" "static" True True
+    , item "cookie-secure" "Secure cookie (behind TLS)" "server" "bool" "CHUSQL_WEB_COOKIE_SECURE" "0" True False
+    , item "body-limit" "Max request body (bytes)" "limits" "int" "CHUSQL_WEB_BODY_LIMIT" "65536" False False
+    , item "session-idle" "Session idle timeout (s)" "limits" "int" "CHUSQL_WEB_SESSION_IDLE" "28800" False False
+    , item "session-max" "Session max age (s)" "limits" "int" "CHUSQL_WEB_SESSION_MAX" "86400" False False
+    , item "login-max-attempts" "Failed logins before lockout" "limits" "int" "CHUSQL_WEB_LOGIN_MAX_ATTEMPTS" "5" False False
+    , item "login-window" "Lockout window (s)" "limits" "int" "CHUSQL_WEB_LOGIN_WINDOW" "300" False False
+    , item "rows-per-page" "Rows per page" "limits" "int" "CHUSQL_WEB_PAGE_SIZE" "25" False False
+    , item "max-page-size" "Rows per page ceiling" "limits" "int" "CHUSQL_WEB_MAX_PAGE_SIZE" "500" False False
+    , item "max-rows" "Rows per query" "limits" "int" "CHUSQL_WEB_MAX_ROWS" "1000" False False
+    , item "max-sql-length" "Max SQL characters" "limits" "int" "CHUSQL_WEB_MAX_SQL_LENGTH" "20000" False False
+    , item "user" "Account name" "auth" "text" "CHUSQL_WEB_USER" "root" True True
+    , item "password" "Password (plain, hashed at start)" "auth" "secret" "CHUSQL_WEB_PASSWORD" "" True True
+    , item "password-hash" "Password hash (pbkdf2)" "auth" "secret" "CHUSQL_WEB_PASSWORD_HASH" "" True True
+    , item "data-dir" "Data directory" "storage" "text" "CHUSQL_DATA_DIR" "" True True
+    , item "pipe-name" "Named pipe" "storage" "text" "CHUSQL_PIPE" "" True True
+    , item "storage-page-size" "Storage page size" "storage" "int" "CHUSQL_PAGE_SIZE" "4096" True True
+    , item "storage-btree-order" "Storage B+tree order" "storage" "int" "CHUSQL_BTREE_ORDER" "4" True True
+    , item "storage-buffer-pool" "Storage buffer pool pages" "storage" "int" "CHUSQL_BUFFER_POOL_SIZE" "1024" True True
+    , item "storage-log" "Storage log level" "storage" "text" "CHUSQL_LOG" "info" True True
+    , item "seed" "Seed demo data on start" "storage" "bool" "CHUSQL_WEB_SEED" "1" True True
+    ]
+  where
+    item k l g kind env def rootOnly restart =
+        SettingItem
+            { siKey = k
+            , siLabel = l
+            , siGroup = g
+            , siKind = kind
+            , siEnv = env
+            , siDefault = def
+            , siRootOnly = rootOnly
+            , siRestart = restart
+            }
+
+-- | 按 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)
+
+-- | 这项是不是要重启才生效
+isRestartRequired :: Text -> Bool
+isRestartRequired key = maybe False siRestart (findItem key)
+
+-- | 改完立刻生效的配置键
+liveKeys :: [Text]
+liveKeys =
+    [ "body-limit"
+    , "session-idle"
+    , "session-max"
+    , "login-max-attempts"
+    , "login-window"
+    , "rows-per-page"
+    , "max-page-size"
+    , "max-rows"
+    , "max-sql-length"
+    ]
+
+-- | 设置文件的候选位置
+settingsFileCandidates :: [FilePath]
+settingsFileCandidates =
+    [ "script" </> "chusql.settings.json"
+    , ".." </> "script" </> "chusql.settings.json"
+    , "chusql.settings.json"
+    ]
+
+-- | 找现成的设置文件，否则挑目录已存在的候选
+resolveSettingsFile :: IO FilePath
+resolveSettingsFile = do
+    found <- firstExistingFile settingsFileCandidates
+    case found of
+        Just path -> pure path
+        Nothing -> do
+            ready <- firstExistingDir settingsFileCandidates
+            pure (maybe (headOr settingsFileCandidates "chusql.settings.json") id ready)
+  where
+    firstExistingFile [] = pure Nothing
+    firstExistingFile (p : ps) = do
+        ok <- doesFileExist p
+        if ok then pure (Just p) else firstExistingFile ps
+
+    -- | 候选所在目录是否已存在
+    firstExistingDir [] = pure Nothing
+    firstExistingDir (p : ps) = do
+        let dir = takeDirectory p
+        ok <- if null dir then pure True else doesDirectoryExist dir
+        if ok then pure (Just p) else firstExistingDir ps
+
+-- | 候选列表里的第一个
+headOr :: [a] -> a -> a
+headOr (x : _) _ = x
+headOr [] d = d
+
+-- | 读设置文件：键 -> 字符串值（文件不存在或坏掉都当空）
+readSettingsFile :: FilePath -> IO (Map.Map Text Text)
+readSettingsFile path = do
+    exists <- doesFileExist path
+    if not exists
+        then pure Map.empty
+        else do
+            raw <- readFileUtf8 path
+            pure $ case A.eitherDecodeStrict' raw of
+                Left _ -> Map.empty
+                Right (A.Object o) -> Map.fromList [(K.toText k, jsonToText v) | (k, v) <- KM.toList o]
+                Right _ -> Map.empty
+  where
+    -- | JSON 值当字符串看
+    jsonToText v = case v of
+        A.String s -> s
+        A.Number n -> T.pack (show n)
+        A.Bool b -> if b then "1" else "0"
+        _ -> ""
+
+-- | 读文件（UTF-8 字节读，避免依赖系统编码）
+readFileUtf8 :: FilePath -> IO BS.ByteString
+readFileUtf8 = BS.readFile
+
+-- | 写设置文件，只写非空值
+writeSettingsFile :: FilePath -> Map.Map Text Text -> IO (Either String ())
+writeSettingsFile path values = do
+    let dir = takeDirectory path
+    prepared <- try (ensureDir dir) :: IO (Either IOException ())
+    case prepared of
+        Left e -> pure (Left ("cannot create the settings directory " ++ dir ++ ": " ++ show e))
+        Right () -> do
+            let encoded =
+                    A.encode
+                        ( A.Object
+                            ( KM.fromList
+                                [ (K.fromText k, A.String v)
+                                | (k, v) <- Map.toList values
+                                , not (T.null v)
+                                ]
+                            )
+                        )
+            written <- try (BS.writeFile path (BL.toStrict encoded)) :: IO (Either IOException ())
+            pure (either (Left . \e -> "cannot write " ++ path ++ ": " ++ show e) Right written)
+  where
+    ensureDir dir = if null dir then pure () else createDirectoryIfMissing True dir
+
+-- | 把界面上传来的值合并进现有文件内容（只接受目录里有的键）
+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 ()
+    | 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", wcUser cfg)
+        , ("seed", boolText (wcSeedDemo cfg))
+        , ("data-dir", maybe "" T.pack (wcDataDir cfg))
+        , ("pipe-name", maybe "" T.pack (wcPipeName cfg))
+        ]
+  where
+    tshow = T.pack . show
+    boolText True = "1"
+    boolText False = "0"

chusql-web/src/ChuSQL/Web/Static.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Web.Static (
+    safeRelative,
+    readStatic,
+    contentTypeOf,
+) where
+
+import qualified Data.ByteString as BS
+import Data.Char (isAsciiLower, isAsciiUpper, isDigit, toLower)
+import Data.Text (Text)
+import qualified Data.Text as T
+import System.Directory (doesFileExist)
+import System.FilePath ((</>), takeExtension)
+
+-- 静态文件交付：文件名白名单加扩展名白名单，不做目录列举。
+
+-- | 文件名长度上限
+maxNameLength :: Int
+maxNameLength = 128
+
+-- | 允许交付的扩展名（只有前端资产）
+allowedExtensions :: [String]
+allowedExtensions = [".html", ".css", ".js", ".svg", ".png", ".ico", ".ttf", ".woff2"]
+
+-- | 把请求里的文件名变成安全的相对路径；不合法给 Nothing
+safeRelative :: Text -> Maybe FilePath
+safeRelative t
+    | T.null t = Nothing
+    | T.length t > maxNameLength = Nothing
+    | ".." `T.isInfixOf` t = Nothing
+    | T.any badChar t = Nothing
+    | map toLower (takeExtension (T.unpack t)) `notElem` allowedExtensions = Nothing
+    | otherwise = Just (T.unpack t)
+  where
+    -- | 只允许字母数字与 ._-
+    badChar c = not (isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("._-" :: String))
+
+-- | 读一个静态文件；不存在（或是目录）给 Nothing
+readStatic :: FilePath -> FilePath -> IO (Maybe BS.ByteString)
+readStatic dir rel = case safeRelative (T.pack rel) of
+    Nothing -> pure Nothing
+    Just name -> do
+        let path = dir </> name
+        ok <- doesFileExist path
+        if ok then Just <$> BS.readFile path else pure Nothing
+
+-- | 按扩展名给 Content-Type
+contentTypeOf :: FilePath -> Text
+contentTypeOf path = case map toLower (takeExtension path) of
+    ".html" -> "text/html; charset=utf-8"
+    ".css" -> "text/css; charset=utf-8"
+    ".js" -> "text/javascript; charset=utf-8"
+    ".json" -> "application/json; charset=utf-8"
+    ".svg" -> "image/svg+xml"
+    ".png" -> "image/png"
+    ".ico" -> "image/x-icon"
+    ".ttf" -> "font/ttf"
+    ".woff2" -> "font/woff2"
+    ".txt" -> "text/plain; charset=utf-8"
+    _ -> "application/octet-stream"

chusql-web/src/ChuSQL/Web/StorageProcess.hs

@@ -0,0 +1,119 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Web.StorageProcess (
+    StorageProcess (..),
+    findStorageServer,
+    startStorageProcess,
+    stopStorageProcess,
+    waitForStorage,
+) where
+
+import ChuSQL.Storage.IPC (Request (..), Response (..), closeConnection, sendRequest)
+import Control.Concurrent (threadDelay)
+import Control.Exception (SomeException, try)
+import Control.Monad (filterM)
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import System.Directory (createDirectoryIfMissing, doesFileExist, getTemporaryDirectory)
+import System.Environment (getEnvironment, setEnv)
+import System.Exit (ExitCode)
+import System.FilePath ((</>))
+import System.IO (Handle)
+import System.Process (
+    CreateProcess (..),
+    ProcessHandle,
+    StdStream (..),
+    createProcess,
+    proc,
+    terminateProcess,
+    waitForProcess,
+ )
+
+-- 拉起并管理 Rust 存储进程，起来后等管道应答 ping 再继续。
+
+data StorageProcess = StorageProcess
+    { spProcess :: ProcessHandle
+    , spPipe :: String
+    , spDataDir :: FilePath
+    }
+
+-- | 找存储进程，没有就给路径提示
+findStorageServer :: Maybe FilePath -> IO (Either String FilePath)
+findStorageServer (Just p) = do
+    ok <- doesFileExist p
+    pure (if ok then Right p else Left ("storage server not found: " ++ p))
+findStorageServer Nothing = do
+    let dirs =
+            [ "chusql-storage/target"
+            , "../chusql-storage/target"
+            , "../../chusql-storage/target"
+            , "target"
+            ]
+        modes = ["release", "debug"]
+        exes = ["chusql-storage.exe", "chusql-storage"]
+        candidates = [d </> m </> e | d <- dirs, m <- modes, e <- exes]
+    found <- filterM doesFileExist candidates
+    pure $ case found of
+        (p : _) -> Right p
+        [] -> Left "no Rust storage server found; run `cargo build --release` in chusql-storage, or pass --storage <path>"
+-- | 起存储进程并等它就绪
+startStorageProcess :: FilePath -> IO (Either String StorageProcess)
+startStorageProcess bin = do
+    stamp <- round . (* 1000000) <$> getPOSIXTime :: IO Integer
+    tmp <- getTemporaryDirectory
+    let pipe = "chusql-web-" ++ show stamp
+        dir = tmp </> pipe
+    createDirectoryIfMissing True dir
+    envs <-
+        childEnv
+            [ ("CHUSQL_PIPE", pipe)
+            , ("CHUSQL_DATA_DIR", dir)
+            ]
+    started <-
+        try (createProcess (proc bin []){env = Just envs, std_out = NoStream, std_err = Inherit}) ::
+            IO (Either SomeException (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
+    case started of
+        Left e -> pure (Left ("failed to start the storage process: " ++ show e))
+        Right (_, _, _, ph) -> do
+            setEnv "CHUSQL_PIPE" pipe
+            setEnv "CHUSQL_DATA_DIR" dir
+            ready <- waitForStorage (200 :: Int)
+            if ready
+                then pure (Right (StorageProcess ph pipe dir))
+                else do
+                    _ <- try (terminateProcess ph) :: IO (Either SomeException ())
+                    pure (Left "storage process did not become ready within 5 seconds (no ping reply on the pipe)")
+
+-- | 停掉存储进程，保留数据目录
+stopStorageProcess :: StorageProcess -> IO ()
+stopStorageProcess sp = do
+    closeConnection
+    _ <- try (terminateProcess (spProcess sp)) :: IO (Either SomeException ())
+    _ <- try (waitForProcess (spProcess sp)) :: IO (Either SomeException ExitCode)
+    pure ()
+
+-- | 轮询 ping 直到对面应答
+waitForStorage :: Int -> IO Bool
+waitForStorage 0 = pure False
+waitForStorage n = do
+    r <- try (sendRequest ReqPing) :: IO (Either SomeException Response)
+    case r of
+        Right RespPong -> pure True
+        _ -> threadDelay 25000 >> waitForStorage (n - 1)
+
+-- | 子进程环境：继承并覆盖两个专用变量
+childEnv :: [(String, String)] -> IO [(String, String)]
+childEnv extra = do
+    base <- getEnvironment
+    let ours = ["CHUSQL_PIPE", "CHUSQL_DATA_DIR"]
+        kept = filter (\(k, _) -> k `notElem` ours) base
+        missing (k, _) = not (any ((== k) . fst) kept)
+        defaults = filter missing storageDefaults
+    pure (kept ++ defaults ++ extra)
+
+-- | 存储进程的调参默认值（可以被用户环境里的同名变量覆盖）
+storageDefaults :: [(String, String)]
+storageDefaults =
+    [ ("CHUSQL_PAGE_SIZE", "4096")
+    , ("CHUSQL_BTREE_ORDER", "4")
+    , ("CHUSQL_LOG", "info")
+    ]

chusql-web/src/ChuSQL/Web/UiSettings.hs

@@ -0,0 +1,180 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Web.UiSettings (
+    uiSettingsFileCandidates,
+    resolveUiSettingsFile,
+    validateUiSettings,
+    readUiSettings,
+    writeUiSettings,
+) where
+
+import Control.Exception (IOException, try)
+import qualified Data.Aeson as A
+import qualified Data.Aeson.Key as K
+import qualified Data.Aeson.KeyMap as KM
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Map.Strict as Map
+import Data.Scientific (floatingOrInteger)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
+import System.FilePath (takeDirectory, (</>))
+
+-- 前端 IDE 设置单独存一份文件，与启动配置 chusql.settings.json 互不干扰。
+
+-- | IDE 设置文件的候选位置
+uiSettingsFileCandidates :: [FilePath]
+uiSettingsFileCandidates =
+    [ "script" </> "chusql.ui.settings.json"
+    , ".." </> "script" </> "chusql.ui.settings.json"
+    , "chusql.ui.settings.json"
+    ]
+
+-- | 找现成的设置文件，否则挑目录已存在的候选
+resolveUiSettingsFile :: IO FilePath
+resolveUiSettingsFile = do
+    found <- firstExistingFile uiSettingsFileCandidates
+    case found of
+        Just path -> pure path
+        Nothing -> do
+            ready <- firstExistingDir uiSettingsFileCandidates
+            pure (maybe firstCandidate id ready)
+  where
+    -- | 候选清单里的第一个
+    firstCandidate = case uiSettingsFileCandidates of
+        (p : _) -> p
+        [] -> "chusql.ui.settings.json"
+
+    firstExistingFile [] = pure Nothing
+    firstExistingFile (p : ps) = do
+        ok <- doesFileExist p
+        if ok then pure (Just p) else firstExistingFile ps
+
+    -- | 候选所在目录是否已存在
+    firstExistingDir [] = pure Nothing
+    firstExistingDir (p : ps) = do
+        let dir = takeDirectory p
+        ok <- if null dir then pure True else doesDirectoryExist dir
+        if ok then pure (Just p) else firstExistingDir ps
+
+-- | 校验一份 IDE 设置，未知键与越界都给错
+validateUiSettings :: A.Value -> Either String (Map.Map Text A.Value)
+validateUiSettings (A.Object o) = Map.fromList <$> mapM checkField (KM.toList o)
+  where
+    checkField (rawKey, value) =
+        let key = K.toText rawKey
+         in case key of
+                "uiFonts" -> pair key <$> fontChain key value
+                "gridFonts" -> pair key <$> fontChain key value
+                "sqlFonts" -> pair key <$> fontChain key value
+                "uiFontSize" -> pair key <$> boundedInt key 11 16 value
+                "gridFontSize" -> pair key <$> boundedInt key 10 18 value
+                "gridRowHeight" -> pair key <$> boundedInt key 18 40 value
+                "sqlFontSize" -> pair key <$> boundedInt key 10 20 value
+                "sqlLineHeight" -> pair key <$> boundedInt key 16 40 value
+                "sqlTabSize" -> pair key <$> boundedInt key 1 8 value
+                "pageSize" -> pair key <$> boundedInt key 10 500 value
+                "nullText" -> pair key <$> shortText key value
+                "sqlLineNumbers" -> pair key <$> boolValue key value
+                "autocomplete" -> pair key <$> boolValue key value
+                "minimap" -> pair key <$> boolValue key value
+                "confirmBeforeCommit" -> pair key <$> boolValue key value
+                _ -> Left ("unknown setting: " ++ T.unpack key)
+
+    pair key value = (key, value)
+
+validateUiSettings _ = Left "settings must be a JSON object"
+
+fontChainMax :: Int
+fontChainMax = 10
+
+fontNameMax :: Int
+fontNameMax = 64
+
+nullTextMax :: Int
+nullTextMax = 64
+
+-- | 字体链：最多 10 项，每项非空且不超 64 字
+fontChain :: Text -> A.Value -> Either String A.Value
+fontChain key value = case value of
+    A.Array xs
+        | V.length xs > fontChainMax -> bad
+        | otherwise -> A.Array . V.fromList <$> mapM item (V.toList xs)
+    _ -> bad
+  where
+    bad =
+        Left
+            ( T.unpack key
+                ++ " expects at most "
+                ++ show fontChainMax
+                ++ " non-empty font names of at most "
+                ++ show fontNameMax
+                ++ " characters"
+            )
+    item (A.String s) =
+        let trimmed = T.strip s
+         in if not (T.null trimmed) && T.length trimmed <= fontNameMax
+                then Right (A.String trimmed)
+                else bad
+    item _ = bad
+
+-- | 区间内的整数，顺便把它整成规范写法
+boundedInt :: Text -> Int -> Int -> A.Value -> Either String A.Value
+boundedInt key lo hi value = case value of
+    A.Number n -> case floatingOrInteger n :: Either Double Integer of
+        Right i
+            | i >= fromIntegral lo && i <= fromIntegral hi -> Right (A.Number (fromIntegral i))
+        _ -> bad
+    _ -> bad
+  where
+    bad = Left (T.unpack key ++ " expects an integer in " ++ show lo ++ ".." ++ show hi)
+
+-- | 空值占位文本：字符串且不超 64 字
+shortText :: Text -> A.Value -> Either String A.Value
+shortText key value = case value of
+    A.String s
+        | T.length s <= nullTextMax -> Right (A.String s)
+    _ ->
+        Left
+            ( T.unpack key
+                ++ " expects a string of at most "
+                ++ show nullTextMax
+                ++ " characters"
+            )
+
+-- | 布尔开关
+boolValue :: Text -> A.Value -> Either String A.Value
+boolValue key value = case value of
+    A.Bool b -> Right (A.Bool b)
+    _ -> Left (T.unpack key ++ " expects a boolean")
+
+-- | 读 IDE 设置文件，缺文件或坏内容都给空对象
+readUiSettings :: FilePath -> IO A.Value
+readUiSettings path = do
+    exists <- doesFileExist path
+    if not exists
+        then pure emptyObject
+        else do
+            raw <- try (BS.readFile path) :: IO (Either IOException BS.ByteString)
+            pure $ case raw of
+                Left _ -> emptyObject
+                Right bytes -> case A.eitherDecodeStrict' bytes of
+                    Right (A.Object o) -> A.Object o
+                    _ -> emptyObject
+  where
+    emptyObject = A.Object KM.empty
+
+-- | 写 IDE 设置文件，先建目录再落盘
+writeUiSettings :: FilePath -> Map.Map Text A.Value -> IO (Either String ())
+writeUiSettings path values = do
+    prepared <- try (ensureDir (takeDirectory path)) :: IO (Either IOException ())
+    case prepared of
+        Left e -> pure (Left ("cannot create the settings directory " ++ takeDirectory path ++ ": " ++ show e))
+        Right () -> do
+            let encoded = A.encode (A.Object (KM.fromList [(K.fromText k, v) | (k, v) <- Map.toList values]))
+            written <- try (BS.writeFile path (BL.toStrict encoded)) :: IO (Either IOException ())
+            pure (either (Left . \e -> "cannot write " ++ path ++ ": " ++ show e) Right written)
+  where
+    ensureDir dir = if null dir then pure () else createDirectoryIfMissing True dir