mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-08-07 01:50:33 +00:00
do not use previous KEM shared secret in multicast packets and in host HELLO (#888)
* do not use previous KEM shared secret in multicast packets and in host HELLO * simplify
This commit is contained in:
Evgeny Poberezkin
@@ -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))
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 ()
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
+61
-15
@@ -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'
|
||||
|
||||
Reference in New Issue
Block a user