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.

6 files changed, 77 insertions, 33 deletions

diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index cb2366f44..57674e2f3 100644
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@@ -15,6 +15,7 @@ import Utility.Tense
 import Logs.Transfer
 
 import qualified Data.Text as T
+import Data.Text (Text)
 import qualified Data.Map as M
 import Data.String
 
@@ -49,6 +50,12 @@ data Alert = Alert
 	, alertIcon :: Maybe String
 	, alertCombiner :: Maybe AlertCombiner
 	, alertName :: Maybe AlertName
+	, alertButton :: Maybe AlertButton
+	}
+
+data AlertButton = AlertButton
+	{ buttonUrl :: Text
+	, buttonLabel :: Text
 	}
 
 type AlertPair = (AlertId, Alert)
@@ -98,11 +105,11 @@ sortAlertPairs :: [AlertPair] -> [AlertPair]
 sortAlertPairs = sortBy compareAlertPairs
 
 {- Renders an alert's header for display, if it has one. -}
-renderAlertHeader :: Alert -> Maybe T.Text
+renderAlertHeader :: Alert -> Maybe Text
 renderAlertHeader alert = renderTense (alertTense alert) <$> alertHeader alert
 
 {- Renders an alert's message for display. -}
-renderAlertMessage :: Alert -> T.Text
+renderAlertMessage :: Alert -> Text
 renderAlertMessage alert = renderTense (alertTense alert) $
 	(alertMessageRender alert) (alertData alert)
 
@@ -182,6 +189,7 @@ baseActivityAlert = Alert
 	, alertIcon = Just "refresh"
 	, alertCombiner = Nothing
 	, alertName = Nothing
+	, alertButton = Nothing
 	}
 
 warningAlert :: String -> String -> Alert
@@ -196,6 +204,7 @@ warningAlert name msg = Alert
 	, alertIcon = Just "exclamation-sign"
 	, alertCombiner = Just $ dataCombiner (++)
 	, alertName = Just $ WarningAlert name
+	, alertButton = Nothing
 	}
 
 activityAlert :: Maybe TenseText -> [TenseChunk] -> Alert
@@ -257,14 +266,15 @@ sanityCheckFixAlert msg = Alert
 	, alertIcon = Just "exclamation-sign"
 	, alertName = Just SanityCheckFixAlert
 	, alertCombiner = Just $ dataCombiner (++)
+	, alertButton = Nothing
 	}
 	where
 		render dta = tenseWords $ alerthead : dta ++ [alertfoot]
 		alerthead = "The daily sanity check found and fixed a problem:"
 		alertfoot = "If these problems persist, consider filing a bug report."
 
-pairRequestAlert :: String -> String -> Alert
-pairRequestAlert repo msg = Alert
+pairRequestAlert :: String -> String -> AlertButton -> Alert
+pairRequestAlert repo msg button = Alert
 	{ alertClass = Message
 	, alertHeader = Just $ tenseWords ["Pair request"]
 	, alertMessageRender = tenseWords
@@ -275,6 +285,7 @@ pairRequestAlert repo msg = Alert
 	, alertIcon = Just "info-sign"
 	, alertName = Just $ PairRequestAlert repo
 	, alertCombiner = Just $ dataCombiner $ const id
+	, alertButton = Just button
 	}
 
 fileAlert :: TenseChunk -> FilePath -> Alert
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs
index 4de160ace..b9c7599f9 100644
--- a/Assistant/DaemonStatus.hs
+++ b/Assistant/DaemonStatus.hs
@@ -5,6 +5,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP, RankNTypes, ImpredicativeTypes #-}
+
 module Assistant.DaemonStatus where
 
 import Common.Annex
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
diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs
index d2c41a3c3..51972a98c 100644
--- a/Assistant/WebApp.hs
+++ b/Assistant/WebApp.hs
@@ -20,6 +20,7 @@ import Yesod
 import Text.Hamlet
 import Data.Text (Text)
 import Control.Concurrent.STM
+import Control.Concurrent
 
 data NavBarItem = DashBoard | Config | About
 	deriving (Eq)
@@ -116,3 +117,18 @@ webAppFormAuthToken = do
  - With noscript, clicking it GETs the Route. -}
 actionButton :: Route WebApp -> (Maybe String) -> String -> String -> Widget
 actionButton route label buttonclass iconclass = $(widgetFile "actionbutton")
+
+type UrlRenderFunc = Route WebApp -> [(Text, Text)] -> Text
+type UrlRenderer = MVar (UrlRenderFunc)
+
+newUrlRenderer :: IO UrlRenderer
+newUrlRenderer = newEmptyMVar
+
+setUrlRenderer :: UrlRenderer -> (UrlRenderFunc) -> IO ()
+setUrlRenderer = putMVar
+
+{- Blocks until the webapp is running and has called setUrlRenderer. -}
+renderUrl :: UrlRenderer -> Route WebApp -> [(Text, Text)] -> IO Text
+renderUrl urlrenderer route params = do
+	r <- readMVar urlrenderer
+	return $ r route params
diff --git a/Assistant/WebApp/SideBar.hs b/Assistant/WebApp/SideBar.hs
index 20fd09c2e..fd1f70038 100644
--- a/Assistant/WebApp/SideBar.hs
+++ b/Assistant/WebApp/SideBar.hs
@@ -36,24 +36,18 @@ sideBarDisplay = do
 	$(widgetFile "sidebar/main")
 	autoUpdate ident NotifierSideBarR (10 :: Int) (10 :: Int)
 	where
+		bootstrapclass :: AlertClass -> Text
 		bootstrapclass Activity = "alert-info"
 		bootstrapclass Warning = "alert"
 		bootstrapclass Error = "alert-error"
 		bootstrapclass Success = "alert-success"
 		bootstrapclass Message = "alert-info"
 
-		renderalert (alertid, alert) = addalert
-			alertid
-			(alertClosable alert)
-			(alertBlockDisplay alert)
-			(bootstrapclass $ alertClass alert)
-			(renderAlertHeader alert)
-			(renderAlertMessage alert)
-			(alertIcon alert)
-
-		addalert :: AlertId -> Bool -> Bool -> Text -> Maybe Text -> Text -> Maybe String -> Widget
-		addalert i closable block divclass heading message icon = do
-			let alertid = show i
+		renderalert (aid, alert) = do
+			let alertid = show aid
+			let closable = alertClosable alert
+			let block = alertBlockDisplay alert
+			let divclass = bootstrapclass $ alertClass alert
 			$(widgetFile "sidebar/alert")
 
 {- Called by client to get a sidebar display.