{-# LANGUAGE BangPatterns, OverloadedStrings, ExistentialQuantification #-}
module Client.Commands
( CommandResult(..)
, execute
, executeUserCommand
, commandExpansion
, tabCompletion
, CommandSection(..)
, Command(..)
, CommandImpl(..)
, commands
, commandsList
) where
import Client.Commands.Arguments.Spec
import Client.Commands.Arguments.Parser
import Client.Commands.Exec
import Client.Commands.Interpolation
import Client.Commands.Recognizer
import Client.Commands.WordCompletion
import Client.Configuration
import Client.Message
import Client.State
import Client.State.Extensions
import Client.State.Focus
import Client.State.Network
import Client.State.Window
import Control.Applicative
import Control.Exception (displayException, try)
import Control.Lens
import Control.Monad
import Data.Foldable
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time (ZonedTime, getZonedTime)
import Irc.Commands
import Irc.Identifier
import Irc.RawIrcMsg
import Irc.Message
import RtsStats (getStats)
import System.Process
import Client.Commands.Channel (channelCommands)
import Client.Commands.Chat (chatCommands, chatCommand', executeChat)
import Client.Commands.Connection (connectionCommands)
import Client.Commands.DCC (dccCommands)
import Client.Commands.Operator (operatorCommands)
import Client.Commands.Queries (queryCommands)
import Client.Commands.Toggles (togglesCommands)
import Client.Commands.Window (windowCommands)
import Client.Commands.ZNC (zncCommands)
import Client.Commands.TabCompletion
import Client.Commands.Types
execute ::
String ->
ClientState ->
IO CommandResult
execute str st =
let st' = set clientErrorMsg Nothing st in
case dropWhile (' '==) str of
[] -> commandFailure st
'/':command -> executeUserCommand Nothing command st'
_ -> executeChat str st'
executeUserCommand ::
Maybe Text ->
String ->
ClientState ->
IO CommandResult
executeUserCommand discoTime command st = do
let key = Text.takeWhile (/=' ') (Text.pack command)
rest = dropWhile (==' ') (dropWhile (/=' ') command)
case views (clientConfig . configMacros) (recognize key) st of
Exact (Macro (MacroSpec spec) cmdExs) ->
case doExpansion spec cmdExs rest of
Nothing -> commandFailureMsg "macro expansions failed" st
Just cmds -> process cmds st
_ -> executeCommand Nothing command st
where
doExpansion spec cmdExs rest =
do args <- parse st spec rest
traverse (resolveMacro (map Text.pack args)) cmdExs
resolveMacro args = resolveMacroExpansions (commandExpansion discoTime st) (expandInt args)
expandInt :: [a] -> Integer -> Maybe a
expandInt args i = preview (ix (fromInteger i)) args
process [] st0 = commandSuccess st0
process (c:cs) st0 =
do res <- executeCommand Nothing (Text.unpack c) st0
case res of
CommandSuccess st1 -> process cs st1
CommandFailure st1 -> process cs st1
CommandQuit st1 -> return (CommandQuit st1)
commandExpansion ::
Maybe Text ->
ClientState ->
Text ->
Maybe Text
commandExpansion discoTime st v =
case v of
"network" -> views clientFocus focusNetwork st
"channel" -> previews (clientFocus . _ChannelFocus . _2) idText st
"nick" -> do net <- views clientFocus focusNetwork st
cs <- preview (clientConnection net) st
return (views csNick idText cs)
"disconnect" -> discoTime
_ -> Nothing
tabCompletion ::
Bool ->
ClientState ->
IO CommandResult
tabCompletion isReversed st =
case dropWhile (' ' ==) $ snd $ clientLine st of
'/':command -> executeCommand (Just isReversed) command st
_ -> nickTabCompletion isReversed st
executeCommand ::
Maybe Bool ->
String ->
ClientState ->
IO CommandResult
executeCommand (Just isReversed) _ st
| Just st' <- commandNameCompletion isReversed st = commandSuccess st'
executeCommand tabCompleteReversed str st =
let (cmd, rest) = break (==' ') str
cmdTxt = Text.toLower (Text.pack cmd)
finish spec exec tab =
case tabCompleteReversed of
Just isReversed -> tab isReversed st rest
Nothing ->
case parse st spec rest of
Nothing -> commandFailureMsg "bad command arguments" st
Just arg -> exec st arg
in
case recognize cmdTxt commands of
Exact Command{cmdImplementation=impl, cmdArgumentSpec=argSpec} ->
case impl of
ClientCommand exec tab ->
finish argSpec exec tab
NetworkCommand exec tab
| Just network <- views clientFocus focusNetwork st
, Just cs <- preview (clientConnection network) st ->
finish argSpec (exec cs) (\x -> tab x cs)
| otherwise -> commandFailureMsg "command requires focused network" st
ChannelCommand exec tab
| ChannelFocus network channelId <- view clientFocus st
, Just cs <- preview (clientConnection network) st
, isChannelIdentifier cs channelId ->
finish argSpec (exec channelId cs) (\x -> tab x channelId cs)
| otherwise -> commandFailureMsg "command requires focused channel" st
ChatCommand exec tab
| ChannelFocus network channelId <- view clientFocus st
, Just cs <- preview (clientConnection network) st ->
finish argSpec (exec channelId cs) (\x -> tab x channelId cs)
| otherwise -> commandFailureMsg "command requires focused chat window" st
_ -> case tabCompleteReversed of
Just isReversed -> nickTabCompletion isReversed st
Nothing -> commandFailureMsg "unknown command" st
expandAliases :: [Command] -> [(Text,Command)]
expandAliases xs =
[ (name, cmd) | cmd <- xs, name <- toList (cmdNames cmd) ]
commands :: Recognizer Command
commands = fromCommands (expandAliases (concatMap cmdSectionCmds commandsList))
commandsList :: [CommandSection]
commandsList =
[ CommandSection "Client commands"
[ Command
(pure "exit")
(pure ())
"Exit the client immediately.\n"
$ ClientCommand cmdExit noClientTab
, Command
(pure "reload")
(optionalArg (simpleToken "[filename]"))
"Reload the client configuration file.\n\
\\n\
\If \^Bfilename\^B is provided it will be used to reload.\n\
\Otherwise the previously loaded configuration file will be reloaded.\n"
$ ClientCommand cmdReload tabReload
, Command
(pure "extension")
(liftA2 (,) (simpleToken "extension") (remainingArg "arguments"))
"Calls the process_command callback of the given extension.\n\
\\n\
\\^Bextension\^B should be the name of the loaded extension.\n"
$ ClientCommand cmdExtension simpleClientTab
, Command
(pure "palette")
(pure ())
"Show the current palette settings and a color chart to help pick new colors.\n"
$ ClientCommand cmdPalette noClientTab
, Command
(pure "digraphs")
(pure ())
"\^BDescription:\^B\n\
\\n\
\ Show the table of digraphs. A digraph is a pair of characters\n\
\ can be used together to represent an uncommon character. Type\n\
\ the two-character digraph corresponding to the desired output\n\
\ character and then press M-k (default binding).\n\
\\n\
\ Note that the digraphs list is searchable with /grep.\n\
\\n\
\\^BSee also:\^B grep\n"
$ ClientCommand cmdDigraphs noClientTab
, Command
(pure "keymap")
(pure ())
"Show the key binding map.\n\
\\n\
\Key bindings can be changed in configuration file. See `glirc --config-format`.\n"
$ ClientCommand cmdKeyMap noClientTab
, Command
(pure "rtsstats")
(pure ())
"Show the GHC RTS statistics.\n"
$ ClientCommand cmdRtsStats noClientTab
, Command
(pure "exec")
(remainingArg "arguments")
"Execute a command synchnonously sending the to a configuration destination.\n\
\\n\
\\^Barguments\^B: [-n[network]] [-c[channel]] [-i input] command [arguments...]\n\
\\n\
\When \^Binput\^B is specified it is sent to the stdin.\n\
\\n\
\When neither \^Bnetwork\^B nor \^Bchannel\^B are specified output goes to client window (*).\n\
\When \^Bnetwork\^B is specified output is sent as raw IRC traffic to the network.\n\
\When \^Bchannel\^B is specified output is sent as chat to the given channel on the current network.\n\
\When \^Bnetwork\^B and \^Bchannel\^B are specified output is sent as chat to the given channel on the given network.\n\
\\n\
\\^Barguments\^B is divided on spaces into words before being processed\
\ by getopt. Use Haskell string literal syntax to create arguments with\
\ escaped characters and spaces inside.\n\
\\n"
$ ClientCommand cmdExec simpleClientTab
, Command
(pure "url")
optionalNumberArg
"Open a URL seen in chat.\n\
\\n\
\The URL is opened using the executable configured under \^Burl-opener\^B.\n\
\\n\
\When this command is active in the textbox, chat messages are filtered to\
\ only show ones with URLs.\n\
\\n\
\When \^Bnumber\^B is omitted it defaults to \^B1\^B. The number selects the\
\ URL to open counting back from the most recent.\n"
$ ClientCommand cmdUrl noClientTab
, Command
(pure "help")
(optionalArg (simpleToken "[command]"))
"Show command documentation.\n\
\\n\
\When \^Bcommand\^B is omitted a list of all commands is displayed.\n\
\When \^Bcommand\^B is specified detailed help for that command is shown.\n"
$ ClientCommand cmdHelp tabHelp
],
togglesCommands, connectionCommands, windowCommands, chatCommands,
queryCommands, channelCommands, zncCommands, operatorCommands,
dccCommands ]
cmdExit :: ClientCommand ()
cmdExit st _ = return (CommandQuit st)
cmdPalette :: ClientCommand ()
cmdPalette st _ = commandSuccess (changeSubfocus FocusPalette st)
cmdDigraphs :: ClientCommand ()
cmdDigraphs st _ = commandSuccess (changeSubfocus FocusDigraphs st)
cmdKeyMap :: ClientCommand ()
cmdKeyMap st _ = commandSuccess (changeSubfocus FocusKeyMap st)
cmdRtsStats :: ClientCommand ()
cmdRtsStats st _ =
do mb <- getStats
case mb of
Nothing -> commandFailureMsg "RTS statistics not available. (Use +RTS -T)" st
Just{} -> commandSuccess $ set clientRtsStats mb
$ changeSubfocus FocusRtsStats st
cmdHelp :: ClientCommand (Maybe String)
cmdHelp st mb = commandSuccess (changeSubfocus focus st)
where
focus = FocusHelp (fmap Text.pack mb)
tabHelp :: Bool -> ClientCommand String
tabHelp isReversed st _ =
simpleTabCompletion plainWordCompleteMode [] commandNames isReversed st
where
commandNames = fst <$> expandAliases (concatMap cmdSectionCmds commandsList)
cmdReload :: ClientCommand (Maybe String)
cmdReload st mbPath =
do let path = mbPath <|> Just (view clientConfigPath st)
res <- loadConfiguration path
case res of
Left e -> commandFailureMsg (describeProblem e) st
Right (path',cfg) ->
do st1 <- clientStartExtensions
$ set clientConfig cfg
$ set clientConfigPath path' st
commandSuccess st1
where
describeProblem err =
Text.pack $
case err of
ConfigurationReadFailed e -> "Failed to open configuration: " ++ e
ConfigurationParseFailed _ e -> "Failed to parse configuration: " ++ e
ConfigurationMalformed _ e -> "Configuration malformed: " ++ e
tabReload :: Bool -> ClientCommand String
tabReload _ st _ = commandFailure st
commandNameCompletion :: Bool -> ClientState -> Maybe ClientState
commandNameCompletion isReversed st =
do guard (cursorPos == n)
clientTextBox (wordComplete plainWordCompleteMode isReversed [] possibilities) st
where
n = length white + length leadingPart
(cursorPos, line) = clientLine st
(white, leadingPart) = takeWhile (' ' /=) <$> span (' '==) line
possibilities = Text.cons '/' <$> commandNames
commandNames = keys commands
++ keys (view (clientConfig . configMacros) st)
cmdExtension :: ClientCommand (String, String)
cmdExtension st (name,command) =
do res <- clientCommandExtension (Text.pack name) (Text.pack command) st
case res of
Nothing -> commandFailureMsg "unknown extension" st
Just st' -> commandSuccess st'
cmdExec :: ClientCommand String
cmdExec st rest =
do now <- getZonedTime
case parseExecCmd rest of
Left es -> failure now es
Right ec ->
case buildTransmitter now ec of
Left es -> failure now es
Right tx ->
do res <- runExecCmd ec
case res of
Left es -> failure now es
Right msgs -> tx (map Text.pack msgs)
where
buildTransmitter now ec =
case (Text.pack <$> view execOutputNetwork ec,
Text.pack <$> view execOutputChannel ec) of
(Unspecified, Unspecified) -> Right (sendToClient now)
(Specified network, Specified channel) ->
case preview (clientConnection network) st of
Nothing -> Left ["Unknown network"]
Just cs -> Right (sendToChannel cs channel)
(_ , Specified channel) ->
case currentNetworkState of
Nothing -> Left ["No current network"]
Just cs -> Right (sendToChannel cs channel)
(Specified network, _) ->
case preview (clientConnection network) st of
Nothing -> Left ["Unknown network"]
Just cs -> Right (sendToNetwork now cs)
(_, Current) ->
case currentNetworkState of
Nothing -> Left ["No current network"]
Just cs ->
case view clientFocus st of
ChannelFocus _ channel -> Right (sendToChannel cs (idText channel))
_ -> Left ["No current channel"]
(Current, _) ->
case currentNetworkState of
Nothing -> Left ["No current network"]
Just cs -> Right (sendToNetwork now cs)
sendToClient now msgs = commandSuccess $! foldl' (recordSuccess now) st msgs
sendToNetwork now cs msgs =
commandSuccess =<<
foldM (\st1 msg ->
case parseRawIrcMsg msg of
Nothing ->
return $! recordError now "" ("Bad raw message: " <> msg) st1
Just raw ->
do sendMsg cs raw
return st1) st msgs
sendToChannel cs channel msgs =
commandSuccess =<<
foldM (\st1 msg ->
do sendMsg cs (ircPrivmsg channel msg)
chatCommand'
(\src tgt -> Privmsg src tgt msg)
channel
cs st1) st (filter (not . Text.null) msgs)
currentNetworkState =
do network <- views clientFocus focusNetwork st
preview (clientConnection network) st
failure now es =
commandFailure $! foldl' (flip (recordError now "")) st (map Text.pack es)
recordSuccess :: ZonedTime -> ClientState -> Text -> ClientState
recordSuccess now ste m =
recordNetworkMessage ClientMessage
{ _msgTime = now
, _msgBody = NormalBody m
, _msgNetwork = ""
} ste
cmdUrl :: ClientCommand (Maybe Int)
cmdUrl st arg =
case view (clientConfig . configUrlOpener) st of
Nothing -> commandFailureMsg "url-opener not configured" st
Just opener -> doUrlOpen opener (maybe 0 (subtract 1) arg)
where
focus = view clientFocus st
urls = toListOf ( clientWindows . ix focus . winMessages . each . wlText
. folding urlMatches) st
doUrlOpen opener n =
case preview (ix n) urls of
Just url -> openUrl opener (Text.unpack url) st
Nothing -> commandFailureMsg "bad url number" st
openUrl :: FilePath -> String -> ClientState -> IO CommandResult
openUrl opener url st =
do res <- try (callProcess opener [url])
case res of
Left e -> commandFailureMsg (Text.pack (displayException (e :: IOError))) st
Right{} -> commandSuccess st