core: handle remote control session setup errors (#3332)
* handle session setup errors * add command/async wrapper * move furniture around
This commit is contained in:
Alexander Bondarenko
committed by
GitHub
GitHub
parent
3dd62ab05a
commit
6d4febb669
@@ -131,26 +131,38 @@ startRemoteHost' rh_ = do
|
||||
withRemoteHostSession_ rhKey $ maybe (Right ((), Just RHSessionStarting)) (\_ -> Left $ ChatErrorRemoteHost rhKey RHEBusy)
|
||||
ctrlAppInfo <- mkCtrlAppInfo
|
||||
(invitation, rchClient, vars) <- withAgent $ \a -> rcConnectHost a pairing (J.toJSON ctrlAppInfo) multicast
|
||||
rhsWaitSession <- async $ waitForSession rhKey remoteHost_ rchClient vars
|
||||
cmdOk <- newEmptyTMVarIO
|
||||
rhsWaitSession <- async $ do
|
||||
atomically $ takeTMVar cmdOk
|
||||
cleanupOnError rchClient $ waitForSession remoteHost_ vars
|
||||
let rhs = RHPendingSession {rhKey, rchClient, rhsWaitSession, remoteHost_}
|
||||
withRemoteHostSession rhKey $ \case
|
||||
RHSessionStarting -> Right ((), RHSessionConnecting rhs)
|
||||
_ -> Left $ ChatErrorRemoteHost rhKey RHEBadState
|
||||
pure (remoteHost_, invitation)
|
||||
(remoteHost_, invitation) <$ atomically (putTMVar cmdOk ())
|
||||
where
|
||||
mkCtrlAppInfo = do
|
||||
deviceName <- chatReadVar localDeviceName
|
||||
pure CtrlAppInfo {appVersionRange = ctrlAppVersionRange, deviceName}
|
||||
parseHostAppInfo :: RCHostHello -> ExceptT RemoteHostError IO HostAppInfo
|
||||
parseHostAppInfo RCHostHello {app = hostAppInfo} = do
|
||||
hostInfo@HostAppInfo {deviceName, appVersion, encoding, encryptFiles} <-
|
||||
hostInfo@HostAppInfo {appVersion, encoding} <-
|
||||
liftEitherWith (RHEProtocolError . RPEInvalidJSON) $ JT.parseEither J.parseJSON hostAppInfo
|
||||
unless (isAppCompatible appVersion ctrlAppVersionRange) $ throwError $ RHEBadVersion appVersion
|
||||
when (encoding == PEKotlin && localEncoding == PESwift) $ throwError $ RHEProtocolError RPEIncompatibleEncoding
|
||||
pure hostInfo
|
||||
waitForSession :: ChatMonad m => RHKey -> Maybe RemoteHostInfo -> RCHostClient -> RCStepTMVar (ByteString, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m ()
|
||||
waitForSession rhKey remoteHost_ _rchClient_kill_on_error vars = do
|
||||
-- TODO handle errors
|
||||
cleanupOnError :: ChatMonad m => RCHostClient -> (TMVar RHKey -> m ()) -> m ()
|
||||
cleanupOnError rchClient action = do
|
||||
currentKey <- newEmptyTMVarIO
|
||||
action currentKey `catchChatError` \err -> do
|
||||
logError $ "startRemoteHost'.waitForSession crashed: " <> tshow err
|
||||
sessions <- asks remoteHostSessions
|
||||
atomically $ readTMVar currentKey >>= (`TM.delete` sessions)
|
||||
liftIO $ cancelHostClient rchClient
|
||||
waitForSession :: ChatMonad m => Maybe RemoteHostInfo -> RCStepTMVar (ByteString, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> TMVar RHKey -> m ()
|
||||
waitForSession remoteHost_ vars currentKey = do
|
||||
let rhKey = maybe RHNew (\RemoteHostInfo {remoteHostId} -> RHId remoteHostId) remoteHost_
|
||||
atomically $ writeTMVar currentKey rhKey
|
||||
(sessId, vars') <- takeRCStep vars
|
||||
toView $ CRRemoteHostSessionCode {remoteHost_, sessionCode = verificationCode sessId} -- display confirmation code, wait for mobile to confirm
|
||||
(RCHostSession {tls, sessionKeys}, rhHello, pairing') <- takeRCStep vars'
|
||||
@@ -158,23 +170,24 @@ startRemoteHost' rh_ = do
|
||||
liftError (ChatErrorRemoteHost rhKey) $ parseHostAppInfo rhHello
|
||||
withRemoteHostSession rhKey $ \case
|
||||
RHSessionConnecting rhs' -> Right ((), RHSessionConfirmed rhs') -- TODO check it's the same session?
|
||||
_ -> Left $ ChatErrorRemoteHost rhKey RHEBadState -- TODO kill client on error
|
||||
_ -> Left $ ChatErrorRemoteHost rhKey RHEBadState
|
||||
-- update remoteHost with updated pairing
|
||||
rhi@RemoteHostInfo {remoteHostId, storePath} <- upsertRemoteHost pairing' remoteHost_ hostDeviceName
|
||||
let rhKey' = RHId remoteHostId
|
||||
let rhKey' = RHId remoteHostId -- rhKey may be invalid after upserting on RHNew
|
||||
atomically $ writeTMVar currentKey rhKey'
|
||||
disconnected <- toIO $ onDisconnected remoteHostId
|
||||
httpClient <- liftEitherError (httpError rhKey) $ attachRevHTTP2Client disconnected tls
|
||||
httpClient <- liftEitherError (httpError rhKey') $ attachRevHTTP2Client disconnected tls
|
||||
let rhClient = mkRemoteHostClient httpClient sessionKeys storePath hostInfo
|
||||
pollAction <- async $ pollEvents remoteHostId rhClient
|
||||
withRemoteHostSession rhKey' $ \case
|
||||
RHSessionConfirmed RHPendingSession {} -> Right ((), RHSessionConnected {rhClient, pollAction, storePath})
|
||||
_ -> Left $ ChatErrorRemoteHost rhKey' RHEBadState -- TODO kill client on error
|
||||
_ -> 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 pairing'@RCHostPairing {knownHost = kh_} rh_ hostDeviceName = do
|
||||
upsertRemoteHost pairing'@RCHostPairing {knownHost = kh_} rhi_ hostDeviceName = do
|
||||
KnownHostPairing {hostDhPubKey = hostDhPubKey'} <- maybe (throwError . ChatError $ CEInternalError "KnownHost is known after verification") pure kh_
|
||||
case rh_ of
|
||||
case rhi_ of
|
||||
Nothing -> do
|
||||
storePath <- liftIO randomStorePath
|
||||
rh@RemoteHost {remoteHostId} <- withStore $ \db -> insertRemoteHost db hostDeviceName storePath pairing' >>= getRemoteHost db
|
||||
@@ -307,11 +320,20 @@ connectRemoteCtrl inv@RCSignedInvitation {invitation = RCInvitation {ca, app}} =
|
||||
rc_ <- withStore' $ \db -> getRemoteCtrlByFingerprint db ca
|
||||
hostAppInfo <- getHostAppInfo v
|
||||
(rcsClient, vars) <- withAgent $ \a -> rcConnectCtrlURI a inv (ctrlPairing <$> rc_) (J.toJSON hostAppInfo)
|
||||
rcsWaitSession <- async $ waitForSession rc_ ctrlDeviceName rcsClient vars
|
||||
updateRemoteCtrlSession $ \case
|
||||
cmdOk <- newEmptyTMVarIO
|
||||
rcsWaitSession <- async $ do
|
||||
atomically $ takeTMVar cmdOk
|
||||
cleanupOnError rcsClient $ waitForSession rc_ ctrlDeviceName rcsClient vars
|
||||
cleanupOnError rcsClient . updateRemoteCtrlSession $ \case
|
||||
RCSessionStarting -> Right RCSessionConnecting {rcsClient, rcsWaitSession}
|
||||
_ -> Left $ ChatErrorRemoteCtrl RCEBadState -- TODO kill rcsClient
|
||||
_ -> Left $ ChatErrorRemoteCtrl RCEBadState
|
||||
atomically $ putTMVar cmdOk ()
|
||||
where
|
||||
cleanupOnError :: ChatMonad m => RCCtrlClient -> m () -> m ()
|
||||
cleanupOnError rcsClient action = action `catchChatError` \e -> do
|
||||
logError $ "connectRemoteCtrl crashed with: " <> tshow e
|
||||
chatWriteVar remoteCtrlSession Nothing -- XXX: can only wipe PendingConfirmation or RCSessionConnecting, which only have rcsClient to cancel
|
||||
liftIO $ cancelCtrlClient rcsClient
|
||||
waitForSession :: ChatMonad m => Maybe RemoteCtrl -> Text -> RCCtrlClient -> RCStepTMVar (ByteString, RCStepTMVar (RCCtrlSession, RCCtrlPairing)) -> m ()
|
||||
waitForSession rc_ ctrlName rcsClient vars = do
|
||||
(uniq, rcsWaitConfirmation) <- takeRCStep vars
|
||||
@@ -319,7 +341,7 @@ connectRemoteCtrl inv@RCSignedInvitation {invitation = RCInvitation {ca, app}} =
|
||||
toView CRRemoteCtrlSessionCode {remoteCtrl_ = (`remoteCtrlInfo` True) <$> rc_, sessionCode}
|
||||
updateRemoteCtrlSession $ \case
|
||||
RCSessionConnecting {rcsWaitSession} -> Right RCSessionPendingConfirmation {ctrlName, rcsClient, sessionCode, rcsWaitSession, rcsWaitConfirmation}
|
||||
_ -> Left $ ChatErrorRemoteCtrl RCEBadState -- TODO kill rcsClient
|
||||
_ -> Left $ ChatErrorRemoteCtrl RCEBadState
|
||||
parseCtrlAppInfo ctrlAppInfo = do
|
||||
CtrlAppInfo {deviceName, appVersionRange} <-
|
||||
liftEitherWith (const $ ChatErrorRemoteCtrl RCEBadInvitation) $ JT.parseEither J.parseJSON ctrlAppInfo
|
||||
@@ -449,7 +471,7 @@ confirmRemoteCtrl _rcId = do
|
||||
|
||||
-- | Take a look at emoji of tlsunique, commit pairing, and start session server
|
||||
verifyRemoteCtrlSession :: ChatMonad m => (ByteString -> m ChatResponse) -> Text -> m RemoteCtrlInfo
|
||||
verifyRemoteCtrlSession execChatCommand sessCode' = do
|
||||
verifyRemoteCtrlSession execChatCommand sessCode' = cleanupOnError $ do
|
||||
(client, ctrlName, sessionCode, vars) <-
|
||||
getRemoteCtrlSession >>= \case
|
||||
RCSessionPendingConfirmation {rcsClient, ctrlName, sessionCode, rcsWaitConfirmation} -> pure (rcsClient, ctrlName, sessionCode, rcsWaitConfirmation)
|
||||
@@ -458,25 +480,35 @@ verifyRemoteCtrlSession execChatCommand sessCode' = do
|
||||
liftIO $ confirmCtrlSession client verified
|
||||
unless verified $ throwError $ ChatErrorRemoteCtrl RCEBadVerificationCode
|
||||
(rcsSession@RCCtrlSession {tls, sessionKeys}, rcCtrlPairing) <- takeRCStep vars
|
||||
rc@RemoteCtrl {remoteCtrlId} <- withStore $ \db -> do
|
||||
rc_ <- liftIO $ getRemoteCtrlByFingerprint db (ctrlFingerprint rcCtrlPairing)
|
||||
case rc_ of
|
||||
Nothing -> insertRemoteCtrl db ctrlName rcCtrlPairing >>= getRemoteCtrl db
|
||||
Just rc@RemoteCtrl {remoteCtrlId} -> do
|
||||
liftIO $ updateCtrlPairingKeys db remoteCtrlId (dhPrivKey rcCtrlPairing)
|
||||
pure rc
|
||||
rc@RemoteCtrl {remoteCtrlId} <- upsertRemoteCtrl ctrlName rcCtrlPairing
|
||||
remoteOutputQ <- asks (tbqSize . config) >>= newTBQueueIO
|
||||
http2Server <- async $ attachHTTP2Server tls $ handleRemoteCommand execChatCommand sessionKeys remoteOutputQ
|
||||
void . forkIO $ monitor http2Server
|
||||
withRemoteCtrlSession $ \case
|
||||
RCSessionPendingConfirmation {} -> Right ((), RCSessionConnected {remoteCtrlId, rcsClient = client, rcsSession, http2Server, remoteOutputQ})
|
||||
_ -> Left $ ChatErrorRemoteCtrl RCEBadState
|
||||
void . forkIO $ do
|
||||
waitCatch http2Server >>= \case
|
||||
Left err | Just (BadThingHappen innerErr) <- fromException err -> logWarn $ "HTTP2 server crashed with internal " <> tshow innerErr
|
||||
Left err | isNothing (fromException @AsyncCancelled err) -> logError $ "HTTP2 server crashed with " <> tshow err
|
||||
_ -> logInfo "HTTP2 server stopped"
|
||||
toView CRRemoteCtrlStopped
|
||||
pure $ remoteCtrlInfo rc True
|
||||
where
|
||||
upsertRemoteCtrl :: ChatMonad m => Text -> RCCtrlPairing -> m RemoteCtrl
|
||||
upsertRemoteCtrl ctrlName rcCtrlPairing = withStore $ \db -> do
|
||||
rc_ <- liftIO $ getRemoteCtrlByFingerprint db (ctrlFingerprint rcCtrlPairing)
|
||||
case rc_ of
|
||||
Nothing -> insertRemoteCtrl db ctrlName rcCtrlPairing >>= getRemoteCtrl db
|
||||
Just rc@RemoteCtrl {remoteCtrlId} -> do
|
||||
liftIO $ updateCtrlPairingKeys db remoteCtrlId (dhPrivKey rcCtrlPairing)
|
||||
pure rc
|
||||
cleanupOnError :: ChatMonad m => m a -> m a
|
||||
cleanupOnError action = action `catchChatError` \e -> do
|
||||
logError $ "verifyRemoteCtrlSession crashed with: " <> tshow e
|
||||
withRemoteCtrlSession_ (\s -> pure (s, Nothing)) >>= mapM_ (liftIO . cancelRemoteCtrl) -- cancel session threads, if any
|
||||
throwError e
|
||||
monitor :: ChatMonad m => Async a -> m ()
|
||||
monitor server = do
|
||||
waitCatch server >>= \case
|
||||
Left err | Just (BadThingHappen innerErr) <- fromException err -> logWarn $ "HTTP2 server crashed with internal " <> tshow innerErr
|
||||
Left err | isNothing (fromException @AsyncCancelled err) -> logError $ "HTTP2 server crashed with " <> tshow err
|
||||
_ -> logInfo "HTTP2 server stopped"
|
||||
toView CRRemoteCtrlStopped
|
||||
|
||||
stopRemoteCtrl :: ChatMonad m => m ()
|
||||
stopRemoteCtrl =
|
||||
|
||||
Reference in New Issue
Block a user