diff options
author | Joey Hess <joey@kitenet.net> | 2012-07-31 01:11:32 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-07-31 01:11:32 -0400 |
commit | 58dfa3fa5b1b8be6f344e9ef5bfb3adda11069ab (patch) | |
tree | 7cdc7977971c2501d485dc793b9bb47a6902b4e0 /Assistant/WebApp/DashBoard.hs | |
parent | 6e40aed948c44348c977bb7ed7a9a6a84b9972ba (diff) |
split up webapp files
Diffstat (limited to 'Assistant/WebApp/DashBoard.hs')
-rw-r--r-- | Assistant/WebApp/DashBoard.hs | 89 |
1 files changed, 89 insertions, 0 deletions
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 |