diff --git a/rfcs/2023-10-25-remote-control.md b/rfcs/2023-10-25-remote-control.md index ba731bc13..b97cb591e 100644 --- a/rfcs/2023-10-25-remote-control.md +++ b/rfcs/2023-10-25-remote-control.md @@ -285,7 +285,7 @@ announcementSecret(n) = sha256(dhSecret(n') || kemSecret(n - 1)) dhSecret(n') = dh(hostHelloDhKey(n - 1), controllerAnnouncementDhKey(n)) // session n -hostHelloSecret(n) = sha256(dhSecret(n) || kemSecret(n - 1)) +hostHelloSecret(n) = dhSecret(n) sessionSecret(n) = sha256(dhSecret(n) || kemSecret(n)) // to encrypt session n data, incl. controller hello dhSecret(n) = dh(hostHelloDhKey(n), controllerAnnouncementDhKey(n)) kemCiphertext(n) = enc(kemSecret(n), kemEncKey(n)) diff --git a/src/Simplex/Messaging/Crypto/SNTRUP761.hs b/src/Simplex/Messaging/Crypto/SNTRUP761.hs index 2dd63c434..99b2771f6 100644 --- a/src/Simplex/Messaging/Crypto/SNTRUP761.hs +++ b/src/Simplex/Messaging/Crypto/SNTRUP761.hs @@ -15,30 +15,17 @@ import Simplex.Messaging.Crypto.SNTRUP761.Bindings -- Hybrid shared secret for crypto_box is defined as SHA256(DHSecret || KEMSharedKey), -- similar to https://datatracker.ietf.org/doc/draft-josefsson-ntruprime-hybrid/ -class KEMSharedSecret kem where kemSecretBytes :: kem -> ScrubbedBytes - newtype KEMHybridSecret = KEMHybridSecret ScrubbedBytes -newtype KEMHybridOrDHSecret = KEMHybridOrDHSecret ScrubbedBytes - -instance KEMSharedSecret KEMHybridSecret where kemSecretBytes (KEMHybridSecret secret) = secret - -instance KEMSharedSecret KEMHybridOrDHSecret where kemSecretBytes (KEMHybridOrDHSecret secret) = secret - -- | NaCl @crypto_box@ decrypt with a shared hybrid DH + KEM secret and 192-bit nonce. -kcbDecrypt :: KEMSharedSecret kem => kem -> CbNonce -> ByteString -> Either CryptoError ByteString -kcbDecrypt = sbDecrypt_ . kemSecretBytes +kcbDecrypt :: KEMHybridSecret -> CbNonce -> ByteString -> Either CryptoError ByteString +kcbDecrypt (KEMHybridSecret k) = sbDecrypt_ k -- | NaCl @crypto_box@ encrypt with a shared hybrid DH + KEM secret and 192-bit nonce. -kcbEncrypt :: KEMSharedSecret kem => kem -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString -kcbEncrypt = sbEncrypt_ . kemSecretBytes +kcbEncrypt :: KEMHybridSecret -> CbNonce -> ByteString -> Int -> Either CryptoError ByteString +kcbEncrypt (KEMHybridSecret k) = sbEncrypt_ k kemHybridSecret :: PublicKeyX25519 -> PrivateKeyX25519 -> KEMSharedKey -> KEMHybridSecret kemHybridSecret k pk (KEMSharedKey kem) = let DhSecretX25519 dh = C.dh' k pk in KEMHybridSecret $ BA.convert (hash $ BA.convert dh <> kem :: Digest SHA256) - -kemHybridOrDHSecret :: PublicKeyX25519 -> PrivateKeyX25519 -> Maybe KEMSharedKey -> KEMHybridOrDHSecret -kemHybridOrDHSecret k pk = \case - Just kem -> KEMHybridOrDHSecret $ kemSecretBytes $ kemHybridSecret k pk kem - Nothing -> let DhSecretX25519 dh = C.dh' k pk in KEMHybridOrDHSecret $ BA.convert dh diff --git a/src/Simplex/RemoteControl/Client.hs b/src/Simplex/RemoteControl/Client.hs index dd7142c9b..d2221956d 100644 --- a/src/Simplex/RemoteControl/Client.hs +++ b/src/Simplex/RemoteControl/Client.hs @@ -30,7 +30,6 @@ import Control.Monad.Except import Control.Monad.IO.Class import Crypto.Random (ChaChaDRG) import qualified Data.Aeson as J -import qualified Data.Aeson.TH as JQ import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB @@ -199,15 +198,14 @@ prepareHostSession pairing@RCHostPairing {idPrivKey, knownHost = knownHost_} RCHostKeys {sessKeys = (_, sessPrivKey), dhKeys = (_, dhPrivKey)} RCHostEncHello {dhPubKey, nonce, encBody} = do - let sharedKey = kemHybridOrDHSecret dhPubKey dhPrivKey $ (\h -> h.storedSessKeys.kemSharedKey) <$> knownHost_ - helloBody <- liftEitherWith (const RCEDecrypt) $ kcbDecrypt sharedKey nonce encBody + let sharedKey = C.dh' dhPubKey dhPrivKey + helloBody <- liftEitherWith (const RCEDecrypt) $ C.cbDecrypt sharedKey nonce encBody hostHello@RCHostHello {v, ca, kem = kemPubKey} <- liftEitherWith RCESyntax $ J.eitherDecodeStrict helloBody (kemCiphertext, kemSharedKey) <- liftIO $ sntrup761Enc drg kemPubKey let hybridKey = kemHybridSecret dhPubKey dhPrivKey kemSharedKey unless (isCompatible v supportedRCVRange) $ throwError RCEVersion let keys = HostSessKeys {hybridKey, idPrivKey, sessPrivKey} - storedSessKeys = StoredHostSessKeys {hostDHPublicKey = dhPubKey, kemSharedKey} - knownHost' <- updateKnownHost ca storedSessKeys + knownHost' <- updateKnownHost ca dhPubKey let ctrlHello = RCCtrlHello {} -- TODO send error response if something fails nonce' <- liftIO . atomically $ C.pseudoRandomCbNonce drg @@ -215,14 +213,14 @@ prepareHostSession let ctrlEncHello = RCCtrlEncHello {kem = kemCiphertext, nonce = nonce', encBody = encBody'} pure (ctrlEncHello, keys, hostHello, pairing {knownHost = Just knownHost'}) where - updateKnownHost :: C.KeyHash -> StoredHostSessKeys -> ExceptT RCErrorType IO KnownHostPairing - updateKnownHost ca storedSessKeys = case knownHost_ of + updateKnownHost :: C.KeyHash -> C.PublicKeyX25519 -> ExceptT RCErrorType IO KnownHostPairing + updateKnownHost ca hostDhPubKey = case knownHost_ of Just h -> do unless (h.hostFingerprint == tlsHostFingerprint) . throwError $ RCEInternal "TLS host CA is different from host pairing, should be caught in TLS handshake" unless (ca == tlsHostFingerprint) $ throwError RCEIdentity - pure (h :: KnownHostPairing) {storedSessKeys} - Nothing -> pure KnownHostPairing {hostFingerprint = ca, storedSessKeys} + pure (h :: KnownHostPairing) {hostDhPubKey} + Nothing -> pure KnownHostPairing {hostFingerprint = ca, hostDhPubKey} data RCCtrlClient = RCCtrlClient { action :: Async (), @@ -252,13 +250,12 @@ connectRCCtrl drg inv@RCInvitation {ca, idkey} pairing_ hostAppInfo = do newCtrlPairing = do ((_, caKey), caCert) <- genCredentials Nothing (0, 24 * 999999) "ca" (_, dhPrivKey) <- C.generateKeyPair' - let storedSessKeys = StoredCtrlSessKeys dhPrivKey Nothing - pure RCCtrlPairing {caKey, caCert, ctrlFingerprint = ca, idPubKey = idkey, storedSessKeys, prevStoredSessKeys = Nothing} + pure RCCtrlPairing {caKey, caCert, ctrlFingerprint = ca, idPubKey = idkey, dhPrivKey, prevDhPrivKey = Nothing} updateCtrlPairing :: RCCtrlPairing -> ExceptT RCErrorType IO RCCtrlPairing - updateCtrlPairing pairing@RCCtrlPairing {ctrlFingerprint, idPubKey, storedSessKeys = currSSK} = do + updateCtrlPairing pairing@RCCtrlPairing {ctrlFingerprint, idPubKey, dhPrivKey = currDhPrivKey} = do unless (ca == ctrlFingerprint && idPubKey == idkey) $ throwError RCEIdentity (_, dhPrivKey) <- liftIO C.generateKeyPair' - pure pairing {storedSessKeys = currSSK {dhPrivKey}, prevStoredSessKeys = Just currSSK} + pure pairing {dhPrivKey, prevDhPrivKey = Just currDhPrivKey} connectRCCtrl_ :: TVar ChaChaDRG -> RCCtrlPairing -> RCInvitation -> J.Value -> ExceptT RCErrorType IO RCCtrlConnection connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, host, port} hostAppInfo = do @@ -298,8 +295,8 @@ connectRCCtrl_ drg pairing'@RCCtrlPairing {caKey, caCert} inv@RCInvitation {ca, sendRCPacket tls hostEncHello ctrlEncHello <- receiveRCPacket tls logDebug "Received ctrl HELLO" - (ctrlSessKeys, pairing'') <- prepareCtrlSession pairing' inv sharedKey kemPrivKey ctrlEncHello - atomically $ putTMVar r' $ Right (RCCtrlSession {tls, sessionKeys = ctrlSessKeys}, pairing'') + ctrlSessKeys <- prepareCtrlSession pairing' inv sharedKey kemPrivKey ctrlEncHello + atomically $ putTMVar r' $ Right (RCCtrlSession {tls, sessionKeys = ctrlSessKeys}, pairing') -- TODO receive OK response logDebug "Session started" -- release second putTMVar in confirmCtrlSession @@ -319,10 +316,10 @@ receiveRCPacket tls = do b' <- liftEitherWith (const RCEBlockSize) $ C.unPad b liftEitherWith RCESyntax $ smpDecode b' -prepareHostHello :: TVar ChaChaDRG -> RCCtrlPairing -> RCInvitation -> J.Value -> ExceptT RCErrorType IO (KEMHybridOrDHSecret, KEMSecretKey, RCHostEncHello) +prepareHostHello :: TVar ChaChaDRG -> RCCtrlPairing -> RCInvitation -> J.Value -> ExceptT RCErrorType IO (C.DhSecretX25519, KEMSecretKey, RCHostEncHello) prepareHostHello drg - RCCtrlPairing {caCert, storedSessKeys = StoredCtrlSessKeys {dhPrivKey, kemSharedKey}} + RCCtrlPairing {caCert, dhPrivKey} RCInvitation {v, dh = dhPubKey} hostAppInfo = do logDebug "Preparing session" @@ -333,15 +330,15 @@ prepareHostHello (kemPubKey, kemPrivKey) <- liftIO $ sntrup761Keypair drg let Fingerprint fp = getFingerprint caCert X509.HashSHA256 helloBody = RCHostHello {v = v', ca = C.KeyHash fp, app = hostAppInfo, kem = kemPubKey} - sharedKey = kemHybridOrDHSecret dhPubKey dhPrivKey kemSharedKey - encBody <- liftEitherWith (const RCEBlockSize) $ kcbEncrypt sharedKey nonce (LB.toStrict $ J.encode helloBody) helloBlockSize + sharedKey = C.dh' dhPubKey dhPrivKey + encBody <- liftEitherWith (const RCEBlockSize) $ C.cbEncrypt sharedKey nonce (LB.toStrict $ J.encode helloBody) helloBlockSize -- let sessKeys = CtrlSessKeys {hybridKey, idPubKey, sessPubKey = skey} let hostEncHello = RCHostEncHello {dhPubKey = C.publicKey dhPrivKey, nonce, encBody} pure (sharedKey, kemPrivKey, hostEncHello) -prepareCtrlSession :: RCCtrlPairing -> RCInvitation -> KEMHybridOrDHSecret -> KEMSecretKey -> RCCtrlEncHello -> ExceptT RCErrorType IO (CtrlSessKeys, RCCtrlPairing) +prepareCtrlSession :: RCCtrlPairing -> RCInvitation -> C.DhSecretX25519 -> KEMSecretKey -> RCCtrlEncHello -> ExceptT RCErrorType IO CtrlSessKeys prepareCtrlSession - pairing@RCCtrlPairing {idPubKey, storedSessKeys = ssk@StoredCtrlSessKeys {dhPrivKey}} + RCCtrlPairing {idPubKey, dhPrivKey} RCInvitation {skey, dh = dhPubKey} sharedKey kemPrivKey = \case @@ -351,11 +348,9 @@ prepareCtrlSession helloBody <- liftEitherWith (const RCEDecrypt) $ kcbDecrypt hybridKey nonce encBody logDebug "Decrypted ctrl HELLO" RCCtrlHello {} <- liftEitherWith RCESyntax $ J.eitherDecodeStrict helloBody - let sessKeys = CtrlSessKeys {hybridKey, idPubKey, sessPubKey = skey} - pairing' = (pairing :: RCCtrlPairing) {storedSessKeys = ssk {kemSharedKey = Just kemSharedKey}} - pure (sessKeys, pairing') + pure CtrlSessKeys {hybridKey, idPubKey, sessPubKey = skey} RCCtrlEncError {nonce, encMessage} -> do - message <- liftEitherWith (const RCEDecrypt) $ kcbDecrypt sharedKey nonce encMessage + message <- liftEitherWith (const RCEDecrypt) $ C.cbDecrypt sharedKey nonce encMessage throwError $ RCECtrlError $ T.unpack $ safeDecodeUtf8 message -- The application should save updated RCHostPairing after user confirmation of the session @@ -379,13 +374,13 @@ findRCCtrlPairing pairings RCEncInvitation {dhPubKey, nonce, encInvitation} = do where decrypt :: [RCCtrlPairing] -> Either RCErrorType (RCCtrlPairing, ByteString) decrypt [] = Left RCECtrlNotFound - decrypt (pairing@RCCtrlPairing {storedSessKeys, prevStoredSessKeys} : rest) = - let r = decrypt_ storedSessKeys <|> (decrypt_ =<< prevStoredSessKeys) + decrypt (pairing@RCCtrlPairing {dhPrivKey, prevDhPrivKey} : rest) = + let r = decrypt_ dhPrivKey <|> (decrypt_ =<< prevDhPrivKey) in maybe (decrypt rest) (Right . (pairing,)) r - decrypt_ :: StoredCtrlSessKeys -> Maybe ByteString - decrypt_ StoredCtrlSessKeys {dhPrivKey, kemSharedKey} = - let key = kemHybridOrDHSecret dhPubKey dhPrivKey kemSharedKey - in eitherToMaybe $ kcbDecrypt key nonce encInvitation + decrypt_ :: C.PrivateKeyX25519 -> Maybe ByteString + decrypt_ dhPrivKey = + let key = C.dh' dhPubKey dhPrivKey + in eitherToMaybe $ C.cbDecrypt key nonce encInvitation -- application should call this function when TMVar resolves confirmCtrlSession :: RCCtrlClient -> Bool -> IO () diff --git a/src/Simplex/RemoteControl/Types.hs b/src/Simplex/RemoteControl/Types.hs index 7d7db0d3b..1c83389f7 100644 --- a/src/Simplex/RemoteControl/Types.hs +++ b/src/Simplex/RemoteControl/Types.hs @@ -119,12 +119,7 @@ data RCHostPairing = RCHostPairing data KnownHostPairing = KnownHostPairing { hostFingerprint :: C.KeyHash, -- this is only changed in the first session, long-term identity of connected remote host - storedSessKeys :: StoredHostSessKeys - } - -data StoredHostSessKeys = StoredHostSessKeys - { hostDHPublicKey :: C.PublicKeyX25519, -- sent by host in HELLO block. Matches one of the DH keys in RCCtrlPairing - kemSharedKey :: KEMSharedKey + hostDhPubKey :: C.PublicKeyX25519 } -- | Long-term part of host (mobile) connection to controller (desktop) @@ -133,13 +128,8 @@ data RCCtrlPairing = RCCtrlPairing caCert :: C.SignedCertificate, ctrlFingerprint :: C.KeyHash, -- long-term identity of connected remote controller idPubKey :: C.PublicKeyEd25519, - storedSessKeys :: StoredCtrlSessKeys, - prevStoredSessKeys :: Maybe StoredCtrlSessKeys - } - -data StoredCtrlSessKeys = StoredCtrlSessKeys - { dhPrivKey :: C.PrivateKeyX25519, - kemSharedKey :: Maybe KEMSharedKey -- this is Nothing only for a new pairing, and once connected it is always Just. + dhPrivKey :: C.PrivateKeyX25519, + prevDhPrivKey :: Maybe C.PrivateKeyX25519 } data RCHostKeys = RCHostKeys diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 8f19c776e..8c37579fc 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -143,7 +143,7 @@ prevRange vr = vr {maxVersion = maxVersion vr - 1} runRight_ :: (Eq e, Show e, HasCallStack) => ExceptT e IO () -> Expectation runRight_ action = runExceptT action `shouldReturn` Right () -runRight :: HasCallStack => ExceptT AgentErrorType IO a -> IO a +runRight :: (Show e, HasCallStack) => ExceptT e IO a -> IO a runRight action = runExceptT action >>= \case Right x -> pure x diff --git a/tests/RemoteControl.hs b/tests/RemoteControl.hs index c4b49289e..cb7bec71b 100644 --- a/tests/RemoteControl.hs +++ b/tests/RemoteControl.hs @@ -4,7 +4,7 @@ module RemoteControl where -import AgentTests.FunctionalAPITests (runRight_) +import AgentTests.FunctionalAPITests (runRight) import Control.Logger.Simple import Crypto.Random (drgNew) import qualified Data.Aeson as J @@ -16,51 +16,97 @@ import UnliftIO.Concurrent remoteControlTests :: Spec remoteControlTests = do describe "New controller/host pairing" $ do - it "should connect" testNewPairing + it "should connect to new pairing" testNewPairing + it "should connect to existing pairing" testExistingPairing testNewPairing :: IO () testNewPairing = do drg <- drgNew >>= newTVarIO hp <- RC.newRCHostPairing invVar <- newEmptyMVar - ctrl <- async . runRight_ $ do + ctrlSessId <- async . runRight $ do logNote "c 1" (inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") logNote "c 2" putMVar invVar (inv, hc) logNote "c 3" - Right (_sessId, r') <- atomically $ takeTMVar r + Right (sessId, r') <- atomically $ takeTMVar r logNote "c 4" Right (_rcHostSession, _rcHelloBody, _hp') <- atomically $ takeTMVar r' logNote "c 5" - threadDelay 1000000 + threadDelay 250000 logNote "ctrl: ciao" liftIO $ RC.cancelHostClient hc + pure sessId (inv, hc) <- takeMVar invVar -- logNote $ decodeUtf8 $ strEncode inv - host <- async . runRight_ $ do + hostSessId <- async . runRight $ do logNote "h 1" (rcCtrlClient, r) <- RC.connectRCCtrlURI drg inv Nothing (J.String "app") logNote "h 2" - Right (_sessId', r') <- atomically $ takeTMVar r + Right (sessId', r') <- atomically $ takeTMVar r logNote "h 3" liftIO $ RC.confirmCtrlSession rcCtrlClient True logNote "h 4" Right (_rcCtrlSession, _rcCtrlPairing) <- atomically $ takeTMVar r' logNote "h 5" - threadDelay 1000000 + threadDelay 250000 logNote "ctrl: adios" - - timeout 10000000 (waitCatch ctrl) >>= \case - Just (Right ()) -> pure () - err -> fail $ "Unexpected controller result: " <> show err + pure sessId' waitCatch hc.action >>= \case Left err -> fromException err `shouldBe` Just AsyncCancelled Right () -> fail "Unexpected controller finish" - timeout 10000000 (waitCatch host) >>= \case - Just (Right ()) -> pure () - err -> fail $ "Unexpected host result: " <> show err + timeout 5000000 (waitBoth ctrlSessId hostSessId) >>= \case + Just (sessId, sessId') -> sessId `shouldBe` sessId' + _ -> fail "timeout" + +testExistingPairing :: IO () +testExistingPairing = do + drg <- drgNew >>= newTVarIO + invVar <- newEmptyMVar + hp <- liftIO $ RC.newRCHostPairing + ctrl <- runCtrl drg hp invVar + inv <- takeMVar invVar + let cp_ = Nothing + host <- runHost drg cp_ inv + timeout 5000000 (waitBoth ctrl host) >>= \case + Nothing -> fail "timeout" + Just (hp', cp') -> do + ctrl' <- runCtrl drg hp' invVar + inv' <- takeMVar invVar + host' <- runHost drg (Just cp') inv' + timeout 5000000 (waitBoth ctrl' host') >>= \case + Nothing -> fail "timeout" + Just (_hp2, cp2) -> do + ctrl2 <- runCtrl drg hp' invVar -- old host pairing used to test controller not updating state + inv2 <- takeMVar invVar + host2 <- runHost drg (Just cp2) inv2 + timeout 5000000 (waitBoth ctrl2 host2) >>= \case + Nothing -> fail "timeout" + Just (hp3, cp3) -> do + ctrl3 <- runCtrl drg hp3 invVar + inv3 <- takeMVar invVar + host3 <- runHost drg (Just cp3) inv3 + timeout 5000000 (waitBoth ctrl3 host3) >>= \case + Nothing -> fail "timeout" + Just _ -> pure () + where + runCtrl drg hp invVar = async . runRight $ do + (inv, hc, r) <- RC.connectRCHost drg hp (J.String "app") + putMVar invVar inv + Right (_sessId, r') <- atomically $ takeTMVar r + Right (_rcHostSession, _rcHelloBody, hp') <- atomically $ takeTMVar r' + threadDelay 250000 + liftIO $ RC.cancelHostClient hc + pure hp' + runHost drg cp_ inv = async . runRight $ do + (rcCtrlClient, r) <- RC.connectRCCtrlURI drg inv cp_ (J.String "app") + Right (_sessId', r') <- atomically $ takeTMVar r + liftIO $ RC.confirmCtrlSession rcCtrlClient True + Right (_rcCtrlSession, cp') <- atomically $ takeTMVar r' + threadDelay 250000 + pure cp'