修bug，完善功能

2026-10-16 23:52:12 +08:00
1 parent 30364b1c4b
commit 6996e19694
@@ -32,13 +32,13 @@ module ChuSQL.Interface.Actions (
    revokeRoleSql,
 ) where

-import Control.Monad (zipWithM)
 import ChuSQL.Core.Model (Column (..), ColumnType (..), Value (..), integerType, numericType, parseColumnType, plainColumn, typeName)
 import qualified ChuSQL.Core.Model as M
-import ChuSQL.Core.Runtime
 import ChuSQL.Core.Protocol (valueFromJSON)
-import Data.Aeson.Types (parseEither)
+import ChuSQL.Core.Runtime
+import Control.Monad (zipWithM)
 import qualified Data.Aeson as A
+import Data.Aeson.Types (parseEither)
 import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
 import Data.List (intercalate)
 import Data.Scientific (floatingOrInteger)
@@ -71,7 +71,7 @@ isIdentifier t =
            (c : cs) -> (isAsciiLower c || isAsciiUpper c || c == '_') && all restChar cs
            [] -> False
  where
-    -- | 标识符里其余字符的合法集
+    -- \| 标识符里其余字符的合法集
    restChar c = isAsciiLower c || isAsciiUpper c || isDigit c || c == '_'

 -- | 检查一个标识符，不合法就报错（带上"是表名还是列名"）
@@ -177,7 +177,7 @@ createTableSql spec = do
    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)
@@ -258,7 +258,7 @@ updateRowSql table key assigns = do
    sets <- mapM assignment cols
    pure ("UPDATE " ++ T.unpack tbl ++ " SET " ++ intercalate ", " sets ++ " WHERE id = " ++ show key)
  where
-    -- | 校验列名并编码赋值
+    -- \| 校验列名并编码赋值
    assignment (name, value) = do
        column <- checkIdent "column" (T.pack name)
        literal <- sqlLiteral value
@@ -286,7 +286,7 @@ whereClause filters = case filters of
        terms <- mapM term filters
        pure (" WHERE " ++ intercalate " AND " terms)
  where
-    -- | 一个等值条件
+    -- \| 一个等值条件
    term (column, value) = do
        col <- checkIdent "column" column
        literal <- sqlLiteral value
@@ -306,7 +306,7 @@ accountName name
    | not (T.all allowed name) = Left ("account name may only contain ASCII letters, digits, dot, dash or underscore: " ++ T.unpack name)
    | otherwise = Right name
  where
-    -- | 账号名允许的字符集
+    -- \| 账号名允许的字符集
    allowed c = isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("_.-" :: String)

 -- | 单引号字符串字面量
@@ -342,7 +342,7 @@ roleName name
    | not (T.all allowed name) = Left ("role name may only contain ASCII letters, digits, dot, dash or underscore: " ++ T.unpack name)
    | otherwise = Right name
  where
-    -- | 角色名允许的字符集
+    -- \| 角色名允许的字符集
    allowed c = isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("_.-" :: String)

 -- | 授权对象：`*`，或长度不超过 128 的裸表名/`库.表`
@@ -355,7 +355,7 @@ grantObject object
    | not (T.all allowed object) = Left ("object name may only contain ASCII letters, digits, dot, dash or underscore: " ++ T.unpack object)
    | otherwise = Right object
  where
-    -- | 授权对象允许的字符集
+    -- \| 授权对象允许的字符集
    allowed c = isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("_.-" :: String)

 -- | 权限清单：词要纯字母，认不认由 server 定
@@ -364,7 +364,7 @@ privilegeWords privileges
    | null privileges = Left "at least one privilege is required"
    | otherwise = mapM word privileges
  where
-    -- | 单个权限词
+    -- \| 单个权限词
    word one
        | T.null one || not (T.all (\c -> isAsciiLower c || isAsciiUpper c) one) = Left ("not a privilege keyword: " ++ T.unpack one)
        | otherwise = Right one
@@ -388,11 +388,16 @@ grantPrivilegesSql privileges object role withOption = do
    target <- grantObject object
    who <- roleName role
    pure
-        ( "GRANT " ++ T.unpack (T.intercalate ", " words') ++ " ON " ++ T.unpack target
-            ++ " TO " ++ T.unpack who ++ tailText
+        ( "GRANT "
+            ++ T.unpack (T.intercalate ", " words')
+            ++ " ON "
+            ++ T.unpack target
+            ++ " TO "
+            ++ T.unpack who
+            ++ tailText
        )
  where
-    -- | 转授权后缀
+    -- \| 转授权后缀
    tailText
        | withOption = " WITH GRANT OPTION"
        | otherwise = ""
@@ -34,9 +34,9 @@ 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 qualified Data.ByteString as BS
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (isJust)
@@ -79,7 +79,7 @@ canonicalSettingKeys :: Map.Map Text Text -> Map.Map Text Text
 canonicalSettingKeys saved =
    foldr (\(key, value) acc -> Map.insert (canonicalKey key) value acc) Map.empty (Map.toList saved)
  where
-    -- | 取一个键的规范名
+    -- \| 取一个键的规范名
    canonicalKey key = fromMaybe key (lookup key keyAliases)

 -- | 设置键别名：非权威写法到权威写法（多数写连字符）
@@ -171,7 +171,7 @@ staticDirCandidates given =
 resolveStaticDir :: FilePath -> IO (Maybe FilePath)
 resolveStaticDir given = go (staticDirCandidates given)
  where
-    -- | 逐个试
+    -- \| 逐个试
    go [] = pure Nothing
    go (d : ds) = do
        ok <- doesDirectoryExist d
@@ -195,11 +195,12 @@ defaultServerConfig = ServerConfig "127.0.0.1" 7777 (1024 * 1024) 1000 ""
 loadServerConfigAt :: FilePath -> IO ServerConfig
 loadServerConfigAt path = do
    values <- readSection path "server"
-    let -- | 取一个键的非空字符串值
+    let
+        -- \| 取一个键的非空字符串值
        textOf key fallback = case Map.lookup key values of
            Just value | not (T.null (T.strip value)) -> T.unpack (T.strip value)
            _ -> fallback
-        -- | 取一个键的整数值
+        -- \| 取一个键的整数值
        intOf key fallback = fromMaybe fallback (Map.lookup key values >>= readMaybe . T.unpack . T.strip)
    pure
        defaultServerConfig
@@ -17,10 +17,8 @@ module ChuSQL.Interface.Link (
    clientReloadPolicy,
 ) where

-import ChuSQL.Interface.Normalization (NormalizationRequest)
-import qualified Data.Aeson as A
-import ChuSQL.Interface.Sudo (SudoCredential, sudoProof, isLocalPeer)
 import ChuSQL.Core.Protocol (Account, QueryResult (..), TableInfo (..))
+import ChuSQL.Interface.Normalization (NormalizationRequest)
 import ChuSQL.Interface.Protocol (
    ClientRequest (..),
    RoleView,
@@ -29,11 +27,13 @@ import ChuSQL.Interface.Protocol (
    encodeRequest,
    protocolVersion,
 )
+import ChuSQL.Interface.Sudo (SudoCredential, isLocalPeer, sudoProof)
 import Control.Concurrent.MVar (MVar, newMVar, withMVar)
 import Control.Exception (IOException, try)
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Char8 as BSC
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.Lazy.Char8 as BLC
-import qualified Data.ByteString.Char8 as BSC
 import Data.Text (Text)
 import qualified Data.Text as T
 import Network.Socket (
@@ -75,7 +75,8 @@ connectClient host port = do
                Right (RespHello version)
                    | version == protocolVersion -> pure (Right client)
                    | otherwise ->
-                        giveUp handle
+                        giveUp
+                            handle
                            ( "server "
                                <> T.pack (address host port)
                                <> " speaks protocol "
@@ -87,7 +88,7 @@ connectClient host port = do
                Right _ -> giveUp handle "unexpected response to hello"
                Left message -> giveUp handle message
  where
-    -- | 对不上就关连接并回错误
+    -- \| 对不上就关连接并回错误
    giveUp handle message = do
        _ <- try (hClose handle) :: IO (Either IOException ())
        pure (Left message)
@@ -4,7 +4,7 @@ module ChuSQL.Interface.Normalization where

 import ChuSQL.Core.Protocol (SchemaColumn)
 import Control.Monad (unless, when)
-import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.!=), (.=))
+import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.!=), (.:), (.:?), (.=))
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Key as K
 import qualified Data.Aeson.KeyMap as KM
@@ -13,25 +13,32 @@ import qualified Data.ByteString.Lazy as BL
 import Data.Char (isAlpha, isAlphaNum, isDigit, isHexDigit, isSpace)
 import Data.List (nub)
 import Data.Scientific (base10Exponent, toBoundedInteger)
-import Data.Word (Word64)
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
+import Data.Word (Word64)
 import Text.ParserCombinators.ReadP

 -- 范式入口的版本化声明、对象身份与严格 JSON 校验。

 data NormalizationDependency = NormalizationDependency [String] [String] deriving (Eq, Show)
 data NormalizationDeclaration = NormalizationDeclaration
-    { ndKeys :: [[String]], ndDependencies :: [NormalizationDependency]
-    , ndComplete :: Bool, ndAtomic :: Maybe Bool
-    } deriving (Eq, Show)
+    { ndKeys :: [[String]]
+    , ndDependencies :: [NormalizationDependency]
+    , ndComplete :: Bool
+    , ndAtomic :: Maybe Bool
+    }
+    deriving (Eq, Show)
 data ObjectIdentity = ObjectIdentity Integer Integer deriving (Eq, Show)
 data NormalizationRequest = NormalizationRequest
-    { nrVersion :: Int, nrDatabase :: Text, nrTable :: Text
+    { nrVersion :: Int
+    , nrDatabase :: Text
+    , nrTable :: Text
    , nrDeclaration :: NormalizationDeclaration
-    , nrExpectedObject :: Maybe ObjectIdentity, nrExpectedSchema :: Maybe Text
-    } deriving (Eq, Show)
+    , nrExpectedObject :: Maybe ObjectIdentity
+    , nrExpectedSchema :: Maybe Text
+    }
+    deriving (Eq, Show)

 -- 拒绝对象中未定义的字段。
 onlyFields :: [Text] -> A.Object -> AT.Parser ()
@@ -58,8 +65,13 @@ instance FromJSON NormalizationDeclaration where
        NormalizationDeclaration keys deps <$> o .:? "dependencies_complete" .!= False <*> o .:? "atomic_attributes"
 instance ToJSON NormalizationDeclaration where
    -- 编码全部声明标志。
-    toJSON d = object ["declared_keys" .= ndKeys d, "dependencies" .= ndDependencies d,
-        "dependencies_complete" .= ndComplete d, "atomic_attributes" .= ndAtomic d]
+    toJSON d =
+        object
+            [ "declared_keys" .= ndKeys d
+            , "dependencies" .= ndDependencies d
+            , "dependencies_complete" .= ndComplete d
+            , "atomic_attributes" .= ndAtomic d
+            ]
 instance FromJSON ObjectIdentity where
    -- 校验稳定对象的正整数编号。
    parseJSON = withObject "object identity" $ \o -> do
@@ -68,6 +80,7 @@ instance FromJSON ObjectIdentity where
        table <- o .: "object_id" >>= identityNumber
        when (db <= 0 || table <= 0) (fail "normalization: invalid object identity")
        pure (ObjectIdentity db table)
+
 -- 兼容目录数值并保留浏览器中的完整编号。
 identityNumber :: A.Value -> AT.Parser Integer
 identityNumber (A.String text)
@@ -90,13 +103,21 @@ instance FromJSON NormalizationRequest where
        when (version /= (1 :: Int)) (fail "normalization: unsupported api_version")
        db <- o .: "database"
        table <- o .: "table"
-        unless (plainName db && case T.splitOn "." table of [name] -> plainName name; [scope, name] -> scope == db && plainName name; _ -> False)
+        unless
+            (plainName db && case T.splitOn "." table of [name] -> plainName name; [scope, name] -> scope == db && plainName name; _ -> False)
            (fail "normalization: invalid or cross-database table name")
        NormalizationRequest version db table <$> o .: "declaration" <*> o .:? "expected_object" <*> o .:? "expected_schema_fingerprint"
 instance ToJSON NormalizationRequest where
    -- 编码专用分析请求。
-    toJSON r = object ["api_version" .= nrVersion r, "database" .= nrDatabase r, "table" .= nrTable r,
-        "declaration" .= nrDeclaration r, "expected_object" .= nrExpectedObject r, "expected_schema_fingerprint" .= nrExpectedSchema r]
+    toJSON r =
+        object
+            [ "api_version" .= nrVersion r
+            , "database" .= nrDatabase r
+            , "table" .= nrTable r
+            , "declaration" .= nrDeclaration r
+            , "expected_object" .= nrExpectedObject r
+            , "expected_schema_fingerprint" .= nrExpectedSchema r
+            ]

 -- 校验与 SQL 一致的裸标识符。
 plainName :: Text -> Bool
@@ -157,26 +178,30 @@ jsonString = do
    -- 保留 JSON 字符串转义。
    piece = ((\c -> ['\\', c]) <$> (char '\\' *> get)) <++ munch1 (\c -> c /= '"' && c /= '\\')

-
 -- 拒绝缺字段或未知标签的线上报告。
 parseNormalizationReport :: A.Value -> AT.Parser A.Value
-parseNormalizationReport value = withObject "normalization report" (\o -> do
-    version <- o .: "api_version"
-    conditional <- o .: "conditional"
-    unless (version == (1 :: Int) && conditional) (fail "normalization: invalid report version or condition")
-    _ <- (o .: "object" :: AT.Parser ObjectIdentity)
-    fingerprint <- o .: "schema_fingerprint"
-    unless (T.length fingerprint == 64 && T.all isHexDigit fingerprint) (fail "normalization: invalid schema fingerprint")
-    view <- o .: "view"
-    unless (view `elem` (["live_schema", "transaction_snapshot"] :: [Text])) (fail "normalization: unknown view")
-    _ <- (o .: "schema" :: AT.Parser [SchemaColumn])
-    _ <- (o .: "declaration" :: AT.Parser NormalizationDeclaration)
-    _ <- (o .: "candidate_keys" :: AT.Parser [[String]])
-    forms <- o .: "findings" >>= mapM parseFinding
-    unless (forms == (["1nf", "2nf", "3nf", "bcnf"] :: [Text])) (fail "normalization: invalid findings")
-    _ <- (o .: "suggestions" :: AT.Parser [A.Value])
-    _ <- (o .: "condition" :: AT.Parser Text)
-    pure value) value
+parseNormalizationReport value =
+    withObject
+        "normalization report"
+        ( \o -> do
+            version <- o .: "api_version"
+            conditional <- o .: "conditional"
+            unless (version == (1 :: Int) && conditional) (fail "normalization: invalid report version or condition")
+            _ <- (o .: "object" :: AT.Parser ObjectIdentity)
+            fingerprint <- o .: "schema_fingerprint"
+            unless (T.length fingerprint == 64 && T.all isHexDigit fingerprint) (fail "normalization: invalid schema fingerprint")
+            view <- o .: "view"
+            unless (view `elem` (["live_schema", "transaction_snapshot"] :: [Text])) (fail "normalization: unknown view")
+            _ <- (o .: "schema" :: AT.Parser [SchemaColumn])
+            _ <- (o .: "declaration" :: AT.Parser NormalizationDeclaration)
+            _ <- (o .: "candidate_keys" :: AT.Parser [[String]])
+            forms <- o .: "findings" >>= mapM parseFinding
+            unless (forms == (["1nf", "2nf", "3nf", "bcnf"] :: [Text])) (fail "normalization: invalid findings")
+            _ <- (o .: "suggestions" :: AT.Parser [A.Value])
+            _ <- (o .: "condition" :: AT.Parser Text)
+            pure value
+        )
+        value
  where
    -- 核对每项结论与证据的稳定形状。
    parseFinding = withObject "normalization finding" $ \o -> do
@@ -33,10 +33,12 @@ passwordKeys = ["password-min-length", "password-classes"]

 -- | 策略值：缺项或空值回落到内置默认
 policyFromValues :: PasswordPolicy -> Map.Map Text Text -> PasswordPolicy
-policyFromValues before values = PasswordPolicy
-    (number "password-min-length" (ppMinLength before)) (number "password-classes" (ppClasses before))
+policyFromValues before values =
+    PasswordPolicy
+        (number "password-min-length" (ppMinLength before))
+        (number "password-classes" (ppClasses before))
  where
-    -- | 取一个键的数值，缺项或空值回落到给定默认
+    -- \| 取一个键的数值，缺项或空值回落到给定默认
    number key fallback = case Map.lookup key values of
        Nothing -> fallback
        Just value -> fromMaybe fallback (readMaybe (T.unpack (if T.null value then defaultOf key else value)))
@@ -13,13 +13,13 @@ module ChuSQL.Interface.Protocol (
    RoleView (..),
 ) where

-import ChuSQL.Interface.Normalization
-import Data.Aeson.Types (parseEither)
 import ChuSQL.Core.Protocol (Account (..), QueryResult (..), TableInfo (..), queryResultJson)
-import Data.Aeson (FromJSON (..), ToJSON (..), Value, object, withObject, (.:), (.:?), (.!=), (.=))
+import ChuSQL.Interface.Normalization
+import Data.Aeson (FromJSON (..), ToJSON (..), Value, object, withObject, (.!=), (.:), (.:?), (.=))
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Key as AK
 import qualified Data.Aeson.KeyMap as KM
+import Data.Aeson.Types (parseEither)
 import qualified Data.ByteString.Char8 as BSC
 import qualified Data.ByteString.Lazy as BL
 import Data.Maybe (fromMaybe)
@@ -233,7 +233,7 @@ decodeResponse raw = case A.eitherDecode raw of
        _ -> Left "response is missing status"
    Right _ -> Left "response is not a JSON object"
  where
-    -- | 按 status 字段分派
+    -- \| 按 status 字段分派
    decodeStatus status fields = case status of
        "hello" -> Right (RespHello (intOf "protocol" fields))
        "ok" -> Right (RespLogin (textOf "user" fields) (boolOf "admin" fields))
@@ -257,23 +257,23 @@ decodeResponse raw = case A.eitherDecode raw of
        "policy" -> Right (RespPolicy (intOf "minLength" fields) (intOf "classes" fields))
        other -> Left ("unexpected status: " <> other)

-    -- | 取一个字段解成目标类型
-    fromField :: A.FromJSON a => Text -> (a -> ServerResponse) -> A.Object -> Either Text ServerResponse
+    -- \| 取一个字段解成目标类型
+    fromField :: (A.FromJSON a) => Text -> (a -> ServerResponse) -> A.Object -> Either Text ServerResponse
    fromField key wrap fields = case A.fromJSON (fromMaybe A.Null (KM.lookup (AK.fromText key) fields)) of
        A.Success value -> Right (wrap value)
        A.Error message -> Left (T.pack message)

-    -- | 取一个整数字段
+    -- \| 取一个整数字段
    intOf key fields = case KM.lookup key fields of
        Just (A.Number number) -> truncate number
        _ -> 0

-    -- | 取一个文本字段
+    -- \| 取一个文本字段
    textOf key fields = case KM.lookup key fields of
        Just (A.String text) -> text
        _ -> ""

-    -- | 取一个布尔字段
+    -- \| 取一个布尔字段
    boolOf key fields = case KM.lookup key fields of
        Just (A.Bool flag) -> flag
        _ -> False
@@ -17,24 +17,24 @@ module ChuSQL.Interface.Session (
    accounts,
 ) where

-import Data.Foldable (for_)
-import ChuSQL.Interface.Normalization
-import qualified Data.Aeson as A
 import ChuSQL.Core.Protocol (Account, QueryResult (..), TableInfo)
 import ChuSQL.Interface.Link (
    Client,
-    clientNormalization,
    clientAccounts,
    clientCatalog,
    clientDatabases,
    clientLogin,
-    clientSudoLogin,
+    clientNormalization,
    clientQuery,
    clientRoles,
+    clientSudoLogin,
 )
-import ChuSQL.Interface.Sudo (SudoCredential)
+import ChuSQL.Interface.Normalization
 import ChuSQL.Interface.Protocol (RoleView)
+import ChuSQL.Interface.Sudo (SudoCredential)
+import qualified Data.Aeson as A
 import Data.Char (isAlpha, isAlphaNum)
+import Data.Foldable (for_)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -94,7 +94,7 @@ switchDatabase session rawName
            Left message -> pure (Left message)
            Right _ -> pure (Right ())
  where
-    -- | 规范化后的库名
+    -- \| 规范化后的库名
    name = T.toLower (T.strip rawName)

 -- | 跑一条语句；结果集里带回的当前库口径跟着一起更新
@@ -105,7 +105,8 @@ runStatement session sql = do
        Left message -> pure (Left message)
        Right result -> do
            for_
-              (qrDatabase result) (writeIORef (ssCurrent session))
+                (qrDatabase result)
+                (writeIORef (ssCurrent session))
            pure (Right result)

 -- | 数据字典（\\dt 与 \\d 用）
@@ -128,5 +129,6 @@ accounts session = clientAccounts (ssClient session)
 analyzeNormalization :: Session -> NormalizationRequest -> IO (Either Text A.Value)
 analyzeNormalization session payload = do
    current <- sessionDatabase session
-    if current /= nrDatabase payload then pure (Left "bad_request: normalization database differs from the selected database")
+    if current /= nrDatabase payload
+        then pure (Left "bad_request: normalization database differs from the selected database")
        else clientNormalization (ssClient session) payload
@@ -67,7 +67,7 @@ settingCatalogue =
    , owned "tcp-max-rows" "TCP rows per result" "network" "int" "1000" "server" "max_rows"
    ]
  where
-    -- | web 自己的键：分区写死 [web]
+    -- \| web 自己的键：分区写死 [web]
    item k l g kind def rootOnly restart =
        SettingItem
            { siKey = k
@@ -94,7 +94,7 @@ settingCatalogue =
            , siTomlKey = tomlKey
            }

-    -- | 换掉落盘用的键名：界面键与 TOML 键不同名时用
+    -- \| 换掉落盘用的键名：界面键与 TOML 键不同名时用
    withTomlKey key spec = spec{siTomlKey = key}

 -- | web 自己的分区名
@@ -130,7 +130,8 @@ isRestartRequired key = maybe False siRestart (findItem key)
 -- | 改完立刻生效的配置键
 liveKeys :: [Text]
 liveKeys =
-    [ "password-min-length", "password-classes"
+    [ "password-min-length"
+    , "password-classes"
    , "body-limit"
    , "session-idle"
    , "session-max"
@@ -146,7 +147,7 @@ liveKeys =
 readSettingsFile :: FilePath -> IO (Map.Map Text Text)
 readSettingsFile path = fmap Map.unions (mapM readSectionOf catalogueSections)
  where
-    -- | 读一个分区，摊成界面键
+    -- \| 读一个分区，摊成界面键
    readSectionOf section = do
        raw <- readSection path section
        let values = if section == webSection then canonicalSettingKeys raw else raw
@@ -163,7 +164,7 @@ readSettingsFile path = fmap Map.unions (mapM readSectionOf catalogueSections)
 writeSettingsFile :: FilePath -> Map.Map Text Text -> IO (Either String ())
 writeSettingsFile path values = writeSections catalogueSections
  where
-    -- | 各分区依次写回
+    -- \| 各分区依次写回
    writeSections [] = pure (Right ())
    writeSections (section : rest) = do
        let entries =
@@ -185,7 +186,7 @@ writeSettingsFile path values = writeSections catalogueSections
 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
@@ -234,8 +235,8 @@ effectiveSettings cfg =
        , ("log-files", T.pack (wcLogFiles cfg))
        ]
  where
-    -- | 数值转文本
+    -- \| 数值转文本
    tshow = T.pack . show
-    -- | 布尔转 "1"/"0"
+    -- \| 布尔转 "1"/"0"
    boolText True = "1"
    boolText False = "0"
@@ -2,9 +2,17 @@
 {-# LANGUAGE OverloadedStrings #-}

 module ChuSQL.Interface.Sudo (
-    SudoCredential, createSudoCredential, removeSudoCredential,
-    readSudoCredential, sudoProof, verifySudoProof, sudoChallenge, sudoPrivileged,
-    newSudoCredential, isLocalPeer, validSudoChallenge,
+    SudoCredential,
+    createSudoCredential,
+    removeSudoCredential,
+    readSudoCredential,
+    sudoProof,
+    verifySudoProof,
+    sudoChallenge,
+    sudoPrivileged,
+    newSudoCredential,
+    isLocalPeer,
+    validSudoChallenge,
 ) where

 import Crypto.Hash (SHA256)
@@ -21,7 +29,7 @@ import Data.Time.Clock (UTCTime, diffUTCTime)
 import Foreign.C.String (CString)
 import Foreign.C.Types (CInt (..))
 import Foreign.Marshal.Alloc (allocaBytes)
-import Network.Socket (SockAddr (..), hostAddressToTuple, hostAddress6ToTuple)
+import Network.Socket (SockAddr (..), hostAddress6ToTuple, hostAddressToTuple)

 -- 用系统保护凭据与一次性挑战验证本机提升身份。

@@ -33,10 +41,13 @@ instance Show SudoCredential where

 -- 检查当前进程的操作系统提升身份。
 foreign import ccall unsafe "chusql_sudo_privileged" nativePrivileged :: IO CInt
+
 -- 创建操作系统保护的本机凭据。
 foreign import ccall safe "chusql_sudo_create" nativeCreate :: CInt -> CString -> IO CInt
+
 -- 读取操作系统保护的本机凭据。
 foreign import ccall safe "chusql_sudo_read" nativeRead :: CInt -> CString -> IO CInt
+
 -- 清理本次服务启动的凭据。
 foreign import ccall safe "chusql_sudo_remove" nativeRemove :: CInt -> IO CInt

@@ -53,7 +64,8 @@ createSudoCredential :: Int -> IO SudoCredential
 createSudoCredential port = do
    credential@(SudoCredential secret) <- newSudoCredential
    status <- BS.useAsCString secret (nativeCreate (fromIntegral port))
-    if status == 0 then pure credential
+    if status == 0
+        then pure credential
        else ioError (userError (T.unpack (nativeError "create" status)))

 -- 生成独立服务实例的随机凭据。
@@ -72,8 +84,10 @@ isLocalPeer _ = False
 -- 校验挑战有效期及其账号绑定证明。
 validSudoChallenge :: SudoCredential -> UTCTime -> Maybe (Text, UTCTime) -> Text -> Text -> Bool
 validSudoChallenge credential now challenge user proof = case challenge of
-    Just (nonce, issued) -> diffUTCTime now issued >= 0 && diffUTCTime now issued <= 60
-        && verifySudoProof credential nonce user proof
+    Just (nonce, issued) ->
+        diffUTCTime now issued >= 0
+            && diffUTCTime now issued <= 60
+            && verifySudoProof credential nonce user proof
    Nothing -> False

 -- 删除本次服务实例的受保护凭据。
@@ -86,10 +100,14 @@ removeSudoCredential port = do
 readSudoCredential :: Int -> IO (Either Text SudoCredential)
 readSudoCredential port = allocaBytes 64 $ \buffer -> do
    status <- nativeRead (fromIntegral port) buffer
-    if status /= 0 then pure (Left (nativeError "read" status)) else do
-        secret <- BS.packCStringLen (buffer, 64)
-        pure $ if BS.all (isHexDigit . toEnum . fromIntegral) secret
-            then Right (SudoCredential secret) else Left "invalid sudo credential"
+    if status /= 0
+        then pure (Left (nativeError "read" status))
+        else do
+            secret <- BS.packCStringLen (buffer, 64)
+            pure $
+                if BS.all (isHexDigit . toEnum . fromIntegral) secret
+                    then Right (SudoCredential secret)
+                    else Left "invalid sudo credential"

 -- 计算绑定挑战与目标账号的认证证明。
 sudoProof :: SudoCredential -> Text -> Text -> Text
@@ -99,10 +117,15 @@ sudoProof (SudoCredential secret) challenge user = TE.decodeUtf8 (convertToBase

 -- 按固定长度常量时间比对认证证明。
 verifySudoProof :: SudoCredential -> Text -> Text -> Text -> Bool
-verifySudoProof credential challenge user proof = T.length proof == 64
-    && BA.constEq (TE.encodeUtf8 (sudoProof credential challenge user)) (TE.encodeUtf8 proof)
+verifySudoProof credential challenge user proof =
+    T.length proof == 64
+        && BA.constEq (TE.encodeUtf8 (sudoProof credential challenge user)) (TE.encodeUtf8 proof)

 -- 将原生错误转换为明确诊断。
 nativeError :: Text -> CInt -> Text
-nativeError operation status = "sudo credential " <> operation <> " failed (OS error "
-    <> T.pack (show status) <> "); requires root or an elevated administrator; stale credential directories must be removed after stopping the server"
+nativeError operation status =
+    "sudo credential "
+        <> operation
+        <> " failed (OS error "
+        <> T.pack (show status)
+        <> "); requires root or an elevated administrator; stale credential directories must be removed after stopping the server"
@@ -1,16 +1,16 @@
 {-# LANGUAGE OverloadedStrings #-}

-module ChuSQL.Interface.TOML
-    ( readSection
-    , writeSection
-    , defaultConfigFile
-    , resolveConfigPath
-    ) where
+module ChuSQL.Interface.TOML (
+    readSection,
+    writeSection,
+    defaultConfigFile,
+    resolveConfigPath,
+) where

 import Control.Exception (IOException, try)
 import qualified Data.ByteString as BS
-import qualified Data.Map.Strict as Map
 import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -36,15 +36,18 @@ writeSection path section values = do
    prepared <- prepareDirectory
    case prepared of
        Left err -> pure (Left err)
-        Right () -> do exists <- doesFileExist path
-                       raw <- if exists then
-                                  TE.decodeUtf8 <$> BS.readFile path
-                              else
-                                  pure ""
-                       let updated = T.unlines (rewrite section values (T.lines raw))
-                       tryWrite (TE.encodeUtf8 updated)
+        Right () -> do
+            exists <- doesFileExist path
+            raw <-
+                if exists
+                    then
+                        TE.decodeUtf8 <$> BS.readFile path
+                    else
+                        pure ""
+            let updated = T.unlines (rewrite section values (T.lines raw))
+            tryWrite (TE.encodeUtf8 updated)
  where
-    -- | 目录不存在就先建
+    -- \| 目录不存在就先建
    prepareDirectory = do
        let dir = takeDirectory path
        if null dir
@@ -52,7 +55,7 @@ writeSection path section values = do
            else do
                done <- try (createDirectoryIfMissing True dir) :: IO (Either IOException ())
                pure (either (Left . show) (const (Right ())) done)
-    -- | 写文件，异常转成错误串
+    -- \| 写文件，异常转成错误串
    tryWrite bytes = do
        done <- try (BS.writeFile path bytes) :: IO (Either IOException ())
        pure (either (Left . show) (const (Right ())) done)
@@ -61,7 +64,7 @@ writeSection path section values = do
 sectionEntries :: Text -> [Text] -> [(Text, Text)]
 sectionEntries wanted = go ""
  where
-    -- | 走到目标分区后收键值对
+    -- \| 走到目标分区后收键值对
    go _ [] = []
    go current (line : rest)
        | Just name <- sectionName line = go name rest
@@ -92,7 +95,7 @@ assignment line = case T.breakOn "=" (stripComment line) of
 stripComment :: Text -> Text
 stripComment = T.pack . go False . T.unpack
  where
-    -- | 引号外遇到 # 就到此为止
+    -- \| 引号外遇到 # 就到此为止
    go _ [] = []
    go inString ('#' : rest)
        | not inString = []
@@ -111,11 +114,11 @@ unquote value
 rewrite :: Text -> Map Text Text -> [Text] -> [Text]
 rewrite section values = addMissing . replaceInSection . dropEmpties
  where
-    -- | 删掉空值的键
+    -- \| 删掉空值的键
    dropEmpties = filter (maybe True (not . T.null . snd) . assignment)
-    -- | 在目标分区里就地换行
+    -- \| 在目标分区里就地换行
    replaceInSection = go ""
-    -- | 走到目标分区后逐行替换
+    -- \| 走到目标分区后逐行替换
    go _ [] = []
    go current (line : rest)
        | Just name <- sectionName line = line : go name rest
@@ -123,7 +126,7 @@ rewrite section values = addMissing . replaceInSection . dropEmpties
        | otherwise = case assignment line of
            Just (key, _) | Just value <- Map.lookup key values -> assignmentLine key value : go current rest
            _ -> line : go current rest
-    -- | 分区里缺的键补在末尾
+    -- \| 分区里缺的键补在末尾
    addMissing lines' =
        let present = Set.fromList (keysOf section lines')
            missing = [(key, value) | (key, value) <- Map.toList values, not (Set.member key present), not (T.null value)]
@@ -139,14 +142,14 @@ quote value
    | T.all allowed value && not (T.null value) = value
    | otherwise = "\"" <> T.replace "\"" "\\\"" value <> "\""
  where
-    -- | 可以裸写的字符集
+    -- \| 可以裸写的字符集
    allowed ch = ch `elem` ("0123456789.-" :: String)

 -- | 取某个分区里出现过的键
 keysOf :: Text -> [Text] -> [Text]
 keysOf wanted = go ""
  where
-    -- | 走到目标分区后收键名
+    -- \| 走到目标分区后收键名
    go _ [] = []
    go current (line : rest)
        | Just name <- sectionName line = go name rest
@@ -160,7 +163,8 @@ appendSection :: Text -> [(Text, Text)] -> [Text] -> [Text]
 appendSection section entries lines' =
    lines'
        ++ (["" | null lines' || not (T.null (last lines'))])
-        ++ ("[" <> section <> "]") : [assignmentLine key value | (key, value) <- entries]
+        ++ ("[" <> section <> "]")
+        : [assignmentLine key value | (key, value) <- entries]

 -- | 全局配置文件的固定路径，跟随系统惯例
 defaultConfigFile :: IO FilePath