core: update remote host session state, terminate TLS in one more case (#3364)
* core: update remote host session state, terminate TLS in one more case * name
This commit is contained in:
Evgeny Poberezkin
GitHub
parent
598b6659cc
commit
c91625b32a
@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/simplex-chat/simplexmq.git
|
||||
tag: 4f5d52ada47a15532766b2ff3d3781be629648d8
|
||||
tag: e0b7942e45e36d92625e07c0c1ce9ca2375a0980
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
{
|
||||
"https://github.com/simplex-chat/simplexmq.git"."c051ebab74632e0eb60686329ab3fad521736f79" = "1j7z3v3vk02nq4sw46flky1l4pjxfiypbwh5s77m6f81rc0vsjvi";
|
||||
"https://github.com/simplex-chat/simplexmq.git"."e0b7942e45e36d92625e07c0c1ce9ca2375a0980" = "0swbcrmdirwqrk0kx5jmc5lcrzasccfwn3papb5c1p8hn0hjnzj7";
|
||||
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
|
||||
"https://github.com/kazu-yamamoto/http2.git"."f5525b755ff2418e6e6ecc69e877363b0d0bcaeb" = "0fyx0047gvhm99ilp212mmz37j84cwrfnpmssib5dw363fyb88b6";
|
||||
"https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";
|
||||
|
||||
@ -32,7 +32,7 @@ import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Word (Word16, Word32)
|
||||
import qualified Network.HTTP.Types as N
|
||||
import Network.HTTP2.Server (responseStreaming)
|
||||
@ -129,7 +129,7 @@ startRemoteHost rh_ = do
|
||||
(rhKey, multicast, remoteHost_, pairing) <- case rh_ of
|
||||
Just (rhId, multicast) -> do
|
||||
rh@RemoteHost {hostPairing} <- withStore $ \db -> getRemoteHost db rhId
|
||||
pure (RHId rhId, multicast, Just $ remoteHostInfo rh True, hostPairing) -- get from the database, start multicast if requested
|
||||
pure (RHId rhId, multicast, Just $ remoteHostInfo rh $ Just RHSStarting, hostPairing) -- get from the database, start multicast if requested
|
||||
Nothing -> (RHNew,False,Nothing,) <$> rcNewHostPairing
|
||||
withRemoteHostSession_ rhKey $ maybe (Right ((), Just RHSessionStarting)) (\_ -> Left $ ChatErrorRemoteHost rhKey RHEBusy)
|
||||
ctrlAppInfo <- mkCtrlAppInfo
|
||||
@ -141,7 +141,9 @@ startRemoteHost rh_ = do
|
||||
handleHostError rhKeyVar $ waitForHostSession remoteHost_ rhKey rhKeyVar vars
|
||||
let rhs = RHPendingSession {rhKey, rchClient, rhsWaitSession, remoteHost_}
|
||||
withRemoteHostSession rhKey $ \case
|
||||
RHSessionStarting -> Right ((), RHSessionConnecting rhs)
|
||||
RHSessionStarting ->
|
||||
let inv = decodeLatin1 $ strEncode invitation
|
||||
in Right ((), RHSessionConnecting inv rhs)
|
||||
_ -> Left $ ChatErrorRemoteHost rhKey RHEBadState
|
||||
(remoteHost_, invitation) <$ atomically (putTMVar cmdOk ())
|
||||
where
|
||||
@ -162,18 +164,22 @@ startRemoteHost rh_ = do
|
||||
sessions <- asks remoteHostSessions
|
||||
session_ <- atomically $ readTVar rhKeyVar >>= (`TM.lookupDelete` sessions)
|
||||
mapM_ (liftIO . cancelRemoteHost) session_
|
||||
waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> TVar RHKey -> RCStepTMVar (ByteString, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m ()
|
||||
waitForHostSession :: ChatMonad m => Maybe RemoteHostInfo -> RHKey -> TVar RHKey -> RCStepTMVar (ByteString, TLS, RCStepTMVar (RCHostSession, RCHostHello, RCHostPairing)) -> m ()
|
||||
waitForHostSession remoteHost_ rhKey rhKeyVar vars = do
|
||||
(sessId, vars') <- takeRCStep vars -- no timeout, waiting for user to scan invite
|
||||
(sessId, tls, vars') <- takeRCStep vars -- no timeout, waiting for user to scan invite
|
||||
let sessCode = verificationCode sessId
|
||||
withRemoteHostSession rhKey $ \case
|
||||
RHSessionConnecting _inv rhs' -> Right ((), RHSessionPendingConfirmation sessCode tls rhs') -- TODO check it's the same session?
|
||||
_ -> Left $ ChatErrorRemoteHost rhKey RHEBadState
|
||||
toView $ CRRemoteHostSessionCode {remoteHost_, sessionCode = verificationCode sessId} -- display confirmation code, wait for mobile to confirm
|
||||
(RCHostSession {tls, sessionKeys}, rhHello, pairing') <- takeRCStep vars' -- no timeout, waiting for user to compare the code
|
||||
(RCHostSession {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
|
||||
RHSessionConnecting rhs' -> Right ((), RHSessionConfirmed tls rhs') -- TODO check it's the same session?
|
||||
RHSessionPendingConfirmation _ tls' rhs' -> Right ((), RHSessionConfirmed tls' rhs') -- TODO check it's the same session?
|
||||
_ -> Left $ ChatErrorRemoteHost rhKey RHEBadState
|
||||
-- update remoteHost with updated pairing
|
||||
rhi@RemoteHostInfo {remoteHostId, storePath} <- upsertRemoteHost pairing' remoteHost_ hostDeviceName
|
||||
rhi@RemoteHostInfo {remoteHostId, storePath} <- upsertRemoteHost pairing' remoteHost_ hostDeviceName RHSConfirmed
|
||||
let rhKey' = RHId remoteHostId -- rhKey may be invalid after upserting on RHNew
|
||||
when (rhKey' /= rhKey) $ do
|
||||
atomically $ writeTVar rhKeyVar rhKey'
|
||||
@ -187,18 +193,18 @@ startRemoteHost rh_ = do
|
||||
_ -> 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_} rhi_ hostDeviceName = do
|
||||
upsertRemoteHost :: ChatMonad m => RCHostPairing -> Maybe RemoteHostInfo -> Text -> RemoteHostSessionState -> m RemoteHostInfo
|
||||
upsertRemoteHost pairing'@RCHostPairing {knownHost = kh_} rhi_ hostDeviceName state = do
|
||||
KnownHostPairing {hostDhPubKey = hostDhPubKey'} <- maybe (throwError . ChatError $ CEInternalError "KnownHost is known after verification") pure kh_
|
||||
case rhi_ of
|
||||
Nothing -> do
|
||||
storePath <- liftIO randomStorePath
|
||||
rh@RemoteHost {remoteHostId} <- withStore $ \db -> insertRemoteHost db hostDeviceName storePath pairing' >>= getRemoteHost db
|
||||
setNewRemoteHostId RHNew remoteHostId
|
||||
pure $ remoteHostInfo rh True
|
||||
pure $ remoteHostInfo rh $ Just state
|
||||
Just rhi@RemoteHostInfo {remoteHostId} -> do
|
||||
withStore' $ \db -> updateHostPairing db remoteHostId hostDeviceName hostDhPubKey'
|
||||
pure (rhi :: RemoteHostInfo) {sessionActive = True}
|
||||
pure (rhi :: RemoteHostInfo) {sessionState = Just state}
|
||||
onDisconnected :: ChatMonad m => RemoteHostId -> m ()
|
||||
onDisconnected remoteHostId = do
|
||||
logDebug "HTTP2 client disconnected"
|
||||
@ -225,7 +231,10 @@ closeRemoteHost rhKey = do
|
||||
cancelRemoteHost :: RemoteHostSession -> IO ()
|
||||
cancelRemoteHost = \case
|
||||
RHSessionStarting -> pure ()
|
||||
RHSessionConnecting rhs -> cancelPendingSession rhs
|
||||
RHSessionConnecting _inv rhs -> cancelPendingSession rhs
|
||||
RHSessionPendingConfirmation _sessCode tls rhs -> do
|
||||
cancelPendingSession rhs
|
||||
closeConnection tls
|
||||
RHSessionConfirmed tls rhs -> do
|
||||
cancelPendingSession rhs
|
||||
closeConnection tls
|
||||
@ -245,26 +254,26 @@ randomStorePath = B.unpack . B64U.encode <$> getRandomBytes 12
|
||||
|
||||
listRemoteHosts :: ChatMonad m => m [RemoteHostInfo]
|
||||
listRemoteHosts = do
|
||||
active <- chatReadVar remoteHostSessions
|
||||
map (rhInfo active) <$> withStore' getRemoteHosts
|
||||
sessions <- chatReadVar remoteHostSessions
|
||||
map (rhInfo sessions) <$> withStore' getRemoteHosts
|
||||
where
|
||||
rhInfo active rh@RemoteHost {remoteHostId} =
|
||||
remoteHostInfo rh (M.member (RHId remoteHostId) active)
|
||||
rhInfo sessions rh@RemoteHost {remoteHostId} =
|
||||
remoteHostInfo rh (rhsSessionState <$> M.lookup (RHId remoteHostId) sessions)
|
||||
|
||||
switchRemoteHost :: ChatMonad m => Maybe RemoteHostId -> m (Maybe RemoteHostInfo)
|
||||
switchRemoteHost rhId_ = do
|
||||
rhi_ <- forM rhId_ $ \rhId -> do
|
||||
let rhKey = RHId rhId
|
||||
rhi <- (`remoteHostInfo` True) <$> withStore (`getRemoteHost` rhId)
|
||||
active <- chatReadVar remoteHostSessions
|
||||
case M.lookup rhKey active of
|
||||
Just RHSessionConnected {} -> pure rhi
|
||||
rh <- withStore (`getRemoteHost` rhId)
|
||||
sessions <- chatReadVar remoteHostSessions
|
||||
case M.lookup rhKey sessions of
|
||||
Just RHSessionConnected {} -> pure $ remoteHostInfo rh $ Just RHSConnected
|
||||
_ -> throwError $ ChatErrorRemoteHost rhKey RHEInactive
|
||||
rhi_ <$ chatWriteVar currentRemoteHost rhId_
|
||||
|
||||
remoteHostInfo :: RemoteHost -> Bool -> RemoteHostInfo
|
||||
remoteHostInfo RemoteHost {remoteHostId, storePath, hostDeviceName} sessionActive =
|
||||
RemoteHostInfo {remoteHostId, storePath, hostDeviceName, sessionActive}
|
||||
remoteHostInfo :: RemoteHost -> Maybe RemoteHostSessionState -> RemoteHostInfo
|
||||
remoteHostInfo RemoteHost {remoteHostId, storePath, hostDeviceName} sessionState =
|
||||
RemoteHostInfo {remoteHostId, storePath, hostDeviceName, sessionState}
|
||||
|
||||
deleteRemoteHost :: ChatMonad m => RemoteHostId -> m ()
|
||||
deleteRemoteHost rhId = do
|
||||
|
||||
@ -3,6 +3,7 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
@ -63,7 +64,8 @@ data RHPendingSession = RHPendingSession
|
||||
|
||||
data RemoteHostSession
|
||||
= RHSessionStarting
|
||||
| RHSessionConnecting {rhPendingSession :: RHPendingSession}
|
||||
| RHSessionConnecting {invitation :: Text, rhPendingSession :: RHPendingSession}
|
||||
| RHSessionPendingConfirmation {sessionCode :: Text, tls :: TLS, rhPendingSession :: RHPendingSession}
|
||||
| RHSessionConfirmed {tls :: TLS, rhPendingSession :: RHPendingSession}
|
||||
| RHSessionConnected
|
||||
{ rchClient :: RCHostClient,
|
||||
@ -73,6 +75,22 @@ data RemoteHostSession
|
||||
storePath :: FilePath
|
||||
}
|
||||
|
||||
data RemoteHostSessionState
|
||||
= RHSStarting
|
||||
| RHSConnecting {invitation :: Text}
|
||||
| RHSPendingConfirmation {sessionCode :: Text}
|
||||
| RHSConfirmed
|
||||
| RHSConnected
|
||||
deriving (Show)
|
||||
|
||||
rhsSessionState :: RemoteHostSession -> RemoteHostSessionState
|
||||
rhsSessionState = \case
|
||||
RHSessionStarting -> RHSStarting
|
||||
RHSessionConnecting {invitation} -> RHSConnecting {invitation}
|
||||
RHSessionPendingConfirmation {sessionCode} -> RHSPendingConfirmation {sessionCode}
|
||||
RHSessionConfirmed {} -> RHSConfirmed
|
||||
RHSessionConnected {} -> RHSConnected
|
||||
|
||||
data RemoteProtocolError
|
||||
= -- | size prefix is malformed
|
||||
RPEInvalidSize
|
||||
@ -112,7 +130,7 @@ data RemoteHostInfo = RemoteHostInfo
|
||||
{ remoteHostId :: RemoteHostId,
|
||||
hostDeviceName :: Text,
|
||||
storePath :: FilePath,
|
||||
sessionActive :: Bool
|
||||
sessionState :: Maybe RemoteHostSessionState
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
@ -174,6 +192,8 @@ $(J.deriveJSON (sumTypeJSON $ dropPrefix "RH") ''RHKey)
|
||||
|
||||
$(J.deriveJSON (enumJSON $ dropPrefix "PE") ''PlatformEncoding)
|
||||
|
||||
$(J.deriveJSON (sumTypeJSON $ dropPrefix "RHS") ''RemoteHostSessionState)
|
||||
|
||||
$(J.deriveJSON defaultJSON ''RemoteHostInfo)
|
||||
|
||||
$(J.deriveJSON defaultJSON ''RemoteCtrlInfo)
|
||||
|
||||
@ -1704,8 +1704,14 @@ viewRemoteHosts = \case
|
||||
[] -> ["No remote hosts"]
|
||||
hs -> "Remote hosts: " : map viewRemoteHostInfo hs
|
||||
where
|
||||
viewRemoteHostInfo RemoteHostInfo {remoteHostId, hostDeviceName, sessionActive} =
|
||||
plain $ tshow remoteHostId <> ". " <> hostDeviceName <> if sessionActive then " (active)" else ""
|
||||
viewRemoteHostInfo RemoteHostInfo {remoteHostId, hostDeviceName, sessionState} =
|
||||
plain $ tshow remoteHostId <> ". " <> hostDeviceName <> maybe "" viewSessionState sessionState
|
||||
viewSessionState = \case
|
||||
RHSStarting -> " (starting)"
|
||||
RHSConnecting _ -> " (connecting)"
|
||||
RHSPendingConfirmation {sessionCode} -> " (pending confirmation, code: " <> sessionCode <> ")"
|
||||
RHSConfirmed -> " (confirmed)"
|
||||
RHSConnected -> " (connected)"
|
||||
|
||||
viewRemoteCtrls :: [RemoteCtrlInfo] -> [StyledString]
|
||||
viewRemoteCtrls = \case
|
||||
@ -1713,7 +1719,7 @@ viewRemoteCtrls = \case
|
||||
hs -> "Remote controllers: " : map viewRemoteCtrlInfo hs
|
||||
where
|
||||
viewRemoteCtrlInfo RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName, sessionActive} =
|
||||
plain $ tshow remoteCtrlId <> ". " <> ctrlDeviceName <> if sessionActive then " (active)" else ""
|
||||
plain $ tshow remoteCtrlId <> ". " <> ctrlDeviceName <> if sessionActive then " (connected)" else ""
|
||||
|
||||
-- TODO fingerprint, accepted?
|
||||
viewRemoteCtrl :: RemoteCtrlInfo -> StyledString
|
||||
|
||||
@ -49,7 +49,7 @@ extra-deps:
|
||||
# - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
|
||||
# - ../simplexmq
|
||||
- github: simplex-chat/simplexmq
|
||||
commit: c051ebab74632e0eb60686329ab3fad521736f79
|
||||
commit: e0b7942e45e36d92625e07c0c1ce9ca2375a0980
|
||||
- github: kazu-yamamoto/http2
|
||||
commit: f5525b755ff2418e6e6ecc69e877363b0d0bcaeb
|
||||
# - ../direct-sqlcipher
|
||||
|
||||
@ -57,11 +57,11 @@ remoteHandshakeTest viaDesktop = testChat2 aliceProfile aliceDesktopProfile $ \m
|
||||
|
||||
desktop ##> "/list remote hosts"
|
||||
desktop <## "Remote hosts:"
|
||||
desktop <## "1. Mobile (active)"
|
||||
desktop <## "1. Mobile (connected)"
|
||||
|
||||
mobile ##> "/list remote ctrls"
|
||||
mobile <## "Remote controllers:"
|
||||
mobile <## "1. My desktop (active)"
|
||||
mobile <## "1. My desktop (connected)"
|
||||
|
||||
if viaDesktop then stopDesktop mobile desktop else stopMobile mobile desktop
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user