fix noscript mode to not allocate notification ids on each refresh

Now the javascript does an ajax call at the start to request the url
to use to poll, and the notification id is generated then, once we know
javascript is working.

1 files changed, 48 insertions, 34 deletions

diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index a9b87ea58..79a388463 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -36,6 +36,7 @@ import Text.Hamlet
 import Network.Socket (PortNumber)
 import Text.Blaze.Renderer.String
 import Data.Text (Text, pack, unpack)
+import qualified Data.Text as T
 import qualified Data.Map as M
 import Control.Concurrent.STM
 
@@ -93,6 +94,8 @@ mkYesod "WebApp" [parseRoutes|
 /noscriptauto NoScriptAutoR GET
 /transfers/#NotificationId TransfersR GET
 /sidebar/#NotificationId SideBarR GET
+/notifier/transfers NotifierTransfersR GET
+/notifier/sidebar NotifierSideBarR GET
 /closealert/#AlertId CloseAlert GET
 /config ConfigR GET
 /addrepository AddRepositoryR GET
@@ -136,19 +139,40 @@ instance Yesod WebApp where
  -
  - The widget should have a html element with an id=ident, which will be
  - replaced when it's updated.
- - 
- - Updating is done by getting html from the gethtml route.
+ -
+ - The geturl route should return the notifier url to use for polling.
  -
  - 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 -> Int -> Int -> Widget
-autoUpdate ident gethtml ms_delay ms_startdelay = do
+autoUpdate ident geturl ms_delay ms_startdelay = do
 	let delay = show ms_delay
 	let startdelay = show ms_startdelay
 	addScript $ StaticR longpolling_js
 	$(widgetFile "longpolling")
 
+{- Notifier urls are requested by the javascript, to avoid allocation
+ - of NotificationIds when noscript pages are loaded. This constructs a
+ - notifier url for a given Route and NotificationBroadcaster.
+ -}
+notifierUrl :: (NotificationId -> Route WebApp) -> (DaemonStatus -> NotificationBroadcaster) -> Handler RepPlain
+notifierUrl route selector = do
+	(urlbits, _params) <- renderRoute . route <$> newNotifier selector
+	webapp <- getYesod
+	return $ RepPlain $ toContent $ T.concat
+		[ "/"
+		, T.intercalate "/" urlbits
+		, "?auth="
+		, secretToken webapp
+		]
+
+getNotifierTransfersR :: Handler RepPlain
+getNotifierTransfersR = notifierUrl TransfersR transferNotifier
+
+getNotifierSideBarR :: Handler RepPlain
+getNotifierSideBarR = notifierUrl SideBarR alertNotifier
+
 {- A display of currently running and queued transfers.
  -
  - Or, if there have never been any this run, an intro display. -}
@@ -159,7 +183,8 @@ transfersDisplay warnNoScript = do
 		M.toList . currentTransfers
 			<$> liftIO (getDaemonStatus $ daemonStatus webapp)
 	queued <- liftIO $ getTransferQueue $ transferQueue webapp
-	let ident = transfersDisplayIdent
+	let ident = "transfers"
+	autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
 	let transfers = current ++ queued
 	if null transfers
 		then ifM (lift $ showIntro <$> getWebAppState)
@@ -168,9 +193,7 @@ transfersDisplay warnNoScript = do
 			)
 		else $(widgetFile "transfers")
 
-transfersDisplayIdent :: Text
-transfersDisplayIdent = "transfers"
-
+{- An intro message, and list of repositories. -}
 introDisplay :: Text -> Widget
 introDisplay ident = do
 	webapp <- lift getYesod
@@ -206,8 +229,8 @@ getTransfersR nid = do
 	page <- widgetToPageContent $ transfersDisplay False
 	hamletToRepHtml $ [hamlet|^{pageBody page}|]
 
-sideBarDisplay :: Bool -> Widget
-sideBarDisplay noScript = do
+sideBarDisplay :: Widget
+sideBarDisplay = do
 	let content = do
 		{- Any yesod message appears as the first alert. -}
 		maybe noop rendermessage =<< lift getMessage
@@ -218,14 +241,9 @@ sideBarDisplay noScript = do
 			<$> liftIO (getDaemonStatus $ daemonStatus webapp)
 		mapM_ renderalert $
 			take displayAlerts $ reverse $ sortAlertPairs alertpairs
-	ident <- lift newIdent
+	let ident = "sidebar"
 	$(widgetFile "sidebar")
-
-	unless noScript $ do
-		{- Set up automatic updates of the sidebar
-		 - when alerts come in. -}
-		nid <- lift $ newNotifier alertNotifier
-		autoUpdate ident (SideBarR nid) (10 :: Int) (10 :: Int)
+	autoUpdate ident NotifierSideBarR (10 :: Int) (10 :: Int)
 	where
 		bootstrapclass Activity = "alert-info"
 		bootstrapclass Warning = "alert"
@@ -264,7 +282,7 @@ getSideBarR :: NotificationId -> Handler RepHtml
 getSideBarR nid = do
 	waitNotifier alertNotifier nid
 
-	page <- widgetToPageContent $ sideBarDisplay True
+	page <- widgetToPageContent sideBarDisplay
 	hamletToRepHtml $ [hamlet|^{pageBody page}|]
 
 {- Called by the client to close an alert. -}
@@ -273,43 +291,39 @@ getCloseAlert i = do
 	webapp <- getYesod
 	void $ liftIO $ removeAlert (daemonStatus webapp) i
 
-dashboard :: Bool -> Bool -> Widget
-dashboard noScript warnNoScript = do
-	sideBarDisplay noScript
-	transfersDisplay warnNoScript
+{- The main dashboard. -}
+dashboard :: Bool -> Widget
+dashboard warnNoScript = do
+	sideBarDisplay
+	let content = transfersDisplay warnNoScript
+	$(widgetFile "dashboard")
 
 getHomeR :: Handler RepHtml
-getHomeR = defaultLayout $ do
-	{- Set up automatic updates for the transfers display. -}
-	nid <- lift $ newNotifier transferNotifier
-	autoUpdate transfersDisplayIdent (TransfersR nid) (10 :: Int) (10 :: Int)
-	
-	dashboard False True
+getHomeR = defaultLayout $ dashboard True
 
-{- Same as HomeR, except with no javascript, so it doesn't allocate
- - new resources each time the page is refreshed, and with autorefreshing
- - via meta refresh. -}
+{- Same as HomeR, except with autorefreshing via meta refresh. -}
 getNoScriptAutoR :: Handler RepHtml
 getNoScriptAutoR = defaultLayout $ do
 	let ident = NoScriptR
 	let delayseconds = 3 :: Int
 	let this = NoScriptAutoR
 	toWidgetHead $(hamletFile $ hamletTemplate "metarefresh")
-	dashboard True False
+	dashboard False
 
+{- Same as HomeR, except no autorefresh at all (and no noscript warning). -}
 getNoScriptR :: Handler RepHtml
 getNoScriptR = defaultLayout $
-	dashboard True True
+	dashboard False
 
 getConfigR :: Handler RepHtml
 getConfigR = defaultLayout $ do
-	sideBarDisplay False
+	sideBarDisplay
 	setTitle "Configuration"
 	[whamlet|<a href="@{HomeR}">main|]
 
 getAddRepositoryR :: Handler RepHtml
 getAddRepositoryR = defaultLayout $ do
-	sideBarDisplay False
+	sideBarDisplay
 	setTitle "Add repository"
 	[whamlet|<a href="@{HomeR}">main|]