glirc-2.11: src/Client/Commands.hs
{-# LANGUAGE BangPatterns, OverloadedStrings #-}
{-|
Module : Client.Commands
Description : Implementation of slash commands
Copyright : (c) Eric Mertens, 2016
License : ISC
Maintainer : emertens@gmail.com
This module renders the lines used in the channel mask list. A mask list
can show channel bans, quiets, invites, and exceptions.
-}
module Client.Commands
( CommandResult(..)
, execute
, executeUserCommand
, tabCompletion
) where
import Client.CApi
import Client.Commands.Exec
import Client.Commands.Interpolation
import Client.Commands.WordCompletion
import Client.Configuration
import Client.Configuration.ServerSettings
import Client.Message
import Client.State
import Client.State.Channel
import qualified Client.State.EditBox as Edit
import Client.State.Focus
import Client.State.Network
import Client.State.Window
import Control.Lens
import Control.Monad
import Data.Char
import Data.Foldable
import Data.HashMap.Strict (HashMap)
import Data.HashSet (HashSet)
import Data.List.Split
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Monoid ((<>))
import Data.Time
import Irc.Commands
import Irc.Identifier
import Irc.RawIrcMsg
import Irc.Message
import Irc.UserInfo
import Irc.Modes
import LensUtils
-- | Possible results of running a command
data CommandResult
= CommandSuccess ClientState
-- ^ Continue running the client, consume input if command was from input
| CommandFailure ClientState
-- ^ Continue running the client, report an error
| CommandQuit ClientState -- ^ Client should close
-- | Type of commands that always work
type ClientCommand =
ClientState ->
String {- ^ command arguments -} ->
IO CommandResult
-- | Type of commands that require an active network to be focused
type NetworkCommand =
NetworkState {- ^ focused connection state -} ->
ClientState ->
String {- ^ command arguments -} ->
IO CommandResult
-- | Type of commands that require an active channel to be focused
type ChannelCommand =
NetworkState {- ^ focused connection state -} ->
Identifier {- ^ focused channel -} ->
ClientState ->
String {- ^ command arguments -} ->
IO CommandResult
-- | Pair of implementations for executing a command and tab completing one.
-- The tab-completion logic is extended with a bool
-- indicating that tab completion should be reversed
data Command
= ClientCommand ClientCommand (Bool -> ClientCommand) -- ^ no requirements
| NetworkCommand NetworkCommand (Bool -> NetworkCommand) -- ^ requires an active network
| ChatCommand ChannelCommand (Bool -> ChannelCommand) -- ^ requires an active chat window
| ChannelCommand ChannelCommand (Bool -> ChannelCommand) -- ^ requires an active channel window
-- | Consider the text entry successful and resume the client
commandSuccess :: Monad m => ClientState -> m CommandResult
commandSuccess = return . CommandSuccess
-- | Consider the text entry a failure and resume the client
commandFailure :: Monad m => ClientState -> m CommandResult
commandFailure = return . CommandFailure
-- | Command failure with an error message printed to client window
commandFailureMsg :: Text -> ClientState -> IO CommandResult
commandFailureMsg e st =
do now <- getZonedTime
return $! CommandFailure $! recordError now st e
-- | Interpret the given chat message or command. Leading @/@ indicates a
-- command. Otherwise if a channel or user query is focused a chat message
-- will be sent.
execute ::
String {- ^ chat or command -} ->
ClientState -> IO CommandResult
execute str st =
case str of
[] -> commandFailure st
'/':command -> executeUserCommand command st
msg -> executeChat msg st
-- | Execute command provided by user, resolve aliases if necessary.
executeUserCommand :: String -> ClientState -> IO CommandResult
executeUserCommand command st =
let key = Text.pack (takeWhile (/=' ') command) in
case preview (clientConfig . configMacros . ix key) st of
Nothing -> executeCommand Nothing command st
Just cmdExs ->
case traverse (resolveExpansions expandVar expandInt) cmdExs of
Nothing -> commandFailureMsg "Macro expansions failed" st
Just cmds -> process cmds st
where
args = Text.words (Text.pack command)
expandInt i = preview (ix (fromInteger i)) args
expandVar 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)
_ -> Nothing
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)
-- | Respond to the TAB key being pressed. This can dispatch to a command
-- specific completion mode when relevant. Otherwise this will complete
-- input based on the users of the channel related to the current buffer.
tabCompletion :: Bool {- ^ reversed -} -> ClientState -> IO CommandResult
tabCompletion isReversed st =
case snd $ clientLine st of
'/':command -> executeCommand (Just isReversed) command st
_ -> commandSuccess (nickTabCompletion isReversed st)
-- | Treat the current text input as a chat message and send it.
executeChat :: String -> ClientState -> IO CommandResult
executeChat msg st =
case view clientFocus st of
ChannelFocus network channel
| Just !cs <- preview (clientConnection network) st ->
do now <- getZonedTime
let msgTxt = Text.pack $ takeWhile (/='\n') msg
ircMsg = ircPrivmsg channel msgTxt
myNick = UserInfo (view csNick cs) "" ""
entry = ClientMessage
{ _msgTime = now
, _msgNetwork = network
, _msgBody = IrcBody (Privmsg myNick channel msgTxt)
}
sendMsg cs ircMsg
commandSuccess $ recordChannelMessage network channel entry st
_ -> commandFailureMsg "This command requires an active channel" st
splitWord :: String -> (String, String)
splitWord str = (w, drop 1 rest)
where
(w, rest) = break isSpace str
nextWord :: String -> Maybe (String, String)
nextWord str =
case splitWord (dropWhile isSpace str) of
(a,b) | null a -> Nothing
| otherwise -> Just (a,b)
-- | Parse and execute the given command. When the first argument is Nothing
-- the command is executed, otherwise the first argument is the cursor
-- position for tab-completion
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) = splitWord str
cmdTxt = Text.toLower (Text.pack cmd) in
case HashMap.lookup cmdTxt commands of
Nothing ->
case tabCompleteReversed of
Nothing -> commandFailureMsg "Unknown command" st
Just isReversed -> commandSuccess (nickTabCompletion isReversed st)
Just (ClientCommand exec tab) ->
maybe exec tab tabCompleteReversed
st rest
Just (NetworkCommand exec tab)
| Just network <- views clientFocus focusNetwork st
, Just cs <- preview (clientConnection network) st ->
maybe exec tab tabCompleteReversed
cs st rest
| otherwise -> commandFailureMsg "This command requires an active network" st
Just (ChannelCommand exec tab)
| ChannelFocus network channelId <- view clientFocus st
, Just cs <- preview (clientConnection network) st
, isChannelIdentifier cs channelId ->
maybe exec tab tabCompleteReversed
cs channelId st rest
| otherwise -> commandFailureMsg "This command requires an active channel" st
Just (ChatCommand exec tab)
| ChannelFocus network channelId <- view clientFocus st
, Just cs <- preview (clientConnection network) st ->
maybe exec tab tabCompleteReversed
cs channelId st rest
| otherwise -> commandFailureMsg "This command requires an active chat window" st
-- Expands each alias to have its own copy of the command callbacks
expandAliases :: [([a],b)] -> [(a,b)]
expandAliases xs = [ (a,b) | (as,b) <- xs, a <- as ]
commands :: HashMap Text Command
commands = HashMap.fromList
$ expandAliases
[ (["connect" ], ClientCommand cmdConnect tabConnect)
, (["exit" ], ClientCommand cmdExit noClientTab)
, (["focus" ], ClientCommand cmdFocus tabFocus)
, (["clear" ], ClientCommand cmdClear noClientTab)
, (["reconnect" ], ClientCommand cmdReconnect noClientTab)
, (["ignore" ], ClientCommand cmdIgnore simpleClientTab)
, (["reload" ], ClientCommand cmdReload tabReload)
, (["extension" ], ClientCommand cmdExtension simpleClientTab)
, (["windows" ], ClientCommand cmdWindows noClientTab)
, (["exec" ], ClientCommand cmdExec simpleClientTab)
, (["quote" ], NetworkCommand cmdQuote simpleNetworkTab)
, (["j","join" ], NetworkCommand cmdJoin simpleNetworkTab)
, (["c","channel"], NetworkCommand cmdChannel simpleNetworkTab)
, (["mode" ], NetworkCommand cmdMode tabMode)
, (["msg" ], NetworkCommand cmdMsg simpleNetworkTab)
, (["notice" ], NetworkCommand cmdNotice simpleNetworkTab)
, (["ctcp" ], NetworkCommand cmdCtcp simpleNetworkTab)
, (["nick" ], NetworkCommand cmdNick simpleNetworkTab)
, (["quit" ], NetworkCommand cmdQuit simpleNetworkTab)
, (["disconnect"], NetworkCommand cmdDisconnect noNetworkTab)
, (["who" ], NetworkCommand cmdWho simpleNetworkTab)
, (["whois" ], NetworkCommand cmdWhois simpleNetworkTab)
, (["whowas" ], NetworkCommand cmdWhowas simpleNetworkTab)
, (["ison" ], NetworkCommand cmdIson simpleNetworkTab)
, (["userhost" ], NetworkCommand cmdUserhost simpleNetworkTab)
, (["away" ], NetworkCommand cmdAway simpleNetworkTab)
, (["links" ], NetworkCommand cmdLinks simpleNetworkTab)
, (["time" ], NetworkCommand cmdTime simpleNetworkTab)
, (["stats" ], NetworkCommand cmdStats simpleNetworkTab)
, (["znc" ], NetworkCommand cmdZnc simpleNetworkTab)
, (["znc-playback"], NetworkCommand cmdZncPlayback noNetworkTab)
, (["invite" ], ChannelCommand cmdInvite simpleChannelTab)
, (["topic" ], ChannelCommand cmdTopic tabTopic )
, (["kick" ], ChannelCommand cmdKick simpleChannelTab)
, (["kickban" ], ChannelCommand cmdKickBan simpleChannelTab)
, (["remove" ], ChannelCommand cmdRemove simpleChannelTab)
, (["part" ], ChannelCommand cmdPart simpleChannelTab)
, (["users" ], ChannelCommand cmdUsers noChannelTab)
, (["channelinfo"], ChannelCommand cmdChannelInfo noChannelTab)
, (["masks" ], ChannelCommand cmdMasks noChannelTab)
, (["me" ], ChatCommand cmdMe simpleChannelTab)
, (["say" ], ChatCommand cmdSay simpleChannelTab)
]
noClientTab :: Bool -> ClientCommand
noClientTab _ st _ = commandFailure st
noNetworkTab :: Bool -> NetworkCommand
noNetworkTab _ _ st _ = commandFailure st
noChannelTab :: Bool -> ChannelCommand
noChannelTab _ _ _ st _ = commandFailure st
simpleClientTab :: Bool -> ClientCommand
simpleClientTab isReversed st _ =
commandSuccess (nickTabCompletion isReversed st)
simpleNetworkTab :: Bool -> NetworkCommand
simpleNetworkTab isReversed _ st _ =
commandSuccess (nickTabCompletion isReversed st)
simpleChannelTab :: Bool -> ChannelCommand
simpleChannelTab isReversed _ _ st _ =
commandSuccess (nickTabCompletion isReversed st)
cmdExit :: ClientCommand
cmdExit st _ = return (CommandQuit st)
-- | When used on a channel that the user is currently
-- joined to this command will clear the messages but
-- preserve the window. When used on a window that the
-- user is not joined to this command will delete the window.
cmdClear :: ClientCommand
cmdClear st rest =
case Text.pack <$> words rest of
[] -> clearFocus (view clientFocus st)
["*"] -> clearFocus Unfocused
[network] -> clearFocus (NetworkFocus network)
[network,channel] -> clearFocus (ChannelFocus network (mkId channel))
_ -> commandFailureMsg "Usage: /clear [network] [channel]" st
where
clearFocus focus = commandSuccess (windowEffect st)
where
windowEffect
| isActive = clearWindow
| otherwise = deleteWindow
deleteWindow = advanceFocus . setWindow Nothing
clearWindow = setWindow (Just emptyWindow)
setWindow = set (clientWindows . at (view clientFocus st))
isActive =
case focus of
Unfocused -> False
NetworkFocus network -> has (clientConnection network) st
ChannelFocus network channel -> has (clientConnection network
.csChannels . ix channel) st
cmdQuote :: NetworkCommand
cmdQuote cs st rest =
case parseRawIrcMsg (Text.pack rest) of
Nothing -> commandFailureMsg "Failed to parse IRC command" st
Just raw ->
do sendMsg cs raw
commandSuccess st
-- | Implementation of @/me@
cmdMe :: ChannelCommand
cmdMe cs channelId st rest =
do now <- getZonedTime
let actionTxt = Text.pack ("\^AACTION " ++ rest ++ "\^A")
!myNick = UserInfo (view csNick cs) "" ""
network = view csNetwork cs
entry = ClientMessage
{ _msgTime = now
, _msgNetwork = network
, _msgBody = IrcBody (Ctcp myNick channelId "ACTION" (Text.pack rest))
}
sendMsg cs (ircPrivmsg channelId actionTxt)
commandSuccess
$ recordChannelMessage network channelId entry st
-- | Implementation of @/ctcp@
cmdCtcp :: NetworkCommand
cmdCtcp cs st rest =
case parse of
Nothing -> commandFailureMsg "Usage: /ctcp TARGET COMMAND ARGS" st
Just (target, cmd, args) ->
do let cmdTxt = Text.toUpper (Text.pack cmd)
argTxt = Text.pack args
tgtTxt = Text.pack target
sendMsg cs (ircPrivmsg (mkId tgtTxt) ("\^A" <> cmdTxt <> " " <> argTxt <> "\^A"))
chatCommand
(\src tgt -> Ctcp src tgt cmdTxt argTxt)
tgtTxt cs st
where
parse =
do (target, rest1) <- nextWord rest
(cmd , args ) <- nextWord rest1
return (target, cmd, args)
-- | Implementation of @/notice@
cmdNotice :: NetworkCommand
cmdNotice cs st rest =
case nextWord rest of
Just (target, rest1) | not (null rest1) ->
do let restTxt = Text.pack rest1
tgtTxt = Text.pack target
sendMsg cs (ircNotice (mkId tgtTxt) restTxt)
chatCommand
(\src tgt -> Notice src tgt restTxt)
tgtTxt cs st
_ -> commandFailureMsg "Usage: /notice TARGET MESSAGE" st
-- | Implementation of @/msg@
cmdMsg :: NetworkCommand
cmdMsg cs st rest =
case nextWord rest of
Just (target, rest1) | not (null rest1) ->
do let restTxt = Text.pack rest1
tgtTxt = Text.pack target
sendMsg cs (ircPrivmsg (mkId tgtTxt) restTxt)
chatCommand
(\src tgt -> Privmsg src tgt restTxt)
tgtTxt cs st
_ -> commandFailureMsg "Usage: /msg TARGET MESSAGE" st
-- | Common logic for @/msg@ and @/notice@
chatCommand ::
(UserInfo -> Identifier -> IrcMsg) ->
Text {- ^ target -} ->
NetworkState ->
ClientState ->
IO CommandResult
chatCommand mkmsg target cs st =
commandSuccess =<< chatCommand' mkmsg target cs st
-- | Common logic for @/msg@ and @/notice@ returning the client state
chatCommand' ::
(UserInfo -> Identifier -> IrcMsg) ->
Text {- ^ target -} ->
NetworkState ->
ClientState ->
IO ClientState
chatCommand' con targetsTxt cs st =
do now <- getZonedTime
let targetTxts = Text.split (==',') targetsTxt
targetIds = mkId <$> targetTxts
!myNick = UserInfo (view csNick cs) "" ""
network = view csNetwork cs
entries = [ (targetId,
ClientMessage
{ _msgTime = now
, _msgNetwork = network
, _msgBody = IrcBody (con myNick targetId)
})
| targetId <- targetIds ]
return $! foldl' (\acc (targetId, entry) ->
recordChannelMessage network targetId entry acc)
st
entries
cmdConnect :: ClientCommand
cmdConnect st rest =
case words rest of
[networkStr] ->
do -- abort any existing connection before connecting
let network = Text.pack networkStr
st' <- addConnection network =<< abortNetwork network st
commandSuccess
$ changeFocus (NetworkFocus network) st'
_ -> commandFailureMsg "Usage: /connect NETWORK" st
cmdFocus :: ClientCommand
cmdFocus st rest =
case words rest of
["*"] ->
commandSuccess (changeFocus Unfocused st)
[network] ->
let focus = NetworkFocus (Text.pack network) in
commandSuccess (changeFocus focus st)
[network,channel] ->
let focus = ChannelFocus (Text.pack network) (mkId (Text.pack channel)) in
commandSuccess
$ changeFocus focus st
_ -> commandFailureMsg "Focus requires a network and an optional channel" st
-- | Implementation of @/windows@ command. Set subfocus to Windows.
cmdWindows :: ClientCommand
cmdWindows st _rest = commandSuccess (changeSubfocus FocusWindows st)
-- | @/connect@ tab completes known server names
tabConnect :: Bool -> ClientCommand
tabConnect isReversed st _
= commandSuccess
$ fromMaybe st
$ clientTextBox (wordComplete id isReversed [] networks) st
where
networks = HashMap.keys $ view clientNetworkMap st
-- | When tab completing the first parameter of the focus command
-- the current networks are used.
tabFocus :: Bool -> ClientCommand
tabFocus isReversed st _
= commandSuccess
$ fromMaybe st
$ clientTextBox (wordComplete id isReversed [] completions) st
where
networks = map mkId $ HashMap.keys $ view clientNetworkMap st
params = words $ uncurry take $ clientLine st
completions
| length params == 2 = networks
| otherwise = currentCompletionList st
cmdWhois :: NetworkCommand
cmdWhois cs st rest =
do sendMsg cs (ircWhois (Text.pack <$> words rest))
commandSuccess st
cmdWho :: NetworkCommand
cmdWho cs st rest =
do sendMsg cs (ircWho (Text.pack <$> words rest))
commandSuccess st
cmdWhowas :: NetworkCommand
cmdWhowas cs st rest =
do sendMsg cs (ircWhowas (Text.pack <$> words rest))
commandSuccess st
cmdIson :: NetworkCommand
cmdIson cs st rest =
do sendMsg cs (ircIson (Text.pack <$> words rest))
commandSuccess st
cmdUserhost :: NetworkCommand
cmdUserhost cs st rest =
do sendMsg cs (ircUserhost (Text.pack <$> words rest))
commandSuccess st
cmdStats :: NetworkCommand
cmdStats cs st rest =
do sendMsg cs (ircStats (Text.pack <$> words rest))
commandSuccess st
cmdAway :: NetworkCommand
cmdAway cs st rest =
do sendMsg cs (ircAway (Text.pack rest))
commandSuccess st
cmdLinks :: NetworkCommand
cmdLinks cs st rest =
do sendMsg cs (ircLinks (Text.pack <$> words rest))
commandSuccess st
cmdTime :: NetworkCommand
cmdTime cs st rest =
do sendMsg cs (ircTime (Text.pack <$> words rest))
commandSuccess st
cmdZnc :: NetworkCommand
cmdZnc cs st rest =
do sendMsg cs (ircZnc (Text.words (Text.pack rest)))
commandSuccess st
-- TODO: support time ranges
cmdZncPlayback :: NetworkCommand
cmdZncPlayback cs st rest =
case words rest of
-- request everything
[] -> success "0"
-- current date explicit time
[timeStr]
| Just tod <- parse timeFormats timeStr ->
do now <- getZonedTime
successZoned
(set (zonedTimeLocalTime . localTimeTimeOfDay) tod now)
-- explicit date and time
[dateStr,timeStr]
| Just day <- parse dateFormats dateStr
, Just tod <- parse timeFormats timeStr ->
do tz <- getCurrentTimeZone
successZoned ZonedTime
{ zonedTimeZone = tz
, zonedTimeToLocalTime = LocalTime
{ localTimeOfDay = tod
, localDay = day } }
_ -> commandFailureMsg "Unable to parse date/time arguments" st
where
-- %k doesn't require a leading 0 for times before 10AM
timeFormats = ["%k:%M:%S","%k:%M"]
dateFormats = ["%F"]
parse formats str =
asum (map (parseTimeM False defaultTimeLocale ?? str) formats)
successZoned = success . formatTime defaultTimeLocale "%s"
success start =
do sendMsg cs (ircZnc ["*playback", "play", "*", Text.pack start])
commandSuccess st
cmdMode :: NetworkCommand
cmdMode cs st rest = modeCommand (Text.pack <$> words rest) cs st
cmdNick :: NetworkCommand
cmdNick cs st rest =
case words rest of
[nick] ->
do sendMsg cs (ircNick (mkId (Text.pack nick)))
commandSuccess st
_ -> commandFailureMsg "Usage: /nick NICK" st
cmdPart :: ChannelCommand
cmdPart cs channelId st rest =
do let msg = rest
sendMsg cs (ircPart channelId (Text.pack msg))
commandSuccess st
-- | This command is equivalent to chatting without a command. The primary use
-- at the moment is to be able to send a leading @/@ to chat easily.
cmdSay :: ChannelCommand
cmdSay _cs _channelId st rest = executeChat rest st
cmdInvite :: ChannelCommand
cmdInvite cs channelId st rest =
case words rest of
[nick] ->
do let freeTarget = has (csChannels . ix channelId . chanModes . ix 'g') cs
cmd = ircInvite (Text.pack nick) channelId
cs' <- if freeTarget
then cs <$ sendMsg cs cmd
else sendModeration channelId [cmd] cs
commandSuccessUpdateCS cs' st
_ -> commandFailureMsg "Usage: /invite NICK" st
commandSuccessUpdateCS :: NetworkState -> ClientState -> IO CommandResult
commandSuccessUpdateCS cs st =
let networkId = view csNetworkId cs in
commandSuccess
$ setStrict (clientConnections . ix networkId) cs st
cmdTopic :: ChannelCommand
cmdTopic cs channelId st rest =
do let cmd =
case rest of
"" -> ircTopic channelId ""
topic | useChanServ channelId cs ->
ircPrivmsg "ChanServ"
("TOPIC " <> idText channelId <> Text.pack (' ' : topic))
| otherwise -> ircTopic channelId (Text.pack topic)
sendMsg cs cmd
commandSuccess st
tabTopic ::
Bool {- ^ reversed -} ->
ChannelCommand
tabTopic _ cs channelId st rest
| all isSpace rest
, Just topic <- preview (csChannels . ix channelId . chanTopic) cs =
do let textBox = set Edit.line (Edit.endLine $ "/topic " ++ Text.unpack topic)
commandSuccess (over clientTextBox textBox st)
| otherwise = commandFailure st
cmdUsers :: ChannelCommand
cmdUsers _ _ st _ = commandSuccess (changeSubfocus FocusUsers st)
cmdChannelInfo :: ChannelCommand
cmdChannelInfo _ _ st _ = commandSuccess (changeSubfocus FocusInfo st)
cmdMasks :: ChannelCommand
cmdMasks cs _ st rest =
case words rest of
[[mode]] | mode `elem` view (csModeTypes . modesLists) cs ->
commandSuccess (changeSubfocus (FocusMasks mode) st)
_ -> commandFailureMsg "Unknown mask mode" st
cmdKick :: ChannelCommand
cmdKick cs channelId st rest =
case nextWord rest of
Nothing -> commandFailureMsg "Usage: /kick NICK [MESSAGE]" st
Just (who,reason) ->
do let msg = Text.pack reason
cmd = ircKick channelId (Text.pack who) msg
cs' <- sendModeration channelId [cmd] cs
commandSuccessUpdateCS cs' st
cmdKickBan :: ChannelCommand
cmdKickBan cs channelId st rest =
case nextWord rest of
Nothing -> commandFailureMsg "Usage: /kickban NICK [MESSAGE]" st
Just (whoStr,reason) ->
do let msg = Text.pack reason
whoTxt = Text.pack whoStr
mask = renderUserInfo (computeBanUserInfo (mkId whoTxt) cs)
cmds = [ ircMode channelId ["b", mask]
, ircKick channelId whoTxt msg
]
cs' <- sendModeration channelId cmds cs
commandSuccessUpdateCS cs' st
computeBanUserInfo :: Identifier -> NetworkState -> UserInfo
computeBanUserInfo who cs =
case view (csUser who) cs of
Nothing -> UserInfo who "*" "*"
Just (UserAndHost _ host) -> UserInfo "*" "*" host
cmdRemove :: ChannelCommand
cmdRemove cs channelId st rest =
case nextWord rest of
Nothing -> commandFailureMsg "Usage: /remove NICK [MESSAGE]" st
Just (who,reason) ->
do let msg = Text.pack reason
cmd = ircRemove channelId (Text.pack who) msg
cs' <- sendModeration channelId [cmd] cs
commandSuccessUpdateCS cs' st
cmdJoin :: NetworkCommand
cmdJoin cs st rest =
let ws = words rest
network = view csNetwork cs
doJoin channelStr keyStr =
do let channelId = mkId (Text.pack (takeWhile (/=',') channelStr))
sendMsg cs (ircJoin (Text.pack channelStr) (Text.pack <$> keyStr))
commandSuccess
$ changeFocus (ChannelFocus network channelId) st
in case ws of
[channel] -> doJoin channel Nothing
[channel,key] -> doJoin channel (Just key)
_ -> commandFailureMsg "Usage: /join CHANNELS [KEYS]" st
-- | @/channel@ command. Takes the name of a channel and switches
-- focus to that channel on the current network.
cmdChannel :: NetworkCommand
cmdChannel cs st rest =
case mkId . Text.pack <$> words rest of
[ channelId ] ->
commandSuccess
$ changeFocus (ChannelFocus (view csNetwork cs) channelId) st
_ -> commandFailureMsg "Usage: /channel CHANNEL" st
cmdQuit :: NetworkCommand
cmdQuit cs st rest =
do let msg = Text.pack rest
sendMsg cs (ircQuit msg)
commandSuccess st
cmdDisconnect :: NetworkCommand
cmdDisconnect cs st _ =
do st' <- abortNetwork (view csNetwork cs) st
commandSuccess st'
-- | Reconnect to the currently focused network. It's possible
-- that we're not currently connected to a network, so
-- this is implemented as a client command.
cmdReconnect :: ClientCommand
cmdReconnect st _
| Just network <- views clientFocus focusNetwork st =
do st' <- addConnection network =<< abortNetwork network st
commandSuccess
$ changeFocus (NetworkFocus network) st'
| otherwise = commandFailureMsg "/reconnect requires focused network" st
cmdIgnore :: ClientCommand
cmdIgnore st rest =
case mkId . Text.pack <$> words rest of
[] -> commandFailure st
xs -> commandSuccess
$ over clientIgnores updateIgnores st
where
updateIgnores :: HashSet Identifier -> HashSet Identifier
updateIgnores s = foldl' updateIgnore s xs
updateIgnore s x = over (contains x) not s
-- | Implementation of @/reload@
--
-- Attempt to reload the configuration file
cmdReload :: ClientCommand
cmdReload st rest =
do let path | null rest = view (clientConfig . configConfigPath) st
| otherwise = Just rest
res <- loadConfiguration path
case res of
Left e -> commandFailureMsg (describeProblem e) st
Right cfg ->
do st1 <- clientStartExtensions (set clientConfig cfg 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
-- | Support file name tab completion when providing an alternative
-- configuration file.
--
-- /NOT IMPLEMENTED/
tabReload :: Bool {- ^ reversed -} -> ClientCommand
tabReload _ st _ = commandFailure st
modeCommand ::
[Text] {- mode parameters -} ->
NetworkState ->
ClientState ->
IO CommandResult
modeCommand modes cs st =
case view clientFocus st of
NetworkFocus _ ->
do sendMsg cs (ircMode (view csNick cs) modes)
commandSuccess st
ChannelFocus _ chan ->
case modes of
[] -> success False [[]]
flags:params ->
case splitModes (view csModeTypes cs) flags params of
Nothing -> commandFailureMsg "Failed to parse modes" st
Just parsedModes ->
success needOp (unsplitModes <$> chunksOf (view csModeCount cs) parsedModes')
where
parsedModes'
| useChanServ chan cs = filter (not . isOpMe) parsedModes
| otherwise = parsedModes
needOp = not (all isPublicChannelMode parsedModes)
where
isOpMe (True, 'o', param) = mkId param == view csNick cs
isOpMe _ = False
success needOp argss =
do let cmds = ircMode chan <$> argss
cs' <- if needOp
then sendModeration chan cmds cs
else cs <$ traverse_ (sendMsg cs) cmds
commandSuccessUpdateCS cs' st
_ -> commandFailure st
tabMode :: Bool -> NetworkCommand
tabMode isReversed cs st rest =
case view clientFocus st of
ChannelFocus _ channel
| flags:params <- Text.words (Text.pack rest)
, Just parsedModes <- splitModes (view csModeTypes cs) flags params
, let parsedModesWithParams =
[ (pol,mode) | (pol,mode,arg) <- parsedModes, not (Text.null arg) ]
, (pol,mode):_ <- drop (paramIndex-3) parsedModesWithParams
, let (hint, completions) = computeModeCompletion pol mode channel cs st
-> commandSuccess
$ fromMaybe st
$ clientTextBox (wordComplete id isReversed hint completions) st
_ -> commandSuccess st
where
paramIndex = length $ words $ uncurry take $ clientLine st
activeNicks ::
ClientState ->
[Identifier]
activeNicks st =
case view clientFocus st of
focus@(ChannelFocus network channel) ->
toListOf
( clientWindows . ix focus
. winMessages . folded
. wlBody . _IrcBody
. folding msgActor . to userNick
. filtered isActive) st
where
isActive n = HashMap.member n userMap
userMap = view ( clientConnection network
. csChannels . ix channel
. chanUsers) st
_ -> []
-- | Use the *!*@host masks of users for channel lists when setting list modes
--
-- Use the channel's mask list for removing modes
--
-- Use the nick list otherwise
computeModeCompletion ::
Bool {- ^ mode polarity -} ->
Char {- ^ mode -} ->
Identifier {- ^ channel -} ->
NetworkState ->
ClientState ->
([Identifier],[Identifier]) {- ^ (hint, complete) -}
computeModeCompletion pol mode channel cs st
| mode `elem` view modesLists modeSettings =
if pol then ([],usermasks) else ([],masks)
| otherwise = (activeNicks st, nicks)
where
modeSettings = view csModeTypes cs
nicks = HashMap.keys (view (csChannels . ix channel . chanUsers) cs)
masks = mkId <$> HashMap.keys (view (csChannels . ix channel . chanLists . ix mode) cs)
usermasks =
[ mkId ("*!*@" <> host)
| nick <- HashMap.keys (view (csChannels . ix channel . chanUsers) cs)
, UserAndHost _ host <- toListOf (csUsers . ix nick) cs
]
-- | Predicate for mode commands that can be performed without ops
isPublicChannelMode :: (Bool, Char, Text) -> Bool
isPublicChannelMode (True, 'b', param) = Text.null param -- query ban list
isPublicChannelMode (True, 'q', param) = Text.null param -- query quiet list
isPublicChannelMode _ = False
commandNameCompletion :: Bool -> ClientState -> Maybe ClientState
commandNameCompletion isReversed st =
do guard (cursorPos == n)
clientTextBox (wordComplete id isReversed [] possibilities) st
where
n = length leadingPart
(cursorPos, line) = clientLine st
leadingPart = takeWhile (not . isSpace) line
possibilities = Text.cons '/' <$> commandNames
commandNames = HashMap.keys commands
++ HashMap.keys (view (clientConfig . configMacros) st)
-- | Complete the nickname at the current cursor position using the
-- userlist for the currently focused channel (if any)
nickTabCompletion :: Bool {- ^ reversed -} -> ClientState -> ClientState
nickTabCompletion isReversed st
= fromMaybe st
$ clientTextBox (wordComplete (++": ") isReversed hint completions) st
where
hint = activeNicks st
completions = currentCompletionList st
-- | Used to send commands that require ops to perform.
-- If this channel is one that the user has chanserv access and ops are needed
-- then ops are requested and the commands are queued, otherwise send them
-- directly.
sendModeration ::
Identifier {- ^ channel -} ->
[RawIrcMsg] {- ^ commands -} ->
NetworkState {- ^ network state -} ->
IO NetworkState
sendModeration channel cmds cs
| useChanServ channel cs =
do sendMsg cs (ircPrivmsg "ChanServ" ("OP " <> idText channel))
return $ csChannels . ix channel . chanQueuedModeration <>~ cmds $ cs
| otherwise = cs <$ traverse_ (sendMsg cs) cmds
useChanServ :: Identifier -> NetworkState -> Bool
useChanServ channel cs =
channel `elem` view (csSettings . ssChanservChannels) cs &&
not (iHaveOp channel cs)
cmdExtension :: ClientCommand
cmdExtension st rest =
case Text.words (Text.pack rest) of
name:params ->
case find (\ae -> aeName ae == name)
(view (clientExtensions . esActive) st) of
Nothing -> commandFailureMsg "Unknown extension" st
Just ae ->
do (st',_) <- clientPark st $ \ptr ->
commandExtension ptr params ae
commandSuccess st'
_ -> commandFailureMsg "Usage: /extension EXTENSION ARGUMENTS" st
-- | Implementation of @/exec@ command.
cmdExec :: ClientCommand
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
(Nothing, Nothing) -> Right (sendToClient now)
(Just network, Nothing) ->
case preview (clientConnection network) st of
Nothing -> Left ["Unknown network"]
Just cs -> Right (sendToNetwork now cs)
(Nothing , Just channel) ->
case currentNetworkState of
Nothing -> Left ["No current network"]
Just cs -> Right (sendToChannel cs channel)
(Just network, Just channel) ->
case preview (clientConnection network) st of
Nothing -> Left ["Unknown network"]
Just cs -> Right (sendToChannel cs channel)
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 st1 ("Bad raw message: " <> msg)
Just raw ->
do sendMsg cs raw
return st1) st msgs
sendToChannel cs channel msgs =
commandSuccess =<<
foldM (\st1 msg ->
do sendMsg cs (ircPrivmsg (mkId 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' (recordError now) st (map Text.pack es)
recordError :: ZonedTime -> ClientState -> Text -> ClientState
recordError now ste e =
recordNetworkMessage ClientMessage
{ _msgTime = now
, _msgBody = ErrorBody e
, _msgNetwork = ""
} ste
recordSuccess :: ZonedTime -> ClientState -> Text -> ClientState
recordSuccess now ste m =
recordNetworkMessage ClientMessage
{ _msgTime = now
, _msgBody = NormalBody m
, _msgNetwork = ""
} ste