diff options
| -rw-r--r-- | Assistant/Threads/WebApp.hs | 100 | ||||
| -rw-r--r-- | templates/longpolling.julius | 8 | ||||
| -rw-r--r-- | templates/page.hamlet | 21 | ||||
| -rw-r--r-- | templates/sidebar.hamlet | 18 | ||||
| -rw-r--r-- | templates/transfers.hamlet | 53 |
5 files changed, 115 insertions, 85 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|] diff --git a/templates/longpolling.julius b/templates/longpolling.julius index 926249a35..95425d615 100644 --- a/templates/longpolling.julius +++ b/templates/longpolling.julius @@ -9,7 +9,7 @@ numerrs=0; -$.LongPoll = (function() { +$.LongPoll#{ident} = (function() { return { send : function() { $.ajax({ @@ -17,7 +17,7 @@ $.LongPoll = (function() { 'dataType': 'html', 'success': function(data, status, jqxhr) { $('##{ident}').replaceWith(data); - setTimeout($.LongPoll.send, #{show delay}); + setTimeout($.LongPoll#{ident}.send, #{show delay}); numerrs=0; }, 'error': function(jqxhr, msg, e) { @@ -26,7 +26,7 @@ $.LongPoll = (function() { window.close(); } else { - setTimeout($.LongPoll.send, #{show delay}); + setTimeout($.LongPoll#{ident}.send, #{show delay}); } }, }); @@ -35,7 +35,7 @@ $.LongPoll = (function() { }()); $(document).bind('ready.app', function() { - setTimeout($.LongPoll.send, #{show startdelay}); + setTimeout($.LongPoll#{ident}.send, #{show startdelay}); }); })( jQuery ); diff --git a/templates/page.hamlet b/templates/page.hamlet index ae80bb05d..c397d248c 100644 --- a/templates/page.hamlet +++ b/templates/page.hamlet @@ -20,23 +20,4 @@ <div .container-fluid> <div .row-fluid> - <div .span3> - <div .sidebar-nav> - <div .alert .alert-info> - <a .close data-dismiss="alert" href="#">×</a> - <b>This is just a demo.</b> If this were not just a demo, - I'd not be filling this sidebar with silly alerts. - <div .alert .alert-success> - <a .close data-dismiss="alert" href="#">×</a> - <b>Well done!</b> - You successfully read this important alert message. - <div .alert .alert-error> - <a .close data-dismiss="alert" href="#">×</a> - <b>Whoops!</b> - Unable to connect to blah blah.. - <div .span9> - $maybe msg <- mmsg - <div .alert .alert-info> - <a .close data-dismiss="alert" href="#">×</a> - #{msg} - ^{widget} + ^{content} diff --git a/templates/sidebar.hamlet b/templates/sidebar.hamlet new file mode 100644 index 000000000..3b5048151 --- /dev/null +++ b/templates/sidebar.hamlet @@ -0,0 +1,18 @@ +<div .span3 ##{ident}> + <div .sidebar-nav> + $maybe msg <- mmsg + <div .alert .alert-info> + <a .close data-dismiss="alert" href="#">×</a> + #{msg} + <div .alert .alert-info> + <a .close data-dismiss="alert" href="#">×</a> + <b>This is just a demo.</b> If this were not just a demo, + I'd not be filling this sidebar with silly alerts. + <div .alert .alert-success> + <a .close data-dismiss="alert" href="#">×</a> + <b>Well done!</b> + You successfully read this important alert message. + <div .alert .alert-error> + <a .close data-dismiss="alert" href="#">×</a> + <b>Whoops!</b> + Unable to connect to blah blah.. #{date} diff --git a/templates/transfers.hamlet b/templates/transfers.hamlet index 417ba3d62..bc69d7f87 100644 --- a/templates/transfers.hamlet +++ b/templates/transfers.hamlet @@ -1,30 +1,29 @@ -<span ##{ident}> - <div .span9> - $if null transfers - <h2>No current transfers - $else - <h2>Transfers - $forall (transfer, info) <- transfers - $with percent <- maybe "unknown" (showPercentage 0) $ percentComplete transfer info - <div .row-fluid> - <h3> - $maybe file <- associatedFile info - #{file} - $nothing - #{show $ transferKey transfer} - $case transferDirection transfer - $of Upload - → - $of Download - ← - <small>#{maybe "unknown" Remote.name $ transferRemote info}</small> - $with size <- maybe "unknown" (roughSize dataUnits True) $ keySize $ transferKey transfer - $if isJust $ startedTime info - <small .pull-right><b>#{percent} of #{size}</b></small> - $else - <small .pull-right>queued (#{size})</small> - <div .progress .progress-striped> - <div .bar style="width: #{percent};"> +<div .span9 ##{ident}> + $if null transfers + <h2>No current transfers + $else + <h2>Transfers + $forall (transfer, info) <- transfers + $with percent <- maybe "unknown" (showPercentage 0) $ percentComplete transfer info + <div .row-fluid> + <h3> + $maybe file <- associatedFile info + #{file} + $nothing + #{show $ transferKey transfer} + $case transferDirection transfer + $of Upload + → + $of Download + ← + <small>#{maybe "unknown" Remote.name $ transferRemote info}</small> + $with size <- maybe "unknown" (roughSize dataUnits True) $ keySize $ transferKey transfer + $if isJust $ startedTime info + <small .pull-right><b>#{percent} of #{size}</b></small> + $else + <small .pull-right>queued (#{size})</small> + <div .progress .progress-striped> + <div .bar style="width: #{percent};"> $if warnNoScript <noscript> <div .navbar .navbar-fixed-bottom> |