From b71daed3ec02cc139d2639fc2cf821fdad8ac588 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 15 Nov 2023 13:17:31 +0000 Subject: [PATCH] core: include session code in all session states (#3374) --- src/Simplex/Chat.hs | 3 +- src/Simplex/Chat/Controller.hs | 32 ++++++++++++++++++-- src/Simplex/Chat/Remote.hs | 52 ++++++++++++++++++-------------- src/Simplex/Chat/Remote/Types.hs | 27 ++++++++--------- src/Simplex/Chat/View.hs | 13 +++++--- 5 files changed, 82 insertions(+), 45 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 619f93b891..b6b7cca1a6 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -1967,8 +1967,7 @@ processChatCommand = \case StoreRemoteFile rh encrypted_ localPath -> withUser_ $ CRRemoteFileStored rh <$> storeRemoteFile rh encrypted_ localPath GetRemoteFile rh rf -> withUser_ $ getRemoteFile rh rf >> ok_ ConnectRemoteCtrl inv -> withUser_ $ do - (rc_, ctrlAppInfo) <- connectRemoteCtrl inv - let remoteCtrl_ = (`remoteCtrlInfo` True) <$> rc_ + (remoteCtrl_, ctrlAppInfo) <- connectRemoteCtrl inv pure CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo, appVersion = currentAppVersion} FindKnownRemoteCtrl -> withUser_ $ findKnownRemoteCtrl >> ok_ ConfirmRemoteCtrl rc -> withUser_ $ confirmRemoteCtrl rc >> ok_ diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 3144c909df..fb03844f89 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -1077,11 +1077,13 @@ data ArchiveError data RemoteCtrlSession = RCSessionStarting | RCSessionConnecting - { rcsClient :: RCCtrlClient, + { remoteCtrlId_ :: Maybe RemoteCtrlId, + rcsClient :: RCCtrlClient, rcsWaitSession :: Async () } | RCSessionPendingConfirmation - { ctrlDeviceName :: Text, + { remoteCtrlId_ :: Maybe RemoteCtrlId, + ctrlDeviceName :: Text, rcsClient :: RCCtrlClient, tls :: TLS, sessionCode :: Text, @@ -1097,6 +1099,28 @@ data RemoteCtrlSession remoteOutputQ :: TBQueue ChatResponse } +data RemoteCtrlSessionState + = RCSStarting + | RCSConnecting + | RCSPendingConfirmation {sessionCode :: Text} + | RCSConnected {sessionCode :: Text} + deriving (Show) + +rcsSessionState :: RemoteCtrlSession -> RemoteCtrlSessionState +rcsSessionState = \case + RCSessionStarting -> RCSStarting + RCSessionConnecting {} -> RCSConnecting + RCSessionPendingConfirmation {tls} -> RCSPendingConfirmation {sessionCode = tlsSessionCode tls} + RCSessionConnected {tls} -> RCSConnected {sessionCode = tlsSessionCode tls} + +-- | UI-accessible remote controller information +data RemoteCtrlInfo = RemoteCtrlInfo + { remoteCtrlId :: RemoteCtrlId, + ctrlDeviceName :: Text, + sessionState :: Maybe RemoteCtrlSessionState + } + deriving (Show) + type ChatMonad' m = (MonadUnliftIO m, MonadReader ChatController m) type ChatMonad m = (ChatMonad' m, MonadError ChatError m) @@ -1259,6 +1283,10 @@ instance ToJSON AUserProtoServers where toJSON (AUPS s) = $(JQ.mkToJSON defaultJSON ''UserProtoServers) s toEncoding (AUPS s) = $(JQ.mkToEncoding defaultJSON ''UserProtoServers) s +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCS") ''RemoteCtrlSessionState) + +$(JQ.deriveJSON defaultJSON ''RemoteCtrlInfo) + $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CR") ''ChatResponse) $(JQ.deriveFromJSON defaultJSON ''ArchiveConfig) diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index 05183c1d8d..16044ee923 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -166,13 +166,13 @@ startRemoteHost rh_ = do waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m () waitForHostSession remoteHost_ rhKey rhKeyVar vars = do (sessId, tls, vars') <- takeRCStep vars -- no timeout, waiting for user to scan invite - let sessCode = verificationCode sessId + let sessionCode = verificationCode sessId withRemoteHostSession rhKey $ \case - RHSessionConnecting _inv rhs' -> Right ((), RHSessionPendingConfirmation sessCode tls rhs') -- TODO check it's the same session? + RHSessionConnecting _inv rhs' -> Right ((), RHSessionPendingConfirmation sessionCode tls rhs') -- TODO check it's the same session? _ -> Left $ ChatErrorRemoteHost rhKey RHEBadState -- display confirmation code, wait for mobile to confirm - let rh_' = (\rh -> rh {sessionState = Just $ RHSPendingConfirmation sessCode}) <$> remoteHost_ - toView $ CRRemoteHostSessionCode {remoteHost_ = rh_', sessionCode = verificationCode sessId} + let rh_' = (\rh -> (rh :: RemoteHostInfo) {sessionState = Just $ RHSPendingConfirmation {sessionCode}}) <$> remoteHost_ + toView $ CRRemoteHostSessionCode {remoteHost_ = rh_', sessionCode} (RCHostSession {sessionKeys}, rhHello, pairing') <- takeRCStep vars' -- no timeout, waiting for user to compare the code hostInfo@HostAppInfo {deviceName = hostDeviceName} <- liftError (ChatErrorRemoteHost rhKey) $ parseHostAppInfo rhHello @@ -180,7 +180,7 @@ startRemoteHost rh_ = do RHSessionPendingConfirmation _ tls' rhs' -> Right ((), RHSessionConfirmed tls' rhs') -- TODO check it's the same session? _ -> Left $ ChatErrorRemoteHost rhKey RHEBadState -- update remoteHost with updated pairing - rhi@RemoteHostInfo {remoteHostId, storePath} <- upsertRemoteHost pairing' rh_' hostDeviceName RHSConfirmed + rhi@RemoteHostInfo {remoteHostId, storePath} <- upsertRemoteHost pairing' rh_' hostDeviceName RHSConfirmed {sessionCode} let rhKey' = RHId remoteHostId -- rhKey may be invalid after upserting on RHNew when (rhKey' /= rhKey) $ do atomically $ writeTVar rhKeyVar rhKey' @@ -193,7 +193,7 @@ startRemoteHost rh_ = do RHSessionConfirmed _ RHPendingSession {rchClient} -> Right ((), RHSessionConnected {rchClient, tls, rhClient, pollAction, storePath}) _ -> Left $ ChatErrorRemoteHost rhKey' RHEBadState chatWriteVar currentRemoteHost $ Just remoteHostId -- this is required for commands to be passed to remote host - toView $ CRRemoteHostConnected rhi {sessionState = Just RHSConnected} + toView $ CRRemoteHostConnected rhi {sessionState = Just RHSConnected {sessionCode}} upsertRemoteHost :: ChatMonad m => RCHostPairing -> Maybe RemoteHostInfo -> Text -> RemoteHostSessionState -> m RemoteHostInfo upsertRemoteHost pairing'@RCHostPairing {knownHost = kh_} rhi_ hostDeviceName state = do KnownHostPairing {hostDhPubKey = hostDhPubKey'} <- maybe (throwError . ChatError $ CEInternalError "KnownHost is known after verification") pure kh_ @@ -268,7 +268,7 @@ switchRemoteHost rhId_ = do rh <- withStore (`getRemoteHost` rhId) sessions <- chatReadVar remoteHostSessions case M.lookup rhKey sessions of - Just RHSessionConnected {} -> pure $ remoteHostInfo rh $ Just RHSConnected + Just RHSessionConnected {tls} -> pure $ remoteHostInfo rh $ Just RHSConnected {sessionCode = tlsSessionCode tls} _ -> throwError $ ChatErrorRemoteHost rhKey RHEInactive rhi_ <$ chatWriteVar currentRemoteHost rhId_ @@ -341,7 +341,7 @@ findKnownRemoteCtrl :: ChatMonad m => m () findKnownRemoteCtrl = undefined -- do -- | Use provided OOB link as an annouce -connectRemoteCtrl :: ChatMonad m => RCSignedInvitation -> m (Maybe RemoteCtrl, CtrlAppInfo) +connectRemoteCtrl :: ChatMonad m => RCSignedInvitation -> m (Maybe RemoteCtrlInfo, CtrlAppInfo) connectRemoteCtrl signedInv@RCSignedInvitation {invitation = inv@RCInvitation {ca, app}} = handleCtrlError "connectRemoteCtrl" $ do (ctrlInfo@CtrlAppInfo {deviceName = ctrlDeviceName}, v) <- parseCtrlAppInfo app withRemoteCtrlSession_ $ maybe (Right ((), Just RCSessionStarting)) (\_ -> Left $ ChatErrorRemoteCtrl RCEBusy) @@ -355,10 +355,10 @@ connectRemoteCtrl signedInv@RCSignedInvitation {invitation = inv@RCInvitation {c atomically $ takeTMVar cmdOk handleCtrlError "waitForCtrlSession" $ waitForCtrlSession rc_ ctrlDeviceName rcsClient vars updateRemoteCtrlSession $ \case - RCSessionStarting -> Right RCSessionConnecting {rcsClient, rcsWaitSession} + RCSessionStarting -> Right RCSessionConnecting {remoteCtrlId_ = remoteCtrlId' <$> rc_, rcsClient, rcsWaitSession} _ -> Left $ ChatErrorRemoteCtrl RCEBadState atomically $ putTMVar cmdOk () - pure (rc_, ctrlInfo) + pure ((`remoteCtrlInfo` Just RCSConnecting) <$> rc_, ctrlInfo) where validateRemoteCtrl RCInvitation {idkey} RemoteCtrl {ctrlPairing = RCCtrlPairing {idPubKey}} = unless (idkey == idPubKey) $ throwError $ ChatErrorRemoteCtrl $ RCEProtocolError $ PRERemoteControl RCEIdentity @@ -366,10 +366,12 @@ connectRemoteCtrl signedInv@RCSignedInvitation {invitation = inv@RCInvitation {c waitForCtrlSession rc_ ctrlName rcsClient vars = do (uniq, tls, rcsWaitConfirmation) <- timeoutThrow (ChatErrorRemoteCtrl RCETimeout) networkIOTimeout $ takeRCStep vars let sessionCode = verificationCode uniq - toView CRRemoteCtrlSessionCode {remoteCtrl_ = (`remoteCtrlInfo` True) <$> rc_, sessionCode} updateRemoteCtrlSession $ \case - RCSessionConnecting {rcsWaitSession} -> Right RCSessionPendingConfirmation {ctrlDeviceName = ctrlName, rcsClient, tls, sessionCode, rcsWaitSession, rcsWaitConfirmation} + RCSessionConnecting {rcsWaitSession} -> + let remoteCtrlId_ = remoteCtrlId' <$> rc_ + in Right RCSessionPendingConfirmation {remoteCtrlId_, ctrlDeviceName = ctrlName, rcsClient, tls, sessionCode, rcsWaitSession, rcsWaitConfirmation} _ -> Left $ ChatErrorRemoteCtrl RCEBadState + toView CRRemoteCtrlSessionCode {remoteCtrl_ = (`remoteCtrlInfo` Just RCSPendingConfirmation {sessionCode}) <$> rc_, sessionCode} parseCtrlAppInfo ctrlAppInfo = do ctrlInfo@CtrlAppInfo {appVersionRange} <- liftEitherWith (const $ ChatErrorRemoteCtrl RCEBadInvitation) $ JT.parseEither J.parseJSON ctrlAppInfo @@ -481,17 +483,23 @@ discoverRemoteCtrls discovered = do listRemoteCtrls :: ChatMonad m => m [RemoteCtrlInfo] listRemoteCtrls = do - active <- chatReadVar remoteCtrlSession >>= \case - Just RCSessionConnected {remoteCtrlId} -> pure $ Just remoteCtrlId - _ -> pure Nothing - map (rcInfo active) <$> withStore' getRemoteCtrls + session <- chatReadVar remoteCtrlSession + let rcId = sessionRcId =<< session + sessState = rcsSessionState <$> session + map (rcInfo rcId sessState) <$> withStore' getRemoteCtrls where - rcInfo activeRcId rc@RemoteCtrl {remoteCtrlId} = - remoteCtrlInfo rc $ activeRcId == Just remoteCtrlId + rcInfo :: Maybe RemoteCtrlId -> Maybe RemoteCtrlSessionState -> RemoteCtrl -> RemoteCtrlInfo + rcInfo rcId sessState rc@RemoteCtrl {remoteCtrlId} = + remoteCtrlInfo rc $ if rcId == Just remoteCtrlId then sessState else Nothing + sessionRcId = \case + RCSessionConnecting {remoteCtrlId_} -> remoteCtrlId_ + RCSessionPendingConfirmation {remoteCtrlId_} -> remoteCtrlId_ + RCSessionConnected {remoteCtrlId} -> Just remoteCtrlId + _ -> Nothing -remoteCtrlInfo :: RemoteCtrl -> Bool -> RemoteCtrlInfo -remoteCtrlInfo RemoteCtrl {remoteCtrlId, ctrlDeviceName} sessionActive = - RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName, sessionActive} +remoteCtrlInfo :: RemoteCtrl -> Maybe RemoteCtrlSessionState -> RemoteCtrlInfo +remoteCtrlInfo RemoteCtrl {remoteCtrlId, ctrlDeviceName} sessionState = + RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName, sessionState} -- XXX: only used for multicast confirmRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m () @@ -521,7 +529,7 @@ verifyRemoteCtrlSession execChatCommand sessCode' = handleCtrlError "verifyRemot withRemoteCtrlSession $ \case RCSessionPendingConfirmation {} -> Right ((), RCSessionConnected {remoteCtrlId, rcsClient = client, rcsSession, tls, http2Server, remoteOutputQ}) _ -> Left $ ChatErrorRemoteCtrl RCEBadState - pure $ remoteCtrlInfo rc True + pure $ remoteCtrlInfo rc $ Just RCSConnected {sessionCode = tlsSessionCode tls} where upsertRemoteCtrl :: ChatMonad m => Text -> RCCtrlPairing -> m RemoteCtrl upsertRemoteCtrl ctrlName rcCtrlPairing = withStore $ \db -> do diff --git a/src/Simplex/Chat/Remote/Types.hs b/src/Simplex/Chat/Remote/Types.hs index ce28040481..c56b2462b0 100644 --- a/src/Simplex/Chat/Remote/Types.hs +++ b/src/Simplex/Chat/Remote/Types.hs @@ -19,6 +19,7 @@ import Data.ByteString (ByteString) import Data.Int (Int64) import Data.Text (Text) import Simplex.Chat.Remote.AppVersion +import Simplex.Chat.Types (verificationCode) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON) @@ -26,7 +27,7 @@ import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client) import Simplex.RemoteControl.Client import Simplex.RemoteControl.Types import Simplex.Messaging.Crypto.File (CryptoFile) -import Simplex.Messaging.Transport (TLS) +import Simplex.Messaging.Transport (TLS (..)) data RemoteHostClient = RemoteHostClient { hostEncoding :: PlatformEncoding, @@ -79,17 +80,20 @@ data RemoteHostSessionState = RHSStarting | RHSConnecting {invitation :: Text} | RHSPendingConfirmation {sessionCode :: Text} - | RHSConfirmed - | RHSConnected + | RHSConfirmed {sessionCode :: Text} + | RHSConnected {sessionCode :: Text} deriving (Show) rhsSessionState :: RemoteHostSession -> RemoteHostSessionState rhsSessionState = \case RHSessionStarting -> RHSStarting RHSessionConnecting {invitation} -> RHSConnecting {invitation} - RHSessionPendingConfirmation {sessionCode} -> RHSPendingConfirmation {sessionCode} - RHSessionConfirmed {} -> RHSConfirmed - RHSessionConnected {} -> RHSConnected + RHSessionPendingConfirmation {tls} -> RHSPendingConfirmation {sessionCode = tlsSessionCode tls} + RHSessionConfirmed {tls} -> RHSConfirmed {sessionCode = tlsSessionCode tls} + RHSessionConnected {tls} -> RHSConnected {sessionCode = tlsSessionCode tls} + +tlsSessionCode :: TLS -> Text +tlsSessionCode = verificationCode . tlsUniq data RemoteProtocolError = -- | size prefix is malformed @@ -143,13 +147,8 @@ data RemoteCtrl = RemoteCtrl ctrlPairing :: RCCtrlPairing } --- | UI-accessible remote controller information -data RemoteCtrlInfo = RemoteCtrlInfo - { remoteCtrlId :: RemoteCtrlId, - ctrlDeviceName :: Text, - sessionActive :: Bool - } - deriving (Show) +remoteCtrlId' :: RemoteCtrl -> RemoteCtrlId +remoteCtrlId' = remoteCtrlId data PlatformEncoding = PESwift @@ -196,8 +195,6 @@ $(J.deriveJSON (sumTypeJSON $ dropPrefix "RHS") ''RemoteHostSessionState) $(J.deriveJSON defaultJSON ''RemoteHostInfo) -$(J.deriveJSON defaultJSON ''RemoteCtrlInfo) - $(J.deriveJSON defaultJSON ''CtrlAppInfo) $(J.deriveJSON defaultJSON ''HostAppInfo) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 544614e23b..98a3edd478 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -1710,16 +1710,21 @@ viewRemoteHosts = \case RHSStarting -> " (starting)" RHSConnecting _ -> " (connecting)" RHSPendingConfirmation {sessionCode} -> " (pending confirmation, code: " <> sessionCode <> ")" - RHSConfirmed -> " (confirmed)" - RHSConnected -> " (connected)" + RHSConfirmed _ -> " (confirmed)" + RHSConnected _ -> " (connected)" viewRemoteCtrls :: [RemoteCtrlInfo] -> [StyledString] viewRemoteCtrls = \case [] -> ["No remote controllers"] hs -> "Remote controllers: " : map viewRemoteCtrlInfo hs where - viewRemoteCtrlInfo RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName, sessionActive} = - plain $ tshow remoteCtrlId <> ". " <> ctrlDeviceName <> if sessionActive then " (connected)" else "" + viewRemoteCtrlInfo RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName, sessionState} = + plain $ tshow remoteCtrlId <> ". " <> ctrlDeviceName <> maybe "" viewSessionState sessionState + viewSessionState = \case + RCSStarting -> " (starting)" + RCSConnecting -> " (connecting)" + RCSPendingConfirmation {sessionCode} -> " (pending confirmation, code: " <> sessionCode <> ")" + RCSConnected _ -> " (connected)" -- TODO fingerprint, accepted? viewRemoteCtrl :: RemoteCtrlInfo -> StyledString