推进

chusql-server/app/Main.hs

@@ -2,6 +2,7 @@
 
 module Main (main) where
 
+import Control.Monad (when)
 import ChuSQL.Core.Engine.Storage.FFI (storageVersion)
 import ChuSQL.Core.Engine.Storage.IPC (closeConnection, localStorageLink, setStorageLink)
 import ChuSQL.Interface.Config (
@@ -22,7 +23,7 @@ import ChuSQL.Server.TCP (
     newServerEnv,
     runServer,
  )
-import Control.Exception (IOException, bracket, try)
+import Control.Exception (IOException, try, bracket_)
 import qualified Data.Aeson as A
 import qualified Data.Aeson.KeyMap as KM
 import Data.Text (Text)
@@ -177,7 +178,8 @@ run opts = do
                     (fromIntegral (wcLoginWindow cfg))
             env <- newServerEnv backend rootName configPath config limiter
             let announce port = putStrLn ("listening:    tcp://" ++ scHost config ++ ":" ++ show port)
-            bracket (pure link) (const closeConnection) (const (serve env announce))
+            bracket_
+              (pure link) closeConnection (serve env announce)
 
 -- | 起 TCP 服务并处理绑定失败
 serve :: ServerEnv -> (Int -> IO ()) -> IO ()
@@ -211,17 +213,17 @@ checkInitialized backend = do
 reportCredential :: Backend -> Text -> Bool -> IO ()
 reportCredential backend rootName legacy = do
     putStrLn ("administrator: " ++ T.unpack rootName)
-    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"
     passwordless <- administratorPasswordless backend rootName
-    if passwordless
-        then do
-            putStrLn "  !! the administrator has no password yet: sign in with an empty password, then set one"
-            putStrLn "  !!   ALTER USER root IDENTIFIED BY '...'   (or use the account page in the Web UI)"
-        else pure ()
+    when passwordless
+      $ do putStrLn
+             "  !! the administrator has no password yet: sign in with an empty password, then set one"
+           putStrLn
+             "  !!   ALTER USER root IDENTIFIED BY '...'   (or use the account page in the Web UI)"
 
 -- | 探测存储是否可用，答不上 ping 就退出
 checkStorage :: Backend -> IO ()
@@ -239,7 +241,7 @@ printBanner cfg config configPath = do
     version <- storageVersion
     putStrLn "================== ChuSQL Server ==================="
     putStrLn ("config file:  " ++ configPath)
-    putStrLn ("protocol:     chusql 1 (one JSON object per line)")
+    putStrLn "protocol:     chusql 1 (one JSON object per line)"
     putStrLn
         ( "limits:       message "
             ++ show (scMaxMessage config)

chusql-server/src/ChuSQL/Server/Accounts.hs

@@ -119,7 +119,7 @@ validateUserName name
 
 -- | 校验新身份的名称
 validateNewName :: Accounts -> Text -> Either AccountError ()
-validateNewName _ name = validateUserName name
+validateNewName _ = validateUserName
 
 storageFailure :: AccountError
 storageFailure = AccountError "storage_error" "account storage unavailable"
@@ -300,7 +300,7 @@ accountCommand _ = Nothing
 
 -- | 按目录管理权限执行账号命令
 runAccountCommand :: Accounts -> Principal -> AccountCommand -> IO (Either AccountError ())
-runAccountCommand service principal command = withMVar (acLock service) $ \_ -> run
+runAccountCommand service principal command = withMVar (acLock service) $ const run
   where
     -- | 校验并执行身份管理权限
     run
@@ -323,7 +323,7 @@ runAccountCommand service principal command = withMVar (acLock service) $ \_ ->
     privilegedChange (AlterAccountAttributes _ attributes) = any (\(key, _) -> key `elem` ["superuser", "system_catalog_manager", "allow_sudo_auth"]) attributes
     privilegedChange _ = False
     -- | 执行已授权的身份命令
-    execute = executeWith (if principalIsRoot principal then service else service{acBackend = (acBackend service){beAccounts = \request -> beAccounts (acBackend service) (ReqCatalogManage request)}})
+    execute = executeWith (if principalIsRoot principal then service else service{acBackend = (acBackend service){beAccounts = beAccounts (acBackend service) . ReqCatalogManage}})
     -- | 通过受限存储请求执行管理操作
     executeWith managed = case command of
         CreateAccount name _ | normalize name == "public" -> pure (Left (AccountError "bad_request" "public is reserved for default privileges"))

chusql-server/src/ChuSQL/Server/Backend.hs

@@ -21,6 +21,7 @@ module ChuSQL.Server.Backend (
     tableRefsOf,
 ) where
 
+import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
 import ChuSQL.Core.Engine (runStatement, runStatementM)
 import ChuSQL.Core.Model
 import ChuSQL.Core.Engine.Semantic (prepare)
@@ -40,7 +41,7 @@ import ChuSQL.Core.Engine.Storage.IPC (
 import ChuSQL.Core.Engine.Syntax.AST
 import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
 import ChuSQL.Core.Protocol (TxnOp (..))
-import Control.Concurrent.MVar (MVar, modifyMVar, readMVar)
+import Control.Concurrent.MVar (MVar, modifyMVar)
 import Data.List (nub, isPrefixOf)
 import Data.Text (Text)
 import Data.Time (getCurrentTime)
@@ -75,16 +76,20 @@ data Backend = Backend
 -- | 按给定列名取列，固定列顺序
 columnsFromStatement :: Database -> Statement -> [String]
 columnsFromStatement db stmt = case prepare db stmt of
-    Right (SelectDistinct q) -> columnsFromStatement db q
-    Right (Select items _ _ _ _ _) -> map fst items
-    Right ShowDomains -> ["domain", "base_type"]
-    _ -> []
+    Left _ -> []
+    Right resolved -> columnsOf resolved
+  where
+    -- | 从已准备的语句提取输出列名
+    columnsOf (SelectDistinct q) = columnsOf q
+    columnsOf Select{selectItems = items} = map fst items
+    columnsOf ShowDomains = ["domain", "base_type"]
+    columnsOf _ = []
 
 -- | 走本地存储链路的后端
 ipcBackend :: IO Backend
 ipcBackend = do
     let backend current = Backend
-            { beStatement = \sql -> runIpc current sql
+            { beStatement = runIpc current
             , beCatalog = do
                 response <- sendRequest (ReqInDatabase current ReqListCatalog)
                 pure $ case response of
@@ -107,7 +112,7 @@ ipcBackend = do
                     RespTables names -> Right names
                     RespError err -> Left err
                     _ -> Left "unexpected database response"
-            , beStorage = \payload -> runRaw payload
+            , beStorage = runRaw
             , beSnapshot = runIPCStorageIn snapshot (sessionEnv current)
             , beApplyTransaction = \ops -> do
                 response <- sendRequest (ReqInDatabase current (ReqApplyTransaction ops))
@@ -149,9 +154,9 @@ ipcBackend = do
                     cols <- case rows of
                         [] -> do
                             db <- runIPCStorageIn schema env
-                            pure (fmap (\structures -> columnsFromStatement structures stmt) db)
+                            pure (fmap (`columnsFromStatement` stmt) db)
                         (r : _) -> pure (Right (map fst r))
-                    pure (fmap (\names -> StatementResult names rows) cols)
+                    pure (fmap (`StatementResult` rows) cols)
 
 -- | 测试用内存后端，状态是一个 Database
 memoryBackend :: String -> MVar Database -> Backend
@@ -331,10 +336,12 @@ statementTables stmt = nub (case stmt of
     SelectDistinct q -> statementTables q
     Select{} ->
         tableRefsOf (selectFrom stmt)
-            ++ concatMap exprTables (maybe [] (: []) (selectWhere stmt) ++ map snd (selectItems stmt) ++ map Col (selectGroupBy stmt ++ map fst (selectOrderBy stmt)))
+            ++ concatMap exprTables (maybeToList (selectWhere stmt) ++ maybeToList (selectHaving stmt)
+                ++ map snd (selectItems stmt) ++ map Col (selectGroupBy stmt)
+                ++ mapMaybe (orderKeyExpression . fst) (selectOrderBy stmt))
     Insert table _ rows -> T.pack table : concatMap exprTables (concat rows)
-    Update table assigns cond -> T.pack table : concatMap exprTables (map snd assigns ++ maybe [] (: []) cond)
-    Delete table cond -> T.pack table : concatMap exprTables (maybe [] (: []) cond)
+    Update table assigns cond -> T.pack table : concatMap exprTables (map snd assigns ++ maybeToList cond)
+    Delete table cond -> T.pack table : concatMap exprTables (maybeToList cond)
     CreateTable table _ -> [T.pack table]
     DropTable table -> [T.pack table]
     CreateIndex table _ -> [T.pack table]
@@ -368,12 +375,12 @@ statementNeedsDatabase stmt = case stmt of
 -- | 将当前库限定的结构目标转为裸表名
 scopeDdl :: String -> Statement -> Either String Statement
 scopeDdl current statement = case statement of
-    CreateTable table columns -> (\key -> CreateTable key columns) <$> target table
+    CreateTable table columns -> (`CreateTable` columns) <$> target table
     DropTable table -> DropTable <$> target table
-    CreateIndex table column -> (\key -> CreateIndex key column) <$> target table
-    DropIndex table column -> (\key -> DropIndex key column) <$> target table
-    DropColumn table column -> (\key -> DropColumn key column) <$> target table
-    AddColumn table column -> (\key -> AddColumn key column) <$> target table
+    CreateIndex table column -> (`CreateIndex` column) <$> target table
+    DropIndex table column -> (`DropIndex` column) <$> target table
+    DropColumn table column -> (`DropColumn` column) <$> target table
+    AddColumn table column -> (`AddColumn` column) <$> target table
     RenameColumn table old new -> (\key -> RenameColumn key old new) <$> target table
     AlterColumnType table column ty -> (\key -> AlterColumnType key column ty) <$> target table
     AlterColumnDefault table column value -> (\key -> AlterColumnDefault key column value) <$> target table
@@ -554,10 +561,10 @@ memoryAccounts db stamp req = do
             | any ((== T.toLower u) . accountUser) accounts -> Left "identity already exists"
             | otherwise -> Right (accounts ++ [Account (highWater + 1) (T.toLower u) "" 1 stamp Nothing False False True False False])
         ReqIdentityAlter u login super enabled manager sudo -> case filter ((== T.toLower u) . accountUser) accounts of
-            [_] -> preserveSuper [if accountUser a == T.toLower u then a{accountCanLogin = maybe (accountCanLogin a) id login,
-                accountIsSuperuser = maybe (accountIsSuperuser a) id super, accountEnabled = maybe (accountEnabled a) id enabled,
-                accountSystemCatalogManager = maybe (accountSystemCatalogManager a) id manager,
-                accountAllowSudoAuth = maybe (accountAllowSudoAuth a) id sudo,
+            [_] -> preserveSuper [if accountUser a == T.toLower u then a{accountCanLogin = fromMaybe (accountCanLogin a) login,
+                accountIsSuperuser = fromMaybe (accountIsSuperuser a) super, accountEnabled = fromMaybe (accountEnabled a) enabled,
+                accountSystemCatalogManager = fromMaybe (accountSystemCatalogManager a) manager,
+                accountAllowSudoAuth = fromMaybe (accountAllowSudoAuth a) sudo,
                 accountRevision = accountRevision a + 1} else a | a <- accounts] accounts
             _ -> Left "unknown account"
         ReqAccountCreate u h

chusql-server/src/ChuSQL/Server/Catalog.hs

@@ -23,6 +23,7 @@ module ChuSQL.Server.Catalog
     , removeMember
     ) where
 
+import Control.Monad (void)
 import ChuSQL.Core.Model (Row, Value (..))
 import ChuSQL.Core.Protocol (Account (..), Request (..))
 import ChuSQL.Interface.Actions (escapeStringLiteral)
@@ -112,11 +113,11 @@ readIdentities catalog = beAccounts (catBackend catalog) ReqAccountsList
 
 -- | 新建一个角色
 insertRole :: Catalog -> Text -> IO (Either String ())
-insertRole catalog role = fmap (fmap (const ())) (beAccounts (catBackend catalog) (ReqRoleCreate (normalizeRole role)))
+insertRole catalog role = fmap void (beAccounts (catBackend catalog) (ReqRoleCreate (normalizeRole role)))
 
 -- | 删掉一个角色，连同它的授权与成员边
 dropRole :: Catalog -> Text -> IO (Either String ())
-dropRole catalog role = fmap (fmap (const ())) (beAccounts (catBackend catalog) (ReqAccountDrop (normalizeRole role)))
+dropRole catalog role = fmap void (beAccounts (catBackend catalog) (ReqAccountDrop (normalizeRole role)))
 
 -- | 全部授权，都不带 grant option
 readGrants :: Catalog -> IO (Either String [Grant])

chusql-server/src/ChuSQL/Server/Normalization.hs

@@ -2,6 +2,7 @@
 
 module ChuSQL.Server.Normalization (normalizationBudget, normalizationReport, schemaFingerprint) where
 
+import Data.Maybe (fromMaybe)
 import qualified ChuSQL.Core.Engine.Normalization as N
 import ChuSQL.Core.Model (Column (..), parseColumnType)
 import ChuSQL.Core.Protocol (SchemaColumn (..), valueToJSON)
@@ -40,7 +41,7 @@ normalizationBudget action = mask $ \restore -> do
                     Right value -> do
                         size <- evaluate (BL.length (BL.take 64001 (A.encode value)))
                         pure (if size > 64000 then Left ("too_large", "normalization report exceeds transport budget") else Right value)
-            pure (maybe (Left ("timeout", "normalization exceeded its five second budget")) id result)
+            pure (fromMaybe (Left ("timeout", "normalization exceeded its five second budget")) result)
 
 -- 编码只影响语义的列信息。
 fingerprintColumn :: SchemaColumn -> A.Value

chusql-server/src/ChuSQL/Server/ObjectACL.hs

@@ -6,6 +6,8 @@ module ChuSQL.Server.ObjectACL
     , objectSelfViews, objectReconcile, objectAffected, objectOwner, objectConnect, objectPrepareCreate, objectUsers
     ) where
 
+import Data.Either (fromRight)
+import Control.Monad (void)
 import ChuSQL.Core.Protocol (Account (..), TableInfo (..))
 import ChuSQL.Interface.Protocol (Grant (..))
 import ChuSQL.Server.Accounts (Principal, principalIsRoot, principalName)
@@ -79,12 +81,12 @@ identifier _ = Left "invalid object identifier"
 resolve :: Backend -> Text -> Text -> IO (Either String Target)
 resolve backend database raw = do
     let object = T.toLower (T.strip raw)
-        (selected, table, kind, label) =
-            if "database:" `T.isPrefixOf` object then (T.drop 9 object, Nothing, "database", object)
-            else if object == "*" || ".*" `T.isSuffixOf` object then
+        (selected, table, kind, label)
+            | "database:" `T.isPrefixOf` object = (T.drop 9 object, Nothing, "database", object)
+            | object == "*" || ".*" `T.isSuffixOf` object =
                 let scope = if object == "*" then database else T.dropEnd 2 object
                 in (scope, Nothing, "tables", scope <> ".*")
-            else case T.splitOn "." object of
+            | otherwise = case T.splitOn "." object of
                 [name] -> (database, Just name, "table", database <> "." <> name)
                 [db, name] -> (db, Just name, "table", object)
                 _ -> ("", Just "", "table", object)
@@ -102,7 +104,7 @@ targets backend = do
     names <- beDatabases backend
     case names of
         Left err -> pure (Left err)
-        Right databases -> fmap (fmap concat . sequence) $ mapM one (filter (/= "system") databases)
+        Right databases -> fmap concat . sequence <$> mapM one (filter (/= "system") databases)
   where
     -- 展开一个数据库和它的表。
     one name = do
@@ -150,7 +152,12 @@ knownRole env value = value `elem` ["0", "public"] || any (\account -> T.pack (s
 roles :: Context -> Text -> [Text]
 roles env value = nub ("public" : go [value])
   where
-    pairs = [(parent, child) | (parentName, childName) <- contextMembers env, Right parent <- [roleId env parentName], Right child <- [roleId env childName], active env parent, active env child]
+    pairs = [(parent, child) |
+               (parentName, childName) <- contextMembers env,
+               Right parent <- [roleId env parentName],
+               active env parent,
+               Right child <- [roleId env childName],
+               active env child]
     -- 展开成员关系的向上闭包。
     go known = let more = [parent | (parent, child) <- pairs, child `elem` known, parent `notElem` known]
                in if null more then known else go (nub (known ++ more))
@@ -208,7 +215,7 @@ readACL backend = do
 
 -- 原子写入权限快照并检查并发版本。
 writeACL :: Backend -> Maybe Text -> ACL -> IO (Either String ())
-writeACL backend expected acl = fmap (fmap (const ())) $ request backend (A.object ["method" A..= ("object_acl_replace" :: Text), "expected" A..= expected, "payload" A..= TE.decodeUtf8 (BL.toStrict (A.encode acl))])
+writeACL backend expected acl = void <$> request backend (A.object ["method" A..= ("object_acl_replace" :: Text), "expected" A..= expected, "payload" A..= TE.decodeUtf8 (BL.toStrict (A.encode acl))])
 
 -- 将旧名称授权一次性绑定到现存对象。
 migrate :: Backend -> Catalog -> Context -> IO (Either String ACL)
@@ -269,7 +276,10 @@ privileges target names =
     if all (`elem` supported) expanded then Right expanded else Left "invalid privilege for object scope"
   where
     supported = if targetKind target == "database" then ["connect", "create"] else ["select", "insert", "update", "delete"]
-    expanded = nub (concatMap (\name -> if name == "all" then supported else [name]) (map T.toLower names))
+    expanded = nub (concatMap
+                      ((\ name -> if name == "all" then supported else [name])
+                         . T.toLower)
+                      names)
 
 -- 检查一组稳定对象上的业务权限。
 objectAuthorize :: Backend -> Catalog -> Principal -> Text -> [(Text, Text)] -> IO (Either String ())
@@ -299,8 +309,11 @@ objectGrant backend catalog principal database names object role option = do
         Right ((env, previous, acl), target) -> case do
             recipient <- roleId env role
             items <- privileges target names
-            grantor <- if principalIsRoot principal then Right (either (const "0") id (roleId env (principalName principal))) else roleId env (principalName principal)
-            case [item | item <- items, not (principalIsRoot principal), not (allowed env acl grantor target item True)] of
+            grantor <- if principalIsRoot principal then Right (fromRight "0" (roleId env (principalName principal))) else roleId env (principalName principal)
+            case [item |
+                    not (principalIsRoot principal),
+                    item <- items,
+                    not (allowed env acl grantor target item True)] of
                 item : _ -> Left ("grant option required: " ++ T.unpack (T.toUpper item <> " ON " <> object))
                 [] -> Right (recipient, grantor, items) of
                     Left err -> pure (Left err)

chusql-server/src/ChuSQL/Server/Policy.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
+
 
 module ChuSQL.Server.Policy (
     configurePasswordPolicy,

chusql-server/src/ChuSQL/Server/Privileges.hs

@@ -6,11 +6,12 @@ module ChuSQL.Server.Privileges
     , newPrivileges, normalizeObject, privilegeCommand, runPrivilegeCommand, claimObject, prepareObject, reconcileObjects, affectedObject
     ) where
 
+import Data.Maybe (maybeToList)
 import ChuSQL.Core.Engine.Syntax.AST
 import ChuSQL.Core.Protocol (Account (..))
 import ChuSQL.Interface.Protocol (Grant (..), RoleView (..))
 import ChuSQL.Server.Accounts (Principal, principalIsRoot, principalIsCatalogManager)
-import ChuSQL.Server.Backend (Backend (..), exprTables, tableRefsOf, systemDatabaseName)
+import ChuSQL.Server.Backend (Backend (..), exprTables, statementTables, systemDatabaseName)
 import ChuSQL.Server.Catalog
 import qualified ChuSQL.Server.ObjectACL as OA
 import Data.List (nub, sort)
@@ -70,7 +71,7 @@ runPrivilegeCommand service principal database command = withTables service $ ca
                     Left err -> pure (Left err)
                     Right () -> eachAction members $ \member -> if (normalizeRole role, normalizeUser member) `elem` pairs then pure (Right ()) else catalog (addMember directory role member)
     RevokeRoleCommand role members
-        | principalIsRoot principal -> after (eachAction members (\member -> catalog (removeMember directory role member)))
+        | principalIsRoot principal -> after (eachAction members (catalog . removeMember directory role))
     _ -> pure (Left forbidden)
   where
     backend = pvBackend service
@@ -146,7 +147,7 @@ authorizeConnect service principal database
 authorizeTables :: Privileges -> Principal -> Text -> [(Text, Text)] -> IO (Either PrivilegeError ())
 authorizeTables service principal database needed
     | principalIsRoot principal = pure (Right ())
-    | T.null database && any (not . T.isPrefixOf "database:" . fst) needed = pure (Left (PrivilegeError "no_database" "no database selected"))
+    | T.null database && (not . all (T.isPrefixOf "database:" . fst)) needed = pure (Left (PrivilegeError "no_database" "no database selected"))
     | otherwise = withTables service $ do
         connected <- if T.null database then pure (Right ()) else catalog (OA.objectConnect (pvBackend service) (pvCatalog service) principal database)
         case connected of Left err -> pure (Left err); Right () -> catalog (OA.objectAuthorize (pvBackend service) (pvCatalog service) principal database needed)
@@ -172,7 +173,12 @@ listRoleViews service = withTables service $ do
     members <- catalog (readMembers (pvCatalog service))
     case (,) <$> names <*> members of
         Left err -> pure (Left err)
-        Right (identities, pairs) -> fmap sequence $ mapM (view pairs) (sort (map accountUser (filter (not . accountCanLogin) identities)))
+        Right (identities, pairs) -> sequence
+                                       <$>
+                                         mapM
+                                           (view pairs)
+                                           (sort
+                                              (map accountUser (filter (not . accountCanLogin) identities)))
   where
     -- 组装一个角色的公开权限视图。
     view members name = do
@@ -199,14 +205,12 @@ reconcileObjects service = withTables service (catalog (OA.objectReconcile (pvBa
 requiredActions :: Statement -> Maybe [(Text, Text)]
 requiredActions statement = case statement of
     SelectDistinct q -> requiredActions q
-    Select{} -> Just (selectNeeds (selectFrom statement) (maybe [] (: []) (selectWhere statement) ++ map snd (selectItems statement)))
+    Select{} -> Just [(ref, "select") | ref <- statementTables statement]
     Insert table _ rows -> Just ((T.pack table, "insert") : selectsOf (concat rows))
-    Update table assignments condition -> Just ((T.pack table, "update") : selectsOf (map snd assignments ++ maybe [] (: []) condition))
-    Delete table condition -> Just ((T.pack table, "delete") : selectsOf (maybe [] (: []) condition))
+    Update table assignments condition -> Just ((T.pack table, "update") : selectsOf (map snd assignments ++ maybeToList condition))
+    Delete table condition -> Just ((T.pack table, "delete") : selectsOf (maybeToList condition))
     _ -> Nothing
   where
-    -- 收集来源树和表达式的读取权限。
-    selectNeeds source expressions = [(ref, "select") | ref <- nub (tableRefsOf source)] ++ selectsOf expressions
     -- 收集表达式中子查询的读取权限。
     selectsOf expressions = [(ref, "select") | ref <- nub (concatMap exprTables expressions)]
 
@@ -218,7 +222,7 @@ withTables service action = withCatalogLock (pvCatalog service) $ do
 
 -- 将目录结果转换为权限错误。
 catalog :: IO (Either String a) -> IO (Either PrivilegeError a)
-catalog action = fmap (either (Left . storageError) Right) action
+catalog = fmap (either (Left . storageError) Right)
 
 -- 分类稳定对象目录的明确错误。
 storageError :: String -> PrivilegeError

chusql-server/src/ChuSQL/Server/Security.hs

@@ -1,5 +1,6 @@
 module ChuSQL.Server.Security (readSecurity, writeSecurity) where
 
+import Control.Monad (when)
 import Control.Concurrent.MVar
 import Control.Exception (bracket_, mask_)
 import System.IO.Unsafe (unsafePerformIO)
@@ -21,11 +22,11 @@ readSecurity = bracket_ enter leave
     (turn, room, readers) = securityGate
     -- 登记共享读取者。
     enter = withMVar turn $ \_ -> modifyMVar_ readers $ \count -> do
-        if count == 0 then takeMVar room else pure ()
+        when (count == 0) $ takeMVar room
         pure (count + 1)
     -- 释放最后一个共享读取者。
     leave = mask_ $ modifyMVar_ readers $ \count -> do
-        if count == 1 then putMVar room () else pure ()
+        when (count == 1) $ putMVar room ()
         pure (count - 1)
 
 -- 独占执行权限或对象变更。

chusql-server/src/ChuSQL/Server/Session.hs

@@ -29,12 +29,17 @@ module ChuSQL.Server.Session
     ) where
 
 import ChuSQL.Core.Model (Database, Row, Table (..), Value (..), Column (..), typeName)
-import ChuSQL.Core.Protocol (SchemaColumn (..))
+import ChuSQL.Core.Protocol
+    ( SchemaColumn(..),
+      Account(..),
+      Request(..),
+      QueryResult(..),
+      TxnOp(..),
+      queryResultJson )
 import ChuSQL.Interface.Normalization
 import ChuSQL.Server.Normalization (normalizationBudget, normalizationReport)
 import Data.Aeson.Types (parseEither)
 import qualified Data.ByteString.Lazy as BL
-import ChuSQL.Core.Protocol (Account (..), Request (..), QueryResult (..), TxnOp (..), queryResultJson)
 import ChuSQL.Core.Engine.Storage.IPC (TableInfo (..))
 import qualified ChuSQL.Core.Engine as Engine
 import qualified ChuSQL.Core.Engine.Error as E
@@ -51,7 +56,7 @@ import Control.Exception (IOException, try)
 import Data.Bifunctor (first)
 import Data.Char (isAlpha, isAlphaNum)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
-import Data.Maybe (isJust)
+import Data.Maybe (isJust, fromMaybe)
 import qualified Data.IntMap.Strict as IM
 import qualified Data.IntSet as IS
 import Data.Text (Text)
@@ -831,7 +836,7 @@ privilegeMessage (PrivilegeError _ message) = message
 
 -- | 只带库名的空结果
 emptyResult :: Maybe Text -> QueryResult
-emptyResult database = QueryResult [] [] 0 False database
+emptyResult = QueryResult [] [] 0 False
 
 -- | 存储结果转成查询结果
 resultOf :: StatementResult -> QueryResult
@@ -845,7 +850,7 @@ resultOf result =
         }
   where
     -- | 按列名取单元格
-    cellOf row name = maybe VNull id (lookup name row)
+    cellOf row name = fromMaybe VNull (lookup name row)
 
 
 -- 展示当前登录身份自己的有效权限。

chusql-server/src/ChuSQL/Server/TCP.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module ChuSQL.Server.TCP (
@@ -29,12 +31,12 @@ import ChuSQL.Server.Privileges (newPrivileges, reconcileObjects)
 import Control.Concurrent (forkIO)
 import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
 import Control.Exception (IOException, bracket, finally, onException, try)
-import Control.Monad (filterM, void)
+import Control.Monad (filterM, void, when)
 import qualified Data.ByteString.Char8 as BSC
 import qualified Data.ByteString.Lazy.Char8 as BLC
 import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
 import qualified Data.Map.Strict as Map
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isNothing)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Network.Socket (
@@ -171,12 +173,15 @@ enableSudo :: ServerEnv -> Int -> IO ()
 enableSudo env port
     | T.null user = pure ()
     | not (isPlainIdentifier user) = ioError (userError "sudo_auth_user must be a plain identity name")
-    | otherwise = modifyMVar_ (srvSudo env) $ \current -> case current of
-        Just _ -> ioError (userError "sudo authentication is already running")
-        Nothing -> do
-            credential <- createSudoCredential port
-            hPutStrLn stderr ("sudo_auth enabled: local elevated identity -> " ++ T.unpack user)
-            pure (Just (port, user, credential))
+    | otherwise = modifyMVar_ (srvSudo env) $ \case
+                                                Just _
+                                                  -> ioError (userError "sudo authentication is already running")
+                                                Nothing
+                                                  -> do credential <- createSudoCredential port
+                                                        hPutStrLn
+                                                          stderr
+                                                          ("sudo_auth enabled: local elevated identity -> " ++ T.unpack user)
+                                                        pure (Just (port, user, credential))
   where
     user = scSudoUser (srvConfig env)
 
@@ -254,7 +259,7 @@ serveConnection env conn = do
     hSetNewlineMode h noNewlineTranslation
     entry <- newLiveEntry (isLocalPeer peer)
     unregister <- registerConnection (srvLive env) entry
-    session <- newSessionWith (srvBackend env) (srvRootName env) (srvSettingsFile env) (\names -> void (dropConnectionsOf (srvLive env) names))
+    session <- newSessionWith (srvBackend env) (srvRootName env) (srvSettingsFile env) (void . dropConnectionsOf (srvLive env))
     outcome <- try (loop h session entry BSC.empty `finally` unregister) :: IO (Either IOException ())
     case outcome of
         Left err | not (isEOFError err) -> hPutStrLn stderr ("connection error: " ++ show err)
@@ -275,7 +280,7 @@ serveConnection env conn = do
                         else do
                             (response, keepGoing) <- dispatch env session entry request
                             send h response
-                            if keepGoing then loop h session entry remaining else pure ()
+                            when keepGoing $ loop h session entry remaining
     -- | 发一条响应并冲缓冲
     send h response = do
         BLC.hPutStr h (encodeResponse response)
@@ -322,7 +327,7 @@ dispatch env session entry request = case request of
         configured <- readMVar (srvSudo env)
         who <- sessionUser session
         case configured of
-            Just _ | leLocal entry && who == Nothing -> do
+            Just _ | leLocal entry && isNothing who -> do
                 nonce <- sudoChallenge
                 now <- getCurrentTime
                 writeIORef (leChallenge entry) (Just (nonce, now))
@@ -376,13 +381,13 @@ dispatch env session entry request = case request of
 -- 消费一次性证明并登录本机映射账号。
 sudoLogin :: ServerEnv -> Session -> LiveEntry -> Text -> Text -> IO ServerResponse
 sudoLogin env session entry user proof = do
-    challenge <- atomicModifyIORef' (leChallenge entry) (\value -> (Nothing, value))
+    challenge <- atomicModifyIORef' (leChallenge entry) (Nothing,)
     configured <- readMVar (srvSudo env)
     now <- getCurrentTime
     who <- sessionUser session
     let key = T.toLower (T.strip user)
         mapped = maybe "" (\(_, name, _) -> name) configured
-        valid = leLocal entry && who == Nothing && key == mapped
+        valid = leLocal entry && isNothing who && key == mapped
             && case configured of
                 Just (_, _, credential) -> validSudoChallenge credential now challenge key proof
                 Nothing -> False

chusql-server/test/Spec.hs

@@ -3,6 +3,7 @@
 
 module Main (main) where
 
+import Data.Either (lefts)
 import ChuSQL.Core.Engine.Storage.IPC (
     Account (..),
     Request (ReqAccountCreate, ReqAccountReset, ReqAccountsList, ReqIdentityAlter),
@@ -55,7 +56,7 @@ import Control.Concurrent (forkIO, forkFinally, killThread, threadDelay)
 import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, takeMVar)
 import System.Timeout (timeout)
 import Control.Exception (IOException, bracket, finally, try)
-import Control.Monad (replicateM_, void)
+import Control.Monad (replicateM_, void, (>=>), when)
 import Data.List (sort)
 import Data.Aeson (decode)
 import qualified Data.Aeson as A
@@ -244,7 +245,9 @@ identitySpec = describe "unified identities" $ do
             asText (at "status" shown) `shouldBe` "result"
             switched <- tcpQuery manager "use system"
             asText (at "status" switched) `shouldBe` "result"
-            mapM_ (\sql -> tcpQuery manager sql >>= \reply -> asText (at "code" reply) `shouldBe` "forbidden")
+            mapM_ (tcpQuery manager
+                     >=>
+                       (\ reply -> asText (at "code" reply) `shouldBe` "forbidden"))
                 ["alter user manager superuser", "alter user managed system_catalog_manager", "alter user managed allow_sudo_auth", "alter user admin identified by 'Another-Pass123!'", "create database forbidden"]
     it "does not inherit catalog management through role membership" $ withTcpServer defaultServerConfig $ \_ handle ->
         withConnection handle $ \admin -> withConnection handle $ \worker -> do
@@ -309,7 +312,9 @@ identitySpec = describe "unified identities" $ do
     it "protects the last enabled login superuser" $ withTcpServer defaultServerConfig $ \_ handle ->
         withConnection handle $ \h -> do
             _ <- tcpLogin h "admin" "s3cret"
-            mapM_ (\sql -> tcpQuery h sql >>= \reply -> asText (at "code" reply) `shouldBe` "bad_request")
+            mapM_ (tcpQuery h
+                     >=>
+                       (\ reply -> asText (at "code" reply) `shouldBe` "bad_request"))
                 ["alter user admin disabled", "alter role admin nologin", "alter user admin nosuperuser", "drop user admin", "drop role admin"]
             shown <- tcpQuery h "show roles"
             asText (at "status" shown) `shouldBe` "result"
@@ -406,7 +411,7 @@ testRootPassword = "s3cret"
 
 -- | 口令哈希：迭代次数压低，跑得快
 testPasswordHash :: Text -> Text
-testPasswordHash raw = hashPasswordWith 1000 (BS.replicate 16 7) raw
+testPasswordHash = hashPasswordWith 1000 (BS.replicate 16 7)
 
 -- 小工具
 
@@ -461,7 +466,8 @@ tempSettingsPath name = do
 removeIfExists :: FilePath -> IO ()
 removeIfExists path = do
     there <- doesFileExist path
-    if there then void (try (removeFile path) :: IO (Either IOException ())) else pure ()
+    when there
+      $ void (try (removeFile path) :: IO (Either IOException ()))
 
 -- | 起一台内存后端的测试服务器：管理员已设口令 `s3cret`
 withTcpServer :: ServerConfig -> (ServerEnv -> ServerHandle -> IO a) -> IO a
@@ -485,7 +491,7 @@ withTcpServerAs password config body = do
 
 -- | 连上服务器并配成行缓冲句柄
 withConnection :: ServerHandle -> (Handle -> IO a) -> IO a
-withConnection handle body = bracket open closeQuietly body
+withConnection handle = bracket open closeQuietly
   where
     -- | 关连接，忽略异常
     closeQuietly h = do
@@ -893,9 +899,9 @@ privilegeSpec = describe "server privileges" $ do
         _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
         _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["all"] "*" "reader" False)
         views <- listRoleViews service
-        fmap (concatMap (map grantPrivilege) . map roleGrants) views
+        fmap (concatMap (map grantPrivilege . roleGrants)) views
             `shouldBe` Right ["select", "insert", "update", "delete"]
-        fmap (concatMap (map grantObject) . map roleGrants) views `shouldBe` Right (replicate 4 "test.*")
+        fmap (concatMap (map grantObject . roleGrants)) views `shouldBe` Right (replicate 4 "test.*")
 
     it "revokes a privilege again" $ withPrivileges $ \service root -> do
         _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
@@ -1061,6 +1067,16 @@ privilegeSpec = describe "server privileges" $ do
         authorizeSql service (Ordinary testAccount) "SELECT name FROM users WHERE id > ANY (SELECT id FROM orders)"
             `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON orders")
 
+    it "requires SELECT on subqueries in HAVING and expression ordering" $ withPrivileges $ \service root -> do
+        _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
+        _ <- runPrivilegeCommand service root testDatabase (GrantPrivilegesCommand ["select"] "users" "reader" False)
+        _ <- runPrivilegeCommand service root testDatabase (GrantRoleCommand "reader" ["alice"])
+        mapM_ (\sql -> authorizeSql service (Ordinary testAccount) sql
+            `shouldReturn` Left (PrivilegeError "forbidden" "permission denied: SELECT ON orders"))
+            [ "SELECT COUNT(*) FROM users HAVING COUNT(*) > (SELECT COUNT(*) FROM orders)"
+            , "SELECT name FROM users ORDER BY (SELECT COUNT(*) FROM orders) + id"
+            ]
+
     it "lists the accounts a role change touches, members included" $ withPrivileges $ \service root -> do
         _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "reader")
         _ <- runPrivilegeCommand service root testDatabase (CreateRoleCommand "inner")
@@ -1202,7 +1218,8 @@ objectPrivilegeSpec = describe "stable object privileges" $ do
         finished <- newEmptyMVar
         revoked <- newEmptyMVar
         let slow = backend{beWithDatabase = \name -> (beWithDatabase backend name){beStatement = \sql -> do
-                if sql == "SELECT * FROM users" then putMVar started () >> takeMVar release else pure ()
+                when (sql == "SELECT * FROM users")
+                  $ putMVar started () >> takeMVar release
                 beStatement (beWithDatabase backend name) sql}}
         settings <- tempSettingsPath "permission-race"
         reader <- newSession slow testRootName settings
@@ -1501,11 +1518,11 @@ sessionAge session wanted = do
 
 -- | 取失败里的文案
 failureMessage :: Either SessionError QueryResult -> Text
-failureMessage outcome = either sessMessage (const "") outcome
+failureMessage = either sessMessage (const "")
 
 -- | 取失败里的错误码
 failureCode :: Either SessionError QueryResult -> Text
-failureCode outcome = either sessCode (const "") outcome
+failureCode = either sessCode (const "")
 
 -- | 取结果第一列的整数
 intValues :: [[Value]] -> [Int]
@@ -1556,7 +1573,7 @@ transactionSpec = describe "server transactions" $ do
         tables <- beCatalog backend
         fmap (map tiTable) tables `shouldBe` Right ["users"]
         updated <- beStatement backend "UPDATE users SET id = 3"
-        fmap (const ()) updated `shouldBe` Right ()
+        void updated `shouldBe` Right ()
         snapshot <- beSnapshot (memoryBackend "other" ref)
         fmap (map (tableRows . snd)) snapshot `shouldBe` Right [[[ ("id", VInt 2) ]]]
     it "keeps catalog and snapshot identities stable across system views and replacements" $ do
@@ -1574,11 +1591,11 @@ transactionSpec = describe "server transactions" $ do
     it "preserves memory schema versions in catalogs and snapshots" $ do
         ref <- newMVar []
         let backend = memoryBackend "test" ref
-        fmap (const ()) <$> beStatement backend "CREATE TABLE versioned (id INT)" `shouldReturn` Right ()
+        void <$> beStatement backend "CREATE TABLE versioned (id INT)" `shouldReturn` Right ()
         first <- beCatalog backend
         fmap (map tiSchemaVersion) first `shouldBe` Right [Just 1]
-        fmap (const ()) <$> beStatement backend "ALTER TABLE versioned ADD COLUMN extra TEXT" `shouldReturn` Right ()
-        fmap (const ()) <$> beStatement backend "ALTER TABLE versioned DROP COLUMN extra" `shouldReturn` Right ()
+        void <$> beStatement backend "ALTER TABLE versioned ADD COLUMN extra TEXT" `shouldReturn` Right ()
+        void <$> beStatement backend "ALTER TABLE versioned DROP COLUMN extra" `shouldReturn` Right ()
         current <- beCatalog backend
         snapshot <- beSnapshot backend
         fmap (map tiSchemaVersion) current `shouldBe` Right [Just 3]
@@ -1687,6 +1704,23 @@ transactionSpec = describe "server transactions" $ do
         late <- runStatementCoded session "commit"
         failureMessage late `shouldBe` "no transaction in progress"
 
+    it "rejects UPDATE constraints without changing or ending the transaction" $ withMemorySession $ \session -> do
+        _ <- mustSql session "CREATE TABLE constrained_updates (id INT PRIMARY KEY, qty INT NOT NULL UNIQUE)"
+        _ <- mustSql session "INSERT INTO constrained_updates (id, qty) VALUES (1, 2), (2, 3)"
+        _ <- mustSql session "BEGIN"
+        mapM_ (\(query, marker) -> do
+            result <- runStatementCoded session query
+            failureMessage result `shouldSatisfy` T.isInfixOf marker)
+            [("UPDATE constrained_updates SET qty = NULL WHERE id = 1", "NOT NULL")
+            , ("UPDATE constrained_updates SET qty = 3 WHERE id = 1", "UNIQUE")
+            , ("UPDATE constrained_updates SET id = 2 WHERE id = 1", "UNIQUE")]
+        unchanged <- mustSql session "SELECT qty FROM constrained_updates ORDER BY id"
+        intValues (qrRows unchanged) `shouldBe` [2, 3]
+        _ <- mustSql session "UPDATE constrained_updates SET qty = qty + 1"
+        _ <- mustSql session "COMMIT"
+        committed <- mustSql session "SELECT qty FROM constrained_updates ORDER BY id"
+        intValues (qrRows committed) `shouldBe` [3, 4]
+
     it "does not switch database inside a transaction" $ withMemorySession $ \session -> do
         _ <- mustSql session "begin"
         denied <- runStatementCoded session "use other"
@@ -1880,10 +1914,10 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
         let alpha = beWithDatabase base "alpha"
             beta = beWithDatabase base "beta"
         unselected <- beStatement base "CREATE TABLE alpha.t (id INT)"
-        fmap (const ()) unselected `shouldBe` Left "no database selected"
+        void unselected `shouldBe` Left "no database selected"
         mustRun (beStatement alpha "CREATE TABLE alpha.t (id INT, value INT)")
         duplicate <- beStatement alpha "CREATE TABLE t (id INT)"
-        fmap (const ()) duplicate `shouldSatisfy` either (const True) (const False)
+        void duplicate `shouldSatisfy` either (const True) (const False)
         mustRun (beStatement alpha "INSERT INTO t (id, value) VALUES (1, 7)")
         mustRun (beStatement alpha "CREATE INDEX ON alpha.t (value)")
         mustRun (beStatement alpha "DROP INDEX ON alpha.t (value)")
@@ -1894,7 +1928,7 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
         rows <- rowsOf (beStatement alpha "SELECT score FROM t")
         intColumn "score" rows `shouldBe` [7]
         crossed <- beStatement beta "DROP TABLE alpha.t"
-        fmap (const ()) crossed `shouldBe` Left "DDL target is outside the current database: alpha.t"
+        void crossed `shouldBe` Left "DDL target is outside the current database: alpha.t"
         mustRun (beStatement alpha "ALTER TABLE alpha.t DROP COLUMN score")
         mustRun (beStatement alpha "DROP TABLE alpha.t")
         catalog <- beCatalog alpha >>= either fail pure
@@ -1903,7 +1937,7 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
     it "isolates domain catalogs by database and hides them from table lists" $ withIpcStorage $ do
         base <- ipcBackend
         unselected <- beStatement base "SHOW DOMAINS"
-        fmap (const ()) unselected `shouldBe` Left "no database selected"
+        void unselected `shouldBe` Left "no database selected"
         mustRun (beStatement base "CREATE DATABASE alpha")
         mustRun (beStatement base "CREATE DATABASE beta")
         let alpha = beWithDatabase base "alpha"
@@ -1919,7 +1953,7 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
         domains <- rowsOf (beStatement beta "SHOW DOMAINS")
         domains `shouldBe` [[("domain", VStr "code"), ("base_type", VStr "varchar(3)")]]
         refused <- beStatement beta "INSERT INTO typed (id) VALUES (1)"
-        fmap (const ()) refused `shouldSatisfy` either (const True) (const False)
+        void refused `shouldSatisfy` either (const True) (const False)
 
     it "resolves nested domains only inside their own database" $ withIpcStorage $ do
         base <- ipcBackend
@@ -1930,12 +1964,12 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
         mustRun (beStatement alpha "CREATE DOMAIN label AS VARCHAR(3)")
         mustRun (beStatement alpha "CREATE DOMAIN product_label AS label")
         absent <- beStatement beta "CREATE DOMAIN product_label AS label"
-        fmap (const ()) absent `shouldBe` Left "unknown domain: label"
+        void absent `shouldBe` Left "unknown domain: label"
         mustRun (beStatement alpha "CREATE TABLE products (name product_label)")
         mustRun (beStatement alpha "INSERT INTO products (name) VALUES ('abc')")
         rowsOf (beStatement alpha "SELECT name FROM products") `shouldReturn` [[("name", VStr "abc")]]
         dependency <- beStatement alpha "DROP DOMAIN label"
-        fmap (const ()) dependency `shouldSatisfy` either (const True) (const False)
+        void dependency `shouldSatisfy` either (const True) (const False)
 
     it "keeps two databases apart" $ withIpcStorage $ do
         base <- ipcBackend
@@ -1965,7 +1999,7 @@ ipcConcurrencySpec = describe "server backend on the real storage" $ do
         _ <- forkIO (writeRows alpha [1 .. 20] doneA)
         _ <- forkIO (writeRows beta [101 .. 120] doneB)
         outs <- sequence [takeMVar doneA, takeMVar doneB]
-        [err | Left err <- concat outs] `shouldBe` []
+        lefts (concat outs) `shouldBe` []
         rowsA <- rowsOf (beStatement alpha "SELECT id FROM p")
         rowsB <- rowsOf (beStatement beta "SELECT id FROM p")
         intColumn "id" rowsA `shouldMatchList` [1 .. 20]