summaryrefslogtreecommitdiff
path: root/Assistant/Threads/WebApp.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-07-29 03:23:17 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-07-29 03:23:17 -0400
commit62dac858807da8fb62ce55adbed84cfe582367b2 (patch)
treeca84c8b1eac3a35c576e9ff7117b53c1ffd5c2e0 /Assistant/Threads/WebApp.hs
parente96107caf3745d658a36e0ad7716dd07a57657a2 (diff)
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.
Diffstat (limited to 'Assistant/Threads/WebApp.hs')
-rw-r--r--Assistant/Threads/WebApp.hs100
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|]