update the sidebar by long polling

Needs to use a different NotificationBroadcaster, and not replace the
whole sidebar div, but instead add in new content. However, it's 3:30 am.

Assistant/Threads/WebApp.hs

@@ -33,6 +33,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
 
 thisThread :: String
 thisThread = "WebApp"
@@ -46,6 +47,10 @@ data WebApp = WebApp
 	, getStatic :: Static
 	}
 
+getNotificationBroadcaster :: WebApp -> IO NotificationBroadcaster
+getNotificationBroadcaster webapp = notificationBroadcaster
+		<$> getDaemonStatus (daemonStatus webapp)
+
 staticFiles "static"
 
 mkYesod "WebApp" [parseRoutes|
@@ -53,6 +58,7 @@ mkYesod "WebApp" [parseRoutes|
 /noscript NoScriptR GET
 /noscriptauto NoScriptAutoR GET
 /transfers/#NotificationId TransfersR GET
+/sidebar/#NotificationId SideBarR GET
 /config ConfigR GET
 /static StaticR Static getStatic
 |]
@@ -62,8 +68,7 @@ instance PathPiece NotificationId where
     fromPathPiece = readish . unpack
 
 instance Yesod WebApp where
-	defaultLayout widget = do
-		mmsg <- getMessage
+	defaultLayout content = do
 		webapp <- getYesod
 		page <- widgetToPageContent $ do
 			addStylesheet $ StaticR css_bootstrap_css
@@ -93,14 +98,12 @@ instance Yesod WebApp where
  - replaced when it's updated.
  - 
  - Updating is done by getting html from the gethtml route.
- - Or, the home route is used if the whole page has to be refreshed to
- - update.
  -
  - ms_delay is how long to delay between AJAX updates
  - ms_startdelay is how long to delay before updating with AJAX at the start
  -}
-autoUpdate :: Text -> Route WebApp -> Route WebApp -> Int -> Int -> Widget
-autoUpdate ident gethtml home ms_delay ms_startdelay = do
+autoUpdate :: Text -> Route WebApp -> Int -> Int -> Widget
+autoUpdate ident gethtml ms_delay ms_startdelay = do
 	let delay = show ms_delay
 	let startdelay = show ms_startdelay
 	$(widgetFile "longpolling")
@@ -120,39 +123,6 @@ transfersDisplay warnNoScript = do
 transfersDisplayIdent :: Text
 transfersDisplayIdent = "transfers"
 
-getNotificationBroadcaster :: WebApp -> IO NotificationBroadcaster
-getNotificationBroadcaster webapp = notificationBroadcaster
-		<$> getDaemonStatus (daemonStatus webapp)
-
-dashboard :: Bool -> Widget
-dashboard warnNoScript = transfersDisplay warnNoScript
-
-getHomeR :: Handler RepHtml
-getHomeR = defaultLayout $ do
-	{- Set up automatic updates for the transfers display. -}
-	webapp <- lift getYesod
-	nid <- liftIO $ notificationHandleToId <$>
-		(newNotificationHandle =<< getNotificationBroadcaster webapp)
-	autoUpdate transfersDisplayIdent (TransfersR nid) HomeR
-		(10 :: Int) (10 :: Int)
-	
-	dashboard True
-
-{- Same as HomeR, except with no javascript, so it doesn't allocate
- - new resources each time the page is refreshed, and with autorefreshing
- - via meta refresh. -}
-getNoScriptAutoR :: Handler RepHtml
-getNoScriptAutoR = defaultLayout $ do
-	let ident = NoScriptR
-	let delayseconds = 3 :: Int
-	let this = NoScriptAutoR
-	toWidgetHead $(hamletFile $ hamletTemplate "metarefresh")
-	dashboard False
-
-getNoScriptR :: Handler RepHtml
-getNoScriptR = defaultLayout $
-	dashboard True
-
 {- Called by client to get a display of currently in process transfers.
  -
  - Returns a div, which will be inserted into the calling page.
@@ -171,8 +141,70 @@ getTransfersR nid = do
 	page <- widgetToPageContent $ transfersDisplay False
 	hamletToRepHtml $ [hamlet|^{pageBody page}|]
 
+sideBarDisplay :: Bool -> Widget
+sideBarDisplay noScript = do
+	date <- liftIO $ show <$> getCurrentTime
+	ident <- lift newIdent
+	mmsg <- lift getMessage
+	$(widgetFile "sidebar")
+	unless noScript $ do
+		{- Set up automatic updates of the sidebar. -}
+		webapp <- lift getYesod
+		nid <- liftIO $ notificationHandleToId <$>
+			(newNotificationHandle =<< getNotificationBroadcaster webapp)
+		autoUpdate ident (SideBarR nid) (10 :: Int) (10 :: Int)
+
+{- Called by client to get a sidebar display.
+ -
+ - Returns a div, which will be inserted into the calling page.
+ -
+ - Note that the head of the widget is not included, only its
+ - body is. To get the widget head content, the widget is also 
+ - inserted onto all pages.
+ -}
+getSideBarR :: NotificationId -> Handler RepHtml
+getSideBarR nid = do
+	{- Block until there is a change from last time. -}
+	webapp <- getYesod
+	b <- liftIO $ getNotificationBroadcaster webapp
+	liftIO $ waitNotification $ notificationHandleFromId b nid
+
+	page <- widgetToPageContent $ sideBarDisplay True
+	hamletToRepHtml $ [hamlet|^{pageBody page}|]
+
+dashboard :: Bool -> Bool -> Widget
+dashboard noScript warnNoScript = do
+	sideBarDisplay noScript
+	transfersDisplay warnNoScript
+
+getHomeR :: Handler RepHtml
+getHomeR = defaultLayout $ do
+	{- Set up automatic updates for the transfers display. -}
+	webapp <- lift getYesod
+	nid <- liftIO $ notificationHandleToId <$>
+		(newNotificationHandle =<< getNotificationBroadcaster webapp)
+	autoUpdate transfersDisplayIdent (TransfersR nid) (10 :: Int) (10 :: Int)
+	
+	dashboard False True
+
+{- Same as HomeR, except with no javascript, so it doesn't allocate
+ - new resources each time the page is refreshed, and with autorefreshing
+ - via meta refresh. -}
+getNoScriptAutoR :: Handler RepHtml
+getNoScriptAutoR = defaultLayout $ do
+	let ident = NoScriptR
+	let delayseconds = 3 :: Int
+	let this = NoScriptAutoR
+	toWidgetHead $(hamletFile $ hamletTemplate "metarefresh")
+	dashboard True False
+
+getNoScriptR :: Handler RepHtml
+getNoScriptR = defaultLayout $
+	dashboard True True
+
 getConfigR :: Handler RepHtml
 getConfigR = defaultLayout $ do
+	sideBarDisplay False
 	setTitle "configuration"
 	[whamlet|<a href="@{HomeR}">main|]
 

templates/longpolling.julius

@@ -9,7 +9,7 @@
 
 numerrs=0;
 
-$.LongPoll = (function() {
+$.LongPoll#{ident} = (function() {
 	return {
 		send : function() {           
 			$.ajax({
@@ -17,7 +17,7 @@ $.LongPoll = (function() {
 				'dataType': 'html',
 				'success': function(data, status, jqxhr) {
 					$('##{ident}').replaceWith(data);
-					setTimeout($.LongPoll.send, #{show delay});
+					setTimeout($.LongPoll#{ident}.send, #{show delay});
 					numerrs=0;
 				},
 				'error': function(jqxhr, msg, e) {
@@ -26,7 +26,7 @@ $.LongPoll = (function() {
 						window.close();
 					}
 					else {
-						setTimeout($.LongPoll.send, #{show delay});
+						setTimeout($.LongPoll#{ident}.send, #{show delay});
 					}
 				},
 			});
@@ -35,7 +35,7 @@ $.LongPoll = (function() {
 }());
 
 $(document).bind('ready.app', function() {
-	setTimeout($.LongPoll.send, #{show startdelay});
+	setTimeout($.LongPoll#{ident}.send, #{show startdelay});
 });
 
 })( jQuery );

templates/page.hamlet

@@ -20,23 +20,4 @@
 
 <div .container-fluid>
   <div .row-fluid>
-    <div .span3>
-      <div .sidebar-nav>
-        <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..
-    <div .span9>
-      $maybe msg <- mmsg
-        <div .alert .alert-info>
-          <a .close data-dismiss="alert" href="#">&times;</a>
-          #{msg}
-      ^{widget}
+    ^{content}

templates/sidebar.hamlet

@@ -0,0 +1,18 @@
+<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}

templates/transfers.hamlet

@@ -1,30 +1,29 @@
-<span ##{ident}>
-  <div .span9>
-    $if null transfers
-      <h2>No current transfers
-    $else
-      <h2>Transfers
-      $forall (transfer, info) <- transfers
-        $with percent <- maybe "unknown" (showPercentage 0) $ percentComplete transfer info
-          <div .row-fluid>
-            <h3>
-              $maybe file <- associatedFile info
-                #{file}
-              $nothing
-                #{show $ transferKey transfer}
-              $case transferDirection transfer
-                $of Upload
-                  &rarr;
-                $of Download
-                  &larr;
-              <small>#{maybe "unknown" Remote.name $ transferRemote info}</small>
-                $with size <- maybe "unknown" (roughSize dataUnits True) $ keySize $ transferKey transfer
-                  $if isJust $ startedTime info
-                      <small .pull-right><b>#{percent} of #{size}</b></small>
-                  $else
-                      <small .pull-right>queued (#{size})</small>
-          <div .progress .progress-striped>
-            <div .bar style="width: #{percent};">
+<div .span9 ##{ident}>
+  $if null transfers
+    <h2>No current transfers
+  $else
+    <h2>Transfers
+    $forall (transfer, info) <- transfers
+      $with percent <- maybe "unknown" (showPercentage 0) $ percentComplete transfer info
+        <div .row-fluid>
+          <h3>
+            $maybe file <- associatedFile info
+              #{file}
+            $nothing
+              #{show $ transferKey transfer}
+            $case transferDirection transfer
+              $of Upload
+                &rarr;
+              $of Download
+                &larr;
+            <small>#{maybe "unknown" Remote.name $ transferRemote info}</small>
+              $with size <- maybe "unknown" (roughSize dataUnits True) $ keySize $ transferKey transfer
+                $if isJust $ startedTime info
+                    <small .pull-right><b>#{percent} of #{size}</b></small>
+                $else
+                    <small .pull-right>queued (#{size})</small>
+        <div .progress .progress-striped>
+          <div .bar style="width: #{percent};">
   $if warnNoScript
     <noscript>
       <div .navbar .navbar-fixed-bottom>