update pair request alert when button is pressed

7 files changed, 54 insertions, 18 deletions

diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index 57674e2f3..f67de2402 100644
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@@ -53,9 +53,13 @@ data Alert = Alert
 	, alertButton :: Maybe AlertButton
 	}
 
+{- When clicked, a button always redirects to a URL
+ - It may also run an IO action in the background, which is useful
+ - to make the button close or otherwise change the alert. -}
 data AlertButton = AlertButton
-	{ buttonUrl :: Text
-	, buttonLabel :: Text
+	{ buttonLabel :: Text
+	, buttonUrl :: Text
+	, buttonAction :: Maybe (AlertId -> IO ())
 	}
 
 type AlertPair = (AlertId, Alert)
diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs
index d2f572d54..b19ce3aa4 100644
--- a/Assistant/Threads/PairListener.hs
+++ b/Assistant/Threads/PairListener.hs
@@ -16,6 +16,7 @@ import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.Alert
 import Utility.Verifiable
+import Utility.Tense
 
 import Network.Multicast
 import Network.Socket
@@ -54,24 +55,38 @@ pairListenerThread st dstatus urlrenderer = thread $ withSocketsDo $ do
  - so repeated requests do not add additional alerts. -}
 pairReqAlert :: DaemonStatusHandle -> UrlRenderer -> PairMsg -> IO ()
 pairReqAlert dstatus urlrenderer msg = unlessM myreq $ do
-	let (_, pairdata) = verifiableVal v
-	let repo = remoteUserName pairdata ++ "@" ++
-		fromMaybe (showAddr $ remoteAddress pairdata)
-			(remoteHostName pairdata) ++
-			(remoteDirectory pairdata)
 	url <- renderUrl urlrenderer (FinishPairR msg) []
 	void $ addAlert dstatus $ pairRequestAlert repo
 		(repo ++ " is sending a pair request.") $
 		AlertButton
 			{ buttonUrl = url
 			, buttonLabel = T.pack "Respond"
+			, buttonAction = Just onclick
 			}
 	where
 		v = fromPairMsg msg
+		(_, pairdata) = verifiableVal v
+		repo = concat
+			[ remoteUserName pairdata
+			, "@"
+			, fromMaybe (showAddr $ remoteAddress pairdata)
+				(remoteHostName pairdata)
+			, ":"
+			, (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
+		{- Remove the button when it's clicked, and convert the
+		 - alert to filler. It 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
+			, alertPriority = Filler
+			, alertData = [UnTensed $ T.pack $ "pair request with " ++ repo ++ " in progress"]
+			}
 
 {- When a valid PairAck is seen, a host has successfully paired with
  - us, and we should finish pairing with them. Then send a PairDone.
diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs
index 51972a98c..64dcd48e3 100644
--- a/Assistant/WebApp.hs
+++ b/Assistant/WebApp.hs
@@ -132,3 +132,10 @@ renderUrl :: UrlRenderer -> Route WebApp -> [(Text, Text)] -> IO Text
 renderUrl urlrenderer route params = do
 	r <- readMVar urlrenderer
 	return $ r route params
+
+{- Redirects back to the referring page, or if there's none, HomeR -}
+redirectBack :: Handler ()
+redirectBack = do
+	clearUltDest
+	setUltDestReferer
+	redirectUltDest HomeR
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
index 992e6ba26..b4e46bd68 100644
--- a/Assistant/WebApp/DashBoard.hs
+++ b/Assistant/WebApp/DashBoard.hs
@@ -116,12 +116,6 @@ postFileBrowserR = void openFileBrowser
 getFileBrowserR :: Handler ()
 getFileBrowserR = whenM openFileBrowser $ redirectBack
 
-redirectBack :: Handler ()
-redirectBack = do
-	clearUltDest
-	setUltDestReferer
-	redirectUltDest HomeR
-
 {- Opens the system file browser on the repo, or, as a fallback,
  - goes to a file:// url. Returns True if it's ok to redirect away
  - from the page (ie, the system file browser was opened). 
diff --git a/Assistant/WebApp/SideBar.hs b/Assistant/WebApp/SideBar.hs
index fd1f70038..2a0073319 100644
--- a/Assistant/WebApp/SideBar.hs
+++ b/Assistant/WebApp/SideBar.hs
@@ -76,4 +76,19 @@ getSideBarR nid = do
 getCloseAlert :: AlertId -> Handler ()
 getCloseAlert i = do
 	webapp <- getYesod
-	void $ liftIO $ removeAlert (daemonStatus webapp) i
+	liftIO $ removeAlert (daemonStatus webapp) i
+
+{- When an alert with a button is clicked on, the button takes us here. -}
+getClickAlert :: AlertId -> Handler ()
+getClickAlert i = do
+	webapp <- getYesod
+	m <- alertMap <$> liftIO (getDaemonStatus $ daemonStatus webapp)
+	case M.lookup i m of
+		Just (Alert { alertButton = Just b }) -> do
+			{- Spawn a thread to run the action while redirecting. -}
+			case buttonAction b of
+				Nothing -> noop
+				Just a -> liftIO $ void $ forkIO $ a i
+			redirect $ buttonUrl b
+		_ -> redirectBack
+
diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes
index a266704b2..7c038389c 100644
--- a/Assistant/WebApp/routes
+++ b/Assistant/WebApp/routes
@@ -21,7 +21,8 @@
 /sidebar/#NotificationId SideBarR GET
 /notifier/transfers NotifierTransfersR GET
 /notifier/sidebar NotifierSideBarR GET
-/closealert/#AlertId CloseAlert GET
+/alert/close/#AlertId CloseAlert GET
+/alert/click/#AlertId ClickAlert GET
 /filebrowser FileBrowserR GET POST
 
 /transfer/pause/#Transfer PauseTransferR GET POST
diff --git a/templates/sidebar/alert.hamlet b/templates/sidebar/alert.hamlet
index a873d171f..73e7e7ded 100644
--- a/templates/sidebar/alert.hamlet
+++ b/templates/sidebar/alert.hamlet
@@ -1,6 +1,6 @@
-<div .alert .fade .in .#{divclass} :block:.alert-block ##{alertid} :closable:onclick="(function( $ ) { $.get('@{CloseAlert aid}') })( jQuery );">
+<div .alert .fade .in .#{divclass} :block:.alert-block ##{alertid}>
   $if closable
-    <a .close>&times;</a>
+    <a .close onclick="(function( $ ) { $.get('@{CloseAlert aid}') })( jQuery );">&times;</a>
   $maybe h <- renderAlertHeader alert
     $if block
       <h4 .alert-heading>
@@ -20,5 +20,5 @@
     $of Nothing
     $of Just button
       <br>
-      <a .btn .btn-primary href="#{buttonUrl button}">
+      <a .btn .btn-primary href="@{ClickAlert aid}">
         #{buttonLabel button}