add an alert while a locally initiated pairing request is in progress

Has a button to cancel the request.

5 files changed, 65 insertions, 21 deletions

diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index 666098c6f..a2f5db4e3 100644
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@@ -32,7 +32,7 @@ data AlertName
 	= FileAlert TenseChunk
 	| SanityCheckFixAlert
 	| WarningAlert String
-	| PairRequestAlert String
+	| PairRequestReceivedAlert String
 	deriving (Eq)
 
 {- The first alert is the new alert, the second is an old alert.
@@ -148,6 +148,7 @@ makeAlertFiller success alert
 		{ alertClass = if c == Activity then c' else c
 		, alertPriority = Filler
 		, alertClosable = True
+		, alertButton = Nothing
 		, alertIcon = Just $ if success then SuccessIcon else ErrorIcon
 		}
 	where
@@ -285,8 +286,15 @@ sanityCheckFixAlert msg = Alert
 		alerthead = "The daily sanity check found and fixed a problem:"
 		alertfoot = "If these problems persist, consider filing a bug report."
 
-pairRequestAlert :: String -> String -> AlertButton -> Alert
-pairRequestAlert repo msg button = Alert
+pairRequestAlert :: AlertButton -> Alert
+pairRequestAlert button = baseActivityAlert
+	{ alertData = [ UnTensed "Pairing request in progress" ]
+	, alertPriority = High
+	, alertButton = Just button
+	}
+
+pairRequestReceivedAlert :: String -> String -> AlertButton -> Alert
+pairRequestReceivedAlert repo msg button = Alert
 	{ alertClass = Message
 	, alertHeader = Nothing
 	, alertMessageRender = tenseWords
@@ -295,7 +303,7 @@ pairRequestAlert repo msg button = Alert
 	, alertPriority = High
 	, alertClosable = True
 	, alertIcon = Just InfoIcon
-	, alertName = Just $ PairRequestAlert repo
+	, alertName = Just $ PairRequestReceivedAlert repo
 	, alertCombiner = Just $ dataCombiner $ const id
 	, alertButton = Just button
 	}
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs
index b9c7599f9..cbd606680 100644
--- a/Assistant/DaemonStatus.hs
+++ b/Assistant/DaemonStatus.hs
@@ -41,8 +41,8 @@ data DaemonStatus = DaemonStatus
 	, lastAlertId :: AlertId
 	-- Ordered list of remotes to talk to.
 	, knownRemotes :: [Remote]
-	-- Pairing requests that are in progress.
-	, pairingInProgress :: [PairingInProgress]
+	-- Pairing request that is in progress.
+	, pairingInProgress :: Maybe PairingInProgress
 	-- Broadcasts notifications about all changes to the DaemonStatus
 	, changeNotifier :: NotificationBroadcaster
 	-- Broadcasts notifications when queued or current transfers change.
@@ -66,7 +66,7 @@ newDaemonStatus = DaemonStatus
 	<*> pure M.empty
 	<*> pure firstAlertId
 	<*> pure []
-	<*> pure []
+	<*> pure Nothing
 	<*> newNotificationBroadcaster
 	<*> newNotificationBroadcaster
 	<*> newNotificationBroadcaster
@@ -260,3 +260,10 @@ alertWhile' dstatus alert a = do
 	(ok, r) <- a
 	updateAlertMap dstatus $ mergeAlert i $ makeAlertFiller ok alert'
 	return r
+
+{- Displays an alert while performing an activity, then removes it. -}
+alertDuring :: DaemonStatusHandle -> Alert -> IO a -> IO a
+alertDuring dstatus alert a = do
+	let alert' = alert { alertClass = Activity }
+	i <- addAlert dstatus alert'
+	removeAlert dstatus i `after` a
diff --git a/Assistant/Pairing/Network.hs b/Assistant/Pairing/Network.hs
index ec7054f9e..2b645a9d9 100644
--- a/Assistant/Pairing/Network.hs
+++ b/Assistant/Pairing/Network.hs
@@ -14,7 +14,6 @@ import Utility.ThreadScheduler
 import Network.Multicast
 import Network.Info
 import Network.Socket
-import Control.Concurrent
 import Control.Exception (bracket)
 import qualified Data.Map as M
 
@@ -31,8 +30,8 @@ multicastAddress :: SomeAddr -> HostName
 multicastAddress (IPv4Addr _) = "224.0.0.1"
 multicastAddress (IPv6Addr _) = "ff02::1"
 
-{- Multicasts a message repeatedly on all interfaces until its thread
- - is killed, with a 2 second delay between each transmission.
+{- Multicasts a message repeatedly on all interfaces forever,
+ - with a 2 second delay between each transmission.
  -
  - The remoteHostAddress is set to the interface's IP address.
  -
@@ -40,8 +39,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 :: (SomeAddr -> PairMsg) -> IO ThreadId
-multicastPairMsg mkmsg = forkIO $ go M.empty
+multicastPairMsg :: (SomeAddr -> PairMsg) -> IO ()
+multicastPairMsg mkmsg = go M.empty
 	where
 		go cache = do
 			addrs <- activeNetworkAddresses
diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs
index 3dc1a331f..e7104dc28 100644
--- a/Assistant/Threads/PairListener.hs
+++ b/Assistant/Threads/PairListener.hs
@@ -56,7 +56,7 @@ pairListenerThread st dstatus urlrenderer = thread $ withSocketsDo $ do
 pairReqAlert :: DaemonStatusHandle -> UrlRenderer -> PairMsg -> IO ()
 pairReqAlert dstatus urlrenderer msg = unlessM myreq $ do
 	url <- renderUrl urlrenderer (FinishPairR msg) []
-	void $ addAlert dstatus $ pairRequestAlert repo
+	void $ addAlert dstatus $ pairRequestReceivedAlert repo
 		(repo ++ " is sending a pair request.") $
 		AlertButton
 			{ buttonUrl = url
@@ -74,16 +74,18 @@ pairReqAlert dstatus urlrenderer msg = unlessM myreq $ do
 			, ":"
 			, (remoteDirectory pairdata)
 			]
-		{- Filter out our own pair requests, by checking if we
-		 - can verify using the secrets of any of them. -}
-		myreq = any (verified v . inProgressSecret) . pairingInProgress
-			<$> getDaemonStatus dstatus
+		{- Filter out our own pair request, by checking if we
+		 - can verify using its secret. -}
+		myreq = maybe False (verified v . inProgressSecret)
+			. pairingInProgress
+				<$> getDaemonStatus dstatus
 		{- 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"]
 			}
diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs
index 54a791639..d4301473f 100644
--- a/Assistant/WebApp/Configurators/Pairing.hs
+++ b/Assistant/WebApp/Configurators/Pairing.hs
@@ -32,6 +32,7 @@ import Assistant.Pairing
 #ifdef WITH_PAIRING
 import Assistant.Pairing.Network
 import Assistant.Common
+import Assistant.Alert
 import Assistant.DaemonStatus
 import Utility.Verifiable
 import Utility.Network
@@ -49,22 +50,49 @@ import qualified Data.Text.Encoding as T
 import qualified Data.ByteString.Lazy as B
 import Data.Char
 import System.Posix.User
+import qualified Control.Exception as E
+import Control.Concurrent
 #endif
 
 getStartPairR :: Handler RepHtml
 #ifdef WITH_PAIRING
 getStartPairR = promptSecret Nothing $ \rawsecret secret -> do
+	dstatus <- daemonStatus <$> lift getYesod
+	urlrender <- lift getUrlRender
+	let homeurl = urlrender HomeR
 	hostname <- liftIO $ getHostname
 	username <- liftIO $ getUserName
 	reldir <- fromJust . relDir <$> lift getYesod
 	let sshkey = "" -- TODO generate/read ssh key
 	let mkmsg addr = PairMsg $ mkVerifiable
 		(PairReq, PairData hostname addr username reldir sshkey) secret
-	pip <- liftIO $ PairingInProgress secret <$> multicastPairMsg mkmsg
-	dstatus <- daemonStatus <$> lift getYesod
-	liftIO $ modifyDaemonStatus_ dstatus $
-		\s -> s { pairingInProgress = pip : pairingInProgress s }
+	liftIO $ do
+		pip <- PairingInProgress secret
+			<$> sendrequests mkmsg dstatus homeurl
+		oldpip <- modifyDaemonStatus dstatus $
+			\s -> (s { pairingInProgress = Just pip }, pairingInProgress s)
+		maybe noop stopold oldpip
 	lift $ redirect $ InprogressPairR rawsecret
+	where
+		{- Sends pairing messages until the thread is killed,
+		 - and shows an activity alert while doing it.
+		 -
+		 - The button returns the user to the HomeR. This is
+		 - not ideal, but they have to be sent somewhere, and could
+		 - have been on a page specific to the in-process pairing
+		 - that just stopped.
+		 -}
+		sendrequests mkmsg dstatus homeurl = forkIO $ do
+			tid <- myThreadId
+			let selfdestruct = AlertButton
+				{ buttonLabel = "Cancel"
+				, buttonUrl = homeurl
+				, buttonAction = Just $ const $ killThread tid
+				}
+			alertDuring dstatus (pairRequestAlert selfdestruct) $ do
+				_ <- E.try (multicastPairMsg mkmsg) :: IO (Either E.SomeException ())
+				return ()
+		stopold = killThread  . inProgressThreadId
 #else
 getStartPairR = noPairing
 #endif