1 files changed, 132 insertions, 0 deletions
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
new file mode 100644
index 000000000..8e526fb1d
--- /dev/null
+++ b/Assistant/WebApp/DashBoard.hs
@@ -0,0 +1,132 @@
+{- git-annex assistant webapp dashboard
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP, 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.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 qualified Git
+
+import Yesod
+import Text.Hamlet
+import qualified Data.Map as M
+import Control.Concurrent
+
+{- 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 <- lift $ runAnnex [] $
+		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 "dashboard/transfers")
+			)
+		else $(widgetFile "dashboard/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/main")
+
+getHomeR :: Handler RepHtml
+getHomeR = ifM (inFirstRun)
+	( redirect ConfigR
+	, bootstrap (Just DashBoard) $ dashboard True
+	)
+
+{- Same as HomeR, except no autorefresh at all (and no noscript warning). -}
+getNoScriptR :: Handler RepHtml
+getNoScriptR = bootstrap (Just DashBoard) $ dashboard False
+
+{- Same as HomeR, except with autorefreshing via meta refresh. -}
+getNoScriptAutoR :: Handler RepHtml
+getNoScriptAutoR = bootstrap (Just DashBoard) $ do
+	let ident = NoScriptR
+	let delayseconds = 3 :: Int
+	let this = NoScriptAutoR
+	toWidgetHead $(hamletFile $ hamletTemplate "dashboard/metarefresh")
+	dashboard False
+
+{- The javascript code does a post. -}
+postFileBrowserR :: Handler ()
+postFileBrowserR = void openFileBrowser
+
+{- Used by non-javascript browsers, where clicking on the link actually
+ - opens this page, so we redirect back to the referrer. -}
+getFileBrowserR :: Handler ()
+getFileBrowserR = whenM openFileBrowser $ do
+	clearUltDest
+	setUltDestReferer
+	redirectUltDest HomeR
+
+{- Opens the system file browser on the repo, or, as a fallback,
+ - goes to a file:// url. Returns True if it's ok to redirect away
+ - from the page (ie, the system file browser was opened). 
+ -
+ - Note that the command is opened using a different thread, to avoid
+ - blocking the response to the browser on it. -}
+openFileBrowser :: Handler Bool
+openFileBrowser = do
+	path <- runAnnex (error "no configured repository") $
+		fromRepo Git.repoPath
+	ifM (liftIO $ inPath cmd <&&> inPath cmd)
+		( do
+			void $ liftIO $ forkIO $ void $
+				boolSystem cmd [Param path]
+			return True
+		, do
+			clearUltDest
+			setUltDest $ "file://" ++ path
+			void $ redirectUltDest HomeR
+			return False
+		)
+	where
+#if OSX
+		cmd = "open"
+#else
+		cmd = "xdg-open"
+#endif