1module Matterhorn.State.Common
2  (
3  -- * System interface
4    openFilePath
5  , openWithOpener
6  , runLoggedCommand
7  , fetchFile
8  , fetchFileAtPath
9
10  -- * Posts
11  , installMessagesFromPosts
12  , updatePostMap
13
14  -- * Utilities
15  , postInfoMessage
16  , postErrorMessageIO
17  , postErrorMessage'
18  , addEmoteFormatting
19  , removeEmoteFormatting
20
21  , fetchMentionedUsers
22  , doPendingUserFetches
23  , doPendingUserStatusFetches
24
25  , module Matterhorn.State.Async
26  )
27where
28
29import           Prelude ()
30import           Matterhorn.Prelude
31
32import           Brick.Main ( invalidateCacheEntry )
33import           Control.Concurrent ( MVar, putMVar, forkIO )
34import qualified Control.Concurrent.STM as STM
35import           Control.Exception ( SomeException, try )
36import qualified Data.ByteString as BS
37import qualified Data.HashMap.Strict as HM
38import qualified Data.Sequence as Seq
39import qualified Data.Set as Set
40import qualified Data.Text as T
41import           Lens.Micro.Platform ( (.=), (%=), (%~), (.~) )
42import           System.Directory ( createDirectoryIfMissing )
43import           System.Environment.XDG.BaseDir ( getUserCacheDir )
44import           System.Exit ( ExitCode(..) )
45import           System.FilePath
46import           System.IO ( hGetContents, hFlush, hPutStrLn )
47import           System.Process ( proc, std_in, std_out, std_err, StdStream(..)
48                                , createProcess, waitForProcess )
49
50import           Network.Mattermost.Endpoints
51import           Network.Mattermost.Lenses
52import           Network.Mattermost.Types
53
54import           Matterhorn.FilePaths ( xdgName )
55import           Matterhorn.State.Async
56import           Matterhorn.Types
57import           Matterhorn.Types.Common
58
59
60-- * Client Messages
61
62-- | Given a collection of posts from the server, save the posts in the
63-- global post map. Also convert the posts to Matterhorn's Message type
64-- and return them along with the set of all usernames mentioned in the
65-- text of the resulting messages.
66--
67-- This also sets the mFlagged field of each message based on whether
68-- its post ID is a flagged post according to crFlaggedPosts at the time
69-- of this call.
70installMessagesFromPosts :: Maybe TeamId -> Posts -> MH Messages
71installMessagesFromPosts mTId postCollection = do
72  flags <- use (csResources.crFlaggedPosts)
73
74  -- Add all posts in this collection to the global post cache
75  updatePostMap mTId postCollection
76
77  mBaseUrl <- case mTId of
78      Nothing -> return Nothing
79      Just tId -> Just <$> getServerBaseUrl tId
80
81  -- Build the ordered list of posts. Note that postsOrder lists the
82  -- posts most recent first, but we want most recent last.
83  let postsInOrder = findPost <$> (Seq.reverse $ postsOrder postCollection)
84      mkClientPost p = toClientPost mBaseUrl p (postId <$> parent p)
85      clientPosts = mkClientPost <$> postsInOrder
86
87      addNext cp (msgs, us) =
88          let (msg, mUsernames) = clientPostToMessage cp
89          in (addMessage (maybeFlag flags msg) msgs, Set.union us mUsernames)
90      (ms, mentions) = foldr addNext (noMessages, mempty) clientPosts
91
92  fetchMentionedUsers mentions
93  return ms
94    where
95        maybeFlag flagSet msg
96          | Just (MessagePostId pId) <- msg^.mMessageId, pId `Set.member` flagSet
97            = msg & mFlagged .~ True
98          | otherwise = msg
99        parent x = do
100            parentId <- x^.postRootIdL
101            HM.lookup parentId (postCollection^.postsPostsL)
102        findPost pId = case HM.lookup pId (postsPosts postCollection) of
103            Nothing -> error $ "BUG: could not find post for post ID " <> show pId
104            Just post -> post
105
106-- Add all posts in this collection to the global post cache
107updatePostMap :: Maybe TeamId -> Posts -> MH ()
108updatePostMap mTId postCollection = do
109  -- Build a map from post ID to Matterhorn message, then add the new
110  -- messages to the global post map. We use the "postsPosts" field for
111  -- this because that might contain more messages than the "postsOrder"
112  -- list, since the former can contain other messages in threads that
113  -- the server sent us, even if those messages are not part of the
114  -- ordered post listing of "postsOrder."
115  mBaseUrl <- case mTId of
116      Nothing -> return Nothing
117      Just tId -> Just <$> getServerBaseUrl tId
118
119  let postMap = HM.fromList
120          [ ( pId
121            , fst $ clientPostToMessage (toClientPost mBaseUrl x Nothing)
122            )
123          | (pId, x) <- HM.toList (postCollection^.postsPostsL)
124          ]
125  csPostMap %= HM.union postMap
126
127-- | Add a 'ClientMessage' to the current channel's message list
128addClientMessage :: ClientMessage -> MH ()
129addClientMessage msg = do
130  tId <- use csCurrentTeamId
131  cid <- use (csCurrentChannelId(tId))
132  uuid <- generateUUID
133  let addCMsg = ccContents.cdMessages %~
134          (addMessage $ clientMessageToMessage msg & mMessageId .~ Just (MessageUUID uuid))
135  csChannels %= modifyChannelById cid addCMsg
136
137  mh $ invalidateCacheEntry $ ChannelMessages cid
138  mh $ invalidateCacheEntry $ ChannelSidebar tId
139
140  let msgTy = case msg^.cmType of
141        Error -> LogError
142        _     -> LogGeneral
143
144  mhLog msgTy $ T.pack $ show msg
145
146-- | Add a new 'ClientMessage' representing an error message to
147--   the current channel's message list
148postInfoMessage :: Text -> MH ()
149postInfoMessage info =
150    addClientMessage =<< newClientMessage Informative (sanitizeUserText' info)
151
152-- | Add a new 'ClientMessage' representing an error message to
153--   the current channel's message list
154postErrorMessage' :: Text -> MH ()
155postErrorMessage' err =
156    addClientMessage =<< newClientMessage Error (sanitizeUserText' err)
157
158postErrorMessageIO :: Text -> ChatState -> IO ChatState
159postErrorMessageIO err st = do
160  msg <- newClientMessage Error err
161  uuid <- generateUUID_IO
162  let cId = st ^. csCurrentChannelId (st^.csCurrentTeamId)
163      addEMsg = ccContents.cdMessages %~
164          (addMessage $ clientMessageToMessage msg & mMessageId .~ Just (MessageUUID uuid))
165  return $ st & csChannels %~ modifyChannelById cId addEMsg
166
167openFilePath :: FilePath -> MH Bool
168openFilePath path = openWithOpener (return path)
169
170openWithOpener :: MH String -> MH Bool
171openWithOpener getTarget = do
172    cfg <- use (csResources.crConfiguration)
173    case configURLOpenCommand cfg of
174        Nothing ->
175            return False
176        Just urlOpenCommand -> do
177            target <- getTarget
178
179            -- Is the URL-opening command interactive? If so, pause
180            -- Matterhorn and run the opener interactively. Otherwise
181            -- run the opener asynchronously and continue running
182            -- Matterhorn interactively.
183            case configURLOpenCommandInteractive cfg of
184                False -> do
185                    outputChan <- use (csResources.crSubprocessLog)
186                    doAsyncWith Preempt $ do
187                        runLoggedCommand outputChan (T.unpack urlOpenCommand)
188                                         [target] Nothing Nothing
189                        return Nothing
190                True -> do
191                    -- If there isn't a new message cutoff showing in
192                    -- the current channel, set one. This way, while the
193                    -- user is gone using their interactive URL opener,
194                    -- when they return, any messages that arrive in the
195                    -- current channel will be displayed as new.
196                    curChan <- use csCurrentChannel
197                    let msgs = curChan^.ccContents.cdMessages
198                    case findLatestUserMessage isEditable msgs of
199                        Nothing -> return ()
200                        Just m ->
201                            case m^.mOriginalPost of
202                                Nothing -> return ()
203                                Just p ->
204                                    case curChan^.ccInfo.cdNewMessageIndicator of
205                                        Hide ->
206                                            csCurrentChannel.ccInfo.cdNewMessageIndicator .= (NewPostsAfterServerTime (p^.postCreateAtL))
207                                        _ -> return ()
208                    -- No need to add a gap here: the websocket
209                    -- disconnect/reconnect events will automatically
210                    -- handle management of messages delivered while
211                    -- suspended.
212
213                    mhSuspendAndResume $ \st -> do
214                        result <- runInteractiveCommand (T.unpack urlOpenCommand) [target]
215
216                        let waitForKeypress = do
217                                putStrLn "Press any key to return to Matterhorn."
218                                void getChar
219
220                        case result of
221                            Right ExitSuccess -> return ()
222                            Left err -> do
223                                putStrLn $ "URL opener subprocess " <> (show urlOpenCommand) <>
224                                           " could not be run: " <> err
225                                waitForKeypress
226                            Right (ExitFailure code) -> do
227                                putStrLn $ "URL opener subprocess " <> (show urlOpenCommand) <>
228                                           " exited with non-zero status " <> show code
229                                waitForKeypress
230
231                        return $ setMode' Main st
232
233            return True
234
235runInteractiveCommand :: String
236                      -> [String]
237                      -> IO (Either String ExitCode)
238runInteractiveCommand cmd args = do
239    let opener = (proc cmd args) { std_in = Inherit
240                                 , std_out = Inherit
241                                 , std_err = Inherit
242                                 }
243    result <- try $ createProcess opener
244    case result of
245        Left (e::SomeException) -> return $ Left $ show e
246        Right (_, _, _, ph) -> do
247            ec <- waitForProcess ph
248            return $ Right ec
249
250runLoggedCommand :: STM.TChan ProgramOutput
251                 -- ^ The output channel to send the output to
252                 -> String
253                 -- ^ The program name
254                 -> [String]
255                 -- ^ Arguments
256                 -> Maybe String
257                 -- ^ The stdin to send, if any
258                 -> Maybe (MVar ProgramOutput)
259                 -- ^ Where to put the program output when it is ready
260                 -> IO ()
261runLoggedCommand outputChan cmd args mInput mOutputVar = void $ forkIO $ do
262    let stdIn = maybe NoStream (const CreatePipe) mInput
263        opener = (proc cmd args) { std_in = stdIn
264                                 , std_out = CreatePipe
265                                 , std_err = CreatePipe
266                                 }
267    result <- try $ createProcess opener
268    case result of
269        Left (e::SomeException) -> do
270            let po = ProgramOutput cmd args "" (show e) (ExitFailure 1)
271            STM.atomically $ STM.writeTChan outputChan po
272            maybe (return ()) (flip putMVar po) mOutputVar
273        Right (stdinResult, Just outh, Just errh, ph) -> do
274            case stdinResult of
275                Just inh -> do
276                    let Just input = mInput
277                    hPutStrLn inh input
278                    hFlush inh
279                Nothing -> return ()
280
281            ec <- waitForProcess ph
282            outResult <- hGetContents outh
283            errResult <- hGetContents errh
284            let po = ProgramOutput cmd args outResult errResult ec
285            STM.atomically $ STM.writeTChan outputChan po
286            maybe (return ()) (flip putMVar po) mOutputVar
287        Right _ ->
288            error $ "BUG: createProcess returned unexpected result, report this at " <>
289                    "https://github.com/matterhorn-chat/matterhorn"
290
291-- | Given a file ID and server session, fetch the file into a temporary
292-- location and return its path. The caller is responsible for deleting
293-- the file.
294fetchFile :: FileId -> Session -> IO String
295fetchFile fId sess = do
296    -- The link is for an attachment, so fetch it and then
297    -- open the local copy.
298    info <- mmGetMetadataForFile fId sess
299    cacheDir <- getUserCacheDir xdgName
300    let dir = cacheDir </> "files" </> T.unpack (idString fId)
301        filename = T.unpack (fileInfoName info)
302        fullPath = dir </> filename
303
304    fetchFileAtPath fId sess fullPath
305    return fullPath
306
307-- | Given a file ID and server session, fetch the file and save it to
308-- the specified destination path. The destination path must refer to
309-- the path to the file itself, not its parent directory. This function
310-- will create only the parent directory in the specified path; it will
311-- not create all path entries recursively. If the file already exists,
312-- this function will overwrite the file.
313--
314-- The caller is responsible for catching all exceptions.
315fetchFileAtPath :: FileId -> Session -> FilePath -> IO ()
316fetchFileAtPath fId sess fullPath = do
317    contents <- mmGetFile fId sess
318    let dir = takeDirectory fullPath
319    createDirectoryIfMissing False dir
320    BS.writeFile fullPath contents
321
322removeEmoteFormatting :: T.Text -> T.Text
323removeEmoteFormatting t
324    | "*" `T.isPrefixOf` t &&
325      "*" `T.isSuffixOf` t = T.init $ T.drop 1 t
326    | otherwise = t
327
328addEmoteFormatting :: T.Text -> T.Text
329addEmoteFormatting t = "*" <> t <> "*"
330
331fetchMentionedUsers :: Set.Set MentionedUser -> MH ()
332fetchMentionedUsers ms
333    | Set.null ms = return ()
334    | otherwise = do
335        let convertMention (UsernameMention u) = UserFetchByUsername u
336            convertMention (UserIdMention i) = UserFetchById i
337        scheduleUserFetches $ convertMention <$> Set.toList ms
338
339doPendingUserStatusFetches :: MH ()
340doPendingUserStatusFetches = do
341    mz <- getScheduledUserStatusFetches
342    case mz of
343        Nothing -> return ()
344        Just z -> do
345            statusChan <- use (csResources.crStatusUpdateChan)
346            liftIO $ STM.atomically $ STM.writeTChan statusChan z
347
348doPendingUserFetches :: MH ()
349doPendingUserFetches = do
350    fs <- getScheduledUserFetches
351
352    let getUsername (UserFetchByUsername u) = Just u
353        getUsername _ = Nothing
354
355        getUserId (UserFetchById i) = Just i
356        getUserId _ = Nothing
357
358    fetchUsers (catMaybes $ getUsername <$> fs) (catMaybes $ getUserId <$> fs)
359
360-- | Given a list of usernames, ensure that we have a user record for
361-- each one in the state, either by confirming that a local record
362-- exists or by issuing a request for user records.
363fetchUsers :: [Text] -> [UserId] -> MH ()
364fetchUsers rawUsernames uids = do
365    st <- use id
366    session <- getSession
367    let usernames = trimUserSigil <$> rawUsernames
368        missingUsernames = filter isMissing usernames
369        isMissing n = and [ not $ T.null n
370                          , not $ isSpecialMention n
371                          , isNothing $ userByUsername n st
372                          ]
373        missingIds = filter (\i -> isNothing $ userById i st) uids
374
375    when (not $ null missingUsernames) $ do
376        mhLog LogGeneral $ T.pack $ "fetchUsers: getting " <> show missingUsernames
377
378    when (not $ null missingIds) $ do
379        mhLog LogGeneral $ T.pack $ "fetchUsers: getting " <> show missingIds
380
381    when ((not $ null missingUsernames) || (not $ null missingIds)) $ do
382        doAsyncWith Normal $ do
383            act1 <- case null missingUsernames of
384                True -> return $ return ()
385                False -> do
386                    results <- mmGetUsersByUsernames (Seq.fromList missingUsernames) session
387                    return $ do
388                        forM_ results (\u -> addNewUser $ userInfoFromUser u True)
389
390            act2 <- case null missingIds of
391                True -> return $ return ()
392                False -> do
393                    results <- mmGetUsersByIds (Seq.fromList missingIds) session
394                    return $ do
395                        forM_ results (\u -> addNewUser $ userInfoFromUser u True)
396
397            return $ Just $ act1 >> act2
398