推进

chusql-web/app/Main.hs

@@ -2,6 +2,7 @@
 
 module Main (main) where
 
+import Control.Monad (when)
 import ChuSQL.Web.API (AppEnv (..), Live (..), newAppEnvAt, setLive, webApp)
 import ChuSQL.Interface.Auth (SessionPolicy (..), setPayloadPolicy)
 import ChuSQL.Interface.Config (
@@ -248,11 +249,11 @@ serve settings app = do
 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"
-            putStrLn "  !! remove it: the administrator password lives in the __system_users system table"
-        else pure ()
+    when legacy
+      $ do putStrLn
+             "  !! the [web] section still carries a plaintext password key; it is ignored now"
+           putStrLn
+             "  !! remove it: the administrator password lives in the __system_users system table"
 
 -- | ping 一次 server，报告它通不通
 checkServer :: Text -> Int -> IO ()

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module ChuSQL.Web.API (
@@ -20,6 +21,7 @@ module ChuSQL.Web.API (
     newAppEnvAt,
 ) where
 
+import Data.Either (fromRight)
 import ChuSQL.Core.Model (Row, Value (..))
 import ChuSQL.Core.Engine.Syntax.AST (Statement (BeginTransaction, CommitTransaction, RollbackTransaction))
 import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
@@ -113,7 +115,7 @@ import ChuSQL.Web.UISettings (
 import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, withMVar)
 import Control.Concurrent (forkIO, threadDelay)
 import Control.Exception (IOException, try)
-import Control.Monad (forever, when)
+import Control.Monad (forever, when, unless)
 import Data.Aeson (FromJSON (..), eitherDecode, object, withObject, (.:), (.=))
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Key as K
@@ -124,7 +126,7 @@ import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
 import Data.List (nub, sortBy)
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
-import Data.Maybe (catMaybes, fromMaybe)
+import Data.Maybe (catMaybes, fromMaybe, isJust)
 import Data.Scientific (fromFloatDigits)
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -244,13 +246,13 @@ reservedDatabase name = name == systemDatabase
 resolveSettingsFileSafe :: IO FilePath
 resolveSettingsFileSafe = do
     found <- try defaultConfigFile :: IO (Either IOException FilePath)
-    pure (either (const "settings.toml") id found)
+    pure (fromRight "settings.toml" found)
 
 -- | 定位 IDE 设置文件，找不到就定下首个候选路径
 resolveUISettingsFileSafe :: IO FilePath
 resolveUISettingsFileSafe = do
     found <- try resolveUISettingsFile :: IO (Either IOException FilePath)
-    pure (either (const fallbackUISettingsFile) id found)
+    pure (fromRight fallbackUISettingsFile found)
   where
     fallbackUISettingsFile = case uiSettingsFileCandidates of
         (p : _) -> p
@@ -271,8 +273,8 @@ liveBodyLimit env = lvBodyLimit <$> readLive env
 -- | 组装 WAI 应用：路由外套四层中间件
 webApp :: AppEnv -> IO Application
 webApp env = do
-    started <- atomicModifyIORef' (aeReaperStarted env) (\old -> (True, old))
-    when (not started) $ do
+    started <- atomicModifyIORef' (aeReaperStarted env) (True,)
+    unless started $ do
         _ <- forkIO $ forever $ do
             threadDelay 60000000
             sweepWebSessions env
@@ -358,7 +360,7 @@ withDatabase env action = do
                 else do
                     editing <- header "X-ChuSQL-Edit"
                     req <- request
-                    let snapshotRead = editing /= Nothing && ((requestMethod req == "GET" && take 2 (pathInfo req) == ["api", "tables"])
+                    let snapshotRead = isJust editing && ((requestMethod req == "GET" && take 2 (pathInfo req) == ["api", "tables"])
                             || (requestMethod req == "POST" && pathInfo req == ["api", "normalization", "analyze"]))
                     console <- liftIO (readIORef (wsConsole ws))
                     caller <- consoleOwner
@@ -651,11 +653,11 @@ itemJson effectiveValues fileValues owner spec =
     fromProcess = Map.lookup (siKey spec) effectiveValues
     effectiveValue = fromMaybe (defaultOf (siKey spec)) fromProcess
     shownValue = if secret then "" else fromMaybe effectiveValue fromFile
-    hasValue = fromFile /= Nothing
+    hasValue = isJust fromFile
     source :: Text
     source
         | secret = if hasValue then "configured" else "not set"
-        | fromFile /= Nothing = "settings file"
+        | isJust fromFile = "settings file"
         | otherwise = "default"
 
 -- | 改设置：写配置文件并让可热改项立即生效
@@ -694,7 +696,7 @@ putSettingsH env = do
                                                 appliedNow = case reloaded of
                                                     Right _ -> nub (applied ++ [k | k <- policyKeys, Map.member k updates])
                                                     Left _ -> applied
-                                                needsRestart = [k | k <- Map.keys updates, not (k `elem` appliedNow), not (T.null (Map.findWithDefault "" k updates))]
+                                                needsRestart = [k | k <- Map.keys updates, k `notElem` appliedNow, not (T.null (Map.findWithDefault "" k updates))]
                                             liftIO (aeLog env ("settings updated by " <> user <> ": " <> T.intercalate ", " (Map.keys updates)))
                                             json
                                                 ( object
@@ -890,7 +892,7 @@ baseDeleteH _env ws target = do
 
 -- | 取一个列值
 lookupValue :: Text -> [(String, Value)] -> Maybe Value
-lookupValue name values = lookup (T.unpack name) values
+lookupValue name = lookup (T.unpack name)
 
 -- | 错误码 + 消息 → 状态码 + 统一错误体
 apiError :: Text -> Text -> ActionM a
@@ -1727,7 +1729,7 @@ executeSql ws live sql = do
                     , "rowCount" .= qrRowCount res
                     , "truncated" .= (qrTruncated res || qrRowCount res > lvMaxRows live)
                     , "database" .= qrDatabase res
-                    , "transaction" .= (transaction /= Nothing)
+                    , "transaction" .= isJust transaction
                     ]
                 )
 
@@ -1739,7 +1741,7 @@ requireUser env = wsUser <$> requireSession env
 requestSessionToken :: ActionM (Maybe Text)
 requestSessionToken = do
     rawHeader <- header "Cookie"
-    pure (fmap TL.toStrict rawHeader >>= \h -> parseCookieHeader sessionCookieName h)
+    pure (rawHeader >>= parseCookieHeader sessionCookieName . TL.toStrict)
 
 -- | 从 Cookie 头里取一个键（没有就给 Nothing）
 parseCookieHeader :: Text -> Text -> Maybe Text

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

@@ -8,6 +8,7 @@ module ChuSQL.Web.Secure (
     bodyLimitDynamic,
 ) where
 
+import Data.Maybe (isNothing)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BSC
 import Data.Text (Text)
@@ -28,7 +29,7 @@ import Network.Wai (Middleware, Request (..), mapResponseHeaders, responseLBS)
 -- | 所有响应都带上的安全头
 securityHeaders :: Middleware
 securityHeaders app req respond =
-    app req (respond . mapResponseHeaders (\headers -> filter (\(name, _) -> name /= "Content-Security-Policy" || lookup name headers == Nothing) extraHeaders ++ headers))
+    app req (respond . mapResponseHeaders (\headers -> filter (\(name, _) -> name /= "Content-Security-Policy" || isNothing (lookup name headers)) extraHeaders ++ headers))
 
 -- | 只给编辑器样式发随机 nonce
 contentSecurityPolicy :: Maybe Text -> Text

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

@@ -8,6 +8,7 @@ module ChuSQL.Web.UISettings (
     writeUISettings,
 ) where
 
+import Data.Maybe (fromMaybe)
 import Control.Exception (IOException, try)
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Key as K
@@ -40,7 +41,7 @@ resolveUISettingsFile = do
         Just path -> pure path
         Nothing -> do
             ready <- firstExistingDir uiSettingsFileCandidates
-            pure (maybe firstCandidate id ready)
+            pure (fromMaybe firstCandidate ready)
   where
     -- | 首选候选路径
     firstCandidate = case uiSettingsFileCandidates of

chusql-web/test/Spec.hs

@@ -34,8 +34,8 @@ import ChuSQL.Web.Static (contentTypeOf, safeRelative)
 import ChuSQL.Web.UISettings (validateUISettings)
 import Control.Concurrent (forkFinally, forkIO)
 import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
-import Control.Exception (IOException, bracket, throwIO, try)
-import Control.Monad (when)
+import Control.Exception (IOException, bracket, throwIO, try, bracket_)
+import Control.Monad (when, unless)
 import Data.Aeson (encode, object, (.=))
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Key as K
@@ -159,15 +159,15 @@ getAs hs path = requestAs methodGet path hs BL.empty
 
 -- | 带 JSON 头发 POST 请求
 postAs :: [Header] -> BS.ByteString -> BL.ByteString -> TestSession WT.SResponse
-postAs hs path payload = requestAs methodPost path (jsonHeaders hs) payload
+postAs hs path = requestAs methodPost path (jsonHeaders hs)
 
 -- | 带 JSON 头发 PUT 请求
 putAs :: [Header] -> BS.ByteString -> BL.ByteString -> TestSession WT.SResponse
-putAs hs path payload = requestAs "PUT" path (jsonHeaders hs) payload
+putAs hs path = requestAs "PUT" path (jsonHeaders hs)
 
 -- | 带 JSON 头发 PATCH 请求
 patchAs :: [Header] -> BS.ByteString -> BL.ByteString -> TestSession WT.SResponse
-patchAs hs path payload = requestAs "PATCH" path (jsonHeaders hs) payload
+patchAs hs path = requestAs "PATCH" path (jsonHeaders hs)
 
 -- | 带头发 DELETE 请求
 deleteAs :: [Header] -> BS.ByteString -> TestSession WT.SResponse
@@ -214,7 +214,7 @@ ensureDatabase hs name = do
     listed <- getAs hs "/api/databases"
     expectStatusWith "list databases" listed 200
     let names = map asText (items (jsonBody listed))
-    when (name `notElem` names) $ do
+    unless (name `elem` names) $ do
         created <- postAs hs "/api/databases" (encode (object ["name" .= name]))
         expectStatusWith ("create database " <> T.unpack name) created 200
 
@@ -224,7 +224,7 @@ ensureTable hs name body = do
     listed <- getAs (withDb testDatabaseName hs) "/api/tables"
     expectStatusWith "list tables" listed 200
     let names = map (asText . at "table") (items (jsonBody listed))
-    when (name `notElem` names) $ do
+    unless (name `elem` names) $ do
         created <- postAs (withDb testDatabaseName hs) "/api/tables" body
         expectStatusWith ("create table " <> T.unpack name) created 200
 
@@ -341,9 +341,7 @@ tempFilePath name = do
 
 -- | 非重复后缀
 uniqueSuffix :: IO String
-uniqueSuffix = do
-    u <- newUnique
-    pure (show (hashUnique u))
+uniqueSuffix = do show . hashUnique <$> newUnique
 
 -- | 文件不存在也算成功
 removeIfExists :: FilePath -> IO ()
@@ -723,8 +721,8 @@ catalogSpec env = describe "databases, tables and rows" $ do
             check (arrayLen (at "columns" (jsonBody rows)) `shouldBe` 3)
             check (arrayLen (at "rows" (jsonBody rows)) `shouldBe` 1)
             check (asInt (at "total" (jsonBody rows)) `shouldBe` 1)
-            check (asInt (maybe A.Null id (nth 0 (firstRow rows))) `shouldBe` 1)
-            check (asText (maybe A.Null id (nth 1 (firstRow rows))) `shouldBe` "alice")
+            check (asInt (fromMaybe A.Null (nth 0 (firstRow rows))) `shouldBe` 1)
+            check (asText (fromMaybe A.Null (nth 1 (firstRow rows))) `shouldBe` "alice")
             updated <-
                 patchAs
                     (withDb testDatabaseName hs)
@@ -732,7 +730,7 @@ catalogSpec env = describe "databases, tables and rows" $ do
                     (encode (object ["values" .= object ["note" .= ("changed" :: Text)]]))
             expectStatusWith "update row" updated 200
             again <- getAs (withDb testDatabaseName hs) "/api/tables/people/rows?limit=10"
-            check (asText (maybe A.Null id (nth 2 (firstRow again))) `shouldBe` "changed")
+            check (asText (fromMaybe A.Null (nth 2 (firstRow again))) `shouldBe` "changed")
         it "deletes the row and then the table" $ do
             hs <- adminHeaders
             ensureDatabase hs testDatabaseName
@@ -932,7 +930,7 @@ roleSpec env = describe "roles and grants" $ do
             listed <- getAs hs "/api/roles"
             expectStatusWith "list roles" listed 200
             let matching = [view | view <- items (jsonBody listed), asText (at "name" view) == "passer"]
-            check ((concatMap (map (asBool . at "grantable") . items . at "grants") matching) `shouldBe` [True])
+            check (concatMap (map (asBool . at "grantable") . items . at "grants") matching `shouldBe` [True])
             refused <-
                 postAs
                     hs
@@ -1047,11 +1045,11 @@ querySpec env = describe "the SQL console" $ do
             ensureDatabase hs testDatabaseName
             result <- testSql hs "SELECT LIST<Int>(1, 2), length('abc')"
             expectStatusWith "typed SQL values" result 200
-            let value = maybe A.Null id (nth 0 (firstRow result))
+            let value = fromMaybe A.Null (nth 0 (firstRow result))
                 envelope = at "__chusql_runtime_v1" value
             check (arrayLen envelope `shouldBe` 3)
-            check (asInt (maybe A.Null id (nth 0 (items envelope))) `shouldBe` 1)
-            check (asInt (maybe A.Null id (nth 1 (firstRow result))) `shouldBe` 3)
+            check (asInt (fromMaybe A.Null (nth 0 (items envelope))) `shouldBe` 1)
+            check (asInt (fromMaybe A.Null (nth 1 (firstRow result))) `shouldBe` 3)
         it "runs DDL and DML and returns positional rows" $ do
             hs <- adminHeaders
             ensureDatabase hs testDatabaseName
@@ -1063,7 +1061,7 @@ querySpec env = describe "the SQL console" $ do
             expectStatusWith "select by SQL" res 200
             check (asInt (at "rowCount" (jsonBody res)) `shouldBe` 1)
             check (arrayLen (at "columns" (jsonBody res)) `shouldBe` 2)
-            check (asText (maybe A.Null id (nth 1 (firstRow res))) `shouldBe` "seven")
+            check (asText (fromMaybe A.Null (nth 1 (firstRow res))) `shouldBe` "seven")
         it "refuses an empty statement" $ do
             hs <- adminHeaders
             ensureDatabase hs testDatabaseName
@@ -1267,10 +1265,10 @@ editSpec env = describe "web editing transactions" $ withApp (webApp env) $ do
         let token = fromMaybe "" (lookup "Cookie" hs >>= parseCookieHeader sessionCookieName . TE.decodeUtf8)
         stored <- liftIO (lookupPayload (aeSessions env) token)
         app <- getState
-        res <- liftIO $ bracket
-            (setPayloadPolicy (aeSessions env) (SessionPolicy (-1) 86400))
-            (const (setPayloadPolicy (aeSessions env) defaultSessionPolicy))
-            (const (editFromApp app hs "expires" []))
+        res <- liftIO $ bracket_
+                          (setPayloadPolicy (aeSessions env) (SessionPolicy (- 1) 86400))
+                          (setPayloadPolicy (aeSessions env) defaultSessionPolicy)
+                          (editFromApp app hs "expires" [])
         expectStatusWith "expired commit" res 401
         case stored of
             Nothing -> check (expectationFailure "missing live web session")