detect when unwanted remote is empty and remove it

Needs fixes to build when the webapp is disabled.

6 files changed, 119 insertions, 12 deletions

diff --git a/Assistant.hs b/Assistant.hs
index ebe1b92e3..ba2916fbf 100644
--- a/Assistant.hs
+++ b/Assistant.hs
@@ -238,7 +238,7 @@ startDaemon assistant foreground startbrowser = do
 #endif
 			, assist $ netWatcherThread
 			, assist $ netWatcherFallbackThread
-			, assist $ transferScannerThread
+			, assist $ transferScannerThread urlrenderer
 			, assist $ configMonitorThread
 			, assist $ glacierThread
 			, watch $ watchThread
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index 206694031..81dc362e4 100644
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@@ -34,6 +34,7 @@ data AlertName
 	| WarningAlert String
 	| PairAlert String
 	| XMPPNeededAlert
+	| RemoteRemovalAlert String
 	| CloudRepoNeededAlert
 	| SyncAlert
 	deriving (Eq)
@@ -351,6 +352,23 @@ cloudRepoNeededAlert friendname button = Alert
 	, alertData = []
 	}
 
+remoteRemovalAlert :: String -> AlertButton -> Alert
+remoteRemovalAlert desc button = Alert
+	{ alertHeader = Just $ fromString $
+		"The repository \"" ++ desc ++ 
+		"\" has been emptied, and can now be removed."
+	, alertIcon = Just InfoIcon
+	, alertPriority = High
+	, alertButton = Just button
+	, alertClosable = True
+	, alertClass = Message
+	, alertMessageRender = tenseWords
+	, alertBlockDisplay = True
+	, alertName = Just $ RemoteRemovalAlert desc
+	, alertCombiner = Just $ dataCombiner $ \_old new -> new
+	, alertData = []
+	}
+
 fileAlert :: TenseChunk -> FilePath -> Alert
 fileAlert msg file = (activityAlert Nothing [f])
 	{ alertName = Just $ FileAlert msg
diff --git a/Assistant/DeleteRemote.hs b/Assistant/DeleteRemote.hs
new file mode 100644
index 000000000..59aff57fe
--- /dev/null
+++ b/Assistant/DeleteRemote.hs
@@ -0,0 +1,52 @@
+{- git-annex assistant remote deletion utilities
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.DeleteRemote where
+
+import Assistant.Common
+import Assistant.WebApp
+import Assistant.WebApp.Types
+import Assistant.Alert
+import Assistant.DaemonStatus
+import qualified Remote
+import Remote.List
+import qualified Git.Command
+import Logs.Trust
+
+import qualified Data.Text as T
+
+{- Removes a remote (but leave the repository as-is), and returns the old
+ - Remote data. -}
+removeRemote :: UUID -> Assistant Remote
+removeRemote uuid = do
+	remote <- fromMaybe (error "unknown remote")
+		<$> liftAnnex (Remote.remoteFromUUID uuid)
+	liftAnnex $ do
+		inRepo $ Git.Command.run
+			[ Param "remote"
+			, Param "remove"
+			, Param (Remote.name remote)
+			]
+		void $ remoteListRefresh
+	updateSyncRemotes
+	return remote
+
+{- Called when a remote was marked as unwanted, and is now empty, so can be
+ - removed. -}
+finishRemovingRemote :: UrlRenderer -> UUID -> Assistant ()
+finishRemovingRemote urlrenderer uuid = do
+	void $ removeRemote uuid
+	liftAnnex $ trustSet uuid DeadTrusted
+
+	desc <- liftAnnex $ Remote.prettyUUID uuid
+	url <- liftIO $ renderUrl urlrenderer (FinishedDeletingRepositoryContentsR uuid) []
+	close <- asIO1 removeAlert
+	void $ addAlert $ remoteRemovalAlert desc $ AlertButton
+		{ buttonLabel = T.pack "Finish removal"
+		, buttonUrl = url
+		, buttonAction = Just close
+		}
diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs
index 4698a0d30..e0e42977a 100644
--- a/Assistant/Threads/TransferScanner.hs
+++ b/Assistant/Threads/TransferScanner.hs
@@ -8,14 +8,17 @@
 module Assistant.Threads.TransferScanner where
 
 import Assistant.Common
+import Assistant.WebApp
 import Assistant.Types.ScanRemotes
 import Assistant.ScanRemotes
 import Assistant.TransferQueue
 import Assistant.DaemonStatus
 import Assistant.Drop
 import Assistant.Sync
+import Assistant.DeleteRemote
 import Logs.Transfer
 import Logs.Location
+import Logs.Group
 import Logs.Web (webUUID)
 import qualified Remote
 import qualified Types.Remote as Remote
@@ -31,8 +34,8 @@ import qualified Data.Set as S
 {- This thread waits until a remote needs to be scanned, to find transfers
  - that need to be made, to keep data in sync.
  -}
-transferScannerThread :: NamedThread
-transferScannerThread = namedThread "TransferScanner" $ do
+transferScannerThread :: UrlRenderer -> NamedThread
+transferScannerThread urlrenderer = namedThread "TransferScanner" $ do
 	startupScan
 	go S.empty
   where
@@ -43,7 +46,7 @@ transferScannerThread = namedThread "TransferScanner" $ do
 		scanrunning True
 		if any fullScan infos || any (`S.notMember` scanned) rs
 			then do
-				expensiveScan rs
+				expensiveScan urlrenderer rs
 				go $ scanned `S.union` S.fromList rs
 			else do
 				mapM_ failedTransferScan rs
@@ -67,6 +70,8 @@ transferScannerThread = namedThread "TransferScanner" $ do
 	 - * We may have run before, and had transfers queued,
 	 -   and then the system (or us) crashed, and that info was
 	 -   lost.
+	 - * A remote may be in the unwanted group, and this is a chance
+	 -   to determine if the remote has been emptied.
 	 -}
 	startupScan = do
 		reconnectRemotes True =<< syncGitRemotes <$> getDaemonStatus
@@ -103,26 +108,46 @@ failedTransferScan r = do
  -
  - TODO: It would be better to first drop as much as we can, before
  - transferring much, to minimise disk use.
+ - 
+ - During the scan, we'll also check if any unwanted repositories are empty,
+ - and can be removed. While unrelated, this is a cheap place to do it,
+ - since we need to look at the locations of all keys anyway.
  -}
-expensiveScan :: [Remote] -> Assistant ()
-expensiveScan rs = unless onlyweb $ do
+expensiveScan :: UrlRenderer -> [Remote] -> Assistant ()
+expensiveScan urlrenderer rs = unless onlyweb $ do
 	debug ["starting scan of", show visiblers]
+
+	unwantedrs <- liftAnnex $ S.fromList
+		<$> filterM inUnwantedGroup (map Remote.uuid rs)
+
 	g <- liftAnnex gitRepo
 	(files, cleanup) <- liftIO $ LsFiles.inRepo [] g
-	forM_ files $ \f -> do
-		ts <- maybe (return []) (findtransfers f)
-			=<< liftAnnex (Backend.lookupFile f)
-		mapM_ (enqueue f) ts
+	removablers <- scan unwantedrs files
 	void $ liftIO cleanup
+
 	debug ["finished scan of", show visiblers]
+
+	nuke <- asIO1  $ finishRemovingRemote urlrenderer
+	liftIO $ forM_ (S.toList removablers) $
+		void . tryNonAsync . nuke
   where
 	onlyweb = all (== webUUID) $ map Remote.uuid rs
 	visiblers = let rs' = filter (not . Remote.readonly) rs
 		in if null rs' then rs else rs'
+
+	scan unwanted [] = return unwanted
+	scan unwanted (f:fs) = do
+		(unwanted', ts) <- maybe
+			(return (unwanted, []))
+			(findtransfers f unwanted)
+				=<< liftAnnex (Backend.lookupFile f)
+		mapM_ (enqueue f) ts
+		scan unwanted' fs
+
 	enqueue f (r, t) =
 		queueTransferWhenSmall "expensive scan found missing object"
 			(Just f) t r
-	findtransfers f (key, _) = do
+	findtransfers f unwanted (key, _) = do
 		{- The syncable remotes may have changed since this
 		 - scan began. -}
 		syncrs <- syncDataRemotes <$> getDaemonStatus
@@ -134,11 +159,13 @@ expensiveScan rs = unless onlyweb $ do
 		liftAnnex $ do
 			let slocs = S.fromList locs
 			let use a = return $ catMaybes $ map (a key slocs) syncrs
-			if present
+			ts <- if present
 				then filterM (wantSend True (Just f) . Remote.uuid . fst)
 					=<< use (genTransfer Upload False)
 				else ifM (wantGet True $ Just f)
 					( use (genTransfer Download True) , return [] )
+			let unwanted' = S.difference unwanted slocs
+			return (unwanted', ts)
 
 genTransfer :: Direction -> Bool -> Key -> S.Set UUID -> Remote -> Maybe (Remote, Transfer)
 genTransfer direction want key slocs r
diff --git a/Logs/Group.hs b/Logs/Group.hs
index c08feffde..85906f0a7 100644
--- a/Logs/Group.hs
+++ b/Logs/Group.hs
@@ -13,6 +13,7 @@ module Logs.Group (
 	groupMap,
 	groupMapLoad,
 	getStandardGroup,
+	inUnwantedGroup
 ) where
 
 import qualified Data.Map as M
@@ -74,3 +75,7 @@ getStandardGroup :: S.Set Group -> Maybe StandardGroup
 getStandardGroup s = case mapMaybe toStandardGroup $ S.toList s of
 	[g] -> Just g
 	_ -> Nothing
+
+inUnwantedGroup :: UUID -> Annex Bool
+inUnwantedGroup u = elem UnwantedGroup 
+	. mapMaybe toStandardGroup . S.toList <$> lookupGroups u
diff --git a/Remote.hs b/Remote.hs
index 7affb93af..27e69a5a0 100644
--- a/Remote.hs
+++ b/Remote.hs
@@ -28,6 +28,7 @@ module Remote (
 	byCost,
 	prettyPrintUUIDs,
 	prettyListUUIDs,
+	prettyUUID,
 	remoteFromUUID,
 	remotesWithUUID,
 	remotesWithoutUUID,
@@ -159,6 +160,10 @@ prettyListUUIDs uuids = do
 	  where
 		n = finddescription m u
 
+{- Nice display of a remote's name and/or description. -}
+prettyUUID :: UUID -> Annex String
+prettyUUID u = concat <$> prettyListUUIDs [u]
+
 {- Gets the remote associated with a UUID.
  - There's no associated remote when this is the UUID of the local repo. -}
 remoteFromUUID :: UUID -> Annex (Maybe Remote)