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.

5 files changed, 115 insertions, 85 deletions

diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index e47ee9fda..500297693 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/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,12 +123,59 @@ transfersDisplay warnNoScript = do
 transfersDisplayIdent :: Text
 transfersDisplayIdent = "transfers"
 
-getNotificationBroadcaster :: WebApp -> IO NotificationBroadcaster
-getNotificationBroadcaster webapp = notificationBroadcaster
-		<$> getDaemonStatus (daemonStatus webapp)
+{- Called by client to get a display of currently in process transfers.
+ -
+ - 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 the getHomeR page.
+ -}
+getTransfersR :: NotificationId -> Handler RepHtml
+getTransfersR nid = do
+	{- Block until there is a change from last time. -}
+	webapp <- getYesod
+	b <- liftIO $ getNotificationBroadcaster webapp
+	liftIO $ waitNotification $ notificationHandleFromId b nid
+
+	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 -> Widget
-dashboard warnNoScript = transfersDisplay warnNoScript
+dashboard :: Bool -> Bool -> Widget
+dashboard noScript warnNoScript = do
+	sideBarDisplay noScript
+	transfersDisplay warnNoScript
 
 getHomeR :: Handler RepHtml
 getHomeR = defaultLayout $ do
@@ -133,10 +183,9 @@ getHomeR = defaultLayout $ do
 	webapp <- lift getYesod
 	nid <- liftIO $ notificationHandleToId <$>
 		(newNotificationHandle =<< getNotificationBroadcaster webapp)
-	autoUpdate transfersDisplayIdent (TransfersR nid) HomeR
-		(10 :: Int) (10 :: Int)
+	autoUpdate transfersDisplayIdent (TransfersR nid) (10 :: Int) (10 :: Int)
 	
-	dashboard True
+	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
@@ -147,32 +196,15 @@ getNoScriptAutoR = defaultLayout $ do
 	let delayseconds = 3 :: Int
 	let this = NoScriptAutoR
 	toWidgetHead $(hamletFile $ hamletTemplate "metarefresh")
-	dashboard False
+	dashboard True 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.
- -
- - 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 the getHomeR page.
- -}
-getTransfersR :: NotificationId -> Handler RepHtml
-getTransfersR nid = do
-	{- Block until there is a change from last time. -}
-	webapp <- getYesod
-	b <- liftIO $ getNotificationBroadcaster webapp
-	liftIO $ waitNotification $ notificationHandleFromId b nid
-
-	page <- widgetToPageContent $ transfersDisplay False
-	hamletToRepHtml $ [hamlet|^{pageBody page}|]
+	dashboard True True
 
 getConfigR :: Handler RepHtml
 getConfigR = defaultLayout $ do
+	sideBarDisplay False
 	setTitle "configuration"
 	[whamlet|<a href="@{HomeR}">main|]
 
diff --git a/templates/longpolling.julius b/templates/longpolling.julius
index 926249a35..95425d615 100644
--- a/templates/longpolling.julius
+++ b/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 );
diff --git a/templates/page.hamlet b/templates/page.hamlet
index ae80bb05d..c397d248c 100644
--- a/templates/page.hamlet
+++ b/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}
diff --git a/templates/sidebar.hamlet b/templates/sidebar.hamlet
new file mode 100644
index 000000000..3b5048151
--- /dev/null
+++ b/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}
diff --git a/templates/transfers.hamlet b/templates/transfers.hamlet
index 417ba3d62..bc69d7f87 100644
--- a/templates/transfers.hamlet
+++ b/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>