dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-06-04 17:21:30 +00:00
Code Issues Packages Projects Releases Wiki Activity

agent: xrcp implementation for connection via link (no multicast) (#884)

Browse Source 
* WIP: start working on connection invites

startSession/OOB is broken now - the port isn't coming from the actualy assigned one.

* Add invite types

* clean old invite-related types

* apply renames

* Move SessionKeys from Invitation

* Stub host-side keys and handle

* move keys and handles to Types

* add Simplex.RemoteControl.Client

* more keys

* progress

* crypto for sessions

* progress to multicast

* multicast crypto

* add RC TLS server

* agent api for remote control

* WIP: tls client

* fix test

* update encoding to include nonce

* add TODO

* update

* Use network-info to find TransportHost

* request and submit tls client certificate

* WIP: add missing bits for testing RC client

* RCEncryptedHello encoding

* add block encoding

* refactor

* validate known host certificate

* remove some spaghetti

* functional API to host/ctrl clients

* refactor connectRCCtrl_

* refactor connectRCHost

* question

* add type

* fix RC session

* update doc

* update doc 2

* add block on confirmation

* remove unused parameter

* export CtrlSessKeys

* export

* fix parsing

* move test of xrcp handshake

* move KEM to HELLO step

* fix JSON

* type

---------

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
Alexander Bondarenko
2023-11-07 15:05:18 +02:00
committed by GitHub
parent 1a0c4b73de
commit 1a8dfb4cbe
22 changed files with 1181 additions and 316 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/RemoteControl/Discovery.hs
+84 -75
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -8,24 +7,23 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
-- XXX: remove non-discovery functions
module Simplex.RemoteControl.Discovery where
import Control.Logger.Simple
import Control.Monad
import Crypto.Random (getRandomBytes)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64.URL as B64U
import Data.Default (def)
import Data.Maybe (listToMaybe, mapMaybe)
import Data.String (IsString)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Clock.System (getSystemTime)
import Data.Word (Word16)
import Network.Info (IPv4 (..), NetworkInterface (..), getNetworkInterfaces)
import qualified Network.Socket as N
import qualified Network.TLS as TLS
import qualified Network.UDP as UDP
import Simplex.RemoteControl.Discovery.Multicast (setMembership)
import Simplex.RemoteControl.Types
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding (Encoding (..))
import Simplex.Messaging.Encoding.String (StrEncoding (..))
@@ -34,7 +32,9 @@ import qualified Simplex.Messaging.Transport as Transport
import Simplex.Messaging.Transport.Client (TransportHost (..), defaultTransportClientConfig, runTransportClient)
import Simplex.Messaging.Transport.Server (defaultTransportServerConfig, runTransportServerSocket, startTCPServer)
import Simplex.Messaging.Util (ifM, tshow)
import Simplex.Messaging.Version (mkVersionRange)
import Simplex.Messaging.Version (VersionRange)
import Simplex.RemoteControl.Discovery.Multicast (setMembership)
import Simplex.RemoteControl.Types
import UnliftIO
import UnliftIO.Concurrent
@@ -48,39 +48,18 @@ pattern ANY_ADDR_V4 = "0.0.0.0"
pattern DISCOVERY_PORT :: (IsString a, Eq a) => a
pattern DISCOVERY_PORT = "5227"
startSession :: MonadIO m => Maybe Text -> (N.HostAddress, Word16) -> C.KeyHash -> m ((C.APublicDhKey, C.APrivateDhKey), C.PrivateKeyEd25519, Announce, SignedOOB)
startSession deviceName serviceAddress caFingerprint = liftIO $ do
sessionStart <- getSystemTime
dh@(C.APublicDhKey C.SX25519 sessionDH, _) <- C.generateDhKeyPair C.SX25519
(C.APublicVerifyKey C.SEd25519 sigPubKey, C.APrivateSignKey C.SEd25519 sigSecretKey) <- C.generateSignatureKeyPair C.SEd25519
let
announce =
Announce
{ versionRange = announceVersionRange,
sessionStart,
announceCounter = 0,
serviceAddress,
caFingerprint,
sessionDH,
announceKey = sigPubKey
}
authToken <- decodeUtf8 . B64U.encode <$> getRandomBytes 12
let
oob =
OOB
{ caFingerprint,
authToken,
host = decodeUtf8 . strEncode $ THIPv4 . N.hostAddressToTuple $ fst serviceAddress,
port = snd serviceAddress,
version = mkVersionRange 1 1,
appName = "simplex-chat",
sigPubKey,
deviceName
}
pure (dh, sigSecretKey, announce, signOOB sigSecretKey oob)
getLocalAddress :: MonadIO m => m (Maybe TransportHost)
getLocalAddress = listToMaybe . mapMaybe usable <$> liftIO getNetworkInterfaces
where
usable NetworkInterface {ipv4 = IPv4 ha} = case N.hostAddressToTuple ha of
(0, 0, 0, 0) -> Nothing -- "no" address
(255, 255, 255, 255) -> Nothing -- broadcast
(127, _, _, _) -> Nothing -- localhost
(169, 254, _, _) -> Nothing -- link-local
ok -> Just $ THIPv4 ok
getLocalAddress :: MonadIO m => TMVar Int -> m (Maybe N.HostAddress)
getLocalAddress subscribers = liftIO $ do
getLocalAddressMulticast :: MonadIO m => TMVar Int -> m (Maybe TransportHost)
getLocalAddressMulticast subscribers = liftIO $ do
probe <- mkIpProbe
let bytes = smpEncode probe
withListener subscribers $ \receiver ->
@@ -89,7 +68,7 @@ getLocalAddress subscribers = liftIO $ do
let expect = do
UDP.recvFrom receiver >>= \case
(p, _) | p /= bytes -> expect
(_, UDP.ClientSockAddr (N.SockAddrInet _port host) _cmsg) -> pure host
(_, UDP.ClientSockAddr (N.SockAddrInet _port host) _cmsg) -> pure $ THIPv4 (N.hostAddressToTuple host)
(_, UDP.ClientSockAddr _badAddr _) -> error "receiving from IPv4 socket"
timeout 1000000 expect
@@ -101,57 +80,77 @@ mkIpProbe = do
-- | 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.
announceCtrl :: MonadUnliftIO m => (MVar () -> MVar rc -> Transport.TLS -> IO ()) -> Tasks -> (C.PrivateKeyEd25519, Announce) -> TLS.Credentials -> m () -> m rc
announceCtrl runCtrl tasks (sigKey, announce@Announce {caFingerprint, serviceAddress=(host, _port)}) credentials finishAction = do
announceCtrl ::
MonadUnliftIO m =>
(MVar rc -> MVar () -> Transport.TLS -> IO ()) ->
Tasks ->
TMVar (Maybe N.PortNumber) ->
Maybe (Text, VersionRange) ->
Maybe Text ->
C.PrivateKeyEd25519 ->
CtrlSessionKeys ->
-- | Session address to announce
TransportHost ->
m () ->
m rc
announceCtrl runCtrl tasks started app_ device_ idkey sk@CtrlSessionKeys {ca, credentials} host finishAction = do
ctrlStarted <- newEmptyMVar
started <- newEmptyTMVarIO
ctrlFinished <- newEmptyMVar
_ <- forkIO $ readMVar ctrlFinished >> finishAction -- attach external cleanup action to session lock
announcer <- async . liftIO $ atomically (takeTMVar started) >>= \case
Nothing -> pure () -- TLS server failed to start, skipping announcer
Just givenPort -> do
logInfo $ "Starting announcer for " <> ident <> " at " <> tshow (host, givenPort)
runAnnouncer (sigKey, announce {serviceAddress = (host, fromIntegral givenPort)})
announcer <-
async . liftIO $
atomically (readTMVar started) >>= \case
Nothing -> pure () -- TLS server failed to start, skipping announcer
Just givenPort -> do
logInfo $ "Starting announcer for " <> ident <> " at " <> tshow (host, givenPort)
runAnnouncer app_ device_ idkey sk (host, givenPort) -- (sigKey, announce {serviceAddress = (host, fromIntegral givenPort)})
tasks `registerAsync` announcer
tlsServer <- startTLSServer started credentials $ \tls -> do
let hooks = undefined -- TODO
tlsServer <- startTLSServer started credentials hooks $ \tls -> do
logInfo $ "Incoming connection for " <> ident
cancel announcer
runCtrl ctrlFinished ctrlStarted tls `catchAny` (logError . tshow)
runCtrl ctrlStarted ctrlFinished tls `catchAny` (logError . tshow)
logInfo $ "Client finished for " <> ident
_ <- forkIO $ waitCatch tlsServer >> void (tryPutMVar ctrlFinished ())
tasks `registerAsync` tlsServer
logInfo $ "Waiting for client for " <> ident
readMVar ctrlStarted
where
ident = decodeUtf8 $ strEncode caFingerprint
ident = decodeUtf8 $ strEncode ca
runAnnouncer :: Maybe (Text, VersionRange) -> Maybe Text -> C.PrivateKeyEd25519 -> CtrlSessionKeys -> (TransportHost, N.PortNumber) -> IO ()
runAnnouncer app_ device_ idSigKey sk (host, port) = error "runAnnouncer: make invites, encrypt and send"
-- | Send replay-proof announce datagrams
runAnnouncer :: (C.PrivateKeyEd25519, Announce) -> IO ()
runAnnouncer (announceKey, initialAnnounce) = withSender $ loop initialAnnounce
where
loop announce sock = do
UDP.send sock $ smpEncode (signAnnounce announceKey announce)
threadDelay 1000000
loop announce {announceCounter = announceCounter announce + 1} sock
-- runAnnouncer :: (C.PrivateKeyEd25519, Announce) -> IO ()
-- runAnnouncer (announceKey, initialAnnounce) = withSender $ loop initialAnnounce
-- where
-- loop announce sock = do
-- UDP.send sock $ smpEncode (signAnnounce announceKey announce)
-- threadDelay 1000000
-- loop announce {announceCounter = announceCounter announce + 1} sock
startTLSServer :: (MonadUnliftIO m) => TMVar (Maybe N.PortNumber) -> TLS.Credentials -> (Transport.TLS -> IO ()) -> m (Async ())
startTLSServer started credentials server = async . liftIO $ do
startedOk <- newEmptyTMVarIO
bracketOnError (startTCPServer startedOk "0") (\_e -> void . atomically $ tryPutTMVar started Nothing) $ \socket ->
-- XXX: move to RemoteControl.Client
startTLSServer :: MonadUnliftIO m => TMVar (Maybe N.PortNumber) -> TLS.Credentials -> TLS.ServerHooks -> (Transport.TLS -> IO ()) -> m (Async ())
startTLSServer startedOnPort credentials hooks server = async . liftIO $ do
started <- newEmptyTMVarIO
bracketOnError (startTCPServer started "0") (\_e -> setPort Nothing) $ \socket ->
ifM
(atomically $ readTMVar startedOk)
do
port <- N.socketPort socket
logInfo $ "System-assigned port: " <> tshow port
atomically $ putTMVar started (Just port)
runTransportServerSocket startedOk (pure socket) "RCP TLS" serverParams defaultTransportServerConfig server
(void . atomically $ tryPutTMVar started Nothing)
(atomically $ readTMVar started)
(runServer started socket)
(setPort Nothing)
where
runServer started socket = do
port <- N.socketPort socket
logInfo $ "System-assigned port: " <> tshow port
setPort $ Just port
runTransportServerSocket started (pure socket) "RCP TLS" serverParams defaultTransportServerConfig server
setPort = void . atomically . tryPutTMVar startedOnPort
serverParams =
def
{ TLS.serverWantClientCert = False,
{ TLS.serverWantClientCert = True,
TLS.serverShared = def {TLS.sharedCredentials = credentials},
TLS.serverHooks = def,
TLS.serverHooks = hooks,
TLS.serverSupported = supportedParameters
}
@@ -171,8 +170,9 @@ openListener subscribers = liftIO $ do
pure sock
closeListener :: MonadIO m => TMVar Int -> UDP.ListenSocket -> m ()
closeListener subscribers sock = liftIO $
partMulticast subscribers (UDP.listenSocket sock) (listenerHostAddr4 sock) `finally` UDP.stop sock
closeListener subscribers sock =
liftIO $
partMulticast subscribers (UDP.listenSocket sock) (listenerHostAddr4 sock) `finally` UDP.stop sock
joinMulticast :: TMVar Int -> N.Socket -> N.HostAddress -> IO ()
joinMulticast subscribers sock group = do
@@ -195,10 +195,19 @@ listenerHostAddr4 sock = case UDP.mySockAddr sock of
N.SockAddrInet _port host -> host
_ -> error "MULTICAST_ADDR_V4 is V4"
recvAnnounce :: (MonadIO m) => UDP.ListenSocket -> m (N.SockAddr, ByteString)
recvAnnounce :: MonadIO m => UDP.ListenSocket -> m (N.SockAddr, ByteString)
recvAnnounce sock = liftIO $ do
(invite, UDP.ClientSockAddr source _cmsg) <- UDP.recvFrom sock
pure (source, invite)
connectTLSClient :: (MonadUnliftIO m) => (TransportHost, Word16) -> C.KeyHash -> (Transport.TLS -> m a) -> m a
connectTLSClient (host, port) caFingerprint = runTransportClient defaultTransportClientConfig Nothing host (show port) (Just caFingerprint)
connectTLSClient ::
MonadUnliftIO m =>
(TransportHost, Word16) ->
HostSessionKeys ->
(HostCryptoHandle -> Transport.TLS -> m a) ->
m a
connectTLSClient (host, port) HostSessionKeys {ca} client =
runTransportClient defaultTransportClientConfig Nothing host (show port) (Just ca) $ \tls -> do
-- TODO: set up host side using
let hch = HostCryptoHandle
client hch tls