module Matterhorn.State.Common
  (
  -- * System interface
    openFilePath
  , openWithOpener
  , runLoggedCommand
  , fetchFile
  , fetchFileAtPath

  -- * Posts
  , installMessagesFromPosts
  , updatePostMap

  -- * Utilities
  , postInfoMessage
  , postErrorMessageIO
  , postErrorMessage'
  , addEmoteFormatting
  , removeEmoteFormatting
  , toggleMouseMode

  , fetchMentionedUsers
  , doPendingUserFetches
  , doPendingUserStatusFetches

  , setThreadOrientationByName

  -- Cache management
  , invalidateChannelRenderingCache
  , invalidateMessageRenderingCacheByPostId

  , module Matterhorn.State.Async
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import           Brick.Main ( invalidateCacheEntry, invalidateCache, getVtyHandle )
import           Control.Concurrent ( MVar, putMVar, forkIO )
import qualified Control.Concurrent.STM as STM
import           Control.Exception ( SomeException, try )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.HashMap.Strict as HM
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Graphics.Vty as Vty
import           Lens.Micro.Platform ( (.=), (%=), (%~), (.~) )
import           System.Directory ( createDirectoryIfMissing )
import           System.Environment.XDG.BaseDir ( getUserCacheDir )
import           System.Exit ( ExitCode(..) )
import           System.FilePath
import           System.IO ( hGetContents, hFlush )
import           System.Process ( proc, std_in, std_out, std_err, StdStream(..)
                                , createProcess, waitForProcess )

import           Network.Mattermost.Endpoints
import           Network.Mattermost.Lenses
import           Network.Mattermost.Types

import           Matterhorn.FilePaths ( xdgName )
import           Matterhorn.State.Async
import           Matterhorn.Types
import           Matterhorn.Types.Common


-- * Client Messages

-- | Given a collection of posts from the server, save the posts in the
-- global post map. Also convert the posts to Matterhorn's Message type
-- and return them along with the set of all usernames mentioned in the
-- text of the resulting messages.
--
-- This also sets the mFlagged field of each message based on whether
-- its post ID is a flagged post according to crFlaggedPosts at the time
-- of this call.
installMessagesFromPosts :: Maybe TeamId -> Posts -> MH Messages
installMessagesFromPosts :: Maybe TeamId -> Posts -> MH Messages
installMessagesFromPosts Maybe TeamId
mTId Posts
postCollection = do
  Set PostId
flags <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources (Set PostId)
crFlaggedPosts)

  -- Add all posts in this collection to the global post cache
  Maybe TeamId -> Posts -> MH ()
updatePostMap Maybe TeamId
mTId Posts
postCollection

  Maybe TeamBaseURL
mBaseUrl <- case Maybe TeamId
mTId of
      Maybe TeamId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      Just TeamId
tId -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TeamId -> MH TeamBaseURL
getServerBaseUrl TeamId
tId

  Text
hostname <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources ConnectionData
crConnforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ConnectionData Text
cdHostnameL)

  -- Build the ordered list of posts. Note that postsOrder lists the
  -- posts most recent first, but we want most recent last.
  let postsInOrder :: Seq Post
postsInOrder = PostId -> Post
findPost forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Seq a -> Seq a
Seq.reverse forall a b. (a -> b) -> a -> b
$ Posts -> Seq PostId
postsOrder Posts
postCollection)
      mkClientPost :: Post -> ClientPost
mkClientPost Post
p = Text -> Maybe TeamBaseURL -> Post -> Maybe PostId -> ClientPost
toClientPost Text
hostname Maybe TeamBaseURL
mBaseUrl Post
p (Post -> PostId
postId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Post -> Maybe Post
parent Post
p)
      clientPosts :: Seq ClientPost
clientPosts = Post -> ClientPost
mkClientPost forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq Post
postsInOrder

      addNext :: ClientPost -> (a, Set MentionedUser) -> (a, Set MentionedUser)
addNext ClientPost
cp (a
msgs, Set MentionedUser
us) =
          let (Message
msg, Set MentionedUser
mUsernames) = ClientPost -> (Message, Set MentionedUser)
clientPostToMessage ClientPost
cp
          in (forall a. MessageOps a => Message -> a -> a
addMessage (Set PostId -> Message -> Message
maybeFlag Set PostId
flags Message
msg) a
msgs, forall a. Ord a => Set a -> Set a -> Set a
Set.union Set MentionedUser
us Set MentionedUser
mUsernames)
      (Messages
ms, Set MentionedUser
mentions) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}.
MessageOps a =>
ClientPost -> (a, Set MentionedUser) -> (a, Set MentionedUser)
addNext (Messages
noMessages, forall a. Monoid a => a
mempty) Seq ClientPost
clientPosts

  Set MentionedUser -> MH ()
fetchMentionedUsers Set MentionedUser
mentions
  forall (m :: * -> *) a. Monad m => a -> m a
return Messages
ms
    where
        maybeFlag :: Set PostId -> Message -> Message
maybeFlag Set PostId
flagSet Message
msg
          | Just (MessagePostId PostId
pId) <- Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe MessageId)
mMessageId, PostId
pId forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PostId
flagSet
            = Message
msg forall a b. a -> (a -> b) -> b
& Lens' Message Bool
mFlagged forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
          | Bool
otherwise = Message
msg
        parent :: Post -> Maybe Post
parent Post
x = do
            PostId
parentId <- Post
xforall s a. s -> Getting a s a -> a
^.Lens' Post (Maybe PostId)
postRootIdL
            forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup PostId
parentId (Posts
postCollectionforall s a. s -> Getting a s a -> a
^.Lens' Posts (HashMap PostId Post)
postsPostsL)
        findPost :: PostId -> Post
findPost PostId
pId = case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup PostId
pId (Posts -> HashMap PostId Post
postsPosts Posts
postCollection) of
            Maybe Post
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"BUG: could not find post for post ID " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show PostId
pId
            Just Post
post -> Post
post

-- Add all posts in this collection to the global post cache
updatePostMap :: Maybe TeamId -> Posts -> MH ()
updatePostMap :: Maybe TeamId -> Posts -> MH ()
updatePostMap Maybe TeamId
mTId Posts
postCollection = do
  -- Build a map from post ID to Matterhorn message, then add the new
  -- messages to the global post map. We use the "postsPosts" field for
  -- this because that might contain more messages than the "postsOrder"
  -- list, since the former can contain other messages in threads that
  -- the server sent us, even if those messages are not part of the
  -- ordered post listing of "postsOrder."
  Maybe TeamBaseURL
mBaseUrl <- case Maybe TeamId
mTId of
      Maybe TeamId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      Just TeamId
tId -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TeamId -> MH TeamBaseURL
getServerBaseUrl TeamId
tId

  Text
hostname <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources ConnectionData
crConnforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ConnectionData Text
cdHostnameL)

  let postMap :: HashMap PostId Message
postMap = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList
          [ ( PostId
pId
            , forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ ClientPost -> (Message, Set MentionedUser)
clientPostToMessage (Text -> Maybe TeamBaseURL -> Post -> Maybe PostId -> ClientPost
toClientPost Text
hostname Maybe TeamBaseURL
mBaseUrl Post
x forall a. Maybe a
Nothing)
            )
          | (PostId
pId, Post
x) <- forall k v. HashMap k v -> [(k, v)]
HM.toList (Posts
postCollectionforall s a. s -> Getting a s a -> a
^.Lens' Posts (HashMap PostId Post)
postsPostsL)
          ]
  Lens' ChatState (HashMap PostId Message)
csPostMap forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HM.union HashMap PostId Message
postMap

-- | Add a 'ClientMessage' to the current channel's message list
addClientMessage :: ClientMessage -> MH ()
addClientMessage :: ClientMessage -> MH ()
addClientMessage ClientMessage
msg = do
    (TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId -> do
        TeamId -> (ChannelId -> ClientChannel -> MH ()) -> MH ()
withCurrentChannel TeamId
tId forall a b. (a -> b) -> a -> b
$ \ChannelId
cid ClientChannel
_ -> do
            UUID
uuid <- MH UUID
generateUUID
            let addCMsg :: ClientChannel -> ClientChannel
addCMsg = Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessages forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~
                    (forall a. MessageOps a => Message -> a -> a
addMessage forall a b. (a -> b) -> a -> b
$ ClientMessage -> Message
clientMessageToMessage ClientMessage
msg forall a b. a -> (a -> b) -> b
& Lens' Message (Maybe MessageId)
mMessageId forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Maybe a
Just (UUID -> MessageId
MessageUUID UUID
uuid))
            Lens' ChatState ClientChannels
csChannels forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ChannelId
-> (ClientChannel -> ClientChannel)
-> ClientChannels
-> ClientChannels
modifyChannelById ChannelId
cid ClientChannel -> ClientChannel
addCMsg

            ChannelId -> MH ()
invalidateChannelRenderingCache ChannelId
cid
            forall a. EventM Name ChatState a -> MH a
mh forall a b. (a -> b) -> a -> b
$ forall n s. Ord n => n -> EventM n s ()
invalidateCacheEntry forall a b. (a -> b) -> a -> b
$ TeamId -> Name
ChannelSidebar TeamId
tId

            let msgTy :: LogCategory
msgTy = case ClientMessage
msgforall s a. s -> Getting a s a -> a
^.Lens' ClientMessage ClientMessageType
cmType of
                  ClientMessageType
Error -> LogCategory
LogError
                  ClientMessageType
_     -> LogCategory
LogGeneral

            LogCategory -> Text -> MH ()
mhLog LogCategory
msgTy forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ClientMessage
msg

-- | Add a new 'ClientMessage' representing an error message to
--   the current channel's message list
postInfoMessage :: Text -> MH ()
postInfoMessage :: Text -> MH ()
postInfoMessage Text
info =
    ClientMessage -> MH ()
addClientMessage forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
ClientMessageType -> Text -> m ClientMessage
newClientMessage ClientMessageType
Informative (Text -> Text
sanitizeUserText' Text
info)

-- | Add a new 'ClientMessage' representing an error message to
--   the current channel's message list
postErrorMessage' :: Text -> MH ()
postErrorMessage' :: Text -> MH ()
postErrorMessage' Text
err =
    ClientMessage -> MH ()
addClientMessage forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadIO m =>
ClientMessageType -> Text -> m ClientMessage
newClientMessage ClientMessageType
Error (Text -> Text
sanitizeUserText' Text
err)

postErrorMessageIO :: Text -> ChatState -> IO ChatState
postErrorMessageIO :: Text -> ChatState -> IO ChatState
postErrorMessageIO Text
err ChatState
st = do
  case ChatState
stforall s a. s -> Getting a s a -> a
^.SimpleGetter ChatState (Maybe TeamId)
csCurrentTeamId of
      Maybe TeamId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ChatState
st
      Just TeamId
tId -> do
          case ChatState
stforall s a. s -> Getting a s a -> a
^.TeamId -> SimpleGetter ChatState (Maybe ChannelId)
csCurrentChannelId(TeamId
tId) of
              Maybe ChannelId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ChatState
st
              Just ChannelId
cId -> do
                  ClientMessage
msg <- forall (m :: * -> *).
MonadIO m =>
ClientMessageType -> Text -> m ClientMessage
newClientMessage ClientMessageType
Error Text
err
                  UUID
uuid <- IO UUID
generateUUID_IO
                  let addEMsg :: ClientChannel -> ClientChannel
addEMsg = Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessages forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~
                          (forall a. MessageOps a => Message -> a -> a
addMessage forall a b. (a -> b) -> a -> b
$ ClientMessage -> Message
clientMessageToMessage ClientMessage
msg forall a b. a -> (a -> b) -> b
& Lens' Message (Maybe MessageId)
mMessageId forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Maybe a
Just (UUID -> MessageId
MessageUUID UUID
uuid))
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ChatState
st forall a b. a -> (a -> b) -> b
& Lens' ChatState ClientChannels
csChannels forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ChannelId
-> (ClientChannel -> ClientChannel)
-> ClientChannels
-> ClientChannels
modifyChannelById ChannelId
cId ClientChannel -> ClientChannel
addEMsg

openFilePath :: FilePath -> MH ()
openFilePath :: String -> MH ()
openFilePath String
path = MH (Either MHError String) -> MH ()
openWithOpener (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right String
path)

openWithOpener :: MH (Either MHError String) -> MH ()
openWithOpener :: MH (Either MHError String) -> MH ()
openWithOpener MH (Either MHError String)
getTarget = do
    Config
cfg <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources Config
crConfiguration)
    case Config -> Maybe Text
configURLOpenCommand Config
cfg of
        Maybe Text
Nothing ->
            MHError -> MH ()
mhError forall a b. (a -> b) -> a -> b
$ Text -> MHError
ConfigOptionMissing Text
"urlOpenCommand"
        Just Text
urlOpenCommand -> do
            Either MHError String
targetResult <- MH (Either MHError String)
getTarget
            let cmdWords :: [Text]
cmdWords = Text -> [Text]
T.words Text
urlOpenCommand
                ([String]
cmds, [String]
args) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
1 (Text -> String
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
cmdWords)
                cmd :: String
cmd = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
cmds then String
"$BROWSER" else forall a. [a] -> a
head [String]
cmds
            case Either MHError String
targetResult of
                Left MHError
e -> do
                    MHError -> MH ()
mhError MHError
e
                Right String
target -> do
                    -- Is the URL-opening command interactive? If
                    -- so, pause Matterhorn and run the opener
                    -- interactively. Otherwise run the opener
                    -- asynchronously and continue running Matterhorn
                    -- interactively.
                    case Config -> Bool
configURLOpenCommandInteractive Config
cfg of
                        Bool
False -> do
                            TChan ProgramOutput
outputChan <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources (TChan ProgramOutput)
crSubprocessLog)
                            AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
Preempt forall a b. (a -> b) -> a -> b
$ do
                                TChan ProgramOutput
-> String
-> [String]
-> Maybe ByteString
-> Maybe (MVar ProgramOutput)
-> IO ()
runLoggedCommand TChan ProgramOutput
outputChan String
cmd
                                                 ([String]
args forall a. Semigroup a => a -> a -> a
<> [String
target])
                                                 forall a. Maybe a
Nothing forall a. Maybe a
Nothing
                                forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                        Bool
True -> do
                            -- If there isn't a new message cutoff
                            -- showing in the current channel, set one.
                            -- This way, while the user is gone using
                            -- their interactive URL opener, when they
                            -- return, any messages that arrive in the
                            -- current channel will be displayed as new.
                            (TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId -> do
                                TeamId -> (ChannelId -> ClientChannel -> MH ()) -> MH ()
withCurrentChannel TeamId
tId forall a b. (a -> b) -> a -> b
$ \ChannelId
cId ClientChannel
curChan -> do
                                    let msgs :: Messages
msgs = ClientChannel
curChanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessages
                                    case (Message -> Bool) -> Messages -> Maybe Message
findLatestUserMessage Message -> Bool
isEditable Messages
msgs of
                                        Maybe Message
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                        Just Message
m ->
                                            case Message
mforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe Post)
mOriginalPost of
                                                Maybe Post
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                                Just Post
p ->
                                                    case ClientChannel
curChanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo NewMessageIndicator
cdNewMessageIndicator of
                                                        NewMessageIndicator
Hide -> ChannelId -> Traversal' ChatState ClientChannel
csChannel(ChannelId
cId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo NewMessageIndicator
cdNewMessageIndicator forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= (ServerTime -> NewMessageIndicator
NewPostsAfterServerTime (Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post ServerTime
postCreateAtL))
                                                        NewMessageIndicator
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

                            -- No need to add a gap here: the websocket
                            -- disconnect/reconnect events will automatically
                            -- handle management of messages delivered while
                            -- suspended.
                            (ChatState -> IO ChatState) -> MH ()
mhSuspendAndResume forall a b. (a -> b) -> a -> b
$ \ChatState
st -> do
                                Either String ExitCode
result <- String -> [String] -> IO (Either String ExitCode)
runInteractiveCommand String
cmd ([String]
args forall a. Semigroup a => a -> a -> a
<> [String
target])

                                let waitForKeypress :: IO ()
waitForKeypress = do
                                        String -> IO ()
putStrLn String
"Press any key to return to Matterhorn."
                                        forall (f :: * -> *) a. Functor f => f a -> f ()
void IO Char
getChar

                                case Either String ExitCode
result of
                                    Right ExitCode
ExitSuccess -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                    Left String
err -> do
                                        String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"URL opener subprocess " forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> String
show Text
urlOpenCommand) forall a. Semigroup a => a -> a -> a
<>
                                                   String
" could not be run: " forall a. Semigroup a => a -> a -> a
<> String
err
                                        IO ()
waitForKeypress
                                    Right (ExitFailure Int
code) -> do
                                        String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"URL opener subprocess " forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> String
show Text
urlOpenCommand) forall a. Semigroup a => a -> a -> a
<>
                                                   String
" exited with non-zero status " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
code
                                        IO ()
waitForKeypress

                                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case ChatState
stforall s a. s -> Getting a s a -> a
^.SimpleGetter ChatState (Maybe TeamId)
csCurrentTeamId of
                                    Maybe TeamId
Nothing -> ChatState
st
                                    Just TeamId
tId -> TeamId -> Mode -> ChatState -> ChatState
pushMode' TeamId
tId Mode
Main ChatState
st

runInteractiveCommand :: String
                      -> [String]
                      -> IO (Either String ExitCode)
runInteractiveCommand :: String -> [String] -> IO (Either String ExitCode)
runInteractiveCommand String
cmd [String]
args = do
    let opener :: CreateProcess
opener = (String -> [String] -> CreateProcess
proc String
cmd [String]
args) { std_in :: StdStream
std_in = StdStream
Inherit
                                 , std_out :: StdStream
std_out = StdStream
Inherit
                                 , std_err :: StdStream
std_err = StdStream
Inherit
                                 }
    Either
  SomeException
  (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
result <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
opener
    case Either
  SomeException
  (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
result of
        Left (SomeException
e::SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
e
        Right (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
ph) -> do
            ExitCode
ec <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ExitCode
ec

runLoggedCommand :: STM.TChan ProgramOutput
                 -- ^ The output channel to send the output to
                 -> String
                 -- ^ The program name
                 -> [String]
                 -- ^ Arguments
                 -> Maybe BSL.ByteString
                 -- ^ The stdin to send, if any
                 -> Maybe (MVar ProgramOutput)
                 -- ^ Where to put the program output when it is ready
                 -> IO ()
runLoggedCommand :: TChan ProgramOutput
-> String
-> [String]
-> Maybe ByteString
-> Maybe (MVar ProgramOutput)
-> IO ()
runLoggedCommand TChan ProgramOutput
outputChan String
cmd [String]
args Maybe ByteString
mInput Maybe (MVar ProgramOutput)
mOutputVar = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
    let stdIn :: StdStream
stdIn = forall b a. b -> (a -> b) -> Maybe a -> b
maybe StdStream
NoStream (forall a b. a -> b -> a
const StdStream
CreatePipe) Maybe ByteString
mInput
        opener :: CreateProcess
opener = (String -> [String] -> CreateProcess
proc String
cmd [String]
args) { std_in :: StdStream
std_in = StdStream
stdIn
                                 , std_out :: StdStream
std_out = StdStream
CreatePipe
                                 , std_err :: StdStream
std_err = StdStream
CreatePipe
                                 }
    Either
  SomeException
  (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
result <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
opener
    case Either
  SomeException
  (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
result of
        Left (SomeException
e::SomeException) -> do
            let po :: ProgramOutput
po = String -> [String] -> String -> String -> ExitCode -> ProgramOutput
ProgramOutput String
cmd [String]
args String
"" (forall a. Show a => a -> String
show SomeException
e) (Int -> ExitCode
ExitFailure Int
1)
            forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
STM.writeTChan TChan ProgramOutput
outputChan ProgramOutput
po
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. MVar a -> a -> IO ()
putMVar ProgramOutput
po) Maybe (MVar ProgramOutput)
mOutputVar
        Right (Maybe Handle
stdinResult, Just Handle
outh, Just Handle
errh, ProcessHandle
ph) -> do
            case Maybe Handle
stdinResult of
                Just Handle
inh -> do
                    case Maybe ByteString
mInput of
                        Just ByteString
input -> do
                            Handle -> ByteString -> IO ()
BSL.hPut Handle
inh ByteString
input
                            Handle -> IO ()
hFlush Handle
inh
                        Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Maybe Handle
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

            ExitCode
ec <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
            String
outResult <- Handle -> IO String
hGetContents Handle
outh
            String
errResult <- Handle -> IO String
hGetContents Handle
errh
            let po :: ProgramOutput
po = String -> [String] -> String -> String -> ExitCode -> ProgramOutput
ProgramOutput String
cmd [String]
args String
outResult String
errResult ExitCode
ec
            forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
STM.writeTChan TChan ProgramOutput
outputChan ProgramOutput
po
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. MVar a -> a -> IO ()
putMVar ProgramOutput
po) Maybe (MVar ProgramOutput)
mOutputVar
        Right (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
_ ->
            forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"BUG: createProcess returned unexpected result, report this at " forall a. Semigroup a => a -> a -> a
<>
                    String
"https://github.com/matterhorn-chat/matterhorn"

-- | Given a file ID and server session, fetch the file into a temporary
-- location and return its path. The caller is responsible for deleting
-- the file.
fetchFile :: FileId -> Session -> IO String
fetchFile :: FileId -> Session -> IO String
fetchFile FileId
fId Session
sess = do
    -- The link is for an attachment, so fetch it and then
    -- open the local copy.
    FileInfo
info <- FileId -> Session -> IO FileInfo
mmGetMetadataForFile FileId
fId Session
sess
    String
cacheDir <- String -> IO String
getUserCacheDir String
xdgName
    let dir :: String
dir = String
cacheDir String -> String -> String
</> String
"files" String -> String -> String
</> Text -> String
T.unpack (forall x. IsId x => x -> Text
idString FileId
fId)
        filename :: String
filename = Text -> String
T.unpack (FileInfo -> Text
fileInfoName FileInfo
info)
        fullPath :: String
fullPath = String
dir String -> String -> String
</> String
filename

    FileId -> Session -> String -> IO ()
fetchFileAtPath FileId
fId Session
sess String
fullPath
    forall (m :: * -> *) a. Monad m => a -> m a
return String
fullPath

-- | Given a file ID and server session, fetch the file and save it to
-- the specified destination path. The destination path must refer to
-- the path to the file itself, not its parent directory. This function
-- will create only the parent directory in the specified path; it will
-- not create all path entries recursively. If the file already exists,
-- this function will overwrite the file.
--
-- The caller is responsible for catching all exceptions.
fetchFileAtPath :: FileId -> Session -> FilePath -> IO ()
fetchFileAtPath :: FileId -> Session -> String -> IO ()
fetchFileAtPath FileId
fId Session
sess String
fullPath = do
    ByteString
contents <- FileId -> Session -> IO ByteString
mmGetFile FileId
fId Session
sess
    let dir :: String
dir = String -> String
takeDirectory String
fullPath
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dir
    String -> ByteString -> IO ()
BS.writeFile String
fullPath ByteString
contents

removeEmoteFormatting :: T.Text -> T.Text
removeEmoteFormatting :: Text -> Text
removeEmoteFormatting Text
t
    | Text
"*" Text -> Text -> Bool
`T.isPrefixOf` Text
t Bool -> Bool -> Bool
&&
      Text
"*" Text -> Text -> Bool
`T.isSuffixOf` Text
t = Text -> Text
T.init forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
1 Text
t
    | Bool
otherwise = Text
t

addEmoteFormatting :: T.Text -> T.Text
addEmoteFormatting :: Text -> Text
addEmoteFormatting Text
t = Text
"*" forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
"*"

fetchMentionedUsers :: Set.Set MentionedUser -> MH ()
fetchMentionedUsers :: Set MentionedUser -> MH ()
fetchMentionedUsers Set MentionedUser
ms
    | forall a. Set a -> Bool
Set.null Set MentionedUser
ms = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise = do
        let convertMention :: MentionedUser -> UserFetch
convertMention (UsernameMention Text
u) = Text -> UserFetch
UserFetchByUsername Text
u
            convertMention (UserIdMention UserId
i) = UserId -> UserFetch
UserFetchById UserId
i
        [UserFetch] -> MH ()
scheduleUserFetches forall a b. (a -> b) -> a -> b
$ MentionedUser -> UserFetch
convertMention forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList Set MentionedUser
ms

doPendingUserStatusFetches :: MH ()
doPendingUserStatusFetches :: MH ()
doPendingUserStatusFetches = do
    Maybe [UserId]
mz <- MH (Maybe [UserId])
getScheduledUserStatusFetches
    case Maybe [UserId]
mz of
        Maybe [UserId]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just [UserId]
z -> do
            TChan [UserId]
statusChan <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources (TChan [UserId])
crStatusUpdateChan)
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
STM.writeTChan TChan [UserId]
statusChan [UserId]
z

doPendingUserFetches :: MH ()
doPendingUserFetches :: MH ()
doPendingUserFetches = do
    [UserFetch]
fs <- MH [UserFetch]
getScheduledUserFetches

    let getUsername :: UserFetch -> Maybe Text
getUsername (UserFetchByUsername Text
u) = forall a. a -> Maybe a
Just Text
u
        getUsername UserFetch
_ = forall a. Maybe a
Nothing

        getUserId :: UserFetch -> Maybe UserId
getUserId (UserFetchById UserId
i) = forall a. a -> Maybe a
Just UserId
i
        getUserId UserFetch
_ = forall a. Maybe a
Nothing

    [Text] -> [UserId] -> MH ()
fetchUsers (forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ UserFetch -> Maybe Text
getUsername forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UserFetch]
fs) (forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ UserFetch -> Maybe UserId
getUserId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UserFetch]
fs)

-- | Given a list of usernames, ensure that we have a user record for
-- each one in the state, either by confirming that a local record
-- exists or by issuing a request for user records.
fetchUsers :: [Text] -> [UserId] -> MH ()
fetchUsers :: [Text] -> [UserId] -> MH ()
fetchUsers [Text]
rawUsernames [UserId]
uids = do
    ChatState
st <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall a. a -> a
id
    Session
session <- MH Session
getSession
    let usernames :: [Text]
usernames = Text -> Text
trimUserSigil forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
rawUsernames
        missingUsernames :: [Text]
missingUsernames = forall a. (a -> Bool) -> [a] -> [a]
filter Text -> Bool
isMissing [Text]
usernames
        isMissing :: Text -> Bool
isMissing Text
n = forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
n
                          , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Bool
isSpecialMention Text
n
                          , forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ Text -> ChatState -> Maybe UserInfo
userByUsername Text
n ChatState
st
                          ]
        missingIds :: [UserId]
missingIds = forall a. (a -> Bool) -> [a] -> [a]
filter (\UserId
i -> forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ UserId -> ChatState -> Maybe UserInfo
userById UserId
i ChatState
st) [UserId]
uids

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
missingUsernames) forall a b. (a -> b) -> a -> b
$ do
        LogCategory -> Text -> MH ()
mhLog LogCategory
LogGeneral forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"fetchUsers: getting " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [Text]
missingUsernames

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UserId]
missingIds) forall a b. (a -> b) -> a -> b
$ do
        LogCategory -> Text -> MH ()
mhLog LogCategory
LogGeneral forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"fetchUsers: getting " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [UserId]
missingIds

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
missingUsernames) Bool -> Bool -> Bool
|| (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UserId]
missingIds)) forall a b. (a -> b) -> a -> b
$ do
        AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
Normal forall a b. (a -> b) -> a -> b
$ do
            MH ()
act1 <- case forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
missingUsernames of
                Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Bool
False -> do
                    Seq User
results <- Seq Text -> Session -> IO (Seq User)
mmGetUsersByUsernames (forall a. [a] -> Seq a
Seq.fromList [Text]
missingUsernames) Session
session
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
                        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Seq User
results (\User
u -> UserInfo -> MH ()
addNewUser forall a b. (a -> b) -> a -> b
$ User -> Bool -> UserInfo
userInfoFromUser User
u Bool
True)

            MH ()
act2 <- case forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UserId]
missingIds of
                Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Bool
False -> do
                    Seq User
results <- Seq UserId -> Session -> IO (Seq User)
mmGetUsersByIds (forall a. [a] -> Seq a
Seq.fromList [UserId]
missingIds) Session
session
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
                        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Seq User
results (\User
u -> UserInfo -> MH ()
addNewUser forall a b. (a -> b) -> a -> b
$ User -> Bool -> UserInfo
userInfoFromUser User
u Bool
True)

            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ MH ()
act1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MH ()
act2

invalidateChannelRenderingCache :: ChannelId -> MH ()
invalidateChannelRenderingCache :: ChannelId -> MH ()
invalidateChannelRenderingCache ChannelId
cId = do
    forall a. EventM Name ChatState a -> MH a
mh forall a b. (a -> b) -> a -> b
$ forall n s. Ord n => n -> EventM n s ()
invalidateCacheEntry forall a b. (a -> b) -> a -> b
$ Name -> Name
MessageInterfaceMessages forall a b. (a -> b) -> a -> b
$ ChannelId -> Name
MessageInput ChannelId
cId
    forall a. EventM Name ChatState a -> MH a
mh forall a b. (a -> b) -> a -> b
$ forall n s. Ord n => n -> EventM n s ()
invalidateCacheEntry forall a b. (a -> b) -> a -> b
$ Name -> Name
MessageInterfaceMessages forall a b. (a -> b) -> a -> b
$ ChannelId -> Name
ThreadMessageInput ChannelId
cId

invalidateMessageRenderingCacheByPostId :: PostId -> MH ()
invalidateMessageRenderingCacheByPostId :: PostId -> MH ()
invalidateMessageRenderingCacheByPostId PostId
pId = do
    forall a. EventM Name ChatState a -> MH a
mh forall a b. (a -> b) -> a -> b
$ forall n s. Ord n => n -> EventM n s ()
invalidateCacheEntry forall a b. (a -> b) -> a -> b
$ MessageId -> Name
RenderedMessage forall a b. (a -> b) -> a -> b
$ PostId -> MessageId
MessagePostId PostId
pId

setThreadOrientationByName :: T.Text -> MH ()
setThreadOrientationByName :: Text -> MH ()
setThreadOrientationByName Text
o = do
    let o' :: Text
o' = Text -> Text
T.strip forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower Text
o
    Maybe ThreadOrientation
new <- case Text
o' of
        Text
"above" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ThreadOrientation
ThreadAbove
        Text
"below" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ThreadOrientation
ThreadBelow
        Text
"left"  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ThreadOrientation
ThreadLeft
        Text
"right" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ThreadOrientation
ThreadRight
        Text
_ -> do
            Text -> MH ()
postErrorMessage' forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"Invalid orientation: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Text
o
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

    case Maybe ThreadOrientation
new of
        Maybe ThreadOrientation
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just ThreadOrientation
n -> do
            Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources Config
crConfigurationforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Config ThreadOrientation
configThreadOrientationL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ThreadOrientation
n
            Text -> MH ()
postInfoMessage forall a b. (a -> b) -> a -> b
$ Text
"Thread orientation set to " forall a. Semigroup a => a -> a -> a
<> Text
o'
            forall a. EventM Name ChatState a -> MH a
mh forall n s. Ord n => EventM n s ()
invalidateCache

toggleMouseMode :: MH ()
toggleMouseMode :: MH ()
toggleMouseMode = do
    Vty
vty <- forall a. EventM Name ChatState a -> MH a
mh forall n s. EventM n s Vty
getVtyHandle
    Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources Config
crConfigurationforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Config Bool
configMouseModeL forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Bool -> Bool
not
    Bool
newMode <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources Config
crConfigurationforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Config Bool
configMouseModeL)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Output -> Mode -> Bool -> IO ()
Vty.setMode (Vty -> Output
Vty.outputIface Vty
vty) Mode
Vty.Mouse Bool
newMode
    Text -> MH ()
postInfoMessage forall a b. (a -> b) -> a -> b
$ if Bool
newMode
                      then Text
"Mouse input is now enabled."
                      else Text
"Mouse input is now disabled."