mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-06-05 03:41:54 +00:00
Add commands for remote session credentials (#3161)
* Add remote host commands * Make startRemoteHost async * Add tests * Trim randomStorePath to 16 chars * Add chat command tests * add view, use view output in test * enable all tests * Fix discovery listener host Must use any, not broadcast on macos. * Fix missing do * address, names * Fix session host flow * fix test --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
Alexander Bondarenko
committed by
GitHub
GitHub
parent
bf7917bd67
commit
0bcf5c9c66
@@ -1,18 +1,21 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module Simplex.Chat.Remote.Discovery
|
||||
( -- * Announce
|
||||
announceRevHTTP2,
|
||||
runAnnouncer,
|
||||
startTLSServer,
|
||||
runHTTP2Client,
|
||||
|
||||
-- * Discovery
|
||||
connectRevHTTP2,
|
||||
openListener,
|
||||
recvAnnounce,
|
||||
connectSessionHost,
|
||||
attachServer,
|
||||
connectTLSClient,
|
||||
attachHTTP2Server,
|
||||
)
|
||||
where
|
||||
|
||||
@@ -20,7 +23,6 @@ import Control.Monad
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Default (def)
|
||||
import Data.String (IsString)
|
||||
import Debug.Trace
|
||||
import qualified Network.Socket as N
|
||||
import qualified Network.TLS as TLS
|
||||
import qualified Network.UDP as UDP
|
||||
@@ -33,54 +35,65 @@ 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 Simplex.Messaging.Util (whenM)
|
||||
import UnliftIO
|
||||
import UnliftIO.Concurrent
|
||||
|
||||
-- | Link-local broadcast address.
|
||||
pattern BROADCAST_ADDR_V4 :: (IsString a, Eq a) => a
|
||||
pattern BROADCAST_ADDR_V4 = "255.255.255.255"
|
||||
pattern BROADCAST_ADDR_V4 = "0.0.0.0"
|
||||
|
||||
pattern ANY_ADDR_V4 :: (IsString a, Eq a) => a
|
||||
pattern ANY_ADDR_V4 = "0.0.0.0"
|
||||
|
||||
pattern BROADCAST_PORT :: (IsString a, Eq a) => a
|
||||
pattern BROADCAST_PORT = "5226"
|
||||
|
||||
runAnnouncer :: (StrEncoding invite, MonadUnliftIO 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
|
||||
}
|
||||
-- | 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 finishAction invite credentials = do
|
||||
httpClient <- newEmptyMVar
|
||||
liftIO $ runTransportServer started BROADCAST_PORT 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 " <> BROADCAST_PORT
|
||||
sock <- UDP.clientSocket BROADCAST_ADDR_V4 BROADCAST_PORT False
|
||||
N.setSocketOption (UDP.udpSocket sock) N.Broadcast 1
|
||||
traceM $ "UDP announce started at " <> BROADCAST_ADDR_V4 <> ":" <> BROADCAST_PORT
|
||||
traceM $ "Server invite: " <> show inviteBS
|
||||
forever $ do
|
||||
UDP.send sock inviteBS
|
||||
threadDelay 1000000
|
||||
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
|
||||
readMVar finished
|
||||
cancel tlsServer
|
||||
finishAction
|
||||
readMVar httpClient
|
||||
|
||||
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 BROADCAST_PORT finished defaultHTTP2BufferSize tls >>= putMVar clientVar
|
||||
-- | 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
|
||||
|
||||
startTLSServer :: (MonadUnliftIO m) => TMVar Bool -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ())
|
||||
startTLSServer started credentials = async . liftIO . runTransportServer started BROADCAST_PORT serverParams defaultTransportServerConfig
|
||||
where
|
||||
serverParams =
|
||||
def
|
||||
{ TLS.serverWantClientCert = False,
|
||||
TLS.serverShared = def {TLS.sharedCredentials = credentials},
|
||||
TLS.serverHooks = def,
|
||||
TLS.serverSupported = supportedParameters
|
||||
}
|
||||
|
||||
-- | 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
|
||||
readMVar finishedVar
|
||||
|
||||
openListener :: (MonadIO m) => m UDP.ListenSocket
|
||||
openListener = liftIO $ do
|
||||
sock <- UDP.serverSocket (BROADCAST_ADDR_V4, read BROADCAST_PORT)
|
||||
sock <- UDP.serverSocket (ANY_ADDR_V4, read BROADCAST_PORT)
|
||||
N.setSocketOption (UDP.listenSocket sock) N.Broadcast 1
|
||||
pure sock
|
||||
|
||||
@@ -89,11 +102,14 @@ recvAnnounce sock = liftIO $ do
|
||||
(invite, UDP.ClientSockAddr source _cmsg) <- UDP.recvFrom sock
|
||||
pure (source, invite)
|
||||
|
||||
connectSessionHost :: (MonadUnliftIO m) => TransportHost -> C.KeyHash -> (Transport.TLS -> m a) -> m a
|
||||
connectSessionHost host caFingerprint = runTransportClient defaultTransportClientConfig Nothing host BROADCAST_PORT (Just caFingerprint)
|
||||
connectRevHTTP2 :: (MonadUnliftIO m) => TransportHost -> C.KeyHash -> (HTTP2Request -> m ()) -> m ()
|
||||
connectRevHTTP2 host fingerprint = connectTLSClient host fingerprint . attachHTTP2Server
|
||||
|
||||
attachServer :: (MonadUnliftIO m) => (HTTP2Request -> m ()) -> Transport.TLS -> m ()
|
||||
attachServer processRequest tls = do
|
||||
connectTLSClient :: (MonadUnliftIO m) => TransportHost -> C.KeyHash -> (Transport.TLS -> m a) -> m a
|
||||
connectTLSClient host caFingerprint = runTransportClient defaultTransportClientConfig Nothing host BROADCAST_PORT (Just caFingerprint)
|
||||
|
||||
attachHTTP2Server :: (MonadUnliftIO m) => (HTTP2Request -> m ()) -> Transport.TLS -> m ()
|
||||
attachHTTP2Server processRequest tls = do
|
||||
withRunInIO $ \unlift ->
|
||||
runHTTP2ServerWith defaultHTTP2BufferSize ($ tls) $ \sessionId r sendResponse -> do
|
||||
reqBody <- getHTTP2Body r defaultHTTP2BufferSize
|
||||
|
||||
@@ -6,26 +6,26 @@ module Simplex.Chat.Remote.Types where
|
||||
|
||||
import Control.Concurrent.Async (Async)
|
||||
import Data.Aeson (ToJSON (..))
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics (Generic)
|
||||
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
|
||||
import Simplex.Messaging.Encoding.String (strToJEncoding, strToJSON)
|
||||
|
||||
type RemoteHostId = Int64
|
||||
|
||||
data RemoteHost = RemoteHost
|
||||
{ remoteHostId :: RemoteHostId,
|
||||
displayName :: Text,
|
||||
-- | Path to store replicated files
|
||||
storePath :: FilePath,
|
||||
-- | A stable part of X509 credentials used to access the host
|
||||
caCert :: ByteString,
|
||||
displayName :: Text,
|
||||
-- | Credentials signing key for root and session certs
|
||||
caKey :: C.Key
|
||||
caKey :: C.APrivateSignKey,
|
||||
-- | A stable part of TLS credentials used in remote session
|
||||
caCert :: C.SignedCertificate,
|
||||
contacted :: Bool
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
@@ -39,19 +39,21 @@ data RemoteCtrl = RemoteCtrl
|
||||
}
|
||||
deriving (Show, Generic, ToJSON)
|
||||
|
||||
-- XXX: until fixed in master
|
||||
instance ToJSON C.KeyHash where
|
||||
toEncoding = strToJEncoding
|
||||
toJSON = strToJSON
|
||||
|
||||
data RemoteHostSession = RemoteHostSession
|
||||
{ -- | Path for local resources to be synchronized with host
|
||||
storePath :: FilePath,
|
||||
ctrlClient :: HTTP2Client
|
||||
}
|
||||
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
|
||||
ctrlAsync :: Async (),
|
||||
discoverer :: Async (),
|
||||
supervisor :: Async (),
|
||||
hostServer :: Maybe (Async ()),
|
||||
discovered :: TMap C.KeyHash TransportHost,
|
||||
accepted :: TMVar RemoteCtrlId
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user