223 lines
9.2 KiB
Haskell
223 lines
9.2 KiB
Haskell
|
{-# 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)")
|