summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-07-31 01:11:32 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-07-31 01:11:32 -0400
commit58dfa3fa5b1b8be6f344e9ef5bfb3adda11069ab (patch)
tree7cdc7977971c2501d485dc793b9bb47a6902b4e0
parent6e40aed948c44348c977bb7ed7a9a6a84b9972ba (diff)
split up webapp files
-rw-r--r--Assistant/Threads/WebApp.hs304
-rw-r--r--Assistant/WebApp.hs106
-rw-r--r--Assistant/WebApp/Configurators.hs56
-rw-r--r--Assistant/WebApp/DashBoard.hs89
-rw-r--r--Assistant/WebApp/Notifications.hs58
-rw-r--r--Assistant/WebApp/SideBar.hs84
-rw-r--r--Assistant/WebApp/routes13
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