{-# 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


-- | This function skips any initial whitespace and returns the first
-- 'token' (i.e. any sequence of non-whitespace characters) as well as
-- the trailing rest of the string, after any whitespace. This is used
-- for tokenizing the first bits of command input while leaving the
-- subsequent chunks unchanged, preserving newlines and other
-- important formatting.
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"
    -- n.b. this is identical to "msg", but is provided as an
    -- alternative mental model for useability.
    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))
            -- XXX: this might be a bit brittle in the future, because it
            -- assumes the shape of an error message. We might want to
            -- think about a better way of discovering this error and
            -- reporting it accordingly?
          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