allow disabling syncing to a repo on its edit form

This is not quite right yet, since it disables it so hard it doesn't show
up in the repo list anymore!

Assistant/WebApp/Configurators/Edit.hs

@@ -13,12 +13,22 @@ import Assistant.Common
 import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
+import Assistant.WebApp.Configurators.Local (syncRemote)
+import Assistant.WebApp.DashBoard (cancelTransfer)
+import Assistant.DaemonStatus
+import Assistant.TransferQueue
+import Assistant.ThreadedMonad
 import Utility.Yesod
 import qualified Remote
+import qualified Remote.List as Remote
+import qualified Types.Remote as Remote
 import Logs.UUID
 import Logs.Group
 import Logs.PreferredContent
+import Logs.Transfer
 import Types.StandardGroups
+import Config
+import Annex.UUID
 
 import Yesod
 import Data.Text (Text)
@@ -32,31 +42,69 @@ data RepoGroup = RepoGroupCustom String | RepoGroupStandard StandardGroup
 data RepoConfig = RepoConfig
 	{ repoDescription :: Text
 	, repoGroup :: RepoGroup
+	, repoEnabled :: Bool
 	}
 	deriving (Show)
 
-getRepoConfig :: UUID -> Annex RepoConfig
+getRepoConfig :: Remote -> Annex RepoConfig
-getRepoConfig uuid = RepoConfig
+getRepoConfig r = RepoConfig
 	<$> (T.pack . fromMaybe "" . M.lookup uuid <$> uuidMap)
 	<*> getrepogroup
+	<*> (thisrepo <||> (elem r <$> Remote.enabledRemoteList))
 	where
 		getrepogroup = do
 			groups <- lookupGroups uuid
 			return $ 
 				maybe (RepoGroupCustom $ unwords $ S.toList groups) RepoGroupStandard
 					(getStandardGroup groups)
+		thisrepo = (==) uuid <$> getUUID
+		uuid = Remote.uuid r
 
-setRepoConfig :: UUID -> RepoConfig -> Annex ()
+{- Returns Just False if the repository has been disabled,
-setRepoConfig uuid c = do
+ - or Just True when enabled. -}
+setRepoConfig :: Remote -> RepoConfig -> Annex (Maybe Bool)
+setRepoConfig r c = do
 	describeUUID uuid $ T.unpack $ repoDescription c
 	case repoGroup c of
 		RepoGroupStandard g -> setStandardGroup uuid g
 		RepoGroupCustom s -> groupSet uuid $ S.fromList $ words s
+	ifM ((==) uuid <$> getUUID)
+		( return Nothing
+		, do
+			enabled <- elem r <$> Remote.enabledRemoteList
+			if (enabled /= repoEnabled c)
+				then do
+					setConfig annex_ignore $
+						if enabled then "true" else "false"
+					void $ Remote.remoteListRefresh
+					return $ Just $ repoEnabled c
+				else return Nothing
+		)
+	where
+		uuid = Remote.uuid r
+		annex_ignore = remoteConfig (Remote.repo r) "ignore"
+
+changeEnabled :: Remote -> Bool -> Handler ()
+changeEnabled r True = syncRemote r
+changeEnabled r False = do
+	webapp <- getYesod
+	let dstatus = daemonStatus webapp
+	let st = fromJust $ threadState webapp
+	liftIO $ runThreadState st $ updateKnownRemotes dstatus
+	{- Stop all transfers to or from this disabled remote.
+	 - XXX Can't stop any ongoing scan, or git syncs. -}
+	void $ liftIO $ dequeueTransfers (transferQueue webapp) dstatus tofrom
+	mapM_ (cancelTransfer False) =<<
+		filter tofrom . M.keys <$>
+			liftIO (currentTransfers <$> getDaemonStatus dstatus)
+	where
+		tofrom t = transferUUID t == Remote.uuid r
 
 editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig
 editRepositoryAForm def = RepoConfig
 	<$> areq textField "Description" (Just $ repoDescription def)
 	<*> areq (selectFieldList $ customgroups++standardgroups) "Repository group" (Just $ repoGroup def)
+	<*> areq checkBoxField "Syncing enabled" (Just $ repoEnabled def)
 	where
 		standardgroups :: [(Text, RepoGroup)]
 		standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g))
@@ -71,12 +119,15 @@ getEditRepositoryR uuid = bootstrap (Just Config) $ do
 	sideBarDisplay
 	setTitle "Configure repository"
 
-	curr <- lift $ runAnnex undefined $ getRepoConfig uuid
+	r <- lift $ fromMaybe (error "Unknown UUID") . M.lookup uuid
+		<$> runAnnex M.empty (Remote.remoteMap id)
+	curr <- lift $ runAnnex undefined $ getRepoConfig r
 	((result, form), enctype) <- lift $
 		runFormGet $ renderBootstrap $ editRepositoryAForm curr
 	case result of
 		FormSuccess input -> lift $ do
-			runAnnex undefined $ setRepoConfig uuid input
+			maybe noop (changeEnabled r) =<<
+				runAnnex undefined (setRepoConfig r input)
 			redirect RepositoriesR
 		_ -> showform form enctype
 	where

Assistant/WebApp/DashBoard.hs

@@ -166,7 +166,7 @@ postCancelTransferR t = cancelTransfer False t
 pauseTransfer :: Transfer -> Handler ()
 pauseTransfer = cancelTransfer True
 
-cancelTransfer :: Bool -> Transfer-> Handler ()
+cancelTransfer :: Bool -> Transfer -> Handler ()
 cancelTransfer pause t = do
 	webapp <- getYesod
 	let dstatus = daemonStatus webapp

debian/changelog

@@ -9,6 +9,8 @@ git-annex (3.20121010) UNRELEASED; urgency=low
   * Makefile: Avoid building with -threaded if the ghc threaded runtime does
     not exist.
   * webapp: Improve wording of intro display. Closes: #689848
+  * webapp: Repositories can now be configured, to change their description,
+    their group, or even to disable syncing to them.
 
  -- Joey Hess <joeyh@debian.org>  Wed, 10 Oct 2012 12:59:25 -0400
 

templates/configurators/editrepository.hamlet

@@ -1,6 +1,6 @@
 <div .span9 .hero-unit>
   <h2>
-    Configuring #{description}
+    Configuring repository: #{description}
   <p>
     <form .form-horizontal enctype=#{enctype}>
       <fieldset>