Send CRRemote*Stopped on all errors (#3376)

* Send CRRemote*Stopped on all errors

Commands use the same action, made idempotent and don't send events.

* fix tests

* get http2 cancelling back

src/Simplex/Chat.hs

@@ -375,7 +375,7 @@ restoreCalls = do
 
 stopChatController :: forall m. MonadUnliftIO m => ChatController -> m ()
 stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession} = do
-  readTVarIO remoteHostSessions >>= mapM_ (liftIO . cancelRemoteHost)
+  readTVarIO remoteHostSessions >>= mapM_ (liftIO . cancelRemoteHost True)
   atomically (stateTVar remoteCtrlSession (,Nothing)) >>= mapM_ (liftIO . cancelRemoteCtrl)
   disconnectAgentClient smpAgent
   readTVarIO s >>= mapM_ (\(a1, a2) -> uninterruptibleCancel a1 >> mapM_ uninterruptibleCancel a2)

src/Simplex/Chat/Controller.hs

@@ -647,7 +647,7 @@ data ChatResponse
   | CRRemoteHostSessionCode {remoteHost_ :: Maybe RemoteHostInfo, sessionCode :: Text}
   | CRNewRemoteHost {remoteHost :: RemoteHostInfo}
   | CRRemoteHostConnected {remoteHost :: RemoteHostInfo}
-  | CRRemoteHostStopped {remoteHostId :: RemoteHostId}
+  | CRRemoteHostStopped {remoteHostId_ :: Maybe RemoteHostId}
   | CRRemoteFileStored {remoteHostId :: RemoteHostId, remoteFileSource :: CryptoFile}
   | CRRemoteCtrlList {remoteCtrls :: [RemoteCtrlInfo]}
   | CRRemoteCtrlFound {remoteCtrl :: RemoteCtrlInfo} -- registered fingerprint, may connect

src/Simplex/Chat/Remote.hs

@@ -157,12 +157,9 @@ startRemoteHost rh_ = do
       when (encoding == PEKotlin && localEncoding == PESwift) $ throwError $ RHEProtocolError RPEIncompatibleEncoding
       pure hostInfo
     handleHostError :: ChatMonad m => TVar RHKey -> m () -> m ()
-    handleHostError rhKeyVar action = do
-      action `catchChatError` \err -> do
-        logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err
-        sessions <- asks remoteHostSessions
-        session_ <- atomically $ readTVar rhKeyVar >>= (`TM.lookupDelete` sessions)
-        mapM_ (liftIO . cancelRemoteHost) session_
+    handleHostError rhKeyVar action = action `catchChatError` \err -> do
+      logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err
+      readTVarIO rhKeyVar >>= cancelRemoteHostSession True True
     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
@@ -185,7 +182,7 @@ startRemoteHost rh_ = do
       when (rhKey' /= rhKey) $ do
         atomically $ writeTVar rhKeyVar rhKey'
         toView $ CRNewRemoteHost rhi
-      disconnected <- toIO $ onDisconnected remoteHostId
+      disconnected <- toIO $ onDisconnected rhKey'
       httpClient <- liftEitherError (httpError rhKey') $ attachRevHTTP2Client disconnected tls
       rhClient <- mkRemoteHostClient httpClient sessionKeys sessId storePath hostInfo
       pollAction <- async $ pollEvents remoteHostId rhClient
@@ -206,13 +203,10 @@ startRemoteHost rh_ = do
         Just rhi@RemoteHostInfo {remoteHostId} -> do
           withStore' $ \db -> updateHostPairing db remoteHostId hostDeviceName hostDhPubKey'
           pure (rhi :: RemoteHostInfo) {sessionState = Just state}
-    onDisconnected :: ChatMonad m => RemoteHostId -> m ()
-    onDisconnected remoteHostId = do
+    onDisconnected :: ChatMonad m => RHKey -> m ()
+    onDisconnected rhKey = do
       logDebug "HTTP2 client disconnected"
-      chatModifyVar currentRemoteHost $ \cur -> if cur == Just remoteHostId then Nothing else cur -- only wipe the closing RH
-      sessions <- asks remoteHostSessions
-      void . atomically $ TM.lookupDelete (RHId remoteHostId) sessions
-      toView $ CRRemoteHostStopped remoteHostId
+      cancelRemoteHostSession True False rhKey
     pollEvents :: ChatMonad m => RemoteHostId -> RemoteHostClient -> m ()
     pollEvents rhId rhClient = do
       oq <- asks outputQ
@@ -225,12 +219,23 @@ startRemoteHost rh_ = do
 closeRemoteHost :: ChatMonad m => RHKey -> m ()
 closeRemoteHost rhKey = do
   logNote $ "Closing remote host session for " <> tshow rhKey
-  chatModifyVar currentRemoteHost $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH
-  join . withRemoteHostSession_ rhKey . maybe (Left $ ChatErrorRemoteHost rhKey RHEInactive) $
-    \s -> Right (liftIO $ cancelRemoteHost s, Nothing)
+  cancelRemoteHostSession False True rhKey
 
-cancelRemoteHost :: RemoteHostSession -> IO ()
-cancelRemoteHost = \case
+cancelRemoteHostSession :: ChatMonad m => Bool -> Bool -> RHKey -> m ()
+cancelRemoteHostSession sendEvent stopHttp rhKey = handleAny (logError . tshow) $ do
+  chatModifyVar currentRemoteHost $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH
+  sessions <- asks remoteHostSessions
+  session_ <- atomically $ TM.lookupDelete rhKey sessions
+  forM_ session_ $ \session -> do
+    liftIO $ cancelRemoteHost stopHttp session
+    when sendEvent $ toView $ CRRemoteHostStopped rhId_
+  where
+    rhId_ = case rhKey of
+      RHNew -> Nothing
+      RHId rhId -> Just rhId
+
+cancelRemoteHost :: Bool -> RemoteHostSession -> IO ()
+cancelRemoteHost stopHttp = \case
   RHSessionStarting -> pure ()
   RHSessionConnecting _inv rhs -> cancelPendingSession rhs
   RHSessionPendingConfirmation _sessCode tls rhs -> do
@@ -241,9 +246,9 @@ cancelRemoteHost = \case
     closeConnection tls
   RHSessionConnected {rchClient, tls, rhClient = RemoteHostClient {httpClient}, pollAction} -> do
     uninterruptibleCancel pollAction
-    closeHTTP2Client httpClient
-    closeConnection tls
-    cancelHostClient rchClient
+    when stopHttp $ closeHTTP2Client httpClient `catchAny` (logError . tshow)
+    closeConnection tls `catchAny` (logError . tshow)
+    cancelHostClient rchClient `catchAny` (logError . tshow)
   where
     cancelPendingSession RHPendingSession {rchClient, rhsWaitSession} = do
       uninterruptibleCancel rhsWaitSession
@@ -544,22 +549,23 @@ verifyRemoteCtrlSession execChatCommand sessCode' = handleCtrlError "verifyRemot
     monitor server = do
       res <- waitCatch server
       logInfo $ "HTTP2 server stopped: " <> tshow res
-      cancelActiveRemoteCtrl
-      toView CRRemoteCtrlStopped
+      cancelActiveRemoteCtrl True
 
 stopRemoteCtrl :: ChatMonad m => m ()
-stopRemoteCtrl =
-  join . withRemoteCtrlSession_ . maybe (Left $ ChatErrorRemoteCtrl RCEInactive) $
-    \s -> Right (liftIO $ cancelRemoteCtrl s, Nothing)
+stopRemoteCtrl = cancelActiveRemoteCtrl False
 
 handleCtrlError :: ChatMonad m => Text -> m a -> m a
 handleCtrlError name action = action `catchChatError` \e -> do
   logError $ name <> " remote ctrl error: " <> tshow e
-  cancelActiveRemoteCtrl
+  cancelActiveRemoteCtrl True
   throwError e
 
-cancelActiveRemoteCtrl :: ChatMonad m => m ()
-cancelActiveRemoteCtrl = withRemoteCtrlSession_ (\s -> pure (s, Nothing)) >>= mapM_ (liftIO . cancelRemoteCtrl)
+cancelActiveRemoteCtrl :: ChatMonad m => Bool -> m ()
+cancelActiveRemoteCtrl sendEvent = handleAny (logError . tshow) $ do
+  session_ <- withRemoteCtrlSession_ (\s -> pure (s, Nothing))
+  forM_ session_ $ \session -> do
+    liftIO $ cancelRemoteCtrl session
+    when sendEvent $ toView CRRemoteCtrlStopped
 
 cancelRemoteCtrl :: RemoteCtrlSession -> IO ()
 cancelRemoteCtrl = \case

src/Simplex/Chat/View.hs

@@ -297,7 +297,9 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
     ]
   CRNewRemoteHost RemoteHostInfo {remoteHostId = rhId, hostDeviceName} -> ["new remote host " <> sShow rhId <> " added: " <> plain hostDeviceName]
   CRRemoteHostConnected RemoteHostInfo {remoteHostId = rhId} -> ["remote host " <> sShow rhId <> " connected"]
-  CRRemoteHostStopped rhId -> ["remote host " <> sShow rhId <> " stopped"]
+  CRRemoteHostStopped rhId_ ->
+    [ maybe "new remote host" (mappend "remote host " . sShow) rhId_ <> " stopped"
+    ]
   CRRemoteFileStored rhId (CryptoFile filePath cfArgs_) ->
     [plain $ "file " <> filePath <> " stored on remote host " <> show rhId]
       <> maybe [] ((: []) . plain . cryptoFileArgsStr testView) cfArgs_

tests/RemoteTests.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module RemoteTests where
@@ -40,7 +39,7 @@ remoteTests = describe "Remote" $ do
   it "sends messages" remoteMessageTest
   describe "remote files" $ do
     it "store/get/send/receive files" remoteStoreFileTest
-    it "should send files from CLI wihtout /store" remoteCLIFileTest
+    it "should send files from CLI without /store" remoteCLIFileTest
   it "switches remote hosts" switchRemoteHostTest
   it "indicates remote hosts" indicateRemoteHostTest
 
@@ -439,24 +438,15 @@ stopDesktop :: HasCallStack => TestCC -> TestCC -> IO ()
 stopDesktop mobile desktop = do
   logWarn "stopping via desktop"
   desktop ##> "/stop remote host 1"
-  -- desktop <## "ok"
-  concurrentlyN_
-    [ do
-        desktop <## "remote host 1 stopped"
-        desktop <## "ok",
-      eventually 3 $ mobile <## "remote controller stopped"
-    ]
+  desktop <## "ok"
+  eventually 3 $ mobile <## "remote controller stopped"
 
 stopMobile :: HasCallStack => TestCC -> TestCC -> IO ()
 stopMobile mobile desktop = do
   logWarn "stopping via mobile"
   mobile ##> "/stop remote ctrl"
-  concurrentlyN_
-    [ do
-        mobile <## "remote controller stopped"
-        mobile <## "ok",
-      eventually 3 $ desktop <## "remote host 1 stopped"
-    ]
+  mobile <## "ok"
+  eventually 3 $ desktop <## "remote host 1 stopped"
 
 -- | Run action with extended timeout
 eventually :: Int -> IO a -> IO a