glirc-2.40: src/Client/Commands/Queries.hs
{-# Language OverloadedStrings #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : Client.Commands.Queries
Description : Query command implementations
Copyright : (c) Eric Mertens, 2016-2020
License : ISC
Maintainer : emertens@gmail.com
-}
module Client.Commands.Queries (queryCommands) where
import Client.Commands.Arguments.Spec (optionalArg, remainingArg, simpleToken, extensionArg, Args)
import Client.Commands.TabCompletion (noNetworkTab, simpleNetworkTab)
import Client.Commands.Types (commandSuccess, commandSuccessUpdateCS, Command(Command), CommandImpl(NetworkCommand), CommandSection(CommandSection), NetworkCommand)
import Client.State (changeSubfocus, ClientState)
import Client.State.Focus (Subfocus(FocusChanList, FocusWho))
import Client.State.Network (sendMsg, csChannelList, clsElist, csPingStatus, _PingConnecting, csWhoReply)
import Client.WhoReply (newWhoReply)
import Control.Applicative (liftA2)
import Control.Lens (has, set, view)
import Control.Monad (unless)
import Data.Maybe (fromMaybe, maybeToList)
import Data.Text qualified as Text
import Irc.Commands
queryCommands :: CommandSection
queryCommands = CommandSection "Queries"
[ Command
(pure "who")
(optionalArg (liftA2 (,) (simpleToken "[channel|nick|mask]") (optionalArg (simpleToken "[options]"))))
"Send WHO query to server with given arguments, or just show the who view.\n"
$ NetworkCommand cmdWho simpleNetworkTab
, Command
(pure "whois")
(remainingArg "arguments")
"Send WHOIS query to server with given arguments.\n"
$ NetworkCommand cmdWhois simpleNetworkTab
, Command
(pure "whowas")
(remainingArg "arguments")
"Send WHOWAS query to server with given arguments.\n"
$ NetworkCommand cmdWhowas simpleNetworkTab
, Command
(pure "ison")
(remainingArg "arguments")
"Send ISON query to server with given arguments.\n"
$ NetworkCommand cmdIson simpleNetworkTab
, Command
(pure "userhost")
(remainingArg "arguments")
"Send USERHOST query to server with given arguments.\n"
$ NetworkCommand cmdUserhost simpleNetworkTab
, Command
(pure "time")
(optionalArg (simpleToken "[servername]"))
"Send TIME query to server with given arguments.\n"
$ NetworkCommand cmdTime simpleNetworkTab
, Command
(pure "stats")
(remainingArg "arguments")
"Send STATS query to server with given arguments.\n"
$ NetworkCommand cmdStats simpleNetworkTab
, Command
(pure "lusers")
(optionalArg (simpleToken "[servername]"))
"Send LUSERS query to a given server.\n"
$ NetworkCommand cmdLusers simpleNetworkTab
, Command
(pure "users")
(optionalArg (simpleToken "[servername]"))
"Send USERS query to a given server.\n"
$ NetworkCommand cmdUsers simpleNetworkTab
, Command
(pure "motd") (optionalArg (simpleToken "[servername]"))
"Send MOTD query to server.\n"
$ NetworkCommand cmdMotd simpleNetworkTab
, Command
(pure "admin") (optionalArg (simpleToken "[servername]"))
"Send ADMIN query to server.\n"
$ NetworkCommand cmdAdmin simpleNetworkTab
, Command
(pure "rules") (optionalArg (simpleToken "[servername]"))
"Send RULES query to server.\n"
$ NetworkCommand cmdRules simpleNetworkTab
, Command
(pure "info") (pure ())
"Send INFO query to server.\n"
$ NetworkCommand cmdInfo noNetworkTab
, Command
(pure "list")
(optionalArg (extensionArg "[clientarg]" listArgs))
"\^BParameters:\^B\n\
\\n\
\ clientarg: An optionally-comma-separated list of\n\
\ flags for controlling the list.\n\
\ ~: Always refresh the list.\n\
\ >n: Show only channels with more than \^Bn\^B users.\n\
\ <n: Show only channels with less than \^Bn\^B users.\n\
\\n\
\ serverarg: The ELIST argument to send to the server.\n\
\\n\
\\^BDescription:\^B\n\
\\n\
\ View the list of public channels on the server.\n\
\\n\
\ Sends a LIST query and caches the result;\n\
\ on larger networks on slower connections,\n\
\ this may take a while to complete.\n\
\\n\
\\^BExamples:\^B\n\
\\n\
\ /list\n\
\ /list >100\n\
\ /list ~ <20\n\
\ /list , *-ops"
$ NetworkCommand cmdList simpleNetworkTab
, Command
(pure "links")
(remainingArg "arguments")
"Send LINKS query to server with given arguments.\n"
$ NetworkCommand cmdLinks simpleNetworkTab
, Command
(pure "version") (optionalArg (simpleToken "[servername]"))
"Send VERSION query to server.\n"
$ NetworkCommand cmdVersion simpleNetworkTab
]
cmdInfo :: NetworkCommand ()
cmdInfo cs st _ =
do sendMsg cs ircInfo
commandSuccess st
cmdVersion :: NetworkCommand (Maybe String)
cmdVersion cs st mbservername =
do sendMsg cs $ ircVersion $ case mbservername of
Just s -> Text.pack s
Nothing -> ""
commandSuccess st
cmdList :: NetworkCommand (Maybe ListArgs)
cmdList cs st rest =
do
let lsa = fromMaybe lsaDefault rest
let connecting = has (csPingStatus . _PingConnecting) cs
let elist = Just (Text.pack (fromMaybe "" (_lsaElist lsa)))
let cached = elist == view (csChannelList . clsElist) cs
let sendM = sendMsg cs (ircList (Text.pack <$> maybeToList (_lsaElist lsa)))
unless (connecting || (cached && not (_lsaRefresh lsa))) sendM
let cs' = set (csChannelList . clsElist) elist cs
let subfocus = FocusChanList (_lsaMin lsa) (_lsaMax lsa)
commandSuccessUpdateCS cs' (changeSubfocus subfocus st)
listArgs :: ClientState -> String -> Maybe (Args ClientState ListArgs)
listArgs _ = fmap (withElist (optionalArg (simpleToken "[serverarg]"))) . lsaParse
where withElist arg a = fmap (\s -> a { _lsaElist = s }) arg
data ListArgs = ListArgs
{ _lsaElist :: Maybe String
, _lsaRefresh :: Bool
, _lsaMin :: Maybe Int
, _lsaMax :: Maybe Int
}
lsaDefault :: ListArgs
lsaDefault = ListArgs
{ _lsaElist = Nothing
, _lsaRefresh = False
, _lsaMin = Nothing
, _lsaMax = Nothing
}
lsaParse :: String -> Maybe ListArgs
lsaParse = lsaParse' lsaDefault
where
lsaParse' lsa str = case str of
'~':rest -> lsaParse' lsa{ _lsaRefresh = True } rest
',':rest -> lsaParse' lsa rest
'>':(reads -> [(min', rest)]) | min' >= 0 ->
lsaParse' lsa{ _lsaMin = Just min'} rest
'<':(reads -> [(max', rest)]) | max' >= 0 ->
lsaParse' lsa{ _lsaMax = Just max'} rest
"" -> Just lsa
_ -> Nothing
cmdLusers :: NetworkCommand (Maybe String)
cmdLusers cs st arg =
do sendMsg cs $ ircLusers $ fmap Text.pack $
case arg of
Nothing -> []
Just x -> ["*", x] -- mask field is legacy
commandSuccess st
cmdUsers :: NetworkCommand (Maybe String)
cmdUsers cs st arg =
do sendMsg cs $ ircUsers $ maybe "" Text.pack arg
commandSuccess st
cmdMotd :: NetworkCommand (Maybe String)
cmdMotd cs st mbservername =
do sendMsg cs $ ircMotd $ case mbservername of
Just s -> Text.pack s
Nothing -> ""
commandSuccess st
cmdAdmin :: NetworkCommand (Maybe String)
cmdAdmin cs st mbservername =
do sendMsg cs $ ircAdmin $ case mbservername of
Just s -> Text.pack s
Nothing -> ""
commandSuccess st
cmdRules :: NetworkCommand (Maybe String)
cmdRules cs st mbservername =
do sendMsg cs $ ircRules $
case mbservername of
Just s -> Text.pack s
Nothing -> ""
commandSuccess st
cmdStats :: NetworkCommand String
cmdStats cs st rest =
do sendMsg cs (ircStats (Text.pack <$> words rest))
commandSuccess st
cmdLinks :: NetworkCommand String
cmdLinks cs st rest =
do sendMsg cs (ircLinks (Text.pack <$> words rest))
commandSuccess st
cmdTime :: NetworkCommand (Maybe String)
cmdTime cs st arg =
do sendMsg cs (ircTime (maybe "" Text.pack arg))
commandSuccess st
cmdWhois :: NetworkCommand String
cmdWhois cs st rest =
do sendMsg cs (ircWhois (Text.pack <$> words rest))
commandSuccess st
cmdWho :: NetworkCommand (Maybe (String, Maybe String))
cmdWho _ st Nothing = commandSuccess (changeSubfocus FocusWho st)
cmdWho cs st (Just (query, arg)) =
do
let query' = Text.pack query
let arg' = fromMaybe "" arg
let cs' = set csWhoReply (newWhoReply query' arg') cs
sendMsg cs (ircWho (query' : maybeToList (Text.pack <$> arg)))
commandSuccessUpdateCS cs' (changeSubfocus FocusWho st)
cmdWhowas :: NetworkCommand String
cmdWhowas cs st rest =
do sendMsg cs (ircWhowas (Text.pack <$> words rest))
commandSuccess st
cmdIson :: NetworkCommand String
cmdIson cs st rest =
do sendMsg cs (ircIson (Text.pack <$> words rest))
commandSuccess st
cmdUserhost :: NetworkCommand String
cmdUserhost cs st rest =
do sendMsg cs (ircUserhost (Text.pack <$> words rest))
commandSuccess st