core: include session code in all session states (#3374)

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_

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)

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

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)

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