add a navbar button that opens the repo in the desktop's native file browser

This should work on linux (xdg-open) and OSX (open). If the program
is not in $PATH, it falls back to opening a browser window/tab with file:///

The only tricky bit is the javascript code, that handles clicking on the
link. This is to avoid unnecessary page refreshes. Until I added the
return false at the end, the <a>'s normal click event also fired, so two
file browsers opened. I have not checked portability extensively.

3 files changed, 38 insertions, 2 deletions

diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs
index 1b767c642..4042d410e 100644
--- a/Assistant/WebApp.hs
+++ b/Assistant/WebApp.hs
@@ -63,7 +63,7 @@ selectNavBar :: Handler [NavBarItem]
 selectNavBar = ifM (inFirstRun) (return firstRunNavBar, return defaultNavBar)
 
 inFirstRun :: Handler Bool
-inFirstRun = isNothing . threadState <$> getYesod
+inFirstRun = isNothing . relDir <$> getYesod
 
 {- Used instead of defaultContent; highlights the current page if it's
  - on the navbar. -}
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
index f4f56a476..a1e499d70 100644
--- a/Assistant/WebApp/DashBoard.hs
+++ b/Assistant/WebApp/DashBoard.hs
@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
 
 module Assistant.WebApp.DashBoard where
 
@@ -23,6 +23,7 @@ import Utility.Percentage
 import Utility.DataUnits
 import Types.Key
 import qualified Remote
+import qualified Git
 
 import Yesod
 import Text.Hamlet
@@ -88,3 +89,37 @@ getNoScriptAutoR = bootstrap (Just DashBoard) $ do
 	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). -}
+openFileBrowser :: Handler Bool
+openFileBrowser = do
+	path <- runAnnex (error "no configured repository") $
+		fromRepo Git.repoPath
+	ifM (liftIO $ inPath cmd <&&> boolSystem cmd [File path])
+		( return True
+		, do
+			clearUltDest
+			setUltDest $ "file://" ++ path
+			void $ redirectUltDest HomeR
+			return False
+		)
+	where
+#if OSX
+		cmd = "open"
+#else
+		cmd = "xdg-open"
+#endif
diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes
index 95813edb6..192e1cd6b 100644
--- a/Assistant/WebApp/routes
+++ b/Assistant/WebApp/routes
@@ -11,5 +11,6 @@
 /notifier/transfers NotifierTransfersR GET
 /notifier/sidebar NotifierSideBarR GET
 /closealert/#AlertId CloseAlert GET
+/filebrowser FileBrowserR GET POST
 
 /static StaticR Static getStatic