core: http transport for remote session (#3178)

* Wire some of the session endpoints

* Start sending remote commands

* Expand remote controller

- Fix queues for pumping to remote
- Add 3-way test
- WIP: Add TTY wrapper for remote hosts
- Stop remote controller w/o ids to match starting

* Fix view events

* Drop notifications, add message test

* refactor, receive test

* hunt down stray asyncs

* Take discovery sockets in brackets

---------

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

src/Simplex/Chat/Remote/Discovery.hs

@@ -12,6 +12,7 @@ module Simplex.Chat.Remote.Discovery
 
     -- * Discovery
     connectRevHTTP2,
+    withListener,
     openListener,
     recvAnnounce,
     connectTLSClient,
@@ -32,7 +33,7 @@ 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, defaultHTTP2ClientConfig)
+import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client, HTTP2ClientError, attachHTTP2Client, connTimeout, defaultHTTP2ClientConfig)
 import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..), runHTTP2ServerWith)
 import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServer)
 import Simplex.Messaging.Util (whenM)
@@ -52,15 +53,16 @@ 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) => IO () -> invite -> TLS.Credentials -> m (Either HTTP2ClientError HTTP2Client)
+announceRevHTTP2 :: (StrEncoding invite, MonadUnliftIO m) => m () -> invite -> TLS.Credentials -> m (Either HTTP2ClientError HTTP2Client)
 announceRevHTTP2 finishAction invite credentials = do
   httpClient <- newEmptyMVar
   started <- newEmptyTMVarIO
   finished <- newEmptyMVar
   announcer <- async . liftIO . whenM (atomically $ takeTMVar started) $ runAnnouncer (strEncode invite)
   tlsServer <- startTLSServer started credentials $ \tls -> cancel announcer >> runHTTP2Client finished httpClient tls
-  _ <- forkIO . liftIO $ do
+  _ <- forkIO $ do
     readMVar finished
+    cancel announcer
     cancel tlsServer
     finishAction
   readMVar httpClient
@@ -68,11 +70,12 @@ announceRevHTTP2 finishAction invite credentials = do
 -- | Broadcast invite with link-local datagrams
 runAnnouncer :: ByteString -> IO ()
 runAnnouncer inviteBS = do
-  sock <- UDP.clientSocket BROADCAST_ADDR_V4 BROADCAST_PORT False
-  N.setSocketOption (UDP.udpSocket sock) N.Broadcast 1
-  forever $ do
-    UDP.send sock inviteBS
-    threadDelay 1000000
+  bracket (UDP.clientSocket BROADCAST_ADDR_V4 BROADCAST_PORT False) UDP.close $ \sock -> do
+    N.setSocketOption (UDP.udpSocket sock) N.Broadcast 1
+    N.setSocketOption (UDP.udpSocket sock) N.ReuseAddr 1
+    forever $ do
+      UDP.send sock inviteBS
+      threadDelay 1000000
 
 startTLSServer :: (MonadUnliftIO m) => TMVar Bool -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ())
 startTLSServer started credentials = async . liftIO . runTransportServer started BROADCAST_PORT serverParams defaultTransportServerConfig
@@ -88,8 +91,13 @@ 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
-  attachHTTP2Client defaultHTTP2ClientConfig ANY_ADDR_V4 BROADCAST_PORT (putMVar finishedVar ()) defaultHTTP2BufferSize tls >>= putMVar clientVar
+  attachHTTP2Client config ANY_ADDR_V4 BROADCAST_PORT (putMVar finishedVar ()) defaultHTTP2BufferSize tls >>= putMVar clientVar
   readMVar finishedVar
+  where
+    config = defaultHTTP2ClientConfig { connTimeout = 86400000000 }
+
+withListener :: (MonadUnliftIO m) => (UDP.ListenSocket -> m a) -> m a
+withListener = bracket openListener (liftIO . UDP.stop)
 
 openListener :: (MonadIO m) => m UDP.ListenSocket
 openListener = liftIO $ do

src/Simplex/Chat/Remote/Types.hs

@@ -5,15 +5,10 @@
 
 module Simplex.Chat.Remote.Types where
 
-import Control.Concurrent.Async (Async)
 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.TMap (TMap)
-import Simplex.Messaging.Transport.Client (TransportHost)
-import Simplex.Messaging.Transport.HTTP2.Client (HTTP2Client)
-import UnliftIO.STM
 
 type RemoteHostId = Int64
 
@@ -40,22 +35,3 @@ data RemoteCtrl = RemoteCtrl
   deriving (Show)
 
 $(J.deriveJSON J.defaultOptions ''RemoteCtrl)
-
-data RemoteHostSession
-  = RemoteHostSessionStarting
-      { announcer :: Async ()
-      }
-  | RemoteHostSessionStarted
-      { -- | Path for local resources to be synchronized with host
-        storePath :: FilePath,
-        ctrlClient :: HTTP2Client
-      }
-
-data RemoteCtrlSession = RemoteCtrlSession
-  { -- | Server side of transport to process remote commands and forward notifications
-    discoverer :: Async (),
-    supervisor :: Async (),
-    hostServer :: Maybe (Async ()),
-    discovered :: TMap C.KeyHash TransportHost,
-    accepted :: TMVar RemoteCtrlId
-  }