diff options
| -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 } |