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