大改，整理项目结构，完成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
@@ -0,0 +1,223 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import ChuSQL.Core.Engine.Storage.FFI (storageVersion)
|
||||
import ChuSQL.Core.Engine.Storage.IPC (closeConnection, localStorageLink, setStorageLink)
|
||||
import ChuSQL.Interface.Auth (Credential (..))
|
||||
import ChuSQL.Interface.Config (
|
||||
WebConfig (..),
|
||||
defaultPassword,
|
||||
defaultUser,
|
||||
loadWebConfigAt,
|
||||
resolveCredential,
|
||||
usingDefaultCredentials,
|
||||
)
|
||||
import ChuSQL.Interface.RateLimit (newRateLimiter)
|
||||
import ChuSQL.Interface.Settings (readSettingsFile)
|
||||
import ChuSQL.Interface.TOML (resolveConfigPath)
|
||||
import ChuSQL.Server.Backend (Backend (..), ipcBackend)
|
||||
import ChuSQL.Server.TCP (
|
||||
ServerConfig (..),
|
||||
ServerEnv,
|
||||
loadServerConfigAt,
|
||||
newServerEnv,
|
||||
runServer,
|
||||
)
|
||||
import Control.Exception (IOException, bracket, try)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (exitFailure)
|
||||
import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
-- TCP 服务器入口：解析命令行与配置，装入存储库并以一行一 JSON 的协议对外服务。
|
||||
|
||||
data Options = Options
|
||||
{ optConfig :: Maybe FilePath
|
||||
, optHost :: Maybe String
|
||||
, optPort :: Maybe Int
|
||||
, optUser :: Maybe Text
|
||||
, optMaxMessage :: Maybe Int
|
||||
, optMaxRows :: Maybe Int
|
||||
, optHelp :: Bool
|
||||
}
|
||||
|
||||
-- | 全部选项都取默认值
|
||||
emptyOptions :: Options
|
||||
emptyOptions =
|
||||
Options
|
||||
{ optConfig = Nothing
|
||||
, optHost = Nothing
|
||||
, optPort = Nothing
|
||||
, optUser = Nothing
|
||||
, optMaxMessage = Nothing
|
||||
, optMaxRows = Nothing
|
||||
, optHelp = False
|
||||
}
|
||||
|
||||
-- | 解析参数
|
||||
parseArgs :: [String] -> Either String Options
|
||||
parseArgs = go emptyOptions
|
||||
where
|
||||
-- | 逐条消费参数列表
|
||||
go opts [] = Right opts
|
||||
go opts ("--help" : rest) = go opts{optHelp = True} rest
|
||||
go opts ("-h" : rest) = go opts{optHelp = True} rest
|
||||
go opts ("--config" : v : rest) = go opts{optConfig = Just v} rest
|
||||
go opts ("--host" : v : rest) = go opts{optHost = Just v} rest
|
||||
go opts ("--user" : v : rest) = go opts{optUser = Just (T.pack v)} rest
|
||||
go opts ("--port" : v : rest) = withInt "--port" v (\n -> go opts{optPort = Just n} rest)
|
||||
go opts ("--max-message" : v : rest) = withInt "--max-message" v (\n -> go opts{optMaxMessage = Just n} rest)
|
||||
go opts ("--max-rows" : v : rest) = withInt "--max-rows" v (\n -> go opts{optMaxRows = Just n} rest)
|
||||
go _ (a : _) = Left ("unrecognized argument or missing value: " ++ a)
|
||||
|
||||
-- | 把参数值读成整数，读不出就报错
|
||||
withInt :: String -> String -> (Int -> Either String Options) -> Either String Options
|
||||
withInt name v k = maybe (Left (name ++ " needs an integer, got: " ++ v)) k (readMaybe v)
|
||||
|
||||
-- | 打印用法说明
|
||||
usage :: IO ()
|
||||
usage = do
|
||||
putStrLn "usage: chusql-server [options]"
|
||||
putStrLn ""
|
||||
putStrLn "config: chusql.toml sits at a fixed place and holds every knob;"
|
||||
putStrLn " Windows: %APPDATA%\\ChuSQL\\chusql.toml"
|
||||
putStrLn " other: $XDG_CONFIG_HOME/ChuSQL/chusql.toml (or ~/.config/ChuSQL/chusql.toml)"
|
||||
putStrLn " [storage] data_dir; [server] host/port/max_message/max_rows;"
|
||||
putStrLn " [web] user/password (administrator credentials)"
|
||||
putStrLn ""
|
||||
putStrLn " --config FILE read that config file instead"
|
||||
putStrLn " --host H listen address ([server] host, default 127.0.0.1)"
|
||||
putStrLn " --port N listen port ([server] port, default 7777)"
|
||||
putStrLn " --user NAME administrator name ([web] user, default root)"
|
||||
putStrLn " --max-message N max bytes per request line ([server] max_message, default 1048576)"
|
||||
putStrLn " --max-rows N rows returned per query ([server] max_rows, default 1000)"
|
||||
putStrLn ""
|
||||
putStrLn "protocol: one JSON object per line; hello / login / query / storage / ping / quit"
|
||||
putStrLn " {\"method\":\"login\",\"user\":\"root\",\"password\":\"...\"} then {\"method\":\"query\",\"sql\":\"SELECT 1\"}"
|
||||
putStrLn " {\"method\":\"storage\",\"request\":{...}} forwards one storage request (Web and the CLI use this)"
|
||||
putStrLn ""
|
||||
putStrLn "storage: this process loads the chusql_core_storage library in-process and owns the data directory"
|
||||
putStrLn ""
|
||||
putStrLn "administrator password: user / password in the [web] section of chusql.toml, else the built-in demo"
|
||||
putStrLn " an empty password means the administrator signs in with no password; ordinary accounts are then refused"
|
||||
putStrLn ("without either the demo administrator is " ++ T.unpack defaultUser ++ " / " ++ T.unpack defaultPassword)
|
||||
|
||||
-- | 命令行覆盖管理员
|
||||
applyWebOptions :: WebConfig -> Options -> WebConfig
|
||||
applyWebOptions cfg opts =
|
||||
cfg
|
||||
{ wcUser = orElse (optUser opts) (wcUser cfg)
|
||||
}
|
||||
|
||||
-- | 命令行覆盖监听配置
|
||||
applyServerOptions :: ServerConfig -> Options -> ServerConfig
|
||||
applyServerOptions config opts =
|
||||
config
|
||||
{ scHost = orElse (optHost opts) (scHost config)
|
||||
, scPort = orElse (optPort opts) (scPort config)
|
||||
, scMaxMessage = orElse (optMaxMessage opts) (scMaxMessage config)
|
||||
, scMaxRows = orElse (optMaxRows opts) (scMaxRows config)
|
||||
}
|
||||
|
||||
-- | 有 Just 就用它，否则用兜底值
|
||||
orElse :: Maybe a -> a -> a
|
||||
orElse (Just x) _ = x
|
||||
orElse Nothing y = y
|
||||
|
||||
-- | 入口
|
||||
main :: IO ()
|
||||
main = do
|
||||
hSetBuffering stdout LineBuffering
|
||||
args <- getArgs
|
||||
case parseArgs args of
|
||||
Left err -> do
|
||||
putStrLn ("bad arguments: " ++ err)
|
||||
usage
|
||||
exitFailure
|
||||
Right opts
|
||||
| optHelp opts -> usage
|
||||
| otherwise -> run opts
|
||||
|
||||
-- | 起服务：装入存储库并装配各服务组件
|
||||
run :: Options -> IO ()
|
||||
run opts = do
|
||||
configPath <- resolveConfigPath (optConfig opts)
|
||||
base <- loadWebConfigAt configPath
|
||||
let cfg = applyWebOptions base opts
|
||||
saved <- readSettingsFile configPath
|
||||
cred <- resolveCredential cfg saved
|
||||
config <- applyServerOptions <$> loadServerConfigAt configPath <*> pure opts
|
||||
opened <- localStorageLink (Just configPath)
|
||||
case opened of
|
||||
Left err -> do
|
||||
putStrLn ("cannot open the storage library: " ++ err)
|
||||
exitFailure
|
||||
Right link -> do
|
||||
setStorageLink link
|
||||
backend <- ipcBackend
|
||||
printBanner cfg config configPath
|
||||
checkStorage backend
|
||||
reportCredential cred saved
|
||||
limiter <-
|
||||
newRateLimiter
|
||||
getCurrentTime
|
||||
(wcLoginMaxAttempts cfg)
|
||||
(fromIntegral (wcLoginWindow cfg))
|
||||
env <- newServerEnv backend cred configPath config limiter
|
||||
let announce port = putStrLn ("listening: tcp://" ++ scHost config ++ ":" ++ show port)
|
||||
bracket (pure link) (const closeConnection) (const (serve env announce))
|
||||
|
||||
-- | 起 TCP 服务并处理绑定失败
|
||||
serve :: ServerEnv -> (Int -> IO ()) -> IO ()
|
||||
serve env announce = do
|
||||
result <- try (runServer env announce) :: IO (Either IOException ())
|
||||
case result of
|
||||
Right () -> pure ()
|
||||
Left e -> do
|
||||
putStrLn ("failed to serve TCP: " ++ show e)
|
||||
putStrLn " the port is probably taken or reserved by the system; try another one: --port 7777"
|
||||
exitFailure
|
||||
|
||||
-- | 报告口令来源，用内置默认口令时告警
|
||||
reportCredential :: Credential -> Map.Map Text Text -> IO ()
|
||||
reportCredential cred saved
|
||||
| usingDefaultCredentials saved = do
|
||||
putStrLn ""
|
||||
putStrLn " !! Administrator credentials are not configured; the built-in demo password is in use:"
|
||||
putStrLn (" !! user " ++ T.unpack (credUser cred) ++ " / password " ++ T.unpack defaultPassword)
|
||||
putStrLn " !! set user / password in the [web] section of chusql.toml and restart"
|
||||
putStrLn ""
|
||||
| T.null (credEncoded cred) =
|
||||
putStrLn ("administrator: " ++ T.unpack (credUser cred) ++ " (passwordless: only the administrator may sign in)")
|
||||
| otherwise = putStrLn ("administrator: " ++ T.unpack (credUser cred) ++ " (credentials come from the settings file only)")
|
||||
|
||||
-- | 探测存储是否可用，答不上 ping 就退出
|
||||
checkStorage :: Backend -> IO ()
|
||||
checkStorage backend = do
|
||||
up <- bePing backend
|
||||
if up
|
||||
then putStrLn "storage: up (the library answered ping)"
|
||||
else do
|
||||
putStrLn "storage: DOWN (the storage library did not answer ping)"
|
||||
exitFailure
|
||||
|
||||
-- | 启动横幅
|
||||
printBanner :: WebConfig -> ServerConfig -> FilePath -> IO ()
|
||||
printBanner cfg config configPath = do
|
||||
version <- storageVersion
|
||||
putStrLn "================== ChuSQL Server ==================="
|
||||
putStrLn ("config file: " ++ configPath)
|
||||
putStrLn ("protocol: chusql 1 (one JSON object per line)")
|
||||
putStrLn
|
||||
( "limits: message "
|
||||
++ show (scMaxMessage config)
|
||||
++ "B, query rows "
|
||||
++ show (scMaxRows config)
|
||||
)
|
||||
putStrLn ("storage: chusql_core_storage library " ++ version)
|
||||
putStrLn ("data dir: " ++ orElse (wcDataDir cfg) "(from the config file, else the default)")
|
||||
@@ -0,0 +1,79 @@
|
||||
cabal-version: 2.4
|
||||
|
||||
name: chusql-server
|
||||
version: 1.0.0
|
||||
synopsis: ChuSQL 数据库服务器：TCP 端点 + 自家协议 + SQL 会话
|
||||
description: ChuSQL 的数据库服务器。负责监听 TCP、一行一条 JSON 的自家协议、
|
||||
登录与限流，并把用户 SQL 转交给 chusql-core-engine（存储则由进程内
|
||||
的 chusql_core_storage 动态库承担）。Web 管理端与命令行客户端都只
|
||||
通过这条 TCP 连接访问数据库。
|
||||
build-type: Simple
|
||||
|
||||
library
|
||||
hs-source-dirs: src
|
||||
exposed-modules: ChuSQL.Server.Accounts
|
||||
ChuSQL.Server.Backend
|
||||
ChuSQL.Server.Policy
|
||||
ChuSQL.Server.Privileges
|
||||
ChuSQL.Server.Session
|
||||
ChuSQL.Server.TCP
|
||||
build-depends: base >= 4.14 && < 5
|
||||
, aeson
|
||||
, bytestring
|
||||
, chusql-core-engine
|
||||
, chusql-core-model
|
||||
, chusql-interface
|
||||
, containers
|
||||
, crypton
|
||||
, directory
|
||||
, filepath
|
||||
, memory
|
||||
, network
|
||||
, scientific
|
||||
, text
|
||||
, time
|
||||
, vector
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
||||
|
||||
executable chusql-server
|
||||
main-is: Main.hs
|
||||
hs-source-dirs: app
|
||||
build-depends: base
|
||||
, chusql-core-engine
|
||||
, chusql-core-model
|
||||
, chusql-interface
|
||||
, chusql-server
|
||||
, containers
|
||||
, filepath
|
||||
, text
|
||||
, time
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -threaded
|
||||
-- 运行期找 libchusql_core_storage.so：$ORIGIN 让二进制与动态库同目录即可
|
||||
if os(linux)
|
||||
ld-options: -Wl,-rpath,$ORIGIN
|
||||
if os(osx)
|
||||
ld-options: -Wl,-rpath,@loader_path
|
||||
|
||||
test-suite chusql-server-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
hs-source-dirs: test
|
||||
build-depends: base
|
||||
, aeson
|
||||
, bytestring
|
||||
, chusql-core-engine
|
||||
, chusql-core-model
|
||||
, chusql-interface
|
||||
, chusql-server
|
||||
, containers
|
||||
, directory
|
||||
, filepath
|
||||
, hspec
|
||||
, network
|
||||
, text
|
||||
, time
|
||||
, vector
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -threaded
|
||||
@@ -0,0 +1,257 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChuSQL.Server.Accounts (
|
||||
Accounts, AccountError (..), Principal (..), PasswordPolicy (..), defaultPasswordPolicy,
|
||||
newAccounts, accountsPolicy, setAccountsPolicy, passwordAllowed,
|
||||
rootUserName, principalName, principalIsRoot,
|
||||
authenticate, currentPrincipal,
|
||||
listAccounts, findAccount, AccountCommand (..), accountCommand, runAccountCommand,
|
||||
) where
|
||||
|
||||
import ChuSQL.Core.Engine.Storage.IPC (Account (..), Request (..))
|
||||
import ChuSQL.Core.Engine.Syntax.AST (Statement (..))
|
||||
import ChuSQL.Interface.Auth
|
||||
import ChuSQL.Interface.Policy (PasswordPolicy (..), defaultPasswordPolicy)
|
||||
import ChuSQL.Server.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 管理，口令在此校验并派生哈希。
|
||||
|
||||
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
|
||||
}
|
||||
|
||||
-- | 建账号服务，记录配置根账号
|
||||
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))
|
||||
|
||||
-- | 校验新账号名，并挡掉管理员保留名
|
||||
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)
|
||||
|
||||
-- | 按令牌解析当前身份，版本对不上即失效
|
||||
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
|
||||
@@ -0,0 +1,426 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChuSQL.Server.Backend (
|
||||
StatementResult (..),
|
||||
Backend (..),
|
||||
columnsFromStatement,
|
||||
currentStamp,
|
||||
exprTables,
|
||||
inDatabase,
|
||||
internalTable,
|
||||
grantsTable,
|
||||
ipcBackend,
|
||||
memoryBackend,
|
||||
membersTable,
|
||||
rolesTable,
|
||||
statementNeedsDatabase,
|
||||
statementTables,
|
||||
systemDatabaseName,
|
||||
tableInfoOf,
|
||||
tableRefsOf,
|
||||
) where
|
||||
|
||||
import ChuSQL.Core.Engine (runStatement, runStatementM)
|
||||
import ChuSQL.Core.Model
|
||||
import ChuSQL.Core.Engine.Semantic (prepare)
|
||||
import ChuSQL.Core.Engine.Storage (MonadStorage (schema))
|
||||
import ChuSQL.Core.Engine.Storage.IPC (
|
||||
Account (..),
|
||||
IPCStorage (..),
|
||||
Request (..),
|
||||
Response (..),
|
||||
SchemaColumn (..),
|
||||
TableInfo (..),
|
||||
sendRawRequest,
|
||||
sendRequest,
|
||||
)
|
||||
import ChuSQL.Core.Engine.Syntax.AST
|
||||
import ChuSQL.Core.Engine.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])
|
||||
-- | 原样转发一条存储请求
|
||||
, beStorage :: A.Value -> IO (Either String A.Value)
|
||||
}
|
||||
|
||||
-- | 按给定列名取列，固定列顺序
|
||||
columnsFromStatement :: Database -> Statement -> [String]
|
||||
columnsFromStatement db stmt = case prepare db stmt of
|
||||
Right (Select cols _ _ _ _ _) -> cols
|
||||
Right (SelectExpr items _ _ _ _ _) -> map fst items
|
||||
_ -> []
|
||||
|
||||
-- | 走本地存储链路的后端
|
||||
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"
|
||||
, beStorage = \payload -> withMVar lock $ \_ -> runRaw payload
|
||||
}
|
||||
-- 没有默认库：没选库时 current 是空串，任何请求都得先选库
|
||||
pure (backend "")
|
||||
where
|
||||
-- | 转发一条存储请求并解析响应
|
||||
runRaw :: A.Value -> IO (Either String A.Value)
|
||||
runRaw payload = do
|
||||
response <- sendRawRequest (BL.toStrict (A.encode payload))
|
||||
pure $ case response of
|
||||
Left err -> Left err
|
||||
Right raw -> case A.eitherDecodeStrict raw of
|
||||
Left err -> Left ("storage response is not valid JSON: " ++ err)
|
||||
Right value -> Right value
|
||||
|
||||
-- | 走存储链路跑一条语句
|
||||
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
|
||||
|
||||
-- | 构造内存后端，Bool 决定普通库还是系统库视角
|
||||
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]))
|
||||
, beStorage = \_ -> pure (Left "storage is not available in this backend")
|
||||
}
|
||||
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)
|
||||
}
|
||||
|
||||
-- | 未选库时的视角：只放行不碰表的语句
|
||||
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")
|
||||
}
|
||||
|
||||
-- | 给语句里的裸表名补上当前库前缀，子查询里的表名也一起改
|
||||
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
|
||||
|
||||
-- | 改写 FROM 子句
|
||||
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)}
|
||||
|
||||
-- | 语句里出现的表
|
||||
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"
|
||||
|
||||
-- | 角色与授权表的名字，不带内部前缀
|
||||
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"
|
||||
@@ -0,0 +1,23 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChuSQL.Server.Policy (
|
||||
configurePasswordPolicy,
|
||||
policyFromValues,
|
||||
passwordKeys,
|
||||
) where
|
||||
|
||||
import ChuSQL.Interface.Policy (defaultPasswordPolicy, passwordKeys, policyFromValues)
|
||||
import ChuSQL.Interface.Settings (applySettings, defaultOf, readSettingsFile)
|
||||
import ChuSQL.Server.Accounts (Accounts, setAccountsPolicy)
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
-- 口令策略装配：从设置文件读 password-* 键算出生效策略，并装到账号服务上。
|
||||
|
||||
-- | 从设置文件装口令策略，坏值报错
|
||||
configurePasswordPolicy :: Accounts -> FilePath -> IO ()
|
||||
configurePasswordPolicy accounts path = do
|
||||
saved <- readSettingsFile path
|
||||
let values = Map.fromList [(key, Map.findWithDefault (defaultOf key) key saved) | key <- passwordKeys]
|
||||
case applySettings Map.empty values of
|
||||
Left err -> ioError (userError err)
|
||||
Right valid -> setAccountsPolicy accounts (policyFromValues defaultPasswordPolicy valid)
|
||||
@@ -0,0 +1,394 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChuSQL.Server.Privileges (
|
||||
Grant (..),
|
||||
Membership (..),
|
||||
PrivilegeCommand (..),
|
||||
PrivilegeError (..),
|
||||
Privileges,
|
||||
RoleView (..),
|
||||
authorize,
|
||||
authorizeTables,
|
||||
filterTables,
|
||||
listRoleViews,
|
||||
newPrivileges,
|
||||
normalizeObject,
|
||||
privilegeCommand,
|
||||
runPrivilegeCommand,
|
||||
) where
|
||||
|
||||
import ChuSQL.Core.Model (Row, Value (..))
|
||||
import ChuSQL.Core.Engine.Syntax.AST
|
||||
import ChuSQL.Server.Accounts (Principal, principalIsRoot, principalName)
|
||||
import ChuSQL.Interface.Actions (sqlLiteral)
|
||||
import ChuSQL.Interface.Protocol (Grant (..), RoleView (..))
|
||||
import ChuSQL.Server.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
|
||||
|
||||
-- 角色与权限服务：角色、授权与成员关系落在 system 库的表里，并据此判权限。
|
||||
|
||||
-- | 出错口径与账号服务一致
|
||||
data PrivilegeError = PrivilegeError Text Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- 一条角色授权（定义在共享协议层）
|
||||
-- | 角色成员资格
|
||||
data Membership = Membership
|
||||
{ memberRole :: Text
|
||||
, memberUser :: Text
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- | 一个角色的全貌：授权与成员
|
||||
|
||||
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
|
||||
|
||||
-- | 一条语句需要哪些 (表, 权限)
|
||||
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
|
||||
-- | FROM 子句要的 SELECT 权限
|
||||
selectNeeds source exprs = [(ref, "select") | ref <- nub (tableRefsOf source)] ++ selectsOf exprs
|
||||
-- | 表达式里子查询要的 SELECT 权限
|
||||
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))
|
||||
}
|
||||
|
||||
-- | 拼一条删授权的 SQL
|
||||
deleteGrantSql :: Text -> Text -> Text -> String
|
||||
deleteGrantSql role privilege object =
|
||||
"DELETE FROM " ++ grantsTable ++ " WHERE role = " ++ roleLiteral role
|
||||
++ " AND privilege = " ++ literal privilege ++ " AND object = " ++ literal object
|
||||
|
||||
-- | 拼一条插入的 SQL
|
||||
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
|
||||
|
||||
-- | 角色名的 SQL 字面量
|
||||
roleLiteral :: Text -> String
|
||||
roleLiteral = literal . normalizeRole
|
||||
|
||||
-- | 文本值的 SQL 字面量
|
||||
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)
|
||||
@@ -0,0 +1,327 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChuSQL.Server.Session
|
||||
( QueryResult (..)
|
||||
, Session
|
||||
, SessionError (..)
|
||||
, engineErrorCode
|
||||
, newSession
|
||||
, sessionUser
|
||||
, sessionIsAdmin
|
||||
, sessionDatabase
|
||||
, isPlainIdentifier
|
||||
, authenticateSession
|
||||
, authenticateSessionCoded
|
||||
, switchDatabase
|
||||
, runStatement
|
||||
, runStatementCoded
|
||||
, catalog
|
||||
, accounts
|
||||
, roleViews
|
||||
, databases
|
||||
, policyOf
|
||||
, reloadPolicy
|
||||
, queryResultJson
|
||||
) where
|
||||
|
||||
import ChuSQL.Core.Model (Value (..))
|
||||
import ChuSQL.Core.Protocol (Account, QueryResult (..), queryResultJson)
|
||||
import ChuSQL.Core.Engine.Storage.IPC (TableInfo (..))
|
||||
import ChuSQL.Core.Engine.Syntax.AST (Statement (..))
|
||||
import ChuSQL.Core.Engine.Syntax.Parser (parseStatement)
|
||||
import ChuSQL.Interface.AccountTable (systemTableInfo)
|
||||
import ChuSQL.Interface.Auth (Credential, defaultSessionPolicy, newSessionStore)
|
||||
import ChuSQL.Server.Accounts
|
||||
import ChuSQL.Server.Backend (Backend (..), StatementResult (..))
|
||||
import ChuSQL.Server.Policy (configurePasswordPolicy)
|
||||
import ChuSQL.Server.Privileges (PrivilegeCommand, PrivilegeError (..), Privileges, RoleView, authorize, filterTables, listRoleViews, newPrivileges, privilegeCommand, runPrivilegeCommand)
|
||||
import Control.Exception (IOException, try)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Char (isAlpha, isAlphaNum)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
|
||||
-- SQL 会话：Web、命令行与 TCP 服务器共用的账号、权限与语句执行入口。
|
||||
|
||||
-- | 带错误码的失败：码与 Web REST 的错误码同一个词汇表
|
||||
data SessionError = SessionError
|
||||
{ sessCode :: Text
|
||||
, sessMessage :: Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | 引擎报错翻成错误码
|
||||
engineErrorCode :: String -> SessionError
|
||||
engineErrorCode err
|
||||
| "no database selected" `T.isInfixOf` message = SessionError "no_database" message
|
||||
| "unknown table" `T.isInfixOf` message = SessionError "not_found" message
|
||||
| otherwise = SessionError "query_error" message
|
||||
where
|
||||
message = T.pack err
|
||||
|
||||
data Session = Session
|
||||
{ ssBackend :: Backend
|
||||
, ssAccounts :: Accounts
|
||||
, ssPrivileges :: Privileges
|
||||
, ssCurrent :: IORef Text
|
||||
, ssPrincipal :: IORef (Maybe Principal)
|
||||
, ssSettingsFile :: FilePath
|
||||
}
|
||||
|
||||
-- | 开一个会话：账号与角色服务、配置策略都和 Web 端一致
|
||||
newSession :: Backend -> Credential -> FilePath -> IO Session
|
||||
newSession backend credential settingsFile = do
|
||||
sessions <- newSessionStore getCurrentTime defaultSessionPolicy
|
||||
accountsService <- newAccounts backend sessions credential
|
||||
privileges <- newPrivileges backend
|
||||
configurePasswordPolicy accountsService settingsFile
|
||||
-- 服务启动后只有系统库：没 USE 之前不预设任何工作库
|
||||
current <- newIORef ""
|
||||
principal <- newIORef Nothing
|
||||
pure (Session backend accountsService privileges current principal settingsFile)
|
||||
|
||||
-- | 当前生效的口令策略（只有管理员能看）
|
||||
policyOf :: Session -> IO (Either Text PasswordPolicy)
|
||||
policyOf session = do
|
||||
admin <- sessionIsAdmin session
|
||||
if not admin
|
||||
then pure (Left "administrator required")
|
||||
else Right <$> accountsPolicy (ssAccounts session)
|
||||
|
||||
-- | 重读设置文件里的口令策略
|
||||
reloadPolicy :: Session -> IO (Either Text PasswordPolicy)
|
||||
reloadPolicy session = do
|
||||
admin <- sessionIsAdmin session
|
||||
if not admin
|
||||
then pure (Left "administrator required")
|
||||
else do
|
||||
outcome <- try (configurePasswordPolicy (ssAccounts session) (ssSettingsFile session)) :: IO (Either IOException ())
|
||||
case outcome of
|
||||
Left err -> pure (Left (T.pack (show err)))
|
||||
Right () -> policyOf session
|
||||
|
||||
-- | 当前登录的账号名
|
||||
sessionUser :: Session -> IO (Maybe Text)
|
||||
sessionUser session = fmap principalName <$> readIORef (ssPrincipal session)
|
||||
|
||||
-- | 是不是配置里的 root
|
||||
sessionIsAdmin :: Session -> IO Bool
|
||||
sessionIsAdmin session = maybe False principalIsRoot <$> readIORef (ssPrincipal session)
|
||||
|
||||
-- | 当前库
|
||||
sessionDatabase :: Session -> IO Text
|
||||
sessionDatabase = readIORef . ssCurrent
|
||||
|
||||
-- | 与解析器一致的裸标识符判断
|
||||
isPlainIdentifier :: Text -> Bool
|
||||
isPlainIdentifier name =
|
||||
not (T.null name)
|
||||
&& T.length name <= 64
|
||||
&& (isAlpha (T.head name) || T.head name == '_')
|
||||
&& T.all (\ch -> isAlphaNum ch || ch == '_') name
|
||||
|
||||
-- | 登录：root 比配置凭据，普通账号查系统表
|
||||
authenticateSession :: Session -> Text -> Text -> IO (Either Text ())
|
||||
authenticateSession session user password =
|
||||
fmap (first sessMessage) (authenticateSessionCoded session user password)
|
||||
|
||||
-- | 登录（带错误码）
|
||||
authenticateSessionCoded :: Session -> Text -> Text -> IO (Either SessionError ())
|
||||
authenticateSessionCoded session user password = do
|
||||
result <- authenticate (ssAccounts session) user password
|
||||
case result of
|
||||
Left err -> pure (Left (accountErrorOf err))
|
||||
Right token -> do
|
||||
who <- currentPrincipal (ssAccounts session) token
|
||||
case who of
|
||||
Left err -> pure (Left (accountErrorOf err))
|
||||
Right principal -> do
|
||||
writeIORef (ssPrincipal session) (Just principal)
|
||||
pure (Right ())
|
||||
|
||||
-- | 换库；系统库只有 root 能进
|
||||
switchDatabase :: Session -> Text -> IO (Either Text ())
|
||||
switchDatabase session name =
|
||||
fmap (first sessMessage) (switchDatabaseCoded session name)
|
||||
|
||||
-- | 换库（带错误码）
|
||||
switchDatabaseCoded :: Session -> Text -> IO (Either SessionError ())
|
||||
switchDatabaseCoded session rawName
|
||||
| not (isPlainIdentifier name) = pure (Left (SessionError "bad_request" ("not a plain database name: " <> name)))
|
||||
| name == "system" = do
|
||||
admin <- sessionIsAdmin session
|
||||
if admin then go else pure (Left (SessionError "forbidden" "the system database is only available to the administrator"))
|
||||
| otherwise = go
|
||||
where
|
||||
name = T.toLower (T.strip rawName)
|
||||
-- | 真的切库并记下当前库
|
||||
go = do
|
||||
backend <- currentBackend session
|
||||
result <- beStatement backend ("USE " ++ T.unpack name)
|
||||
case result of
|
||||
Left err -> pure (Left (engineErrorCode err))
|
||||
Right _ -> writeIORef (ssCurrent session) name >> pure (Right ())
|
||||
|
||||
-- | 跑一条语句：USE、账号与角色语句分流，其余交引擎
|
||||
runStatement :: Session -> Text -> IO (Either Text QueryResult)
|
||||
runStatement session sql = fmap (first sessMessage) (runStatementCoded session sql)
|
||||
|
||||
-- | 跑一条语句（带错误码）
|
||||
runStatementCoded :: Session -> Text -> IO (Either SessionError QueryResult)
|
||||
runStatementCoded session sql = case parseStatement (T.unpack sql) of
|
||||
Right (UseDatabase name) -> do
|
||||
switched <- switchDatabaseCoded session (T.pack name)
|
||||
case switched of
|
||||
Left err -> pure (Left err)
|
||||
Right () -> do
|
||||
current <- readIORef (ssCurrent session)
|
||||
pure (Right (emptyResult (Just current)))
|
||||
Right statement
|
||||
| Just command <- accountCommand statement -> runAccount session command
|
||||
| Just command <- privilegeCommand statement -> runPrivilege session command
|
||||
| otherwise -> do
|
||||
allowed <- authorized session statement
|
||||
case allowed of
|
||||
Left err -> pure (Left err)
|
||||
Right () -> runPlain session sql
|
||||
Left _ -> runPlain session sql
|
||||
|
||||
-- | 普通身份跑语句前的权限判定；管理员与未登录放行
|
||||
authorized :: Session -> Statement -> IO (Either SessionError ())
|
||||
authorized session statement = do
|
||||
who <- readIORef (ssPrincipal session)
|
||||
case who of
|
||||
Just principal | not (principalIsRoot principal) -> do
|
||||
database <- readIORef (ssCurrent session)
|
||||
result <- authorize (ssPrivileges session) principal database statement
|
||||
pure (either (Left . privilegeErrorOf) (const (Right ())) result)
|
||||
_ -> pure (Right ())
|
||||
|
||||
-- | 落到引擎/存储层的一条语句
|
||||
runPlain :: Session -> Text -> IO (Either SessionError QueryResult)
|
||||
runPlain session sql = do
|
||||
backend <- currentBackend session
|
||||
result <- beStatement backend (T.unpack sql)
|
||||
pure (either (Left . engineErrorCode) (Right . resultOf) result)
|
||||
|
||||
-- | 数据字典；普通身份只看到有 SELECT 权的表
|
||||
catalog :: Session -> IO (Either Text [TableInfo])
|
||||
catalog session = do
|
||||
current <- readIORef (ssCurrent session)
|
||||
if T.null current
|
||||
then pure (Left "no database selected")
|
||||
else do
|
||||
backend <- currentBackend session
|
||||
result <- beCatalog backend
|
||||
case result of
|
||||
Left e -> pure (Left (T.pack e))
|
||||
Right infos -> do
|
||||
who <- readIORef (ssPrincipal session)
|
||||
visible <- case who of
|
||||
Just principal | not (principalIsRoot principal) -> do
|
||||
allowed <- filterTables (ssPrivileges session) principal current (map (T.pack . tiTable) infos)
|
||||
pure (either (Left . privilegeMessage) (\names -> Right (filter (\info -> T.pack (tiTable info) `elem` names) infos)) allowed)
|
||||
_ -> pure (Right infos)
|
||||
case visible of
|
||||
Left message -> pure (Left message)
|
||||
Right tables
|
||||
| current == "system" -> Right <$> withAccountInfo session tables
|
||||
| otherwise -> pure (Right tables)
|
||||
|
||||
-- | 系统库里补上账号表
|
||||
withAccountInfo :: Session -> [TableInfo] -> IO [TableInfo]
|
||||
withAccountInfo session tables = do
|
||||
admin <- sessionIsAdmin session
|
||||
if not admin
|
||||
then pure tables
|
||||
else do
|
||||
result <- listAccounts (ssAccounts session)
|
||||
pure $ case result of
|
||||
Left _ -> tables
|
||||
Right rows -> systemTableInfo{tiRows = length rows} : tables
|
||||
|
||||
-- | 库清单（\l 用）
|
||||
databases :: Session -> IO (Either Text [Text])
|
||||
databases session = do
|
||||
result <- beDatabases (ssBackend session)
|
||||
pure (either (Left . T.pack) (Right . map T.pack) result)
|
||||
|
||||
-- | 角色总览，只给管理员
|
||||
roleViews :: Session -> IO (Either Text [RoleView])
|
||||
roleViews session = do
|
||||
admin <- sessionIsAdmin session
|
||||
if not admin
|
||||
then pure (Left "administrator required")
|
||||
else do
|
||||
result <- listRoleViews (ssPrivileges session)
|
||||
pure (either (Left . privilegeMessage) Right result)
|
||||
|
||||
-- | 账号清单（\du 与账号管理页用）；只给管理员
|
||||
accounts :: Session -> IO (Either Text [Account])
|
||||
accounts session = do
|
||||
admin <- sessionIsAdmin session
|
||||
if not admin
|
||||
then pure (Left "administrator required")
|
||||
else do
|
||||
result <- listAccounts (ssAccounts session)
|
||||
pure (either (Left . T.pack . show) Right result)
|
||||
|
||||
-- | 当前库对应的后端
|
||||
currentBackend :: Session -> IO Backend
|
||||
currentBackend session = do
|
||||
name <- readIORef (ssCurrent session)
|
||||
pure (beWithDatabase (ssBackend session) (T.unpack name))
|
||||
|
||||
-- | 账号语句走账号服务，普通账号一律拒绝
|
||||
runAccount :: Session -> AccountCommand -> IO (Either SessionError QueryResult)
|
||||
runAccount session command = do
|
||||
who <- readIORef (ssPrincipal session)
|
||||
case who of
|
||||
Nothing -> pure (Left (SessionError "unauthorized" "sign in first"))
|
||||
Just principal -> do
|
||||
result <- runAccountCommand (ssAccounts session) principal command
|
||||
pure (either (Left . accountErrorOf) (const (Right (emptyResult Nothing))) result)
|
||||
|
||||
-- | 角色语句走权限服务，普通账号拒绝
|
||||
runPrivilege :: Session -> PrivilegeCommand -> IO (Either SessionError QueryResult)
|
||||
runPrivilege session command = do
|
||||
who <- readIORef (ssPrincipal session)
|
||||
case who of
|
||||
Nothing -> pure (Left (SessionError "unauthorized" "sign in first"))
|
||||
Just principal -> do
|
||||
database <- readIORef (ssCurrent session)
|
||||
result <- runPrivilegeCommand (ssPrivileges session) principal database command
|
||||
pure (either (Left . privilegeErrorOf) (const (Right (emptyResult Nothing))) result)
|
||||
|
||||
-- | 账号错误转成会话错误
|
||||
accountErrorOf :: AccountError -> SessionError
|
||||
accountErrorOf (AccountError code message) = SessionError code message
|
||||
|
||||
-- | 权限错误转成会话错误
|
||||
privilegeErrorOf :: PrivilegeError -> SessionError
|
||||
privilegeErrorOf (PrivilegeError code message) = SessionError code message
|
||||
|
||||
-- | 取权限错误的文案
|
||||
privilegeMessage :: PrivilegeError -> Text
|
||||
privilegeMessage (PrivilegeError _ message) = message
|
||||
|
||||
-- | 只带库名的空结果
|
||||
emptyResult :: Maybe Text -> QueryResult
|
||||
emptyResult database = QueryResult [] [] 0 False database
|
||||
|
||||
-- | 存储结果转成查询结果
|
||||
resultOf :: StatementResult -> QueryResult
|
||||
resultOf result =
|
||||
QueryResult
|
||||
{ qrColumns = map T.pack (srColumns result)
|
||||
, qrRows = [map (cellOf row) (srColumns result) | row <- srRows result]
|
||||
, qrRowCount = length (srRows result)
|
||||
, qrTruncated = False
|
||||
, qrDatabase = Nothing
|
||||
}
|
||||
where
|
||||
-- | 按列名取单元格
|
||||
cellOf row name = maybe VNull id (lookup name row)
|
||||
|
||||
@@ -0,0 +1,288 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ChuSQL.Server.TCP (
|
||||
ServerConfig (..),
|
||||
defaultServerConfig,
|
||||
loadServerConfigAt,
|
||||
ServerEnv (..),
|
||||
newServerEnv,
|
||||
ServerHandle (..),
|
||||
startServer,
|
||||
runServer,
|
||||
) where
|
||||
|
||||
import ChuSQL.Interface.Auth (Credential)
|
||||
import ChuSQL.Interface.Config (ServerConfig (..), defaultServerConfig, loadServerConfigAt)
|
||||
import ChuSQL.Interface.Policy (PasswordPolicy (..))
|
||||
import ChuSQL.Interface.Protocol (ClientRequest (..), ServerResponse (..), decodeRequest, encodeResponse, protocolVersion)
|
||||
import ChuSQL.Interface.RateLimit (RateLimiter, rateLimitBlock, rateLimitClear, rateLimitRecord)
|
||||
import ChuSQL.Server.Backend (Backend (..))
|
||||
import ChuSQL.Server.Session (QueryResult (..), Session, SessionError (..), accounts, authenticateSessionCoded, catalog, databases, newSession, policyOf, reloadPolicy, roleViews, runStatementCoded, sessionIsAdmin, sessionUser)
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
|
||||
import Control.Exception (IOException, try)
|
||||
import Control.Monad (void)
|
||||
import qualified Data.ByteString.Char8 as BSC
|
||||
import qualified Data.ByteString.Lazy.Char8 as BLC
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Network.Socket (
|
||||
AddrInfo (..),
|
||||
AddrInfoFlag (AI_PASSIVE),
|
||||
SockAddr (SockAddrInet, SockAddrInet6),
|
||||
Socket,
|
||||
SocketOption (ReuseAddr),
|
||||
SocketType (Stream),
|
||||
accept,
|
||||
addrAddress,
|
||||
addrFamily,
|
||||
bind,
|
||||
close,
|
||||
defaultHints,
|
||||
defaultProtocol,
|
||||
getAddrInfo,
|
||||
getSocketName,
|
||||
listen,
|
||||
setSocketOption,
|
||||
socket,
|
||||
socketToHandle,
|
||||
)
|
||||
import System.IO (BufferMode (LineBuffering), IOMode (ReadWriteMode), hClose, hFlush, hPutStrLn, hSetBuffering, hSetNewlineMode, noNewlineTranslation, stderr)
|
||||
import System.IO.Error (isEOFError)
|
||||
|
||||
-- TCP 服务器：监听端口，一连接一会话，按一行一 JSON 收发协议消息。
|
||||
|
||||
-- 服务器
|
||||
|
||||
data ServerEnv = ServerEnv
|
||||
{ srvBackend :: Backend
|
||||
, srvCredential :: Credential
|
||||
, srvSettingsFile :: FilePath
|
||||
, srvConfig :: ServerConfig
|
||||
, srvLimiter :: RateLimiter
|
||||
}
|
||||
|
||||
-- | 组装服务器环境：每个连接再各开一个会话
|
||||
newServerEnv :: Backend -> Credential -> FilePath -> ServerConfig -> RateLimiter -> IO ServerEnv
|
||||
newServerEnv backend credential settingsFile config limiter =
|
||||
pure (ServerEnv backend credential settingsFile config limiter)
|
||||
|
||||
data ServerHandle = ServerHandle
|
||||
{ shPort :: Int
|
||||
, shStop :: IO ()
|
||||
}
|
||||
|
||||
-- | 起监听并在线程里收连接（测试与嵌入用）
|
||||
startServer :: ServerEnv -> IO ServerHandle
|
||||
startServer env = do
|
||||
sock <- listenSocket (scHost (srvConfig env)) (scPort (srvConfig env))
|
||||
port <- actualPort sock
|
||||
stopped <- newMVar False
|
||||
_ <- forkIO (acceptLoop env sock stopped)
|
||||
pure (ServerHandle port (stopListening sock stopped))
|
||||
|
||||
-- | 在调用线程里收连接（可执行文件用）；绑好端口先回调一次
|
||||
runServer :: ServerEnv -> (Int -> IO ()) -> IO ()
|
||||
runServer env announce = do
|
||||
sock <- listenSocket (scHost (srvConfig env)) (scPort (srvConfig env))
|
||||
port <- actualPort sock
|
||||
announce port
|
||||
stopped <- newMVar False
|
||||
acceptLoop env sock stopped
|
||||
|
||||
-- | 置停止标记并关掉监听套接字
|
||||
stopListening :: Socket -> MVar Bool -> IO ()
|
||||
stopListening sock stopped = do
|
||||
modifyMVar_ stopped (const (pure True))
|
||||
void (try (close sock) :: IO (Either IOException ()))
|
||||
|
||||
-- | 建监听套接字；端口 0 表示由系统分配
|
||||
listenSocket :: String -> Int -> IO Socket
|
||||
listenSocket host port = do
|
||||
let hints = defaultHints{addrSocketType = Stream, addrFlags = [AI_PASSIVE]}
|
||||
node = if null host then Nothing else Just host
|
||||
infos <- getAddrInfo (Just hints) node (Just (show port))
|
||||
case infos of
|
||||
[] -> ioError (userError ("cannot resolve listen address: " ++ host))
|
||||
(info : _) -> do
|
||||
sock <- socket (addrFamily info) Stream defaultProtocol
|
||||
setSocketOption sock ReuseAddr 1
|
||||
bind sock (addrAddress info)
|
||||
listen sock 128
|
||||
pure sock
|
||||
|
||||
-- | 系统分配端口后读回真正的端口
|
||||
actualPort :: Socket -> IO Int
|
||||
actualPort sock = do
|
||||
address <- getSocketName sock
|
||||
pure $ case address of
|
||||
SockAddrInet port _ -> fromIntegral port
|
||||
SockAddrInet6 port _ _ _ -> fromIntegral port
|
||||
_ -> 0
|
||||
|
||||
-- | 循环 accept，把每个连接交给独立线程
|
||||
acceptLoop :: ServerEnv -> Socket -> MVar Bool -> IO ()
|
||||
acceptLoop env sock stopped = loop
|
||||
where
|
||||
-- | 等下一个连接
|
||||
loop = do
|
||||
stop <- readMVar stopped
|
||||
if stop
|
||||
then pure ()
|
||||
else do
|
||||
accepted <- try (accept sock) :: IO (Either IOException (Socket, SockAddr))
|
||||
case accepted of
|
||||
Left err -> do
|
||||
stopping <- readMVar stopped
|
||||
if stopping then pure () else hPutStrLn stderr ("accept failed: " ++ show err)
|
||||
Right (conn, _) -> do
|
||||
void (forkIO (reportConnection env conn))
|
||||
loop
|
||||
|
||||
-- | 连接线程：异常写到 stderr
|
||||
reportConnection :: ServerEnv -> Socket -> IO ()
|
||||
reportConnection env conn = do
|
||||
outcome <- try (serveConnection env conn) :: IO (Either IOException ())
|
||||
case outcome of
|
||||
Left err -> hPutStrLn stderr ("connection failed: " ++ show err)
|
||||
Right () -> pure ()
|
||||
|
||||
-- | 一个连接一个会话：一行一条 JSON，读到 EOF 就收工
|
||||
serveConnection :: ServerEnv -> Socket -> IO ()
|
||||
serveConnection env conn = do
|
||||
h <- socketToHandle conn ReadWriteMode
|
||||
hSetBuffering h LineBuffering
|
||||
hSetNewlineMode h noNewlineTranslation
|
||||
session <- newSession (srvBackend env) (srvCredential env) (srvSettingsFile env)
|
||||
outcome <- try (loop h session) :: IO (Either IOException ())
|
||||
case outcome of
|
||||
Left err | not (isEOFError err) -> hPutStrLn stderr ("connection error: " ++ show err)
|
||||
_ -> pure ()
|
||||
void (try (hClose h) :: IO (Either IOException ()))
|
||||
where
|
||||
-- | 逐行读请求并应答
|
||||
loop h session = do
|
||||
line <- BSC.hGetLine h
|
||||
let cleaned = BSC.dropWhileEnd (== '\r') line
|
||||
if BSC.length cleaned > scMaxMessage (srvConfig env)
|
||||
then send h (RespError "too_large" "request line too large") >> loop h session
|
||||
else case decodeRequest cleaned of
|
||||
Left message -> send h (RespError "bad_request" message) >> loop h session
|
||||
Right request -> do
|
||||
(response, keepGoing) <- dispatch env session request
|
||||
send h response
|
||||
if keepGoing then loop h session else pure ()
|
||||
-- | 发一条响应并冲缓冲
|
||||
send h response = do
|
||||
BLC.hPutStr h (encodeResponse response)
|
||||
BLC.hPutStr h "\n"
|
||||
hFlush h
|
||||
|
||||
-- | 一条请求一条响应，quit 后停连接
|
||||
dispatch :: ServerEnv -> Session -> ClientRequest -> IO (ServerResponse, Bool)
|
||||
dispatch env session request = case request of
|
||||
ReqHello version
|
||||
| version == protocolVersion -> pure (RespHello protocolVersion, True)
|
||||
| otherwise -> pure (RespError "bad_request" ("unsupported protocol version: " <> tshow version), True)
|
||||
ReqLogin user password -> do
|
||||
response <- login env session user password
|
||||
pure (response, True)
|
||||
ReqQuery sql -> do
|
||||
who <- sessionUser session
|
||||
response <- case who of
|
||||
Nothing -> pure (RespError "unauthorized" "sign in first")
|
||||
Just _
|
||||
| T.null (T.strip sql) -> pure (RespError "bad_request" "sql must not be empty")
|
||||
| otherwise -> do
|
||||
result <- runStatementCoded session sql
|
||||
pure $ case result of
|
||||
Left err -> RespError (sessCode err) (sessMessage err)
|
||||
Right queryResult -> RespResult (trimResult (scMaxRows (srvConfig env)) queryResult)
|
||||
pure (response, True)
|
||||
ReqStorage payload -> do
|
||||
who <- sessionUser session
|
||||
response <- case who of
|
||||
Nothing -> pure (RespError "unauthorized" "sign in first")
|
||||
Just _ -> do
|
||||
admin <- sessionIsAdmin session
|
||||
if not admin
|
||||
then pure (RespError "forbidden" "administrator required")
|
||||
else do
|
||||
result <- beStorage (srvBackend env) payload
|
||||
pure $ case result of
|
||||
Left err -> RespError "storage_error" (T.pack err)
|
||||
Right value -> RespStorage value
|
||||
pure (response, True)
|
||||
ReqCatalog -> do
|
||||
response <- overSession session (catalog session) RespCatalog
|
||||
pure (response, True)
|
||||
ReqDatabases -> do
|
||||
response <- overSession session (databases session) RespDatabases
|
||||
pure (response, True)
|
||||
ReqRoles -> do
|
||||
response <- overSession session (roleViews session) RespRoles
|
||||
pure (response, True)
|
||||
ReqAccounts -> do
|
||||
response <- overSession session (accounts session) RespAccounts
|
||||
pure (response, True)
|
||||
ReqPolicy -> do
|
||||
response <- overSession session (policyOf session) policyResponse
|
||||
pure (response, True)
|
||||
ReqReloadPolicy -> do
|
||||
response <- overSession session (reloadPolicy session) policyResponse
|
||||
pure (response, True)
|
||||
ReqPing -> pure (RespPong, True)
|
||||
ReqQuit -> pure (RespBye, False)
|
||||
|
||||
-- | 口令策略在线上只有两个数字：最短长度与至少几类字符
|
||||
policyResponse :: PasswordPolicy -> ServerResponse
|
||||
policyResponse (PasswordPolicy minLength classes) = RespPolicy minLength classes
|
||||
|
||||
-- | 会话方法统一口径：没登录先挡，其余失败按码表落到响应
|
||||
overSession :: Session -> IO (Either Text a) -> (a -> ServerResponse) -> IO ServerResponse
|
||||
overSession session action wrap = do
|
||||
who <- sessionUser session
|
||||
case who of
|
||||
Nothing -> pure (RespError "unauthorized" "sign in first")
|
||||
Just _ -> do
|
||||
result <- action
|
||||
pure $ case result of
|
||||
Left message -> RespError (sessionCode message) message
|
||||
Right value -> wrap value
|
||||
|
||||
-- | 会话层的失败文案归一到协议错误码
|
||||
sessionCode :: Text -> Text
|
||||
sessionCode message
|
||||
| message == "no database selected" = "no_database"
|
||||
| message == "administrator required" = "forbidden"
|
||||
| otherwise = "query_error"
|
||||
|
||||
-- | 登录：按账号名限流，成功清账
|
||||
login :: ServerEnv -> Session -> Text -> Text -> IO ServerResponse
|
||||
login env session user password = do
|
||||
let key = T.toLower (T.strip user)
|
||||
blocked <- rateLimitBlock (srvLimiter env) key
|
||||
case blocked of
|
||||
Just seconds -> pure (RespError "too_many_attempts" ("too many failed logins, retry in " <> tshow (ceiling seconds :: Integer) <> "s"))
|
||||
Nothing -> do
|
||||
result <- authenticateSessionCoded session key password
|
||||
case result of
|
||||
Left err -> do
|
||||
rateLimitRecord (srvLimiter env) key
|
||||
pure (RespError (sessCode err) (sessMessage err))
|
||||
Right () -> do
|
||||
rateLimitClear (srvLimiter env) key
|
||||
who <- sessionUser session
|
||||
admin <- sessionIsAdmin session
|
||||
pure (RespLogin (fromMaybe key who) admin)
|
||||
|
||||
-- | 按上限截行，总行数保持不变
|
||||
trimResult :: Int -> QueryResult -> QueryResult
|
||||
trimResult limit result
|
||||
| length (qrRows result) > limit = result{qrRows = take limit (qrRows result), qrTruncated = True}
|
||||
| otherwise = result
|
||||
|
||||
-- | show 成 Text
|
||||
tshow :: Show a => a -> Text
|
||||
tshow = T.pack . show
|
||||
@@ -0,0 +1,10 @@
|
||||
resolver: lts-24.59
|
||||
|
||||
extra-lib-dirs:
|
||||
- ../chusql-core/storage/target/release
|
||||
|
||||
packages:
|
||||
- .
|
||||
- ../chusql-core/engine
|
||||
- ../chusql-core/model
|
||||
- ../chusql-interface
|
||||
@@ -0,0 +1,12 @@
|
||||
# This file was autogenerated by Stack.
|
||||
# You should not edit this file by hand.
|
||||
# For more information, please see the documentation at:
|
||||
# https://docs.haskellstack.org/en/stable/topics/lock_files
|
||||
|
||||
packages: []
|
||||
snapshots:
|
||||
- completed:
|
||||
sha256: 0f728e30e843d7f00460ad56858b995a3b227fca683659c7df9f2fc3988a3ce1
|
||||
size: 732465
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/59.yaml
|
||||
original: lts-24.59
|
||||
@@ -0,0 +1,416 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import ChuSQL.Core.Model (Database, Table (..), Value (..), pattern TInt, pattern TStr)
|
||||
import ChuSQL.Interface.Auth (Credential (..), hashPasswordWith)
|
||||
import ChuSQL.Interface.Protocol (ClientRequest (..), ServerResponse (..), decodeRequest, encodeResponse)
|
||||
import ChuSQL.Interface.RateLimit (newRateLimiter)
|
||||
import ChuSQL.Server.Backend (memoryBackend)
|
||||
import ChuSQL.Server.Session (QueryResult (..))
|
||||
import ChuSQL.Server.TCP (
|
||||
ServerConfig (..),
|
||||
ServerEnv,
|
||||
ServerHandle (..),
|
||||
defaultServerConfig,
|
||||
loadServerConfigAt,
|
||||
newServerEnv,
|
||||
startServer,
|
||||
)
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.MVar (newMVar)
|
||||
import Control.Exception (IOException, bracket, finally, try)
|
||||
import Control.Monad (void)
|
||||
import Data.Aeson (decode)
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.Aeson.Key as K
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as BSC
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Network.Socket (
|
||||
AddrInfo (..),
|
||||
SocketType (Stream),
|
||||
addrAddress,
|
||||
addrFamily,
|
||||
connect,
|
||||
defaultHints,
|
||||
defaultProtocol,
|
||||
getAddrInfo,
|
||||
socket,
|
||||
socketToHandle,
|
||||
withSocketsDo,
|
||||
)
|
||||
import System.Directory (doesFileExist, getTemporaryDirectory, removeFile)
|
||||
import System.FilePath ((</>))
|
||||
import System.IO (
|
||||
BufferMode (LineBuffering),
|
||||
Handle,
|
||||
IOMode (ReadWriteMode),
|
||||
hClose,
|
||||
hFlush,
|
||||
hIsEOF,
|
||||
hSetBuffering,
|
||||
hSetNewlineMode,
|
||||
noNewlineTranslation,
|
||||
)
|
||||
import System.Timeout (timeout)
|
||||
import Test.Hspec
|
||||
|
||||
-- TCP 服务器测试：协议编解码、配置读取与真连服务器的端到端用例。
|
||||
|
||||
-- | 测试入口
|
||||
main :: IO ()
|
||||
main = hspec spec
|
||||
|
||||
-- | 全部用例
|
||||
spec :: Spec
|
||||
spec = do
|
||||
tcpSpec
|
||||
tcpServerSpec
|
||||
|
||||
-- 夹具：内存后端装在 MVar 里，跟 Web 测试同一套表
|
||||
|
||||
-- | 夹具库名
|
||||
testDatabaseName :: String
|
||||
testDatabaseName = "test"
|
||||
|
||||
-- | users 5 行 + orders 1 行
|
||||
testDb :: Database
|
||||
testDb =
|
||||
[ ( "users"
|
||||
, Table
|
||||
"users"
|
||||
[("id", TInt), ("name", TStr), ("age", TInt)]
|
||||
[ [("id", VInt i), ("name", VStr ("user" ++ show i)), ("age", VInt (20 + i))]
|
||||
| i <- [1 .. 5]
|
||||
]
|
||||
)
|
||||
, ( "orders"
|
||||
, Table
|
||||
"orders"
|
||||
[("id", TInt), ("user_id", TInt)]
|
||||
[[("id", VInt 1), ("user_id", VInt 1)]]
|
||||
)
|
||||
]
|
||||
|
||||
-- | 测试账号：迭代次数压低（跑得快），口令 `s3cret`
|
||||
testCredential :: Credential
|
||||
testCredential = Credential "admin" (hashPasswordWith 1000 (BS.replicate 16 7) "s3cret")
|
||||
|
||||
-- 小工具
|
||||
|
||||
-- | 取字段
|
||||
field :: Text -> A.Value -> Maybe A.Value
|
||||
field name (A.Object o) = KM.lookup (K.fromText name) o
|
||||
field _ _ = Nothing
|
||||
|
||||
-- | 取字段（没有给 Null）
|
||||
at :: Text -> A.Value -> A.Value
|
||||
at name value = fromMaybe A.Null (field name value)
|
||||
|
||||
-- | 当数组看
|
||||
items :: A.Value -> [A.Value]
|
||||
items (A.Array xs) = V.toList xs
|
||||
items _ = []
|
||||
|
||||
-- | 当文本看
|
||||
asText :: A.Value -> Text
|
||||
asText (A.String t) = t
|
||||
asText _ = ""
|
||||
|
||||
-- | 当整数看
|
||||
asInt :: A.Value -> Int
|
||||
asInt (A.Number n) = round n
|
||||
asInt _ = -1
|
||||
|
||||
-- | JSON 当布尔看
|
||||
asBool :: A.Value -> Bool
|
||||
asBool (A.Bool b) = b
|
||||
asBool _ = False
|
||||
|
||||
-- | 第 i 个元素（越界给 Nothing，不用 `!!`）
|
||||
nth :: Int -> [a] -> Maybe a
|
||||
nth i xs = case drop i xs of
|
||||
(x : _) -> Just x
|
||||
[] -> Nothing
|
||||
|
||||
-- | 临时 TOML
|
||||
tcpConfigPath :: String -> IO FilePath
|
||||
tcpConfigPath name = do
|
||||
tmp <- getTemporaryDirectory
|
||||
pure (tmp </> ("chusql-server-test-" ++ name ++ ".toml"))
|
||||
|
||||
-- | 临时设置文件（新会话读口令策略用）
|
||||
tempSettingsPath :: String -> IO FilePath
|
||||
tempSettingsPath name = do
|
||||
tmp <- getTemporaryDirectory
|
||||
pure (tmp </> ("chusql-server-test-" ++ name ++ "-settings.json"))
|
||||
|
||||
-- | 文件不存在也算成功
|
||||
removeIfExists :: FilePath -> IO ()
|
||||
removeIfExists path = do
|
||||
there <- doesFileExist path
|
||||
if there then void (try (removeFile path) :: IO (Either IOException ())) else pure ()
|
||||
|
||||
-- | 起一台内存后端的测试服务器
|
||||
withTcpServer :: ServerConfig -> (ServerEnv -> ServerHandle -> IO a) -> IO a
|
||||
withTcpServer config body = do
|
||||
db <- newMVar testDb
|
||||
limiter <- newRateLimiter getCurrentTime 50 300
|
||||
path <- tempSettingsPath "tcp-server"
|
||||
removeIfExists path
|
||||
env <- newServerEnv (memoryBackend testDatabaseName db) testCredential path config{scPort = 0} limiter
|
||||
handle <- startServer env
|
||||
body env handle `finally` shStop handle
|
||||
|
||||
-- | 连上服务器并配成行缓冲句柄
|
||||
withConnection :: ServerHandle -> (Handle -> IO a) -> IO a
|
||||
withConnection handle body = bracket open closeQuietly body
|
||||
where
|
||||
-- | 关连接，忽略异常
|
||||
closeQuietly h = do
|
||||
_ <- try (hClose h) :: IO (Either IOException ())
|
||||
pure ()
|
||||
-- | 建连接并配成行缓冲句柄
|
||||
open = withSocketsDo $ do
|
||||
infos <- getAddrInfo (Just defaultHints{addrSocketType = Stream}) (Just "127.0.0.1") (Just (show (shPort handle)))
|
||||
info <- case infos of
|
||||
(i : _) -> pure i
|
||||
[] -> ioError (userError "cannot resolve the test server address")
|
||||
sock <- socket (addrFamily info) Stream defaultProtocol
|
||||
connect sock (addrAddress info)
|
||||
h <- socketToHandle sock ReadWriteMode
|
||||
hSetBuffering h LineBuffering
|
||||
hSetNewlineMode h noNewlineTranslation
|
||||
pure h
|
||||
|
||||
-- | 发一行收一行；服务器不回话就判失败，别把用例挂死
|
||||
tcpTalk :: Handle -> BS.ByteString -> IO A.Value
|
||||
tcpTalk h raw = do
|
||||
BSC.hPutStr h raw
|
||||
BSC.hPutStr h "\n"
|
||||
hFlush h
|
||||
line <- timeout (5 * 1000000) (BSC.hGetLine h)
|
||||
case line of
|
||||
Just got -> pure (fromMaybe A.Null (decode (BL.fromStrict got)))
|
||||
Nothing -> do
|
||||
expectationFailure "the TCP server did not answer in time"
|
||||
pure A.Null
|
||||
|
||||
-- | 登录一行
|
||||
tcpLogin :: Handle -> Text -> Text -> IO A.Value
|
||||
tcpLogin h user password =
|
||||
tcpTalk h (BSC.pack ("{\"method\":\"login\",\"user\":\"" ++ T.unpack user ++ "\",\"password\":\"" ++ T.unpack password ++ "\"}"))
|
||||
|
||||
-- | 查询一行
|
||||
tcpQuery :: Handle -> Text -> IO A.Value
|
||||
tcpQuery h sql = tcpTalk h (BSC.pack ("{\"method\":\"query\",\"sql\":\"" ++ T.unpack sql ++ "\"}"))
|
||||
|
||||
-- | 断言对端已经收工（读到 EOF）
|
||||
tcpClosed :: Handle -> IO ()
|
||||
tcpClosed h = do
|
||||
done <- timeout (5 * 1000000) (hIsEOF h)
|
||||
done `shouldBe` Just True
|
||||
|
||||
-- 用例
|
||||
|
||||
-- | 协议与配置的用例
|
||||
tcpSpec :: Spec
|
||||
tcpSpec = do
|
||||
describe "TCP protocol: decoding a request line" $ do
|
||||
it "hello without a protocol number takes the current version" $
|
||||
decodeRequest "{\"method\":\"hello\"}" `shouldBe` Right (ReqHello 1)
|
||||
it "hello keeps the protocol number the client asked for" $
|
||||
decodeRequest "{\"method\":\"hello\",\"protocol\":2}" `shouldBe` Right (ReqHello 2)
|
||||
it "method names are case-insensitive" $
|
||||
decodeRequest "{\"method\":\"PING\"}" `shouldBe` Right ReqPing
|
||||
it "unknown extra fields are ignored" $
|
||||
decodeRequest "{\"method\":\"quit\",\"line\":7}" `shouldBe` Right ReqQuit
|
||||
it "login without a password is refused" $
|
||||
decodeRequest "{\"method\":\"login\",\"user\":\"admin\"}" `shouldBe` Left "login needs both user and password"
|
||||
it "query without sql is refused" $
|
||||
decodeRequest "{\"method\":\"query\"}" `shouldBe` Left "query needs sql"
|
||||
it "an unknown method is named in the error" $
|
||||
decodeRequest "{\"method\":\"frobnicate\"}" `shouldBe` Left "unknown method: frobnicate"
|
||||
it "a line that is not JSON is a bad request, not a crash" $
|
||||
decodeRequest "not json" `shouldBe` Left "request is not valid JSON"
|
||||
|
||||
describe "TCP protocol: encoding a response" $ do
|
||||
it "hello carries the protocol version and the server name" $ do
|
||||
let value = fromMaybe A.Null (decode (encodeResponse (RespHello 1)))
|
||||
asText (at "status" value) `shouldBe` "hello"
|
||||
asText (at "server" value) `shouldBe` "chusql-server"
|
||||
asInt (at "protocol" value) `shouldBe` 1
|
||||
it "login reports the account and whether it is the administrator" $ do
|
||||
let value = fromMaybe A.Null (decode (encodeResponse (RespLogin "admin" True)))
|
||||
asText (at "user" value) `shouldBe` "admin"
|
||||
asBool (at "admin" value) `shouldBe` True
|
||||
it "an error carries a code and a message" $ do
|
||||
let value = fromMaybe A.Null (decode (encodeResponse (RespError "no_database" "no database selected")))
|
||||
asText (at "status" value) `shouldBe` "error"
|
||||
asText (at "code" value) `shouldBe` "no_database"
|
||||
asText (at "message" value) `shouldBe` "no database selected"
|
||||
it "a result set is the command line JSON with a status field added" $ do
|
||||
let sample = QueryResult ["id"] [[VInt 1]] 1 False (Just "test")
|
||||
value = fromMaybe A.Null (decode (encodeResponse (RespResult sample)))
|
||||
asText (at "status" value) `shouldBe` "result"
|
||||
map asText (items (at "columns" value)) `shouldBe` ["id"]
|
||||
asInt (at "rowCount" value) `shouldBe` 1
|
||||
asBool (at "truncated" value) `shouldBe` False
|
||||
asText (at "database" value) `shouldBe` "test"
|
||||
|
||||
describe "server config ([server] in chusql.toml)" $ do
|
||||
it "falls back to the defaults when the file has no server section" $ do
|
||||
path <- tcpConfigPath "server-default"
|
||||
removeIfExists path
|
||||
loadServerConfigAt path `shouldReturn` defaultServerConfig
|
||||
it "reads host, port, max_message and max_rows" $ do
|
||||
path <- tcpConfigPath "server-keys"
|
||||
BS.writeFile path "[server]\nhost = \"0.0.0.0\"\nport = 7777\nmax_message = 4096\nmax_rows = 7\n"
|
||||
config <- loadServerConfigAt path
|
||||
scHost config `shouldBe` "0.0.0.0"
|
||||
scPort config `shouldBe` 7777
|
||||
scMaxMessage config `shouldBe` 4096
|
||||
scMaxRows config `shouldBe` 7
|
||||
it "keeps the HTTP, storage and page keys out of the server config" $ do
|
||||
path <- tcpConfigPath "server-other-keys"
|
||||
BS.writeFile path "[web]\nport = 8888\n\n[storage]\ndata_dir = \"/tmp/chusql\"\n\n[page]\nsize = 8192\n"
|
||||
config <- loadServerConfigAt path
|
||||
scPort config `shouldBe` scPort defaultServerConfig
|
||||
scMaxRows config `shouldBe` scMaxRows defaultServerConfig
|
||||
|
||||
-- | 真连 TCP 服务器的用例
|
||||
tcpServerSpec :: Spec
|
||||
tcpServerSpec = do
|
||||
describe "TCP server: handshake and login" $ do
|
||||
it "binds a real port when asked for port 0" $
|
||||
withTcpServer defaultServerConfig $ \_ handle ->
|
||||
shPort handle `shouldSatisfy` (> 0)
|
||||
it "answers hello with the same protocol version" $
|
||||
withTcpServer defaultServerConfig $ \_ handle ->
|
||||
withConnection handle $ \h -> do
|
||||
reply <- tcpTalk h "{\"method\":\"hello\",\"protocol\":1}"
|
||||
asText (at "status" reply) `shouldBe` "hello"
|
||||
asInt (at "protocol" reply) `shouldBe` 1
|
||||
it "still answers a client that connects long after startup" $
|
||||
-- 回归点：早先 accept 外面套 timeout 轮询，超时异常会在 accept
|
||||
-- 返回后把刚拿到的连接丢掉，只有延迟连接的客户端能撞上
|
||||
withTcpServer defaultServerConfig $ \_ handle -> do
|
||||
threadDelay 400000
|
||||
withConnection handle $ \h -> do
|
||||
reply <- tcpTalk h "{\"method\":\"hello\",\"protocol\":1}"
|
||||
asText (at "status" reply) `shouldBe` "hello"
|
||||
asText (at "server" reply) `shouldBe` "chusql-server"
|
||||
it "refuses a protocol version it does not speak" $
|
||||
withTcpServer defaultServerConfig $ \_ handle ->
|
||||
withConnection handle $ \h -> do
|
||||
reply <- tcpTalk h "{\"method\":\"hello\",\"protocol\":9}"
|
||||
asText (at "code" reply) `shouldBe` "bad_request"
|
||||
asText (at "message" reply) `shouldBe` "unsupported protocol version: 9"
|
||||
it "refuses a query before login" $
|
||||
withTcpServer defaultServerConfig $ \_ handle ->
|
||||
withConnection handle $ \h -> do
|
||||
reply <- tcpQuery h "select * from users"
|
||||
asText (at "status" reply) `shouldBe` "error"
|
||||
asText (at "code" reply) `shouldBe` "unauthorized"
|
||||
asText (at "message" reply) `shouldBe` "sign in first"
|
||||
it "refuses a wrong password and then accepts the right one" $
|
||||
withTcpServer defaultServerConfig $ \_ handle ->
|
||||
withConnection handle $ \h -> do
|
||||
bad <- tcpLogin h "admin" "wrong"
|
||||
asText (at "status" bad) `shouldBe` "error"
|
||||
asText (at "code" bad) `shouldBe` "unauthorized"
|
||||
good <- tcpLogin h "admin" "s3cret"
|
||||
asText (at "status" good) `shouldBe` "ok"
|
||||
asText (at "user" good) `shouldBe` "admin"
|
||||
asBool (at "admin" good) `shouldBe` True
|
||||
|
||||
describe "TCP server: SQL over the wire" $ do
|
||||
it "USE picks a database and the result reports it" $
|
||||
withTcpServer defaultServerConfig $ \_ handle ->
|
||||
withConnection handle $ \h -> do
|
||||
_ <- tcpLogin h "admin" "s3cret"
|
||||
reply <- tcpQuery h "use test"
|
||||
asText (at "status" reply) `shouldBe` "result"
|
||||
asText (at "database" reply) `shouldBe` "test"
|
||||
it "SELECT returns the fixture rows" $
|
||||
withTcpServer defaultServerConfig $ \_ handle ->
|
||||
withConnection handle $ \h -> do
|
||||
_ <- tcpLogin h "admin" "s3cret"
|
||||
_ <- tcpQuery h "use test"
|
||||
reply <- tcpQuery h "select * from users"
|
||||
asText (at "status" reply) `shouldBe` "result"
|
||||
map asText (items (at "columns" reply)) `shouldBe` ["id", "name", "age"]
|
||||
asInt (at "rowCount" reply) `shouldBe` 5
|
||||
let first = case map items (items (at "rows" reply)) of
|
||||
(r : _) -> r
|
||||
[] -> []
|
||||
length first `shouldBe` 3
|
||||
asInt (fromMaybe A.Null (nth 0 first)) `shouldBe` 1
|
||||
asText (fromMaybe A.Null (nth 1 first)) `shouldBe` "user1"
|
||||
it "an unknown table maps to not_found" $
|
||||
withTcpServer defaultServerConfig $ \_ handle ->
|
||||
withConnection handle $ \h -> do
|
||||
_ <- tcpLogin h "admin" "s3cret"
|
||||
_ <- tcpQuery h "use test"
|
||||
reply <- tcpQuery h "select * from nope"
|
||||
asText (at "code" reply) `shouldBe` "not_found"
|
||||
it "a query without a selected database maps to no_database" $
|
||||
withTcpServer defaultServerConfig $ \_ handle ->
|
||||
withConnection handle $ \h -> do
|
||||
_ <- tcpLogin h "admin" "s3cret"
|
||||
reply <- tcpQuery h "select * from users"
|
||||
asText (at "code" reply) `shouldBe` "no_database"
|
||||
it "an empty sql is a bad request" $
|
||||
withTcpServer defaultServerConfig $ \_ handle ->
|
||||
withConnection handle $ \h -> do
|
||||
_ <- tcpLogin h "admin" "s3cret"
|
||||
reply <- tcpTalk h "{\"method\":\"query\",\"sql\":\" \"}"
|
||||
asText (at "code" reply) `shouldBe` "bad_request"
|
||||
asText (at "message" reply) `shouldBe` "sql must not be empty"
|
||||
it "the row limit truncates the rows but keeps the total count" $
|
||||
withTcpServer defaultServerConfig{scMaxRows = 2} $ \_ handle ->
|
||||
withConnection handle $ \h -> do
|
||||
_ <- tcpLogin h "admin" "s3cret"
|
||||
_ <- tcpQuery h "use test"
|
||||
reply <- tcpQuery h "select * from users"
|
||||
length (items (at "rows" reply)) `shouldBe` 2
|
||||
asInt (at "rowCount" reply) `shouldBe` 5
|
||||
asBool (at "truncated" reply) `shouldBe` True
|
||||
|
||||
describe "TCP server: framing and lifecycle" $ do
|
||||
it "a bad JSON line does not kill the connection" $
|
||||
withTcpServer defaultServerConfig $ \_ handle ->
|
||||
withConnection handle $ \h -> do
|
||||
bad <- tcpTalk h "not json"
|
||||
asText (at "code" bad) `shouldBe` "bad_request"
|
||||
pong <- tcpTalk h "{\"method\":\"ping\"}"
|
||||
asText (at "status" pong) `shouldBe` "pong"
|
||||
it "a line over the message limit is refused as too_large" $
|
||||
withTcpServer defaultServerConfig{scMaxMessage = 32} $ \_ handle ->
|
||||
withConnection handle $ \h -> do
|
||||
reply <- tcpTalk h (BSC.pack ("{\"method\":\"query\",\"sql\":\"" ++ replicate 40 'a' ++ "\"}"))
|
||||
asText (at "code" reply) `shouldBe` "too_large"
|
||||
it "ping answers pong and quit closes the connection" $
|
||||
withTcpServer defaultServerConfig $ \_ handle ->
|
||||
withConnection handle $ \h -> do
|
||||
pong <- tcpTalk h "{\"method\":\"ping\"}"
|
||||
asText (at "status" pong) `shouldBe` "pong"
|
||||
bye <- tcpTalk h "{\"method\":\"quit\"}"
|
||||
asText (at "status" bye) `shouldBe` "bye"
|
||||
tcpClosed h
|
||||
it "one connection is one session" $
|
||||
withTcpServer defaultServerConfig $ \_ handle ->
|
||||
withConnection handle $ \h -> do
|
||||
reply <- tcpLogin h "admin" "s3cret"
|
||||
asText (at "status" reply) `shouldBe` "ok"
|
||||
withConnection handle $ \other -> do
|
||||
blocked <- tcpQuery other "select * from users"
|
||||
asText (at "code" blocked) `shouldBe` "unauthorized"
|
||||
Reference in new issue
Block a user