From 8482dbfd99810edc98cae6e0e13c3b613ff9206d Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 1 Nov 2023 19:08:36 +0000 Subject: [PATCH] core: update remote API commands/events (#3295) * core: update remote API * Add session verification event between tls and http2 * roll back char_ '@' parsers * use more specific parser for verification codes * cabal.project.local for mac --------- Co-authored-by: IC Rainbow --- cabal.project | 2 +- scripts/cabal.project.local.mac | 5 ++ src/Simplex/Chat.hs | 28 ++++---- src/Simplex/Chat/Controller.hs | 41 ++++++------ src/Simplex/Chat/Remote.hs | 100 +++++++++++++++++------------ src/Simplex/Chat/Remote/RevHTTP.hs | 5 -- src/Simplex/Chat/View.hs | 19 ++++-- tests/RemoteTests.hs | 21 ++++-- 8 files changed, 130 insertions(+), 91 deletions(-) diff --git a/cabal.project b/cabal.project index b693f6c88f..7fe664f4e1 100644 --- a/cabal.project +++ b/cabal.project @@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: db1b2f77cd1c172fab26b68c507cdd2c1b7b0e63 + tag: a5fed340e2814a226180ce1abe606ac79366fe5b source-repository-package type: git diff --git a/scripts/cabal.project.local.mac b/scripts/cabal.project.local.mac index 35c10db756..dd62f1a391 100644 --- a/scripts/cabal.project.local.mac +++ b/scripts/cabal.project.local.mac @@ -1,6 +1,11 @@ ignore-project: False -- amend to point to the actual openssl location + +package simplexmq + extra-include-dirs: /opt/homebrew/opt/openssl@1.1/include + extra-lib-dirs: /opt/homebrew/opt/openssl@1.1/lib + package direct-sqlcipher extra-include-dirs: /opt/homebrew/opt/openssl@1.1/include extra-lib-dirs: /opt/homebrew/opt/openssl@1.1/lib diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 157d7cea26..28b4c51120 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -1922,10 +1922,10 @@ processChatCommand = \case DeleteRemoteHost rh -> deleteRemoteHost rh >> ok_ StoreRemoteFile rh encrypted_ localPath -> CRRemoteFileStored rh <$> storeRemoteFile rh encrypted_ localPath GetRemoteFile rh rf -> getRemoteFile rh rf >> ok_ - StartRemoteCtrl -> withUser_ $ startRemoteCtrl (execChatCommand Nothing) >> ok_ - RegisterRemoteCtrl oob -> withUser_ $ CRRemoteCtrlRegistered <$> withStore' (`insertRemoteCtrl` oob) - AcceptRemoteCtrl rc -> withUser_ $ acceptRemoteCtrl rc >> ok_ - RejectRemoteCtrl rc -> withUser_ $ rejectRemoteCtrl rc >> ok_ + ConnectRemoteCtrl oob -> withUser_ $ CRRemoteCtrlRegistered <$> withStore' (`insertRemoteCtrl` oob) + FindKnownRemoteCtrl -> withUser_ $ findKnownRemoteCtrl (execChatCommand Nothing) >> ok_ + ConfirmRemoteCtrl rc -> withUser_ $ confirmRemoteCtrl rc >> ok_ + VerifyRemoteCtrlSession rc sessId -> withUser_ $ verifyRemoteCtrlSession rc sessId >> ok_ StopRemoteCtrl -> withUser_ $ stopRemoteCtrl >> ok_ ListRemoteCtrls -> withUser_ $ CRRemoteCtrlList <$> listRemoteCtrls DeleteRemoteCtrl rc -> withUser_ $ deleteRemoteCtrl rc >> ok_ @@ -5798,14 +5798,14 @@ chatCommandP = "/sync " *> char_ '@' *> (SyncContactRatchet <$> displayName <*> (" force=on" $> True <|> pure False)), "/_get code @" *> (APIGetContactCode <$> A.decimal), "/_get code #" *> (APIGetGroupMemberCode <$> A.decimal <* A.space <*> A.decimal), - "/_verify code @" *> (APIVerifyContact <$> A.decimal <*> optional (A.space *> textP)), - "/_verify code #" *> (APIVerifyGroupMember <$> A.decimal <* A.space <*> A.decimal <*> optional (A.space *> textP)), + "/_verify code @" *> (APIVerifyContact <$> A.decimal <*> optional (A.space *> verifyCodeP)), + "/_verify code #" *> (APIVerifyGroupMember <$> A.decimal <* A.space <*> A.decimal <*> optional (A.space *> verifyCodeP)), "/_enable @" *> (APIEnableContact <$> A.decimal), "/_enable #" *> (APIEnableGroupMember <$> A.decimal <* A.space <*> A.decimal), "/code " *> char_ '@' *> (GetContactCode <$> displayName), "/code #" *> (GetGroupMemberCode <$> displayName <* A.space <* char_ '@' <*> displayName), - "/verify " *> char_ '@' *> (VerifyContact <$> displayName <*> optional (A.space *> textP)), - "/verify #" *> (VerifyGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName <*> optional (A.space *> textP)), + "/verify " *> char_ '@' *> (VerifyContact <$> displayName <*> optional (A.space *> verifyCodeP)), + "/verify #" *> (VerifyGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName <*> optional (A.space *> verifyCodeP)), "/enable " *> char_ '@' *> (EnableContact <$> displayName), "/enable #" *> (EnableGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName), ("/help files" <|> "/help file" <|> "/hf") $> ChatHelp HSFiles, @@ -5856,7 +5856,7 @@ chatCommandP = "/_connect " *> (APIConnect <$> A.decimal <*> incognitoOnOffP <* A.space <*> ((Just <$> strP) <|> A.takeByteString $> Nothing)), "/_connect " *> (APIAddContact <$> A.decimal <*> incognitoOnOffP), "/_set incognito :" *> (APISetConnectionIncognito <$> A.decimal <* A.space <*> onOffP), - ("/connect" <|> "/c") *> (Connect <$> incognitoP <* A.space <*> ((Just <$> strP) <|> A.takeByteString $> Nothing)), + ("/connect" <|> "/c") *> (Connect <$> incognitoP <* A.space <*> ((Just <$> strP) <|> A.takeTill isSpace $> Nothing)), ("/connect" <|> "/c") *> (AddContact <$> incognitoP), SendMessage <$> chatNameP <* A.space <*> msgTextP, "@#" *> (SendMemberContactMessage <$> displayName <* A.space <* char_ '@' <*> displayName <* A.space <*> msgTextP), @@ -5926,12 +5926,11 @@ chatCommandP = "/delete remote host " *> (DeleteRemoteHost <$> A.decimal), "/store remote file " *> (StoreRemoteFile <$> A.decimal <*> optional (" encrypt=" *> onOffP) <* A.space <*> filePath), "/get remote file " *> (GetRemoteFile <$> A.decimal <* A.space <*> jsonP), - "/start remote ctrl" $> StartRemoteCtrl, - "/register remote ctrl " *> (RegisterRemoteCtrl <$> strP), - -- "/_register remote ctrl " *> (RegisterRemoteCtrl <$> jsonP), + "/connect remote ctrl " *> (ConnectRemoteCtrl <$> strP), + "/find remote ctrl" $> FindKnownRemoteCtrl, + "/confirm remote ctrl " *> (ConfirmRemoteCtrl <$> A.decimal), + "/verify remote ctrl " *> (VerifyRemoteCtrlSession <$> A.decimal <* A.space <*> textP), "/list remote ctrls" $> ListRemoteCtrls, - "/accept remote ctrl " *> (AcceptRemoteCtrl <$> A.decimal), - "/reject remote ctrl " *> (RejectRemoteCtrl <$> A.decimal), "/stop remote ctrl" $> StopRemoteCtrl, "/delete remote ctrl " *> (DeleteRemoteCtrl <$> A.decimal), ("/quit" <|> "/q" <|> "/exit") $> QuitChat, @@ -5997,6 +5996,7 @@ chatCommandP = fullNameP = A.space *> textP <|> pure "" textP = safeDecodeUtf8 <$> A.takeByteString pwdP = jsonP <|> (UserPwd . safeDecodeUtf8 <$> A.takeTill (== ' ')) + verifyCodeP = safeDecodeUtf8 <$> A.takeWhile (\c -> isDigit c || c == ' ') msgTextP = jsonP <|> textP stringP = T.unpack . safeDecodeUtf8 <$> A.takeByteString filePath = stringP diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 25fe9294c6..77976da05c 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -426,11 +426,11 @@ data ChatCommand | DeleteRemoteHost RemoteHostId -- ^ Unregister remote host and remove its data | StoreRemoteFile {remoteHostId :: RemoteHostId, storeEncrypted :: Maybe Bool, localPath :: FilePath} | GetRemoteFile {remoteHostId :: RemoteHostId, file :: RemoteFile} - | StartRemoteCtrl -- ^ Start listening for announcements from all registered controllers - | RegisterRemoteCtrl SignedOOB -- ^ Register OOB data for remote controller discovery and handshake + | ConnectRemoteCtrl SignedOOB -- ^ Connect new or existing controller via OOB data + | FindKnownRemoteCtrl -- ^ Start listening for announcements from all existing controllers + | ConfirmRemoteCtrl RemoteCtrlId -- ^ Confirm the connection with found controller + | VerifyRemoteCtrlSession RemoteCtrlId Text -- ^ Verify remote controller session | ListRemoteCtrls - | AcceptRemoteCtrl RemoteCtrlId -- ^ Accept discovered data and store confirmation - | RejectRemoteCtrl RemoteCtrlId -- ^ Reject and blacklist discovered data | StopRemoteCtrl -- ^ Stop listening for announcements or terminate an active session | DeleteRemoteCtrl RemoteCtrlId -- ^ Remove all local data associated with a remote controller session | QuitChat @@ -458,11 +458,11 @@ allowRemoteCommand = \case GetRemoteFile {} -> False StopRemoteHost _ -> False DeleteRemoteHost _ -> False - RegisterRemoteCtrl {} -> False - StartRemoteCtrl -> False + ConnectRemoteCtrl {} -> False + FindKnownRemoteCtrl -> False + ConfirmRemoteCtrl _ -> False + VerifyRemoteCtrlSession {} -> False ListRemoteCtrls -> False - AcceptRemoteCtrl _ -> False - RejectRemoteCtrl _ -> False StopRemoteCtrl -> False DeleteRemoteCtrl _ -> False ExecChatStoreSQL _ -> False @@ -641,14 +641,16 @@ data ChatResponse | CRRemoteHostCreated {remoteHost :: RemoteHostInfo} | CRRemoteHostList {remoteHosts :: [RemoteHostInfo]} | CRRemoteHostStarted {remoteHost :: RemoteHostInfo, sessionOOB :: Text} + | CRRemoteHostSessionCode {remoteHost :: RemoteHostInfo, sessionCode :: Text} | CRRemoteHostConnected {remoteHost :: RemoteHostInfo} | CRRemoteHostStopped {remoteHostId :: RemoteHostId} | CRRemoteFileStored {remoteHostId :: RemoteHostId, remoteFileSource :: CryptoFile} | CRRemoteCtrlList {remoteCtrls :: [RemoteCtrlInfo]} - | CRRemoteCtrlRegistered {remoteCtrl :: RemoteCtrlInfo} - | CRRemoteCtrlAnnounce {fingerprint :: C.KeyHash} -- unregistered fingerprint, needs confirmation + | CRRemoteCtrlRegistered {remoteCtrl :: RemoteCtrlInfo} -- TODO remove + | CRRemoteCtrlAnnounce {fingerprint :: C.KeyHash} -- TODO remove, unregistered fingerprint, needs confirmation -- TODO is it needed? | CRRemoteCtrlFound {remoteCtrl :: RemoteCtrlInfo} -- registered fingerprint, may connect - | CRRemoteCtrlConnecting {remoteCtrl :: RemoteCtrlInfo} + | CRRemoteCtrlConnecting {remoteCtrl :: RemoteCtrlInfo} -- TODO is remove + | CRRemoteCtrlSessionCode {remoteCtrl :: RemoteCtrlInfo, sessionCode :: Text, newCtrl :: Bool} | CRRemoteCtrlConnected {remoteCtrl :: RemoteCtrlInfo} | CRRemoteCtrlStopped | CRSQLResult {rows :: [Text]} @@ -679,8 +681,9 @@ allowRemoteEvent = \case CRRemoteCtrlAnnounce {} -> False CRRemoteCtrlFound {} -> False CRRemoteCtrlConnecting {} -> False + CRRemoteCtrlSessionCode {} -> False CRRemoteCtrlConnected {} -> False - CRRemoteCtrlStopped {} -> False + CRRemoteCtrlStopped -> False _ -> True logResponseToFile :: ChatResponse -> Bool @@ -1060,6 +1063,7 @@ data RemoteCtrlError | RCECertificateExpired {remoteCtrlId :: RemoteCtrlId} -- ^ A connection or CA certificate in a chain have bad validity period | RCECertificateUntrusted {remoteCtrlId :: RemoteCtrlId} -- ^ TLS is unable to validate certificate chain presented for a connection | RCEBadFingerprint -- ^ Bad fingerprint data provided in OOB + | RCEBadVerificationCode -- ^ The code submitted doesn't match session TLSunique | RCEHTTP2Error {http2Error :: String} | RCEHTTP2RespStatus {statusCode :: Maybe Int} -- TODO remove | RCEInvalidResponse {responseError :: String} @@ -1071,13 +1075,14 @@ data ArchiveError | AEImportFile {file :: String, chatError :: ChatError} deriving (Show, Exception) +-- | Host (mobile) side of transport to process remote commands and forward notifications data RemoteCtrlSession = RemoteCtrlSession - { -- | Host (mobile) side of transport to process remote commands and forward notifications - discoverer :: Async (), - supervisor :: Async (), - hostServer :: Maybe (Async ()), - discovered :: TMap C.KeyHash (TransportHost, Word16), - accepted :: TMVar RemoteCtrlId, + { discoverer :: Async (), -- multicast listener + supervisor :: Async (), -- session state/subprocess supervisor + hostServer :: Maybe (Async ()), -- a running session + discovered :: TMap C.KeyHash (TransportHost, Word16), -- multicast-announced services + confirmed :: TMVar RemoteCtrlId, -- connection fingerprint found/stored in DB + verified :: TMVar (RemoteCtrlId, Text), -- user confirmed the session remoteOutputQ :: TBQueue ChatResponse } diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index cc3eb9f199..cb943ac2c5 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -7,7 +8,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} - {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Simplex.Chat.Remote where @@ -41,7 +41,7 @@ import Simplex.Chat.Controller import Simplex.Chat.Files import Simplex.Chat.Messages (chatNameStr) import Simplex.Chat.Remote.Protocol -import Simplex.Chat.Remote.RevHTTP (announceRevHTTP2, connectRevHTTP2) +import Simplex.Chat.Remote.RevHTTP (announceRevHTTP2, attachHTTP2Server) import Simplex.Chat.Remote.Transport import Simplex.Chat.Remote.Types import Simplex.Chat.Store.Files @@ -56,6 +56,7 @@ import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding (smpDecode) import Simplex.Messaging.Encoding.String (StrEncoding (..)) import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.Transport (tlsUniq) import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) import Simplex.Messaging.Transport.HTTP2.File (hSendFile) @@ -65,6 +66,7 @@ import qualified Simplex.RemoteControl.Discovery as Discovery import Simplex.RemoteControl.Types import System.FilePath (takeFileName, ()) import UnliftIO +import UnliftIO.Concurrent (threadDelay) import UnliftIO.Directory (copyFile, createDirectoryIfMissing, renameFile) -- * Desktop side @@ -93,13 +95,15 @@ startRemoteHost rhId = do rh <- withStore (`getRemoteHost` rhId) tasks <- startRemoteHostSession rh logInfo $ "Remote host session starting for " <> tshow rhId - asyncRegistered tasks $ run rh tasks `catchAny` \err -> do - logError $ "Remote host session startup failed for " <> tshow rhId <> ": " <> tshow err - cancelTasks tasks - chatModifyVar remoteHostSessions $ M.delete rhId - throwError $ fromMaybe (mkChatError err) $ fromException err - -- logInfo $ "Remote host session starting for " <> tshow rhId + asyncRegistered tasks $ + run rh tasks `catchAny` \err -> do + logError $ "Remote host session startup failed for " <> tshow rhId <> ": " <> tshow err + cancelTasks tasks + chatModifyVar remoteHostSessions $ M.delete rhId + throwError $ fromMaybe (mkChatError err) $ fromException err where + -- logInfo $ "Remote host session starting for " <> tshow rhId + run :: ChatMonad m => RemoteHost -> Tasks -> m () run rh@RemoteHost {storePath} tasks = do (fingerprint, credentials) <- liftIO $ genSessionCredentials rh @@ -109,7 +113,7 @@ startRemoteHost rhId = do chatModifyVar currentRemoteHost $ \cur -> if cur == Just rhId then Nothing else cur -- only wipe the closing RH withRemoteHostSession rhId $ \sessions _ -> Right <$> TM.delete rhId sessions toView (CRRemoteHostStopped rhId) -- only signal "stopped" when the session is unregistered cleanly - -- block until some client is connected or an error happens + -- block until some client is connected or an error happens logInfo $ "Remote host session connecting for " <> tshow rhId rcName <- chatReadVar localDeviceName localAddr <- asks multicastSubscribers >>= Discovery.getLocalAddress >>= maybe (throwError . ChatError $ CEInternalError "unable to get local address") pure @@ -127,12 +131,14 @@ startRemoteHost rhId = do logInfo $ "Remote host session started for " <> tshow rhId chatModifyVar remoteHostSessions $ M.adjust (\rhs -> rhs {remoteHostClient = Just remoteHostClient}) rhId chatWriteVar currentRemoteHost $ Just rhId - toView $ CRRemoteHostConnected RemoteHostInfo - { remoteHostId = rhId, - storePath = storePath, - displayName = hostDeviceName remoteHostClient, - sessionActive = True - } + toView $ + CRRemoteHostConnected + RemoteHostInfo + { remoteHostId = rhId, + storePath = storePath, + displayName = hostDeviceName remoteHostClient, + sessionActive = True + } genSessionCredentials RemoteHost {caKey, caCert} = do sessionCreds <- genCredentials (Just parent) (0, 24) "Session" @@ -251,34 +257,48 @@ liftRH rhId = liftError (ChatErrorRemoteHost rhId . RHProtocolError) -- * Mobile side -startRemoteCtrl :: forall m . ChatMonad m => (ByteString -> m ChatResponse) -> m () -startRemoteCtrl execChatCommand = do +findKnownRemoteCtrl :: forall m. ChatMonad m => (ByteString -> m ChatResponse) -> m () +findKnownRemoteCtrl execChatCommand = do logInfo "Starting remote host" checkNoRemoteCtrlSession -- tiny race with the final @chatWriteVar@ until the setup finishes and supervisor spawned discovered <- newTVarIO mempty discoverer <- async $ discoverRemoteCtrls discovered -- TODO extract to a controller service singleton size <- asks $ tbqSize . config remoteOutputQ <- newTBQueueIO size - accepted <- newEmptyTMVarIO - supervisor <- async $ runHost discovered accepted $ handleRemoteCommand execChatCommand remoteOutputQ - chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, accepted, remoteOutputQ} + confirmed <- newEmptyTMVarIO + verified <- newEmptyTMVarIO + supervisor <- async $ do + threadDelay 500000 -- give chat controller a chance to reply with "ok" to prevent flaking tests + runHost discovered confirmed verified $ handleRemoteCommand execChatCommand remoteOutputQ + chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, confirmed, verified, remoteOutputQ} -- | Track remote host lifecycle in controller session state and signal UI on its progress -runHost :: ChatMonad m => TM.TMap C.KeyHash (TransportHost, Word16) -> TMVar RemoteCtrlId -> (HTTP2Request -> m ()) -> m () -runHost discovered accepted handleHttp = do - remoteCtrlId <- atomically (readTMVar accepted) -- wait for ??? +runHost :: ChatMonad m => TM.TMap C.KeyHash (TransportHost, Word16) -> TMVar RemoteCtrlId -> TMVar (RemoteCtrlId, Text) -> (HTTP2Request -> m ()) -> m () +runHost discovered confirmed verified handleHttp = do + remoteCtrlId <- atomically (readTMVar confirmed) -- wait for discoverRemoteCtrls.process or confirmRemoteCtrl to confirm fingerprint as a known RC rc@RemoteCtrl {fingerprint} <- withStore (`getRemoteCtrl` remoteCtrlId) serviceAddress <- atomically $ TM.lookup fingerprint discovered >>= maybe retry pure -- wait for location of the matching fingerprint toView $ CRRemoteCtrlConnecting $ remoteCtrlInfo rc False atomically $ writeTVar discovered mempty -- flush unused sources - server <- async $ connectRevHTTP2 serviceAddress fingerprint handleHttp -- spawn server for remote protocol commands + server <- async $ + -- spawn server for remote protocol commands + Discovery.connectTLSClient serviceAddress fingerprint $ \tls -> do + let sessionCode = decodeUtf8 . strEncode $ tlsUniq tls + toView $ CRRemoteCtrlSessionCode {remoteCtrl = remoteCtrlInfo rc True, sessionCode, newCtrl = False} + userInfo <- atomically $ readTMVar verified + if userInfo == (remoteCtrlId, sessionCode) + then do + toView $ CRRemoteCtrlConnected $ remoteCtrlInfo rc True + attachHTTP2Server handleHttp tls + else do + toView $ CRChatCmdError Nothing $ ChatErrorRemoteCtrl RCEBadVerificationCode + -- the server doesn't enter its loop and waitCatch below falls through chatModifyVar remoteCtrlSession $ fmap $ \s -> s {hostServer = Just server} - toView $ CRRemoteCtrlConnected $ remoteCtrlInfo rc True _ <- waitCatch server -- wait for the server to finish chatWriteVar remoteCtrlSession Nothing toView CRRemoteCtrlStopped -handleRemoteCommand :: forall m . ChatMonad m => (ByteString -> m ChatResponse) -> TBQueue ChatResponse -> HTTP2Request -> m () +handleRemoteCommand :: forall m. ChatMonad m => (ByteString -> m ChatResponse) -> TBQueue ChatResponse -> HTTP2Request -> m () handleRemoteCommand execChatCommand remoteOutputQ HTTP2Request {request, reqBody, sendResponse} = do logDebug "handleRemoteCommand" liftRC (tryRemoteError parseRequest) >>= \case @@ -358,7 +378,7 @@ handleStoreFile fileName fileSize fileDigest getChunk = pure filePath handleGetFile :: ChatMonad m => User -> RemoteFile -> Respond m -> m () -handleGetFile User {userId} RemoteFile{userId = commandUserId, fileId, sent, fileSource = cf'@CryptoFile {filePath}} reply = do +handleGetFile User {userId} RemoteFile {userId = commandUserId, fileId, sent, fileSource = cf'@CryptoFile {filePath}} reply = do logDebug $ "GetFile: " <> tshow filePath unless (userId == commandUserId) $ throwChatError $ CEDifferentActiveUser {commandUserId, activeUserId = userId} path <- maybe filePath ( filePath) <$> chatReadVar filesFolder @@ -385,7 +405,7 @@ discoverRemoteCtrls discovered = do Left _ -> receive sock -- TODO it is probably better to report errors to view here _nonV4 -> receive sock - process sock (sockAddr, Announce {caFingerprint, serviceAddress=(annAddr, port)}) = do + process sock (sockAddr, Announce {caFingerprint, serviceAddress = (annAddr, port)}) = do unless (annAddr == sockAddr) $ logError "Announced address doesn't match socket address" let addr = THIPv4 (hostAddressToTuple sockAddr) ifM @@ -406,13 +426,13 @@ discoverRemoteCtrls discovered = do Just True -> chatReadVar remoteCtrlSession >>= \case Nothing -> toView . CRChatError Nothing . ChatError $ CEInternalError "Remote host found without running a session" - Just RemoteCtrlSession {accepted} -> atomically $ void $ tryPutTMVar accepted remoteCtrlId -- previously accepted controller, connect automatically + Just RemoteCtrlSession {confirmed} -> atomically $ void $ tryPutTMVar confirmed remoteCtrlId -- previously accepted controller, connect automatically listRemoteCtrls :: ChatMonad m => m [RemoteCtrlInfo] listRemoteCtrls = do active <- - chatReadVar remoteCtrlSession - $>>= \RemoteCtrlSession {accepted} -> atomically $ tryReadTMVar accepted + chatReadVar remoteCtrlSession $>>= \RemoteCtrlSession {confirmed} -> + atomically $ tryReadTMVar confirmed map (rcInfo active) <$> withStore' getRemoteCtrls where rcInfo activeRcId rc@RemoteCtrl {remoteCtrlId} = @@ -422,19 +442,17 @@ remoteCtrlInfo :: RemoteCtrl -> Bool -> RemoteCtrlInfo remoteCtrlInfo RemoteCtrl {remoteCtrlId, displayName, fingerprint, accepted} sessionActive = RemoteCtrlInfo {remoteCtrlId, displayName, fingerprint, accepted, sessionActive} -acceptRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m () -acceptRemoteCtrl rcId = do +confirmRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m () +confirmRemoteCtrl rcId = do -- TODO check it exists, check the ID is the same as in session - RemoteCtrlSession {accepted} <- getRemoteCtrlSession + RemoteCtrlSession {confirmed} <- getRemoteCtrlSession withStore' $ \db -> markRemoteCtrlResolution db rcId True - atomically . void $ tryPutTMVar accepted rcId -- the remote host can now proceed with connection + atomically . void $ tryPutTMVar confirmed rcId -- the remote host can now proceed with connection -rejectRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m () -rejectRemoteCtrl rcId = do - withStore' $ \db -> markRemoteCtrlResolution db rcId False - RemoteCtrlSession {discoverer, supervisor} <- getRemoteCtrlSession - cancel discoverer - cancel supervisor +verifyRemoteCtrlSession :: ChatMonad m => RemoteCtrlId -> Text -> m () +verifyRemoteCtrlSession rcId sessId = do + RemoteCtrlSession {verified} <- getRemoteCtrlSession + void . atomically $ tryPutTMVar verified (rcId, sessId) stopRemoteCtrl :: ChatMonad m => m () stopRemoteCtrl = do diff --git a/src/Simplex/Chat/Remote/RevHTTP.hs b/src/Simplex/Chat/Remote/RevHTTP.hs index c6c777596a..08c844dcf0 100644 --- a/src/Simplex/Chat/Remote/RevHTTP.hs +++ b/src/Simplex/Chat/Remote/RevHTTP.hs @@ -11,11 +11,9 @@ module Simplex.Chat.Remote.RevHTTP where import Simplex.RemoteControl.Discovery import Simplex.RemoteControl.Types import Control.Logger.Simple -import Data.Word (Word16) import qualified Network.TLS as TLS import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Transport as Transport -import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.HTTP2 (defaultHTTP2BufferSize, getHTTP2Body) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError (..), attachHTTP2Client, bodyHeadSize, connTimeout, defaultHTTP2ClientConfig) import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..), runHTTP2ServerWith) @@ -39,9 +37,6 @@ runHTTP2Client finishedVar clientVar tls = -- TODO connection timeout config = defaultHTTP2ClientConfig {bodyHeadSize = doNotPrefetchHead, connTimeout = maxBound} -connectRevHTTP2 :: (MonadUnliftIO m) => (TransportHost, Word16) -> C.KeyHash -> (HTTP2Request -> m ()) -> m () -connectRevHTTP2 serviceAddress fingerprint = connectTLSClient serviceAddress fingerprint . attachHTTP2Server - attachHTTP2Server :: (MonadUnliftIO m) => (HTTP2Request -> m ()) -> Transport.TLS -> m () attachHTTP2Server processRequest tls = do withRunInIO $ \unlift -> diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index ed4b768cd8..8779480a5c 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -275,17 +275,26 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRRemoteHostCreated RemoteHostInfo {remoteHostId} -> ["remote host " <> sShow remoteHostId <> " created"] CRRemoteHostList hs -> viewRemoteHosts hs CRRemoteHostStarted {remoteHost = RemoteHostInfo {remoteHostId = rhId}, sessionOOB} -> ["remote host " <> sShow rhId <> " started", "connection code:", plain sessionOOB] + CRRemoteHostSessionCode {remoteHost = RemoteHostInfo {remoteHostId = rhId}, sessionCode} -> + ["remote host " <> sShow rhId <> " is connecting", "Compare session code with host:", plain sessionCode] CRRemoteHostConnected RemoteHostInfo {remoteHostId = rhId} -> ["remote host " <> sShow rhId <> " connected"] CRRemoteHostStopped rhId -> ["remote host " <> sShow rhId <> " stopped"] CRRemoteFileStored rhId (CryptoFile filePath cfArgs_) -> [plain $ "file " <> filePath <> " stored on remote host " <> show rhId] <> maybe [] ((: []) . plain . cryptoFileArgsStr testView) cfArgs_ CRRemoteCtrlList cs -> viewRemoteCtrls cs - CRRemoteCtrlRegistered RemoteCtrlInfo {remoteCtrlId = rcId} -> ["remote controller " <> sShow rcId <> " registered"] - CRRemoteCtrlAnnounce fingerprint -> ["remote controller announced", "connection code:", plain $ strEncode fingerprint] - CRRemoteCtrlFound rc -> ["remote controller found:", viewRemoteCtrl rc] - CRRemoteCtrlConnecting RemoteCtrlInfo {remoteCtrlId = rcId, displayName = rcName} -> ["remote controller " <> sShow rcId <> " connecting to " <> plain rcName] - CRRemoteCtrlConnected RemoteCtrlInfo {remoteCtrlId = rcId, displayName = rcName} -> ["remote controller " <> sShow rcId <> " connected, " <> plain rcName] + CRRemoteCtrlRegistered RemoteCtrlInfo {remoteCtrlId = rcId} -> + ["remote controller " <> sShow rcId <> " registered"] + CRRemoteCtrlAnnounce fingerprint -> + ["remote controller announced", "connection code:", plain $ strEncode fingerprint] + CRRemoteCtrlFound rc -> + ["remote controller found:", viewRemoteCtrl rc] + CRRemoteCtrlConnecting RemoteCtrlInfo {remoteCtrlId = rcId, displayName = rcName} -> + ["remote controller " <> sShow rcId <> " connecting to " <> plain rcName] + CRRemoteCtrlSessionCode {remoteCtrl = RemoteCtrlInfo {remoteCtrlId = rcId, displayName = rcName}, sessionCode} -> + ["remote controller " <> sShow rcId <> " connected to " <> plain rcName, "Compare session code with controller and use:", "/verify remote ctrl " <> sShow rcId <> " " <> plain sessionCode] + CRRemoteCtrlConnected RemoteCtrlInfo {remoteCtrlId = rcId, displayName = rcName} -> + ["remote controller " <> sShow rcId <> " session started with " <> plain rcName] CRRemoteCtrlStopped -> ["remote controller stopped"] CRSQLResult rows -> map plain rows CRSlowSQLQueries {chatQueries, agentQueries} -> diff --git a/tests/RemoteTests.hs b/tests/RemoteTests.hs index 7c62333d66..b2e7aa5cb1 100644 --- a/tests/RemoteTests.hs +++ b/tests/RemoteTests.hs @@ -30,7 +30,7 @@ import Simplex.Chat.Remote.Types import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFileArgs (..)) import Simplex.Messaging.Encoding (smpDecode) -import Simplex.Messaging.Encoding.String (strDecode, strEncode) +import Simplex.Messaging.Encoding.String (strEncode) import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials) import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Response (..), closeHTTP2Client, sendRequest) @@ -408,7 +408,7 @@ startRemote mobile desktop = do mobile ##> "/set device name Mobile" mobile <## "ok" - mobile ##> "/start remote ctrl" + mobile ##> "/find remote ctrl" mobile <## "ok" mobile <## "remote controller announced" mobile <## "connection code:" @@ -416,13 +416,20 @@ startRemote mobile desktop = do -- The user scans OOB QR code and confirms it matches the announced stuff fromString annFingerprint `shouldBe` strEncode oobFingerprint - mobile ##> ("/register remote ctrl " <> oobLink) + mobile ##> ("/connect remote ctrl " <> oobLink) mobile <## "remote controller 1 registered" - mobile ##> "/accept remote ctrl 1" - mobile <## "ok" -- alternative scenario: accepted before controller start + mobile ##> "/confirm remote ctrl 1" + mobile <## "ok" mobile <## "remote controller 1 connecting to My desktop" - mobile <## "remote controller 1 connected, My desktop" - desktop <## "remote host 1 connected" + -- TODO: rework tls connection prelude + mobile <## "remote controller 1 connected to My desktop" + mobile <## "Compare session code with controller and use:" + verifyCmd <- getTermLine mobile + mobile ##> verifyCmd + mobile <## "ok" + concurrently_ + (mobile <## "remote controller 1 session started with My desktop") + (desktop <## "remote host 1 connected") contactBob :: TestCC -> TestCC -> IO () contactBob desktop bob = do