pairing works!!

Finally.

Last bug fixes here: Send PairResp with same UUID in the PairReq.
Fix off-by-one in code that filters out our own pairing messages.

Also reworked the pairing alerts, which are still slightly buggy.

Assistant/Alert.hs

@@ -32,7 +32,7 @@ data AlertName
 	= FileAlert TenseChunk
 	| SanityCheckFixAlert
 	| WarningAlert String
-	| PairRequestReceivedAlert String
+	| PairAlert String
 	deriving (Eq)
 
 {- The first alert is the new alert, the second is an old alert.
@@ -293,18 +293,27 @@ pairingAlert button = baseActivityAlert
 	, alertButton = Just button
 	}
 
-pairRequestReceivedAlert :: String -> String -> AlertButton -> Alert
-pairRequestReceivedAlert repo msg button = Alert
+pairRequestReceivedAlert :: String -> AlertButton -> Alert
+pairRequestReceivedAlert repo button = Alert
 	{ alertClass = Message
 	, alertHeader = Nothing
 	, alertMessageRender = tenseWords
-	, alertData = [UnTensed $ T.pack msg]
+	, alertData = [UnTensed $ T.pack $ repo ++ " is sending a pair request."]
 	, alertBlockDisplay = False
 	, alertPriority = High
 	, alertClosable = True
 	, alertIcon = Just InfoIcon
-	, alertName = Just $ PairRequestReceivedAlert repo
-	, alertCombiner = Just $ dataCombiner $ const id
+	, alertName = Just $ PairAlert repo
+	, alertCombiner = Just $ dataCombiner $ \_old new -> new
+	, alertButton = Just button
+	}
+
+pairRequestAcknowledgedAlert :: String -> AlertButton -> Alert
+pairRequestAcknowledgedAlert repo button = baseActivityAlert
+	{ alertData = ["Pair request with", UnTensed (T.pack repo), Tensed "in progress" "complete"]
+	, alertPriority = High
+	, alertName = Just $ PairAlert repo
+	, alertCombiner = Just $ dataCombiner $ \_old new -> new
 	, alertButton = Just button
 	}
 

Assistant/Pairing.hs

@@ -68,6 +68,7 @@ data PairingInProgress = PairingInProgress
 	, inProgressPairData :: PairData
 	, inProgressPairStage :: PairStage
 	}
+	deriving (Show)
 
 data SomeAddr = IPv4Addr HostAddress | IPv6Addr HostAddress6
 	deriving (Ord, Eq, Read, Show)

Assistant/Pairing/Network.hs

@@ -58,14 +58,14 @@ multicastPairMsg repeats secret pairdata stage = go M.empty repeats
 			threadDelaySeconds (Seconds 2)
 			go cache' $ pred <$> n
 		sendinterface cache i = void $ catchMaybeIO $
-			withSocketsDo $ bracket
-				(multicastSender (multicastAddress i) pairingPort)
-				(sClose . fst)
-				(\(sock, addr) -> do
+			withSocketsDo $ bracket setup cleanup use
+			where
+				setup = multicastSender (multicastAddress i) pairingPort
+				cleanup (sock, _) = sClose sock -- FIXME does not work
+				use (sock, addr) = do
 					setInterface sock (showAddr i)
 					maybe noop (\s -> void $ sendTo sock s addr)
 						(M.lookup i cache)
-				)
 		updatecache cache [] = cache
 		updatecache cache (i:is)
 			| M.member i cache = updatecache cache is
@@ -106,3 +106,19 @@ activeNetworkAddresses :: IO [SomeAddr]
 activeNetworkAddresses = filter (not . all (`elem` "0.:") . showAddr)
 	. concat . map (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni])
 	<$> getNetworkInterfaces
+
+{- A human-visible description of the repository being paired with.
+ - Note that the repository's description is not shown to the user, because
+ - it could be something like "my repo", which is confusing when pairing
+ - with someone else's repo. However, this has the same format as the
+ - default decription of a repo. -}
+pairRepo :: PairMsg -> String
+pairRepo msg = concat
+	[ remoteUserName d
+	, "@"
+	, fromMaybe (showAddr $ pairMsgAddr msg) (remoteHostName d)
+	, ":"
+	, remoteDirectory d
+	]
+	where
+		d = pairMsgData msg

Assistant/Ssh.hs

@@ -32,6 +32,9 @@ data SshKeyPair = SshKeyPair
 	, sshPrivKey :: String
 	}
 
+instance Show SshKeyPair where
+	show = sshPubKey
+
 type SshPubKey = String
 
 {- ssh -ofoo=bar command-line option -}

Assistant/Threads/PairListener.hs

@@ -17,7 +17,6 @@ import Assistant.DaemonStatus
 import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.Alert
-import Utility.Tense
 
 import Network.Multicast
 import Network.Socket
@@ -40,7 +39,7 @@ pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $
 				sane <- checkSane msg
 				(pip, verified) <- verificationCheck m
 					=<< (pairingInProgress <$> getDaemonStatus dstatus)
-				let wrongstage = maybe False (\p -> pairMsgStage m < inProgressPairStage p) pip
+				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
@@ -107,32 +106,13 @@ pairReqReceived True _ _ _ = noop -- ignore our own PairReq
 pairReqReceived False dstatus urlrenderer msg = do
 	url <- renderUrl urlrenderer (FinishPairR msg) []
 	void $ addAlert dstatus $ pairRequestReceivedAlert repo
-		(repo ++ " is sending a pair request.") $
 		AlertButton
 			{ buttonUrl = url
 			, buttonLabel = T.pack "Respond"
-			, buttonAction = Just onclick
+			, buttonAction = Nothing
 			}
 	where
-		pairdata = pairMsgData msg
-		repo = concat
-			[ remoteUserName pairdata
-			, "@"
-			, fromMaybe (showAddr $ pairMsgAddr msg)
-				(remoteHostName pairdata)
-			, ":"
-			, (remoteDirectory pairdata)
-			]
-		{- Remove the button when it's clicked, and change the
-		 - alert to be in progress. This alert cannot be entirely
-		 - removed since more pair request messages are coming in
-		 - and would re-add it. -}
-		onclick i = updateAlert dstatus i $ \alert -> Just $ alert
-			{ alertButton = Nothing
-			, alertClass = Activity
-			, alertIcon = Just ActivityIcon
-			, alertData = [UnTensed $ T.pack $ "pair request with " ++ repo ++ " in progress"]
-			}
+		repo = pairRepo msg
 
 {- 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,

Assistant/WebApp/Configurators/Pairing.hs

@@ -42,7 +42,7 @@ import Control.Concurrent
 {- Starts sending out pair requests. -}
 getStartPairR :: Handler RepHtml
 #ifdef WITH_PAIRING
-getStartPairR = promptSecret Nothing $ startPairing PairReq noop
+getStartPairR = promptSecret Nothing $ startPairing PairReq noop pairingAlert Nothing
 #else
 getStartPairR = noPairing
 #endif
@@ -54,11 +54,13 @@ getFinishPairR :: PairMsg -> Handler RepHtml
 #ifdef WITH_PAIRING
 getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do
 	liftIO $ setup
-	startPairing PairAck cleanup "" secret
+	startPairing PairAck cleanup alert uuid "" secret
 	where
+		alert = pairRequestAcknowledgedAlert $ pairRepo msg
 		setup  = setupAuthorizedKeys msg
 		cleanup = removeAuthorizedKeys False $
 			remoteSshPubKey $ pairMsgData msg
+		uuid = Just $ pairUUID $ pairMsgData msg
 #else
 getFinishPairR _ = noPairing
 #endif
@@ -83,8 +85,8 @@ getInprogressPairR _ = noPairing
  -
  - Redirects to the pairing in progress page.
  -}
-startPairing :: PairStage -> IO () -> Text -> Secret -> Widget
-startPairing stage oncancel displaysecret secret = do
+startPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget
+startPairing stage oncancel alert muuid displaysecret secret = do
 	keypair <- liftIO $ genSshKeyPair
 	dstatus <- daemonStatus <$> lift getYesod
 	urlrender <- lift getUrlRender
@@ -93,7 +95,7 @@ startPairing stage oncancel displaysecret secret = do
 		<*> liftIO getUserName
 		<*> (fromJust . relDir <$> lift getYesod)
 		<*> pure (sshPubKey keypair)
-		<*> liftIO genUUID
+		<*> liftIO (maybe genUUID return muuid)
 	liftIO $ do
 		let sender = multicastPairMsg Nothing secret pairdata
 		let pip = PairingInProgress secret Nothing keypair pairdata stage
@@ -117,7 +119,7 @@ startPairing stage oncancel displaysecret secret = do
 					oncancel
 					killThread tid
 				}
-			alertDuring dstatus (pairingAlert selfdestruct) $ do
+			alertDuring dstatus (alert selfdestruct) $ do
 				_ <- E.try (sender stage) :: IO (Either E.SomeException ())
 				return ()