From 91561da351c19ce621f0723620519999f162f6b3 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Sat, 7 Oct 2023 16:23:24 +0300 Subject: [PATCH] core: http transport for remote session (#3178) * 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> --- apps/simplex-chat/Main.hs | 7 +- .../src/Directory/Service.hs | 2 +- src/Simplex/Chat.hs | 17 +- src/Simplex/Chat/Controller.hs | 95 +++++++- src/Simplex/Chat/Messages.hs | 4 +- src/Simplex/Chat/Remote.hs | 219 ++++++++++++------ src/Simplex/Chat/Remote/Discovery.hs | 26 ++- src/Simplex/Chat/Remote/Types.hs | 24 -- src/Simplex/Chat/Terminal/Input.hs | 10 +- src/Simplex/Chat/Terminal/Output.hs | 18 +- src/Simplex/Chat/Types.hs | 1 + src/Simplex/Chat/View.hs | 22 +- tests/ChatTests/Utils.hs | 3 + tests/RemoteTests.hs | 100 ++++++-- 14 files changed, 376 insertions(+), 172 deletions(-) diff --git a/apps/simplex-chat/Main.hs b/apps/simplex-chat/Main.hs index 8dd02623e..c2ad7e7eb 100644 --- a/apps/simplex-chat/Main.hs +++ b/apps/simplex-chat/Main.hs @@ -3,10 +3,11 @@ module Main where import Control.Concurrent (threadDelay) +import Control.Concurrent.STM.TVar (readTVarIO) import Data.Time.Clock (getCurrentTime) import Data.Time.LocalTime (getCurrentTimeZone) import Server -import Simplex.Chat.Controller (versionNumber, versionString) +import Simplex.Chat.Controller (currentRemoteHost, versionNumber, versionString) import Simplex.Chat.Core import Simplex.Chat.Options import Simplex.Chat.Terminal @@ -28,10 +29,12 @@ main = do t <- withTerminal pure simplexChatTerminal terminalChatConfig opts t else simplexChatCore terminalChatConfig opts Nothing $ \user cc -> do + rh <- readTVarIO $ currentRemoteHost cc + let cmdRH = rh -- response RemoteHost is the same as for the command itself r <- sendChatCmdStr cc chatCmd ts <- getCurrentTime tz <- getCurrentTimeZone - putStrLn $ serializeChatResponse (Just user) ts tz r + putStrLn $ serializeChatResponse (rh, Just user) ts tz cmdRH r threadDelay $ chatCmdDelay opts * 1000000 welcome :: ChatOpts -> IO () diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 7ed39847a..a30638249 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -494,7 +494,7 @@ directoryService st DirectoryOpts {superUsers, serviceName, testing} user@User { sendChatCmdStr cc cmdStr >>= \r -> do ts <- getCurrentTime tz <- getCurrentTimeZone - sendReply $ serializeChatResponse (Just user) ts tz r + sendReply $ serializeChatResponse (Nothing, Just user) ts tz Nothing r DCCommandError tag -> sendReply $ "Command error: " <> show tag | otherwise = sendReply "You are not allowed to use this command" where diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index bcd23f44e..dc06d082b 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -193,6 +193,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen firstTime = dbNew chatStore activeTo <- newTVarIO ActiveNone currentUser <- newTVarIO user + currentRemoteHost <- newTVarIO Nothing servers <- agentServers config smpAgent <- getSMPAgentClient aCfg {tbqSize} servers agentStore agentAsync <- newTVarIO Nothing @@ -216,7 +217,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen showLiveItems <- newTVarIO False userXFTPFileConfig <- newTVarIO $ xftpFileConfig cfg tempDirectory <- newTVarIO tempDir - pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, subscriptionMode, chatLock, sndFiles, rcvFiles, currentCalls, remoteHostSessions, remoteCtrlSession, config, sendNotification, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems, userXFTPFileConfig, tempDirectory, logFilePath = logFile} + pure ChatController {activeTo, firstTime, currentUser, currentRemoteHost, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, subscriptionMode, chatLock, sndFiles, rcvFiles, currentCalls, remoteHostSessions, remoteCtrlSession, config, sendNotification, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems, userXFTPFileConfig, tempDirectory, logFilePath = logFile} where configServers :: DefaultAgentServers configServers = @@ -327,7 +328,9 @@ restoreCalls = do atomically $ writeTVar calls callsMap stopChatController :: forall m. MonadUnliftIO m => ChatController -> m () -stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags} = do +stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession} = do + readTVarIO remoteHostSessions >>= mapM_ cancelRemoteHostSession + readTVarIO remoteCtrlSession >>= mapM_ cancelRemoteCtrlSession_ disconnectAgentClient smpAgent readTVarIO s >>= mapM_ (\(a1, a2) -> uninterruptibleCancel a1 >> mapM_ uninterruptibleCancel a2) closeFiles sndFiles @@ -349,8 +352,8 @@ execChatCommand rh s = do case parseChatCommand s of Left e -> pure $ chatCmdError u e Right cmd -> case rh of - Nothing -> execChatCommand_ u cmd - Just remoteHostId -> execRemoteCommand u remoteHostId (s, cmd) + Just remoteHostId | allowRemoteCommand cmd -> execRemoteCommand u remoteHostId (s, cmd) + _ -> execChatCommand_ u cmd execChatCommand' :: ChatMonad' m => ChatCommand -> m ChatResponse execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` cmd) @@ -1843,10 +1846,10 @@ processChatCommand = \case StartRemoteHost rh -> startRemoteHost rh StopRemoteHost rh -> closeRemoteHostSession rh DeleteRemoteHost rh -> deleteRemoteHost rh - StartRemoteCtrl -> startRemoteCtrl + StartRemoteCtrl -> startRemoteCtrl (execChatCommand Nothing) AcceptRemoteCtrl rc -> acceptRemoteCtrl rc RejectRemoteCtrl rc -> rejectRemoteCtrl rc - StopRemoteCtrl rc -> stopRemoteCtrl rc + StopRemoteCtrl -> stopRemoteCtrl RegisterRemoteCtrl oob -> registerRemoteCtrl oob ListRemoteCtrls -> listRemoteCtrls DeleteRemoteCtrl rc -> deleteRemoteCtrl rc @@ -5631,7 +5634,7 @@ chatCommandP = "/list remote ctrls" $> ListRemoteCtrls, "/accept remote ctrl " *> (AcceptRemoteCtrl <$> A.decimal), "/reject remote ctrl " *> (RejectRemoteCtrl <$> A.decimal), - "/stop remote ctrl " *> (StopRemoteCtrl <$> A.decimal), + "/stop remote ctrl" $> StopRemoteCtrl, "/delete remote ctrl " *> (DeleteRemoteCtrl <$> A.decimal), ("/quit" <|> "/q" <|> "/exit") $> QuitChat, ("/version" <|> "/v") $> ShowVersion, diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 986eaf073..dad5138bc 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -72,6 +72,7 @@ import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), Cor import Simplex.Messaging.TMap (TMap) import Simplex.Messaging.Transport (simplexMQVersion) import Simplex.Messaging.Transport.Client (TransportHost) +import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client) import Simplex.Messaging.Util (allFinally, catchAllErrors, liftEitherError, tryAllErrors, (<$$>)) import Simplex.Messaging.Version import System.IO (Handle) @@ -171,6 +172,7 @@ data ChatDatabase = ChatDatabase {chatStore :: SQLiteStore, agentStore :: SQLite data ChatController = ChatController { currentUser :: TVar (Maybe User), + currentRemoteHost :: TVar (Maybe RemoteHostId), activeTo :: TVar ActiveTo, firstTime :: Bool, smpAgent :: AgentClient, @@ -424,6 +426,7 @@ data ChatCommand | CreateRemoteHost -- ^ Configure a new remote host | ListRemoteHosts | StartRemoteHost RemoteHostId -- ^ Start and announce a remote host + -- | SwitchRemoteHost (Maybe RemoteHostId) -- ^ Switch current remote host | StopRemoteHost RemoteHostId -- ^ Shut down a running session | DeleteRemoteHost RemoteHostId -- ^ Unregister remote host and remove its data | RegisterRemoteCtrl RemoteCtrlOOB -- ^ Register OOB data for satellite discovery and handshake @@ -431,7 +434,7 @@ data ChatCommand | ListRemoteCtrls | AcceptRemoteCtrl RemoteCtrlId -- ^ Accept discovered data and store confirmation | RejectRemoteCtrl RemoteCtrlId -- ^ Reject and blacklist discovered data - | StopRemoteCtrl RemoteCtrlId -- ^ Stop listening for announcements or terminate an active session + | StopRemoteCtrl -- ^ Stop listening for announcements or terminate an active session | DeleteRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a satellite session | QuitChat | ShowVersion @@ -442,6 +445,29 @@ data ChatCommand | GetAgentSubsDetails deriving (Show) +allowRemoteCommand :: ChatCommand -> Bool -- XXX: consider using Relay/Block/ForceLocal +allowRemoteCommand = \case + StartChat {} -> False + APIStopChat -> False + APIActivateChat -> False + APISuspendChat {} -> False + SetTempFolder {} -> False + QuitChat -> False + CreateRemoteHost -> False + ListRemoteHosts -> False + StartRemoteHost {} -> False + -- SwitchRemoteHost {} -> False + StopRemoteHost {} -> False + DeleteRemoteHost {} -> False + RegisterRemoteCtrl {} -> False + StartRemoteCtrl -> False + ListRemoteCtrls -> False + AcceptRemoteCtrl {} -> False + RejectRemoteCtrl {} -> False + StopRemoteCtrl -> False + DeleteRemoteCtrl {} -> False + _ -> True + data ChatResponse = CRActiveUser {user :: User} | CRUsersList {users :: [UserInfo]} @@ -619,7 +645,7 @@ data ChatResponse | CRRemoteCtrlRejected {remoteCtrlId :: RemoteCtrlId} | CRRemoteCtrlConnecting {remoteCtrlId :: RemoteCtrlId, displayName :: Text} | CRRemoteCtrlConnected {remoteCtrlId :: RemoteCtrlId, displayName :: Text} - | CRRemoteCtrlStopped {remoteCtrlId :: RemoteCtrlId} + | CRRemoteCtrlStopped {_nullary :: Maybe Int} | CRRemoteCtrlDeleted {remoteCtrlId :: RemoteCtrlId} | CRSQLResult {rows :: [Text]} | CRSlowSQLQueries {chatQueries :: [SlowSQLQuery], agentQueries :: [SlowSQLQuery]} @@ -638,6 +664,27 @@ data ChatResponse | CRTimedAction {action :: String, durationMilliseconds :: Int64} deriving (Show) +allowRemoteEvent :: ChatResponse -> Bool +allowRemoteEvent = \case + CRRemoteHostCreated {} -> False + CRRemoteHostList {} -> False + CRRemoteHostStarted {} -> False + CRRemoteHostConnected {} -> False + CRRemoteHostStopped {} -> False + CRRemoteHostDeleted {} -> False + CRRemoteCtrlList {} -> False + CRRemoteCtrlRegistered {} -> False + CRRemoteCtrlStarted {} -> False + CRRemoteCtrlAnnounce {} -> False + CRRemoteCtrlFound {} -> False + CRRemoteCtrlAccepted {} -> False + CRRemoteCtrlRejected {} -> False + CRRemoteCtrlConnecting {} -> False + CRRemoteCtrlConnected {} -> False + CRRemoteCtrlStopped {} -> False + CRRemoteCtrlDeleted {} -> False + _ -> True + logResponseToFile :: ChatResponse -> Bool logResponseToFile = \case CRContactsDisconnected {} -> True @@ -1107,6 +1154,27 @@ instance ToJSON ArchiveError where toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "AE" toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "AE" +data RemoteHostSession + = RemoteHostSessionStarting + { announcer :: Async () + } + | RemoteHostSessionStarted + { -- | Path for local resources to be synchronized with host + storePath :: FilePath, + ctrlClient :: HTTP2Client + } + +data RemoteCtrlSession = RemoteCtrlSession + { -- | Server side of transport to process remote commands and forward notifications + discoverer :: Async (), + supervisor :: Async (), + hostServer :: Maybe (Async ()), + discovered :: TMap C.KeyHash TransportHost, + accepted :: TMVar RemoteCtrlId, + remoteOutputQ :: TBQueue ChatResponse, + remoteNotifyQ :: TBQueue Notification + } + type ChatMonad' m = (MonadUnliftIO m, MonadReader ChatController m) type ChatMonad m = (ChatMonad' m, MonadError ChatError m) @@ -1152,16 +1220,19 @@ unsetActive a = asks activeTo >>= atomically . (`modifyTVar` unset) -- | Emit local events. toView :: ChatMonad' m => ChatResponse -> m () -toView = toView_ Nothing - --- | Used by transport to mark remote events with source. -toViewRemote :: ChatMonad' m => RemoteHostId -> ChatResponse -> m () -toViewRemote = toView_ . Just - -toView_ :: ChatMonad' m => Maybe RemoteHostId -> ChatResponse -> m () -toView_ rh event = do - q <- asks outputQ - atomically $ writeTBQueue q (Nothing, rh, event) +toView event = do + localQ <- asks outputQ + chatReadVar remoteCtrlSession >>= \case + Nothing -> atomically $ writeTBQueue localQ (Nothing, Nothing, event) + Just RemoteCtrlSession {remoteOutputQ} -> + if allowRemoteEvent event + then do + -- TODO: filter events or let the UI ignore trigger events by itself? + -- traceM $ "Sending event to remote Q: " <> show event + atomically $ writeTBQueue remoteOutputQ event -- TODO: check full? + else do + -- traceM $ "Sending event to local Q: " <> show event + atomically $ writeTBQueue localQ (Nothing, Nothing, event) withStore' :: ChatMonad m => (DB.Connection -> IO a) -> m a withStore' action = withStore $ liftIO . action diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index b9ce95373..87bd8f4ef 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -43,7 +43,7 @@ import Simplex.Messaging.Agent.Protocol (AgentMsgId, MsgMeta (..), MsgReceiptSta import Simplex.Messaging.Crypto.File (CryptoFile (..)) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, parseAll, sumTypeJSON) +import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, parseAll, enumJSON, sumTypeJSON) import Simplex.Messaging.Protocol (MsgBody) import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>)) @@ -880,7 +880,7 @@ data SndCIStatusProgress deriving (Eq, Show, Generic) instance FromJSON SndCIStatusProgress where - parseJSON = J.genericParseJSON . sumTypeJSON $ dropPrefix "SSP" + parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "SSP" instance ToJSON SndCIStatusProgress where toJSON = J.genericToJSON . enumJSON $ dropPrefix "SSP" diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index 8f7a3b4f4..722274335 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -4,12 +4,15 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module Simplex.Chat.Remote where +import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class +import Control.Monad.Reader (asks) import Control.Monad.STM (retry) import Crypto.Random (getRandomBytes) import qualified Data.Aeson as J @@ -18,9 +21,13 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Base64.URL as B64U import qualified Data.ByteString.Char8 as B import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (fromMaybe) import qualified Data.Map.Strict as M +import qualified Data.Text as T import qualified Network.HTTP.Types as HTTP +import qualified Network.HTTP.Types.Status as Status import qualified Network.HTTP2.Client as HTTP2Client +import qualified Network.HTTP2.Server as HTTP2Server import Network.Socket (SockAddr (..), hostAddressToTuple) import Simplex.Chat.Controller import qualified Simplex.Chat.Remote.Discovery as Discovery @@ -36,7 +43,7 @@ import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..)) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client) import qualified Simplex.Messaging.Transport.HTTP2.Client as HTTP2 import qualified Simplex.Messaging.Transport.HTTP2.Server as HTTP2 -import Simplex.Messaging.Util (bshow) +import Simplex.Messaging.Util (bshow, ifM, tshow) import System.Directory (getFileSize) import UnliftIO @@ -54,32 +61,67 @@ withRemoteHost remoteHostId action = startRemoteHost :: (ChatMonad m) => RemoteHostId -> m ChatResponse startRemoteHost remoteHostId = do - M.lookup remoteHostId <$> chatReadVar remoteHostSessions >>= \case + asks remoteHostSessions >>= atomically . TM.lookup remoteHostId >>= \case Just _ -> throwError $ ChatErrorRemoteHost remoteHostId RHBusy - Nothing -> withRemoteHost remoteHostId run - where - run RemoteHost {storePath, caKey, caCert} = do - announcer <- async $ do - cleanup <- toIO $ closeRemoteHostSession remoteHostId >>= toView - let parent = (C.signatureKeyPair caKey, caCert) - sessionCreds <- liftIO $ genCredentials (Just parent) (0, 24) "Session" - let (fingerprint, credentials) = tlsCredentials $ sessionCreds :| [parent] - Discovery.announceRevHTTP2 cleanup fingerprint credentials >>= \case - Left todo'err -> liftIO cleanup -- TODO: log error - Right ctrlClient -> do - chatModifyVar remoteHostSessions $ M.insert remoteHostId RemoteHostSessionStarted {storePath, ctrlClient} - -- TODO: start streaming outputQ - toView CRRemoteHostConnected {remoteHostId} + Nothing -> withRemoteHost remoteHostId $ \rh -> do + announcer <- async $ run rh chatModifyVar remoteHostSessions $ M.insert remoteHostId RemoteHostSessionStarting {announcer} pure CRRemoteHostStarted {remoteHostId} + where + cleanup finished = do + logInfo "Remote host http2 client fininshed" + atomically $ writeTVar finished True + closeRemoteHostSession remoteHostId >>= toView + run RemoteHost {storePath, caKey, caCert} = do + finished <- newTVarIO False + let parent = (C.signatureKeyPair caKey, caCert) + sessionCreds <- liftIO $ genCredentials (Just parent) (0, 24) "Session" + let (fingerprint, credentials) = tlsCredentials $ sessionCreds :| [parent] + Discovery.announceRevHTTP2 (cleanup finished) fingerprint credentials >>= \case + Left h2ce -> do + logError $ "Failed to set up remote host connection: " <> tshow h2ce + cleanup finished + Right ctrlClient -> do + chatModifyVar remoteHostSessions $ M.insert remoteHostId RemoteHostSessionStarted {storePath, ctrlClient} + chatWriteVar currentRemoteHost $ Just remoteHostId + sendHello ctrlClient >>= \case + Left h2ce -> do + logError $ "Failed to send initial remote host request: " <> tshow h2ce + cleanup finished + Right HTTP2.HTTP2Response {respBody = HTTP2Body {bodyHead}} -> do + logDebug $ "Got initial from remote host: " <> tshow bodyHead + _ <- asks outputQ >>= async . pollRemote finished ctrlClient "/recv" (Nothing, Just remoteHostId,) + toView CRRemoteHostConnected {remoteHostId} + +sendHello :: (ChatMonad m) => HTTP2Client -> m (Either HTTP2.HTTP2ClientError HTTP2.HTTP2Response) +sendHello http = liftIO (HTTP2.sendRequestDirect http req Nothing) + where + req = HTTP2Client.requestNoBody "GET" "/" mempty + +pollRemote :: (ChatMonad m, J.FromJSON a) => TVar Bool -> HTTP2Client -> ByteString -> (a -> b) -> TBQueue b -> m () +pollRemote finished http path f queue = loop + where + loop = do + liftIO (HTTP2.sendRequestDirect http req Nothing) >>= \case + Left e -> logError $ "pollRemote: " <> tshow (path, e) + Right HTTP2.HTTP2Response {respBody = HTTP2Body {bodyHead}} -> + case J.eitherDecodeStrict' bodyHead of + Left e -> logError $ "pollRemote/decode: " <> tshow (path, e) + Right o -> atomically $ writeTBQueue queue (f o) + readTVarIO finished >>= (`unless` loop) + req = HTTP2Client.requestNoBody "GET" path mempty closeRemoteHostSession :: (ChatMonad m) => RemoteHostId -> m ChatResponse closeRemoteHostSession remoteHostId = withRemoteHostSession remoteHostId $ \session -> do - case session of - RemoteHostSessionStarting {announcer} -> cancel announcer - RemoteHostSessionStarted {ctrlClient} -> liftIO (HTTP2.closeHTTP2Client ctrlClient) + liftIO $ cancelRemoteHostSession session + chatWriteVar currentRemoteHost Nothing chatModifyVar remoteHostSessions $ M.delete remoteHostId - pure CRRemoteHostStopped { remoteHostId } + pure CRRemoteHostStopped {remoteHostId} + +cancelRemoteHostSession :: MonadUnliftIO m => RemoteHostSession -> m () +cancelRemoteHostSession = \case + RemoteHostSessionStarting {announcer} -> cancel announcer + RemoteHostSessionStarted {ctrlClient} -> liftIO $ HTTP2.closeHTTP2Client ctrlClient createRemoteHost :: (ChatMonad m) => m ChatResponse createRemoteHost = do @@ -87,10 +129,7 @@ createRemoteHost = do ((_, caKey), caCert) <- liftIO $ genCredentials Nothing (-25, 24 * 365) displayName storePath <- liftIO randomStorePath remoteHostId <- withStore' $ \db -> insertRemoteHost db storePath displayName caKey caCert - let oobData = - RemoteCtrlOOB - { caFingerprint = C.certificateFingerprint caCert - } + let oobData = RemoteCtrlOOB {caFingerprint = C.certificateFingerprint caCert} pure CRRemoteHostCreated {remoteHostId, oobData} -- | Generate a random 16-char filepath without / in it by using base64url encoding. @@ -113,41 +152,40 @@ deleteRemoteHost remoteHostId = withRemoteHost remoteHostId $ \rh -> do pure CRRemoteHostDeleted {remoteHostId} processRemoteCommand :: (ChatMonad m) => RemoteHostSession -> (ByteString, ChatCommand) -> m ChatResponse -processRemoteCommand RemoteHostSessionStarting {} _ = error "TODO: sending remote commands before session started" -processRemoteCommand RemoteHostSessionStarted {ctrlClient} (s, cmd) = +processRemoteCommand RemoteHostSessionStarting {} _ = pure . CRChatError Nothing . ChatError $ CEInternalError "sending remote commands before session started" +processRemoteCommand RemoteHostSessionStarted {ctrlClient} (s, cmd) = do + logDebug $ "processRemoteCommand: " <> T.pack (show s) -- XXX: intercept and filter some commands -- TODO: store missing files on remote host relayCommand ctrlClient s relayCommand :: (ChatMonad m) => HTTP2Client -> ByteString -> m ChatResponse relayCommand http s = - postBytestring Nothing http "/relay" mempty s >>= \case - Left e -> error "TODO: http2chatError" + postBytestring Nothing http "/send" mempty s >>= \case + Left e -> err $ "relayCommand/post: " <> show e Right HTTP2.HTTP2Response {respBody = HTTP2Body {bodyHead}} -> do - remoteChatResponse <- - if iTax - then case J.eitherDecodeStrict bodyHead of -- XXX: large JSONs can overflow into buffered chunks - Left e -> error "TODO: json2chatError" e - Right (raw :: J.Value) -> case J.fromJSON (sum2tagged raw) of - J.Error e -> error "TODO: json2chatError" e - J.Success cr -> pure cr - else case J.eitherDecodeStrict bodyHead of -- XXX: large JSONs can overflow into buffered chunks - Left e -> error "TODO: json2chatError" e - Right cr -> pure cr + logDebug $ "Got /send response: " <> T.pack (show bodyHead) + remoteChatResponse <- case J.eitherDecodeStrict bodyHead of -- XXX: large JSONs can overflow into buffered chunks + Left e -> err $ "relayCommand/decodeValue: " <> show e + Right json -> case J.fromJSON $ toTaggedJSON json of + J.Error e -> err $ "relayCommand/fromJSON: " <> show e + J.Success cr -> pure cr case remoteChatResponse of -- TODO: intercept file responses and fetch files when needed -- XXX: is that even possible, to have a file response to a command? _ -> pure remoteChatResponse where - iTax = True -- TODO: get from RemoteHost + err = pure . CRChatError Nothing . ChatError . CEInternalError + toTaggedJSON :: J.Value -> J.Value + toTaggedJSON = id -- owsf2tagged TODO: get from RemoteHost -- XXX: extract to http2 transport - postBytestring timeout c path hs body = liftIO $ HTTP2.sendRequest c req timeout + postBytestring timeout' c path hs body = liftIO $ HTTP2.sendRequestDirect c req timeout' where req = HTTP2Client.requestBuilder "POST" path hs (Binary.fromByteString body) -- | Convert swift single-field sum encoding into tagged/discriminator-field -sum2tagged :: J.Value -> J.Value -sum2tagged = \case +owsf2tagged :: J.Value -> J.Value +owsf2tagged = \case J.Object todo'convert -> J.Object todo'convert skip -> skip @@ -161,13 +199,13 @@ storeRemoteFile http localFile = do where postFile timeout c path hs file = liftIO $ do fileSize <- fromIntegral <$> getFileSize file - HTTP2.sendRequest c (req fileSize) timeout + HTTP2.sendRequestDirect c (req fileSize) timeout where - req size = HTTP2Client.requestFile "POST" path hs (HTTP2Client.FileSpec file 0 size) + req size = HTTP2Client.requestFile "PUT" path hs (HTTP2Client.FileSpec file 0 size) fetchRemoteFile :: (ChatMonad m) => HTTP2Client -> FilePath -> FileTransferId -> m ChatResponse fetchRemoteFile http storePath remoteFileId = do - liftIO (HTTP2.sendRequest http req Nothing) >>= \case + liftIO (HTTP2.sendRequestDirect http req Nothing) >>= \case Left e -> error "TODO: http2chatError" Right HTTP2.HTTP2Response {respBody} -> do error "TODO: stream body into a local file" -- XXX: consult headers for a file name? @@ -175,47 +213,84 @@ fetchRemoteFile http storePath remoteFileId = do req = HTTP2Client.requestNoBody "GET" path mempty path = "/fetch/" <> bshow remoteFileId -processControllerRequest :: (ChatMonad m) => RemoteCtrlId -> HTTP2.HTTP2Request -> m () -processControllerRequest rc req = error "TODO: processControllerRequest" +processControllerRequest :: forall m . (ChatMonad m) => (ByteString -> m ChatResponse) -> HTTP2.HTTP2Request -> m () +processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody = HTTP2Body {bodyHead}, sendResponse} = do + logDebug $ "Remote controller request: " <> T.pack (show $ method <> " " <> path) + res <- tryChatError $ case (method, path) of + ("GET", "/") -> getHello + ("POST", "/send") -> sendCommand + ("GET", "/recv") -> recvMessage + ("PUT", "/store") -> storeFile + ("GET", "/fetch") -> fetchFile + unexpected -> respondWith Status.badRequest400 $ "unexpected method/path: " <> Binary.putStringUtf8 (show unexpected) + case res of + Left e -> logError $ "Error handling remote controller request: (" <> tshow (method <> " " <> path) <> "): " <> tshow e + Right () -> logDebug $ "Remote controller request: " <> tshow (method <> " " <> path) <> " OK" + where + method = fromMaybe "" $ HTTP2Server.requestMethod request + path = fromMaybe "" $ HTTP2Server.requestPath request + getHello = respond "OK" + sendCommand = execChatCommand bodyHead >>= respondJSON + recvMessage = chatReadVar remoteCtrlSession >>= \case + Nothing -> respondWith Status.internalServerError500 "session not active" + Just rcs -> atomically (readTBQueue $ remoteOutputQ rcs) >>= respondJSON + storeFile = respondWith Status.notImplemented501 "TODO: storeFile" + fetchFile = respondWith Status.notImplemented501 "TODO: fetchFile" + + respondJSON :: J.ToJSON a => a -> m () + respondJSON = respond . Binary.fromLazyByteString . J.encode + + respond = respondWith Status.ok200 + respondWith status = liftIO . sendResponse . HTTP2Server.responseBuilder status [] -- * ChatRequest handlers -startRemoteCtrl :: (ChatMonad m) => m ChatResponse -startRemoteCtrl = +startRemoteCtrl :: (ChatMonad m) => (ByteString -> m ChatResponse) -> m ChatResponse +startRemoteCtrl execChatCommand = chatReadVar remoteCtrlSession >>= \case Just _busy -> throwError $ ChatErrorRemoteCtrl RCEBusy Nothing -> do - accepted <- newEmptyTMVarIO + size <- asks $ tbqSize . config + remoteOutputQ <- newTBQueueIO size + remoteNotifyQ <- newTBQueueIO size discovered <- newTVarIO mempty discoverer <- async $ discoverRemoteCtrls discovered + accepted <- newEmptyTMVarIO supervisor <- async $ do remoteCtrlId <- atomically (readTMVar accepted) withRemoteCtrl remoteCtrlId $ \RemoteCtrl {displayName, fingerprint} -> do source <- atomically $ TM.lookup fingerprint discovered >>= maybe retry pure toView $ CRRemoteCtrlConnecting {remoteCtrlId, displayName} atomically $ writeTVar discovered mempty -- flush unused sources - server <- async $ Discovery.connectRevHTTP2 source fingerprint (processControllerRequest remoteCtrlId) + server <- async $ Discovery.connectRevHTTP2 source fingerprint (processControllerRequest execChatCommand) chatModifyVar remoteCtrlSession $ fmap $ \s -> s {hostServer = Just server} toView $ CRRemoteCtrlConnected {remoteCtrlId, displayName} _ <- waitCatch server chatWriteVar remoteCtrlSession Nothing - toView $ CRRemoteCtrlStopped {remoteCtrlId} - chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, accepted} + toView $ CRRemoteCtrlStopped Nothing + chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, accepted, remoteOutputQ, remoteNotifyQ} pure $ CRRemoteCtrlStarted Nothing discoverRemoteCtrls :: (ChatMonad m) => TM.TMap C.KeyHash TransportHost -> m () -discoverRemoteCtrls discovered = Discovery.openListener >>= go +discoverRemoteCtrls discovered = Discovery.withListener go where go sock = Discovery.recvAnnounce sock >>= \case - (SockAddrInet _port addr, invite) -> case strDecode invite of + (SockAddrInet _sockPort sockAddr, invite) -> case strDecode invite of Left _ -> go sock -- ignore malformed datagrams Right fingerprint -> do - atomically $ TM.insert fingerprint (THIPv4 $ hostAddressToTuple addr) discovered + let addr = THIPv4 (hostAddressToTuple sockAddr) + ifM + (atomically $ TM.member fingerprint discovered) + (logDebug $ "Fingerprint announce already knwon: " <> T.pack (show (addr, invite))) + (do + logInfo $ "New fingerprint announce: " <> T.pack (show (addr, invite)) + atomically $ TM.insert fingerprint addr discovered + ) withStore' (`getRemoteCtrlByFingerprint` fingerprint) >>= \case - Nothing -> toView $ CRRemoteCtrlAnnounce fingerprint -- unknown controller, ui action required + Nothing -> toView $ CRRemoteCtrlAnnounce fingerprint -- unknown controller, ui "register" action required Just found@RemoteCtrl {remoteCtrlId, accepted=storedChoice} -> case storedChoice of - Nothing -> toView $ CRRemoteCtrlFound found -- first-time controller, ui action required + Nothing -> toView $ CRRemoteCtrlFound found -- first-time controller, ui "accept" action required Just False -> pure () -- skipping a rejected item Just True -> chatReadVar remoteCtrlSession >>= \case Nothing -> toView . CRChatError Nothing . ChatError $ CEInternalError "Remote host found without running a session" @@ -258,20 +333,28 @@ rejectRemoteCtrl remoteCtrlId = do cancel supervisor pure $ CRRemoteCtrlRejected {remoteCtrlId} -stopRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m ChatResponse -stopRemoteCtrl remoteCtrlId = +stopRemoteCtrl :: (ChatMonad m) => m ChatResponse +stopRemoteCtrl = chatReadVar remoteCtrlSession >>= \case Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive - Just RemoteCtrlSession {discoverer, supervisor, hostServer} -> do - cancel discoverer -- may be gone by now - case hostServer of - Just host -> cancel host -- supervisor will clean up - Nothing -> do - cancel supervisor -- supervisor is blocked until session progresses - chatWriteVar remoteCtrlSession Nothing - toView $ CRRemoteCtrlStopped {remoteCtrlId} + Just rcs -> do + cancelRemoteCtrlSession rcs $ do + chatWriteVar remoteCtrlSession Nothing + toView $ CRRemoteCtrlStopped Nothing pure $ CRCmdOk Nothing +cancelRemoteCtrlSession_ :: MonadUnliftIO m => RemoteCtrlSession -> m () +cancelRemoteCtrlSession_ rcs = cancelRemoteCtrlSession rcs $ pure () + +cancelRemoteCtrlSession :: MonadUnliftIO m => RemoteCtrlSession -> m () -> m () +cancelRemoteCtrlSession RemoteCtrlSession {discoverer, supervisor, hostServer} cleanup = do + cancel discoverer -- may be gone by now + case hostServer of + Just host -> cancel host -- supervisor will clean up + Nothing -> do + cancel supervisor -- supervisor is blocked until session progresses + cleanup + deleteRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m ChatResponse deleteRemoteCtrl remoteCtrlId = chatReadVar remoteCtrlSession >>= \case diff --git a/src/Simplex/Chat/Remote/Discovery.hs b/src/Simplex/Chat/Remote/Discovery.hs index 2faed66cd..40314b4cb 100644 --- a/src/Simplex/Chat/Remote/Discovery.hs +++ b/src/Simplex/Chat/Remote/Discovery.hs @@ -12,6 +12,7 @@ module Simplex.Chat.Remote.Discovery -- * Discovery connectRevHTTP2, + withListener, openListener, recvAnnounce, connectTLSClient, @@ -32,7 +33,7 @@ import Simplex.Messaging.Transport (supportedParameters) import qualified Simplex.Messaging.Transport as Transport import Simplex.Messaging.Transport.Client (TransportHost (..), defaultTransportClientConfig, runTransportClient) import Simplex.Messaging.Transport.HTTP2 (defaultHTTP2BufferSize, getHTTP2Body) -import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError, attachHTTP2Client, defaultHTTP2ClientConfig) +import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError, attachHTTP2Client, connTimeout, defaultHTTP2ClientConfig) import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..), runHTTP2ServerWith) import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServer) import Simplex.Messaging.Util (whenM) @@ -52,15 +53,16 @@ pattern BROADCAST_PORT = "5226" -- | Announce tls server, wait for connection and attach http2 client to it. -- -- Announcer is started when TLS server is started and stopped when a connection is made. -announceRevHTTP2 :: (StrEncoding invite, MonadUnliftIO m) => IO () -> invite -> TLS.Credentials -> m (Either HTTP2ClientError HTTP2Client) +announceRevHTTP2 :: (StrEncoding invite, MonadUnliftIO m) => m () -> invite -> TLS.Credentials -> m (Either HTTP2ClientError HTTP2Client) announceRevHTTP2 finishAction invite credentials = do httpClient <- newEmptyMVar started <- newEmptyTMVarIO finished <- newEmptyMVar announcer <- async . liftIO . whenM (atomically $ takeTMVar started) $ runAnnouncer (strEncode invite) tlsServer <- startTLSServer started credentials $ \tls -> cancel announcer >> runHTTP2Client finished httpClient tls - _ <- forkIO . liftIO $ do + _ <- forkIO $ do readMVar finished + cancel announcer cancel tlsServer finishAction readMVar httpClient @@ -68,11 +70,12 @@ announceRevHTTP2 finishAction invite credentials = do -- | Broadcast invite with link-local datagrams runAnnouncer :: ByteString -> IO () runAnnouncer inviteBS = do - sock <- UDP.clientSocket BROADCAST_ADDR_V4 BROADCAST_PORT False - N.setSocketOption (UDP.udpSocket sock) N.Broadcast 1 - forever $ do - UDP.send sock inviteBS - threadDelay 1000000 + bracket (UDP.clientSocket BROADCAST_ADDR_V4 BROADCAST_PORT False) UDP.close $ \sock -> do + N.setSocketOption (UDP.udpSocket sock) N.Broadcast 1 + N.setSocketOption (UDP.udpSocket sock) N.ReuseAddr 1 + forever $ do + UDP.send sock inviteBS + threadDelay 1000000 startTLSServer :: (MonadUnliftIO m) => TMVar Bool -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ()) startTLSServer started credentials = async . liftIO . runTransportServer started BROADCAST_PORT serverParams defaultTransportServerConfig @@ -88,8 +91,13 @@ startTLSServer started credentials = async . liftIO . runTransportServer started -- | Attach HTTP2 client and hold the TLS until the attached client finishes. runHTTP2Client :: MVar () -> MVar (Either HTTP2ClientError HTTP2Client) -> Transport.TLS -> IO () runHTTP2Client finishedVar clientVar tls = do - attachHTTP2Client defaultHTTP2ClientConfig ANY_ADDR_V4 BROADCAST_PORT (putMVar finishedVar ()) defaultHTTP2BufferSize tls >>= putMVar clientVar + attachHTTP2Client config ANY_ADDR_V4 BROADCAST_PORT (putMVar finishedVar ()) defaultHTTP2BufferSize tls >>= putMVar clientVar readMVar finishedVar + where + config = defaultHTTP2ClientConfig { connTimeout = 86400000000 } + +withListener :: (MonadUnliftIO m) => (UDP.ListenSocket -> m a) -> m a +withListener = bracket openListener (liftIO . UDP.stop) openListener :: (MonadIO m) => m UDP.ListenSocket openListener = liftIO $ do diff --git a/src/Simplex/Chat/Remote/Types.hs b/src/Simplex/Chat/Remote/Types.hs index f13c3c84e..cdff2b7ac 100644 --- a/src/Simplex/Chat/Remote/Types.hs +++ b/src/Simplex/Chat/Remote/Types.hs @@ -5,15 +5,10 @@ module Simplex.Chat.Remote.Types where -import Control.Concurrent.Async (Async) import qualified Data.Aeson.TH as J import Data.Int (Int64) import Data.Text (Text) import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.TMap (TMap) -import Simplex.Messaging.Transport.Client (TransportHost) -import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client) -import UnliftIO.STM type RemoteHostId = Int64 @@ -40,22 +35,3 @@ data RemoteCtrl = RemoteCtrl deriving (Show) $(J.deriveJSON J.defaultOptions ''RemoteCtrl) - -data RemoteHostSession - = RemoteHostSessionStarting - { announcer :: Async () - } - | RemoteHostSessionStarted - { -- | Path for local resources to be synchronized with host - storePath :: FilePath, - ctrlClient :: HTTP2Client - } - -data RemoteCtrlSession = RemoteCtrlSession - { -- | Server side of transport to process remote commands and forward notifications - discoverer :: Async (), - supervisor :: Async (), - hostServer :: Maybe (Async ()), - discovered :: TMap C.KeyHash TransportHost, - accepted :: TMVar RemoteCtrlId - } diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index 1097a7954..4a73a0fd7 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -53,15 +53,16 @@ getKey = runInputLoop :: ChatTerminal -> ChatController -> IO () runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do s <- atomically . readTBQueue $ inputQ cc + rh <- readTVarIO $ currentRemoteHost cc let bs = encodeUtf8 $ T.pack s cmd = parseChatCommand bs unless (isMessage cmd) $ echo s - r <- runReaderT (execChatCommand Nothing bs) cc + r <- runReaderT (execChatCommand rh bs) cc case r of CRChatCmdError _ _ -> when (isMessage cmd) $ echo s CRChatError _ _ -> when (isMessage cmd) $ echo s _ -> pure () - printRespToTerminal ct cc False r + printRespToTerminal ct cc False rh r startLiveMessage cmd r where echo s = printToTerminal ct [plain s] @@ -134,7 +135,7 @@ runTerminalInput ct cc = withChatTerm ct $ do receiveFromTTY cc ct receiveFromTTY :: forall m. MonadTerminal m => ChatController -> ChatTerminal -> m () -receiveFromTTY cc@ChatController {inputQ, activeTo, currentUser, chatStore} ct@ChatTerminal {termSize, termState, liveMessageState} = +receiveFromTTY cc@ChatController {inputQ, activeTo, currentUser, currentRemoteHost, chatStore} ct@ChatTerminal {termSize, termState, liveMessageState} = forever $ getKey >>= liftIO . processKey >> withTermLock ct (updateInput ct) where processKey :: (Key, Modifiers) -> IO () @@ -166,7 +167,8 @@ receiveFromTTY cc@ChatController {inputQ, activeTo, currentUser, chatStore} ct@C kill promptThreadId atomically $ writeTVar liveMessageState Nothing r <- sendUpdatedLiveMessage cc sentMsg lm False - printRespToTerminal ct cc False r + rh <- readTVarIO currentRemoteHost -- XXX: should be inherited from live message state + printRespToTerminal ct cc False rh r where kill sel = deRefWeak (sel lm) >>= mapM_ killThread diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index 74bb9e8c0..e6792129c 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/src/Simplex/Chat/Terminal/Output.hs @@ -21,6 +21,7 @@ import Simplex.Chat.Controller import Simplex.Chat.Messages hiding (NewChatItem (..)) import Simplex.Chat.Styled import Simplex.Chat.View +import Simplex.Chat.Remote.Types (RemoteHostId) import System.Console.ANSI.Types import System.IO (IOMode (..), hPutStrLn, withFile) import System.Mem.Weak (Weak) @@ -112,7 +113,7 @@ withTermLock ChatTerminal {termLock} action = do runTerminalOutput :: ChatTerminal -> ChatController -> IO () runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = do forever $ do - (_, _, r) <- atomically $ readTBQueue outputQ + (_, outputRH, r) <- atomically $ readTBQueue outputQ case r of CRNewChatItem _ ci -> markChatItemRead ci CRChatItemUpdated _ ci -> markChatItemRead ci @@ -121,7 +122,7 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d Just path -> if logResponseToFile r then logResponse path else printToTerminal ct _ -> printToTerminal ct liveItems <- readTVarIO showLiveItems - responseString cc liveItems r >>= printResp + responseString cc liveItems outputRH r >>= printResp where markChatItemRead (AChatItem _ _ chat item@ChatItem {chatDir, meta = CIMeta {itemStatus}}) = case (muted chat chatDir, itemStatus) of @@ -132,15 +133,16 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d _ -> pure () logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s -printRespToTerminal :: ChatTerminal -> ChatController -> Bool -> ChatResponse -> IO () -printRespToTerminal ct cc liveItems r = responseString cc liveItems r >>= printToTerminal ct +printRespToTerminal :: ChatTerminal -> ChatController -> Bool -> Maybe RemoteHostId -> ChatResponse -> IO () +printRespToTerminal ct cc liveItems outputRH r = responseString cc liveItems outputRH r >>= printToTerminal ct -responseString :: ChatController -> Bool -> ChatResponse -> IO [StyledString] -responseString cc liveItems r = do - user <- readTVarIO $ currentUser cc +responseString :: ChatController -> Bool -> Maybe RemoteHostId -> ChatResponse -> IO [StyledString] +responseString cc liveItems outputRH r = do + currentRH <- readTVarIO $ currentRemoteHost cc + user <- readTVarIO $ currentUser cc -- XXX: local user, should be subsumed by remote when connected ts <- getCurrentTime tz <- getCurrentTimeZone - pure $ responseToView user (config cc) liveItems ts tz r + pure $ responseToView (currentRH, user) (config cc) liveItems ts tz outputRH r printToTerminal :: ChatTerminal -> [StyledString] -> IO () printToTerminal ct s = diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 088f23e05..03e0135e7 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -1442,6 +1442,7 @@ serializeIntroStatus = \case GMIntroConnected -> "con" data Notification = Notification {title :: Text, text :: Text} + deriving (Show, Generic, FromJSON, ToJSON) textParseJSON :: TextEncoding a => String -> J.Value -> JT.Parser a textParseJSON name = J.withText name $ maybe (fail $ "bad " <> name) pure . textDecode diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index f32b1835e..f98406d1b 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -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] diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index 6831cf319..107faef72 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -34,6 +34,9 @@ import Test.Hspec defaultPrefs :: Maybe Preferences defaultPrefs = Just $ toChatPrefs defaultChatPrefs +aliceDesktopProfile :: Profile +aliceDesktopProfile = Profile {displayName = "alice_desktop", fullName = "Alice Desktop", image = Nothing, contactLink = Nothing, preferences = defaultPrefs} + aliceProfile :: Profile aliceProfile = Profile {displayName = "alice", fullName = "Alice", image = Nothing, contactLink = Nothing, preferences = defaultPrefs} diff --git a/tests/RemoteTests.hs b/tests/RemoteTests.hs index d1c162187..f9137cdba 100644 --- a/tests/RemoteTests.hs +++ b/tests/RemoteTests.hs @@ -31,7 +31,8 @@ remoteTests :: SpecWith FilePath remoteTests = describe "Handshake" $ do it "generates usable credentials" genCredentialsTest it "connects announcer with discoverer over reverse-http2" announceDiscoverHttp2Test - it "connects desktop and mobile" remoteHandshakeTest + xit "connects desktop and mobile" remoteHandshakeTest + it "send messages via remote desktop" remoteCommandTest -- * Low-level TLS with ephemeral credentials @@ -39,11 +40,10 @@ genCredentialsTest :: (HasCallStack) => FilePath -> IO () genCredentialsTest _tmp = do (fingerprint, credentials) <- genTestCredentials started <- newEmptyTMVarIO - server <- Discovery.startTLSServer started credentials serverHandler - ok <- atomically (readTMVar started) - unless ok $ cancel server >> error "TLS server failed to start" - Discovery.connectTLSClient "127.0.0.1" fingerprint clientHandler - cancel server + bracket (Discovery.startTLSServer started credentials serverHandler) cancel $ \_server -> do + ok <- atomically (readTMVar started) + unless ok $ error "TLS server failed to start" + Discovery.connectTLSClient "127.0.0.1" fingerprint clientHandler where serverHandler serverTls = do traceM " - Sending from server" @@ -62,19 +62,21 @@ announceDiscoverHttp2Test :: (HasCallStack) => FilePath -> IO () announceDiscoverHttp2Test _tmp = do (fingerprint, credentials) <- genTestCredentials finished <- newEmptyMVar - announcer <- async $ do + controller <- async $ do traceM " - Controller: starting" - http <- Discovery.announceRevHTTP2 (putMVar finished ()) fingerprint credentials >>= either (fail . show) pure - traceM " - Controller: got client" - sendRequest http (C.requestNoBody "GET" "/" []) (Just 10000000) >>= \case - Left err -> do - traceM " - Controller: got error" - fail $ show err - Right HTTP2Response {} -> - traceM " - Controller: got response" - closeHTTP2Client http - dis <- async $ do - sock <- Discovery.openListener + bracket + (Discovery.announceRevHTTP2 (putMVar finished ()) fingerprint credentials >>= either (fail . show) pure) + closeHTTP2Client + ( \http -> do + traceM " - Controller: got client" + sendRequest http (C.requestNoBody "GET" "/" []) (Just 10000000) >>= \case + Left err -> do + traceM " - Controller: got error" + fail $ show err + Right HTTP2Response {} -> + traceM " - Controller: got response" + ) + host <- async $ Discovery.withListener $ \sock -> do (N.SockAddrInet _port addr, invite) <- Discovery.recvAnnounce sock strDecode invite `shouldBe` Right fingerprint traceM " - Host: connecting" @@ -84,14 +86,13 @@ announceDiscoverHttp2Test _tmp = do traceM " - Host: got request" sendResponse $ S.responseNoBody ok200 [] traceM " - Host: sent response" - takeMVar finished - cancel server + takeMVar finished `finally` cancel server traceM " - Host: finished" - waitBoth dis announcer `shouldReturn` ((), ()) + (waitBoth host controller `shouldReturn` ((), ())) `onException` (cancel host >> cancel controller) -- * Chat commands -remoteHandshakeTest :: HasCallStack => FilePath -> IO () +remoteHandshakeTest :: (HasCallStack) => FilePath -> IO () remoteHandshakeTest = testChat2 aliceProfile bobProfile $ \desktop mobile -> do desktop ##> "/list remote hosts" desktop <## "No remote hosts" @@ -103,7 +104,6 @@ remoteHandshakeTest = testChat2 aliceProfile bobProfile $ \desktop mobile -> do desktop ##> "/list remote hosts" desktop <## "Remote hosts:" desktop <## "1. TODO" -- TODO host name probably should be Maybe, as when host is created there is no name yet - desktop ##> "/start remote host 1" desktop <## "remote host 1 started" @@ -124,9 +124,9 @@ remoteHandshakeTest = testChat2 aliceProfile bobProfile $ \desktop mobile -> do mobile <## "remote controller 1 accepted" -- alternative scenario: accepted before controller start mobile <## "remote controller 1 connecting to TODO" mobile <## "remote controller 1 connected, TODO" - mobile ##> "/stop remote ctrl 1" + mobile ##> "/stop remote ctrl" mobile <## "ok" - mobile <## "remote controller 1 stopped" -- TODO two outputs + mobile <## "remote controller stopped" mobile ##> "/delete remote ctrl 1" mobile <## "remote controller 1 deleted" mobile ##> "/list remote ctrls" @@ -139,6 +139,56 @@ remoteHandshakeTest = testChat2 aliceProfile bobProfile $ \desktop mobile -> do desktop ##> "/list remote hosts" desktop <## "No remote hosts" +remoteCommandTest :: (HasCallStack) => FilePath -> IO () +remoteCommandTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> do + desktop ##> "/create remote host" + desktop <## "remote host 1 created" + desktop <## "connection code:" + fingerprint <- getTermLine desktop + + desktop ##> "/start remote host 1" + desktop <## "remote host 1 started" + + mobile ##> "/start remote ctrl" + mobile <## "remote controller started" + mobile <## "remote controller announced" + mobile <## "connection code:" + fingerprint' <- getTermLine mobile + fingerprint' `shouldBe` fingerprint + mobile ##> ("/register remote ctrl " <> fingerprint') + mobile <## "remote controller 1 registered" + mobile ##> "/accept remote ctrl 1" + mobile <## "remote controller 1 accepted" -- alternative scenario: accepted before controller start + mobile <## "remote controller 1 connecting to TODO" + mobile <## "remote controller 1 connected, TODO" + desktop <## "remote host 1 connected" + + traceM " - exchanging contacts" + bob ##> "/c" + inv' <- getInvitation bob + desktop ##> ("/c " <> inv') + desktop <## "confirmation sent!" + concurrently_ + (desktop <## "bob (Bob): contact is connected") + (bob <## "alice (Alice): contact is connected") + + traceM " - sending messages" + desktop #> "@bob hello there 🙂" + bob <# "alice> hello there 🙂" + bob #> "@alice hi" + desktop <# "bob> hi" + + traceM " - post-remote checks" + mobile ##> "/stop remote ctrl" + mobile <## "ok" + concurrently_ + (mobile <## "remote controller stopped") + (desktop <## "remote host 1 stopped") + mobile ##> "/contacts" + mobile <## "bob (Bob)" + + traceM " - done" + -- * Utils genTestCredentials :: IO (C.KeyHash, TLS.Credentials)