{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
module Matterhorn.Command
( commandList
, dispatchCommand
, printArgSpec
, toggleMessagePreview
)
where
import Prelude ()
import Matterhorn.Prelude
import Brick.Main ( invalidateCache )
import qualified Control.Exception as Exn
import qualified Data.Char as Char
import qualified Data.Text as T
import Lens.Micro.Platform ( (%=) )
import qualified Network.Mattermost.Endpoints as MM
import qualified Network.Mattermost.Exceptions as MM
import qualified Network.Mattermost.Types as MM
import Matterhorn.State.Attachments
import Matterhorn.Connection ( connectWebsockets )
import Matterhorn.Constants ( normalChannelSigil )
import Matterhorn.HelpTopics
import Matterhorn.Scripts
import Matterhorn.State.Help
import Matterhorn.State.Editing
import Matterhorn.State.ChannelList
import Matterhorn.State.Channels
import Matterhorn.State.ChannelTopicWindow
import Matterhorn.State.ChannelSelect
import Matterhorn.State.Common
import Matterhorn.State.Logging
import Matterhorn.State.PostListWindow
import Matterhorn.State.UserListWindow
import Matterhorn.State.ChannelListWindow
import Matterhorn.State.ThemeListWindow
import Matterhorn.State.Messages
import Matterhorn.State.NotifyPrefs
import Matterhorn.State.Teams
import Matterhorn.State.Users
import Matterhorn.Themes ( attrForUsername )
import Matterhorn.Types
unwordHead :: Text -> Maybe (Text, Text)
unwordHead :: Text -> Maybe (Text, Text)
unwordHead Text
t =
let t' :: Text
t' = (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
Char.isSpace Text
t
(Text
w, Text
rs) = (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
Char.isSpace Text
t'
in if Text -> Bool
T.null Text
w
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just (Text
w, (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
Char.isSpace Text
rs)
printArgSpec :: CmdArgs a -> Text
printArgSpec :: forall a. CmdArgs a -> Text
printArgSpec CmdArgs a
NoArg = Text
""
printArgSpec (LineArg Text
ts) = Text
"<" forall a. Semigroup a => a -> a -> a
<> Text
ts forall a. Semigroup a => a -> a -> a
<> Text
">"
printArgSpec (TokenArg Text
t CmdArgs rest
NoArg) = Text
"<" forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
">"
printArgSpec (UserArg CmdArgs rest
rs) = Text
"<" forall a. Semigroup a => a -> a -> a
<> Text -> Text
addUserSigil Text
"user" forall a. Semigroup a => a -> a -> a
<> Text
">" forall a. Semigroup a => a -> a -> a
<> Text -> Text
addSpace (forall a. CmdArgs a -> Text
printArgSpec CmdArgs rest
rs)
printArgSpec (ChannelArg CmdArgs rest
rs) = Text
"<" forall a. Semigroup a => a -> a -> a
<> Text
normalChannelSigil forall a. Semigroup a => a -> a -> a
<> Text
"channel>" forall a. Semigroup a => a -> a -> a
<> Text -> Text
addSpace (forall a. CmdArgs a -> Text
printArgSpec CmdArgs rest
rs)
printArgSpec (TokenArg Text
t CmdArgs rest
rs) = Text
"<" forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
">" forall a. Semigroup a => a -> a -> a
<> Text -> Text
addSpace (forall a. CmdArgs a -> Text
printArgSpec CmdArgs rest
rs)
addSpace :: Text -> Text
addSpace :: Text -> Text
addSpace Text
"" = Text
""
addSpace Text
t = Text
" " forall a. Semigroup a => a -> a -> a
<> Text
t
matchArgs :: CmdArgs a -> Text -> Either Text a
matchArgs :: forall a. CmdArgs a -> Text -> Either Text a
matchArgs CmdArgs a
NoArg Text
t = case Text -> Maybe (Text, Text)
unwordHead Text
t of
Maybe (Text, Text)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (Text
a, Text
as)
| Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
T.all Char -> Bool
Char.isSpace Text
as) -> forall a b. a -> Either a b
Left (Text
"Unexpected arguments '" forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
"'")
| Bool
otherwise -> forall a b. a -> Either a b
Left (Text
"Unexpected argument '" forall a. Semigroup a => a -> a -> a
<> Text
a forall a. Semigroup a => a -> a -> a
<> Text
"'")
matchArgs (LineArg Text
_) Text
t = forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
matchArgs spec :: CmdArgs a
spec@(UserArg CmdArgs rest
rs) Text
t = case Text -> Maybe (Text, Text)
unwordHead Text
t of
Maybe (Text, Text)
Nothing -> case CmdArgs rest
rs of
CmdArgs rest
NoArg -> forall a b. a -> Either a b
Left (Text
"Missing argument: " forall a. Semigroup a => a -> a -> a
<> forall a. CmdArgs a -> Text
printArgSpec CmdArgs a
spec)
CmdArgs rest
_ -> forall a b. a -> Either a b
Left (Text
"Missing arguments: " forall a. Semigroup a => a -> a -> a
<> forall a. CmdArgs a -> Text
printArgSpec CmdArgs a
spec)
Just (Text
a, Text
as) -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. CmdArgs a -> Text -> Either Text a
matchArgs CmdArgs rest
rs Text
as
matchArgs spec :: CmdArgs a
spec@(ChannelArg CmdArgs rest
rs) Text
t = case Text -> Maybe (Text, Text)
unwordHead Text
t of
Maybe (Text, Text)
Nothing -> case CmdArgs rest
rs of
CmdArgs rest
NoArg -> forall a b. a -> Either a b
Left (Text
"Missing argument: " forall a. Semigroup a => a -> a -> a
<> forall a. CmdArgs a -> Text
printArgSpec CmdArgs a
spec)
CmdArgs rest
_ -> forall a b. a -> Either a b
Left (Text
"Missing arguments: " forall a. Semigroup a => a -> a -> a
<> forall a. CmdArgs a -> Text
printArgSpec CmdArgs a
spec)
Just (Text
a, Text
as) -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. CmdArgs a -> Text -> Either Text a
matchArgs CmdArgs rest
rs Text
as
matchArgs spec :: CmdArgs a
spec@(TokenArg Text
_ CmdArgs rest
rs) Text
t = case Text -> Maybe (Text, Text)
unwordHead Text
t of
Maybe (Text, Text)
Nothing -> case CmdArgs rest
rs of
CmdArgs rest
NoArg -> forall a b. a -> Either a b
Left (Text
"Missing argument: " forall a. Semigroup a => a -> a -> a
<> forall a. CmdArgs a -> Text
printArgSpec CmdArgs a
spec)
CmdArgs rest
_ -> forall a b. a -> Either a b
Left (Text
"Missing arguments: " forall a. Semigroup a => a -> a -> a
<> forall a. CmdArgs a -> Text
printArgSpec CmdArgs a
spec)
Just (Text
a, Text
as) -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. CmdArgs a -> Text -> Either Text a
matchArgs CmdArgs rest
rs Text
as
commandList :: [Cmd]
commandList :: [Cmd]
commandList =
[ forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"quit" Text
"Exit Matterhorn" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () -> MH ()
requestQuit
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"right" Text
"Focus on the next channel" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
nextChannel
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"left" Text
"Focus on the previous channel" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
prevChannel
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"create-channel" Text
"Create a new public channel"
(Text -> CmdArgs Text
LineArg Text
"channel name") forall a b. (a -> b) -> a -> b
$ \ Text
name -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
TeamId -> Bool -> Text -> MH ()
createOrdinaryChannel TeamId
tId Bool
True Text
name
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"create-private-channel" Text
"Create a new private channel"
(Text -> CmdArgs Text
LineArg Text
"channel name") forall a b. (a -> b) -> a -> b
$ \ Text
name -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
TeamId -> Bool -> Text -> MH ()
createOrdinaryChannel TeamId
tId Bool
False Text
name
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"delete-channel" Text
"Delete the current channel"
CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
beginCurrentChannelDeleteConfirm
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"hide" Text
"Hide the current DM or group channel from the channel list"
CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
TeamId -> (ChannelId -> ClientChannel -> MH ()) -> MH ()
withCurrentChannel TeamId
tId forall a b. (a -> b) -> a -> b
$ \ChannelId
cId ClientChannel
_ -> do
ChannelId -> MH ()
hideDMChannel ChannelId
cId
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"reconnect" Text
"Force a reconnection attempt to the server"
CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () ->
MH ()
connectWebsockets
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"members" Text
"Show the current channel's members"
CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
enterChannelMembersUserList
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"leave" Text
"Leave a normal channel or hide a DM channel" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
startLeaveCurrentChannel
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"join" Text
"Find a channel to join" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
enterChannelListWindowMode
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"join" Text
"Join the specified channel" (forall rest. CmdArgs rest -> CmdArgs (Text, rest)
ChannelArg CmdArgs ()
NoArg) forall a b. (a -> b) -> a -> b
$ \(Text
n, ()) -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
TeamId -> Text -> MH ()
joinChannelByName TeamId
tId Text
n
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"theme" Text
"List the available themes" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
enterThemeListMode
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"theme" Text
"Set the color theme"
(forall rest. Text -> CmdArgs rest -> CmdArgs (Text, rest)
TokenArg Text
"theme" CmdArgs ()
NoArg) forall a b. (a -> b) -> a -> b
$ \ (Text
themeName, ()) -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
TeamId -> Text -> MH ()
setTheme TeamId
tId Text
themeName
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"topic" Text
"Set the current channel's topic (header) interactively"
CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
openChannelTopicWindow
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"topic" Text
"Set the current channel's topic (header)"
(Text -> CmdArgs Text
LineArg Text
"topic") forall a b. (a -> b) -> a -> b
$ \ Text
p -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
if Bool -> Bool
not (Text -> Bool
T.null Text
p) then TeamId -> Text -> MH ()
setChannelTopic TeamId
tId Text
p else forall (m :: * -> *) a. Monad m => a -> m a
return ()
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"add-user" Text
"Search for a user to add to the current channel"
CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
enterChannelInviteUserList
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"msg" Text
"Search for a user to enter a private chat"
CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
enterDMSearchUserList
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"msg" Text
"Chat with the specified user"
(forall rest. CmdArgs rest -> CmdArgs (Text, rest)
UserArg CmdArgs ()
NoArg) forall a b. (a -> b) -> a -> b
$ \ (Text
name, ()) -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
TeamId -> Text -> MH ()
changeChannelByName TeamId
tId Text
name
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"username-attribute" Text
"Display the attribute used to color the specified username"
(forall rest. CmdArgs rest -> CmdArgs (Text, rest)
UserArg CmdArgs ()
NoArg) forall a b. (a -> b) -> a -> b
$ \ (Text
name, ()) ->
Text -> MH ()
displayUsernameAttribute Text
name
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"msg" Text
"Go to a user's channel and send the specified message or command"
(forall rest. CmdArgs rest -> CmdArgs (Text, rest)
UserArg forall a b. (a -> b) -> a -> b
$ Text -> CmdArgs Text
LineArg Text
"message or command") forall a b. (a -> b) -> a -> b
$ \ (Text
name, Text
msg) -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
UserFetch -> (Maybe UserInfo -> MH ()) -> MH ()
withFetchedUserMaybe (Text -> UserFetch
UserFetchByUsername Text
name) forall a b. (a -> b) -> a -> b
$ \Maybe UserInfo
foundUser -> do
case Maybe UserInfo
foundUser of
Just UserInfo
user -> TeamId -> UserInfo -> Maybe (ChannelId -> MH ()) -> MH ()
createOrFocusDMChannel TeamId
tId UserInfo
user forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \ChannelId
_ -> do
TeamId -> (ChannelId -> ClientChannel -> MH ()) -> MH ()
withCurrentChannel TeamId
tId forall a b. (a -> b) -> a -> b
$ \ChannelId
cId ClientChannel
_ ->
Lens' ChatState (EditState Name) -> Text -> MH ()
handleInputSubmission (ChannelId -> Lens' ChatState (EditState Name)
channelEditor(ChannelId
cId)) Text
msg
Maybe UserInfo
Nothing -> MHError -> MH ()
mhError forall a b. (a -> b) -> a -> b
$ Text -> MHError
NoSuchUser Text
name
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"log-start" Text
"Begin logging debug information to the specified path"
(forall rest. Text -> CmdArgs rest -> CmdArgs (Text, rest)
TokenArg Text
"path" CmdArgs ()
NoArg) forall a b. (a -> b) -> a -> b
$ \ (Text
path, ()) ->
FilePath -> MH ()
startLogging forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
path
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"log-snapshot" Text
"Dump the current debug log buffer to the specified path"
(forall rest. Text -> CmdArgs rest -> CmdArgs (Text, rest)
TokenArg Text
"path" CmdArgs ()
NoArg) forall a b. (a -> b) -> a -> b
$ \ (Text
path, ()) ->
FilePath -> MH ()
logSnapshot forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
path
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"log-stop" Text
"Stop logging"
CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () ->
MH ()
stopLogging
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"log-mark" Text
"Add a custom marker message to the Matterhorn debug log"
(Text -> CmdArgs Text
LineArg Text
"message") forall a b. (a -> b) -> a -> b
$ \ Text
markMsg ->
LogCategory -> Text -> MH ()
mhLog LogCategory
LogUserMark Text
markMsg
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"log-status" Text
"Show current debug logging status"
CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () ->
MH ()
getLogDestination
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"add-user" Text
"Add a user to the current channel"
(forall rest. CmdArgs rest -> CmdArgs (Text, rest)
UserArg CmdArgs ()
NoArg) forall a b. (a -> b) -> a -> b
$ \ (Text
uname, ()) -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
TeamId -> Text -> MH ()
addUserByNameToCurrentChannel TeamId
tId Text
uname
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"remove" Text
"Remove a user from the current channel"
(forall rest. CmdArgs rest -> CmdArgs (Text, rest)
UserArg CmdArgs ()
NoArg) forall a b. (a -> b) -> a -> b
$ \ (Text
uname, ()) -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
TeamId -> Text -> MH ()
removeUserFromCurrentChannel TeamId
tId Text
uname
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"user" Text
"Show users to initiate a private DM chat channel"
CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
enterDMSearchUserList
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"message-preview" Text
"Toggle preview of the current message" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \()
_ ->
MH ()
toggleMessagePreview
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"toggle-truncate-verbatim-blocks" Text
"Toggle truncation of verbatim and code blocks" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \()
_ ->
MH ()
toggleVerbatimBlockTruncation
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"toggle-channel-list" Text
"Toggle channel list visibility" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \()
_ ->
MH ()
toggleChannelListVisibility
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"toggle-message-timestamps" Text
"Toggle message timestamps" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \()
_ ->
MH ()
toggleMessageTimestamps
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"toggle-expanded-topics" Text
"Toggle expanded channel topics" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \()
_ ->
MH ()
toggleExpandedChannelTopics
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"cycle-channel-list-sorting" Text
"Cycle through channel list sorting modes for this team" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \()
_ ->
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
cycleChannelListSortingMode
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"thread-orientation" Text
"Set the orientation of the thread UI" (Text -> CmdArgs Text
LineArg Text
"left|right|above|below") forall a b. (a -> b) -> a -> b
$ \Text
o ->
Text -> MH ()
setThreadOrientationByName Text
o
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"focus" Text
"Focus on a channel or user"
(forall rest. CmdArgs rest -> CmdArgs (Text, rest)
ChannelArg CmdArgs ()
NoArg) forall a b. (a -> b) -> a -> b
$ \ (Text
name, ()) -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
TeamId -> Text -> MH ()
changeChannelByName TeamId
tId Text
name
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"focus" Text
"Select from available channels" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
beginChannelSelect
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"help" Text
"Show the main help screen" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ ()
_ -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
TeamId -> HelpTopic -> MH ()
showHelpScreen TeamId
tId HelpTopic
mainHelpTopic
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"shortcuts" Text
"Show keyboard shortcuts" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ ()
_ -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
TeamId -> HelpTopic -> MH ()
showHelpScreen TeamId
tId HelpTopic
mainHelpTopic
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"help" Text
"Show help about a particular topic"
(forall rest. Text -> CmdArgs rest -> CmdArgs (Text, rest)
TokenArg Text
"topic" CmdArgs ()
NoArg) forall a b. (a -> b) -> a -> b
$ \ (Text
topicName, ()) -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
case Text -> Maybe HelpTopic
lookupHelpTopic Text
topicName of
Maybe HelpTopic
Nothing -> MHError -> MH ()
mhError forall a b. (a -> b) -> a -> b
$ Text -> MHError
NoSuchHelpTopic Text
topicName
Just HelpTopic
topic -> TeamId -> HelpTopic -> MH ()
showHelpScreen TeamId
tId HelpTopic
topic
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"sh" Text
"List the available shell scripts" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () ->
MH ()
listScripts
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"group-create" Text
"Create a group chat"
(Text -> CmdArgs Text
LineArg (Text -> Text
addUserSigil Text
"user" forall a. Semigroup a => a -> a -> a
<> Text
" [" forall a. Semigroup a => a -> a -> a
<> Text -> Text
addUserSigil Text
"user" forall a. Semigroup a => a -> a -> a
<> Text
" ...]")) forall a b. (a -> b) -> a -> b
$ \ Text
t -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
TeamId -> Text -> MH ()
createGroupChannel TeamId
tId Text
t
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"sh" Text
"Run a prewritten shell script"
(forall rest. Text -> CmdArgs rest -> CmdArgs (Text, rest)
TokenArg Text
"script" (Text -> CmdArgs Text
LineArg Text
"message")) forall a b. (a -> b) -> a -> b
$ \ (Text
script, Text
text) -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
TeamId -> (ChannelId -> ClientChannel -> MH ()) -> MH ()
withCurrentChannel TeamId
tId forall a b. (a -> b) -> a -> b
$ \ChannelId
cId ClientChannel
_ -> do
Lens' ChatState (EditState Name) -> Text -> Text -> MH ()
findAndRunScript (ChannelId -> Lens' ChatState (EditState Name)
channelEditor(ChannelId
cId)) Text
script Text
text
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"flags" Text
"Open a window of your flagged posts" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
enterFlaggedPostListMode
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"pinned-posts" Text
"Open a window of this channel's pinned posts" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \ () -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
enterPinnedPostListMode
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"search" Text
"Search for posts with given terms" (Text -> CmdArgs Text
LineArg Text
"terms") forall a b. (a -> b) -> a -> b
$ \Text
t -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
TeamId -> Text -> MH ()
enterSearchResultPostListMode TeamId
tId Text
t
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"notify-prefs" Text
"Edit the current channel's notification preferences" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \()
_ -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
enterEditNotifyPrefsMode
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"rename-channel-url" Text
"Rename the current channel's URL name" (forall rest. Text -> CmdArgs rest -> CmdArgs (Text, rest)
TokenArg Text
"channel name" CmdArgs ()
NoArg) forall a b. (a -> b) -> a -> b
$ \ (Text
name, ()
_) -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
TeamId -> Text -> MH ()
renameChannelUrl TeamId
tId Text
name
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"move-team-left" Text
"Move the currently-selected team to the left in the team list" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \()
_ ->
MH ()
moveCurrentTeamLeft
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"move-team-right" Text
"Move the currently-selected team to the right in the team list" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \()
_ ->
MH ()
moveCurrentTeamRight
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"attach" Text
"Attach a given file without browsing" (Text -> CmdArgs Text
LineArg Text
"path") forall a b. (a -> b) -> a -> b
$ \Text
path -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId -> do
MessageInterfaceFocus
foc <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (TeamId -> Lens' ChatState TeamState
csTeam(TeamId
tId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' TeamState MessageInterfaceFocus
tsMessageInterfaceFocus)
case MessageInterfaceFocus
foc of
MessageInterfaceFocus
FocusThread ->
forall i.
Lens' ChatState (MessageInterface Name i) -> Text -> MH ()
attachFileByPath (HasCallStack => TeamId -> Lens' ChatState ThreadInterface
unsafeThreadInterface(TeamId
tId)) Text
path
MessageInterfaceFocus
FocusCurrentChannel ->
TeamId -> (ChannelId -> ClientChannel -> MH ()) -> MH ()
withCurrentChannel TeamId
tId forall a b. (a -> b) -> a -> b
$ \ChannelId
cId ClientChannel
_ ->
forall i.
Lens' ChatState (MessageInterface Name i) -> Text -> MH ()
attachFileByPath (ChannelId -> Lens' ChatState ChannelMessageInterface
csChannelMessageInterface(ChannelId
cId)) Text
path
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"toggle-mouse-input" Text
"Toggle whether mouse input is enabled" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \()
_ ->
MH ()
toggleMouseMode
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"toggle-favorite" Text
"Toggle the favorite status of the current channel" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \()
_ -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
toggleChannelFavoriteStatus
, forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"toggle-sidebar-group" Text
"Toggle the visibility of the current channel's sidebar group" CmdArgs ()
NoArg forall a b. (a -> b) -> a -> b
$ \()
_ -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam TeamId -> MH ()
toggleCurrentChannelChannelListGroup
, let names :: Text
names = Text -> [Text] -> Text
T.intercalate Text
"|" forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, ChannelListGroupLabel)]
channelListGroupNames
in forall a. Text -> Text -> CmdArgs a -> CmdExec a -> Cmd
Cmd Text
"toggle-sidebar-group" Text
"Toggle the visibility of the named sidebar group" (Text -> CmdArgs Text
LineArg Text
names) forall a b. (a -> b) -> a -> b
$ \Text
name -> do
(TeamId -> MH ()) -> MH ()
withCurrentTeam (Text -> TeamId -> MH ()
toggleCurrentChannelChannelListGroupByName Text
name)
]
displayUsernameAttribute :: Text -> MH ()
displayUsernameAttribute :: Text -> MH ()
displayUsernameAttribute Text
name = do
let an :: AttrName
an = Text -> AttrName
attrForUsername Text
trimmed
trimmed :: Text
trimmed = Text -> Text
trimUserSigil Text
name
Text -> MH ()
postInfoMessage forall a b. (a -> b) -> a -> b
$ Text
"The attribute used for " forall a. Semigroup a => a -> a -> a
<> Text -> Text
addUserSigil Text
trimmed forall a. Semigroup a => a -> a -> a
<>
Text
" is " forall a. Semigroup a => a -> a -> a
<> (AttrName -> Text
attrNameToConfig AttrName
an)
execMMCommand :: MM.TeamId -> Text -> Text -> MH ()
execMMCommand :: TeamId -> Text -> Text -> MH ()
execMMCommand TeamId
tId Text
name Text
rest = do
TeamId -> (ChannelId -> ClientChannel -> MH ()) -> MH ()
withCurrentChannel TeamId
tId forall a b. (a -> b) -> a -> b
$ \ChannelId
cId ClientChannel
_ -> do
Session
session <- MH Session
getSession
EditMode
em <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (ChannelId -> Lens' ChatState (EditState Name)
channelEditor(ChannelId
cId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (EditState n) EditMode
esEditMode)
let mc :: MinCommand
mc = MM.MinCommand
{ minComChannelId :: ChannelId
MM.minComChannelId = ChannelId
cId
, minComCommand :: Text
MM.minComCommand = Text
"/" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
rest
, minComParentId :: Maybe PostId
MM.minComParentId = case EditMode
em of
Replying Message
_ Post
p -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall x y. HasId x y => x -> y
MM.getId Post
p
Editing Post
p MessageType
_ -> Post -> Maybe PostId
MM.postRootId Post
p
EditMode
_ -> forall a. Maybe a
Nothing
, minComRootId :: Maybe PostId
MM.minComRootId = case EditMode
em of
Replying Message
_ Post
p -> Post -> Maybe PostId
MM.postRootId Post
p forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Post -> PostId
MM.postId Post
p)
Editing Post
p MessageType
_ -> Post -> Maybe PostId
MM.postRootId Post
p
EditMode
_ -> forall a. Maybe a
Nothing
, minComTeamId :: TeamId
MM.minComTeamId = TeamId
tId
}
runCmd :: IO ()
runCmd = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ MinCommand -> Session -> IO CommandResponse
MM.mmExecuteCommand MinCommand
mc Session
session
handleHTTP :: HTTPResponseException -> m (Maybe Text)
handleHTTP (MM.HTTPResponseException FilePath
err) =
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (FilePath -> Text
T.pack FilePath
err))
handleCmdErr :: MattermostServerError -> m (Maybe Text)
handleCmdErr (MM.MattermostServerError Text
err) =
let (Text
_, Text
msg) = Text -> Text -> (Text, Text)
T.breakOn Text
": " Text
err in
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Int -> Text -> Text
T.drop Int
2 Text
msg))
handleMMErr :: MattermostError -> m (Maybe Text)
handleMMErr (MM.MattermostError
{ mattermostErrorMessage :: MattermostError -> Text
MM.mattermostErrorMessage = Text
msg }) =
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Text
msg)
Maybe Text
errMsg <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (IO ()
runCmd forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exn.catch` forall {m :: * -> *}.
Monad m =>
HTTPResponseException -> m (Maybe Text)
handleHTTP
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exn.catch` forall {m :: * -> *}.
Monad m =>
MattermostServerError -> m (Maybe Text)
handleCmdErr
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exn.catch` forall {m :: * -> *}. Monad m => MattermostError -> m (Maybe Text)
handleMMErr
case Maybe Text
errMsg of
Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Text
err ->
MHError -> MH ()
mhError forall a b. (a -> b) -> a -> b
$ Text -> MHError
GenericError (Text
"Error running command: " forall a. Semigroup a => a -> a -> a
<> Text
err)
dispatchCommand :: MM.TeamId -> Text -> MH ()
dispatchCommand :: TeamId -> Text -> MH ()
dispatchCommand TeamId
tId Text
cmd =
case Text -> Maybe (Text, Text)
unwordHead Text
cmd of
Just (Text
x, Text
xs)
| [Cmd]
matchingCmds <- [ Cmd
c
| c :: Cmd
c@(Cmd Text
name Text
_ CmdArgs a
_ CmdExec a
_) <- [Cmd]
commandList
, Text
name forall a. Eq a => a -> a -> Bool
== Text
x
] -> [Text] -> [Cmd] -> MH ()
go [] [Cmd]
matchingCmds
where go :: [Text] -> [Cmd] -> MH ()
go [] [] = do
TeamId -> Text -> Text -> MH ()
execMMCommand TeamId
tId Text
x Text
xs
go [Text]
errs [] = do
let msg :: Text
msg = (Text
"error running command /" forall a. Semigroup a => a -> a -> a
<> Text
x forall a. Semigroup a => a -> a -> a
<> Text
":\n" forall a. Semigroup a => a -> a -> a
<>
forall a. Monoid a => [a] -> a
mconcat [ Text
" " forall a. Semigroup a => a -> a -> a
<> Text
e | Text
e <- [Text]
errs ])
MHError -> MH ()
mhError forall a b. (a -> b) -> a -> b
$ Text -> MHError
GenericError Text
msg
go [Text]
errs (Cmd Text
_ Text
_ CmdArgs a
spec CmdExec a
exe : [Cmd]
cs) =
case forall a. CmdArgs a -> Text -> Either Text a
matchArgs CmdArgs a
spec Text
xs of
Left Text
e -> [Text] -> [Cmd] -> MH ()
go (Text
eforall a. a -> [a] -> [a]
:[Text]
errs) [Cmd]
cs
Right a
args -> CmdExec a
exe a
args
Maybe (Text, Text)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
toggleMessagePreview :: MH ()
toggleMessagePreview :: MH ()
toggleMessagePreview = do
forall a. EventM Name ChatState a -> MH a
mh forall n s. Ord n => EventM n s ()
invalidateCache
Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources Config
crConfigurationforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Config Bool
configShowMessagePreviewL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Bool -> Bool
not