diff options
author | 2012-09-11 12:58:00 -0400 | |
---|---|---|
committer | 2012-09-11 12:58:00 -0400 | |
commit | aace44454a8866e8dab251c2b9c98e2d48e3f071 (patch) | |
tree | fbde4f1d7012ef2e3da239c1ad59ee4f7d1bb689 | |
parent | 16d27e9c023231dcf80923d72633c80dbd91116e (diff) |
keep track of the stage we're at in pairing
This avoids us responding to our own pairing messages, as well
as ignoring any out of order messages that might be received somehow.
-rw-r--r-- | Assistant/Pairing.hs | 3 | ||||
-rw-r--r-- | Assistant/Pairing/Network.hs | 13 | ||||
-rw-r--r-- | Assistant/Threads/PairListener.hs | 25 | ||||
-rw-r--r-- | Assistant/WebApp/Configurators/Pairing.hs | 10 |
4 files changed, 29 insertions, 22 deletions
diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs index ca0cc2f39..c519dbd88 100644 --- a/Assistant/Pairing.hs +++ b/Assistant/Pairing.hs @@ -26,7 +26,7 @@ data PairStage | PairAck {- "I saw your PairAck; you can stop sending them." -} | PairDone - deriving (Eq, Read, Show) + deriving (Eq, Read, Show, Ord) newtype PairMsg = PairMsg (Verifiable (PairStage, PairData, SomeAddr)) deriving (Eq, Read, Show) @@ -66,6 +66,7 @@ data PairingInProgress = PairingInProgress , inProgressThreadId :: Maybe ThreadId , inProgressSshKeyPair :: SshKeyPair , inProgressPairData :: PairData + , inProgressPairStage :: PairStage } data SomeAddr = IPv4Addr HostAddress | IPv6Addr HostAddress6 diff --git a/Assistant/Pairing/Network.hs b/Assistant/Pairing/Network.hs index 2afbf1f56..18351321b 100644 --- a/Assistant/Pairing/Network.hs +++ b/Assistant/Pairing/Network.hs @@ -47,8 +47,8 @@ multicastAddress (IPv6Addr _) = "ff02::1" - but it allows new network interfaces to be used as they come up. - On the other hand, the expensive DNS lookups are cached. -} -multicastPairMsg :: Maybe Int -> Secret -> PairStage -> PairData -> IO () -multicastPairMsg repeats secret stage pairdata = go M.empty repeats +multicastPairMsg :: Maybe Int -> Secret -> PairData -> PairStage -> IO () +multicastPairMsg repeats secret pairdata stage = go M.empty repeats where go _ (Just 0) = noop go cache n = do @@ -73,13 +73,14 @@ multicastPairMsg repeats secret stage pairdata = go M.empty repeats mkmsg addr = PairMsg $ mkVerifiable (stage, pairdata, addr) secret -startSending :: DaemonStatusHandle -> PairingInProgress -> IO () -> IO () -startSending dstatus pip sender = do - tid <- forkIO sender - let pip' = pip { inProgressThreadId = Just tid } +startSending :: DaemonStatusHandle -> PairingInProgress -> PairStage -> (PairStage -> IO ()) -> IO () +startSending dstatus pip stage sender = void $ forkIO $ do + tid <- myThreadId + let pip' = pip { inProgressPairStage = stage, inProgressThreadId = Just tid } oldpip <- modifyDaemonStatus dstatus $ \s -> (s { pairingInProgress = Just pip' }, pairingInProgress s) maybe noop stopold oldpip + sender stage where stopold = maybe noop killThread . inProgressThreadId diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 93eef65ba..d4f8a07c8 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -40,15 +40,19 @@ pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $ sane <- checkSane msg (pip, verified) <- verificationCheck m =<< (pairingInProgress <$> getDaemonStatus dstatus) - case (sane, pairMsgStage m) of - (False, _) -> go sock cache - (_, PairReq) -> do + let wrongstage = maybe False (\p -> pairMsgStage m < inProgressPairStage p) pip + case (wrongstage, sane, pairMsgStage m) of + -- ignore our own messages, and + -- out of order messages + (True, _, _) -> go sock cache + (_, False, _) -> go sock cache + (_, _, PairReq) -> do pairReqReceived verified dstatus urlrenderer m go sock $ invalidateCache m cache - (_, PairAck) -> do + (_, _, PairAck) -> do pairAckReceived verified pip st dstatus scanremotes m cache >>= go sock - (_, PairDone) -> do + (_, _, PairDone) -> do pairDoneReceived verified pip st dstatus scanremotes m go sock cache @@ -132,14 +136,15 @@ pairReqReceived False dstatus urlrenderer msg = do {- When a verified PairAck is seen, a host is ready to pair with us, and has - already configured our ssh key. Stop sending PairReqs, finish the pairing, - - and send a single PairDone. -} + - and send a single PairDone. + -} pairAckReceived :: Bool -> Maybe PairingInProgress -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PairMsg -> [PairingInProgress] -> IO [PairingInProgress] pairAckReceived True (Just pip) st dstatus scanremotes msg cache = do stopSending dstatus pip setupAuthorizedKeys msg finishedPairing st dstatus scanremotes msg (inProgressSshKeyPair pip) - startSending dstatus pip $ multicastPairMsg - (Just 1) (inProgressSecret pip) PairDone (inProgressPairData pip) + startSending dstatus pip PairDone $ multicastPairMsg + (Just 1) (inProgressSecret pip) (inProgressPairData pip) return $ pip:(take 10 cache) {- A stale PairAck might also be seen, after we've finished pairing. - Perhaps our PairDone was not received. To handle this, we keep @@ -149,8 +154,8 @@ pairAckReceived _ _ _ dstatus _ msg cache = do let pips = filter (verifiedPairMsg msg) cache unless (null pips) $ forM_ pips $ \pip -> - startSending dstatus pip $ multicastPairMsg - (Just 1) (inProgressSecret pip) PairDone (inProgressPairData pip) + startSending dstatus pip PairDone $ multicastPairMsg + (Just 1) (inProgressSecret pip) (inProgressPairData pip) return cache {- If we get a verified PairDone, the host has accepted our PairAck, and diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index b50d32f62..20ef35c83 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -95,9 +95,9 @@ startPairing stage oncancel displaysecret secret = do <*> pure (sshPubKey keypair) <*> liftIO genUUID liftIO $ do - let sender = multicastPairMsg Nothing secret stage pairdata - let pip = PairingInProgress secret Nothing keypair pairdata - startSending dstatus pip $ sendrequests sender dstatus urlrender + let sender = multicastPairMsg Nothing secret pairdata + let pip = PairingInProgress secret Nothing keypair pairdata stage + startSending dstatus pip stage $ sendrequests sender dstatus urlrender lift $ redirect $ InprogressPairR $ toSecretReminder displaysecret where {- Sends pairing messages until the thread is killed, @@ -108,7 +108,7 @@ startPairing stage oncancel displaysecret secret = do - have been on a page specific to the in-process pairing - that just stopped, so can't go back there. -} - sendrequests sender dstatus urlrender = do + sendrequests sender dstatus urlrender _stage = do tid <- myThreadId let selfdestruct = AlertButton { buttonLabel = "Cancel" @@ -118,7 +118,7 @@ startPairing stage oncancel displaysecret secret = do killThread tid } alertDuring dstatus (pairingAlert selfdestruct) $ do - _ <- E.try sender :: IO (Either E.SomeException ()) + _ <- E.try (sender stage) :: IO (Either E.SomeException ()) return () data InputSecret = InputSecret { secretText :: Maybe Text } |