From 77410e5d5e434b209297dd4181668b515174723c Mon Sep 17 00:00:00 2001 From: IC Rainbow Date: Wed, 27 Sep 2023 13:40:19 +0300 Subject: [PATCH] Add remote host discovery --- cabal.project | 2 +- package.yaml | 3 + simplex-chat.cabal | 22 +++++ src/Simplex/Chat.hs | 15 +-- src/Simplex/Chat/Remote.hs | 3 + src/Simplex/Chat/Remote/Discovery.hs | 132 +++++++++++++++++++++++++++ src/Simplex/Chat/Remote/Types.hs | 4 +- 7 files changed, 171 insertions(+), 10 deletions(-) create mode 100644 src/Simplex/Chat/Remote/Discovery.hs diff --git a/cabal.project b/cabal.project index b4024f088c..7d7339a7fb 100644 --- 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 diff --git a/package.yaml b/package.yaml index 5c8c11a698..5337b7eecf 100644 --- 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.* diff --git a/simplex-chat.cabal b/simplex-chat.cabal index eda9c371d3..1af77b9112 100644 --- 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.* diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index d14ab59700..afcd95443e 100644 --- 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" diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index ba543e33f2..34c6b31a46 100644 --- 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 diff --git a/src/Simplex/Chat/Remote/Discovery.hs b/src/Simplex/Chat/Remote/Discovery.hs new file mode 100644 index 0000000000..ace1ced313 --- /dev/null +++ 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 diff --git a/src/Simplex/Chat/Remote/Types.hs b/src/Simplex/Chat/Remote/Types.hs index 8e705d5d28..9f28eab551 100644 --- 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 }