xrcp: limit multicast validity time window (#1899)

Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>

protocol/xrcp.md

@@ -71,7 +71,7 @@ The session invitation contains this data:
 
 Host application decrypts (except the first session) and validates the invitation:
 - Session signature is valid.
-- Timestamp is within some window from the current time.
+- Timestamp of a multicast announcement is not earlier than 3660 seconds before and not later than 3600 seconds after the current time of the host. The host ignores announcements outside of this interval and continues listening.
 - Long-term key signature is valid.
 - Long-term CA and signature key are the same as in the first session.
 - Some version in the offered range is supported.

src/Simplex/RemoteControl/Client.hs

@@ -26,6 +26,7 @@ module Simplex.RemoteControl.Client
     -- for tests only
     sendRCPacket,
     receiveRCPacket,
+    findRCCtrlPairing,
   ) where
 
 import Control.Applicative ((<|>))
@@ -46,7 +47,7 @@ import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
 import Data.Maybe (isNothing)
 import qualified Data.Text as T
-import Data.Time.Clock.System (getSystemTime)
+import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import Data.Tuple (swap)
 import Data.Word (Word16)
 import qualified Data.X509 as X
@@ -395,8 +396,10 @@ findRCCtrlPairing :: NonEmpty RCCtrlPairing -> RCEncInvitation -> ExceptT RCErro
 findRCCtrlPairing pairings RCEncInvitation {dhPubKey, nonce, encInvitation} = do
   (pairing, signedInvStr) <- liftEither $ decrypt (L.toList pairings)
   signedInv <- liftEitherWith RCESyntax $ strDecode signedInvStr
-  inv@(RCVerifiedInvitation RCInvitation {dh = invDh}) <- maybe (throwE RCEInvitation) pure $ verifySignedInvitation signedInv
+  inv@(RCVerifiedInvitation RCInvitation {dh = invDh, ts}) <- maybe (throwE RCEInvitation) pure $ verifySignedInvitation signedInv
   unless (invDh == dhPubKey) $ throwE RCEInvitation
+  now <- systemSeconds <$> liftIO getSystemTime
+  unless (now - 3660 <= systemSeconds ts && systemSeconds ts <= now + 3600) $ throwE RCEInvitation
   pure (pairing, inv)
   where
     decrypt :: [RCCtrlPairing] -> Either RCErrorType (RCCtrlPairing, ByteString)

src/Simplex/RemoteControl/Discovery.hs

@@ -122,18 +122,22 @@ closeListener subscribers 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)
+  if now == 0
+    then
+      setMembership sock group True >>= \case
+        Left e -> atomically (putTMVar subscribers now) >> logError ("setMembership failed " <> tshow e)
+        Right () -> atomically $ putTMVar subscribers (now + 1)
+    else 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)
+  if now == 1
+    then
+      setMembership sock group False >>= \case
+        Left e -> atomically (putTMVar subscribers (now - 1)) >> logError ("setMembership failed " <> tshow e)
+        Right () -> atomically $ putTMVar subscribers (now - 1)
+    else atomically $ putTMVar subscribers (max 0 (now - 1))
 
 listenerHostAddr4 :: UDP.ListenSocket -> N.HostAddress
 listenerHostAddr4 sock = case UDP.mySockAddr sock of

tests/RemoteControl.hs

@@ -9,13 +9,15 @@ module RemoteControl where
 
 import AgentTests.FunctionalAPITests (runRight)
 import Control.Logger.Simple
+import Control.Monad (void)
+import Control.Monad.Trans.Except (runExceptT)
 import Crypto.Random (ChaChaDRG)
 import qualified Data.Aeson as J
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.List (stripPrefix)
 import Data.List.NonEmpty (NonEmpty (..))
-import Data.Time.Clock.System (SystemTime (..))
+import Data.Time.Clock.System (SystemTime (..), getSystemTime)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String (StrEncoding (..))
 import Simplex.Messaging.Transport (TSbChainKeys (..))
@@ -24,8 +26,10 @@ import qualified Simplex.RemoteControl.Client as HC (RCHostClient (action))
 import qualified Simplex.RemoteControl.Client as RC
 import Simplex.RemoteControl.Discovery (mkLastLocalHost, preferAddress)
 import Simplex.RemoteControl.Invitation
-  ( RCInvitation (..),
+  ( RCEncInvitation (..),
+    RCInvitation (..),
     RCSignedInvitation,
+    signInvitation,
     verifySignedInvitation,
   )
 import Simplex.RemoteControl.Types
@@ -45,6 +49,7 @@ remoteControlTests = do
     it "should connect to existing pairing" testExistingPairing
   describe "Multicast discovery" $ do
     it "should find paired host and connect" testMulticast
+    it "should accept announcement only within timestamp window" testAnnouncementTimestamp
 
 testPreferAddress :: Spec
 testPreferAddress = do
@@ -244,6 +249,26 @@ testMulticast = do
         Nothing -> fail "timeout"
         Just _ -> pure ()
 
+testAnnouncementTimestamp :: IO ()
+testAnnouncementTimestamp = do
+  drg <- C.newRandom
+  RCHostPairing {caKey, caCert, idPrivKey} <- RC.newRCHostPairing drg
+  (hostDhPubKey, dhPrivKey) <- atomically $ C.generateKeyPair @'C.X25519 drg
+  (skey, sessPrivKey) <- atomically $ C.generateKeyPair @'C.Ed25519 drg
+  (dh, ctrlDhPrivKey) <- atomically $ C.generateKeyPair @'C.X25519 drg
+  nonce <- atomically $ C.randomCbNonce drg
+  now <- systemSeconds <$> getSystemTime
+  let pairing = RCCtrlPairing {caKey, caCert, ctrlFingerprint = C.KeyHash "test-ca", idPubKey = C.publicKey idPrivKey, dhPrivKey, prevDhPrivKey = Nothing}
+      announce offset = do
+        let inv = RCInvitation {ca = C.KeyHash "test-ca", host = "127.0.0.1", port = 5223, v = supportedRCPVRange, app = J.String "app", ts = MkSystemTime (now + offset) 0, skey, idkey = C.publicKey idPrivKey, dh}
+        encInvitation <- either (fail . show) pure $ C.cbEncrypt (C.dh' hostDhPubKey ctrlDhPrivKey) nonce (strEncode $ signInvitation sessPrivKey idPrivKey inv) 900
+        runExceptT . void $ RC.findRCCtrlPairing (pairing :| []) RCEncInvitation {dhPubKey = dh, nonce, encInvitation}
+  announce 0 `shouldReturn` Right ()
+  announce (-3600) `shouldReturn` Right ()
+  announce 3500 `shouldReturn` Right ()
+  announce (-3700) `shouldReturn` Left RCEInvitation
+  announce 3700 `shouldReturn` Left RCEInvitation
+
 runCtrl :: TVar ChaChaDRG -> Bool -> RCHostPairing -> MVar RCSignedInvitation -> IO (Async RCHostPairing)
 runCtrl drg multicast hp invVar = async . runRight $ do
   (_found, inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") multicast Nothing Nothing