大改，整理项目结构，完成rust ffi调用，写好tcp接口

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

@@ -0,0 +1,21 @@
+cabal-version: 2.4
+
+name:           chusql-core-model
+version:        1.0.0
+synopsis:       ChuSQL 共用数据模型与线上协议类型
+description:    ChuSQL 各进程共用的纯数据类型：列与值的模型、存储层线上协议
+                （请求/响应/表结构与账号）以及查询结果集。这里不放任何执行
+                逻辑，前端只依赖这个包就不会把引擎链进自己的二进制。
+build-type:     Simple
+
+library
+    hs-source-dirs:   src
+    exposed-modules:  ChuSQL.Core.Model
+                      ChuSQL.Core.Protocol
+    build-depends:    base >= 4.14 && < 5
+                    , aeson
+                    , hashable
+                    , scientific
+                    , text
+    default-language: Haskell2010
+    ghc-options:      -Wall

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

@@ -0,0 +1,422 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module ChuSQL.Core.Model
+    ( ColumnType (..)
+    , Column (..)
+    , pattern TInt
+    , pattern TStr
+    , pattern TBool
+    , TypeClass (..)
+    , Value (..)
+    , Row
+    , Table (..)
+    , Database
+    , colNames
+    , colType
+    , lookupTable
+    , allColumns
+    , qualify
+    , unqualify
+    , resolveColumn
+    , plainColumn
+    , typeLabel
+    , typeName
+    , parseColumnType
+    , typeClassOf
+    , assignable
+    , integerType
+    , numericType
+    , valueFits
+    , coerceValue
+    ) where
+
+import Data.Char (isDigit, isSpace, toLower)
+import Data.Hashable (Hashable (..))
+import Data.List (isSuffixOf, stripPrefix)
+import Data.Maybe (fromMaybe)
+
+-- 数据模型：列类型、列约束、值、行、表、数据库，外加查表小工具。
+
+-- | 列的基础类型
+data ColumnType
+    = CInt
+    | CBigInt
+    | CSmallInt
+    | CStr
+    | CVarchar Int
+    | CChar Int
+    | CBool
+    | CFloat
+    | CDouble
+    | CDecimal Int Int
+    | CDate
+    | CTimestamp
+    | CBlob
+    deriving (Show, Eq)
+
+-- | 列定义：类型 + 约束；约束全部取默认值就是普通可空列。
+data Column = Column
+    { columnType :: ColumnType
+    , columnNullable :: Bool
+    , columnDefault :: Maybe Value
+    , columnAutoIncrement :: Bool
+    , columnUnique :: Bool
+    , columnPrimaryKey :: Bool
+    , columnCheck :: Maybe String
+    }
+    deriving (Eq)
+
+-- | 普通可空列
+plainColumn :: ColumnType -> Column
+plainColumn t = Column t True Nothing False False False Nothing
+
+-- | 普通整型列的匹配模式
+pattern TInt :: Column
+pattern TInt <- Column CInt _ _ _ _ _ _
+  where
+    TInt = plainColumn CInt
+
+-- | 普通字符串列的匹配模式
+pattern TStr :: Column
+pattern TStr <- Column CStr _ _ _ _ _ _
+  where
+    TStr = plainColumn CStr
+
+-- | 普通布尔列的匹配模式
+pattern TBool :: Column
+pattern TBool <- Column CBool _ _ _ _ _ _
+  where
+    TBool = plainColumn CBool
+
+-- | 错误消息里用的类型名
+typeLabel :: ColumnType -> String
+typeLabel CInt = "TInt"
+typeLabel CBigInt = "TBigInt"
+typeLabel CSmallInt = "TSmallInt"
+typeLabel CStr = "TStr"
+typeLabel (CVarchar n) = "TVarchar " ++ show n
+typeLabel (CChar n) = "TChar " ++ show n
+typeLabel CBool = "TBool"
+typeLabel CFloat = "TFloat"
+typeLabel CDouble = "TDouble"
+typeLabel (CDecimal p s) = "TDecimal " ++ show p ++ " " ++ show s
+typeLabel CDate = "TDate"
+typeLabel CTimestamp = "TTimestamp"
+typeLabel CBlob = "TBlob"
+
+-- | 线上/磁盘上的类型名
+typeName :: ColumnType -> String
+typeName CInt = "int"
+typeName CBigInt = "bigint"
+typeName CSmallInt = "smallint"
+typeName CStr = "str"
+typeName (CVarchar n) = "varchar(" ++ show n ++ ")"
+typeName (CChar n) = "char(" ++ show n ++ ")"
+typeName CBool = "bool"
+typeName CFloat = "float"
+typeName CDouble = "double"
+typeName (CDecimal p s) = "decimal(" ++ show p ++ "," ++ show s ++ ")"
+typeName CDate = "date"
+typeName CTimestamp = "timestamp"
+typeName CBlob = "blob"
+
+-- | 解析类型名，可带长度/精度参数；不认识的给 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
+  where
+    -- | 去掉空白的类型名
+    cleaned = map toLower (filter (not . isSpace) raw)
+    -- | 基础名与参数段
+    (base, rest) = span (/= '(') cleaned
+    -- | 括号里的参数表
+    args = case stripSuffixMaybe ")" (drop 1 rest) of
+        Nothing -> []
+        Just inner -> map (filter (not . isSpace)) (splitOn ',' inner)
+
+-- | 去掉结尾
+stripSuffixMaybe :: String -> String -> Maybe String
+stripSuffixMaybe suffix s
+    | suffix `isSuffixOf` s = Just (take (length s - length suffix) s)
+    | otherwise = Nothing
+
+-- | 按逗号切开
+splitOn :: Char -> String -> [String]
+splitOn sep s = case break (== sep) s of
+    (part, []) -> [part]
+    (part, _ : rest) -> part : splitOn sep rest
+
+-- | 正数参数
+positive :: String -> Maybe Int
+positive s
+    | not (null s) && all isDigit s = Just (read s)
+    | otherwise = Nothing
+
+-- | 非负整数参数
+plain :: String -> Maybe Int
+plain = positive
+
+-- | 写出普通列就只说类型名，带约束才补在后面
+instance Show Column where
+    show c = typeLabel (columnType c) ++ notNull ++ def ++ auto ++ uni ++ key ++ check
+      where
+        notNull = if columnNullable c then "" else " NOT NULL"
+        def = maybe "" (\v -> " DEFAULT " ++ show v) (columnDefault c)
+        auto = if columnAutoIncrement c then " AUTO_INCREMENT" else ""
+        uni = if columnUnique c then " UNIQUE" else ""
+        key = if columnPrimaryKey c then " PRIMARY KEY" else ""
+        check = maybe "" (\s -> " CHECK (" ++ s ++ ")") (columnCheck c)
+
+-- | 类型大类
+data TypeClass
+    = NumericClass
+    | TextClass
+    | TemporalClass
+    | BooleanClass
+    deriving (Show, Eq)
+
+-- | 整型大类判断
+typeClassOf :: ColumnType -> TypeClass
+typeClassOf CInt = NumericClass
+typeClassOf CBigInt = NumericClass
+typeClassOf CSmallInt = NumericClass
+typeClassOf CFloat = NumericClass
+typeClassOf CDouble = NumericClass
+typeClassOf CDecimal{} = NumericClass
+typeClassOf CStr = TextClass
+typeClassOf CVarchar{} = TextClass
+typeClassOf CChar{} = TextClass
+typeClassOf CBlob = TextClass
+typeClassOf CDate = TemporalClass
+typeClassOf CTimestamp = TemporalClass
+typeClassOf CBool = BooleanClass
+
+-- | 同大类可赋值；日期/时间列接受字符串字面量
+assignable :: ColumnType -> ColumnType -> Bool
+assignable target source
+    | target == source = True
+    | typeClassOf target == typeClassOf source = True
+    | typeClassOf target == TemporalClass && typeClassOf source == TextClass = True
+    | otherwise = False
+
+-- | 是不是整数类型
+integerType :: ColumnType -> Bool
+integerType CInt = True
+integerType CBigInt = True
+integerType CSmallInt = True
+integerType _ = False
+
+-- | 是不是数值类型
+numericType :: ColumnType -> Bool
+numericType t = typeClassOf t == NumericClass
+
+-- | 值能不能放进这一列（先不看可空）
+valueFits :: ColumnType -> Value -> Bool
+valueFits _ VNull = True
+valueFits CInt (VInt _) = True
+valueFits CBigInt (VInt _) = True
+valueFits CSmallInt (VInt _) = True
+valueFits CFloat (VInt _) = True
+valueFits CFloat (VFloat _) = True
+valueFits CDouble (VInt _) = True
+valueFits CDouble (VFloat _) = True
+valueFits CDecimal{} (VInt _) = True
+valueFits CDecimal{} (VFloat _) = True
+valueFits CStr (VStr _) = True
+valueFits CVarchar{} (VStr _) = True
+valueFits CChar{} (VStr _) = True
+valueFits CBool (VBool _) = True
+valueFits CDate (VStr _) = True
+valueFits CTimestamp (VStr _) = True
+valueFits CBlob (VStr _) = True
+valueFits _ _ = False
+
+-- | 把值收进列类型：NULL 原样通过，类型不符报错
+coerceValue :: ColumnType -> Value -> Either String Value
+coerceValue _ VNull = Right VNull
+coerceValue t v = case t of
+    CInt -> toInt t v
+    CBigInt -> toInt t v
+    CSmallInt -> toInt t v
+    CFloat -> toFloat t v
+    CDouble -> toFloat t v
+    CDecimal p s -> toDecimal p s v
+    CStr -> toText t v
+    CVarchar n -> toSized n v
+    CChar n -> toSized n v
+    CBool -> toBool t v
+    CDate -> toDate v
+    CTimestamp -> toTimestamp v
+    CBlob -> toText t v
+
+-- | 整数收进整型列
+toInt :: ColumnType -> Value -> Either String Value
+toInt _ (VInt n) = Right (VInt n)
+toInt t (VFloat d) = case properFraction d :: (Int, Double) of
+    (n, frac)
+        | frac == 0 -> Right (VInt n)
+        | otherwise -> Left ("cannot put a fractional number into " ++ typeLabel t)
+toInt t _ = Left ("cannot put this value into " ++ typeLabel t)
+
+-- | 数值收进浮点列
+toFloat :: ColumnType -> Value -> Either String Value
+toFloat _ (VInt n) = Right (VFloat (fromIntegral n))
+toFloat _ (VFloat d) = Right (VFloat d)
+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))
+  where
+    -- | 缩放因子
+    scale = (10 :: Double) ^ max 0 s
+    -- | 按比例四舍五入
+    rounded d = Right (VFloat (fromIntegral (round (d * scale) :: Integer) / scale))
+
+-- | 字符串收进文本列
+toText :: ColumnType -> Value -> Either String Value
+toText _ (VStr s) = Right (VStr s)
+toText t _ = Left ("cannot put this value into " ++ typeLabel t)
+
+-- | 按列长度限制收字符串
+toSized :: Int -> Value -> Either String Value
+toSized n (VStr s)
+    | length s <= n = Right (VStr s)
+    | otherwise = Left ("value is longer than " ++ show n ++ " characters")
+toSized _ _ = Left "cannot put this value into a character column"
+
+-- | 布尔收进布尔列
+toBool :: ColumnType -> Value -> Either String Value
+toBool _ (VBool b) = Right (VBool b)
+toBool t _ = Left ("cannot put this value into " ++ typeLabel t)
+
+-- | 字符串收进日期列
+toDate :: Value -> Either String Value
+toDate (VStr s)
+    | validDateText s = Right (VStr s)
+    | otherwise = Left "date must look like YYYY-MM-DD"
+toDate _ = Left "date must be a string"
+
+-- | 字符串收进时间戳列
+toTimestamp :: Value -> Either String Value
+toTimestamp (VStr s)
+    | validTimestampText s = Right (VStr s)
+    | otherwise = Left "timestamp must look like YYYY-MM-DD HH:MM:SS"
+toTimestamp _ = Left "timestamp must be a string"
+
+-- | YYYY-MM-DD
+validDateText :: String -> Bool
+validDateText s = case splitOn '-' s of
+    [y, m, d] -> allOf 4 y && allOf 2 m && allOf 2 d
+    _ -> False
+
+-- | 日期时间格式；中间允许空格或 T
+validTimestampText :: String -> Bool
+validTimestampText s = case break (\c -> c == ' ' || c == 'T') s of
+    (d, _ : tm) -> validDateText d && validTimeText tm
+    _ -> False
+
+-- | HH:MM:SS
+validTimeText :: String -> Bool
+validTimeText t = case splitOn ':' t of
+    [h, m, sec] -> allOf 2 h && allOf 2 m && allOf 2 sec
+    _ -> False
+
+-- | 一段字符串是不是固定长度的数字
+allOf :: Int -> String -> Bool
+allOf n s = length s == n && all isDigit s
+
+
+-- | 引擎里的一行值
+data Value
+    = VNull
+    | VInt Int
+    | VFloat Double
+    | VStr String
+    | VBool Bool
+    deriving (Show, Eq)
+
+-- | 值按类型打散搅拌
+instance Hashable Value where
+    hashWithSalt s VNull = hashWithSalt (hashWithSalt s (0 :: Int)) ()
+    hashWithSalt s (VInt n) = hashWithSalt (hashWithSalt s (1 :: Int)) n
+    hashWithSalt s (VFloat d) = hashWithSalt (hashWithSalt s (2 :: Int)) d
+    hashWithSalt s (VStr t) = hashWithSalt (hashWithSalt s (3 :: Int)) t
+    hashWithSalt s (VBool b) = hashWithSalt (hashWithSalt s (4 :: Int)) b
+
+-- | 一行数据
+type Row = [(String, Value)]
+
+-- | 一张表：名字、列定义与全部行
+data Table = Table
+    { tableName :: String
+    , tableCols :: [(String, Column)]
+    , tableRows :: [Row]
+    }
+    deriving (Show)
+
+-- | 库：库名到表的映射
+type Database = [(String, Table)]
+
+-- | 取表的列名
+colNames :: Table -> [String]
+colNames = map fst . tableCols
+
+-- | 查某列的定义
+colType :: Table -> String -> Maybe Column
+colType t c = lookup c (tableCols t)
+
+-- | 按名查表，没有就报错
+lookupTable :: Database -> String -> Either String Table
+lookupTable db t = maybe (Left ("unknown table: " ++ t)) Right (lookup t db)
+
+-- | 通配列名
+allColumns :: String
+allColumns = "*"
+
+-- | 给列名加别名前缀
+qualify :: Maybe String -> String -> String
+qualify Nothing c = c
+qualify (Just a) c = a ++ "." ++ c
+
+-- | 去掉别名前缀
+unqualify :: Maybe String -> String -> String
+unqualify Nothing c = c
+unqualify (Just a) c = fromMaybe c (stripPrefix (a ++ ".") c)
+
+-- | 裸列仅允许唯一匹配，限定名必须精确匹配
+resolveColumn :: String -> [(String, a)] -> Either String (String, a)
+resolveColumn name env = case [(k, v) | (k, v) <- env, matches k] of
+    [entry] -> Right entry
+    [] -> Left ("unknown column: " ++ name)
+    _ -> Left ("ambiguous column: " ++ name)
+  where
+    -- | 裸名或带后缀的名称
+    matches k = k == name || ('.' : name) `isSuffixOf` k

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

@@ -0,0 +1,357 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChuSQL.Core.Protocol (
+    SchemaColumn (..),
+    Request (..),
+    Response (..),
+    TableInfo (..),
+    Account (..),
+    QueryResult (..),
+    valueToJSON,
+    valueFromJSON,
+    rowToJSON,
+    rowFromJSON,
+    queryResultJson,
+) where
+
+import ChuSQL.Core.Model (Row, Value (..))
+import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.!=), (.=))
+import qualified Data.Aeson as A
+import qualified Data.Aeson.Key as K
+import qualified Data.Aeson.KeyMap as KM
+import Data.Aeson.Types (Parser)
+import Data.Scientific (floatingOrInteger, fromFloatDigits)
+import qualified Data.Text as T
+import Data.Text (Text)
+
+-- 线上协议类型：存储层请求/响应与查询结果集。
+
+-- | 数据字典里一列的线上形状
+data SchemaColumn = SchemaColumn
+    { scName :: String
+    , scType :: String
+    , scNullable :: Bool
+    , scDefault :: Maybe Value
+    , scAutoIncrement :: Bool
+    , scPrimaryKey :: Bool
+    , scUnique :: Bool
+    , scCheck :: Maybe String
+    }
+    deriving (Show, Eq)
+
+-- | 列编码成 JSON
+instance ToJSON SchemaColumn where
+    toJSON sc =
+        object
+            [ "name" .= scName sc
+            , "ty" .= scType sc
+            , "nullable" .= scNullable sc
+            , "default" .= fmap valueToJSON (scDefault sc)
+            , "auto_increment" .= scAutoIncrement sc
+            , "primary_key" .= scPrimaryKey sc
+            , "unique" .= scUnique sc
+            , "check" .= scCheck sc
+            ]
+
+-- | JSON 解回列
+instance FromJSON SchemaColumn where
+    parseJSON = withObject "SchemaColumn" $ \o -> do
+        n <- o .: "name"
+        t <- o .: "ty"
+        nullable <- o .:? "nullable" .!= True
+        defJson <- o .:? "default"
+        def <- mapM valueFromJSON defJson
+        auto <- o .:? "auto_increment" .!= False
+        pk <- o .:? "primary_key" .!= False
+        uniq <- o .:? "unique" .!= False
+        chk <- o .:? "check"
+        pure (SchemaColumn n t nullable def auto pk uniq chk)
+
+-- | 存储层请求
+data Request
+    = ReqPing
+    | ReqDatabase String String
+    | ReqAllCatalog
+    | ReqInDatabase String Request
+    | ReqAccountsList
+    | ReqAccountCreate T.Text T.Text
+    | ReqAccountReset T.Text T.Text
+    | ReqAccountLogin T.Text (Maybe T.Text)
+    | ReqAccountDrop T.Text
+    | ReqScan String
+    | ReqScanColumns String [String]
+    | ReqInsert String Row
+    | ReqInsertBatch String [Row]
+    | ReqDeleteKeys String [Int]
+    | ReqReplaceAll String [Row]
+    | ReqListTables
+    | ReqLookupByColumn String String Value
+    | ReqRangeByIndex String String (Maybe (Value, Bool)) (Maybe (Value, Bool))
+    | ReqDescribeTable String
+    | ReqCreateTable String [SchemaColumn]
+    | ReqDropTable String
+    | ReqCreateIndex String String
+    | ReqDropIndex String String
+    | ReqDropColumn String String
+    | ReqReplaceSchema String [SchemaColumn] [Row]
+    | ReqListCatalog
+
+-- | 请求编码成 JSON
+instance ToJSON Request where
+    toJSON (ReqDatabase method name) = object ["method" .= method, "database" .= name]
+    toJSON ReqAllCatalog = object ["method" .= ("all_catalogs" :: T.Text)]
+    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 ReqAccountsList = object ["method" .= ("accounts_list" :: T.Text)]
+    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]
+    toJSON (ReqAccountDrop u) = object ["method" .= ("account_drop" :: T.Text), "user" .= u]
+    toJSON ReqPing = object ["method" .= ("ping" :: T.Text)]
+    toJSON (ReqScan t) = object ["method" .= ("scan" :: T.Text), "table" .= t]
+    toJSON (ReqScanColumns t cols) = object ["method" .= ("scan" :: T.Text), "table" .= t, "columns" .= cols]
+    toJSON (ReqInsert t r) =
+        object
+            [ "method" .= ("insert" :: T.Text)
+            , "table" .= t
+            , "row" .= rowToJSON r
+            ]
+    toJSON (ReqInsertBatch t rs) =
+        object
+            [ "method" .= ("insert_batch" :: T.Text)
+            , "table" .= t
+            , "rows" .= map rowToJSON rs
+            ]
+    toJSON (ReqDeleteKeys t ks) =
+        object
+            [ "method" .= ("delete_keys" :: T.Text)
+            , "table" .= t
+            , "keys" .= ks
+            ]
+    toJSON (ReqReplaceAll t rs) =
+        object
+            [ "method" .= ("replace_all" :: T.Text)
+            , "table" .= t
+            , "rows" .= map rowToJSON rs
+            ]
+    toJSON ReqListTables = object ["method" .= ("list_tables" :: T.Text)]
+    toJSON (ReqLookupByColumn t c k) =
+        object
+            [ "method" .= ("lookup_by_index" :: T.Text)
+            , "table" .= t
+            , "column" .= c
+            , "key" .= valueToJSON k
+            ]
+    toJSON (ReqRangeByIndex t c lo hi) =
+        object
+            [ "method" .= ("range_by_index" :: T.Text)
+            , "table" .= t
+            , "column" .= c
+            , "lo" .= fmap (valueToJSON . fst) lo
+            , "lo_inclusive" .= maybe True snd lo
+            , "hi" .= fmap (valueToJSON . fst) hi
+            , "hi_inclusive" .= maybe True snd hi
+            ]
+    toJSON (ReqDescribeTable t) =
+        object
+            [ "method" .= ("describe_table" :: T.Text)
+            , "table" .= t
+            ]
+    toJSON (ReqCreateTable t cols) =
+        object
+            [ "method" .= ("create_table" :: T.Text)
+            , "table" .= t
+            , "columns" .= cols
+            ]
+    toJSON (ReqDropTable t) =
+        object ["method" .= ("drop_table" :: T.Text), "table" .= t]
+    toJSON (ReqCreateIndex t c) =
+        object
+            [ "method" .= ("create_index" :: T.Text)
+            , "table" .= t
+            , "column" .= c
+            ]
+    toJSON (ReqDropIndex t c) =
+        object
+            [ "method" .= ("drop_index" :: T.Text)
+            , "table" .= t
+            , "column" .= c
+            ]
+    toJSON (ReqDropColumn t c) =
+        object
+            [ "method" .= ("drop_column" :: T.Text)
+            , "table" .= t
+            , "column" .= c
+            ]
+    toJSON (ReqReplaceSchema t cols rs) =
+        object
+            [ "method" .= ("replace_schema" :: T.Text)
+            , "table" .= t
+            , "columns" .= cols
+            , "rows" .= map rowToJSON rs
+            ]
+    toJSON ReqListCatalog = object ["method" .= ("list_catalog" :: T.Text)]
+
+-- | 一张表的梗概：列、行数、索引与列统计
+data TableInfo = TableInfo
+    { tiTable :: String
+    , tiColumns :: [SchemaColumn]
+    , tiRows :: Int
+    , tiIndexes :: [String]
+    , tiStats :: [(String, Int, Bool)]
+    }
+    deriving (Show, Eq)
+
+-- | 表信息编码成 JSON
+instance ToJSON TableInfo where
+    toJSON info =
+        object
+            [ "table" .= tiTable info
+            , "columns" .= tiColumns info
+            , "row_count" .= tiRows info
+            , "indexes" .= map (\name -> object ["column" .= name]) (tiIndexes info)
+            , "stats" .= map statJson (tiStats info)
+            ]
+      where
+        statJson (name, distinct, capped) =
+            object ["name" .= name, "distinct" .= distinct, "capped" .= capped]
+
+-- | JSON 解回表信息
+instance FromJSON TableInfo where
+    parseJSON = withObject "TableInfo" $ \o -> do
+        table <- o .: "table"
+        columns <- o .: "columns"
+        count <- o .: "row_count"
+        indexes <- o .:? "indexes" .!= []
+        stats <- o .:? "stats" .!= []
+        indexColumns <- mapM (\v -> withObject "IndexWire" (.: "column") v) (indexes :: [A.Value])
+        parsedStats <- mapM parseStat (stats :: [A.Value])
+        pure (TableInfo table columns count indexColumns parsedStats)
+      where
+        parseStat = withObject "ColumnStat" $ \o -> do
+            name <- o .: "name"
+            distinct <- o .: "distinct"
+            capped <- o .:? "capped" .!= False
+            pure (name, distinct, capped)
+
+-- | 一条账号记录
+data Account = Account
+    { accountId :: Integer
+    , accountUser :: T.Text
+    , accountHash :: T.Text
+    , accountRevision :: Integer
+    , accountRegisteredAt :: T.Text
+    , accountLastLoginAt :: Maybe T.Text
+    } deriving (Eq)
+
+-- | 账号的展示：只露账号名与版本号
+instance Show Account where
+    show a = "Account " ++ show (accountUser a) ++ " revision=" ++ show (accountRevision a)
+
+-- | JSON 解回账号
+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"
+
+-- | 账号编码成 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]
+
+-- | 存储层响应
+data Response
+    = RespPong
+    | RespAccounts [Account]
+    | RespRows [Row]
+    | RespTables [String]
+    | RespSchema TableInfo
+    | RespNoIndex
+    | RespOk
+    | RespError String
+    | RespCatalog [TableInfo]
+
+-- | JSON 解回响应
+instance FromJSON Response where
+    parseJSON = withObject "Response" $ \o -> do
+        status <- o .: "status"
+        case status :: T.Text of
+            "accounts" -> RespAccounts <$> o .: "accounts"
+            "pong" -> pure RespPong
+            "ok" -> pure RespOk
+            "no_index" -> pure RespNoIndex
+            "rows" -> RespRows <$> (o .: "rows" >>= mapM rowFromJSON)
+            "tables" -> RespTables <$> o .: "tables"
+            "error" -> RespError <$> o .: "message"
+            "schema" -> RespSchema <$> parseJSON (A.Object o)
+            "catalog" -> do
+                xs <- o .: "schemas" :: Parser [A.Value]
+                RespCatalog <$> mapM parseJSON xs
+            other -> fail ("unknown status: " ++ T.unpack other)
+
+-- | 值编码成 JSON
+valueToJSON :: Value -> A.Value
+valueToJSON VNull = A.Null
+valueToJSON (VInt n) = A.Number (fromIntegral n)
+valueToJSON (VFloat d) = A.Number (fromFloatDigits d)
+valueToJSON (VStr s) = A.String (T.pack s)
+valueToJSON (VBool b) = A.Bool b
+
+-- | JSON 解回值
+valueFromJSON :: A.Value -> Parser Value
+valueFromJSON A.Null = pure VNull
+valueFromJSON (A.Number n) =
+    case floatingOrInteger n :: Either Double Integer of
+        Right i -> pure (VInt (fromIntegral i))
+        Left d -> pure (VFloat d)
+valueFromJSON (A.String s) = pure (VStr (T.unpack s))
+valueFromJSON (A.Bool b) = pure (VBool b)
+valueFromJSON _ = fail "unsupported value type"
+
+-- | 一行编码成 JSON
+rowToJSON :: Row -> A.Value
+rowToJSON r =
+    A.Object (KM.fromList [(K.fromString k, valueToJSON v) | (k, v) <- r])
+
+-- | JSON 解回一行
+rowFromJSON :: A.Value -> Parser Row
+rowFromJSON (A.Object o) = mapM toPair (KM.toList o)
+  where
+    -- | 键值对解成一个字段
+    toPair (k, v) = do
+        val <- valueFromJSON v
+        pure (K.toString k, val)
+rowFromJSON _ = fail "row must be a JSON object"
+
+-- | 一条语句的结果集：列名与排好的行
+data QueryResult = QueryResult
+    { qrColumns :: [Text]
+    , qrRows :: [[Value]]
+    , qrRowCount :: Int
+    , qrTruncated :: Bool
+    , qrDatabase :: Maybe Text
+    }
+    deriving (Eq, Show)
+
+-- | JSON 解回结果集
+instance FromJSON QueryResult where
+    parseJSON = withObject "QueryResult" $ \o -> do
+        cols <- o .: "columns"
+        rows <- o .: "rows"
+        QueryResult cols <$> mapM (mapM valueFromJSON) rows
+            <*> o .:? "rowCount" .!= 0
+            <*> o .:? "truncated" .!= False
+            <*> o .:? "database"
+
+-- | 结果还原成 JSON（JSON 输出与 TCP 结果集共用）
+queryResultJson :: QueryResult -> A.Value
+queryResultJson result =
+    object
+        [ "columns" .= qrColumns result
+        , "rows" .= map (map valueToJSON) (qrRows result)
+        , "rowCount" .= qrRowCount result
+        , "truncated" .= qrTruncated result
+        , "database" .= qrDatabase result
+        ]

chusql-core/model/stack.yaml

@@ -0,0 +1,4 @@
+resolver: lts-24.59
+
+packages:
+    - .

chusql-core/model/stack.yaml.lock

@@ -0,0 +1,12 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/topics/lock_files
+
+packages: []
+snapshots:
+- completed:
+    sha256: 0f728e30e843d7f00460ad56858b995a3b227fca683659c7df9f2fc3988a3ce1
+    size: 732465
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/59.yaml
+  original: lts-24.59