Merge branch 'develop'

CHANGELOG.md

@@ -1,4 +1,14 @@
 
+40900.0.1
+=========
+
+Bug fixes:
+ * Terminal escapes are now sanitized from local user input and
+   user-provided values from the server (#390).
+ * The Cabal package now includes XML syntax and DTD files in the
+   manifest.
+ * Releases now ship the syntax DTD.
+
 40900.0.0
 =========
 

matterhorn.cabal

@@ -1,5 +1,5 @@
 name:                matterhorn
-version:             40900.0.0
+version:             40900.0.1
 synopsis:            Terminal client for the Mattermost chat system
 description:         This is a terminal client for the Mattermost chat
                      system. Please see the README for a list of
@@ -14,6 +14,10 @@ build-type:          Simple
 cabal-version:       >= 1.18
 tested-with:         GHC == 7.10.3, GHC == 8.0.1
 
+data-files:          syntax/*.xml
+                     syntax/language.dtd
+                     syntax/LICENSE
+
 extra-doc-files:     CHANGELOG.md
                      README.md
                      PRACTICES.md
@@ -78,6 +82,7 @@ executable matterhorn
                        Prelude.MH
                        Types
                        Types.Channels
+                       Types.Common
                        Types.DirectionalSeq
                        Types.KeyEvents
                        Types.Messages
@@ -94,7 +99,7 @@ executable matterhorn
                        NoImplicitPrelude
   ghc-options:         -Wall -threaded -with-rtsopts=-I0
   build-depends:       base                 >=4.8     && <5
-                     , mattermost-api       == 40900.0.0
+                     , mattermost-api       == 40900.1.0
                      , base-compat          >= 0.9    && < 0.10
                      , unordered-containers >= 0.2    && < 0.3
                      , containers           >= 0.5.7  && < 0.6
@@ -143,6 +148,7 @@ test-suite test_messages
                     , TimeUtils
                     , Types.Messages
                     , Types.Posts
+                    , Types.Common
                     , Types.DirectionalSeq
                     , Prelude.MH
   default-language:   Haskell2010
@@ -163,8 +169,8 @@ test-suite test_messages
                     , filepath             >= 1.4    && < 1.5
                     , hashable             >= 1.2    && < 1.3
                     , Hclip                >= 3.0    && < 3.1
-                    , mattermost-api       == 40900.0.0
-                    , mattermost-api-qc    == 40900.0.0
+                    , mattermost-api       == 40900.1.0
+                    , mattermost-api-qc    == 40900.1.0
                     , microlens-platform   >= 0.3    && < 0.4
                     , mtl                  >= 2.2    && < 2.3
                     , process              >= 1.4    && < 1.7

src/Draw/JoinChannel.hs

@@ -22,6 +22,7 @@ import           Network.Mattermost.Types ( Channel )
 import           Draw.Main
 import           Themes
 import           Types
+import           Types.Common
 
 
 drawJoinChannel :: ChatState -> [Widget Name]
@@ -49,7 +50,7 @@ joinChannelBox st =
 
 renderJoinListItem :: Bool -> Channel -> Widget Name
 renderJoinListItem _ chan =
-    let baseStr = chan^.channelNameL <> " (" <> chan^.channelDisplayNameL <> ")"
-        s = "  " <> (T.strip $ chan^.channelPurposeL)
+    let baseStr = (sanitizeUserText $ chan^.channelNameL) <> " (" <> (sanitizeUserText $ chan^.channelDisplayNameL) <> ")"
+        s = "  " <> (T.strip $ sanitizeUserText $ chan^.channelPurposeL)
     in (vLimit 1 $ padRight Max $ txt baseStr) <=>
        (vLimit 1 $ txtWrapWith (defaultWrapSettings { preserveIndentation = True }) s)

src/Events.hs

@@ -22,6 +22,7 @@ import           HelpTopics
 import           State
 import           State.Common
 import           Types
+import           Types.Common
 import           Types.KeyEvents
 
 import           Events.ChannelScroll
@@ -200,7 +201,7 @@ handleWSEvent we = do
         -- shortcuts, but it's probably a good idea to handle these
         -- messages anyway.
         WMEphemeralMessage
-            | Just p <- wepPost $ weData we -> postInfoMessage $ p^.postMessageL
+            | Just p <- wepPost $ weData we -> postInfoMessage (sanitizeUserText $ p^.postMessageL)
             | otherwise -> return ()
 
         WMPreferenceChanged

src/State.hs

@@ -155,6 +155,7 @@ import           Markdown ( blockGetURLs, findVerbatimChunk )
 import           Themes
 import           TimeUtils ( justBefore, justAfter )
 import           Types
+import           Types.Common
 import           Zipper ( Zipper )
 import qualified Zipper as Z
 
@@ -477,8 +478,8 @@ beginEditMessage = do
             -- removed formatting needs to be reinstated just prior to
             -- issuing the API call to update the post.
             let toEdit = if msg^.mType == CP Emote
-                         then removeEmoteFormatting $ postMessage p
-                         else postMessage p
+                         then removeEmoteFormatting $ sanitizeUserText $ postMessage p
+                         else sanitizeUserText $ postMessage p
             csEditState.cedEditor %= applyEdit (clearZipper >> (insertMany toEdit))
         _ -> return ()
 
@@ -1148,8 +1149,8 @@ attemptCreateDMChannel name = do
   me <- gets myUser
   displayNick <- use (to useNickname)
   uList       <- use (to sortedUserList)
-  let myName = if displayNick && not (T.null $ userNickname me)
-               then userNickname me
+  let myName = if displayNick && not (T.null $ sanitizeUserText $ userNickname me)
+               then sanitizeUserText $ userNickname me
                else me^.userUsernameL
   when (name /= myName) $ do
       let uName = if displayNick
@@ -1231,7 +1232,7 @@ handleNewChannel_ permitPostpone switch nc member = do
         -- async work to do before we can register this channel (in
         -- which case abort because we got rescheduled).
         mName <- case chType of
-            Direct -> case userIdForDMChannel (myUserId st) $ channelName nc of
+            Direct -> case userIdForDMChannel (myUserId st) (sanitizeUserText $ channelName nc) of
                 -- If this is a direct channel but we can't extract a
                 -- user ID from the name, then it failed to parse. We
                 -- need to assign a channel name in our channel map,
@@ -1243,7 +1244,7 @@ handleNewChannel_ permitPostpone switch nc member = do
                 -- least we can go ahead and register the channel and
                 -- handle events for it. That isn't very useful but it's
                 -- probably better than ignoring this entirely.
-                Nothing -> return $ Just $ channelName nc
+                Nothing -> return $ Just $ sanitizeUserText $ channelName nc
                 Just otherUserId ->
                     case usernameForUserId otherUserId st of
                         -- If we found a user ID in the channel name
@@ -1262,7 +1263,7 @@ handleNewChannel_ permitPostpone switch nc member = do
                         -- name (this has the same problems as above).
                         Nothing -> do
                             case permitPostpone of
-                                False -> return $ Just $ channelName nc
+                                False -> return $ Just $ sanitizeUserText $ channelName nc
                                 True -> do
                                     handleNewUsers $ Seq.singleton otherUserId
                                     doAsyncWith Normal $
@@ -1338,7 +1339,7 @@ runNotifyCommand post mentioned = do
         Nothing -> return ()
         Just cmd ->
             doAsyncWith Preempt $ do
-                let messageString = T.unpack $ postMessage post
+                let messageString = T.unpack $ sanitizeUserText $ postMessage post
                     notified = if mentioned then "1" else "2"
                     sender = T.unpack $ maybePostUsername st post
                 runLoggedCommand False outputChan (T.unpack cmd)

src/State/Editing.hs

@@ -33,6 +33,7 @@ import           Config
 import           Events.Keybindings
 import           State.Common
 import           Types
+import           Types.Common ( sanitizeChar, sanitizeUserText' )
 
 
 startMultilineEditing :: MH ()
@@ -70,7 +71,7 @@ invokeExternalEditor = do
                     Left _ -> do
                         postErrorMessageIO "Failed to decode file contents as UTF-8" st
                     Right t -> do
-                        let tmpLines = T.lines t
+                        let tmpLines = T.lines $ sanitizeUserText' t
                         return $ st & csEditState.cedEditor.editContentsL .~ (Z.textZipper tmpLines Nothing)
                                     & csEditState.cedMultiline .~ (length tmpLines > 1)
             Sys.ExitFailure _ -> return st
@@ -81,7 +82,7 @@ toggleMessagePreview = csShowMessagePreview %= not
 handlePaste :: BS.ByteString -> MH ()
 handlePaste bytes = do
   let pasteStr = T.pack (UTF8.toString bytes)
-  csEditState.cedEditor %= applyEdit (Z.insertMany pasteStr)
+  csEditState.cedEditor %= applyEdit (Z.insertMany (sanitizeUserText' pasteStr))
   contents <- use (csEditState.cedEditor.to getEditContents)
   case length contents > 1 of
       True -> startMultilineEditing
@@ -201,7 +202,8 @@ handleEditingInput e = do
                              csEditState.cedEditor %= applyEdit (Z.deleteChar >>> Z.deletePrevChar)
                          | otherwise -> backspace
 
-          EvKey (KChar ch) [] | editingPermitted st && smartBacktick && ch `elem` smartChars ->
+          EvKey (KChar ch) []
+            | editingPermitted st && smartBacktick && ch `elem` smartChars ->
               -- Smart char insertion:
               let doInsertChar = do
                     csEditState.cedEditor %= applyEdit (Z.insertChar ch)
@@ -214,7 +216,9 @@ handleEditingInput e = do
                       (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csEditState.cedEditor) ->
                         csEditState.cedEditor %= applyEdit Z.moveRight
                     | otherwise -> doInsertChar
-
+            | editingPermitted st -> do
+              csEditState.cedEditor %= applyEdit (Z.insertMany (sanitizeChar ch))
+              sendUserTypingAction
           _ | editingPermitted st -> do
               mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent e
               sendUserTypingAction

src/State/Setup.hs

@@ -35,6 +35,7 @@ import           TeamSelect
 import           Themes
 import           TimeUtils ( lookupLocalTimeZone )
 import           Types
+import           Types.Common
 import qualified Zipper as Z
 
 
@@ -117,7 +118,7 @@ setupState logFile initialConfig = do
           interactiveTeamSelection $ toList teams
       Just tName -> do
           let matchingTeam = listToMaybe $ filter matches $ toList teams
-              matches t = teamName t == tName
+              matches t = (sanitizeUserText $ teamName t) == tName
           case matchingTeam of
               Nothing -> interactiveTeamSelection (toList teams)
               Just t -> return t

src/TeamSelect.hs

@@ -17,6 +17,7 @@ import           System.Exit ( exitSuccess )
 import           Network.Mattermost.Types
 
 import           Markdown
+import           Types.Common
 
 
 type State = List () Team
@@ -61,7 +62,7 @@ teamSelect st =
 
 renderTeamItem :: Bool -> Team -> Widget ()
 renderTeamItem _ t =
-    padRight Max $ txt $ teamName t
+    padRight Max $ txt $ sanitizeUserText $ teamName t
 
 onEvent :: State -> BrickEvent () e -> EventM () (Next State)
 onEvent _  (VtyEvent (EvKey KEsc [])) = liftIO exitSuccess

src/Types.hs

@@ -239,6 +239,7 @@ import           Network.Mattermost.WebSocket ( WebsocketEvent )
 import           Completion ( Completer )
 import           InputHistory
 import           Types.Channels
+import           Types.Common
 import           Types.DirectionalSeq ( emptyDirSeq )
 import           Types.KeyEvents
 import           Types.Messages
@@ -364,7 +365,7 @@ mkNames myUser users chans =
                             [ (userUsername u, getId u) | u <- HM.elems users ]
             }
   where lookupChan n = [ c^.channelIdL
-                       | c <- toList chans, c^.channelNameL == n
+                       | c <- toList chans, (sanitizeUserText $ c^.channelNameL) == n
                        ]
 
 -- ** 'MMNames' Lenses

src/Types/Channels.hs

@@ -70,6 +70,7 @@ import           Types.Messages ( Messages, noMessages, addMessage
 import           Types.Posts ( ClientMessageType(UnknownGap)
                              , newClientMessage, postIsLeave, postIsJoin )
 import           Types.Users ( TypingUsers, noTypingUsers, addTypingUser )
+import           Types.Common
 
 
 -- * Channel representations
@@ -86,8 +87,8 @@ data ClientChannel = ClientChannel
 -- Get a channel's name, depending on its type
 preferredChannelName :: Channel -> Text
 preferredChannelName ch
-    | channelType ch == Group = channelDisplayName ch
-    | otherwise = channelName ch
+    | channelType ch == Group = sanitizeUserText $ channelDisplayName ch
+    | otherwise               = sanitizeUserText $ channelName ch
 
 data NewMessageIndicator =
     Hide
@@ -104,8 +105,8 @@ initialChannelInfo chan =
                    , _cdMentionCount           = 0
                    , _cdUpdated                = updated
                    , _cdName                   = preferredChannelName chan
-                   , _cdHeader                 = chan^.channelHeaderL
-                   , _cdPurpose                = chan^.channelPurposeL
+                   , _cdHeader                 = sanitizeUserText $ chan^.channelHeaderL
+                   , _cdPurpose                = sanitizeUserText $ chan^.channelPurposeL
                    , _cdType                   = chan^.channelTypeL
                    , _cdNotifyProps            = emptyChannelNotifyProps
                    , _cdTypingUsers            = noTypingUsers
@@ -121,8 +122,8 @@ channelInfoFromChannelWithData chan chanMember ci =
               v -> v
           , _cdUpdated          = updated
           , _cdName             = preferredChannelName chan
-          , _cdHeader           = (chan^.channelHeaderL)
-          , _cdPurpose          = (chan^.channelPurposeL)
+          , _cdHeader           = (sanitizeUserText $ chan^.channelHeaderL)
+          , _cdPurpose          = (sanitizeUserText $ chan^.channelPurposeL)
           , _cdType             = (chan^.channelTypeL)
           , _cdMentionCount     = chanMember^.to channelMemberMentionCount
           , _cdNotifyProps      = chanMember^.to channelMemberNotifyProps
@@ -311,7 +312,7 @@ updateNewMessageIndicator m =
 -- whether a channel is in fact that channel, even if the user has
 -- changed its display name.
 isTownSquare :: Channel -> Bool
-isTownSquare c = c^.channelNameL == "town-square"
+isTownSquare c = (sanitizeUserText $ c^.channelNameL) == "town-square"
 
 channelDeleted :: Channel -> Bool
 channelDeleted c = c^.channelDeleteAtL > c^.channelCreateAtL

src/Types/Common.hs

@@ -0,0 +1,26 @@
+module Types.Common
+  ( sanitizeUserText
+  , sanitizeUserText'
+  , sanitizeChar
+  )
+where
+
+import Prelude ()
+import Prelude.MH
+
+import qualified Data.Text as T
+
+import Network.Mattermost.Types ( UserText, unsafeUserText )
+
+sanitizeUserText :: UserText -> T.Text
+sanitizeUserText = sanitizeUserText' . unsafeUserText
+
+sanitizeUserText' :: T.Text -> T.Text
+sanitizeUserText' t =
+    T.replace "\ESC" "<ESC>" $
+    T.replace "\t" " " t
+
+sanitizeChar :: Char -> T.Text
+sanitizeChar '\ESC' = "<ESC>"
+sanitizeChar '\t' = " "
+sanitizeChar c = T.singleton c

src/Types/Posts.hs

@@ -58,6 +58,8 @@ import           Lens.Micro.Platform ( makeLenses )
 import           Network.Mattermost.Lenses
 import           Network.Mattermost.Types
 
+import           Types.Common
+
 
 -- * Client Messages
 
@@ -161,8 +163,8 @@ postIsTopicChange p = postType p == PostTypeHeaderChange
 postIsEmote :: Post -> Bool
 postIsEmote p =
     and [ p^.postPropsL.postPropsOverrideIconUrlL == Just (""::Text)
-        , ("*" `T.isPrefixOf` postMessage p)
-        , ("*" `T.isSuffixOf` postMessage p)
+        , ("*" `T.isPrefixOf` (sanitizeUserText $ postMessage p))
+        , ("*" `T.isSuffixOf` (sanitizeUserText $ postMessage p))
         ]
 
 -- | Find out whether a 'Post' is a user joining a channel
@@ -186,7 +188,7 @@ unEmote _ t = t
 --   'ParentId' if it has a known one.
 toClientPost :: Post -> Maybe PostId -> ClientPost
 toClientPost p parentId = ClientPost
-  { _cpText          = (getBlocks $ unEmote (postClientPostType p) $ postMessage p)
+  { _cpText          = (getBlocks $ unEmote (postClientPostType p) $ sanitizeUserText $ postMessage p)
                        <> getAttachmentText p
   , _cpUser          = postUserId p
   , _cpUserOverride  = p^.postPropsL.postPropsOverrideUsernameL