detect when unwanted remote is empty and remove it

Needs fixes to build when the webapp is disabled.

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

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

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
+		}

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 :: UrlRenderer -> NamedThread
-transferScannerThread = namedThread "TransferScanner" $ do
+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 :: UrlRenderer -> [Remote] -> Assistant ()
-expensiveScan rs = unless onlyweb $ do
+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
+	removablers <- scan unwantedrs files
-		ts <- maybe (return []) (findtransfers f)
-			=<< liftAnnex (Backend.lookupFile f)
-		mapM_ (enqueue f) ts
 	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

Assistant/WebApp/Configurators/AWS.hs

@@ -180,7 +180,7 @@ enableAWSRemote remotetype uuid = do
 			makeAWSRemote remotetype creds name (const noop) M.empty
 		_ -> do
 			description <- liftAnnex $
-				T.pack . concat <$> Remote.prettyListUUIDs [uuid]
+				T.pack <$> Remote.prettyUUID uuid
 			$(widgetFile "configurators/enableaws")
 
 makeAWSRemote :: RemoteType -> AWSCreds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()

Assistant/WebApp/Configurators/Delete.hs

@@ -10,28 +10,29 @@
 module Assistant.WebApp.Configurators.Delete where
 
 import Assistant.WebApp.Common
+import Assistant.DeleteRemote
 import Assistant.WebApp.Utility
 import Assistant.DaemonStatus
 import Assistant.ScanRemotes
 import qualified Remote
-import Remote.List (remoteListRefresh)
-import qualified Git.Command
 import qualified Git
 import Locations.UserConfig
 import Utility.FileMode
 import Logs.Trust
+import Logs.Remote
 import Logs.PreferredContent
 import Types.StandardGroups
 
-import qualified Data.Text as T
 import System.IO.HVFS (SystemFS(..))
+import qualified Data.Text as T
+import qualified Data.Map as M
 
 getDeleteRepositoryR :: UUID -> Handler RepHtml
 getDeleteRepositoryR uuid = go =<< liftAnnex (Remote.remoteFromUUID uuid)
   where
   	go Nothing = redirect DeleteCurrentRepositoryR
 	go (Just r) = deletionPage $ do
-		reponame <- liftAnnex $ concat <$> Remote.prettyListUUIDs [uuid]
+		reponame <- liftAnnex $ Remote.prettyUUID uuid
 		$(widgetFile "configurators/delete/choose")
 
 getDeleteRepositoryFromListR :: UUID -> Handler RepHtml
@@ -39,20 +40,6 @@ getDeleteRepositoryFromListR uuid = do
 	void $ liftAssistant $ removeRemote uuid
 	redirect DashboardR
 
-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
-
 getStartDeleteRepositoryContentsR :: UUID -> Handler RepHtml
 getStartDeleteRepositoryContentsR uuid = deletionPage $ do
 	remote <- fromMaybe (error "unknown remote")
@@ -62,9 +49,16 @@ getStartDeleteRepositoryContentsR uuid = deletionPage $ do
 		setStandardGroup uuid UnwantedGroup
 	liftAssistant $ addScanRemotes True [remote]
 
-	reponame <- liftAnnex $ concat <$> Remote.prettyListUUIDs [uuid]
+	reponame <- liftAnnex $ Remote.prettyUUID uuid
 	$(widgetFile "configurators/delete/started")
 
+getFinishedDeletingRepositoryContentsR :: UUID -> Handler RepHtml
+getFinishedDeletingRepositoryContentsR uuid = deletionPage $ do
+	reponame <- liftAnnex $ Remote.prettyUUID uuid
+	{- If it's not listed in the remote log, it must be a git repo. -}
+	gitrepo <- liftAnnex $ M.notMember uuid <$> readRemoteLog
+	$(widgetFile "configurators/delete/finished")	
+
 getDeleteCurrentRepositoryR :: Handler RepHtml
 getDeleteCurrentRepositoryR = deleteCurrentRepository
 

Assistant/WebApp/Configurators/Local.hs

@@ -27,7 +27,7 @@ import Utility.Mounts
 import Utility.DiskFree
 import Utility.DataUnits
 import Utility.Network
-import Remote (prettyListUUIDs)
+import Remote (prettyUUID)
 import Annex.UUID
 import Types.StandardGroups
 import Logs.PreferredContent
@@ -261,8 +261,7 @@ combineRepos dir name = liftAnnex $ do
 
 getEnableDirectoryR :: UUID -> Handler RepHtml
 getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do
-	description <- liftAnnex $
+	description <- liftAnnex $ T.pack <$> prettyUUID uuid
-		T.pack . concat <$> prettyListUUIDs [uuid]
 	$(widgetFile "configurators/enabledirectory")
 
 {- List of removable drives. -}

Assistant/WebApp/Configurators/Ssh.hs

@@ -148,8 +148,7 @@ postEnableRsyncR u = do
 		_ -> redirect AddSshR
   where
 	showform form enctype status = do
-		description <- liftAnnex $
+		description <- liftAnnex $ T.pack <$> prettyUUID u
-			T.pack . concat <$> prettyListUUIDs [u]
 		$(widgetFile "configurators/ssh/enable")
 	enable sshdata = lift $ redirect $ ConfirmSshR $
 		sshdata { rsyncOnly = True }

Assistant/WebApp/Configurators/WebDAV.hs

@@ -113,7 +113,7 @@ postEnableWebDAVR uuid = do
 				makeWebDavRemote name (toCredPair input) (const noop) M.empty
 			_ -> do
 				description <- liftAnnex $
-					T.pack . concat <$> Remote.prettyListUUIDs [uuid]
+					T.pack <$> Remote.prettyUUID uuid
 				$(widgetFile "configurators/enablewebdav")
 #else
 postEnableWebDAVR _ = error "WebDAV not supported by this build"

Assistant/WebApp/routes

@@ -29,10 +29,6 @@
 /config/repository/edit/new/cloud/#UUID EditNewCloudRepositoryR GET POST
 /config/repository/sync/disable/#UUID DisableSyncR GET
 /config/repository/sync/enable/#UUID EnableSyncR GET
-/config/repository/delete/choose/#UUID DeleteRepositoryR GET
-/config/repository/delete/fromlist/#UUID DeleteRepositoryFromListR GET
-/config/repository/delete/contents/start/#UUID StartDeleteRepositoryContentsR GET
-/config/repository/delete/here DeleteCurrentRepositoryR GET POST
 
 /config/repository/add/drive AddDriveR GET POST
 /config/repository/add/drive/confirm/#RemovableDrive ConfirmAddDriveR GET
@@ -47,6 +43,12 @@
 /config/repository/add/cloud/glacier AddGlacierR GET POST
 /config/repository/add/cloud/box.com AddBoxComR GET POST
 
+/config/repository/delete/choose/#UUID DeleteRepositoryR GET
+/config/repository/delete/fromlist/#UUID DeleteRepositoryFromListR GET
+/config/repository/delete/contents/start/#UUID StartDeleteRepositoryContentsR GET
+/config/repository/delete/contents/finish/#UUID FinishedDeletingRepositoryContentsR GET
+/config/repository/delete/here DeleteCurrentRepositoryR GET POST
+
 /config/repository/pair/local/start StartLocalPairR GET POST
 /config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET
 /config/repository/pair/local/finish/#PairMsg FinishLocalPairR GET POST

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

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)

templates/configurators/delete/finished.hamlet

@@ -0,0 +1,14 @@
+<div .span9 .hero-unit>
+  <h2>
+    Repository removed
+  <p>
+    As much data as possible has been removed from the repository
+    "#{reponame}", and it has been removed from the list of repositories.
+  <p>
+    $if gitrepo
+     <div .alert>
+       Since "#{reponame}" is a git repository, it still contains
+       some data. To completely remove it, you should go delete that git
+       repository.
+    $else
+      Now you can go go delete the underlying storage of the repository.