Add remote host discovery

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: 8d47f690838371bc848e4b31a4b09ef6bf67ccc5
+    tag: 681fa93bf342d7c836fa0ff69b767dcd08526f03
 
 source-repository-package
     type: git

package.yaml

@@ -25,6 +25,7 @@ dependencies:
   - constraints >= 0.12 && < 0.14
   - containers == 0.6.*
   - cryptonite == 0.30.*
+  - data-default >= 0.7 && < 0.8
   - directory == 1.3.*
   - direct-sqlcipher == 2.3.*
   - email-validate == 2.3.*
@@ -35,6 +36,7 @@ dependencies:
   - memory == 0.18.*
   - mtl == 2.3.*
   - network >= 3.1.2.7 && < 3.2
+  - network-udp >= 0.0 && < 0.1
   - optparse-applicative >= 0.15 && < 0.17
   - process == 1.6.*
   - random >= 1.1 && < 1.3
@@ -48,6 +50,7 @@ dependencies:
   - terminal == 0.2.*
   - text == 2.0.*
   - time == 1.9.*
+  - tls
   - unliftio == 0.2.*
   - unliftio-core == 0.2.*
   - zip == 2.0.*

simplex-chat.cabal

@@ -122,6 +122,7 @@ library
       Simplex.Chat.ProfileGenerator
       Simplex.Chat.Protocol
       Simplex.Chat.Remote
+      Simplex.Chat.Remote.Discovery
       Simplex.Chat.Remote.Types
       Simplex.Chat.Store
       Simplex.Chat.Store.Connections
@@ -161,6 +162,7 @@ library
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
     , cryptonite ==0.30.*
+    , data-default ==0.7.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , email-validate ==2.3.*
@@ -171,6 +173,7 @@ library
     , memory ==0.18.*
     , mtl ==2.3.*
     , network >=3.1.2.7 && <3.2
+    , network-udp ==0.0.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
@@ -184,6 +187,7 @@ library
     , terminal ==0.2.*
     , text ==2.0.*
     , time ==1.9.*
+    , tls
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , zip ==2.0.*
@@ -211,6 +215,7 @@ executable simplex-bot
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
     , cryptonite ==0.30.*
+    , data-default ==0.7.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , email-validate ==2.3.*
@@ -221,6 +226,7 @@ executable simplex-bot
     , memory ==0.18.*
     , mtl ==2.3.*
     , network >=3.1.2.7 && <3.2
+    , network-udp ==0.0.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
@@ -235,6 +241,7 @@ executable simplex-bot
     , terminal ==0.2.*
     , text ==2.0.*
     , time ==1.9.*
+    , tls
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , zip ==2.0.*
@@ -262,6 +269,7 @@ executable simplex-bot-advanced
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
     , cryptonite ==0.30.*
+    , data-default ==0.7.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , email-validate ==2.3.*
@@ -272,6 +280,7 @@ executable simplex-bot-advanced
     , memory ==0.18.*
     , mtl ==2.3.*
     , network >=3.1.2.7 && <3.2
+    , network-udp ==0.0.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
@@ -286,6 +295,7 @@ executable simplex-bot-advanced
     , terminal ==0.2.*
     , text ==2.0.*
     , time ==1.9.*
+    , tls
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , zip ==2.0.*
@@ -315,6 +325,7 @@ executable simplex-broadcast-bot
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
     , cryptonite ==0.30.*
+    , data-default ==0.7.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , email-validate ==2.3.*
@@ -325,6 +336,7 @@ executable simplex-broadcast-bot
     , memory ==0.18.*
     , mtl ==2.3.*
     , network >=3.1.2.7 && <3.2
+    , network-udp ==0.0.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
@@ -339,6 +351,7 @@ executable simplex-broadcast-bot
     , terminal ==0.2.*
     , text ==2.0.*
     , time ==1.9.*
+    , tls
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , zip ==2.0.*
@@ -367,6 +380,7 @@ executable simplex-chat
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
     , cryptonite ==0.30.*
+    , data-default ==0.7.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , email-validate ==2.3.*
@@ -377,6 +391,7 @@ executable simplex-chat
     , memory ==0.18.*
     , mtl ==2.3.*
     , network ==3.1.*
+    , network-udp ==0.0.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
@@ -391,6 +406,7 @@ executable simplex-chat
     , terminal ==0.2.*
     , text ==2.0.*
     , time ==1.9.*
+    , tls
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , websockets ==0.12.*
@@ -423,6 +439,7 @@ executable simplex-directory-service
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
     , cryptonite ==0.30.*
+    , data-default ==0.7.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , email-validate ==2.3.*
@@ -433,6 +450,7 @@ executable simplex-directory-service
     , memory ==0.18.*
     , mtl ==2.3.*
     , network >=3.1.2.7 && <3.2
+    , network-udp ==0.0.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
@@ -447,6 +465,7 @@ executable simplex-directory-service
     , terminal ==0.2.*
     , text ==2.0.*
     , time ==1.9.*
+    , tls
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , zip ==2.0.*
@@ -498,6 +517,7 @@ test-suite simplex-chat-test
     , constraints >=0.12 && <0.14
     , containers ==0.6.*
     , cryptonite ==0.30.*
+    , data-default ==0.7.*
     , deepseq ==1.4.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
@@ -510,6 +530,7 @@ test-suite simplex-chat-test
     , memory ==0.18.*
     , mtl ==2.3.*
     , network ==3.1.*
+    , network-udp ==0.0.*
     , optparse-applicative >=0.15 && <0.17
     , process ==1.6.*
     , random >=1.1 && <1.3
@@ -525,6 +546,7 @@ test-suite simplex-chat-test
     , terminal ==0.2.*
     , text ==2.0.*
     , time ==1.9.*
+    , tls
     , unliftio ==0.2.*
     , unliftio-core ==0.2.*
     , zip ==2.0.*

src/Simplex/Chat.hs

@@ -63,6 +63,7 @@ import Simplex.Chat.Options
 import Simplex.Chat.ProfileGenerator (generateRandomProfile)
 import Simplex.Chat.Protocol
 import Simplex.Chat.Remote
+import qualified Simplex.Chat.Remote.Discovery as Discovery
 import Simplex.Chat.Remote.Types
 import Simplex.Chat.Store
 import Simplex.Chat.Store.Connections
@@ -1852,12 +1853,14 @@ processChatCommand = \case
   ListRemoteHosts -> pure $ chatCmdError Nothing "not supported"
   StartRemoteHost rh -> do
     RemoteHost {displayName = _, storePath, caKey, caCert} <- error "TODO: get from DB"
-    (fingerprint, sessionCreds) <- error "TODO: derive session creds" (caKey, caCert)
+    (fingerprint :: ByteString, sessionCreds) <- error "TODO: derive session creds" (caKey, caCert)
-    _announcer <- async $ error "TODO: run announcer" fingerprint
+    cleanup <- toIO $ chatModifyVar remoteHostSessions (M.delete rh)
-    hostAsync <- async $ error "TODO: runServer" storePath sessionCreds
+    Discovery.runAnnouncer cleanup fingerprint sessionCreds >>= \case
-    chatModifyVar remoteHostSessions $ M.insert rh RemoteHostSession {hostAsync, storePath, ctrlClient = undefined}
+      Left todo'err -> pure $ chatCmdError Nothing "TODO: Some HTTP2 error"
-    pure $ chatCmdError Nothing "not supported"
+      Right ctrlClient -> do
-  StopRemoteHost _rh -> pure $ chatCmdError Nothing "not supported"
+        chatModifyVar remoteHostSessions $ M.insert rh RemoteHostSession {storePath, ctrlClient}
+        pure $ CRRemoteHostStarted rh
+  StopRemoteHost rh -> closeRemoteHostSession rh $> CRRemoteHostStopped rh
   DisposeRemoteHost _rh -> pure $ chatCmdError Nothing "not supported"
   RegisterRemoteCtrl _displayName _oobData -> pure $ chatCmdError Nothing "not supported"
   ListRemoteCtrls -> pure $ chatCmdError Nothing "not supported"

src/Simplex/Chat/Remote.hs

@@ -29,6 +29,9 @@ withRemoteHostSession remoteHostId action = do
   where
     err = throwError $ ChatErrorRemoteHost remoteHostId RHMissing
 
+closeRemoteHostSession :: ChatMonad m => RemoteHostId -> m ()
+closeRemoteHostSession rh = withRemoteHostSession rh (liftIO . HTTP2.closeHTTP2Client . ctrlClient)
+
 processRemoteCommand :: ChatMonad m => RemoteHostSession -> (ByteString, ChatCommand) -> m ChatResponse
 processRemoteCommand rhs = \case
   -- XXX: intercept and filter some commands

src/Simplex/Chat/Remote/Discovery.hs

@@ -0,0 +1,132 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Chat.Remote.Discovery
+  ( runAnnouncer,
+    runDiscoverer,
+  )
+where
+
+import Control.Monad
+import Data.ByteString.Builder (Builder, intDec)
+import Data.Default (def)
+import Data.String (IsString)
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
+import Debug.Trace
+import qualified Network.HTTP.Types as HTTP
+import qualified Network.HTTP2.Server as HTTP2
+import qualified Network.Socket as N
+import qualified Network.TLS as TLS
+import qualified Network.UDP as UDP
+import Simplex.Chat.Controller (ChatMonad)
+import Simplex.Chat.Types ()
+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, defaultHTTP2ClientConfig)
+import Simplex.Messaging.Transport.HTTP2.Server (HTTP2Request (..), runHTTP2ServerWith)
+import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServer)
+import UnliftIO
+import UnliftIO.Concurrent
+
+runAnnouncer :: (StrEncoding invite, ChatMonad m) => IO () -> invite -> TLS.Credentials -> m (Either HTTP2ClientError HTTP2Client)
+runAnnouncer finished invite credentials = do
+  started <- newEmptyTMVarIO
+  aPid <- async $ announcer started (strEncode invite)
+  let serverParams =
+        def
+          { TLS.serverWantClientCert = False,
+            TLS.serverShared = def {TLS.sharedCredentials = credentials},
+            TLS.serverHooks = def,
+            TLS.serverSupported = supportedParameters
+          }
+  httpClient <- newEmptyMVar
+  liftIO $ runTransportServer started partyPort serverParams defaultTransportServerConfig (run aPid httpClient)
+  takeMVar httpClient
+  where
+    announcer started inviteBS = do
+      atomically (takeTMVar started) >>= \case
+        False ->
+          error "Server not started?.."
+        True -> liftIO $ do
+          traceM $ "TCP server started at " <> partyPort
+          sock <- UDP.clientSocket broadcastAddrV4 partyPort False
+          N.setSocketOption (UDP.udpSocket sock) N.Broadcast 1
+          traceM $ "UDP announce started at " <> broadcastAddrV4 <> ":" <> partyPort
+          traceM $ "Server invite: " <> show inviteBS
+          forever $ do
+            UDP.send sock inviteBS
+            threadDelay 1000000
+
+    run :: Async () -> MVar (Either HTTP2ClientError HTTP2Client) -> Transport.TLS -> IO ()
+    run aPid clientVar tls = do
+      cancel aPid
+      let partyHost = "255.255.255.255" -- XXX: get from tls somehow? not required as host verification is disabled.
+      attachHTTP2Client defaultHTTP2ClientConfig partyHost partyPort finished defaultHTTP2BufferSize tls >>= putMVar clientVar
+
+-- | Link-local broadcast address.
+broadcastAddrV4 :: (IsString a) => a
+broadcastAddrV4 = "255.255.255.255"
+
+partyPort :: (IsString a) => a
+partyPort = "5226" -- XXX: should be `0` or something, to get a random port and announce it
+
+runDiscoverer :: (ChatMonad m) => Text -> m ()
+runDiscoverer oobData =
+  case strDecode (encodeUtf8 oobData) of
+    Left err -> traceM $ "oobData decode error: " <> err
+    Right expected -> liftIO $ do
+      traceM $ "runDiscoverer: locating " <> show oobData
+      sock <- UDP.serverSocket (broadcastAddrV4, read partyPort)
+      N.setSocketOption (UDP.listenSocket sock) N.Broadcast 1
+      traceM $ "runDiscoverer: " <> show sock
+      go sock expected
+  where
+    go sock expected = do
+      (invite, UDP.ClientSockAddr source _cmsg) <- UDP.recvFrom sock
+      traceShowM (invite, source)
+      let expect hash = hash `elem` [expected] -- XXX: can be a callback to fetch actual invite list just in time
+      case strDecode invite of
+        Left err -> do
+          traceM $ "Inivite decode error: " <> err
+          go sock expected
+        Right inviteHash | not (expect inviteHash) -> do
+          traceM $ "Skipping unexpected invite " <> show (strEncode inviteHash)
+          go sock expected
+        Right _expected -> do
+          host <- case source of
+            N.SockAddrInet _port addr -> do
+              pure $ THIPv4 (N.hostAddressToTuple addr)
+            unexpected ->
+              -- TODO: actually, Apple mandates IPv6 support
+              fail $ "Discoverer: expected an IPv4 party, got " <> show unexpected
+          traceM $ "Discoverer: go connect " <> show host
+          runTransportClient defaultTransportClientConfig Nothing host partyPort (Just expected) $ \tls -> do
+            traceM "2PTTH server starting"
+            run tls
+            traceM "2PTTH server finished"
+
+    run tls = runHTTP2ServerWith defaultHTTP2BufferSize ($ tls) $ \sessionId r sendResponse -> do
+      reqBody <- getHTTP2Body r 16384
+      processRequest HTTP2Request {sessionId, request = r, reqBody, sendResponse}
+
+    processRequest req = do
+      traceM $ "Got request: " <> show (request req)
+      -- TODO: sendResponse req . HTTP2.promiseResponse $ HTTP2.pushPromise path response weight
+      sendResponse req $ HTTP2.responseStreaming HTTP.ok200 sseHeaders sseExample
+
+    sseHeaders = [(HTTP.hContentType, "text/event-stream")]
+
+    sseExample :: (Builder -> IO ()) -> IO () -> IO ()
+    sseExample write flush = forM_ [1 .. 10] $ \i -> do
+      let payload = "[" <> intDec i <> ", \"blah\"]"
+      write "event: message\n" -- XXX: SSE header line
+      write $ "data: " <> payload <> "\n" -- XXX: SSE payload line
+      write "\n" -- XXX: SSE delimiter
+      flush
+      threadDelay 1000000

src/Simplex/Chat/Remote/Types.hs

@@ -31,9 +31,7 @@ data RemoteCtrl = RemoteCtrl
   }
 
 data RemoteHostSession = RemoteHostSession
-  { -- | process to communicate with the host
+  { -- | Path for local resources to be synchronized with host
-    hostAsync :: Async (),
-    -- | Path for local resources to be synchronized with host
     storePath :: FilePath,
     ctrlClient :: HTTP2Client
   }