Improve local pairing behavior when two computers both try to start the pairing process separately.

I was able to reproduce something very like this bug by starting
pairing separately on both computers under poor network conditions (ie,
weak wifi on my front porch). Neither computer showed an alert for the
PairReq messages it was seeing (intermittently) from the other.

So, I've made a new PairReq message that has not been seen before
always make the alert pop up, even if the assistant thinks it is
in the middle of its own pairing process (or even another pairing
process with a different box on the LAN).

(This shouldn't cause a rogue PairAck to disrupt a pairing process part
way through.)

2 files changed, 21 insertions, 9 deletions

diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs
index 4736c4396..bb1384a15 100644
--- a/Assistant/Pairing.hs
+++ b/Assistant/Pairing.hs
@@ -28,7 +28,7 @@ data PairStage
 	| PairAck
 	{- "I saw your PairAck; you can stop sending them." -}
 	| PairDone
-	deriving (Eq, Read, Show, Ord)
+	deriving (Eq, Read, Show, Ord, Enum)
 
 newtype PairMsg = PairMsg (Verifiable (PairStage, PairData, SomeAddr))
 	deriving (Eq, Read, Show)
diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs
index 0d3be4660..cd95ab5a4 100644
--- a/Assistant/Threads/PairListener.hs
+++ b/Assistant/Threads/PairListener.hs
@@ -43,20 +43,32 @@ pairListenerThread urlrenderer = namedThread "PairListener" $ do
 			(pip, verified) <- verificationCheck m
 				=<< (pairingInProgress <$> getDaemonStatus)
 			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
-				(_, False, _) -> go reqs cache sock
-				(True, _, _) -> go reqs cache sock
-				(_, _, PairReq) -> if m `elem` reqs
+			let fromus = maybe False (\p -> remoteSshPubKey (pairMsgData m) == remoteSshPubKey (inProgressPairData p)) pip
+			case (wrongstage, fromus, sane, pairMsgStage m) of
+				(_, True, _, _) -> do
+					debug ["ignoring message that looped back"]
+					go reqs cache sock
+				(_, _, False, _) -> go reqs cache sock
+				-- PairReq starts a pairing process, so a
+				-- new one is always heeded, even if
+				-- some other pairing is in process.
+				(_, _, _, PairReq) -> if m `elem` reqs
 					then go reqs (invalidateCache m cache) sock
 					else do
 						pairReqReceived verified urlrenderer m
 						go (m:take 10 reqs) (invalidateCache m cache) sock
-				(_, _, PairAck) -> do
+				(True, _, _, _) -> do
+					debug
+						["ignoring out of order message"
+						, show (pairMsgStage m)
+						, "expected"
+						, show (succ . inProgressPairStage <$> pip)
+						]
+					go reqs cache sock
+				(_, _, _, PairAck) -> do
 					cache' <- pairAckReceived verified pip m cache
 					go reqs cache' sock
-				(_, _, PairDone) -> do
+				(_,_ , _, PairDone) -> do
 					pairDoneReceived verified pip m
 					go reqs cache sock