From 3518c586cfad6563b7ac2f0a02fb15efdbfad08d Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Thu, 23 Jan 2014 16:37:08 -0400
Subject: [PATCH] fix transfers of key with no associated file

Several places assumed this would not happen, and when the AssociatedFile
was Nothing, did nothing.

As part of this, preferred content checks pass the Key around.

Note that checkMatcher is sometimes now called with Just Key and Just File.
It currently constructs a FileMatcher, ignoring the Key. However, if it
constructed a FileKeyMatcher, which contained both, then it might be
possible to speed up parts of Limit, which currently call the somewhat
expensive lookupFileKey to get the Key.

I have not made this optimisation yet, because I am not sure if the key is
always the same. Will need some significant checking to satisfy myself
that's the case..
---
 Annex/Drop.hs                        | 48 +++++++++++++++++-----------
 Annex/FileMatcher.hs                 | 29 ++++++++++-------
 Annex/Wanted.hs                      | 17 ++++------
 Assistant/Drop.hs                    |  1 -
 Assistant/Threads/TransferScanner.hs |  4 +--
 Assistant/TransferQueue.hs           |  4 +--
 Assistant/TransferSlots.hs           | 18 ++++++-----
 Command/Copy.hs                      |  4 +--
 Command/Drop.hs                      |  2 +-
 Command/Get.hs                       |  2 +-
 Command/Sync.hs                      |  4 +--
 Limit/Wanted.hs                      |  4 +--
 Logs/PreferredContent.hs             |  6 ++--
 13 files changed, 79 insertions(+), 64 deletions(-)

diff --git a/Annex/Drop.hs b/Annex/Drop.hs
index 09ca822a35..61b0cf9e10 100644
--- a/Annex/Drop.hs
+++ b/Annex/Drop.hs
@@ -11,6 +11,7 @@ import Common.Annex
 import Logs.Trust
 import Config.NumCopies
 import Types.Remote (uuid)
+import Types.Key (key2file)
 import qualified Remote
 import qualified Command.Drop
 import Command
@@ -43,15 +44,14 @@ type Reason = String
  - or commandAction.
  -}
 handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> CommandActionRunner -> Annex ()
-handleDropsFrom _ _ _ _ _ Nothing _ _ = noop
-handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote runner = do
+handleDropsFrom locs rs reason fromhere key afile knownpresentremote runner = do
 	fs <- ifM isDirect
 		( do
 			l <- associatedFilesRelative key
 			if null l
-				then return [afile]
+				then return $ maybe [] (:[]) afile
 				else return l
-		, return [afile]
+		, return $ maybe [] (:[]) afile
 		)
 	n <- getcopies fs
 	if fromhere && checkcopies n Nothing
@@ -60,7 +60,9 @@ handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote runn
   where
 	getcopies fs = do
 		(untrusted, have) <- trustPartition UnTrusted locs
-		numcopies <- maximum <$> mapM getFileNumCopies fs
+		numcopies <- if null fs
+			then getNumCopies
+			else maximum <$> mapM getFileNumCopies fs
 		return (NumCopies (length have), numcopies, S.fromList untrusted)
 
 	{- Check that we have enough copies still to drop the content.
@@ -85,28 +87,36 @@ handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote runn
 			dropr fs r n >>= go fs rest
 		| otherwise = noop
 
-	checkdrop fs n@(have, numcopies, _untrusted) u a =
-		ifM (allM (wantDrop True u . Just) fs)
-			( ifM (safely $ runner $ a numcopies)
-				( do
-					liftIO $ debugM "drop" $ unwords
-						[ "dropped"
-						, afile
-						, "(from " ++ maybe "here" show u ++ ")"
-						, "(copies now " ++ show (fromNumCopies have - 1) ++ ")"
-						, ": " ++ reason
-						]
-					return $ decrcopies n u
+	checkdrop fs n u a
+		| null fs = check $ -- no associated files; unused content
+			wantDrop True u (Just key) Nothing
+		| otherwise = check $
+			allM (wantDrop True u (Just key) . Just) fs
+		where
+			check c = ifM c
+				( dodrop n u a
 				, return n
 				)
+
+	dodrop n@(have, numcopies, _untrusted) u a = 
+		ifM (safely $ runner $ a numcopies)
+			( do
+				liftIO $ debugM "drop" $ unwords
+					[ "dropped"
+					, fromMaybe (key2file key) afile
+					, "(from " ++ maybe "here" show u ++ ")"
+					, "(copies now " ++ show (fromNumCopies have - 1) ++ ")"
+					, ": " ++ reason
+					]
+				return $ decrcopies n u
 			, return n
 			)
 
 	dropl fs n = checkdrop fs n Nothing $ \numcopies ->
-		Command.Drop.startLocal (Just afile) numcopies key knownpresentremote
+		Command.Drop.startLocal afile numcopies key knownpresentremote
 
 	dropr fs r n  = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->
-		Command.Drop.startRemote (Just afile) numcopies key r
+		Command.Drop.startRemote afile numcopies key r
 
 	slocs = S.fromList locs
 	
diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs
index c144920cfb..158f3e787b 100644
--- a/Annex/FileMatcher.hs
+++ b/Annex/FileMatcher.hs
@@ -1,6 +1,6 @@
 {- git-annex file matching
  -
- - Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -28,18 +28,25 @@ import qualified Data.Set as S
 type FileMatcher = Matcher MatchFiles
 
 checkFileMatcher :: FileMatcher -> FilePath -> Annex Bool
-checkFileMatcher matcher file = checkFileMatcher' matcher file S.empty True
+checkFileMatcher matcher file = checkMatcher matcher Nothing (Just file) S.empty True
 
-checkFileMatcher' :: FileMatcher -> FilePath -> AssumeNotPresent -> Bool -> Annex Bool
-checkFileMatcher' matcher file notpresent def
+checkMatcher :: FileMatcher -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Bool -> Annex Bool
+checkMatcher matcher mkey afile notpresent def
 	| isEmpty matcher = return def
-	| otherwise = do
-		matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
-		let mi = MatchingFile $ FileInfo
-			{ matchFile = matchfile
-			, relFile = file
-			}
-		matchMrun matcher $ \a -> a notpresent mi
+	| otherwise = case (mkey, afile) of
+		(_, Just file) -> go =<< fileMatchInfo file
+		(Just key, _) -> go (MatchingKey key)
+		_ -> return def
+  where
+	go mi = matchMrun matcher $ \a -> a notpresent mi
+
+fileMatchInfo :: FilePath -> Annex MatchInfo
+fileMatchInfo file = do
+	matchfile <- getTopFilePath <$> inRepo (toTopFilePath file)
+	return $ MatchingFile $ FileInfo
+		{ matchFile = matchfile
+		, relFile = file
+		}
 
 matchAll :: FileMatcher
 matchAll = generate []
diff --git a/Annex/Wanted.hs b/Annex/Wanted.hs
index 04dcc1c1ca..42f813bbbc 100644
--- a/Annex/Wanted.hs
+++ b/Annex/Wanted.hs
@@ -14,19 +14,16 @@ import Annex.UUID
 import qualified Data.Set as S
 
 {- Check if a file is preferred content for the local repository. -}
-wantGet :: Bool -> AssociatedFile -> Annex Bool
-wantGet def Nothing = return def
-wantGet def (Just file) = isPreferredContent Nothing S.empty file def
+wantGet :: Bool -> Maybe Key -> AssociatedFile -> Annex Bool
+wantGet def key file = isPreferredContent Nothing S.empty key file def
 
 {- Check if a file is preferred content for a remote. -}
-wantSend :: Bool -> AssociatedFile -> UUID -> Annex Bool
-wantSend def Nothing _ = return def
-wantSend def (Just file) to = isPreferredContent (Just to) S.empty file def
+wantSend :: Bool -> Maybe Key -> AssociatedFile -> UUID -> Annex Bool
+wantSend def key file to = isPreferredContent (Just to) S.empty key file def
 
 {- Check if a file can be dropped, maybe from a remote.
  - Don't drop files that are preferred content. -}
-wantDrop :: Bool -> Maybe UUID -> AssociatedFile -> Annex Bool
-wantDrop def _ Nothing = return $ not def
-wantDrop def from (Just file) = do
+wantDrop :: Bool -> Maybe UUID -> Maybe Key -> AssociatedFile -> Annex Bool
+wantDrop def from key file = do
 	u <- maybe getUUID (return . id) from
-	not <$> isPreferredContent (Just u) (S.singleton u) file def
+	not <$> isPreferredContent (Just u) (S.singleton u) key file def
diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs
index 3020b0f4fe..faff37a23d 100644
--- a/Assistant/Drop.hs
+++ b/Assistant/Drop.hs
@@ -19,7 +19,6 @@ import RunCommand
 {- Drop from local and/or remote when allowed by the preferred content and
  - numcopies settings. -}
 handleDrops :: Reason -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant ()
-handleDrops _ _ _ Nothing _ = noop
 handleDrops reason fromhere key f knownpresentremote = do
 	syncrs <- syncDataRemotes <$> getDaemonStatus
 	locs <- liftAnnex $ loggedLocations key
diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs
index 60f6dc28b5..6aefb2920e 100644
--- a/Assistant/Threads/TransferScanner.hs
+++ b/Assistant/Threads/TransferScanner.hs
@@ -164,9 +164,9 @@ expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do
 			let slocs = S.fromList locs
 			let use a = return $ mapMaybe (a key slocs) syncrs
 			ts <- if present
-				then filterM (wantSend True (Just f) . Remote.uuid . fst)
+				then filterM (wantSend True (Just key) (Just f) . Remote.uuid . fst)
 					=<< use (genTransfer Upload False)
-				else ifM (wantGet True $ Just f)
+				else ifM (wantGet True (Just key) (Just f))
 					( use (genTransfer Download True) , return [] )
 			let unwanted' = S.difference unwanted slocs
 			return (unwanted', ts)
diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs
index 6d8e728524..86dd36d04d 100644
--- a/Assistant/TransferQueue.hs
+++ b/Assistant/TransferQueue.hs
@@ -58,7 +58,7 @@ queueTransfers = queueTransfersMatching (const True)
  - condition. Honors preferred content settings. -}
 queueTransfersMatching :: (UUID -> Bool) -> Reason -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant ()
 queueTransfersMatching matching reason schedule k f direction
-	| direction == Download = whenM (liftAnnex $ wantGet True f) go
+	| direction == Download = whenM (liftAnnex $ wantGet True (Just k) f) go
 	| otherwise = go
   where
 	go = do
@@ -82,7 +82,7 @@ queueTransfersMatching matching reason schedule k f direction
 		 - already have it. -}
 		| otherwise = do
 			s <- locs
-			filterM (wantSend True f . Remote.uuid) $
+			filterM (wantSend True (Just k) f . Remote.uuid) $
 				filter (\r -> not (inset s r || Remote.readonly r)) rs
 	  where
 	  	locs = S.fromList <$> Remote.keyLocations k
diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs
index cb5d61a396..6fc8c3fd78 100644
--- a/Assistant/TransferSlots.hs
+++ b/Assistant/TransferSlots.hs
@@ -103,8 +103,8 @@ runTransferThread' program batchmaker d run = go
 {- By the time this is called, the daemonstatus's currentTransfers map should
  - already have been updated to include the transfer. -}
 genTransfer :: Transfer -> TransferInfo -> TransferGenerator
-genTransfer t info = case (transferRemote info, associatedFile info) of
-	(Just remote, Just file) 
+genTransfer t info = case transferRemote info of
+	Just remote 
 		| Git.repoIsLocalUnknown (Remote.repo remote) -> do
 			-- optimisation for removable drives not plugged in
 			liftAnnex $ recordFailedTransfer t info
@@ -114,7 +114,7 @@ genTransfer t info = case (transferRemote info, associatedFile info) of
 			( do
 				debug [ "Transferring:" , describeTransfer t info ]
 				notifyTransfer
-				return $ Just (t, info, go remote file)
+				return $ Just (t, info, go remote)
 			, do
 				debug [ "Skipping unnecessary transfer:",
 					describeTransfer t info ]
@@ -149,10 +149,12 @@ genTransfer t info = case (transferRemote info, associatedFile info) of
 	 - usual cleanup. However, first check if something else is
 	 - running the transfer, to avoid removing active transfers.
 	 -}
-	go remote file transferrer = ifM (liftIO $ performTransfer transferrer t $ associatedFile info)
+	go remote transferrer = ifM (liftIO $ performTransfer transferrer t $ associatedFile info)
 		( do
-			void $ addAlert $ makeAlertFiller True $
-				transferFileAlert direction True file
+			maybe noop
+				(void . addAlert . makeAlertFiller True 
+					. transferFileAlert direction True)
+				(associatedFile info)
 			unless isdownload $
 				handleDrops
 					("object uploaded to " ++ show remote)
@@ -188,11 +190,11 @@ genTransfer t info = case (transferRemote info, associatedFile info) of
 shouldTransfer :: Transfer -> TransferInfo -> Annex Bool
 shouldTransfer t info
 	| transferDirection t == Download =
-		(not <$> inAnnex key) <&&> wantGet True file
+		(not <$> inAnnex key) <&&> wantGet True (Just key) file
 	| transferDirection t == Upload = case transferRemote info of
 		Nothing -> return False
 		Just r -> notinremote r
-			<&&> wantSend True file (Remote.uuid r)
+			<&&> wantSend True (Just key) file (Remote.uuid r)
 	| otherwise = return False
   where
 	key = transferKey t
diff --git a/Command/Copy.hs b/Command/Copy.hs
index 395992ed0c..e2bd1fce40 100644
--- a/Command/Copy.hs
+++ b/Command/Copy.hs
@@ -37,5 +37,5 @@ start to from file (key, backend) = stopUnless shouldCopy $
   where
 	shouldCopy = checkAuto (check <||> numCopiesCheck file key (<))
 	check = case to of
-		Nothing -> wantGet False (Just file)
-		Just r -> wantSend False (Just file) (Remote.uuid r)
+		Nothing -> wantGet False (Just key) (Just file)
+		Just r -> wantSend False (Just key) (Just file) (Remote.uuid r)
diff --git a/Command/Drop.hs b/Command/Drop.hs
index bf832e8d59..d17302035f 100644
--- a/Command/Drop.hs
+++ b/Command/Drop.hs
@@ -34,7 +34,7 @@ seek ps = do
 
 start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
 start from file (key, _) = checkDropAuto from file key $ \numcopies ->
-	stopUnless (checkAuto $ wantDrop False (Remote.uuid <$> from) (Just file)) $
+	stopUnless (checkAuto $ wantDrop False (Remote.uuid <$> from) (Just key) (Just file)) $
 		case from of
 			Nothing -> startLocal (Just file) numcopies key Nothing
 			Just remote -> do
diff --git a/Command/Get.hs b/Command/Get.hs
index cdb85af944..fb2145fddf 100644
--- a/Command/Get.hs
+++ b/Command/Get.hs
@@ -36,7 +36,7 @@ seek ps = do
 start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
 start from file (key, _) = start' expensivecheck from key (Just file)
   where
-	expensivecheck = checkAuto (numCopiesCheck file key (<) <||> wantGet False (Just file))
+	expensivecheck = checkAuto (numCopiesCheck file key (<) <||> wantGet False (Just key) (Just file))
 
 startKeys :: Maybe Remote -> Key -> CommandStart
 startKeys from key = start' (return True) from key Nothing
diff --git a/Command/Sync.hs b/Command/Sync.hs
index 9db3c7ad7f..5763709ac7 100644
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -519,7 +519,7 @@ syncFile rs f (k, _) = do
   	wantget have = allM id 
 		[ pure (not $ null have)
 		, not <$> inAnnex k
-		, wantGet True (Just f)
+		, wantGet True (Just k) (Just f)
 		]
 	handleget have = ifM (wantget have)
 		( return [ get have ]
@@ -531,7 +531,7 @@ syncFile rs f (k, _) = do
 
 	wantput r
 		| Remote.readonly r || remoteAnnexReadOnly (Types.Remote.gitconfig r) = return False
-		| otherwise = wantSend True (Just f) (Remote.uuid r)
+		| otherwise = wantSend True (Just k) (Just f) (Remote.uuid r)
 	handleput lack = ifM (inAnnex k)
 		( map put <$> (filterM wantput lack)
 		, return []
diff --git a/Limit/Wanted.hs b/Limit/Wanted.hs
index 7e92782029..01b8da6b34 100644
--- a/Limit/Wanted.hs
+++ b/Limit/Wanted.hs
@@ -13,10 +13,10 @@ import Limit
 import Types.FileMatcher
 
 addWantGet :: Annex ()
-addWantGet = addLimit $ Right $ const $ checkWant $ wantGet False
+addWantGet = addLimit $ Right $ const $ checkWant $ wantGet False Nothing
 
 addWantDrop :: Annex ()
-addWantDrop = addLimit $ Right $ const $ checkWant $ wantDrop False Nothing
+addWantDrop = addLimit $ Right $ const $ checkWant $ wantDrop False Nothing Nothing
 
 checkWant :: (Maybe FilePath -> Annex Bool) -> MatchInfo -> Annex Bool
 checkWant a (MatchingFile fi) = a (Just $ matchFile fi)
diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs
index 2a9aed36bd..4b25ea094c 100644
--- a/Logs/PreferredContent.hs
+++ b/Logs/PreferredContent.hs
@@ -38,13 +38,13 @@ import Types.StandardGroups
 
 {- Checks if a file is preferred content for the specified repository
  - (or the current repository if none is specified). -}
-isPreferredContent :: Maybe UUID -> AssumeNotPresent -> FilePath -> Bool -> Annex Bool
-isPreferredContent mu notpresent file def = do
+isPreferredContent :: Maybe UUID -> AssumeNotPresent -> Maybe Key -> AssociatedFile -> Bool -> Annex Bool
+isPreferredContent mu notpresent mkey afile def = do
 	u <- maybe getUUID return mu
 	m <- preferredContentMap
 	case M.lookup u m of
 		Nothing -> return def
-		Just matcher -> checkFileMatcher' matcher file notpresent def
+		Just matcher -> checkMatcher matcher mkey afile notpresent def
 
 {- The map is cached for speed. -}
 preferredContentMap :: Annex Annex.PreferredContentMap