add a UUID to pair requests

Pair requests the the same UUID are part of the same pairing session,
which allows us to detect attempts to brute force the shared secret,
as that will result in pair requests with the same UUID that are
not verified with the right secret.

3 files changed, 26 insertions, 7 deletions

diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs
index 8031a7213..de69d8410 100644
--- a/Assistant/Pairing.hs
+++ b/Assistant/Pairing.hs
@@ -7,6 +7,7 @@
 
 module Assistant.Pairing where
 
+import Common.Annex
 import Utility.Verifiable
 import Assistant.Ssh
 
@@ -49,6 +50,7 @@ data PairData = PairData
 	, remoteUserName :: UserName
 	, remoteDirectory :: FilePath
 	, remoteSshPubKey :: SshPubKey
+	, pairUUID :: UUID
 	}
 	deriving (Eq, Read, Show)
 
diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs
index 7ba673ec2..09fd9513d 100644
--- a/Assistant/Threads/PairListener.hs
+++ b/Assistant/Threads/PairListener.hs
@@ -36,8 +36,8 @@ pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $
 		go sock cache = getmsg sock [] >>= \msg -> case readish msg of
 			Nothing -> go sock cache
 			Just m -> do
-				pip <- pairingInProgress <$> getDaemonStatus dstatus
-				let verified = maybe False (verifiedPairMsg m) pip
+				(pip, verified) <- verificationCheck m
+					=<< (pairingInProgress <$> getDaemonStatus dstatus)
 				case pairMsgStage m of
 					PairReq -> do
 						pairReqReceived verified dstatus urlrenderer m
@@ -49,6 +49,23 @@ pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $
 						pairDoneReceived verified pip st dstatus scanremotes m
 						go sock	cache
 
+		{- As well as verifying the message using the shared secret,
+		 - check its UUID against the UUID we have stored. If
+		 - they're the same, someone is sending bogus messages,
+		 - which could be an attempt to brute force the shared
+		 - secret. -}
+		verificationCheck m (Just pip) = do
+			let verified = verifiedPairMsg m pip
+			let sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData $ m)
+			if (not verified && sameuuid)
+				then do
+					runThreadState st $
+						warning "detected possible pairing brute force attempt; disabled pairing"
+					stopSending dstatus pip
+					return (Nothing, False)
+				else return (Just pip, verified && sameuuid)
+		verificationCheck _ Nothing = return (Nothing, False)
+
 		{- PairReqs invalidate the cache of recently finished pairings.
 		 - This is so that, if a new pairing is started with the
 		 - same secret used before, a bogus PairDone is not sent. -}
@@ -125,12 +142,10 @@ pairAckReceived _ _ _ dstatus _ msg cache = do
 {- If we get a verified PairDone, the host has accepted our PairAck, and
  - has paired with us. Stop sending PairAcks, and finish pairing with them.
  -
- - If we get an unverified PairDone that matches the PairReq 
  - TODO: Should third-party hosts remove their pair request alert when they
- - see a PairDone? How to tell if a PairDone matches with the PairReq 
- - that brought up the alert? Cannot verify it without the secret..
- - Also, the user could have already clicked on the alert and be entering
- - the secret. Would be better to start a fresh pair request in this
+ - see a PairDone? 
+ - Complication: The user could have already clicked on the alert and be
+ - entering the secret. Would be better to start a fresh pair request in this
  - situation.
  -}
 pairDoneReceived :: Bool -> Maybe PairingInProgress -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PairMsg -> IO ()
diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs
index dab5bf4f8..be79d574d 100644
--- a/Assistant/WebApp/Configurators/Pairing.hs
+++ b/Assistant/WebApp/Configurators/Pairing.hs
@@ -24,6 +24,7 @@ import Assistant.Alert
 import Assistant.DaemonStatus
 import Utility.Verifiable
 import Utility.Network
+import Annex.UUID
 #endif
 
 import Yesod
@@ -91,6 +92,7 @@ startPairing stage oncancel displaysecret secret = do
 		<*> liftIO getUserName
 		<*> (fromJust . relDir <$> lift getYesod)
 		<*> pure (sshPubKey keypair)
+		<*> liftIO genUUID
 	liftIO $ do
 		let sender = multicastPairMsg Nothing secret stage pairdata
 		let pip = PairingInProgress secret Nothing keypair pairdata