webapp: Add UI to stop assistant.

Would like to also have restart UI, but that's rather harder to do,
seems it'd need to start another copy of the webapp, and redirect the
browser to its new url, but running two assistants in the same repo at
the same time isn't good.

Assistant/Threads/WebApp.hs

@@ -25,6 +25,7 @@ import Assistant.WebApp.Configurators.AWS
 import Assistant.WebApp.Configurators.WebDAV
 import Assistant.WebApp.Configurators.XMPP
 import Assistant.WebApp.Documentation
+import Assistant.WebApp.Control
 import Assistant.WebApp.OtherRepos
 import Assistant.Types.ThreadedMonad
 import Utility.WebApp

Assistant/WebApp.hs

@@ -25,7 +25,9 @@ inFirstRun = isNothing . relDir <$> getYesod
 
 newWebAppState :: IO (TMVar WebAppState)
 newWebAppState = do
-	otherrepos <- listOtherRepos
+	cwd <- getCurrentDirectory
+	otherrepos <- filter (\p -> not (snd p `dirContains` cwd))
+		<$> listRepos
 	atomically $ newTMVar $ WebAppState
 		{ showIntro = True
 		, otherRepos = otherrepos }
@@ -101,14 +103,13 @@ redirectBack = do
 	setUltDestReferer
 	redirectUltDest HomeR
 
-{- List of other known repsitories, and link to add a new one. -}
-otherReposWidget :: Widget
-otherReposWidget = do
+controlMenu :: Widget
+controlMenu = do
 	repolist <- lift $ otherRepos <$> getWebAppState
-	$(widgetFile "otherrepos")
+	$(widgetFile "controlmenu")
 
-listOtherRepos :: IO [(String, String)]
-listOtherRepos = do
+listRepos :: IO [(String, String)]
+listRepos = do
 	f <- autoStartFile
 	dirs <- nub <$> ifM (doesFileExist f) ( lines <$> readFile f, return [])
 	names <- mapM relHome dirs

Assistant/WebApp/Control.hs

@@ -0,0 +1,28 @@
+{- git-annex assistant webapp control
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+
+module Assistant.WebApp.Control where
+
+import Assistant.WebApp.Common
+
+import Control.Concurrent
+import System.Posix (getProcessID, signalProcess, sigTERM)
+
+getShutdownR :: Handler RepHtml
+getShutdownR = page "Shutdown" Nothing $
+	$(widgetFile "control/shutdown")
+
+getShutdownConfirmedR :: Handler RepHtml
+getShutdownConfirmedR = page "Shutdown" Nothing $ do
+	{- Wait 2 seconds before shutting down, to give the web page time
+	 - to display. -}
+	void $ liftIO $ forkIO $ do
+		threadDelay 2000000
+		signalProcess sigTERM =<< getProcessID
+	$(widgetFile "control/shutdownconfirmed")

Assistant/WebApp/routes

@@ -5,6 +5,9 @@
 /about/license LicenseR GET
 /about/repogroups RepoGroupR GET
 
+/shutdown ShutdownR GET
+/shutdown/confirm ShutdownConfirmedR GET
+
 /config ConfigurationR GET
 /config/repository RepositoriesR GET
 /config/xmpp XMPPR GET

debian/changelog

@@ -1,3 +1,9 @@
+git-annex (3.20130103) UNRELEASED; urgency=low
+
+  * webapp: Add UI to stop assistant.
+
+ -- Joey Hess <joeyh@debian.org>  Thu, 03 Jan 2013 14:58:45 -0400
+
 git-annex (3.20130102) unstable; urgency=low
 
   * direct, indirect: New commands, that switch a repository to and from

templates/control/shutdown.hamlet

@@ -0,0 +1,8 @@
+<div .span9 .hero-unit>
+  <h2>
+    Shutdown daemon?
+  <p>
+    <a .btn .btn-danger href="@{ShutdownConfirmedR}">
+      <i .icon-off></i> Confirm shutdown
+    <a .btn href="@{HomeR}">
+      Keep running

templates/control/shutdownconfirmed.hamlet

@@ -0,0 +1,2 @@
+<div .span9 .hero-unit>
+  Shutting down...

templates/controlmenu.hamlet

@@ -2,9 +2,11 @@
   $forall (name, path) <- repolist
     <li>
       <a href="@{SwitchToRepositoryR path}">
-        #{name}
+        <i .icon-folder-close></i> #{name}
   $if not (null repolist)
     <li .divider></li>
   <li>
     <a href="@{NewRepositoryR}">
-      Add another repository
+      <i .icon-plus-sign></i> Add another repository
+    <a href="@{ShutdownR}">
+      <i .icon-off></i> Shut down

templates/page.hamlet

@@ -16,7 +16,7 @@
             <a .dropdown-toggle data-toggle="dropdown" href="#menu1">
               Current Repository: #{reldir}
               <b .caret></b>
-            ^{otherReposWidget}
+            ^{controlMenu}
       $nothing
 <div .container-fluid>
   <div .row-fluid>