show alerts in the sidebar

This has a bug -- it seems long polling can only wait on one page at a
time. Need to re-unify the notifiers.

3 files changed, 58 insertions, 11 deletions

diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index c8bfa48fd..f4220eea9 100644
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@@ -14,12 +14,23 @@ import Yesod
 type Widget = forall sub master. GWidget sub master ()
 
 {- Different classes of alerts are displayed differently. -}
-data AlertClass = Activity | Warning | Error | Message
+data AlertClass = Activity | Warning | Error | Success | Message
+	deriving (Eq)
 
-{- An alert can be a simple message, or a Yesod Widget -}
+{- An alert can be a simple message, or an arbitrary Yesod Widget -}
 data AlertMessage = StringAlert String | WidgetAlert Widget
 
 data Alert = Alert
 	{ alertClass :: AlertClass
+	, alertHeader :: Maybe String
 	, alertMessage :: AlertMessage
+	, alertBlockDisplay :: Bool
+	}
+
+activityAlert :: Maybe String -> String -> Alert
+activityAlert header message = Alert
+	{ alertClass = Activity
+	, alertHeader = header
+	, alertMessage = StringAlert message
+	, alertBlockDisplay = False
 	}
diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs
index ab57bf04a..5086f95a2 100644
--- a/Assistant/Threads/Watcher.hs
+++ b/Assistant/Threads/Watcher.hs
@@ -19,6 +19,7 @@ import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
 import Assistant.Changes
 import Assistant.TransferQueue
+import Assistant.Alert
 import Logs.Transfer
 import Utility.DirWatcher
 import Utility.Types.DirWatcher
@@ -60,7 +61,7 @@ watchThread st dstatus transferqueue changechan = do
 	void $ watchDir "." ignored hooks startup
 	debug thisThread [ "watching", "."]
 	where
-		startup = statupScan st dstatus
+		startup = startupScan st dstatus
 		hook a = Just $ runHandler thisThread st dstatus transferqueue changechan a
 		hooks = WatchHooks
 			{ addHook = hook onAdd
@@ -71,11 +72,12 @@ watchThread st dstatus transferqueue changechan = do
 			}
 
 {- Initial scartup scan. The action should return once the scan is complete. -}
-statupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a
-statupScan st dstatus scanner = do
+startupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a
+startupScan st dstatus scanner = do
 	runThreadState st $
 		showAction "scanning"
-	r <- scanner
+	let alert = activityAlert Nothing "Performing startup scan"
+	r <- alertWhile dstatus alert scanner
 	modifyDaemonStatus_ dstatus $ \s -> s { scanComplete = True }
 
 	-- Notice any files that were deleted before watching was started.
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 3db5f368c..132aad22e 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -14,6 +14,7 @@ import Assistant.Common
 import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
 import Assistant.TransferQueue
+import Assistant.Alert hiding (Widget)
 import Utility.NotificationBroadcaster
 import Utility.WebApp
 import Utility.Yesod
@@ -33,7 +34,7 @@ import Network.Socket (PortNumber)
 import Text.Blaze.Renderer.String
 import Data.Text (Text, pack, unpack)
 import qualified Data.Map as M
-import Data.Time.Clock
+import Data.Function
 
 thisThread :: String
 thisThread = "WebApp"
@@ -151,14 +152,47 @@ getTransfersR nid = do
 
 sideBarDisplay :: Bool -> Widget
 sideBarDisplay noScript = do
-	date <- liftIO $ show <$> getCurrentTime
+	let content = do
+		{- Any yesod message appears as the first alert. -}
+		maybe noop rendermessage =<< lift getMessage
+	
+		{- Add newest 10 alerts to the sidebar. -}
+		webapp <- lift getYesod
+		alerts <- M.toList . alertMap
+			<$> liftIO (getDaemonStatus $ daemonStatus webapp)
+		mapM_ renderalert $
+			take 10 $ reverse $ sortBy (compare `on` fst) alerts
 	ident <- lift newIdent
-	mmsg <- lift getMessage
 	$(widgetFile "sidebar")
+
 	unless noScript $ do
-		{- Set up automatic updates of the sidebar. -}
-		nid <- lift $ newNotifier transferNotifier
+		{- Set up automatic updates of the sidebar
+		 - when alerts come in. -}
+		nid <- lift $ newNotifier alertNotifier
 		autoUpdate ident (SideBarR nid) (10 :: Int) (10 :: Int)
+	where
+		bootstrapclass Activity = "alert-info"
+		bootstrapclass Warning = "alert"
+		bootstrapclass Error = "alert-error"
+		bootstrapclass Success = "alert-success"
+		bootstrapclass Message = "alert-info"
+
+		renderalert (alertid, alert) = addalert
+			(show alertid)
+			-- Activity alerts auto-close
+			(not noScript && alertClass alert /= Activity)
+			(alertBlockDisplay alert)
+			(bootstrapclass $ alertClass alert)
+			(alertHeader alert)
+			$ case alertMessage alert of
+				StringAlert s -> [whamlet|#{s}|]
+				WidgetAlert w -> w
+
+		rendermessage msg = addalert "yesodmessage" True False
+			"alert-info" Nothing [whamlet|#{msg}|]
+
+		addalert :: String -> Bool -> Bool -> Text -> Maybe String -> Widget -> Widget
+		addalert alertid closable block divclass heading widget = $(widgetFile "alert")
 
 {- Called by client to get a sidebar display.
  -