修bug，完善功能

chusql-bootstrap/app/Main.hs

@@ -2,19 +2,19 @@
 
 module Main (main) where
 
-import Data.Maybe (fromMaybe)
-import ChuSQL.Core.Engine.Storage.IPC (closeConnection, localStorageLink, sendRawRequest, setStorageLink)
 import ChuSQL.Bootstrap (preinstalledTypes, runBootstrap)
 import ChuSQL.Core.Engine.Storage.FFI (maintainStorage)
+import ChuSQL.Core.Engine.Storage.IPC (closeConnection, localStorageLink, sendRawRequest, setStorageLink)
 import ChuSQL.Interface.Auth (hashPassword)
 import ChuSQL.Interface.Config (loadWebConfigAt, rootUserName)
 import ChuSQL.Interface.TOML (resolveConfigPath)
+import Control.Exception (finally)
 import qualified Data.Aeson as A
 import qualified Data.ByteString.Lazy.Char8 as BL
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.IO as TIO
-import Control.Exception (finally)
 import System.Environment (getArgs)
 import System.Exit (exitFailure)
 import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout)
@@ -46,7 +46,7 @@ emptyOptions =
 parseArgs :: [String] -> Either String Options
 parseArgs = go emptyOptions
   where
-    -- | 逐条消费参数列表
+    -- \| 逐条消费参数列表
     go opts [] = Right opts
     go opts (command : rest)
         | command `elem` ["repair", "recover", "recovery", "reset"] = case optMode opts of
@@ -156,8 +156,9 @@ send request = do
 readPassword :: Options -> IO (Either String Text)
 readPassword opts
     | optPasswordless opts = pure (Right "")
-    | optPasswordStdin opts = do Right . T.dropWhileEnd (\ c -> c == '\r' || c == '\n')
-                                   <$> TIO.getLine
+    | optPasswordStdin opts = do
+        Right . T.dropWhileEnd (\c -> c == '\r' || c == '\n')
+            <$> TIO.getLine
     | otherwise = pure (Left "pass --password-stdin or --passwordless")
 
 -- | 打印错误并退出 1

chusql-bootstrap/src/ChuSQL/Bootstrap.hs

@@ -14,21 +14,34 @@ import qualified Data.Text as T
 
 -- | 现有内置类型及其默认参数
 preinstalledTypes :: [A.Value]
-preinstalledTypes = map definition
-    [ ("int", CInt, False), ("integer", CInt, False)
-    , ("bigint", CBigInt, False), ("smallint", CSmallInt, False)
-    , ("varchar", CStr, True), ("char", CChar 1, True)
-    , ("text", CStr, False), ("str", CStr, False)
-    , ("boolean", CBool, False), ("bool", CBool, False)
-    , ("float", CFloat, False), ("real", CFloat, False), ("double", CDouble, False)
-    , ("decimal", CDecimal 10 0, True), ("numeric", CDecimal 10 0, True)
-    , ("date", CDate, False), ("timestamp", CTimestamp, False), ("blob", CBlob, False)
-    ]
+preinstalledTypes =
+    map
+        definition
+        [ ("int", CInt, False)
+        , ("integer", CInt, False)
+        , ("bigint", CBigInt, False)
+        , ("smallint", CSmallInt, False)
+        , ("varchar", CStr, True)
+        , ("char", CChar 1, True)
+        , ("text", CStr, False)
+        , ("str", CStr, False)
+        , ("boolean", CBool, False)
+        , ("bool", CBool, False)
+        , ("float", CFloat, False)
+        , ("real", CFloat, False)
+        , ("double", CDouble, False)
+        , ("decimal", CDecimal 10 0, True)
+        , ("numeric", CDecimal 10 0, True)
+        , ("date", CDate, False)
+        , ("timestamp", CTimestamp, False)
+        , ("blob", CBlob, False)
+        ]
   where
-    -- | 编码类型的名称与基础表示
+    -- \| 编码类型的名称与基础表示
     definition :: (Text, ColumnType, Bool) -> A.Value
-    definition (name, base, parameterized) = A.object
-        ["name" A..= name, "base_type" A..= typeName base, "parameterized" A..= parameterized]
+    definition (name, base, parameterized) =
+        A.object
+            ["name" A..= name, "base_type" A..= typeName base, "parameterized" A..= parameterized]
 
 -- | 依次引导身份、迁移目录并预装类型
 runBootstrap :: (A.Value -> IO (Either String A.Value)) -> Text -> Text -> IO (Either String Int)
@@ -44,11 +57,11 @@ runBootstrap send name encoded = do
                     installed <- send (A.object ["method" A..= ("bootstrap_types" :: Text), "types" A..= preinstalledTypes])
                     pure (expect "rows" installed >>= installedTypes)
   where
-    -- | 确认系统目录已初始化
+    -- \| 确认系统目录已初始化
     initializedCatalog fields
         | KM.lookup "initialized" fields == Just (A.Bool True) = Right ()
         | otherwise = Left "system catalog is not initialized"
-    -- | 确认所选引导身份可以管理系统
+    -- \| 确认所选引导身份可以管理系统
     administrator fields = case KM.lookup "accounts" fields of
         Nothing -> Left "missing identity directory"
         Just value -> case A.fromJSON value :: A.Result [Account] of
@@ -56,15 +69,16 @@ runBootstrap send name encoded = do
             A.Success accounts
                 | any (\a -> accountUser a == T.toLower name && accountCanLogin a && accountEnabled a && accountIsSuperuser a) accounts -> Right ()
                 | otherwise -> Left "bootstrap identity is not an enabled login superuser; existing identities were preserved"
-    -- | 确认全部预装类型存在且定义一致
+    -- \| 确认全部预装类型存在且定义一致
     installedTypes fields = case KM.lookup "rows" fields of
         Just (A.Array rows)
             | all (\definition -> any (matches definition) (toList rows)) preinstalledTypes -> Right (length rows)
             | otherwise -> Left "preinstalled type verification failed"
         _ -> Left "missing preinstalled type directory"
-    -- | 比对类型定义并检查持久化编号
-    matches (A.Object definition) (A.Object saved) = all (\(key, value) -> KM.lookup key saved == Just value) (KM.toList definition)
-        && case KM.lookup "id" saved of Just (A.Number n) -> n > 0; _ -> False
+    -- \| 比对类型定义并检查持久化编号
+    matches (A.Object definition) (A.Object saved) =
+        all (\(key, value) -> KM.lookup key saved == Just value) (KM.toList definition)
+            && case KM.lookup "id" saved of Just (A.Number n) -> n > 0; _ -> False
     matches _ _ = False
 
 -- | 校验响应状态并返回明确错误

chusql-bootstrap/test/Spec.hs

@@ -2,18 +2,18 @@
 
 module Main (main) where
 
-import Data.Maybe (fromMaybe)
 import ChuSQL.Bootstrap (preinstalledTypes, runBootstrap)
-import ChuSQL.Core.Protocol (Account (..))
-import ChuSQL.Core.Model (columnType, typeName)
+import ChuSQL.Core.Engine.Storage.IPC (closeConnection, localStorageLink, sendRawRequest, setStorageLink)
 import ChuSQL.Core.Engine.Syntax.AST (Statement (CreateTable))
 import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
-import ChuSQL.Core.Engine.Storage.IPC (closeConnection, localStorageLink, sendRawRequest, setStorageLink)
+import ChuSQL.Core.Model (columnType, typeName)
+import ChuSQL.Core.Protocol (Account (..))
 import Control.Exception (finally)
 import qualified Data.Aeson as A
 import qualified Data.Aeson.KeyMap as KM
 import qualified Data.ByteString.Lazy as BL
-import Data.IORef (newIORef, readIORef, modifyIORef')
+import Data.IORef (modifyIORef', newIORef, readIORef)
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Unique (hashUnique, newUnique)
@@ -33,7 +33,8 @@ main = hspec $ do
             runBootstrap send "root" "new-hash" `shouldReturn` Right 18
             calls <- requests
             map (field "method") calls `shouldBe` map A.String ["bootstrap_system", "identity_initialize", "bootstrap_types"]
-        mapM_ (\(title, replies, err) -> it title (expectBootstrapFailure replies err))
+        mapM_
+            (\(title, replies, err) -> it title (expectBootstrapFailure replies err))
             [ ("stops on storage errors", [Left "storage unavailable"], "storage unavailable")
             , ("rejects an uninitialized system response", [Right (A.object ["status" A..= ("system" :: Text), "initialized" A..= False])], "system catalog is not initialized")
             , ("preserves a demoted identity and stops before type installation", [Right ready, Right (identity False)], "bootstrap identity is not an enabled login superuser; existing identities were preserved")
@@ -86,9 +87,9 @@ identity super = A.object ["status" A..= ("accounts" :: Text), "accounts" A..= [
 
 -- | 已写入编号的类型响应
 installed :: A.Value
-installed = A.object ["status" A..= ("rows" :: Text), "rows" A..= zipWith (curry numbered) [1 :: Int .. ] preinstalledTypes]
+installed = A.object ["status" A..= ("rows" :: Text), "rows" A..= zipWith (curry numbered) [1 :: Int ..] preinstalledTypes]
   where
-    -- | 给预装定义添加持久化编号
+    -- \| 给预装定义添加持久化编号
     numbered (n, A.Object fields) = A.Object (KM.insert "id" (A.toJSON n) fields)
     numbered (_, value) = value
 
@@ -103,7 +104,7 @@ mock replies = do
     calls <- newIORef []
     queuedReplies <- newIORef replies
     let
-        -- | 消费一条模拟响应
+        -- \| 消费一条模拟响应
         send request = do
             modifyIORef' calls (++ [request])
             remaining <- readIORef queuedReplies