split up webapp files

7 files changed, 413 insertions, 297 deletions

diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 79a388463..7b794b6eb 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -11,321 +11,31 @@
 module Assistant.Threads.WebApp where
 
 import Assistant.Common
+import Assistant.WebApp
+import Assistant.WebApp.DashBoard
+import Assistant.WebApp.SideBar
+import Assistant.WebApp.Notifications
+import Assistant.WebApp.Configurators
 import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
 import Assistant.TransferQueue
-import Assistant.Alert hiding (Widget)
-import Utility.NotificationBroadcaster
 import Utility.WebApp
 import Utility.Yesod
 import Utility.FileMode
 import Utility.TempFile
 import Git
-import Logs.Transfer
-import Utility.Percentage
-import Utility.DataUnits
-import Types.Key
-import qualified Remote
-import Logs.Web (webUUID)
-import Logs.Trust
-import Annex.UUID (getUUID)
 
 import Yesod
 import Yesod.Static
 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
+import Data.Text (pack, unpack)
 
 thisThread :: String
 thisThread = "WebApp"
 
-data WebApp = WebApp
-	{ threadState :: ThreadState
-	, daemonStatus :: DaemonStatusHandle
-	, transferQueue :: TransferQueue
-	, secretToken :: Text
-	, relDir :: FilePath
-	, getStatic :: Static
-	, webAppState :: TMVar WebAppState
-	}
-
-data WebAppState = WebAppState
-	{ showIntro :: Bool
-	}
-
-newWebAppState :: IO (TMVar WebAppState)
-newWebAppState = liftIO $ atomically $
-	newTMVar $ WebAppState { showIntro = True }
-
-getWebAppState :: forall sub. GHandler sub WebApp WebAppState
-getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod
-
-modifyWebAppState :: forall sub. (WebAppState -> WebAppState) -> GHandler sub WebApp ()
-modifyWebAppState a = go =<< webAppState <$> getYesod
-	where
-		go s = liftIO $ atomically $ do
-			v <- takeTMVar s
-			putTMVar s $ a v
-
-waitNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> NotificationId -> GHandler sub WebApp ()
-waitNotifier selector nid = do
-	notifier <- getNotifier selector
-	liftIO $ waitNotification $ notificationHandleFromId notifier nid
-
-newNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationId
-newNotifier selector = do
-	notifier <- getNotifier selector
-	liftIO $ notificationHandleToId <$> newNotificationHandle notifier
-
-getNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationBroadcaster
-getNotifier selector = do
-	webapp <- getYesod
-	liftIO $ selector <$> getDaemonStatus (daemonStatus webapp)
-
-staticFiles "static"
-
-mkYesod "WebApp" [parseRoutes|
-/ HomeR GET
-/noscript NoScriptR GET
-/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
-/static StaticR Static getStatic
-|]
-
-instance PathPiece NotificationId where
-    toPathPiece = pack . show
-    fromPathPiece = readish . unpack
-
-instance PathPiece AlertId where
-    toPathPiece = pack . show
-    fromPathPiece = readish . unpack
-
-instance Yesod WebApp where
-	defaultLayout content = do
-		webapp <- getYesod
-		page <- widgetToPageContent $ do
-			addStylesheet $ StaticR css_bootstrap_css
-			addStylesheet $ StaticR css_bootstrap_responsive_css
-			addScript $ StaticR jquery_full_js
-			addScript $ StaticR js_bootstrap_dropdown_js
-			addScript $ StaticR js_bootstrap_modal_js
-			$(widgetFile "page")
-		hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap")
-
-	{- Require an auth token be set when accessing any (non-static route) -}
-	isAuthorized _ _ = checkAuthToken secretToken
-
-	{- Add the auth token to every url generated, except static subsite
-         - urls (which can show up in Permission Denied pages). -}
-	joinPath = insertAuthToken secretToken excludeStatic
-		where
-			excludeStatic [] = True
-			excludeStatic (p:_) = p /= "static"
-
-	makeSessionBackend = webAppSessionBackend
-	jsLoader _ = BottomOfHeadBlocking
-
-{- Add to any widget to make it auto-update using long polling.
- -
- - The widget should have a html element with an id=ident, which will be
- - replaced when it's updated.
- -
- - 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 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. -}
-transfersDisplay :: Bool -> Widget
-transfersDisplay warnNoScript = do
-	webapp <- lift getYesod
-	current <- liftIO $ runThreadState (threadState webapp) $
-		M.toList . currentTransfers
-			<$> liftIO (getDaemonStatus $ daemonStatus webapp)
-	queued <- liftIO $ getTransferQueue $ transferQueue webapp
-	let ident = "transfers"
-	autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
-	let transfers = current ++ queued
-	if null transfers
-		then ifM (lift $ showIntro <$> getWebAppState)
-			( introDisplay ident
-			, $(widgetFile "transfers")
-			)
-		else $(widgetFile "transfers")
-
-{- An intro message, and list of repositories. -}
-introDisplay :: Text -> Widget
-introDisplay ident = do
-	webapp <- lift getYesod
-	let reldir = relDir webapp
-	l <- liftIO $ runThreadState (threadState webapp) $ do
-		u <- getUUID
-		rs <- map Remote.uuid <$> Remote.remoteList
-		rs' <- snd <$> trustPartition DeadTrusted rs
-		Remote.prettyListUUIDs $ filter (/= webUUID) $ nub $ u:rs'
-	let remotelist = zip counter l
-	let n = length l
-	let numrepos = show n
-	let notenough = n < 2
-	let barelyenough = n == 2
-	let morethanenough = n > 2
-	$(widgetFile "intro")
-	lift $ modifyWebAppState $ \s -> s { showIntro = False }
-	where
-		counter = map show ([1..] :: [Int])
-
-{- 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
-	waitNotifier transferNotifier nid
-
-	page <- widgetToPageContent $ transfersDisplay False
-	hamletToRepHtml $ [hamlet|^{pageBody page}|]
-
-sideBarDisplay :: Widget
-sideBarDisplay = do
-	let content = do
-		{- Any yesod message appears as the first alert. -}
-		maybe noop rendermessage =<< lift getMessage
-	
-		{- Add newest alerts to the sidebar. -}
-		webapp <- lift getYesod
-		alertpairs <- M.toList . alertMap
-			<$> liftIO (getDaemonStatus $ daemonStatus webapp)
-		mapM_ renderalert $
-			take displayAlerts $ reverse $ sortAlertPairs alertpairs
-	let ident = "sidebar"
-	$(widgetFile "sidebar")
-	autoUpdate ident NotifierSideBarR (10 :: Int) (10 :: Int)
-	where
-		bootstrapclass Activity = "alert-info"
-		bootstrapclass Warning = "alert"
-		bootstrapclass Error = "alert-error"
-		bootstrapclass Success = "alert-success"
-		bootstrapclass Message = "alert-info"
-
-		renderalert (alertid, alert) = addalert
-			alertid
-			(alertClosable alert)
-			(alertBlockDisplay alert)
-			(bootstrapclass $ alertClass alert)
-			(alertHeader alert)
-			$ case alertMessage alert of
-				StringAlert s -> [whamlet|#{s}|]
-				WidgetAlert w -> w alert
-
-		rendermessage msg = addalert firstAlertId True False
-			"alert-info" Nothing [whamlet|#{msg}|]
-
-		addalert :: AlertId -> Bool -> Bool -> Text -> Maybe String -> Widget -> Widget
-		addalert i closable block divclass heading widget = do
-			let alertid = show i
-			let closealert = CloseAlert i
-			$(widgetFile "alert")
-
-{- 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
-	waitNotifier alertNotifier nid
-
-	page <- widgetToPageContent sideBarDisplay
-	hamletToRepHtml $ [hamlet|^{pageBody page}|]
-
-{- Called by the client to close an alert. -}
-getCloseAlert :: AlertId -> Handler ()
-getCloseAlert i = do
-	webapp <- getYesod
-	void $ liftIO $ removeAlert (daemonStatus webapp) i
-
-{- The main dashboard. -}
-dashboard :: Bool -> Widget
-dashboard warnNoScript = do
-	sideBarDisplay
-	let content = transfersDisplay warnNoScript
-	$(widgetFile "dashboard")
-
-getHomeR :: Handler RepHtml
-getHomeR = defaultLayout $ dashboard True
-
-{- 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 False
-
-{- Same as HomeR, except no autorefresh at all (and no noscript warning). -}
-getNoScriptR :: Handler RepHtml
-getNoScriptR = defaultLayout $
-	dashboard False
-
-getConfigR :: Handler RepHtml
-getConfigR = defaultLayout $ do
-	sideBarDisplay
-	setTitle "Configuration"
-	[whamlet|<a href="@{HomeR}">main|]
-
-getAddRepositoryR :: Handler RepHtml
-getAddRepositoryR = defaultLayout $ do
-	sideBarDisplay
-	setTitle "Add repository"
-	[whamlet|<a href="@{HomeR}">main|]
+mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
 
 webAppThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Maybe (IO ()) -> IO ()
 webAppThread st dstatus transferqueue onstartup = do
diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs
new file mode 100644
index 000000000..d3989a68a
--- /dev/null
+++ b/Assistant/WebApp.hs
@@ -0,0 +1,106 @@
+{- git-annex assistant webapp data types
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Assistant.WebApp where
+
+import Assistant.Common
+import Assistant.ThreadedMonad
+import Assistant.DaemonStatus
+import Assistant.TransferQueue
+import Assistant.Alert hiding (Widget)
+import Utility.NotificationBroadcaster
+import Utility.WebApp
+import Utility.Yesod
+
+import Yesod
+import Yesod.Static
+import Text.Hamlet
+import Data.Text (Text, pack, unpack)
+import Control.Concurrent.STM
+
+staticFiles "static"
+
+mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
+
+data WebApp = WebApp
+	{ threadState :: ThreadState
+	, daemonStatus :: DaemonStatusHandle
+	, transferQueue :: TransferQueue
+	, secretToken :: Text
+	, relDir :: FilePath
+	, getStatic :: Static
+	, webAppState :: TMVar WebAppState
+	}
+
+instance Yesod WebApp where
+	defaultLayout content = do
+		webapp <- getYesod
+		page <- widgetToPageContent $ do
+			addStylesheet $ StaticR css_bootstrap_css
+			addStylesheet $ StaticR css_bootstrap_responsive_css
+			addScript $ StaticR jquery_full_js
+			addScript $ StaticR js_bootstrap_dropdown_js
+			addScript $ StaticR js_bootstrap_modal_js
+			$(widgetFile "page")
+		hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap")
+
+	{- Require an auth token be set when accessing any (non-static route) -}
+	isAuthorized _ _ = checkAuthToken secretToken
+
+	{- Add the auth token to every url generated, except static subsite
+         - urls (which can show up in Permission Denied pages). -}
+	joinPath = insertAuthToken secretToken excludeStatic
+		where
+			excludeStatic [] = True
+			excludeStatic (p:_) = p /= "static"
+
+	makeSessionBackend = webAppSessionBackend
+	jsLoader _ = BottomOfHeadBlocking
+
+data WebAppState = WebAppState
+	{ showIntro :: Bool
+	}
+
+newWebAppState :: IO (TMVar WebAppState)
+newWebAppState = liftIO $ atomically $
+	newTMVar $ WebAppState { showIntro = True }
+
+getWebAppState :: forall sub. GHandler sub WebApp WebAppState
+getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod
+
+modifyWebAppState :: forall sub. (WebAppState -> WebAppState) -> GHandler sub WebApp ()
+modifyWebAppState a = go =<< webAppState <$> getYesod
+	where
+		go s = liftIO $ atomically $ do
+			v <- takeTMVar s
+			putTMVar s $ a v
+
+waitNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> NotificationId -> GHandler sub WebApp ()
+waitNotifier selector nid = do
+	notifier <- getNotifier selector
+	liftIO $ waitNotification $ notificationHandleFromId notifier nid
+
+newNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationId
+newNotifier selector = do
+	notifier <- getNotifier selector
+	liftIO $ notificationHandleToId <$> newNotificationHandle notifier
+
+getNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationBroadcaster
+getNotifier selector = do
+	webapp <- getYesod
+	liftIO $ selector <$> getDaemonStatus (daemonStatus webapp)
+
+instance PathPiece NotificationId where
+    toPathPiece = pack . show
+    fromPathPiece = readish . unpack
+
+instance PathPiece AlertId where
+    toPathPiece = pack . show
+    fromPathPiece = readish . unpack
diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs
new file mode 100644
index 000000000..be6f12db3
--- /dev/null
+++ b/Assistant/WebApp/Configurators.hs
@@ -0,0 +1,56 @@
+{- git-annex assistant webapp configurators
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+
+module Assistant.WebApp.Configurators where
+
+import Assistant.Common
+import Assistant.WebApp
+import Assistant.WebApp.SideBar
+import Assistant.ThreadedMonad
+import Utility.Yesod
+import qualified Remote
+import Logs.Web (webUUID)
+import Logs.Trust
+import Annex.UUID (getUUID)
+
+import Yesod
+import Data.Text (Text)
+
+{- An intro message, list of repositories, and nudge to make more. -}
+introDisplay :: Text -> Widget
+introDisplay ident = do
+	webapp <- lift getYesod
+	let reldir = relDir webapp
+	l <- liftIO $ runThreadState (threadState webapp) $ do
+		u <- getUUID
+		rs <- map Remote.uuid <$> Remote.remoteList
+		rs' <- snd <$> trustPartition DeadTrusted rs
+		Remote.prettyListUUIDs $ filter (/= webUUID) $ nub $ u:rs'
+	let remotelist = zip counter l
+	let n = length l
+	let numrepos = show n
+	let notenough = n < 2
+	let barelyenough = n == 2
+	let morethanenough = n > 2
+	$(widgetFile "intro")
+	lift $ modifyWebAppState $ \s -> s { showIntro = False }
+	where
+		counter = map show ([1..] :: [Int])
+
+getConfigR :: Handler RepHtml
+getConfigR = defaultLayout $ do
+	sideBarDisplay
+	setTitle "Configuration"
+	[whamlet|<a href="@{HomeR}">main|]
+
+getAddRepositoryR :: Handler RepHtml
+getAddRepositoryR = defaultLayout $ do
+	sideBarDisplay
+	setTitle "Add repository"
+	[whamlet|<a href="@{HomeR}">main|]
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
new file mode 100644
index 000000000..5df68c93b
--- /dev/null
+++ b/Assistant/WebApp/DashBoard.hs
@@ -0,0 +1,89 @@
+{- git-annex assistant webapp dashboard
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+
+module Assistant.WebApp.DashBoard where
+
+import Assistant.Common
+import Assistant.WebApp
+import Assistant.WebApp.SideBar
+import Assistant.WebApp.Notifications
+import Assistant.WebApp.Configurators
+import Assistant.ThreadedMonad
+import Assistant.DaemonStatus
+import Assistant.TransferQueue
+import Utility.NotificationBroadcaster
+import Utility.Yesod
+import Logs.Transfer
+import Utility.Percentage
+import Utility.DataUnits
+import Types.Key
+import qualified Remote
+
+import Yesod
+import Text.Hamlet
+import qualified Data.Map as M
+
+{- A display of currently running and queued transfers.
+ -
+ - Or, if there have never been any this run, an intro display. -}
+transfersDisplay :: Bool -> Widget
+transfersDisplay warnNoScript = do
+	webapp <- lift getYesod
+	current <- liftIO $ runThreadState (threadState webapp) $
+		M.toList . currentTransfers
+			<$> liftIO (getDaemonStatus $ daemonStatus webapp)
+	queued <- liftIO $ getTransferQueue $ transferQueue webapp
+	let ident = "transfers"
+	autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
+	let transfers = current ++ queued
+	if null transfers
+		then ifM (lift $ showIntro <$> getWebAppState)
+			( introDisplay ident
+			, $(widgetFile "transfers")
+			)
+		else $(widgetFile "transfers")
+
+{- 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
+	waitNotifier transferNotifier nid
+
+	page <- widgetToPageContent $ transfersDisplay False
+	hamletToRepHtml $ [hamlet|^{pageBody page}|]
+
+{- The main dashboard. -}
+dashboard :: Bool -> Widget
+dashboard warnNoScript = do
+	sideBarDisplay
+	let content = transfersDisplay warnNoScript
+	$(widgetFile "dashboard")
+
+getHomeR :: Handler RepHtml
+getHomeR = defaultLayout $ dashboard True
+
+{- 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 False
+
+{- Same as HomeR, except no autorefresh at all (and no noscript warning). -}
+getNoScriptR :: Handler RepHtml
+getNoScriptR = defaultLayout $
+	dashboard False
diff --git a/Assistant/WebApp/Notifications.hs b/Assistant/WebApp/Notifications.hs
new file mode 100644
index 000000000..1e7c0176a
--- /dev/null
+++ b/Assistant/WebApp/Notifications.hs
@@ -0,0 +1,58 @@
+{- git-annex assistant webapp notifications
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+
+module Assistant.WebApp.Notifications where
+
+import Assistant.Common
+import Assistant.WebApp
+import Assistant.DaemonStatus
+import Utility.NotificationBroadcaster
+import Utility.Yesod
+
+import Yesod
+import Data.Text (Text)
+import qualified Data.Text as T
+
+{- Add to any widget to make it auto-update using long polling.
+ -
+ - The widget should have a html element with an id=ident, which will be
+ - replaced when it's updated.
+ -
+ - 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 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
diff --git a/Assistant/WebApp/SideBar.hs b/Assistant/WebApp/SideBar.hs
new file mode 100644
index 000000000..4df0c8d55
--- /dev/null
+++ b/Assistant/WebApp/SideBar.hs
@@ -0,0 +1,84 @@
+{- git-annex assistant webapp sidebar
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+
+module Assistant.WebApp.SideBar where
+
+import Assistant.Common
+import Assistant.WebApp
+import Assistant.WebApp.Notifications
+import Assistant.DaemonStatus
+import Assistant.Alert hiding (Widget)
+import Utility.NotificationBroadcaster
+import Utility.Yesod
+
+import Yesod
+import Data.Text (Text)
+import qualified Data.Map as M
+
+sideBarDisplay :: Widget
+sideBarDisplay = do
+	let content = do
+		{- Any yesod message appears as the first alert. -}
+		maybe noop rendermessage =<< lift getMessage
+	
+		{- Add newest alerts to the sidebar. -}
+		webapp <- lift getYesod
+		alertpairs <- M.toList . alertMap
+			<$> liftIO (getDaemonStatus $ daemonStatus webapp)
+		mapM_ renderalert $
+			take displayAlerts $ reverse $ sortAlertPairs alertpairs
+	let ident = "sidebar"
+	$(widgetFile "sidebar")
+	autoUpdate ident NotifierSideBarR (10 :: Int) (10 :: Int)
+	where
+		bootstrapclass Activity = "alert-info"
+		bootstrapclass Warning = "alert"
+		bootstrapclass Error = "alert-error"
+		bootstrapclass Success = "alert-success"
+		bootstrapclass Message = "alert-info"
+
+		renderalert (alertid, alert) = addalert
+			alertid
+			(alertClosable alert)
+			(alertBlockDisplay alert)
+			(bootstrapclass $ alertClass alert)
+			(alertHeader alert)
+			$ case alertMessage alert of
+				StringAlert s -> [whamlet|#{s}|]
+				WidgetAlert w -> w alert
+
+		rendermessage msg = addalert firstAlertId True False
+			"alert-info" Nothing [whamlet|#{msg}|]
+
+		addalert :: AlertId -> Bool -> Bool -> Text -> Maybe String -> Widget -> Widget
+		addalert i closable block divclass heading widget = do
+			let alertid = show i
+			let closealert = CloseAlert i
+			$(widgetFile "alert")
+
+{- 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
+	waitNotifier alertNotifier nid
+
+	page <- widgetToPageContent sideBarDisplay
+	hamletToRepHtml $ [hamlet|^{pageBody page}|]
+
+{- Called by the client to close an alert. -}
+getCloseAlert :: AlertId -> Handler ()
+getCloseAlert i = do
+	webapp <- getYesod
+	void $ liftIO $ removeAlert (daemonStatus webapp) i
diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes
new file mode 100644
index 000000000..75f1ad7c7
--- /dev/null
+++ b/Assistant/WebApp/routes
@@ -0,0 +1,13 @@
+/ HomeR GET
+/noscript NoScriptR GET
+/noscriptauto NoScriptAutoR GET
+/config ConfigR GET
+/addrepository AddRepositoryR GET
+
+/transfers/#NotificationId TransfersR GET
+/sidebar/#NotificationId SideBarR GET
+/notifier/transfers NotifierTransfersR GET
+/notifier/sidebar NotifierSideBarR GET
+/closealert/#AlertId CloseAlert GET
+
+/static StaticR Static getStatic