remote protocol (#3225)

* draft remote protocol types and external api

* types (it compiles)

* add error

* move remote controller from http to remote host client protocol

* refactor (doesnt compile)

* fix compile

* Connect remote session

* WIP: wire in remote protocol

* add commands and events

* cleanup

* fix desktop shutdown

* prepare for testing remote files

* Add file IO

* update simplexmq to master

with http2 to 4.1.4

* use json transcoder

* update simplexmq

* collapse RemoteHostSession states

* fold RemoteHello back into the protocol command
move http-command-response-http wrapper to protocol

* use sendRemoteCommand with optional attachments
use streaming request/response

* ditch lazy body streaming

* fix formatting

* put body builder/processor closer together

* wrap handleRemoteCommand around sending files

* handle ChatError's too

* remove binary, use 32-bit encoding for JSON bodies

* enable tests

* refactor

* refactor request handling

* return ChatError

* Flatten remote host

---------

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

cabal.project

@@ -9,7 +9,7 @@ constraints: zip +disable-bzip2 +disable-zstd
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/simplexmq.git
-    tag: 1ad69cf74f18f25713ce564e1629d2538313b9e0
+    tag: deb3fc73595ceae34902d3402d075e3a531d5221
 
 source-repository-package
     type: git
@@ -19,7 +19,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/kazu-yamamoto/http2.git
-    tag: b5a1b7200cf5bc7044af34ba325284271f6dff25
+    tag: 804fa283f067bd3fd89b8c5f8d25b3047813a517
 
 source-repository-package
     type: git

package.yaml

@@ -19,7 +19,6 @@ dependencies:
   - attoparsec == 0.14.*
   - base >= 4.7 && < 5
   - base64-bytestring >= 1.0 && < 1.3
-  - binary >= 0.8 && < 0.9
   - bytestring == 0.11.*
   - composition == 1.0.*
   - constraints >= 0.12 && < 0.14
@@ -36,6 +35,7 @@ dependencies:
   - memory == 0.18.*
   - mtl == 2.3.*
   - network >= 3.1.2.7 && < 3.2
+  - network-transport == 0.5.6
   - network-udp >= 0.0 && < 0.1
   - optparse-applicative >= 0.15 && < 0.17
   - process == 1.6.*

scripts/nix/sha256map.nix

@@ -1,7 +1,7 @@
 {
-  "https://github.com/simplex-chat/simplexmq.git"."1ad69cf74f18f25713ce564e1629d2538313b9e0" = "1kil0962pn3ksnxh7dcwcbnkidz95yl31rm4m585ps7wnh6fp0l9";
+  "https://github.com/simplex-chat/simplexmq.git"."deb3fc73595ceae34902d3402d075e3a531d5221" = "031zrk32p8ji8hlvk8aj1v99g5zpcsran8qhq36sgi34sy6864z6";
   "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
-  "https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb";
+  "https://github.com/kazu-yamamoto/http2.git"."804fa283f067bd3fd89b8c5f8d25b3047813a517" = "1j67wp7rfybfx3ryx08z6gqmzj85j51hmzhgx47ihgmgr47sl895";
   "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "0kiwhvml42g9anw4d2v0zd1fpc790pj9syg5x3ik4l97fnkbbwpp";
   "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";
   "https://github.com/simplex-chat/aeson.git"."aab7b5a14d6c5ea64c64dcaee418de1bb00dcc2b" = "0jz7kda8gai893vyvj96fy962ncv8dcsx71fbddyy8zrvc88jfrr";

simplex-chat.cabal

@@ -127,6 +127,7 @@ library
       Simplex.Chat.Protocol
       Simplex.Chat.Remote
       Simplex.Chat.Remote.Discovery
+      Simplex.Chat.Remote.Protocol
       Simplex.Chat.Remote.Types
       Simplex.Chat.Store
       Simplex.Chat.Store.Connections
@@ -160,7 +161,6 @@ library
     , attoparsec ==0.14.*
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
-    , binary ==0.8.*
     , bytestring ==0.11.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -177,6 +177,7 @@ library
     , memory ==0.18.*
     , mtl ==2.3.*
     , network >=3.1.2.7 && <3.2
+    , network-transport ==0.5.6
     , network-udp ==0.0.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
@@ -213,7 +214,6 @@ executable simplex-bot
     , attoparsec ==0.14.*
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
-    , binary ==0.8.*
     , bytestring ==0.11.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -230,6 +230,7 @@ executable simplex-bot
     , memory ==0.18.*
     , mtl ==2.3.*
     , network >=3.1.2.7 && <3.2
+    , network-transport ==0.5.6
     , network-udp ==0.0.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
@@ -267,7 +268,6 @@ executable simplex-bot-advanced
     , attoparsec ==0.14.*
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
-    , binary ==0.8.*
     , bytestring ==0.11.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -284,6 +284,7 @@ executable simplex-bot-advanced
     , memory ==0.18.*
     , mtl ==2.3.*
     , network >=3.1.2.7 && <3.2
+    , network-transport ==0.5.6
     , network-udp ==0.0.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
@@ -323,7 +324,6 @@ executable simplex-broadcast-bot
     , attoparsec ==0.14.*
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
-    , binary ==0.8.*
     , bytestring ==0.11.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -340,6 +340,7 @@ executable simplex-broadcast-bot
     , memory ==0.18.*
     , mtl ==2.3.*
     , network >=3.1.2.7 && <3.2
+    , network-transport ==0.5.6
     , network-udp ==0.0.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
@@ -378,7 +379,6 @@ executable simplex-chat
     , attoparsec ==0.14.*
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
-    , binary ==0.8.*
     , bytestring ==0.11.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -395,6 +395,7 @@ executable simplex-chat
     , memory ==0.18.*
     , mtl ==2.3.*
     , network ==3.1.*
+    , network-transport ==0.5.6
     , network-udp ==0.0.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
@@ -437,7 +438,6 @@ executable simplex-directory-service
     , attoparsec ==0.14.*
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
-    , binary ==0.8.*
     , bytestring ==0.11.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -454,6 +454,7 @@ executable simplex-directory-service
     , memory ==0.18.*
     , mtl ==2.3.*
     , network >=3.1.2.7 && <3.2
+    , network-transport ==0.5.6
     , network-udp ==0.0.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
@@ -519,7 +520,6 @@ test-suite simplex-chat-test
     , attoparsec ==0.14.*
     , base >=4.7 && <5
     , base64-bytestring >=1.0 && <1.3
-    , binary ==0.8.*
     , bytestring ==0.11.*
     , composition ==1.0.*
     , constraints >=0.12 && <0.14
@@ -539,6 +539,7 @@ test-suite simplex-chat-test
     , memory ==0.18.*
     , mtl ==2.3.*
     , network ==3.1.*
+    , network-transport ==0.5.6
     , network-udp ==0.0.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*

src/Simplex/Chat.hs

@@ -109,6 +109,7 @@ import System.Random (randomRIO)
 import Text.Read (readMaybe)
 import UnliftIO.Async
 import UnliftIO.Concurrent (forkFinally, forkIO, mkWeakThreadId, threadDelay)
+import qualified UnliftIO.Exception as E
 import UnliftIO.Directory
 import UnliftIO.IO (hClose, hSeek, hTell, openFile)
 import UnliftIO.STM
@@ -389,17 +390,20 @@ execChatCommand rh s = do
   case parseChatCommand s of
     Left e -> pure $ chatCmdError u e
     Right cmd -> case rh of
-      Just remoteHostId | allowRemoteCommand cmd -> execRemoteCommand u remoteHostId (s, cmd)
+      Just remoteHostId | allowRemoteCommand cmd -> execRemoteCommand u remoteHostId s
       _ -> execChatCommand_ u cmd
 
 execChatCommand' :: ChatMonad' m => ChatCommand -> m ChatResponse
 execChatCommand' cmd = asks currentUser >>= readTVarIO >>= (`execChatCommand_` cmd)
 
 execChatCommand_ :: ChatMonad' m => Maybe User -> ChatCommand -> m ChatResponse
-execChatCommand_ u cmd = either (CRChatCmdError u) id <$> runExceptT (processChatCommand cmd)
+execChatCommand_ u cmd = handleCommandError u $ processChatCommand cmd
 
-execRemoteCommand :: ChatMonad' m => Maybe User -> RemoteHostId -> (ByteString, ChatCommand) -> m ChatResponse
+execRemoteCommand :: ChatMonad' m => Maybe User -> RemoteHostId -> ByteString -> m ChatResponse
-execRemoteCommand u rhId scmd = either (CRChatCmdError u) id <$> runExceptT (getRemoteHostSession rhId >>= (`processRemoteCommand` scmd))
+execRemoteCommand u rhId s = handleCommandError u $ getRemoteHostSession rhId >>= \rh -> processRemoteCommand rhId rh s
+
+handleCommandError :: ChatMonad' m => Maybe User -> ExceptT ChatError m ChatResponse -> m ChatResponse
+handleCommandError u a = either (CRChatCmdError u) id <$> (runExceptT a `E.catch` (pure . Left . mkChatError))
 
 parseChatCommand :: ByteString -> Either String ChatCommand
 parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace

src/Simplex/Chat/Controller.hs

@@ -72,7 +72,6 @@ import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), Cor
 import Simplex.Messaging.TMap (TMap)
 import Simplex.Messaging.Transport (simplexMQVersion)
 import Simplex.Messaging.Transport.Client (TransportHost)
-import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
 import Simplex.Messaging.Util (allFinally, catchAllErrors, liftEitherError, tryAllErrors, (<$$>))
 import Simplex.Messaging.Version
 import System.IO (Handle)
@@ -1153,6 +1152,7 @@ data RemoteHostError
   | RHTimeout -- ^ A discovery or a remote operation has timed out
   | RHDisconnected {reason :: Text} -- ^ A session disconnected by a host
   | RHConnectionLost {reason :: Text} -- ^ A session disconnected due to transport issues
+  | RHProtocolError RemoteProtocolError
   deriving (Show, Exception, Generic)
 
 instance FromJSON RemoteHostError where
@@ -1175,6 +1175,7 @@ data RemoteCtrlError
   | RCEHTTP2Error {http2Error :: String}
   | RCEHTTP2RespStatus {statusCode :: Maybe Int} -- TODO remove
   | RCEInvalidResponse {responseError :: String}
+  | RCEProtocolError {protocolError :: RemoteProtocolError}
   deriving (Show, Exception, Generic)
 
 instance FromJSON RemoteCtrlError where
@@ -1196,16 +1197,6 @@ instance ToJSON ArchiveError where
   toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "AE"
   toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "AE"
 
-data RemoteHostSession
-  = RemoteHostSessionStarting
-      { announcer :: Async ()
-      }
-  | RemoteHostSessionStarted
-      { -- | Path for local resources to be synchronized with host
-        storePath :: FilePath,
-        ctrlClient :: HTTP2Client
-      }
-
 data RemoteCtrlSession = RemoteCtrlSession
   { -- | Host (mobile) side of transport to process remote commands and forward notifications
     discoverer :: Async (),

src/Simplex/Chat/Remote.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 
@@ -20,148 +19,136 @@ import Control.Monad.IO.Class
 import Control.Monad.Reader (asks)
 import Control.Monad.STM (retry)
 import Crypto.Random (getRandomBytes)
-import Data.Aeson ((.=))
 import qualified Data.Aeson as J
-import qualified Data.Aeson.Key as JK
+import Data.ByteString (ByteString)
-import qualified Data.Aeson.KeyMap as JM
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import qualified Data.Binary.Builder as Binary
-import Data.ByteString (ByteString, hPut)
 import qualified Data.ByteString.Base64.URL as B64U
+import Data.ByteString.Builder (Builder)
 import qualified Data.ByteString.Char8 as B
-import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty (..))
 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 (decodeUtf8, encodeUtf8)
+import Data.Text.Encoding (encodeUtf8)
-import qualified Network.HTTP.Types as HTTP
+import Data.Word (Word32)
-import qualified Network.HTTP.Types.Status as Status
+import Network.HTTP2.Server (responseStreaming)
-import qualified Network.HTTP2.Client as HC
+import qualified Network.HTTP.Types as N
-import qualified Network.HTTP2.Server as HS
 import Network.Socket (SockAddr (..), hostAddressToTuple)
 import Simplex.Chat.Controller
-import Simplex.Chat.Messages (AChatItem (..), CIFile (..), CIFileStatus (..), ChatItem (..), chatNameStr)
-import Simplex.Chat.Messages.CIContent (MsgDirection (..), SMsgDirection (..))
 import qualified Simplex.Chat.Remote.Discovery as Discovery
+import Simplex.Chat.Remote.Protocol
 import Simplex.Chat.Remote.Types
-import Simplex.Chat.Store.Files (getRcvFileTransfer)
-import Simplex.Chat.Store.Profiles (getUser)
 import Simplex.Chat.Store.Remote
-import Simplex.Chat.Store.Shared (StoreError (..))
-import Simplex.Chat.Types
-import Simplex.FileTransfer.Util (uniqueCombine)
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Crypto.File (CryptoFile (..))
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
-import Simplex.Messaging.Parsers (pattern SingleFieldJSONTag, pattern TaggedObjectJSONData, pattern TaggedObjectJSONTag)
+import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..))
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
-import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), defaultHTTP2BufferSize)
+import Simplex.Messaging.Transport.HTTP2.File (hSendFile)
-import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError, HTTP2Response (..))
+import Simplex.Messaging.Util (ifM, liftEitherError, liftEitherWith, liftError, liftIOEither, tryAllErrors, tshow, ($>>=))
-import qualified Simplex.Messaging.Transport.HTTP2.Client as HTTP2
+import System.FilePath ((</>))
-import qualified Simplex.Messaging.Transport.HTTP2.Server as HTTP2
-import Simplex.Messaging.Util (bshow, ifM, liftEitherError, liftEitherWith, tshow, ($>>=))
-import System.FilePath (isPathSeparator, takeFileName, (</>))
 import UnliftIO
-import UnliftIO.Directory (createDirectoryIfMissing, getFileSize)
+
+-- * Desktop side
 
 getRemoteHostSession :: ChatMonad m => RemoteHostId -> m RemoteHostSession
-getRemoteHostSession rhId = chatReadVar remoteHostSessions >>= maybe err pure . M.lookup rhId
+getRemoteHostSession rhId = withRemoteHostSession rhId $ \_ s -> pure $ Right s
-  where
-    err = throwError $ ChatErrorRemoteHost rhId RHMissing
 
-checkNoRemoteHostSession :: ChatMonad m => RemoteHostId -> m ()
+withRemoteHostSession :: ChatMonad m => RemoteHostId -> (TM.TMap RemoteHostId RemoteHostSession -> RemoteHostSession -> STM (Either ChatError a)) -> m a
-checkNoRemoteHostSession rhId = chatReadVar remoteHostSessions >>= maybe (pure ()) err . M.lookup rhId
+withRemoteHostSession rhId = withRemoteHostSession_ rhId missing
   where
-    err _ = throwError $ ChatErrorRemoteHost rhId RHBusy
+    missing _ = pure . Left $ ChatErrorRemoteHost rhId RHMissing
+
+withNoRemoteHostSession :: ChatMonad m => RemoteHostId -> (TM.TMap RemoteHostId RemoteHostSession -> STM (Either ChatError a)) -> m a
+withNoRemoteHostSession rhId action = withRemoteHostSession_ rhId action busy
+  where
+    busy _ _ = pure . Left $ ChatErrorRemoteHost rhId RHBusy
+
+-- | Atomically process controller state wrt. specific remote host session
+withRemoteHostSession_ :: ChatMonad m => RemoteHostId -> (TM.TMap RemoteHostId RemoteHostSession -> STM (Either ChatError a)) -> (TM.TMap RemoteHostId RemoteHostSession -> RemoteHostSession -> STM (Either ChatError a)) -> m a
+withRemoteHostSession_ rhId missing present = do
+  sessions <- asks remoteHostSessions
+  liftIOEither . atomically $ TM.lookup rhId sessions >>= maybe (missing sessions) (present sessions)
 
 startRemoteHost :: ChatMonad m => RemoteHostId -> m ()
 startRemoteHost rhId = do
-  checkNoRemoteHostSession rhId
   rh <- withStore (`getRemoteHost` rhId)
-  announcer <- async $ do
+  tasks <- startRemoteHostSession rh
-    finished <- newTVarIO False
+  logInfo $ "Remote host session starting for " <> tshow rhId
-    http <- start rh finished `onChatError` cleanup finished
+  asyncRegistered tasks $ run rh tasks `catchAny` \err -> do
-    run rh finished http
+    logError $ "Remote host session startup failed for " <> tshow rhId <> ": " <> tshow err
-  chatModifyVar remoteHostSessions $ M.insert rhId RemoteHostSessionStarting {announcer}
+    cancelTasks tasks
+    chatModifyVar remoteHostSessions $ M.delete rhId
+    throwError $ fromMaybe (mkChatError err) $ fromException err
+  -- logInfo $ "Remote host session starting for " <> tshow rhId
   where
-    cleanup finished = do
+    run :: ChatMonad m => RemoteHost -> Tasks -> m ()
-      logInfo "Remote host http2 client fininshed"
+    run rh@RemoteHost {storePath} tasks = do
-      atomically $ writeTVar finished True
+      (fingerprint, credentials) <- liftIO $ genSessionCredentials rh
-      -- TODO why this is not an error?
+      cleanupIO <- toIO $ do
-      M.lookup rhId <$> chatReadVar remoteHostSessions >>= \case
+        logNote $ "Remote host session stopping for " <> tshow rhId
-        Nothing -> logInfo $ "Session already closed for remote host " <> tshow rhId
+        cancelTasks tasks -- cancel our tasks anyway
-        Just _ -> closeRemoteHostSession rhId >> toView (CRRemoteHostStopped rhId)
+        chatModifyVar currentRemoteHost $ \cur -> if cur == Just rhId then Nothing else cur -- only wipe the closing RH
-    start rh@RemoteHost {storePath, caKey, caCert} finished = do
+        withRemoteHostSession rhId $ \sessions _ -> Right <$> TM.delete rhId sessions
-      let parent = (C.signatureKeyPair caKey, caCert)
+        toView (CRRemoteHostStopped rhId) -- only signal "stopped" when the session is unregistered cleanly
-      sessionCreds <- liftIO $ genCredentials (Just parent) (0, 24) "Session"
+      -- block until some client is connected or an error happens
-      let (fingerprint, credentials) = tlsCredentials $ sessionCreds :| [parent]
+      logInfo $ "Remote host session connecting for " <> tshow rhId
-      u <- askUnliftIO
+      httpClient <- liftEitherError (ChatErrorRemoteCtrl . RCEHTTP2Error . show) $ Discovery.announceRevHTTP2 tasks fingerprint credentials cleanupIO
-      ctrlClient <- liftHTTP2 $ Discovery.announceRevHTTP2 fingerprint credentials $ unliftIO u (cleanup finished) -- >>= \case
+      logInfo $ "Remote host session connected for " <> tshow rhId
-      chatModifyVar remoteHostSessions $ M.insert rhId RemoteHostSessionStarted {storePath, ctrlClient}
-      chatWriteVar currentRemoteHost $ Just rhId
-      HTTP2Response {respBody = HTTP2Body {bodyHead}} <- sendHello ctrlClient
       rcName <- chatReadVar localDeviceName
-      -- TODO what sets session active?
+      -- test connection and establish a protocol layer
-      toView CRRemoteHostConnected {remoteHost = remoteHostInfo rh True rcName}
+      remoteHostClient <- liftRH rhId $ createRemoteHostClient httpClient rcName
-      pure ctrlClient
+      -- set up message polling
-    run RemoteHost {storePath} finished ctrlClient = do
       oq <- asks outputQ
-      let toViewRemote = atomically . writeTBQueue oq . (Nothing,Just rhId,)
+      asyncRegistered tasks . forever $ do
-      -- TODO remove REST
+        liftRH rhId (remoteRecv remoteHostClient 1000000) >>= mapM_ (atomically . writeTBQueue oq . (Nothing,Just rhId,))
-      void . async $ pollRemote finished ctrlClient "/recv" $ handleFile >=> toViewRemote
+      -- update session state
+      logInfo $ "Remote host session started for " <> tshow rhId
+      chatModifyVar remoteHostSessions $ M.adjust (\rhs -> rhs {remoteHostClient = Just remoteHostClient}) rhId
+      chatWriteVar currentRemoteHost $ Just rhId
+      toView $ CRRemoteHostConnected RemoteHostInfo
+        { remoteHostId = rhId,
+          storePath = storePath,
+          displayName = remoteDeviceName remoteHostClient,
+          remoteCtrlOOB = RemoteCtrlOOB {fingerprint, displayName=rcName},
+          sessionActive = True
+        }
+
+    genSessionCredentials RemoteHost {caKey, caCert} = do
+      sessionCreds <- genCredentials (Just parent) (0, 24) "Session"
+      pure . tlsCredentials $ sessionCreds :| [parent]
       where
-        -- TODO move to view / terminal
+        parent = (C.signatureKeyPair caKey, caCert)
-        handleFile = \case
-          cr@CRRcvFileComplete {user, chatItem = AChatItem c SMDRcv i ci@ChatItem {file = Just ciFile@CIFile {fileStatus = CIFSRcvComplete}}} -> do
-            maybe cr update <$> handleRcvFileComplete ctrlClient storePath user ciFile
-            where
-              update localFile = cr {chatItem = AChatItem c SMDRcv i ci {file = Just localFile}}
-          cr -> pure cr
 
-sendHello :: ChatMonad m => HTTP2Client -> m HTTP2Response
+-- | Atomically check/register session and prepare its task list
-sendHello http = liftHTTP2 $ HTTP2.sendRequestDirect http req Nothing
+startRemoteHostSession :: ChatMonad m => RemoteHost -> m Tasks
-  where
+startRemoteHostSession RemoteHost {remoteHostId, storePath} = withNoRemoteHostSession remoteHostId $ \sessions -> do
-    req = HC.requestNoBody "GET" "/" mempty
+  remoteHostTasks <- newTVar []
-
+  TM.insert remoteHostId RemoteHostSession {remoteHostTasks, storePath, remoteHostClient = Nothing} sessions
--- TODO how (on what condition) it would stop polling?
+  pure $ Right remoteHostTasks
--- TODO add JSON translation
-pollRemote :: ChatMonad m => TVar Bool -> HTTP2Client -> ByteString -> (ChatResponse -> m ()) -> m ()
-pollRemote finished http path action = loop `catchChatError` \e -> action (CRChatError Nothing e) >> loop
-  where
-    loop = do
-      -- TODO this will never load full body
-      HTTP2Response {respBody = HTTP2Body {bodyHead}} <- liftHTTP2 $ HTTP2.sendRequestDirect http req Nothing
-      json <- liftEitherWith (ChatErrorRemoteCtrl . RCEInvalidResponse) $ J.eitherDecodeStrict' bodyHead -- of
-      action json
-      readTVarIO finished >>= (`unless` loop)
-    req = HC.requestNoBody "GET" path mempty
 
 closeRemoteHostSession :: ChatMonad m => RemoteHostId -> m ()
-closeRemoteHostSession remoteHostId = do
+closeRemoteHostSession rhId = do
-  session <- getRemoteHostSession remoteHostId
+  logNote $ "Closing remote host session for " <> tshow rhId
-  logInfo $ "Closing remote host session for " <> tshow remoteHostId
+  chatModifyVar currentRemoteHost $ \cur -> if cur == Just rhId then Nothing else cur -- only wipe the closing RH
-  liftIO $ cancelRemoteHostSession session
+  session <- withRemoteHostSession rhId $ \sessions rhs -> Right rhs <$ TM.delete rhId sessions
-  chatWriteVar currentRemoteHost Nothing
+  cancelRemoteHostSession session
-  chatModifyVar remoteHostSessions $ M.delete remoteHostId
 
 cancelRemoteHostSession :: MonadUnliftIO m => RemoteHostSession -> m ()
-cancelRemoteHostSession = \case
+cancelRemoteHostSession RemoteHostSession {remoteHostTasks, remoteHostClient} = do
-  RemoteHostSessionStarting {announcer} -> cancel announcer
+  cancelTasks remoteHostTasks
-  RemoteHostSessionStarted {ctrlClient} -> liftIO $ HTTP2.closeHTTP2Client ctrlClient
+  mapM_ closeRemoteHostClient remoteHostClient
 
 createRemoteHost :: ChatMonad m => m RemoteHostInfo
 createRemoteHost = do
-  let rhName = "TODO" -- you don't have remote host name here, it will be passed from remote host
+  ((_, caKey), caCert) <- liftIO $ genCredentials Nothing (-25, 24 * 365) "Host"
-  ((_, caKey), caCert) <- liftIO $ genCredentials Nothing (-25, 24 * 365) rhName
   storePath <- liftIO randomStorePath
-  remoteHostId <- withStore' $ \db -> insertRemoteHost db storePath rhName caKey caCert
+  let remoteName = "" -- will be passed from remote host in hello
-  rcName <- chatReadVar localDeviceName
+  remoteHostId <- withStore' $ \db -> insertRemoteHost db storePath remoteName caKey caCert
-  let remoteCtrlOOB = RemoteCtrlOOB {fingerprint = C.certificateFingerprint caCert, displayName = rcName}
+  localName <- chatReadVar localDeviceName
-  pure RemoteHostInfo {remoteHostId, storePath, displayName = rhName, remoteCtrlOOB, sessionActive = False}
+  let remoteCtrlOOB = RemoteCtrlOOB {fingerprint = C.certificateFingerprint caCert, displayName = localName}
+  pure RemoteHostInfo {remoteHostId, storePath, displayName = remoteName, remoteCtrlOOB, sessionActive = False}
 
 -- | Generate a random 16-char filepath without / in it by using base64url encoding.
 randomStorePath :: IO FilePath
@@ -191,241 +178,111 @@ deleteRemoteHost rhId = do
     Nothing -> logWarn "Local file store not available while deleting remote host"
   withStore' (`deleteRemoteHostRecord` rhId)
 
-processRemoteCommand :: ChatMonad m => RemoteHostSession -> (ByteString, ChatCommand) -> m ChatResponse
+processRemoteCommand :: ChatMonad m => RemoteHostId -> RemoteHostSession -> ByteString -> m ChatResponse
-processRemoteCommand RemoteHostSessionStarting {} _ = pure $ chatCmdError Nothing "remote command sent before session started"
+processRemoteCommand remoteHostId RemoteHostSession {remoteHostClient = Just rhc} s = liftRH remoteHostId $ remoteSend rhc s
-processRemoteCommand RemoteHostSessionStarted {ctrlClient} (s, cmd) =
+processRemoteCommand _ _ _ = pure $ chatCmdError Nothing "remote command sent before session started"
-  uploadFile cmd >>= relayCommand ctrlClient
-  where
-    fileCmd cmdPfx cn hostPath = utf8String $ unwords [cmdPfx, chatNameStr cn, hostPath]
-    uploadFile = \case
-      SendFile cn ctrlPath -> fileCmd "/file" cn <$> storeRemoteFile ctrlClient ctrlPath
-      SendImage cn ctrlPath -> fileCmd "/image" cn <$> storeRemoteFile ctrlClient ctrlPath
-      -- TODO APISendMessage should only be used with host path already, and UI has to upload file first.
-      -- The problem is that we cannot have different file names in host and controller, because it simply won't be able to show files.
-      -- So we need to ask the host to store files BEFORE storing them in the app storage and use host names in the command and to store the file locally if it has to be shown,
-      -- or don't even store it if it's not image/video.
-      -- The current approach won't work.
-      -- It also does not account for local file encryption.
-      -- Also, local file encryption setting should be tracked in the controller, as otherwise host won't be able to decide what to do having received the upload command.
-      APISendMessage {composedMessage = cm@ComposedMessage {fileSource = Just CryptoFile {filePath = ctrlPath, cryptoArgs}}} -> do
-        hostPath <- storeRemoteFile ctrlClient ctrlPath
-        let cm' = cm {fileSource = Just CryptoFile {filePath = hostPath, cryptoArgs}} :: ComposedMessage
-        -- TODO we shouldn't manipulate JSON like that
-        pure $ B.takeWhile (/= '{') s <> B.toStrict (J.encode cm')
-      _ -> pure s
 
-relayCommand :: ChatMonad m => HTTP2Client -> ByteString -> m ChatResponse
+liftRH :: ChatMonad m => RemoteHostId -> ExceptT RemoteProtocolError IO a -> m a
-relayCommand http s = do
+liftRH rhId = liftError (ChatErrorRemoteHost rhId . RHProtocolError)
-  -- TODO ExceptT
-  let timeout' = Nothing
-  HTTP2Response {respBody = HTTP2Body {bodyHead}} <-
-    liftHTTP2 $ HTTP2.sendRequestDirect http req timeout'
-  -- TODO: large JSONs can overflow into buffered chunks
-  json <- liftEitherWith (ChatErrorRemoteCtrl . RCEInvalidResponse) $ J.eitherDecodeStrict' bodyHead
-  case J.fromJSON $ toTaggedJSON json of
-    J.Error e -> err $ show e
-    J.Success cr -> pure cr  
-  where
-    err = pure . CRChatError Nothing . ChatErrorRemoteCtrl . RCEInvalidResponse
-    toTaggedJSON :: J.Value -> J.Value
-    toTaggedJSON = id -- owsf2tagged TODO: get from RemoteHost
-    req = HC.requestBuilder "POST" "/send" mempty (Binary.fromByteString s)
 
--- TODO fileName is just metadata that does not determine the actual file location for UI, or whether it is encrypted or not
+-- * Mobile side
--- fileSource is the actual file location (with information whether it is locally encrypted)
-handleRcvFileComplete :: ChatMonad m => HTTP2Client -> FilePath -> User -> CIFile 'MDRcv -> m (Maybe (CIFile 'MDRcv))
-handleRcvFileComplete http storePath remoteUser f@CIFile {fileId, fileName} =
-  chatReadVar filesFolder >>= \case
-    Just baseDir -> do
-      let hostStore = baseDir </> storePath
-      createDirectoryIfMissing True hostStore
-      -- TODO the problem here is that the name may turn out to be different and nothing will work
-      -- file processing seems to work "accidentally", not "by design"
-      localPath <- uniqueCombine hostStore fileName
-      fetchRemoteFile http remoteUser fileId localPath
-      pure $ Just (f {fileName = localPath} :: CIFile 'MDRcv)
-    -- TODO below will not work with CLI, it should store file to download folder when not specified
-    -- It should not load all files when received, instead it should only load files received with /fr commands
-    Nothing -> Nothing <$ logError "Local file store not available while fetching remote file"
 
--- | Convert swift single-field sum encoding into tagged/discriminator-field
+startRemoteCtrl :: forall m . ChatMonad m => (ByteString -> m ChatResponse) -> m ()
-owsf2tagged :: J.Value -> J.Value
-owsf2tagged = fst . convert
-  where
-    convert val = case val of
-      J.Object o
-        | JM.size o == 2 ->
-            case JM.toList o of
-              [OwsfTag, o'] -> tagged o'
-              [o', OwsfTag] -> tagged o'
-              _ -> props
-        | otherwise -> props
-        where
-          props = (J.Object $ fmap owsf2tagged o, False)
-      J.Array a -> (J.Array $ fmap owsf2tagged a, False)
-      _ -> (val, False)
-    -- `tagged` converts the pair of single-field object encoding to tagged encoding.
-    -- It sets innerTag returned by `convert` to True to prevent the tag being overwritten.
-    tagged (k, v) = (J.Object pairs, True)
-      where
-        (v', innerTag) = convert v
-        pairs = case v' of
-          -- `innerTag` indicates that internal object already has tag,
-          -- so the current tag cannot be inserted into it.
-          J.Object o
-            | innerTag -> pair
-            | otherwise -> JM.insert TaggedObjectJSONTag tag o
-          _ -> pair
-        tag = J.String $ JK.toText k
-        pair = JM.fromList [TaggedObjectJSONTag .= tag, TaggedObjectJSONData .= v']
-
-pattern OwsfTag :: (JK.Key, J.Value)
-pattern OwsfTag = (SingleFieldJSONTag, J.Bool True)
-
-storeRemoteFile :: ChatMonad m => HTTP2Client -> FilePath -> m FilePath
-storeRemoteFile http localFile = do
-  fileSize <- liftIO $ fromIntegral <$> getFileSize localFile
-  -- TODO configure timeout
-  let timeout' = Nothing
-  r@HTTP2Response {respBody = HTTP2Body {bodyHead}} <-
-    liftHTTP2 $ HTTP2.sendRequestDirect http (req fileSize) timeout'
-  responseStatusOK r
-  -- TODO what if response doesn't fit in the head?
-  -- it'll be solved when processing moved to POST with Command/Response types
-  pure $ B.unpack bodyHead
-  where
-    -- TODO local file encryption?
-    uri = "/store?" <> HTTP.renderSimpleQuery False [("file_name", utf8String $ takeFileName localFile)]
-    req size = HC.requestFile "PUT" uri mempty (HC.FileSpec localFile 0 size)
-
-liftHTTP2 :: ChatMonad m => IO (Either HTTP2ClientError a) -> m a
-liftHTTP2 = liftEitherError $ ChatErrorRemoteCtrl . RCEHTTP2Error . show
-
-responseStatusOK :: ChatMonad m => HTTP2Response -> m ()
-responseStatusOK HTTP2Response {response} = do
-  let s = HC.responseStatus response
-  unless (s == Just Status.ok200) $
-    throwError $ ChatErrorRemoteCtrl $ RCEHTTP2RespStatus $ Status.statusCode <$> s
-
-fetchRemoteFile :: ChatMonad m => HTTP2Client -> User -> Int64 -> FilePath -> m ()
-fetchRemoteFile http User {userId = remoteUserId} remoteFileId localPath = do
-  r@HTTP2Response {respBody} <- liftHTTP2 $ HTTP2.sendRequestDirect http req Nothing
-  responseStatusOK r
-  writeBodyToFile localPath respBody
-  where
-    req = HC.requestNoBody "GET" path mempty
-    path = "/fetch?" <> HTTP.renderSimpleQuery False [("user_id", bshow remoteUserId), ("file_id", bshow remoteFileId)]
-
--- XXX: extract to Transport.HTTP2 ?
-writeBodyToFile :: MonadUnliftIO m => FilePath -> HTTP2Body -> m ()
-writeBodyToFile path HTTP2Body {bodyHead, bodySize, bodyPart} = do
-  logInfo $ "Receiving " <> tshow bodySize <> " bytes to " <> tshow path
-  liftIO . withFile path WriteMode $ \h -> do
-    hPut h bodyHead
-    mapM_ (hPutBodyChunks h) bodyPart
-
-hPutBodyChunks :: Handle -> (Int -> IO ByteString) -> IO ()
-hPutBodyChunks h getChunk = do
-  chunk <- getChunk defaultHTTP2BufferSize
-  unless (B.null chunk) $ do
-    hPut h chunk
-    hPutBodyChunks h getChunk
-
--- TODO command/response pattern, remove REST conventions
-processControllerRequest :: forall m. ChatMonad m => (ByteString -> m ChatResponse) -> HTTP2.HTTP2Request -> m ()
-processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody, sendResponse} = do
-  logDebug $ "Remote controller request: " <> tshow (method <> " " <> path)
-  res <- tryChatError $ case (method, ps) of
-    ("GET", []) -> getHello
-    ("POST", ["send"]) -> sendCommand
-    ("GET", ["recv"]) -> recvMessage
-    ("PUT", ["store"]) -> storeFile
-    ("GET", ["fetch"]) -> fetchFile
-    unexpected -> respondWith Status.badRequest400 $ "unexpected method/path: " <> Binary.putStringUtf8 (show unexpected)
-  case res of
-    Left e -> logError $ "Error handling remote controller request: (" <> tshow (method <> " " <> path) <> "): " <> tshow e
-    Right () -> logDebug $ "Remote controller request: " <> tshow (method <> " " <> path) <> " OK"
-  where
-    method = fromMaybe "" $ HS.requestMethod request
-    path = fromMaybe "/" $ HS.requestPath request
-    (ps, query) = HTTP.decodePath path
-    getHello = respond "OK"
-    sendCommand = execChatCommand (bodyHead reqBody) >>= respondJSON
-    recvMessage =
-      chatReadVar remoteCtrlSession >>= \case
-        Nothing -> respondWith Status.internalServerError500 "session not active"
-        Just rcs -> atomically (readTBQueue $ remoteOutputQ rcs) >>= respondJSON
-    -- TODO liftEither storeFileQuery
-    storeFile = case storeFileQuery of
-      Left err -> respondWith Status.badRequest400 (Binary.putStringUtf8 err)
-      Right fileName -> do
-        baseDir <- fromMaybe "." <$> chatReadVar filesFolder
-        localPath <- uniqueCombine baseDir fileName
-        logDebug $ "Storing controller file to " <> tshow (baseDir, localPath)
-        writeBodyToFile localPath reqBody
-        let storeRelative = takeFileName localPath
-        respond $ Binary.putStringUtf8 storeRelative
-      where
-        storeFileQuery = parseField "file_name" $ A.many1 (A.satisfy $ not . isPathSeparator)
-    -- TODO move to ExceptT monad, catch errors in one place, convert errors to responses
-    fetchFile = case fetchFileQuery of
-      Left err -> respondWith Status.badRequest400 (Binary.putStringUtf8 err)
-      Right (userId, fileId) -> do
-        logInfo $ "Fetching file " <> tshow fileId <> " from user " <> tshow userId
-        x <- withStore' $ \db -> runExceptT $ do
-          user <- getUser db userId
-          getRcvFileTransfer db user fileId
-        -- TODO this error handling is very ad-hoc, there is no separation between Chat errors and responses
-        case x of
-          Right RcvFileTransfer {fileStatus = RFSComplete RcvFileInfo {filePath}} -> do
-            baseDir <- fromMaybe "." <$> chatReadVar filesFolder
-            let fullPath = baseDir </> filePath
-            size <- fromInteger <$> getFileSize fullPath
-            liftIO . sendResponse . HS.responseFile Status.ok200 mempty $ HS.FileSpec fullPath 0 size
-          Right _ -> respondWith Status.internalServerError500 "The requested file is not complete"
-          Left SEUserNotFound {} -> respondWith Status.notFound404 "User not found"
-          Left SERcvFileNotFound {} -> respondWith Status.notFound404 "File not found"
-          _ -> respondWith Status.internalServerError500 "Store error"
-      where
-        fetchFileQuery =
-          (,)
-            <$> parseField "user_id" A.decimal
-            <*> parseField "file_id" A.decimal
-
-    parseField :: ByteString -> A.Parser a -> Either String a
-    parseField field p = maybe (Left $ "missing " <> B.unpack field) (A.parseOnly $ p <* A.endOfInput) (join $ lookup field query)
-
-    respondJSON :: (J.ToJSON a) => a -> m ()
-    respondJSON = respond . Binary.fromLazyByteString . J.encode
-
-    respond = respondWith Status.ok200
-    respondWith status = liftIO . sendResponse . HS.responseBuilder status []
-
--- * ChatRequest handlers
-
-startRemoteCtrl :: ChatMonad m => (ByteString -> m ChatResponse) -> m ()
 startRemoteCtrl execChatCommand = do
-  checkNoRemoteCtrlSession
+  logInfo "Starting remote host"
+  checkNoRemoteCtrlSession -- tiny race with the final @chatWriteVar@ until the setup finishes and supervisor spawned
+  discovered <- newTVarIO mempty
+  discoverer <- async $ discoverRemoteCtrls discovered -- TODO extract to a controller service singleton
   size <- asks $ tbqSize . config
   remoteOutputQ <- newTBQueueIO size
-  discovered <- newTVarIO mempty
-  discoverer <- async $ discoverRemoteCtrls discovered
   accepted <- newEmptyTMVarIO
-  supervisor <- async $ runSupervisor discovered accepted
+  supervisor <- async $ runHost discovered accepted $ handleRemoteCommand execChatCommand remoteOutputQ
   chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, accepted, remoteOutputQ}
+
+-- | Track remote host lifecycle in controller session state and signal UI on its progress
+runHost :: ChatMonad m => TM.TMap C.KeyHash TransportHost -> TMVar RemoteCtrlId -> (HTTP2Request -> m ()) -> m ()
+runHost discovered accepted handleHttp = do
+  remoteCtrlId <- atomically (readTMVar accepted) -- wait for ???
+  rc@RemoteCtrl {fingerprint} <- withStore (`getRemoteCtrl` remoteCtrlId)
+  source <- atomically $ TM.lookup fingerprint discovered >>= maybe retry pure -- wait for location of the matching fingerprint
+  toView $ CRRemoteCtrlConnecting $ remoteCtrlInfo rc False
+  atomically $ writeTVar discovered mempty -- flush unused sources
+  server <- async $ Discovery.connectRevHTTP2 source fingerprint handleHttp -- spawn server for remote protocol commands
+  chatModifyVar remoteCtrlSession $ fmap $ \s -> s {hostServer = Just server}
+  toView $ CRRemoteCtrlConnected $ remoteCtrlInfo rc True
+  _ <- waitCatch server -- wait for the server to finish
+  chatWriteVar remoteCtrlSession Nothing
+  toView CRRemoteCtrlStopped
+
+handleRemoteCommand :: forall m . ChatMonad m => (ByteString -> m ChatResponse) -> TBQueue ChatResponse -> HTTP2Request -> m ()
+handleRemoteCommand execChatCommand remoteOutputQ HTTP2Request {request, reqBody, sendResponse} = do
+  logDebug "handleRemoteCommand"
+  liftRC (tryRemoteError parseRequest) >>= \case
+    Right (getNext, rc) -> processCommand getNext rc `catchAny` (reply . RRProtocolError . RPEException . tshow)
+    Left e -> reply $ RRProtocolError e
   where
-    runSupervisor discovered accepted = do
+    parseRequest :: ExceptT RemoteProtocolError IO (GetChunk, RemoteCommand)
-      remoteCtrlId <- atomically (readTMVar accepted)
+    parseRequest = do
-      rc@RemoteCtrl {fingerprint} <- withStore (`getRemoteCtrl` remoteCtrlId)
+      (header, getNext) <- parseHTTP2Body request reqBody
-      source <- atomically $ TM.lookup fingerprint discovered >>= maybe retry pure
+      (getNext,) <$> liftEitherWith (RPEInvalidJSON . T.pack) (J.eitherDecodeStrict' header)
-      toView $ CRRemoteCtrlConnecting $ remoteCtrlInfo rc False
+    processCommand :: GetChunk -> RemoteCommand -> m ()
-      atomically $ writeTVar discovered mempty -- flush unused sources
+    processCommand getNext = \case
-      server <- async $ Discovery.connectRevHTTP2 source fingerprint (processControllerRequest execChatCommand)
+      RCHello {deviceName = desktopName} -> handleHello desktopName >>= reply
-      chatModifyVar remoteCtrlSession $ fmap $ \s -> s {hostServer = Just server}
+      RCSend {command} -> handleSend execChatCommand command >>= reply
-      toView $ CRRemoteCtrlConnected $ remoteCtrlInfo rc True
+      RCRecv {wait = time} -> handleRecv time remoteOutputQ >>= reply
-      _ <- waitCatch server
+      RCStoreFile {fileSize, encrypt} -> handleStoreFile fileSize encrypt getNext >>= reply
-      chatWriteVar remoteCtrlSession Nothing
+      RCGetFile {filePath} -> handleGetFile filePath replyWith
-      toView CRRemoteCtrlStopped
+    reply :: RemoteResponse -> m ()
+    reply = (`replyWith` \_ -> pure ())
+    replyWith :: Respond m
+    replyWith rr attach =
+      liftIO . sendResponse . responseStreaming N.status200 [] $ \send flush -> do
+        send $ sizePrefixedEncode rr
+        attach send
+        flush
+
+type GetChunk = Int -> IO ByteString
+
+type SendChunk = Builder -> IO ()
+
+type Respond m = RemoteResponse -> (SendChunk -> IO ()) -> m ()
+
+liftRC :: ChatMonad m => ExceptT RemoteProtocolError IO a -> m a
+liftRC = liftError (ChatErrorRemoteCtrl . RCEProtocolError)
+
+tryRemoteError :: ExceptT RemoteProtocolError IO a -> ExceptT RemoteProtocolError IO (Either RemoteProtocolError a)
+tryRemoteError = tryAllErrors (RPEException . tshow)
+{-# INLINE tryRemoteError #-}
+
+handleHello :: ChatMonad m => Text -> m RemoteResponse
+handleHello desktopName = do
+  logInfo $ "Hello from " <> tshow desktopName
+  mobileName <- chatReadVar localDeviceName
+  pure RRHello {encoding = localEncoding, deviceName = mobileName}
+
+handleSend :: ChatMonad m => (ByteString -> m ChatResponse) -> Text -> m RemoteResponse
+handleSend execChatCommand command = do
+  logDebug $ "Send: " <> tshow command
+  -- execChatCommand checks for remote-allowed commands
+  -- convert errors thrown in ChatMonad into error responses to prevent aborting the protocol wrapper
+  RRChatResponse <$> execChatCommand (encodeUtf8 command) `catchError` (pure . CRChatError Nothing)
+
+handleRecv :: MonadUnliftIO m => Int -> TBQueue ChatResponse -> m RemoteResponse
+handleRecv time events = do
+  logDebug $ "Recv: " <> tshow time
+  RRChatEvent <$> (timeout time . atomically $ readTBQueue events)
+
+handleStoreFile :: ChatMonad m => Word32 -> Maybe Bool -> GetChunk -> m RemoteResponse
+handleStoreFile _fileSize _encrypt _getNext = error "TODO" <$ logError "TODO: handleStoreFile"
+
+handleGetFile :: ChatMonad m => FilePath -> Respond m -> m ()
+handleGetFile path reply = do
+  logDebug $ "GetFile: " <> tshow path
+  withFile path ReadMode $ \h -> do
+    fileSize' <- hFileSize h
+    when (fileSize' > toInteger (maxBound :: Word32)) $ throwIO RPEFileTooLarge
+    let fileSize = fromInteger fileSize'
+    reply RRFile {fileSize} $ \send -> hSendFile h send fileSize
 
 -- TODO the problem with this code was that it wasn't clear where the recursion can happen,
 -- by splitting receiving and processing to two functions it becomes clear

src/Simplex/Chat/Remote/Discovery.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -20,6 +21,7 @@ module Simplex.Chat.Remote.Discovery
   )
 where
 
+import Control.Logger.Simple
 import Control.Monad
 import Data.ByteString (ByteString)
 import Data.Default (def)
@@ -27,16 +29,17 @@ import Data.String (IsString)
 import qualified Network.Socket as N
 import qualified Network.TLS as TLS
 import qualified Network.UDP as UDP
+import Simplex.Chat.Remote.Types (Tasks, registerAsync)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import Simplex.Messaging.Transport (supportedParameters)
 import qualified Simplex.Messaging.Transport as Transport
 import Simplex.Messaging.Transport.Client (TransportHost (..), defaultTransportClientConfig, runTransportClient)
 import Simplex.Messaging.Transport.HTTP2 (defaultHTTP2BufferSize, getHTTP2Body)
-import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError, attachHTTP2Client, connTimeout, defaultHTTP2ClientConfig)
+import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError (..), attachHTTP2Client, bodyHeadSize, connTimeout, defaultHTTP2ClientConfig)
 import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..), runHTTP2ServerWith)
 import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServer)
-import Simplex.Messaging.Util (whenM)
+import Simplex.Messaging.Util (ifM, tshow, whenM)
 import UnliftIO
 import UnliftIO.Concurrent
 
@@ -53,18 +56,33 @@ pattern BROADCAST_PORT = "5226"
 -- | Announce tls server, wait for connection and attach http2 client to it.
 --
 -- Announcer is started when TLS server is started and stopped when a connection is made.
-announceRevHTTP2 :: StrEncoding a => a -> TLS.Credentials -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
+announceRevHTTP2 :: StrEncoding a => Tasks -> a -> TLS.Credentials -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
-announceRevHTTP2 invite credentials finishAction = do
+announceRevHTTP2 tasks invite credentials finishAction = do
   httpClient <- newEmptyMVar
   started <- newEmptyTMVarIO
   finished <- newEmptyMVar
-  announcer <- async . liftIO . whenM (atomically $ takeTMVar started) $ runAnnouncer (strEncode invite)
+  _ <- forkIO $ readMVar finished >> finishAction -- attach external cleanup action to session lock
-  tlsServer <- startTLSServer started credentials $ \tls -> cancel announcer >> runHTTP2Client finished httpClient tls
+  announcer <- async . liftIO . whenM (atomically $ takeTMVar started) $ do
-  _ <- forkIO $ do
+    logInfo $ "Starting announcer for " <> tshow (strEncode invite)
-    readMVar finished
+    runAnnouncer (strEncode invite)
+  tasks `registerAsync` announcer
+  tlsServer <- startTLSServer started credentials $ \tls -> do
+    logInfo $ "Incoming connection for " <> tshow (strEncode invite)
     cancel announcer
-    cancel tlsServer
+    runHTTP2Client finished httpClient tls `catchAny` (logError . tshow)
-    finishAction
+    logInfo $ "Client finished for " <> tshow (strEncode invite)
+  -- BUG: this should be handled in HTTP2Client wrapper
+  _ <- forkIO $ do
+    waitCatch tlsServer >>= \case
+      Left err | fromException err == Just AsyncCancelled -> logDebug "tlsServer cancelled"
+      Left err -> do
+        logError $ "tlsServer failed to start: " <> tshow err
+        void $ tryPutMVar httpClient $ Left HCNetworkError
+        void . atomically $ tryPutTMVar started False
+      Right () -> pure ()
+    void $ tryPutMVar finished ()
+  tasks `registerAsync` tlsServer
+  logInfo $ "Waiting for client for " <> tshow (strEncode invite)
   readMVar httpClient
 
 -- | Broadcast invite with link-local datagrams
@@ -77,8 +95,7 @@ runAnnouncer inviteBS = do
       UDP.send sock inviteBS
       threadDelay 1000000
 
--- TODO what prevents second client from connecting to the same server?
+-- XXX: Do we need to start multiple TLS servers for different mobile hosts?
--- Do we need to start multiple TLS servers for different mobile hosts?
 startTLSServer :: (MonadUnliftIO m) => TMVar Bool -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ())
 startTLSServer started credentials = async . liftIO . runTransportServer started BROADCAST_PORT serverParams defaultTransportServerConfig
   where
@@ -92,11 +109,17 @@ startTLSServer started credentials = async . liftIO . runTransportServer started
 
 -- | 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 = do
+runHTTP2Client finishedVar clientVar tls =
-  attachHTTP2Client config ANY_ADDR_V4 BROADCAST_PORT (putMVar finishedVar ()) defaultHTTP2BufferSize tls >>= putMVar clientVar
+  ifM (isEmptyMVar clientVar)
-  readMVar finishedVar
+    attachClient
+    (logError "HTTP2 session already started on this listener")
   where
-    config = defaultHTTP2ClientConfig { connTimeout = 86400000000 }
+    attachClient = do
+      client <- attachHTTP2Client config ANY_ADDR_V4 BROADCAST_PORT (putMVar finishedVar ()) defaultHTTP2BufferSize tls
+      putMVar clientVar client
+      readMVar finishedVar
+    -- TODO connection timeout
+    config = defaultHTTP2ClientConfig {bodyHeadSize = doNotPrefetchHead, connTimeout = maxBound}
 
 withListener :: (MonadUnliftIO m) => (UDP.ListenSocket -> m a) -> m a
 withListener = bracket openListener (liftIO . UDP.stop)
@@ -122,5 +145,9 @@ attachHTTP2Server :: (MonadUnliftIO m) => (HTTP2Request -> m ()) -> Transport.TL
 attachHTTP2Server processRequest tls = do
   withRunInIO $ \unlift ->
     runHTTP2ServerWith defaultHTTP2BufferSize ($ tls) $ \sessionId r sendResponse -> do
-      reqBody <- getHTTP2Body r defaultHTTP2BufferSize
+      reqBody <- getHTTP2Body r doNotPrefetchHead
       unlift $ processRequest HTTP2Request {sessionId, request = r, reqBody, sendResponse}
+
+-- | Suppress storing initial chunk in bodyHead, forcing clients and servers to stream chunks
+doNotPrefetchHead :: Int
+doNotPrefetchHead = 0

src/Simplex/Chat/Remote/Protocol.hs

@@ -0,0 +1,199 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Simplex.Chat.Remote.Protocol where
+
+import Control.Logger.Simple
+import Control.Monad
+import Control.Monad.Except
+import Data.Aeson ((.=))
+import qualified Data.Aeson as J
+import qualified Data.Aeson.Key as JK
+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 qualified Data.ByteString.Lazy as BL
+import Data.String (fromString)
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8)
+import Data.Word (Word32)
+import qualified Network.HTTP.Types as N
+import qualified Network.HTTP2.Client as H
+import Network.Transport.Internal (decodeWord32)
+import Simplex.Chat.Controller (ChatResponse)
+import Simplex.Chat.Remote.Types
+import Simplex.Messaging.Crypto.File (CryptoFile)
+import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON, pattern SingleFieldJSONTag, pattern TaggedObjectJSONData, pattern TaggedObjectJSONTag)
+import Simplex.Messaging.Transport.Buffer (getBuffered)
+import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..), HTTP2BodyChunk, getBodyChunk)
+import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2Response (..), closeHTTP2Client, sendRequestDirect)
+import Simplex.Messaging.Transport.HTTP2.File (hReceiveFile, hSendFile)
+import Simplex.Messaging.Util (liftEitherError, liftEitherWith, tshow, whenM)
+import System.FilePath ((</>))
+import UnliftIO
+import UnliftIO.Directory (doesFileExist, getFileSize)
+
+data RemoteCommand
+  = RCHello {deviceName :: Text}
+  | 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 {fileSize :: Word32, encrypt :: Maybe Bool} -- requires attachment
+  | RCGetFile {filePath :: FilePath}
+  deriving (Show)
+
+data RemoteResponse
+  = RRHello {encoding :: PlatformEncoding, deviceName :: Text}
+  | RRChatResponse {chatResponse :: ChatResponse}
+  | RRChatEvent {chatEvent :: Maybe ChatResponse} -- ^ 'Nothing' on poll timeout
+  | RRFileStored {fileSource :: CryptoFile}
+  | RRFile {fileSize :: Word32} -- provides attachment
+  | RRProtocolError {remoteProcotolError :: RemoteProtocolError} -- ^ The protocol error happened on the server side
+  deriving (Show)
+
+-- Force platform-independent encoding as the types aren't UI-visible
+$(deriveJSON (taggedObjectJSON $ dropPrefix "RC") ''RemoteCommand)
+$(deriveJSON (taggedObjectJSON $ dropPrefix "RR") ''RemoteResponse)
+
+-- * Client side / desktop
+
+createRemoteHostClient :: HTTP2Client -> Text -> ExceptT RemoteProtocolError IO RemoteHostClient
+createRemoteHostClient httpClient desktopName = do
+  logInfo "Sending initial hello"
+  (_getNext, rr) <- sendRemoteCommand httpClient localEncoding Nothing RCHello {deviceName = desktopName}
+  case rr of
+    rrh@RRHello {encoding, deviceName = mobileName} -> do
+      logInfo $ "Got initial hello: " <> tshow rrh
+      when (encoding == PEKotlin && localEncoding == PESwift) $ throwError RPEIncompatibleEncoding
+      pure RemoteHostClient {remoteEncoding = encoding, remoteDeviceName = mobileName, httpClient}
+    _ -> throwError $ RPEUnexpectedResponse $ tshow rr
+
+closeRemoteHostClient :: MonadIO m => RemoteHostClient -> m ()
+closeRemoteHostClient RemoteHostClient {httpClient} = liftIO $ closeHTTP2Client httpClient
+
+-- ** Commands
+
+remoteSend :: RemoteHostClient -> ByteString -> ExceptT RemoteProtocolError IO ChatResponse
+remoteSend RemoteHostClient {httpClient, remoteEncoding} cmd = do
+  (_getNext, rr) <- sendRemoteCommand httpClient remoteEncoding Nothing RCSend {command = decodeUtf8 cmd}
+  case rr of
+    RRChatResponse cr -> pure cr
+    _ -> throwError $ RPEUnexpectedResponse $ tshow rr
+
+remoteRecv :: RemoteHostClient -> Int -> ExceptT RemoteProtocolError IO (Maybe ChatResponse)
+remoteRecv RemoteHostClient {httpClient, remoteEncoding} ms = do
+  (_getNext, rr) <- sendRemoteCommand httpClient remoteEncoding Nothing RCRecv {wait=ms}
+  case rr of
+    RRChatEvent cr_ -> pure cr_
+    _ -> throwError $ RPEUnexpectedResponse $ tshow rr
+
+remoteStoreFile :: RemoteHostClient -> FilePath -> Maybe Bool -> ExceptT RemoteProtocolError IO CryptoFile
+remoteStoreFile RemoteHostClient {httpClient, remoteEncoding} localPath encrypt = do
+  (_getNext, rr) <- withFile localPath ReadMode $ \h -> do
+    fileSize' <- hFileSize h
+    when (fileSize' > toInteger (maxBound :: Word32)) $ throwError RPEFileTooLarge
+    let fileSize = fromInteger fileSize'
+    sendRemoteCommand httpClient remoteEncoding (Just (h, fileSize)) RCStoreFile {encrypt, fileSize}
+  case rr of
+    RRFileStored {fileSource} -> pure fileSource
+    _ -> throwError $ RPEUnexpectedResponse $ tshow rr
+
+-- TODO this should work differently for CLI and UI clients
+-- CLI - potentially, create new unique names and report them as created
+-- UI - always use the same names and report error if file already exists
+-- alternatively, CLI should also use a fixed folder for remote session
+-- Possibly, path in the database should be optional and CLI commands should allow configuring it per session or use temp or download folder
+remoteGetFile :: RemoteHostClient -> FilePath -> FilePath -> ExceptT RemoteProtocolError IO FilePath
+remoteGetFile RemoteHostClient {httpClient, remoteEncoding} baseDir filePath = do
+  (getNext, rr) <- sendRemoteCommand httpClient remoteEncoding Nothing RCGetFile {filePath}
+  expectedSize <- case rr of
+    RRFile {fileSize} -> pure fileSize
+    _ -> throwError $ RPEUnexpectedResponse $ tshow rr
+  whenM (liftIO $ doesFileExist localFile) $ throwError RPEStoredFileExists
+  rc <- liftIO $ withFile localFile WriteMode $ \h -> hReceiveFile getNext h expectedSize
+  when (rc /= 0) $ throwError RPEInvalidSize
+  whenM ((== expectedSize) . fromIntegral <$> getFileSize localFile) $ throwError RPEInvalidSize
+  pure localFile
+  where
+    localFile = baseDir </> filePath
+
+sendRemoteCommand :: HTTP2Client -> PlatformEncoding -> Maybe (Handle, Word32) -> RemoteCommand -> ExceptT RemoteProtocolError IO (Int -> IO ByteString, RemoteResponse)
+sendRemoteCommand http remoteEncoding attachment_ rc = do
+  HTTP2Response {response, respBody} <- liftEitherError (RPEHTTP2 . tshow) $ sendRequestDirect http httpRequest Nothing
+  (header, getNext) <- parseHTTP2Body response respBody
+  rr <- liftEitherWith (RPEInvalidJSON . fromString) $ J.eitherDecodeStrict header >>= JT.parseEither J.parseJSON . convertJSON remoteEncoding localEncoding
+  pure (getNext, rr)
+  where
+    httpRequest = H.requestStreaming N.methodPost "/" mempty $ \send flush -> do
+      send $ sizePrefixedEncode rc
+      case attachment_ of
+        Nothing -> pure ()
+        Just (h, sz) -> hSendFile h send sz
+      flush
+
+-- * Transport-level wrappers
+
+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
+
+-- | Convert swift single-field sum encoding into tagged/discriminator-field
+owsf2tagged :: J.Value -> J.Value
+owsf2tagged = fst . convert
+  where
+    convert val = case val of
+      J.Object o
+        | JM.size o == 2 ->
+            case JM.toList o of
+              [OwsfTag, o'] -> tagged o'
+              [o', OwsfTag] -> tagged o'
+              _ -> props
+        | otherwise -> props
+        where
+          props = (J.Object $ fmap owsf2tagged o, False)
+      J.Array a -> (J.Array $ fmap owsf2tagged a, False)
+      _ -> (val, False)
+    -- `tagged` converts the pair of single-field object encoding to tagged encoding.
+    -- It sets innerTag returned by `convert` to True to prevent the tag being overwritten.
+    tagged (k, v) = (J.Object pairs, True)
+      where
+        (v', innerTag) = convert v
+        pairs = case v' of
+          -- `innerTag` indicates that internal object already has tag,
+          -- so the current tag cannot be inserted into it.
+          J.Object o
+            | innerTag -> pair
+            | otherwise -> JM.insert TaggedObjectJSONTag tag o
+          _ -> pair
+        tag = J.String $ JK.toText k
+        pair = JM.fromList [TaggedObjectJSONTag .= tag, TaggedObjectJSONData .= v']
+
+pattern OwsfTag :: (JK.Key, J.Value)
+pattern OwsfTag = (SingleFieldJSONTag, J.Bool True)
+
+-- | Convert a command or a response into 'Builder'.
+sizePrefixedEncode :: J.ToJSON a => a -> Builder
+sizePrefixedEncode value = word32BE (fromIntegral $ BL.length json) <> lazyByteString json
+  where
+    json = J.encode value
+
+-- | Parse HTTP request or response to a size-prefixed chunk and a function to read more.
+parseHTTP2Body :: HTTP2BodyChunk a => a -> HTTP2Body -> ExceptT RemoteProtocolError IO (ByteString, Int -> IO ByteString)
+parseHTTP2Body hr HTTP2Body {bodyBuffer} = do
+  rSize <- liftIO $ decodeWord32 <$> getNext 4
+  when (rSize > fromIntegral (maxBound :: Int)) $ throwError RPEInvalidSize
+  r <- liftIO $ getNext $ fromIntegral rSize
+  pure (r, getNext)
+  where
+    getNext sz = getBuffered bodyBuffer sz Nothing $ getBodyChunk hr

src/Simplex/Chat/Remote/Types.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
@@ -5,10 +6,39 @@
 
 module Simplex.Chat.Remote.Types where
 
+import Control.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.Messaging.Transport.HTTP2.Client (HTTP2Client)
+import Simplex.Messaging.Parsers (dropPrefix, enumJSON, sumTypeJSON)
+import UnliftIO
+
+data RemoteHostClient = RemoteHostClient
+  { remoteEncoding :: PlatformEncoding,
+    remoteDeviceName :: Text,
+    httpClient :: HTTP2Client
+  }
+
+data RemoteHostSession = RemoteHostSession
+  { remoteHostTasks :: Tasks,
+    remoteHostClient :: Maybe RemoteHostClient,
+    storePath :: FilePath
+  }
+
+data RemoteProtocolError
+  = RPEInvalidSize -- ^ size prefix is malformed
+  | RPEInvalidJSON {invalidJSON :: Text} -- ^ failed to parse RemoteCommand or RemoteResponse
+  | RPEIncompatibleEncoding
+  | RPEUnexpectedFile
+  | RPENoFile
+  | RPEFileTooLarge
+  | RPEUnexpectedResponse {response :: Text} -- ^ Wrong response received for the command sent
+  | RPEStoredFileExists -- ^ A file already exists in the destination position
+  | RPEHTTP2 {http2Error :: Text}
+  | RPEException {someException :: Text}
+  deriving (Show, Exception)
 
 type RemoteHostId = Int64
 
@@ -30,8 +60,6 @@ data RemoteCtrlOOB = RemoteCtrlOOB
   }
   deriving (Show)
 
-$(J.deriveJSON J.defaultOptions ''RemoteCtrlOOB)
-
 data RemoteHostInfo = RemoteHostInfo
   { remoteHostId :: RemoteHostId,
     storePath :: FilePath,
@@ -41,8 +69,6 @@ data RemoteHostInfo = RemoteHostInfo
   }
   deriving (Show)
 
-$(J.deriveJSON J.defaultOptions ''RemoteHostInfo)
-
 type RemoteCtrlId = Int64
 
 data RemoteCtrl = RemoteCtrl
@@ -53,8 +79,6 @@ data RemoteCtrl = RemoteCtrl
   }
   deriving (Show)
 
-$(J.deriveJSON J.defaultOptions {J.omitNothingFields = True} ''RemoteCtrl)
-
 data RemoteCtrlInfo = RemoteCtrlInfo
   { remoteCtrlId :: RemoteCtrlId,
     displayName :: Text,
@@ -64,4 +88,38 @@ data RemoteCtrlInfo = RemoteCtrlInfo
   }
   deriving (Show)
 
+-- TODO: put into a proper place
+data PlatformEncoding
+  = PESwift
+  | PEKotlin
+  deriving (Show, Eq)
+
+localEncoding :: PlatformEncoding
+#if defined(darwin_HOST_OS) && defined(swiftJSON)
+localEncoding = PESwift
+#else
+localEncoding = PEKotlin
+#endif
+
+type Tasks = TVar [Async ()]
+
+asyncRegistered :: MonadUnliftIO m => Tasks -> m () -> m ()
+asyncRegistered tasks action = async action >>= registerAsync tasks
+
+registerAsync :: MonadIO m => Tasks -> Async () -> m ()
+registerAsync tasks = atomically . modifyTVar tasks . (:)
+
+cancelTasks :: (MonadIO m) => Tasks -> m ()
+cancelTasks tasks = readTVarIO tasks >>= mapM_ cancel
+
+$(J.deriveJSON (sumTypeJSON $ dropPrefix "RPE") ''RemoteProtocolError)
+
+$(J.deriveJSON (enumJSON $ dropPrefix "PE") ''PlatformEncoding)
+
+$(J.deriveJSON J.defaultOptions ''RemoteCtrlOOB)
+
+$(J.deriveJSON J.defaultOptions ''RemoteHostInfo)
+
+$(J.deriveJSON J.defaultOptions {J.omitNothingFields = True} ''RemoteCtrl)
+
 $(J.deriveJSON J.defaultOptions {J.omitNothingFields = True} ''RemoteCtrlInfo)

stack.yaml

@@ -49,7 +49,7 @@ extra-deps:
   # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
   # - ../simplexmq
   - github: simplex-chat/simplexmq
-    commit: 1ad69cf74f18f25713ce564e1629d2538313b9e0
+    commit: deb3fc73595ceae34902d3402d075e3a531d5221
   - github: kazu-yamamoto/http2
     commit: b5a1b7200cf5bc7044af34ba325284271f6dff25
   # - ../direct-sqlcipher

tests/JSONTests.hs

@@ -9,7 +9,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB
 import GHC.Generics (Generic)
 import Generic.Random (genericArbitraryU)
 import MobileTests
-import Simplex.Chat.Remote (owsf2tagged)
+import Simplex.Chat.Remote.Protocol (owsf2tagged)
 import Simplex.Messaging.Parsers
 import Test.Hspec
 import Test.Hspec.QuickCheck (modifyMaxSuccess)

tests/RemoteTests.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -8,17 +7,18 @@ module RemoteTests where
 
 import ChatClient
 import ChatTests.Utils
+import Control.Logger.Simple
 import Control.Monad
 import qualified Data.ByteString as B
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Map.Strict as M
-import Debug.Trace
 import Network.HTTP.Types (ok200)
 import qualified Network.HTTP2.Client as C
 import qualified Network.HTTP2.Server as S
 import qualified Network.Socket as N
 import qualified Network.TLS as TLS
 import qualified Simplex.Chat.Controller as Controller
+import Simplex.Chat.Remote.Types
 import qualified Simplex.Chat.Remote.Discovery as Discovery
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
@@ -27,17 +27,21 @@ import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Transport.Credentials (genCredentials, tlsCredentials)
 import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Response (..), closeHTTP2Client, sendRequest)
 import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..))
+import Simplex.Messaging.Util
 import System.FilePath (makeRelative, (</>))
 import Test.Hspec
 import UnliftIO
+import UnliftIO.Concurrent
 import UnliftIO.Directory
 
 remoteTests :: SpecWith FilePath
-remoteTests = fdescribe "Handshake" $ do
+remoteTests = describe "Remote" $ do
   it "generates usable credentials" genCredentialsTest
   it "connects announcer with discoverer over reverse-http2" announceDiscoverHttp2Test
-  it "connects desktop and mobile" remoteHandshakeTest
+  it "performs protocol handshake" remoteHandshakeTest
-  it "send messages via remote desktop" remoteCommandTest
+  it "performs protocol handshake (again)" remoteHandshakeTest -- leaking servers regression check
+  it "sends messages" remoteMessageTest
+  xit "sends files" remoteFileTest
 
 -- * Low-level TLS with ephemeral credentials
 
@@ -51,14 +55,14 @@ genCredentialsTest _tmp = do
     Discovery.connectTLSClient "127.0.0.1" fingerprint clientHandler
   where
     serverHandler serverTls = do
-      traceM "    - Sending from server"
+      logNote "Sending from server"
       Transport.putLn serverTls "hi client"
-      traceM "    - Reading from server"
+      logNote "Reading from server"
       Transport.getLn serverTls `shouldReturn` "hi server"
     clientHandler clientTls = do
-      traceM "    - Sending from client"
+      logNote "Sending from client"
       Transport.putLn clientTls "hi server"
-      traceM "    - Reading from client"
+      logNote "Reading from client"
       Transport.getLn clientTls `shouldReturn` "hi client"
 
 -- * UDP discovery and rever HTTP2
@@ -66,34 +70,37 @@ genCredentialsTest _tmp = do
 announceDiscoverHttp2Test :: (HasCallStack) => FilePath -> IO ()
 announceDiscoverHttp2Test _tmp = do
   (fingerprint, credentials) <- genTestCredentials
+  tasks <- newTVarIO []
   finished <- newEmptyMVar
   controller <- async $ do
-    traceM "    - Controller: starting"
+    logNote "Controller: starting"
     bracket
-      (Discovery.announceRevHTTP2 fingerprint credentials (putMVar finished ()) >>= either (fail . show) pure)
+      (Discovery.announceRevHTTP2 tasks fingerprint credentials (putMVar finished ()) >>= either (fail . show) pure)
       closeHTTP2Client
       ( \http -> do
-          traceM "    - Controller: got client"
+          logNote "Controller: got client"
           sendRequest http (C.requestNoBody "GET" "/" []) (Just 10000000) >>= \case
             Left err -> do
-              traceM "    - Controller: got error"
+              logNote "Controller: got error"
               fail $ show err
             Right HTTP2Response {} ->
-              traceM "    - Controller: got response"
+              logNote "Controller: got response"
       )
   host <- async $ Discovery.withListener $ \sock -> do
     (N.SockAddrInet _port addr, invite) <- Discovery.recvAnnounce sock
     strDecode invite `shouldBe` Right fingerprint
-    traceM "    - Host: connecting"
+    logNote "Host: connecting"
     server <- async $ Discovery.connectTLSClient (THIPv4 $ N.hostAddressToTuple addr) fingerprint $ \tls -> do
-      traceM "    - Host: got tls"
+      logNote "Host: got tls"
       flip Discovery.attachHTTP2Server tls $ \HTTP2Request {sendResponse} -> do
-        traceM "    - Host: got request"
+        logNote "Host: got request"
         sendResponse $ S.responseNoBody ok200 []
-        traceM "    - Host: sent response"
+        logNote "Host: sent response"
     takeMVar finished `finally` cancel server
-    traceM "    - Host: finished"
+    logNote "Host: finished"
-  (waitBoth host controller `shouldReturn` ((), ())) `onException` (cancel host >> cancel controller)
+  tasks `registerAsync` controller
+  tasks `registerAsync` host
+  (waitBoth host controller `shouldReturn` ((), ())) `finally` cancelTasks tasks
 
 -- * Chat commands
 
@@ -101,62 +108,59 @@ remoteHandshakeTest :: (HasCallStack) => FilePath -> IO ()
 remoteHandshakeTest = testChat2 aliceProfile bobProfile $ \desktop mobile -> do
   desktop ##> "/list remote hosts"
   desktop <## "No remote hosts"
-  desktop ##> "/create remote host"
+
-  desktop <## "remote host 1 created"
+  startRemote mobile desktop
-  desktop <## "connection code:"
+
-  fingerprint <- getTermLine desktop
+  logNote "Session active"
 
   desktop ##> "/list remote hosts"
   desktop <## "Remote hosts:"
-  desktop <## "1. TODO" -- TODO host name probably should be Maybe, as when host is created there is no name yet
+  desktop <## "1.  (active)"
-  desktop ##> "/start remote host 1"
-  desktop <## "ok"
-
-  mobile ##> "/start remote ctrl"
-  mobile <## "ok"
-  mobile <## "remote controller announced"
-  mobile <## "connection code:"
-  fingerprint' <- getTermLine mobile
-  fingerprint' `shouldBe` fingerprint
-  mobile ##> "/list remote ctrls"
-  mobile <## "No remote controllers"
-  mobile ##> ("/register remote ctrl " <> fingerprint' <> " " <> "My desktop")
-  mobile <## "remote controller 1 registered"
-  mobile ##> "/list remote ctrls"
-  mobile <## "Remote controllers:"
-  mobile <## "1. My desktop"
-  mobile ##> "/accept remote ctrl 1"
-  mobile <## "ok" -- alternative scenario: accepted before controller start
-  mobile <## "remote controller 1 connecting to My desktop"
-  mobile <## "remote controller 1 connected, My desktop"
-
-  traceM "    - Session active"
-  desktop ##> "/list remote hosts"
-  desktop <## "Remote hosts:"
-  desktop <## "1. TODO (active)"
   mobile ##> "/list remote ctrls"
   mobile <## "Remote controllers:"
   mobile <## "1. My desktop (active)"
 
-  traceM "    - Shutting desktop"
+  stopMobile mobile desktop `catchAny` (logError . tshow)
-  desktop ##> "/stop remote host 1"
+  -- TODO: add a case for 'stopDesktop'
-  desktop <## "ok"
+
   desktop ##> "/delete remote host 1"
   desktop <## "ok"
   desktop ##> "/list remote hosts"
   desktop <## "No remote hosts"
 
-  traceM "    - Shutting mobile"
-  mobile ##> "/stop remote ctrl"
-  mobile <## "ok"
-  mobile <## "remote controller stopped"
   mobile ##> "/delete remote ctrl 1"
   mobile <## "ok"
   mobile ##> "/list remote ctrls"
   mobile <## "No remote controllers"
 
-remoteCommandTest :: (HasCallStack) => FilePath -> IO ()
+remoteMessageTest :: (HasCallStack) => FilePath -> IO ()
-remoteCommandTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> do
+remoteMessageTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> do
+  startRemote mobile desktop
+  contactBob desktop bob
+
+  logNote "sending messages"
+  desktop #> "@bob hello there 🙂"
+  bob <# "alice> hello there 🙂"
+  bob #> "@alice hi"
+  desktop <# "bob> hi"
+
+  logNote "post-remote checks"
+  stopMobile mobile desktop
+
+  mobile ##> "/contacts"
+  mobile <## "bob (Bob)"
+
+  bob ##> "/contacts"
+  bob <## "alice (Alice)"
+
+  desktop ##> "/contacts"
+  -- empty contact list on desktop-local
+
+  threadDelay 1000000
+  logNote "done"
+
+remoteFileTest :: (HasCallStack) => FilePath -> IO ()
+remoteFileTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mobile desktop bob -> do
   let mobileFiles = "./tests/tmp/mobile_files"
   mobile ##> ("/_files_folder " <> mobileFiles)
   mobile <## "ok"
@@ -167,6 +171,89 @@ remoteCommandTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mob
   bob ##> ("/_files_folder " <> bobFiles)
   bob <## "ok"
 
+  startRemote mobile desktop
+  contactBob desktop bob
+
+  rhs <- readTVarIO (Controller.remoteHostSessions $ chatController desktop)
+  desktopStore <- case M.lookup 1 rhs of
+    Just RemoteHostSession {storePath} -> pure storePath
+    _ -> fail "Host session 1 should be started"
+
+  doesFileExist "./tests/tmp/mobile_files/test.pdf" `shouldReturn` False
+  doesFileExist (desktopFiles </> desktopStore </> "test.pdf") `shouldReturn` False
+  mobileName <- userName mobile
+
+  bobsFile <- makeRelative bobFiles <$> makeAbsolute "tests/fixtures/test.pdf"
+  bob #> ("/f @" <> mobileName <> " " <> bobsFile)
+  bob <## "use /fc 1 to cancel sending"
+
+  desktop <# "bob> sends file test.pdf (266.0 KiB / 272376 bytes)"
+  desktop <## "use /fr 1 [<dir>/ | <path>] to receive it"
+  desktop ##> "/fr 1"
+  concurrentlyN_
+    [ do
+        bob <## "started sending file 1 (test.pdf) to alice"
+        bob <## "completed sending file 1 (test.pdf) to alice",
+      do
+        desktop <## "saving file 1 from bob to test.pdf"
+        desktop <## "started receiving file 1 (test.pdf) from bob"
+    ]
+  let desktopReceived = desktopFiles </> desktopStore </> "test.pdf"
+  -- desktop <## ("completed receiving file 1 (" <> desktopReceived <> ") from bob")
+  desktop <## "completed receiving file 1 (test.pdf) from bob"
+  bobsFileSize <- getFileSize bobsFile
+  -- getFileSize desktopReceived `shouldReturn` bobsFileSize
+  bobsFileBytes <- B.readFile bobsFile
+  -- B.readFile desktopReceived `shouldReturn` bobsFileBytes
+
+  -- test file transit on mobile
+  mobile ##> "/fs 1"
+  mobile <## "receiving file 1 (test.pdf) complete, path: test.pdf"
+  getFileSize (mobileFiles </> "test.pdf") `shouldReturn` bobsFileSize
+  B.readFile (mobileFiles </> "test.pdf") `shouldReturn` bobsFileBytes
+
+  logNote "file received"
+
+  desktopFile <- makeRelative desktopFiles <$> makeAbsolute "tests/fixtures/logo.jpg" -- XXX: not necessary for _send, but required for /f
+  logNote $ "sending " <> tshow desktopFile
+  doesFileExist (bobFiles </> "logo.jpg") `shouldReturn` False
+  doesFileExist (mobileFiles </> "logo.jpg") `shouldReturn` False
+  desktop ##> "/_send @2 json {\"filePath\": \"./tests/fixtures/logo.jpg\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi, sending a file\"}}"
+  desktop <# "@bob hi, sending a file"
+  desktop <# "/f @bob logo.jpg"
+  desktop <## "use /fc 2 to cancel sending"
+
+  bob <# "alice> hi, sending a file"
+  bob <# "alice> sends file logo.jpg (31.3 KiB / 32080 bytes)"
+  bob <## "use /fr 2 [<dir>/ | <path>] to receive it"
+  bob ##> "/fr 2"
+  concurrentlyN_
+    [ do
+        bob <## "saving file 2 from alice to logo.jpg"
+        bob <## "started receiving file 2 (logo.jpg) from alice"
+        bob <## "completed receiving file 2 (logo.jpg) from alice"
+        bob ##> "/fs 2"
+        bob <## "receiving file 2 (logo.jpg) complete, path: logo.jpg",
+      do
+        desktop <## "started sending file 2 (logo.jpg) to bob"
+        desktop <## "completed sending file 2 (logo.jpg) to bob"
+    ]
+  desktopFileSize <- getFileSize desktopFile
+  getFileSize (bobFiles </> "logo.jpg") `shouldReturn` desktopFileSize
+  getFileSize (mobileFiles </> "logo.jpg") `shouldReturn` desktopFileSize
+
+  desktopFileBytes <- B.readFile desktopFile
+  B.readFile (bobFiles </> "logo.jpg") `shouldReturn` desktopFileBytes
+  B.readFile (mobileFiles </> "logo.jpg") `shouldReturn` desktopFileBytes
+
+  logNote "file sent"
+
+  stopMobile mobile desktop
+
+-- * Utils
+
+startRemote :: TestCC -> TestCC -> IO ()
+startRemote mobile desktop = do
   desktop ##> "/create remote host"
   desktop <## "remote host 1 created"
   desktop <## "connection code:"
@@ -189,7 +276,9 @@ remoteCommandTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mob
   mobile <## "remote controller 1 connected, My desktop"
   desktop <## "remote host 1 connected"
 
-  traceM "    - exchanging contacts"
+contactBob :: TestCC -> TestCC -> IO ()
+contactBob desktop bob = do
+  logNote "exchanging contacts"
   bob ##> "/c"
   inv' <- getInvitation bob
   desktop ##> ("/c " <> inv')
@@ -198,102 +287,33 @@ remoteCommandTest = testChat3 aliceProfile aliceDesktopProfile bobProfile $ \mob
     (desktop <## "bob (Bob): contact is connected")
     (bob <## "alice (Alice): contact is connected")
 
-  traceM "    - sending messages"
-  desktop #> "@bob hello there 🙂"
-  bob <# "alice> hello there 🙂"
-  bob #> "@alice hi"
-  desktop <# "bob> hi"
-
-  withXFTPServer $ do
-    rhs <- readTVarIO (Controller.remoteHostSessions $ chatController desktop)
-    desktopStore <- case M.lookup 1 rhs of
-      Just Controller.RemoteHostSessionStarted {storePath} -> pure storePath
-      _ -> fail "Host session 1 should be started"
-
-    doesFileExist "./tests/tmp/mobile_files/test.pdf" `shouldReturn` False
-    doesFileExist (desktopFiles </> desktopStore </> "test.pdf") `shouldReturn` False
-    mobileName <- userName mobile
-
-    bobsFile <- makeRelative bobFiles <$> makeAbsolute "tests/fixtures/test.pdf"
-    bob #> ("/f @" <> mobileName <> " " <> bobsFile)
-    bob <## "use /fc 1 to cancel sending"
-
-    desktop <# "bob> sends file test.pdf (266.0 KiB / 272376 bytes)"
-    desktop <## "use /fr 1 [<dir>/ | <path>] to receive it"
-    desktop ##> "/fr 1"
-    concurrently_
-      do
-        bob <## "started sending file 1 (test.pdf) to alice"
-        bob <## "completed sending file 1 (test.pdf) to alice"
-
-      do
-        desktop <## "saving file 1 from bob to test.pdf"
-        desktop <## "started receiving file 1 (test.pdf) from bob"
-
-    let desktopReceived = desktopFiles </> desktopStore </> "test.pdf"
-    desktop <## ("completed receiving file 1 (" <> desktopReceived <> ") from bob")
-    bobsFileSize <- getFileSize bobsFile
-    getFileSize desktopReceived `shouldReturn` bobsFileSize
-    bobsFileBytes <- B.readFile bobsFile
-    B.readFile desktopReceived `shouldReturn` bobsFileBytes
-
-    -- test file transit on mobile
-    mobile ##> "/fs 1"
-    mobile <## "receiving file 1 (test.pdf) complete, path: test.pdf"
-    getFileSize (mobileFiles </> "test.pdf") `shouldReturn` bobsFileSize
-    B.readFile (mobileFiles </> "test.pdf") `shouldReturn` bobsFileBytes
-
-    traceM "    - file received"
-
-    desktopFile <- makeRelative desktopFiles <$> makeAbsolute "tests/fixtures/logo.jpg" -- XXX: not necessary for _send, but required for /f
-    traceM $ "    - sending " <> show desktopFile
-    doesFileExist (bobFiles </> "logo.jpg") `shouldReturn` False
-    doesFileExist (mobileFiles </> "logo.jpg") `shouldReturn` False
-    desktop ##> "/_send @2 json {\"filePath\": \"./tests/fixtures/logo.jpg\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi, sending a file\"}}"
-    desktop <# "@bob hi, sending a file"
-    desktop <# "/f @bob logo.jpg"
-    desktop <## "use /fc 2 to cancel sending"
-
-    bob <# "alice> hi, sending a file"
-    bob <# "alice> sends file logo.jpg (31.3 KiB / 32080 bytes)"
-    bob <## "use /fr 2 [<dir>/ | <path>] to receive it"
-    bob ##> "/fr 2"
-    concurrently_
-      do
-        bob <## "saving file 2 from alice to logo.jpg"
-        bob <## "started receiving file 2 (logo.jpg) from alice"
-        bob <## "completed receiving file 2 (logo.jpg) from alice"
-        bob ##> "/fs 2"
-        bob <## "receiving file 2 (logo.jpg) complete, path: logo.jpg"
-      do
-        desktop <## "started sending file 2 (logo.jpg) to bob"
-        desktop <## "completed sending file 2 (logo.jpg) to bob"
-    desktopFileSize <- getFileSize desktopFile
-    getFileSize (bobFiles </> "logo.jpg") `shouldReturn` desktopFileSize
-    getFileSize (mobileFiles </> "logo.jpg") `shouldReturn` desktopFileSize
-
-    desktopFileBytes <- B.readFile desktopFile
-    B.readFile (bobFiles </> "logo.jpg") `shouldReturn` desktopFileBytes
-    B.readFile (mobileFiles </> "logo.jpg") `shouldReturn` desktopFileBytes
-
-    traceM "    - file sent"
-
-  traceM "    - post-remote checks"
-  mobile ##> "/stop remote ctrl"
-  mobile <## "ok"
-  concurrently_
-    (mobile <## "remote controller stopped")
-    (desktop <## "remote host 1 stopped")
-
-  mobile ##> "/contacts"
-  mobile <## "bob (Bob)"
-
-  traceM "    - done"
-
--- * Utils
-
 genTestCredentials :: IO (C.KeyHash, TLS.Credentials)
 genTestCredentials = do
   caCreds <- liftIO $ genCredentials Nothing (0, 24) "CA"
   sessionCreds <- liftIO $ genCredentials (Just caCreds) (0, 24) "Session"
   pure . tlsCredentials $ sessionCreds :| [caCreds]
+
+stopDesktop :: HasCallStack => TestCC -> TestCC -> IO ()
+stopDesktop mobile desktop = do
+  logWarn "stopping via desktop"
+  desktop ##> "/stop remote host 1"
+  -- desktop <## "ok"
+  concurrently_
+    (desktop <## "remote host 1 stopped")
+    (eventually 3 $ mobile <## "remote controller stopped")
+
+stopMobile :: HasCallStack => TestCC -> TestCC -> IO ()
+stopMobile mobile desktop = do
+  logWarn "stopping via mobile"
+  mobile ##> "/stop remote ctrl"
+  mobile <## "ok"
+  concurrently_
+    (mobile <## "remote controller stopped")
+    (eventually 3 $ desktop <## "remote host 1 stopped")
+
+-- | Run action with extended timeout
+eventually :: Int -> IO a -> IO a
+eventually retries action = tryAny action >>= \case -- TODO: only catch timeouts
+  Left err | retries == 0 -> throwIO err
+  Left _ -> eventually (retries - 1) action
+  Right r -> pure r

tests/Test.hs

@@ -19,7 +19,7 @@ import WebRTCTests
 
 main :: IO ()
 main = do
-  setLogLevel LogError -- LogDebug
+  setLogLevel LogError
   withGlobalLogging logCfg . hspec $ do
     describe "Schema dump" schemaDumpTest
     describe "SimpleX chat markdown" markdownTests

tests/ViewTests.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module ViewTests where