darkplaces-rcon-util-0.1: src/DRcon/CommandArgs.hs

module DRcon.CommandArgs (
    ProtocolOptions(..),
    BaseArgs(..),
    CommandArgs(..),
    parseRconMode,
    checkTimeout,
    parseEncoding,
    showEncoding,
    parseColorMode,
    argsParser,
    maybeArgsParser
) where
import Options.Applicative
import DarkPlaces.Text (DecodeType(..))
import DarkPlaces.Rcon hiding (connect, send)
import DRcon.Polyfills (readMaybe)
import Data.Tuple (swap)
import Data.Maybe (fromMaybe)


data BaseArgs = BaseArgs {
    confServerString :: String,
    confPassword     :: Maybe String,
    confMode         :: Maybe RconMode,
    confTimeDiff     :: Maybe Int,
    confTimeout      :: Maybe Float,
    confEncoding     :: Maybe DecodeType,
    confProtoOptions :: Maybe ProtocolOptions
} deriving(Show, Read, Eq)


data CommandArgs = CommandArgs {
    cliServerName   :: String,
    cliBaseArgs     :: BaseArgs,
    cliColor        :: Maybe Bool,
    cliCommand      :: Maybe String
} deriving(Show, Read, Eq)


eitherArgs :: Either String a -> ReadM a
eitherArgs (Right v) = return v
eitherArgs (Left msg) = readerError msg


parseRconMode :: String -> Either String RconMode
parseRconMode ms = case readMaybe ms of
    Just x | x >= 0 && x < 3 -> Right $ toEnum x
    _ -> Left "value should be 0, 1 or 2"


checkTimeout :: Float -> Either String Float
checkTimeout t
    | t > 0 = Right t
    | otherwise = Left "value should be bigger then 0"


encodings :: [(String, DecodeType)]
encodings = [
    ("utf8", Utf8Lenient),
    ("utf8-lenient", Utf8Lenient),
    ("utf8-ignore", Utf8Ignore),
    ("utf8-strict", Utf8Strict),
    ("nexuiz", NexuizDecode)]


parseEncoding :: String -> Either String DecodeType
parseEncoding encname = case lookup encname encodings of
    Just v -> Right v
    Nothing -> Left "Error bad decode type. Major values are ut8 and nexuiz"


showEncoding :: DecodeType -> String
showEncoding enc = fromMaybe first $ lookup enc encLst
  where
    encLst = map swap encodings
    first = fst $ head encodings


parseColorMode :: String -> ReadM (Maybe Bool)
parseColorMode mode_str
    | mode_str == "always" = return $ Just True
    | mode_str == "auto" = return Nothing
    | mode_str == "never" = return $ Just False
    | otherwise = readerError "value should be always, auto or never"


protoOptionsParser :: Parser (Maybe ProtocolOptions)
protoOptionsParser =
    flag' (Just OnlyIPv4) (short '4' <> help "Forces to use IPv4 addresses only")
    <|> flag' (Just OnlyIPv6) (short '6' <> help "Forces to use IPv6 addresses only")
    <|> (pure Nothing)


commandParser :: Parser String
commandParser = unwords <$> (some $ argument str (
    metavar "COMMAND"
    <> help "Command that will be sent to server"))


argsParser :: Parser CommandArgs
argsParser = argsConstructor
    <$> protoOptionsParser
    <*> optional (strOption (
        short 'p'
        <> long "password"
        <> help "Server's password"
        <> metavar "PASSWORD"))
    <*> optional (option (str >>= eitherArgs . parseRconMode) (
        short 'm'
        <> long "mode"
        <> help "Use secure rcon, same as `rcon_secure' cvar, 1 is default"
        <> metavar "MODE"))
    <*> optional (option auto (
        short 'd'
        <> long "time-diff"
        <> help "Integer difference between client and server time, can be negative"
        <> metavar "TIMEDIFF"))
    <*> optional (option (auto >>= eitherArgs . checkTimeout) (
        short 't'
        <> long "timeout"
        <> help "How many time wait for response after send or previous response"
        <> metavar "TIMEOUT"))
    <*> optional (option (str >>= eitherArgs . parseEncoding) (
        short 'e'
        <> long "encoding"
        <> help "Server encoding. Major options is `utf8' and `nexuiz'"
        <> metavar "ENCODING"))
    <*> option (str >>= parseColorMode) (
        long "color"
        <> value Nothing
        <> help "Possible values are: `auto', `always' and `never'"
        <> metavar "COLOR_MODE")
    <*> argument str (
        help "Server to connect or config section"
        <> metavar "SERVER")
    <*> optional commandParser
  where
    argsConstructor protoOpt password mode tdiff tout enc color server cmd =
        let baseArgs = BaseArgs {confServerString=server,
                                 confPassword=password,
                                 confMode=mode,
                                 confTimeDiff=tdiff,
                                 confTimeout=tout,
                                 confEncoding=enc,
                                 confProtoOptions=protoOpt}
        in CommandArgs {cliServerName=server,
                        cliBaseArgs=baseArgs,
                        cliColor=color,
                        cliCommand=cmd}


maybeArgsParser :: Parser (Maybe CommandArgs)
maybeArgsParser = flag' Nothing (
    long "version"
    <> short 'V'
    <> hidden) <|> (Just <$> argsParser)