diff options
Diffstat (limited to 'Assistant/Threads/WebApp.hs')
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 58 |
1 files changed, 49 insertions, 9 deletions
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 |