大改，整理项目结构，完成rust ffi调用，写好tcp接口
This commit is contained in:
LIm1tZz7 committed
1 parent
df6d348995
commit
9758439b82
118 files changed
+8103
-6321
No files matched your search
File diff suppressed because it is too large.
Load diff
@@ -1,257 +0,0 @@
|
||||
{-# 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
|
||||
@@ -1,285 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChuSQL.Web.Actions (
|
||||
ColumnSpec (..),
|
||||
CreateTableSpec (..),
|
||||
isIdentifier,
|
||||
columnTypeOf,
|
||||
columnTypeName,
|
||||
coerceValue,
|
||||
sqlLiteral,
|
||||
escapeStringLiteral,
|
||||
createDatabaseSql,
|
||||
dropDatabaseSql,
|
||||
createTableSql,
|
||||
dropTableSql,
|
||||
createIndexSql,
|
||||
dropIndexSql,
|
||||
dropColumnSql,
|
||||
insertRowSql,
|
||||
insertRowsSql,
|
||||
updateRowSql,
|
||||
deleteRowSql,
|
||||
selectRowsSql,
|
||||
createUserSql,
|
||||
alterUserSql,
|
||||
dropUserSql,
|
||||
) where
|
||||
|
||||
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)
|
||||
import Data.Scientific (floatingOrInteger)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
-- 把界面上的一键操作翻译成安全 SQL：标识符过白名单，值一律转义。
|
||||
|
||||
data ColumnSpec = ColumnSpec
|
||||
{ csName :: Text
|
||||
, csType :: Text
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
data CreateTableSpec = CreateTableSpec
|
||||
{ ctsTable :: Text
|
||||
, ctsColumns :: [ColumnSpec]
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 表名/列名的白名单
|
||||
isIdentifier :: Text -> Bool
|
||||
isIdentifier t =
|
||||
not (T.null t)
|
||||
&& T.length t <= 64
|
||||
&& case T.unpack t of
|
||||
(c : cs) -> (isAsciiLower c || isAsciiUpper c || c == '_') && all restChar cs
|
||||
[] -> False
|
||||
where
|
||||
restChar c = isAsciiLower c || isAsciiUpper c || isDigit c || c == '_'
|
||||
|
||||
-- | 检查一个标识符，不合法就报错（带上"是表名还是列名"）
|
||||
checkIdent :: Text -> Text -> Either String Text
|
||||
checkIdent what name
|
||||
| isIdentifier name = Right name
|
||||
| otherwise = Left (T.unpack what ++ " name is not a plain identifier: " ++ T.unpack name)
|
||||
|
||||
-- | 列表不能空
|
||||
requireNonEmpty :: String -> [a] -> Either String [a]
|
||||
requireNonEmpty what xs
|
||||
| null xs = Left (what ++ " must not be empty")
|
||||
| otherwise = Right xs
|
||||
|
||||
-- | 线上列类型名（和数据字典里的写法一致）转本地类型
|
||||
columnTypeOf :: Text -> Maybe Column
|
||||
columnTypeOf = fmap plainColumn . parseColumnType . T.unpack . T.strip
|
||||
|
||||
-- | 本地类型转线上名字
|
||||
columnTypeName :: Column -> Text
|
||||
columnTypeName = T.pack . typeName . columnType
|
||||
|
||||
-- | 字符串字面量转义：单引号翻倍（引擎的词法器就是这么折回去的）
|
||||
escapeStringLiteral :: String -> String
|
||||
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 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 -> 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
|
||||
createTableSql spec = do
|
||||
tbl <- checkIdent "table" (ctsTable spec)
|
||||
cols <- requireNonEmpty "columns" (ctsColumns spec)
|
||||
defs <- mapM columnDef cols
|
||||
pure ("CREATE TABLE " ++ T.unpack tbl ++ " (" ++ intercalate ", " defs ++ ")")
|
||||
where
|
||||
columnDef (ColumnSpec name ty) = do
|
||||
col <- checkIdent "column" name
|
||||
ctype <- maybe (Left ("unknown column type: " ++ T.unpack ty)) Right (columnTypeOf ty)
|
||||
pure (T.unpack col ++ " " ++ T.unpack (columnTypeName ctype))
|
||||
|
||||
-- | 构造 DROP TABLE 语句
|
||||
dropTableSql :: Text -> Either String String
|
||||
dropTableSql table = do
|
||||
tbl <- checkIdent "table" table
|
||||
pure ("DROP TABLE " ++ T.unpack tbl)
|
||||
|
||||
-- | 构造 CREATE INDEX 语句
|
||||
createIndexSql :: Text -> Text -> Either String String
|
||||
createIndexSql table column = do
|
||||
tbl <- checkIdent "table" table
|
||||
col <- checkIdent "column" column
|
||||
pure ("CREATE INDEX ON " ++ T.unpack tbl ++ " (" ++ T.unpack col ++ ")")
|
||||
|
||||
-- | 构造 DROP INDEX 语句
|
||||
dropIndexSql :: Text -> Text -> Either String String
|
||||
dropIndexSql table column = do
|
||||
tbl <- checkIdent "table" table
|
||||
col <- checkIdent "column" column
|
||||
pure ("DROP INDEX ON " ++ T.unpack tbl ++ " (" ++ T.unpack col ++ ")")
|
||||
|
||||
-- | 删列：列定义、索引与数据一起没
|
||||
dropColumnSql :: Text -> Text -> Either String String
|
||||
dropColumnSql table column = do
|
||||
tbl <- checkIdent "table" table
|
||||
col <- checkIdent "column" column
|
||||
pure ("ALTER TABLE " ++ T.unpack tbl ++ " DROP COLUMN " ++ T.unpack col)
|
||||
|
||||
-- | 构造单行 INSERT 语句
|
||||
insertRowSql :: Text -> [(String, Value)] -> Either String String
|
||||
insertRowSql table row = do
|
||||
tbl <- checkIdent "table" table
|
||||
cols <- requireNonEmpty "values" row
|
||||
names <- mapM (checkIdent "column" . T.pack . fst) cols
|
||||
pure
|
||||
( "INSERT INTO "
|
||||
++ T.unpack tbl
|
||||
++ " ("
|
||||
++ intercalate ", " (map T.unpack names)
|
||||
++ ") VALUES ("
|
||||
++ intercalate ", " (map (sqlLiteral . snd) cols)
|
||||
++ ")"
|
||||
)
|
||||
|
||||
-- | 一次插多行，N 行只落一次盘
|
||||
insertRowsSql :: Text -> [[(String, Value)]] -> Either String String
|
||||
insertRowsSql table rows = do
|
||||
tbl <- checkIdent "table" table
|
||||
rs <- requireNonEmpty "rows" rows
|
||||
case rs of
|
||||
[] -> Left "rows must not be empty"
|
||||
(first : _) -> do
|
||||
names <- mapM (checkIdent "column" . T.pack . fst) first
|
||||
let widths = map length rs
|
||||
if any (/= length first) widths
|
||||
then Left "all rows must have the same columns"
|
||||
else
|
||||
pure
|
||||
( "INSERT INTO "
|
||||
++ T.unpack tbl
|
||||
++ " ("
|
||||
++ intercalate ", " (map T.unpack names)
|
||||
++ ") VALUES "
|
||||
++ intercalate ", " ["(" ++ intercalate ", " (map (sqlLiteral . snd) r) ++ ")" | r <- rs]
|
||||
)
|
||||
|
||||
-- | 构造按 id 改行的 UPDATE 语句
|
||||
updateRowSql :: Text -> Int -> [(String, Value)] -> Either String String
|
||||
updateRowSql table key assigns = do
|
||||
tbl <- checkIdent "table" table
|
||||
cols <- requireNonEmpty "values" assigns
|
||||
sets <- mapM (\(n, v) -> (\c -> T.unpack c ++ " = " ++ sqlLiteral v) <$> checkIdent "column" (T.pack n)) cols
|
||||
pure ("UPDATE " ++ T.unpack tbl ++ " SET " ++ intercalate ", " sets ++ " WHERE id = " ++ show key)
|
||||
|
||||
-- | 按 id 删一行，存储层原地删
|
||||
deleteRowSql :: Text -> Int -> Either String String
|
||||
deleteRowSql table key = do
|
||||
tbl <- checkIdent "table" table
|
||||
pure ("DELETE FROM " ++ T.unpack tbl ++ " WHERE id = " ++ show key)
|
||||
|
||||
-- | 浏览一张表的 SELECT，带排序与等值过滤
|
||||
selectRowsSql :: Text -> Maybe (Text, Bool) -> [(Text, Value)] -> Either String String
|
||||
selectRowsSql table order filters = do
|
||||
tbl <- checkIdent "table" table
|
||||
whereSql <- whereClause filters
|
||||
orderSql <- orderClause order
|
||||
pure ("SELECT * FROM " ++ T.unpack tbl ++ whereSql ++ orderSql)
|
||||
|
||||
-- | 拼 WHERE 子句，无条件给空串
|
||||
whereClause :: [(Text, Value)] -> Either String String
|
||||
whereClause filters = case filters of
|
||||
[] -> pure ""
|
||||
_ -> do
|
||||
terms <- mapM term filters
|
||||
pure (" WHERE " ++ intercalate " AND " terms)
|
||||
where
|
||||
term (column, value) = do
|
||||
col <- checkIdent "column" column
|
||||
pure (T.unpack col ++ " = " ++ sqlLiteral value)
|
||||
|
||||
-- | 拼 ORDER BY 子句，无排序给空串
|
||||
orderClause :: Maybe (Text, Bool) -> Either String String
|
||||
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)
|
||||
@@ -1,198 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChuSQL.Web.Auth (
|
||||
Credential (..),
|
||||
defaultIterations,
|
||||
hashPassword,
|
||||
hashPasswordWith,
|
||||
hashLooksValid,
|
||||
verifyPassword,
|
||||
SessionPolicy (..),
|
||||
defaultSessionPolicy,
|
||||
SessionStore,
|
||||
newSessionStore,
|
||||
sessionPolicy,
|
||||
setSessionPolicy,
|
||||
createSession,
|
||||
createVersionedSession,
|
||||
lookupVersionedSession,
|
||||
lookupSession,
|
||||
deleteSession,
|
||||
sessionToken,
|
||||
) where
|
||||
|
||||
import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar)
|
||||
import Crypto.Hash (SHA256 (..))
|
||||
import qualified Crypto.KDF.PBKDF2 as PBKDF2
|
||||
import Crypto.Random (getRandomBytes)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.ByteArray (constEq)
|
||||
import Data.ByteArray.Encoding (Base (Base16), convertFromBase, convertToBase)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
-- 口令与 Session：口令只存 PBKDF2 编码串，会话是服务端内存状态。
|
||||
|
||||
data Credential = Credential
|
||||
{ credUser :: Text
|
||||
, credEncoded :: Text
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 默认迭代次数（10 万次）
|
||||
defaultIterations :: Int
|
||||
defaultIterations = 100000
|
||||
|
||||
-- | 派生密钥长度（字节）
|
||||
keyLength :: Int
|
||||
keyLength = 32
|
||||
|
||||
-- | 盐长度（字节）
|
||||
saltLength :: Int
|
||||
saltLength = 16
|
||||
|
||||
-- | 迭代次数的上界：配置串被人改坏时不至于把自己算死
|
||||
maxIterations :: Int
|
||||
maxIterations = 10000000
|
||||
|
||||
-- | PBKDF2-HMAC-SHA256 派生
|
||||
deriveKey :: Int -> BS.ByteString -> BS.ByteString -> BS.ByteString
|
||||
deriveKey iters salt password =
|
||||
PBKDF2.generate (PBKDF2.prfHMAC SHA256) (PBKDF2.Parameters iters keyLength) password salt
|
||||
|
||||
-- | 字节转十六进制
|
||||
hexEncode :: BS.ByteString -> Text
|
||||
hexEncode = TE.decodeUtf8 . convertToBase Base16
|
||||
|
||||
-- | 十六进制转字节（长度不对/有非法字符就给 Nothing）
|
||||
hexDecode :: Text -> Maybe BS.ByteString
|
||||
hexDecode t = case convertFromBase Base16 (TE.encodeUtf8 t) of
|
||||
Left _ -> Nothing
|
||||
Right bs -> Just bs
|
||||
|
||||
-- | 编码成 `pbkdf2-sha256$次数$盐$哈希`
|
||||
encodeHash :: Int -> BS.ByteString -> BS.ByteString -> Text
|
||||
encodeHash iters salt digest =
|
||||
T.intercalate "$" ["pbkdf2-sha256", T.pack (show iters), hexEncode salt, hexEncode digest]
|
||||
|
||||
-- | 解回 (次数, 盐, 哈希)，坏格式给 Nothing
|
||||
parseHash :: Text -> Maybe (Int, BS.ByteString, BS.ByteString)
|
||||
parseHash t = case T.splitOn "$" t of
|
||||
[alg, itersT, saltT, digestT]
|
||||
| alg == "pbkdf2-sha256" -> do
|
||||
iters <- readMaybe (T.unpack itersT) :: Maybe Int
|
||||
salt <- hexDecode saltT
|
||||
digest <- hexDecode digestT
|
||||
if iters < 1000 || iters > maxIterations || BS.null salt || BS.length digest /= keyLength
|
||||
then Nothing
|
||||
else Just (iters, salt, digest)
|
||||
_ -> Nothing
|
||||
|
||||
-- | 用给定盐生成编码串（给定盐是为了能写确定性测试）
|
||||
hashPasswordWith :: Int -> BS.ByteString -> Text -> Text
|
||||
hashPasswordWith iters salt password =
|
||||
encodeHash iters salt (deriveKey iters salt (TE.encodeUtf8 password))
|
||||
|
||||
-- | 给一个口令配随机盐，生成编码串
|
||||
hashPassword :: Text -> IO Text
|
||||
hashPassword password = do
|
||||
salt <- getRandomBytes saltLength
|
||||
pure (hashPasswordWith defaultIterations salt password)
|
||||
|
||||
-- | 恒定时间校验口令是否匹配
|
||||
verifyPassword :: Text -> Text -> Bool
|
||||
verifyPassword encoded candidate = case parseHash encoded of
|
||||
Nothing -> False
|
||||
Just (iters, salt, digest) -> constEq digest (deriveKey iters salt (TE.encodeUtf8 candidate))
|
||||
|
||||
-- | 编码串本身是否合法（不看口令）
|
||||
hashLooksValid :: Text -> Bool
|
||||
hashLooksValid = isJust . parseHash
|
||||
|
||||
data Session = Session
|
||||
{ sessUser :: Text
|
||||
, sessCreated :: UTCTime
|
||||
, sessSeen :: UTCTime
|
||||
, sessRevision :: Maybe Integer
|
||||
}
|
||||
|
||||
data SessionPolicy = SessionPolicy
|
||||
{ spIdleSeconds :: NominalDiffTime
|
||||
, spAbsoluteSeconds :: NominalDiffTime
|
||||
}
|
||||
|
||||
-- | 默认：空闲 8 小时、绝对 24 小时
|
||||
defaultSessionPolicy :: SessionPolicy
|
||||
defaultSessionPolicy = SessionPolicy (8 * 3600) (24 * 3600)
|
||||
|
||||
data SessionStore = SessionStore
|
||||
{ storeMap :: MVar (Map.Map Text Session)
|
||||
, storeClock :: IO UTCTime
|
||||
, storePolicy :: IORef SessionPolicy
|
||||
}
|
||||
|
||||
-- | 造一个空仓库
|
||||
newSessionStore :: IO UTCTime -> SessionPolicy -> IO SessionStore
|
||||
newSessionStore clock policy = do
|
||||
ref <- newMVar Map.empty
|
||||
policyRef <- newIORef policy
|
||||
pure (SessionStore ref clock policyRef)
|
||||
|
||||
-- | 现在用的是哪套过期策略
|
||||
sessionPolicy :: SessionStore -> IO SessionPolicy
|
||||
sessionPolicy = readIORef . storePolicy
|
||||
|
||||
-- | 换一套过期策略（设置页热改）
|
||||
setSessionPolicy :: SessionStore -> SessionPolicy -> IO ()
|
||||
setSessionPolicy store = writeIORef (storePolicy store)
|
||||
|
||||
-- | 这条会话过期了吗
|
||||
expired :: UTCTime -> SessionPolicy -> Session -> Bool
|
||||
expired now pol s =
|
||||
diffUTCTime now (sessSeen s) > spIdleSeconds pol
|
||||
|| diffUTCTime now (sessCreated s) > spAbsoluteSeconds pol
|
||||
|
||||
-- | 清掉过期会话
|
||||
prune :: UTCTime -> SessionPolicy -> Map.Map Text Session -> Map.Map Text Session
|
||||
prune now pol = Map.filter (not . expired now pol)
|
||||
|
||||
-- | 随机令牌：32 字节，十六进制 64 个字符
|
||||
sessionToken :: IO Text
|
||||
sessionToken = hexEncode <$> getRandomBytes 32
|
||||
|
||||
-- | 开一条会话，返回令牌
|
||||
createSession :: SessionStore -> Text -> IO Text
|
||||
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 revision) (prune now pol m))
|
||||
pure token
|
||||
|
||||
-- | 查令牌并刷新最后活动时间
|
||||
lookupSession :: SessionStore -> Text -> IO (Maybe Text)
|
||||
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, sessRevision s))
|
||||
|
||||
-- | 删掉一条会话（退出登录）
|
||||
deleteSession :: SessionStore -> Text -> IO ()
|
||||
deleteSession store token = modifyMVar_ (storeMap store) (pure . Map.delete token)
|
||||
@@ -1,400 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
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 (..),
|
||||
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（真存储）和内存（测试）两套。
|
||||
|
||||
data StatementResult = StatementResult
|
||||
{ srColumns :: [String]
|
||||
, srRows :: [Row]
|
||||
}
|
||||
|
||||
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 prepare db stmt of
|
||||
Right (Select cols _ _ _ _ _) -> cols
|
||||
Right (SelectExpr items _ _ _ _ _) -> map fst items
|
||||
_ -> []
|
||||
|
||||
-- | 走本地端点的后端（真存储：Windows 具名管道 / Unix 套接字）
|
||||
ipcBackend :: IO Backend
|
||||
ipcBackend = do
|
||||
lock <- newMVar ()
|
||||
let backend current = Backend
|
||||
{ beStatement = \sql -> withMVar lock $ \_ -> runIpc current sql
|
||||
, beCatalog = withMVar lock $ \_ -> do
|
||||
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 -> 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)
|
||||
case result of
|
||||
Left e -> pure (Left e)
|
||||
Right rows -> do
|
||||
cols <- case rows of
|
||||
[] -> do
|
||||
db <- runIPCStorage (schema :: IPCStorage Database)
|
||||
pure (columnsFromStatement db stmt)
|
||||
(r : _) -> pure (map fst r)
|
||||
pure (Right (StatementResult cols rows))
|
||||
|
||||
-- | 内存后端（测试）：状态就是一个 `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 -> 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)
|
||||
| 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 (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 = [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 = 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"
|
||||
@@ -1,210 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChuSQL.Web.Config (
|
||||
WebConfig (..),
|
||||
defaultWebConfig,
|
||||
defaultUser,
|
||||
defaultPassword,
|
||||
usingDefaultCredentials,
|
||||
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 Text.Read (readMaybe)
|
||||
|
||||
-- 运行参数：命令行 > 全局 chusql.toml 的分区 > 内置默认，不看环境变量。
|
||||
-- 配置文件位置是固定的（安装时定下，见 ChuSQL.Web.TOML.defaultConfigFile），
|
||||
-- 想读别处的文件只能在命令行用 --config 指。
|
||||
-- 自己那段是 [web]；管名与数据目录取自 [server] pipe_name / [storage] data_dir，
|
||||
-- 因为它们是存储进程的事实，前端只当端点读。root 凭据只认 [web] 里的明文。
|
||||
|
||||
-- | 默认账号名
|
||||
defaultUser :: Text
|
||||
defaultUser = "root"
|
||||
|
||||
-- | 默认口令（只为方便本地测试；生产/对外必须覆盖）
|
||||
defaultPassword :: Text
|
||||
defaultPassword = "chusql"
|
||||
|
||||
data WebConfig = WebConfig
|
||||
{ wcHost :: String
|
||||
, wcPort :: Int
|
||||
, wcStaticDir :: FilePath
|
||||
, wcUser :: Text
|
||||
, wcStorageServer :: Maybe FilePath
|
||||
, wcPipeName :: Maybe String
|
||||
, wcDataDir :: Maybe FilePath
|
||||
, wcCookieSecure :: Bool
|
||||
, wcBodyLimit :: Int
|
||||
, wcSessionIdle :: Int
|
||||
, wcSessionMax :: Int
|
||||
, wcLoginMaxAttempts :: Int
|
||||
, wcLoginWindow :: Int
|
||||
, wcPageSize :: Int
|
||||
, wcMaxPageSize :: Int
|
||||
, wcMaxRows :: Int
|
||||
, wcMaxSqlLength :: Int
|
||||
, wcSeedDemo :: Bool
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 内置默认
|
||||
defaultWebConfig :: WebConfig
|
||||
defaultWebConfig =
|
||||
WebConfig
|
||||
{ wcHost = "127.0.0.1"
|
||||
, wcPort = 7777
|
||||
, wcStaticDir = "static"
|
||||
, wcUser = ""
|
||||
, wcStorageServer = Nothing
|
||||
, wcPipeName = Nothing
|
||||
, wcDataDir = Nothing
|
||||
, wcCookieSecure = False
|
||||
, wcBodyLimit = 65536
|
||||
, wcSessionIdle = 8 * 3600
|
||||
, wcSessionMax = 24 * 3600
|
||||
, wcLoginMaxAttempts = 5
|
||||
, wcLoginWindow = 5 * 60
|
||||
, wcPageSize = 25
|
||||
, wcMaxPageSize = 500
|
||||
, wcMaxRows = 1000
|
||||
, wcMaxSqlLength = 20000
|
||||
, wcSeedDemo = False
|
||||
}
|
||||
|
||||
-- | [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)
|
||||
|
||||
-- | 下划线写法到连字符写法的别名
|
||||
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")
|
||||
]
|
||||
|
||||
-- | 这份配置用的还是内置默认口令吗。
|
||||
-- 显式留空（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]
|
||||
staticDirCandidates given =
|
||||
[given, "static", "chusql-web/static", "../chusql-web/static", "../static"]
|
||||
|
||||
-- | 找出真正能用的静态目录
|
||||
resolveStaticDir :: FilePath -> IO (Maybe FilePath)
|
||||
resolveStaticDir given = go (staticDirCandidates given)
|
||||
where
|
||||
go [] = pure Nothing
|
||||
go (d : ds) = do
|
||||
ok <- doesDirectoryExist d
|
||||
if ok then pure (Just d) else go ds
|
||||
@@ -10,16 +10,17 @@ module ChuSQL.Web.Demo (
|
||||
seedDemo,
|
||||
) where
|
||||
|
||||
import ChuSQL.Model (Value (..))
|
||||
import ChuSQL.Storage.IPC (TableInfo (..))
|
||||
import ChuSQL.Web.Actions (
|
||||
import ChuSQL.Core.Model (Value (..))
|
||||
import ChuSQL.Core.Protocol (TableInfo (..))
|
||||
import ChuSQL.Interface.Actions (
|
||||
ColumnSpec (..),
|
||||
CreateTableSpec (..),
|
||||
createIndexSql,
|
||||
createTableSql,
|
||||
insertRowsSql,
|
||||
)
|
||||
import ChuSQL.Web.Backend (Backend (..))
|
||||
import ChuSQL.Interface.Session (Session, catalog, runStatement)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
||||
-- 演示数据：三张表加一个二级索引，语句与界面走同一套拼 SQL 的代码。
|
||||
@@ -75,12 +76,12 @@ data SeedReport = SeedReport
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 缺什么补什么，可反复点不重复灌
|
||||
seedDemo :: Backend -> IO (Either String SeedReport)
|
||||
seedDemo backend = do
|
||||
catalog <- beCatalog backend
|
||||
case catalog of
|
||||
Left e -> pure (Left e)
|
||||
-- | 按需灌演示数据：缺表补表、缺索引补索引
|
||||
seedDemo :: Session -> IO (Either Text SeedReport)
|
||||
seedDemo session = do
|
||||
catalogResult <- catalog session
|
||||
case catalogResult of
|
||||
Left message -> pure (Left message)
|
||||
Right infos -> do
|
||||
let existingTables = map tiTable infos
|
||||
missing = [spec | spec <- demoTableSpecs, T.unpack (ctsTable spec) `notElem` existingTables]
|
||||
@@ -93,34 +94,33 @@ seedDemo backend = do
|
||||
]
|
||||
created <- runAll (map createTableSql missing)
|
||||
case created of
|
||||
Left e -> pure (Left e)
|
||||
Left message -> pure (Left message)
|
||||
Right () -> do
|
||||
rowsDone <- runAll [insertRowsSql t rs | (t, rs) <- demoRows, t `elem` missingNames]
|
||||
case rowsDone of
|
||||
Left e -> pure (Left e)
|
||||
Left message -> pure (Left message)
|
||||
Right () -> do
|
||||
indexes <-
|
||||
runAll [createIndexSql t c | (t, c) <- wantedIndexes]
|
||||
pure $
|
||||
fmap
|
||||
(const (SeedReport (map T.unpack missingNames) skipped (map (T.unpack . snd) wantedIndexes)))
|
||||
indexes
|
||||
indexes <- runAll [createIndexSql t c | (t, c) <- wantedIndexes]
|
||||
pure $ fmap (const (SeedReport (map T.unpack missingNames) skipped (map (T.unpack . snd) wantedIndexes))) indexes
|
||||
where
|
||||
runAll :: [Either String String] -> IO (Either String ())
|
||||
-- | 顺序跑完一串语句，首错即停
|
||||
runAll :: [Either String String] -> IO (Either Text ())
|
||||
runAll [] = pure (Right ())
|
||||
runAll (sql : rest) = case sql of
|
||||
Left e -> pure (Left e)
|
||||
Left e -> pure (Left (T.pack e))
|
||||
Right statement -> do
|
||||
result <- beStatement backend statement
|
||||
result <- runStatement session (T.pack statement)
|
||||
case result of
|
||||
Left e -> pure (Left e)
|
||||
Left message -> pure (Left message)
|
||||
Right _ -> runAll rest
|
||||
|
||||
indexMissing :: [TableInfo] -> T.Text -> T.Text -> Bool
|
||||
-- | 目录里这张表缺不缺这个索引
|
||||
indexMissing :: [TableInfo] -> Text -> Text -> Bool
|
||||
indexMissing infos t c = case lookup (T.unpack t) [(tiTable i, tiIndexes i) | i <- infos] of
|
||||
Nothing -> True
|
||||
Just cols -> T.unpack c `notElem` cols
|
||||
|
||||
-- | 演示用户数据
|
||||
userRecords :: [(String, Int)]
|
||||
userRecords =
|
||||
[ ("Alice", 24)
|
||||
@@ -135,6 +135,7 @@ userRecords =
|
||||
, ("Judy", 29)
|
||||
]
|
||||
|
||||
-- | 演示订单数据
|
||||
orderRecords :: [(Int, String, Int)]
|
||||
orderRecords =
|
||||
[ (1, "Laptop", 1299)
|
||||
@@ -151,6 +152,7 @@ orderRecords =
|
||||
, (9, "Lamp", 39)
|
||||
]
|
||||
|
||||
-- | 演示产品数据
|
||||
productRecords :: [(String, Int, Int)]
|
||||
productRecords =
|
||||
[ ("Laptop", 1001, 1299)
|
||||
|
||||
@@ -1,396 +0,0 @@
|
||||
{-# 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)
|
||||
@@ -1,72 +0,0 @@
|
||||
module ChuSQL.Web.RateLimit (
|
||||
RateLimiter,
|
||||
newRateLimiter,
|
||||
setRateLimit,
|
||||
rateLimitBlock,
|
||||
rateLimitRecord,
|
||||
rateLimitClear,
|
||||
) where
|
||||
|
||||
import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime)
|
||||
|
||||
-- 登录失败限流：按用户名数一个滑动窗口里的失败次数。
|
||||
|
||||
data Attempt = Attempt
|
||||
{ attCount :: Int
|
||||
, attStart :: UTCTime
|
||||
}
|
||||
|
||||
data RateLimitPolicy = RateLimitPolicy
|
||||
{ rlpMax :: Int
|
||||
, rlpWindow :: NominalDiffTime
|
||||
}
|
||||
|
||||
data RateLimiter = RateLimiter
|
||||
{ rlMap :: MVar (Map.Map Text Attempt)
|
||||
, rlPolicy :: IORef RateLimitPolicy
|
||||
, rlClock :: IO UTCTime
|
||||
}
|
||||
|
||||
-- | 造一个限流器：多少次失败、窗口多长
|
||||
newRateLimiter :: IO UTCTime -> Int -> NominalDiffTime -> IO RateLimiter
|
||||
newRateLimiter clock maxFailures window = do
|
||||
ref <- newMVar Map.empty
|
||||
policyRef <- newIORef (RateLimitPolicy maxFailures window)
|
||||
pure (RateLimiter ref policyRef clock)
|
||||
|
||||
-- | 换一套限流阈值（设置页热改）
|
||||
setRateLimit :: RateLimiter -> Int -> NominalDiffTime -> IO ()
|
||||
setRateLimit rl maxFailures window =
|
||||
writeIORef (rlPolicy rl) (RateLimitPolicy maxFailures window)
|
||||
|
||||
-- | 这个键被锁住了吗？锁住就返回还要等多少秒
|
||||
rateLimitBlock :: RateLimiter -> Text -> IO (Maybe NominalDiffTime)
|
||||
rateLimitBlock rl key = do
|
||||
now <- rlClock rl
|
||||
pol <- readIORef (rlPolicy rl)
|
||||
m <- readMVar (rlMap rl)
|
||||
pure $ case Map.lookup key m of
|
||||
Just a
|
||||
| attCount a >= rlpMax pol ->
|
||||
let left = rlpWindow pol - diffUTCTime now (attStart a)
|
||||
in if left > 0 then Just left else Nothing
|
||||
_ -> Nothing
|
||||
|
||||
-- | 记一次失败
|
||||
rateLimitRecord :: RateLimiter -> Text -> IO ()
|
||||
rateLimitRecord rl key = do
|
||||
now <- rlClock rl
|
||||
pol <- readIORef (rlPolicy rl)
|
||||
modifyMVar_ (rlMap rl) $ \m ->
|
||||
let kept = Map.filter (\a -> diffUTCTime now (attStart a) < rlpWindow pol) m
|
||||
old = Map.findWithDefault (Attempt 0 now) key kept
|
||||
fresh = if attCount old == 0 then Attempt 1 now else old{attCount = attCount old + 1}
|
||||
in pure (Map.insert key fresh kept)
|
||||
|
||||
-- | 登录成功就把失败记录清掉
|
||||
rateLimitClear :: RateLimiter -> Text -> IO ()
|
||||
rateLimitClear rl key = modifyMVar_ (rlMap rl) (pure . Map.delete key)
|
||||
@@ -1,237 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChuSQL.Web.Settings (
|
||||
SettingItem (..),
|
||||
settingCatalogue,
|
||||
findItem,
|
||||
isRootOnly,
|
||||
isLockedSetting,
|
||||
isRestartRequired,
|
||||
readSettingsFile,
|
||||
writeSettingsFile,
|
||||
applySettings,
|
||||
liveKeys,
|
||||
defaultOf,
|
||||
effectiveSettings,
|
||||
) where
|
||||
|
||||
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
|
||||
|
||||
-- Web 配置项目录，与启动脚本共用一份全局 chusql.toml；
|
||||
-- 每个键只写在它所属的那一段里，web 不再复制存储层的键。
|
||||
|
||||
data SettingItem = SettingItem
|
||||
{ siKey :: Text
|
||||
, siLabel :: Text
|
||||
, siGroup :: Text
|
||||
, siKind :: Text
|
||||
, siDefault :: Text
|
||||
, siRootOnly :: Bool
|
||||
, siRestart :: Bool
|
||||
, siSection :: Text
|
||||
, siTomlKey :: Text
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 全部可配置项（顺序即界面里的顺序）
|
||||
settingCatalogue :: [SettingItem]
|
||||
settingCatalogue =
|
||||
[ 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
|
||||
-- web 自己的键：分区写死 [web]，TOML 键名就是界面键名
|
||||
item k l g kind def rootOnly restart =
|
||||
SettingItem
|
||||
{ siKey = k
|
||||
, siLabel = l
|
||||
, siGroup = g
|
||||
, siKind = kind
|
||||
, 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
|
||||
findItem key = case [i | i <- settingCatalogue, siKey i == key] of
|
||||
(i : _) -> Just i
|
||||
[] -> Nothing
|
||||
|
||||
-- | 这项是不是重要参数（只有配置账号能改）
|
||||
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)
|
||||
|
||||
-- | 改完立刻生效的配置键
|
||||
liveKeys :: [Text]
|
||||
liveKeys =
|
||||
[ "password-min-length", "password-classes"
|
||||
, "body-limit"
|
||||
, "session-idle"
|
||||
, "session-max"
|
||||
, "login-max-attempts"
|
||||
, "login-window"
|
||||
, "rows-per-page"
|
||||
, "max-page-size"
|
||||
, "max-rows"
|
||||
, "max-sql-length"
|
||||
]
|
||||
|
||||
-- | 读目录里用到的每个分区，摊成界面键；只有 [web] 统一成连字符写法
|
||||
readSettingsFile :: FilePath -> IO (Map.Map Text Text)
|
||||
readSettingsFile path = fmap Map.unions (mapM readSectionOf catalogueSections)
|
||||
where
|
||||
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]
|
||||
]
|
||||
)
|
||||
|
||||
-- | 按分区写回：每个键落进自己的段，别的分区与注释原样保留
|
||||
writeSettingsFile :: FilePath -> Map.Map Text Text -> IO (Either String ())
|
||||
writeSettingsFile path values = writeSections catalogueSections
|
||||
where
|
||||
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)
|
||||
applySettings current = go (Right current) . Map.toList
|
||||
where
|
||||
go (Left e) _ = Left e
|
||||
go (Right acc) [] = Right acc
|
||||
go (Right acc) ((key, value) : rest) = case findItem key of
|
||||
Nothing -> Left ("unknown setting: " ++ T.unpack key)
|
||||
Just spec -> case checkKind spec value of
|
||||
Left e -> Left e
|
||||
Right () -> go (Right (Map.insert key value acc)) rest
|
||||
|
||||
-- | 按类型校验一个值（空串表示"清掉"，一律放行）
|
||||
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)
|
||||
| siKind spec == "bool" = case T.toLower (T.strip value) of
|
||||
v | v `elem` ["0", "1", "true", "false", "yes", "no", "on", "off"] -> Right ()
|
||||
_ -> Left (T.unpack (siKey spec) ++ " needs a boolean, got: " ++ T.unpack value)
|
||||
| otherwise = Right ()
|
||||
|
||||
-- | 一项的内置默认值（设置被清掉、也没有别处给值时用它）
|
||||
defaultOf :: Text -> Text
|
||||
defaultOf key = maybe "" siDefault (findItem key)
|
||||
|
||||
-- | 本进程启动时生效的配置，摊成键值对
|
||||
effectiveSettings :: WebConfig -> Map.Map Text Text
|
||||
effectiveSettings cfg =
|
||||
Map.fromList
|
||||
[ ("port", tshow (wcPort cfg))
|
||||
, ("host", T.pack (wcHost cfg))
|
||||
, ("static-dir", T.pack (wcStaticDir cfg))
|
||||
, ("cookie-secure", boolText (wcCookieSecure cfg))
|
||||
, ("body-limit", tshow (wcBodyLimit cfg))
|
||||
, ("session-idle", tshow (wcSessionIdle cfg))
|
||||
, ("session-max", tshow (wcSessionMax cfg))
|
||||
, ("login-max-attempts", tshow (wcLoginMaxAttempts cfg))
|
||||
, ("login-window", tshow (wcLoginWindow cfg))
|
||||
, ("rows-per-page", tshow (wcPageSize cfg))
|
||||
, ("max-page-size", tshow (wcMaxPageSize cfg))
|
||||
, ("max-rows", tshow (wcMaxRows cfg))
|
||||
, ("max-sql-length", tshow (wcMaxSqlLength 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))
|
||||
]
|
||||
where
|
||||
tshow = T.pack . show
|
||||
boolText True = "1"
|
||||
boolText False = "0"
|
||||
@@ -23,7 +23,7 @@ maxNameLength = 128
|
||||
allowedExtensions :: [String]
|
||||
allowedExtensions = [".html", ".css", ".js", ".svg", ".png", ".ico", ".ttf", ".woff2"]
|
||||
|
||||
-- | 把请求里的文件名变成安全的相对路径；不合法给 Nothing
|
||||
-- | 把请求文件名校验成安全相对路径，不合法给 Nothing
|
||||
safeRelative :: Text -> Maybe FilePath
|
||||
safeRelative t
|
||||
| T.null t = Nothing
|
||||
@@ -33,6 +33,7 @@ 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
|
||||
|
||||
@@ -1,113 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChuSQL.Web.StorageProcess (
|
||||
StorageProcess (..),
|
||||
findStorageServer,
|
||||
startStorageProcess,
|
||||
startStorageProcessAt,
|
||||
platformBinaryName,
|
||||
storageChildArgs,
|
||||
stopStorageProcess,
|
||||
waitForStorage,
|
||||
) where
|
||||
|
||||
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 System.Directory (doesFileExist)
|
||||
import System.Exit (ExitCode)
|
||||
import System.FilePath ((</>))
|
||||
import System.Info (os)
|
||||
import System.IO (Handle)
|
||||
import System.Process (
|
||||
CreateProcess (..),
|
||||
ProcessHandle,
|
||||
StdStream (..),
|
||||
createProcess,
|
||||
proc,
|
||||
terminateProcess,
|
||||
waitForProcess,
|
||||
)
|
||||
|
||||
-- 拉起并管理 Rust 存储进程，起来后等管道应答 ping 再继续。
|
||||
-- 调参、管名与数据目录都在全局 chusql.toml 里，孩子自己读；这里只负责起进程、
|
||||
-- 用 --config 把「读哪份配置文件」告诉它，并等就绪。
|
||||
|
||||
data StorageProcess = StorageProcess
|
||||
{ spProcess :: ProcessHandle
|
||||
, spPipe :: String
|
||||
}
|
||||
|
||||
-- | 可执行文件名跟平台走：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
|
||||
ok <- doesFileExist p
|
||||
pure (if ok then Right p else Left ("storage server not found: " ++ p))
|
||||
findStorageServer Nothing = do
|
||||
let dirs =
|
||||
[ "chusql-storage/target"
|
||||
, "../chusql-storage/target"
|
||||
, "../../chusql-storage/target"
|
||||
, "target"
|
||||
]
|
||||
modes = ["release", "debug"]
|
||||
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 -> 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 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
|
||||
setPipeName pipe
|
||||
ready <- waitForStorage (200 :: Int)
|
||||
if ready
|
||||
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)")
|
||||
|
||||
-- | 停掉存储进程，保留数据目录
|
||||
stopStorageProcess :: StorageProcess -> IO ()
|
||||
stopStorageProcess sp = do
|
||||
closeConnection
|
||||
_ <- try (terminateProcess (spProcess sp)) :: IO (Either SomeException ())
|
||||
_ <- try (waitForProcess (spProcess sp)) :: IO (Either SomeException ExitCode)
|
||||
pure ()
|
||||
|
||||
-- | 轮询 ping 直到对面应答
|
||||
waitForStorage :: Int -> IO Bool
|
||||
waitForStorage 0 = pure False
|
||||
waitForStorage n = do
|
||||
r <- try (sendRequest ReqPing) :: IO (Either SomeException Response)
|
||||
case r of
|
||||
Right RespPong -> pure True
|
||||
_ -> threadDelay 25000 >> waitForStorage (n - 1)
|
||||
@@ -1,163 +0,0 @@
|
||||
{-# 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
|
||||
@@ -42,15 +42,18 @@ resolveUISettingsFile = do
|
||||
ready <- firstExistingDir uiSettingsFileCandidates
|
||||
pure (maybe firstCandidate id ready)
|
||||
where
|
||||
-- | 首选候选路径
|
||||
firstCandidate = case uiSettingsFileCandidates of
|
||||
(p : _) -> p
|
||||
[] -> "chusql.ui.settings.json"
|
||||
|
||||
-- | 第一个存在的候选文件
|
||||
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
|
||||
@@ -61,6 +64,7 @@ resolveUISettingsFile = do
|
||||
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
|
||||
in case key of
|
||||
@@ -80,16 +84,20 @@ validateUISettings (A.Object o) = Map.fromList <$> mapM checkField (KM.toList o)
|
||||
"minimap" -> pair key <$> boolValue key value
|
||||
_ -> Left ("unknown setting: " ++ T.unpack key)
|
||||
|
||||
-- | 把键和值配成一对
|
||||
pair key value = (key, value)
|
||||
|
||||
validateUISettings _ = Left "settings must be a JSON object"
|
||||
|
||||
-- | 字体链最多几项
|
||||
fontChainMax :: Int
|
||||
fontChainMax = 10
|
||||
|
||||
-- | 单个字体名最长多少字
|
||||
fontNameMax :: Int
|
||||
fontNameMax = 64
|
||||
|
||||
-- | 空值占位文本最长多少字
|
||||
nullTextMax :: Int
|
||||
nullTextMax = 64
|
||||
|
||||
Reference in new issue
Block a user