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.

Assistant.hs

@@ -97,6 +97,10 @@
  - ScanRemotes (STM TMVar)
  - 	Remotes that have been disconnected, and should be scanned
  - 	are indicated by writing to this TMVar.
+ - UrlRenderer (MVar)
+ - 	A Yesod route rendering function is stored here. This allows
+ - 	things that need to render Yesod routes to block until the webapp
+ - 	has started up and such rendering is possible.
  -}
 
 {-# LANGUAGE CPP #-}
@@ -125,6 +129,7 @@ import Assistant.Threads.NetWatcher
 import Assistant.Threads.TransferScanner
 import Assistant.Threads.TransferPoller
 #ifdef WITH_WEBAPP
+import Assistant.WebApp
 import Assistant.Threads.WebApp
 #ifdef WITH_PAIRING
 import Assistant.Threads.PairListener
@@ -170,12 +175,13 @@ startAssistant assistant daemonize webappwaiter = do
 			transferqueue <- newTransferQueue
 			transferslots <- newTransferSlots
 			scanremotes <- newScanRemoteMap
+			urlrenderer <- newUrlRenderer
 			mapM_ (startthread dstatus)
 				[ watch $ commitThread st changechan commitchan transferqueue dstatus
 #ifdef WITH_WEBAPP
-				, assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots Nothing webappwaiter
+				, assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots urlrenderer Nothing webappwaiter
 #ifdef WITH_PAIRING
-				, assist $ pairListenerThread st dstatus
+				, assist $ pairListenerThread st dstatus urlrenderer
 #endif
 #endif
 				, assist $ pushThread st dstatus commitchan pushmap

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

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

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"

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

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

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.

Command/WebApp.hs

@@ -16,6 +16,7 @@ import Assistant.ScanRemotes
 import Assistant.TransferQueue
 import Assistant.TransferSlots
 import Assistant.Threads.WebApp
+import Assistant.WebApp
 import Utility.WebApp
 import Utility.Daemon (checkDaemon, lockPidFile)
 import Init
@@ -92,10 +93,12 @@ firstRun = do
 	scanremotes <- newScanRemoteMap
 	transferqueue <- newTransferQueue
 	transferslots <- newTransferSlots
+	urlrenderer <- newUrlRenderer
 	v <- newEmptyMVar
 	let callback a = Just $ a v
 	void $ runNamedThread dstatus $
-		webAppThread Nothing dstatus scanremotes transferqueue transferslots
+		webAppThread Nothing dstatus scanremotes
+			transferqueue transferslots urlrenderer
 			(callback signaler) (callback mainthread)
 	where
 		signaler v = do

templates/sidebar/alert.hamlet

@@ -1,18 +1,24 @@
-<div .alert .fade .in .#{divclass} :block:.alert-block ##{alertid} :closable:onclick="(function( $ ) { $.get('@{CloseAlert i}') })( jQuery );">
+<div .alert .fade .in .#{divclass} :block:.alert-block ##{alertid} :closable:onclick="(function( $ ) { $.get('@{CloseAlert aid}') })( jQuery );">
   $if closable
     <a .close>&times;</a>
-  $maybe h <- heading
+  $maybe h <- renderAlertHeader alert
     $if block
       <h4 .alert-heading>
-        $case icon
+        $case alertIcon alert
           $of Nothing
           $of Just name
             <i .icon-#{name}></i> #
         #{h}
     $else
-      $case icon
+      $case alertIcon alert
         $of Nothing
         $of Just name
           <i .icon-#{name}></i> #
       <strong>#{h}</strong> #
-  #{message}
+  #{renderAlertMessage alert}
+  $case alertButton alert
+    $of Nothing
+    $of Just button
+      <br>
+      <a .btn .btn-primary href="#{buttonUrl button}">
+        #{buttonLabel button}