Add remote host discovery

2025-06-28 12:19:54 +00:00 · 2023-09-27 13:40:19 +03:00 · 2023-09-27 13:40:19 +03:00 · 77410e5d5e
commit 77410e5d5e
parent 3e29c664ac
7 changed files with 171 additions and 10 deletions
--- a/cabal.project
+++ b/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
--- a/package.yaml
+++ b/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.*
--- a/simplex-chat.cabal
+++ b/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.*
--- a/src/Simplex/Chat.hs
+++ b/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)
-    _announcer <- async $ error "TODO: run announcer" fingerprint
-    hostAsync <- async $ error "TODO: runServer" storePath sessionCreds
-    chatModifyVar remoteHostSessions $ M.insert rh RemoteHostSession {hostAsync, storePath, ctrlClient = undefined}
-    pure $ chatCmdError Nothing "not supported"
-  StopRemoteHost _rh -> pure $ chatCmdError Nothing "not supported"
+    (fingerprint :: ByteString, sessionCreds) <- error "TODO: derive session creds" (caKey, caCert)
+    cleanup <- toIO $ chatModifyVar remoteHostSessions (M.delete rh)
+    Discovery.runAnnouncer cleanup fingerprint sessionCreds >>= \case
+      Left todo'err -> pure $ chatCmdError Nothing "TODO: Some HTTP2 error"
+      Right ctrlClient -> do
+        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"
--- a/src/Simplex/Chat/Remote.hs
+++ b/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
--- a/src/Simplex/Chat/Remote/Discovery.hs
+++ b/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
--- a/src/Simplex/Chat/Remote/Types.hs
+++ b/src/Simplex/Chat/Remote/Types.hs
@ -31,9 +31,7 @@ data RemoteCtrl = RemoteCtrl
  }

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