core: add remote stop reason and state (#3444)
* add remote stop reason and state * rename --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
Alexander Bondarenko
committed by
GitHub
GitHub
parent
6f3174d0a1
commit
74e80eb348
@@ -662,14 +662,14 @@ data ChatResponse
|
||||
| CRRemoteHostSessionCode {remoteHost_ :: Maybe RemoteHostInfo, sessionCode :: Text}
|
||||
| CRNewRemoteHost {remoteHost :: RemoteHostInfo}
|
||||
| CRRemoteHostConnected {remoteHost :: RemoteHostInfo}
|
||||
| CRRemoteHostStopped {remoteHostId_ :: Maybe RemoteHostId}
|
||||
| CRRemoteHostStopped {remoteHostId_ :: Maybe RemoteHostId, rhsState :: RemoteHostSessionState, rhStopReason :: RemoteHostStopReason}
|
||||
| CRRemoteFileStored {remoteHostId :: RemoteHostId, remoteFileSource :: CryptoFile}
|
||||
| CRRemoteCtrlList {remoteCtrls :: [RemoteCtrlInfo]}
|
||||
| CRRemoteCtrlFound {remoteCtrl :: RemoteCtrlInfo, ctrlAppInfo_ :: Maybe CtrlAppInfo, appVersion :: AppVersion, compatible :: Bool}
|
||||
| CRRemoteCtrlConnecting {remoteCtrl_ :: Maybe RemoteCtrlInfo, ctrlAppInfo :: CtrlAppInfo, appVersion :: AppVersion}
|
||||
| CRRemoteCtrlSessionCode {remoteCtrl_ :: Maybe RemoteCtrlInfo, sessionCode :: Text}
|
||||
| CRRemoteCtrlConnected {remoteCtrl :: RemoteCtrlInfo}
|
||||
| CRRemoteCtrlStopped
|
||||
| CRRemoteCtrlStopped {rcsState :: RemoteCtrlSessionState, rcStopReason :: RemoteCtrlStopReason}
|
||||
| CRSQLResult {rows :: [Text]}
|
||||
| CRSlowSQLQueries {chatQueries :: [SlowSQLQuery], agentQueries :: [SlowSQLQuery]}
|
||||
| CRDebugLocks {chatLockName :: Maybe String, agentLocks :: AgentLocks}
|
||||
@@ -700,14 +700,14 @@ allowRemoteEvent = \case
|
||||
CRRemoteHostSessionCode {} -> False
|
||||
CRNewRemoteHost _ -> False
|
||||
CRRemoteHostConnected _ -> False
|
||||
CRRemoteHostStopped _ -> False
|
||||
CRRemoteHostStopped {} -> False
|
||||
CRRemoteFileStored {} -> False
|
||||
CRRemoteCtrlList _ -> False
|
||||
CRRemoteCtrlFound {} -> False
|
||||
CRRemoteCtrlConnecting {} -> False
|
||||
CRRemoteCtrlSessionCode {} -> False
|
||||
CRRemoteCtrlConnected _ -> False
|
||||
CRRemoteCtrlStopped -> False
|
||||
CRRemoteCtrlStopped {} -> False
|
||||
CRSQLResult _ -> False
|
||||
CRSlowSQLQueries {} -> False
|
||||
_ -> True
|
||||
@@ -1083,6 +1083,12 @@ data RemoteHostError
|
||||
| RHEProtocolError RemoteProtocolError
|
||||
deriving (Show, Exception)
|
||||
|
||||
data RemoteHostStopReason
|
||||
= RHSRConnectionFailed ChatError
|
||||
| RHSRCrashed ChatError
|
||||
| RHSRDisconnected
|
||||
deriving (Show, Exception)
|
||||
|
||||
-- TODO review errors, some of it can be covered by HTTP2 errors
|
||||
data RemoteCtrlError
|
||||
= RCEInactive -- ^ No session is running
|
||||
@@ -1098,6 +1104,13 @@ data RemoteCtrlError
|
||||
| RCEProtocolError {protocolError :: RemoteProtocolError}
|
||||
deriving (Show, Exception)
|
||||
|
||||
data RemoteCtrlStopReason
|
||||
= RCSRDiscoveryFailed ChatError
|
||||
| RCSRConnectionFailed ChatError
|
||||
| RCSRSetupFailed ChatError
|
||||
| RCSRDisconnected
|
||||
deriving (Show, Exception)
|
||||
|
||||
data ArchiveError
|
||||
= AEImport {chatError :: ChatError}
|
||||
| AEImportFile {file :: String, chatError :: ChatError}
|
||||
@@ -1323,6 +1336,10 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCS") ''RemoteCtrlSessionState)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''RemoteCtrlInfo)
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RCSR") ''RemoteCtrlStopReason)
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RHSR") ''RemoteHostStopReason)
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CR") ''ChatResponse)
|
||||
|
||||
$(JQ.deriveFromJSON defaultJSON ''ArchiveConfig)
|
||||
|
||||
@@ -169,12 +169,12 @@ startRemoteHost rh_ = do
|
||||
handleConnectError :: ChatMonad m => RHKey -> SessionSeq -> m a -> m a
|
||||
handleConnectError rhKey sessSeq action = action `catchChatError` \err -> do
|
||||
logError $ "startRemoteHost.rcConnectHost crashed: " <> tshow err
|
||||
cancelRemoteHostSession (Just sessSeq) rhKey
|
||||
cancelRemoteHostSession (Just (sessSeq, RHSRConnectionFailed err)) rhKey
|
||||
throwError err
|
||||
handleHostError :: ChatMonad m => SessionSeq -> TVar RHKey -> m () -> m ()
|
||||
handleHostError sessSeq rhKeyVar action = action `catchChatError` \err -> do
|
||||
logError $ "startRemoteHost.waitForHostSession crashed: " <> tshow err
|
||||
readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just sessSeq)
|
||||
readTVarIO rhKeyVar >>= cancelRemoteHostSession (Just (sessSeq, RHSRCrashed err))
|
||||
waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> SessionSeq -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m ()
|
||||
waitForHostSession remoteHost_ rhKey sseq rhKeyVar vars = do
|
||||
(sessId, tls, vars') <- timeoutThrow (ChatErrorRemoteHost rhKey RHETimeout) 60000000 $ takeRCStep vars
|
||||
@@ -220,7 +220,7 @@ startRemoteHost rh_ = do
|
||||
onDisconnected :: ChatMonad m => RHKey -> SessionSeq -> m ()
|
||||
onDisconnected rhKey sseq = do
|
||||
logDebug $ "HTTP2 client disconnected: " <> tshow (rhKey, sseq)
|
||||
cancelRemoteHostSession (Just sseq) rhKey
|
||||
cancelRemoteHostSession (Just (sseq, RHSRDisconnected)) rhKey
|
||||
pollEvents :: ChatMonad m => RemoteHostId -> RemoteHostClient -> m ()
|
||||
pollEvents rhId rhClient = do
|
||||
oq <- asks outputQ
|
||||
@@ -246,24 +246,25 @@ closeRemoteHost rhKey = do
|
||||
logNote $ "Closing remote host session for " <> tshow rhKey
|
||||
cancelRemoteHostSession Nothing rhKey
|
||||
|
||||
cancelRemoteHostSession :: ChatMonad m => Maybe SessionSeq -> RHKey -> m ()
|
||||
cancelRemoteHostSession sseq_ rhKey = do
|
||||
cancelRemoteHostSession :: ChatMonad m => Maybe (SessionSeq, RemoteHostStopReason) -> RHKey -> m ()
|
||||
cancelRemoteHostSession handlerInfo_ rhKey = do
|
||||
sessions <- asks remoteHostSessions
|
||||
crh <- asks currentRemoteHost
|
||||
deregistered <- atomically $
|
||||
TM.lookup rhKey sessions >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just (sessSeq, _) | maybe False (/= sessSeq) sseq_ -> pure Nothing -- ignore cancel from a ghost session handler
|
||||
Just (sessSeq, _) | maybe False (/= sessSeq) (fst <$> handlerInfo_) -> pure Nothing -- ignore cancel from a ghost session handler
|
||||
Just (_, rhs) -> do
|
||||
TM.delete rhKey sessions
|
||||
modifyTVar' crh $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH
|
||||
pure $ Just rhs
|
||||
forM_ deregistered $ \session -> do
|
||||
liftIO $ cancelRemoteHost handlingError session `catchAny` (logError . tshow)
|
||||
when handlingError $ toView $ CRRemoteHostStopped rhId_
|
||||
forM_ (snd <$> handlerInfo_) $ \rhStopReason ->
|
||||
toView $ CRRemoteHostStopped {remoteHostId_, rhsState = rhsSessionState session, rhStopReason}
|
||||
where
|
||||
handlingError = isJust sseq_
|
||||
rhId_ = case rhKey of
|
||||
handlingError = isJust handlerInfo_
|
||||
remoteHostId_ = case rhKey of
|
||||
RHNew -> Nothing
|
||||
RHId rhId -> Just rhId
|
||||
|
||||
@@ -395,7 +396,7 @@ findKnownRemoteCtrl = do
|
||||
sseq <- startRemoteCtrlSession
|
||||
foundCtrl <- newEmptyTMVarIO
|
||||
cmdOk <- newEmptyTMVarIO
|
||||
action <- async $ handleCtrlError sseq "findKnownRemoteCtrl.discover" $ do
|
||||
action <- async $ handleCtrlError sseq RCSRDiscoveryFailed "findKnownRemoteCtrl.discover" $ do
|
||||
atomically $ takeTMVar cmdOk
|
||||
(RCCtrlPairing {ctrlFingerprint}, inv@(RCVerifiedInvitation RCInvitation {app})) <-
|
||||
timeoutThrow (ChatErrorRemoteCtrl RCETimeout) discoveryTimeout . withAgent $ \a -> rcDiscoverCtrl a pairings
|
||||
@@ -441,7 +442,7 @@ startRemoteCtrlSession = do
|
||||
Right sseq <$ writeTVar session (Just (sseq, RCSessionStarting))
|
||||
|
||||
connectRemoteCtrl :: ChatMonad m => RCVerifiedInvitation -> SessionSeq -> m (Maybe RemoteCtrlInfo, CtrlAppInfo)
|
||||
connectRemoteCtrl verifiedInv@(RCVerifiedInvitation inv@RCInvitation {ca, app}) sseq = handleCtrlError sseq "connectRemoteCtrl" $ do
|
||||
connectRemoteCtrl verifiedInv@(RCVerifiedInvitation inv@RCInvitation {ca, app}) sseq = handleCtrlError sseq RCSRConnectionFailed "connectRemoteCtrl" $ do
|
||||
ctrlInfo@CtrlAppInfo {deviceName = ctrlDeviceName} <- parseCtrlAppInfo app
|
||||
v <- checkAppVersion ctrlInfo
|
||||
rc_ <- withStore' $ \db -> getRemoteCtrlByFingerprint db ca
|
||||
@@ -452,7 +453,7 @@ connectRemoteCtrl verifiedInv@(RCVerifiedInvitation inv@RCInvitation {ca, app})
|
||||
cmdOk <- newEmptyTMVarIO
|
||||
rcsWaitSession <- async $ do
|
||||
atomically $ takeTMVar cmdOk
|
||||
handleCtrlError sseq "waitForCtrlSession" $ waitForCtrlSession rc_ ctrlDeviceName rcsClient vars
|
||||
handleCtrlError sseq RCSRConnectionFailed "waitForCtrlSession" $ waitForCtrlSession rc_ ctrlDeviceName rcsClient vars
|
||||
updateRemoteCtrlSession sseq $ \case
|
||||
RCSessionStarting -> Right RCSessionConnecting {remoteCtrlId_ = remoteCtrlId' <$> rc_, rcsClient, rcsWaitSession}
|
||||
_ -> Left $ ChatErrorRemoteCtrl RCEBadState
|
||||
@@ -602,7 +603,7 @@ verifyRemoteCtrlSession execChatCommand sessCode' = do
|
||||
Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive
|
||||
Just (sseq, RCSessionPendingConfirmation {rcsClient, ctrlDeviceName = ctrlName, sessionCode, rcsWaitConfirmation}) -> pure (sseq, rcsClient, ctrlName, sessionCode, rcsWaitConfirmation)
|
||||
_ -> throwError $ ChatErrorRemoteCtrl RCEBadState
|
||||
handleCtrlError sseq "verifyRemoteCtrlSession" $ do
|
||||
handleCtrlError sseq RCSRSetupFailed "verifyRemoteCtrlSession" $ do
|
||||
let verified = sameVerificationCode sessCode' sessionCode
|
||||
timeoutThrow (ChatErrorRemoteCtrl RCETimeout) networkIOTimeout . liftIO $ confirmCtrlSession client verified -- signal verification result before crashing
|
||||
unless verified $ throwError $ ChatErrorRemoteCtrl $ RCEProtocolError PRESessionCode
|
||||
@@ -630,31 +631,32 @@ verifyRemoteCtrlSession execChatCommand sessCode' = do
|
||||
monitor sseq server = do
|
||||
res <- waitCatch server
|
||||
logInfo $ "HTTP2 server stopped: " <> tshow res
|
||||
cancelActiveRemoteCtrl (Just sseq)
|
||||
cancelActiveRemoteCtrl $ Just (sseq, RCSRDisconnected)
|
||||
|
||||
stopRemoteCtrl :: ChatMonad m => m ()
|
||||
stopRemoteCtrl = cancelActiveRemoteCtrl Nothing
|
||||
|
||||
handleCtrlError :: ChatMonad m => SessionSeq -> Text -> m a -> m a
|
||||
handleCtrlError sseq name action =
|
||||
handleCtrlError :: ChatMonad m => SessionSeq -> (ChatError -> RemoteCtrlStopReason) -> Text -> m a -> m a
|
||||
handleCtrlError sseq mkReason name action =
|
||||
action `catchChatError` \e -> do
|
||||
logError $ name <> " remote ctrl error: " <> tshow e
|
||||
cancelActiveRemoteCtrl (Just sseq)
|
||||
cancelActiveRemoteCtrl $ Just (sseq, mkReason e)
|
||||
throwError e
|
||||
|
||||
-- | Stop session controller, unless session update key is present but stale
|
||||
cancelActiveRemoteCtrl :: ChatMonad m => Maybe SessionSeq -> m ()
|
||||
cancelActiveRemoteCtrl sseq_ = handleAny (logError . tshow) $ do
|
||||
cancelActiveRemoteCtrl :: ChatMonad m => Maybe (SessionSeq, RemoteCtrlStopReason) -> m ()
|
||||
cancelActiveRemoteCtrl handlerInfo_ = handleAny (logError . tshow) $ do
|
||||
var <- asks remoteCtrlSession
|
||||
session_ <- atomically $ readTVar var >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just (oldSeq, _) | maybe False (/= oldSeq) sseq_ -> pure Nothing
|
||||
Just (oldSeq, _) | maybe False (/= oldSeq) (fst <$> handlerInfo_) -> pure Nothing
|
||||
Just (_, s) -> Just s <$ writeTVar var Nothing
|
||||
forM_ session_ $ \session -> do
|
||||
liftIO $ cancelRemoteCtrl handlingError session
|
||||
when handlingError $ toView CRRemoteCtrlStopped
|
||||
forM_ (snd <$> handlerInfo_) $ \rcStopReason ->
|
||||
toView CRRemoteCtrlStopped {rcsState = rcsSessionState session, rcStopReason}
|
||||
where
|
||||
handlingError = isJust sseq_
|
||||
handlingError = isJust handlerInfo_
|
||||
|
||||
cancelRemoteCtrl :: Bool -> RemoteCtrlSession -> IO ()
|
||||
cancelRemoteCtrl handlingError = \case
|
||||
|
||||
@@ -299,8 +299,8 @@ 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_ ->
|
||||
[ maybe "new remote host" (mappend "remote host " . sShow) rhId_ <> " stopped"
|
||||
CRRemoteHostStopped {remoteHostId_} ->
|
||||
[ maybe "new remote host" (mappend "remote host " . sShow) remoteHostId_ <> " stopped"
|
||||
]
|
||||
CRRemoteFileStored rhId (CryptoFile filePath cfArgs_) ->
|
||||
[plain $ "file " <> filePath <> " stored on remote host " <> show rhId]
|
||||
@@ -311,7 +311,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
||||
<> maybe (deviceName <> "not compatible") (\info -> viewRemoteCtrl info appVersion compatible) ctrlAppInfo_
|
||||
]
|
||||
where
|
||||
deviceName = if T.null ctrlDeviceName then "" else plain ctrlDeviceName <> ", "
|
||||
deviceName = if T.null ctrlDeviceName then "" else plain ctrlDeviceName <> ", "
|
||||
CRRemoteCtrlConnecting {remoteCtrl_, ctrlAppInfo, appVersion} ->
|
||||
[ (maybe "connecting new remote controller" (\RemoteCtrlInfo {remoteCtrlId} -> "connecting remote controller " <> sShow remoteCtrlId) remoteCtrl_ <> ": ")
|
||||
<> viewRemoteCtrl ctrlAppInfo appVersion True
|
||||
@@ -323,7 +323,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
||||
]
|
||||
CRRemoteCtrlConnected RemoteCtrlInfo {remoteCtrlId = rcId, ctrlDeviceName} ->
|
||||
["remote controller " <> sShow rcId <> " session started with " <> plain ctrlDeviceName]
|
||||
CRRemoteCtrlStopped -> ["remote controller stopped"]
|
||||
CRRemoteCtrlStopped {} -> ["remote controller stopped"]
|
||||
CRSQLResult rows -> map plain rows
|
||||
CRSlowSQLQueries {chatQueries, agentQueries} ->
|
||||
let viewQuery SlowSQLQuery {query, queryStats = SlowQueryStats {count, timeMax, timeAvg}} =
|
||||
|
||||
Reference in New Issue
Block a user