v26.10.1 正式版

修复部分问题，优化性能，进一步推进类型系统

chusql-interface/src/ChuSQL/Interface/Actions.hs

@@ -34,6 +34,9 @@ module ChuSQL.Interface.Actions (
 
 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 qualified Data.Aeson as A
 import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
 import Data.List (intercalate)
@@ -88,24 +91,50 @@ columnTypeOf = fmap plainColumn . parseColumnType . T.unpack . T.strip
 
 -- | 本地类型转线上名字
 columnTypeName :: Column -> Text
-columnTypeName = T.pack . typeName . columnType
+columnTypeName column = T.pack $ case columnType column of
+    CRuntime tid -> renderTypeExpr (typeExpression tid)
+    ty -> typeName ty
 
 -- | 字符串字面量转义：单引号翻倍（引擎的词法器就是这么折回去的）
 escapeStringLiteral :: String -> String
 escapeStringLiteral = concatMap (\c -> if c == '\'' then "''" else [c])
 
 -- | 值转 SQL 字面量
-sqlLiteral :: Value -> String
-sqlLiteral VNull = "NULL"
-sqlLiteral (VInt n) = show n
-sqlLiteral (VFloat d) = show d
-sqlLiteral (VStr s) = "'" ++ escapeStringLiteral s ++ "'"
-sqlLiteral (VBool True) = "TRUE"
-sqlLiteral (VBool False) = "FALSE"
+sqlLiteral :: Value -> Either String String
+sqlLiteral VNull = Right "NULL"
+sqlLiteral (VInt n) = Right (show n)
+sqlLiteral (VFloat d)
+    | isNaN d || isInfinite d = Left "SQL floating literal must be finite"
+    | otherwise = Right (show d)
+sqlLiteral (VStr s) = Right ("'" ++ escapeStringLiteral s ++ "'")
+sqlLiteral (VBool True) = Right "TRUE"
+sqlLiteral (VBool False) = Right "FALSE"
+sqlLiteral (VRuntime tid value) = do
+    validateValue builtinTypes tid value
+    runtimeLiteral (typeExpression tid) value
+
+-- | 渲染类型化构造器的 SQL 字面量
+runtimeLiteral :: TypeExpr -> RuntimeValue -> Either String String
+runtimeLiteral _ (RInt n) = Right (show n)
+runtimeLiteral _ (RDouble n) = Right (show n)
+runtimeLiteral _ (RBool b) = Right (if b then "TRUE" else "FALSE")
+runtimeLiteral _ (RString text) = Right ("'" ++ escapeStringLiteral text ++ "'")
+runtimeLiteral (TypeApply (TypeConstructorId 5) [child]) (RList values) = do
+    items <- mapM (runtimeLiteral child) values
+    Right ("LIST<" ++ renderTypeExpr child ++ ">(" ++ intercalate ", " items ++ ")")
+runtimeLiteral (TypeApply (TypeConstructorId 6) [child]) (RMaybe value) = do
+    item <- maybe (Right "") (runtimeLiteral child) value
+    Right ("MAYBE<" ++ renderTypeExpr child ++ ">(" ++ item ++ ")")
+runtimeLiteral (TypeApply (TypeConstructorId 7) fields) (RTuple values)
+    | length fields == length values = do
+        items <- sequence (zipWith runtimeLiteral fields values)
+        Right ("TUPLE<" ++ intercalate ", " (map renderTypeExpr fields) ++ ">(" ++ intercalate ", " items ++ ")")
+runtimeLiteral _ _ = Left "runtime value does not match its type expression"
 
 -- | JSON 值按列类型转成引擎的值；类型对不上就报错
 coerceValue :: Column -> A.Value -> Either String Value
 coerceValue col v = case v of
+    A.Object _ -> parseEither valueFromJSON v >>= M.coerceValue t
     A.Null -> Right VNull
     A.Bool b -> M.coerceValue t (VBool b)
     A.Number n -> case floatingOrInteger n :: Either Double Integer of
@@ -186,13 +215,14 @@ insertRowSql table row = do
     tbl <- checkIdent "table" table
     cols <- requireNonEmpty "values" row
     names <- mapM (checkIdent "column" . T.pack . fst) cols
+    literals <- mapM (sqlLiteral . snd) cols
     pure
         ( "INSERT INTO "
             ++ T.unpack tbl
             ++ " ("
             ++ intercalate ", " (map T.unpack names)
             ++ ") VALUES ("
-            ++ intercalate ", " (map (sqlLiteral . snd) cols)
+            ++ intercalate ", " literals
             ++ ")"
         )
 
@@ -208,14 +238,15 @@ insertRowsSql table rows = do
             let widths = map length rs
             if any (/= length first) widths
                 then Left "all rows must have the same columns"
-                else
+                else do
+                    literals <- mapM (mapM (sqlLiteral . snd)) rs
                     pure
                         ( "INSERT INTO "
                             ++ T.unpack tbl
                             ++ " ("
                             ++ intercalate ", " (map T.unpack names)
                             ++ ") VALUES "
-                            ++ intercalate ", " ["(" ++ intercalate ", " (map (sqlLiteral . snd) r) ++ ")" | r <- rs]
+                            ++ intercalate ", " ["(" ++ intercalate ", " values ++ ")" | values <- literals]
                         )
 
 -- | 构造按 id 改行的 UPDATE 语句
@@ -223,8 +254,14 @@ updateRowSql :: Text -> Int -> [(String, Value)] -> Either String String
 updateRowSql table key assigns = do
     tbl <- checkIdent "table" table
     cols <- requireNonEmpty "values" assigns
-    sets <- mapM (\(n, v) -> (\c -> T.unpack c ++ " = " ++ sqlLiteral v) <$> checkIdent "column" (T.pack n)) cols
+    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
+        Right (T.unpack column ++ " = " ++ literal)
 
 -- | 按 id 删一行，存储层原地删
 deleteRowSql :: Text -> Int -> Either String String
@@ -251,7 +288,8 @@ whereClause filters = case filters of
     -- | 一个等值条件
     term (column, value) = do
         col <- checkIdent "column" column
-        pure (T.unpack col ++ " = " ++ sqlLiteral value)
+        literal <- sqlLiteral value
+        pure (T.unpack col ++ " = " ++ literal)
 
 -- | 拼 ORDER BY 子句，无排序给空串
 orderClause :: Maybe (Text, Bool) -> Either String String
@@ -309,6 +347,8 @@ roleName name
 -- | 授权对象：`*`，或长度不超过 128 的裸表名/`库.表`
 grantObject :: Text -> Either String Text
 grantObject object
+    | "database:" `T.isPrefixOf` T.toLower object = ("DATABASE " <>) <$> checkIdent "database" (T.drop 9 object)
+    | ".*" `T.isSuffixOf` object = (<> ".*") <$> checkIdent "database" (T.dropEnd 2 object)
     | T.strip object == "*" = Right "*"
     | T.null object || T.length object > 128 = Left "object name is empty or too long"
     | not (T.all allowed object) = Left ("object name may only contain ASCII letters, digits, dot, dash or underscore: " ++ T.unpack object)

chusql-interface/src/ChuSQL/Interface/Config.hs

@@ -186,12 +186,13 @@ data ServerConfig = ServerConfig
     , scPort :: Int
     , scMaxMessage :: Int
     , scMaxRows :: Int
+    , scSudoUser :: Text
     }
     deriving (Eq, Show)
 
 -- | 默认本机 7777，行 1 MiB，最多 1000 行
 defaultServerConfig :: ServerConfig
-defaultServerConfig = ServerConfig "127.0.0.1" 7777 (1024 * 1024) 1000
+defaultServerConfig = ServerConfig "127.0.0.1" 7777 (1024 * 1024) 1000 ""
 
 -- | 读 [server] 段键，缺的用默认
 loadServerConfigAt :: FilePath -> IO ServerConfig
@@ -211,4 +212,5 @@ loadServerConfigAt path = do
             , scPort = intOf "port" (scPort defaultServerConfig)
             , scMaxMessage = intOf "max_message" (scMaxMessage defaultServerConfig)
             , scMaxRows = intOf "max_rows" (scMaxRows defaultServerConfig)
+            , scSudoUser = T.toLower (T.pack (textOf "sudo_auth_user" ""))
             }

chusql-interface/src/ChuSQL/Interface/Link.hs

@@ -5,6 +5,7 @@ module ChuSQL.Interface.Link (
     connectClient,
     closeClient,
     clientLogin,
+    clientSudoLogin,
     clientQuery,
     clientPing,
     clientCatalog,
@@ -15,6 +16,7 @@ module ChuSQL.Interface.Link (
     clientReloadPolicy,
 ) where
 
+import ChuSQL.Interface.Sudo (SudoCredential, sudoProof, isLocalPeer)
 import ChuSQL.Core.Protocol (Account, QueryResult (..), TableInfo (..))
 import ChuSQL.Interface.Protocol (
     ClientRequest (..),
@@ -40,6 +42,7 @@ import Network.Socket (
     defaultHints,
     defaultProtocol,
     getAddrInfo,
+    getPeerName,
     socket,
     socketToHandle,
  )
@@ -52,17 +55,18 @@ import System.IO.Error (isEOFError)
 data Client = Client
     { clHandle :: Handle
     , clLock :: MVar ()
+    , clLocal :: Bool
     }
 
 -- | 连上 server 并对协议版本，失败给人话错误
 connectClient :: Text -> Int -> IO (Either Text Client)
 connectClient host port = do
-    opened <- try (openConnection host port) :: IO (Either IOException Handle)
+    opened <- try (openConnection host port) :: IO (Either IOException (Handle, Bool))
     case opened of
         Left err -> pure (Left ("cannot reach the server at " <> T.pack (address host port) <> ": " <> T.pack (describe err)))
-        Right handle -> do
+        Right (handle, local) -> do
             lock <- newMVar ()
-            let client = Client handle lock
+            let client = Client handle lock local
             greeted <- request client (ReqHello protocolVersion)
             case greeted of
                 Right (RespHello version)
@@ -117,6 +121,26 @@ clientLogin client user password = do
         Right (RespLogin _ admin) -> pure (Right admin)
         Right other -> pure (failed "login" other)
 
+-- 验证一次性挑战并用本机身份登录。
+clientSudoLogin :: Client -> SudoCredential -> Text -> IO (Either Text Bool)
+clientSudoLogin client _ _ | not (clLocal client) = pure (Left "sudo authentication requires a local server")
+clientSudoLogin client credential user = withMVar (clLock client) $ \_ -> do
+    outcome <- try authenticate :: IO (Either IOException (Either Text Bool))
+    pure $ either (Left . T.pack . describe) id outcome
+  where
+    -- 在同一连接连续交换挑战与证明。
+    authenticate = do
+        challenge <- exchange (clHandle client) ReqSudoChallenge
+        case challenge of
+            Right (RespSudoChallenge nonce) | T.length nonce == 64 -> do
+                answer <- exchange (clHandle client) (ReqSudoLogin user (sudoProof credential nonce user))
+                pure $ case answer of
+                    Left message -> Left message
+                    Right (RespLogin _ admin) -> Right admin
+                    Right other -> failed "sudo login" other
+            Right other -> pure (failed "sudo challenge" other)
+            Left message -> pure (Left message)
+
 -- | 跑一条语句，拿回结果集
 clientQuery :: Client -> Text -> IO (Either Text QueryResult)
 clientQuery client sql = do
@@ -196,7 +220,7 @@ failed what response = case response of
     _ -> Left ("unexpected response to " <> what)
 
 -- | 建连接（套接字转成文本模式的行缓冲句柄）
-openConnection :: Text -> Int -> IO Handle
+openConnection :: Text -> Int -> IO (Handle, Bool)
 openConnection host port = do
     let hints = defaultHints{addrSocketType = Stream}
     infos <- getAddrInfo (Just hints) (Just (T.unpack host)) (Just (show port))
@@ -205,10 +229,11 @@ openConnection host port = do
         (info : _) -> do
             sock <- socket (addrFamily info) Stream defaultProtocol
             connect sock (addrAddress info)
+            peer <- getPeerName sock
             handle <- socketToHandle sock ReadWriteMode
             hSetBuffering handle LineBuffering
             hSetNewlineMode handle noNewlineTranslation
-            pure handle
+            pure (handle, isLocalPeer peer)
 
 -- | 把主机端口拼成地址字样
 address :: Text -> Int -> String

chusql-interface/src/ChuSQL/Interface/Protocol.hs

@@ -91,6 +91,8 @@ serverName = "chusql-server"
 data ClientRequest
     = ReqHello Int
     | ReqLogin Text Text
+    | ReqSudoChallenge
+    | ReqSudoLogin Text Text
     | ReqQuery Text
     | ReqPing
     | ReqQuit
@@ -109,6 +111,7 @@ data WireRequest = WireRequest
     , wrProtocol :: Maybe Int
     , wrUser :: Maybe Text
     , wrPassword :: Maybe Text
+    , wrProof :: Maybe Text
     , wrSql :: Maybe Text
     , wrRequest :: Maybe Value
     }
@@ -121,6 +124,7 @@ instance A.FromJSON WireRequest where
             <*> o A..:? "protocol"
             <*> o A..:? "user"
             <*> o A..:? "password"
+            <*> o A..:? "proof"
             <*> o A..:? "sql"
             <*> o A..:? "request"
 
@@ -133,6 +137,10 @@ decodeRequest raw = case A.eitherDecodeStrict raw of
         "login" -> case (wrUser wire, wrPassword wire) of
             (Just user, Just password) -> Right (ReqLogin user password)
             _ -> Left "login needs both user and password"
+        "sudo_challenge" -> Right ReqSudoChallenge
+        "sudo_login" -> case (wrUser wire, wrProof wire) of
+            (Just user, Just proof) -> Right (ReqSudoLogin user proof)
+            _ -> Left "sudo_login needs both user and proof"
         "query" -> maybe (Left "query needs sql") (Right . ReqQuery) (wrSql wire)
         "storage" -> maybe (Left "storage needs request") (Right . ReqStorage) (wrRequest wire)
         "catalog" -> Right ReqCatalog
@@ -154,6 +162,8 @@ requestJson :: ClientRequest -> Value
 requestJson request = case request of
     ReqHello version -> object ["method" .= ("hello" :: Text), "protocol" .= version]
     ReqLogin user password -> object ["method" .= ("login" :: Text), "user" .= user, "password" .= password]
+    ReqSudoChallenge -> object ["method" .= ("sudo_challenge" :: Text)]
+    ReqSudoLogin user proof -> object ["method" .= ("sudo_login" :: Text), "user" .= user, "proof" .= proof]
     ReqQuery sql -> object ["method" .= ("query" :: Text), "sql" .= sql]
     ReqPing -> object ["method" .= ("ping" :: Text)]
     ReqQuit -> object ["method" .= ("quit" :: Text)]
@@ -169,6 +179,7 @@ requestJson request = case request of
 data ServerResponse
     = RespHello Int
     | RespLogin Text Bool
+    | RespSudoChallenge Text
     | RespResult QueryResult
     | RespPong
     | RespBye
@@ -190,6 +201,7 @@ responseJson :: ServerResponse -> Value
 responseJson response = case response of
     RespHello version -> object ["status" .= ("hello" :: Text), "protocol" .= version, "server" .= serverName]
     RespLogin user admin -> object ["status" .= ("ok" :: Text), "user" .= user, "admin" .= admin]
+    RespSudoChallenge challenge -> object ["status" .= ("sudo_challenge" :: Text), "challenge" .= challenge]
     RespPong -> object ["status" .= ("pong" :: Text)]
     RespBye -> object ["status" .= ("bye" :: Text)]
     RespError code message -> object ["status" .= ("error" :: Text), "code" .= code, "message" .= message]
@@ -216,6 +228,7 @@ decodeResponse raw = case A.eitherDecode raw of
     decodeStatus status fields = case status of
         "hello" -> Right (RespHello (intOf "protocol" fields))
         "ok" -> Right (RespLogin (textOf "user" fields) (boolOf "admin" fields))
+        "sudo_challenge" -> fromField "challenge" RespSudoChallenge fields
         "pong" -> Right RespPong
         "bye" -> Right RespBye
         "error" -> Right (RespError (textOf "code" fields) (textOf "message" fields))

chusql-interface/src/ChuSQL/Interface/Session.hs

@@ -7,6 +7,7 @@ module ChuSQL.Interface.Session (
     sessionDatabase,
     isPlainIdentifier,
     authenticateSession,
+    authenticateSudoSession,
     switchDatabase,
     runStatement,
     catalog,
@@ -22,9 +23,11 @@ import ChuSQL.Interface.Link (
     clientCatalog,
     clientDatabases,
     clientLogin,
+    clientSudoLogin,
     clientQuery,
     clientRoles,
  )
+import ChuSQL.Interface.Sudo (SudoCredential)
 import ChuSQL.Interface.Protocol (RoleView)
 import Data.Char (isAlpha, isAlphaNum)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
@@ -68,6 +71,14 @@ authenticateSession session user password = do
         Left message -> pure (Left message)
         Right admin -> writeIORef (ssAdmin session) admin >> pure (Right ())
 
+-- 用受保护本机凭据登录并记录身份。
+authenticateSudoSession :: Session -> SudoCredential -> Text -> IO (Either Text ())
+authenticateSudoSession session credential user = do
+    answer <- clientSudoLogin (ssClient session) credential user
+    case answer of
+        Left message -> pure (Left message)
+        Right admin -> writeIORef (ssAdmin session) admin >> pure (Right ())
+
 -- | 换库：名字先按解析器规矩校验，由 server 执行 USE
 switchDatabase :: Session -> Text -> IO (Either Text ())
 switchDatabase session rawName

chusql-interface/src/ChuSQL/Interface/Sudo.hs

@@ -0,0 +1,108 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Interface.Sudo (
+    SudoCredential, createSudoCredential, removeSudoCredential,
+    readSudoCredential, sudoProof, verifySudoProof, sudoChallenge, sudoPrivileged,
+    newSudoCredential, isLocalPeer, validSudoChallenge,
+) where
+
+import Crypto.Hash (SHA256)
+import Crypto.MAC.HMAC (HMAC, hmac)
+import Crypto.Random (getRandomBytes)
+import qualified Data.ByteArray as BA
+import Data.ByteArray.Encoding (Base (Base16), convertToBase)
+import qualified Data.ByteString as BS
+import Data.Char (isHexDigit)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+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)
+
+-- 用系统保护凭据与一次性挑战验证本机提升身份。
+
+newtype SudoCredential = SudoCredential BS.ByteString
+
+-- 隐藏本机凭据的诊断内容。
+instance Show SudoCredential where
+    show _ = "SudoCredential <redacted>"
+
+-- 检查当前进程的操作系统提升身份。
+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
+
+-- 判断当前进程是否以提升身份运行。
+sudoPrivileged :: IO Bool
+sudoPrivileged = (/= 0) <$> nativePrivileged
+
+-- 生成随机挑战和服务实例凭据。
+sudoChallenge :: IO Text
+sudoChallenge = TE.decodeUtf8 . convertToBase Base16 <$> (getRandomBytes 32 :: IO BS.ByteString)
+
+-- 创建本次服务实例的受保护凭据。
+createSudoCredential :: Int -> IO SudoCredential
+createSudoCredential port = do
+    credential@(SudoCredential secret) <- newSudoCredential
+    status <- BS.useAsCString secret (nativeCreate (fromIntegral port))
+    if status == 0 then pure credential
+        else ioError (userError (T.unpack (nativeError "create" status)))
+
+-- 生成独立服务实例的随机凭据。
+newSudoCredential :: IO SudoCredential
+newSudoCredential = SudoCredential . TE.encodeUtf8 <$> sudoChallenge
+
+-- 判断内核报告的连接地址是否为回环。
+isLocalPeer :: SockAddr -> Bool
+isLocalPeer (SockAddrInet _ host) = let (first, _, _, _) = hostAddressToTuple host in first == 127
+isLocalPeer (SockAddrInet6 _ _ host _) = case hostAddress6ToTuple host of
+    (0, 0, 0, 0, 0, 0, 0, 1) -> True
+    (0, 0, 0, 0, 0, 65535, high, _) -> high >= 32512 && high <= 32767
+    _ -> False
+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
+    Nothing -> False
+
+-- 删除本次服务实例的受保护凭据。
+removeSudoCredential :: Int -> IO ()
+removeSudoCredential port = do
+    status <- nativeRemove (fromIntegral port)
+    if status == 0 then pure () else ioError (userError (T.unpack (nativeError "remove" status)))
+
+-- 验证操作系统身份并读取本机凭据。
+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"
+
+-- 计算绑定挑战与目标账号的认证证明。
+sudoProof :: SudoCredential -> Text -> Text -> Text
+sudoProof (SudoCredential secret) challenge user = TE.decodeUtf8 (convertToBase Base16 digest)
+  where
+    digest = hmac secret (TE.encodeUtf8 ("chusql-sudo-v1:" <> challenge <> ":" <> T.toLower (T.strip user))) :: HMAC SHA256
+
+-- 按固定长度常量时间比对认证证明。
+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)
+
+-- 将原生错误转换为明确诊断。
+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"