343 lines
16 KiB
Haskell
343 lines
16 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Main (main) where
|
|
|
|
import ChuSQL.Web.API (AppEnv (..), Live (..), newAppEnvAt, setLive, webApp)
|
|
import ChuSQL.Interface.Auth (SessionPolicy (..), setPayloadPolicy)
|
|
import ChuSQL.Interface.Config (
|
|
ServerConfig (..),
|
|
WebConfig (..),
|
|
defaultUser,
|
|
loadServerConfigAt,
|
|
loadWebConfigAt,
|
|
legacyPasswordKey,
|
|
resolveStaticDir,
|
|
rootUserName,
|
|
staticDirCandidates,
|
|
)
|
|
import ChuSQL.Interface.Link (clientPing, closeClient, connectClient)
|
|
import ChuSQL.Interface.RateLimit (newRateLimiter)
|
|
import ChuSQL.Interface.Session (authenticateSession, newSession)
|
|
import ChuSQL.Interface.Settings (effectiveSettings, readSettingsFile)
|
|
import ChuSQL.Interface.TOML (resolveConfigPath)
|
|
import ChuSQL.Web.Demo (SeedReport (..), seedDemo)
|
|
import Control.Exception (IOException, try)
|
|
import Data.Char (toLower)
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.String (fromString)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.IO as TIO
|
|
import Data.Time.Clock (getCurrentTime)
|
|
import Network.Wai (Application)
|
|
import qualified Network.Wai.Handler.Warp as Warp
|
|
import System.Environment (getArgs)
|
|
import System.Exit (exitFailure)
|
|
import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout)
|
|
import Text.Read (readMaybe)
|
|
|
|
-- Web 管理端入口：读配置，把请求转给拥有存储的 server，最后起 Warp。
|
|
|
|
data Options = Options
|
|
{ optConfig :: Maybe FilePath
|
|
, optHost :: Maybe String
|
|
, optPort :: Maybe Int
|
|
, optStatic :: Maybe FilePath
|
|
, optUser :: Maybe Text
|
|
, optCookieSecure :: Maybe Bool
|
|
, optBodyLimit :: Maybe Int
|
|
, optSessionIdle :: Maybe Int
|
|
, optSessionMax :: Maybe Int
|
|
, optLoginMaxAttempts :: Maybe Int
|
|
, optLoginWindow :: Maybe Int
|
|
, optPageSize :: Maybe Int
|
|
, optMaxPageSize :: Maybe Int
|
|
, optMaxRows :: Maybe Int
|
|
, optMaxSqlLength :: Maybe Int
|
|
, optSeedDemo :: Maybe Bool
|
|
, optHelp :: Bool
|
|
}
|
|
|
|
-- | 一个开关都没给
|
|
emptyOptions :: Options
|
|
emptyOptions =
|
|
Options
|
|
{ optConfig = Nothing
|
|
, optHost = Nothing
|
|
, optPort = Nothing
|
|
, optStatic = Nothing
|
|
, optUser = Nothing
|
|
, optCookieSecure = Nothing
|
|
, optBodyLimit = Nothing
|
|
, optSessionIdle = Nothing
|
|
, optSessionMax = Nothing
|
|
, optLoginMaxAttempts = Nothing
|
|
, optLoginWindow = Nothing
|
|
, optPageSize = Nothing
|
|
, optMaxPageSize = Nothing
|
|
, optMaxRows = Nothing
|
|
, optMaxSqlLength = Nothing
|
|
, optSeedDemo = Nothing
|
|
, optHelp = False
|
|
}
|
|
|
|
-- | 解析参数
|
|
parseArgs :: [String] -> Either String Options
|
|
parseArgs = go emptyOptions
|
|
where
|
|
-- | 逐个参数累加进 Options
|
|
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 ("--static" : v : rest) = go opts{optStatic = 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 ("--body-limit" : v : rest) = withInt "--body-limit" v (\n -> go opts{optBodyLimit = Just n} rest)
|
|
go opts ("--session-idle" : v : rest) = withInt "--session-idle" v (\n -> go opts{optSessionIdle = Just n} rest)
|
|
go opts ("--session-max" : v : rest) = withInt "--session-max" v (\n -> go opts{optSessionMax = Just n} rest)
|
|
go opts ("--login-max-attempts" : v : rest) = withInt "--login-max-attempts" v (\n -> go opts{optLoginMaxAttempts = Just n} rest)
|
|
go opts ("--login-window" : v : rest) = withInt "--login-window" v (\n -> go opts{optLoginWindow = Just n} rest)
|
|
go opts ("--page-size" : v : rest) = withInt "--page-size" v (\n -> go opts{optPageSize = Just n} rest)
|
|
go opts ("--max-page-size" : v : rest) = withInt "--max-page-size" v (\n -> go opts{optMaxPageSize = Just n} rest)
|
|
go opts ("--max-rows" : v : rest) = withInt "--max-rows" v (\n -> go opts{optMaxRows = Just n} rest)
|
|
go opts ("--max-sql-length" : v : rest) = withInt "--max-sql-length" v (\n -> go opts{optMaxSqlLength = Just n} rest)
|
|
go opts ("--seed" : v : rest) = go opts{optSeedDemo = Just (isTrue v)} rest
|
|
go opts ("--cookie-secure" : v : rest) = go opts{optCookieSecure = Just (isTrue v)} 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)
|
|
|
|
-- | 把 1/true/yes/on 认成真
|
|
isTrue :: String -> Bool
|
|
isTrue s = map toLower s `elem` ["1", "true", "yes", "on"]
|
|
|
|
-- | 打印命令行用法
|
|
usage :: IO ()
|
|
usage = do
|
|
putStrLn "usage: chusql-web [options]"
|
|
putStrLn ""
|
|
putStrLn "config: chusql.toml sits at a fixed place and its sections hold every knob below;"
|
|
putStrLn " Windows: %APPDATA%\\ChuSQL\\chusql.toml"
|
|
putStrLn " other: $XDG_CONFIG_HOME/ChuSQL/chusql.toml (or ~/.config/ChuSQL/chusql.toml)"
|
|
putStrLn " [web] host/port/static_dir/user (administrator name) and the limits;"
|
|
putStrLn " [storage] data_dir; [page] size; [btree] order; [buffer] pool_size; [log] level"
|
|
putStrLn ""
|
|
putStrLn " --config FILE read that config file instead ([web] host ...)"
|
|
putStrLn " --host H listen address ([web] host, default 127.0.0.1)"
|
|
putStrLn " --port N listen port ([web] port, default 7778)"
|
|
putStrLn " --static DIR static asset directory ([web] static_dir, default static)"
|
|
putStrLn " --user NAME administrator name ([web] user, default root)"
|
|
putStrLn " --cookie-secure BOOL add Secure to the cookie ([web] cookie_secure, default false)"
|
|
putStrLn " --body-limit N max request body bytes ([web] body_limit, default 65536)"
|
|
putStrLn " --session-idle N session idle timeout, sec ([web] session_idle, default 28800)"
|
|
putStrLn " --session-max N session max age, sec ([web] session_max, default 86400)"
|
|
putStrLn " --login-max-attempts N failed logins before 429 ([web] login_max_attempts, default 5)"
|
|
putStrLn " --login-window N lockout window, sec ([web] login_window, default 300)"
|
|
putStrLn " --page-size N rows per page by default ([web] rows_per_page, default 25)"
|
|
putStrLn " --max-page-size N rows per page ceiling ([web] max_page_size, default 500)"
|
|
putStrLn " --max-rows N rows returned per query ([web] max_rows, default 1000)"
|
|
putStrLn " --max-sql-length N max SQL characters ([web] max_sql_length, default 20000)"
|
|
putStrLn " --seed BOOL load demo data when the db is empty ([web] seed, default false)"
|
|
putStrLn ""
|
|
putStrLn "administrator password: lives in the __system_users system table, never in chusql.toml"
|
|
putStrLn " the installer always sets one; an account whose hash is still empty signs in with an empty password"
|
|
putStrLn (" the [web] user key only picks the administrator name (default " ++ T.unpack defaultUser ++ ")")
|
|
putStrLn "ordinary accounts: CREATE USER / ALTER USER / DROP USER from the SQL console (administrator only)"
|
|
putStrLn "storage: the server owns the data directory and loads the chusql_core_storage library;"
|
|
putStrLn " this process is a plain TCP client: every statement, lookup and account request goes to it"
|
|
putStrLn " [server] host / port says where it listens; [storage] data_dir, [page] size, [btree] order,"
|
|
putStrLn " [buffer] pool_size and [log] level are the server's own"
|
|
|
|
-- | 命令行覆盖配置
|
|
applyOptions :: WebConfig -> Options -> WebConfig
|
|
applyOptions cfg opts =
|
|
cfg
|
|
{ wcHost = orElse (optHost opts) (wcHost cfg)
|
|
, wcPort = orElse (optPort opts) (wcPort cfg)
|
|
, wcStaticDir = orElse (optStatic opts) (wcStaticDir cfg)
|
|
, wcUser = orElse (optUser opts) (wcUser cfg)
|
|
, wcCookieSecure = orElse (optCookieSecure opts) (wcCookieSecure cfg)
|
|
, wcBodyLimit = orElse (optBodyLimit opts) (wcBodyLimit cfg)
|
|
, wcSessionIdle = orElse (optSessionIdle opts) (wcSessionIdle cfg)
|
|
, wcSessionMax = orElse (optSessionMax opts) (wcSessionMax cfg)
|
|
, wcLoginMaxAttempts = orElse (optLoginMaxAttempts opts) (wcLoginMaxAttempts cfg)
|
|
, wcLoginWindow = orElse (optLoginWindow opts) (wcLoginWindow cfg)
|
|
, wcPageSize = orElse (optPageSize opts) (wcPageSize cfg)
|
|
, wcMaxPageSize = orElse (optMaxPageSize opts) (wcMaxPageSize cfg)
|
|
, wcMaxRows = orElse (optMaxRows opts) (wcMaxRows cfg)
|
|
, wcMaxSqlLength = orElse (optMaxSqlLength opts) (wcMaxSqlLength cfg)
|
|
, wcSeedDemo = orElse (optSeedDemo opts) (wcSeedDemo cfg)
|
|
}
|
|
where
|
|
-- | 有就用新的，没有留旧值
|
|
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
|
|
|
|
-- | 读配置装配环境，检查 server，起 Warp
|
|
run :: Options -> IO ()
|
|
run opts = do
|
|
configPath <- resolveConfigPath (optConfig opts)
|
|
base <- loadWebConfigAt configPath
|
|
let cfg = applyOptions base opts
|
|
foundStatic <- resolveStaticDir (wcStaticDir cfg)
|
|
case foundStatic of
|
|
Nothing -> do
|
|
putStrLn ("static directory not found; looked in: " ++ unwords (staticDirCandidates (wcStaticDir cfg)))
|
|
exitFailure
|
|
Just staticDir -> do
|
|
let settingsFile = configPath
|
|
policy = SessionPolicy (fromIntegral (wcSessionIdle cfg)) (fromIntegral (wcSessionMax cfg))
|
|
saved <- readSettingsFile settingsFile
|
|
legacy <- legacyPasswordKey settingsFile
|
|
config <- loadServerConfigAt settingsFile
|
|
limiter <-
|
|
newRateLimiter
|
|
getCurrentTime
|
|
(wcLoginMaxAttempts cfg)
|
|
(fromIntegral (wcLoginWindow cfg))
|
|
env0 <- newAppEnvAt settingsFile (T.pack (scHost config)) (scPort config) limiter staticDir
|
|
let env =
|
|
env0
|
|
{ aeCookieSecure = wcCookieSecure cfg
|
|
, aeEffective = effectiveSettings cfg
|
|
, aeLog = TIO.putStrLn
|
|
}
|
|
setPayloadPolicy (aeSessions env) policy
|
|
setLive env (liveFromConfig cfg)
|
|
app <- webApp env
|
|
printBanner cfg configPath staticDir
|
|
reportCredential cfg saved legacy
|
|
checkServer (aeServerHost env) (aeServerPort env)
|
|
seedIfWanted cfg saved (aeServerHost env) (aeServerPort env)
|
|
let settings =
|
|
Warp.setPort (wcPort cfg) (Warp.setHost (fromString (wcHost cfg)) Warp.defaultSettings)
|
|
serve settings app
|
|
|
|
-- | 本次启动的配置摊成热改参数
|
|
liveFromConfig :: WebConfig -> Live
|
|
liveFromConfig cfg =
|
|
Live
|
|
{ lvBodyLimit = wcBodyLimit cfg
|
|
, lvSessionIdle = wcSessionIdle cfg
|
|
, lvSessionMax = wcSessionMax cfg
|
|
, lvLoginMaxAttempts = wcLoginMaxAttempts cfg
|
|
, lvLoginWindow = wcLoginWindow cfg
|
|
, lvPageSize = wcPageSize cfg
|
|
, lvMaxPageSize = wcMaxPageSize cfg
|
|
, lvMaxRows = wcMaxRows cfg
|
|
, lvMaxSqlLength = wcMaxSqlLength cfg
|
|
}
|
|
|
|
-- | 起 HTTP 服务，绑不上端口给人话
|
|
serve :: Warp.Settings -> Application -> IO ()
|
|
serve settings app = do
|
|
result <- try (Warp.runSettings settings app) :: IO (Either IOException ())
|
|
case result of
|
|
Right () -> pure ()
|
|
Left e -> do
|
|
putStrLn ("failed to serve HTTP: " ++ show e)
|
|
putStrLn " the port is probably taken or reserved by the system; try another one: --port 7778"
|
|
putStrLn " on Windows: netsh interface ipv4 show excludedportrange protocol=tcp"
|
|
exitFailure
|
|
|
|
-- | 报告管理员账号状态：配置里还留着明文口令键就提醒
|
|
reportCredential :: WebConfig -> Map.Map Text Text -> Bool -> IO ()
|
|
reportCredential cfg saved legacy = do
|
|
putStrLn ("administrator: " ++ T.unpack (rootUserName cfg saved))
|
|
if legacy
|
|
then do
|
|
putStrLn " !! the [web] section still carries a plaintext password key; it is ignored now"
|
|
putStrLn " !! remove it: the administrator password lives in the __system_users system table"
|
|
else pure ()
|
|
|
|
-- | 配了 seed 就补演示数据（管理员已设口令时跳过）
|
|
seedIfWanted :: WebConfig -> Map.Map Text Text -> Text -> Int -> IO ()
|
|
seedIfWanted cfg saved host port
|
|
| not (wcSeedDemo cfg) = pure ()
|
|
| otherwise = do
|
|
opened <- connectClient host port
|
|
case opened of
|
|
Left message -> TIO.putStrLn ("demo data skipped: " <> message)
|
|
Right client -> do
|
|
session <- newSession client
|
|
signed <- authenticateSession session (rootUserName cfg saved) ""
|
|
case signed of
|
|
Left message -> TIO.putStrLn ("demo data skipped: " <> message <> " (set the administrator password after seeding)")
|
|
Right () -> do
|
|
result <- seedDemo session
|
|
case result of
|
|
Left message -> TIO.putStrLn ("demo data skipped: " <> message)
|
|
Right report ->
|
|
TIO.putStrLn
|
|
( "demo data: "
|
|
<> (if null (srCreated report) then "already present" else "created " <> T.pack (unwords (srCreated report)))
|
|
<> (if null (srSkipped report) then "" else ", kept " <> T.pack (unwords (srSkipped report)))
|
|
<> (if null (srIndexes report) then "" else ", index on " <> T.pack (unwords (srIndexes report)))
|
|
)
|
|
closeClient client
|
|
|
|
-- | ping 一次 server，报告它通不通
|
|
checkServer :: Text -> Int -> IO ()
|
|
checkServer host port = do
|
|
opened <- connectClient host port
|
|
case opened of
|
|
Left message -> putStrLn ("storage: DOWN (" ++ T.unpack message ++ ")")
|
|
Right client -> do
|
|
probe <- clientPing client
|
|
closeClient client
|
|
case probe of
|
|
Right () -> putStrLn "storage: up (the server answered ping)"
|
|
Left message -> putStrLn ("storage: DOWN (" ++ T.unpack message ++ ")")
|
|
|
|
-- | 启动横幅
|
|
printBanner :: WebConfig -> FilePath -> FilePath -> IO ()
|
|
printBanner cfg configPath staticDir = do
|
|
putStrLn "==================== ChuSQL Web ===================="
|
|
putStrLn ("url: http://" ++ wcHost cfg ++ ":" ++ show (wcPort cfg) ++ "/")
|
|
putStrLn ("config file: " ++ configPath)
|
|
putStrLn ("static dir: " ++ staticDir)
|
|
putStrLn
|
|
( "limits: body "
|
|
++ show (wcBodyLimit cfg)
|
|
++ "B, page "
|
|
++ show (wcPageSize cfg)
|
|
++ "/"
|
|
++ show (wcMaxPageSize cfg)
|
|
++ " rows, query rows "
|
|
++ show (wcMaxRows cfg)
|
|
++ ", sql "
|
|
++ show (wcMaxSqlLength cfg)
|
|
++ " chars"
|
|
)
|
|
putStrLn
|
|
( "auth: session idle "
|
|
++ show (wcSessionIdle cfg)
|
|
++ "s / max "
|
|
++ show (wcSessionMax cfg)
|
|
++ "s, lockout after "
|
|
++ show (wcLoginMaxAttempts cfg)
|
|
++ " failures in "
|
|
++ show (wcLoginWindow cfg)
|
|
++ "s"
|
|
)
|
|
putStrLn "storage: through the server that owns the data directory"
|