diff --git a/cabal.project b/cabal.project index 5730bfb7b9..c9273ea950 100644 --- a/cabal.project +++ b/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: c051ebab74632e0eb60686329ab3fad521736f79 + tag: 4f5d52ada47a15532766b2ff3d3781be629648d8 source-repository-package type: git diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 60e861a484..8b9abfde5f 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -103,7 +103,7 @@ import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport.Client (defaultSocksProxy) import Simplex.Messaging.Util import Simplex.Messaging.Version -import System.Exit (exitFailure, exitSuccess) +import System.Exit (ExitCode, exitFailure, exitSuccess) import System.FilePath (takeFileName, ()) import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, stdout) import System.Random (randomRIO) @@ -411,7 +411,12 @@ execRemoteCommand :: ChatMonad' m => Maybe User -> RemoteHostId -> ChatCommand - execRemoteCommand u rhId cmd s = handleCommandError u $ getRemoteHostClient rhId >>= \rh -> processRemoteCommand rhId rh cmd s handleCommandError :: ChatMonad' m => Maybe User -> ExceptT ChatError m ChatResponse -> m ChatResponse -handleCommandError u a = either (CRChatCmdError u) id <$> (runExceptT a `E.catch` (pure . Left . mkChatError)) +handleCommandError u a = either (CRChatCmdError u) id <$> (runExceptT a `E.catches` ioErrors) + where + ioErrors = + [ E.Handler $ \(e :: ExitCode) -> E.throwIO e, + E.Handler $ pure . Left . mkChatError + ] parseChatCommand :: ByteString -> Either String ChatCommand parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 84bbe37337..622ce7b706 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -1048,6 +1048,7 @@ data RemoteHostError = RHEMissing -- ^ No remote session matches this identifier | RHEInactive -- ^ A session exists, but not active | RHEBusy -- ^ A session is already running + | RHETimeout | RHEBadState -- ^ Illegal state transition | RHEBadVersion {appVersion :: AppVersion} | RHEDisconnected {reason :: Text} -- TODO should be sent when disconnected? @@ -1059,10 +1060,10 @@ data RemoteCtrlError = RCEInactive -- ^ No session is running | RCEBadState -- ^ A session is in a wrong state for the current operation | RCEBusy -- ^ A session is already running + | RCETimeout | RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text} -- ^ A session disconnected by a controller | RCEBadInvitation | RCEBadVersion {appVersion :: AppVersion} - | RCEBadVerificationCode -- ^ The code submitted doesn't match session TLSunique | RCEHTTP2Error {http2Error :: Text} -- TODO currently not used | RCEProtocolError {protocolError :: RemoteProtocolError} deriving (Show, Exception) diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index 57dcd33e43..e819f02240 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -90,6 +90,9 @@ ctrlAppVersionRange = mkAppVersionRange minRemoteHostVersion currentAppVersion hostAppVersionRange :: AppVersionRange hostAppVersionRange = mkAppVersionRange minRemoteCtrlVersion currentAppVersion +networkIOTimeout :: Int +networkIOTimeout = 15000000 + -- * Desktop side getRemoteHostClient :: ChatMonad m => RemoteHostId -> m RemoteHostClient @@ -161,9 +164,9 @@ startRemoteHost rh_ = do mapM_ (liftIO . cancelRemoteHost) session_ waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> TVar RHKey -> RCStepTMVar (ByteString, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m () waitForHostSession remoteHost_ rhKey rhKeyVar vars = do - (sessId, vars') <- takeRCStep vars + (sessId, vars') <- takeRCStep vars -- no timeout, waiting for user to scan invite toView $ CRRemoteHostSessionCode {remoteHost_, sessionCode = verificationCode sessId} -- display confirmation code, wait for mobile to confirm - (RCHostSession {tls, sessionKeys}, rhHello, pairing') <- takeRCStep vars' + (RCHostSession {tls, 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 @@ -180,7 +183,7 @@ startRemoteHost rh_ = do rhClient <- mkRemoteHostClient httpClient sessionKeys sessId storePath hostInfo pollAction <- async $ pollEvents remoteHostId rhClient withRemoteHostSession rhKey' $ \case - RHSessionConfirmed _ RHPendingSession {} -> Right ((), RHSessionConnected {tls, rhClient, pollAction, storePath}) + 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 @@ -216,7 +219,7 @@ 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 $ ChatErrorRemoteCtrl RCEInactive) $ + join . withRemoteHostSession_ rhKey . maybe (Left $ ChatErrorRemoteHost rhKey RHEInactive) $ \s -> Right (liftIO $ cancelRemoteHost s, Nothing) cancelRemoteHost :: RemoteHostSession -> IO () @@ -226,10 +229,11 @@ cancelRemoteHost = \case RHSessionConfirmed tls rhs -> do cancelPendingSession rhs closeConnection tls - RHSessionConnected {tls, rhClient = RemoteHostClient {httpClient}, pollAction} -> do + RHSessionConnected {rchClient, tls, rhClient = RemoteHostClient {httpClient}, pollAction} -> do uninterruptibleCancel pollAction closeHTTP2Client httpClient closeConnection tls + cancelHostClient rchClient where cancelPendingSession RHPendingSession {rchClient, rhsWaitSession} = do uninterruptibleCancel rhsWaitSession @@ -333,7 +337,8 @@ connectRemoteCtrl signedInv@RCSignedInvitation {invitation = inv@RCInvitation {c rc_ <- withStore' $ \db -> getRemoteCtrlByFingerprint db ca mapM_ (validateRemoteCtrl inv) rc_ hostAppInfo <- getHostAppInfo v - (rcsClient, vars) <- withAgent $ \a -> rcConnectCtrlURI a signedInv (ctrlPairing <$> rc_) (J.toJSON hostAppInfo) + (rcsClient, vars) <- timeoutThrow (ChatErrorRemoteCtrl RCETimeout) networkIOTimeout . withAgent $ \a -> + rcConnectCtrlURI a signedInv (ctrlPairing <$> rc_) (J.toJSON hostAppInfo) cmdOk <- newEmptyTMVarIO rcsWaitSession <- async $ do atomically $ takeTMVar cmdOk @@ -348,7 +353,7 @@ connectRemoteCtrl signedInv@RCSignedInvitation {invitation = inv@RCInvitation {c unless (idkey == idPubKey) $ throwError $ ChatErrorRemoteCtrl $ RCEProtocolError $ PRERemoteControl RCEIdentity waitForCtrlSession :: ChatMonad m => Maybe RemoteCtrl -> Text -> RCCtrlClient -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> m () waitForCtrlSession rc_ ctrlName rcsClient vars = do - (uniq, tls, rcsWaitConfirmation) <- takeRCStep vars + (uniq, tls, rcsWaitConfirmation) <- timeoutThrow (ChatErrorRemoteCtrl RCETimeout) networkIOTimeout $ takeRCStep vars let sessionCode = verificationCode uniq toView CRRemoteCtrlSessionCode {remoteCtrl_ = (`remoteCtrlInfo` True) <$> rc_, sessionCode} updateRemoteCtrlSession $ \case @@ -397,6 +402,9 @@ handleRemoteCommand execChatCommand encryption remoteOutputQ HTTP2Request {reque attach send flush +timeoutThrow :: (MonadUnliftIO m, MonadError e m) => e -> Int -> m a -> m a +timeoutThrow e ms action = timeout ms action >>= maybe (throwError e) pure + takeRCStep :: ChatMonad m => RCStepTMVar a -> m a takeRCStep = liftEitherError (\e -> ChatErrorAgent {agentError = RCP e, connectionEntity_ = Nothing}) . atomically . takeTMVar @@ -490,9 +498,9 @@ verifyRemoteCtrlSession execChatCommand sessCode' = handleCtrlError "verifyRemot RCSessionPendingConfirmation {rcsClient, ctrlDeviceName = ctrlName, sessionCode, rcsWaitConfirmation} -> pure (rcsClient, ctrlName, sessionCode, rcsWaitConfirmation) _ -> throwError $ ChatErrorRemoteCtrl RCEBadState let verified = sameVerificationCode sessCode' sessionCode - liftIO $ confirmCtrlSession client verified + timeoutThrow (ChatErrorRemoteCtrl RCETimeout) networkIOTimeout . liftIO $ confirmCtrlSession client verified -- signal verification result before crashing unless verified $ throwError $ ChatErrorRemoteCtrl $ RCEProtocolError PRESessionCode - (rcsSession@RCCtrlSession {tls, sessionKeys}, rcCtrlPairing) <- takeRCStep vars + (rcsSession@RCCtrlSession {tls, sessionKeys}, rcCtrlPairing) <- timeoutThrow (ChatErrorRemoteCtrl RCETimeout) networkIOTimeout $ takeRCStep vars rc@RemoteCtrl {remoteCtrlId} <- upsertRemoteCtrl ctrlName rcCtrlPairing remoteOutputQ <- asks (tbqSize . config) >>= newTBQueueIO encryption <- mkCtrlRemoteCrypto sessionKeys $ tlsUniq tls diff --git a/src/Simplex/Chat/Remote/Types.hs b/src/Simplex/Chat/Remote/Types.hs index 419339e41e..17ea8e1599 100644 --- a/src/Simplex/Chat/Remote/Types.hs +++ b/src/Simplex/Chat/Remote/Types.hs @@ -65,7 +65,13 @@ data RemoteHostSession = RHSessionStarting | RHSessionConnecting {rhPendingSession :: RHPendingSession} | RHSessionConfirmed {tls :: TLS, rhPendingSession :: RHPendingSession} - | RHSessionConnected {tls :: TLS, rhClient :: RemoteHostClient, pollAction :: Async (), storePath :: FilePath} + | RHSessionConnected + { rchClient :: RCHostClient, + tls :: TLS, + rhClient :: RemoteHostClient, + pollAction :: Async (), + storePath :: FilePath + } data RemoteProtocolError = -- | size prefix is malformed