diff --git a/package.yaml b/package.yaml index 3b00c8552..9f2aa77cb 100644 --- a/package.yaml +++ b/package.yaml @@ -51,6 +51,7 @@ dependencies: - mtl == 2.3.* - network >= 3.1.2.7 && < 3.2 - network-transport == 0.5.6 + - network-udp >= 0.0 && < 0.1 - optparse-applicative >= 0.15 && < 0.17 - process == 1.6.* - random >= 1.1 && < 1.3 diff --git a/simplexmq.cabal b/simplexmq.cabal index 7ad59b427..84450caf7 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -141,6 +141,9 @@ library Simplex.Messaging.Transport.WebSockets Simplex.Messaging.Util Simplex.Messaging.Version + Simplex.RemoteControl.Discovery + Simplex.RemoteControl.Discovery.Multicast + Simplex.RemoteControl.Types other-modules: Paths_simplexmq hs-source-dirs: @@ -176,6 +179,7 @@ library , mtl ==2.3.* , network >=3.1.2.7 && <3.2 , network-transport ==0.5.6 + , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 @@ -239,6 +243,7 @@ executable ntf-server , mtl ==2.3.* , network >=3.1.2.7 && <3.2 , network-transport ==0.5.6 + , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 @@ -303,6 +308,7 @@ executable smp-agent , mtl ==2.3.* , network >=3.1.2.7 && <3.2 , network-transport ==0.5.6 + , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 @@ -367,6 +373,7 @@ executable smp-server , mtl ==2.3.* , network >=3.1.2.7 && <3.2 , network-transport ==0.5.6 + , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 @@ -431,6 +438,7 @@ executable xftp , mtl ==2.3.* , network >=3.1.2.7 && <3.2 , network-transport ==0.5.6 + , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 @@ -495,6 +503,7 @@ executable xftp-server , mtl ==2.3.* , network >=3.1.2.7 && <3.2 , network-transport ==0.5.6 + , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 @@ -594,6 +603,7 @@ test-suite simplexmq-test , mtl ==2.3.* , network >=3.1.2.7 && <3.2 , network-transport ==0.5.6 + , network-udp ==0.0.* , optparse-applicative >=0.15 && <0.17 , process ==1.6.* , random >=1.1 && <1.3 diff --git a/src/Simplex/RemoteControl/Discovery.hs b/src/Simplex/RemoteControl/Discovery.hs new file mode 100644 index 000000000..e085efa67 --- /dev/null +++ b/src/Simplex/RemoteControl/Discovery.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +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.String (IsString) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Data.Time.Clock.System (getSystemTime) +import Data.Word (Word16) +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 (..)) +import Simplex.Messaging.Transport (supportedParameters) +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 UnliftIO +import UnliftIO.Concurrent + +-- | mDNS multicast group +pattern MULTICAST_ADDR_V4 :: (IsString a, Eq a) => a +pattern MULTICAST_ADDR_V4 = "224.0.0.251" + +pattern ANY_ADDR_V4 :: (IsString a, Eq a) => a +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 => TMVar Int -> m (Maybe N.HostAddress) +getLocalAddress subscribers = liftIO $ do + probe <- mkIpProbe + let bytes = smpEncode probe + withListener subscribers $ \receiver -> + withSender $ \sender -> do + UDP.send sender bytes + let expect = do + UDP.recvFrom receiver >>= \case + (p, _) | p /= bytes -> expect + (_, UDP.ClientSockAddr (N.SockAddrInet _port host) _cmsg) -> pure host + (_, UDP.ClientSockAddr _badAddr _) -> error "receiving from IPv4 socket" + timeout 1000000 expect + +mkIpProbe :: MonadIO m => m IpProbe +mkIpProbe = do + randomNonce <- liftIO $ getRandomBytes 32 + pure IpProbe {versionRange = ipProbeVersionRange, randomNonce} + +-- | 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 + 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)}) + tasks `registerAsync` announcer + tlsServer <- startTLSServer started credentials $ \tls -> do + logInfo $ "Incoming connection for " <> ident + cancel announcer + runCtrl ctrlFinished ctrlStarted 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 + +-- | 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 + +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 -> + 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) + where + serverParams = + def + { TLS.serverWantClientCert = False, + TLS.serverShared = def {TLS.sharedCredentials = credentials}, + TLS.serverHooks = def, + TLS.serverSupported = supportedParameters + } + +withSender :: MonadUnliftIO m => (UDP.UDPSocket -> m a) -> m a +withSender = bracket (liftIO $ UDP.clientSocket MULTICAST_ADDR_V4 DISCOVERY_PORT False) (liftIO . UDP.close) + +withListener :: MonadUnliftIO m => TMVar Int -> (UDP.ListenSocket -> m a) -> m a +withListener subscribers = bracket (openListener subscribers) (closeListener subscribers) + +openListener :: MonadIO m => TMVar Int -> m UDP.ListenSocket +openListener subscribers = liftIO $ do + sock <- UDP.serverSocket (MULTICAST_ADDR_V4, read DISCOVERY_PORT) + logDebug $ "Discovery listener socket: " <> tshow sock + let raw = UDP.listenSocket sock + -- N.setSocketOption raw N.Broadcast 1 + joinMulticast subscribers raw (listenerHostAddr4 sock) + 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 + +joinMulticast :: TMVar Int -> N.Socket -> N.HostAddress -> IO () +joinMulticast subscribers sock group = do + now <- atomically $ takeTMVar subscribers + when (now == 0) $ do + setMembership sock group True >>= \case + Left e -> atomically (putTMVar subscribers now) >> logError ("setMembership failed " <> tshow e) + Right () -> atomically $ putTMVar subscribers (now + 1) + +partMulticast :: TMVar Int -> N.Socket -> N.HostAddress -> IO () +partMulticast subscribers sock group = do + now <- atomically $ takeTMVar subscribers + when (now == 1) $ + setMembership sock group False >>= \case + Left e -> atomically (putTMVar subscribers now) >> logError ("setMembership failed " <> tshow e) + Right () -> atomically $ putTMVar subscribers (now - 1) + +listenerHostAddr4 :: UDP.ListenSocket -> N.HostAddress +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 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) diff --git a/src/Simplex/RemoteControl/Discovery/Multicast.hsc b/src/Simplex/RemoteControl/Discovery/Multicast.hsc new file mode 100644 index 000000000..1a5260da3 --- /dev/null +++ b/src/Simplex/RemoteControl/Discovery/Multicast.hsc @@ -0,0 +1,48 @@ +module Simplex.RemoteControl.Discovery.Multicast + ( setMembership + ) where + +import Foreign (Ptr, allocaBytes, castPtr, pokeByteOff) +import Foreign.C.Types (CInt (..)) +import Network.Socket + +#include + +{- | Toggle multicast group membership. + +NB: Group membership is per-host, not per-process. A socket is only used to access system interface for groups. +-} +setMembership :: Socket -> HostAddress -> Bool -> IO (Either CInt ()) +setMembership sock group membership = allocaBytes #{size struct ip_mreq} $ \mReqPtr -> do + #{poke struct ip_mreq, imr_multiaddr} mReqPtr group + #{poke struct ip_mreq, imr_interface} mReqPtr (0 :: HostAddress) -- attempt to contact the group on ANY interface + withFdSocket sock $ \fd -> do + rc <- c_setsockopt fd c_IPPROTO_IP flag (castPtr mReqPtr) (#{size struct ip_mreq}) + if rc == 0 + then pure $ Right () + else pure $ Left rc + where + flag = if membership then c_IP_ADD_MEMBERSHIP else c_IP_DROP_MEMBERSHIP + +#ifdef mingw32_HOST_OS + +foreign import stdcall unsafe "setsockopt" + c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt + +c_IP_ADD_MEMBERSHIP, c_IP_DROP_MEMBERSHIP :: CInt +c_IP_ADD_MEMBERSHIP = 12 +c_IP_DROP_MEMBERSHIP = 13 + +#else + +foreign import ccall unsafe "setsockopt" + c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt + +c_IP_ADD_MEMBERSHIP, c_IP_DROP_MEMBERSHIP :: CInt +c_IP_ADD_MEMBERSHIP = #const IP_ADD_MEMBERSHIP +c_IP_DROP_MEMBERSHIP = #const IP_DROP_MEMBERSHIP + +#endif + +c_IPPROTO_IP :: CInt +c_IPPROTO_IP = #const IPPROTO_IP diff --git a/src/Simplex/RemoteControl/Types.hs b/src/Simplex/RemoteControl/Types.hs new file mode 100644 index 000000000..b01c47e9b --- /dev/null +++ b/src/Simplex/RemoteControl/Types.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} + +module Simplex.RemoteControl.Types where + +import Control.Monad +import Crypto.Error (eitherCryptoError) +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.ByteArray (convert) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Foldable (toList) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8Lenient, encodeUtf8) +import Data.Time.Clock.System (SystemTime) +import Data.Word (Word16) +import Network.HTTP.Types (parseSimpleQuery) +import Network.HTTP.Types.URI (renderSimpleQuery, urlDecode, urlEncode) +import qualified Network.Socket as N +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding (Encoding (..)) +import Simplex.Messaging.Encoding.String (StrEncoding (..)) +import Simplex.Messaging.Version (VersionRange, mkVersionRange) +import UnliftIO + +ipProbeVersionRange :: VersionRange +ipProbeVersionRange = mkVersionRange 1 1 + +data IpProbe = IpProbe + { versionRange :: VersionRange, + randomNonce :: ByteString + } deriving (Show) + +instance Encoding IpProbe where + smpEncode IpProbe {versionRange, randomNonce} = smpEncode (versionRange, 'I', randomNonce) + + smpP = IpProbe <$> (smpP <* "I") *> smpP + +announceVersionRange :: VersionRange +announceVersionRange = mkVersionRange 1 1 + +data Announce = Announce + { versionRange :: VersionRange, + sessionStart :: SystemTime, + announceCounter :: Word16, + serviceAddress :: (N.HostAddress, Word16), + caFingerprint :: C.KeyHash, + sessionDH :: C.PublicKeyX25519, + announceKey :: C.PublicKeyEd25519 + } deriving (Show) + +instance Encoding Announce where + smpEncode Announce {versionRange, sessionStart, announceCounter, serviceAddress, caFingerprint, sessionDH, announceKey} = + smpEncode (versionRange, 'A', sessionStart, announceCounter, serviceAddress) + <> smpEncode (caFingerprint, sessionDH, announceKey) + + smpP = Announce <$> (smpP <* "A") <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP + +data SignedAnnounce = SignedAnnounce Announce (C.Signature 'C.Ed25519) + +instance Encoding SignedAnnounce where + smpEncode (SignedAnnounce ann (C.SignatureEd25519 sig)) = smpEncode (ann, convert sig :: ByteString) + + smpP = do + sa <- SignedAnnounce <$> smpP <*> signatureP + unless (verifySignedAnnounce sa) $ fail "bad announce signature" + pure sa + where + signatureP = do + bs <- smpP :: A.Parser ByteString + case eitherCryptoError (Ed25519.signature bs) of + Left ce -> fail $ show ce + Right ok -> pure $ C.SignatureEd25519 ok + +signAnnounce :: C.PrivateKey C.Ed25519 -> Announce -> SignedAnnounce +signAnnounce announceSecret ann = SignedAnnounce ann sig + where + sig = + case C.sign (C.APrivateSignKey C.SEd25519 announceSecret) (smpEncode ann) of + C.ASignature C.SEd25519 s -> s + _ -> error "signing with ed25519" + +verifySignedAnnounce :: SignedAnnounce -> Bool +verifySignedAnnounce (SignedAnnounce ann@Announce {announceKey} sig) = C.verify aKey aSig (smpEncode ann) + where + aKey = C.APublicVerifyKey C.SEd25519 announceKey + aSig = C.ASignature C.SEd25519 sig + +data OOB = OOB + { -- authority part + caFingerprint :: C.KeyHash, + authToken :: Text, + host :: Text, + port :: Word16, + -- query part + version :: VersionRange, -- v= + appName :: Text, -- app= + sigPubKey :: C.PublicKeyEd25519, -- key= + deviceName :: Maybe Text -- device= + } + deriving (Eq, Show) + +instance StrEncoding OOB where + strEncode OOB {caFingerprint, authToken, host, port, version, appName, sigPubKey, deviceName} = + schema <> "://" <> authority <> "#/?" <> renderSimpleQuery False query + where + schema = "xrcp" + authority = + mconcat + [ strEncode caFingerprint, + ":", + encodeUtf8 authToken, + "@", + encodeUtf8 host, + ":", + strEncode port + ] + query = + [ ("v", strEncode version), + ("app", encodeUtf8 appName), + ("key", strEncode $ C.encodePubKey sigPubKey) + ] + ++ [("device", urlEncode True $ encodeUtf8 name) | name <- toList deviceName] + + strP = do + _ <- A.string "xrcp://" + caFingerprint <- strP + _ <- A.char ':' + authToken <- decodeUtf8Lenient <$> A.takeWhile (/= '@') + _ <- A.char '@' + host <- decodeUtf8Lenient <$> A.takeWhile (/= ':') + _ <- A.char ':' + port <- strP + + _ <- A.string "#/?" + q <- parseSimpleQuery <$> A.takeByteString + version <- maybe (fail "missing version") (either fail pure . strDecode) (lookup "v" q) + appName <- maybe (fail "missing appName") (pure . decodeUtf8Lenient) (lookup "app" q) + sigPubKeyB64 <- maybe (fail "missing key") pure (lookup "key" q) + sigPubKey <- either fail pure $ strDecode sigPubKeyB64 >>= C.decodePubKey + let deviceName = fmap (decodeUtf8Lenient . urlDecode True) (lookup "device" q) + pure OOB {caFingerprint, authToken, host, port, version, appName, sigPubKey, deviceName} + +data SignedOOB = SignedOOB OOB (C.Signature 'C.Ed25519) + deriving (Eq, Show) + +instance StrEncoding SignedOOB where + strEncode (SignedOOB oob sig) = strEncode oob <> "&sig=" <> strEncode (C.signatureBytes sig) + + strDecode s = do + unless (B.length sig == sigLen) $ Left "bad size" + unless ("&sig=" `B.isPrefixOf` sig) $ Left "bad signature prefix" + signedOOB <- SignedOOB <$> strDecode oob <*> (strDecode (B.drop 5 sig) >>= C.decodeSignature) + unless (verifySignedOOB signedOOB) $ Left "bad signature" + pure signedOOB + where + l = B.length s + (oob, sig) = B.splitAt (l - sigLen) s + sigLen = 93 -- &sig= + ed25519 sig size in base64 (88) + + -- XXX: strP is used in chat command parser, but default strP assumes bas64url-encoded bytestring, where OOB is an URL-like + strP = A.takeWhile (/= ' ') >>= either fail pure . strDecode + +signOOB :: C.PrivateKey C.Ed25519 -> OOB -> SignedOOB +signOOB key oob = SignedOOB oob sig + where + sig = + case C.sign (C.APrivateSignKey C.SEd25519 key) (strEncode oob) of + C.ASignature C.SEd25519 s -> s + _ -> error "signing with ed25519" + +verifySignedOOB :: SignedOOB -> Bool +verifySignedOOB (SignedOOB oob@OOB {sigPubKey} sig) = C.verify aKey aSig (strEncode oob) + where + aKey = C.APublicVerifyKey C.SEd25519 sigPubKey + aSig = C.ASignature C.SEd25519 sig + +decodeOOBLink :: Text -> Either String OOB +decodeOOBLink = fmap (\(SignedOOB oob _verified) -> oob) . strDecode . encodeUtf8 + +-- XXX: Move to utils? +type Tasks = TVar [Async ()] + +asyncRegistered :: MonadUnliftIO m => Tasks -> m () -> m () +asyncRegistered tasks action = async action >>= registerAsync tasks + +registerAsync :: MonadIO m => Tasks -> Async () -> m () +registerAsync tasks = atomically . modifyTVar tasks . (:) + +cancelTasks :: (MonadIO m) => Tasks -> m () +cancelTasks tasks = readTVarIO tasks >>= mapM_ cancel