77 lines
4.1 KiB
Haskell
77 lines
4.1 KiB
Haskell
|
{-# LANGUAGE OverloadedStrings #-}
|
||
|
|
|
||
|
|
module ChuSQL.Bootstrap (preinstalledTypes, runBootstrap) where
|
||
|
|
|
||
|
|
import ChuSQL.Core.Model (ColumnType (..), typeName)
|
||
|
|
import ChuSQL.Core.Protocol (Account (..))
|
||
|
|
import qualified Data.Aeson as A
|
||
|
|
import qualified Data.Aeson.KeyMap as KM
|
||
|
|
import Data.Foldable (toList)
|
||
|
|
import Data.Text (Text)
|
||
|
|
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)
|
||
|
|
]
|
||
|
|
where
|
||
|
|
-- | 编码类型的名称与基础表示
|
||
|
|
definition :: (Text, ColumnType, Bool) -> A.Value
|
||
|
|
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)
|
||
|
|
runBootstrap send name encoded = do
|
||
|
|
initialized <- send (A.object ["method" A..= ("bootstrap_system" :: Text), "user" A..= name, "password_hash" A..= encoded])
|
||
|
|
case expect "system" initialized >>= initializedCatalog of
|
||
|
|
Left err -> pure (Left err)
|
||
|
|
Right () -> do
|
||
|
|
migrated <- send (A.object ["method" A..= ("identity_initialize" :: Text), "administrator" A..= name])
|
||
|
|
case expect "accounts" migrated >>= administrator of
|
||
|
|
Left err -> pure (Left err)
|
||
|
|
Right () -> 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
|
||
|
|
A.Error _ -> Left "invalid identity directory"
|
||
|
|
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 _ _ = False
|
||
|
|
|
||
|
|
-- | 校验响应状态并返回明确错误
|
||
|
|
expect :: Text -> Either String A.Value -> Either String (KM.KeyMap A.Value)
|
||
|
|
expect _ (Left err) = Left err
|
||
|
|
expect status (Right (A.Object fields))
|
||
|
|
| KM.lookup "status" fields == Just (A.String status) = Right fields
|
||
|
|
| Just (A.String err) <- KM.lookup "message" fields = Left (T.unpack err)
|
||
|
|
| otherwise = Left ("unexpected bootstrap response; expected " ++ T.unpack status)
|
||
|
|
expect _ (Right _) = Left "invalid bootstrap response"
|