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.

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
 	}

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.

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.
  -

templates/sidebar.hamlet

@@ -1,18 +1,3 @@
 <div .span3 ##{ident}>
   <div .sidebar-nav>
-    $maybe msg <- mmsg
-      <div .alert .alert-info>
-        <a .close data-dismiss="alert" href="#">&times;</a>
-          #{msg}
-    <div .alert .alert-info>
-      <a .close data-dismiss="alert" href="#">&times;</a>
-      <b>This is just a demo.</b> If this were not just a demo,
-      I'd not be filling this sidebar with silly alerts.
-    <div .alert .alert-success>
-      <a .close data-dismiss="alert" href="#">&times;</a>
-      <b>Well done!</b>
-      You successfully read this important alert message.
-    <div .alert .alert-error>
-      <a .close data-dismiss="alert" href="#">&times;</a>
-      <b>Whoops!</b>
-      Unable to connect to blah blah.. #{date}
+    ^{content}