core: return controller app info in response when connecting, validate ID key (#3353)

This commit is contained in:
Evgeny Poberezkin
2023-11-12 14:40:49 +00:00
committed by GitHub
parent 8e3e58cac8
commit 92e3f576ca
8 changed files with 70 additions and 56 deletions
+20 -17
View File
@@ -75,11 +75,11 @@ import UnliftIO.Directory (copyFile, createDirectoryIfMissing, renameFile)
-- when acting as host
minRemoteCtrlVersion :: AppVersion
minRemoteCtrlVersion = AppVersion [5, 4, 0, 2]
minRemoteCtrlVersion = AppVersion [5, 4, 0, 3]
-- when acting as controller
minRemoteHostVersion :: AppVersion
minRemoteHostVersion = AppVersion [5, 4, 0, 2]
minRemoteHostVersion = AppVersion [5, 4, 0, 3]
currentAppVersion :: AppVersion
currentAppVersion = AppVersion SC.version
@@ -256,10 +256,9 @@ switchRemoteHost rhId_ = do
_ -> throwError $ ChatErrorRemoteHost rhKey RHEInactive
rhi_ <$ chatWriteVar currentRemoteHost rhId_
-- XXX: replacing hostPairing replaced with sessionActive, could be a ($>)
remoteHostInfo :: RemoteHost -> Bool -> RemoteHostInfo
remoteHostInfo RemoteHost {remoteHostId, storePath, hostName} sessionActive =
RemoteHostInfo {remoteHostId, storePath, hostName, sessionActive}
remoteHostInfo RemoteHost {remoteHostId, storePath, hostDeviceName} sessionActive =
RemoteHostInfo {remoteHostId, storePath, hostDeviceName, sessionActive}
deleteRemoteHost :: ChatMonad m => RemoteHostId -> m ()
deleteRemoteHost rhId = do
@@ -325,37 +324,41 @@ findKnownRemoteCtrl :: ChatMonad m => m ()
findKnownRemoteCtrl = undefined -- do
-- | Use provided OOB link as an annouce
connectRemoteCtrl :: ChatMonad m => RCSignedInvitation -> m ()
connectRemoteCtrl inv@RCSignedInvitation {invitation = RCInvitation {ca, app}} = do
(ctrlDeviceName, v) <- parseCtrlAppInfo app
connectRemoteCtrl :: ChatMonad m => RCSignedInvitation -> m (Maybe RemoteCtrl, CtrlAppInfo)
connectRemoteCtrl signedInv@RCSignedInvitation {invitation = inv@RCInvitation {ca, app}} = handleCtrlError "connectRemoteCtrl" $ do
(ctrlInfo@CtrlAppInfo {deviceName = ctrlDeviceName}, v) <- parseCtrlAppInfo app
withRemoteCtrlSession_ $ maybe (Right ((), Just RCSessionStarting)) (\_ -> Left $ ChatErrorRemoteCtrl RCEBusy)
rc_ <- withStore' $ \db -> getRemoteCtrlByFingerprint db ca
mapM_ (validateRemoteCtrl inv) rc_
hostAppInfo <- getHostAppInfo v
(rcsClient, vars) <- withAgent $ \a -> rcConnectCtrlURI a inv (ctrlPairing <$> rc_) (J.toJSON hostAppInfo)
(rcsClient, vars) <- withAgent $ \a -> rcConnectCtrlURI a signedInv (ctrlPairing <$> rc_) (J.toJSON hostAppInfo)
cmdOk <- newEmptyTMVarIO
rcsWaitSession <- async $ do
atomically $ takeTMVar cmdOk
handleCtrlError "waitForCtrlSession" $ waitForCtrlSession rc_ ctrlDeviceName rcsClient vars
handleCtrlError "connectRemoteCtrl" . updateRemoteCtrlSession $ \case
updateRemoteCtrlSession $ \case
RCSessionStarting -> Right RCSessionConnecting {rcsClient, rcsWaitSession}
_ -> Left $ ChatErrorRemoteCtrl RCEBadState
atomically $ putTMVar cmdOk ()
pure (rc_, ctrlInfo)
where
validateRemoteCtrl RCInvitation {idkey} RemoteCtrl {ctrlPairing = RCCtrlPairing {idPubKey}} =
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
let sessionCode = verificationCode uniq
toView CRRemoteCtrlSessionCode {remoteCtrl_ = (`remoteCtrlInfo` True) <$> rc_, sessionCode}
updateRemoteCtrlSession $ \case
RCSessionConnecting {rcsWaitSession} -> Right RCSessionPendingConfirmation {ctrlName, rcsClient, tls, sessionCode, rcsWaitSession, rcsWaitConfirmation}
RCSessionConnecting {rcsWaitSession} -> Right RCSessionPendingConfirmation {ctrlDeviceName = ctrlName, rcsClient, tls, sessionCode, rcsWaitSession, rcsWaitConfirmation}
_ -> Left $ ChatErrorRemoteCtrl RCEBadState
parseCtrlAppInfo ctrlAppInfo = do
CtrlAppInfo {deviceName, appVersionRange} <-
ctrlInfo@CtrlAppInfo {appVersionRange} <-
liftEitherWith (const $ ChatErrorRemoteCtrl RCEBadInvitation) $ JT.parseEither J.parseJSON ctrlAppInfo
v <- case compatibleAppVersion hostAppVersionRange appVersionRange of
Just (AppCompatible v) -> pure v
Nothing -> throwError $ ChatErrorRemoteCtrl $ RCEBadVersion $ maxVersion appVersionRange
pure (deviceName, v)
pure (ctrlInfo, v)
getHostAppInfo appVersion = do
hostDeviceName <- chatReadVar localDeviceName
encryptFiles <- chatReadVar encryptLocalFiles
@@ -465,8 +468,8 @@ listRemoteCtrls = do
remoteCtrlInfo rc $ activeRcId == Just remoteCtrlId
remoteCtrlInfo :: RemoteCtrl -> Bool -> RemoteCtrlInfo
remoteCtrlInfo RemoteCtrl {remoteCtrlId, ctrlName} sessionActive =
RemoteCtrlInfo {remoteCtrlId, ctrlName, sessionActive}
remoteCtrlInfo RemoteCtrl {remoteCtrlId, ctrlDeviceName} sessionActive =
RemoteCtrlInfo {remoteCtrlId, ctrlDeviceName, sessionActive}
-- XXX: only used for multicast
confirmRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m ()
@@ -482,7 +485,7 @@ verifyRemoteCtrlSession :: ChatMonad m => (ByteString -> m ChatResponse) -> Text
verifyRemoteCtrlSession execChatCommand sessCode' = handleCtrlError "verifyRemoteCtrlSession" $ do
(client, ctrlName, sessionCode, vars) <-
getRemoteCtrlSession >>= \case
RCSessionPendingConfirmation {rcsClient, ctrlName, sessionCode, rcsWaitConfirmation} -> pure (rcsClient, ctrlName, sessionCode, rcsWaitConfirmation)
RCSessionPendingConfirmation {rcsClient, ctrlDeviceName = ctrlName, sessionCode, rcsWaitConfirmation} -> pure (rcsClient, ctrlName, sessionCode, rcsWaitConfirmation)
_ -> throwError $ ChatErrorRemoteCtrl RCEBadState
let verified = sameVerificationCode sessCode' sessionCode
liftIO $ confirmCtrlSession client verified
@@ -506,7 +509,7 @@ verifyRemoteCtrlSession execChatCommand sessCode' = handleCtrlError "verifyRemot
Just rc@RemoteCtrl {ctrlPairing} -> do
let dhPrivKey' = dhPrivKey rcCtrlPairing
liftIO $ updateRemoteCtrl db rc ctrlName dhPrivKey'
pure rc {ctrlName, ctrlPairing = ctrlPairing {dhPrivKey = dhPrivKey'}}
pure rc {ctrlDeviceName = ctrlName, ctrlPairing = ctrlPairing {dhPrivKey = dhPrivKey'}}
monitor :: ChatMonad m => Async () -> m ()
monitor server = do
res <- waitCatch server