From f7f34d20721f11e977ae5fd9dc3f184b422a42e2 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 18 Oct 2012 14:55:59 -0400
Subject: [PATCH] drop unwanted content in the transfer scan

This was complicated quite a bit by needing to check numcopies. I optimised
that, so it only looks up numcopies once per file, no matter how many
remotes it checks to drop from. Although it did just occur to me that
it might be better to first check if it wants to drop content, and only
then check numcopies..
---
 Assistant/Threads/TransferScanner.hs       | 67 ++++++++++++++++++----
 Command/Drop.hs                            |  2 +-
 doc/design/assistant/transfer_control.mdwn |  2 +-
 3 files changed, 57 insertions(+), 14 deletions(-)

diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs
index a664f31124..6606bdc35b 100644
--- a/Assistant/Threads/TransferScanner.hs
+++ b/Assistant/Threads/TransferScanner.hs
@@ -15,14 +15,17 @@ import Assistant.DaemonStatus
 import Assistant.Alert
 import Logs.Transfer
 import Logs.Location
+import Logs.Trust
 import Logs.Web (webUUID)
 import qualified Remote
 import qualified Types.Remote as Remote
 import Utility.ThreadScheduler
 import qualified Git.LsFiles as LsFiles
+import qualified Command.Drop
 import Command
 import Annex.Content
 import Annex.Wanted
+import Config
 
 import qualified Data.Set as S
 
@@ -118,27 +121,67 @@ expensiveScan st dstatus transferqueue rs = unless onlyweb $ do
 			debug thisThread ["queuing", show t]
 			queueTransferWhenSmall transferqueue dstatus (Just f) t r
 		findtransfers f (key, _) = do
-			locs <- S.fromList <$> loggedLocations key
-			{- Queue transfers from any syncable remote. The
-			 - syncable remotes may have changed since this
+			locs <- loggedLocations key
+			{- The syncable remotes may have changed since this
 			 - scan began. -}
-			let use a = do
-				syncrs <- liftIO $ syncRemotes <$> getDaemonStatus dstatus
-				return $ catMaybes $ map (a key locs) syncrs
-			ifM (inAnnex key)
-				( filterM (wantSend (Just f) . Remote.uuid . fst)
+			syncrs <- liftIO $ syncRemotes <$> getDaemonStatus dstatus
+			present <- inAnnex key
+
+			handleDrops locs syncrs present f key
+
+			let slocs = S.fromList locs
+			let use a = return $ catMaybes $ map (a key slocs) syncrs
+			if present
+				then filterM (wantSend (Just f) . Remote.uuid . fst)
 					=<< use (genTransfer Upload False)
-				, ifM (wantGet $ Just f)
+				else ifM (wantGet $ Just f)
 					( use (genTransfer Download True) , return [] )
-				)
 
 genTransfer :: Direction -> Bool -> Key -> S.Set UUID -> Remote -> Maybe (Remote, Transfer)
-genTransfer direction want key locs r
+genTransfer direction want key slocs r
 	| direction == Upload && Remote.readonly r = Nothing
-	| (S.member (Remote.uuid r) locs) == want = Just
+	| (S.member (Remote.uuid r) slocs) == want = Just
 		(r, Transfer direction (Remote.uuid r) key)
 	| otherwise = Nothing
 
+{- Drop from local or remote when allowed by the preferred content and
+ - numcopies settings. -}
+handleDrops :: [UUID] -> [Remote] -> Bool -> FilePath -> Key -> Annex ()
+handleDrops locs rs present f key
+	| present = do
+		n <- getcopies
+		if checkcopies n
+			then go rs =<< dropl n
+			else go rs n
+	| otherwise = go rs =<< getcopies
+	where
+		getcopies = do
+			have <- length . snd <$> trustPartition UnTrusted locs
+			numcopies <- getNumCopies =<< numCopies f
+			return (have, numcopies)
+		checkcopies (have, numcopies) = have > numcopies
+		decrcopies (have, numcopies) = (have - 1, numcopies)
+
+		go [] _ = noop
+		go (r:rest) n
+			| checkcopies n = dropr r n >>= go rest
+			| otherwise = noop
+
+		checkdrop n@(_, numcopies) u a = 
+			ifM (wantDrop u (Just f))
+				( ifM (doCommand $ a (Just numcopies))
+					( return $ decrcopies n
+					, return n
+					)
+				, return n
+				)
+
+		dropl n = checkdrop n Nothing $ \numcopies ->
+			Command.Drop.startLocal f numcopies key
+
+		dropr r n  = checkdrop n (Just $ Remote.uuid r) $ \numcopies ->
+			Command.Drop.startRemote f numcopies key r
+
 remoteHas :: Remote -> Key -> Annex Bool
 remoteHas r key = elem
 	<$> pure (Remote.uuid r)
diff --git a/Command/Drop.hs b/Command/Drop.hs
index 26e80f8e55..9e58701dbd 100644
--- a/Command/Drop.hs
+++ b/Command/Drop.hs
@@ -48,7 +48,7 @@ startLocal file numcopies key = stopUnless (inAnnex key) $ do
 
 startRemote :: FilePath -> Maybe Int -> Key -> Remote -> CommandStart
 startRemote file numcopies key remote = do
-	showStart "drop" file
+	showStart ("drop " ++ Remote.name remote) file
 	next $ performRemote key numcopies remote
 
 performLocal :: Key -> Maybe Int -> CommandPerform
diff --git a/doc/design/assistant/transfer_control.mdwn b/doc/design/assistant/transfer_control.mdwn
index 8f8dad556b..54b7a30c22 100644
--- a/doc/design/assistant/transfer_control.mdwn
+++ b/doc/design/assistant/transfer_control.mdwn
@@ -30,7 +30,7 @@ the same content, this gets tricky. Let's assume there are not.)
 1. The preferred content expression can change, or a new repo is added, or
    groups change. Generally, some change to global annex state. Only way to deal
    with this is an expensive scan. (The rest of the items below come from
-   analizing the terminals used in preferred content expressions.)
+   analizing the terminals used in preferred content expressions.) **done**
 2. renaming of a file (ie, moved to `archive/`)
 3. some other repository gets the file (`in`, `copies`)
 4. some other repository drops the file (`in`, `copies` .. However, it's