Operator.hs

{-# Language OverloadedStrings #-}
{-|
Module      : Client.Commands.Operator
Description : Operator command implementations
Copyright   : (c) Eric Mertens, 2016-2020
License     : ISC
Maintainer  : emertens@gmail.com
-}

module Client.Commands.Operator (operatorCommands) where

import           Control.Applicative
import           Client.Commands.Arguments.Spec
import           Client.Commands.TabCompletion
import           Client.Commands.Types
import           Client.State.Network (sendMsg)
import           Data.Maybe (fromMaybe, maybeToList)
import qualified Data.Text as Text
import           Irc.Commands
import           Irc.RawIrcMsg

operatorCommands :: CommandSection
operatorCommands = CommandSection "Network operator commands"

  [ Command
      (pure "oper")
      (liftA2 (,) (simpleToken "user") (simpleToken "password"))
      "Authenticate as a server operator.\n"
    $ NetworkCommand cmdOper noNetworkTab

  , Command
      (pure "kill")
      (liftA2 (,) (simpleToken "client") (remainingArg "reason"))
      "Kill a client connection to the server.\n"
    $ NetworkCommand cmdKill simpleNetworkTab

  , Command
      (pure "kline")
      (liftA3 (,,) (simpleToken "minutes") (simpleToken "user@host") (remainingArg "reason"))
      "Ban a client from the server.\n"
    $ NetworkCommand cmdKline simpleNetworkTab

  , Command
      (pure "unkline")
      (liftA2 (,) (simpleToken "[user@]host") (optionalArg (simpleToken "[servername]")))
      "Unban a client from the server.\n"
    $ NetworkCommand cmdUnkline simpleNetworkTab

  , Command
      (pure "undline")
      (liftA2 (,) (simpleToken "host") (optionalArg (simpleToken "[servername]")))
      "Unban a client from the server.\n"
    $ NetworkCommand cmdUndline simpleNetworkTab

  , Command
      (pure "unxline")
      (liftA2 (,) (simpleToken "gecos") (optionalArg (simpleToken "[servername]")))
      "Unban a gecos from the server.\n"
    $ NetworkCommand cmdUnxline simpleNetworkTab

  , Command
      (pure "unresv")
      (liftA2 (,) (simpleToken "channel|nick") (optionalArg (simpleToken "[servername]")))
      "Unban a channel or nickname from the server.\n"
    $ NetworkCommand cmdUnresv simpleNetworkTab

  , Command
      (pure "testline")
      (simpleToken "[[nick!]user@]host")
      "Check matching I/K/D lines for a [[nick!]user@]host\n"
    $ NetworkCommand cmdTestline simpleNetworkTab

  , Command
      (pure "testkline")
      (simpleToken "[user@]host")
      "Check matching K/D lines for a [user@]host\n"
    $ NetworkCommand cmdTestkline simpleNetworkTab

  , Command
      (pure "testgecos")
      (simpleToken "gecos")
      "Check matching X lines for a gecos\n"
    $ NetworkCommand cmdTestGecos simpleNetworkTab

  , Command
      (pure "testmask")
      (liftA2 (,) (simpleToken "[nick!]user@host") (remainingArg "[gecos]"))
      "Test how many local and global clients match a mask.\n"
    $ NetworkCommand cmdTestmask simpleNetworkTab

  , Command
      (pure "masktrace")
      (liftA2 (,) (simpleToken "[nick!]user@host") (remainingArg "[gecos]"))
      "Outputs a list of local users matching the given masks.\n"
    $ NetworkCommand cmdMasktrace simpleNetworkTab

  , Command
      (pure "chantrace")
      (simpleToken "channel")
      "Outputs a list of channel members in etrace format.\n"
    $ NetworkCommand cmdChantrace simpleNetworkTab

  , Command
      (pure "trace")
      (optionalArg (liftA2 (,) (simpleToken "[server|nick]") (optionalArg (simpleToken "[location]"))))
      "Outputs a list users on a server.\n"
    $ NetworkCommand cmdTrace simpleNetworkTab

  , Command
      (pure "etrace")
      (optionalArg (simpleToken "[-full|-v4|-v6|nick]"))
      "Outputs a list users on a server.\n"
    $ NetworkCommand cmdEtrace simpleNetworkTab

  , Command
      (pure "map")
      (pure ())
      "Display network map.\n"
    $ NetworkCommand cmdMap simpleNetworkTab

  , Command
      (pure "sconnect")
      (liftA2 (,) (simpleToken "connect_to") (optionalArg (liftA2 (,) (simpleToken "[port]") (optionalArg (simpleToken "[remote]")))))
      "Connect two servers together.\n"
    $ NetworkCommand cmdSconnect simpleNetworkTab

  , Command
      (pure "squit")
      (liftA2 (,) (simpleToken "server") (remainingArg "[reason]"))
      "Split a server away from your side of the network.\n"
    $ NetworkCommand cmdSquit simpleNetworkTab

  , Command
      (pure "modload")
      (liftA2 (,) (simpleToken "[path/]module") (optionalArg (simpleToken "[remote]")))
      "Load an IRCd module.\n"
    $ NetworkCommand cmdModload simpleNetworkTab

  , Command
      (pure "modunload")
      (liftA2 (,) (simpleToken "module") (optionalArg (simpleToken "[remote]")))
      "Unload an IRCd module.\n"
    $ NetworkCommand cmdModunload simpleNetworkTab

  , Command
      (pure "modlist")
      (optionalArg (liftA2 (,) (simpleToken "pattern") (optionalArg (simpleToken "[remote]"))))
      "List loaded IRCd modules.\n"
    $ NetworkCommand cmdModlist simpleNetworkTab

  , Command
      (pure "modrestart")
      (optionalArg (simpleToken "[server]"))
      "Reload all IRCd modules.\n"
    $ NetworkCommand cmdModrestart simpleNetworkTab

  , Command
      (pure "modreload")
      (liftA2 (,) (simpleToken "module") (optionalArg (simpleToken "[remote]")))
      "Reload an IRCd module.\n"
    $ NetworkCommand cmdModreload simpleNetworkTab

  , Command
      (pure "grant")
      (liftA2 (,) (simpleToken "target") (simpleToken "privset"))
      "Manually assign a privset to a user.\n"
    $ NetworkCommand cmdGrant simpleNetworkTab

  , Command
      (pure "privs")
      (optionalArg (simpleToken "[target]"))
      "Check operator privileges of the target.\n"
    $ NetworkCommand cmdPrivs simpleNetworkTab
  ]

cmdGrant :: NetworkCommand (String, String)
cmdGrant cs st (target, privset) =
  do sendMsg cs (rawIrcMsg "GRANT" (Text.pack <$> [target, privset]))
     commandSuccess st

cmdPrivs :: NetworkCommand (Maybe String)
cmdPrivs cs st mbTarget =
  do sendMsg cs (rawIrcMsg "PRIVS" (Text.pack <$> maybeToList mbTarget))
     commandSuccess st

cmdModlist :: NetworkCommand (Maybe (String, Maybe String))
cmdModlist cs st args =
  do let argList = case args of
                     Nothing -> []
                     Just (x, xs) -> x : maybeToList xs
     sendMsg cs (rawIrcMsg "MODLIST" (Text.pack <$> argList))
     commandSuccess st

cmdModrestart :: NetworkCommand (Maybe String)
cmdModrestart cs st args =
  do sendMsg cs (rawIrcMsg "MODRESTART" (Text.pack <$> maybeToList args))
     commandSuccess st

cmdModload :: NetworkCommand (String, Maybe String)
cmdModload cs st (mod_, remote) =
  do sendMsg cs (rawIrcMsg "MODLOAD" (Text.pack <$> (mod_ : maybeToList remote)))
     commandSuccess st

cmdModunload :: NetworkCommand (String, Maybe String)
cmdModunload cs st (mod_, remote) =
  do sendMsg cs (rawIrcMsg "MODUNLOAD" (Text.pack <$> (mod_ : maybeToList remote)))
     commandSuccess st

cmdModreload :: NetworkCommand (String, Maybe String)
cmdModreload cs st (mod_, remote) =
  do sendMsg cs (rawIrcMsg "MODRELOAD" (Text.pack <$> (mod_ : maybeToList remote)))
     commandSuccess st

cmdSquit :: NetworkCommand (String, String)
cmdSquit cs st (server, reason) =
  do sendMsg cs (rawIrcMsg "SQUIT" (Text.pack <$> [server, reason]))
     commandSuccess st

cmdSconnect :: NetworkCommand (String, Maybe (String, Maybe String))
cmdSconnect cs st (server, rest) =
  do let args = case rest of
                  Nothing -> [server]
                  Just (x, xs) -> server : x : maybeToList xs
     sendMsg cs (rawIrcMsg "CONNECT" (Text.pack <$> args))
     commandSuccess st

cmdKill :: NetworkCommand (String, String)
cmdKill cs st (client,rest) =
  do sendMsg cs (ircKill (Text.pack client) (Text.pack rest))
     commandSuccess st

cmdKline :: NetworkCommand (String, String, String)
cmdKline cs st (minutes, mask, reason) =
  do sendMsg cs (ircKline (Text.pack minutes) (Text.pack mask) (Text.pack reason))
     commandSuccess st

cmdUnkline :: NetworkCommand (String, Maybe String)
cmdUnkline cs st (mask, server) =
  do sendMsg cs (ircUnkline (Text.pack mask) (Text.pack <$> server))
     commandSuccess st

cmdUndline :: NetworkCommand (String, Maybe String)
cmdUndline cs st (mask, server) =
  do sendMsg cs (ircUndline (Text.pack mask) (Text.pack <$> server))
     commandSuccess st

cmdUnxline :: NetworkCommand (String, Maybe String)
cmdUnxline cs st (mask, server) =
  do sendMsg cs (ircUnxline (Text.pack mask) (Text.pack <$> server))
     commandSuccess st

cmdUnresv :: NetworkCommand (String, Maybe String)
cmdUnresv cs st (mask, server) =
  do sendMsg cs (ircUnresv (Text.pack mask) (Text.pack <$> server))
     commandSuccess st

cmdTestline :: NetworkCommand String
cmdTestline cs st mask =
  do sendMsg cs (ircTestline (Text.pack mask))
     commandSuccess st

cmdTestkline :: NetworkCommand String
cmdTestkline cs st mask =
  do sendMsg cs (rawIrcMsg "TESTKLINE" [Text.pack mask])
     commandSuccess st

cmdTestGecos :: NetworkCommand String
cmdTestGecos cs st mask =
  do sendMsg cs (rawIrcMsg "TESTGECOS" [Text.pack mask])
     commandSuccess st

cmdTestmask :: NetworkCommand (String, String)
cmdTestmask cs st (mask, gecos) =
  do sendMsg cs (ircTestmask (Text.pack mask) (Text.pack gecos))
     commandSuccess st

cmdMasktrace :: NetworkCommand (String, String)
cmdMasktrace cs st (mask, gecos) =
  do sendMsg cs (ircMasktrace (Text.pack mask) (Text.pack gecos))
     commandSuccess st

cmdChantrace :: NetworkCommand String
cmdChantrace cs st chan =
  do sendMsg cs (ircChantrace (Text.pack chan))
     commandSuccess st

cmdEtrace :: NetworkCommand (Maybe String)
cmdEtrace cs st arg =
  do sendMsg cs (ircEtrace (Text.pack (fromMaybe "" arg)))
     commandSuccess st

cmdTrace :: NetworkCommand (Maybe (String, Maybe String))
cmdTrace cs st args =
  do let argsList =
           case args of
            Nothing           -> []
            Just (x, Nothing) -> [x]
            Just (x, Just y)  -> [x, y]
     sendMsg cs (ircTrace (map Text.pack argsList))
     commandSuccess st

cmdMap :: NetworkCommand ()
cmdMap cs st _ =
  do sendMsg cs ircMap
     commandSuccess st

cmdOper :: NetworkCommand (String, String)
cmdOper cs st (user, pass) =
  do sendMsg cs (ircOper (Text.pack user) (Text.pack pass))
     commandSuccess st