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.

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 }