From 339c3d2be187c843ab63a0eb519c04ed987d271c Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Wed, 15 Nov 2023 19:31:36 +0200 Subject: [PATCH] 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 | 2 +- src/Simplex/Chat/Controller.hs | 2 +- src/Simplex/Chat/Remote.hs | 64 +++++++++++++++++++--------------- src/Simplex/Chat/View.hs | 4 ++- tests/RemoteTests.hs | 20 +++-------- 5 files changed, 45 insertions(+), 47 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index b6b7cca1a6..ea16785e44 100644 --- a/src/Simplex/Chat.hs +++ b/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) diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index fb03844f89..68d909f784 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/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 diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index b3d2d0ebf0..23d74404d5 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/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 diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 98a3edd478..a6843de601 100644 --- a/src/Simplex/Chat/View.hs +++ b/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_ diff --git a/tests/RemoteTests.hs b/tests/RemoteTests.hs index e3bef7f9e7..0d3dc74627 100644 --- a/tests/RemoteTests.hs +++ b/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