修复错误，优化性能，实现类型系统，优化安装卸载过程

chusql-core/model/chusql-core-model.cabal

@@ -2,10 +2,11 @@ cabal-version: 2.4
 
 name:           chusql-core-model
 version:        1.0.0
-synopsis:       ChuSQL 共用数据模型与线上协议类型
-description:    ChuSQL 各进程共用的纯数据类型：列与值的模型、存储层线上协议
-                （请求/响应/表结构与账号）以及查询结果集。这里不放任何执行
-                逻辑，前端只依赖这个包就不会把引擎链进自己的二进制。
+synopsis:       Shared ChuSQL data models and wire protocol types
+description:    Defines shared column and value models, storage protocol requests
+                and responses, table schemas, accounts, and query results.
+                Contains data types without execution logic, allowing clients to
+                use the models without linking the query engine.
 build-type:     Simple
 
 library

chusql-core/model/src/ChuSQL/Core/Model.hs

@@ -29,6 +29,8 @@ module ChuSQL.Core.Model
     , typeLabel
     , typeName
     , parseColumnType
+    , domainTableName
+    , isDomainTable
     , typeClassOf
     , assignable
     , comparableTypes
@@ -44,7 +46,7 @@ module ChuSQL.Core.Model
 
 import Data.Char (isDigit, isSpace, toLower)
 import Data.Hashable (Hashable (..))
-import Data.List (isSuffixOf, stripPrefix)
+import Data.List (isPrefixOf, isSuffixOf, stripPrefix)
 import Data.Maybe (fromMaybe, mapMaybe)
 
 -- 数据模型：列类型、列约束、值、行、表、数据库，外加查表小工具。
@@ -64,6 +66,8 @@ data ColumnType
     | CDate
     | CTimestamp
     | CBlob
+    | CNull
+    | CDomain String ColumnType
     deriving (Show, Eq)
 
 -- | 列定义：类型 + 约束；约束全部取默认值就是普通可空列。
@@ -115,6 +119,8 @@ typeLabel (CDecimal p s) = "TDecimal " ++ show p ++ " " ++ show s
 typeLabel CDate = "TDate"
 typeLabel CTimestamp = "TTimestamp"
 typeLabel CBlob = "TBlob"
+typeLabel CNull = "NULL"
+typeLabel (CDomain name _) = name
 
 -- | 线上/磁盘上的类型名
 typeName :: ColumnType -> String
@@ -131,35 +137,50 @@ typeName (CDecimal p s) = "decimal(" ++ show p ++ "," ++ show s ++ ")"
 typeName CDate = "date"
 typeName CTimestamp = "timestamp"
 typeName CBlob = "blob"
+typeName CNull = "null"
+typeName (CDomain name base) = "domain(" ++ name ++ "," ++ typeName base ++ ")"
+
+-- | 生成类型定义的目录键
+domainTableName :: String -> String
+domainTableName name = "__system_domain_" ++ map toLower name
+
+-- | 判断类型定义目录键
+isDomainTable :: String -> Bool
+isDomainTable name = "__system_domain_" `isPrefixOf` map toLower name
 
 -- | 解析类型名，可带长度/精度参数；不认识的给 Nothing
 parseColumnType :: String -> Maybe ColumnType
-parseColumnType raw = case (base, args) of
-    ("int", []) -> Just CInt
-    ("integer", []) -> Just CInt
-    ("bigint", []) -> Just CBigInt
-    ("smallint", []) -> Just CSmallInt
-    ("str", []) -> Just CStr
-    ("text", []) -> Just CStr
-    ("varchar", []) -> Just CStr
-    ("varchar", [n]) -> CVarchar <$> positive n
-    ("char", []) -> Just (CChar 1)
-    ("char", [n]) -> CChar <$> positive n
-    ("bool", []) -> Just CBool
-    ("boolean", []) -> Just CBool
-    ("float", []) -> Just CFloat
-    ("real", []) -> Just CFloat
-    ("double", []) -> Just CDouble
-    ("decimal", []) -> Just (CDecimal 10 0)
-    ("numeric", []) -> Just (CDecimal 10 0)
-    ("decimal", [p]) -> flip CDecimal 0 <$> positive p
-    ("numeric", [p]) -> flip CDecimal 0 <$> positive p
-    ("decimal", [p, s]) -> CDecimal <$> positive p <*> plain s
-    ("numeric", [p, s]) -> CDecimal <$> positive p <*> plain s
-    ("date", []) -> Just CDate
-    ("timestamp", []) -> Just CTimestamp
-    ("blob", []) -> Just CBlob
-    _ -> Nothing
+parseColumnType raw
+    | Just inner <- stripPrefix "domain(" raw
+    , Just body <- stripSuffixMaybe ")" inner
+    , (name, ',' : definition) <- break (== ',') body =
+        CDomain name <$> parseColumnType definition
+    | otherwise = case (base, args) of
+        ("int", []) -> Just CInt
+        ("integer", []) -> Just CInt
+        ("bigint", []) -> Just CBigInt
+        ("smallint", []) -> Just CSmallInt
+        ("str", []) -> Just CStr
+        ("text", []) -> Just CStr
+        ("varchar", []) -> Just CStr
+        ("varchar", [n]) -> CVarchar <$> positive n
+        ("char", []) -> Just (CChar 1)
+        ("char", [n]) -> CChar <$> positive n
+        ("bool", []) -> Just CBool
+        ("boolean", []) -> Just CBool
+        ("float", []) -> Just CFloat
+        ("real", []) -> Just CFloat
+        ("double", []) -> Just CDouble
+        ("decimal", []) -> Just (CDecimal 10 0)
+        ("numeric", []) -> Just (CDecimal 10 0)
+        ("decimal", [p]) -> flip CDecimal 0 <$> positive p
+        ("numeric", [p]) -> flip CDecimal 0 <$> positive p
+        ("decimal", [p, s]) -> CDecimal <$> positive p <*> plain s
+        ("numeric", [p, s]) -> CDecimal <$> positive p <*> plain s
+        ("date", []) -> Just CDate
+        ("timestamp", []) -> Just CTimestamp
+        ("blob", []) -> Just CBlob
+        _ -> Nothing
   where
     -- | 去掉空白的类型名
     cleaned = map toLower (filter (not . isSpace) raw)
@@ -209,6 +230,7 @@ data TypeClass
     | TextClass
     | TemporalClass
     | BooleanClass
+    | NullClass
     deriving (Show, Eq)
 
 -- | 整型大类判断
@@ -226,10 +248,13 @@ typeClassOf CBlob = TextClass
 typeClassOf CDate = TemporalClass
 typeClassOf CTimestamp = TemporalClass
 typeClassOf CBool = BooleanClass
+typeClassOf CNull = NullClass
+typeClassOf (CDomain _ base) = typeClassOf base
 
 -- | 同大类可赋值；日期/时间列接受字符串字面量
 assignable :: ColumnType -> ColumnType -> Bool
 assignable target source
+    | source == CNull = True
     | target == source = True
     | typeClassOf target == typeClassOf source = True
     | typeClassOf target == TemporalClass && typeClassOf source == TextClass = True
@@ -240,11 +265,12 @@ integerType :: ColumnType -> Bool
 integerType CInt = True
 integerType CBigInt = True
 integerType CSmallInt = True
+integerType (CDomain _ base) = integerType base
 integerType _ = False
 
 -- | 比较用的类型族：同大类可比，日期时间与文本互比
 comparableTypes :: ColumnType -> ColumnType -> Bool
-comparableTypes a b = sameClass || crossTemporal
+comparableTypes a b = a == CNull || b == CNull || sameClass || crossTemporal
   where
     -- | 两个类型同属一个大类
     sameClass = typeClassOf a == typeClassOf b
@@ -261,6 +287,7 @@ numericType t = typeClassOf t == NumericClass
 
 -- | 值能不能放进这一列（先不看可空）
 valueFits :: ColumnType -> Value -> Bool
+valueFits (CDomain _ base) value = valueFits base value
 valueFits _ VNull = True
 valueFits CInt (VInt _) = True
 valueFits CBigInt (VInt _) = True
@@ -297,6 +324,8 @@ coerceValue t v = case t of
     CDate -> toDate v
     CTimestamp -> toTimestamp v
     CBlob -> toText t v
+    CNull -> Left "a NULL output cannot contain a non-NULL value"
+    CDomain _ base -> coerceValue base v
 
 -- | 整数收进整型列
 toInt :: ColumnType -> Value -> Either String Value
@@ -315,15 +344,22 @@ toFloat t _ = Left ("cannot put this value into " ++ typeLabel t)
 
 -- | DECIMAL 按小数位四舍五入
 toDecimal :: Int -> Int -> Value -> Either String Value
-toDecimal p s v = case v of
-    VInt n -> rounded (fromIntegral n)
-    VFloat d -> rounded d
-    _ -> Left ("cannot put this value into " ++ typeLabel (CDecimal p s))
+toDecimal p s v
+    | p <= 0 || p > 308 || s < 0 || s > p = Left "invalid decimal precision or scale"
+    | otherwise = case v of
+        VInt n -> rounded (fromIntegral n)
+        VFloat d -> rounded d
+        _ -> Left ("cannot put this value into " ++ typeLabel (CDecimal p s))
   where
     -- | 缩放因子
-    scale = (10 :: Double) ^ max 0 s
+    scale = (10 :: Double) ^ s
     -- | 按比例四舍五入
-    rounded d = Right (VFloat (fromIntegral (round (d * scale) :: Integer) / scale))
+    rounded d
+        | isNaN d || isInfinite d || isInfinite (d * scale) = Left "decimal value is not finite or exceeds precision"
+        | abs result >= (10 :: Double) ^ (p - s) = Left "decimal value exceeds precision"
+        | otherwise = Right (VFloat result)
+      where
+        result = fromIntegral (round (d * scale) :: Integer) / scale
 
 -- | 字符串收进文本列
 toText :: ColumnType -> Value -> Either String Value
@@ -562,5 +598,6 @@ resolveColumn name env = case [(k, v) | (k, v) <- env, matches k] of
     [] -> Left ("unknown column: " ++ name)
     _ -> Left ("ambiguous column: " ++ name)
   where
-    -- | 裸名、补充了库前缀的写法，或 schema 键自带库前缀的写法
-    matches k = k == name || ('.' : name) `isSuffixOf` k || ('.' : k) `isSuffixOf` name
+    -- | 裸名匹配末段，库限定名只补一层前缀
+    matches k = k == name || ('.' : name) `isSuffixOf` k
+        || (length (filter (== '.') name) == 2 && length (filter (== '.') k) == 1 && ('.' : k) `isSuffixOf` name)

chusql-core/model/src/ChuSQL/Core/Protocol.hs

@@ -75,6 +75,10 @@ data Request
     | ReqAllCatalog
     | ReqInDatabase String Request
     | ReqAccountsList
+    | ReqIdentityInitialize T.Text
+    | ReqRoleCreate T.Text
+    | ReqCatalogManage Request
+    | ReqIdentityAlter T.Text (Maybe Bool) (Maybe Bool) (Maybe Bool) (Maybe Bool)
     | ReqAccountCreate T.Text T.Text
     | ReqAccountReset T.Text T.Text
     | ReqAccountLogin T.Text (Maybe T.Text)
@@ -134,7 +138,12 @@ instance ToJSON Request where
     toJSON (ReqInDatabase name req) = case toJSON req of
         A.Object fields -> A.Object (KM.insert "database" (A.String (T.pack name)) fields)
         other -> other
+    toJSON (ReqCatalogManage command) = object ["method" .= ("catalog_manage" :: T.Text), "command" .= command]
     toJSON ReqAccountsList = object ["method" .= ("accounts_list" :: T.Text)]
+    toJSON (ReqIdentityInitialize u) = object ["method" .= ("identity_initialize" :: T.Text), "administrator" .= u]
+    toJSON (ReqRoleCreate u) = object ["method" .= ("role_create" :: T.Text), "user" .= u]
+    toJSON (ReqIdentityAlter u login super enabled manager) = object ["method" .= ("identity_alter" :: T.Text), "user" .= u,
+        "can_login" .= login, "is_superuser" .= super, "enabled" .= enabled, "system_catalog_manager" .= manager]
     toJSON (ReqAccountCreate u h) = object ["method" .= ("account_create" :: T.Text), "user" .= u, "password_hash" .= h]
     toJSON (ReqAccountReset u h) = object ["method" .= ("account_reset" :: T.Text), "user" .= u, "password_hash" .= h]
     toJSON (ReqAccountLogin u at) = object ["method" .= ("account_login" :: T.Text), "user" .= u, "at" .= at]
@@ -303,6 +312,10 @@ data Account = Account
     , accountRevision :: Integer
     , accountRegisteredAt :: T.Text
     , accountLastLoginAt :: Maybe T.Text
+    , accountCanLogin :: Bool
+    , accountIsSuperuser :: Bool
+    , accountEnabled :: Bool
+    , accountSystemCatalogManager :: Bool
     } deriving (Eq)
 
 -- | 账号的展示：只露账号名与版本号
@@ -314,12 +327,14 @@ instance FromJSON Account where
     parseJSON = withObject "Account" $ \o -> Account <$> o .: "id" <*> o .: "user"
         <*> o .: "password_hash" <*> o .: "revision"
         <*> o .:? "registered_at" .!= "" <*> o .:? "last_login_at"
+        <*> o .:? "can_login" .!= True <*> o .:? "is_superuser" .!= False <*> o .:? "enabled" .!= True <*> o .:? "system_catalog_manager" .!= False
 
 -- | 账号编码成 JSON
 instance ToJSON Account where
     toJSON a = object ["id" .= accountId a, "user" .= accountUser a,
         "password_hash" .= accountHash a, "revision" .= accountRevision a,
-        "registered_at" .= accountRegisteredAt a, "last_login_at" .= accountLastLoginAt a]
+        "registered_at" .= accountRegisteredAt a, "last_login_at" .= accountLastLoginAt a,
+        "can_login" .= accountCanLogin a, "is_superuser" .= accountIsSuperuser a, "enabled" .= accountEnabled a, "system_catalog_manager" .= accountSystemCatalogManager a]
 
 -- | 存储层响应
 data Response