diff options
author | 2012-07-28 21:21:22 -0400 | |
---|---|---|
committer | 2012-07-28 21:21:22 -0400 | |
commit | 6a9abf652612af149be806ba8055879141929475 (patch) | |
tree | 71e3b185f3a82f3e9c3eb23cb30d921e28c568ab /Assistant/Threads/WebApp.hs | |
parent | 5be5cb219f1d277fbc7c8b0a33a9012fcd219a00 (diff) |
add NotificationID to StatusR, and use it to block
Diffstat (limited to 'Assistant/Threads/WebApp.hs')
-rw-r--r-- | Assistant/Threads/WebApp.hs | 27 |
1 files changed, 22 insertions, 5 deletions
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 6e895ccf6..430e6f50c 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Assistant.Threads.WebApp where @@ -13,6 +14,7 @@ import Assistant.Common import Assistant.ThreadedMonad import Assistant.DaemonStatus import Assistant.TransferQueue +import Utility.NotificationBroadcaster import Utility.WebApp import Utility.Yesod import Utility.FileMode @@ -49,11 +51,15 @@ staticFiles "static" mkYesod "WebApp" [parseRoutes| / HomeR GET -/status StatusR GET +/status/#NotificationId StatusR GET /config ConfigR GET /static StaticR Static getStatic |] +instance PathPiece NotificationId where + toPathPiece = pack . show + fromPathPiece = readish . unpack + instance Yesod WebApp where defaultLayout widget = do mmsg <- getMessage @@ -107,7 +113,7 @@ autoUpdate updating gethtml home ms_delay ms_startdelay = do ms_to_seconds :: Int -> Int ms_to_seconds ms = ceiling ((fromIntegral ms :: Double) / 1000) -{- Continually updating status display. -} +{- A dynamically updating status display. -} statusDisplay :: Widget statusDisplay = do webapp <- lift getYesod @@ -122,7 +128,13 @@ statusDisplay = do updating <- lift newIdent $(widgetFile "status") - autoUpdate updating StatusR HomeR (3000 :: Int) (40 :: Int) + nid <- liftIO $ notificationHandleToId <$> + (newNotificationHandle =<< getNotificationBroadcaster webapp) + autoUpdate updating (StatusR nid) HomeR (3000 :: Int) (40 :: Int) + +getNotificationBroadcaster :: WebApp -> IO NotificationBroadcaster +getNotificationBroadcaster webapp = notificationBroadcaster + <$> getDaemonStatus (daemonStatus webapp) getHomeR :: Handler RepHtml getHomeR = defaultLayout statusDisplay @@ -136,8 +148,13 @@ getHomeR = defaultLayout statusDisplay - body is. To get the widget head content, the widget is also - inserted onto the getHomeR page. -} -getStatusR :: Handler RepHtml -getStatusR = do +getStatusR :: NotificationId -> Handler RepHtml +getStatusR nid = do + {- Block until there is an updated status to display. -} + webapp <- getYesod + b <- liftIO $ getNotificationBroadcaster webapp + liftIO $ waitNotification $ notificationHandleFromId b nid + page <- widgetToPageContent statusDisplay hamletToRepHtml $ [hamlet|^{pageBody page}|] |