core: use xrcp protocol for desktop/mobile connection (#3305)

* WIP: start working on /connect remote ctrl

OOB is broken, requires fixing simplexmq bits.

* WIP: pull CtrlCryptoHandle from xrcp

* place xrcp stubs

* WIP: start switching to RemoteControl.Client types

* fix http2 sha

* fix sha256map.nix

* fix cabal.project

* update RC test

* WIP: add new remote session

* fix compilation

* simplify

* attach HTTP2 server to TLS

* starting host session in controller (WIP)

* more WIP

* compiles

* compiles2

* wip

* pass startRemote' test

* async to poll for events from host, test to send messages fails

* move xrcp handshake test to simplexmq

* detect session stops

* fix connectRemoteCtrl

* use step type

* app info

* WIP: pairing stores

* plug in hello/appInfo/pairings

* negotiate app version

* update simplexmw, remove KEM secrets from DB

* fix file tests

* tone down http2 shutdown errors

* Add stored session test

* bump simplexmq tag

* update simplexmq

* refactor, fix

* removed unused errors

* rename fields, remove unused file

* rename errors

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>

src/Simplex/Chat/Remote/AppVersion.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Simplex.Chat.Remote.AppVersion
+  ( AppVersionRange (minVersion, maxVersion),
+    AppVersion (..),
+    pattern AppCompatible,
+    mkAppVersionRange,
+    compatibleAppVersion,
+    isAppCompatible,
+  )
+  where
+
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Aeson as J
+import qualified Data.Aeson.Encoding as JE
+import qualified Data.Aeson.TH as JQ
+import qualified Data.Text as T
+import Data.Version (parseVersion, showVersion)
+import qualified Data.Version as V
+import Simplex.Messaging.Parsers (defaultJSON)
+import Text.ParserCombinators.ReadP (readP_to_S)
+
+newtype AppVersion = AppVersion V.Version
+  deriving (Eq, Ord, Show)
+
+instance ToJSON AppVersion where
+  toJSON (AppVersion v) = J.String . T.pack $ showVersion v
+  toEncoding (AppVersion v) = JE.text . T.pack $ showVersion v
+
+instance FromJSON AppVersion where
+  parseJSON = J.withText "AppVersion" $ parse . T.unpack
+    where
+      parse s = case filter (null . snd) $ readP_to_S parseVersion s of
+        (v, _) : _ -> pure $ AppVersion v
+        _ -> fail $ "bad AppVersion: " <> s
+
+data AppVersionRange = AppVRange
+  { minVersion :: AppVersion,
+    maxVersion :: AppVersion
+  }
+
+mkAppVersionRange :: AppVersion -> AppVersion -> AppVersionRange
+mkAppVersionRange v1 v2
+  | v1 <= v2 = AppVRange v1 v2
+  | otherwise = error "invalid version range"
+
+newtype AppCompatible a = AppCompatible_ a
+
+pattern AppCompatible :: a -> AppCompatible a
+pattern AppCompatible a <- AppCompatible_ a
+
+{-# COMPLETE AppCompatible #-}
+
+isAppCompatible :: AppVersion -> AppVersionRange -> Bool
+isAppCompatible v (AppVRange v1 v2) = v1 <= v && v <= v2
+
+isCompatibleAppRange :: AppVersionRange -> AppVersionRange -> Bool
+isCompatibleAppRange (AppVRange min1 max1) (AppVRange min2 max2) = min1 <= max2 && min2 <= max1
+
+compatibleAppVersion :: AppVersionRange -> AppVersionRange -> Maybe (AppCompatible AppVersion)
+compatibleAppVersion vr1 vr2 =
+  min (maxVersion vr1) (maxVersion vr2) `mkCompatibleIf` isCompatibleAppRange vr1 vr2
+
+mkCompatibleIf :: AppVersion -> Bool -> Maybe (AppCompatible AppVersion)
+v `mkCompatibleIf` cond = if cond then Just $ AppCompatible_ v else Nothing
+
+$(JQ.deriveJSON defaultJSON ''AppVersionRange)

src/Simplex/Chat/Remote/Protocol.hs

@@ -19,7 +19,7 @@ import qualified Data.Aeson.KeyMap as JM
 import Data.Aeson.TH (deriveJSON)
 import qualified Data.Aeson.Types as JT
 import Data.ByteString (ByteString)
-import Data.ByteString.Builder (Builder, word32BE, lazyByteString)
+import Data.ByteString.Builder (Builder, lazyByteString, word32BE)
 import qualified Data.ByteString.Lazy as LB
 import Data.String (fromString)
 import Data.Text (Text)
@@ -39,7 +39,8 @@ import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBod
 import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect)
 import Simplex.Messaging.Transport.HTTP2.File (hSendFile)
 import Simplex.Messaging.Util (liftEitherError, liftEitherWith, tshow)
-import System.FilePath ((</>), takeFileName)
+import Simplex.RemoteControl.Types (HostSessKeys)
+import System.FilePath (takeFileName, (</>))
 import UnliftIO
 
 data RemoteCommand
@@ -66,14 +67,21 @@ $(deriveJSON (taggedObjectJSON $ dropPrefix "RR") ''RemoteResponse)
 
 -- * Client side / desktop
 
-createRemoteHostClient :: HTTP2Client -> dh -> Text -> ExceptT RemoteProtocolError IO RemoteHostClient
-createRemoteHostClient httpClient todo'dhKey desktopName = do
+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}
+      pure RemoteHostClient
+        { hostEncoding = encoding,
+          hostDeviceName = mobileName,
+          httpClient,
+          encryptHostFiles = encryptFiles,
+          sessionKeys,
+          storePath
+        }
     r -> badResponse r
 
 closeRemoteHostClient :: MonadIO m => RemoteHostClient -> m ()

src/Simplex/Chat/Remote/RevHTTP.hs

@@ -8,37 +8,20 @@
 
 module Simplex.Chat.Remote.RevHTTP where
 
-import Simplex.RemoteControl.Discovery
-import Simplex.RemoteControl.Types
-import Control.Logger.Simple
-import qualified Network.TLS as TLS
-import qualified Simplex.Messaging.Crypto as C
-import qualified Simplex.Messaging.Transport as Transport
+import Simplex.Messaging.Transport (TLS)
 import Simplex.Messaging.Transport.HTTP2 (defaultHTTP2BufferSize, getHTTP2Body)
 import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError (..), attachHTTP2Client, bodyHeadSize, connTimeout, defaultHTTP2ClientConfig)
 import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..), runHTTP2ServerWith)
-import Simplex.Messaging.Util (ifM)
+import Simplex.RemoteControl.Discovery
 import UnliftIO
 
-announceRevHTTP2 :: MonadUnliftIO m => Tasks -> (C.PrivateKeyEd25519, Announce) -> TLS.Credentials -> m () -> m (Either HTTP2ClientError HTTP2Client)
-announceRevHTTP2 = announceCtrl runHTTP2Client
-
--- | Attach HTTP2 client and hold the TLS until the attached client finishes.
-runHTTP2Client :: MVar () -> MVar (Either HTTP2ClientError HTTP2Client) -> Transport.TLS -> IO ()
-runHTTP2Client finishedVar clientVar tls =
-  ifM (isEmptyMVar clientVar)
-    attachClient
-    (logError "HTTP2 session already started on this listener")
+attachRevHTTP2Client :: IO () -> TLS -> IO (Either HTTP2ClientError HTTP2Client)
+attachRevHTTP2Client disconnected = attachHTTP2Client config ANY_ADDR_V4 "0" disconnected defaultHTTP2BufferSize
   where
-    attachClient = do
-      client <- attachHTTP2Client config ANY_ADDR_V4 DISCOVERY_PORT (putMVar finishedVar ()) defaultHTTP2BufferSize tls
-      putMVar clientVar client
-      readMVar finishedVar
-    -- TODO connection timeout
     config = defaultHTTP2ClientConfig {bodyHeadSize = doNotPrefetchHead, connTimeout = maxBound}
 
-attachHTTP2Server :: (MonadUnliftIO m) => (HTTP2Request -> m ()) -> Transport.TLS -> m ()
-attachHTTP2Server processRequest tls = do
+attachHTTP2Server :: MonadUnliftIO m => TLS -> (HTTP2Request -> m ()) -> m ()
+attachHTTP2Server tls processRequest = do
   withRunInIO $ \unlift ->
     runHTTP2ServerWith defaultHTTP2BufferSize ($ tls) $ \sessionId r sendResponse -> do
       reqBody <- getHTTP2Body r doNotPrefetchHead

src/Simplex/Chat/Remote/Types.hs

@@ -9,34 +9,45 @@
 
 module Simplex.Chat.Remote.Types where
 
+import Control.Concurrent.Async (Async)
 import Control.Exception (Exception)
 import qualified Data.Aeson.TH as J
 import Data.Int (Int64)
 import Data.Text (Text)
-import qualified Simplex.Messaging.Crypto as C
+import Simplex.Chat.Remote.AppVersion
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON)
 import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
-import Simplex.RemoteControl.Types (Tasks)
+import Simplex.RemoteControl.Client
+import Simplex.RemoteControl.Types
 import Simplex.Messaging.Crypto.File (CryptoFile)
 
 data RemoteHostClient = RemoteHostClient
   { hostEncoding :: PlatformEncoding,
     hostDeviceName :: Text,
     httpClient :: HTTP2Client,
-    encryptHostFiles :: Bool
-  }
-
-data RemoteHostSession = RemoteHostSession
-  { remoteHostTasks :: Tasks,
-    remoteHostClient :: Maybe RemoteHostClient,
+    sessionKeys :: HostSessKeys,
+    encryptHostFiles :: Bool,
     storePath :: FilePath
   }
 
+data RHPendingSession = RHPendingSession
+  { rhKey :: RHKey,
+    rchClient :: RCHostClient,
+    rhsWaitSession :: Async (),
+    remoteHost_ :: Maybe RemoteHostInfo
+  }
+
+data RemoteHostSession
+  = RHSessionStarting
+  | RHSessionConnecting {rhPendingSession :: RHPendingSession}
+  | RHSessionConfirmed {rhPendingSession :: RHPendingSession}
+  | RHSessionConnected {rhClient :: RemoteHostClient, pollAction :: Async (), storePath :: FilePath}
+
 data RemoteProtocolError
   = -- | size prefix is malformed
     RPEInvalidSize
   | -- | failed to parse RemoteCommand or RemoteResponse
-    RPEInvalidJSON {invalidJSON :: Text}
+    RPEInvalidJSON {invalidJSON :: String}
   | RPEIncompatibleEncoding
   | RPEUnexpectedFile
   | RPENoFile
@@ -52,47 +63,39 @@ data RemoteProtocolError
 
 type RemoteHostId = Int64
 
+data RHKey = RHNew | RHId {remoteHostId :: RemoteHostId}
+  deriving (Eq, Ord, Show)
+
+-- | Storable/internal remote host data
 data RemoteHost = RemoteHost
   { remoteHostId :: RemoteHostId,
+    hostName :: Text,
     storePath :: FilePath,
-    displayName :: Text,
-    -- | Credentials signing key for root and session certs
-    caKey :: C.APrivateSignKey,
-    -- | A stable part of TLS credentials used in remote session
-    caCert :: C.SignedCertificate,
-    contacted :: Bool
+    hostPairing :: RCHostPairing
   }
-  deriving (Show)
-
-data RemoteCtrlOOB = RemoteCtrlOOB
-  { fingerprint :: C.KeyHash,
-    displayName :: Text
-  }
-  deriving (Show)
 
+-- | UI-accessible remote host information
 data RemoteHostInfo = RemoteHostInfo
   { remoteHostId :: RemoteHostId,
+    hostName :: Text,
     storePath :: FilePath,
-    displayName :: Text,
     sessionActive :: Bool
   }
   deriving (Show)
 
 type RemoteCtrlId = Int64
 
+-- | Storable/internal remote controller data
 data RemoteCtrl = RemoteCtrl
   { remoteCtrlId :: RemoteCtrlId,
-    displayName :: Text,
-    fingerprint :: C.KeyHash,
-    accepted :: Maybe Bool
+    ctrlName :: Text,
+    ctrlPairing :: RCCtrlPairing
   }
-  deriving (Show)
 
+-- | UI-accessible remote controller information
 data RemoteCtrlInfo = RemoteCtrlInfo
   { remoteCtrlId :: RemoteCtrlId,
-    displayName :: Text,
-    fingerprint :: C.KeyHash,
-    accepted :: Maybe Bool,
+    ctrlName :: Text,
     sessionActive :: Bool
   }
   deriving (Show)
@@ -117,14 +120,30 @@ data RemoteFile = RemoteFile
   }
   deriving (Show)
 
+data CtrlAppInfo = CtrlAppInfo
+  { appVersionRange :: AppVersionRange,
+    deviceName :: Text
+  }
+
+data HostAppInfo = HostAppInfo
+  { appVersion :: AppVersion,
+    deviceName :: Text,
+    encoding :: PlatformEncoding,
+    encryptFiles :: Bool -- if the host encrypts files in app storage
+  }
+
 $(J.deriveJSON defaultJSON ''RemoteFile)
 
 $(J.deriveJSON (sumTypeJSON $ dropPrefix "RPE") ''RemoteProtocolError)
 
+$(J.deriveJSON (sumTypeJSON $ dropPrefix "RH") ''RHKey)
+
 $(J.deriveJSON (enumJSON $ dropPrefix "PE") ''PlatformEncoding)
 
 $(J.deriveJSON defaultJSON ''RemoteHostInfo)
 
-$(J.deriveJSON defaultJSON ''RemoteCtrl)
-
 $(J.deriveJSON defaultJSON ''RemoteCtrlInfo)
+
+$(J.deriveJSON defaultJSON ''CtrlAppInfo)
+
+$(J.deriveJSON defaultJSON ''HostAppInfo)