使用React js完成web前端
This commit is contained in:
LIm1tZz7 committed
1 parent
9e8c5f1ef0
commit
7600f0f9ed
130 files changed
+12708
-788
No files matched your search
@@ -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"
|
||||
Reference in new issue
Block a user