module Matterhorn.State.Common
(
openFilePath
, openWithOpener
, runLoggedCommand
, fetchFile
, fetchFileAtPath
, installMessagesFromPosts
, updatePostMap
, postInfoMessage
, postErrorMessageIO
, postErrorMessage'
, addEmoteFormatting
, removeEmoteFormatting
, toggleMouseMode
, fetchMentionedUsers
, doPendingUserFetches
, doPendingUserStatusFetches
, setThreadOrientationByName
, 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
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)
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)
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
updatePostMap :: Maybe TeamId -> Posts -> MH ()
updatePostMap :: Maybe TeamId -> Posts -> MH ()
updatePostMap Maybe TeamId
mTId Posts
postCollection = do
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
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
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)
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
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
(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 ()
(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
-> String
-> [String]
-> Maybe BSL.ByteString
-> Maybe (MVar ProgramOutput)
-> 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"
fetchFile :: FileId -> Session -> IO String
fetchFile :: FileId -> Session -> IO String
fetchFile FileId
fId Session
sess = do
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
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)
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."