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

@@ -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,13 +87,23 @@ 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)
+	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"
-						, afile
+					, fromMaybe (key2file key) afile
 					, "(from " ++ maybe "here" show u ++ ")"
 					, "(copies now " ++ show (fromNumCopies have - 1) ++ ")"
 					, ": " ++ reason
@@ -99,14 +111,12 @@ handleDropsFrom locs rs reason fromhere key (Just afile) knownpresentremote runn
 				return $ decrcopies n u
 			, return n
 			)
-			, 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
 	

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
+	| 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)
-		let mi = MatchingFile $ FileInfo
+	return $ MatchingFile $ FileInfo
 		{ matchFile = matchfile
 		, relFile = file
 		}
-		matchMrun matcher $ \a -> a notpresent mi
 
 matchAll :: FileMatcher
 matchAll = generate []

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

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

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)

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

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

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)

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

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

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 []

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)

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