module Main where
import DRcon.CommandArgs
import DRcon.ConfigFile
import DRcon.Paths
import DRcon.EvalParser
import DRcon.Prompt
import DRcon.Version (versionInfo)
import DarkPlaces.Rcon hiding (connect, send, getPassword)
import qualified DarkPlaces.Rcon as RCON
import DarkPlaces.Text
import Options.Applicative
import qualified Data.ByteString.Lazy as BL
import System.Timeout
import qualified Data.ByteString.UTF8 as BU
import Control.Monad.Error
import System.Console.Haskeline
import System.Console.Haskeline.History (historyLines)
import Control.Monad.State.Strict
import Data.Maybe
import qualified Data.Text as T
import Data.Text.Encoding as TE
import Text.Printf
import Data.Char (toUpper)
data ReplState = ReplState {
replLastCmd :: Maybe InputType,
replColor :: Bool,
replTimeout :: Float,
replEncoding :: DecodeType,
replPromp :: (String, Prompt),
replConnection :: RconConnection,
replName :: String
}
type Repl m = InputT (StateT ReplState m)
updateLastCmd :: (Monad m) => InputType -> Repl m ()
updateLastCmd cmd = lift $ modify (\s -> s {replLastCmd=Just cmd})
newPrompt :: String -> (String, Prompt)
newPrompt str = (str, parsePrompt str)
toMicroseconds :: Float -> Int
toMicroseconds v = round $ v * 1e6
printRecv :: RconConnection -> (Float, Bool, DecodeType) -> BinStreamState -> IO ()
printRecv con parm@(time, color, enc) st = do
mdata <- timeout (toMicroseconds time) $ RCON.recvRcon con
let st_args = PrintStreamArgs {
withColor=color,
streamState=st,
decodeFun=toUTF enc}
case mdata of
(Just r) -> printStreamDPText st_args (BL.fromStrict r) >>= printRecv con parm
Nothing -> streamEnd color st
rconExec :: DRconArgs -> String -> Bool -> IO ()
rconExec dargs command color = do
con <- RCON.connect (connectInfo dargs)
RCON.send con (BU.fromString command)
printRecv con (time, color, enc) defaultStreamState
RCON.close con
where
time = drconTimeout dargs
enc = drconEncoding dargs
getInputLineWithPrompt :: Repl IO (Maybe String)
getInputLineWithPrompt = do
state <- lift get
let prompt = snd $ replPromp state
con = replConnection state
name = replName state
prompt_vars <- liftIO $ getPromptVars name con
getInputLine $ renderPrompt prompt_vars prompt
replLoop :: Repl IO ()
replLoop = handle (\Interrupt -> replLoop) $ withInterrupt $ do
minput <- getInputLineWithPrompt
case minput of
Nothing -> lift (replConnection <$> get) >>= liftIO . RCON.close
Just input -> case parseCommand input of
Left e -> do
outputStrLn $ show e
replLoop
Right a -> replAction a
replAction :: InputType -> Repl IO ()
replAction cmd = case cmd of
Empty -> replLoop
Quit -> do
con <- lift $ replConnection <$> get
liftIO $ RCON.close con
RepeatLast -> do
last <- lift $ replLastCmd <$> get
case last of
Nothing -> outputStrLn noLastCmd >> replLoop
Just last_cmd -> replAction last_cmd
Help -> do
outputStrLn $ T.unpack helpMessage
updateLastCmd cmd
replLoop
ListVars -> do
outputStrLn $ T.unpack helpVars
updateLastCmd cmd
replLoop
Show var -> do
con <- lift $ replConnection <$> get
val <- showVar <$> case var of
Mode -> liftIO $ SetMode <$> getMode con
TimeDiff -> liftIO $ SetTimeDiff <$> getTimeDiff con
Timeout -> lift $ SetTimeout . replTimeout <$> get
Encoding -> lift $ SetEncoding . replEncoding <$> get
Color -> lift $ SetColor . replColor <$> get
PromptVar -> lift $ SetPrompt . fst . replPromp <$> get
outputStrLn $ printf "%s: %s" (toTitle $ show var) val
updateLastCmd cmd
replLoop
Set var_set -> do
con <- lift $ replConnection <$> get
case var_set of
SetMode mode -> liftIO $ setMode con mode
SetTimeDiff diff -> liftIO $ setTimeDiff con diff
SetTimeout t -> lift $ modify (\s -> s {replTimeout=t})
SetEncoding enc -> lift $ modify (\s -> s {replEncoding=enc})
SetColor c -> lift $ modify (\s -> s {replColor=c})
SetPrompt p -> lift $ modify (\s -> s {replPromp=newPrompt p})
updateLastCmd cmd
replLoop
Version -> do
outputStrLn versionInfo
updateLastCmd cmd
replLoop
Login -> do
pwd <- getPassword Nothing "Password: "
con <- lift $ replConnection <$> get
case pwd of
(Just pass) -> liftIO $ RCON.setPassword con (BU.fromString pass)
Nothing -> return ()
replLoop
History v -> do
-- 10 is default value for history
let num = fromMaybe 10 v
history <- getHistory
let h_lines = take num $ historyLines history
forM_ h_lines $ outputStrLn . (replicate 2 ' ' ++)
updateLastCmd cmd
replLoop
RconCommand command -> do
rconEval $ TE.encodeUtf8 command
updateLastCmd cmd
replLoop
where
toTitle s = (\(f, e) -> map toUpper f ++ e) $ splitAt 1 s
rconEval :: BU.ByteString -> Repl IO ()
rconEval command = do
repl_state <- lift get
let time = replTimeout repl_state
color = replColor repl_state
enc = replEncoding repl_state
con = replConnection repl_state
liftIO $ RCON.send con command
liftIO $ printRecv con (time, color, enc) defaultStreamState
noLastCmd = "there is no last command to perform\n" ++
"use :? for help."
rconRepl :: DRconArgs -> Bool -> IO ()
rconRepl dargs color = do
con <- RCON.connect (connectInfo dargs)
hist_path <- historyPath
let base_settings = defaultSettings {historyFile=Just hist_path,
autoAddHistory=True}
let repl_state = ReplState {replLastCmd=Nothing,
replColor=color,
replTimeout=drconTimeout dargs,
replEncoding=drconEncoding dargs,
replPromp=newPrompt $ drconPrompt dargs,
replConnection=con,
replName=connectName dargs}
let hline_settings = setComplete comp base_settings
evalStateT (runInputT hline_settings replLoop) repl_state
where
compliter prev cmd = return $
(simpleCompletion . T.unpack) <$> internalAutoComplete (T.pack prev) (T.pack cmd)
comp = completeWordWithPrev Nothing " \t" compliter
processArgs :: Maybe CommandArgs -> UtilError ()
processArgs Nothing = liftIO $ putStrLn versionInfo
processArgs (Just args) = do
drcon_args <- rconConfigure (cliServerName args) (cliBaseArgs args)
color <- liftIO $ case cliColor args of
(Just c) -> return c
Nothing -> supportColors
case cliCommand args of
(Just command) -> liftIO $ rconExec drcon_args command color
Nothing -> liftIO $ rconRepl drcon_args color
main :: IO ()
main = handleErrors . processArgs =<< execParser opts
where
opts = info (helper <*> maybeArgsParser)
(fullDesc <> progDesc "Darkplaces rcon client utility")
handleErrors me = do
r <- runErrorT me
case r of
(Right ()) -> return ()
(Left e) -> putStrLn e