大更新：
1、完善SQL语法 2、移除node前端，只保留静态资源 3、写好安装脚本 4、做好linux适配
This commit is contained in:
LIm1tZz7 committed
1 parent
687c012841
commit
df6d348995
166 files changed
+16317
-10763
No files matched your search
@@ -0,0 +1,257 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChuSQL.Web.Accounts (
|
||||
Accounts, AccountError (..), Principal (..), PasswordPolicy (..), defaultPasswordPolicy,
|
||||
newAccounts, accountsPolicy, setAccountsPolicy, passwordAllowed,
|
||||
rootUserName, principalName, principalIsRoot,
|
||||
authenticate, currentPrincipal,
|
||||
listAccounts, findAccount, AccountCommand (..), accountCommand, runAccountCommand,
|
||||
) where
|
||||
|
||||
import ChuSQL.Storage.IPC (Account (..), Request (..))
|
||||
import ChuSQL.Syntax.AST (Statement (..))
|
||||
import ChuSQL.Web.Auth
|
||||
import ChuSQL.Web.Backend (Backend (..), currentStamp)
|
||||
import Control.Concurrent.MVar (MVar, newMVar, withMVar)
|
||||
import Data.Char (isAlphaNum, isAscii, isAsciiLower, isAsciiUpper, isDigit)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
||||
-- 账号服务：root 来自配置，普通账号由 root 用 CREATE/ALTER/DROP USER 管，口令在这里做策略检查与 PBKDF2 派生。
|
||||
|
||||
data PasswordPolicy = PasswordPolicy
|
||||
{ ppMinLength :: Int
|
||||
, ppClasses :: Int
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 默认：至少 12 个字符、至少两类字符
|
||||
defaultPasswordPolicy :: PasswordPolicy
|
||||
defaultPasswordPolicy = PasswordPolicy 12 2
|
||||
|
||||
data AccountError = AccountError Text Text deriving (Show, Eq)
|
||||
|
||||
-- | 当前身份：配置里的管理员，或系统表里的一个普通账号
|
||||
data Principal
|
||||
= Root Text
|
||||
| Ordinary Account
|
||||
deriving (Eq)
|
||||
|
||||
instance Show Principal where
|
||||
show (Root name) = "root " ++ show name
|
||||
show (Ordinary a) = "account " ++ show (accountUser a)
|
||||
|
||||
-- | 这个身份叫什么
|
||||
principalName :: Principal -> Text
|
||||
principalName (Root name) = name
|
||||
principalName (Ordinary a) = accountUser a
|
||||
|
||||
-- | 是不是配置里的管理员
|
||||
principalIsRoot :: Principal -> Bool
|
||||
principalIsRoot (Root _) = True
|
||||
principalIsRoot (Ordinary _) = False
|
||||
|
||||
data Accounts = Accounts
|
||||
{ acBackend :: Backend
|
||||
, acSessions :: SessionStore
|
||||
, acLock :: MVar ()
|
||||
, acPolicy :: IORef PasswordPolicy
|
||||
, acRoot :: Credential
|
||||
}
|
||||
|
||||
-- | 只记下配置根账号；root 不写系统表，所以启动时不需要任何持久化动作
|
||||
newAccounts :: Backend -> SessionStore -> Credential -> IO Accounts
|
||||
newAccounts backend sessions credential = do
|
||||
lock <- newMVar ()
|
||||
policy <- newIORef defaultPasswordPolicy
|
||||
pure (Accounts backend sessions lock policy credential)
|
||||
|
||||
-- | 账号名统一小写去空白
|
||||
normalize :: Text -> Text
|
||||
normalize = T.toLower . T.strip
|
||||
|
||||
-- | 配置里的管理员叫什么
|
||||
rootName :: Accounts -> Text
|
||||
rootName = normalize . credUser . acRoot
|
||||
|
||||
-- | 管理员名字（界面显示用）
|
||||
rootUserName :: Accounts -> Text
|
||||
rootUserName = rootName
|
||||
|
||||
accountsPolicy :: Accounts -> IO PasswordPolicy
|
||||
accountsPolicy = readIORef . acPolicy
|
||||
|
||||
setAccountsPolicy :: Accounts -> PasswordPolicy -> IO ()
|
||||
setAccountsPolicy service = writeIORef (acPolicy service)
|
||||
|
||||
-- | 口令策略：长度 + 字符类别（历史与有效期随自助改密一起取消）
|
||||
passwordAllowed :: PasswordPolicy -> Text -> Either AccountError ()
|
||||
passwordAllowed policy password
|
||||
| T.length password < ppMinLength policy || T.length password > 256 = bad "password length does not meet policy"
|
||||
| classes < ppClasses policy = bad "password needs more character classes"
|
||||
| otherwise = Right ()
|
||||
where
|
||||
bad = Left . AccountError "bad_request"
|
||||
classes =
|
||||
length
|
||||
( filter id
|
||||
[ T.any isAsciiLower password
|
||||
, T.any isAsciiUpper password
|
||||
, T.any isDigit password
|
||||
, T.any (not . isAlphaNum) password
|
||||
]
|
||||
)
|
||||
|
||||
-- | 账号名规则：ASCII 字母数字与点、短横线、下划线
|
||||
validateUserName :: Text -> Either AccountError ()
|
||||
validateUserName name
|
||||
| T.null name || T.length name > 64 || not (T.all allowed name) =
|
||||
Left (AccountError "bad_request" "invalid account name")
|
||||
| otherwise = Right ()
|
||||
where
|
||||
allowed c = isAscii c && (isAlphaNum c || c `elem` ("_.-" :: String))
|
||||
|
||||
-- | 新建/改口令时的额外限制：管理员的名字保留给配置里的 root
|
||||
validateNewName :: Accounts -> Text -> Either AccountError ()
|
||||
validateNewName service name = do
|
||||
validateUserName name
|
||||
if normalize name == rootName service
|
||||
then Left (AccountError "bad_request" "the administrator name is reserved")
|
||||
else Right ()
|
||||
|
||||
storageFailure :: AccountError
|
||||
storageFailure = AccountError "storage_error" "account storage unavailable"
|
||||
|
||||
unauthorized :: AccountError
|
||||
unauthorized = AccountError "unauthorized" "invalid account or session"
|
||||
|
||||
-- | 存储侧报错翻成账号错误
|
||||
storageResult :: Either String [Account] -> Either AccountError ()
|
||||
storageResult (Right _) = Right ()
|
||||
storageResult (Left "account already exists") = Left (AccountError "conflict" "account already exists")
|
||||
storageResult (Left "unknown account") = Left (AccountError "not_found" "unknown account")
|
||||
storageResult (Left _) = Left storageFailure
|
||||
|
||||
-- | 读系统表里的普通账号
|
||||
readAccounts :: Accounts -> IO (Either AccountError [Account])
|
||||
readAccounts service = fmap (either (const (Left storageFailure)) Right) (beAccounts (acBackend service) ReqAccountsList)
|
||||
|
||||
-- | 当前令牌对应的身份；会话版本与账号 revision 对不上就失效
|
||||
currentUnlocked :: Accounts -> Text -> IO (Either AccountError Principal)
|
||||
currentUnlocked service token = do
|
||||
session <- lookupVersionedSession (acSessions service) token
|
||||
case session of
|
||||
Nothing -> pure (Left unauthorized)
|
||||
Just (user, revision)
|
||||
| user == rootName service && revision == Nothing -> pure (Right (Root (rootName service)))
|
||||
| otherwise -> do
|
||||
stored <- readAccounts service
|
||||
pure $ do
|
||||
accounts <- stored
|
||||
account <- case filter ((== user) . accountUser) accounts of
|
||||
[a] -> Right a
|
||||
_ -> Left unauthorized
|
||||
if revision == Just (accountRevision account)
|
||||
then Right (Ordinary account)
|
||||
else Left unauthorized
|
||||
|
||||
currentPrincipal :: Accounts -> Text -> IO (Either AccountError Principal)
|
||||
currentPrincipal service token = withMVar (acLock service) $ \_ -> currentUnlocked service token
|
||||
|
||||
-- | 登录：先比配置里的 root，再查系统表里的普通账号（没有切换身份的入口）。
|
||||
-- 配置里的口令留空即"免密"：只有管理员能用空口令进来，普通账号一律拒绝。
|
||||
authenticate :: Accounts -> Text -> Text -> IO (Either AccountError Text)
|
||||
authenticate service user password = withMVar (acLock service) $ \_ ->
|
||||
if normalize user == rootName service
|
||||
then signInRoot
|
||||
else
|
||||
if passwordless
|
||||
then pure (Left (AccountError "forbidden" "this server only accepts the administrator"))
|
||||
else signInOrdinary
|
||||
where
|
||||
passwordless = T.null (credEncoded (acRoot service))
|
||||
signInRoot
|
||||
| passwordless =
|
||||
if T.null password
|
||||
then Right <$> createVersionedSession (acSessions service) (rootName service) Nothing
|
||||
else pure (Left unauthorized)
|
||||
| verifyPassword (credEncoded (acRoot service)) password =
|
||||
Right <$> createVersionedSession (acSessions service) (rootName service) Nothing
|
||||
| otherwise = pure (Left unauthorized)
|
||||
signInOrdinary = do
|
||||
stored <- readAccounts service
|
||||
case stored of
|
||||
Left err -> pure (Left err)
|
||||
Right accounts -> case filter ((== normalize user) . accountUser) accounts of
|
||||
[a] | verifyPassword (accountHash a) password -> do
|
||||
stamp <- currentStamp
|
||||
written <- beAccounts (acBackend service) (ReqAccountLogin (accountUser a) (Just stamp))
|
||||
case written of
|
||||
Left _ -> pure (Left storageFailure)
|
||||
Right _ -> Right <$> createVersionedSession (acSessions service) (accountUser a) (Just (accountRevision a))
|
||||
_ -> pure (Left unauthorized)
|
||||
|
||||
-- | 系统表里的普通账号清单（root 专用）
|
||||
listAccounts :: Accounts -> IO (Either AccountError [Account])
|
||||
listAccounts service = withMVar (acLock service) $ \_ -> readAccounts service
|
||||
|
||||
-- | 按用户名找一个普通账号
|
||||
findAccount :: Accounts -> Text -> IO (Either AccountError Account)
|
||||
findAccount service name = withMVar (acLock service) $ \_ -> do
|
||||
stored <- readAccounts service
|
||||
pure $ do
|
||||
accounts <- stored
|
||||
case filter ((== normalize name) . accountUser) accounts of
|
||||
[a] -> Right a
|
||||
[] -> Left (AccountError "not_found" "unknown account")
|
||||
_ -> Left storageFailure
|
||||
|
||||
-- | 建一个普通账号
|
||||
createUser :: Accounts -> Text -> Text -> IO (Either AccountError ())
|
||||
createUser service name password = withMVar (acLock service) $ \_ -> do
|
||||
policy <- accountsPolicy service
|
||||
case validateNewName service name >> passwordAllowed policy password of
|
||||
Left err -> pure (Left err)
|
||||
Right () -> do
|
||||
encoded <- hashPassword password
|
||||
storageResult <$> beAccounts (acBackend service) (ReqAccountCreate (normalize name) encoded)
|
||||
|
||||
-- | 改一个普通账号的口令（管理员重置，不受历史/有效期限制）
|
||||
resetPassword :: Accounts -> Text -> Text -> IO (Either AccountError ())
|
||||
resetPassword service name password = withMVar (acLock service) $ \_ -> do
|
||||
policy <- accountsPolicy service
|
||||
case validateNewName service name >> passwordAllowed policy password of
|
||||
Left err -> pure (Left err)
|
||||
Right () -> do
|
||||
encoded <- hashPassword password
|
||||
storageResult <$> beAccounts (acBackend service) (ReqAccountReset (normalize name) encoded)
|
||||
|
||||
-- | 删一个普通账号
|
||||
dropUser :: Accounts -> Text -> IO (Either AccountError ())
|
||||
dropUser service name = withMVar (acLock service) $ \_ ->
|
||||
case validateUserName name of
|
||||
Left err -> pure (Left err)
|
||||
Right () -> storageResult <$> beAccounts (acBackend service) (ReqAccountDrop (normalize name))
|
||||
|
||||
-- | 账号管理命令：SQL 语句与一键接口在这上面汇合
|
||||
data AccountCommand
|
||||
= CreateAccount Text Text
|
||||
| ResetAccountPassword Text Text
|
||||
| DropAccount Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 一条语句是不是账号管理语句
|
||||
accountCommand :: Statement -> Maybe AccountCommand
|
||||
accountCommand (CreateUser name password) = Just (CreateAccount (T.pack name) (T.pack password))
|
||||
accountCommand (AlterUser name password) = Just (ResetAccountPassword (T.pack name) (T.pack password))
|
||||
accountCommand (DropUser name) = Just (DropAccount (T.pack name))
|
||||
accountCommand _ = Nothing
|
||||
|
||||
-- | 执行一条账号管理命令；普通账号一律拒绝
|
||||
runAccountCommand :: Accounts -> Principal -> AccountCommand -> IO (Either AccountError ())
|
||||
runAccountCommand _ (Ordinary _) _ = pure (Left (AccountError "forbidden" "administrator required"))
|
||||
runAccountCommand service (Root _) command = case command of
|
||||
CreateAccount name password -> createUser service name password
|
||||
ResetAccountPassword name password -> resetPassword service name password
|
||||
DropAccount name -> dropUser service name
|
||||
@@ -9,6 +9,8 @@ module ChuSQL.Web.Actions (
|
||||
coerceValue,
|
||||
sqlLiteral,
|
||||
escapeStringLiteral,
|
||||
createDatabaseSql,
|
||||
dropDatabaseSql,
|
||||
createTableSql,
|
||||
dropTableSql,
|
||||
createIndexSql,
|
||||
@@ -19,9 +21,13 @@ module ChuSQL.Web.Actions (
|
||||
updateRowSql,
|
||||
deleteRowSql,
|
||||
selectRowsSql,
|
||||
createUserSql,
|
||||
alterUserSql,
|
||||
dropUserSql,
|
||||
) where
|
||||
|
||||
import ChuSQL.Model (Column (..), Value (..))
|
||||
import ChuSQL.Model (Column (..), ColumnType (..), Value (..), integerType, numericType, parseColumnType, plainColumn, typeName)
|
||||
import qualified ChuSQL.Model as M
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
|
||||
import Data.List (intercalate)
|
||||
@@ -69,21 +75,11 @@ requireNonEmpty what xs
|
||||
|
||||
-- | 线上列类型名（和数据字典里的写法一致）转本地类型
|
||||
columnTypeOf :: Text -> Maybe Column
|
||||
columnTypeOf t = case T.toLower (T.strip t) of
|
||||
"int" -> Just TInt
|
||||
"integer" -> Just TInt
|
||||
"str" -> Just TStr
|
||||
"text" -> Just TStr
|
||||
"varchar" -> Just TStr
|
||||
"bool" -> Just TBool
|
||||
"boolean" -> Just TBool
|
||||
_ -> Nothing
|
||||
columnTypeOf = fmap plainColumn . parseColumnType . T.unpack . T.strip
|
||||
|
||||
-- | 本地类型转线上名字
|
||||
columnTypeName :: Column -> Text
|
||||
columnTypeName TInt = "int"
|
||||
columnTypeName TStr = "str"
|
||||
columnTypeName TBool = "bool"
|
||||
columnTypeName = T.pack . typeName . columnType
|
||||
|
||||
-- | 字符串字面量转义：单引号翻倍（引擎的词法器就是这么折回去的）
|
||||
escapeStringLiteral :: String -> String
|
||||
@@ -91,31 +87,48 @@ 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"
|
||||
|
||||
-- | JSON 值按列类型转成引擎的值；类型对不上就报错
|
||||
coerceValue :: Column -> A.Value -> Either String Value
|
||||
coerceValue TInt v = case v of
|
||||
coerceValue col v = case v of
|
||||
A.Null -> Right VNull
|
||||
A.Bool b -> M.coerceValue t (VBool b)
|
||||
A.Number n -> case floatingOrInteger n :: Either Double Integer of
|
||||
Right i -> Right (VInt (fromIntegral i))
|
||||
Left _ -> Left "expected an integer"
|
||||
A.String s -> case readMaybe (T.unpack (T.strip s)) :: Maybe Int of
|
||||
Just i -> Right (VInt i)
|
||||
Nothing -> Left ("expected an integer, got: " ++ T.unpack s)
|
||||
_ -> Left "expected an integer"
|
||||
coerceValue TStr v = case v of
|
||||
A.String s -> Right (VStr (T.unpack s))
|
||||
_ -> Left "expected a string"
|
||||
coerceValue TBool v = case v of
|
||||
A.Bool b -> Right (VBool b)
|
||||
A.String s -> case T.toLower (T.strip s) of
|
||||
"true" -> Right (VBool True)
|
||||
"false" -> Right (VBool False)
|
||||
_ -> Left ("expected true/false, got: " ++ T.unpack s)
|
||||
_ -> Left "expected true/false"
|
||||
Right i -> M.coerceValue t (VInt (fromIntegral i))
|
||||
Left d -> M.coerceValue t (VFloat d)
|
||||
A.String s
|
||||
| integerType t -> case readMaybe (T.unpack (T.strip s)) :: Maybe Int of
|
||||
Just i -> M.coerceValue t (VInt i)
|
||||
Nothing -> Left ("expected an integer, got: " ++ T.unpack s)
|
||||
| numericType t -> case readMaybe (T.unpack (T.strip s)) :: Maybe Double of
|
||||
Just d -> M.coerceValue t (VFloat d)
|
||||
Nothing -> Left ("expected a number, got: " ++ T.unpack s)
|
||||
| t == CBool -> case T.toLower (T.strip s) of
|
||||
"true" -> Right (VBool True)
|
||||
"false" -> Right (VBool False)
|
||||
_ -> Left ("expected true/false, got: " ++ T.unpack s)
|
||||
| otherwise -> M.coerceValue t (VStr (T.unpack s))
|
||||
_ -> Left "unsupported value"
|
||||
where
|
||||
t = columnType col
|
||||
|
||||
-- | 构造 CREATE DATABASE
|
||||
createDatabaseSql :: Text -> Either String String
|
||||
createDatabaseSql name = do
|
||||
db <- checkIdent "database" name
|
||||
pure ("CREATE DATABASE " ++ T.unpack db)
|
||||
|
||||
-- | 构造 DROP DATABASE
|
||||
dropDatabaseSql :: Text -> Either String String
|
||||
dropDatabaseSql name = do
|
||||
db <- checkIdent "database" name
|
||||
pure ("DROP DATABASE " ++ T.unpack db)
|
||||
|
||||
-- | 构造 CREATE TABLE 语句
|
||||
createTableSql :: CreateTableSpec -> Either String String
|
||||
@@ -235,3 +248,38 @@ orderClause Nothing = pure ""
|
||||
orderClause (Just (column, ascending)) = do
|
||||
col <- checkIdent "column" column
|
||||
pure (" ORDER BY " ++ T.unpack col ++ (if ascending then " ASC" else " DESC"))
|
||||
|
||||
-- | 账号名：与普通标识符同一套规则，另允许点与短横线（写成字符串形式）
|
||||
accountName :: Text -> Either String Text
|
||||
accountName name
|
||||
| T.null name || T.length name > 64 = Left "account name is empty or too long"
|
||||
| not (T.all allowed name) = Left ("account name may only contain ASCII letters, digits, dot, dash or underscore: " ++ T.unpack name)
|
||||
| otherwise = Right name
|
||||
where
|
||||
allowed c = isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("_.-" :: String)
|
||||
|
||||
-- | 单引号字符串字面量
|
||||
quoted :: Text -> String
|
||||
quoted value = "'" ++ escapeStringLiteral (T.unpack value) ++ "'"
|
||||
|
||||
-- | 构造 CREATE USER（口令是明文，账号服务负责加盐派生）
|
||||
createUserSql :: Text -> Text -> Either String String
|
||||
createUserSql name password = do
|
||||
user <- accountName name
|
||||
if T.null password || T.length password > 256
|
||||
then Left "password must not be empty or longer than 256 characters"
|
||||
else pure ("CREATE USER " ++ T.unpack user ++ " IDENTIFIED BY " ++ quoted password)
|
||||
|
||||
-- | 构造 ALTER USER（改一个普通账号的口令）
|
||||
alterUserSql :: Text -> Text -> Either String String
|
||||
alterUserSql name password = do
|
||||
user <- accountName name
|
||||
if T.null password || T.length password > 256
|
||||
then Left "password must not be empty or longer than 256 characters"
|
||||
else pure ("ALTER USER " ++ T.unpack user ++ " IDENTIFIED BY " ++ quoted password)
|
||||
|
||||
-- | 构造 DROP USER
|
||||
dropUserSql :: Text -> Either String String
|
||||
dropUserSql name = do
|
||||
user <- accountName name
|
||||
pure ("DROP USER " ++ T.unpack user)
|
||||
+829
-313
File diff suppressed because it is too large.
Load diff
@@ -14,9 +14,10 @@ module ChuSQL.Web.Auth (
|
||||
sessionPolicy,
|
||||
setSessionPolicy,
|
||||
createSession,
|
||||
createVersionedSession,
|
||||
lookupVersionedSession,
|
||||
lookupSession,
|
||||
deleteSession,
|
||||
deleteOtherSessions,
|
||||
sessionToken,
|
||||
) where
|
||||
|
||||
@@ -118,6 +119,7 @@ data Session = Session
|
||||
{ sessUser :: Text
|
||||
, sessCreated :: UTCTime
|
||||
, sessSeen :: UTCTime
|
||||
, sessRevision :: Maybe Integer
|
||||
}
|
||||
|
||||
data SessionPolicy = SessionPolicy
|
||||
@@ -166,33 +168,31 @@ sessionToken = hexEncode <$> getRandomBytes 32
|
||||
|
||||
-- | 开一条会话，返回令牌
|
||||
createSession :: SessionStore -> Text -> IO Text
|
||||
createSession store user = do
|
||||
createSession store user = createVersionedSession store user Nothing
|
||||
|
||||
createVersionedSession :: SessionStore -> Text -> Maybe Integer -> IO Text
|
||||
createVersionedSession store user revision = do
|
||||
token <- sessionToken
|
||||
now <- storeClock store
|
||||
pol <- sessionPolicy store
|
||||
modifyMVar_ (storeMap store) $ \m ->
|
||||
pure (Map.insert token (Session user now now) (prune now pol m))
|
||||
pure (Map.insert token (Session user now now revision) (prune now pol m))
|
||||
pure token
|
||||
|
||||
-- | 查令牌并刷新最后活动时间
|
||||
lookupSession :: SessionStore -> Text -> IO (Maybe Text)
|
||||
lookupSession store token = do
|
||||
lookupSession store token = fmap (fmap fst) (lookupVersionedSession store token)
|
||||
|
||||
lookupVersionedSession :: SessionStore -> Text -> IO (Maybe (Text, Maybe Integer))
|
||||
lookupVersionedSession store token = do
|
||||
now <- storeClock store
|
||||
pol <- sessionPolicy store
|
||||
modifyMVar (storeMap store) $ \m -> do
|
||||
let kept = prune now pol m
|
||||
pure $ case Map.lookup token kept of
|
||||
Nothing -> (kept, Nothing)
|
||||
Just s -> (Map.insert token s{sessSeen = now} kept, Just (sessUser s))
|
||||
Just s -> (Map.insert token s{sessSeen = now} kept, Just (sessUser s, sessRevision s))
|
||||
|
||||
-- | 删掉一条会话（退出登录）
|
||||
deleteSession :: SessionStore -> Text -> IO ()
|
||||
deleteSession store token = modifyMVar_ (storeMap store) (pure . Map.delete token)
|
||||
|
||||
-- | 删掉除这条外的全部会话，返回条数
|
||||
deleteOtherSessions :: SessionStore -> Text -> IO Int
|
||||
deleteOtherSessions store keep = do
|
||||
removed <- modifyMVar (storeMap store) $ \m -> do
|
||||
let kept = Map.filterWithKey (\k _ -> k == keep) m
|
||||
pure (kept, Map.size m - Map.size kept)
|
||||
pure removed
|
||||
@@ -4,27 +4,45 @@ module ChuSQL.Web.Backend (
|
||||
StatementResult (..),
|
||||
Backend (..),
|
||||
columnsFromStatement,
|
||||
currentStamp,
|
||||
exprTables,
|
||||
inDatabase,
|
||||
internalTable,
|
||||
grantsTable,
|
||||
ipcBackend,
|
||||
memoryBackend,
|
||||
membersTable,
|
||||
rolesTable,
|
||||
statementNeedsDatabase,
|
||||
statementTables,
|
||||
systemDatabaseName,
|
||||
tableInfoOf,
|
||||
tableRefsOf,
|
||||
) where
|
||||
|
||||
import ChuSQL.Engine (runStatement, runStatementM)
|
||||
import ChuSQL.Model
|
||||
import ChuSQL.Semantic (prepare)
|
||||
import ChuSQL.Storage (MonadStorage (schema))
|
||||
import ChuSQL.Storage.IPC (
|
||||
Account (..),
|
||||
IPCStorage (..),
|
||||
Request (..),
|
||||
Response (..),
|
||||
SchemaColumn (..),
|
||||
TableInfo (..),
|
||||
doListCatalog,
|
||||
sendRequest,
|
||||
)
|
||||
import ChuSQL.Syntax.AST
|
||||
import ChuSQL.Syntax.Parser (parseStatement)
|
||||
import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, readMVar, withMVar)
|
||||
import Data.List (nub)
|
||||
import Data.Text (Text)
|
||||
import Data.Time (getCurrentTime)
|
||||
import Data.Time.Format (defaultTimeLocale, formatTime)
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.ByteString.Lazy.Char8 as BL
|
||||
import qualified Data.Text as T
|
||||
|
||||
-- 后端：跑一条语句与取数据字典，分 IPC（真存储）和内存（测试）两套。
|
||||
|
||||
@@ -37,40 +55,52 @@ data Backend = Backend
|
||||
{ beStatement :: String -> IO (Either String StatementResult)
|
||||
, beCatalog :: IO (Either String [TableInfo])
|
||||
, bePing :: IO Bool
|
||||
, beAccounts :: Request -> IO (Either String [Account])
|
||||
, beWithDatabase :: String -> Backend
|
||||
, beDatabases :: IO (Either String [String])
|
||||
}
|
||||
|
||||
-- | 按给定列名取列，固定列顺序
|
||||
columnsFromStatement :: Database -> Statement -> [String]
|
||||
columnsFromStatement db stmt = case stmt of
|
||||
Select cols from _ _ _
|
||||
| cols == [allColumns] -> wildcard from
|
||||
| otherwise -> cols
|
||||
columnsFromStatement db stmt = case prepare db stmt of
|
||||
Right (Select cols _ _ _ _ _) -> cols
|
||||
Right (SelectExpr items _ _ _ _ _) -> map fst items
|
||||
_ -> []
|
||||
where
|
||||
-- | 展开 *：单表按列序，JOIN 左表在前
|
||||
wildcard (FromTable mAlias tbl) = case lookup tbl db of
|
||||
Nothing -> []
|
||||
Just t -> [qualify mAlias c | c <- colNames t]
|
||||
wildcard (FromJoin left mAlias tbl _) = wildcard left ++ wildcard (FromTable mAlias tbl)
|
||||
|
||||
-- | 走命名管道的后端（真存储）
|
||||
-- | 走本地端点的后端（真存储：Windows 具名管道 / Unix 套接字）
|
||||
ipcBackend :: IO Backend
|
||||
ipcBackend = do
|
||||
lock <- newMVar ()
|
||||
pure
|
||||
Backend
|
||||
{ beStatement = \sql -> withMVar lock $ \_ -> runIpc sql
|
||||
let backend current = Backend
|
||||
{ beStatement = \sql -> withMVar lock $ \_ -> runIpc current sql
|
||||
, beCatalog = withMVar lock $ \_ -> do
|
||||
result <- doListCatalog
|
||||
pure (either Left Right result)
|
||||
response <- sendRequest (ReqInDatabase current ReqListCatalog)
|
||||
pure $ case response of
|
||||
RespCatalog infos -> Right infos
|
||||
RespError err -> Left err
|
||||
_ -> Left "unexpected catalog response"
|
||||
, bePing = withMVar lock $ \_ -> do
|
||||
resp <- sendRequest ReqPing
|
||||
pure (case resp of RespPong -> True; _ -> False)
|
||||
, beAccounts = \req -> withMVar lock $ \_ -> do
|
||||
response <- sendRequest req
|
||||
pure $ case response of
|
||||
RespAccounts accounts -> Right accounts
|
||||
RespError err -> Left err
|
||||
_ -> Left "unexpected account response"
|
||||
, beWithDatabase = backend
|
||||
, beDatabases = withMVar lock $ \_ -> do
|
||||
response <- sendRequest (ReqDatabase "list_databases" "")
|
||||
pure $ case response of
|
||||
RespTables names -> Right names
|
||||
RespError err -> Left err
|
||||
_ -> Left "unexpected database response"
|
||||
}
|
||||
-- 没有默认库：没选库时 current 是空串，任何请求都得先选库
|
||||
pure (backend "")
|
||||
where
|
||||
-- | 解析并执行，空结果时补一次表头
|
||||
runIpc :: String -> IO (Either String StatementResult)
|
||||
runIpc sql = case parseStatement sql of
|
||||
runIpc :: String -> String -> IO (Either String StatementResult)
|
||||
runIpc current sql = case fmap (inDatabase current) (parseStatement sql) of
|
||||
Left e -> pure (Left e)
|
||||
Right stmt -> do
|
||||
result <- runIPCStorage (runStatementM stmt)
|
||||
@@ -84,42 +114,287 @@ ipcBackend = do
|
||||
(r : _) -> pure (map fst r)
|
||||
pure (Right (StatementResult cols rows))
|
||||
|
||||
-- | 内存后端（测试）：状态就是一个 `Database`
|
||||
memoryBackend :: MVar Database -> Backend
|
||||
memoryBackend ref =
|
||||
-- | 内存后端（测试）：状态就是一个 `Database`，名字是它代表的库
|
||||
memoryBackend :: String -> MVar Database -> Backend
|
||||
memoryBackend = memoryBackendWith False
|
||||
|
||||
-- | 同一份内存状态可以按普通库（trusted=False）或系统库（trusted=True）视角跑：
|
||||
-- 系统库要能读写角色/授权表，普通库连看都不许看。
|
||||
memoryBackendWith :: Bool -> String -> MVar Database -> Backend
|
||||
memoryBackendWith trusted name ref =
|
||||
Backend
|
||||
{ beStatement = \sql -> modifyMVar ref $ \db -> case parseStatement sql of
|
||||
Left e -> pure (db, Left e)
|
||||
Right stmt -> case runStatement db stmt of
|
||||
{ beStatement = \sql -> case parseStatement sql of
|
||||
Left e -> pure (Left e)
|
||||
-- 内存夹具也有"库"的概念：USE 只能切到它有的两个名字（自己 + system），
|
||||
-- 与 beDatabases 口径一致；引擎的内存存储不实现库管理，所以拦在这里。
|
||||
Right (UseDatabase target)
|
||||
| target == name || target == systemDatabaseName -> pure (Right (StatementResult [] []))
|
||||
| otherwise -> pure (Left ("unknown database: " ++ target))
|
||||
Right stmt -> modifyMVar ref $ \db -> case runStatement (scoped db) stmt of
|
||||
Left e -> pure (db, Left e)
|
||||
Right (db', rows) -> pure (db', Right (StatementResult (colsOf db stmt rows) rows))
|
||||
Right (db', rows)
|
||||
| any (hidden . fst) db' -> pure (db, Left "reserved system table")
|
||||
| otherwise -> pure (filter (hidden . fst) db ++ db', Right (StatementResult (colsOf (scoped db) stmt rows) rows))
|
||||
, beCatalog = do
|
||||
db <- readMVar ref
|
||||
pure (Right (map tableInfoOf db))
|
||||
pure (Right (map tableInfoOf (filter (not . internalTable . fst) db)))
|
||||
, bePing = pure True
|
||||
, beAccounts = \req -> do
|
||||
stamp <- currentStamp
|
||||
modifyMVar ref $ \db -> case memoryAccounts db stamp req of
|
||||
Left err -> pure (db, Left err)
|
||||
Right accounts -> pure ((usersTable, Table usersTable [("account", TStr)]
|
||||
[[("account", VStr (BL.unpack (A.encode a))) ] | a <- accounts]) : filter ((/= usersTable) . fst) db, Right accounts)
|
||||
, beWithDatabase = withDatabase
|
||||
, beDatabases = pure (Right (nub [name, systemDatabaseName]))
|
||||
}
|
||||
where
|
||||
-- | 有行用行上的键，空结果回退语法树
|
||||
scoped = if trusted then filter (not . reserved . fst) else visible
|
||||
hidden = if trusted then reserved else internalTable
|
||||
colsOf db stmt rows = case rows of
|
||||
[] -> columnsFromStatement db stmt
|
||||
(r : _) -> map fst r
|
||||
|
||||
-- 系统库视角给权限服务用；夹具自己的库走普通视角；没选库时只放行不碰表的语句
|
||||
withDatabase target
|
||||
| target == systemDatabaseName = memoryBackendWith True name ref
|
||||
| target == name = memoryBackendWith False name ref
|
||||
| null target = noDatabaseBackend (memoryBackendWith False name ref)
|
||||
| otherwise = unavailableDatabase ("unknown database: " ++ target) (memoryBackendWith False name ref)
|
||||
|
||||
unavailableDatabase :: String -> Backend -> Backend
|
||||
unavailableDatabase message backend = backend
|
||||
{ beStatement = \_ -> pure (Left message)
|
||||
, beCatalog = pure (Left message)
|
||||
}
|
||||
|
||||
-- | 没选库时的视角：不碰表的语句（USE、建库、账号与角色）照跑，
|
||||
-- 一旦语句里出现裸表名就报 no database selected。
|
||||
-- 与存储层口径一致：`db.table` 这种限定名不需要先选库。
|
||||
noDatabaseBackend :: Backend -> Backend
|
||||
noDatabaseBackend backend = backend
|
||||
{ beStatement = \sql -> case parseStatement sql of
|
||||
Left e -> pure (Left e)
|
||||
Right stmt
|
||||
| statementNeedsDatabase stmt -> pure (Left "no database selected")
|
||||
| otherwise -> beStatement backend sql
|
||||
, beCatalog = pure (Left "no database selected")
|
||||
}
|
||||
|
||||
-- | Database context is an immutable request value, never shared connection state.
|
||||
-- 子查询里出现的表名同样要带上数据库前缀，否则会落到错误的库里。
|
||||
inDatabase :: String -> Statement -> Statement
|
||||
inDatabase current = walk
|
||||
where
|
||||
walk :: Statement -> Statement
|
||||
walk stmt = case stmt of
|
||||
q@Select{} ->
|
||||
q
|
||||
{ selectFrom = source (selectFrom q)
|
||||
, selectWhere = fmap expr (selectWhere q)
|
||||
}
|
||||
q@SelectExpr{} ->
|
||||
q
|
||||
{ selectItems = [(label, expr e) | (label, e) <- selectItems q]
|
||||
, selectFrom = source (selectFrom q)
|
||||
, selectWhere = fmap expr (selectWhere q)
|
||||
}
|
||||
Insert t cols rows -> Insert (table t) cols (map (map expr) rows)
|
||||
Delete t cond -> Delete (table t) (fmap expr cond)
|
||||
Update t assigns cond -> Update (table t) [(c, expr e) | (c, e) <- assigns] (fmap expr cond)
|
||||
CreateTable t cols -> CreateTable (table t) cols
|
||||
DropTable t -> DropTable (table t)
|
||||
CreateIndex t c -> CreateIndex (table t) c
|
||||
DropIndex t c -> DropIndex (table t) c
|
||||
DropColumn t c -> DropColumn (table t) c
|
||||
AddColumn t def -> AddColumn (table t) def
|
||||
RenameColumn t old new -> RenameColumn (table t) old new
|
||||
AlterColumnType t c ty -> AlterColumnType (table t) c ty
|
||||
AlterColumnDefault t c v -> AlterColumnDefault (table t) c v
|
||||
AlterColumnNull t c b -> AlterColumnNull (table t) c b
|
||||
other -> other
|
||||
|
||||
table t | '.' `elem` t || null current = t
|
||||
| otherwise = current ++ "." ++ t
|
||||
|
||||
source FromUnit = FromUnit
|
||||
source (FromTable a t) = FromTable a (table t)
|
||||
source (FromJoin k l a t e) = FromJoin k (source l) a (table t) (expr e)
|
||||
|
||||
-- 表达式里的子查询也要一起改写
|
||||
expr (ScalarSub sq) = ScalarSub (sub sq)
|
||||
expr (ExistsSub sq neg) = ExistsSub (sub sq) neg
|
||||
expr (InSub a sq neg) = InSub (expr a) (sub sq) neg
|
||||
expr (InList a items neg) = InList (expr a) (map expr items) neg
|
||||
expr (Add a b) = Add (expr a) (expr b)
|
||||
expr (Sub a b) = Sub (expr a) (expr b)
|
||||
expr (Mul a b) = Mul (expr a) (expr b)
|
||||
expr (Div a b) = Div (expr a) (expr b)
|
||||
expr (Neg a) = Neg (expr a)
|
||||
expr (Gt a b) = Gt (expr a) (expr b)
|
||||
expr (Lt a b) = Lt (expr a) (expr b)
|
||||
expr (Eq a b) = Eq (expr a) (expr b)
|
||||
expr (And a b) = And (expr a) (expr b)
|
||||
expr (Or a b) = Or (expr a) (expr b)
|
||||
expr (IsNull a) = IsNull (expr a)
|
||||
expr (IsNotNull a) = IsNotNull (expr a)
|
||||
expr (CountOf a) = CountOf (expr a)
|
||||
expr (SumOf a) = SumOf (expr a)
|
||||
expr (AvgOf a) = AvgOf (expr a)
|
||||
expr (MinOf a) = MinOf (expr a)
|
||||
expr (MaxOf a) = MaxOf (expr a)
|
||||
expr other = other
|
||||
|
||||
sub sq = sq {subqueryStatement = walk (subqueryStatement sq)}
|
||||
|
||||
-- | 语句里出现的表（含 JOIN、子查询、INSERT/UPDATE/DELETE 的目标）
|
||||
statementTables :: Statement -> [Text]
|
||||
statementTables stmt = nub (case stmt of
|
||||
Select{} ->
|
||||
tableRefsOf (selectFrom stmt)
|
||||
++ concatMap exprTables (maybe [] (: []) (selectWhere stmt))
|
||||
SelectExpr{} ->
|
||||
tableRefsOf (selectFrom stmt)
|
||||
++ concatMap exprTables (maybe [] (: []) (selectWhere stmt) ++ map snd (selectItems stmt))
|
||||
Insert table _ rows -> T.pack table : concatMap exprTables (concat rows)
|
||||
Update table assigns cond -> T.pack table : concatMap exprTables (map snd assigns ++ maybe [] (: []) cond)
|
||||
Delete table cond -> T.pack table : concatMap exprTables (maybe [] (: []) cond)
|
||||
CreateTable table _ -> [T.pack table]
|
||||
DropTable table -> [T.pack table]
|
||||
CreateIndex table _ -> [T.pack table]
|
||||
DropIndex table _ -> [T.pack table]
|
||||
DropColumn table _ -> [T.pack table]
|
||||
AddColumn table _ -> [T.pack table]
|
||||
RenameColumn table _ _ -> [T.pack table]
|
||||
AlterColumnType table _ _ -> [T.pack table]
|
||||
AlterColumnDefault table _ _ -> [T.pack table]
|
||||
AlterColumnNull table _ _ -> [T.pack table]
|
||||
_ -> [])
|
||||
|
||||
-- | 语句需不需要一个当前库：出现的表里有没写库名的就必须要
|
||||
statementNeedsDatabase :: Statement -> Bool
|
||||
statementNeedsDatabase stmt = any (not . T.any (== '.')) (statementTables stmt)
|
||||
|
||||
-- | FROM 子句里的所有表
|
||||
tableRefsOf :: FromClause -> [Text]
|
||||
tableRefsOf FromUnit = []
|
||||
tableRefsOf (FromTable _ name) = [T.pack name]
|
||||
tableRefsOf (FromJoin _ left _ name cond) = tableRefsOf left ++ [T.pack name] ++ exprTables cond
|
||||
|
||||
-- | 表达式里出现的表（子查询是唯一的来路）
|
||||
exprTables :: Expr -> [Text]
|
||||
exprTables expr = case expr of
|
||||
ScalarSub sub -> statementTables (subqueryStatement sub)
|
||||
ExistsSub sub _ -> statementTables (subqueryStatement sub)
|
||||
InSub value sub _ -> exprTables value ++ statementTables (subqueryStatement sub)
|
||||
InList value items _ -> concatMap exprTables (value : items)
|
||||
Add a b -> both a b
|
||||
Sub a b -> both a b
|
||||
Mul a b -> both a b
|
||||
Div a b -> both a b
|
||||
Gt a b -> both a b
|
||||
Lt a b -> both a b
|
||||
Eq a b -> both a b
|
||||
And a b -> both a b
|
||||
Or a b -> both a b
|
||||
Neg a -> exprTables a
|
||||
IsNull a -> exprTables a
|
||||
IsNotNull a -> exprTables a
|
||||
CountOf a -> exprTables a
|
||||
SumOf a -> exprTables a
|
||||
AvgOf a -> exprTables a
|
||||
MinOf a -> exprTables a
|
||||
MaxOf a -> exprTables a
|
||||
_ -> []
|
||||
where
|
||||
both a b = exprTables a ++ exprTables b
|
||||
|
||||
-- | 一张表的线上信息（内存实现：没有索引，统计现算）
|
||||
tableInfoOf :: (String, Table) -> TableInfo
|
||||
tableInfoOf (name, tbl) =
|
||||
TableInfo
|
||||
{ tiTable = name
|
||||
, tiColumns = [SchemaColumn c (wireType ty) | (c, ty) <- tableCols tbl]
|
||||
, tiColumns = [wireColumn c ty | (c, ty) <- tableCols tbl]
|
||||
, tiRows = length (tableRows tbl)
|
||||
, tiIndexes = []
|
||||
, tiStats = [(c, distinctOf c, False) | (c, _) <- tableCols tbl]
|
||||
}
|
||||
where
|
||||
-- | 某一列有几个不同值
|
||||
distinctOf c = length (nub [v | r <- tableRows tbl, Just v <- [lookup c r]])
|
||||
|
||||
-- | 本地列类型转线上字符串（和 IPC 那边同一套写法）
|
||||
wireType :: Column -> String
|
||||
wireType TInt = "int"
|
||||
wireType TStr = "str"
|
||||
wireType TBool = "bool"
|
||||
wireType = typeName . columnType
|
||||
|
||||
-- | 本地列转线上 schema
|
||||
wireColumn :: String -> Column -> SchemaColumn
|
||||
wireColumn name col =
|
||||
SchemaColumn
|
||||
{ scName = name
|
||||
, scType = wireType col
|
||||
, scNullable = columnNullable col
|
||||
, scDefault = columnDefault col
|
||||
, scAutoIncrement = columnAutoIncrement col
|
||||
, scPrimaryKey = columnPrimaryKey col
|
||||
, scUnique = columnUnique col
|
||||
, scCheck = columnCheck col
|
||||
}
|
||||
|
||||
-- | 系统库：账号、角色与授权表住在这里，其中的表都是系统表，只给管理员
|
||||
systemDatabaseName :: String
|
||||
systemDatabaseName = "system"
|
||||
|
||||
usersTable :: String
|
||||
usersTable = "__chusql_users"
|
||||
|
||||
-- | 角色与授权表：住在 system 库，名字不带 `__chusql_` 前缀（Rust 存储层拒收那个前缀）
|
||||
rolesTable :: String
|
||||
rolesTable = "sys_roles"
|
||||
|
||||
grantsTable :: String
|
||||
grantsTable = "sys_grants"
|
||||
|
||||
membersTable :: String
|
||||
membersTable = "sys_members"
|
||||
|
||||
internalNames :: [String]
|
||||
internalNames = [rolesTable, grantsTable, membersTable]
|
||||
|
||||
reserved :: String -> Bool
|
||||
reserved = T.isPrefixOf "__chusql_" . T.toLower . T.pack
|
||||
|
||||
-- | 服务自己的内部表：目录里不出现，普通作用域读写都拒（系统作用域才放行角色/授权表）
|
||||
internalTable :: String -> Bool
|
||||
internalTable name = reserved name || T.unpack (T.toLower (T.pack name)) `elem` internalNames
|
||||
|
||||
visible :: Database -> Database
|
||||
visible = filter (not . internalTable . fst)
|
||||
|
||||
-- | 当前 UTC 时间，写法与引擎的 timestamp 一致
|
||||
currentStamp :: IO T.Text
|
||||
currentStamp = T.pack . formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" <$> getCurrentTime
|
||||
|
||||
memoryAccounts :: Database -> T.Text -> Request -> Either String [Account]
|
||||
memoryAccounts db stamp req = do
|
||||
accounts <- case lookup usersTable db of
|
||||
Nothing -> Right []
|
||||
Just table -> mapM decodeAccount (tableRows table)
|
||||
case req of
|
||||
ReqAccountsList -> Right accounts
|
||||
ReqAccountCreate u h
|
||||
| any ((== T.toLower u) . accountUser) accounts -> Left "account already exists"
|
||||
| otherwise -> Right (accounts ++ [Account (1 + maximum (0 : map accountId accounts)) (T.toLower u) h 1 stamp Nothing])
|
||||
ReqAccountReset u h -> case filter ((== T.toLower u) . accountUser) accounts of
|
||||
[_] -> Right [if accountUser x == T.toLower u then x{accountHash = h, accountRevision = accountRevision x + 1} else x | x <- accounts]
|
||||
_ -> Left "unknown account"
|
||||
ReqAccountLogin u at -> case filter ((== T.toLower u) . accountUser) accounts of
|
||||
[_] -> Right [if accountUser x == T.toLower u then x{accountLastLoginAt = at} else x | x <- accounts]
|
||||
_ -> Left "unknown account"
|
||||
ReqAccountDrop u -> case filter ((== T.toLower u) . accountUser) accounts of
|
||||
[] -> Left "unknown account"
|
||||
_ -> Right [x | x <- accounts, accountUser x /= T.toLower u]
|
||||
_ -> Left "invalid account request"
|
||||
where
|
||||
decodeAccount row = case lookup "account" row of
|
||||
Just (VStr encoded) -> A.eitherDecode (BL.pack encoded)
|
||||
_ -> Left "invalid account record"
|
||||
@@ -6,22 +6,31 @@ module ChuSQL.Web.Config (
|
||||
defaultUser,
|
||||
defaultPassword,
|
||||
usingDefaultCredentials,
|
||||
loadWebConfig,
|
||||
loadWebConfigAt,
|
||||
resolveCredential,
|
||||
resolveStaticDir,
|
||||
staticDirCandidates,
|
||||
rootUserName,
|
||||
canonicalSettingKeys,
|
||||
resolvePipeName,
|
||||
) where
|
||||
|
||||
import ChuSQL.Storage.IPC (defaultPipeName)
|
||||
import ChuSQL.Web.Auth (Credential (..), hashPassword)
|
||||
import ChuSQL.Web.TOML (readSection)
|
||||
import Data.Char (toLower)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import System.Directory (doesDirectoryExist)
|
||||
import System.Environment (lookupEnv)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
-- 运行参数：命令行 > 环境变量 > 内置默认；默认只听本机 127.0.0.1:7777。
|
||||
-- 运行参数：命令行 > 全局 chusql.toml 的分区 > 内置默认，不看环境变量。
|
||||
-- 配置文件位置是固定的（安装时定下，见 ChuSQL.Web.TOML.defaultConfigFile），
|
||||
-- 想读别处的文件只能在命令行用 --config 指。
|
||||
-- 自己那段是 [web]；管名与数据目录取自 [server] pipe_name / [storage] data_dir，
|
||||
-- 因为它们是存储进程的事实，前端只当端点读。root 凭据只认 [web] 里的明文。
|
||||
|
||||
-- | 默认账号名
|
||||
defaultUser :: Text
|
||||
@@ -36,8 +45,6 @@ data WebConfig = WebConfig
|
||||
, wcPort :: Int
|
||||
, wcStaticDir :: FilePath
|
||||
, wcUser :: Text
|
||||
, wcPasswordHash :: Maybe Text
|
||||
, wcPassword :: Maybe Text
|
||||
, wcStorageServer :: Maybe FilePath
|
||||
, wcPipeName :: Maybe String
|
||||
, wcDataDir :: Maybe FilePath
|
||||
@@ -62,9 +69,7 @@ defaultWebConfig =
|
||||
{ wcHost = "127.0.0.1"
|
||||
, wcPort = 7777
|
||||
, wcStaticDir = "static"
|
||||
, wcUser = defaultUser
|
||||
, wcPasswordHash = Nothing
|
||||
, wcPassword = Nothing
|
||||
, wcUser = ""
|
||||
, wcStorageServer = Nothing
|
||||
, wcPipeName = Nothing
|
||||
, wcDataDir = Nothing
|
||||
@@ -81,68 +86,114 @@ defaultWebConfig =
|
||||
, wcSeedDemo = False
|
||||
}
|
||||
|
||||
-- | 这份配置用的还是内置默认口令吗
|
||||
usingDefaultCredentials :: WebConfig -> Bool
|
||||
usingDefaultCredentials cfg = wcPasswordHash cfg == Nothing && wcPassword cfg == Nothing
|
||||
-- | [web] 分区里的键统一成连字符写法（scripts/chusql.toml 用的是下划线）
|
||||
-- 两种写法同时出现时，连字符（设置页写的规范形式）优先。
|
||||
canonicalSettingKeys :: Map.Map Text Text -> Map.Map Text Text
|
||||
canonicalSettingKeys saved =
|
||||
foldr (\(key, value) acc -> Map.insert (canonicalKey key) value acc) Map.empty (Map.toList saved)
|
||||
where
|
||||
canonicalKey key = fromMaybe key (lookup key keyAliases)
|
||||
|
||||
-- | 备一份凭据：哈希 > 明文 > 内置默认
|
||||
resolveCredential :: WebConfig -> IO Credential
|
||||
resolveCredential cfg = case (wcPasswordHash cfg, wcPassword cfg) of
|
||||
(Just encoded, _) -> pure (Credential (wcUser cfg) encoded)
|
||||
(Nothing, Just plain) -> do
|
||||
encoded <- hashPassword plain
|
||||
pure (Credential (wcUser cfg) encoded)
|
||||
(Nothing, Nothing) -> do
|
||||
encoded <- hashPassword defaultPassword
|
||||
pure (Credential (wcUser cfg) encoded)
|
||||
-- | 下划线写法到连字符写法的别名
|
||||
keyAliases :: [(Text, Text)]
|
||||
keyAliases =
|
||||
[ ("static_dir", "static-dir")
|
||||
, ("session_idle", "session-idle")
|
||||
, ("session_max", "session-max")
|
||||
, ("login_max_attempts", "login-max-attempts")
|
||||
, ("login_window", "login-window")
|
||||
, ("body_limit", "body-limit")
|
||||
, ("rows_per_page", "rows-per-page")
|
||||
, ("max_page_size", "max-page-size")
|
||||
, ("max_rows", "max-rows")
|
||||
, ("max_sql_length", "max-sql-length")
|
||||
, ("password_min_length", "password-min-length")
|
||||
, ("password_classes", "password-classes")
|
||||
, ("storage_server", "storage-server")
|
||||
]
|
||||
|
||||
-- | 从环境变量读配置，缺省用内置默认
|
||||
loadWebConfig :: IO WebConfig
|
||||
loadWebConfig = do
|
||||
let d = defaultWebConfig
|
||||
host <- envOr "CHUSQL_WEB_HOST" (wcHost d)
|
||||
port <- envInt "CHUSQL_WEB_PORT" (wcPort d)
|
||||
staticDir <- envOr "CHUSQL_WEB_STATIC" (wcStaticDir d)
|
||||
user <- T.pack <$> envOr "CHUSQL_WEB_USER" (T.unpack (wcUser d))
|
||||
passwordHash <- envText "CHUSQL_WEB_PASSWORD_HASH"
|
||||
password <- envText "CHUSQL_WEB_PASSWORD"
|
||||
server <- envMaybe "CHUSQL_STORAGE_SERVER"
|
||||
pipe <- envMaybe "CHUSQL_PIPE"
|
||||
dataDir <- envMaybe "CHUSQL_DATA_DIR"
|
||||
secure <- envBool "CHUSQL_WEB_COOKIE_SECURE" (wcCookieSecure d)
|
||||
limit <- envInt "CHUSQL_WEB_BODY_LIMIT" (wcBodyLimit d)
|
||||
idle <- envInt "CHUSQL_WEB_SESSION_IDLE" (wcSessionIdle d)
|
||||
sessionMax <- envInt "CHUSQL_WEB_SESSION_MAX" (wcSessionMax d)
|
||||
loginMax <- envInt "CHUSQL_WEB_LOGIN_MAX_ATTEMPTS" (wcLoginMaxAttempts d)
|
||||
loginWindow <- envInt "CHUSQL_WEB_LOGIN_WINDOW" (wcLoginWindow d)
|
||||
pageSize <- envInt "CHUSQL_WEB_PAGE_SIZE" (wcPageSize d)
|
||||
maxPageSize <- envInt "CHUSQL_WEB_MAX_PAGE_SIZE" (wcMaxPageSize d)
|
||||
maxRows <- envInt "CHUSQL_WEB_MAX_ROWS" (wcMaxRows d)
|
||||
maxSqlLength <- envInt "CHUSQL_WEB_MAX_SQL_LENGTH" (wcMaxSqlLength d)
|
||||
seedDemo <- envBool "CHUSQL_WEB_SEED" (wcSeedDemo d)
|
||||
pure
|
||||
WebConfig
|
||||
{ wcHost = host
|
||||
, wcPort = port
|
||||
, wcStaticDir = staticDir
|
||||
, wcUser = user
|
||||
, wcPasswordHash = passwordHash
|
||||
, wcPassword = password
|
||||
, wcStorageServer = server
|
||||
, wcPipeName = pipe
|
||||
, wcDataDir = dataDir
|
||||
, wcCookieSecure = secure
|
||||
, wcBodyLimit = limit
|
||||
, wcSessionIdle = idle
|
||||
, wcSessionMax = sessionMax
|
||||
, wcLoginMaxAttempts = loginMax
|
||||
, wcLoginWindow = loginWindow
|
||||
, wcPageSize = pageSize
|
||||
, wcMaxPageSize = maxPageSize
|
||||
, wcMaxRows = maxRows
|
||||
, wcMaxSqlLength = maxSqlLength
|
||||
, wcSeedDemo = seedDemo
|
||||
}
|
||||
-- | 这份配置用的还是内置默认口令吗。
|
||||
-- 显式留空（password = ""）是"只允许管理员免密登录"，算已经配置过。
|
||||
usingDefaultCredentials :: Map.Map Text Text -> Bool
|
||||
usingDefaultCredentials saved = Map.notMember "password" saved
|
||||
|
||||
-- | 设置文件里某个键的非空值
|
||||
nonEmptyValue :: Text -> Map.Map Text Text -> Maybe Text
|
||||
nonEmptyValue key saved = case T.strip <$> Map.lookup key saved of
|
||||
Just value | not (T.null value) -> Just value
|
||||
_ -> Nothing
|
||||
|
||||
-- | root 凭据只认设置文件里的明文：给了明文就哈希它；显式留空就是免密（空编码串）；
|
||||
-- 没配这一项才回落到内置演示口令。
|
||||
resolveCredential :: WebConfig -> Map.Map Text Text -> IO Credential
|
||||
resolveCredential cfg saved = do
|
||||
encoded <- case Map.lookup "password" saved of
|
||||
Just plain | not (T.null (T.strip plain)) -> hashPassword (T.strip plain)
|
||||
Just _ -> pure ""
|
||||
Nothing -> hashPassword defaultPassword
|
||||
pure (Credential (rootUserName cfg saved) encoded)
|
||||
|
||||
-- | 管理员名字：命令行 --user > 设置文件 user > 内置默认
|
||||
rootUserName :: WebConfig -> Map.Map Text Text -> Text
|
||||
rootUserName cfg saved
|
||||
| not (T.null (T.strip (wcUser cfg))) = T.strip (wcUser cfg)
|
||||
| otherwise = fromMaybe defaultUser (nonEmptyValue "user" saved)
|
||||
|
||||
-- | 读配置：内置默认 < [web] 分区（端点取自 [server] / [storage]）。
|
||||
-- user / password 不在这里读：它们由 rootUserName / resolveCredential 直接看设置文件。
|
||||
loadWebConfigAt :: FilePath -> IO WebConfig
|
||||
loadWebConfigAt path = do
|
||||
raw <- readSection path "web"
|
||||
server <- readSection path "server"
|
||||
storage <- readSection path "storage"
|
||||
pure (withEndpoint server storage (webConfigFromSection (canonicalSettingKeys raw)))
|
||||
|
||||
-- | 端点：存储进程 bind 的管名与它用的数据目录，前端只读不改
|
||||
withEndpoint :: Map.Map Text Text -> Map.Map Text Text -> WebConfig -> WebConfig
|
||||
withEndpoint server storage cfg =
|
||||
cfg
|
||||
{ wcPipeName = T.unpack <$> nonEmptyValue "pipe_name" server
|
||||
, wcDataDir = T.unpack <$> nonEmptyValue "data_dir" storage
|
||||
}
|
||||
|
||||
-- | 实际要连的管名：配置里没有就用与存储层一致的默认值
|
||||
resolvePipeName :: WebConfig -> String
|
||||
resolvePipeName cfg = fromMaybe defaultPipeName (wcPipeName cfg)
|
||||
|
||||
-- | [web] 分区里的启动参数，缺失或坏值一律回到内置默认
|
||||
webConfigFromSection :: Map.Map Text Text -> WebConfig
|
||||
webConfigFromSection saved =
|
||||
defaultWebConfig
|
||||
{ wcHost = T.unpack (sectionText "host" saved (T.pack (wcHost defaultWebConfig)))
|
||||
, wcPort = sectionInt "port" saved (wcPort defaultWebConfig)
|
||||
, wcStaticDir = T.unpack (sectionText "static-dir" saved (T.pack (wcStaticDir defaultWebConfig)))
|
||||
, wcCookieSecure = sectionBool "cookie-secure" saved (wcCookieSecure defaultWebConfig)
|
||||
, wcBodyLimit = sectionInt "body-limit" saved (wcBodyLimit defaultWebConfig)
|
||||
, wcSessionIdle = sectionInt "session-idle" saved (wcSessionIdle defaultWebConfig)
|
||||
, wcSessionMax = sectionInt "session-max" saved (wcSessionMax defaultWebConfig)
|
||||
, wcLoginMaxAttempts = sectionInt "login-max-attempts" saved (wcLoginMaxAttempts defaultWebConfig)
|
||||
, wcLoginWindow = sectionInt "login-window" saved (wcLoginWindow defaultWebConfig)
|
||||
, wcPageSize = sectionInt "rows-per-page" saved (wcPageSize defaultWebConfig)
|
||||
, wcMaxPageSize = sectionInt "max-page-size" saved (wcMaxPageSize defaultWebConfig)
|
||||
, wcMaxRows = sectionInt "max-rows" saved (wcMaxRows defaultWebConfig)
|
||||
, wcMaxSqlLength = sectionInt "max-sql-length" saved (wcMaxSqlLength defaultWebConfig)
|
||||
, wcSeedDemo = sectionBool "seed" saved (wcSeedDemo defaultWebConfig)
|
||||
, wcStorageServer = T.unpack <$> nonEmptyValue "storage-server" saved
|
||||
}
|
||||
|
||||
-- | 分区里一个键的非空字符串值
|
||||
sectionText :: Text -> Map.Map Text Text -> Text -> Text
|
||||
sectionText key saved def = fromMaybe def (nonEmptyValue key saved)
|
||||
|
||||
-- | 分区里的整数，解析不出来就用内置默认
|
||||
sectionInt :: Text -> Map.Map Text Text -> Int -> Int
|
||||
sectionInt key saved def = fromMaybe def (nonEmptyValue key saved >>= readMaybe . T.unpack)
|
||||
|
||||
-- | 分区里的布尔（1/true/yes/on 都算真）
|
||||
sectionBool :: Text -> Map.Map Text Text -> Bool -> Bool
|
||||
sectionBool key saved def = case nonEmptyValue key saved of
|
||||
Nothing -> def
|
||||
Just value -> map toLower (T.unpack value) `elem` ["1", "true", "yes", "on"]
|
||||
|
||||
-- | 静态目录候选位置，按顺序取第一个存在的
|
||||
staticDirCandidates :: FilePath -> [FilePath]
|
||||
@@ -157,31 +208,3 @@ resolveStaticDir given = go (staticDirCandidates given)
|
||||
go (d : ds) = do
|
||||
ok <- doesDirectoryExist d
|
||||
if ok then pure (Just d) else go ds
|
||||
|
||||
-- | 读一个字符串，缺省给默认值
|
||||
envOr :: String -> String -> IO String
|
||||
envOr name def = fromMaybe def <$> lookupEnv name
|
||||
|
||||
-- | 读一个环境变量（空串当没设）
|
||||
envMaybe :: String -> IO (Maybe String)
|
||||
envMaybe name = do
|
||||
v <- lookupEnv name
|
||||
pure (case v of Just s | not (null s) -> Just s; _ -> Nothing)
|
||||
|
||||
-- | 读成 Text
|
||||
envText :: String -> IO (Maybe Text)
|
||||
envText name = fmap (fmap T.pack) (envMaybe name)
|
||||
|
||||
-- | 读成整数，解析不出来就用默认值
|
||||
envInt :: String -> Int -> IO Int
|
||||
envInt name def = do
|
||||
v <- envMaybe name
|
||||
pure (fromMaybe def (v >>= \s -> readMaybe s))
|
||||
|
||||
-- | 读成布尔（1/true/yes/on 都算真）
|
||||
envBool :: String -> Bool -> IO Bool
|
||||
envBool name def = do
|
||||
v <- envMaybe name
|
||||
pure $ case v of
|
||||
Nothing -> def
|
||||
Just s -> map toLower s `elem` ["1", "true", "yes", "on"]
|
||||
@@ -106,7 +106,6 @@ seedDemo backend = do
|
||||
(const (SeedReport (map T.unpack missingNames) skipped (map (T.unpack . snd) wantedIndexes)))
|
||||
indexes
|
||||
where
|
||||
-- | 逐条执行，遇到错就停
|
||||
runAll :: [Either String String] -> IO (Either String ())
|
||||
runAll [] = pure (Right ())
|
||||
runAll (sql : rest) = case sql of
|
||||
@@ -117,7 +116,6 @@ seedDemo backend = do
|
||||
Left e -> pure (Left e)
|
||||
Right _ -> runAll rest
|
||||
|
||||
-- | 这张表上是否还没有这个索引
|
||||
indexMissing :: [TableInfo] -> T.Text -> T.Text -> Bool
|
||||
indexMissing infos t c = case lookup (T.unpack t) [(tiTable i, tiIndexes i) | i <- infos] of
|
||||
Nothing -> True
|
||||
|
||||
@@ -0,0 +1,396 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | 角色与权限服务。
|
||||
--
|
||||
-- 模型：权限挂在角色上，用户通过角色成员资格继承角色权限；管理员（root）隐式全权，
|
||||
-- 新账号默认零权限。语句（CREATE ROLE / DROP ROLE / GRANT / REVOKE）由引擎解析并做
|
||||
-- 基本校验，真正落库在这里。
|
||||
--
|
||||
-- 存储：system 库里的三张普通表（`sys_roles` / `sys_grants` / `sys_members`）。
|
||||
-- 起普通名字是因为 Rust 存储层拒收 `__chusql_` 前缀的表名，那条路走不通；
|
||||
-- 读写都借 system 作用域后端的普通 SQL，内存后端与 IPC 后端共用一套逻辑。
|
||||
module ChuSQL.Web.Privileges (
|
||||
Grant (..),
|
||||
Membership (..),
|
||||
PrivilegeCommand (..),
|
||||
PrivilegeError (..),
|
||||
Privileges,
|
||||
RoleView (..),
|
||||
authorize,
|
||||
authorizeTables,
|
||||
filterTables,
|
||||
listRoleViews,
|
||||
newPrivileges,
|
||||
normalizeObject,
|
||||
privilegeCommand,
|
||||
runPrivilegeCommand,
|
||||
) where
|
||||
|
||||
import ChuSQL.Model (Row, Value (..))
|
||||
import ChuSQL.Syntax.AST
|
||||
import ChuSQL.Web.Accounts (Principal, principalIsRoot, principalName)
|
||||
import ChuSQL.Web.Actions (sqlLiteral)
|
||||
import ChuSQL.Web.Backend (
|
||||
Backend (..),
|
||||
StatementResult (..),
|
||||
exprTables,
|
||||
grantsTable,
|
||||
membersTable,
|
||||
rolesTable,
|
||||
systemDatabaseName,
|
||||
tableRefsOf,
|
||||
)
|
||||
import Control.Concurrent.MVar (MVar, newMVar, withMVar)
|
||||
import Data.List (intercalate, isInfixOf, nub, sort)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
||||
-- | 出错口径与账号服务一致，映射由 API 层统一做
|
||||
data PrivilegeError = PrivilegeError Text Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 一条角色授权：角色 + 具体权限 + 对象（`*` 或 `库.表`）
|
||||
data Grant = Grant
|
||||
{ grantRole :: Text
|
||||
, grantPrivilege :: Text
|
||||
, grantObject :: Text
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- | 角色成员资格
|
||||
data Membership = Membership
|
||||
{ memberRole :: Text
|
||||
, memberUser :: Text
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- | 一个角色的全貌
|
||||
data RoleView = RoleView
|
||||
{ roleName :: Text
|
||||
, roleGrants :: [Grant]
|
||||
, roleMembers :: [Text]
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
data PrivilegeCommand
|
||||
= CreateRoleCommand Text
|
||||
| DropRoleCommand Text
|
||||
| GrantPrivilegesCommand [Text] Text Text
|
||||
| RevokePrivilegesCommand [Text] Text Text
|
||||
| GrantRoleCommand Text [Text]
|
||||
| RevokeRoleCommand Text [Text]
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Privileges = Privileges
|
||||
{ pvBackend :: Backend
|
||||
, pvLock :: MVar ()
|
||||
}
|
||||
|
||||
-- | 服务固定看 system 库；构造时不碰存储，第一次用才建表
|
||||
newPrivileges :: Backend -> IO Privileges
|
||||
newPrivileges base = do
|
||||
lock <- newMVar ()
|
||||
pure (Privileges (beWithDatabase base systemDatabaseName) lock)
|
||||
|
||||
-- | 语句 → 管理命令（引擎只解析与基本校验，不认的语句给 Nothing）
|
||||
privilegeCommand :: Statement -> Maybe PrivilegeCommand
|
||||
privilegeCommand stmt = case stmt of
|
||||
CreateRole name -> Just (CreateRoleCommand (T.pack name))
|
||||
DropRole name -> Just (DropRoleCommand (T.pack name))
|
||||
GrantPrivileges privs obj role ->
|
||||
Just (GrantPrivilegesCommand (map T.toLower (map T.pack privs)) (T.pack obj) (T.pack role))
|
||||
RevokePrivileges privs obj role ->
|
||||
Just (RevokePrivilegesCommand (map T.toLower (map T.pack privs)) (T.pack obj) (T.pack role))
|
||||
GrantRole role members -> Just (GrantRoleCommand (T.pack role) (map T.pack members))
|
||||
RevokeRole role members -> Just (RevokeRoleCommand (T.pack role) (map T.pack members))
|
||||
_ -> Nothing
|
||||
|
||||
-- | 执行管理命令：只有管理员能跑，命令提到的角色必须已经存在
|
||||
runPrivilegeCommand :: Privileges -> Principal -> Text -> PrivilegeCommand -> IO (Either PrivilegeError ())
|
||||
runPrivilegeCommand service principal database command
|
||||
| not (principalIsRoot principal) = pure (Left forbidden)
|
||||
| needsDatabase = pure (Left (PrivilegeError "no_database" "no database selected"))
|
||||
| otherwise = withTables service (applyCommand service database command)
|
||||
where
|
||||
-- 授权到具体对象（不是 `*`）时要把裸表名补成 `库.表`，没选库就无从补全
|
||||
needsDatabase = T.null database && case command of
|
||||
GrantPrivilegesCommand _ object _ -> T.strip object /= "*"
|
||||
RevokePrivilegesCommand _ object _ -> T.strip object /= "*"
|
||||
_ -> False
|
||||
|
||||
-- | 语句鉴权：管理员全通；普通身份按语句需要的每一项 (表, 权限) 查
|
||||
authorize :: Privileges -> Principal -> Text -> Statement -> IO (Either PrivilegeError ())
|
||||
authorize service principal database stmt
|
||||
| principalIsRoot principal = pure (Right ())
|
||||
| otherwise = case requiredActions stmt of
|
||||
Nothing -> pure (Left forbidden)
|
||||
Just needed -> authorizeTables service principal database needed
|
||||
|
||||
-- | 直接查一组 (表, 权限)：一键接口用这个
|
||||
authorizeTables :: Privileges -> Principal -> Text -> [(Text, Text)] -> IO (Either PrivilegeError ())
|
||||
authorizeTables service principal database needed
|
||||
| principalIsRoot principal = pure (Right ())
|
||||
| otherwise = withTables service $ do
|
||||
grants <- grantsOfUser service (principalName principal)
|
||||
pure (grants >>= \found -> checkAll database found needed)
|
||||
|
||||
-- | 只留下用户有 SELECT 权限的表（管理员看全部）；表清单接口用
|
||||
filterTables :: Privileges -> Principal -> Text -> [Text] -> IO (Either PrivilegeError [Text])
|
||||
filterTables service principal database tables
|
||||
| principalIsRoot principal = pure (Right tables)
|
||||
| otherwise = withTables service $ do
|
||||
grants <- grantsOfUser service (principalName principal)
|
||||
pure ((\found -> [table | table <- tables, checkAll database found [(table, "select")] == Right ()]) <$> grants)
|
||||
|
||||
-- | 角色总览（REST 与测试用）
|
||||
listRoleViews :: Privileges -> IO (Either PrivilegeError [RoleView])
|
||||
listRoleViews service = withTables service $ do
|
||||
names <- roleNames service
|
||||
case names of
|
||||
Left err -> pure (Left err)
|
||||
Right known -> sequence <$> mapM view (sort known)
|
||||
where
|
||||
view role = do
|
||||
grants <- roleGrantsOf service role
|
||||
members <- membersOfRole service role
|
||||
pure (RoleView role <$> grants <*> members)
|
||||
|
||||
-- | 授权对象落库口径：`*` 原样，裸表名按当前库补全
|
||||
normalizeObject :: Text -> Text -> Text
|
||||
normalizeObject database object
|
||||
| T.strip object == "*" = "*"
|
||||
| T.any (== '.') object = T.toLower (T.strip object)
|
||||
| otherwise = normalizeUser database <> "." <> normalizeUser object
|
||||
|
||||
-- | 一条语句需要哪些 (表, 权限)；Nothing 表示管理员专属
|
||||
requiredActions :: Statement -> Maybe [(Text, Text)]
|
||||
requiredActions stmt = case stmt of
|
||||
Select{} -> Just (selectNeeds (selectFrom stmt) (maybe [] (: []) (selectWhere stmt)))
|
||||
SelectExpr{} ->
|
||||
Just (selectNeeds (selectFrom stmt) (maybe [] (: []) (selectWhere stmt) ++ map snd (selectItems stmt)))
|
||||
Insert table _ rows -> Just ((T.pack table, "insert") : selectsOf (concat rows))
|
||||
Update table assigns cond -> Just ((T.pack table, "update") : selectsOf (map snd assigns ++ maybe [] (: []) cond))
|
||||
Delete table cond -> Just ((T.pack table, "delete") : selectsOf (maybe [] (: []) cond))
|
||||
_ -> Nothing
|
||||
where
|
||||
selectNeeds source exprs = [(ref, "select") | ref <- nub (tableRefsOf source)] ++ selectsOf exprs
|
||||
selectsOf exprs = [(ref, "select") | ref <- nub (concatMap exprTables exprs)]
|
||||
|
||||
-- | 每项 (表, 权限) 都要被某条授权覆盖
|
||||
checkAll :: Text -> [Grant] -> [(Text, Text)] -> Either PrivilegeError ()
|
||||
checkAll database grants needed = case [pair | pair@(table, privilege) <- needed, not (covered table privilege)] of
|
||||
[] -> Right ()
|
||||
((table, privilege) : _) ->
|
||||
Left (PrivilegeError "forbidden" ("permission denied: " <> T.toUpper privilege <> " ON " <> table))
|
||||
where
|
||||
covered table privilege =
|
||||
let target = normalizeObject database table
|
||||
in any
|
||||
(\grant -> (grantObject grant == "*" || grantObject grant == target) && grantPrivilege grant == privilege)
|
||||
grants
|
||||
|
||||
-- | 一个用户实际能用的授权：他所属角色身上的那些
|
||||
grantsOfUser :: Privileges -> Text -> IO (Either PrivilegeError [Grant])
|
||||
grantsOfUser service user = do
|
||||
members <- readRows service membersTable
|
||||
rows <- readRows service grantsTable
|
||||
pure $ do
|
||||
memberRows <- members
|
||||
grantRows <- rows
|
||||
let mine = [normalizeRole (cell "role" row) | row <- memberRows, normalizeUser (cell "member" row) == normalizeUser user]
|
||||
pure [grantOf row | row <- grantRows, normalizeRole (cell "role" row) `elem` mine]
|
||||
|
||||
-- | 一个角色挂着的授权
|
||||
roleGrantsOf :: Privileges -> Text -> IO (Either PrivilegeError [Grant])
|
||||
roleGrantsOf service role = do
|
||||
rows <- readRows service grantsTable
|
||||
pure $ fmap (map grantOf . filter (\row -> normalizeRole (cell "role" row) == normalizeRole role)) rows
|
||||
|
||||
-- | 角色名清单（统一小写）
|
||||
roleNames :: Privileges -> IO (Either PrivilegeError [Text])
|
||||
roleNames service = do
|
||||
rows <- readRows service rolesTable
|
||||
pure (map (normalizeRole . cell "name") <$> rows)
|
||||
|
||||
-- | 一个角色的成员清单
|
||||
membersOfRole :: Privileges -> Text -> IO (Either PrivilegeError [Text])
|
||||
membersOfRole service role = do
|
||||
rows <- readRows service membersTable
|
||||
pure $
|
||||
fmap
|
||||
(map (normalizeUser . cell "member") . filter (\row -> normalizeRole (cell "role" row) == normalizeRole role))
|
||||
rows
|
||||
|
||||
-- | 角色必须存在，否则命令不落地
|
||||
requireRole :: Privileges -> Text -> IO (Either PrivilegeError ())
|
||||
requireRole service role = do
|
||||
known <- roleNames service
|
||||
pure $ case known of
|
||||
Left err -> Left err
|
||||
Right names
|
||||
| normalizeRole role `elem` names -> Right ()
|
||||
| otherwise -> Left (unknownRole role)
|
||||
|
||||
-- | 真正落库（表已经保证存在）
|
||||
applyCommand :: Privileges -> Text -> PrivilegeCommand -> IO (Either PrivilegeError ())
|
||||
applyCommand service database command = case command of
|
||||
CreateRoleCommand role -> do
|
||||
known <- roleNames service
|
||||
case known of
|
||||
Left err -> pure (Left err)
|
||||
Right names
|
||||
| normalizeRole role `elem` names -> pure (Left (PrivilegeError "conflict" ("role already exists: " <> role)))
|
||||
| otherwise -> exec service (insertSql rolesTable ["name"] [normalizeRole role])
|
||||
DropRoleCommand role -> do
|
||||
allowed <- requireRole service role
|
||||
case allowed of
|
||||
Left err -> pure (Left err)
|
||||
Right () -> do
|
||||
first <- exec service ("DELETE FROM " ++ rolesTable ++ " WHERE name = " ++ roleLiteral role)
|
||||
second <- exec service ("DELETE FROM " ++ grantsTable ++ " WHERE role = " ++ roleLiteral role)
|
||||
third <- exec service ("DELETE FROM " ++ membersTable ++ " WHERE role = " ++ roleLiteral role)
|
||||
pure (sequence_ [first, second, third])
|
||||
GrantPrivilegesCommand privileges object role -> do
|
||||
allowed <- requireRole service role
|
||||
case allowed of
|
||||
Left err -> pure (Left err)
|
||||
Right () -> each (expandPrivileges privileges) $ \privilege -> do
|
||||
let target = normalizeObject database object
|
||||
cleared <- exec service (deleteGrantSql role privilege target)
|
||||
case cleared of
|
||||
Left err -> pure (Left err)
|
||||
Right () ->
|
||||
exec service (insertSql grantsTable ["role", "privilege", "object"] [normalizeRole role, privilege, target])
|
||||
RevokePrivilegesCommand privileges object role -> do
|
||||
allowed <- requireRole service role
|
||||
case allowed of
|
||||
Left err -> pure (Left err)
|
||||
Right () ->
|
||||
each (expandPrivileges privileges) $ \privilege ->
|
||||
exec service (deleteGrantSql role privilege (normalizeObject database object))
|
||||
GrantRoleCommand role users -> do
|
||||
allowed <- requireRole service role
|
||||
case allowed of
|
||||
Left err -> pure (Left err)
|
||||
Right () ->
|
||||
each users $ \user -> do
|
||||
known <- membersOfRole service role
|
||||
case known of
|
||||
Left err -> pure (Left err)
|
||||
Right members
|
||||
| normalizeUser user `elem` members -> pure (Right ())
|
||||
| otherwise ->
|
||||
exec service (insertSql membersTable ["role", "member"] [normalizeRole role, normalizeUser user])
|
||||
RevokeRoleCommand role users -> do
|
||||
allowed <- requireRole service role
|
||||
case allowed of
|
||||
Left err -> pure (Left err)
|
||||
Right () ->
|
||||
each users $ \user ->
|
||||
exec
|
||||
service
|
||||
( "DELETE FROM " ++ membersTable ++ " WHERE role = " ++ roleLiteral role
|
||||
++ " AND member = " ++ literal (normalizeUser user)
|
||||
)
|
||||
|
||||
-- | 建表只在第一次用时做；已经有了就算成功
|
||||
withTables :: Privileges -> IO (Either PrivilegeError a) -> IO (Either PrivilegeError a)
|
||||
withTables service action = withMVar (pvLock service) $ \_ -> do
|
||||
ready <- ensureTables service
|
||||
case ready of
|
||||
Left err -> pure (Left err)
|
||||
Right () -> action
|
||||
|
||||
ensureTables :: Privileges -> IO (Either PrivilegeError ())
|
||||
ensureTables service = each tableDefs (createTable service)
|
||||
where
|
||||
tableDefs =
|
||||
[ (rolesTable, "(name VARCHAR(64))")
|
||||
, (grantsTable, "(role VARCHAR(64), privilege VARCHAR(16), object VARCHAR(128))")
|
||||
, (membersTable, "(role VARCHAR(64), member VARCHAR(64))")
|
||||
]
|
||||
|
||||
createTable :: Privileges -> (String, String) -> IO (Either PrivilegeError ())
|
||||
createTable service (table, columns) = do
|
||||
result <- beStatement (pvBackend service) ("CREATE TABLE " ++ table ++ " " ++ columns)
|
||||
pure $ case result of
|
||||
Right _ -> Right ()
|
||||
Left err
|
||||
| "exists" `isInfixOf` err -> Right ()
|
||||
| otherwise -> Left (storageError err)
|
||||
|
||||
-- | 跑一条内部写语句
|
||||
exec :: Privileges -> String -> IO (Either PrivilegeError ())
|
||||
exec service sql = do
|
||||
result <- beStatement (pvBackend service) sql
|
||||
pure $ case result of
|
||||
Left err -> Left (storageError err)
|
||||
Right _ -> Right ()
|
||||
|
||||
-- | 读一张内部表
|
||||
readRows :: Privileges -> String -> IO (Either PrivilegeError [Row])
|
||||
readRows service table = do
|
||||
result <- beStatement (pvBackend service) ("SELECT * FROM " ++ table)
|
||||
pure $ case result of
|
||||
Left err -> Left (storageError err)
|
||||
Right res -> Right (srRows res)
|
||||
|
||||
-- | 行里取一列文本
|
||||
cell :: String -> Row -> Text
|
||||
cell column row = case lookup column row of
|
||||
Just (VStr value) -> T.pack value
|
||||
_ -> ""
|
||||
|
||||
grantOf :: Row -> Grant
|
||||
grantOf row =
|
||||
Grant
|
||||
{ grantRole = normalizeRole (cell "role" row)
|
||||
, grantPrivilege = T.toLower (T.strip (cell "privilege" row))
|
||||
, grantObject = T.toLower (T.strip (cell "object" row))
|
||||
}
|
||||
|
||||
deleteGrantSql :: Text -> Text -> Text -> String
|
||||
deleteGrantSql role privilege object =
|
||||
"DELETE FROM " ++ grantsTable ++ " WHERE role = " ++ roleLiteral role
|
||||
++ " AND privilege = " ++ literal privilege ++ " AND object = " ++ literal object
|
||||
|
||||
insertSql :: String -> [String] -> [Text] -> String
|
||||
insertSql table columns values =
|
||||
"INSERT INTO " ++ table ++ " (" ++ intercalate ", " columns ++ ") VALUES (" ++ intercalate ", " (map literal values) ++ ")"
|
||||
|
||||
-- | 授权里的 ALL 展开成四种具体权限（存具体权限，鉴权不做兜底）
|
||||
expandPrivileges :: [Text] -> [Text]
|
||||
expandPrivileges privileges = nub (concatMap expand (map (T.toLower . T.strip) privileges))
|
||||
where
|
||||
expand "all" = ["select", "insert", "update", "delete"]
|
||||
expand other = [other]
|
||||
|
||||
-- | 一串动作挨着跑，遇到第一个错误就停
|
||||
each :: [a] -> (a -> IO (Either PrivilegeError ())) -> IO (Either PrivilegeError ())
|
||||
each [] _ = pure (Right ())
|
||||
each (item : rest) action = do
|
||||
result <- action item
|
||||
case result of
|
||||
Left err -> pure (Left err)
|
||||
Right () -> each rest action
|
||||
|
||||
roleLiteral :: Text -> String
|
||||
roleLiteral = literal . normalizeRole
|
||||
|
||||
literal :: Text -> String
|
||||
literal = sqlLiteral . VStr . T.unpack
|
||||
|
||||
normalizeRole :: Text -> Text
|
||||
normalizeRole = T.toLower . T.strip
|
||||
|
||||
normalizeUser :: Text -> Text
|
||||
normalizeUser = T.toLower . T.strip
|
||||
|
||||
forbidden :: PrivilegeError
|
||||
forbidden = PrivilegeError "forbidden" "administrator required"
|
||||
|
||||
unknownRole :: Text -> PrivilegeError
|
||||
unknownRole role = PrivilegeError "not_found" ("unknown role: " <> role)
|
||||
|
||||
storageError :: String -> PrivilegeError
|
||||
storageError message = PrivilegeError "storage_error" ("privilege storage: " <> T.pack message)
|
||||
@@ -5,9 +5,8 @@ module ChuSQL.Web.Settings (
|
||||
settingCatalogue,
|
||||
findItem,
|
||||
isRootOnly,
|
||||
isLockedSetting,
|
||||
isRestartRequired,
|
||||
settingsFileCandidates,
|
||||
resolveSettingsFile,
|
||||
readSettingsFile,
|
||||
writeSettingsFile,
|
||||
applySettings,
|
||||
@@ -16,72 +15,93 @@ module ChuSQL.Web.Settings (
|
||||
effectiveSettings,
|
||||
) where
|
||||
|
||||
import ChuSQL.Web.Config (WebConfig (..))
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.Aeson.Key as K
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import ChuSQL.Web.Config (WebConfig (..), canonicalSettingKeys, defaultUser)
|
||||
import ChuSQL.Web.TOML (readSection, writeSection)
|
||||
import Data.List (nub)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Control.Exception (IOException, try)
|
||||
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
|
||||
import System.FilePath (takeDirectory, (</>))
|
||||
|
||||
-- Web 配置项目录，与启动脚本共用一份设置文件，支持热改与重启生效。
|
||||
-- Web 配置项目录，与启动脚本共用一份全局 chusql.toml；
|
||||
-- 每个键只写在它所属的那一段里，web 不再复制存储层的键。
|
||||
|
||||
data SettingItem = SettingItem
|
||||
{ siKey :: Text
|
||||
, siLabel :: Text
|
||||
, siGroup :: Text
|
||||
, siKind :: Text
|
||||
, siEnv :: Text
|
||||
, siDefault :: Text
|
||||
, siRootOnly :: Bool
|
||||
, siRestart :: Bool
|
||||
, siSection :: Text
|
||||
, siTomlKey :: Text
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 全部可配置项（顺序即界面里的顺序）
|
||||
settingCatalogue :: [SettingItem]
|
||||
settingCatalogue =
|
||||
[ item "port" "HTTP port" "server" "int" "CHUSQL_WEB_PORT" "7777" True True
|
||||
, item "host" "Listen address" "server" "text" "CHUSQL_WEB_HOST" "127.0.0.1" True True
|
||||
, item "static-dir" "Static directory" "server" "text" "CHUSQL_WEB_STATIC" "static" True True
|
||||
, item "cookie-secure" "Secure cookie (behind TLS)" "server" "bool" "CHUSQL_WEB_COOKIE_SECURE" "0" True False
|
||||
, item "body-limit" "Max request body (bytes)" "limits" "int" "CHUSQL_WEB_BODY_LIMIT" "65536" False False
|
||||
, item "session-idle" "Session idle timeout (s)" "limits" "int" "CHUSQL_WEB_SESSION_IDLE" "28800" False False
|
||||
, item "session-max" "Session max age (s)" "limits" "int" "CHUSQL_WEB_SESSION_MAX" "86400" False False
|
||||
, item "login-max-attempts" "Failed logins before lockout" "limits" "int" "CHUSQL_WEB_LOGIN_MAX_ATTEMPTS" "5" False False
|
||||
, item "login-window" "Lockout window (s)" "limits" "int" "CHUSQL_WEB_LOGIN_WINDOW" "300" False False
|
||||
, item "rows-per-page" "Rows per page" "limits" "int" "CHUSQL_WEB_PAGE_SIZE" "25" False False
|
||||
, item "max-page-size" "Rows per page ceiling" "limits" "int" "CHUSQL_WEB_MAX_PAGE_SIZE" "500" False False
|
||||
, item "max-rows" "Rows per query" "limits" "int" "CHUSQL_WEB_MAX_ROWS" "1000" False False
|
||||
, item "max-sql-length" "Max SQL characters" "limits" "int" "CHUSQL_WEB_MAX_SQL_LENGTH" "20000" False False
|
||||
, item "user" "Account name" "auth" "text" "CHUSQL_WEB_USER" "root" True True
|
||||
, item "password" "Password (plain, hashed at start)" "auth" "secret" "CHUSQL_WEB_PASSWORD" "" True True
|
||||
, item "password-hash" "Password hash (pbkdf2)" "auth" "secret" "CHUSQL_WEB_PASSWORD_HASH" "" True True
|
||||
, item "data-dir" "Data directory" "storage" "text" "CHUSQL_DATA_DIR" "" True True
|
||||
, item "pipe-name" "Named pipe" "storage" "text" "CHUSQL_PIPE" "" True True
|
||||
, item "storage-page-size" "Storage page size" "storage" "int" "CHUSQL_PAGE_SIZE" "4096" True True
|
||||
, item "storage-btree-order" "Storage B+tree order" "storage" "int" "CHUSQL_BTREE_ORDER" "4" True True
|
||||
, item "storage-buffer-pool" "Storage buffer pool pages" "storage" "int" "CHUSQL_BUFFER_POOL_SIZE" "1024" True True
|
||||
, item "storage-log" "Storage log level" "storage" "text" "CHUSQL_LOG" "info" True True
|
||||
, item "seed" "Seed demo data on start" "storage" "bool" "CHUSQL_WEB_SEED" "1" True True
|
||||
[ item "port" "HTTP port" "server" "int" "7777" True True
|
||||
, item "host" "Listen address" "server" "text" "127.0.0.1" True True
|
||||
, item "static-dir" "Static directory" "server" "text" "static" True True
|
||||
, item "cookie-secure" "Secure cookie (behind TLS)" "server" "bool" "0" True False
|
||||
, item "body-limit" "Max request body (bytes)" "limits" "int" "65536" False False
|
||||
, item "session-idle" "Session idle timeout (s)" "limits" "int" "28800" False False
|
||||
, item "session-max" "Session max age (s)" "limits" "int" "86400" False False
|
||||
, item "login-max-attempts" "Failed logins before lockout" "limits" "int" "5" False False
|
||||
, item "login-window" "Lockout window (s)" "limits" "int" "300" False False
|
||||
, item "rows-per-page" "Rows per page" "limits" "int" "25" False False
|
||||
, item "max-page-size" "Rows per page ceiling" "limits" "int" "500" False False
|
||||
, item "max-rows" "Rows per query" "limits" "int" "1000" False False
|
||||
, item "max-sql-length" "Max SQL characters" "limits" "int" "20000" False False
|
||||
, item "user" "管理员账号（设置文件）" "auth" "text" "root" True True
|
||||
, item "password" "管理员口令（设置文件，明文）" "auth" "secret" "" True True
|
||||
, item "password-min-length" "口令最短长度" "auth" "int" "12" True False
|
||||
, item "password-classes" "口令字符类别数" "auth" "int" "2" True False
|
||||
, owned "data-dir" "Data directory" "storage" "text" "" "storage" "data_dir"
|
||||
, owned "pipe-name" "Endpoint name" "storage" "text" "" "server" "pipe_name"
|
||||
, owned "storage-page-size" "Storage page size" "storage" "int" "4096" "page" "size"
|
||||
, owned "storage-btree-order" "Storage B+tree order" "storage" "int" "4" "btree" "order"
|
||||
, owned "storage-buffer-pool" "Storage buffer pool pages" "storage" "int" "1024" "buffer" "pool_size"
|
||||
, owned "storage-log" "Storage log level" "storage" "text" "info" "log" "level"
|
||||
, item "storage-server" "Storage server executable" "storage" "text" "" True True
|
||||
, item "seed" "Seed demo data on start" "storage" "bool" "1" True True
|
||||
]
|
||||
where
|
||||
item k l g kind env def rootOnly restart =
|
||||
-- web 自己的键：分区写死 [web]，TOML 键名就是界面键名
|
||||
item k l g kind def rootOnly restart =
|
||||
SettingItem
|
||||
{ siKey = k
|
||||
, siLabel = l
|
||||
, siGroup = g
|
||||
, siKind = kind
|
||||
, siEnv = env
|
||||
, siDefault = def
|
||||
, siRootOnly = rootOnly
|
||||
, siRestart = restart
|
||||
, siSection = webSection
|
||||
, siTomlKey = k
|
||||
}
|
||||
-- 存储层的键：只读自己那段
|
||||
owned k l g kind def section tomlKey =
|
||||
SettingItem
|
||||
{ siKey = k
|
||||
, siLabel = l
|
||||
, siGroup = g
|
||||
, siKind = kind
|
||||
, siDefault = def
|
||||
, siRootOnly = True
|
||||
, siRestart = True
|
||||
, siSection = section
|
||||
, siTomlKey = tomlKey
|
||||
}
|
||||
|
||||
-- | web 自己那段
|
||||
webSection :: Text
|
||||
webSection = "web"
|
||||
|
||||
-- | 目录里涉及的分区（按出现顺序，去重）
|
||||
catalogueSections :: [Text]
|
||||
catalogueSections = nub [siSection i | i <- settingCatalogue]
|
||||
|
||||
-- | 按 key 找一项
|
||||
findItem :: Text -> Maybe SettingItem
|
||||
@@ -93,6 +113,14 @@ findItem key = case [i | i <- settingCatalogue, siKey i == key] of
|
||||
isRootOnly :: Text -> Bool
|
||||
isRootOnly key = maybe False siRootOnly (findItem key)
|
||||
|
||||
-- | 只读项：root 凭据只认设置文件里的明文，网页端不能改（改文件后重启生效）
|
||||
lockedKeys :: [Text]
|
||||
lockedKeys = ["user", "password"]
|
||||
|
||||
-- | 这项在界面上是不是只读
|
||||
isLockedSetting :: Text -> Bool
|
||||
isLockedSetting = (`elem` lockedKeys)
|
||||
|
||||
-- | 这项是不是要重启才生效
|
||||
isRestartRequired :: Text -> Bool
|
||||
isRestartRequired key = maybe False siRestart (findItem key)
|
||||
@@ -100,7 +128,8 @@ isRestartRequired key = maybe False siRestart (findItem key)
|
||||
-- | 改完立刻生效的配置键
|
||||
liveKeys :: [Text]
|
||||
liveKeys =
|
||||
[ "body-limit"
|
||||
[ "password-min-length", "password-classes"
|
||||
, "body-limit"
|
||||
, "session-idle"
|
||||
, "session-max"
|
||||
, "login-max-attempts"
|
||||
@@ -111,87 +140,42 @@ liveKeys =
|
||||
, "max-sql-length"
|
||||
]
|
||||
|
||||
-- | 设置文件的候选位置
|
||||
settingsFileCandidates :: [FilePath]
|
||||
settingsFileCandidates =
|
||||
[ "script" </> "chusql.settings.json"
|
||||
, ".." </> "script" </> "chusql.settings.json"
|
||||
, "chusql.settings.json"
|
||||
]
|
||||
|
||||
-- | 找现成的设置文件，否则挑目录已存在的候选
|
||||
resolveSettingsFile :: IO FilePath
|
||||
resolveSettingsFile = do
|
||||
found <- firstExistingFile settingsFileCandidates
|
||||
case found of
|
||||
Just path -> pure path
|
||||
Nothing -> do
|
||||
ready <- firstExistingDir settingsFileCandidates
|
||||
pure (maybe (headOr settingsFileCandidates "chusql.settings.json") id ready)
|
||||
where
|
||||
firstExistingFile [] = pure Nothing
|
||||
firstExistingFile (p : ps) = do
|
||||
ok <- doesFileExist p
|
||||
if ok then pure (Just p) else firstExistingFile ps
|
||||
|
||||
-- | 候选所在目录是否已存在
|
||||
firstExistingDir [] = pure Nothing
|
||||
firstExistingDir (p : ps) = do
|
||||
let dir = takeDirectory p
|
||||
ok <- if null dir then pure True else doesDirectoryExist dir
|
||||
if ok then pure (Just p) else firstExistingDir ps
|
||||
|
||||
-- | 候选列表里的第一个
|
||||
headOr :: [a] -> a -> a
|
||||
headOr (x : _) _ = x
|
||||
headOr [] d = d
|
||||
|
||||
-- | 读设置文件：键 -> 字符串值（文件不存在或坏掉都当空）
|
||||
-- | 读目录里用到的每个分区，摊成界面键；只有 [web] 统一成连字符写法
|
||||
readSettingsFile :: FilePath -> IO (Map.Map Text Text)
|
||||
readSettingsFile path = do
|
||||
exists <- doesFileExist path
|
||||
if not exists
|
||||
then pure Map.empty
|
||||
else do
|
||||
raw <- readFileUtf8 path
|
||||
pure $ case A.eitherDecodeStrict' raw of
|
||||
Left _ -> Map.empty
|
||||
Right (A.Object o) -> Map.fromList [(K.toText k, jsonToText v) | (k, v) <- KM.toList o]
|
||||
Right _ -> Map.empty
|
||||
readSettingsFile path = fmap Map.unions (mapM readSectionOf catalogueSections)
|
||||
where
|
||||
-- | JSON 值当字符串看
|
||||
jsonToText v = case v of
|
||||
A.String s -> s
|
||||
A.Number n -> T.pack (show n)
|
||||
A.Bool b -> if b then "1" else "0"
|
||||
_ -> ""
|
||||
readSectionOf section = do
|
||||
raw <- readSection path section
|
||||
let values = if section == webSection then canonicalSettingKeys raw else raw
|
||||
pure
|
||||
( Map.fromList
|
||||
[ (siKey i, value)
|
||||
| i <- settingCatalogue
|
||||
, siSection i == section
|
||||
, Just value <- [Map.lookup (siTomlKey i) values]
|
||||
]
|
||||
)
|
||||
|
||||
-- | 读文件（UTF-8 字节读，避免依赖系统编码）
|
||||
readFileUtf8 :: FilePath -> IO BS.ByteString
|
||||
readFileUtf8 = BS.readFile
|
||||
|
||||
-- | 写设置文件，只写非空值
|
||||
-- | 按分区写回：每个键落进自己的段，别的分区与注释原样保留
|
||||
writeSettingsFile :: FilePath -> Map.Map Text Text -> IO (Either String ())
|
||||
writeSettingsFile path values = do
|
||||
let dir = takeDirectory path
|
||||
prepared <- try (ensureDir dir) :: IO (Either IOException ())
|
||||
case prepared of
|
||||
Left e -> pure (Left ("cannot create the settings directory " ++ dir ++ ": " ++ show e))
|
||||
Right () -> do
|
||||
let encoded =
|
||||
A.encode
|
||||
( A.Object
|
||||
( KM.fromList
|
||||
[ (K.fromText k, A.String v)
|
||||
| (k, v) <- Map.toList values
|
||||
, not (T.null v)
|
||||
]
|
||||
)
|
||||
)
|
||||
written <- try (BS.writeFile path (BL.toStrict encoded)) :: IO (Either IOException ())
|
||||
pure (either (Left . \e -> "cannot write " ++ path ++ ": " ++ show e) Right written)
|
||||
writeSettingsFile path values = writeSections catalogueSections
|
||||
where
|
||||
ensureDir dir = if null dir then pure () else createDirectoryIfMissing True dir
|
||||
writeSections [] = pure (Right ())
|
||||
writeSections (section : rest) = do
|
||||
let entries =
|
||||
Map.fromList
|
||||
[ (siTomlKey i, value)
|
||||
| i <- settingCatalogue
|
||||
, siSection i == section
|
||||
, Just value <- [Map.lookup (siKey i) values]
|
||||
]
|
||||
if Map.null entries
|
||||
then writeSections rest
|
||||
else do
|
||||
written <- writeSection path section entries
|
||||
case written of
|
||||
Left err -> pure (Left err)
|
||||
Right () -> writeSections rest
|
||||
|
||||
-- | 把界面上传来的值合并进现有文件内容（只接受目录里有的键）
|
||||
applySettings :: Map.Map Text Text -> Map.Map Text Text -> Either String (Map.Map Text Text)
|
||||
@@ -209,6 +193,10 @@ applySettings current = go (Right current) . Map.toList
|
||||
checkKind :: SettingItem -> Text -> Either String ()
|
||||
checkKind spec value
|
||||
| T.null (T.strip value) = Right ()
|
||||
| Just (lo, hi) <- lookup (siKey spec) [("password-min-length", (8, 256)), ("password-classes", (1, 4))] =
|
||||
case reads (T.unpack (T.strip value)) :: [(Int, String)] of
|
||||
[(n, "")] | n >= lo && n <= hi -> Right ()
|
||||
_ -> Left (T.unpack (siKey spec) ++ " is outside the permitted range")
|
||||
| siKind spec == "int" = case reads (T.unpack (T.strip value)) :: [(Int, String)] of
|
||||
[(_, "")] -> Right ()
|
||||
_ -> Left (T.unpack (siKey spec) ++ " needs an integer, got: " ++ T.unpack value)
|
||||
@@ -238,7 +226,7 @@ effectiveSettings cfg =
|
||||
, ("max-page-size", tshow (wcMaxPageSize cfg))
|
||||
, ("max-rows", tshow (wcMaxRows cfg))
|
||||
, ("max-sql-length", tshow (wcMaxSqlLength cfg))
|
||||
, ("user", wcUser cfg)
|
||||
, ("user", if T.null (T.strip (wcUser cfg)) then defaultUser else T.strip (wcUser cfg))
|
||||
, ("seed", boolText (wcSeedDemo cfg))
|
||||
, ("data-dir", maybe "" T.pack (wcDataDir cfg))
|
||||
, ("pipe-name", maybe "" T.pack (wcPipeName cfg))
|
||||
|
||||
@@ -33,7 +33,6 @@ safeRelative t
|
||||
| map toLower (takeExtension (T.unpack t)) `notElem` allowedExtensions = Nothing
|
||||
| otherwise = Just (T.unpack t)
|
||||
where
|
||||
-- | 只允许字母数字与 ._-
|
||||
badChar c = not (isAsciiLower c || isAsciiUpper c || isDigit c || c `elem` ("._-" :: String))
|
||||
|
||||
-- | 读一个静态文件；不存在（或是目录）给 Nothing
|
||||
|
||||
@@ -4,19 +4,22 @@ module ChuSQL.Web.StorageProcess (
|
||||
StorageProcess (..),
|
||||
findStorageServer,
|
||||
startStorageProcess,
|
||||
startStorageProcessAt,
|
||||
platformBinaryName,
|
||||
storageChildArgs,
|
||||
stopStorageProcess,
|
||||
waitForStorage,
|
||||
) where
|
||||
|
||||
import ChuSQL.Storage.IPC (Request (..), Response (..), closeConnection, sendRequest)
|
||||
import ChuSQL.Storage.IPC (Request (..), Response (..), closeConnection, sendRequest, setPipeName)
|
||||
import ChuSQL.Web.Config (loadWebConfigAt, resolvePipeName)
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Exception (SomeException, try)
|
||||
import Control.Monad (filterM)
|
||||
import Data.Time.Clock.POSIX (getPOSIXTime)
|
||||
import System.Directory (createDirectoryIfMissing, doesFileExist, getTemporaryDirectory)
|
||||
import System.Environment (getEnvironment, setEnv)
|
||||
import System.Directory (doesFileExist)
|
||||
import System.Exit (ExitCode)
|
||||
import System.FilePath ((</>))
|
||||
import System.Info (os)
|
||||
import System.IO (Handle)
|
||||
import System.Process (
|
||||
CreateProcess (..),
|
||||
@@ -29,13 +32,21 @@ import System.Process (
|
||||
)
|
||||
|
||||
-- 拉起并管理 Rust 存储进程，起来后等管道应答 ping 再继续。
|
||||
-- 调参、管名与数据目录都在全局 chusql.toml 里，孩子自己读；这里只负责起进程、
|
||||
-- 用 --config 把「读哪份配置文件」告诉它，并等就绪。
|
||||
|
||||
data StorageProcess = StorageProcess
|
||||
{ spProcess :: ProcessHandle
|
||||
, spPipe :: String
|
||||
, spDataDir :: FilePath
|
||||
}
|
||||
|
||||
-- | 可执行文件名跟平台走：Windows 带 .exe，其它平台不带。同一个 target 目录里可能
|
||||
-- 同时躺着一份别处交叉编译出来的 .exe（Windows PE），在 Linux 上误选它只会拿到
|
||||
-- config file not found（Windows 进程看不到 /tmp/... 这样的路径）。目标平台当参数传，
|
||||
-- 两个分支都能被测试直接钉住。
|
||||
platformBinaryName :: String -> String -> FilePath
|
||||
platformBinaryName targetOs stem = if targetOs == "mingw32" then stem ++ ".exe" else stem
|
||||
|
||||
-- | 找存储进程，没有就给路径提示
|
||||
findStorageServer :: Maybe FilePath -> IO (Either String FilePath)
|
||||
findStorageServer (Just p) = do
|
||||
@@ -49,36 +60,37 @@ findStorageServer Nothing = do
|
||||
, "target"
|
||||
]
|
||||
modes = ["release", "debug"]
|
||||
exes = ["chusql-storage.exe", "chusql-storage"]
|
||||
exes = [platformBinaryName os "chusql-storage"]
|
||||
candidates = [d </> m </> e | d <- dirs, m <- modes, e <- exes]
|
||||
found <- filterM doesFileExist candidates
|
||||
pure $ case found of
|
||||
(p : _) -> Right p
|
||||
[] -> Left "no Rust storage server found; run `cargo build --release` in chusql-storage, or pass --storage <path>"
|
||||
-- | 起存储进程并等它就绪
|
||||
startStorageProcess :: FilePath -> IO (Either String StorageProcess)
|
||||
startStorageProcess bin = do
|
||||
stamp <- round . (* 1000000) <$> getPOSIXTime :: IO Integer
|
||||
tmp <- getTemporaryDirectory
|
||||
let pipe = "chusql-web-" ++ show stamp
|
||||
dir = tmp </> pipe
|
||||
createDirectoryIfMissing True dir
|
||||
envs <-
|
||||
childEnv
|
||||
[ ("CHUSQL_PIPE", pipe)
|
||||
, ("CHUSQL_DATA_DIR", dir)
|
||||
]
|
||||
|
||||
-- | 按配置文件里的管名起存储进程
|
||||
startStorageProcess :: FilePath -> FilePath -> IO (Either String StorageProcess)
|
||||
startStorageProcess bin configPath = do
|
||||
cfg <- loadWebConfigAt configPath
|
||||
startStorageProcessAt bin (resolvePipeName cfg) configPath
|
||||
|
||||
-- | 给存储子进程的参数：配置文件位置是固定的，唯一的显式覆盖就是写进 --config
|
||||
storageChildArgs :: FilePath -> [String]
|
||||
storageChildArgs configPath = ["--config", configPath]
|
||||
|
||||
-- | 用给定的管名起存储进程，并把本进程的端点也指到它；环境原样继承
|
||||
startStorageProcessAt :: FilePath -> String -> FilePath -> IO (Either String StorageProcess)
|
||||
startStorageProcessAt bin pipe configPath = do
|
||||
let child = (proc bin (storageChildArgs configPath)){std_out = NoStream, std_err = Inherit}
|
||||
started <-
|
||||
try (createProcess (proc bin []){env = Just envs, std_out = NoStream, std_err = Inherit}) ::
|
||||
try (createProcess child) ::
|
||||
IO (Either SomeException (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
|
||||
case started of
|
||||
Left e -> pure (Left ("failed to start the storage process: " ++ show e))
|
||||
Right (_, _, _, ph) -> do
|
||||
setEnv "CHUSQL_PIPE" pipe
|
||||
setEnv "CHUSQL_DATA_DIR" dir
|
||||
setPipeName pipe
|
||||
ready <- waitForStorage (200 :: Int)
|
||||
if ready
|
||||
then pure (Right (StorageProcess ph pipe dir))
|
||||
then pure (Right (StorageProcess ph pipe))
|
||||
else do
|
||||
_ <- try (terminateProcess ph) :: IO (Either SomeException ())
|
||||
pure (Left "storage process did not become ready within 5 seconds (no ping reply on the pipe)")
|
||||
@@ -99,21 +111,3 @@ waitForStorage n = do
|
||||
case r of
|
||||
Right RespPong -> pure True
|
||||
_ -> threadDelay 25000 >> waitForStorage (n - 1)
|
||||
|
||||
-- | 子进程环境：继承并覆盖两个专用变量
|
||||
childEnv :: [(String, String)] -> IO [(String, String)]
|
||||
childEnv extra = do
|
||||
base <- getEnvironment
|
||||
let ours = ["CHUSQL_PIPE", "CHUSQL_DATA_DIR"]
|
||||
kept = filter (\(k, _) -> k `notElem` ours) base
|
||||
missing (k, _) = not (any ((== k) . fst) kept)
|
||||
defaults = filter missing storageDefaults
|
||||
pure (kept ++ defaults ++ extra)
|
||||
|
||||
-- | 存储进程的调参默认值（可以被用户环境里的同名变量覆盖）
|
||||
storageDefaults :: [(String, String)]
|
||||
storageDefaults =
|
||||
[ ("CHUSQL_PAGE_SIZE", "4096")
|
||||
, ("CHUSQL_BTREE_ORDER", "4")
|
||||
, ("CHUSQL_LOG", "info")
|
||||
]
|
||||
@@ -0,0 +1,163 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChuSQL.Web.TOML
|
||||
( readSection
|
||||
, writeSection
|
||||
, defaultConfigFile
|
||||
, resolveConfigPath
|
||||
) where
|
||||
|
||||
import Control.Exception (IOException, try)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import System.Directory (XdgDirectory (XdgConfig), createDirectoryIfMissing, doesFileExist, getXdgDirectory)
|
||||
import System.FilePath (takeDirectory, (</>))
|
||||
|
||||
-- 全局 chusql.toml 的最小读写：只认 [section] 与 key = value。
|
||||
-- 读写都是一次性打开就关，不长期占着文件句柄，别的层随时能读同一份文件。
|
||||
|
||||
-- | 读一个分区；文件不存在或没有这个分区都当空表
|
||||
readSection :: FilePath -> Text -> IO (Map Text Text)
|
||||
readSection path section = do
|
||||
exists <- doesFileExist path
|
||||
if not exists
|
||||
then pure Map.empty
|
||||
else do
|
||||
raw <- BS.readFile path
|
||||
pure (Map.fromList (sectionEntries section (T.lines (TE.decodeUtf8 raw))))
|
||||
|
||||
-- | 只重写一个分区，其它行（含注释与别的层）原样保留
|
||||
writeSection :: FilePath -> Text -> Map Text Text -> IO (Either String ())
|
||||
writeSection path section values = do
|
||||
prepared <- prepareDirectory
|
||||
case prepared of
|
||||
Left err -> pure (Left err)
|
||||
Right () -> do
|
||||
exists <- doesFileExist path
|
||||
raw <- if exists then TE.decodeUtf8 <$> BS.readFile path else pure ""
|
||||
let updated = T.unlines (rewrite section values (T.lines raw))
|
||||
written <- tryWrite (TE.encodeUtf8 updated)
|
||||
pure written
|
||||
where
|
||||
prepareDirectory = do
|
||||
let dir = takeDirectory path
|
||||
if null dir
|
||||
then pure (Right ())
|
||||
else do
|
||||
done <- try (createDirectoryIfMissing True dir) :: IO (Either IOException ())
|
||||
pure (either (Left . show) (const (Right ())) done)
|
||||
tryWrite bytes = do
|
||||
done <- try (BS.writeFile path bytes) :: IO (Either IOException ())
|
||||
pure (either (Left . show) (const (Right ())) done)
|
||||
|
||||
-- | 分区里的键值对
|
||||
sectionEntries :: Text -> [Text] -> [(Text, Text)]
|
||||
sectionEntries wanted = go ""
|
||||
where
|
||||
go _ [] = []
|
||||
go current (line : rest)
|
||||
| Just name <- sectionName line = go name rest
|
||||
| current /= wanted = go current rest
|
||||
| otherwise = case assignment line of
|
||||
Nothing -> go current rest
|
||||
Just entry -> entry : go current rest
|
||||
|
||||
-- | 是不是分区头，返回分区名
|
||||
sectionName :: Text -> Maybe Text
|
||||
sectionName line = case T.strip line of
|
||||
stripped
|
||||
| "[" `T.isPrefixOf` stripped && "]" `T.isSuffixOf` stripped && T.length stripped > 2 ->
|
||||
Just (T.strip (T.drop 1 (T.dropEnd 1 stripped)))
|
||||
_ -> Nothing
|
||||
|
||||
-- | 是不是 key = value
|
||||
assignment :: Text -> Maybe (Text, Text)
|
||||
assignment line = case T.breakOn "=" (stripComment line) of
|
||||
(key, rest)
|
||||
| not (T.null rest)
|
||||
, let name = T.strip key
|
||||
, not (T.null name) ->
|
||||
Just (name, unquote (T.strip (T.drop 1 rest)))
|
||||
_ -> Nothing
|
||||
|
||||
-- | 去掉行尾注释（引号里的 # 不算）
|
||||
stripComment :: Text -> Text
|
||||
stripComment = T.pack . go False . T.unpack
|
||||
where
|
||||
go _ [] = []
|
||||
go inString ('#' : rest)
|
||||
| not inString = []
|
||||
| otherwise = '#' : go inString rest
|
||||
go inString ('"' : rest) = '"' : go (not inString) rest
|
||||
go inString (ch : rest) = ch : go inString rest
|
||||
|
||||
-- | 去掉包裹的引号
|
||||
unquote :: Text -> Text
|
||||
unquote value
|
||||
| T.length value >= 2 && T.head value == '"' && T.last value == '"' = T.drop 1 (T.dropEnd 1 value)
|
||||
| T.length value >= 2 && T.head value == '\'' && T.last value == '\'' = T.drop 1 (T.dropEnd 1 value)
|
||||
| otherwise = value
|
||||
|
||||
-- | 行级重写：本分区里已有的键就地更新，空值删行，缺的键补在分区末尾
|
||||
rewrite :: Text -> Map Text Text -> [Text] -> [Text]
|
||||
rewrite section values = addMissing . replaceInSection . dropEmpties
|
||||
where
|
||||
dropEmpties = filter (\line -> maybe True (not . T.null . snd) (assignment line))
|
||||
replaceInSection = go ""
|
||||
go _ [] = []
|
||||
go current (line : rest)
|
||||
| Just name <- sectionName line = line : go name rest
|
||||
| current /= section = line : go current rest
|
||||
| otherwise = case assignment line of
|
||||
Just (key, _) | Just value <- Map.lookup key values -> assignmentLine key value : go current rest
|
||||
_ -> line : go current rest
|
||||
addMissing lines' =
|
||||
let present = Set.fromList (keysOf section lines')
|
||||
missing = [(key, value) | (key, value) <- Map.toList values, not (Set.member key present), not (T.null value)]
|
||||
in if null missing then lines' else appendSection section missing lines'
|
||||
|
||||
assignmentLine :: Text -> Text -> Text
|
||||
assignmentLine key value = key <> " = " <> quote value
|
||||
|
||||
quote :: Text -> Text
|
||||
quote value
|
||||
| T.all allowed value && not (T.null value) = value
|
||||
| otherwise = "\"" <> T.replace "\"" "\\\"" value <> "\""
|
||||
where
|
||||
allowed ch = ch `elem` ("0123456789.-" :: String)
|
||||
|
||||
-- | 取某个分区里出现过的键
|
||||
keysOf :: Text -> [Text] -> [Text]
|
||||
keysOf wanted = go ""
|
||||
where
|
||||
go _ [] = []
|
||||
go current (line : rest)
|
||||
| Just name <- sectionName line = go name rest
|
||||
| current /= wanted = go current rest
|
||||
| otherwise = case assignment line of
|
||||
Just (key, _) -> key : go current rest
|
||||
Nothing -> go current rest
|
||||
|
||||
-- | 没有这个分区就在末尾补一个
|
||||
appendSection :: Text -> [(Text, Text)] -> [Text] -> [Text]
|
||||
appendSection section entries lines' =
|
||||
lines'
|
||||
++ (if null lines' || not (T.null (last lines')) then [""] else [])
|
||||
++ ("[" <> section <> "]") : [assignmentLine key value | (key, value) <- entries]
|
||||
|
||||
-- | 全局配置文件的位置：安装时定下的固定路径，跟随系统惯例
|
||||
-- （Windows: %APPDATA%\ChuSQL\chusql.toml；其它平台: $XDG_CONFIG_HOME 或 ~/.config 下的 ChuSQL/chusql.toml）
|
||||
defaultConfigFile :: IO FilePath
|
||||
defaultConfigFile = do
|
||||
dir <- getXdgDirectory XdgConfig "ChuSQL"
|
||||
pure (dir </> "chusql.toml")
|
||||
|
||||
-- | 定位配置文件：命令行 --config 指的是哪份就读哪份，否则用固定路径
|
||||
resolveConfigPath :: Maybe FilePath -> IO FilePath
|
||||
resolveConfigPath (Just path) = pure path
|
||||
resolveConfigPath Nothing = defaultConfigFile
|
||||
@@ -1,11 +1,11 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChuSQL.Web.UiSettings (
|
||||
module ChuSQL.Web.UISettings (
|
||||
uiSettingsFileCandidates,
|
||||
resolveUiSettingsFile,
|
||||
validateUiSettings,
|
||||
readUiSettings,
|
||||
writeUiSettings,
|
||||
resolveUISettingsFile,
|
||||
validateUISettings,
|
||||
readUISettings,
|
||||
writeUISettings,
|
||||
) where
|
||||
|
||||
import Control.Exception (IOException, try)
|
||||
@@ -22,19 +22,19 @@ import qualified Data.Vector as V
|
||||
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
|
||||
import System.FilePath (takeDirectory, (</>))
|
||||
|
||||
-- 前端 IDE 设置单独存一份文件，与启动配置 chusql.settings.json 互不干扰。
|
||||
-- 前端 IDE 设置单独存一份文件，与全局启动配置 chusql.toml 互不干扰。
|
||||
|
||||
-- | IDE 设置文件的候选位置
|
||||
uiSettingsFileCandidates :: [FilePath]
|
||||
uiSettingsFileCandidates =
|
||||
[ "script" </> "chusql.ui.settings.json"
|
||||
, ".." </> "script" </> "chusql.ui.settings.json"
|
||||
[ "scripts" </> "chusql.ui.settings.json"
|
||||
, ".." </> "scripts" </> "chusql.ui.settings.json"
|
||||
, "chusql.ui.settings.json"
|
||||
]
|
||||
|
||||
-- | 找现成的设置文件，否则挑目录已存在的候选
|
||||
resolveUiSettingsFile :: IO FilePath
|
||||
resolveUiSettingsFile = do
|
||||
resolveUISettingsFile :: IO FilePath
|
||||
resolveUISettingsFile = do
|
||||
found <- firstExistingFile uiSettingsFileCandidates
|
||||
case found of
|
||||
Just path -> pure path
|
||||
@@ -42,7 +42,6 @@ resolveUiSettingsFile = do
|
||||
ready <- firstExistingDir uiSettingsFileCandidates
|
||||
pure (maybe firstCandidate id ready)
|
||||
where
|
||||
-- | 候选清单里的第一个
|
||||
firstCandidate = case uiSettingsFileCandidates of
|
||||
(p : _) -> p
|
||||
[] -> "chusql.ui.settings.json"
|
||||
@@ -52,7 +51,6 @@ resolveUiSettingsFile = do
|
||||
ok <- doesFileExist p
|
||||
if ok then pure (Just p) else firstExistingFile ps
|
||||
|
||||
-- | 候选所在目录是否已存在
|
||||
firstExistingDir [] = pure Nothing
|
||||
firstExistingDir (p : ps) = do
|
||||
let dir = takeDirectory p
|
||||
@@ -60,8 +58,8 @@ resolveUiSettingsFile = do
|
||||
if ok then pure (Just p) else firstExistingDir ps
|
||||
|
||||
-- | 校验一份 IDE 设置，未知键与越界都给错
|
||||
validateUiSettings :: A.Value -> Either String (Map.Map Text A.Value)
|
||||
validateUiSettings (A.Object o) = Map.fromList <$> mapM checkField (KM.toList o)
|
||||
validateUISettings :: A.Value -> Either String (Map.Map Text A.Value)
|
||||
validateUISettings (A.Object o) = Map.fromList <$> mapM checkField (KM.toList o)
|
||||
where
|
||||
checkField (rawKey, value) =
|
||||
let key = K.toText rawKey
|
||||
@@ -84,7 +82,7 @@ validateUiSettings (A.Object o) = Map.fromList <$> mapM checkField (KM.toList o)
|
||||
|
||||
pair key value = (key, value)
|
||||
|
||||
validateUiSettings _ = Left "settings must be a JSON object"
|
||||
validateUISettings _ = Left "settings must be a JSON object"
|
||||
|
||||
fontChainMax :: Int
|
||||
fontChainMax = 10
|
||||
@@ -150,8 +148,8 @@ boolValue key value = case value of
|
||||
_ -> Left (T.unpack key ++ " expects a boolean")
|
||||
|
||||
-- | 读 IDE 设置文件，缺文件或坏内容都给空对象
|
||||
readUiSettings :: FilePath -> IO A.Value
|
||||
readUiSettings path = do
|
||||
readUISettings :: FilePath -> IO A.Value
|
||||
readUISettings path = do
|
||||
exists <- doesFileExist path
|
||||
if not exists
|
||||
then pure emptyObject
|
||||
@@ -166,8 +164,8 @@ readUiSettings path = do
|
||||
emptyObject = A.Object KM.empty
|
||||
|
||||
-- | 写 IDE 设置文件，先建目录再落盘
|
||||
writeUiSettings :: FilePath -> Map.Map Text A.Value -> IO (Either String ())
|
||||
writeUiSettings path values = do
|
||||
writeUISettings :: FilePath -> Map.Map Text A.Value -> IO (Either String ())
|
||||
writeUISettings path values = do
|
||||
prepared <- try (ensureDir (takeDirectory path)) :: IO (Either IOException ())
|
||||
case prepared of
|
||||
Left e -> pure (Left ("cannot create the settings directory " ++ takeDirectory path ++ ": " ++ show e))
|
||||
|
||||
Reference in new issue
Block a user