first pass at alert buttons

They work fine. But I had to go to a lot of trouble to get Yesod to render
routes in a pure function. It may instead make more sense to have each
alert have an assocated IO action, and a single route that runs the IO
action of a given alert id. I just wish I'd realized that before the past
several hours of struggling with something Yesod really doesn't want to
allow.

2 files changed, 38 insertions, 17 deletions

diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs
index 12f10070c..45496ddf2 100644
--- a/Assistant/Threads/PairListener.hs
+++ b/Assistant/Threads/PairListener.hs
@@ -12,17 +12,20 @@ import Assistant.Pairing
 import Assistant.Pairing.Network
 import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
+import Assistant.WebApp
+import Assistant.WebApp.Types
 import Assistant.Alert
 import Utility.Verifiable
 
 import Network.Multicast
 import Network.Socket
+import qualified Data.Text as T
 
 thisThread :: ThreadName
 thisThread = "PairListener"
 
-pairListenerThread :: ThreadState -> DaemonStatusHandle -> NamedThread
-pairListenerThread st dstatus = thread $ withSocketsDo $ do
+pairListenerThread :: ThreadState -> DaemonStatusHandle -> UrlRenderer -> NamedThread
+pairListenerThread st dstatus urlrenderer = thread $ withSocketsDo $ do
 	sock <- multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort
 	forever $ do
 		msg <- getmsg sock []
@@ -39,19 +42,34 @@ pairListenerThread st dstatus = thread $ withSocketsDo $ do
 				chunksz = 1024
 
 		dispatch Nothing = noop
-		dispatch (Just (PairReqM (PairReq v))) = unlessM (mypair v) $ do
-			let pairdata = verifiableVal v
-			let repo = remoteUserName pairdata ++ "@" ++
-				fromMaybe (showAddr $ remoteAddress pairdata)
-					(remoteHostName pairdata) ++
-					(remoteDirectory pairdata)
-			let msg = repo ++ " is sending a pair request."
-			{- Pair request alerts from the same host combine,
-			 - so repeated requests do not add additional alerts. -}
-			void $ addAlert dstatus $ pairRequestAlert repo msg
-		dispatch (Just (PairAckM _)) = noop -- TODO
+		dispatch (Just (PairReqM r@(PairReq v))) =
+			unlessM (mypair v) $
+				pairReqAlert dstatus urlrenderer r
+		dispatch (Just (PairAckM r@(PairAck v))) =
+			unlessM (mypair v) $
+				pairAckAlert dstatus r
 
 		{- Filter out our own pair requests, by checking if we
 		 - can verify using the secrets of any of them. -}
 		mypair v = any (verified v . inProgressSecret) . pairingInProgress
 			<$> getDaemonStatus dstatus
+
+{- Pair request alerts from the same host combine,
+ - so repeated requests do not add additional alerts. -}
+pairReqAlert :: DaemonStatusHandle -> UrlRenderer -> PairReq -> IO ()
+pairReqAlert dstatus urlrenderer r@(PairReq v) = do
+	let pairdata = verifiableVal v
+	let repo = remoteUserName pairdata ++ "@" ++
+		fromMaybe (showAddr $ remoteAddress pairdata)
+			(remoteHostName pairdata) ++
+			(remoteDirectory pairdata)
+	let msg = repo ++ " is sending a pair request."
+	url <- renderUrl urlrenderer (FinishPairR r) []
+	void $ addAlert dstatus $ pairRequestAlert repo msg $
+		AlertButton
+			{ buttonUrl = url
+			, buttonLabel = T.pack "Respond"
+			}
+
+pairAckAlert :: DaemonStatusHandle -> PairAck -> IO ()
+pairAckAlert dstatus r@(PairAck v) = error "TODO"
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 54627f38e..d7d5c2602 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -49,10 +49,11 @@ webAppThread
 	-> ScanRemoteMap
 	-> TransferQueue
 	-> TransferSlots
+	-> UrlRenderer
 	-> Maybe (IO String)
 	-> Maybe (Url -> FilePath -> IO ())
 	-> NamedThread
-webAppThread mst dstatus scanremotes transferqueue transferslots postfirstrun onstartup = thread $ do
+webAppThread mst dstatus scanremotes transferqueue transferslots urlrenderer postfirstrun onstartup = thread $ do
 	webapp <- WebApp
 		<$> pure mst
 		<*> pure dstatus
@@ -64,14 +65,16 @@ webAppThread mst dstatus scanremotes transferqueue transferslots postfirstrun on
 		<*> pure $(embed "static")
 		<*> newWebAppState
 		<*> pure postfirstrun
+	setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
 	app <- toWaiAppPlain webapp
 	app' <- ifM debugEnabled
 		( return $ httpDebugLogger app
 		, return app
 		)
-	runWebApp app' $ \port -> case mst of
-		Nothing -> withTempFile "webapp.html" $ \tmpfile _ -> go port webapp tmpfile
-		Just st -> go port webapp =<< runThreadState st (fromRepo gitAnnexHtmlShim)
+	runWebApp app' $ \port -> do
+		case mst of
+			Nothing -> withTempFile "webapp.html" $ \tmpfile _ -> go port webapp tmpfile
+			Just st -> go port webapp =<< runThreadState st (fromRepo gitAnnexHtmlShim)
 	where
 		thread = NamedThread thisThread
 		getreldir Nothing = return Nothing