diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index 8bb354c216..6ff470cca1 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -141,18 +141,21 @@ startRemoteHost' rh_ = do mkCtrlAppInfo = do deviceName <- chatReadVar localDeviceName pure CtrlAppInfo {appVersionRange = ctrlAppVersionRange, deviceName} - parseHostAppInfo RCHostHello {app = hostAppInfo} rhKey = do - HostAppInfo {deviceName, appVersion} <- - liftEitherWith (ChatErrorRemoteHost rhKey . RHEProtocolError . RPEInvalidJSON) $ JT.parseEither J.parseJSON hostAppInfo - unless (isAppCompatible appVersion ctrlAppVersionRange) $ throwError $ ChatErrorRemoteHost rhKey $ RHEBadVersion appVersion - pure deviceName + parseHostAppInfo :: RCHostHello -> ExceptT RemoteHostError IO HostAppInfo + parseHostAppInfo RCHostHello {app = hostAppInfo} = do + hostInfo@HostAppInfo {deviceName, appVersion, encoding, encryptFiles} <- + 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 (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' - hostDeviceName <- parseHostAppInfo rhHello rhKey + hostInfo@HostAppInfo {deviceName = hostDeviceName} <- + 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 @@ -161,7 +164,7 @@ startRemoteHost' rh_ = do let rhKey' = RHId remoteHostId disconnected <- toIO $ onDisconnected remoteHostId httpClient <- liftEitherError (httpError rhKey) $ attachRevHTTP2Client disconnected tls - rhClient <- liftRC $ createRemoteHostClient httpClient sessionKeys storePath hostDeviceName + let rhClient = mkRemoteHostClient httpClient sessionKeys storePath hostInfo pollAction <- async $ pollEvents remoteHostId rhClient withRemoteHostSession rhKey' $ \case RHSessionConfirmed RHPendingSession {} -> Right ((), RHSessionConnected {rhClient, pollAction, storePath}) @@ -346,7 +349,6 @@ handleRemoteCommand execChatCommand _sessionKeys remoteOutputQ HTTP2Request {req replyError = reply . RRChatResponse . CRChatCmdError Nothing processCommand :: User -> GetChunk -> RemoteCommand -> m () processCommand user getNext = \case - RCHello {deviceName = desktopName} -> handleHello desktopName >>= reply RCSend {command} -> handleSend execChatCommand command >>= reply RCRecv {wait = time} -> handleRecv time remoteOutputQ >>= reply RCStoreFile {fileName, fileSize, fileDigest} -> handleStoreFile fileName fileSize fileDigest getNext >>= reply @@ -376,13 +378,6 @@ tryRemoteError :: ExceptT RemoteProtocolError IO a -> ExceptT RemoteProtocolErro tryRemoteError = tryAllErrors (RPEException . tshow) {-# INLINE tryRemoteError #-} -handleHello :: ChatMonad m => Text -> m RemoteResponse -handleHello desktopName = do - logInfo $ "Hello from " <> tshow desktopName - mobileName <- chatReadVar localDeviceName - encryptFiles <- chatReadVar encryptLocalFiles - pure RRHello {encoding = localEncoding, deviceName = mobileName, encryptFiles} - handleSend :: ChatMonad m => (ByteString -> m ChatResponse) -> Text -> m RemoteResponse handleSend execChatCommand command = do logDebug $ "Send: " <> tshow command diff --git a/src/Simplex/Chat/Remote/Protocol.hs b/src/Simplex/Chat/Remote/Protocol.hs index 2868a45107..62db487cbd 100644 --- a/src/Simplex/Chat/Remote/Protocol.hs +++ b/src/Simplex/Chat/Remote/Protocol.hs @@ -9,7 +9,6 @@ module Simplex.Chat.Remote.Protocol where -import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Data.Aeson ((.=)) @@ -44,8 +43,7 @@ import System.FilePath (takeFileName, ()) import UnliftIO data RemoteCommand - = RCHello {deviceName :: Text} - | RCSend {command :: Text} -- TODO maybe ChatCommand here? + = RCSend {command :: Text} -- TODO maybe ChatCommand here? | RCRecv {wait :: Int} -- this wait should be less than HTTP timeout | -- local file encryption is determined by the host, but can be overridden for videos RCStoreFile {fileName :: String, fileSize :: Word32, fileDigest :: FileDigest} -- requires attachment @@ -53,8 +51,7 @@ data RemoteCommand deriving (Show) data RemoteResponse - = RRHello {encoding :: PlatformEncoding, deviceName :: Text, encryptFiles :: Bool} - | RRChatResponse {chatResponse :: ChatResponse} + = RRChatResponse {chatResponse :: ChatResponse} | RRChatEvent {chatEvent :: Maybe ChatResponse} -- ^ 'Nothing' on poll timeout | RRFileStored {filePath :: String} | RRFile {fileSize :: Word32, fileDigest :: FileDigest} -- provides attachment , fileDigest :: FileDigest @@ -67,22 +64,16 @@ $(deriveJSON (taggedObjectJSON $ dropPrefix "RR") ''RemoteResponse) -- * Client side / desktop -createRemoteHostClient :: HTTP2Client -> HostSessKeys -> FilePath -> Text -> ExceptT RemoteProtocolError IO RemoteHostClient -createRemoteHostClient httpClient sessionKeys storePath desktopName = do - logDebug "Sending initial hello" - sendRemoteCommand' httpClient localEncoding Nothing RCHello {deviceName = desktopName} >>= \case - RRHello {encoding, deviceName = mobileName, encryptFiles} -> do - logDebug "Got initial hello" - when (encoding == PEKotlin && localEncoding == PESwift) $ throwError RPEIncompatibleEncoding - pure RemoteHostClient - { hostEncoding = encoding, - hostDeviceName = mobileName, - httpClient, - encryptHostFiles = encryptFiles, - sessionKeys, - storePath - } - r -> badResponse r +mkRemoteHostClient :: HTTP2Client -> HostSessKeys -> FilePath -> HostAppInfo -> RemoteHostClient +mkRemoteHostClient httpClient sessionKeys storePath HostAppInfo {encoding, deviceName, encryptFiles} = + RemoteHostClient + { hostEncoding = encoding, + hostDeviceName = deviceName, + httpClient, + encryptHostFiles = encryptFiles, + sessionKeys, + storePath + } closeRemoteHostClient :: MonadIO m => RemoteHostClient -> m () closeRemoteHostClient RemoteHostClient {httpClient} = liftIO $ closeHTTP2Client httpClient @@ -148,7 +139,7 @@ convertJSON :: PlatformEncoding -> PlatformEncoding -> J.Value -> J.Value convertJSON _remote@PEKotlin _local@PEKotlin = id convertJSON PESwift PESwift = id convertJSON PESwift PEKotlin = owsf2tagged -convertJSON PEKotlin PESwift = error "unsupported convertJSON: K/S" -- guarded by createRemoteHostClient +convertJSON PEKotlin PESwift = error "unsupported convertJSON: K/S" -- guarded by handshake -- | Convert swift single-field sum encoding into tagged/discriminator-field owsf2tagged :: J.Value -> J.Value