{-# 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.Connection ( connectWebsockets )
import Matterhorn.Constants ( userSigil, normalChannelSigil )
import Matterhorn.HelpTopics
import Matterhorn.Scripts
import Matterhorn.State.Help
import Matterhorn.State.Editing
import Matterhorn.State.Channels
import Matterhorn.State.ChannelTopicWindow
import Matterhorn.State.ChannelSelect
import Matterhorn.State.Logging
import Matterhorn.State.PostListOverlay
import Matterhorn.State.UserListOverlay
import Matterhorn.State.ChannelListOverlay
import Matterhorn.State.ThemeListOverlay
import Matterhorn.State.Messages
import Matterhorn.State.NotifyPrefs
import Matterhorn.State.Common ( postInfoMessage )
import Matterhorn.State.Users
import Matterhorn.Themes ( attrForUsername )
import Matterhorn.Types
unwordHead :: Text -> Maybe (Text, Text)
unwordHead t =
let t' = T.dropWhile Char.isSpace t
(w, rs) = T.break Char.isSpace t'
in if T.null w
then Nothing
else Just (w, T.dropWhile Char.isSpace rs)
printArgSpec :: CmdArgs a -> Text
printArgSpec NoArg = ""
printArgSpec (LineArg ts) = "<" <> ts <> ">"
printArgSpec (TokenArg t NoArg) = "<" <> t <> ">"
printArgSpec (UserArg rs) = "<" <> userSigil <> "user>" <> addSpace (printArgSpec rs)
printArgSpec (ChannelArg rs) = "<" <> normalChannelSigil <> "channel>" <> addSpace (printArgSpec rs)
printArgSpec (TokenArg t rs) = "<" <> t <> ">" <> addSpace (printArgSpec rs)
addSpace :: Text -> Text
addSpace "" = ""
addSpace t = " " <> t
matchArgs :: CmdArgs a -> Text -> Either Text a
matchArgs NoArg t = case unwordHead t of
Nothing -> return ()
Just (a, as)
| not (T.all Char.isSpace as) -> Left ("Unexpected arguments '" <> t <> "'")
| otherwise -> Left ("Unexpected argument '" <> a <> "'")
matchArgs (LineArg _) t = return t
matchArgs spec@(UserArg rs) t = case unwordHead t of
Nothing -> case rs of
NoArg -> Left ("Missing argument: " <> printArgSpec spec)
_ -> Left ("Missing arguments: " <> printArgSpec spec)
Just (a, as) -> (,) <$> pure a <*> matchArgs rs as
matchArgs spec@(ChannelArg rs) t = case unwordHead t of
Nothing -> case rs of
NoArg -> Left ("Missing argument: " <> printArgSpec spec)
_ -> Left ("Missing arguments: " <> printArgSpec spec)
Just (a, as) -> (,) <$> pure a <*> matchArgs rs as
matchArgs spec@(TokenArg _ rs) t = case unwordHead t of
Nothing -> case rs of
NoArg -> Left ("Missing argument: " <> printArgSpec spec)
_ -> Left ("Missing arguments: " <> printArgSpec spec)
Just (a, as) -> (,) <$> pure a <*> matchArgs rs as
commandList :: [Cmd]
commandList =
[ Cmd "quit" "Exit Matterhorn" NoArg $ \ () -> requestQuit
, Cmd "right" "Focus on the next channel" NoArg $ \ () ->
nextChannel
, Cmd "left" "Focus on the previous channel" NoArg $ \ () ->
prevChannel
, Cmd "create-channel" "Create a new public channel"
(LineArg "channel name") $ \ name ->
createOrdinaryChannel True name
, Cmd "create-private-channel" "Create a new private channel"
(LineArg "channel name") $ \ name ->
createOrdinaryChannel False name
, Cmd "delete-channel" "Delete the current channel"
NoArg $ \ () ->
beginCurrentChannelDeleteConfirm
, Cmd "hide" "Hide the current DM or group channel from the channel list"
NoArg $ \ () -> do
hideDMChannel =<< use csCurrentChannelId
, Cmd "reconnect" "Force a reconnection attempt to the server"
NoArg $ \ () ->
connectWebsockets
, Cmd "members" "Show the current channel's members"
NoArg $ \ () ->
enterChannelMembersUserList
, Cmd "leave" "Leave a normal channel or hide a DM channel" NoArg $ \ () ->
startLeaveCurrentChannel
, Cmd "join" "Find a channel to join" NoArg $ \ () ->
enterChannelListOverlayMode
, Cmd "join" "Join the specified channel" (ChannelArg NoArg) $ \(n, ()) ->
joinChannelByName n
, Cmd "theme" "List the available themes" NoArg $ \ () ->
enterThemeListMode
, Cmd "theme" "Set the color theme"
(TokenArg "theme" NoArg) $ \ (themeName, ()) ->
setTheme themeName
, Cmd "topic" "Set the current channel's topic (header) interactively"
NoArg $ \ () ->
openChannelTopicWindow
, Cmd "topic" "Set the current channel's topic (header)"
(LineArg "topic") $ \ p ->
if not (T.null p) then setChannelTopic p else return ()
, Cmd "add-user" "Search for a user to add to the current channel"
NoArg $ \ () ->
enterChannelInviteUserList
, Cmd "msg" "Search for a user to enter a private chat"
NoArg $ \ () ->
enterDMSearchUserList
, Cmd "msg" "Chat with the specified user"
(UserArg NoArg) $ \ (name, ()) ->
changeChannelByName name
, Cmd "username-attribute" "Display the attribute used to color the specified username"
(UserArg NoArg) $ \ (name, ()) ->
displayUsernameAttribute name
, Cmd "msg" "Go to a user's channel and send the specified message or command"
(UserArg $ LineArg "message or command") $ \ (name, msg) -> do
withFetchedUserMaybe (UserFetchByUsername name) $ \foundUser -> do
case foundUser of
Just user -> createOrFocusDMChannel user $ Just $ \cId ->
handleInputSubmission cId msg
Nothing -> mhError $ NoSuchUser name
, Cmd "log-start" "Begin logging debug information to the specified path"
(TokenArg "path" NoArg) $ \ (path, ()) ->
startLogging $ T.unpack path
, Cmd "log-snapshot" "Dump the current debug log buffer to the specified path"
(TokenArg "path" NoArg) $ \ (path, ()) ->
logSnapshot $ T.unpack path
, Cmd "log-stop" "Stop logging"
NoArg $ \ () ->
stopLogging
, Cmd "log-mark" "Add a custom marker message to the Matterhorn debug log"
(LineArg "message") $ \ markMsg ->
mhLog LogUserMark markMsg
, Cmd "log-status" "Show current debug logging status"
NoArg $ \ () ->
getLogDestination
, Cmd "add-user" "Add a user to the current channel"
(UserArg NoArg) $ \ (uname, ()) ->
addUserByNameToCurrentChannel uname
, Cmd "remove-user" "Remove a user from the current channel"
(UserArg NoArg) $ \ (uname, ()) ->
removeUserFromCurrentChannel uname
, Cmd "user" "Show users to initiate a private DM chat channel"
NoArg $ \ () ->
enterDMSearchUserList
, Cmd "message-preview" "Toggle preview of the current message" NoArg $ \_ ->
toggleMessagePreview
, Cmd "toggle-channel-list" "Toggle channel list visibility" NoArg $ \_ ->
toggleChannelListVisibility
, Cmd "toggle-message-timestamps" "Toggle message timestamps" NoArg $ \_ ->
toggleMessageTimestamps
, Cmd "toggle-expanded-topics" "Toggle expanded channel topics" NoArg $ \_ ->
toggleExpandedChannelTopics
, Cmd "focus" "Focus on a channel or user"
(ChannelArg NoArg) $ \ (name, ()) ->
changeChannelByName name
, Cmd "focus" "Select from available channels" NoArg $ \ () ->
beginChannelSelect
, Cmd "help" "Show the main help screen" NoArg $ \ _ ->
showHelpScreen mainHelpTopic
, Cmd "shortcuts" "Show keyboard shortcuts" NoArg $ \ _ ->
showHelpScreen mainHelpTopic
, Cmd "help" "Show help about a particular topic"
(TokenArg "topic" NoArg) $ \ (topicName, ()) ->
case lookupHelpTopic topicName of
Nothing -> mhError $ NoSuchHelpTopic topicName
Just topic -> showHelpScreen topic
, Cmd "sh" "List the available shell scripts" NoArg $ \ () ->
listScripts
, Cmd "group-msg" "Create a group chat"
(LineArg (userSigil <> "user [" <> userSigil <> "user ...]")) createGroupChannel
, Cmd "sh" "Run a prewritten shell script"
(TokenArg "script" (LineArg "message")) $ \ (script, text) -> do
cId <- use csCurrentChannelId
findAndRunScript cId script text
, Cmd "flags" "Open a window of your flagged posts" NoArg $ \ () ->
enterFlaggedPostListMode
, Cmd "pinned-posts" "Open a window of this channel's pinned posts" NoArg $ \ () ->
enterPinnedPostListMode
, Cmd "search" "Search for posts with given terms" (LineArg "terms") $
enterSearchResultPostListMode
, Cmd "notify-prefs" "Edit the current channel's notification preferences" NoArg $ \_ ->
enterEditNotifyPrefsMode
]
displayUsernameAttribute :: Text -> MH ()
displayUsernameAttribute name = do
let an = attrForUsername trimmed
trimmed = trimUserSigil name
postInfoMessage $ "The attribute used for " <> userSigil <> trimmed <>
" is " <> (attrNameToConfig an)
execMMCommand :: Text -> Text -> MH ()
execMMCommand name rest = do
cId <- use csCurrentChannelId
session <- getSession
em <- use (csEditState.cedEditMode)
tId <- gets myTeamId
let mc = MM.MinCommand
{ MM.minComChannelId = cId
, MM.minComCommand = "/" <> name <> " " <> rest
, MM.minComParentId = case em of
Replying _ p -> Just $ MM.getId p
Editing p _ -> MM.postRootId p
_ -> Nothing
, MM.minComRootId = case em of
Replying _ p -> MM.postRootId p <|> (Just $ MM.postId p)
Editing p _ -> MM.postRootId p
_ -> Nothing
, MM.minComTeamId = tId
}
runCmd = liftIO $ do
void $ MM.mmExecuteCommand mc session
handleHTTP (MM.HTTPResponseException err) =
return (Just (T.pack err))
handleCmdErr (MM.MattermostServerError err) =
let (_, msg) = T.breakOn ": " err in
return (Just (T.drop 2 msg))
handleMMErr (MM.MattermostError
{ MM.mattermostErrorMessage = msg }) =
return (Just msg)
errMsg <- liftIO $ (runCmd >> return Nothing) `Exn.catch` handleHTTP
`Exn.catch` handleCmdErr
`Exn.catch` handleMMErr
case errMsg of
Nothing -> return ()
Just err ->
mhError $ GenericError ("Error running command: " <> err)
dispatchCommand :: Text -> MH ()
dispatchCommand cmd =
case unwordHead cmd of
Just (x, xs)
| matchingCmds <- [ c
| c@(Cmd name _ _ _) <- commandList
, name == x
] -> go [] matchingCmds
where go [] [] = do
execMMCommand x xs
go errs [] = do
let msg = ("error running command /" <> x <> ":\n" <>
mconcat [ " " <> e | e <- errs ])
mhError $ GenericError msg
go errs (Cmd _ _ spec exe : cs) =
case matchArgs spec xs of
Left e -> go (e:errs) cs
Right args -> exe args
_ -> return ()
toggleMessagePreview :: MH ()
toggleMessagePreview = do
mh invalidateCache
csShowMessagePreview %= not