core: update remote host session state, terminate TLS in one more case (#3364)

* core: update remote host session state, terminate TLS in one more case

* name

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: 4f5d52ada47a15532766b2ff3d3781be629648d8
+    tag: e0b7942e45e36d92625e07c0c1ce9ca2375a0980
 
 source-repository-package
     type: git

scripts/nix/sha256map.nix

@@ -1,5 +1,5 @@
 {
-  "https://github.com/simplex-chat/simplexmq.git"."c051ebab74632e0eb60686329ab3fad521736f79" = "1j7z3v3vk02nq4sw46flky1l4pjxfiypbwh5s77m6f81rc0vsjvi";
+  "https://github.com/simplex-chat/simplexmq.git"."e0b7942e45e36d92625e07c0c1ce9ca2375a0980" = "0swbcrmdirwqrk0kx5jmc5lcrzasccfwn3papb5c1p8hn0hjnzj7";
   "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
   "https://github.com/kazu-yamamoto/http2.git"."f5525b755ff2418e6e6ecc69e877363b0d0bcaeb" = "0fyx0047gvhm99ilp212mmz37j84cwrfnpmssib5dw363fyb88b6";
   "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";

src/Simplex/Chat/Remote.hs

@@ -32,7 +32,7 @@ import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
+import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Word (Word16, Word32)
 import qualified Network.HTTP.Types as N
 import Network.HTTP2.Server (responseStreaming)
@@ -129,7 +129,7 @@ startRemoteHost rh_ = do
   (rhKey, multicast, remoteHost_, pairing) <- case rh_ of
     Just (rhId, multicast) -> do
       rh@RemoteHost {hostPairing} <- withStore $ \db -> getRemoteHost db rhId
-      pure (RHId rhId, multicast, Just $ remoteHostInfo rh True, hostPairing) -- get from the database, start multicast if requested
+      pure (RHId rhId, multicast, Just $ remoteHostInfo rh $ Just RHSStarting, hostPairing) -- get from the database, start multicast if requested
     Nothing -> (RHNew,False,Nothing,) <$> rcNewHostPairing
   withRemoteHostSession_ rhKey $ maybe (Right ((), Just RHSessionStarting)) (\_ -> Left $ ChatErrorRemoteHost rhKey RHEBusy)
   ctrlAppInfo <- mkCtrlAppInfo
@@ -141,7 +141,9 @@ startRemoteHost rh_ = do
     handleHostError rhKeyVar $ waitForHostSession remoteHost_ rhKey rhKeyVar vars
   let rhs = RHPendingSession {rhKey, rchClient, rhsWaitSession, remoteHost_}
   withRemoteHostSession rhKey $ \case
-    RHSessionStarting -> Right ((), RHSessionConnecting rhs)
+    RHSessionStarting ->
+      let inv = decodeLatin1 $ strEncode invitation
+       in Right ((), RHSessionConnecting inv rhs)
     _ -> Left $ ChatErrorRemoteHost rhKey RHEBadState
   (remoteHost_, invitation) <$ atomically (putTMVar cmdOk ())
   where
@@ -162,18 +164,22 @@ startRemoteHost rh_ = do
         sessions <- asks remoteHostSessions
         session_ <- atomically $ readTVar rhKeyVar >>= (`TM.lookupDelete` sessions)
         mapM_ (liftIO . cancelRemoteHost) session_
-    waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> TVar RHKey -> RCStepTMVar (ByteString, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m ()
+    waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m ()
     waitForHostSession remoteHost_ rhKey rhKeyVar vars = do
-      (sessId, vars') <- takeRCStep vars -- no timeout, waiting for user to scan invite
+      (sessId, tls, vars') <- takeRCStep vars -- no timeout, waiting for user to scan invite
+      let sessCode = verificationCode sessId
+      withRemoteHostSession rhKey $ \case
+        RHSessionConnecting _inv rhs' -> Right ((), RHSessionPendingConfirmation sessCode tls rhs') -- TODO check it's the same session?
+        _ -> Left $ ChatErrorRemoteHost rhKey RHEBadState
       toView $ CRRemoteHostSessionCode {remoteHost_, sessionCode = verificationCode sessId} -- display confirmation code, wait for mobile to confirm
-      (RCHostSession {tls, sessionKeys}, rhHello, pairing') <- takeRCStep vars' -- no timeout, waiting for user to compare the code
+      (RCHostSession {sessionKeys}, rhHello, pairing') <- takeRCStep vars' -- no timeout, waiting for user to compare the code
       hostInfo@HostAppInfo {deviceName = hostDeviceName} <-
         liftError (ChatErrorRemoteHost rhKey) $ parseHostAppInfo rhHello
       withRemoteHostSession rhKey $ \case
-        RHSessionConnecting rhs' -> Right ((), RHSessionConfirmed tls rhs') -- TODO check it's the same session?
+        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' remoteHost_ hostDeviceName
+      rhi@RemoteHostInfo {remoteHostId, storePath} <- upsertRemoteHost pairing' remoteHost_ hostDeviceName RHSConfirmed
       let rhKey' = RHId remoteHostId -- rhKey may be invalid after upserting on RHNew
       when (rhKey' /= rhKey) $ do
         atomically $ writeTVar rhKeyVar rhKey'
@@ -187,18 +193,18 @@ startRemoteHost rh_ = do
         _ -> Left $ ChatErrorRemoteHost rhKey' RHEBadState
       chatWriteVar currentRemoteHost $ Just remoteHostId -- this is required for commands to be passed to remote host
       toView $ CRRemoteHostConnected rhi
-    upsertRemoteHost :: ChatMonad m => RCHostPairing -> Maybe RemoteHostInfo -> Text -> m RemoteHostInfo
+    upsertRemoteHost :: ChatMonad m => RCHostPairing -> Maybe RemoteHostInfo -> Text -> RemoteHostSessionState -> m RemoteHostInfo
-    upsertRemoteHost pairing'@RCHostPairing {knownHost = kh_} rhi_ hostDeviceName = do
+    upsertRemoteHost pairing'@RCHostPairing {knownHost = kh_} rhi_ hostDeviceName state = do
       KnownHostPairing {hostDhPubKey = hostDhPubKey'} <- maybe (throwError . ChatError $ CEInternalError "KnownHost is known after verification") pure kh_
       case rhi_ of
         Nothing -> do
           storePath <- liftIO randomStorePath
           rh@RemoteHost {remoteHostId} <- withStore $ \db -> insertRemoteHost db hostDeviceName storePath pairing' >>= getRemoteHost db
           setNewRemoteHostId RHNew remoteHostId
-          pure $ remoteHostInfo rh True
+          pure $ remoteHostInfo rh $ Just state
         Just rhi@RemoteHostInfo {remoteHostId} -> do
           withStore' $ \db -> updateHostPairing db remoteHostId hostDeviceName hostDhPubKey'
-          pure (rhi :: RemoteHostInfo) {sessionActive = True}
+          pure (rhi :: RemoteHostInfo) {sessionState = Just state}
     onDisconnected :: ChatMonad m => RemoteHostId -> m ()
     onDisconnected remoteHostId = do
       logDebug "HTTP2 client disconnected"
@@ -225,7 +231,10 @@ closeRemoteHost rhKey = do
 cancelRemoteHost :: RemoteHostSession -> IO ()
 cancelRemoteHost = \case
   RHSessionStarting -> pure ()
-  RHSessionConnecting rhs -> cancelPendingSession rhs
+  RHSessionConnecting _inv rhs -> cancelPendingSession rhs
+  RHSessionPendingConfirmation _sessCode tls rhs -> do
+    cancelPendingSession rhs
+    closeConnection tls
   RHSessionConfirmed tls rhs -> do
     cancelPendingSession rhs
     closeConnection tls
@@ -245,26 +254,26 @@ randomStorePath = B.unpack . B64U.encode <$> getRandomBytes 12
 
 listRemoteHosts :: ChatMonad m => m [RemoteHostInfo]
 listRemoteHosts = do
-  active <- chatReadVar remoteHostSessions
+  sessions <- chatReadVar remoteHostSessions
-  map (rhInfo active) <$> withStore' getRemoteHosts
+  map (rhInfo sessions) <$> withStore' getRemoteHosts
   where
-    rhInfo active rh@RemoteHost {remoteHostId} =
+    rhInfo sessions rh@RemoteHost {remoteHostId} =
-      remoteHostInfo rh (M.member (RHId remoteHostId) active)
+      remoteHostInfo rh (rhsSessionState <$> M.lookup (RHId remoteHostId) sessions)
 
 switchRemoteHost :: ChatMonad m => Maybe RemoteHostId -> m (Maybe RemoteHostInfo)
 switchRemoteHost rhId_ = do
   rhi_ <- forM rhId_ $ \rhId -> do
     let rhKey = RHId rhId
-    rhi <- (`remoteHostInfo` True) <$> withStore (`getRemoteHost` rhId)
+    rh <- withStore (`getRemoteHost` rhId)
-    active <- chatReadVar remoteHostSessions
+    sessions <- chatReadVar remoteHostSessions
-    case M.lookup rhKey active of
+    case M.lookup rhKey sessions of
-      Just RHSessionConnected {} -> pure rhi
+      Just RHSessionConnected {} -> pure $ remoteHostInfo rh $ Just RHSConnected
       _ -> throwError $ ChatErrorRemoteHost rhKey RHEInactive
   rhi_ <$ chatWriteVar currentRemoteHost rhId_
 
-remoteHostInfo :: RemoteHost -> Bool -> RemoteHostInfo
+remoteHostInfo :: RemoteHost -> Maybe RemoteHostSessionState -> RemoteHostInfo
-remoteHostInfo RemoteHost {remoteHostId, storePath, hostDeviceName} sessionActive =
+remoteHostInfo RemoteHost {remoteHostId, storePath, hostDeviceName} sessionState =
-  RemoteHostInfo {remoteHostId, storePath, hostDeviceName, sessionActive}
+  RemoteHostInfo {remoteHostId, storePath, hostDeviceName, sessionState}
 
 deleteRemoteHost :: ChatMonad m => RemoteHostId -> m ()
 deleteRemoteHost rhId = do

src/Simplex/Chat/Remote/Types.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -63,7 +64,8 @@ data RHPendingSession = RHPendingSession
 
 data RemoteHostSession
   = RHSessionStarting
-  | RHSessionConnecting {rhPendingSession :: RHPendingSession}
+  | RHSessionConnecting {invitation :: Text, rhPendingSession :: RHPendingSession}
+  | RHSessionPendingConfirmation {sessionCode :: Text, tls :: TLS, rhPendingSession :: RHPendingSession}
   | RHSessionConfirmed {tls :: TLS, rhPendingSession :: RHPendingSession}
   | RHSessionConnected
     { rchClient :: RCHostClient,
@@ -73,6 +75,22 @@ data RemoteHostSession
       storePath :: FilePath
     }
 
+data RemoteHostSessionState
+  = RHSStarting
+  | RHSConnecting {invitation :: Text}
+  | RHSPendingConfirmation {sessionCode :: Text}
+  | RHSConfirmed
+  | RHSConnected
+  deriving (Show)
+
+rhsSessionState :: RemoteHostSession -> RemoteHostSessionState
+rhsSessionState = \case
+  RHSessionStarting -> RHSStarting
+  RHSessionConnecting {invitation} -> RHSConnecting {invitation}
+  RHSessionPendingConfirmation {sessionCode} -> RHSPendingConfirmation {sessionCode}
+  RHSessionConfirmed {} -> RHSConfirmed
+  RHSessionConnected {} -> RHSConnected
+
 data RemoteProtocolError
   = -- | size prefix is malformed
     RPEInvalidSize
@@ -112,7 +130,7 @@ data RemoteHostInfo = RemoteHostInfo
   { remoteHostId :: RemoteHostId,
     hostDeviceName :: Text,
     storePath :: FilePath,
-    sessionActive :: Bool
+    sessionState :: Maybe RemoteHostSessionState
   }
   deriving (Show)
 
@@ -174,6 +192,8 @@ $(J.deriveJSON (sumTypeJSON $ dropPrefix "RH") ''RHKey)
 
 $(J.deriveJSON (enumJSON $ dropPrefix "PE") ''PlatformEncoding)
 
+$(J.deriveJSON (sumTypeJSON $ dropPrefix "RHS") ''RemoteHostSessionState)
+
 $(J.deriveJSON defaultJSON ''RemoteHostInfo)
 
 $(J.deriveJSON defaultJSON ''RemoteCtrlInfo)

src/Simplex/Chat/View.hs

@@ -1704,8 +1704,14 @@ viewRemoteHosts = \case
   [] -> ["No remote hosts"]
   hs -> "Remote hosts: " : map viewRemoteHostInfo hs
   where
-    viewRemoteHostInfo RemoteHostInfo {remoteHostId, hostDeviceName, sessionActive} =
+    viewRemoteHostInfo RemoteHostInfo {remoteHostId, hostDeviceName, sessionState} =
-      plain $ tshow remoteHostId <> ". " <> hostDeviceName <> if sessionActive then " (active)" else ""
+      plain $ tshow remoteHostId <> ". " <> hostDeviceName <> maybe "" viewSessionState sessionState
+    viewSessionState = \case
+      RHSStarting -> " (starting)"
+      RHSConnecting _ -> " (connecting)"
+      RHSPendingConfirmation {sessionCode} -> " (pending confirmation, code: " <> sessionCode <> ")"
+      RHSConfirmed -> " (confirmed)"
+      RHSConnected -> " (connected)"
 
 viewRemoteCtrls :: [RemoteCtrlInfo] -> [StyledString]
 viewRemoteCtrls = \case
@@ -1713,7 +1719,7 @@ viewRemoteCtrls = \case
   hs -> "Remote controllers: " : map viewRemoteCtrlInfo hs
   where
     viewRemoteCtrlInfo RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName, sessionActive} =
-      plain $ tshow remoteCtrlId <> ". " <> ctrlDeviceName <> if sessionActive then " (active)" else ""
+      plain $ tshow remoteCtrlId <> ". " <> ctrlDeviceName <> if sessionActive then " (connected)" else ""
 
 -- TODO fingerprint, accepted?
 viewRemoteCtrl :: RemoteCtrlInfo -> StyledString

stack.yaml

@@ -49,7 +49,7 @@ extra-deps:
   # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
   # - ../simplexmq
   - github: simplex-chat/simplexmq
-    commit: c051ebab74632e0eb60686329ab3fad521736f79
+    commit: e0b7942e45e36d92625e07c0c1ce9ca2375a0980
   - github: kazu-yamamoto/http2
     commit: f5525b755ff2418e6e6ecc69e877363b0d0bcaeb
   # - ../direct-sqlcipher

tests/RemoteTests.hs

@@ -57,11 +57,11 @@ remoteHandshakeTest viaDesktop = testChat2 aliceProfile aliceDesktopProfile $ \m
 
   desktop ##> "/list remote hosts"
   desktop <## "Remote hosts:"
-  desktop <## "1. Mobile (active)"
+  desktop <## "1. Mobile (connected)"
 
   mobile ##> "/list remote ctrls"
   mobile <## "Remote controllers:"
-  mobile <## "1. My desktop (active)"
+  mobile <## "1. My desktop (connected)"
 
   if viaDesktop then stopDesktop mobile desktop else stopMobile mobile desktop