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.

1 files changed, 66 insertions, 34 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|]