remote: refactor (WIP) (#3222)

* remote: refactor (WIP)

* refactor discoverRemoteCtrls

* refactor processRemoteCommand, storeRemoteFile

* refactor fetchRemoteFile

* refactor startRemoteHost, receiving files

* refactor relayCommand

apps/ios/SimpleXChat/APITypes.swift

@@ -1804,7 +1804,6 @@ public enum ArchiveError: Decodable {
 }
 
 public enum RemoteCtrlError: Decodable {
-  case missing(remoteCtrlId: Int64)
   case inactive
   case busy
   case timeout

apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/model/SimpleXAPI.kt

@@ -4521,7 +4521,6 @@ sealed class RemoteHostError {
 @Serializable
 sealed class RemoteCtrlError {
   val string: String get() = when (this) {
-    is Missing -> "missing"
     is Inactive -> "inactive"
     is Busy -> "busy"
     is Timeout -> "timeout"
@@ -4531,7 +4530,6 @@ sealed class RemoteCtrlError {
     is CertificateUntrusted -> "certificateUntrusted"
     is BadFingerprint -> "badFingerprint"
   }
-  @Serializable @SerialName("missing") class Missing(val remoteCtrlId: Long): RemoteCtrlError()
   @Serializable @SerialName("inactive") object Inactive: RemoteCtrlError()
   @Serializable @SerialName("busy") object Busy: RemoteCtrlError()
   @Serializable @SerialName("timeout") object Timeout: RemoteCtrlError()

src/Simplex/Chat.hs

@@ -397,7 +397,7 @@ execChatCommand_ :: ChatMonad' m => Maybe User -> ChatCommand -> m ChatResponse
 execChatCommand_ u cmd = either (CRChatCmdError u) id <$> runExceptT (processChatCommand cmd)
 
 execRemoteCommand :: ChatMonad' m => Maybe User -> RemoteHostId -> (ByteString, ChatCommand) -> m ChatResponse
-execRemoteCommand u rh scmd = either (CRChatCmdError u) id <$> runExceptT (withRemoteHostSession rh $ \rhs -> processRemoteCommand rhs scmd)
+execRemoteCommand u rhId scmd = either (CRChatCmdError u) id <$> runExceptT (getRemoteHostSession rhId >>= (`processRemoteCommand` scmd))
 
 parseChatCommand :: ByteString -> Either String ChatCommand
 parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace
@@ -5154,9 +5154,6 @@ closeFileHandle fileId files = do
   h_ <- atomically . stateTVar fs $ \m -> (M.lookup fileId m, M.delete fileId m)
   liftIO $ mapM_ hClose h_ `catchAll_` pure ()
 
-throwChatError :: ChatMonad m => ChatErrorType -> m a
-throwChatError = throwError . ChatError
-
 deleteMembersConnections :: ChatMonad m => User -> [GroupMember] -> m ()
 deleteMembersConnections user members = do
   let memberConns =

src/Simplex/Chat/Controller.hs

@@ -1158,8 +1158,7 @@ instance ToJSON RemoteHostError where
 
 -- TODO review errors, some of it can be covered by HTTP2 errors
 data RemoteCtrlError
-  = RCEMissing {remoteCtrlId :: RemoteCtrlId} -- ^ No remote session matches this identifier
-  | RCEInactive -- ^ No session is running
+  = RCEInactive -- ^ No session is running
   | RCEBusy -- ^ A session is already running
   | RCETimeout -- ^ Remote operation timed out
   | RCEDisconnected {remoteCtrlId :: RemoteCtrlId, reason :: Text} -- ^ A session disconnected by a controller
@@ -1167,6 +1166,9 @@ data RemoteCtrlError
   | RCECertificateExpired {remoteCtrlId :: RemoteCtrlId} -- ^ A connection or CA certificate in a chain have bad validity period
   | RCECertificateUntrusted {remoteCtrlId :: RemoteCtrlId} -- ^ TLS is unable to validate certificate chain presented for a connection
   | RCEBadFingerprint -- ^ Bad fingerprint data provided in OOB
+  | RCEHTTP2Error {http2Error :: String}
+  | RCEHTTP2RespStatus {statusCode :: Maybe Int} -- TODO remove
+  | RCEInvalidResponse {responseError :: String}
   deriving (Show, Exception, Generic)
 
 instance FromJSON RemoteCtrlError where
@@ -1199,7 +1201,7 @@ data RemoteHostSession
       }
 
 data RemoteCtrlSession = RemoteCtrlSession
-  { -- | Server side of transport to process remote commands and forward notifications
+  { -- | Host (mobile) side of transport to process remote commands and forward notifications
     discoverer :: Async (),
     supervisor :: Async (),
     hostServer :: Maybe (Async ()),
@@ -1239,6 +1241,10 @@ chatFinally :: ChatMonad m => m a -> m b -> m a
 chatFinally = allFinally mkChatError
 {-# INLINE chatFinally #-}
 
+onChatError :: ChatMonad m => m a -> m b -> m a
+a `onChatError` onErr = a `catchChatError` \e -> onErr >> throwError e
+{-# INLINE onChatError #-}
+
 mkChatError :: SomeException -> ChatError
 mkChatError = ChatError . CEException . show
 {-# INLINE mkChatError #-}
@@ -1246,6 +1252,9 @@ mkChatError = ChatError . CEException . show
 chatCmdError :: Maybe User -> String -> ChatResponse
 chatCmdError user = CRChatCmdError user . ChatError . CECommandError
 
+throwChatError :: ChatMonad m => ChatErrorType -> m a
+throwChatError = throwError . ChatError
+
 -- | Emit local events.
 toView :: ChatMonad' m => ChatResponse -> m ()
 toView event = do

src/Simplex/Chat/Remote.hs

@@ -38,8 +38,8 @@ import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import qualified Network.HTTP.Types as HTTP
 import qualified Network.HTTP.Types.Status as Status
-import qualified Network.HTTP2.Client as HTTP2Client
-import qualified Network.HTTP2.Server as HTTP2Server
+import qualified Network.HTTP2.Client as HC
+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)
@@ -60,103 +60,100 @@ 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.Client (HTTP2Client)
+import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError, HTTP2Response (..))
 import qualified Simplex.Messaging.Transport.HTTP2.Client as HTTP2
 import qualified Simplex.Messaging.Transport.HTTP2.Server as HTTP2
-import Simplex.Messaging.Util (bshow, ifM, tshow, ($>>=))
+import Simplex.Messaging.Util (bshow, ifM, liftEitherError, liftEitherWith, tshow, ($>>=))
 import System.FilePath (isPathSeparator, takeFileName, (</>))
 import UnliftIO
 import UnliftIO.Directory (createDirectoryIfMissing, getFileSize)
 
-withRemoteHostSession :: (ChatMonad m) => RemoteHostId -> (RemoteHostSession -> m a) -> m a
-withRemoteHostSession remoteHostId action = do
-  chatReadVar remoteHostSessions >>= maybe err action . M.lookup remoteHostId
+getRemoteHostSession :: ChatMonad m => RemoteHostId -> m RemoteHostSession
+getRemoteHostSession rhId = chatReadVar remoteHostSessions >>= maybe err pure . M.lookup rhId
   where
-    err = throwError $ ChatErrorRemoteHost remoteHostId RHMissing
+    err = throwError $ ChatErrorRemoteHost rhId RHMissing
 
-withRemoteHost :: (ChatMonad m) => RemoteHostId -> (RemoteHost -> m a) -> m a
-withRemoteHost remoteHostId action =
-  withStore' (`getRemoteHost` remoteHostId) >>= \case
-    Nothing -> throwError $ ChatErrorRemoteHost remoteHostId RHMissing
-    Just rh -> action rh
+checkNoRemoteHostSession :: ChatMonad m => RemoteHostId -> m ()
+checkNoRemoteHostSession rhId = chatReadVar remoteHostSessions >>= maybe (pure ()) err . M.lookup rhId
+  where
+    err _ = throwError $ ChatErrorRemoteHost rhId RHBusy
 
-startRemoteHost :: (ChatMonad m) => RemoteHostId -> m ()
-startRemoteHost remoteHostId = do
-  asks remoteHostSessions >>= atomically . TM.lookup remoteHostId >>= \case
-    Just _ -> throwError $ ChatErrorRemoteHost remoteHostId RHBusy
-    Nothing -> withRemoteHost remoteHostId $ \rh -> do
-      announcer <- async $ run rh
-      chatModifyVar remoteHostSessions $ M.insert remoteHostId RemoteHostSessionStarting {announcer}
+startRemoteHost :: ChatMonad m => RemoteHostId -> m ()
+startRemoteHost rhId = do
+  checkNoRemoteHostSession rhId
+  rh <- withStore (`getRemoteHost` rhId)
+  announcer <- async $ do
+    finished <- newTVarIO False
+    http <- start rh finished `onChatError` cleanup finished
+    run rh finished http
+  chatModifyVar remoteHostSessions $ M.insert rhId RemoteHostSessionStarting {announcer}
   where
     cleanup finished = do
       logInfo "Remote host http2 client fininshed"
       atomically $ writeTVar finished True
-      M.lookup remoteHostId <$> chatReadVar remoteHostSessions >>= \case
-        Nothing -> logInfo $ "Session already closed for remote host " <> tshow remoteHostId
-        Just _ -> closeRemoteHostSession remoteHostId >> toView (CRRemoteHostStopped remoteHostId)
-    run rh@RemoteHost {storePath, caKey, caCert} = do
-      finished <- newTVarIO False
+      -- TODO why this is not an error?
+      M.lookup rhId <$> chatReadVar remoteHostSessions >>= \case
+        Nothing -> logInfo $ "Session already closed for remote host " <> tshow rhId
+        Just _ -> closeRemoteHostSession rhId >> toView (CRRemoteHostStopped rhId)
+    start rh@RemoteHost {storePath, caKey, caCert} finished = do
       let parent = (C.signatureKeyPair caKey, caCert)
       sessionCreds <- liftIO $ genCredentials (Just parent) (0, 24) "Session"
       let (fingerprint, credentials) = tlsCredentials $ sessionCreds :| [parent]
-      Discovery.announceRevHTTP2 (cleanup finished) fingerprint credentials >>= \case
-        Left h2ce -> do
-          logError $ "Failed to set up remote host connection: " <> tshow h2ce
-          cleanup finished
-        Right ctrlClient -> do
-          chatModifyVar remoteHostSessions $ M.insert remoteHostId RemoteHostSessionStarted {storePath, ctrlClient}
-          chatWriteVar currentRemoteHost $ Just remoteHostId
-          sendHello ctrlClient >>= \case
-            Left h2ce -> do
-              logError $ "Failed to send initial remote host request: " <> tshow h2ce
-              cleanup finished
-            Right HTTP2.HTTP2Response {respBody = HTTP2Body {bodyHead}} -> do
-              logDebug $ "Got initial from remote host: " <> tshow bodyHead
-              oq <- asks outputQ
-              let toViewRemote = atomically . writeTBQueue oq . (Nothing,Just remoteHostId,)
-              void . async $ pollRemote finished ctrlClient "/recv" $ \chatResponse -> do
-                case chatResponse of
-                  CRRcvFileComplete {user = ru, chatItem = AChatItem c d@SMDRcv i ci@ChatItem {file = Just ciFile}} -> do
-                    handleRcvFileComplete ctrlClient storePath ru ciFile >>= \case
-                      Nothing -> toViewRemote chatResponse
-                      Just localFile -> toViewRemote CRRcvFileComplete {user = ru, chatItem = AChatItem c d i ci {file = Just localFile}}
-                  _ -> toViewRemote chatResponse
-              rcName <- chatReadVar localDeviceName
-              -- TODO what sets session active?
-              toView CRRemoteHostConnected {remoteHost = remoteHostInfo rh True rcName}
+      u <- askUnliftIO
+      ctrlClient <- liftHTTP2 $ Discovery.announceRevHTTP2 fingerprint credentials $ unliftIO u (cleanup finished) -- >>= \case
+      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?
+      toView CRRemoteHostConnected {remoteHost = remoteHostInfo rh True rcName}
+      pure ctrlClient
+    run RemoteHost {storePath} finished ctrlClient = do
+      oq <- asks outputQ
+      let toViewRemote = atomically . writeTBQueue oq . (Nothing,Just rhId,)
+      -- TODO remove REST
+      void . async $ pollRemote finished ctrlClient "/recv" $ handleFile >=> toViewRemote
+      where
+        -- TODO move to view / terminal
+        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 (Either HTTP2.HTTP2ClientError HTTP2.HTTP2Response)
-sendHello http = liftIO (HTTP2.sendRequestDirect http req Nothing)
+sendHello :: ChatMonad m => HTTP2Client -> m HTTP2Response
+sendHello http = liftHTTP2 $ HTTP2.sendRequestDirect http req Nothing
   where
-    req = HTTP2Client.requestNoBody "GET" "/" mempty
+    req = HC.requestNoBody "GET" "/" mempty
 
-pollRemote :: (ChatMonad m, J.FromJSON a) => TVar Bool -> HTTP2Client -> ByteString -> (a -> m ()) -> m ()
-pollRemote finished http path action = loop
+-- TODO how (on what condition) it would stop polling?
+-- 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
-      liftIO (HTTP2.sendRequestDirect http req Nothing) >>= \case
-        Left e -> logError $ "pollRemote: " <> tshow (path, e)
-        Right HTTP2.HTTP2Response {respBody = HTTP2Body {bodyHead}} -> do
-          logDebug $ "Got /recv response: " <> decodeUtf8 bodyHead
-          case J.eitherDecodeStrict' bodyHead of
-            Left e -> logError $ "pollRemote/decode: " <> tshow (path, e)
-            Right o -> action o
+      -- 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 = HTTP2Client.requestNoBody "GET" path mempty
+    req = HC.requestNoBody "GET" path mempty
 
-closeRemoteHostSession :: (ChatMonad m) => RemoteHostId -> m ()
-closeRemoteHostSession remoteHostId = withRemoteHostSession remoteHostId $ \session -> do
+closeRemoteHostSession :: ChatMonad m => RemoteHostId -> m ()
+closeRemoteHostSession remoteHostId = do
+  session <- getRemoteHostSession remoteHostId
   logInfo $ "Closing remote host session for " <> tshow remoteHostId
   liftIO $ cancelRemoteHostSession session
   chatWriteVar currentRemoteHost Nothing
   chatModifyVar remoteHostSessions $ M.delete remoteHostId
 
-cancelRemoteHostSession :: (MonadUnliftIO m) => RemoteHostSession -> m ()
+cancelRemoteHostSession :: MonadUnliftIO m => RemoteHostSession -> m ()
 cancelRemoteHostSession = \case
   RemoteHostSessionStarting {announcer} -> cancel announcer
   RemoteHostSessionStarted {ctrlClient} -> liftIO $ HTTP2.closeHTTP2Client ctrlClient
 
-createRemoteHost :: (ChatMonad m) => m RemoteHostInfo
+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) rhName
@@ -170,7 +167,7 @@ createRemoteHost = do
 randomStorePath :: IO FilePath
 randomStorePath = B.unpack . B64U.encode <$> getRandomBytes 12
 
-listRemoteHosts :: (ChatMonad m) => m [RemoteHostInfo]
+listRemoteHosts :: ChatMonad m => m [RemoteHostInfo]
 listRemoteHosts = do
   active <- chatReadVar remoteHostSessions
   rcName <- chatReadVar localDeviceName
@@ -184,75 +181,72 @@ remoteHostInfo RemoteHost {remoteHostId, storePath, displayName, caCert} session
   let remoteCtrlOOB = RemoteCtrlOOB {fingerprint = C.certificateFingerprint caCert, displayName = rcName}
    in RemoteHostInfo {remoteHostId, storePath, displayName, remoteCtrlOOB, sessionActive}
 
-deleteRemoteHost :: (ChatMonad m) => RemoteHostId -> m ()
-deleteRemoteHost remoteHostId = withRemoteHost remoteHostId $ \RemoteHost {storePath} -> do
+deleteRemoteHost :: ChatMonad m => RemoteHostId -> m ()
+deleteRemoteHost rhId = do
+  RemoteHost {storePath} <- withStore (`getRemoteHost` rhId)
   chatReadVar filesFolder >>= \case
     Just baseDir -> do
       let hostStore = baseDir </> storePath
       logError $ "TODO: remove " <> tshow hostStore
     Nothing -> logWarn "Local file store not available while deleting remote host"
-  withStore' $ \db -> deleteRemoteHostRecord db remoteHostId
+  withStore' (`deleteRemoteHostRecord` rhId)
 
-processRemoteCommand :: (ChatMonad m) => RemoteHostSession -> (ByteString, ChatCommand) -> m ChatResponse
-processRemoteCommand RemoteHostSessionStarting {} _ = pure . CRChatError Nothing . ChatError $ CEInternalError "sending remote commands before session started"
-processRemoteCommand RemoteHostSessionStarted {ctrlClient} (s, cmd) = do
-  logDebug $ "processRemoteCommand: " <> tshow (s, cmd)
-  case cmd of
-    SendFile cn ctrlPath -> do
-      storeRemoteFile ctrlClient ctrlPath >>= \case
-        -- TODO: use Left
-        Nothing -> pure . CRChatError Nothing . ChatError $ CEInternalError "failed to store file on remote host"
-        Just hostPath -> relayCommand ctrlClient $ "/file " <> utf8String (chatNameStr cn) <> " " <> utf8String hostPath
-    SendImage cn ctrlPath -> do
-      storeRemoteFile ctrlClient ctrlPath >>= \case
-        Nothing -> pure . CRChatError Nothing . ChatError $ CEInternalError "failed to store image on remote host"
-        Just hostPath -> relayCommand ctrlClient $ "/image " <> utf8String (chatNameStr cn) <> " " <> utf8String hostPath
-    APISendMessage {composedMessage = cm@ComposedMessage {fileSource = Just CryptoFile {filePath = ctrlPath, cryptoArgs}}} -> do
-      storeRemoteFile ctrlClient ctrlPath >>= \case
-        Nothing -> pure . CRChatError Nothing . ChatError $ CEInternalError "failed to store file on remote host"
-        Just hostPath -> do
-          let cm' = cm {fileSource = Just CryptoFile {filePath = hostPath, cryptoArgs}} :: ComposedMessage
-          relayCommand ctrlClient $ B.takeWhile (/= '{') s <> B.toStrict (J.encode cm')
-    _ -> relayCommand ctrlClient s
-
-relayCommand :: (ChatMonad m) => HTTP2Client -> ByteString -> m ChatResponse
-relayCommand http s =
-  postBytestring Nothing http "/send" mempty s >>= \case
-    Left e -> err $ "relayCommand/post: " <> show e
-    Right HTTP2.HTTP2Response {respBody = HTTP2Body {bodyHead}} -> do
-      logDebug $ "Got /send response: " <> decodeUtf8 bodyHead
-      remoteChatResponse <- case J.eitherDecodeStrict bodyHead of -- XXX: large JSONs can overflow into buffered chunks
-        Left e -> err $ "relayCommand/decodeValue: " <> show e
-        Right json -> case J.fromJSON $ toTaggedJSON json of
-          J.Error e -> err $ "relayCommand/fromJSON: " <> show e
-          J.Success cr -> pure cr
-      case remoteChatResponse of
-        -- TODO: intercept file responses and fetch files when needed
-        -- XXX: is that even possible, to have a file response to a command?
-        _ -> pure remoteChatResponse
+processRemoteCommand :: ChatMonad m => RemoteHostSession -> (ByteString, ChatCommand) -> m ChatResponse
+processRemoteCommand RemoteHostSessionStarting {} _ = pure $ chatCmdError Nothing "remote command sent before session started"
+processRemoteCommand RemoteHostSessionStarted {ctrlClient} (s, cmd) =
+  uploadFile cmd >>= relayCommand ctrlClient
   where
-    err = pure . CRChatError Nothing . ChatError . CEInternalError
+    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
+relayCommand http s = do
+  -- 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
-    -- XXX: extract to http2 transport
-    postBytestring timeout' c path hs body = liftIO $ HTTP2.sendRequestDirect c req timeout'
-      where
-        req = HTTP2Client.requestBuilder "POST" path hs (Binary.fromByteString body)
+    req = HC.requestBuilder "POST" "/send" mempty (Binary.fromByteString s)
 
-handleRcvFileComplete :: (ChatMonad m) => HTTP2Client -> FilePath -> User -> CIFile 'MDRcv -> m (Maybe (CIFile 'MDRcv))
-handleRcvFileComplete http storePath remoteUser cif@CIFile {fileId, fileName, fileStatus} = case fileStatus of
-  CIFSRcvComplete ->
-    chatReadVar filesFolder >>= \case
-      Just baseDir -> do
-        let hostStore = baseDir </> storePath
-        createDirectoryIfMissing True hostStore
-        localPath <- uniqueCombine hostStore fileName
-        ok <- fetchRemoteFile http remoteUser fileId localPath
-        if ok
-          then pure $ Just (cif {fileName = localPath} :: CIFile 'MDRcv)
-          else Nothing <$ logError "fetchRemoteFile failed"
-      Nothing -> Nothing <$ logError "Local file store not available while fetching remote file"
-  _ -> Nothing <$ logDebug ("Ingoring invalid file notification for file (" <> tshow fileId <> ") " <> tshow fileName)
+-- TODO fileName is just metadata that does not determine the actual file location for UI, or whether it is encrypted or not
+-- 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
 owsf2tagged :: J.Value -> J.Value
@@ -288,36 +282,42 @@ owsf2tagged = fst . convert
 pattern OwsfTag :: (JK.Key, J.Value)
 pattern OwsfTag = (SingleFieldJSONTag, J.Bool True)
 
-storeRemoteFile :: (MonadUnliftIO m) => HTTP2Client -> FilePath -> m (Maybe FilePath)
+storeRemoteFile :: ChatMonad m => HTTP2Client -> FilePath -> m FilePath
 storeRemoteFile http localFile = do
-  putFile Nothing http uri mempty localFile >>= \case
-    Left h2ce -> Nothing <$ logError (tshow h2ce)
-    Right HTTP2.HTTP2Response {response, respBody = HTTP2Body {bodyHead}} ->
-      case HTTP.statusCode <$> HTTP2Client.responseStatus response of
-        Just 200 -> pure . Just $ B.unpack bodyHead
-        notOk -> Nothing <$ logError ("Bad response status: " <> tshow notOk)
+  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)]
-    putFile timeout' c path hs file = liftIO $ do
-      fileSize <- fromIntegral <$> getFileSize file
-      HTTP2.sendRequestDirect c (req fileSize) timeout'
-      where
-        req size = HTTP2Client.requestFile "PUT" path hs (HTTP2Client.FileSpec file 0 size)
+    req size = HC.requestFile "PUT" uri mempty (HC.FileSpec localFile 0 size)
 
-fetchRemoteFile :: (MonadUnliftIO m) => HTTP2Client -> User -> Int64 -> FilePath -> m Bool
+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
-  liftIO (HTTP2.sendRequestDirect http req Nothing) >>= \case
-    Left h2ce -> False <$ logError (tshow h2ce)
-    Right HTTP2.HTTP2Response {response, respBody} ->
-      if HTTP2Client.responseStatus response == Just Status.ok200
-        then True <$ writeBodyToFile localPath respBody
-        else False <$ (logError $ "Request failed: " <> maybe "(??)" tshow (HTTP2Client.responseStatus response) <> " " <> decodeUtf8 (bodyHead respBody))
+  r@HTTP2Response {respBody} <- liftHTTP2 $ HTTP2.sendRequestDirect http req Nothing
+  responseStatusOK r
+  writeBodyToFile localPath respBody
   where
-    req = HTTP2Client.requestNoBody "GET" path mempty
+    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 :: 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
@@ -331,7 +331,8 @@ hPutBodyChunks h getChunk = do
     hPut h chunk
     hPutBodyChunks h getChunk
 
-processControllerRequest :: forall m. (ChatMonad m) => (ByteString -> m ChatResponse) -> HTTP2.HTTP2Request -> m ()
+-- 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
@@ -345,8 +346,8 @@ processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody, s
     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 "" $ HTTP2Server.requestMethod request
-    path = fromMaybe "/" $ HTTP2Server.requestPath request
+    method = fromMaybe "" $ HS.requestMethod request
+    path = fromMaybe "/" $ HS.requestPath request
     (ps, query) = HTTP.decodePath path
     getHello = respond "OK"
     sendCommand = execChatCommand (bodyHead reqBody) >>= respondJSON
@@ -354,6 +355,7 @@ processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody, s
       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
@@ -365,6 +367,7 @@ processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody, s
         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
@@ -372,12 +375,13 @@ processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody, s
         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 . HTTP2Server.responseFile Status.ok200 mempty $ HTTP2Server.FileSpec fullPath 0 size
+            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"
@@ -395,101 +399,106 @@ processControllerRequest execChatCommand HTTP2.HTTP2Request {request, reqBody, s
     respondJSON = respond . Binary.fromLazyByteString . J.encode
 
     respond = respondWith Status.ok200
-    respondWith status = liftIO . sendResponse . HTTP2Server.responseBuilder status []
+    respondWith status = liftIO . sendResponse . HS.responseBuilder status []
 
 -- * ChatRequest handlers
 
-startRemoteCtrl :: (ChatMonad m) => (ByteString -> m ChatResponse) -> m ()
-startRemoteCtrl execChatCommand =
-  chatReadVar remoteCtrlSession >>= \case
-    Just _busy -> throwError $ ChatErrorRemoteCtrl RCEBusy
-    Nothing -> do
-      size <- asks $ tbqSize . config
-      remoteOutputQ <- newTBQueueIO size
-      discovered <- newTVarIO mempty
-      discoverer <- async $ discoverRemoteCtrls discovered
-      accepted <- newEmptyTMVarIO
-      supervisor <- async $ do
-        remoteCtrlId <- atomically (readTMVar accepted)
-        withRemoteCtrl remoteCtrlId $ \rc@RemoteCtrl {fingerprint} -> do
-          source <- atomically $ TM.lookup fingerprint discovered >>= maybe retry pure
-          toView $ CRRemoteCtrlConnecting $ remoteCtrlInfo rc False
-          atomically $ writeTVar discovered mempty -- flush unused sources
-          server <- async $ Discovery.connectRevHTTP2 source fingerprint (processControllerRequest execChatCommand)
-          chatModifyVar remoteCtrlSession $ fmap $ \s -> s {hostServer = Just server}
-          toView $ CRRemoteCtrlConnected $ remoteCtrlInfo rc True
-          _ <- waitCatch server
-          chatWriteVar remoteCtrlSession Nothing
-          toView CRRemoteCtrlStopped
-      chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, accepted, remoteOutputQ}
-
-discoverRemoteCtrls :: (ChatMonad m) => TM.TMap C.KeyHash TransportHost -> m ()
-discoverRemoteCtrls discovered = Discovery.withListener go
+startRemoteCtrl :: ChatMonad m => (ByteString -> m ChatResponse) -> m ()
+startRemoteCtrl execChatCommand = do
+  checkNoRemoteCtrlSession
+  size <- asks $ tbqSize . config
+  remoteOutputQ <- newTBQueueIO size
+  discovered <- newTVarIO mempty
+  discoverer <- async $ discoverRemoteCtrls discovered
+  accepted <- newEmptyTMVarIO
+  supervisor <- async $ runSupervisor discovered accepted
+  chatWriteVar remoteCtrlSession $ Just RemoteCtrlSession {discoverer, supervisor, hostServer = Nothing, discovered, accepted, remoteOutputQ}
   where
-    go sock =
+    runSupervisor discovered accepted = do
+      remoteCtrlId <- atomically (readTMVar accepted)
+      rc@RemoteCtrl {fingerprint} <- withStore (`getRemoteCtrl` remoteCtrlId)
+      source <- atomically $ TM.lookup fingerprint discovered >>= maybe retry pure
+      toView $ CRRemoteCtrlConnecting $ remoteCtrlInfo rc False
+      atomically $ writeTVar discovered mempty -- flush unused sources
+      server <- async $ Discovery.connectRevHTTP2 source fingerprint (processControllerRequest execChatCommand)
+      chatModifyVar remoteCtrlSession $ fmap $ \s -> s {hostServer = Just server}
+      toView $ CRRemoteCtrlConnected $ remoteCtrlInfo rc True
+      _ <- waitCatch server
+      chatWriteVar remoteCtrlSession Nothing
+      toView CRRemoteCtrlStopped
+
+-- 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
+discoverRemoteCtrls :: ChatMonad m => TM.TMap C.KeyHash TransportHost -> m ()
+discoverRemoteCtrls discovered = Discovery.withListener $ receive >=> process
+  where
+    -- TODO how would it receive more than one fingerprint?
+    receive sock =
       Discovery.recvAnnounce sock >>= \case
         (SockAddrInet _sockPort sockAddr, invite) -> case strDecode invite of
-          Left _ -> go sock -- ignore malformed datagrams
-          Right fingerprint -> do
-            let addr = THIPv4 (hostAddressToTuple sockAddr)
-            ifM
-              (atomically $ TM.member fingerprint discovered)
-              (logDebug $ "Fingerprint announce already knwon: " <> tshow (addr, invite))
-              ( do
-                  logInfo $ "New fingerprint announce: " <> tshow (addr, invite)
-                  atomically $ TM.insert fingerprint addr discovered
-              )
-            withStore' (`getRemoteCtrlByFingerprint` fingerprint) >>= \case
-              Nothing -> toView $ CRRemoteCtrlAnnounce fingerprint -- unknown controller, ui "register" action required
-              Just found@RemoteCtrl {remoteCtrlId, accepted = storedChoice} -> case storedChoice of
-                Nothing -> toView $ CRRemoteCtrlFound $ remoteCtrlInfo found False -- first-time controller, ui "accept" action required
-                Just False -> pure () -- skipping a rejected item
-                Just True ->
-                  chatReadVar remoteCtrlSession >>= \case
-                    Nothing -> toView . CRChatError Nothing . ChatError $ CEInternalError "Remote host found without running a session"
-                    Just RemoteCtrlSession {accepted} -> atomically $ void $ tryPutTMVar accepted remoteCtrlId -- previously accepted controller, connect automatically
-        _nonV4 -> go sock
+          -- TODO it is probably better to report errors to view here
+          Left _ -> receive sock
+          Right fingerprint -> pure (sockAddr, fingerprint)
+        _nonV4 -> receive sock
+    process (sockAddr, fingerprint) = do
+      let addr = THIPv4 (hostAddressToTuple sockAddr)
+      ifM
+        (atomically $ TM.member fingerprint discovered)
+        (logDebug $ "Fingerprint already known: " <> tshow (addr, fingerprint))
+        ( do
+            logInfo $ "New fingerprint announced: " <> tshow (addr, fingerprint)
+            atomically $ TM.insert fingerprint addr discovered
+        )
+      -- TODO we check fingerprint for duplicate where id doesn't matter - to prevent re-insert - and don't check to prevent duplicate events,
+      -- so UI now will have to check for duplicates again
+      withStore' (`getRemoteCtrlByFingerprint` fingerprint) >>= \case
+        Nothing -> toView $ CRRemoteCtrlAnnounce fingerprint -- unknown controller, ui "register" action required
+        -- TODO Maybe Bool is very confusing - the intent is very unclear here
+        Just found@RemoteCtrl {remoteCtrlId, accepted = storedChoice} -> case storedChoice of
+          Nothing -> toView $ CRRemoteCtrlFound $ remoteCtrlInfo found False -- first-time controller, ui "accept" action required
+          Just False -> pure () -- skipping a rejected item
+          Just True ->
+            chatReadVar remoteCtrlSession >>= \case
+              Nothing -> toView . CRChatError Nothing . ChatError $ CEInternalError "Remote host found without running a session"
+              Just RemoteCtrlSession {accepted} -> atomically $ void $ tryPutTMVar accepted remoteCtrlId -- previously accepted controller, connect automatically
 
-listRemoteCtrls :: (ChatMonad m) => m [RemoteCtrlInfo]
+listRemoteCtrls :: ChatMonad m => m [RemoteCtrlInfo]
 listRemoteCtrls = do
   active <-
     chatReadVar remoteCtrlSession
       $>>= \RemoteCtrlSession {accepted} -> atomically $ tryReadTMVar accepted
   map (rcInfo active) <$> withStore' getRemoteCtrls
   where
-    rcInfo active rc@RemoteCtrl {remoteCtrlId} =
-      remoteCtrlInfo rc $ active == Just remoteCtrlId
+    rcInfo activeRcId rc@RemoteCtrl {remoteCtrlId} =
+      remoteCtrlInfo rc $ activeRcId == Just remoteCtrlId
 
 remoteCtrlInfo :: RemoteCtrl -> Bool -> RemoteCtrlInfo
 remoteCtrlInfo RemoteCtrl {remoteCtrlId, displayName, fingerprint, accepted} sessionActive =
   RemoteCtrlInfo {remoteCtrlId, displayName, fingerprint, accepted, sessionActive}
 
-acceptRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m ()
-acceptRemoteCtrl remoteCtrlId = do
-  withStore' $ \db -> markRemoteCtrlResolution db remoteCtrlId True
-  chatReadVar remoteCtrlSession >>= \case
-    Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive
-    Just RemoteCtrlSession {accepted} -> atomically . void $ tryPutTMVar accepted remoteCtrlId -- the remote host can now proceed with connection
+acceptRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m ()
+acceptRemoteCtrl rcId = do
+  -- TODO check it exists, check the ID is the same as in session
+  RemoteCtrlSession {accepted} <- getRemoteCtrlSession
+  withStore' $ \db -> markRemoteCtrlResolution db rcId True
+  atomically . void $ tryPutTMVar accepted rcId -- the remote host can now proceed with connection
 
-rejectRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m ()
-rejectRemoteCtrl remoteCtrlId = do
-  withStore' $ \db -> markRemoteCtrlResolution db remoteCtrlId False
-  chatReadVar remoteCtrlSession >>= \case
-    Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive
-    Just RemoteCtrlSession {discoverer, supervisor} -> do
-      cancel discoverer
-      cancel supervisor
+rejectRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m ()
+rejectRemoteCtrl rcId = do
+  withStore' $ \db -> markRemoteCtrlResolution db rcId False
+  RemoteCtrlSession {discoverer, supervisor} <- getRemoteCtrlSession
+  cancel discoverer
+  cancel supervisor
 
-stopRemoteCtrl :: (ChatMonad m) => m ()
-stopRemoteCtrl =
-  chatReadVar remoteCtrlSession >>= \case
-    Nothing -> throwError $ ChatErrorRemoteCtrl RCEInactive
-    Just rcs -> cancelRemoteCtrlSession rcs $ chatWriteVar remoteCtrlSession Nothing
+stopRemoteCtrl :: ChatMonad m => m ()
+stopRemoteCtrl = do
+  rcs <- getRemoteCtrlSession
+  cancelRemoteCtrlSession rcs $ chatWriteVar remoteCtrlSession Nothing
 
-cancelRemoteCtrlSession_ :: (MonadUnliftIO m) => RemoteCtrlSession -> m ()
+cancelRemoteCtrlSession_ :: MonadUnliftIO m => RemoteCtrlSession -> m ()
 cancelRemoteCtrlSession_ rcs = cancelRemoteCtrlSession rcs $ pure ()
 
-cancelRemoteCtrlSession :: (MonadUnliftIO m) => RemoteCtrlSession -> m () -> m ()
+cancelRemoteCtrlSession :: MonadUnliftIO m => RemoteCtrlSession -> m () -> m ()
 cancelRemoteCtrlSession RemoteCtrlSession {discoverer, supervisor, hostServer} cleanup = do
   cancel discoverer -- may be gone by now
   case hostServer of
@@ -498,17 +507,19 @@ cancelRemoteCtrlSession RemoteCtrlSession {discoverer, supervisor, hostServer} c
       cancel supervisor -- supervisor is blocked until session progresses
       cleanup
 
-deleteRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> m ()
-deleteRemoteCtrl remoteCtrlId =
-  chatReadVar remoteCtrlSession >>= \case
-    Nothing -> withStore' $ \db -> deleteRemoteCtrlRecord db remoteCtrlId
-    Just _ -> throwError $ ChatErrorRemoteCtrl RCEBusy
+deleteRemoteCtrl :: ChatMonad m => RemoteCtrlId -> m ()
+deleteRemoteCtrl rcId = do
+  checkNoRemoteCtrlSession
+  -- TODO check it exists
+  withStore' (`deleteRemoteCtrlRecord` rcId)
 
-withRemoteCtrl :: (ChatMonad m) => RemoteCtrlId -> (RemoteCtrl -> m a) -> m a
-withRemoteCtrl remoteCtrlId action =
-  withStore' (`getRemoteCtrl` remoteCtrlId) >>= \case
-    Nothing -> throwError $ ChatErrorRemoteCtrl RCEMissing {remoteCtrlId}
-    Just rc -> action rc
+getRemoteCtrlSession :: ChatMonad m => m RemoteCtrlSession
+getRemoteCtrlSession =
+  chatReadVar remoteCtrlSession >>= maybe (throwError $ ChatErrorRemoteCtrl RCEInactive) pure
+
+checkNoRemoteCtrlSession :: ChatMonad m => m ()
+checkNoRemoteCtrlSession =
+  chatReadVar remoteCtrlSession >>= maybe (pure ()) (\_ -> throwError $ ChatErrorRemoteCtrl RCEBusy)
 
 utf8String :: [Char] -> ByteString
 utf8String = encodeUtf8 . T.pack

src/Simplex/Chat/Remote/Discovery.hs

@@ -53,8 +53,8 @@ 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 invite, MonadUnliftIO m) => m () -> invite -> TLS.Credentials -> m (Either HTTP2ClientError HTTP2Client)
-announceRevHTTP2 finishAction invite credentials = do
+announceRevHTTP2 :: StrEncoding a => a -> TLS.Credentials -> IO () -> IO (Either HTTP2ClientError HTTP2Client)
+announceRevHTTP2 invite credentials finishAction = do
   httpClient <- newEmptyMVar
   started <- newEmptyTMVarIO
   finished <- newEmptyMVar
@@ -77,6 +77,8 @@ runAnnouncer inviteBS = do
       UDP.send sock inviteBS
       threadDelay 1000000
 
+-- TODO what prevents second client from connecting to the same server?
+-- 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

src/Simplex/Chat/Store/Remote.hs

@@ -4,14 +4,15 @@
 
 module Simplex.Chat.Store.Remote where
 
+import Control.Monad.Except
 import Data.Int (Int64)
 import Data.Text (Text)
 import Database.SQLite.Simple (Only (..))
 import qualified Database.SQLite.Simple as SQL
 import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
-import Simplex.Chat.Store.Shared (insertedRowId)
+import Simplex.Chat.Store.Shared
 import Simplex.Chat.Remote.Types
-import Simplex.Messaging.Agent.Store.SQLite (maybeFirstRow)
+import Simplex.Messaging.Agent.Store.SQLite (firstRow, maybeFirstRow)
 import qualified Simplex.Messaging.Crypto as C
 
 insertRemoteHost :: DB.Connection -> FilePath -> Text -> C.APrivateSignKey -> C.SignedCertificate -> IO RemoteHostId
@@ -23,9 +24,9 @@ getRemoteHosts :: DB.Connection -> IO [RemoteHost]
 getRemoteHosts db =
   map toRemoteHost <$> DB.query_ db remoteHostQuery
 
-getRemoteHost :: DB.Connection -> RemoteHostId -> IO (Maybe RemoteHost)
+getRemoteHost :: DB.Connection -> RemoteHostId -> ExceptT StoreError IO RemoteHost
 getRemoteHost db remoteHostId =
-  maybeFirstRow toRemoteHost $
+  ExceptT . firstRow toRemoteHost (SERemoteHostNotFound remoteHostId) $
     DB.query db (remoteHostQuery <> " WHERE remote_host_id = ?") (Only remoteHostId)
 
 remoteHostQuery :: SQL.Query
@@ -48,9 +49,9 @@ getRemoteCtrls :: DB.Connection -> IO [RemoteCtrl]
 getRemoteCtrls db =
   map toRemoteCtrl <$> DB.query_ db remoteCtrlQuery
 
-getRemoteCtrl :: DB.Connection -> RemoteCtrlId -> IO (Maybe RemoteCtrl)
+getRemoteCtrl :: DB.Connection -> RemoteCtrlId -> ExceptT StoreError IO RemoteCtrl
 getRemoteCtrl db remoteCtrlId =
-  maybeFirstRow toRemoteCtrl $
+  ExceptT . firstRow toRemoteCtrl (SERemoteCtrlNotFound remoteCtrlId) $
     DB.query db (remoteCtrlQuery <> " WHERE remote_controller_id = ?") (Only remoteCtrlId)
 
 getRemoteCtrlByFingerprint :: DB.Connection -> C.KeyHash -> IO (Maybe RemoteCtrl)

src/Simplex/Chat/Store/Shared.hs

@@ -31,6 +31,7 @@ import Database.SQLite.Simple.QQ (sql)
 import GHC.Generics (Generic)
 import Simplex.Chat.Messages
 import Simplex.Chat.Protocol
+import Simplex.Chat.Remote.Types
 import Simplex.Chat.Types
 import Simplex.Chat.Types.Preferences
 import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, UserId)
@@ -100,6 +101,8 @@ data StoreError
   | SEHostMemberIdNotFound {groupId :: Int64}
   | SEContactNotFoundByFileId {fileId :: FileTransferId}
   | SENoGroupSndStatus {itemId :: ChatItemId, groupMemberId :: GroupMemberId}
+  | SERemoteHostNotFound {remoteHostId :: RemoteHostId}
+  | SERemoteCtrlNotFound {remoteCtrlId :: RemoteCtrlId}
   deriving (Show, Exception, Generic)
 
 instance FromJSON StoreError where

tests/RemoteTests.hs

@@ -33,7 +33,7 @@ import UnliftIO
 import UnliftIO.Directory
 
 remoteTests :: SpecWith FilePath
-remoteTests = describe "Handshake" $ do
+remoteTests = fdescribe "Handshake" $ do
   it "generates usable credentials" genCredentialsTest
   it "connects announcer with discoverer over reverse-http2" announceDiscoverHttp2Test
   it "connects desktop and mobile" remoteHandshakeTest
@@ -70,7 +70,7 @@ announceDiscoverHttp2Test _tmp = do
   controller <- async $ do
     traceM "    - Controller: starting"
     bracket
-      (Discovery.announceRevHTTP2 (putMVar finished ()) fingerprint credentials >>= either (fail . show) pure)
+      (Discovery.announceRevHTTP2 fingerprint credentials (putMVar finished ()) >>= either (fail . show) pure)
       closeHTTP2Client
       ( \http -> do
           traceM "    - Controller: got client"