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

{-# 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"