packages feed

matterhorn (empty) → 30802.1.0

raw patch · 42 files changed

+7147/−0 lines, 42 filesdep +Hclipdep +Uniquedep +basesetup-changed

Dependencies added: Hclip, Unique, base, base-compat, brick, bytestring, cheapskate, checkers, config-ini, connection, containers, directory, filepath, gitrev, hashable, mattermost-api, mattermost-api-qc, microlens-platform, mtl, process, quickcheck-text, stm, strict, string-conversions, tasty, tasty-hunit, tasty-quickcheck, temporary, text, text-zipper, time, transformers, unordered-containers, utf8-string, vector, vty, xdg-basedir

Files

+ LICENSE view
@@ -0,0 +1,12 @@+Copyright (c) 2016, Getty Ritter+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ matterhorn.cabal view
@@ -0,0 +1,137 @@+name:                matterhorn+version:             30802.1.0+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+                     features and information on getting started.+license:             BSD3+license-file:        LICENSE+author:              Getty Ritter <gdritter@galois.com>+maintainer:          Getty Ritter <gdritter@galois.com>+copyright:           ©2016-2017 AUTHORS.txt+category:            Chat+build-type:          Simple+cabal-version:       >= 1.12+tested-with:         GHC == 7.10.3, GHC == 8.0.1++source-repository    head+  type: git+  location: https://github.com/matterhorn-chat/matterhorn.git++executable matterhorn+  hs-source-dirs:      src+  main-is:             Main.hs+  other-modules:       Config+                       Command+                       Connection+                       Completion+                       State+                       State.Common+                       State.Editing+                       State.Setup+                       Zipper+                       Themes+                       Draw+                       Draw.Main+                       Draw.ShowHelp+                       Draw.LeaveChannelConfirm+                       Draw.DeleteChannelConfirm+                       Draw.JoinChannel+                       Draw.Util+                       InputHistory+                       IOUtil+                       Events+                       Events.ShowHelp+                       Events.MessageSelect+                       Events.Main+                       Events.JoinChannel+                       Events.ChannelScroll+                       Events.ChannelSelect+                       Events.UrlSelect+                       Events.LeaveChannelConfirm+                       Events.DeleteChannelConfirm+                       Types+                       Types.Messages+                       Types.Posts+                       FilePaths+                       TeamSelect+                       Login+                       Markdown+                       Options+                       Paths_matterhorn+  default-extensions:  OverloadedStrings,+                       ScopedTypeVariables+  ghc-options:         -Wall -threaded+  build-depends:       base >=4.8 && <5+                     , mattermost-api >= 30802.1.0+                     , base-compat+                     , unordered-containers+                     , containers >= 0.5.7+                     , connection+                     , text+                     , bytestring+                     , stm+                     , config-ini >= 0.1.2+                     , process+                     , microlens-platform+                     , brick >= 0.17+                     , vty >= 5.15.1+                     , transformers+                     , text-zipper >= 0.10+                     , time >= 1.6+                     , xdg-basedir+                     , filepath+                     , directory+                     , vector < 0.12+                     , strict+                     , hashable+                     , cheapskate+                     , utf8-string+                     , temporary+                     , gitrev+                     , Hclip+                     , mtl+  default-language:    Haskell2010++test-suite test_messages+  type:               exitcode-stdio-1.0+  main-is:            test_messages.hs+  default-language:   Haskell2010+  default-extensions: OverloadedStrings+                    , ScopedTypeVariables+  ghc-options:        -Wall -fno-warn-orphans+  hs-source-dirs:     src, test+  build-depends:      base >=4.7 && <5+                    , base-compat+                    , brick >= 0.17+                    , bytestring+                    , cheapskate+                    , checkers+                    , config-ini >= 0.1.2+                    , connection+                    , containers >= 0.5.7+                    , directory+                    , filepath+                    , hashable+                    , Hclip+                    , mattermost-api >= 30802.0.0+                    , mattermost-api-qc >= 30802.1.0+                    , microlens-platform+                    , mtl+                    , process+                    , quickcheck-text+                    , stm+                    , strict+                    , string-conversions+                    , tasty+                    , tasty-hunit+                    , tasty-quickcheck+                    , text+                    , text-zipper >= 0.10+                    , time >= 1.6+                    , transformers+                    , Unique+                    , unordered-containers+                    , vector < 0.12+                    , vty >= 5.15.1+                    , xdg-basedir
+ src/Command.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE GADTs #-}+module Command where++import Prelude ()+import Prelude.Compat++import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Data.Monoid ((<>))+import qualified Data.Text as T+import System.Exit (ExitCode(..))+import System.Process (readProcessWithExitCode)++import FilePaths (Script(..), getAllScripts, locateScriptPath)+import Lens.Micro.Platform (use)++import State+import State.Common+import State.Editing+import Types++printArgSpec :: CmdArgs a -> T.Text+printArgSpec NoArg = ""+printArgSpec (LineArg ts) = "[" <> ts <> "]"+printArgSpec (TokenArg t NoArg) = "[" <> t <> "]"+printArgSpec (TokenArg t rs) = "[" <> t <> "] " <> printArgSpec rs++matchArgs :: CmdArgs a -> [T.Text] -> Either T.Text a+matchArgs NoArg []  = return ()+matchArgs NoArg [t] = Left ("unexpected argument '" <> t <> "'")+matchArgs NoArg ts  = Left ("unexpected arguments '" <> T.unwords ts <> "'")+matchArgs (LineArg _) ts = return (T.unwords ts)+matchArgs rs@(TokenArg _ NoArg) [] = Left ("missing argument: " <> printArgSpec rs)+matchArgs rs@(TokenArg _ _) [] = Left ("missing arguments: " <> printArgSpec rs)+matchArgs (TokenArg _ rs) (t:ts) = (,) <$> pure t <*> matchArgs rs ts++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 channel"+    (LineArg "channel name") $ \ name ->+      createOrdinaryChannel name+  , Cmd "delete-channel" "Delete the current channel"+    NoArg $ \ () ->+      beginCurrentChannelDeleteConfirm+  , Cmd "members" "Show the current channel's members"+    NoArg $ \ () ->+      fetchCurrentChannelMembers+  , Cmd "leave" "Leave the current channel" NoArg $ \ () ->+      startLeaveCurrentChannel+  , Cmd "join" "Join a channel" NoArg $ \ () ->+      startJoinChannel+  , Cmd "theme" "List the available themes" NoArg $ \ () ->+      listThemes+  , Cmd "theme" "Set the color theme"+    (TokenArg "theme" NoArg) $ \ (themeName, ()) ->+      setTheme themeName+  , Cmd "topic" "Set the current channel's topic"+    (LineArg "topic") $ \ p -> do+      when (not $ T.null p) $ do+          st <- use id+          liftIO $ setChannelTopic st p+  , Cmd "add-user" "Add a user to the current channel"+    (TokenArg "username" NoArg) $ \ (uname, ()) ->+        addUserToCurrentChannel uname+  , Cmd "focus" "Focus on a named channel"+    (TokenArg "channel" NoArg) $ \ (name, ()) ->+        changeChannel name+  , Cmd "help" "Show this help screen" NoArg $ \ _ ->+        showHelpScreen MainHelp+  , Cmd "help" "Show help about a particular topic"+      (TokenArg "topic" NoArg) $ \ (topic, ()) ->+        case topic of+          "main"    -> showHelpScreen MainHelp+          "scripts" -> showHelpScreen ScriptHelp+          _         -> do+            let msg = ("Unknown help topic: `" <> topic <> "`. " <>+                      "Available topics are:\n  - main\n  - scripts\n")+            postErrorMessage msg+  , Cmd "sh" "List the available shell scripts" NoArg $ \ () ->+      listScripts+  , Cmd "sh" "Run a prewritten shell script"+    (TokenArg "script" (LineArg "message")) $ \ (script, text) -> do+      fpMb <- liftIO $ locateScriptPath (T.unpack script)+      case fpMb of+        ScriptPath scriptPath -> do+          doAsyncWith Preempt $ runScript scriptPath text+        NonexecScriptPath scriptPath -> do+          let msg = ("The script `" <> T.pack scriptPath <> "` cannot be " <>+               "executed. Try running\n" <>+               "```\n" <>+               "$ chmod u+x " <> T.pack scriptPath <> "\n" <>+               "```\n" <>+               "to correct this error. " <> scriptHelpAddendum)+          postErrorMessage msg+        ScriptNotFound -> do+          let msg = ("No script named " <> script <> " was found")+          postErrorMessage msg+  , Cmd "me" "Send an emote message"+    (LineArg "message") $+    \msg -> execMMCommand "me" msg++  , Cmd "shrug" "Send a message followed by a shrug emoticon"+    (LineArg "message") $+    \msg -> execMMCommand "shrug" msg+  ]++scriptHelpAddendum :: T.Text+scriptHelpAddendum =+  "For more help with scripts, run the command\n" <>+  "```\n/help scripts\n```\n"++runScript :: FilePath -> T.Text -> IO (MH ())+runScript fp text = do+  (code, stdout, stderr) <- readProcessWithExitCode fp [] (T.unpack text)+  case code of+    ExitSuccess -> return $ do+      mode <- use (csEditState.cedEditMode)+      sendMessage mode (T.pack stdout)+    ExitFailure _ -> return $ do+      let msgText = "The script `" <> T.pack fp <> "` exited with a " <>+                    "non-zero exit code."+          msgText' = if stderr == ""+                       then msgText+                       else msgText <> " It also produced the " <>+                            "following output on stderr:\n~~~~~\n" <>+                            T.pack stderr <> "~~~~~\n" <> scriptHelpAddendum+      postErrorMessage msgText'++listScripts :: MH ()+listScripts = do+  (execs, nonexecs) <- liftIO getAllScripts+  let scripts = ("Available scripts are:\n" <>+                 mconcat [ "  - " <> T.pack cmd <> "\n"+                         | cmd <- execs+                         ])+  postInfoMessage scripts+  case nonexecs of+    [] -> return ()+    _  -> do+      let errMsg = ("Some non-executable script files are also " <>+                    "present. If you want to run these as scripts " <>+                    "in Matterhorn, mark them executable with \n" <>+                    "```\n" <>+                    "$ chmod u+x [script path]\n" <>+                    "```\n" <>+                    "\n" <>+                    mconcat [ "  - " <> T.pack cmd <> "\n"+                            | cmd <- nonexecs+                            ] <> "\n" <> scriptHelpAddendum)+      postErrorMessage errMsg++dispatchCommand :: T.Text -> MH ()+dispatchCommand cmd =+  case T.words cmd of+    (x:xs) | matchingCmds <- [ c | c@(Cmd name _ _ _) <- commandList+                             , name == x+                             ] -> go [] matchingCmds+      where go [] [] = do+              let msg = ("error running command /" <> x <> ":\n" <>+                         "no such command")+              postErrorMessage msg+            go errs [] = do+              let msg = ("error running command /" <> x <> ":\n" <>+                         mconcat [ "    " <> e | e <- errs ])+              postErrorMessage msg+            go errs (Cmd _ _ spec exe : cs) =+              case matchArgs spec xs of+                Left e -> go (e:errs) cs+                Right args -> exe args+    _ -> return ()
+ src/Completion.hs view
@@ -0,0 +1,63 @@+-- Heavily inspired by tab completion from glirc:+-- https://github.com/glguy/irc-core/blob/v2/src/Client/Commands/WordCompletion.hs+module Completion where++import           Prelude ()+import           Prelude.Compat++import           Control.Applicative ( (<|>) )+import           Control.Monad ( guard )+import           Data.Char ( isSpace )+import           Data.List ( find )+import qualified Data.Set as Set+import           Data.Set ( Set )+import qualified Data.Text as T++data Direction = Forwards | Backwards+  deriving (Read, Show, Eq, Ord)++search :: Direction+       -> T.Text       -- ^ prefix+       -> T.Text       -- ^ current match+       -> Set T.Text   -- ^ potential completions+       -> Maybe T.Text+search direction prefix current options+  | Just next <- advanceFun direction current options+  , prefix `T.isPrefixOf` next+  = Just next++  | otherwise = case direction of+    Backwards -> find (prefix `T.isPrefixOf`)+                      (Set.toDescList options)+    Forwards  -> do x <- Set.lookupGE prefix options+                    guard (prefix `T.isPrefixOf` x)+                    Just x+  where+  advanceFun Forwards  = Set.lookupGT+  advanceFun Backwards = Set.lookupLT++wordComplete :: Direction+             -> [T.Text]     -- ^ priority completions+             -> Set T.Text   -- ^ potential completions+             -> T.Text       -- ^ current prompt+             -> Maybe T.Text -- ^ previous search+             -> Maybe T.Text -- ^ completion+wordComplete direction hints options prompt previous = do+  let current = currentWord prompt+  guard (not (T.null current))+  case previous of+    Just pattern | pattern `T.isPrefixOf` current ->+      search direction pattern current options++    _ -> find (current `T.isPrefixOf`) hints <|>+         search direction current current options++-- | trim whitespace and do any other edits we need+-- to focus on the current word+currentWord :: T.Text -> T.Text+currentWord line+  = T.reverse+  $ T.takeWhile (not . isSpace)+  $ T.dropWhile (\x -> x==' ' || x==':')+  $ T.reverse+  $ line
+ src/Config.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE RecordWildCards #-}++module Config+  ( Config(..)+  , PasswordSource(..)+  , findConfig+  , getCredentials+  , defaultConfig+  ) where++import           Prelude ()+import           Prelude.Compat++import           Control.Applicative+import           Control.Monad.Trans.Except+import           Data.Ini.Config+import qualified Data.Text as T+import qualified Data.Text.IO as T+import           Data.Monoid ((<>))+import           System.Process (readProcess)++import           IOUtil+import           FilePaths+import           Types++defaultPort :: Int+defaultPort = 443++fromIni :: IniParser Config+fromIni = do+  section "mattermost" $ do+    configUser           <- fieldMb "user"+    configHost           <- fieldMb "host"+    configTeam           <- fieldMb "team"+    configPort           <- fieldDefOf "port" number (configPort defaultConfig)+    configTimeFormat     <- fieldMb "timeFormat"+    configDateFormat     <- fieldMb "dateFormat"+    configTheme          <- fieldMb "theme"+    configURLOpenCommand <- fieldMb "urlOpenCommand"+    configSmartBacktick  <- fieldFlagDef "smartbacktick"+      (configSmartBacktick defaultConfig)+    configShowMessagePreview <- fieldFlagDef "showMessagePreview"+      (configShowMessagePreview defaultConfig)+    configActivityBell <- fieldFlagDef "activityBell"+      (configActivityBell defaultConfig)+    configPass <- (Just . PasswordCommand <$> field "passcmd") <|>+                  (Just . PasswordString  <$> field "pass") <|>+                  pure Nothing+    return Config { .. }++defaultConfig :: Config+defaultConfig =+    Config { configUser               = Nothing+           , configHost               = Nothing+           , configTeam               = Nothing+           , configPort               = defaultPort+           , configPass               = Nothing+           , configTimeFormat         = Nothing+           , configDateFormat         = Nothing+           , configTheme              = Nothing+           , configSmartBacktick      = True+           , configURLOpenCommand     = Nothing+           , configActivityBell       = False+           , configShowMessagePreview = False+           }++findConfig :: Maybe FilePath -> IO (Either String Config)+findConfig Nothing = do+    cfg <- locateConfig configFileName+    case cfg of+        Nothing -> return $ Right defaultConfig+        Just path -> getConfig path+findConfig (Just path) = getConfig path++getConfig :: FilePath -> IO (Either String Config)+getConfig fp = runExceptT $ do+  t <- (convertIOException $ T.readFile fp) `catchE`+       (\e -> throwE $ "Could not read " <> show fp <> ": " <> e)+  case parseIniFile t fromIni of+    Left err -> do+      throwE $ "Unable to parse " ++ fp ++ ":" ++ err+    Right conf -> do+      actualPass <- case configPass conf of+        Just (PasswordCommand cmdString) -> do+          let (cmd:rest) = T.unpack <$> T.words cmdString+          output <- convertIOException (readProcess cmd rest "") `catchE`+                    (\e -> throwE $ "Could not execute password command: " <> e)+          return $ Just $ T.pack (takeWhile (/= '\n') output)+        Just (PasswordString pass) -> return $ Just pass+        Nothing -> return Nothing++      return conf { configPass = PasswordString <$> actualPass }++-- | Returns the hostname, username, and password from the config. Only+-- returns Just if all three have been provided. The idea is that if+-- this returns Nothing, we're missing at least some of these values.+getCredentials :: Config -> Maybe ConnectionInfo+getCredentials config = do+    pass <- configPass config+    passStr <- case pass of+        PasswordString p -> return p+        PasswordCommand _ ->+            error $ "BUG: unexpected credentials state: " <>+                    show (configPass config)++    ConnectionInfo <$> configHost config+                   <*> (pure $ configPort config)+                   <*> configUser config+                   <*> (pure passStr)
+ src/Connection.hs view
@@ -0,0 +1,40 @@+module Connection where++import           Prelude ()+import           Prelude.Compat++import           Brick.BChan+import           Control.Concurrent (forkIO, threadDelay)+import           Control.Concurrent.MVar+import           Control.Exception (SomeException, catch)+import           Control.Monad (void)+import           Lens.Micro.Platform++import           Network.Mattermost.WebSocket++import           Types++connectWebsockets :: ChatState -> IO ()+connectWebsockets st = do+  let shunt e = writeBChan (st^.csResources.crEventQueue) (WSEvent e)+  let runWS = mmWithWebSocket (st^.csSession) shunt $ \ _ -> do+                writeBChan (st^.csResources.crEventQueue) WebsocketConnect+                waitAndQuit st+  void $ forkIO $ runWS `catch` handleTimeout 1 st+                        `catch` handleError 5 st++waitAndQuit :: ChatState -> IO ()+waitAndQuit st =+  void (takeMVar (st^.csResources.crQuitCondition))++handleTimeout :: Int -> ChatState -> MMWebSocketTimeoutException -> IO ()+handleTimeout seconds st _ = reconnectAfter seconds st++handleError :: Int -> ChatState -> SomeException -> IO ()+handleError seconds st _ = reconnectAfter seconds st++reconnectAfter :: Int -> ChatState -> IO ()+reconnectAfter seconds st = do+  writeBChan (st^.csResources.crEventQueue) WebsocketDisconnect+  threadDelay (seconds * 1000 * 1000)+  writeBChan (st^.csResources.crEventQueue) RefreshWebsocketEvent
+ src/Draw.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PackageImports #-}+module Draw (draw) where++import Brick+import Lens.Micro.Platform ((^.))++import Types+import Draw.Main+import Draw.ShowHelp+import Draw.LeaveChannelConfirm+import Draw.DeleteChannelConfirm+import Draw.JoinChannel++draw :: ChatState -> [Widget Name]+draw st =+    case st^.csMode of+        Main                       -> drawMain st+        ChannelScroll              -> drawMain st+        UrlSelect                  -> drawMain st+        ShowHelp screen            -> drawShowHelp screen st+        ChannelSelect              -> drawMain st+        LeaveChannelConfirm        -> drawLeaveChannelConfirm st+        JoinChannel                -> drawJoinChannel st+        MessageSelect              -> drawMain st+        MessageSelectDeleteConfirm -> drawMain st+        DeleteChannelConfirm       -> drawDeleteChannelConfirm st
+ src/Draw/DeleteChannelConfirm.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}+module Draw.DeleteChannelConfirm+    ( drawDeleteChannelConfirm+    )+where++import Prelude ()+import Prelude.Compat++import Brick+import Brick.Widgets.Center+import Brick.Widgets.Border+import Lens.Micro.Platform ((^.))++import Types+import Themes+import Draw.Main++drawDeleteChannelConfirm :: ChatState -> [Widget Name]+drawDeleteChannelConfirm st =+    confirmBox st : (forceAttr "invalid" <$> drawMain st)++confirmBox :: ChatState -> Widget Name+confirmBox st =+    let cName = st^.csCurrentChannel.ccInfo.cdName+    in centerLayer $ hLimit 50 $ vLimit 15 $+       withDefAttr dialogAttr $+       borderWithLabel (txt "Confirm Delete Channel") $+       vBox [ padBottom (Pad 1) $ hCenter $ txt "Are you sure you want to delete this channel?"+            , padBottom (Pad 1) $ hCenter $ withDefAttr dialogEmphAttr $ txt cName+            , hCenter $ txt "Press " <+> (withDefAttr dialogEmphAttr $ txt "Y") <+> txt " to delete the channel"+            , hCenter $ txt "or any other key to cancel."+            ]
+ src/Draw/JoinChannel.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}+module Draw.JoinChannel+    ( drawJoinChannel+    )+where++import Prelude ()+import Prelude.Compat++import Brick+import Brick.Widgets.List+import Brick.Widgets.Center+import Brick.Widgets.Border+import Data.Monoid ((<>))+import Lens.Micro.Platform ((^.))+import qualified Data.Vector as V++import Network.Mattermost (Channel)+import Network.Mattermost.Lenses (channelDisplayNameL, channelNameL)++import Types+import Themes+import Draw.Main++drawJoinChannel :: ChatState -> [Widget Name]+drawJoinChannel st = joinChannelBox st : (forceAttr "invalid" <$> drawMain st)++joinChannelBox :: ChatState -> Widget Name+joinChannelBox st =+    let chList = case st^.csJoinChannelList of+          Nothing -> center $ withDefAttr dialogEmphAttr $ txt "[Loading channel list]"+          Just chanList -> renderList renderJoinListItem True chanList+        highlight = withDefAttr dialogEmphAttr+        cur = maybe 0 ((+1) . fst) (listSelectedElement =<< st^.csJoinChannelList)+        len = maybe 0 (\l -> V.length $ l^.listElementsL) $ st^.csJoinChannelList+    in centerLayer $+       vLimit 20 $+       hLimit 60 $+       withDefAttr dialogAttr $+       borderWithLabel (txt "Join Channel") $+       vBox [ chList+            , hBorderWithLabel (str $ (show cur) <> "/" <> (show len))+            , hCenter $ txt "Use " <+> (highlight $ txt "arrow keys") <+> txt " and " <+>+                        (highlight $ txt "Enter") <+> txt " to select a channel"+            , hCenter $ txt "to join or press " <+> (highlight $ txt "Esc") <+> txt " to cancel."+            ]++renderJoinListItem :: Bool -> Channel -> Widget Name+renderJoinListItem _ chan =+    padRight Max $ txt $ chan^.channelNameL <> " (" <> chan^.channelDisplayNameL <> ")"
+ src/Draw/LeaveChannelConfirm.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}+module Draw.LeaveChannelConfirm+    ( drawLeaveChannelConfirm+    )+where++import Prelude ()+import Prelude.Compat++import Brick+import Brick.Widgets.Center+import Brick.Widgets.Border+import Lens.Micro.Platform ((^.))++import Types+import Themes+import Draw.Main++drawLeaveChannelConfirm :: ChatState -> [Widget Name]+drawLeaveChannelConfirm st =+    confirmBox st : (forceAttr "invalid" <$> drawMain st)++confirmBox :: ChatState -> Widget Name+confirmBox st =+    let cName = st^.csCurrentChannel.ccInfo.cdName+    in centerLayer $ hLimit 50 $ vLimit 15 $+       withDefAttr dialogAttr $+       borderWithLabel (txt "Confirm Leave Channel") $+       vBox [ padBottom (Pad 1) $ hCenter $ txt "Are you sure you want to leave this channel?"+            , padBottom (Pad 1) $ hCenter $ withDefAttr dialogEmphAttr $ txt cName+            , hCenter $ txt "Press " <+> (withDefAttr dialogEmphAttr $ txt "Y") <+> txt " to leave the channel"+            , hCenter $ txt "or any other key to cancel."+            ]
+ src/Draw/Main.hs view
@@ -0,0 +1,619 @@+{-# LANGUAGE MultiWayIf #-}+module Draw.Main (drawMain) where++import           Prelude ()+import           Prelude.Compat++import           Brick+import           Brick.Widgets.Border+import           Brick.Widgets.Border.Style+import           Brick.Widgets.Center (hCenter)+import           Brick.Widgets.Edit (editContentsL, renderEditor, getEditContents)+import           Brick.Widgets.List (renderList)+import           Control.Arrow ((>>>))+import           Control.Monad (foldM)+import           Control.Monad.Trans.Reader (withReaderT)+import           Data.Time.Clock (UTCTime(..))+import           Data.Time.Calendar (fromGregorian)+import           Data.Time.Format ( formatTime+                                  , defaultTimeLocale )+import           Data.Time.LocalTime ( TimeZone, utcToLocalTime+                                     , localTimeToUTC, localDay+                                     , LocalTime(..), midnight )+import qualified Data.HashMap.Strict as HM+import qualified Data.Sequence as Seq+import qualified Data.Foldable as F+import           Data.HashMap.Strict ( HashMap )+import           Data.List (intersperse)+import qualified Data.Map.Strict as Map+import           Data.Maybe (listToMaybe, maybeToList, catMaybes, isJust)+import           Data.Monoid ((<>))+import qualified Data.Set as Set+import           Data.Text (Text)+import qualified Data.Text as T+import           Data.Text.Zipper (cursorPosition, insertChar, getText, gotoEOL)+import           Lens.Micro.Platform++import           Network.Mattermost+import           Network.Mattermost.Lenses++import qualified Graphics.Vty as Vty++import           Markdown+import           State+import           State.Common+import           Themes+import           Types+import           Types.Posts+import           Types.Messages+import           Draw.Util++renderChatMessage :: UserSet -> ChannelSet -> (UTCTime -> Widget Name) -> Message -> Widget Name+renderChatMessage uSet cSet renderTimeFunc msg =+    let m = renderMessage msg True uSet cSet+        msgAtch = if Seq.null (msg^.mAttachments)+          then emptyWidget+          else withDefAttr clientMessageAttr $ vBox+                 [ txt ("  [attached: `" <> a^.attachmentName <> "`]")+                 | a <- F.toList (msg^.mAttachments)+                 ]+        msgReac = if Map.null (msg^.mReactions)+          then emptyWidget+          else let renderR e 1 = " [" <> e <> "]"+                   renderR e n+                     | n > 1     = " [" <> e <> " " <> T.pack (show n) <> "]"+                     | otherwise = ""+                   reacMsg = Map.foldMapWithKey renderR (msg^.mReactions)+               in withDefAttr emojiAttr $ txt ("   " <> reacMsg)+        msgTxt =+          case msg^.mUserName of+            Just _+              | msg^.mType == CP Join || msg^.mType == CP Leave ->+                  withDefAttr clientMessageAttr m+              | otherwise -> m+            Nothing ->+                case msg^.mType of+                    C DateTransition -> withDefAttr dateTransitionAttr (hBorderWithLabel m)+                    C NewMessagesTransition -> withDefAttr newMessageTransitionAttr (hBorderWithLabel m)+                    C Error -> withDefAttr errorMessageAttr m+                    _ -> withDefAttr clientMessageAttr m+        fullMsg = msgTxt <=> msgAtch <=> msgReac+        maybeRenderTime w = renderTimeFunc (msg^.mDate) <+> txt " " <+> w+        maybeRenderTimeWith f = case msg^.mType of+            C DateTransition -> id+            C NewMessagesTransition -> id+            _ -> f+    in maybeRenderTimeWith maybeRenderTime fullMsg++channelListWidth :: Int+channelListWidth = 20++renderChannelList :: ChatState -> Widget Name+renderChannelList st = hLimit channelListWidth $ maybeViewport $+                       vBox $ concat $ renderChannelGroup st <$> channelGroups+    where+        -- Only render the channel list in a viewport if we're not in+        -- channel select mode, since we don't want or need the viewport+        -- state to be affected by channel select input.+        maybeViewport = if st^.csMode == ChannelSelect+                        then id+                        else viewport ChannelList Vertical+        channelGroups = [ ( "Channels"+                          , getOrdinaryChannels st+                          , st^.csChannelSelectChannelMatches+                          )+                        , ( "Users"+                          , getDmChannels st+                          , st^.csChannelSelectUserMatches+                          )+                        ]++renderChannelGroup :: ChatState+                   -> (T.Text, [ChannelListEntry], HM.HashMap T.Text ChannelSelectMatch)+                   -> [Widget Name]+renderChannelGroup st (groupName, entries, csMatches) =+    let header label = hBorderWithLabel $ withDefAttr channelListHeaderAttr $ txt label+    in header groupName : (renderChannelListEntry st csMatches <$> entries)++data ChannelListEntry =+    ChannelListEntry { entryChannelName :: T.Text+                     , entrySigil       :: T.Text+                     , entryLabel       :: T.Text+                     , entryMakeWidget  :: T.Text -> Widget Name+                     , entryHasUnread   :: Bool+                     , entryIsRecent    :: Bool+                     }++renderChannelListEntry :: ChatState+                       -> HM.HashMap T.Text ChannelSelectMatch+                       -> ChannelListEntry+                       -> Widget Name+renderChannelListEntry st csMatches entry =+    decorate $ decorateRecent $ padRight Max $+    entryMakeWidget entry $ entrySigil entry <> entryLabel entry+    where+    decorate = if | matches -> const $+                      let Just (ChannelSelectMatch preMatch inMatch postMatch) =+                                   HM.lookup (entryLabel entry) csMatches+                      in (txt $ entrySigil entry)+                          <+> txt preMatch+                          <+> (forceAttr channelSelectMatchAttr $ txt inMatch)+                          <+> txt postMatch+                  | isChanSelect &&+                    (not $ T.null $ st^.csChannelSelectString) -> const emptyWidget+                  | current ->+                      if isChanSelect+                      then forceAttr currentChannelNameAttr+                      else visible . forceAttr currentChannelNameAttr+                  | entryHasUnread entry ->+                      forceAttr unreadChannelAttr+                  | otherwise -> id++    decorateRecent = if entryIsRecent entry+                     then (<+> (withDefAttr recentMarkerAttr $ str "<"))+                     else id++    matches = isChanSelect && (HM.member (entryLabel entry) csMatches) &&+              (not $ T.null $ st^.csChannelSelectString)++    isChanSelect = st^.csMode == ChannelSelect+    current = entryChannelName entry == currentChannelName+    currentChannelName = st^.csCurrentChannel.ccInfo.cdName++getOrdinaryChannels :: ChatState -> [ChannelListEntry]+getOrdinaryChannels st =+    [ ChannelListEntry n sigil n txt unread recent+    | n <- (st ^. csNames . cnChans)+    , let Just chan = st ^. csNames . cnToChanId . at n+          unread = hasUnread st chan+          recent = Just chan == st^.csRecentChannel+          sigil = case st ^. csLastChannelInput . at chan of+            Nothing      -> T.singleton normalChannelSigil+            Just ("", _) -> T.singleton normalChannelSigil+            _            -> "»"+    ]++getDmChannels :: ChatState -> [ChannelListEntry]+getDmChannels st =+    [ ChannelListEntry cname sigil uname colorUsername' unread recent+    | u <- sortedUserList st+    , let colorUsername' =+            if | u^.uiStatus == Offline ->+                 withDefAttr clientMessageAttr . txt+               | otherwise ->+                 colorUsername+          sigil =+            case do { cId <- m_chanId; st^.csLastChannelInput.at cId } of+              Nothing      -> T.singleton $ userSigilFromInfo u+              Just ("", _) -> T.singleton $ userSigilFromInfo u+              _            -> "»"+          uname = u^.uiName+          cname = getDMChannelName (st^.csMe^.userIdL) (u^.uiId)+          recent = maybe False ((== st^.csRecentChannel) . Just) m_chanId+          m_chanId = st^.csNames.cnToChanId.at (u^.uiName)+          unread = maybe False (hasUnread st) m_chanId+       ]++previewFromInput :: T.Text -> T.Text -> Maybe Message+previewFromInput _ s | s == T.singleton cursorSentinel = Nothing+previewFromInput uname s =+    -- If it starts with a slash but not /me, this has no preview+    -- representation+    let isCommand = "/" `T.isPrefixOf` s+        isEmote = "/me " `T.isPrefixOf` s+        content = if isEmote+                  then T.stripStart $ T.drop 3 s+                  else s+        msgTy = if isEmote then CP Emote else CP NormalPost+    in if isCommand && not isEmote+       then Nothing+       else Just $ Message { _mText          = getBlocks content+                           , _mUserName      = Just uname+                           , _mDate          = UTCTime (fromGregorian 1970 1 1) 0+                           -- The date is not used for preview+                           -- rendering, but we need to provide one.+                           -- Ideally we'd just today's date, but the+                           -- rendering function is pure so we can't.+                           , _mType          = msgTy+                           , _mPending       = False+                           , _mDeleted       = False+                           , _mAttachments   = mempty+                           , _mInReplyToMsg  = NotAReply+                           , _mPostId        = Nothing+                           , _mReactions     = mempty+                           , _mOriginalPost  = Nothing+                           }++renderUserCommandBox :: UserSet -> ChannelSet -> ChatState -> Widget Name+renderUserCommandBox uSet cSet st =+    let prompt = txt $ case st^.csEditState.cedEditMode of+            Replying _ _ -> "reply> "+            Editing _    ->  "edit> "+            NewPost      ->      "> "+        inputBox = renderEditor True (st^.csCmdLine)+        curContents = getEditContents $ st^.csCmdLine+        multilineContent = length curContents > 1+        multilineHints =+            (borderElem bsHorizontal) <+>+            (str $ "[" <> (show $ (+1) $ fst $ cursorPosition $+                                  st^.csCmdLine.editContentsL) <>+                   "/" <> (show $ length curContents) <> "]") <+>+            (hBorderWithLabel $ withDefAttr clientEmphAttr $+             (str "In multi-line mode. Press M-e to finish."))++        replyDisplay = case st^.csEditState.cedEditMode of+            Replying msg _ ->+                let msgWithoutParent = msg & mInReplyToMsg .~ NotAReply+                in hBox [ replyArrow+                        , addEllipsis $ renderMessage msgWithoutParent True uSet cSet+                        ]+            _ -> emptyWidget++        commandBox = case st^.csEditState.cedMultiline of+            False ->+                let linesStr = if numLines == 1+                               then "line"+                               else "lines"+                    numLines = length curContents+                in vLimit 1 $+                   prompt <+> if multilineContent+                              then ((withDefAttr clientEmphAttr $+                                     str $ "[" <> show numLines <> " " <> linesStr <>+                                           "; Enter: send, M-e: edit, Backspace: cancel] ")) <+>+                                   (txt $ head curContents) <+>+                                   (showCursor MessageInput (Location (0,0)) $ str " ")+                              else inputBox+            True -> vLimit 5 inputBox <=> multilineHints+    in replyDisplay <=> commandBox++maxMessageHeight :: Int+maxMessageHeight = 200++renderSingleMessage :: ChatState -> UserSet -> ChannelSet -> Message -> Widget Name+renderSingleMessage st uSet cSet = renderChatMessage uSet cSet (withBrackets . renderTime st)++renderCurrentChannelDisplay :: UserSet -> ChannelSet -> ChatState -> Widget Name+renderCurrentChannelDisplay uSet cSet st = (header <+> conn) <=> messages+    where+    conn = case st^.csConnectionStatus of+      Connected -> emptyWidget+      Disconnected -> withDefAttr errorMessageAttr (str "[NOT CONNECTED]")+    header = withDefAttr channelHeaderAttr $+             padRight Max $+             case T.null topicStr of+                 True -> case chnType of+                   Direct ->+                     case findUserByDMChannelName (st^.usrMap)+                                                  chnName+                                                  (st^.csMe^.userIdL) of+                       Nothing -> txt $ mkChannelName (chan^.ccInfo)+                       Just u  -> colorUsername $ mkDMChannelName u+                   _        -> txt $ mkChannelName (chan^.ccInfo)+                 False -> renderText $+                          mkChannelName (chan^.ccInfo) <> " - " <> topicStr+    messages = body <+> txt " "++    body = chatText <=> case chan^.ccInfo.cdCurrentState of+      ChanUnloaded    -> withDefAttr clientMessageAttr $+                           txt "[Loading channel...]"+      ChanLoadPending -> withDefAttr clientMessageAttr $+                          txt "[Loading channel...]"+      ChanRefreshing  -> withDefAttr clientMessageAttr $+                           txt "[Refreshing channel...]"+      _               -> emptyWidget++    chatText = case st^.csMode of+        ChannelScroll ->+            viewport (ChannelMessages cId) Vertical $+            cached (ChannelMessages cId) $+            vBox $ (withDefAttr loadMoreAttr $ hCenter $+                    str "<< Press C-b to load more messages >>") :+                   (F.toList $ renderSingleMessage st uSet cSet <$> channelMessages)+        MessageSelect ->+            renderMessagesWithSelect (st^.csMessageSelect) channelMessages+        MessageSelectDeleteConfirm ->+            renderMessagesWithSelect (st^.csMessageSelect) channelMessages+        _ -> renderLastMessages $ reverseMessages channelMessages++    renderMessagesWithSelect (MessageSelectState selPostId) msgs =+        -- In this case, we want to fill the message list with messages+        -- but use the post ID as a cursor. To do this efficiently we+        -- only want to render enough messages to fill the screen.+        --+        -- If the message area is H rows high, this actually renders at+        -- most 2H rows' worth of messages and then does the appropriate+        -- cropping. This way we can simplify the math needed to figure+        -- out how to crop while bounding the number of messages we+        -- render around the cursor.+        --+        -- First, we sanity-check the application state because under+        -- some conditions, the selected message might be gone (e.g.+        -- deleted).+        let (s, (before, after)) = splitMessages selPostId msgs+        in case s of+             Nothing -> renderLastMessages before+             Just m -> unsafeMessageSelectList before after m++    unsafeMessageSelectList before after curMsg = Widget Greedy Greedy $ do+        ctx <- getContext++        -- Render the message associated with the current post ID.+        curMsgResult <- withReaderT relaxHeight $ render $+            forceAttr messageSelectAttr $+            padRight Max $ renderSingleMessage st uSet cSet curMsg++        let targetHeight = ctx^.availHeightL+            upperHeight = targetHeight `div` 2+            lowerHeight = targetHeight - upperHeight++            lowerRender = render1HLimit Vty.vertJoin targetHeight+            upperRender = render1HLimit (flip Vty.vertJoin) targetHeight++        lowerHalf <- foldM lowerRender Vty.emptyImage after+        upperHalf <- foldM upperRender Vty.emptyImage before++        let curHeight = Vty.imageHeight $ curMsgResult^.imageL+            uncropped = upperHalf Vty.<-> curMsgResult^.imageL Vty.<-> lowerHalf+            img = if Vty.imageHeight lowerHalf < (lowerHeight - curHeight)+                  then Vty.cropTop targetHeight uncropped+                  else if Vty.imageHeight upperHalf < upperHeight+                       then Vty.cropBottom targetHeight uncropped+                       else Vty.cropTop upperHeight upperHalf Vty.<->+                            curMsgResult^.imageL Vty.<->+                            (if curHeight < lowerHeight+                             then Vty.cropBottom (lowerHeight - curHeight) lowerHalf+                             else Vty.cropBottom lowerHeight lowerHalf)++        return $ emptyResult & imageL .~ img++    channelMessages =+        insertTransitions (getDateFormat st)+                          (st ^. timeZone)+                          (getNewMessageCutoff cId st)+                          (getMessageListing cId st)++    renderLastMessages :: RetrogradeMessages -> Widget Name+    renderLastMessages msgs =+        Widget Greedy Greedy $ do+            ctx <- getContext+            let targetHeight = ctx^.availHeightL+                renderBuild = render1HLimit (flip Vty.vertJoin) targetHeight+            img <- foldM renderBuild Vty.emptyImage msgs+            return $ emptyResult & imageL .~ (Vty.cropTop targetHeight img)++    relaxHeight c = c & availHeightL .~ (max maxMessageHeight (c^.availHeightL))++    render1HLimit fjoin lim img msg = if Vty.imageHeight img >= lim+                                      then return img+                                      else fjoin img <$> render1 msg++    render1 :: Message -> RenderM Name Vty.Image+    render1 msg = case msg^.mDeleted of+                    True -> return Vty.emptyImage+                    False -> do+                      r <- withReaderT relaxHeight $+                           render $ padRight Max $+                                  renderSingleMessage st uSet cSet msg+                      return $ r^.imageL++    cId = st^.csCurrentChannelId+    chan = st^.csCurrentChannel+    chnName = chan^.ccInfo.cdName+    chnType = chan^.ccInfo.cdType+    topicStr = chan^.ccInfo.cdHeader++getMessageListing :: ChannelId -> ChatState -> Messages+getMessageListing cId st =+    st ^. msgMap . ix cId . ccContents . cdMessages++insertTransitions :: Text -> TimeZone -> Maybe UTCTime -> Messages -> Messages+insertTransitions datefmt tz cutoff ms = foldr addMessage ms transitions+    where transitions = newMessagesT <> dateT+          newMessagesT = case cutoff of+                           Nothing -> []+                           Just t -> [newMessagesMsg $ justBefore t]+          dateT = fmap dateMsg dateRange+          dateRange = let dr = foldr checkDateChange [] ms+                      in if length dr > 1 then tail dr else []+          checkDateChange m [] = [dayStart $ m^.mDate]+          checkDateChange m dl = if dayOf (head dl) == dayOf (m^.mDate)+                                 then dl+                                 else dayStart (m^.mDate) : dl+          dayOf = localDay . utcToLocalTime tz+          dayStart dt = localTimeToUTC tz $ LocalTime (dayOf dt) $ midnight+          justBefore (UTCTime d t) = UTCTime d $ pred t+          dateMsg d = Message (getBlocks (T.pack $ formatTime defaultTimeLocale+                                          (T.unpack datefmt)+                                          (utcToLocalTime tz d)))+                      Nothing d (C DateTransition) False False+                      Seq.empty NotAReply Nothing mempty Nothing+          newMessagesMsg d = Message (getBlocks (T.pack "New Messages"))+                             Nothing d (C NewMessagesTransition)+                             False False Seq.empty NotAReply+                             Nothing mempty Nothing+++findUserByDMChannelName :: HashMap UserId UserInfo+                        -> T.Text -- ^ the dm channel name+                        -> UserId -- ^ me+                        -> Maybe UserInfo -- ^ you+findUserByDMChannelName userMap dmchan me = listToMaybe+  [ user+  | u <- HM.keys userMap+  , getDMChannelName me u == dmchan+  , user <- maybeToList (HM.lookup u userMap)+  ]++renderChannelSelect :: ChatState -> Widget Name+renderChannelSelect st =+    withDefAttr channelSelectPromptAttr $+    (txt "Switch to channel: ") <+>+     (showCursor ChannelSelectString (Location (T.length $ st^.csChannelSelectString, 0)) $+      txt $+      (if T.null $ st^.csChannelSelectString+       then " "+       else st^.csChannelSelectString))++drawMain :: ChatState -> [Widget Name]+drawMain st = [mainInterface st]++messageSelectBottomBar :: ChatState -> Widget Name+messageSelectBottomBar st =+    let optionStr = if null usableOptions+                    then "(no actions available for this message)"+                    else T.intercalate " " usableOptions+        usableOptions = catMaybes $ mkOption <$> options+        mkOption (f, k, desc) = if f postMsg+                                then Just $ k <> ":" <> desc+                                else Nothing+        numURLs = Seq.length $ msgURLs postMsg+        s = if numURLs == 1 then "" else "s"+        hasURLs = numURLs > 0+        openUrlsMsg = "open " <> (T.pack $ show numURLs) <> " URL" <> s+        hasVerb = isJust (findVerbatimChunk (postMsg^.mText))+        options = [ (isReplyable, "r", "reply")+                  , (\m -> isMine st m && isEditable m, "e", "edit")+                  , (\m -> isMine st m && isDeletable m, "d", "delete")+                  , (const hasURLs, "o", openUrlsMsg)+                  , (const hasVerb, "y", "yank")+                  ]+        Just postMsg = getSelectedMessage st++    in hBox [ borderElem bsHorizontal+            , txt "["+            , withDefAttr messageSelectStatusAttr $+              txt $ "Message select: " <> optionStr+            , txt "]"+            , hBorder+            ]++completionAlternatives :: ChatState -> Widget Name+completionAlternatives st =+    let alternatives = intersperse (txt " ") $ mkAlternative <$> st^.csEditState.cedCompletionAlternatives+        mkAlternative val = let format = if val == st^.csEditState.cedCurrentAlternative+                                         then visible . withDefAttr completionAlternativeCurrentAttr+                                         else id+                            in format $ txt val+    in hBox [ borderElem bsHorizontal+            , txt "["+            , withDefAttr completionAlternativeListAttr $+              vLimit 1 $ viewport CompletionAlternatives Horizontal $ hBox alternatives+            , txt "]"+            , borderElem bsHorizontal+            ]++previewMaxHeight :: Int+previewMaxHeight = 5++maybePreviewViewport :: Widget Name -> Widget Name+maybePreviewViewport w =+    Widget Greedy Fixed $ do+        result <- render w+        case (Vty.imageHeight $ result^.imageL) > previewMaxHeight of+            False -> return result+            True ->+                render $ vLimit previewMaxHeight $ viewport MessagePreviewViewport Vertical $+                         (Widget Fixed Fixed $ return result)++inputPreview :: UserSet -> ChannelSet -> ChatState -> Widget Name+inputPreview uSet cSet st | not $ st^.csShowMessagePreview = emptyWidget+                          | otherwise = thePreview+    where+    uname = st^.csMe.userUsernameL+    -- Insert a cursor sentinel into the input text just before+    -- rendering the preview. We use the inserted sentinel (which is+    -- not rendered) to get brick to ensure that the line the cursor is+    -- on is visible in the preview viewport. We put the sentinel at+    -- the *end* of the line because it will still influence markdown+    -- parsing and can create undesirable/confusing churn in the+    -- rendering while the cursor moves around. If the cursor is at the+    -- end of whatever line the user is editing, that is very unlikely+    -- to be a problem.+    curContents = getText $ (gotoEOL >>> insertChar cursorSentinel) $+                  st^.csCmdLine.editContentsL+    curStr = T.intercalate "\n" curContents+    previewMsg = previewFromInput uname curStr+    thePreview = let noPreview = str "(No preview)"+                     msgPreview = case previewMsg of+                       Nothing -> noPreview+                       Just pm -> if T.null curStr+                                  then noPreview+                                  else renderMessage pm True uSet cSet+                 in (maybePreviewViewport msgPreview) <=>+                    hBorderWithLabel (withDefAttr clientEmphAttr $ str "[Preview ↑]")++userInputArea :: UserSet -> ChannelSet -> ChatState -> Widget Name+userInputArea uSet cSet st =+    case st^.csMode of+        ChannelSelect -> renderChannelSelect st+        UrlSelect     -> hCenter $ hBox [ txt "Press "+                                        , withDefAttr clientEmphAttr $ txt "Enter"+                                        , txt " to open the selected URL or "+                                        , withDefAttr clientEmphAttr $ txt "Escape"+                                        , txt " to cancel."+                                        ]+        ChannelScroll -> hCenter $ hBox [ txt "Press "+                                        , withDefAttr clientEmphAttr $ txt "Escape"+                                        , txt " to stop scrolling and resume chatting."+                                        ]+        MessageSelectDeleteConfirm -> renderDeleteConfirm+        _             -> renderUserCommandBox uSet cSet st++renderDeleteConfirm :: Widget Name+renderDeleteConfirm =+    hCenter $ txt "Are you sure you want to delete the selected message? (y/n)"++mainInterface :: ChatState -> Widget Name+mainInterface st =+    (renderChannelList st <+> vBorder <+> mainDisplay)+      <=> bottomBorder+      <=> inputPreview uSet cSet st+      <=> userInputArea uSet cSet st+    where+    mainDisplay = case st^.csMode of+        UrlSelect -> renderUrlList st+        _         -> maybeSubdue $ renderCurrentChannelDisplay uSet cSet st+    uSet = Set.fromList (map _uiName (HM.elems (st^.usrMap)))+    cSet = Set.fromList (_cdName <$> _ccInfo <$> (HM.elems $ st^.msgMap))++    bottomBorder = case st^.csMode of+        MessageSelect -> messageSelectBottomBar st+        _ -> case st^.csCurrentCompletion of+            Just _ | length (st^.csEditState.cedCompletionAlternatives) > 1 -> completionAlternatives st+            _ -> maybeSubdue $ hLimit channelListWidth hBorder <+> borderElem bsIntersectB <+> hBorder++    maybeSubdue = if st^.csMode == ChannelSelect+                  then forceAttr ""+                  else id++renderUrlList :: ChatState -> Widget Name+renderUrlList st =+    header <=> urlDisplay+    where+        header = withDefAttr channelHeaderAttr $ vLimit 1 $+                 (txt $ "URLs: " <> (st^.csCurrentChannel.ccInfo.cdName)) <+>+                 fill ' '++        urlDisplay = if F.length urls == 0+                     then str "No URLs found in this channel."+                     else renderList renderItem True urls++        urls = st^.csUrlList++        renderItem sel link =+          let time = link^.linkTime+          in attr sel $ vLimit 2 $+            (vLimit 1 $+             hBox [ colorUsername (link^.linkUser)+                  , if link^.linkName == link^.linkURL+                      then emptyWidget+                      else (txt ": " <+> (renderText $ link^.linkName))+                  , fill ' '+                  , renderDate st time+                  , str " "+                  , renderTime st time+                  ] ) <=>+            (vLimit 1 (renderText $ link^.linkURL))++        attr True = forceAttr "urlListSelectedAttr"+        attr False = id
+ src/Draw/ShowHelp.hs view
@@ -0,0 +1,180 @@+module Draw.ShowHelp (drawShowHelp) where++import Prelude ()+import Prelude.Compat++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Center (hCenter, centerLayer)+import Lens.Micro.Platform+import Data.List (sortBy)+import Data.Ord (comparing)+import qualified Data.Text as T+import Data.Monoid ((<>))+import qualified Graphics.Vty as Vty+import Network.Mattermost.Version (mmApiVersion)++import Themes+import Types+import Command+import Events.ShowHelp+import Events.ChannelScroll+import Events.ChannelSelect+import Events.UrlSelect+import Events.Main+import Events.MessageSelect+import State.Editing (editingKeybindings)+import Markdown (renderText)+import Options (mhVersion)++drawShowHelp :: HelpScreen -> ChatState -> [Widget Name]+drawShowHelp screen = const [helpBox name widget]+  where (name, widget) = case screen of+          MainHelp   -> (HelpText,       mainHelp)+          ScriptHelp -> (ScriptHelpText, scriptHelp)++withMargins :: (Int, Int) -> Widget a -> Widget a+withMargins (hMargin, vMargin) w =+    Widget (hSize w) (vSize w) $ do+        ctx <- getContext+        let wl = ctx^.availWidthL - (2 * hMargin)+            hl = ctx^.availHeightL - (2 * vMargin)+        render $ hLimit wl $ vLimit hl w++keybindSections :: [(T.Text, [Keybinding])]+keybindSections =+    [ ("This Help Page", helpKeybindings)+    , ("Main Interface", mainKeybindings)+    , ("Channel Select Mode", channelSelectKeybindings)+    , ("URL Select Mode", urlSelectKeybindings)+    , ("Channel Scroll Mode", channelScrollKeybindings)+    , ("Message Select Mode", messageSelectKeybindings)+    , ("Text Editing", editingKeybindings)+    ]++helpBox :: Name -> Widget Name -> Widget Name+helpBox n helpText =+    centerLayer $ withMargins (2, 1) $+      (withDefAttr helpAttr $ borderWithLabel (withDefAttr helpEmphAttr $ txt "Matterhorn Help") $+       (viewport HelpViewport Vertical $ cached n helpText)) <=>+      quitMessage+    where+    quitMessage = padTop (Pad 1) $ hCenter $ txt "Press Esc to exit the help screen."++mainHelp :: Widget Name+mainHelp = commandHelp+  where+    commandHelp = vBox $ [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ str mhVersion+                         , hCenter $ withDefAttr helpEmphAttr $ str mmApiVersion+                         , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Commands"+                         , mkCommandHelpText $ sortBy (comparing commandName) commandList+                         ] <>+                         (mkKeybindingHelp <$> keybindSections)++    mkCommandHelpText :: [Cmd] -> Widget Name+    mkCommandHelpText cs =+      let helpInfo = [ (info, desc)+                     | Cmd cmd desc args _ <- cs+                     , let argSpec = printArgSpec args+                           info = T.cons '/' cmd <> " " <> argSpec+                     ]+          commandNameWidth = 4 + (maximum $ T.length <$> fst <$> helpInfo)+      in hCenter $+         vBox [ (withDefAttr helpEmphAttr $ txt $ padTo commandNameWidth info) <+> renderText desc+              | (info, desc) <- helpInfo+              ]++kbColumnWidth :: Int+kbColumnWidth = 12++kbDescColumnWidth :: Int+kbDescColumnWidth = 60++mkKeybindingHelp :: (T.Text, [Keybinding]) -> Widget Name+mkKeybindingHelp (sectionName, kbs) =+    (hCenter $ padTop (Pad 1) $ withDefAttr helpEmphAttr $ txt $ "Keybindings: " <> sectionName) <=>+    (hCenter $ vBox $ mkKeybindHelp <$> (sortBy (comparing (ppKbEvent.kbEvent)) kbs))++mkKeybindHelp :: Keybinding -> Widget Name+mkKeybindHelp (KB desc ev _) =+    (withDefAttr helpEmphAttr $ txt $ padTo kbColumnWidth $ ppKbEvent ev) <+>+    (vLimit 1 $ hLimit kbDescColumnWidth $ renderText desc <+> fill ' ')++ppKbEvent :: Vty.Event -> T.Text+ppKbEvent (Vty.EvKey k mods) =+    T.intercalate "-" $ (ppMod <$> mods) <> [ppKey k]+ppKbEvent _ = "<????>"++ppKey :: Vty.Key -> T.Text+ppKey (Vty.KChar c)   = ppChar c+ppKey (Vty.KFun n)    = "F" <> (T.pack $ show n)+ppKey Vty.KBackTab    = "S-Tab"+ppKey Vty.KEsc        = "Esc"+ppKey Vty.KBS         = "Backspace"+ppKey Vty.KEnter      = "Enter"+ppKey Vty.KUp         = "Up"+ppKey Vty.KDown       = "Down"+ppKey Vty.KLeft       = "Left"+ppKey Vty.KRight      = "Right"+ppKey Vty.KHome       = "Home"+ppKey Vty.KEnd        = "End"+ppKey Vty.KPageUp     = "PgUp"+ppKey Vty.KPageDown   = "PgDown"+ppKey Vty.KDel        = "Del"+ppKey _               = "???"++ppChar :: Char -> T.Text+ppChar '\t' = "Tab"+ppChar ' '  = "Space"+ppChar c    = T.singleton c++ppMod :: Vty.Modifier -> T.Text+ppMod Vty.MMeta  = "M"+ppMod Vty.MAlt   = "A"+ppMod Vty.MCtrl  = "C"+ppMod Vty.MShift = "S"++padTo :: Int -> T.Text -> T.Text+padTo n s = s <> T.replicate (n - T.length s) " "++scriptHelp :: Widget Name+scriptHelp = vBox+  [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Using Scripts"+  , padTop (Pad 1) $ hCenter $ hLimit 100 $ vBox scriptHelpText+  ]+  where scriptHelpText = map (padTop (Pad 1) . renderText . mconcat)+          [ [ "Matterhorn has a special feature that allows you to use "+             , "prewritten shell scripts to preprocess messages. "+             , "For example, this can allow you to run various filters over "+             , "your written text, do certain kinds of automated formatting, "+             , "or just automatically cowsay-ify a message.\n" ]+           , [ "These scripts can be any kind of executable file, "+             , "as long as the file lives in "+             , "*~/.config/matterhorn/scripts* (unless you've explicitly "+             , "moved your XDG configuration directory elsewhere). "+             , "Those executables are given no arguments "+             , "on the command line and are passed your typed message on "+             , "*stdin*; whatever they produce on *stdout* is sent "+             , "as a message. If the script exits successfully, then everything "+             , "that appeared on *stderr* is discarded; if it instead exits with "+             , "a failing exit code, your message is *not* sent, and you are "+             , "presented with whatever was printed on stderr as a "+             , "local error message.\n" ]+           , [ "To run a script, simply type\n" ]+           , [ "> *> /sh [script-name] [my-message]*\n" ]+           , [ "And the script named *[script-name]* will be invoked with "+             , "the text of *[my-message]*. If the script does not exist, "+             , "or if it exists but is not marked as executable, you'll be "+             , "presented with an appropriate error message.\n" ]+           , [ "For example, if you want to use a basic script to "+             , "automatically ROT13 your message, you can write a shell "+             , "script using the standard Unix *tr* utility, like this:\n" ]+           , [ "> *#!/bin/bash -e*\n"+             , "> *tr '[A-Za-z]' '[N-ZA-Mn-za-m]'*\n\n" ]+           , [ "Move this script to *~/.config/matterhorn/scripts/rot13* "+             , "and be sure it's executable with\n" ]+           , [ "> *$ chmod u+x ~/.config/matterhorn/scripts/rot13*\n\n" ]+           , [ "after which you can send ROT13 messages with the "+             , "Matterhorn command " ]+           , [ "> *> /sh rot13 Hello, world!*\n" ]+           ]
+ src/Draw/Util.hs view
@@ -0,0 +1,62 @@+module Draw.Util where++import Prelude ()+import Prelude.Compat++import Brick+import qualified Data.Text as T+import Data.Time.Clock (UTCTime(..))+import Data.Time.Format (formatTime, defaultTimeLocale)+import Data.Time.LocalTime (TimeZone, utcToLocalTime)+import Lens.Micro.Platform+import Network.Mattermost++import Types+import Themes++defaultTimeFormat :: T.Text+defaultTimeFormat = "%R"++defaultDateFormat :: T.Text+defaultDateFormat = "%Y-%m-%d"++getTimeFormat :: ChatState -> T.Text+getTimeFormat st = maybe defaultTimeFormat id (st^.timeFormat)++getDateFormat :: ChatState -> T.Text+getDateFormat st = maybe defaultDateFormat id (st^.dateFormat)++renderTime :: ChatState -> UTCTime -> Widget Name+renderTime st = renderUTCTime (getTimeFormat st) (st^.timeZone)++renderDate :: ChatState -> UTCTime -> Widget Name+renderDate st = renderUTCTime (getDateFormat st) (st^.timeZone)++renderUTCTime :: T.Text -> TimeZone -> UTCTime -> Widget a+renderUTCTime fmt tz t =+    let timeStr = T.pack $ formatTime defaultTimeLocale (T.unpack fmt) (utcToLocalTime tz t)+    in if T.null fmt+       then emptyWidget+       else withDefAttr timeAttr (txt timeStr)++withBrackets :: Widget a -> Widget a+withBrackets w = str "[" <+> w <+> str "]"++userSigilFromInfo :: UserInfo -> Char+userSigilFromInfo u = case u^.uiStatus of+    Offline -> ' '+    Online  -> '+'+    Away    -> '-'+    Other _ -> '?'++mkChannelName :: ChannelInfo -> T.Text+mkChannelName c = T.cons sigil (c^.cdName)+  where sigil =  case c^.cdType of+          Private   -> '?'+          Ordinary  -> normalChannelSigil+          Group     -> normalChannelSigil+          Direct    -> userSigil+          _         -> '!'++mkDMChannelName :: UserInfo -> T.Text+mkDMChannelName u = T.cons (userSigilFromInfo u) (u^.uiName)
+ src/Events.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE MultiWayIf #-}+module Events where++import           Prelude ()+import           Prelude.Compat++import           Brick+import           Control.Monad.IO.Class (liftIO)+import qualified Data.Text as T+import           Data.Monoid ((<>))+import qualified Graphics.Vty as Vty+import           Lens.Micro.Platform++import           Network.Mattermost+import           Network.Mattermost.Lenses+import           Network.Mattermost.WebSocket++import           Connection+import           State+import           State.Common+import           Types++import           Events.ShowHelp+import           Events.Main+import           Events.JoinChannel+import           Events.ChannelScroll+import           Events.ChannelSelect+import           Events.LeaveChannelConfirm+import           Events.DeleteChannelConfirm+import           Events.UrlSelect+import           Events.MessageSelect++onEvent :: ChatState -> BrickEvent Name MHEvent -> EventM Name (Next ChatState)+onEvent st ev = runMHEvent st $ case ev of+  (AppEvent e) -> onAppEvent e+  (VtyEvent (Vty.EvKey (Vty.KChar 'l') [Vty.MCtrl])) -> do+    Just vty <- mh getVtyHandle+    liftIO $ Vty.refresh vty+  (VtyEvent e) -> onVtyEvent e+  _ -> return ()++onAppEvent :: MHEvent -> MH ()+onAppEvent RefreshWebsocketEvent = do+  st <- use id+  liftIO $ connectWebsockets st+onAppEvent WebsocketDisconnect =+  csConnectionStatus .= Disconnected+onAppEvent WebsocketConnect = do+  csConnectionStatus .= Connected+  refreshLoadedChannels+onAppEvent (WSEvent we) =+  handleWSEvent we+onAppEvent (RespEvent f) = f+onAppEvent (AsyncErrEvent e) = do+  let msg = "An unexpected error has occurred! The exception encountered was:\n  " <>+            T.pack (show e) <>+            "\nPlease report this error at https://github.com/matterhorn-chat/matterhorn/issues"+  postErrorMessage msg++onVtyEvent :: Vty.Event -> MH ()+onVtyEvent e = do+    -- Even if we aren't showing the help UI when a resize occurs, we+    -- need to invalidate its cache entry anyway in case the new size+    -- differs from the cached size.+    case e of+        (Vty.EvResize _ _) -> do+            mh $ invalidateCacheEntry HelpText+            mh $ invalidateCacheEntry ScriptHelpText+        _ -> return ()++    mode <- use csMode+    case mode of+        Main                       -> onEventMain e+        ShowHelp _                 -> onEventShowHelp e+        ChannelSelect              -> onEventChannelSelect e+        UrlSelect                  -> onEventUrlSelect e+        LeaveChannelConfirm        -> onEventLeaveChannelConfirm e+        JoinChannel                -> onEventJoinChannel e+        ChannelScroll              -> onEventChannelScroll e+        MessageSelect              -> onEventMessageSelect e+        MessageSelectDeleteConfirm -> onEventMessageSelectDeleteConfirm e+        DeleteChannelConfirm       -> onEventDeleteChannelConfirm e++handleWSEvent :: WebsocketEvent -> MH ()+handleWSEvent we = do+  myId <- use (csMe.userIdL)+  myTeamId <- use (csMyTeam.teamIdL)+  case weEvent we of+    WMPosted -> case wepPost (weData we) of+      Just p  -> do+          -- If the message is a header change, also update the channel+          -- metadata.+          case postPropsNewHeader (p^.postPropsL) of+              Just newHeader | postType p == SystemHeaderChange ->+                  csChannel(postChannelId p).ccInfo.cdHeader .= newHeader+              _ -> return ()+          addMessageToState p+      Nothing -> return ()+    WMPostEdited -> case wepPost (weData we) of+      Just p  -> editMessage p+      Nothing -> return ()+    WMPostDeleted -> case wepPost (weData we) of+      Just p  -> deleteMessage p+      Nothing ->  return ()+    WMStatusChange -> case wepStatus (weData we) of+      Just status -> case wepUserId (weData we) of+          Just uId -> updateStatus uId status+          Nothing -> return ()+      Nothing -> return ()+    WMUserAdded -> case webChannelId (weBroadcast we) of+      Just cId -> if wepUserId (weData we) == Just myId &&+                     wepTeamId (weData we) == Just myTeamId+                  then handleChannelInvite cId+                  else return ()+      Nothing -> return ()+    WMUserUpdated -> -- XXX+      return ()+    WMNewUser -> do+      let Just newUserId = wepUserId $ weData we+      handleNewUser newUserId+    WMUserRemoved -> -- XXX+      return ()+    WMChannelDeleted -> -- XXX+      return ()+    WMDirectAdded -> -- XXX+      return ()+    WMChannelCreated -> -- XXX+      return ()+    WMGroupAdded -> -- XXX+      return ()+    WMLeaveTeam -> -- XXX: How do we deal with this one?+      return ()+    -- An 'ephemeral message' is just MatterMost's version+    -- of our 'client message'. This can be a little bit+    -- wacky, e.g. if the user types '/shortcuts' in the+    -- browser, we'll get an ephemeral message even in+    -- MatterHorn with the browser shortcuts, but it's+    -- probably a good idea to handle these messages anyway.+    WMEphemeralMessage -> case wepPost (weData we) of+      Just p  -> do+        postInfoMessage (p^.postMessageL)+      Nothing -> return ()+    -- Right now, we don't use any server preferences in+    -- our client, but that might change+    WMPreferenceChanged -> return ()+    -- This happens whenever a user connects to the server+    -- I think all the information we need (about being+    -- online or away or what-have-you) gets represented+    -- in StatusChanged messages, so we can ignore it.+    WMHello -> return ()+    -- right now we don't show typing notifications. maybe+    -- we should? i dunno.+    WMTyping -> return ()+    -- Do we need to do anything with this?+    WMUpdateTeam -> return ()+    WMReactionAdded -> case wepReaction (weData we) of+      Just r  -> case webChannelId (weBroadcast we) of+        Just cId -> addReaction r cId+        Nothing -> return ()+      Nothing -> return ()+    WMReactionRemoved -> case wepReaction (weData we) of+      Just r  -> case webChannelId (weBroadcast we) of+        Just cId -> removeReaction r cId+        Nothing -> return ()+      Nothing -> return ()+    WMAddedToTeam -> return () -- XXX: we need to handle this+    WMWebRTC      -> return ()+    WMAuthenticationChallenge -> return ()
+ src/Events/ChannelScroll.hs view
@@ -0,0 +1,40 @@+module Events.ChannelScroll where++import Prelude ()+import Prelude.Compat++import Brick+import qualified Graphics.Vty as Vty+import Lens.Micro.Platform++import Types+import State++channelScrollKeybindings :: [Keybinding]+channelScrollKeybindings =+  [ KB "Load more messages in the current channel"+    (Vty.EvKey (Vty.KChar 'b') [Vty.MCtrl])+    loadMoreMessages+  , KB "Select and open a URL posted to the current channel"+    (Vty.EvKey (Vty.KChar 'o') [Vty.MCtrl])+    startUrlSelect+  , KB "Scroll up" (Vty.EvKey Vty.KPageUp [])+    channelPageUp+  , KB "Scroll down" (Vty.EvKey Vty.KPageDown [])+    channelPageDown+  , KB "Cancel scrolling and return to channel view"+    (Vty.EvKey Vty.KEsc []) $+    csMode .= Main+  ]++onEventChannelScroll :: Vty.Event -> MH ()+onEventChannelScroll (Vty.EvResize _ _) = do+    cId <- use csCurrentChannelId+    mh $ do+      invalidateCache+      let vp = ChannelMessages cId+      vScrollToEnd $ viewportScroll vp+onEventChannelScroll e+  | Just kb <- lookupKeybinding e channelScrollKeybindings = kbAction kb+onEventChannelScroll _ = do+    return ()
+ src/Events/ChannelSelect.hs view
@@ -0,0 +1,48 @@+module Events.ChannelSelect where++import Prelude ()+import Prelude.Compat++import Data.Monoid ((<>))+import qualified Data.Text as T+import qualified Data.HashMap.Strict as HM+import qualified Graphics.Vty as Vty+import Lens.Micro.Platform++import Types+import State++onEventChannelSelect :: Vty.Event -> MH ()+onEventChannelSelect e | Just kb <- lookupKeybinding e channelSelectKeybindings =+    kbAction kb+onEventChannelSelect (Vty.EvKey Vty.KBS []) = do+    csChannelSelectString %= (\s -> if T.null s then s else T.init s)+    updateChannelSelectMatches+onEventChannelSelect (Vty.EvKey (Vty.KChar c) []) | c /= '\t' = do+    csChannelSelectString %= (flip T.snoc c)+    updateChannelSelectMatches+onEventChannelSelect _ = return ()++channelSelectKeybindings :: [Keybinding]+channelSelectKeybindings =+    [ KB "Select matching channel"+         (Vty.EvKey Vty.KEnter []) $ do+             -- If there is only one channel selection match, switch to+             -- it+             st <- use id+             let allMatches = (HM.elems $ st^.csChannelSelectChannelMatches) <>+                              (HM.elems $ st^.csChannelSelectUserMatches)+             case allMatches of+                 [single] -> do+                     csMode .= Main+                     changeChannel (channelNameFromMatch single)+                 _ -> return ()++    , KB "Cancel channel selection"+         (Vty.EvKey Vty.KEsc []) $ do+           csMode .= Main++    , KB "Cancel channel selection"+         (Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl]) $ do+           csMode .= Main+    ]
+ src/Events/DeleteChannelConfirm.hs view
@@ -0,0 +1,20 @@+module Events.DeleteChannelConfirm where++import Prelude ()+import Prelude.Compat++import qualified Graphics.Vty as Vty+import Lens.Micro.Platform++import Types+import State++onEventDeleteChannelConfirm :: Vty.Event -> MH ()+onEventDeleteChannelConfirm (Vty.EvKey k []) = do+    case k of+        Vty.KChar c | c `elem` ("yY"::String) ->+            deleteCurrentChannel+        _ -> return ()+    csMode .= Main+onEventDeleteChannelConfirm _ = do+    csMode .= Main
+ src/Events/JoinChannel.hs view
@@ -0,0 +1,40 @@+module Events.JoinChannel where++import Prelude ()+import Prelude.Compat++import Brick.Widgets.List+import qualified Graphics.Vty as Vty+import Lens.Micro.Platform++import Types+import State (joinChannel)++joinChannelListKeys :: [Vty.Key]+joinChannelListKeys =+    [ Vty.KUp+    , Vty.KDown+    , Vty.KPageUp+    , Vty.KPageDown+    , Vty.KHome+    , Vty.KEnd+    ]++onEventJoinChannel :: Vty.Event -> MH ()+onEventJoinChannel e@(Vty.EvKey k []) | k `elem` joinChannelListKeys = do+    chList <- use csJoinChannelList+    result <- case chList of+        Nothing -> return Nothing+        Just l -> Just <$> mh (handleListEvent e l)+    csJoinChannelList .= result+onEventJoinChannel (Vty.EvKey Vty.KEnter []) = do+    chList <- use csJoinChannelList+    case chList of+        Nothing -> return ()+        Just l -> case listSelectedElement l of+            Nothing -> return ()+            Just (_, chan) -> joinChannel chan+onEventJoinChannel (Vty.EvKey Vty.KEsc []) = do+    csMode .= Main+onEventJoinChannel _ = do+    return ()
+ src/Events/LeaveChannelConfirm.hs view
@@ -0,0 +1,19 @@+module Events.LeaveChannelConfirm where++import Prelude ()+import Prelude.Compat++import qualified Graphics.Vty as Vty+import Lens.Micro.Platform++import Types+import State++onEventLeaveChannelConfirm :: Vty.Event -> MH ()+onEventLeaveChannelConfirm (Vty.EvKey k []) = do+    case k of+        Vty.KChar c | c `elem` ("yY"::String) ->+            leaveCurrentChannel+        _ -> return ()+    csMode .= Main+onEventLeaveChannelConfirm _ = return ()
+ src/Events/Main.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE MultiWayIf #-}+module Events.Main where++import Prelude ()+import Prelude.Compat++import Brick+import Brick.Widgets.Edit+import Data.Maybe (catMaybes)+import Data.Monoid ((<>))+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Text.Zipper as Z+import qualified Data.Text.Zipper.Generic.Words as Z+import qualified Graphics.Vty as Vty+import Lens.Micro.Platform++import Types+import State+import State.Editing+import Command+import Completion+import InputHistory++import Network.Mattermost (Type(..))++onEventMain :: Vty.Event -> MH ()+onEventMain e | Just kb <- lookupKeybinding e mainKeybindings = kbAction kb+onEventMain (Vty.EvPaste bytes) = handlePaste bytes+onEventMain e = handleEditingInput e++mainKeybindings :: [Keybinding]+mainKeybindings =+    [ KB "Show this help screen"+         (Vty.EvKey (Vty.KFun 1) []) $+         showHelpScreen MainHelp++    , KB "Select a message to edit/reply/delete"+         (Vty.EvKey (Vty.KChar 's') [Vty.MCtrl]) $+         beginMessageSelect++    , KB "Reply to the most recent message"+         (Vty.EvKey (Vty.KChar 'r') [Vty.MCtrl]) $+         replyToLatestMessage++    , KB "Toggle message preview"+         (Vty.EvKey (Vty.KChar 'p') [Vty.MMeta]) $+         toggleMessagePreview++    , KB "Invoke *$EDITOR* to edit the current message"+         (Vty.EvKey (Vty.KChar 'k') [Vty.MMeta]) $+         invokeExternalEditor++    , KB "Enter fast channel selection mode"+         (Vty.EvKey (Vty.KChar 'g') [Vty.MCtrl]) $+         beginChannelSelect++    , KB "Quit"+         (Vty.EvKey (Vty.KChar 'q') [Vty.MCtrl]) $ requestQuit++    , KB "Tab-complete forward"+         (Vty.EvKey (Vty.KChar '\t') []) $+         tabComplete Forwards++    , KB "Tab-complete backward"+         (Vty.EvKey (Vty.KBackTab) []) $+         tabComplete Backwards++    , KB "Scroll up in the channel input history"+         (Vty.EvKey Vty.KUp []) $ do+             -- Up in multiline mode does the usual thing; otherwise we+             -- navigate the history.+             isMultiline <- use (csEditState.cedMultiline)+             case isMultiline of+                 True -> mhHandleEventLensed csCmdLine handleEditorEvent+                                           (Vty.EvKey Vty.KUp [])+                 False -> channelHistoryBackward++    , KB "Scroll down in the channel input history"+         (Vty.EvKey Vty.KDown []) $ do+             -- Down in multiline mode does the usual thing; otherwise+             -- we navigate the history.+             isMultiline <- use (csEditState.cedMultiline)+             case isMultiline of+                 True -> mhHandleEventLensed csCmdLine handleEditorEvent+                                           (Vty.EvKey Vty.KDown [])+                 False -> channelHistoryForward++    , KB "Page up in the channel message list"+         (Vty.EvKey Vty.KPageUp []) $ do+             cId <- use csCurrentChannelId+             let vp = ChannelMessages cId+             mh $ invalidateCacheEntry vp+             mh $ vScrollToEnd $ viewportScroll vp+             mh $ vScrollBy (viewportScroll vp) (-1 * pageAmount)+             csMode .= ChannelScroll++    , KB "Change to the next channel in the channel list"+         (Vty.EvKey (Vty.KChar 'n') [Vty.MCtrl]) $+         nextChannel++    , KB "Change to the previous channel in the channel list"+         (Vty.EvKey (Vty.KChar 'p') [Vty.MCtrl]) $+         prevChannel++    , KB "Change to the next channel with unread messages"+         (Vty.EvKey (Vty.KChar 'a') [Vty.MMeta]) $+         nextUnreadChannel++    , KB "Change to the most recently-focused channel"+         (Vty.EvKey (Vty.KChar 's') [Vty.MMeta]) $+         recentChannel++    , KB "Send the current message"+         (Vty.EvKey Vty.KEnter []) $ do+             isMultiline <- use (csEditState.cedMultiline)+             case isMultiline of+                 -- Enter in multiline mode does the usual thing; we+                 -- only send on Enter when we're outside of multiline+                 -- mode.+                 True -> mhHandleEventLensed csCmdLine handleEditorEvent+                                           (Vty.EvKey Vty.KEnter [])+                 False -> do+                   csCurrentCompletion .= Nothing+                   handleInputSubmission++    , KB "Select and open a URL posted to the current channel"+         (Vty.EvKey (Vty.KChar 'o') [Vty.MCtrl]) $+           startUrlSelect++    , KB "Clear the current channel's unread message indicator"+         (Vty.EvKey (Vty.KChar 'l') [Vty.MMeta]) $ do+           cId <- use csCurrentChannelId+           clearNewMessageCutoff cId++    , KB "Toggle multi-line message compose mode"+         (Vty.EvKey (Vty.KChar 'e') [Vty.MMeta]) $+           toggleMultilineEditing++    , KB "Cancel message reply or update"+         (Vty.EvKey Vty.KEsc []) $+         cancelReplyOrEdit++    , KB "Cancel message reply or update"+         (Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl]) $+         cancelReplyOrEdit+    ]++handleInputSubmission :: MH ()+handleInputSubmission = do+  cmdLine <- use csCmdLine+  cId <- use csCurrentChannelId++  -- send the relevant message+  mode <- use (csEditState.cedEditMode)+  let (line:rest) = getEditContents cmdLine+      allLines = T.intercalate "\n" $ line : rest++  -- We clean up before dispatching the command or sending the message+  -- since otherwise the command could change the state and then doing+  -- cleanup afterwards could clean up the wrong things.+  csCmdLine                     %= applyEdit Z.clearZipper+  csInputHistory                %= addHistoryEntry allLines cId+  csInputHistoryPosition.at cId .= Nothing+  csEditState.cedEditMode       .= NewPost++  case T.uncons line of+    Just ('/',cmd) -> dispatchCommand cmd+    _              -> sendMessage mode allLines++tabComplete :: Completion.Direction -> MH ()+tabComplete dir = do+  st <- use id+  let completableChannels = catMaybes (flip map (st^.csNames.cnChans) $ \cname -> do+          -- Only permit completion of channel names for non-Group channels+          cId <- st^.csNames.cnToChanId.at cname+          let cInfo = st^.csChannel(cId).ccInfo+          case cInfo^.cdType /= Group of+              True -> Just cname+              False -> Nothing+          )++      priorities  = [] :: [T.Text]-- XXX: add recent completions to this+      completions = Set.fromList (st^.csNames.cnUsers +++                                  completableChannels +++                                  map (T.singleton userSigil <>) (st^.csNames.cnUsers) +++                                  map (T.singleton normalChannelSigil <>) completableChannels +++                                  map ("/" <>) (commandName <$> commandList))++      line        = Z.currentLine $ st^.csCmdLine.editContentsL+      curComp     = st^.csCurrentCompletion+      (nextComp, alts) = case curComp of+          Nothing -> let cw = currentWord line+                     in (Just cw, filter (cw `T.isPrefixOf`) $ Set.toList completions)+          Just cw -> (Just cw, filter (cw `T.isPrefixOf`) $ Set.toList completions)++      mb_word     = wordComplete dir priorities completions line curComp+  csCurrentCompletion .= nextComp+  csEditState.cedCompletionAlternatives .= alts+  let (edit, curAlternative) = case mb_word of+          Nothing -> (id, "")+          Just w -> (Z.insertMany w . Z.deletePrevWord, w)++  csCmdLine %= (applyEdit edit)+  csEditState.cedCurrentAlternative .= curAlternative
+ src/Events/MessageSelect.hs view
@@ -0,0 +1,81 @@+module Events.MessageSelect where++import Prelude ()+import Prelude.Compat++import Data.Monoid ((<>))+import qualified Data.Text as T+import qualified Graphics.Vty as Vty+import Lens.Micro.Platform++import Types+import State++messagesPerPageOperation :: Int+messagesPerPageOperation = 10++onEventMessageSelect :: Vty.Event -> MH ()+onEventMessageSelect e | Just kb <- lookupKeybinding e messageSelectKeybindings =+  kbAction kb+onEventMessageSelect _ = return ()++onEventMessageSelectDeleteConfirm :: Vty.Event -> MH ()+onEventMessageSelectDeleteConfirm (Vty.EvKey (Vty.KChar 'y') []) = do+    deleteSelectedMessage+    csMode .= Main+onEventMessageSelectDeleteConfirm _ =+    csMode .= Main++messageSelectKeybindings :: [Keybinding]+messageSelectKeybindings =+    [ KB "Cancel message selection"+         (Vty.EvKey Vty.KEsc []) $ csMode .= Main++    , KB "Cancel message selection"+         (Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl]) $+         csMode .= Main++    , KB "Select the previous message"+         (Vty.EvKey (Vty.KChar 'k') []) $+         messageSelectUp++    , KB "Select the previous message"+         (Vty.EvKey Vty.KUp []) $+         messageSelectUp++    , KB (T.pack $ "Move the cursor up by " <> show messagesPerPageOperation <> " messages")+         (Vty.EvKey Vty.KPageUp []) $+         messageSelectUpBy messagesPerPageOperation++    , KB "Select the next message"+         (Vty.EvKey (Vty.KChar 'j') []) $+         messageSelectDown++    , KB "Select the next message"+         (Vty.EvKey Vty.KDown []) $+         messageSelectDown++    , KB (T.pack $ "Move the cursor down by " <> show messagesPerPageOperation <> " messages")+         (Vty.EvKey Vty.KPageDown []) $+         messageSelectDownBy messagesPerPageOperation++    , KB "Open all URLs in the selected message"+         (Vty.EvKey (Vty.KChar 'o') []) $+         openSelectedMessageURLs++    , KB "Begin composing a reply to the selected message"+         (Vty.EvKey (Vty.KChar 'r') []) $+         beginReplyCompose++    , KB "Begin editing the selected message"+         (Vty.EvKey (Vty.KChar 'e') []) $+         beginUpdateMessage++    , KB "Delete the selected message (with confirmation)"+         (Vty.EvKey (Vty.KChar 'd') []) $+         beginConfirmDeleteSelectedMessage++    , KB "Copy a verbatim section to the clipboard"+         (Vty.EvKey (Vty.KChar 'y') []) $+         copyVerbatimToClipboard+    ]
+ src/Events/ShowHelp.hs view
@@ -0,0 +1,40 @@+module Events.ShowHelp where++import Prelude ()+import Prelude.Compat++import Brick+import qualified Graphics.Vty as Vty+import Lens.Micro.Platform++import Types+import State++onEventShowHelp :: Vty.Event -> MH ()+onEventShowHelp e | Just kb <- lookupKeybinding e helpKeybindings =+  kbAction kb+onEventShowHelp (Vty.EvKey _ _) = do+  csMode .= Main+onEventShowHelp _ = return ()++helpKeybindings :: [Keybinding]+helpKeybindings =+    [ KB "Scroll up"+         (Vty.EvKey Vty.KUp []) $ do+             mh $ vScrollBy (viewportScroll HelpViewport) (-1)+    , KB "Scroll down"+         (Vty.EvKey Vty.KDown []) $ do+             mh $ vScrollBy (viewportScroll HelpViewport) 1+    , KB "Page up"+         (Vty.EvKey Vty.KPageUp []) $ do+             mh $ vScrollBy (viewportScroll HelpViewport) (-1 * pageAmount)+    , KB "Page down"+         (Vty.EvKey Vty.KPageDown []) $ do+             mh $ vScrollBy (viewportScroll HelpViewport) pageAmount+    , KB "Page down"+         (Vty.EvKey (Vty.KChar ' ') []) $ do+             mh $ vScrollBy (viewportScroll HelpViewport) pageAmount+    , KB "Return to the main interface"+         (Vty.EvKey Vty.KEsc []) $ do+           csMode .= Main+    ]
+ src/Events/UrlSelect.hs view
@@ -0,0 +1,39 @@+module Events.UrlSelect where++import Prelude ()+import Prelude.Compat++import Brick.Widgets.List+import qualified Graphics.Vty as Vty+import Lens.Micro.Platform++import Types+import State++onEventUrlSelect :: Vty.Event -> MH ()+onEventUrlSelect e+    | Just kb <- lookupKeybinding e urlSelectKeybindings = kbAction kb+    | otherwise = mhHandleEventLensed csUrlList handleListEvent e++urlSelectKeybindings :: [Keybinding]+urlSelectKeybindings =+    [ KB "Open the selected URL, if any"+         (Vty.EvKey Vty.KEnter []) $ do+             openSelectedURL+             csMode .= Main++    , KB "Cancel URL selection"+         (Vty.EvKey Vty.KEsc []) $ stopUrlSelect++    , KB "Cancel URL selection"+         (Vty.EvKey (Vty.KChar 'q') []) $ stopUrlSelect++    , KB "Move cursor down"+         (Vty.EvKey (Vty.KChar 'j') []) $+           mhHandleEventLensed csUrlList handleListEvent (Vty.EvKey Vty.KDown [])++    , KB "Move cursor up"+         (Vty.EvKey (Vty.KChar 'k') []) $+           mhHandleEventLensed csUrlList handleListEvent (Vty.EvKey Vty.KUp [])++    ]
+ src/FilePaths.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE TupleSections #-}+module FilePaths+  ( historyFilePath+  , historyFileName++  , configFileName++  , xdgName+  , locateConfig++  , Script(..)+  , locateScriptPath+  , getAllScripts+  ) where++import Prelude ()+import Prelude.Compat++import Control.Monad (forM, filterM)+import Data.Monoid ((<>))+import Data.Maybe (listToMaybe)+import System.Directory ( doesFileExist+                        , doesDirectoryExist+                        , getDirectoryContents+                        , getPermissions+                        , executable+                        )+import System.Environment.XDG.BaseDir (getUserConfigFile, getAllConfigFiles)+import System.FilePath (takeBaseName)++xdgName :: String+xdgName = "matterhorn"++historyFileName :: FilePath+historyFileName = "history.txt"++configFileName :: FilePath+configFileName = "config.ini"++historyFilePath :: IO FilePath+historyFilePath = getUserConfigFile xdgName historyFileName++-- | Find a specified configuration file by looking in all of the+-- supported locations.+locateConfig :: FilePath -> IO (Maybe FilePath)+locateConfig filename = do+  xdgLocations <- getAllConfigFiles "matterhorn" filename+  let confLocations = ["./" <> filename] +++                      xdgLocations +++                      ["/etc/matterhorn/" <> filename]+  results <- forM confLocations $ \fp -> (fp,) <$> doesFileExist fp+  return $ listToMaybe $ fst <$> filter snd results++scriptDirName :: FilePath+scriptDirName = "scripts"++data Script+  = ScriptPath FilePath+  | NonexecScriptPath FilePath+  | ScriptNotFound+    deriving (Eq, Read, Show)++toScript :: FilePath -> IO (Script)+toScript fp = do+  perm <- getPermissions fp+  return $ if executable perm+    then ScriptPath fp+    else NonexecScriptPath fp++isExecutable :: FilePath -> IO Bool+isExecutable fp = do+  perm <- getPermissions fp+  return (executable perm)++locateScriptPath :: FilePath -> IO Script+locateScriptPath name+  | head name == '.' = return ScriptNotFound+  | otherwise = do+    xdgLocations <- getAllConfigFiles "matterhorn" scriptDirName+    let cmdLocations = [ xdgLoc ++ "/" ++ name+                       | xdgLoc <- xdgLocations+                       ] ++ [ "/etc/matterhorn/scripts/" <> name ]+    existingFiles <- filterM doesFileExist cmdLocations+    executables <- mapM toScript existingFiles+    return $ case executables of+      (path:_) -> path+      _        -> ScriptNotFound++-- | This returns a list of valid scripts, and a list of non-executable+--   scripts.+getAllScripts :: IO ([FilePath], [FilePath])+getAllScripts = do+  xdgLocations <- getAllConfigFiles "matterhorn" scriptDirName+  let cmdLocations = xdgLocations ++ ["/etc/matterhorn/scripts"]+  let getCommands dir = do+        exists <- doesDirectoryExist dir+        if exists+          then map ((dir ++ "/") ++) `fmap` getDirectoryContents dir+          else return []+  let isNotHidden f = case f of+        ('.':_) -> False+        []      -> False+        _       -> True+  allScripts <- concat `fmap` mapM getCommands cmdLocations+  execs <- filterM isExecutable allScripts+  nonexecs <- filterM (fmap not . isExecutable) allScripts+  return ( filter isNotHidden $ map takeBaseName execs+         , filter isNotHidden $ map takeBaseName nonexecs+         )
+ src/IOUtil.hs view
@@ -0,0 +1,19 @@+module IOUtil+  ( convertIOException+  ) where++import Prelude ()+import Prelude.Compat++import Control.Exception+import Control.Monad.IO.Class+import Control.Monad.Trans.Except+import System.IO.Error (ioeGetErrorString)++convertIOException :: IO a -> ExceptT String IO a+convertIOException act = do+    result <- liftIO $ (Right <$> act) `catch`+                       (\(e::IOError) -> return $ Left $ ioeGetErrorString e)+    case result of+        Left e -> throwE e+        Right v -> return v
+ src/InputHistory.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE TemplateHaskell #-}+module InputHistory+  ( InputHistory+  , newHistory+  , readHistory+  , writeHistory+  , addHistoryEntry+  , getHistoryEntry+  , removeChannelHistory+  ) where++import Prelude ()+import Prelude.Compat++import Control.Monad.Trans.Except+import Lens.Micro.Platform+import qualified Data.HashMap.Strict as HM+import System.Directory (createDirectoryIfMissing)+import System.FilePath (dropFileName)+import qualified System.IO.Strict as S+import qualified Data.Vector as V+import           Data.Text ( Text )++import IOUtil+import FilePaths+import Network.Mattermost (ChannelId)++data InputHistory =+    InputHistory { _historyEntries :: HM.HashMap ChannelId (V.Vector Text)+                 }+                 deriving (Show)++makeLenses ''InputHistory++newHistory :: InputHistory+newHistory = InputHistory mempty++removeChannelHistory :: ChannelId -> InputHistory -> InputHistory+removeChannelHistory cId ih = ih & historyEntries.at cId .~ Nothing++writeHistory :: InputHistory -> IO ()+writeHistory ih = do+    historyFile <- historyFilePath+    createDirectoryIfMissing True $ dropFileName historyFile+    let entries = (\(cId, z) -> (cId, V.toList z)) <$>+                  (HM.toList $ ih^.historyEntries)+    writeFile historyFile $ show entries++readHistory :: IO (Either String InputHistory)+readHistory = runExceptT $ do+    contents <- convertIOException (S.readFile =<< historyFilePath)+    case reads contents of+        [(val, "")] -> do+            let entries = (\(cId, es) -> (cId, V.fromList es)) <$> val+            return $ InputHistory $ HM.fromList entries+        _ -> throwE "Failed to parse history file"++addHistoryEntry :: Text -> ChannelId -> InputHistory -> InputHistory+addHistoryEntry e cId ih = ih & historyEntries.at cId %~ insertEntry+    where+    insertEntry Nothing  = Just $ V.singleton e+    insertEntry (Just v) =+      Just $ V.cons e (V.filter (/= e) v)++getHistoryEntry :: ChannelId -> Int -> InputHistory -> Maybe Text+getHistoryEntry cId i ih = do+    es <- ih^.historyEntries.at cId+    es ^? ix i
+ src/Login.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE MultiWayIf #-}+module Login+  ( interactiveGatherCredentials+  ) where++import Prelude ()+import Prelude.Compat++import Brick+import Brick.Widgets.Edit+import Brick.Widgets.Center+import Brick.Widgets.Border+import Control.Monad.IO.Class (liftIO)+import Data.Maybe (isNothing)+import Text.Read (readMaybe)+import qualified Data.Text as T+import Graphics.Vty hiding (Config)+import System.Exit (exitSuccess)++import Network.Mattermost.Exceptions (LoginFailureException(..))++import Config+import Markdown+import Types (ConnectionInfo(..), AuthenticationException(..))++data Name = Hostname | Port | Username | Password deriving (Ord, Eq, Show)++data State =+    State { hostnameEdit :: Editor T.Text Name+          , portEdit     :: Editor T.Text Name+          , usernameEdit :: Editor T.Text Name+          , passwordEdit :: Editor T.Text Name+          , focus    :: Name+          , previousError :: Maybe AuthenticationException+          }++toPassword :: [T.Text] -> Widget a+toPassword s = txt $ T.replicate (T.length $ T.concat s) "*"++interactiveGatherCredentials :: Config+                             -> Maybe AuthenticationException+                             -> IO ConnectionInfo+interactiveGatherCredentials config authError = do+    let state = State { hostnameEdit = editor Hostname (txt . T.concat) (Just 1) hStr+                      , portEdit = editor Port (txt . T.concat) (Just 1) (T.pack $ show $ configPort config)+                      , usernameEdit = editor Username (txt . T.concat) (Just 1) uStr+                      , passwordEdit = editor Password toPassword     (Just 1) pStr+                      , focus = initialFocus+                      , previousError = authError+                      }+        hStr = maybe "" id $ configHost config+        uStr = maybe "" id $ configUser config+        pStr = case configPass config of+            Just (PasswordString s) -> s+            _                       -> ""+        initialFocus = if | T.null hStr -> Hostname+                          | T.null uStr -> Username+                          | T.null pStr -> Password+                          | otherwise   -> Hostname+    finalSt <- defaultMain app state+    let finalH = T.concat $ getEditContents $ hostnameEdit finalSt+        finalPort = read $ T.unpack $ T.concat $ getEditContents $ portEdit finalSt+        finalU = T.concat $ getEditContents $ usernameEdit finalSt+        finalPass = T.concat $ getEditContents $ passwordEdit finalSt+    return $ ConnectionInfo finalH finalPort finalU finalPass++app :: App State e Name+app = App+  { appDraw         = credsDraw+  , appChooseCursor = showFirstCursor+  , appHandleEvent  = onEvent+  , appStartEvent   = return+  , appAttrMap      = const colorTheme+  }++errorAttr :: AttrName+errorAttr = "errorMessage"++colorTheme :: AttrMap+colorTheme = attrMap defAttr+  [ (editAttr, black `on` white)+  , (editFocusedAttr, black `on` yellow)+  , (errorAttr, fg red)+  ]++credsDraw :: State -> [Widget Name]+credsDraw st =+    [ center (credentialsForm st <=> errorMessageDisplay st)+    ]++errorMessageDisplay :: State -> Widget Name+errorMessageDisplay st = do+    case previousError st of+        Nothing -> emptyWidget+        -- XXX+        Just e -> txt " " <=>+                  (withDefAttr errorAttr $+                   hCenter (str "Error: " <+> renderAuthError e))++renderAuthError :: AuthenticationException -> Widget Name+renderAuthError (ConnectError _) = txt "Could not connect to server"+renderAuthError (ResolveError _) = txt "Could not resolve server hostname"+renderAuthError (OtherAuthError e) = str $ show e+renderAuthError (LoginError (LoginFailureException msg)) = str msg++credentialsForm :: State -> Widget Name+credentialsForm st =+    hCenter $ hLimit 50 $ vLimit 15 $+    border $+    vBox [ renderText "Please enter your MatterMost credentials to log in."+         , txt " "+         , txt "Hostname:" <+> renderEditor (focus st == Hostname) (hostnameEdit st)+         , txt " "+         , txt "Port:    " <+> renderEditor (focus st == Port) (portEdit st)+         , txt " "+         , txt "Username:" <+> renderEditor (focus st == Username) (usernameEdit st)+         , txt " "+         , txt "Password:" <+> renderEditor (focus st == Password) (passwordEdit st)+         , txt " "+         , renderText "Press Enter to log in or Esc to exit."+         ]++onEvent :: State -> BrickEvent Name e -> EventM Name (Next State)+onEvent _  (VtyEvent (EvKey KEsc [])) = liftIO exitSuccess+onEvent st (VtyEvent (EvKey (KChar '\t') [])) =+    continue $ st { focus = if | focus st == Hostname -> Port+                               | focus st == Port     -> Username+                               | focus st == Username -> Password+                               | focus st == Password -> Hostname+                  }+onEvent st (VtyEvent (EvKey KEnter [])) =+    -- check for valid (non-empty) contents+    let h = T.concat $ getEditContents $ hostnameEdit st+        u = T.concat $ getEditContents $ usernameEdit st+        p = T.concat $ getEditContents $ passwordEdit st+        port :: Maybe Int+        port = readMaybe (T.unpack $ T.concat $ getEditContents $ portEdit st)+    in case T.null h || T.null u || T.null p || isNothing port of+        True -> continue st+        False -> halt st+onEvent st (VtyEvent e) =+    case focus st of+        Hostname -> do+            e' <- handleEditorEvent e (hostnameEdit st)+            continue $ st { hostnameEdit = e' }+        Port -> do+            e' <- handleEditorEvent e (portEdit st)+            continue $ st { portEdit = e' }+        Username -> do+            e' <- handleEditorEvent e (usernameEdit st)+            continue $ st { usernameEdit = e' }+        Password -> do+            e' <- handleEditorEvent e (passwordEdit st)+            continue $ st { passwordEdit = e' }+onEvent st _ = continue st
+ src/Main.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE RecordWildCards #-}++module Main where++import           Prelude ()+import           Prelude.Compat++import           Brick+import           Brick.BChan+import           Control.Concurrent (forkIO)+import qualified Control.Concurrent.STM as STM+import           Control.Exception (try)+import           Control.Monad (forever, void)+import           Data.Monoid ((<>))+import qualified Graphics.Vty as Vty+import           Lens.Micro.Platform+import           System.Exit (exitFailure)+import           System.IO (IOMode(WriteMode), openFile, hClose)++import           Config+import           Options+import           State.Setup+import           Events+import           Draw+import           Types+import           InputHistory++main :: IO ()+main = do+  opts <- grabOptions+  configResult <- findConfig (optConfLocation opts)+  config <- case configResult of+      Left err -> do+          putStrLn $ "Error loading config: " <> err+          exitFailure+      Right c -> return c++  eventChan <- newBChan 25+  writeBChan eventChan RefreshWebsocketEvent++  requestChan <- STM.atomically STM.newTChan+  void $ forkIO $ forever $ do+    req <- STM.atomically $ STM.readTChan requestChan+    res <- try req+    case res of+      Left e    -> writeBChan eventChan (AsyncErrEvent e)+      Right upd -> writeBChan eventChan (RespEvent upd)++  logFile <- case optLogLocation opts of+    Just path -> Just `fmap` openFile path WriteMode+    Nothing   -> return Nothing+  st <- setupState logFile config requestChan eventChan++  let mkVty = do+        vty <- Vty.mkVty Vty.defaultConfig+        let output = Vty.outputIface vty+        Vty.setMode output Vty.BracketedPaste True+        return vty++  finalSt <- customMain mkVty (Just eventChan) app st+  case logFile of+    Nothing -> return ()+    Just h -> hClose h+  writeHistory (finalSt^.csInputHistory)++app :: App ChatState MHEvent Name+app = App+  { appDraw         = draw+  , appChooseCursor = showFirstCursor+  , appHandleEvent  = onEvent+  , appStartEvent   = return+  , appAttrMap      = (^.csResources.crTheme)+  }
+ src/Markdown.hs view
@@ -0,0 +1,414 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ParallelListComp #-}++module Markdown+  ( UserSet+  , ChannelSet+  , renderMessage+  , renderText+  , blockGetURLs+  , cursorSentinel+  , addEllipsis+  , replyArrow+  , findVerbatimChunk+  )+where++import Prelude ()+import Prelude.Compat++import           Brick ( (<+>), Widget, textWidth )+import qualified Brick.Widgets.Border as B+import qualified Brick.Widgets.Border.Style as B+import qualified Brick as B+import           Cheapskate.Types ( Block+                                  , Blocks+                                  , Inlines+                                  , ListType+                                  )+import qualified Cheapskate as C+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Foldable as F+import           Data.Monoid (First(..), (<>))+import           Data.Sequence ( Seq+                               , ViewL(..)+                               , ViewR(..)+                               , (<|)+                               , (|>)+                               , viewl+                               , viewr)+import qualified Data.Sequence as S+import           Data.Set (Set)+import qualified Data.Set as Set+import qualified Graphics.Vty as V+import           Lens.Micro.Platform ((^.))++import           Themes+import           Types (userSigil, normalChannelSigil)+import           Types.Posts+import           Types.Messages++type UserSet = Set Text+type ChannelSet = Set Text++omitUsernameTypes :: [MessageType]+omitUsernameTypes =+    [ CP Join+    , CP Leave+    , CP TopicChange+    ]++getReplyToMessage :: Message -> Maybe Message+getReplyToMessage m =+    case m^.mInReplyToMsg of+        ParentLoaded _ parent -> Just parent+        _ -> Nothing++renderMessage :: Message -> Bool -> UserSet -> ChannelSet -> Widget a+renderMessage msg renderReplyParent uSet cSet =+    let msgUsr = case msg^.mUserName of+          Just u+            | msg^.mType `elem` omitUsernameTypes -> Nothing+            | otherwise -> Just u+          Nothing -> Nothing+        mine = case msgUsr of+          Just un+            | msg^.mType == CP Emote -> B.txt "*" <+> colorUsername un+                                    <+> B.txt " " <+> renderMarkdown uSet cSet (msg^.mText)+            | otherwise -> colorUsername un <+> B.txt ": " <+> renderMarkdown uSet cSet (msg^.mText)+          Nothing -> renderMarkdown uSet cSet (msg^.mText)+        parent = if not renderReplyParent+                 then Nothing+                 else getReplyToMessage msg+    in case parent of+        Nothing -> mine+        Just m -> let parentMsg = renderMessage m False uSet cSet+                  in (replyArrow <+>+                     (addEllipsis $ B.forceAttr replyParentAttr parentMsg))+                      B.<=> mine++addEllipsis :: Widget a -> Widget a+addEllipsis w = B.Widget (B.hSize w) (B.vSize w) $ do+    ctx <- B.getContext+    let aw = ctx^.B.availWidthL+    result <- B.render w+    let withEllipsis = (B.hLimit (aw - 3) $ B.vLimit 1 $ (B.Widget B.Fixed B.Fixed $ return result)) <+>+                       B.str "..."+    if (V.imageHeight (result^.B.imageL) > 1) || (V.imageWidth (result^.B.imageL) == aw) then+        B.render withEllipsis else+        return result++-- Cursor sentinel for tracking the user's cursor position in previews.+cursorSentinel :: Char+cursorSentinel = '‸'++-- Render markdown with username highlighting+renderMarkdown :: UserSet -> ChannelSet -> Blocks -> Widget a+renderMarkdown uSet cSet =+  B.vBox . F.toList . fmap (toWidget uSet cSet) . addBlankLines++-- Add blank lines only between adjacent elements of the same type, to+-- save space+addBlankLines :: Seq Block -> Seq Block+addBlankLines = go' . viewl+  where go' EmptyL = S.empty+        go' (x :< xs) = go x (viewl xs)+        go a@C.Para {} (b@C.Para {} :< rs) =+             a <| blank <| go b (viewl rs)+        go a@C.Header {} (b@C.Header {} :< rs) =+             a <| blank <| go b (viewl rs)+        go a@C.Blockquote {} (b@C.Blockquote {} :< rs) =+             a <| blank <| go b (viewl rs)+        go a@C.List {} (b@C.List {} :< rs) =+             a <| blank <| go b (viewl rs)+        go a@C.CodeBlock {} (b@C.CodeBlock {} :< rs) =+             a <| blank <| go b (viewl rs)+        go a@C.HtmlBlock {} (b@C.HtmlBlock {} :< rs) =+             a <| blank <| go b (viewl rs)+        go x (y :< rs) = x <| go y (viewl rs)+        go x (EmptyL) = S.singleton x+        blank = C.Para (S.singleton (C.Str " "))++-- Render text to markdown without username highlighting+renderText :: Text -> Widget a+renderText txt = renderMarkdown Set.empty Set.empty bs+  where C.Doc _ bs = C.markdown C.def txt++vBox :: F.Foldable f => f (Widget a) -> Widget a+vBox = B.vBox . F.toList++hBox :: F.Foldable f => f (Widget a) -> Widget a+hBox = B.hBox . F.toList++--++class ToWidget t where+  toWidget :: UserSet -> ChannelSet -> t -> Widget a++header :: Int -> Widget a+header n = B.txt (T.replicate n "#")++instance ToWidget Block where+  toWidget uPat cPat (C.Para is) = toInlineChunk is uPat cPat+  toWidget uPat cPat (C.Header n is) =+    B.withDefAttr clientHeaderAttr+      (header n <+> B.txt " " <+> toInlineChunk is uPat cPat)+  toWidget uPat cPat (C.Blockquote is) =+    B.padLeft (B.Pad 4) (vBox $ fmap (toWidget uPat cPat) is)+  toWidget uPat cPat (C.List _ l bs) = toList l bs uPat cPat+  toWidget _ _ (C.CodeBlock _ tx) =+    B.withDefAttr codeAttr $+        let padding = B.padLeftRight 1 (B.vLimit (length theLines) B.vBorder)+            theLines = expandEmpty <$> T.lines tx+            expandEmpty "" = " "+            expandEmpty s  = s+        in padding <+> (B.vBox $ textWithCursor <$> theLines)+  toWidget _ _ (C.HtmlBlock txt) = textWithCursor txt+  toWidget _ _ (C.HRule) = B.vLimit 1 (B.fill '*')++toInlineChunk :: Inlines -> UserSet -> ChannelSet -> Widget a+toInlineChunk is uSet cSet = B.Widget B.Fixed B.Fixed $ do+  ctx <- B.getContext+  let width = ctx^.B.availWidthL+      fs    = toFragments is+      ws    = fmap gatherWidgets (split width uSet cSet fs)+  B.render (vBox (fmap hBox ws))++toList :: ListType -> [Blocks] -> UserSet -> ChannelSet -> Widget a+toList lt bs uSet cSet = vBox+  [ B.txt i <+> (vBox (fmap (toWidget uSet cSet) b))+  | b <- bs | i <- is ]+  where is = case lt of+          C.Bullet _ -> repeat ("• ")+          C.Numbered _ _ -> [ T.pack (show (n :: Int)) <> ". "+                            | n <- [1..] ]++-- We want to do word-wrapping, but for that we want a linear+-- sequence of chunks we can break up. The typical Markdown+-- format doesn't fit the bill: when it comes to bold or italic+-- bits, we'd have treat it all as one. This representation is+-- more amenable to splitting up those bits.+data Fragment = Fragment+  { fTextual :: TextFragment+  , _fStyle  :: FragmentStyle+  } deriving (Show)++data TextFragment+  = TStr Text+  | TSpace+  | TSoftBreak+  | TLineBreak+  | TLink Text+  | TRawHtml Text+    deriving (Show, Eq)++data FragmentStyle+  = Normal+  | Emph+  | Strong+  | Code+  | User+  | Link+  | Emoji+  | Channel+    deriving (Eq, Show)++-- We convert it pretty mechanically:+toFragments :: Inlines -> Seq Fragment+toFragments = go Normal+  where go n c = case viewl c of+          C.Str t :< xs ->+            Fragment (TStr t) n <| go n xs+          C.Space :< xs ->+            Fragment TSpace n <| go n xs+          C.SoftBreak :< xs ->+            Fragment TSoftBreak n <| go n xs+          C.LineBreak :< xs ->+            Fragment TLineBreak n <| go n xs+          C.Link label url _ :< xs ->+            case F.toList label of+              [C.Str s] | s == url -> Fragment (TLink url) Link <| go n xs+              _                    -> go Link label <> go n xs+          C.RawHtml t :< xs ->+            Fragment (TRawHtml t) n <| go n xs+          C.Code t :< xs ->+            let ts  = [ Fragment frag Code+                      | wd <- T.split (== ' ') t+                      , frag <- case wd of+                          "" -> [TSpace]+                          _  -> [TSpace, TStr wd]+                      ]+                ts' = case ts of+                  (Fragment TSpace _:rs) -> rs+                  _                      -> ts+            in S.fromList ts' <> go n xs+          C.Emph is :< xs ->+            go Emph is <> go n xs+          C.Strong is :< xs ->+            go Strong is <> go n xs+          C.Image _ _ _ :< xs ->+            Fragment (TStr "[img]") Link <| go n xs+          C.Entity t :< xs ->+            Fragment (TStr t) Link <| go n xs+          EmptyL -> S.empty++--++data SplitState = SplitState+  { splitChunks  :: Seq (Seq Fragment)+  , splitCurrCol :: Int+  }++separate :: UserSet -> ChannelSet -> Seq Fragment -> Seq Fragment+separate uSet cSet sq = case viewl sq of+  Fragment (TStr s) n :< xs -> gatherStrings s n xs+  Fragment x n :< xs        -> Fragment x n <| separate uSet cSet xs+  EmptyL                    -> S.empty+  where gatherStrings s n rs =+          let s' = removeCursor s+          in case viewl rs of+            _ | s' `Set.member` uSet ||+                ((T.singleton userSigil) `T.isPrefixOf` s' && (T.drop 1 s' `Set.member` uSet)) ->+                buildString s n <| separate uSet cSet rs+            _ | ((T.singleton normalChannelSigil) `T.isPrefixOf` s' && (T.drop 1 s' `Set.member` cSet)) ->+                buildString s n <| separate uSet cSet rs+            Fragment (TStr s'') n' :< xs+              | n == n' -> gatherStrings (s <> s'') n xs+            Fragment _ _ :< _ -> buildString s n <| separate uSet cSet rs+            EmptyL -> S.singleton (buildString s n)+        buildString s n =+            let s' = removeCursor s+            in if | n == Code -> Fragment (TStr s) n+                  | ":" `T.isPrefixOf` s' &&+                    ":" `T.isSuffixOf` s' &&+                    textWidth s' > 2 ->+                      Fragment (TStr s) Emoji+                  | s' `Set.member` uSet ->+                      Fragment (TStr s) User+                  | (T.singleton userSigil) `T.isPrefixOf` (removeCursor s) &&+                    (T.drop 1 (removeCursor s) `Set.member` uSet) ->+                      Fragment (TStr s) User+                  | (T.singleton normalChannelSigil) `T.isPrefixOf` (removeCursor s) &&+                    (T.drop 1 (removeCursor s) `Set.member` cSet) ->+                      Fragment (TStr s) Channel+                  | otherwise -> Fragment (TStr s) n++removeCursor :: T.Text -> T.Text+removeCursor = T.filter (/= cursorSentinel)++split :: Int -> UserSet -> ChannelSet -> Seq Fragment -> Seq (Seq Fragment)+split maxCols uSet cSet = splitChunks+                          . go (SplitState (S.singleton S.empty) 0)+                          . separate uSet cSet+  where go st (viewl-> f :< fs) = go st' fs+          where st' =+                  if | fTextual f == TSoftBreak || fTextual f == TLineBreak ->+                         st { splitChunks = splitChunks st |> S.empty+                            , splitCurrCol = 0+                            }+                     | available >= fsize ->+                         st { splitChunks  = addFragment f (splitChunks st)+                            , splitCurrCol = splitCurrCol st + fsize+                            }+                     | fTextual f == TSpace ->+                         st { splitChunks = splitChunks st |> S.empty+                            , splitCurrCol = 0+                            }+                     | otherwise ->+                         st { splitChunks  = splitChunks st |> S.singleton f+                            , splitCurrCol = fsize+                            }+                available = maxCols - splitCurrCol st+                fsize = fragmentSize f+                addFragment x (viewr-> ls :> l) = ( ls |> (l |> x))+                addFragment _ _ = error "[unreachable]"+        go st _                 = st++fragmentSize :: Fragment -> Int+fragmentSize f = case fTextual f of+  TStr t     -> textWidth t+  TLink t    -> textWidth t+  TRawHtml t -> textWidth t+  TSpace     -> 1+  TLineBreak -> 0+  TSoftBreak -> 0++strOf :: TextFragment -> Text+strOf f = case f of+  TStr t     -> t+  TLink t    -> t+  TRawHtml t -> t+  TSpace     -> " "+  _          -> ""++-- This finds adjacent string-ey fragments and concats them, so+-- we can use fewer widgets+gatherWidgets :: Seq Fragment -> Seq (Widget a)+gatherWidgets (viewl-> (Fragment frag style :< rs)) = go style (strOf frag) rs+  where go s t (viewl-> (Fragment f s' :< xs))+          | s == s' = go s (t <> strOf f) xs+        go s t xs =+          let w = case s of+                Normal -> textWithCursor t+                Emph   -> B.withDefAttr clientEmphAttr (textWithCursor t)+                Strong -> B.withDefAttr clientStrongAttr (textWithCursor t)+                Code   -> B.withDefAttr codeAttr (textWithCursor t)+                Link   -> B.withDefAttr urlAttr (textWithCursor t)+                Emoji  -> B.withDefAttr emojiAttr (textWithCursor t)+                User   -> B.withDefAttr (attrForUsername $ removeCursor t)+                                        (textWithCursor t)+                Channel -> B.withDefAttr channelNameAttr (textWithCursor t)+          in w <| gatherWidgets xs+gatherWidgets _ =+  S.empty++textWithCursor :: T.Text -> Widget a+textWithCursor t+    | T.any (== cursorSentinel) t = B.visible $ B.txt $ removeCursor t+    | otherwise = B.txt t++inlinesToText :: Seq C.Inline -> T.Text+inlinesToText = F.fold . fmap go+  where go (C.Str t)       = t+        go C.Space         = " "+        go C.SoftBreak     = " "+        go C.LineBreak     = " "+        go (C.Emph is)     = F.fold (fmap go is)+        go (C.Strong is)   = F.fold (fmap go is)+        go (C.Code t)      = t+        go (C.Link is _ _) = F.fold (fmap go is)+        go (C.Image _ _ _) = "[img]"+        go (C.Entity t)    = t+        go (C.RawHtml t)   = t+++++blockGetURLs :: C.Block -> S.Seq (T.Text, T.Text)+blockGetURLs (C.Para is) = mconcat $ inlineGetURLs <$> F.toList is+blockGetURLs (C.Header _ is) = mconcat $ inlineGetURLs <$> F.toList is+blockGetURLs (C.Blockquote bs) = mconcat $ blockGetURLs <$> F.toList bs+blockGetURLs (C.List _ _ bss) = mconcat $ mconcat $ (blockGetURLs <$>) <$> (F.toList <$> bss)+blockGetURLs _ = mempty++inlineGetURLs :: C.Inline -> S.Seq (T.Text, T.Text)+inlineGetURLs (C.Emph is) = mconcat $ inlineGetURLs <$> F.toList is+inlineGetURLs (C.Strong is) = mconcat $ inlineGetURLs <$> F.toList is+inlineGetURLs (C.Link is url "") = (url, inlinesToText is) S.<| (mconcat $ inlineGetURLs <$> F.toList is)+inlineGetURLs (C.Link is _ url) = (url, inlinesToText is) S.<| (mconcat $ inlineGetURLs <$> F.toList is)+inlineGetURLs (C.Image is _ _) = mconcat $ inlineGetURLs <$> F.toList is+inlineGetURLs _ = mempty++replyArrow :: Widget a+replyArrow =+    hBox [ B.str " "+         , B.borderElem B.bsCornerTL+         , B.str "▸"+         ]++findVerbatimChunk :: C.Blocks -> Maybe T.Text+findVerbatimChunk = getFirst . F.foldMap go+  where go (C.CodeBlock _ t) = First (Just t)+        go _                 = First Nothing
+ src/Options.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE TemplateHaskell #-}++module Options where++import Prelude ()+import Prelude.Compat++import Data.Version (showVersion)+import Development.GitRev+import Network.Mattermost.Version (mmApiVersion)+import Paths_matterhorn (version)+import System.Console.GetOpt+import System.Environment (getArgs)+import System.Exit (exitFailure, exitSuccess)++data Behaviour+  = Normal+  | ShowVersion+  | ShowHelp+    deriving (Eq, Show)++data Options = Options+  { optConfLocation :: Maybe FilePath+  , optLogLocation  :: Maybe FilePath+  , optBehaviour    :: Behaviour+  } deriving (Eq, Show)++defaultOptions :: Options+defaultOptions = Options+  { optConfLocation = Nothing+  , optLogLocation  = Nothing+  , optBehaviour    = Normal+  }++optDescrs :: [OptDescr (Options -> Options)]+optDescrs =+  [ Option ['c'] ["config"]+    (ReqArg (\ path c -> c { optConfLocation = Just path }) "PATH")+    "Path to the configuration file"+  , Option ['l'] ["logs"]+    (ReqArg (\ path c -> c { optLogLocation = Just path }) "PATH")+    "Path to the desired debug logs"+  , Option ['v'] ["version"]+    (NoArg (\ c -> c { optBehaviour = ShowVersion }))+    "Print version information and exit"+  , Option ['h'] ["help"]+    (NoArg (\ c -> c { optBehaviour = ShowHelp }))+    "Print help for command-line flags and exit"+  ]++mhVersion :: String+mhVersion+  | $(gitHash) == ("UNKNOWN" :: String) = "matterhorn " ++ showVersion version+  | otherwise = "matterhorn " ++ showVersion version ++ " (" +++                $(gitBranch) ++ "@" ++ take 7 $(gitHash) ++ ")"++fullVersionString :: String+fullVersionString = mhVersion ++ "\n using " ++ mmApiVersion++usage :: IO ()+usage = putStr (usageInfo "matterhorn" optDescrs)++grabOptions :: IO Options+grabOptions = do+  args <- getArgs+  case getOpt Permute optDescrs args of+    (aps, [], []) -> do+      let rs = foldr (.) id aps defaultOptions+      case optBehaviour rs of+        Normal -> return rs+        ShowHelp -> usage >> exitSuccess+        ShowVersion -> putStrLn fullVersionString >> exitSuccess+    (_, _, []) -> do+      usage+      exitFailure+    (_, _, errs) -> do+      mapM_ putStr errs+      usage+      exitFailure
+ src/State.hs view
@@ -0,0 +1,1080 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+module State where++import           Prelude ()+import           Prelude.Compat++import           Brick (invalidateCacheEntry)+import           Brick.Widgets.Edit (getEditContents, editContentsL)+import           Brick.Widgets.List (list, listMoveTo, listSelectedElement)+import           Control.Applicative+import           Control.Exception (SomeException, catch, try)+import           Control.Monad.IO.Class (liftIO)+import qualified Control.Concurrent.STM as STM+import           Data.Char (isAlphaNum)+import           Brick.Main (getVtyHandle, viewportScroll, vScrollToBeginning, vScrollBy)+import           Brick.Widgets.Edit (applyEdit)+import           Control.Monad (when, void)+import qualified Data.ByteString as BS+import           Data.Text.Zipper (textZipper, clearZipper, insertMany, gotoEOL)+import qualified Data.HashMap.Strict as HM+import qualified Data.Sequence as Seq+import           Data.List (sort)+import           Data.Maybe (maybeToList, isJust, catMaybes, isNothing)+import           Data.Monoid ((<>))+import           Data.Time.Clock (UTCTime, getCurrentTime)+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Data.Foldable as F+import           Graphics.Vty (outputIface)+import           Graphics.Vty.Output.Interface (ringTerminalBell)+import           Lens.Micro.Platform+import           System.Exit (ExitCode(..))+import           System.Process (proc, std_in, std_out, std_err, StdStream(..),+                                 createProcess, waitForProcess)+import           System.IO (hGetContents)+import           System.Directory ( createDirectoryIfMissing )+import           System.Environment.XDG.BaseDir ( getUserCacheDir )+import           System.FilePath++import           Network.Mattermost+import           Network.Mattermost.Exceptions+import           Network.Mattermost.Lenses++import           Config+import           FilePaths+import           Types+import           Types.Posts+import           Types.Messages+import           InputHistory+import           Themes+import           Zipper (Zipper)+import qualified Zipper as Z+import           Markdown (blockGetURLs, findVerbatimChunk)++import           State.Common++-- * Hard-coded constants++-- | The number of posts to include per page+pageAmount :: Int+pageAmount = 15++-- * Refreshing Channel Data++-- | Get all the new messages for a given channel. In addition, load the+-- channel metadata and update that, too.+refreshChannel :: ChannelId -> MH ()+refreshChannel chan = do+  msgs <- use (csChannel(chan).ccContents.cdMessages)+  session <- use csSession+  myTeamId <- use (csMyTeam.teamIdL)+  doAsyncWith Normal $+    case getLatestPostId msgs of+    Just pId -> do+      -- Get the latest channel metadata.+      cwd <- mmGetChannel session myTeamId chan++      -- Load posts since the last post in this channel.  Note that+      -- postsOrder from mattermost-api is most recent first.+      posts <- mmGetPostsAfter session myTeamId chan pId 0 100+      return $ do+        mapM_ addMessageToState [ (posts^.postsPostsL) HM.! p+                                | p <- F.toList (posts^.postsOrderL)+                                ]+        let newChanInfo ci = channelInfoFromChannelWithData cwd ci+                               & cdCurrentState     .~ ChanLoaded++        csChannel(chan).ccInfo %= newChanInfo+    _ -> return (return ())++-- | Find all the loaded channels and refresh their state, setting the+-- state as dirty until we get a response+refreshLoadedChannels :: MH ()+refreshLoadedChannels = do+  msgs <- use msgMap+  sequence_+    [ refreshChannel cId+    | (cId, chan) <- HM.toList msgs+    , chan^.ccInfo.cdCurrentState == ChanLoaded+    ]+  let upd ChanLoaded = ChanRefreshing+      upd chanState  = chanState+  msgMap.each.ccInfo.cdCurrentState %= upd++-- * Message selection mode++beginMessageSelect :: MH ()+beginMessageSelect = do+    -- Get the number of messages in the current channel and set the+    -- currently selected message index to be the most recently received+    -- message that corresponds to a Post (i.e. exclude informative+    -- messages).+    --+    -- If we can't find one at all, we ignore the mode switch request+    -- and just return.+    chanMsgs <- use(csCurrentChannel . ccContents . cdMessages)+    let recentPost = getLatestPostId chanMsgs++    when (isJust recentPost) $ do+        csMode .= MessageSelect+        csMessageSelect .= MessageSelectState recentPost++getSelectedMessage :: ChatState -> Maybe Message+getSelectedMessage st+    | st^.csMode /= MessageSelect && st^.csMode /= MessageSelectDeleteConfirm = Nothing+    | otherwise = do+        selPostId <- selectMessagePostId $ st^.csMessageSelect++        let chanMsgs = st ^. csCurrentChannel . ccContents . cdMessages+        findMessage selPostId chanMsgs++messageSelectUp :: MH ()+messageSelectUp = do+    mode <- use csMode+    selected <- use (csMessageSelect.to selectMessagePostId)+    case selected of+        Just _ | mode == MessageSelect -> do+            chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)+            let nextPostId = getPrevPostId selected chanMsgs+            csMessageSelect .= MessageSelectState (nextPostId <|> selected)+        _ -> return ()++messageSelectDown :: MH ()+messageSelectDown = do+    mode <- use csMode+    selected <- use (csMessageSelect.to selectMessagePostId)+    case selected of+        Just _ | mode == MessageSelect -> do+            chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)+            let nextPostId = getNextPostId selected chanMsgs+            csMessageSelect .= MessageSelectState (nextPostId <|> selected)+        _ -> return ()++isMine :: ChatState -> Message -> Bool+isMine st msg = (Just $ st^.csMe.userUsernameL) == msg^.mUserName++messageSelectDownBy :: Int -> MH ()+messageSelectDownBy amt+    | amt <= 0 = return ()+    | otherwise =+        messageSelectDown >> messageSelectDownBy (amt - 1)++messageSelectUpBy :: Int -> MH ()+messageSelectUpBy amt+    | amt <= 0 = return ()+    | otherwise =+      messageSelectUp >> messageSelectUpBy (amt - 1)++beginConfirmDeleteSelectedMessage :: MH ()+beginConfirmDeleteSelectedMessage =+    csMode .= MessageSelectDeleteConfirm++deleteSelectedMessage :: MH ()+deleteSelectedMessage = do+    selectedMessage <- use (to getSelectedMessage)+    st <- use id+    case selectedMessage of+        Just msg | isMine st msg && isDeletable msg -> do+            cId <- use csCurrentChannelId+            session <- use csSession+            myTeamId <- use (csMyTeam.teamIdL)+            doAsyncWith Preempt $ do+                let Just p = msg^.mOriginalPost+                mmDeletePost session myTeamId cId (postId p)+                return $ do+                    csEditState.cedEditMode .= NewPost+                    csMode .= Main+        _ -> return ()++beginCurrentChannelDeleteConfirm :: MH ()+beginCurrentChannelDeleteConfirm = do+    cId <- use csCurrentChannelId+    chType <- use (csChannel(cId).ccInfo.cdType)+    if chType /= Direct+       then csMode .= DeleteChannelConfirm+       else postErrorMessage "The /delete-channel command cannot be used with direct message channels."++deleteCurrentChannel :: MH ()+deleteCurrentChannel = do+    cId <- use csCurrentChannelId+    session <- use csSession+    myTeamId <- use (csMyTeam.teamIdL)+    doAsyncWith Preempt $ do+        mmDeleteChannel session myTeamId cId+        return $ do+            csMode .= Main+            leaveCurrentChannel++beginUpdateMessage :: MH ()+beginUpdateMessage = do+    selected <- use (to getSelectedMessage)+    st <- use id+    case selected of+        Just msg | isMine st msg && isEditable msg -> do+            let Just p = msg^.mOriginalPost+            csMode .= Main+            csEditState.cedEditMode .= Editing p+            csCmdLine %= applyEdit (clearZipper >> (insertMany $ postMessage p))+        _ -> return ()++replyToLatestMessage :: MH ()+replyToLatestMessage = do+  msgs <- use (csCurrentChannel . ccContents . cdMessages)+  case findLatestUserMessage isReplyable msgs of+    Just msg -> do let Just p = msg^.mOriginalPost+                   csMode .= Main+                   csEditState.cedEditMode .= Replying msg p+    _ -> return ()++beginReplyCompose :: MH ()+beginReplyCompose = do+    selected <- use (to getSelectedMessage)+    case selected of+        Nothing -> return ()+        Just msg -> do+            let Just p = msg^.mOriginalPost+            csMode .= Main+            csEditState.cedEditMode .= Replying msg p++cancelReplyOrEdit :: MH ()+cancelReplyOrEdit = do+    mode <- use (csEditState.cedEditMode)+    case mode of+        NewPost -> return ()+        _ -> do+            csEditState.cedEditMode .= NewPost+            csCmdLine %= applyEdit clearZipper++copyVerbatimToClipboard :: MH ()+copyVerbatimToClipboard = do+    selectedMessage <- use (to getSelectedMessage)+    case selectedMessage of+        Nothing -> return ()+        Just m -> case findVerbatimChunk (m^.mText) of+            Nothing -> return ()+            Just txt -> do+              copyToClipboard txt+              csMode .= Main++-- * Joining, Leaving, and Inviting++startJoinChannel :: MH ()+startJoinChannel = do+    session <- use csSession+    myTeamId <- use (csMyTeam.teamIdL)+    doAsyncWith Preempt $ do+        -- We don't get to just request all channels, so we request channels in+        -- chunks of 50.  A better UI might be to request an initial set and+        -- then wait for the user to demand more.+        let fetchCount     = 50+            loop acc start = do+              newChans <- mmGetMoreChannels session myTeamId start fetchCount+              let chans = acc <> newChans+              if length newChans < fetchCount+                then return chans+                else loop chans (start+fetchCount)+        chans <- loop mempty 0+        return $ do+            csJoinChannelList .= (Just $ list JoinChannelList (V.fromList $ F.toList chans) 1)++    csMode .= JoinChannel+    csJoinChannelList .= Nothing++joinChannel :: Channel -> MH ()+joinChannel chan = do+    let cId = getId chan+    session <- use csSession+    myTeamId <- use (csMyTeam.teamIdL)+    doAsyncWith Preempt $ do+        void $ mmJoinChannel session myTeamId cId+        return (return ())++    csMode .= Main++-- | When another user adds us to a channel, we need to fetch the+-- channel info for that channel.+handleChannelInvite :: ChannelId -> MH ()+handleChannelInvite cId = do+    st <- use id+    doAsyncWith Normal $ do+        tryMM (mmGetChannel (st^.csSession) (st^.csMyTeam.teamIdL) cId)+              (\(ChannelWithData chan _) -> do+                return $ do+                  handleNewChannel (preferredChannelName chan) False chan+                  asyncFetchScrollback Normal cId)++startLeaveCurrentChannel :: MH ()+startLeaveCurrentChannel = do+    cInfo <- use (csCurrentChannel.ccInfo)+    case canLeaveChannel cInfo of+        True -> csMode .= LeaveChannelConfirm+        False -> postErrorMessage "The /leave command cannot be used with this channel."++canLeaveChannel :: ChannelInfo -> Bool+canLeaveChannel cInfo = not $ cInfo^.cdType `elem` [Direct, Group]++leaveCurrentChannel :: MH ()+leaveCurrentChannel = do+    cId <- use csCurrentChannelId+    cInfo <- use (csCurrentChannel.ccInfo)+    session <- use csSession+    myTeamId <- use (csMyTeam.teamIdL)++    when (canLeaveChannel cInfo) $ doAsyncWith Preempt $ do+        mmLeaveChannel session myTeamId cId+        return (removeChannelFromState cId)++removeChannelFromState :: ChannelId -> MH ()+removeChannelFromState cId = do+    cName <- use (csChannel(cId).ccInfo.cdName)+    chType <- use (csChannel(cId).ccInfo.cdType)+    when (chType /= Direct) $ do+            csEditState.cedInputHistoryPosition .at cId .= Nothing+            csEditState.cedLastChannelInput     .at cId .= Nothing+            -- Update input history+            csEditState.cedInputHistory         %= removeChannelHistory cId+            -- Flush cnToChanId+            csNames.cnToChanId                  .at cName .= Nothing+            -- Flush cnChans+            csNames.cnChans                     %= filter (/= cName)+            -- Update msgMap+            msgMap                              .at cId .= Nothing+            -- Remove from focus zipper+            csFocus                             %= Z.filterZipper (/= cId)++fetchCurrentChannelMembers :: MH ()+fetchCurrentChannelMembers = do+    cId <- use csCurrentChannelId+    session <- use csSession+    myTeamId <- use (csMyTeam.teamIdL)+    doAsyncWith Preempt $ do+        chanUserMap <- mmGetChannelMembers session myTeamId cId 0 10000++        -- Construct a message listing them all and post it to the+        -- channel:+        let msgStr = "Channel members (" <> (T.pack $ show $ length chanUsers) <> "):\n" <>+                     T.intercalate ", " usernames+            chanUsers = snd <$> HM.toList chanUserMap+            usernames = sort $ userUsername <$> (F.toList chanUsers)++        return $ postInfoMessage msgStr++-- *  Channel Updates and Notifications++hasUnread :: ChatState -> ChannelId -> Bool+hasUnread st cId = maybe False id $ do+  chan <- st^.msgMap.at(cId)+  u <- chan^.ccInfo.cdViewed+  let v = chan^.ccInfo.cdUpdated+  return (v > u)++setLastViewedFor :: ChannelId -> MH ()+setLastViewedFor cId = do+  now <- getNow+  msgs <- use msgMap+  if cId `HM.member` msgs+    then csChannel(cId).ccInfo.cdViewed .= Just now+    else handleChannelInvite cId++updateViewed :: MH ()+updateViewed = do+  st <- use id+  liftIO (updateViewedIO st)++resetHistoryPosition :: MH ()+resetHistoryPosition = do+    cId <- use csCurrentChannelId+    csInputHistoryPosition.at cId .= Just Nothing++updateStatus :: UserId -> T.Text -> MH ()+updateStatus uId t =+  usrMap.ix(uId).uiStatus .= statusFromText t++clearEditor :: MH ()+clearEditor = csCmdLine %= applyEdit clearZipper++loadLastEdit :: MH ()+loadLastEdit = do+    cId <- use csCurrentChannelId+    lastInput <- use (csLastChannelInput.at cId)+    case lastInput of+        Nothing -> return ()+        Just (lastEdit, lastEditMode) -> do+            csCmdLine %= (applyEdit $ insertMany (lastEdit) . clearZipper)+            csEditState.cedEditMode .= lastEditMode++saveCurrentEdit :: MH ()+saveCurrentEdit = do+    cId <- use csCurrentChannelId+    cmdLine <- use csCmdLine+    mode <- use (csEditState.cedEditMode)+    csLastChannelInput.at cId .=+      Just (T.intercalate "\n" $ getEditContents $ cmdLine, mode)++resetCurrentEdit :: MH ()+resetCurrentEdit = do+    cId <- use csCurrentChannelId+    csLastChannelInput.at cId .= Nothing++updateChannelListScroll :: MH ()+updateChannelListScroll = do+    mh $ vScrollToBeginning (viewportScroll ChannelList)++postChangeChannelCommon :: MH ()+postChangeChannelCommon = do+    resetHistoryPosition+    fetchCurrentScrollback+    resetEditorState+    updateChannelListScroll+    loadLastEdit+    resetCurrentEdit++resetEditorState :: MH ()+resetEditorState = do+    csEditState.cedEditMode .= NewPost+    clearEditor++preChangeChannelCommon :: MH ()+preChangeChannelCommon = do+    cId <- use csCurrentChannelId+    csRecentChannel .= Just cId+    saveCurrentEdit+    clearNewMessageCutoff cId++nextChannel :: MH ()+nextChannel = do+    st <- use id+    setFocusWith (getNextNonDMChannel st Z.right)++prevChannel :: MH ()+prevChannel = do+    st <- use id+    setFocusWith (getNextNonDMChannel st Z.left)++recentChannel :: MH ()+recentChannel = do+  recent <- use csRecentChannel+  case recent of+    Nothing  -> return ()+    Just cId -> setFocus cId++nextUnreadChannel :: MH ()+nextUnreadChannel = do+    st <- use id+    setFocusWith (getNextUnreadChannel st)++getNextNonDMChannel :: ChatState+                    -> (Zipper ChannelId -> Zipper ChannelId)+                    -> (Zipper ChannelId -> Zipper ChannelId)+getNextNonDMChannel st shift z =+    if (st^?msgMap.ix(Z.focus z).ccInfo.cdType) == Just Direct+    then z+    else go (shift z)+  where go z'+          | (st^?msgMap.ix(Z.focus z').ccInfo.cdType) /= Just Direct = z'+          | otherwise = go (shift z')++getNextUnreadChannel :: ChatState+                     -> (Zipper ChannelId -> Zipper ChannelId)+getNextUnreadChannel st = Z.findRight (hasUnread st)++listThemes :: MH ()+listThemes = do+    let mkThemeList _ = T.intercalate "\n\n" $+                        "Available built-in themes:" :+                        (("  " <>) <$> fst <$> themes)+    postInfoMessage (mkThemeList themes)++setTheme :: T.Text -> MH ()+setTheme name =+    case lookup name themes of+        Nothing -> listThemes+        Just t -> csResources.crTheme .= t++channelPageUp :: MH ()+channelPageUp = do+  cId <- use csCurrentChannelId+  mh $ vScrollBy (viewportScroll (ChannelMessages cId)) (-1 * pageAmount)++channelPageDown :: MH ()+channelPageDown = do+  cId <- use csCurrentChannelId+  mh $ vScrollBy (viewportScroll (ChannelMessages cId)) pageAmount++asyncFetchMoreMessages :: ChatState -> ChannelId -> IO ()+asyncFetchMoreMessages st cId =+    doAsyncWithIO Preempt st $ do+        let offset = length $ st^.csChannel(cId).ccContents.cdMessages+            numToFetch = 10+        posts <- mmGetPosts (st^.csSession) (st^.csMyTeam.teamIdL) cId (offset - 1) numToFetch+        return $ do+            cc <- fromPosts posts+            ccId <- use csCurrentChannelId+            mh $ invalidateCacheEntry (ChannelMessages ccId)+            mapM_ (\m ->+                   csChannel(ccId).ccContents.cdMessages %= (addMessage m))+                 (cc^.cdMessages)++loadMoreMessages :: MH ()+loadMoreMessages = do+    mode <- use csMode+    cId  <- use csCurrentChannelId+    st   <- use id+    case mode of+        ChannelScroll -> do+            liftIO $ asyncFetchMoreMessages st cId+        _ -> return ()++channelByName :: ChatState -> T.Text -> Maybe ChannelId+channelByName st n+    | (T.singleton normalChannelSigil) `T.isPrefixOf` n = st ^. csNames . cnToChanId . at (T.tail n)+    | (T.singleton userSigil) `T.isPrefixOf` n = st ^. csNames . cnToChanId . at (T.tail n)+    | otherwise            = st ^. csNames . cnToChanId . at n++-- | This switches to the named channel or creates it if it is a missing+-- but valid user channel.+changeChannel :: T.Text -> MH ()+changeChannel name = do+    st <- use id+    case channelByName st name of+      Just cId -> setFocus cId+      Nothing -> attemptCreateDMChannel name++setFocus :: ChannelId -> MH ()+setFocus cId = setFocusWith (Z.findRight (== cId))++setFocusWith :: (Zipper ChannelId -> Zipper ChannelId) -> MH ()+setFocusWith f = do+    oldZipper <- use csFocus+    let newZipper = f oldZipper+        newFocus = Z.focus newZipper+        oldFocus = Z.focus oldZipper++    -- If we aren't changing anything, skip all the book-keeping because+    -- we'll end up clobbering things like csRecentChannel.+    when (newFocus /= oldFocus) $ do+        preChangeChannelCommon+        csFocus .= newZipper+        updateViewed+        postChangeChannelCommon++attemptCreateDMChannel :: T.Text -> MH ()+attemptCreateDMChannel name = do+  users <- use (csNames.cnUsers)+  nameToChanId <- use (csNames.cnToChanId)+  if name `elem` users && not (name `HM.member` nameToChanId)+    then do+      -- We have a user of that name but no channel. Time to make one!+      tId <- use (csMyTeam.teamIdL)+      Just uId <- use (csNames.cnToUserId.at(name))+      session <- use csSession+      doAsyncWith Normal $ do+        -- create a new channel+        nc <- mmCreateDirect session tId uId+        return $ handleNewChannel name True nc+    else+      postErrorMessage ("No channel or user named " <> name)++createOrdinaryChannel :: T.Text -> MH ()+createOrdinaryChannel name  = do+  tId <- use (csMyTeam.teamIdL)+  session <- use csSession+  doAsyncWith Preempt $ do+    -- create a new chat channel+    let slug = T.map (\ c -> if isAlphaNum c then c else '-') (T.toLower name)+        minChannel = MinChannel+          { minChannelName        = slug+          , minChannelDisplayName = name+          , minChannelPurpose     = Nothing+          , minChannelHeader      = Nothing+          , minChannelType        = Ordinary+          }+    tryMM (mmCreateChannel session tId minChannel)+          (return . handleNewChannel name True)++handleNewChannel :: T.Text -> Bool -> Channel -> MH ()+handleNewChannel name switch nc = do+  -- time to do a lot of state updating:+  -- create a new ClientChannel structure+  now <- getNow+  let cChannel = ClientChannel+        { _ccContents = emptyChannelContents+        , _ccInfo     = ChannelInfo+                          { _cdViewed           = Nothing+                          , _cdUpdated          = now+                          , _cdName             = preferredChannelName nc+                          , _cdHeader           = nc^.channelHeaderL+                          , _cdType             = nc^.channelTypeL+                          , _cdCurrentState     = ChanLoaded+                          , _cdNewMessageCutoff = Nothing+                          }+        }+  -- add it to the message map, and to the map so we can look it up by+  -- user name+  csNames.cnToChanId.at(name) .= Just (getId nc)+  let chType = nc^.channelTypeL+  -- For direct channels the username is already in the user list so+  -- do nothing+  when (chType /= Direct) $+      csNames.cnChans %= (sort . (name:))+  msgMap.at(getId nc) .= Just cChannel+  -- we should figure out how to do this better: this adds it to the+  -- channel zipper in such a way that we don't ever change our focus+  -- to something else, which is kind of silly+  names <- use csNames+  let newZip = Z.updateList (mkChannelZipperList names)+  csFocus %= newZip+    -- and we finally set our focus to the newly created channel+  when switch $ setFocus (getId nc)++editMessage :: Post -> MH ()+editMessage new = do+  now <- getNow+  st <- use id+  let chan = csChannel (postChannelId new)+      isEditedMessage m = m^.mPostId == Just (new^.postIdL)+      msg = clientPostToMessage st (toClientPost new (new^.postParentIdL))+  chan . ccContents . cdMessages . traversed . filtered isEditedMessage .= msg+  chan . ccInfo . cdUpdated .= now+  csPostMap.ix(postId new) .= msg+  cId <- use csCurrentChannelId+  when (postChannelId new == cId) $+    updateViewed++deleteMessage :: Post -> MH ()+deleteMessage new = do+  now <- getNow+  let isDeletedMessage m = m^.mPostId == Just (new^.postIdL)+      chan = csChannel (postChannelId new)+  chan.ccContents.cdMessages.traversed.filtered isDeletedMessage %= (& mDeleted .~ True)+  chan.ccInfo.cdUpdated .= now+  cId <- use csCurrentChannelId+  when (postChannelId new == cId) $+    updateViewed++maybeRingBell :: MH ()+maybeRingBell = do+    doBell <- use (csResources.crConfiguration.to configActivityBell)+    when doBell $ do+        -- This is safe because we only get Nothing in appStartEvent.+        Just vty <- mh getVtyHandle+        liftIO $ ringTerminalBell $ outputIface vty++addMessageToState :: Post -> MH ()+addMessageToState new = do+  st <- use id+  asyncFetchAttachments new+  case st^.msgMap.at (postChannelId new) of+      Nothing ->+          -- When we join channels, sometimes we get the "user has+          -- been added to channel" message here BEFORE we get the+          -- websocket event that says we got added to a channel. This+          -- means the message arriving here in addMessage can't be+          -- added yet because we haven't fetched the channel metadata+          -- in the websocket handler. So to be safe we just drop the+          -- message here, but this is the only case of messages that we+          -- /expect/ to drop for this reason. Hence the check for the+          -- msgMap channel ID key presence above.+          return ()+      Just _ -> do+          now <- getNow+          let cp = toClientPost new (new^.postParentIdL)+              fromMe = (cp^.cpUser == (Just $ getId (st^.csMe))) &&+                       (isNothing $ cp^.cpUserOverride)+              updateTime = if fromMe then id else const now+              cId = postChannelId new++              doAddMessage = do+                s <- use id+                let chan = msgMap . ix cId+                    msg' = clientPostToMessage s (toClientPost new (new^.postParentIdL))+                csPostMap.ix(postId new) .= msg'+                chan.ccContents.cdMessages %= (addMessage msg')+                chan.ccInfo.cdUpdated %= updateTime+                when (not fromMe) $ maybeRingBell+                ccId <- use csCurrentChannelId+                if postChannelId new == ccId+                  then updateViewed+                  else setNewMessageCutoff cId msg'++              doHandleNewMessage = do+                  -- If the message is in reply to another message,+                  -- try to find it in the scrollback for the post's+                  -- channel. If the message isn't there, fetch it. If+                  -- we have to fetch it, don't post this message to the+                  -- channel until we have fetched the parent.+                  case getMessageForPostId st <$> cp^.cpInReplyToPost of+                      Just (ParentNotLoaded parentId) -> do+                          doAsyncWith Normal $ do+                              let theTeamId = st^.csMyTeam.teamIdL+                              p <- mmGetPost (st^.csSession) theTeamId cId parentId+                              let postMap = HM.fromList [ ( pId+                                                          , clientPostToMessage st (toClientPost x (x^.postParentIdL))+                                                          )+                                                        | (pId, x) <- HM.toList (p^.postsPostsL)+                                                        ]+                              return $ do+                                csPostMap %= HM.union postMap+                                doAddMessage+                      _ -> doAddMessage++          -- If this message was written by a user we don't know about,+          -- fetch the user's information before posting the message.+          case cp^.cpUser of+              Nothing -> doHandleNewMessage+              Just uId ->+                  case st^.usrMap.at uId of+                      Just _ -> doHandleNewMessage+                      Nothing -> do+                          handleNewUser uId+                          doAsyncWith Normal $ return doHandleNewMessage++setNewMessageCutoff :: ChannelId -> Message -> MH ()+setNewMessageCutoff cId msg =+    csChannel(cId).ccInfo.cdNewMessageCutoff %= (<|> Just (msg^.mDate))++clearNewMessageCutoff :: ChannelId -> MH ()+clearNewMessageCutoff cId =+    csChannel(cId).ccInfo.cdNewMessageCutoff .= Nothing++getNewMessageCutoff :: ChannelId -> ChatState -> Maybe UTCTime+getNewMessageCutoff cId st = do+    cc <- st^.msgMap.at cId+    cc^.ccInfo.cdNewMessageCutoff++execMMCommand :: T.Text -> T.Text -> MH ()+execMMCommand name rest = do+  cId      <- use csCurrentChannelId+  session  <- use csSession+  myTeamId <- use (csMyTeam.teamIdL)+  let mc = MinCommand+             { minComChannelId = cId+             , minComCommand   = "/" <> name <> " " <> rest+             }+      runCmd = liftIO $ do+        void $ mmExecute session myTeamId mc+      handler (HTTPResponseException err) = return (Just err)+  errMsg <- liftIO $ (runCmd >> return Nothing) `catch` handler+  case errMsg of+    Nothing -> return ()+    Just err ->+      postErrorMessage ("Error running command: " <> (T.pack err))++fetchCurrentScrollback :: MH ()+fetchCurrentScrollback = do+  cId <- use csCurrentChannelId+  currentState <- preuse (msgMap.ix(cId).ccInfo.cdCurrentState)+  didQueue <- case maybe False (== ChanUnloaded) currentState of+      True -> do+          asyncFetchScrollback Preempt cId+          return True+      False -> return False+  csChannel(cId).ccInfo.cdCurrentState %=+    if didQueue then const ChanLoadPending else id++mkChannelZipperList :: MMNames -> [ChannelId]+mkChannelZipperList chanNames =+  [ (chanNames ^. cnToChanId) HM.! i+  | i <- chanNames ^. cnChans ] +++  [ c+  | i <- chanNames ^. cnUsers+  , c <- maybeToList (HM.lookup i (chanNames ^. cnToChanId)) ]++setChannelTopic :: ChatState -> T.Text -> IO ()+setChannelTopic st msg = do+    let chanId = st^.csCurrentChannelId+        theTeamId = st^.csMyTeam.teamIdL+    doAsyncWithIO Normal st $ do+        void $ mmSetChannelHeader (st^.csSession) theTeamId chanId msg+        return $ msgMap.at chanId.each.ccInfo.cdHeader .= msg++channelHistoryForward :: MH ()+channelHistoryForward = do+  cId <- use csCurrentChannelId+  inputHistoryPos <- use (csInputHistoryPosition.at cId)+  inputHistory <- use csInputHistory+  case inputHistoryPos of+      Just (Just i)+        | i == 0 -> do+          -- Transition out of history navigation+          csInputHistoryPosition.at cId .= Just Nothing+          loadLastEdit+        | otherwise -> do+          let Just entry = getHistoryEntry cId newI inputHistory+              newI = i - 1+              eLines = T.lines entry+              mv = if length eLines == 1 then gotoEOL else id+          csCmdLine.editContentsL .= (mv $ textZipper eLines Nothing)+          csInputHistoryPosition.at cId .= (Just $ Just newI)+      _ -> return ()++channelHistoryBackward :: MH ()+channelHistoryBackward = do+  cId <- use csCurrentChannelId+  inputHistoryPos <- use (csInputHistoryPosition.at cId)+  inputHistory <- use csInputHistory+  case inputHistoryPos of+      Just (Just i) ->+          let newI = i + 1+          in case getHistoryEntry cId newI inputHistory of+              Nothing -> return ()+              Just entry -> do+                  let eLines = T.lines entry+                      mv = if length eLines == 1 then gotoEOL else id+                  csCmdLine.editContentsL .= (mv $ textZipper eLines Nothing)+                  csInputHistoryPosition.at cId .= (Just $ Just newI)+      _ ->+          let newI = 0+          in case getHistoryEntry cId newI inputHistory of+              Nothing -> return ()+              Just entry ->+                  let eLines = T.lines entry+                      mv = if length eLines == 1 then gotoEOL else id+                  in do+                    saveCurrentEdit+                    csCmdLine.editContentsL .= (mv $ textZipper eLines Nothing)+                    csInputHistoryPosition.at cId .= (Just $ Just newI)++showHelpScreen :: HelpScreen -> MH ()+showHelpScreen screen = do+    mh $ vScrollToBeginning (viewportScroll HelpViewport)+    csMode .= ShowHelp screen++beginChannelSelect :: MH ()+beginChannelSelect = do+    csMode                        .= ChannelSelect+    csChannelSelectString         .= ""+    csChannelSelectChannelMatches .= mempty+    csChannelSelectUserMatches    .= mempty++updateChannelSelectMatches :: MH ()+updateChannelSelectMatches = do+    -- Given the current channel select string, find all the channel and+    -- user matches and then update the match lists.+    chanNameMatches <- use (csChannelSelectString.to channelNameMatch)+    chanNames   <- use (csNames.cnChans)+    userNames   <- use (to sortedUserList)+    let chanMatches = catMaybes (fmap chanNameMatches chanNames)+    let userMatches = catMaybes (fmap chanNameMatches (fmap _uiName userNames))+    let mkMap ms = HM.fromList [(channelNameFromMatch m, m) | m <- ms]+    csChannelSelectChannelMatches .= mkMap chanMatches+    csChannelSelectUserMatches    .= mkMap userMatches++channelNameMatch :: T.Text -> T.Text -> Maybe ChannelSelectMatch+channelNameMatch patStr chanName =+    if T.null patStr+    then Nothing+    else do+        pat <- parseChannelSelectPattern patStr+        applySelectPattern pat chanName++applySelectPattern :: ChannelSelectPattern -> T.Text -> Maybe ChannelSelectMatch+applySelectPattern (CSP ty pat) chanName = do+    let applyType Infix  | pat `T.isInfixOf`  chanName =+            case T.breakOn pat chanName of+                (pre, post) -> return (pre, pat, T.drop (T.length pat) post)++        applyType Prefix | pat `T.isPrefixOf` chanName = do+            let (b, a) = T.splitAt (T.length pat) chanName+            return ("", b, a)++        applyType Suffix | pat `T.isSuffixOf` chanName = do+            let (b, a) = T.splitAt (T.length chanName - T.length pat) chanName+            return (b, a, "")++        applyType Equal  | pat == chanName =+            return ("", chanName, "")++        applyType _ = Nothing++    (pre, m, post) <- applyType ty+    return $ ChannelSelectMatch pre m post++parseChannelSelectPattern :: T.Text -> Maybe ChannelSelectPattern+parseChannelSelectPattern pat = do+    (pat1, pfx) <- case "^" `T.isPrefixOf` pat of+        True  -> return (T.tail pat, Just Prefix)+        False -> return (pat, Nothing)++    (pat2, sfx) <- case "$" `T.isSuffixOf` pat1 of+        True  -> return (T.init pat1, Just Suffix)+        False -> return (pat1, Nothing)++    case (pfx, sfx) of+        (Nothing, Nothing)         -> return $ CSP Infix  pat2+        (Just Prefix, Nothing)     -> return $ CSP Prefix pat2+        (Nothing, Just Suffix)     -> return $ CSP Suffix pat2+        (Just Prefix, Just Suffix) -> return $ CSP Equal  pat2+        tys                        -> error $ "BUG: invalid channel select case: " <> show tys++startUrlSelect :: MH ()+startUrlSelect = do+    urls <- use (csCurrentChannel.to findUrls.to V.fromList)+    csMode    .= UrlSelect+    csUrlList .= (listMoveTo (length urls - 1) $ list UrlList urls 2)++stopUrlSelect :: MH ()+stopUrlSelect = csMode .= Main++findUrls :: ClientChannel -> [LinkChoice]+findUrls chan =+    let msgs = chan^.ccContents.cdMessages+    in removeDuplicates $ concat $ F.toList $ F.toList <$> Seq.reverse <$> msgURLs <$> msgs++removeDuplicates :: [LinkChoice] -> [LinkChoice]+removeDuplicates = snd . go Set.empty+  where go before [] = (before, [])+        go before (x:xs) =+          let (before', xs') = go before xs in+          if (x^.linkURL) `Set.member` before'+            then (before', xs')+            else (Set.insert (x^.linkURL) before', x : xs')++msgURLs :: Message -> Seq.Seq LinkChoice+msgURLs msg | Just uname <- msg^.mUserName =+  let msgUrls = (\ (url, text) -> LinkChoice (msg^.mDate) uname text url Nothing) <$>+                  (mconcat $ blockGetURLs <$> (F.toList $ msg^.mText))+      attachmentURLs = (\ a ->+                          LinkChoice+                            (msg^.mDate)+                            uname+                            ("attachment `" <> (a^.attachmentName) <> "`")+                            (a^.attachmentURL)+                            (Just (a^.attachmentFileId)))+                       <$> (msg^.mAttachments)+  in msgUrls <> attachmentURLs+msgURLs _ = mempty++openSelectedURL :: MH ()+openSelectedURL = do+  mode <- use csMode+  when (mode == UrlSelect) $ do+    selected <- use (csUrlList.to listSelectedElement)+    case selected of+        Nothing -> return ()+        Just (_, link) -> do+            opened <- openURL link+            when (not opened) $ do+                let msg = "Config option 'urlOpenCommand' missing; cannot open URL."+                postInfoMessage msg+                csMode .= Main++openURL :: LinkChoice -> MH Bool+openURL link = do+    cmd <- use (csResources.crConfiguration.to configURLOpenCommand)+    case cmd of+        Nothing ->+            return False+        Just urlOpenCommand ->+            case _linkFileId link of+              Nothing -> do+                runLoggedCommand (T.unpack urlOpenCommand) [T.unpack $ link^.linkURL]+                return True+              Just fId -> do+                sess  <- use csSession+                doAsyncWith Normal $ do+                  info     <- mmGetFileInfo sess fId+                  contents <- mmGetFile sess fId+                  cacheDir <- getUserCacheDir xdgName+                  let dir   = cacheDir </> "files" </> T.unpack (idString fId)+                      fname = dir </> T.unpack (fileInfoName info)+                  createDirectoryIfMissing True dir+                  BS.writeFile fname contents+                  return $! runLoggedCommand (T.unpack urlOpenCommand) [fname]+                return True++runLoggedCommand :: String -> [String] -> MH ()+runLoggedCommand cmd args = do+  st <- use id+  liftIO $ do+    let opener = (proc cmd args) { std_in = NoStream+                                 , std_out = CreatePipe+                                 , std_err = CreatePipe+                                 }+    result <- try $ createProcess opener+    case result of+        Left (e::SomeException) -> do+            let po = ProgramOutput cmd args "" (show e) (ExitFailure 1)+            STM.atomically $ STM.writeTChan (st^.csResources.crSubprocessLog) po+        Right (Nothing, Just outh, Just errh, ph) -> do+            ec <- waitForProcess ph+            outResult <- hGetContents outh+            errResult <- hGetContents errh+            let po = ProgramOutput cmd args outResult errResult ec+            STM.atomically $ STM.writeTChan (st^.csResources.crSubprocessLog) po+        Right _ ->+            error $ "BUG: createProcess returned unexpected result, report this at " <>+                    "https://github.com/matterhorn-chat/matterhorn"++openSelectedMessageURLs :: MH ()+openSelectedMessageURLs = do+    mode <- use csMode+    when (mode == MessageSelect) $ do+        Just curMsg <- use (to getSelectedMessage)+        let urls = msgURLs curMsg+        when (not (null urls)) $ do+            openedAll <- and <$> mapM openURL urls+            case openedAll of+                True -> csMode .= Main+                False -> do+                    let msg = "Config option 'urlOpenCommand' missing; cannot open URL."+                    postInfoMessage msg++shouldSkipMessage :: T.Text -> Bool+shouldSkipMessage "" = True+shouldSkipMessage s = T.all (`elem` (" \t"::String)) s++sendMessage :: EditMode -> T.Text -> MH ()+sendMessage mode msg =+    case shouldSkipMessage msg of+        True -> return ()+        False -> do+            status <- use csConnectionStatus+            st <- use id+            case status of+                Disconnected -> do+                    let m = "Cannot send messages while disconnected."+                    postErrorMessage m+                Connected -> do+                    let myId   = st^.csMe.userIdL+                        chanId = st^.csCurrentChannelId+                        theTeamId = st^.csMyTeam.teamIdL+                    doAsync Preempt $ do+                      case mode of+                        NewPost -> do+                            pendingPost <- mkPendingPost msg myId chanId+                            void $ mmPost (st^.csSession) theTeamId pendingPost+                        Replying _ p -> do+                            pendingPost <- mkPendingPost msg myId chanId+                            let modifiedPost =+                                    pendingPost { pendingPostParentId = Just $ postId p+                                                , pendingPostRootId = Just $ postId p+                                                }+                            void $ mmPost (st^.csSession) theTeamId modifiedPost+                        Editing p -> do+                            now <- getCurrentTime+                            let modifiedPost = p { postMessage = msg+                                                 , postPendingPostId = Nothing+                                                 , postUpdateAt = now+                                                 }+                            void $ mmUpdatePost (st^.csSession) theTeamId modifiedPost++handleNewUser :: UserId -> MH ()+handleNewUser newUserId = do+    -- Fetch the new user record.+    st <- use id+    doAsyncWith Normal $ do+        newUser <- mmGetUser (st^.csSession) newUserId+        -- Also re-load the team members so we can tell whether the new+        -- user is in the current user's team.+        teamUsers <- mmGetProfiles (st^.csSession) (st^.csMyTeam.teamIdL) 0 10000+        let uInfo = userInfoFromUser newUser (HM.member newUserId teamUsers)++        return $ do+            -- Update the name map and the list of known users+            usrMap . at newUserId .= Just uInfo+            csNames . cnUsers %= (sort . ((newUser^.userUsernameL):))
+ src/State/Common.hs view
@@ -0,0 +1,263 @@+module State.Common where++import           Prelude ()+import           Prelude.Compat++import qualified Control.Concurrent.STM as STM+import           Control.Exception (try)+import           Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Data.Foldable as F+import qualified Data.HashMap.Strict as HM+import           Data.List (sort)+import qualified Data.Map.Strict as Map+import           Data.Monoid ((<>))+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import           Data.Time.Clock (getCurrentTime)+import           Lens.Micro.Platform+import           System.Hclip (setClipboard, ClipboardException(..))++import           Network.Mattermost+import           Network.Mattermost.Lenses+import           Network.Mattermost.Exceptions++import           Types+import           Types.Posts+import           Types.Messages++-- * MatterMost API++-- | Try to run a computation, posting an informative error+--   message if it fails with a 'MattermostServerError'.+tryMM :: IO a+      -- ^ The action to try (usually a MM API call)+      -> (a -> IO (MH ()))+      -- ^ What to do on success+      -> IO (MH ())+tryMM act onSuccess = do+    result <- liftIO $ try act+    case result of+        Left (MattermostServerError msg) -> return $ postErrorMessage msg+        Right value                      -> liftIO $ onSuccess value++-- * Background Computation++-- | Priority setting for asynchronous work items. Preempt means that+-- the queued item will be the next work item begun (i.e. it goes to the+-- front of the queue); normal means it will go last in the queue.+data AsyncPriority = Preempt | Normal++-- | Run a computation in the background, ignoring any results+--   from it.+doAsync :: AsyncPriority -> IO () -> MH ()+doAsync prio thunk = doAsyncWith prio (thunk >> return (return ()))++-- | Run a computation in the background, returning a computation+--   to be called on the 'ChatState' value.+doAsyncWith :: AsyncPriority -> IO (MH ()) -> MH ()+doAsyncWith prio thunk = do+    let putChan = case prio of+          Preempt -> STM.unGetTChan+          Normal  -> STM.writeTChan+    queue <- use (csResources.crRequestQueue)+    liftIO $ STM.atomically $ putChan queue $ thunk++doAsyncIO :: AsyncPriority -> ChatState -> IO () -> IO ()+doAsyncIO prio st thunk =+  doAsyncWithIO prio st (thunk >> return (return ()))++-- | Run a computation in the background, returning a computation+--   to be called on the 'ChatState' value.+doAsyncWithIO :: AsyncPriority -> ChatState -> IO (MH ()) -> IO ()+doAsyncWithIO prio st thunk = do+    let putChan = case prio of+          Preempt -> STM.unGetTChan+          Normal  -> STM.writeTChan+    let queue = st^.csResources.crRequestQueue+    STM.atomically $ putChan queue $ thunk++-- * Client Messages++-- | Create 'ChannelContents' from a 'Posts' value+fromPosts :: Posts -> MH ChannelContents+fromPosts ps = do+  msgs <- messagesFromPosts ps+  F.forM_ (ps^.postsPostsL) $+    asyncFetchAttachments+  return (ChannelContents msgs)++getDMChannelName :: UserId -> UserId -> T.Text+getDMChannelName me you = cname+  where+  [loUser, hiUser] = sort $ idString <$> [ you, me ]+  cname = loUser <> "__" <> hiUser++messagesFromPosts :: Posts -> MH Messages+messagesFromPosts p = do -- (msgs, st')+  st <- use id+  csPostMap %= HM.union (postMap st)+  st' <- use id+  let msgs = postsToMessages (clientPostToMessage st') (clientPost <$> ps)+      postsToMessages f = foldr (addMessage . f) noMessages+  return msgs+    where+        postMap :: ChatState -> HM.HashMap PostId Message+        postMap st = HM.fromList [ ( pId+                                , clientPostToMessage st (toClientPost x Nothing)+                                )+                              | (pId, x) <- HM.toList (p^.postsPostsL)+                              ]+        -- n.b. postsOrder is most recent first+        ps   = findPost <$> (Seq.reverse $ postsOrder p)+        clientPost :: Post -> ClientPost+        clientPost x = toClientPost x (postId <$> parent x)+        parent x = do+            parentId <- x^.postParentIdL+            HM.lookup parentId (p^.postsPostsL)+        findPost pId = case HM.lookup pId (postsPosts p) of+            Nothing -> error $ "BUG: could not find post for post ID " <> show pId+            Just post -> post++asyncFetchAttachments :: Post -> MH ()+asyncFetchAttachments p = do+  let cId = (p^.postChannelIdL)+      pId = (p^.postIdL)+  session <- use csSession+  host    <- use (csResources.crConn.cdHostnameL)+  F.forM_ (p^.postFileIdsL) $ \fId -> doAsyncWith Normal $ do+    info <- mmGetFileInfo session fId+    let scheme = "https://"+        attUrl = scheme <> host <> urlForFile fId+        attachment = Attachment+                       { _attachmentName   = fileInfoName info+                       , _attachmentURL    = attUrl+                       , _attachmentFileId = fId+                       }+        addAttachment m+          | m^.mPostId == Just pId =+            m & mAttachments %~ (attachment Seq.<|)+          | otherwise              = m+    return $+      csChannel(cId).ccContents.cdMessages.traversed %= addAttachment++-- | Create a new 'ClientMessage' value+newClientMessage :: (MonadIO m) => ClientMessageType -> T.Text -> m ClientMessage+newClientMessage ty msg = do+  now <- liftIO getCurrentTime+  return (ClientMessage msg now ty)++-- | Add a 'ClientMessage' to the current channel's message list+addClientMessage :: ClientMessage -> MH ()+addClientMessage msg = do+  cid <- use csCurrentChannelId+  msgMap.ix cid.ccContents.cdMessages %= (addMessage $ clientMessageToMessage msg)++-- | Add a new 'ClientMessage' representing an error message to+--   the current channel's message list+postInfoMessage :: T.Text -> MH ()+postInfoMessage err = do+    msg <- newClientMessage Informative err+    doAsyncWith Normal (return $ addClientMessage msg)++-- | Add a new 'ClientMessage' representing an error message to+--   the current channel's message list+postErrorMessage :: T.Text -> MH ()+postErrorMessage err = do+    msg <- newClientMessage Error err+    doAsyncWith Normal (return $ addClientMessage msg)++postErrorMessageIO :: T.Text -> ChatState -> IO ChatState+postErrorMessageIO err st = do+  now <- liftIO getCurrentTime+  let msg = ClientMessage err now Error+      cId = st ^. csCurrentChannelId+  return $ st & msgMap.ix cId.ccContents.cdMessages %~ (addMessage $ clientMessageToMessage msg)++numScrollbackPosts :: Int+numScrollbackPosts = 100++-- | Fetch scrollback for a channel in the background+asyncFetchScrollback :: AsyncPriority -> ChannelId -> MH ()+asyncFetchScrollback prio cId = do+    session  <- use csSession+    myTeamId <- use (csMyTeam.teamIdL)+    Just viewTime <- preuse (msgMap.ix cId.ccInfo.cdViewed)+    doAsyncWith prio $ do+        posts <- mmGetPosts session myTeamId cId 0 numScrollbackPosts+        return $ do+            mapM_ (asyncFetchReactionsForPost cId) (posts^.postsPostsL)+            contents <- fromPosts posts+            -- We need to set the new message cutoff only if there are+            -- actually messages that came in after our last view time.+            let setCutoff = if hasNew+                            then const $ Just $ minimum (_mDate <$> newMessages)+                            else id+                hasNew = not $ null newMessages+                newMessages = case viewTime of+                    Nothing -> mempty+                    Just vt -> messagesAfter vt $ contents^.cdMessages+            csChannel(cId).ccContents .= contents+            csChannel(cId).ccInfo.cdCurrentState .= ChanLoaded+            csChannel(cId).ccInfo.cdNewMessageCutoff %= setCutoff++asyncFetchReactionsForPost :: ChannelId -> Post -> MH ()+asyncFetchReactionsForPost cId p+  | not (p^.postHasReactionsL) = return ()+  | otherwise = do+      session <- use csSession+      myTeamId <- use (csMyTeam.teamIdL)+      doAsyncWith Normal $ do+        reactions <- mmGetReactionsForPost session myTeamId cId (p^.postIdL)+        return $ do+          let insert r = Map.insertWith (+) (r^.reactionEmojiNameL) 1+              insertAll m = foldr insert m reactions+              upd m | m^.mPostId == Just (p^.postIdL) =+                        m & mReactions %~ insertAll+                    | otherwise = m+          csChannel(cId).ccContents.cdMessages %= fmap upd++addReaction :: Reaction -> ChannelId -> MH ()+addReaction r cId = csChannel(cId).ccContents.cdMessages %= fmap upd+  where upd m | m^.mPostId == Just (r^.reactionPostIdL) =+                  m & mReactions %~ (Map.insertWith (+) (r^.reactionEmojiNameL) 1)+              | otherwise = m++removeReaction :: Reaction -> ChannelId -> MH ()+removeReaction r cId = csChannel(cId).ccContents.cdMessages %= fmap upd+  where upd m | m^.mPostId == Just (r^.reactionPostIdL) =+                  m & mReactions %~ (Map.insertWith (+) (r^.reactionEmojiNameL) (-1))+              | otherwise = m++updateViewedIO :: ChatState -> IO ()+updateViewedIO st = do+  -- Only do this if we're connected to avoid triggering noisy exceptions.+  case st^.csConnectionStatus of+      Connected -> do+          now <- getCurrentTime+          let cId = st^.csCurrentChannelId+              pId = st^.csRecentChannel+          doAsyncWithIO Preempt st $ do+            mmViewChannel+              (st^.csSession)+              (getId (st^.csMyTeam))+              cId+              pId+            return (csChannel(cId).ccInfo.cdViewed .= Just now)+      Disconnected -> return ()++copyToClipboard :: T.Text -> MH ()+copyToClipboard txt = do+  result <- liftIO (try (setClipboard (T.unpack txt)))+  case result of+    Left e -> do+      let errMsg = case e of+            UnsupportedOS _ ->+              "Matterhorn does not support yanking on this operating system."+            NoTextualData ->+              "Textual data is required to set the clipboard."+            MissingCommands cmds ->+              "Could not set clipboard due to missing one of the " <>+              "required program(s): " <> (T.pack $ show cmds)+      postErrorMessage errMsg+    Right () ->+      return ()
+ src/State/Editing.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE MultiWayIf #-}++module State.Editing where++import           Prelude ()+import           Prelude.Compat++import           Brick.Widgets.Edit (Editor, handleEditorEvent, getEditContents, editContentsL)+import           Brick.Widgets.Edit (applyEdit)+import qualified Codec.Binary.UTF8.Generic as UTF8+import           Control.Arrow+import           Control.Monad (void)+import           Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString as BS+import qualified Data.HashMap.Strict as HM+import           Data.Monoid ((<>))+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Zipper as Z+import qualified Data.Text.Zipper.Generic.Words as Z+import           Graphics.Vty (Event(..), Key(..), Modifier(..))+import           Lens.Micro.Platform+import qualified System.Environment as Sys+import qualified System.Exit as Sys+import qualified System.IO as Sys+import qualified System.IO.Temp as Sys+import qualified System.Process as Sys++import           Network.Mattermost+import           Network.Mattermost.Lenses++import           Config+import           Types++import           State.Common++startMultilineEditing :: MH ()+startMultilineEditing = csEditState.cedMultiline .= True++toggleMultilineEditing :: MH ()+toggleMultilineEditing = csEditState.cedMultiline %= not++invokeExternalEditor :: MH ()+invokeExternalEditor = do+    -- If EDITOR is in the environment, write the current message to a+    -- temp file, invoke EDITOR on it, read the result, remove the temp+    -- file, and update the program state.+    --+    -- If EDITOR is not present, fall back to 'vi'.+    mEnv <- liftIO $ Sys.lookupEnv "EDITOR"+    let editorProgram = maybe "vi" id mEnv++    mhSuspendAndResume $ \ st -> do+      Sys.withSystemTempFile "matterhorn_editor.tmp" $ \tmpFileName tmpFileHandle -> do+        -- Write the current message to the temp file+        Sys.hPutStr tmpFileHandle $ T.unpack $ T.intercalate "\n" $+            getEditContents $ st^.csCmdLine+        Sys.hClose tmpFileHandle++        -- Run the editor+        status <- Sys.system (editorProgram <> " " <> tmpFileName)++        -- On editor exit, if exited with zero status, read temp file.+        -- If non-zero status, skip temp file read.+        case status of+            Sys.ExitSuccess -> do+                tmpBytes <- BS.readFile tmpFileName+                case T.decodeUtf8' tmpBytes of+                    Left _ -> do+                        postErrorMessageIO "Failed to decode file contents as UTF-8" st+                    Right t -> do+                        let tmpLines = T.lines t+                        return $ st & csCmdLine.editContentsL .~ (Z.textZipper tmpLines Nothing)+                                    & csEditState.cedMultiline .~ (length tmpLines > 1)+            Sys.ExitFailure _ -> return st++toggleMessagePreview :: MH ()+toggleMessagePreview = csShowMessagePreview %= not++addUserToCurrentChannel :: T.Text -> MH ()+addUserToCurrentChannel uname = do+    -- First: is this a valid username?+    usrs <- use usrMap+    let results = filter ((== uname) . _uiName . snd) $ HM.toList usrs+    case results of+        [(uid, _)] -> do+            cId <- use csCurrentChannelId+            session <- use csSession+            myTeamId <- use (csMyTeam.teamIdL)+            doAsyncWith Normal $ do+                tryMM (void $ mmChannelAddUser session myTeamId cId uid)+                      (const $ return (return ()))+        _ -> do+            postErrorMessage ("No such user: " <> uname)++handlePaste :: BS.ByteString -> MH ()+handlePaste bytes = do+  let pasteStr = T.pack (UTF8.toString bytes)+  csCmdLine %= applyEdit (Z.insertMany pasteStr)+  contents <- use (csCmdLine.to getEditContents)+  case length contents > 1 of+      True -> startMultilineEditing+      False -> return ()++editingPermitted :: ChatState -> Bool+editingPermitted st =+    (length (getEditContents $ st^.csCmdLine) == 1) ||+    st^.csEditState.cedMultiline++editingKeybindings :: [Keybinding]+editingKeybindings =+  [ KB "Transpose the final two characters"+    (EvKey (KChar 't') [MCtrl]) $ do+    csCmdLine %= applyEdit Z.transposeChars+  , KB "Move one character to the right"+    (EvKey (KChar 'f') [MCtrl]) $ do+    csCmdLine %= applyEdit Z.moveRight+  , KB "Move one character to the left"+    (EvKey (KChar 'b') [MCtrl]) $ do+    csCmdLine %= applyEdit Z.moveLeft+  , KB "Move one word to the right"+    (EvKey (KChar 'f') [MMeta]) $ do+    csCmdLine %= applyEdit Z.moveWordRight+  , KB "Move one word to the left"+    (EvKey (KChar 'b') [MMeta]) $ do+    csCmdLine %= applyEdit Z.moveWordLeft+  , KB "Delete the word to the left of the cursor"+    (EvKey (KBS) [MMeta]) $ do+    csCmdLine %= applyEdit Z.deletePrevWord+  , KB "Delete the word to the left of the cursor"+    (EvKey (KChar 'w') [MCtrl]) $ do+    csCmdLine %= applyEdit Z.deletePrevWord+  , KB "Delete the word to the right of the cursor"+    (EvKey (KChar 'd') [MMeta]) $ do+    csCmdLine %= applyEdit Z.deleteWord+  , KB "Kill the line to the right of the current position and copy it"+    (EvKey (KChar 'k') [MCtrl]) $ do+      z <- use (csCmdLine.editContentsL)+      let restOfLine = Z.currentLine (Z.killToBOL z)+      csEditState.cedYankBuffer .= restOfLine+      csCmdLine %= applyEdit Z.killToEOL+  , KB "Paste the current buffer contents at the cursor"+    (EvKey (KChar 'y') [MCtrl]) $ do+      buf <- use (csEditState.cedYankBuffer)+      csCmdLine %= applyEdit (Z.insertMany buf)+  ]++handleEditingInput :: Event -> MH ()+handleEditingInput e = do+    -- Only handle input events to the editor if we permit editing:+    -- if multiline mode is off, or if there is only one line of text+    -- in the editor. This means we skip input this catch-all handler+    -- if we're *not* in multiline mode *and* there are multiple lines,+    -- i.e., we are showing the user the status message about the+    -- current editor state and editing is not permitted.++    smartBacktick <- use (csResources.crConfiguration.to configSmartBacktick)+    let smartChars = "*`_"+    st <- use id+    case lookupKeybinding e editingKeybindings of+      Just kb | editingPermitted st -> kbAction kb+      _ -> do+        case e of+          -- Not editing; backspace here means cancel multi-line message+          -- composition+          EvKey KBS [] | (not $ editingPermitted st) ->+            csCmdLine %= applyEdit Z.clearZipper++          -- Backspace in editing mode with smart pair insertion means+          -- smart pair removal when possible+          EvKey KBS [] | editingPermitted st && smartBacktick ->+              let backspace = csCmdLine %= applyEdit Z.deletePrevChar+              in case cursorAtOneOf smartChars (st^.csCmdLine) of+                  Nothing -> backspace+                  Just ch ->+                      -- Smart char removal:+                      if | (cursorAtChar ch $ applyEdit Z.moveLeft $ st^.csCmdLine) &&+                           (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csCmdLine) ->+                             csCmdLine %= applyEdit (Z.deleteChar >>> Z.deletePrevChar)+                         | otherwise -> backspace++          EvKey (KChar ch) [] | editingPermitted st && smartBacktick && ch `elem` smartChars ->+              -- Smart char insertion:+              let doInsertChar = csCmdLine %= applyEdit (Z.insertChar ch)+              in if | (editorEmpty $ st^.csCmdLine) ||+                         ((cursorAtChar ' ' (applyEdit Z.moveLeft $ st^.csCmdLine)) &&+                          (cursorIsAtEnd $ st^.csCmdLine)) ->+                        csCmdLine %= applyEdit (Z.insertMany (T.pack $ ch:ch:[]) >>> Z.moveLeft)+                    | (cursorAtChar ch $ st^.csCmdLine) &&+                      (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csCmdLine) ->+                        csCmdLine %= applyEdit Z.moveRight+                    | otherwise -> doInsertChar++          _ | editingPermitted st -> mhHandleEventLensed csCmdLine handleEditorEvent e+            | otherwise -> return ()++        csCurrentCompletion .= Nothing++editorEmpty :: Editor T.Text a -> Bool+editorEmpty e = cursorIsAtEnd e &&+                cursorIsAtBeginning e++cursorIsAtEnd :: Editor T.Text a -> Bool+cursorIsAtEnd e =+    let col = snd $ Z.cursorPosition z+        curLine = Z.currentLine z+        z = e^.editContentsL+    in col == T.length curLine++cursorIsAtBeginning :: Editor T.Text a -> Bool+cursorIsAtBeginning e =+    let col = snd $ Z.cursorPosition z+        z = e^.editContentsL+    in col == 0++cursorAtOneOf :: [Char] -> Editor T.Text a -> Maybe Char+cursorAtOneOf [] _ = Nothing+cursorAtOneOf (c:cs) e =+    if cursorAtChar c e+    then Just c+    else cursorAtOneOf cs e++cursorAtChar :: Char -> Editor T.Text a -> Bool+cursorAtChar ch e =+    let col = snd $ Z.cursorPosition z+        curLine = Z.currentLine z+        z = e^.editContentsL+    in (T.singleton ch) `T.isPrefixOf` T.drop col curLine
+ src/State/Setup.hs view
@@ -0,0 +1,348 @@+module State.Setup where++import           Prelude ()+import           Prelude.Compat++import           Brick.BChan+import           Brick.Widgets.List (list)+import           Control.Concurrent (threadDelay, forkIO)+import qualified Control.Concurrent.STM as STM+import           Control.Concurrent.MVar (newEmptyMVar)+import           Control.Exception (SomeException, catch, try)+import           Control.Monad (forM, forever, when, void)+import           Control.Monad.IO.Class (liftIO)+import qualified Data.Text as T+import qualified Data.Foldable as F+import qualified Data.HashMap.Strict as HM+import           Data.List (sort)+import           Data.Maybe (listToMaybe, maybeToList, fromJust)+import           Data.Monoid ((<>))+import qualified Data.Sequence as Seq+import           Data.Time.LocalTime ( TimeZone(..), getCurrentTimeZone )+import           Lens.Micro.Platform+import           System.Exit (exitFailure, ExitCode(ExitSuccess))+import           System.IO (Handle, hPutStrLn, hFlush)+import           System.IO.Temp (openTempFile)+import           System.Directory (getTemporaryDirectory)++import           Network.Mattermost+import           Network.Mattermost.Lenses+import           Network.Mattermost.Logging (mmLoggerDebug)++import           Config+import           InputHistory+import           Login+import           State.Common+import           TeamSelect+import           Themes+import           Types+import           Zipper (Zipper)+import qualified Zipper as Z++fetchUserStatuses :: Session -> IO (MH ())+fetchUserStatuses session = do+  statusMap <- mmGetStatuses session+  return $ do+    let updateUser u = u & uiStatus .~ (case HM.lookup (u^.uiId) statusMap of+                                          Nothing -> Offline+                                          Just t  -> statusFromText t)+    usrMap.each %= updateUser++userRefresh :: Session -> RequestChan -> IO ()+userRefresh session requestChan = void $ forkIO $ forever refresh+  where refresh = do+          let seconds = (* (1000 * 1000))+          threadDelay (seconds 30)+          STM.atomically $ STM.writeTChan requestChan $ do+            rs <- try $ fetchUserStatuses session+            case rs of+              Left (_ :: SomeException) -> return (return ())+              Right upd -> return upd++startSubprocessLogger :: STM.TChan ProgramOutput -> RequestChan -> IO ()+startSubprocessLogger logChan requestChan = do+    let logMonitor mPair = do+          ProgramOutput progName args out err ec <-+              STM.atomically $ STM.readTChan logChan++          -- If either stdout or stderr is non-empty or there was an exit+          -- failure, log it and notify the user.+          let emptyOutput s = null s || s == "\n"++          case ec == ExitSuccess && emptyOutput out && emptyOutput err of+              -- the "good" case, no output and exit sucess+              True -> logMonitor mPair+              False -> do+                  (logPath, logHandle) <- case mPair of+                      Just p ->+                          return p+                      Nothing -> do+                          tmp <- getTemporaryDirectory+                          openTempFile tmp "matterhorn-subprocess.log"++                  hPutStrLn logHandle $+                      unlines [ "Program: " <> progName+                              , "Arguments: " <> show args+                              , "Exit code: " <> show ec+                              , "Stdout:"+                              , out+                              , "Stderr:"+                              , err+                              ]+                  hFlush logHandle++                  STM.atomically $ STM.writeTChan requestChan $ do+                      return $ do+                          let msg = T.pack $ "Program " <> show progName <>+                                             " produced unexpected output; see " <>+                                             logPath <> " for details."+                          postErrorMessage msg++                  logMonitor (Just (logPath, logHandle))++    void $ forkIO $ logMonitor Nothing++startTimezoneMonitor :: TimeZone -> RequestChan -> IO ()+startTimezoneMonitor tz requestChan = do+  -- Start the timezone monitor thread+  let timezoneMonitorSleepInterval = minutes 5+      minutes = (* (seconds 60))+      seconds = (* (1000 * 1000))+      timezoneMonitor prevTz = do+        threadDelay timezoneMonitorSleepInterval++        newTz <- getCurrentTimeZone+        when (newTz /= prevTz) $+            STM.atomically $ STM.writeTChan requestChan $ do+                return $ timeZone .= newTz++        timezoneMonitor newTz++  void $ forkIO (timezoneMonitor tz)++mkChanNames :: User -> HM.HashMap UserId User -> Seq.Seq Channel -> MMNames+mkChanNames myUser users chans = MMNames+  { _cnChans = sort+               [ preferredChannelName c+               | c <- F.toList chans, channelType c /= Direct ]+  , _cnDMs = sort+             [ channelName c+             | c <- F.toList chans, channelType c == Direct ]+  , _cnToChanId = HM.fromList $+                  [ (preferredChannelName c, channelId c) | c <- F.toList chans ] +++                  [ (userUsername u, c)+                  | u <- HM.elems users+                  , c <- lookupChan (getDMChannelName (getId myUser) (getId u))+                  ]+  , _cnUsers = sort (map userUsername (HM.elems users))+  , _cnToUserId = HM.fromList+                  [ (userUsername u, getId u) | u <- HM.elems users ]+  }+  where lookupChan n = [ c^.channelIdL+                       | c <- F.toList chans, c^.channelNameL == n+                       ]++newState :: ChatResources+         -> Zipper ChannelId+         -> User+         -> Team+         -> TimeZone+         -> InputHistory+         -> ChatState+newState rs i u m tz hist = ChatState+  { _csResources                   = rs+  , _csFocus                       = i+  , _csMe                          = u+  , _csMyTeam                      = m+  , _csNames                       = emptyMMNames+  , _msgMap                        = HM.empty+  , _csPostMap                     = HM.empty+  , _usrMap                        = HM.empty+  , _timeZone                      = tz+  , _csEditState                   = emptyEditState hist+  , _csMode                        = Main+  , _csShowMessagePreview          = configShowMessagePreview $ rs^.crConfiguration+  , _csChannelSelectString         = ""+  , _csChannelSelectChannelMatches = mempty+  , _csChannelSelectUserMatches    = mempty+  , _csRecentChannel               = Nothing+  , _csUrlList                     = list UrlList mempty 2+  , _csConnectionStatus            = Connected+  , _csJoinChannelList             = Nothing+  , _csMessageSelect               = MessageSelectState Nothing+  }++setupState :: Maybe Handle -> Config -> RequestChan -> BChan MHEvent -> IO ChatState+setupState logFile config requestChan eventChan = do+  -- If we don't have enough credentials, ask for them.+  connInfo <- case getCredentials config of+      Nothing -> interactiveGatherCredentials config Nothing+      Just connInfo -> return connInfo++  let setLogger = case logFile of+        Nothing -> id+        Just f  -> \ cd -> cd `withLogger` mmLoggerDebug f++  let loginLoop cInfo = do+        cd <- setLogger `fmap`+                initConnectionData (ciHostname cInfo)+                                   (fromIntegral (ciPort cInfo))++        putStrLn "Authenticating..."++        let login = Login { username = ciUsername cInfo+                          , password = ciPassword cInfo+                          }+        result <- (Right <$> mmLogin cd login)+                    `catch` (\e -> return $ Left $ ResolveError e)+                    `catch` (\e -> return $ Left $ ConnectError e)+                    `catch` (\e -> return $ Left $ OtherAuthError e)++        -- Update the config with the entered settings so we can let the+        -- user adjust if something went wrong rather than enter them+        -- all again.+        let modifiedConfig =+                config { configUser = Just $ ciUsername cInfo+                       , configPass = Just $ PasswordString $ ciPassword cInfo+                       , configPort = ciPort cInfo+                       , configHost = Just $ ciHostname cInfo+                       }++        case result of+            Right (Right (sess, user)) ->+                return (sess, user, cd)+            Right (Left e) ->+                interactiveGatherCredentials modifiedConfig (Just $ LoginError e) >>=+                    loginLoop+            Left e ->+                interactiveGatherCredentials modifiedConfig (Just e) >>=+                    loginLoop++  (session, myUser, cd) <- loginLoop connInfo++  initialLoad <- mmGetInitialLoad session+  when (Seq.null $ initialLoadTeams initialLoad) $ do+      putStrLn "Error: your account is not a member of any teams"+      exitFailure++  myTeam <- case configTeam config of+      Nothing -> do+          interactiveTeamSelection $ F.toList $ initialLoadTeams initialLoad+      Just tName -> do+          let matchingTeam = listToMaybe $ filter matches $ F.toList $ initialLoadTeams initialLoad+              matches t = teamName t == tName+          case matchingTeam of+              Nothing -> interactiveTeamSelection (F.toList (initialLoadTeams initialLoad))+              Just t -> return t++  quitCondition <- newEmptyMVar+  slc <- STM.atomically STM.newTChan++  let themeName = case configTheme config of+          Nothing -> defaultThemeName+          Just t -> t+      theme = case lookup themeName themes of+          Nothing -> fromJust $ lookup defaultThemeName themes+          Just t -> t+      cr = ChatResources+             { _crSession       = session+             , _crConn          = cd+             , _crRequestQueue  = requestChan+             , _crEventQueue    = eventChan+             , _crTheme         = theme+             , _crQuitCondition = quitCondition+             , _crConfiguration = config+             , _crSubprocessLog = slc+             }+  initializeState cr myTeam myUser++loadAllUsers :: Session -> IO (HM.HashMap UserId User)+loadAllUsers session = go HM.empty 0+  where go users n = do+          newUsers <- mmGetUsers session (n * 50) 50+          if HM.null newUsers+            then return users+            else go (newUsers <> users) (n+1)++initializeState :: ChatResources -> Team -> User -> IO ChatState+initializeState cr myTeam myUser = do+  let ChatResources session _ requestChan _ _ _ _ _ = cr+  let myTeamId = getId myTeam++  STM.atomically $ STM.writeTChan requestChan $ fetchUserStatuses session++  userRefresh session requestChan++  putStrLn $ "Loading channels for team " <> show (teamName myTeam) <> "..."+  chans <- mmGetChannels session myTeamId++  msgs <- fmap (HM.fromList . F.toList) $ forM (F.toList chans) $ \c -> do+      let cChannel = ClientChannel+                       { _ccContents = emptyChannelContents+                       , _ccInfo     = initialChannelInfo c & cdCurrentState .~ state+                       }++          state = if c^.channelNameL == "town-square"+                  then ChanLoadPending+                  else ChanUnloaded++      return (getId c, cChannel)++  teamUsers <- mmGetProfiles session myTeamId 0 10000+  users <- loadAllUsers session+  let mkUser u = userInfoFromUser u (HM.member (u^.userIdL) teamUsers)+  tz    <- getCurrentTimeZone+  hist  <- do+      result <- readHistory+      case result of+          Left _ -> return newHistory+          Right h -> return h++  startTimezoneMonitor tz requestChan++  startSubprocessLogger (cr^.crSubprocessLog) requestChan++  let chanNames = mkChanNames myUser users chans+      Just townSqId = chanNames ^. cnToChanId . at "town-square"+      chanIds = [ (chanNames ^. cnToChanId) HM.! i+                | i <- chanNames ^. cnChans ] +++                [ c+                | i <- chanNames ^. cnUsers+                , c <- maybeToList (HM.lookup i (chanNames ^. cnToChanId)) ]+      chanZip = Z.findRight (== townSqId) (Z.fromList chanIds)+      st = newState cr chanZip myUser myTeam tz hist+             & usrMap .~ fmap mkUser users+             & msgMap .~ msgs+             & csNames .~ chanNames++  -- Fetch town-square asynchronously, but put it in the queue early.+  case F.find ((== townSqId) . getId) chans of+      Nothing -> return ()+      Just c -> doAsyncWithIO Preempt st $ do+          cwd <- liftIO $ mmGetChannel session myTeamId (getId c)+          return $ do+              csChannel(getId c).ccInfo %= channelInfoFromChannelWithData cwd+              liftIO $ updateViewedIO st+              asyncFetchScrollback Preempt (getId c)++  -- It's important to queue up these channel metadata fetches first so+  -- that by the time the scrollback requests are processed, we have the+  -- latest metadata.+  --+  -- First we queue up fetches for non-DM channels:+  F.forM_ chans $ \c ->+      when (getId c /= townSqId && c^.channelTypeL /= Direct) $+          doAsyncWithIO Normal st $ do+              cwd <- liftIO $ mmGetChannel session myTeamId (getId c)+              return $ do+                  csChannel(getId c).ccInfo %= channelInfoFromChannelWithData cwd++  -- Then we queue up fetches for DM channels:+  F.forM_ chans $ \c ->+      when (c^.channelTypeL == Direct) $+          doAsyncWithIO Normal st $ do+              cwd <- liftIO $ mmGetChannel session myTeamId (getId c)+              return $ do+                  csChannel(getId c).ccInfo %= channelInfoFromChannelWithData cwd++  return st
+ src/TeamSelect.hs view
@@ -0,0 +1,69 @@+module TeamSelect+  ( interactiveTeamSelection+  ) where++import Prelude ()+import Prelude.Compat++import Brick+import Brick.Widgets.List+import Brick.Widgets.Center+import Brick.Widgets.Border+import Control.Monad.IO.Class (liftIO)+import qualified Data.Vector as V+import Graphics.Vty+import System.Exit (exitSuccess)++import Network.Mattermost++import Markdown++type State = List () Team++interactiveTeamSelection :: [Team] -> IO Team+interactiveTeamSelection teams = do+    let state = list () (V.fromList teams) 1+    finalSt <- defaultMain app state+    let Just (_, t) = listSelectedElement finalSt+    return t++app :: App State e ()+app = App+  { appDraw         = teamSelectDraw+  , appChooseCursor = neverShowCursor+  , appHandleEvent  = onEvent+  , appStartEvent   = return+  , appAttrMap      = const colorTheme+  }++colorTheme :: AttrMap+colorTheme = attrMap defAttr+  [ (listSelectedFocusedAttr, black `on` yellow)+  ]++teamSelectDraw :: State -> [Widget ()]+teamSelectDraw st =+    [ teamSelect st+    ]++teamSelect :: State -> Widget ()+teamSelect st =+    center $ hLimit 50 $ vLimit 15 $+    vBox [ hCenter $ txt "Welcome to MatterMost. Please select a team:"+         , txt " "+         , border theList+         , txt " "+         , renderText "Press Enter to select a team and connect or Esc to exit."+         ]+    where+    theList = renderList renderTeamItem True st++renderTeamItem :: Bool -> Team -> Widget ()+renderTeamItem _ t =+    padRight Max $ txt $ teamName t++onEvent :: State -> BrickEvent () e -> EventM () (Next State)+onEvent _  (VtyEvent (EvKey KEsc [])) = liftIO exitSuccess+onEvent st (VtyEvent (EvKey KEnter [])) = halt st+onEvent st (VtyEvent e) = continue =<< handleListEvent e st+onEvent st _ = continue st
+ src/Themes.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE OverloadedStrings #-}+module Themes+  ( defaultThemeName+  , themes++  -- * Attribute names+  , timeAttr+  , channelHeaderAttr+  , channelListHeaderAttr+  , currentChannelNameAttr+  , unreadChannelAttr+  , urlAttr+  , codeAttr+  , emailAttr+  , emojiAttr+  , channelNameAttr+  , clientMessageAttr+  , clientHeaderAttr+  , clientEmphAttr+  , clientStrongAttr+  , dateTransitionAttr+  , newMessageTransitionAttr+  , errorMessageAttr+  , helpAttr+  , helpEmphAttr+  , channelSelectPromptAttr+  , channelSelectMatchAttr+  , completionAlternativeListAttr+  , completionAlternativeCurrentAttr+  , dialogAttr+  , dialogEmphAttr+  , recentMarkerAttr+  , replyParentAttr+  , loadMoreAttr+  , urlListSelectedAttr+  , messageSelectAttr+  , messageSelectStatusAttr++  -- * Username formatting+  , colorUsername+  , attrForUsername+  ) where++import Prelude ()+import Prelude.Compat++import Data.Hashable (hash)+import Data.Monoid ((<>))+import Graphics.Vty+import Brick+import Brick.Widgets.List+import qualified Data.Text as T++import Types (userSigil)++defaultThemeName :: T.Text+defaultThemeName = darkColorThemeName++helpAttr :: AttrName+helpAttr = "help"++helpEmphAttr :: AttrName+helpEmphAttr = "helpEmphasis"++recentMarkerAttr :: AttrName+recentMarkerAttr = "recentMarker"++replyParentAttr :: AttrName+replyParentAttr = "replyParent"++loadMoreAttr :: AttrName+loadMoreAttr = "loadMoreMessages"++urlListSelectedAttr :: AttrName+urlListSelectedAttr = "urlListSelectedAttr"++messageSelectAttr :: AttrName+messageSelectAttr = "messageSelectAttr"++dialogAttr :: AttrName+dialogAttr = "dialog"++dialogEmphAttr :: AttrName+dialogEmphAttr = "dialogEmphasis"++channelSelectMatchAttr :: AttrName+channelSelectMatchAttr = "channelSelectMatch"++channelSelectPromptAttr :: AttrName+channelSelectPromptAttr = "channelSelectPrompt"++completionAlternativeListAttr :: AttrName+completionAlternativeListAttr = "completionAlternativeList"++completionAlternativeCurrentAttr :: AttrName+completionAlternativeCurrentAttr = "completionAlternativeCurrent"++darkColorThemeName :: T.Text+darkColorThemeName = "builtin:dark"++lightColorThemeName :: T.Text+lightColorThemeName = "builtin:light"++timeAttr :: AttrName+timeAttr = "time"++channelHeaderAttr :: AttrName+channelHeaderAttr = "channelHeader"++channelListHeaderAttr :: AttrName+channelListHeaderAttr = "channelListHeader"++currentChannelNameAttr :: AttrName+currentChannelNameAttr = "currentChannelName"++channelNameAttr :: AttrName+channelNameAttr = "channelNameAttr"++unreadChannelAttr :: AttrName+unreadChannelAttr = "unreadChannel"++dateTransitionAttr :: AttrName+dateTransitionAttr = "dateTransition"++newMessageTransitionAttr :: AttrName+newMessageTransitionAttr = "newMessageTransition"++urlAttr :: AttrName+urlAttr = "url"++codeAttr :: AttrName+codeAttr = "code"++emailAttr :: AttrName+emailAttr = "email"++emojiAttr :: AttrName+emojiAttr = "emoji"++clientMessageAttr :: AttrName+clientMessageAttr = "clientMessage"++clientHeaderAttr :: AttrName+clientHeaderAttr = "clientHeader"++clientEmphAttr :: AttrName+clientEmphAttr = "clientEmph"++clientStrongAttr :: AttrName+clientStrongAttr = "clientStrong"++errorMessageAttr :: AttrName+errorMessageAttr = "errorMessage"++messageSelectStatusAttr :: AttrName+messageSelectStatusAttr = "messageSelectStatus"++themes :: [(T.Text, AttrMap)]+themes =+    [ (darkColorThemeName,      darkColorTheme)+    , (lightColorThemeName,     lightColorTheme)+    ]++lightColorTheme :: AttrMap+lightColorTheme = attrMap (black `on` white) $+  [ (timeAttr,                         fg black)+  , (channelHeaderAttr,                fg black `withStyle` underline)+  , (channelListHeaderAttr,            fg cyan)+  , (currentChannelNameAttr,           black `on` yellow `withStyle` bold)+  , (unreadChannelAttr,                black `on` cyan   `withStyle` bold)+  , (urlAttr,                          fg brightYellow)+  , (emailAttr,                        fg yellow)+  , (codeAttr,                         fg magenta)+  , (emojiAttr,                        fg yellow)+  , (channelNameAttr,                  fg blue)+  , (clientMessageAttr,                fg black)+  , (clientEmphAttr,                   fg black `withStyle` bold)+  , (clientStrongAttr,                 fg black `withStyle` bold `withStyle` underline)+  , (clientHeaderAttr,                 fg red `withStyle` bold)+  , (dateTransitionAttr,               fg green)+  , (newMessageTransitionAttr,         black `on` yellow)+  , (errorMessageAttr,                 fg red)+  , (helpAttr,                         black `on` cyan)+  , (helpEmphAttr,                     fg white)+  , (channelSelectMatchAttr,           black `on` magenta)+  , (channelSelectPromptAttr,          fg black)+  , (completionAlternativeListAttr,    white `on` blue)+  , (completionAlternativeCurrentAttr, black `on` yellow)+  , (dialogAttr,                       black `on` cyan)+  , (dialogEmphAttr,                   fg white)+  , (listSelectedFocusedAttr,          black `on` yellow)+  , (recentMarkerAttr,                 fg black `withStyle` bold)+  , (loadMoreAttr,                     black `on` cyan)+  , (urlListSelectedAttr,              black `on` yellow)+  , (messageSelectAttr,                black `on` yellow)+  , (messageSelectStatusAttr,          fg black)+  ] <>+  ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..] usernameColors)++darkAttrs :: [(AttrName, Attr)]+darkAttrs =+  [ (timeAttr,                         fg white)+  , (channelHeaderAttr,                fg white `withStyle` underline)+  , (channelListHeaderAttr,            fg cyan)+  , (currentChannelNameAttr,           black `on` yellow `withStyle` bold)+  , (unreadChannelAttr,                black `on` cyan   `withStyle` bold)+  , (urlAttr,                          fg yellow)+  , (emailAttr,                        fg yellow)+  , (codeAttr,                         fg magenta)+  , (emojiAttr,                        fg yellow)+  , (channelNameAttr,                  fg cyan)+  , (clientMessageAttr,                fg white)+  , (clientEmphAttr,                   fg white `withStyle` bold)+  , (clientStrongAttr,                 fg white `withStyle` bold `withStyle` underline)+  , (clientHeaderAttr,                 fg red `withStyle` bold)+  , (dateTransitionAttr,               fg green)+  , (newMessageTransitionAttr,         fg yellow `withStyle` bold)+  , (errorMessageAttr,                 fg red)+  , (helpAttr,                         black `on` cyan)+  , (helpEmphAttr,                     fg white)+  , (channelSelectMatchAttr,           black `on` magenta)+  , (channelSelectPromptAttr,          fg white)+  , (completionAlternativeListAttr,    white `on` blue)+  , (completionAlternativeCurrentAttr, black `on` yellow)+  , (dialogAttr,                       black `on` cyan)+  , (dialogEmphAttr,                   fg white)+  , (listSelectedFocusedAttr,          black `on` yellow)+  , (recentMarkerAttr,                 fg yellow `withStyle` bold)+  , (loadMoreAttr,                     black `on` cyan)+  , (urlListSelectedAttr,              black `on` yellow)+  , (messageSelectAttr,                black `on` yellow)+  , (messageSelectStatusAttr,          fg white)+  ] <>+  ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..] usernameColors)++darkColorTheme :: AttrMap+darkColorTheme = attrMap defAttr darkAttrs++usernameAttr :: Int -> AttrName+usernameAttr i = "username" <> (attrName $ show i)++colorUsername :: T.Text -> Widget a+colorUsername s = withDefAttr (attrForUsername s) $ txt s++attrForUsername :: T.Text -> AttrName+attrForUsername s+    | (T.singleton userSigil) `T.isPrefixOf` s ||+      "+" `T.isPrefixOf` s ||+      "-" `T.isPrefixOf` s ||+      " " `T.isPrefixOf` s+      = usernameAttr $ hash (T.tail s) `mod` (length usernameColors)+    | otherwise = usernameAttr $ hash s `mod` (length usernameColors)++usernameColors :: [Attr]+usernameColors =+    [ fg red+    , fg green+    , fg yellow+    , fg blue+    , fg magenta+    , fg cyan+    , fg brightRed+    , fg brightGreen+    , fg brightYellow+    , fg brightBlue+    , fg brightMagenta+    , fg brightCyan+    ]
+ src/Types.hs view
@@ -0,0 +1,660 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Types where++import           Prelude ()+import           Prelude.Compat++import           Brick (EventM, txt, Next)+import qualified Brick+import           Brick.BChan+import           Brick.AttrMap (AttrMap)+import           Brick.Widgets.Edit (Editor, editor)+import           Brick.Widgets.List (List)+import qualified Control.Concurrent.STM as STM+import           Control.Concurrent.MVar (MVar)+import           Control.Exception (SomeException)+import qualified Control.Monad.State as St+import           Data.HashMap.Strict (HashMap)+import           Data.Time.Clock (UTCTime, getCurrentTime)+import           Data.Time.LocalTime (TimeZone)+import qualified Data.HashMap.Strict as HM+import           Data.List (partition, sort)+import           Data.Maybe+import           Data.Monoid+import qualified Graphics.Vty as Vty+import           Lens.Micro.Platform (at, makeLenses, lens, (&), (^.), (^?), (%~), (.~),+                                      ix, to, SimpleGetter)+import           Network.Mattermost+import           Network.Mattermost.Exceptions+import           Network.Mattermost.Lenses+import           Network.Mattermost.WebSocket+import           Network.Connection (HostNotResolved, HostCannotConnect)+import qualified Data.Text as T+import           System.Exit (ExitCode)++import           Zipper (Zipper, focusL)++import           InputHistory++import           Types.Posts+import           Types.Messages+++-- * Configuration++-- | A user password is either given to us directly, or a command+-- which we execute to find the password.+data PasswordSource =+    PasswordString T.Text+    | PasswordCommand T.Text+    deriving (Eq, Read, Show)++-- | These are all the values that can be read in our configuration+-- file.+data Config = Config+  { configUser           :: Maybe T.Text+  , configHost           :: Maybe T.Text+  , configTeam           :: Maybe T.Text+  , configPort           :: Int+  , configPass           :: Maybe PasswordSource+  , configTimeFormat     :: Maybe T.Text+  , configDateFormat     :: Maybe T.Text+  , configTheme          :: Maybe T.Text+  , configSmartBacktick  :: Bool+  , configURLOpenCommand :: Maybe T.Text+  , configActivityBell   :: Bool+  , configShowMessagePreview :: Bool+  } deriving (Eq, Show)++-- * 'MMNames' structures++-- | The 'MMNames' record is for listing human-readable+--   names and mapping them back to internal IDs.+data MMNames = MMNames+  { _cnChans    :: [T.Text] -- ^ All channel names+  , _cnDMs      :: [T.Text] -- ^ All DM channel names+  , _cnToChanId :: HashMap T.Text ChannelId+      -- ^ Mapping from channel names to 'ChannelId' values+  , _cnUsers    :: [T.Text] -- ^ All users+  , _cnToUserId :: HashMap T.Text UserId+      -- ^ Mapping from user names to 'UserId' values+  }++-- | An empty 'MMNames' record+emptyMMNames :: MMNames+emptyMMNames = MMNames mempty mempty mempty mempty mempty++-- ** 'MMNames' Lenses++makeLenses ''MMNames++-- * Internal Names and References++-- | This 'Name' type is the value used in `brick` to identify the+-- currently focused widget or state.+data Name = ChannelMessages ChannelId+          | MessageInput+          | ChannelList+          | HelpViewport+          | HelpText+          | ScriptHelpText+          | ChannelSelectString+          | CompletionAlternatives+          | JoinChannelList+          | UrlList+          | MessagePreviewViewport+          deriving (Eq, Show, Ord)++-- | The sum type of exceptions we expect to encounter on authentication+-- failure. We encode them explicitly here so that we can print them in+-- a more user-friendly manner than just 'show'.+data AuthenticationException =+    ConnectError HostCannotConnect+    | ResolveError HostNotResolved+    | LoginError LoginFailureException+    | OtherAuthError SomeException+    deriving (Show)++-- | Our 'ConnectionInfo' contains exactly as much information as is+-- necessary to start a connection with a MatterMost server+data ConnectionInfo =+    ConnectionInfo { ciHostname :: T.Text+                   , ciPort     :: Int+                   , ciUsername :: T.Text+                   , ciPassword :: T.Text+                   }++-- | We want to continue referring to posts by their IDs, but we don't want to+-- have to synthesize new valid IDs for messages from the client+-- itself (like error messages or informative client responses). To+-- that end, a PostRef can be either a PostId or a newly-generated+-- client ID+data PostRef+  = MMId PostId+  | CLId Int+    deriving (Eq, Show)++-- | For representing links to things in the 'open links' view+data LinkChoice = LinkChoice+  { _linkTime   :: UTCTime+  , _linkUser   :: T.Text+  , _linkName   :: T.Text+  , _linkURL    :: T.Text+  , _linkFileId :: Maybe FileId+  } deriving (Eq, Show)++makeLenses ''LinkChoice++-- * Channel representations++-- | A 'ClientChannel' contains both the message+--   listing and the metadata about a channel+data ClientChannel = ClientChannel+  { _ccContents :: ChannelContents+    -- ^ A list of 'Message's in the channel+  , _ccInfo     :: ChannelInfo+    -- ^ The 'ChannelInfo' for the channel+  }++-- Sigils+normalChannelSigil :: Char+normalChannelSigil = '~'++userSigil :: Char+userSigil = '@'++-- Get a channel's name, depending on its type+preferredChannelName :: Channel -> T.Text+preferredChannelName ch+    | channelType ch == Group = channelDisplayName ch+    | otherwise = channelName ch++initialChannelInfo :: Channel -> ChannelInfo+initialChannelInfo chan =+    let updated  = chan ^. channelLastPostAtL+    in ChannelInfo { _cdViewed           = Nothing+                   , _cdUpdated          = updated+                   , _cdName             = preferredChannelName chan+                   , _cdHeader           = chan^.channelHeaderL+                   , _cdType             = chan^.channelTypeL+                   , _cdCurrentState     = ChanUnloaded+                   , _cdNewMessageCutoff = Nothing+                   }++channelInfoFromChannelWithData :: ChannelWithData -> ChannelInfo -> ChannelInfo+channelInfoFromChannelWithData (ChannelWithData chan chanData) ci =+    let viewed   = chanData ^. channelDataLastViewedAtL+        updated  = chan ^. channelLastPostAtL+    in ci { _cdViewed           = Just viewed+          , _cdUpdated          = updated+          , _cdName             = preferredChannelName chan+          , _cdHeader           = (chan^.channelHeaderL)+          , _cdType             = (chan^.channelTypeL)+          }++-- | The 'ChannelContents' is a wrapper for a list of+--   'Message' values+data ChannelContents = ChannelContents+  { _cdMessages :: Messages+  }++-- | An initial empty 'ChannelContents' value+emptyChannelContents :: ChannelContents+emptyChannelContents = ChannelContents+  { _cdMessages = noMessages+  }++-- | The 'ChannelState' represents our internal state+--   of the channel with respect to our knowledge (or+--   lack thereof) about the server's information+--   about the channel.+data ChannelState+  = ChanUnloaded+  | ChanLoaded+  | ChanLoadPending+  | ChanRefreshing+    deriving (Eq, Show)++-- | The 'ChannelInfo' record represents metadata+--   about a channel+data ChannelInfo = ChannelInfo+  { _cdViewed           :: Maybe UTCTime+    -- ^ The last time we looked at a channel+  , _cdUpdated          :: UTCTime+    -- ^ The last time a message showed up in the channel+  , _cdName             :: T.Text+    -- ^ The name of the channel+  , _cdHeader           :: T.Text+    -- ^ The header text of a channel+  , _cdType             :: Type+    -- ^ The type of a channel: public, private, or DM+  , _cdCurrentState     :: ChannelState+    -- ^ The current state of the channel+  , _cdNewMessageCutoff :: Maybe UTCTime+    -- ^ The last time we looked at the new messages in+    --   this channel, if ever+  }++-- ** Channel-matching types++data ChannelSelectMatch =+    ChannelSelectMatch { nameBefore     :: T.Text+                       , nameMatched    :: T.Text+                       , nameAfter      :: T.Text+                       }+                       deriving (Eq, Show)++channelNameFromMatch :: ChannelSelectMatch -> T.Text+channelNameFromMatch (ChannelSelectMatch b m a) = b <> m <> a++data ChannelSelectPattern = CSP MatchType T.Text+                          deriving (Eq, Show)++data MatchType = Prefix | Suffix | Infix | Equal deriving (Eq, Show)+++-- ** Channel-related Lenses++makeLenses ''ChannelContents+makeLenses ''ChannelInfo+makeLenses ''ClientChannel++-- * 'UserInfo' Values++-- | A 'UserInfo' value represents everything we need to know at+--   runtime about a user+data UserInfo = UserInfo+  { _uiName   :: T.Text+  , _uiId     :: UserId+  , _uiStatus :: UserStatus+  , _uiInTeam :: Bool+  } deriving (Eq, Show)++-- | Create a 'UserInfo' value from a Mattermost 'User' value+userInfoFromUser :: User -> Bool -> UserInfo+userInfoFromUser up inTeam = UserInfo+  { _uiName   = userUsername up+  , _uiId     = userId up+  , _uiStatus = Offline+  , _uiInTeam = inTeam+  }++-- | The 'UserStatus' value represents possible current status for+--   a user+data UserStatus+  = Online+  | Away+  | Offline+  | Other T.Text+    deriving (Eq, Show)++statusFromText :: T.Text -> UserStatus+statusFromText t = case t of+  "online"  -> Online+  "offline" -> Offline+  "away"    -> Away+  _         -> Other t++-- ** 'UserInfo' lenses++makeLenses ''UserInfo++instance Ord UserInfo where+  u1 `compare` u2+    | u1^.uiStatus == Offline && u2^.uiStatus /= Offline =+      GT+    | u1^.uiStatus /= Offline && u2^.uiStatus == Offline =+      LT+    | otherwise =+      (u1^.uiName) `compare` (u2^.uiName)++-- * Application State Values++data ProgramOutput =+    ProgramOutput { program :: FilePath+                  , programArgs :: [String]+                  , programStdout :: String+                  , programStderr :: String+                  , programExitCode :: ExitCode+                  }++-- | 'ChatResources' represents configuration and+-- connection-related information, as opposed to+-- current model or view information. Information+-- that goes in the 'ChatResources' value should be+-- limited to information that we read or set up+-- prior to setting up the bulk of the application state.+data ChatResources = ChatResources+  { _crSession       :: Session+  , _crConn          :: ConnectionData+  , _crRequestQueue  :: RequestChan+  , _crEventQueue    :: BChan MHEvent+  , _crSubprocessLog :: STM.TChan ProgramOutput+  , _crTheme         :: AttrMap+  , _crQuitCondition :: MVar ()+  , _crConfiguration :: Config+  }++-- | The 'ChatEditState' value contains the editor widget itself+--   as well as history and metadata we need for editing-related+--   operations.+data ChatEditState = ChatEditState+  { _cedEditor               :: Editor T.Text Name+  , _cedEditMode             :: EditMode+  , _cedMultiline            :: Bool+  , _cedInputHistory         :: InputHistory+  , _cedInputHistoryPosition :: HM.HashMap ChannelId (Maybe Int)+  , _cedLastChannelInput     :: HM.HashMap ChannelId (T.Text, EditMode)+  , _cedCurrentCompletion    :: Maybe T.Text+  , _cedCurrentAlternative   :: T.Text+  , _cedCompletionAlternatives :: [T.Text]+  , _cedYankBuffer           :: T.Text+  }++data EditMode =+    NewPost+    | Editing Post+    | Replying Message Post+      deriving (Show)++-- | We can initialize a new 'ChatEditState' value with just an+--   edit history, which we save locally.+emptyEditState :: InputHistory -> ChatEditState+emptyEditState hist = ChatEditState+  { _cedEditor               = editor MessageInput (txt . T.unlines) Nothing ""+  , _cedMultiline            = False+  , _cedInputHistory         = hist+  , _cedInputHistoryPosition = mempty+  , _cedLastChannelInput     = mempty+  , _cedCurrentCompletion    = Nothing+  , _cedCompletionAlternatives = []+  , _cedCurrentAlternative   = ""+  , _cedEditMode             = NewPost+  , _cedYankBuffer           = ""+  }++-- | A 'RequestChan' is a queue of operations we have to perform+--   in the background to avoid blocking on the main loop+type RequestChan = STM.TChan (IO (MH ()))++-- | The 'HelpScreen' type represents the set of possible 'Help'+--   dialogues we have to choose from.+data HelpScreen+  = MainHelp+  | ScriptHelp+    deriving (Eq)++-- | The 'Mode' represents the current dominant UI activity+data Mode =+    Main+    | ShowHelp HelpScreen+    | ChannelSelect+    | UrlSelect+    | LeaveChannelConfirm+    | DeleteChannelConfirm+    | JoinChannel+    | ChannelScroll+    | MessageSelect+    | MessageSelectDeleteConfirm+    deriving (Eq)++-- | We're either connected or we're not.+data ConnectionStatus = Connected | Disconnected++-- | This is the giant bundle of fields that represents the current+--  state of our application at any given time. Some of this should+--  be broken out further, but hasn't yet been.+data ChatState = ChatState+  { _csResources                   :: ChatResources+  , _csFocus                       :: Zipper ChannelId+  , _csNames                       :: MMNames+  , _csMe                          :: User+  , _csMyTeam                      :: Team+  , _msgMap                        :: HashMap ChannelId ClientChannel+  , _csPostMap                     :: HashMap PostId Message+  , _usrMap                        :: HashMap UserId UserInfo+  , _timeZone                      :: TimeZone+  , _csEditState                   :: ChatEditState+  , _csMode                        :: Mode+  , _csShowMessagePreview          :: Bool+  , _csChannelSelectString         :: T.Text+  , _csChannelSelectChannelMatches :: HashMap T.Text ChannelSelectMatch+  , _csChannelSelectUserMatches    :: HashMap T.Text ChannelSelectMatch+  , _csRecentChannel               :: Maybe ChannelId+  , _csUrlList                     :: List Name LinkChoice+  , _csConnectionStatus            :: ConnectionStatus+  , _csJoinChannelList             :: Maybe (List Name Channel)+  , _csMessageSelect               :: MessageSelectState+  }++data MessageSelectState =+    MessageSelectState { selectMessagePostId :: Maybe PostId }++-- * MH Monad++-- | A value of type 'MH' @a@ represents a computation that can+-- manipulate the application state and also request that the+-- application quit+newtype MH a =+  MH { fromMH :: St.StateT (ChatState, ChatState -> EventM Name (Next ChatState))+                           (EventM Name) a }++-- | Run an 'MM' computation, choosing whether to continue or halt+--   based on the resulting+runMHEvent :: ChatState -> MH () -> EventM Name (Next ChatState)+runMHEvent st (MH mote) = do+  ((), (st', rs)) <- St.runStateT mote (st, Brick.continue)+  rs st'++-- | Run an 'MM computation, ignoring any requests to quit+runMH :: ChatState -> MH () -> EventM Name ChatState+runMH st (MH mote) = do+  ((), (st', _)) <- St.runStateT mote (st, Brick.continue)+  return st'++-- | lift a computation in 'EventM' into 'MH'+mh :: EventM Name a -> MH a+mh = MH . St.lift++mhHandleEventLensed :: Lens' ChatState b -> (e -> b -> EventM Name b) -> e -> MH ()+mhHandleEventLensed ln f event = MH $ do+  (st, b) <- St.get+  n <- St.lift $ f event (st ^. ln)+  St.put (st & ln .~ n , b)++mhSuspendAndResume :: (ChatState -> IO ChatState) -> MH ()+mhSuspendAndResume mote = MH $ do+  (st, _) <- St.get+  St.put (st, \ _ -> Brick.suspendAndResume (mote st))++-- | This will request that after this computation finishes the+-- application should exit+requestQuit :: MH ()+requestQuit = MH $ do+  (st, _) <- St.get+  St.put (st, Brick.halt)++getNow :: MH UTCTime+getNow = St.liftIO getCurrentTime++instance Functor MH where+  fmap f (MH x) = MH (fmap f x)++instance Applicative MH where+  pure x = MH (pure x)+  MH f <*> MH x = MH (f <*> x)++instance Monad MH where+  return x = MH (return x)+  MH x >>= f = MH (x >>= \ x' -> fromMH (f x'))++-- We want to pretend that the state is only the ChatState, rather+-- than the ChatState and the Brick continuation+instance St.MonadState ChatState MH where+  get = fst `fmap` MH St.get+  put st = MH $ do+    (_, c) <- St.get+    St.put (st, c)++instance St.MonadIO MH where+  liftIO = MH . St.liftIO++-- | This represents any event that we might care about in the+--   main application loop+data MHEvent+  = WSEvent WebsocketEvent+    -- ^ For events that arise from the websocket+  | RespEvent (MH ())+    -- ^ For the result values of async IO operations+  | AsyncErrEvent SomeException+    -- ^ For errors that arise in the course of async IO operations+  | RefreshWebsocketEvent+    -- ^ Tell our main loop to refresh the websocket connection+  | WebsocketDisconnect+  | WebsocketConnect++-- ** Application State Lenses++makeLenses ''ChatResources+makeLenses ''ChatState+makeLenses ''ChatEditState++-- ** Utility Lenses+csCurrentChannelId :: Lens' ChatState ChannelId+csCurrentChannelId = csFocus.focusL++csCurrentChannel :: Lens' ChatState ClientChannel+csCurrentChannel =+  lens (\ st -> (st^.msgMap) HM.! (st^.csCurrentChannelId))+       (\ st n -> st & msgMap %~ HM.insert (st^.csCurrentChannelId) n)++csChannel :: ChannelId -> Lens' ChatState ClientChannel+csChannel cId =+  lens (\ st -> (st^.msgMap) HM.! cId)+       (\ st n -> st & msgMap %~ HM.insert cId n)++csUser :: UserId -> Lens' ChatState UserInfo+csUser uId =+  lens (\ st -> (st^.usrMap) HM.! uId)+       (\ st n -> st & usrMap %~ HM.insert uId n)++-- ** Interim lenses for backwards compat++csSession :: Lens' ChatState Session+csSession = csResources . crSession++csCmdLine :: Lens' ChatState (Editor T.Text Name)+csCmdLine = csEditState . cedEditor++csInputHistory :: Lens' ChatState InputHistory+csInputHistory = csEditState . cedInputHistory++csInputHistoryPosition :: Lens' ChatState (HM.HashMap ChannelId (Maybe Int))+csInputHistoryPosition = csEditState . cedInputHistoryPosition++csLastChannelInput :: Lens' ChatState (HM.HashMap ChannelId (T.Text, EditMode))+csLastChannelInput = csEditState . cedLastChannelInput++csCurrentCompletion :: Lens' ChatState (Maybe T.Text)+csCurrentCompletion = csEditState . cedCurrentCompletion++timeFormat :: SimpleGetter ChatState (Maybe T.Text)+timeFormat = csResources . crConfiguration . to configTimeFormat++dateFormat :: SimpleGetter ChatState (Maybe T.Text)+dateFormat = csResources . crConfiguration . to configDateFormat++-- ** 'ChatState' Helper Functions++getMessageForPostId :: ChatState -> PostId -> ReplyState+getMessageForPostId st pId =+    case st^.csPostMap.at(pId) of+        Nothing -> ParentNotLoaded pId+        Just m -> ParentLoaded pId m++getUsernameForUserId :: ChatState -> UserId -> Maybe T.Text+getUsernameForUserId st uId = st^.usrMap ^? ix uId.uiName++clientPostToMessage :: ChatState -> ClientPost -> Message+clientPostToMessage st cp = Message+  { _mText          = _cpText cp+  , _mUserName      = case _cpUserOverride cp of+    Just n+      | _cpType cp == NormalPost -> Just (n <> "[BOT]")+    _ -> getUsernameForUserId st =<< _cpUser cp+  , _mDate          = _cpDate cp+  , _mType          = CP $ _cpType cp+  , _mPending       = _cpPending cp+  , _mDeleted       = _cpDeleted cp+  , _mAttachments   = _cpAttachments cp+  , _mInReplyToMsg  =+    case cp^.cpInReplyToPost of+      Nothing  -> NotAReply+      Just pId -> getMessageForPostId st pId+  , _mPostId        = Just $ cp^.cpPostId+  , _mReactions     = _cpReactions cp+  , _mOriginalPost  = Just $ cp^.cpOriginalPost+  }++-- * Slash Commands++-- | The 'CmdArgs' type represents the arguments to a slash-command;+--   the type parameter represents the argument structure.+data CmdArgs :: * -> * where+  NoArg    :: CmdArgs ()+  LineArg  :: T.Text -> CmdArgs T.Text+  TokenArg :: T.Text -> CmdArgs rest -> CmdArgs (T.Text, rest)++-- | A 'CmdExec' value represents the implementation of a command+--   when provided with its arguments+type CmdExec a = a -> MH ()++-- | A 'Cmd' packages up a 'CmdArgs' specifier and the 'CmdExec'+--   implementation with a name and a description.+data Cmd = forall a. Cmd+  { cmdName    :: T.Text+  , cmdDescr   :: T.Text+  , cmdArgSpec :: CmdArgs a+  , cmdAction  :: CmdExec a+  }++-- | Helper function to extract the name out of a 'Cmd' value+commandName :: Cmd -> T.Text+commandName (Cmd name _ _ _ ) = name++-- * Keybindings++-- | A 'Keybinding' represents a keybinding along with its+--   implementation+data Keybinding =+    KB { kbDescription :: T.Text+       , kbEvent :: Vty.Event+       , kbAction :: MH ()+       }++-- | Find a keybinding that matches a Vty Event+lookupKeybinding :: Vty.Event -> [Keybinding] -> Maybe Keybinding+lookupKeybinding e kbs = listToMaybe $ filter ((== e) . kbEvent) kbs++sortedUserList :: ChatState -> [UserInfo]+sortedUserList st = sort yes ++ sort no+  where userList = filter showUser (HM.elems(st^.usrMap))+        showUser u = not (isSelf u) && (u^.uiInTeam)+        isSelf u = (st^.csMe.userIdL) == (u^.uiId)+        hasUnread u =+          case st^.csNames.cnToChanId.at(u^.uiName) of+            Nothing  -> False+            Just cId+              | (st^.csCurrentChannelId) == cId -> False+              | otherwise ->+                  let info = st^.csChannel(cId).ccInfo+                  in case info^.cdViewed of+                      Nothing -> False+                      Just v -> info^.cdUpdated > v+        (yes, no) = partition hasUnread userList
+ src/Types/Messages.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}++module Types.Messages+  ( Message(..)+  , isDeletable, isReplyable, isEditable+  , mText, mUserName, mDate, mType, mPending, mDeleted+  , mAttachments, mInReplyToMsg, mPostId, mReactions+  , mOriginalPost+  , MessageType(..)+  , ReplyState(..)+  , clientMessageToMessage+  , Messages+  , ChronologicalMessages+  , RetrogradeMessages+  , MessageOps (..)+  , noMessages+  , splitMessages+  , findMessage+  , getNextPostId+  , getPrevPostId+  , getLatestPostId+  , findLatestUserMessage+  , messagesAfter+  , reverseMessages+  , unreverseMessages+  )+where++import           Cheapskate (Blocks)+import           Control.Applicative+import qualified Data.Map.Strict as Map+import           Data.Maybe (isJust)+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import           Data.Time.Clock (UTCTime)+import           Lens.Micro.Platform+import           Network.Mattermost+import           Types.Posts++-- * Messages++-- | A 'Message' is any message we might want to render, either from+--   Mattermost itself or from a client-internal source.+data Message = Message+  { _mText          :: Blocks+  , _mUserName      :: Maybe T.Text+  , _mDate          :: UTCTime+  , _mType          :: MessageType+  , _mPending       :: Bool+  , _mDeleted       :: Bool+  , _mAttachments   :: Seq.Seq Attachment+  , _mInReplyToMsg  :: ReplyState+  , _mPostId        :: Maybe PostId+  , _mReactions     :: Map.Map T.Text Int+  , _mOriginalPost  :: Maybe Post+  } deriving (Show)++isDeletable :: Message -> Bool+isDeletable m = _mType m `elem` [CP NormalPost, CP Emote]++isReplyable :: Message -> Bool+isReplyable m = _mType m `elem` [CP NormalPost, CP Emote]++isEditable :: Message -> Bool+isEditable m = _mType m `elem` [CP NormalPost, CP Emote]++-- | A 'Message' is the representation we use for storage and+--   rendering, so it must be able to represent either a+--   post from Mattermost or an internal message. This represents+--   the union of both kinds of post types.+data MessageType = C ClientMessageType+                 | CP PostType+                 deriving (Eq, Show)++-- | The 'ReplyState' of a message represents whether a message+--   is a reply, and if so, to what message+data ReplyState =+    NotAReply+    | ParentLoaded PostId Message+    | ParentNotLoaded PostId+    deriving (Show)++-- | Convert a 'ClientMessage' to a 'Message'+clientMessageToMessage :: ClientMessage -> Message+clientMessageToMessage cm = Message+  { _mText          = getBlocks (_cmText cm)+  , _mUserName      = Nothing+  , _mDate          = _cmDate cm+  , _mType          = C $ _cmType cm+  , _mPending       = False+  , _mDeleted       = False+  , _mAttachments   = Seq.empty+  , _mInReplyToMsg  = NotAReply+  , _mPostId        = Nothing+  , _mReactions     = Map.empty+  , _mOriginalPost  = Nothing+  }++-- ** 'Message' Lenses++makeLenses ''Message++-- ----------------------------------------------------------------------++-- These declarations allow the use of a DirectionalSeq, which is a Seq+-- that uses a phantom type to identify the ordering of the elements+-- in the sequence (Forward or Reverse).  The constructors are not+-- exported from this module so that a DirectionalSeq can only be+-- constructed by the functions in this module.++data Chronological+data Retrograde+class SeqDirection a+instance SeqDirection Chronological+instance SeqDirection Retrograde++data SeqDirection dir => DirectionalSeq dir a =+    DSeq { dseq :: Seq.Seq a }+         deriving (Show, Functor, Foldable, Traversable)++instance SeqDirection a => Monoid (DirectionalSeq a Message) where+    mempty = DSeq mempty+    mappend a b = DSeq $ mappend (dseq a) (dseq b)++onDirectedSeq :: SeqDirection dir => (Seq.Seq a -> Seq.Seq b)+              -> DirectionalSeq dir a -> DirectionalSeq dir b+onDirectedSeq f = DSeq . f . dseq++-- ----------------------------------------------------------------------++-- * Message Collections++-- | A wrapper for an ordered, unique list of 'Message' values.+--+-- This type has (and promises) the following instances: Show,+-- Functor, Monoid, Foldable, Traversable+type ChronologicalMessages = DirectionalSeq Chronological Message+type Messages = ChronologicalMessages++-- | There are also cases where the list of 'Message' values are kept+-- in reverse order (most recent -> oldest); these cases are+-- represented by the `RetrogradeMessages` type.+type RetrogradeMessages = DirectionalSeq Retrograde Message++-- ** Common operations on Messages++class MessageOps a where+    addMessage :: Message -> a -> a++instance MessageOps ChronologicalMessages where+    addMessage m ml =+        case Seq.viewr (dseq ml) of+            Seq.EmptyR -> DSeq $ Seq.singleton m+            _ Seq.:> l ->+                case compare (m^.mDate) (l^.mDate) of+                  GT -> DSeq $ dseq ml Seq.|> m+                  EQ -> if m^.mPostId == l^.mPostId && isJust (m^.mPostId)+                        then ml+                        else dirDateInsert m ml+                  LT -> dirDateInsert m ml++dirDateInsert :: Message -> ChronologicalMessages -> ChronologicalMessages+dirDateInsert m = onDirectedSeq $ finalize . foldr insAfter initial+   where initial = (Just m, mempty)+         insAfter c (Nothing, l) = (Nothing, c Seq.<| l)+         insAfter c (Just n, l) =+             case compare (n^.mDate) (c^.mDate) of+               GT -> (Nothing, c Seq.<| (n Seq.<| l))+               EQ -> if n^.mPostId == c^.mPostId && isJust (c^.mPostId)+                     then (Nothing, c Seq.<| l)+                     else (Just n, c Seq.<| l)+               LT -> (Just n, c Seq.<| l)+         finalize (Just n, l) = n Seq.<| l+         finalize (_, l) = l++noMessages :: Messages+noMessages = DSeq mempty++-- | Searches for the specified PostId and returns a tuple where the+-- first element is the Message associated with the PostId (if it+-- exists), and the second element is another tuple: the first element+-- of the second is all the messages from the beginning of the list to+-- the message just before the PostId message (or all messages if not+-- found) *in reverse order*, and the second element of the second are+-- all the messages that follow the found message (none if the message+-- was never found) in *forward* order.+splitMessages :: Maybe PostId+              -> Messages+              -> (Maybe Message, (RetrogradeMessages, Messages))+splitMessages Nothing msgs =+    (Nothing, (DSeq $ Seq.reverse $ dseq msgs, noMessages))+splitMessages pid msgs =+    -- n.b. searches from the end as that is usually where the message+    -- is more likely to be found.  There is usually < 1000 messages+    -- total, so this does not need hyper efficiency.+    case Seq.viewr (dseq msgs) of+      Seq.EmptyR  -> (Nothing, (reverseMessages noMessages, noMessages))+      ms Seq.:> m -> if m^.mPostId == pid+                     then (Just m, (DSeq $ Seq.reverse ms, noMessages))+                     else let (a, (b,c)) = splitMessages pid $ DSeq ms+                          in case a of+                               Nothing -> (a, (DSeq $ m Seq.<| (dseq b), c))+                               Just _  -> (a, (b, DSeq $ (dseq c) Seq.|> m))++-- | findMessage searches for a specific message as identified by the+-- PostId.  The search starts from the most recent messages because+-- that is the most likely place the message will occur.+findMessage :: PostId -> Messages -> Maybe Message+findMessage pid msgs =+    Seq.findIndexR (\m -> m^.mPostId == Just pid) (dseq msgs)+    >>= Just . Seq.index (dseq msgs)++-- | Look forward for the first Message that corresponds to a user+-- Post (i.e. has a post ID) that follows the specified PostId+getNextPostId :: Maybe PostId -> Messages -> Maybe PostId+getNextPostId = getRelPostId foldl++-- | Look backwards for the first Message that corresponds to a user+-- Post (i.e. has a post ID) that comes before the specified PostId.+getPrevPostId :: Maybe PostId -> Messages -> Maybe PostId+getPrevPostId = getRelPostId $ foldr . flip++-- | Find the next PostId after the specified PostId (if there is one)+-- by folding in the specified direction+getRelPostId :: ((Either PostId (Maybe PostId)+                      -> Message+                      -> Either PostId (Maybe PostId))+                -> Either PostId (Maybe PostId)+                -> Messages+                -> Either PostId (Maybe PostId))+             -> Maybe PostId+             -> Messages+             -> Maybe PostId+getRelPostId folD jp = case jp of+                         Nothing -> getLatestPostId+                         Just p -> either (const Nothing) id . folD fnd (Left p)+    where fnd = either fndp fndnext+          fndp c v = if v^.mPostId == Just c then Right Nothing else Left c+          idOfPost m = if m^.mDeleted then Nothing else m^.mPostId+          fndnext n m = Right (n <|> idOfPost m)++-- | Find the most recent message that is a Post (as opposed to a+-- local message) (if any).+getLatestPostId :: Messages -> Maybe PostId+getLatestPostId msgs =+    Seq.findIndexR valid (dseq msgs)+    >>= _mPostId <$> Seq.index (dseq msgs)+    where valid m = not (m^.mDeleted) && isJust (m^.mPostId)++-- | Find the most recent message that is a message posted by a user+-- that matches the (if any), skipping local client messages and any+-- user event that is not a message (i.e. find a normal message or an+-- emote).+findLatestUserMessage :: (Message -> Bool) -> Messages -> Maybe Message+findLatestUserMessage f msgs =+    case getLatestPostId msgs of+        Nothing -> Nothing+        Just pid -> findUserMessageFrom pid msgs+    where findUserMessageFrom p ms =+              let Just msg = findMessage p ms+              in if f msg+                 then Just msg+                 else case getPrevPostId (msg^.mPostId) msgs of+                        Nothing -> Nothing+                        Just p' -> findUserMessageFrom p' msgs++-- | Return all messages that were posted after the specified date/time.+messagesAfter :: UTCTime -> Messages -> Messages+messagesAfter viewTime = onDirectedSeq $ Seq.takeWhileR (\m -> m^.mDate > viewTime)++-- | Reverse the order of the messages+reverseMessages :: Messages -> RetrogradeMessages+reverseMessages = DSeq . Seq.reverse . dseq++-- | Unreverse the order of the messages+unreverseMessages :: RetrogradeMessages -> Messages+unreverseMessages = DSeq . Seq.reverse . dseq
+ src/Types/Posts.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TemplateHaskell #-}++module Types.Posts where++import           Cheapskate (Blocks)+import qualified Cheapskate as C+import qualified Data.Map.Strict as Map+import           Data.Monoid ((<>))+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import           Data.Time.Clock (UTCTime)+import           Lens.Micro.Platform ((^.), makeLenses)+import           Network.Mattermost+import           Network.Mattermost.Lenses++-- * Client Messages++-- | A 'ClientMessage' is a message given to us by our client,+--   like help text or an error message.+data ClientMessage = ClientMessage+  { _cmText :: T.Text+  , _cmDate :: UTCTime+  , _cmType :: ClientMessageType+  } deriving (Eq, Show)++-- | We format 'ClientMessage' values differently depending on+--   their 'ClientMessageType'+data ClientMessageType =+    Informative+    | Error+    | DateTransition+    | NewMessagesTransition+    deriving (Eq, Show)++-- ** 'ClientMessage' Lenses++makeLenses ''ClientMessage++-- * Mattermost Posts++-- | A 'ClientPost' is a temporary internal representation of+--   the Mattermost 'Post' type, with unnecessary information+--   removed and some preprocessing done.+data ClientPost = ClientPost+  { _cpText          :: Blocks+  , _cpUser          :: Maybe UserId+  , _cpUserOverride  :: Maybe T.Text+  , _cpDate          :: UTCTime+  , _cpType          :: PostType+  , _cpPending       :: Bool+  , _cpDeleted       :: Bool+  , _cpAttachments   :: Seq.Seq Attachment+  , _cpInReplyToPost :: Maybe PostId+  , _cpPostId        :: PostId+  , _cpChannelId     :: ChannelId+  , _cpReactions     :: Map.Map T.Text Int+  , _cpOriginalPost  :: Post+  } deriving (Show)++-- | An attachment has a very long URL associated, as well as+--   an actual file URL+data Attachment = Attachment+  { _attachmentName   :: T.Text+  , _attachmentURL    :: T.Text+  , _attachmentFileId :: FileId+  } deriving (Eq, Show)++-- | A Mattermost 'Post' value can represent either a normal+--   chat message or one of several special events.+data PostType =+    NormalPost+    | Emote+    | Join+    | Leave+    | TopicChange+    deriving (Eq, Show)++-- ** Creating 'ClientPost' Values++-- | Parse text as Markdown and extract the AST+getBlocks :: T.Text -> Blocks+getBlocks s = bs where C.Doc _ bs = C.markdown C.def s++-- | Determine the internal 'PostType' based on a 'Post'+postClientPostType :: Post -> PostType+postClientPostType cp =+    if | postIsEmote cp       -> Emote+       | postIsJoin  cp       -> Join+       | postIsLeave cp       -> Leave+       | postIsTopicChange cp -> TopicChange+       | otherwise            -> NormalPost++-- | Find out whether a 'Post' represents a topic change+postIsTopicChange :: Post -> Bool+postIsTopicChange p = postType p == SystemHeaderChange++-- | Find out whether a 'Post' is from a @/me@ command+postIsEmote :: Post -> Bool+postIsEmote p =+    and [ p^.postPropsL.postPropsOverrideIconUrlL == Just (""::T.Text)+        , ("*" `T.isPrefixOf` postMessage p)+        , ("*" `T.isSuffixOf` postMessage p)+        ]++-- | Find out whether a 'Post' is a user joining a channel+postIsJoin :: Post -> Bool+postIsJoin p = "has joined the channel" `T.isInfixOf` postMessage p++-- | Find out whether a 'Post' is a user leaving a channel+postIsLeave :: Post -> Bool+postIsLeave p = "has left the channel" `T.isInfixOf` postMessage p++-- | Undo the automatic formatting of posts generated by @/me@-commands+unEmote :: PostType -> T.Text -> T.Text+unEmote Emote t = if "*" `T.isPrefixOf` t && "*" `T.isSuffixOf` t+                  then T.init $ T.tail t+                  else t+unEmote _ t = t++-- | Convert a Mattermost 'Post' to a 'ClientPost', passing in a+--   'ParentId' if it has a known one.+toClientPost :: Post -> Maybe PostId -> ClientPost+toClientPost p parentId = ClientPost+  { _cpText          = (getBlocks $ unEmote (postClientPostType p) $ postMessage p)+                       <> getAttachmentText p+  , _cpUser          = postUserId p+  , _cpUserOverride  = case p^.postPropsL.postPropsOverrideIconUrlL of+      Just _ -> Nothing+      _      -> p^.postPropsL.postPropsOverrideUsernameL+  , _cpDate          = postCreateAt p+  , _cpType          = postClientPostType p+  , _cpPending       = False+  , _cpDeleted       = False+  , _cpAttachments   = Seq.empty+  , _cpInReplyToPost = parentId+  , _cpPostId        = p^.postIdL+  , _cpChannelId     = p^.postChannelIdL+  , _cpReactions     = Map.empty+  , _cpOriginalPost  = p+  }++-- | Right now, instead of treating 'attachment' properties specially, we're+--   just going to roll them directly into the message text+getAttachmentText :: Post -> Blocks+getAttachmentText p =+  case p^.postPropsL.postPropsAttachmentsL of+    Nothing -> Seq.empty+    Just attachments ->+      fmap (C.Blockquote . render) attachments+  where render att = getBlocks (att^.ppaTextL)++-- ** 'ClientPost' Lenses++makeLenses ''Attachment+makeLenses ''ClientPost
+ src/Zipper.hs view
@@ -0,0 +1,72 @@+module Zipper where++import Prelude ()+import Prelude.Compat++import Lens.Micro.Platform (Lens, lens, ix, (&), (.~))++data Zipper a = Zipper+  { zFocus :: Int+  , zElems :: [a]+  }++-- Move the focus one element to the left+left :: Zipper a -> Zipper a+left z = z { zFocus = (zFocus z - 1) `mod` length (zElems z) }++-- A lens on the zipper moved to the left+leftL :: Lens (Zipper a) (Zipper a) (Zipper a) (Zipper a)+leftL = lens left (\ _ b -> right b)++-- Move the focus one element to the right+right :: Zipper a -> Zipper a+right z = z { zFocus = (zFocus z + 1) `mod` length (zElems z) }++-- A lens on the zipper moved to the right+rightL :: Lens (Zipper a) (Zipper a) (Zipper a) (Zipper a)+rightL = lens right (\ _ b -> left b)++-- Return the focus element+focus :: Zipper a -> a+focus z = zElems z !! zFocus z++-- A lens to return the focus element+focusL :: Lens (Zipper a) (Zipper a) a a+focusL = lens focus upd+  where upd (Zipper n elems) x = Zipper n (elems & ix(n) .~ x)++-- Turn a list into a wraparound zipper, focusing on the head+fromList :: [a] -> Zipper a+fromList xs = Zipper { zFocus = 0, zElems = xs }++-- Shift the focus until a given element is found, or return the+-- same zipper if none applies+findRight :: (a -> Bool) -> Zipper a -> Zipper a+findRight f z+  | f (focus z) = z+  | otherwise   = go (right z) (zFocus z)+  where go zC n+          | n == zFocus zC = zC+          | f (focus zC)   = zC+          | otherwise      = go (right zC) n++-- Shift the focus until a given element is found, or return the+-- same zipper if none applies+findLeft :: (a -> Bool) -> Zipper a -> Zipper a+findLeft f z+  | f (focus z) = z+  | otherwise   = go (left z) (zFocus z)+  where go zC n+          | n == zFocus zC = zC+          | f (focus zC)   = zC+          | otherwise      = go (left zC) n++updateList :: (Eq a) => [a] -> Zipper a -> Zipper a+updateList newList oldZip = findLeft (== oldFocus) newZip+  where oldFocus = focus oldZip+        newZip   = oldZip { zElems = newList }++filterZipper :: (Eq a) => (a -> Bool) -> Zipper a -> Zipper a+filterZipper f oldZip = findLeft (== oldFocus) newZip+  where oldFocus = focus oldZip+        newZip   = oldZip { zElems = filter f $ zElems oldZip }
+ test/test_messages.hs view
@@ -0,0 +1,562 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module Main where++import           Control.Exception+import           Data.List (intercalate, sortBy)+import qualified Data.List.UniqueUnsorted as U+import qualified Data.Map as Map+import           Data.Maybe (isNothing, fromJust)+import           Data.Monoid ((<>))+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import           Data.Time.Calendar (Day(..))+import           Data.Time.Clock (UTCTime(..), getCurrentTime+                                 , secondsToDiffTime)+import           Lens.Micro.Platform+import           Message_QCA+import           Network.Mattermost.Types+import           System.Exit+import           Test.QuickCheck.Checkers+import           Test.QuickCheck.Classes+import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.QuickCheck+import           Types.Messages+import           Types.Posts++main :: IO ()+main = defaultMain tests `catch` (\e -> do+                                    if e == ExitSuccess+                                    then putStrLn "Passed"+                                    else do putStrLn "FAILED"+                                            throwIO e)++tests :: TestTree+tests = testGroup "Messages Tests"+        [ createTests+        , movementTests+        , reversalTests+        , splitTests+        , instanceTests+        ]+++test_m1 :: IO Message+test_m1 = do t1 <- getCurrentTime+             return $ Message Seq.empty Nothing t1 (CP NormalPost) False False Seq.empty NotAReply Nothing Map.empty Nothing++test_m2 :: IO Message+test_m2 = do t2 <- getCurrentTime+             return $ Message Seq.empty Nothing t2 (CP Emote) False False Seq.empty NotAReply (Just $ fromId $ Id $ T.pack "m2") Map.empty Nothing++test_m3 :: IO Message+test_m3 = do t3 <- getCurrentTime+             return $ Message Seq.empty Nothing t3 (CP NormalPost) False False Seq.empty NotAReply (Just $ fromId $ Id $ T.pack "m3") Map.empty Nothing++setDateOrderMessages :: [Message] -> [Message]+setDateOrderMessages = snd . foldl setTimeAndInsert (startTime, [])+    where setTimeAndInsert (t, ml) m = let t2 = tick t+                                       in (t2, ml ++ [m {_mDate = t2}])+          startTime = UTCTime (ModifiedJulianDay 100) (secondsToDiffTime 0)+          tick (UTCTime d t) = UTCTime d $ succ t++makeMsgs :: [Message] -> Messages+makeMsgs = foldr addMessage noMessages++idlist :: Foldable t => t Message -> [Maybe PostId]+idlist = foldr (\m s -> m^.mPostId : s) []++postids :: (Foldable t) => String -> t Message -> String+postids names msgs = let zipf = (\(n,z) m -> if null n+                                             then ("", ('?', m) : z)+                                             else (init n, (last n, m) : z))+                         zipped = snd $ foldr (flip zipf) (names, []) msgs+                         pid (n, m) = show n <> ".mPostID=" <> show (m^.mPostId)+                     in intercalate ", " $ map pid zipped++uniqueIds :: Foldable t => t Message -> Bool+uniqueIds msgs =+    let ids = idlist msgs+    in  length ids == length (U.unique ids)++validIds :: Foldable t => t Message -> Bool+validIds = null . filter isNothing . idlist++tastyBatch :: TestBatch -> TestTree+tastyBatch b = testGroup (fst b) $ tastyTests (snd b)+    where tastyTests = map tastyTest+          tastyTest = uncurry testProperty++createTests :: TestTree+createTests = testGroup "Create"+              [ testCase "no messages"+                    $ 0 @=? length noMessages+              , testProperty "has messages"+                    $ \x -> not (null (x :: Messages)) ==> 0 /= length x+              , testProperty "add to empty"+                    $ \x -> 1 == (length $ addMessage x noMessages)+              , testProperty "add to add to empty"+                    $ \(x, y) -> 2 == (length $ makeMsgs [x, y])+              , testProperty "join to empty"+                    $ \(x, y) ->+                        let m1 = makeMsgs [x, y]+                            m2 = noMessages+                        in (2 == (length $ m1 <> m2) &&+                            2 == (length $ m2 <> m1))++              , testProperty "join one to many"+                    $ \(x, y, z) ->+                        let l1 = setDateOrderMessages [x, y]+                            m1 = makeMsgs l1+                            m2 = addMessage z noMessages+                            j2 = m2 <> m1+                        in idlist [z, x, y] === idlist j2++              , testProperty "join many to one"+                    $ \(x, y, z) ->+                        let l1 = setDateOrderMessages [x, y]+                            m1 = makeMsgs l1+                            m2 = addMessage z noMessages+                            j1 = m1 <> m2+                        in idlist [x, y, z] === idlist j1++              , testProperty "join to many"+                    $ \(w, x, y, z) ->+                        let l1 = setDateOrderMessages [x, y]+                            l2 = setDateOrderMessages [w, z]+                            m1 = makeMsgs l1+                            m2 = makeMsgs l2+                            -- note that mappend is literal: there is+                            -- no date relationship between the+                            -- members l1 and l2 and mappend doesn't+                            -- enforce one.+                            j1 = m1 <> m2+                            j2 = m2 <> m1+                        in (4 == (length j1) &&+                            4 == (length j2) &&+                            idlist (l1 <> l2) == idlist j1 &&+                            idlist (l2 <> l1) == idlist j2)++              , testProperty "natural ordering of addMessage"+                    $ \(w, x, y, z) ->+                        let l = setDateOrderMessages [w, x, y, z]+                        in idlist l === idlist (makeMsgs l)++              , testProperty "reverse ordering of addMessage"+                    $ \(w, x, y, z) ->+                        let l = setDateOrderMessages [w, x, y, z]+                        in idlist l === idlist (makeMsgs $ reverse l)++              , testProperty "mirrored ordering of addMessage"+                    $ \(w, x, y, z) ->+                        let l = setDateOrderMessages [w, x, y, z]+                            [w', x', y', z'] = l+                        in idlist l === idlist (makeMsgs [y', z', w', x'])++              , testProperty "ordering 1 of addMessage"+                    $ \(w, x, y, z) ->+                        let l = setDateOrderMessages [w, x, y, z]+                            [w', x', y', z'] = l+                        in+                           idlist l === idlist (makeMsgs [y', w', z', x'])++              , testProperty "ordering 2 of addMessage"+                    $ \(w, x, y, z) ->+                        let l = setDateOrderMessages [w, x, y, z]+                            [w', x', y', z'] = l+                        in idlist l === idlist (makeMsgs [x', z', w', y'])++              , testProperty "duplicated last addMessage"+                    $ \(w, x, y, z) ->+                        let l = setDateOrderMessages $ map postMsg [w, x, y, z]+                        in uniqueIds l ==>+                          idlist l === idlist (makeMsgs $ [last l] <> l)++              , testProperty "duplicated natural ordering of addMessage"+                    $ \(w, x, y, z) ->+                        let l = setDateOrderMessages $ map postMsg [w, x, y, z]+                        in idlist l === idlist (makeMsgs $ l <> l)++              , testProperty "duplicated reverse ordering of addMessage"+                    $ \(w, x, y, z) ->+                        let l = setDateOrderMessages $ map postMsg [w, x, y, z]+                        in idlist l === idlist (makeMsgs $ reverse l <> l)++              , testProperty "duplicated mirrored ordering of addMessage"+                    $ \(w, x, y, z) ->+                        let l = setDateOrderMessages $ map postMsg [w, x, y, z]+                            [w', x', y', z'] = l+                        in idlist l === idlist (makeMsgs $ [y', z', w', x'] <> l)++              , testProperty "duplicated ordering 1 of addMessage"+                    $ \(w, x, y, z) ->+                        let l = setDateOrderMessages $ postMsg <$> [w, x, y, z]+                            [w', x', y', z'] = l+                        in idlist l === idlist (makeMsgs $ [y', w', z', x'] <> l)++              , testProperty "duplicated ordering 2 of addMessage"+                    $ \(w, x, y, z) ->+                        let l = setDateOrderMessages $ postMsg <$> [w, x, y, z]+                            [w', x', y', z'] = l+                        in idlist l === idlist (makeMsgs $ [x', z', w', y'] <> l)++              , testProperty "non-posted are not duplicate removed"+                    $ \(w, x, y, z) ->+                        let l = setDateOrderMessages [w, x, y, z]+                            [w', x', y', z'] = l+                            l' = [x', z', w', y']+                            ex = sortBy (\a b -> compare (a^.mDate) (b^.mDate))+                                 ([e | e <- l', isNothing (e^.mPostId) ] <> l)+                        in idlist ex === idlist (makeMsgs $ l' <> l)++              , testProperty "duplicate dates different IDs in posted order"+                    $ \(w, x, y, z) ->+                        let d = UTCTime+                                (ModifiedJulianDay 1234)+                                (secondsToDiffTime 9876)+                            l = foldl (setTime d) [] $ postMsg <$> [w, x, y, z]+                            setTime t ml m = ml ++ [m {_mDate = t}]+                            [w', x', y', z'] = l+                            l' = [x', z', w', y']+                            ex = l+                        in uniqueIds l ==>+                           idlist ex === idlist (makeMsgs $ l' <> l)+++              ]++movementTests :: TestTree+movementTests = testGroup "Movement"+                [ moveUpTestEmpty+                , moveUpTestSingle+                , moveUpTestMultipleStart+                , moveUpTestMultipleEnd+                , moveUpTestMultipleSkipDeleted+                , moveUpTestMultipleSkipDeletedAll+                , moveDownTestEmpty+                , moveDownTestMultipleStart+                , moveDownTestSingle+                , moveDownTestMultipleEnd+                , moveDownTestMultipleSkipDeleted+                , moveDownTestMultipleSkipDeletedAll+                ]++moveDownTestEmpty :: TestTree+moveDownTestEmpty = testProperty "Move up in empty messages" $+                    \x -> Nothing == getNextPostId x noMessages++moveUpTestEmpty :: TestTree+moveUpTestEmpty = testProperty "Move down in empty messages" $+                    \x -> Nothing == getPrevPostId x noMessages++moveDownTestSingle :: TestTree+moveDownTestSingle = testProperty "Move up from single message" $+                   \x -> let msgs = addMessage x noMessages+                         in Nothing == (getNextPostId (x^.mPostId) msgs)++moveUpTestSingle :: TestTree+moveUpTestSingle = testProperty "Move down from single message" $+                    \x -> let msgs = addMessage x noMessages+                          in Nothing == (getPrevPostId (x^.mPostId) msgs)++moveDownTestMultipleStart :: TestTree+moveDownTestMultipleStart =+    testProperty "Move down in multiple messages from the start" $+                     \(x', y', z') ->+                         let [x, y, z] = setDateOrderMessages+                                         [ postMsg x'+                                         , postMsg y'+                                         , postMsg z'+                                         ]+                             msgs = makeMsgs [x, y, z]+                             msgid = getNextPostId (x^.mPostId) msgs+                             -- for useful info on failure:+                             idents = postids "xyz" msgs+                             info = idents <> " against " <> show msgid+                         in counterexample info $+                                y^.mPostId == msgid++moveUpTestMultipleStart :: TestTree+moveUpTestMultipleStart =+    testProperty "Move up in multiple messages from the start" $+                     \(x', y', z') ->+                         let [x, y, z] = setDateOrderMessages+                                         [ postMsg x', postMsg y', postMsg z']+                             msgs = makeMsgs [x, y, z]+                             msgid = getPrevPostId (x^.mPostId) msgs+                             -- for useful info on failure:+                             idents = postids "xyz" msgs+                             info = idents <> " against " <> show msgid+                         in uniqueIds msgs ==>+                            counterexample info $ Nothing == msgid++moveDownTestMultipleEnd :: TestTree+moveDownTestMultipleEnd =+    testProperty "Move down in multiple messages from the end" $+                     \(x', y', z') ->+                         let [x, y, z] = setDateOrderMessages+                                         [ postMsg x', postMsg y', postMsg z']+                             msgs = makeMsgs [x, y, z]+                             msgid = getNextPostId (z^.mPostId) msgs+                             -- for useful info on failure:+                             idents = postids "xyz" msgs+                             info = idents <> " against " <> show msgid+                         in uniqueIds msgs ==>+                            counterexample info $ Nothing == msgid++moveUpTestMultipleEnd :: TestTree+moveUpTestMultipleEnd =+    testProperty "Move up in multiple messages from the end" $+                     \(x', y', z') ->+                         let [x, y, z] = setDateOrderMessages+                                         [ postMsg x', postMsg y', postMsg z']+                             msgs = makeMsgs [x, y, z]+                             msgid = getPrevPostId (z^.mPostId) msgs+                             -- for useful info on failure:+                             idents = postids "xyz" msgs+                             info = idents <> " against " <> show msgid+                         in uniqueIds msgs ==>+                            counterexample info $ (y^.mPostId) == msgid++moveDownTestMultipleSkipDeleted :: TestTree+moveDownTestMultipleSkipDeleted =+    testProperty "Move down in multiple messages skipping deleteds" $+                     \(w', x', y', z') ->+                         let [w, x, y, z] = setDateOrderMessages+                                            [ postMsg w'+                                            , delMsg x'+                                            , delMsg y'+                                            , postMsg z']+                             msgs = makeMsgs [w, x, y, z]+                             msgid = getNextPostId (w^.mPostId) msgs+                             -- for useful info on failure:+                             idents = postids "wxyz" msgs+                             info = idents <> " against " <> show msgid+                         in counterexample info $ (z^.mPostId) == msgid++moveUpTestMultipleSkipDeleted :: TestTree+moveUpTestMultipleSkipDeleted =+    testProperty "Move one up in multiple messages skipping deleteds" $+                     \(w', x', y', z') ->+                         let [w, x, y, z] = setDateOrderMessages+                                            [ postMsg w'+                                            , delMsg x'+                                            , delMsg y'+                                            , postMsg z']+                             msgs = makeMsgs [w, x, y, z]+                             msgid = getPrevPostId (z^.mPostId) msgs+                             -- for useful info on failure:+                             idents = postids "wxyz" msgs+                             info = idents <> " against " <> show msgid+                         in uniqueIds msgs ==>+                            counterexample info $ (w^.mPostId) == msgid++moveDownTestMultipleSkipDeletedAll :: TestTree+moveDownTestMultipleSkipDeletedAll =+    testProperty "Move one down in multiple deleted messages skipping deleteds" $+                     \(w', x', y', z') ->+                         -- n.b. current selected is also deleted,+                         -- which can happen due to multi-user async+                         -- server changes.+                         let [w, x, y, z] = setDateOrderMessages+                                            [ delMsg w'+                                            , delMsg x'+                                            , delMsg y'+                                            , delMsg z']+                             msgs = makeMsgs [w, x, y, z]+                             msgid = getNextPostId (w^.mPostId) msgs+                             -- for useful info on failure:+                             idents = postids "wxyz" msgs+                             info = idents <> " against " <> show msgid+                         in counterexample info $ Nothing == msgid++moveUpTestMultipleSkipDeletedAll :: TestTree+moveUpTestMultipleSkipDeletedAll =+    testProperty "Move one up in multiple deleted messages skipping deleteds" $+                     \(w', x', y', z') ->+                         -- n.b. current selected is also deleted,+                         -- which can happen due to multi-user async+                         -- server changes.+                         let [w, x, y, z] = setDateOrderMessages+                                            [ delMsg w'+                                            , delMsg x'+                                            , delMsg y'+                                            , delMsg z']+                             msgs = makeMsgs [w, x, y, z]+                             msgid = getPrevPostId (z^.mPostId) msgs+                             -- for useful info on failure:+                             idents = postids "wxyz" msgs+                             info = idents <> " against " <> show msgid+                         in uniqueIds msgs ==>+                            counterexample info $ Nothing == msgid++reversalTests :: TestTree+reversalTests = testGroup "Reversal"+                [ testProperty "round trip" $+                     \l -> let rr = unreverseMessages (reverseMessages l)+                           in idlist l === idlist rr+                , testProperty "getLatestMessage finds same in either dir" $+                     \l -> let rr = unreverseMessages (reverseMessages l)  -- KWQ: just one reverse, not two+                           in getLatestPostId l === getLatestPostId rr+                , testCase "reverse nothing" $+                      (null $ unreverseMessages $ reverseMessages noMessages) @?+                      "reverse of empty Messages"+                , testProperty "reverse order" $+                      \l -> let r = reverseMessages l+                            in idlist l === reverse (idlist r)+                ]++splitTests :: TestTree+splitTests = testGroup "Split"+             [ testCase "split nothing on empty" $+                        let (m, _) = splitMessages Nothing noMessages+                        in isNothing m @? "must be nothing"++             , testProperty "split just on empty" $ \x ->+                   let (m, _) = splitMessages (Just x) noMessages+                   in isNothing m++             , testProperty "split nothing on list" $ \x ->+                 let (m, _) = splitMessages Nothing x+                 in isNothing m++             , testProperty "split nothing on not found" $ \(w', x', y', z') ->+                 let (m, _) = splitMessages (w^.mPostId) msgs+                     [w, x, y, z] = setDateOrderMessages [w', x', y', z']+                     msgs = makeMsgs [x, y, z]+                     idents = postids "wxyz" msgs+                     info = idents <> " against " <> show ((fromJust m)^.mPostId)+                 in uniqueIds [w, x, y, z] ==>+                    counterexample info $ isNothing m++             , testProperty "all before reversed on split nothing"+                   $ \(w, x, y, z) ->+                       let (_, (before, _)) = splitMessages Nothing msgs+                           msgs = makeMsgs inpl+                           inpl = setDateOrderMessages [w, x, y, z]+                           control = idlist (reverse inpl)+                           result = idlist before+                           info = show control <> " /= " <> show result+                       in counterexample info $ control == result++             , testProperty "all before reversed on not found"+                   $ \(w', x', y', z') ->+                       let (_, (before, _)) = splitMessages (w^.mPostId) msgs+                           msgs = makeMsgs inpl+                           inpl = [x, y, z]+                           [w, x, y, z] = setDateOrderMessages [w', x', y', z']+                       in uniqueIds [w, x, y, z] ==>+                          idlist (reverse inpl) == idlist before++             , testProperty "found at first position"+                   $ \(w', x', y', z') ->+                       let (m, _) = splitMessages (w^.mPostId) msgs+                           msgs = makeMsgs inpl+                           inpl = [w, x, y, z]+                           [w, x, y, z] = setDateOrderMessages [w', x', y', z']+                       in validIds inpl && uniqueIds inpl ==>+                          w^.mPostId == (fromJust m)^.mPostId++             , testProperty "no before when found at first position"+                   $ \(w', x', y', z') ->+                       let (_, (before, _)) = splitMessages (w^.mPostId) msgs+                           msgs = makeMsgs inpl+                           inpl = [w, x, y, z]+                           [w, x, y, z] = setDateOrderMessages [w', x', y', z']+                           info = show (idlist inpl) <> " ==> " <> (show $ idlist before)+                       in validIds inpl && uniqueIds inpl ==>+                          counterexample info $ null $ unreverseMessages before+             , testProperty "remaining after when found at first position"+                   $ \(w', x', y', z') ->+                       let (_, (_, after)) = splitMessages (w^.mPostId) msgs+                           msgs = makeMsgs inpl+                           inpl = [w, x, y, z]+                           [w, x, y, z] = setDateOrderMessages [w', x', y', z']+                           info = show (idlist inpl) <> " ==> " <> (show $ idlist after)+                       in validIds inpl && uniqueIds inpl ==>+                          counterexample info $+                                         idlist (tail inpl) == idlist after++             , testProperty "found at last position"+                   $ \(w', x', y', z') ->+                       let (m, _) = splitMessages (z^.mPostId) msgs+                           msgs = makeMsgs inpl+                           inpl = [w, x, y, z]+                           [w, x, y, z] = setDateOrderMessages [w', x', y', z']+                       in validIds inpl && uniqueIds inpl ==>+                          z^.mPostId == (fromJust m)^.mPostId++             , testProperty "reversed before when found at last position"+                   $ \(w', x', y', z') ->+                       let (_, (before, _)) = splitMessages (z^.mPostId) msgs+                           msgs = makeMsgs inpl+                           inpl = [w, x, y, z]+                           [w, x, y, z] = setDateOrderMessages [w', x', y', z']+                           info = show (idlist inpl) <> " ==> " <> (show $ idlist before)+                       in validIds inpl && uniqueIds inpl ==>+                          counterexample info $+                                         idlist (reverse $ init inpl) == idlist before++             , testProperty "no after when found at last position"+                   $ \(w', x', y', z') ->+                       let (_, (_, after)) = splitMessages (z^.mPostId) msgs+                           msgs = makeMsgs inpl+                           inpl = [w, x, y, z]+                           [w, x, y, z] = setDateOrderMessages [w', x', y', z']+                           info = show (idlist inpl) <> " ==> " <> (show $ idlist after)+                       in validIds inpl && uniqueIds inpl ==>+                          counterexample info $ null after++             , testProperty "found at midpoint position"+                   $ \(v', w', x', y', z') ->+                       let (m, _) = splitMessages (x^.mPostId) msgs+                           msgs = makeMsgs inpl+                           inpl = [v, w, x, y, z]+                           [v, w, x, y, z] = setDateOrderMessages+                                             [v', w', x', y', z']+                       in validIds inpl && uniqueIds inpl ==>+                          x^.mPostId == (fromJust m)^.mPostId++             , testProperty "reversed before when found at midpoint position"+                   $ \(v', w', x', y', z') ->+                       let (_, (before, _)) = splitMessages (x^.mPostId) msgs+                           msgs = makeMsgs inpl+                           inpl = [v, w, x, y, z]+                           [v, w, x, y, z] = setDateOrderMessages+                                             [v', w', x', y', z']+                           info = show (idlist inpl) <> " ==> " <> (show $ idlist before)+                       in validIds inpl && uniqueIds inpl ==>+                          counterexample info $+                                         idlist [w, v] == idlist before++             , testProperty "after when found at midpoint position"+                   $ \(v', w', x', y', z') ->+                       let (_, (_, after)) = splitMessages (x^.mPostId) msgs+                           msgs = makeMsgs inpl+                           inpl = [v, w, x, y, z]+                           [v, w, x, y, z] = setDateOrderMessages+                                             [v', w', x', y', z']+                           info = show (idlist inpl) <> " ==> " <> (show $ idlist after)+                       in validIds inpl && uniqueIds inpl ==>+                          counterexample info $+                                         idlist [y, z] == idlist after+             ]+++instanceTests :: TestTree+instanceTests = testGroup "Messages Instances"+                $ map tastyBatch+                      [ (monoid (undefined :: Messages))+                      , (monoid (undefined :: RetrogradeMessages))+                      ]++instance EqProp Messages where+    a =-= b = idlist a =-= idlist b++instance EqProp RetrogradeMessages where+    a =-= b = idlist a =-= idlist b++instance EqProp PostId where+    a =-= b = (show $ idString a) =-= (show $ idString b)