assistant: Now honors preferred content settings when deciding what to transfer.

Both when queueing downloads, and uploads, consults the preferred content
settings.

I didn't make it check yet when requeing failed transfers or queuing
deferred downloads; dealing with the preferred content settings (or indeed,
other settings) changing while the assistant is running still needs work.

Annex/Wanted.hs

@@ -10,7 +10,6 @@ module Annex.Wanted where
 import Common.Annex
 import Logs.PreferredContent
 import Git.FilePath
-import qualified Annex
 import Annex.UUID
 import Types.Remote
 
@@ -24,9 +23,9 @@ wantGet (Just file) = do
 	isPreferredContent Nothing S.empty fp
 
 {- Check if a file is preferred content for a remote. -}
-wantSend :: UUID -> AssociatedFile -> Annex Bool
+wantSend :: AssociatedFile -> UUID -> Annex Bool
-wantSend _ Nothing = return True
+wantSend Nothing _ = return True
-wantSend to (Just file) = do
+wantSend (Just file) to = do
 	fp <- inRepo $ toTopFilePath file
 	isPreferredContent (Just to) S.empty fp
 

Assistant/Threads/Committer.hs

@@ -210,7 +210,7 @@ handleAdds delayadd st changechan transferqueue dstatus cs = returnWhen (null in
 				sha <- inRepo $
 					Git.HashObject.hashObject BlobObject link
 				stageSymlink file sha
-			queueTransfers Next transferqueue dstatus key (Just file) Upload
+			queueTransfers Next transferqueue dstatus st key (Just file) Upload
 			showEndOk
 			return $ Just change
 

Assistant/Threads/TransferScanner.hs

@@ -22,6 +22,7 @@ import Utility.ThreadScheduler
 import qualified Git.LsFiles as LsFiles
 import Command
 import Annex.Content
+import Annex.Wanted
 
 import qualified Data.Set as S
 
@@ -105,18 +106,20 @@ expensiveScan st dstatus transferqueue rs = unless onlyweb $ do
 			in if null rs' then rs else rs'
 		go [] = noop
 		go (f:fs) = do
-			mapM_ (enqueue f) =<< catMaybes <$> runThreadState st
+			mapM_ (enqueue f) =<< runThreadState st
-				(ifAnnexed f findtransfers $ return [])
+				(ifAnnexed f (findtransfers f) $ return [])
 			go fs
 		enqueue f (r, t) = do
 			debug thisThread ["queuing", show t]
 			queueTransferWhenSmall transferqueue dstatus (Just f) t r
-		findtransfers (key, _) = do
+		findtransfers f (key, _) = do
 			locs <- loggedLocations key
-			let use a = return $ map (a key locs) rs
+			let use a = return $ catMaybes $ map (a key locs) rs
 			ifM (inAnnex key)
-				( use $ check Upload False
+				( filterM (wantSend (Just f) . Remote.uuid . fst)
-				, use $ check Download True
+					=<< use (check Upload False)
+				, ifM (wantGet $ Just f)
+					( use (check Download True) , return [] )
 				)
 		check direction want key locs r
 			| direction == Upload && Remote.readonly r = Nothing

Assistant/TransferQueue.hs

@@ -27,6 +27,7 @@ import Logs.Transfer
 import Types.Remote
 import qualified Remote
 import qualified Types.Remote as Remote
+import Annex.Wanted
 
 import Control.Concurrent.STM
 import qualified Data.Map as M
@@ -56,22 +57,26 @@ stubInfo f r = stubTransferInfo
 	, associatedFile = f
 	}
 
-{- Adds transfers to queue for some of the known remotes. -}
+{- Adds transfers to queue for some of the known remotes.
+ - Honors preferred content settings, only transferring wanted files. -}
 queueTransfers :: Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> AssociatedFile -> Direction -> Annex ()
 queueTransfers = queueTransfersMatching (const True)
 
 {- Adds transfers to queue for some of the known remotes, that match a
- - condition. -}
+ - condition. Honors preferred content settings. -}
 queueTransfersMatching :: (UUID -> Bool) -> Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> AssociatedFile -> Direction -> Annex ()
-queueTransfersMatching matching schedule q dstatus k f direction = do
+queueTransfersMatching matching schedule q dstatus k f direction
-	rs <- sufficientremotes
+	| direction == Download = whenM (wantGet f) go
-		=<< knownRemotes <$> liftIO (getDaemonStatus dstatus)
+	| otherwise = go
-	let matchingrs = filter (matching . Remote.uuid) rs
-	if null matchingrs
-		then defer
-		else forM_ matchingrs $ \r -> liftIO $
-			enqueue schedule q dstatus (gentransfer r) (stubInfo f r)
 	where
+		go = do
+			rs <- sufficientremotes
+				=<< knownRemotes <$> liftIO (getDaemonStatus dstatus)
+			let matchingrs = filter (matching . Remote.uuid) rs
+			if null matchingrs
+				then defer
+				else forM_ matchingrs $ \r -> liftIO $
+					enqueue schedule q dstatus (gentransfer r) (stubInfo f r)
 		sufficientremotes rs
 			{- Queue downloads from all remotes that
 			 - have the key, with the cheapest ones first.
@@ -80,11 +85,9 @@ queueTransfersMatching matching schedule q dstatus k f direction = do
 			| direction == Download = do
 				uuids <- Remote.keyLocations k
 				return $ filter (\r -> uuid r `elem` uuids) rs
-			{- TODO: Determine a smaller set of remotes that
+			{- Upload to all remotes that want the content. -}
-			 - can be uploaded to, in order to ensure all
+			| otherwise = filterM (wantSend f . Remote.uuid) $
-			 - remotes can access the content. Currently,
+				filter (not . Remote.readonly) rs
-			 - send to every remote we can. -}
-			| otherwise = return $ filter (not . Remote.readonly) rs
 		gentransfer r = Transfer
 			{ transferDirection = direction
 			, transferKey = k

Command/Copy.hs

@@ -32,4 +32,4 @@ start to from file (key, backend) = autoCopies file key (<) $
 	where
 		shouldCopy = case to of
 			Nothing -> checkAuto $ wantGet (Just file)
-			Just r -> checkAuto $ wantSend (Remote.uuid r) (Just file)
+			Just r -> checkAuto $ wantSend (Just file) (Remote.uuid r)

debian/changelog

@@ -13,6 +13,8 @@ git-annex (3.20121002) UNRELEASED; urgency=low
   * drop --auto: If the repository the content is dropped from has
     preferred content configured, drop only content that is not preferred.
   * copy --auto: Only transfer content that the destination repository prefers.
+  * assistant: Now honors preferred content settings when deciding what to
+    transfer.
   * --copies=group:number can now be used to match files that are present
     in a specified number of repositories in a group.
   * Added --smallerthan, --largerthan, and --inall limits.

doc/design/assistant/transfer_control.mdwn

@@ -6,7 +6,8 @@ it doesn't currently have, is covered by the [[partial_content]] page.
 
 But often the remote is just a removable drive or a cloud remote,
 that has a limited size. This page is about making the assistant do
-something smart with such remotes.
+something smart with such remotes. (Which it now does.. **done** except for
+an easy way to configure this.)
 
 ## specifying what data a remote prefers to contain **done**