From f5ef46d01eb7bbaac45eec162267bcbf2500d511 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 26 Jul 2012 21:03:46 -0400
Subject: cleaned up refreshing code into a widget

Very happy to have a reusable autoUpdate widget that can make any Yesod
widget automatically refresh!

Also added support for non-javascript browsers, falling back to meta
refresh.

Also, the home page is now rendered with the webapp status on it, before
any refreshing is done.
---
 Assistant/Threads/WebApp.hs | 58 ++++++++++++++++++++++++++++++++++++++-------
 1 file changed, 49 insertions(+), 9 deletions(-)

(limited to 'Assistant')

diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 2d78609e8..0e1f9ba95 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -41,7 +41,7 @@ staticFiles "static"
 
 mkYesod "WebApp" [parseRoutes|
 / HomeR GET
-/poll PollR GET
+/status StatusR GET
 /config ConfigR GET
 /static StaticR Static getStatic
 |]
@@ -66,23 +66,63 @@ instance Yesod WebApp where
 	makeSessionBackend = webAppSessionBackend
 	jsLoader _ = BottomOfHeadBlocking
 
+{- Add to any widget to make it auto-update.
+ -
+ - The widget should have a html element with id=poll, which will be
+ - 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 updates.
+ - ms_startdelay is how long to delay before updating the widget at the
+ - state.
+ -}
+autoUpdate :: Text -> Route WebApp -> Route WebApp -> Int -> Int -> Widget
+autoUpdate poll gethtml home ms_delay ms_startdelay = do
+	{- Fallback refreshing is provided for non-javascript browsers. -}
+	let delayseconds = show $ ms_to_seconds ms_delay
+	toWidgetHead $(hamletFile $ hamletTemplate "metarefresh")
+
+	{- Use long polling to update the status display. -}
+	let delay = show ms_delay
+	let startdelay = show ms_startdelay
+	addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.6.2/jquery.min.js"
+	toWidgetHead $(juliusFile $ juliusTemplate "longpolling")
+	where
+		ms_to_seconds :: Int -> Int
+		ms_to_seconds ms = ceiling ((fromIntegral ms :: Double) / 1000)
+
+{- Continually updating status display. -}
+statusDisplay :: Widget
+statusDisplay = do
+	webapp <- lift getYesod
+	time <- show <$> liftIO getCurrentTime
+	
+	poll <- lift newIdent
+	$(whamletFile $ hamletTemplate "status")
+	
+	autoUpdate poll StatusR HomeR (3000 :: Int) (40 :: Int)
+
 getHomeR :: Handler RepHtml
 getHomeR = defaultLayout $ do
-	[whamlet|<div id="poll">Starting ...|]
-	addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.6.2/jquery.min.js"
-	toWidgetBody $(juliusFile $ juliusTemplate "longpolling")
+	statusDisplay
 	[whamlet|<p><a href="@{ConfigR}">config|]
 
 {- Called by client to poll for a new webapp status display.
  -
  - Should block until the status has changed, and then return a div
  - containing the new status, 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.
  -}
-getPollR :: Handler RepHtml
-getPollR = do
-	webapp <- getYesod
-	time <- show <$> liftIO getCurrentTime
-	hamletToRepHtml $(hamletFile $ hamletTemplate "poll")
+getStatusR :: Handler RepHtml
+getStatusR = do
+	page <- widgetToPageContent statusDisplay
+	hamletToRepHtml $ [hamlet|^{pageBody page}|]
 
 getConfigR :: Handler RepHtml
 getConfigR = defaultLayout $ do
-- 
cgit v1.2.3