ChuNa7a/ChuSQL
1
0 Fork 0
Code Issues Pull Requests Actions 7 Packages Projects Releases Wiki Activity

修复错误，优化性能，实现类型系统，优化安装卸载过程

Browse Source
This commit is contained in:
LIm1tZz7 committed 2026-10-05 00:15:01 +08:00
1 parent fd5f320360
commit 48eec484b7
104 files changed
+4127 -845
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

chusql-web/app/Main.hs
+21 -28
View File
@@ -18,12 +18,11 @@ import ChuSQL.Interface.Config (
import ChuSQL.Interface.Link (clientPing, closeClient, connectClient)
import ChuSQL.Interface.RateLimit (newRateLimiter)
import ChuSQL.Interface.Session (authenticateSession, newSession)
import ChuSQL.Interface.Settings (effectiveSettings, readSettingsFile)
import ChuSQL.Interface.Settings (effectiveSettings)
import ChuSQL.Interface.TOML (resolveConfigPath)
import ChuSQL.Web.Demo (SeedReport (..), seedDemo)
import Control.Exception (IOException, try)
import Data.Char (toLower)
import qualified Data.Map.Strict as Map
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text as T
@@ -42,7 +41,6 @@ data Options = Options
{ optConfig :: Maybe FilePath
, optHost :: Maybe String
, optPort :: Maybe Int
, optStatic :: Maybe FilePath
, optUser :: Maybe Text
, optCookieSecure :: Maybe Bool
, optBodyLimit :: Maybe Int
@@ -65,7 +63,6 @@ emptyOptions =
{ optConfig = Nothing
, optHost = Nothing
, optPort = Nothing
, optStatic = Nothing
, optUser = Nothing
, optCookieSecure = Nothing
, optBodyLimit = Nothing
@@ -90,8 +87,7 @@ parseArgs = go emptyOptions
go opts ("--help" : rest) = go opts{optHelp = True} rest
go opts ("-h" : rest) = go opts{optHelp = True} rest
go opts ("--config" : v : rest) = go opts{optConfig = Just v} rest
go opts ("--host" : v : rest) = go opts{optHost = Just v} rest
go opts ("--static" : v : rest) = go opts{optStatic = Just v} rest
go opts ("--listen-host" : v : rest) = go opts{optHost = Just v} rest
go opts ("--user" : v : rest) = go opts{optUser = Just (T.pack v)} rest
go opts ("--port" : v : rest) = withInt "--port" v (\n -> go opts{optPort = Just n} rest)
go opts ("--body-limit" : v : rest) = withInt "--body-limit" v (\n -> go opts{optBodyLimit = Just n} rest)
@@ -120,17 +116,16 @@ usage :: IO ()
usage = do
putStrLn "usage: chusql-web [options]"
putStrLn ""
putStrLn "config: chusql.toml sits at a fixed place and its sections hold every knob below;"
putStrLn " Windows: %APPDATA%\\ChuSQL\\chusql.toml"
putStrLn " other: $XDG_CONFIG_HOME/ChuSQL/chusql.toml (or ~/.config/ChuSQL/chusql.toml)"
putStrLn " [web] host/port/static_dir/user (administrator name) and the limits;"
putStrLn " [storage] data_dir; [page] size; [btree] order; [buffer] pool_size; [log] level"
putStrLn "config: settings.toml sits at a fixed place and its sections hold every knob below;"
putStrLn " Windows: %APPDATA%\\ChuSQL\\settings.toml"
putStrLn " other: $XDG_CONFIG_HOME/ChuSQL/settings.toml (or ~/.config/ChuSQL/settings.toml)"
putStrLn " [web] listen_host/port and the limits;"
putStrLn " [storage] data_dir/log_files; [page] size; [btree] order; [buffer] pool_size; [log] level"
putStrLn ""
putStrLn " --config FILE read that config file instead ([web] host ...)"
putStrLn " --host H listen address ([web] host, default 127.0.0.1)"
putStrLn " --config FILE read that config file instead ([web] listen_host ...)"
putStrLn " --listen-host H listen address ([web] listen_host, default 127.0.0.1)"
putStrLn " --port N listen port ([web] port, default 7778)"
putStrLn " --static DIR static asset directory ([web] static_dir, default static)"
putStrLn " --user NAME administrator name ([web] user, default root)"
putStrLn (" --user NAME administrator name (default " ++ T.unpack defaultUser ++ ")")
putStrLn " --cookie-secure BOOL add Secure to the cookie ([web] cookie_secure, default false)"
putStrLn " --body-limit N max request body bytes ([web] body_limit, default 65536)"
putStrLn " --session-idle N session idle timeout, sec ([web] session_idle, default 28800)"
@@ -143,13 +138,13 @@ usage = do
putStrLn " --max-sql-length N max SQL characters ([web] max_sql_length, default 20000)"
putStrLn " --seed BOOL load demo data when the db is empty ([web] seed, default false)"
putStrLn ""
putStrLn "administrator password: lives in the __system_users system table, never in chusql.toml"
putStrLn "administrator password: lives in the __system_users system table, never in settings.toml"
putStrLn " the installer always sets one; an account whose hash is still empty signs in with an empty password"
putStrLn (" the [web] user key only picks the administrator name (default " ++ T.unpack defaultUser ++ ")")
putStrLn " the administrator name comes from --user; settings.toml does not carry it"
putStrLn "ordinary accounts: CREATE USER / ALTER USER / DROP USER from the SQL console (administrator only)"
putStrLn "storage: the server owns the data directory and loads the chusql_core_storage library;"
putStrLn " this process is a plain TCP client: every statement, lookup and account request goes to it"
putStrLn " [server] host / port says where it listens; [storage] data_dir, [page] size, [btree] order,"
putStrLn " [server] listen_host / port says where it listens; [storage] data_dir, [page] size, [btree] order,"
putStrLn " [buffer] pool_size and [log] level are the server's own"
-- | 命令行覆盖配置
@@ -158,7 +153,6 @@ applyOptions cfg opts =
cfg
{ wcHost = orElse (optHost opts) (wcHost cfg)
, wcPort = orElse (optPort opts) (wcPort cfg)
, wcStaticDir = orElse (optStatic opts) (wcStaticDir cfg)
, wcUser = orElse (optUser opts) (wcUser cfg)
, wcCookieSecure = orElse (optCookieSecure opts) (wcCookieSecure cfg)
, wcBodyLimit = orElse (optBodyLimit opts) (wcBodyLimit cfg)
@@ -206,7 +200,6 @@ run opts = do
Just staticDir -> do
let settingsFile = configPath
policy = SessionPolicy (fromIntegral (wcSessionIdle cfg)) (fromIntegral (wcSessionMax cfg))
saved <- readSettingsFile settingsFile
legacy <- legacyPasswordKey settingsFile
config <- loadServerConfigAt settingsFile
limiter <-
@@ -225,9 +218,9 @@ run opts = do
setLive env (liveFromConfig cfg)
app <- webApp env
printBanner cfg configPath staticDir
reportCredential cfg saved legacy
reportCredential cfg legacy
checkServer (aeServerHost env) (aeServerPort env)
seedIfWanted cfg saved (aeServerHost env) (aeServerPort env)
seedIfWanted cfg (aeServerHost env) (aeServerPort env)
let settings =
Warp.setPort (wcPort cfg) (Warp.setHost (fromString (wcHost cfg)) Warp.defaultSettings)
serve settings app
@@ -260,9 +253,9 @@ serve settings app = do
exitFailure
-- | 报告管理员账号状态：配置里还留着明文口令键就提醒
reportCredential :: WebConfig -> Map.Map Text Text -> Bool -> IO ()
reportCredential cfg saved legacy = do
putStrLn ("administrator: " ++ T.unpack (rootUserName cfg saved))
reportCredential :: WebConfig -> Bool -> IO ()
reportCredential cfg legacy = do
putStrLn ("administrator: " ++ T.unpack (rootUserName cfg))
if legacy
then do
putStrLn " !! the [web] section still carries a plaintext password key; it is ignored now"
@@ -270,8 +263,8 @@ reportCredential cfg saved legacy = do
else pure ()
-- | 配了 seed 就补演示数据（管理员已设口令时跳过）
seedIfWanted :: WebConfig -> Map.Map Text Text -> Text -> Int -> IO ()
seedIfWanted cfg saved host port
seedIfWanted :: WebConfig -> Text -> Int -> IO ()
seedIfWanted cfg host port
| not (wcSeedDemo cfg) = pure ()
| otherwise = do
opened <- connectClient host port
@@ -279,7 +272,7 @@ seedIfWanted cfg saved host port
Left message -> TIO.putStrLn ("demo data skipped: " <> message)
Right client -> do
session <- newSession client
signed <- authenticateSession session (rootUserName cfg saved) ""
signed <- authenticateSession session (rootUserName cfg) ""
case signed of
Left message -> TIO.putStrLn ("demo data skipped: " <> message <> " (set the administrator password after seeding)")
Right () -> do
chusql-web/chusql-web.cabal
+5 -5
View File
@@ -2,11 +2,11 @@ cabal-version: 2.4
name: chusql-web
version: 1.0.0
synopsis: ChuSQL Web 管理端：Scotty + REST API + 静态页面
description: ChuSQL 的浏览器管理端。负责 HTTP 交付、鉴权、静态文件，
并把用户的 SQL 经 TCP 转交给 chusql-server（存储由服务器进程里的
chusql_core_storage 动态库承担）。本进程不链引擎，也不碰存储。
数据库服务器与 TCP 协议在 chusql-server 包里，这里只做 HTTP 这一面。
synopsis: ChuSQL web administration with Scotty, REST APIs, and static pages
description: Provides the browser administration interface, HTTP APIs,
authentication, and static file delivery. Forwards SQL to
chusql-server over TCP; query execution and storage remain in
the database server process.
build-type: Simple
library
chusql-web/src/ChuSQL/Web/API.hs
+2 -2
View File
@@ -229,7 +229,7 @@ reservedDatabase name = name == systemDatabase
resolveSettingsFileSafe :: IO FilePath
resolveSettingsFileSafe = do
found <- try defaultConfigFile :: IO (Either IOException FilePath)
pure (either (const "chusql.toml") id found)
pure (either (const "settings.toml") id found)
-- | 定位 IDE 设置文件，找不到就定下首个候选路径
resolveUISettingsFileSafe :: IO FilePath
@@ -403,7 +403,7 @@ indexH env = do
case content of
Nothing -> do
status status500
json (apiErrorJson "missing_static" "index.html not found (check the --static directory)")
json (apiErrorJson "missing_static" "index.html not found in the static directory")
Just page -> do
nonce <- liftIO sessionToken
let (beforeHead, afterHead) = BS.breakSubstring "</head>" page
chusql-web/src/ChuSQL/Web/UISettings.hs
+3 -3
View File
@@ -22,13 +22,13 @@ import qualified Data.Vector as V
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
import System.FilePath (takeDirectory, (</>))
-- 前端 IDE 设置单独存一份文件，与全局启动配置 chusql.toml 互不干扰。
-- 前端 IDE 设置单独存一份文件，与全局启动配置 settings.toml 互不干扰。
-- | IDE 设置文件的候选位置
uiSettingsFileCandidates :: [FilePath]
uiSettingsFileCandidates =
[ "scripts" </> "chusql.ui.settings.json"
, ".." </> "scripts" </> "chusql.ui.settings.json"
[ "resources" </> "chusql.ui.settings.json"
, ".." </> "resources" </> "chusql.ui.settings.json"
, "chusql.ui.settings.json"
]
chusql-web/static/app.js
+1 -1
View File
@@ -587,7 +587,7 @@ function renderSettingsTab(el) {
el.innerHTML = `
<div class="settings-view">
<header><h1>设置</h1><p class="muted">IDE 设置存在 chusql.ui.settings.json，服务器设置写回 chusql.toml 的 [web] 分区。</p></header>
<header><h1>设置</h1><p class="muted">IDE 设置存在 chusql.ui.settings.json，服务器设置写回 settings.toml 的 [web] 分区。</p></header>
<fieldset class="settings-group"><legend>界面</legend>
${fontField('uiFonts')}${numberField('uiFontSize')}
</fieldset>
chusql-web/test/Gates.hs
+21 -10
View File
@@ -20,10 +20,10 @@ readUtf8 path = TE.decodeUtf8 <$> BS.readFile path
gateSpec :: Spec
gateSpec = do
describe "Installer scripts (scripts/)" $ do
it "install.sh releases files, writes chusql.toml, sets PATH and removes the package" $ do
it "install.sh releases files, writes settings.toml, sets PATH and removes the package" $ do
installer <- readUtf8 (".." </> "scripts" </> "install.sh")
installer `shouldSatisfy` T.isInfixOf "libchusql_core_storage"
installer `shouldSatisfy` T.isInfixOf "chusql.toml"
installer `shouldSatisfy` T.isInfixOf "settings.toml"
installer `shouldSatisfy` T.isInfixOf "PATH"
installer `shouldSatisfy` T.isInfixOf "rm -rf"
-- 一份脚本三种来源：包内（旁边有 bin/）、在线（管道进来时 $0 是 sh，按平台取 release 资源）、
@@ -138,20 +138,26 @@ gateSpec = do
ps `shouldSatisfy` T.isInfixOf "chusql-$Platform"
ps `shouldSatisfy` T.isInfixOf "chusql-web\\static"
ps `shouldSatisfy` T.isInfixOf "bin\\csql.exe"
-- 配置模板跟组件目录走：包内目录叫 resources，不再是 scripts
ps `shouldSatisfy` T.isInfixOf "resources\\settings.toml.windows"
ps `shouldSatisfy` (not . T.isInfixOf "scripts\\settings.toml")
sh `shouldSatisfy` T.isInfixOf "resources/settings.toml.linux"
sh `shouldSatisfy` (not . T.isInfixOf "scripts/settings.toml")
ps `shouldSatisfy` T.isInfixOf "Test-Installed $name 'cli'"
ps `shouldSatisfy` (not . T.isInfixOf "$Component")
ignore <- readUtf8 (".." </> ".gitignore")
ignore `shouldSatisfy` T.isInfixOf "releases/"
-- static_dir 是相对路径，启动器必须先切到安装目录；少了这一句，从别处执行
-- 静态目录固定在安装目录下，启动器必须先切到安装目录；少了这一句，从别处执行
-- csql-web 就会因为找不到 static/ 直接退出（Windows 的 .ps1 靠 -WorkingDirectory）。
it "csql-web.sh switches to the install dir before starting" $ do
launcher <- readUtf8 (".." </> "scripts" </> "csql-web.sh")
launcher `shouldSatisfy` T.isInfixOf "cd \"$home_dir\""
launcher `shouldSatisfy` T.isInfixOf "chusql-server"
-- 默认数据目录按平台惯例算，三处必须说同一件事：Rust 代码、配置示例、模板。
-- 跟安装脚本装的位置也是一处：Windows 装到 %LOCALAPPDATA%\ChuSQL、Unix 装到 ~/.local/share/chusql，
-- 数据都放在它下面的 data/ 里。
-- 日志目录由 [storage] log_files 决定，不再是硬编码的 logs
launcher `shouldSatisfy` T.isInfixOf "log_files"
-- 默认数据目录按平台惯例算，两处必须说同一件事：Rust 代码与配置示例。
-- 模板路径占位符在安装时填入绝对路径。
it "the default data dir follows the platform, and code and template agree" $ do
rust <- readUtf8 (".." </> "chusql-core" </> "storage" </> "src" </> "config.rs")
rust `shouldSatisfy` T.isInfixOf "default_data_dir"
@@ -165,10 +171,15 @@ gateSpec = do
exampleFile `shouldSatisfy` T.isInfixOf "%LOCALAPPDATA%"
exampleFile `shouldSatisfy` T.isInfixOf "XDG_DATA_HOME"
template <- readUtf8 (".." </> "scripts" </> "chusql.toml")
template <- readUtf8 (".." </> "resources" </> "settings.toml.linux")
-- 模板那行是安装时被 sed / -replace 替换的占位，必须保持能生效
template `shouldSatisfy` T.isInfixOf "\ndata_dir = "
template `shouldSatisfy` T.isInfixOf "%LOCALAPPDATA%"
-- 日志跟数据分家：启动器与安装脚本按 log_files 决定日志落哪个目录
template `shouldSatisfy` T.isInfixOf "log_files = \"@LOG_DIR@\""
-- 静态目录与管理员名都不再写进配置：前者写死 static，后者由 --user 给（默认 root）；
-- 监听地址是活的配置项（[server] listen_host / [web] listen_host），模板里可以留空靠内置默认
template `shouldSatisfy` (not . T.isInfixOf "static_dir =")
template `shouldSatisfy` (not . T.isInfixOf "user =")
-- 管道传输退休后，两侧都不该再算套接字路径、也不该再认管名。
it "neither side computes a socket path or a pipe name any more" $ do
haskellIpc <- readUtf8 (".." </> "chusql-core" </> "engine" </> "src" </> "ChuSQL" </> "Core" </> "Engine" </> "Storage" </> "IPC.hs")
@@ -217,8 +228,8 @@ gateSpec = do
release `shouldSatisfy` (not . T.isInfixOf "component: [web, cli]")
it "no layer looks for a storage executable or a pipe name any more" $ do
engine <- readUtf8 (".." </> "chusql-core" </> "engine" </> "test" </> "Spec.hs")
bench <- readUtf8 (".." </> "chusql-benchmark" </> "src" </> "Main.hs")
template <- readUtf8 (".." </> "scripts" </> "chusql.toml")
bench <- readUtf8 (".." </> "benchmark" </> "src" </> "Main.hs")
template <- readUtf8 (".." </> "resources" </> "settings.toml.linux")
mapM_
(\src -> src `shouldSatisfy` (not . T.isInfixOf "pipe_name"))
[engine, bench, template]
chusql-web/test/Spec.hs
+19 -14
View File
@@ -9,6 +9,7 @@ import ChuSQL.Interface.Settings (
applySettings,
defaultOf,
isLockedSetting,
isRestartRequired,
liveKeys,
readSettingsFile,
settingCatalogue,
@@ -382,12 +383,12 @@ startLiveWorld label = do
uniq <- uniqueSuffix
let root = tmp </> ("chusql-web-live-" ++ label ++ "-" ++ uniq)
dataDir = root </> "data"
config = root </> "chusql.toml"
config = root </> "settings.toml"
createDirectoryIfMissing True dataDir
writeFile config (serverConfigText dataDir)
seedSystemCatalog config
(_, Just out, _, process) <-
createProcess (proc bin ["--config", config]){std_out = CreatePipe, std_err = NoStream}
createProcess (proc bin ["--config", config, "--user", T.unpack adminUser]){std_out = CreatePipe, std_err = NoStream}
port <- readListeningPort out
_ <- forkIO (drainHandle out)
setAdminPassword port
@@ -416,12 +417,11 @@ serverConfigText :: FilePath -> String
serverConfigText dataDir =
unlines
[ "[web]"
, "user = \"" ++ T.unpack adminUser ++ "\""
, "password-min-length = 8"
, "password-classes = 2"
, ""
, "[server]"
, "host = \"127.0.0.1\""
, "listen_host = \"127.0.0.1\""
, "port = 0"
, ""
, "[storage]"
@@ -472,7 +472,7 @@ locateServerExe = do
seedSystemCatalog :: FilePath -> IO ()
seedSystemCatalog config = do
bootstrap <- locateBootstrapExe
(code, out, errOut) <- readProcessWithExitCode bootstrap ["--config", config, "--passwordless"] ""
(code, out, errOut) <- readProcessWithExitCode bootstrap ["--config", config, "--passwordless", "--user", T.unpack adminUser] ""
case code of
ExitSuccess -> pure ()
_ -> fail ("the fixture bootstrap program failed (exit " ++ show code ++ "): " ++ out ++ errOut)
@@ -541,21 +541,23 @@ unitSpec = describe "pure helpers" $ do
it "round-trips settings through a real TOML file" $ do
path <- tempFilePath "settings"
removeIfExists path
writeSettingsFile path (Map.fromList [("rows-per-page", "50"), ("user", "admin")])
writeSettingsFile path (Map.fromList [("rows-per-page", "50"), ("log-files", "./logs")])
>>= (`shouldSatisfy` isRightE)
values <- readSettingsFile path
Map.lookup "rows-per-page" values `shouldBe` Just "50"
Map.lookup "user" values `shouldBe` Just "admin"
Map.lookup "log-files" values `shouldBe` Just "./logs"
it "rejects unknown settings and out-of-range limits" $ do
applySettings Map.empty (Map.fromList [("nope", "1")]) `shouldSatisfy` isLeftE
applySettings Map.empty (Map.fromList [("password-min-length", "3")]) `shouldSatisfy` isLeftE
applySettings Map.empty (Map.fromList [("password-min-length", "12")]) `shouldSatisfy` isRightE
it "marks the administrator name as locked and lists the live keys" $ do
isLockedSetting "user" `shouldBe` True
it "lists the live keys and locks nothing" $ do
isLockedSetting "user" `shouldBe` False
isLockedSetting "rows-per-page" `shouldBe` False
("rows-per-page" `elem` liveKeys) `shouldBe` True
length settingCatalogue `shouldSatisfy` (> 20)
defaultOf "rows-per-page" `shouldBe` "25"
defaultOf "log-files" `shouldBe` "./logs"
isRestartRequired "log-files" `shouldBe` True
it "validates IDE settings" $ do
validateUISettings (object ["sqlFontSize" .= (13 :: Int), "minimap" .= False])
`shouldSatisfy` isRightE
@@ -753,7 +755,9 @@ settingsSpec env = describe "settings and password policy" $ do
let entries = items (at "items" (jsonBody res))
check (length entries `shouldSatisfy` (> 20))
check (asText (at "value" (headEntry "rows-per-page" entries)) `shouldBe` "25")
check (at "locked" (headEntry "user" entries) `shouldBe` A.Bool True)
-- 设置目录里没有任何只读键（管理员名已不写进配置），新的日志目录项在列
check (at "locked" (headEntry "rows-per-page" entries) `shouldBe` A.Bool False)
check (asText (at "value" (headEntry "log-files" entries)) `shouldBe` "./logs")
it "writes a setting, makes the server reload the policy, and reports it applied" $ do
hs <- adminHeaders
res <-
@@ -777,13 +781,14 @@ settingsSpec env = describe "settings and password policy" $ do
check (asInt (at "minLength" (at "policy" (jsonBody me))) `shouldBe` 16)
values <- liftIO (readSettingsFile (aeSettingsFile env))
check (Map.lookup "password-min-length" values `shouldBe` Just "16")
check (Map.lookup "user" values `shouldBe` Just adminUser)
it "refuses unknown settings and the locked administrator name" $ do
-- 管理员名不再落进配置文件：它由 --user 给
check (Map.member "user" values `shouldBe` False)
it "refuses unknown settings, including the retired administrator name" $ do
hs <- adminHeaders
unknown <- putAs hs "/api/settings" (encode (object ["values" .= object ["nope" .= ("1" :: Text)]]))
expectStatusWith "unknown setting" unknown 400
locked <- putAs hs "/api/settings" (encode (object ["values" .= object ["user" .= ("hacked" :: Text)]]))
expectStatusWith "locked administrator name" locked 403
retired <- putAs hs "/api/settings" (encode (object ["values" .= object ["user" .= ("hacked" :: Text)]]))
expectStatusWith "retired administrator name" retired 400
-- 账号表 ---------------------------------------------------------------------