blade/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2024-12-17 17:20:21 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

core: http transport for remote session (#3178)

Browse Source 
* Wire some of the session endpoints

* Start sending remote commands

* Expand remote controller

- Fix queues for pumping to remote
- Add 3-way test
- WIP: Add TTY wrapper for remote hosts
- Stop remote controller w/o ids to match starting

* Fix view events

* Drop notifications, add message test

* refactor, receive test

* hunt down stray asyncs

* Take discovery sockets in brackets

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
Alexander Bondarenko
2023-10-07 16:23:24 +03:00
committed by GitHub
parent 3ac342782b
commit 91561da351
14 changed files with 376 additions and 172 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/View.hs
+12 -10
View File
@@ -66,11 +66,11 @@ import System.Console.ANSI.Types
type CurrentTime = UTCTime
serializeChatResponse :: Maybe User -> CurrentTime -> TimeZone -> ChatResponse -> String
serializeChatResponse user_ ts tz = unlines . map unStyle . responseToView user_ defaultChatConfig False ts tz
serializeChatResponse :: (Maybe RemoteHostId, Maybe User) -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> String
serializeChatResponse user_ ts tz remoteHost_ = unlines . map unStyle . responseToView user_ defaultChatConfig False ts tz remoteHost_
responseToView :: Maybe User -> ChatConfig -> Bool -> CurrentTime -> TimeZone -> ChatResponse -> [StyledString]
responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView} liveItems ts tz = \case
responseToView :: (Maybe RemoteHostId, Maybe User) -> ChatConfig -> Bool -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> [StyledString]
responseToView (currentRH, user_) ChatConfig {logLevel, showReactions, showReceipts, testView} liveItems ts tz outputRH = \case
CRActiveUser User {profile} -> viewUserProfile $ fromLocalProfile profile
CRUsersList users -> viewUsersList users
CRChatStarted _ -> ["chat started"]
@@ -274,7 +274,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
CRRemoteCtrlRejected rcId -> ["remote controller " <> sShow rcId <> " rejected"]
CRRemoteCtrlConnecting rcId rcName -> ["remote controller " <> sShow rcId <> " connecting to " <> plain rcName]
CRRemoteCtrlConnected rcId rcName -> ["remote controller " <> sShow rcId <> " connected, " <> plain rcName]
CRRemoteCtrlStopped rcId -> ["remote controller " <> sShow rcId <> " stopped"]
CRRemoteCtrlStopped _ -> ["remote controller stopped"]
CRRemoteCtrlDeleted rcId -> ["remote controller " <> sShow rcId <> " deleted"]
CRSQLResult rows -> map plain rows
CRSlowSQLQueries {chatQueries, agentQueries} ->
@@ -323,12 +323,14 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
| otherwise = []
ttyUserPrefix :: User -> [StyledString] -> [StyledString]
ttyUserPrefix _ [] = []
ttyUserPrefix User {userId, localDisplayName = u} ss = prependFirst userPrefix ss
ttyUserPrefix User {userId, localDisplayName = u} ss = prependFirst prefix ss
where
userPrefix = case user_ of
Just User {userId = activeUserId} -> if userId /= activeUserId then prefix else ""
_ -> prefix
prefix = "[user: " <> highlight u <> "] "
prefix = if outputRH /= currentRH then r else userPrefix
r = case outputRH of
Nothing -> "[local] " <> userPrefix
Just rh -> "[remote: ]" <> highlight (show rh) <> "] "
userPrefix = if Just userId /= currentUserId then "[user: " <> highlight u <> "] " else ""
currentUserId = fmap (\User {userId} -> userId) user_
ttyUser' :: Maybe User -> [StyledString] -> [StyledString]
ttyUser' = maybe id ttyUser
ttyUserPrefix' :: Maybe User -> [StyledString] -> [StyledString]