add Key to all ActionItem constructors

Annex/Drop.hs

@@ -125,10 +125,12 @@ handleDropsFrom locs rs reason fromhere key afile preverified runner = do
 			)
 
 	dropl fs n = checkdrop fs n Nothing $ \numcopies ->
-		Command.Drop.startLocal afile (mkActionItem afile) numcopies key preverified
+		Command.Drop.startLocal afile ai numcopies key preverified
 
 	dropr fs r n  = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->
-		Command.Drop.startRemote afile (mkActionItem afile) numcopies key r
+		Command.Drop.startRemote afile ai numcopies key r
+
+	ai = mkActionItem (key, afile)
 
 	slocs = S.fromList locs
 	

CmdLine/Seek.hs

@@ -186,7 +186,7 @@ withKeyOptions ko auto keyaction = withKeyOptions' ko auto mkkeyaction
 		matcher <- Limit.getMatcher
 		return $ \v@(k, ai) ->
 			let i = case ai of
-				ActionItemBranchFilePath (BranchFilePath _ topf) ->
+				ActionItemBranchFilePath (BranchFilePath _ topf) _ ->
 					MatchingKey k (AssociatedFile $ Just $ getTopFilePath topf)
 				_ -> MatchingKey k (AssociatedFile Nothing)
 			in whenM (matcher i) $
@@ -229,10 +229,11 @@ withKeyOptions' ko auto mkkeyaction fallbackaction params = do
 		keyaction <- mkkeyaction
 		forM_ bs $ \b -> do
 			(l, cleanup) <- inRepo $ LsTree.lsTree LsTree.LsTreeRecursive b
-			forM_ l $ \i -> do
+			forM_ l $ \i -> catKey (LsTree.sha i) >>= \case
-				let bfp = mkActionItem $ BranchFilePath b (LsTree.file i)
+				Nothing -> noop
-				maybe noop (\k -> keyaction (k, bfp))
+				Just k -> 
-					=<< catKey (LsTree.sha i)
+					let bfp = mkActionItem (BranchFilePath b (LsTree.file i), k)
+					in keyaction (k, bfp)
 			unlessM (liftIO cleanup) $
 				error ("git ls-tree " ++ Git.fromRef b ++ " failed")
 	runfailedtransfers = do

Command/Drop.hs

@@ -63,9 +63,10 @@ seek o = allowConcurrentOutput $
 	go = whenAnnexed $ start o
 
 start :: DropOptions -> FilePath -> Key -> CommandStart
-start o file key = start' o key afile (mkActionItem afile)
+start o file key = start' o key afile ai
   where
 	afile = AssociatedFile (Just file)
+	ai = mkActionItem (key, afile)
 
 start' :: DropOptions -> Key -> AssociatedFile -> ActionItem -> CommandStart
 start' o key afile ai = onlyActionOn key $ do

Command/Find.hs

@@ -73,7 +73,7 @@ start o file key = ifM (limited <||> inAnnex key)
 	)
 
 startKeys :: FindOptions -> (Key, ActionItem) -> CommandStart
-startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf)) = 
+startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf) _) = 
 	start o (getTopFilePath topf) key
 startKeys _ _ = stop
 

Command/Fsck.hs

@@ -114,7 +114,7 @@ start from inc file key = Backend.getBackend file key >>= \case
 			Nothing -> go $ perform key file backend numcopies
 			Just r -> go $ performRemote key afile backend numcopies r
   where
-	go = runFsck inc (mkActionItem afile) key
+	go = runFsck inc (mkActionItem (key, afile)) key
 	afile = AssociatedFile (Just file)
 
 perform :: Key -> FilePath -> Backend -> NumCopies -> Annex Bool
@@ -134,7 +134,7 @@ perform key file backend numcopies = do
 		]
   where
 	afile = AssociatedFile (Just file)
-	ai = ActionItemAssociatedFile afile
+	ai = mkActionItem (key, afile)
 
 {- To fsck a remote, the content is retrieved to a tmp file,
  - and checked locally. -}
@@ -161,7 +161,7 @@ performRemote key afile backend numcopies remote =
 		, withLocalCopy localcopy $ checkBackendRemote backend key remote ai
 		, checkKeyNumCopies key afile numcopies
 		]
-	ai = ActionItemAssociatedFile afile
+	ai = mkActionItem (key, afile)
 	withtmp a = do
 		pid <- liftIO getPID
 		t <- fromRepo gitAnnexTmpObjectDir
@@ -275,7 +275,7 @@ verifyLocationLog' key ai present u updatestatus = do
 			fix InfoMissing
 			warning $
 				"** Based on the location log, " ++
-				actionItemDesc ai key ++
+				actionItemDesc ai ++
 				"\n** was expected to be present, " ++
 				"but its content is missing."
 			return False
@@ -295,7 +295,7 @@ verifyLocationLog' key ai present u updatestatus = do
 {- Verifies that all repos that are required to contain the content do,
  - checking against the location log. -}
 verifyRequiredContent :: Key -> ActionItem -> Annex Bool
-verifyRequiredContent key ai@(ActionItemAssociatedFile afile) = do
+verifyRequiredContent key ai@(ActionItemAssociatedFile afile _) = do
 	requiredlocs <- S.fromList . M.keys <$> requiredContentMap
 	if S.null requiredlocs
 		then return True
@@ -310,7 +310,7 @@ verifyRequiredContent key ai@(ActionItemAssociatedFile afile) = do
 					missingrequired <- Remote.prettyPrintUUIDs "missingrequired" missinglocs
 					warning $
 						"** Required content " ++
-						actionItemDesc ai key ++
+						actionItemDesc ai ++
 						" is missing from these repositories:\n" ++
 						missingrequired
 					return False
@@ -401,7 +401,7 @@ checkKeySizeOr bad key file ai = case keySize key of
 	badsize a b = do
 		msg <- bad key
 		warning $ concat
-			[ actionItemDesc ai key
+			[ actionItemDesc ai
 			, ": Bad file size ("
 			, compareSizes storageUnits True a b
 			, "); "
@@ -419,7 +419,7 @@ checkKeyUpgrade backend key ai (AssociatedFile (Just file)) =
 	case Types.Backend.canUpgradeKey backend of
 		Just a | a key -> do
 			warning $ concat
-				[ actionItemDesc ai key
+				[ actionItemDesc ai
 				, ": Can be upgraded to an improved key format. "
 				, "You can do so by running: git annex migrate --backend="
 				, decodeBS (formatKeyVariety (keyVariety key)) ++ " "
@@ -451,18 +451,20 @@ checkBackend backend key keystatus afile = go =<< isDirect
 		content <- calcRepo $ gitAnnexLocation key
 		ifM (pure (isKeyUnlockedThin keystatus) <&&> (not <$> isUnmodified key content))
 			( nocheck
-			, checkBackendOr badContent backend key content (mkActionItem afile)
+			, checkBackendOr badContent backend key content ai
 			)
 	go True = case afile of
 		AssociatedFile Nothing -> nocheck
 		AssociatedFile (Just f) -> checkdirect f
 	checkdirect file = ifM (Direct.goodContent key file)
-		( checkBackendOr' (badContentDirect file) backend key file (mkActionItem afile)
+		( checkBackendOr' (badContentDirect file) backend key file ai
 			(Direct.goodContent key file)
 		, nocheck
 		)
 	nocheck = return True
 
+	ai = mkActionItem (key, afile)
+
 checkBackendRemote :: Backend -> Key -> Remote -> ActionItem -> FilePath -> Annex Bool
 checkBackendRemote backend key remote ai localcopy =
 	checkBackendOr (badContentRemote remote localcopy) backend key localcopy ai
@@ -485,7 +487,7 @@ checkBackendOr' bad backend key file ai postcheck =
 					unless ok $ do
 						msg <- bad key
 						warning $ concat
-							[ actionItemDesc ai key
+							[ actionItemDesc ai
 							, ": Bad file content; "
 							, msg
 							]

Command/Get.hs

@@ -49,9 +49,10 @@ seek o = allowConcurrentOutput $ do
 			=<< workTreeItems (getFiles o)
 
 start :: GetOptions -> Maybe Remote -> FilePath -> Key -> CommandStart
-start o from file key = start' expensivecheck from key afile (mkActionItem afile)
+start o from file key = start' expensivecheck from key afile ai
   where
 	afile = AssociatedFile (Just file)
+	ai = mkActionItem (key, afile)
 	expensivecheck
 		| autoMode o = numCopiesCheck file key (<)
 			<||> wantGet False (Just key) afile

Command/Info.hs

@@ -445,9 +445,8 @@ transfer_list = stat desc $ nojson $ lift $ do
 	desc = "transfers in progress"
 	line uuidmap t i = unwords
 		[ formatDirection (transferDirection t) ++ "ing"
-		, actionItemDesc
+		, actionItemDesc $ mkActionItem
-			(ActionItemAssociatedFile (associatedFile i))
+			(transferKey t, associatedFile i)
-			(transferKey t)
 		, if transferDirection t == Upload then "to" else "from"
 		, maybe (fromUUID $ transferUUID t) Remote.name $
 			M.lookup (transferUUID t) uuidmap

Command/MetaData.hs

@@ -93,7 +93,7 @@ seek o = case batchOption o of
 		_ -> giveup "--batch is currently only supported in --json mode"
 
 start :: VectorClock -> MetaDataOptions -> FilePath -> Key -> CommandStart
-start c o file k = startKeys c o (k, mkActionItem afile)
+start c o file k = startKeys c o (k, mkActionItem (k, afile))
   where
 	afile = AssociatedFile (Just file)
 
@@ -164,7 +164,7 @@ startBatch (i, (MetaData m)) = case i of
 	Left f -> do
 		mk <- lookupFile f
 		case mk of
-			Just k -> go k (mkActionItem (AssociatedFile (Just f)))
+			Just k -> go k (mkActionItem (k, AssociatedFile (Just f)))
 			Nothing -> giveup $ "not an annexed file: " ++ f
 	Right k -> go k (mkActionItem k)
   where

Command/Mirror.hs

@@ -48,9 +48,10 @@ seek o = allowConcurrentOutput $
 		=<< workTreeItems (mirrorFiles o)
 
 start :: MirrorOptions -> FilePath -> Key -> CommandStart
-start o file k = startKey o afile (k, mkActionItem afile)
+start o file k = startKey o afile (k, ai)
   where
 	afile = AssociatedFile (Just file)
+	ai = mkActionItem (k, afile)
 
 startKey :: MirrorOptions -> AssociatedFile -> (Key, ActionItem) -> CommandStart
 startKey o afile (key, ai) = onlyActionOn key $ case fromToOptions o of

Command/Move.hs

@@ -64,10 +64,10 @@ seek o = allowConcurrentOutput $ do
 			=<< workTreeItems (moveFiles o)
 
 start :: FromToHereOptions -> RemoveWhen -> FilePath -> Key -> CommandStart
-start fromto removewhen f k =
+start fromto removewhen f k = start' fromto removewhen afile k ai
-	start' fromto removewhen afile k (mkActionItem afile)
   where
 	afile = AssociatedFile (Just f)
+	ai = mkActionItem (k, afile)
 
 startKey :: FromToHereOptions -> RemoveWhen -> (Key, ActionItem) -> CommandStart
 startKey fromto removewhen = 

Command/Sync.hs

@@ -690,7 +690,7 @@ syncFile ebloom rs af k = onlyActionOn' k $ do
 		, return []
 		)
 	get have = includeCommandAction $ do
-		showStartKey "get" k (mkActionItem af)
+		showStartKey "get" k ai
 		next $ next $ getKey' k af have
 
 	wantput r
@@ -705,7 +705,9 @@ syncFile ebloom rs af k = onlyActionOn' k $ do
 		, return []
 		)
 	put dest = includeCommandAction $ 
-		Command.Move.toStart' dest Command.Move.RemoveNever af k (mkActionItem af)
+		Command.Move.toStart' dest Command.Move.RemoveNever af k ai
+
+	ai = mkActionItem (k, af)
 
 {- When a remote has an annex-tracking-branch configuration, change the export
  - to contain the current content of the branch. Otherwise, transfer any files

Command/Whereis.hs

@@ -48,7 +48,7 @@ seek o = do
 				=<< workTreeItems (whereisFiles o)
 
 start :: M.Map UUID Remote -> FilePath -> Key -> CommandStart
-start remotemap file key = startKeys remotemap (key, mkActionItem afile)
+start remotemap file key = startKeys remotemap (key, mkActionItem (key, afile))
   where
 	afile = AssociatedFile (Just file)
 

Logs/Transfer.hs

@@ -31,8 +31,8 @@ describeTransfer :: Transfer -> TransferInfo -> String
 describeTransfer t info = unwords
 	[ show $ transferDirection t
 	, show $ transferUUID t
-	, actionItemDesc
+	, actionItemDesc $ ActionItemAssociatedFile
-		(ActionItemAssociatedFile (associatedFile info))
+		(associatedFile info)
 		(transferKey t)
 	, show $ bytesComplete info
 	]

Messages.hs

@@ -77,7 +77,7 @@ showStart' command mdesc = outputMessage json $
 
 showStartKey :: String -> Key -> ActionItem -> Annex ()
 showStartKey command key i = outputMessage json $
-	command ++ " " ++ actionItemDesc i key ++ " "
+	command ++ " " ++ actionItemDesc i ++ " "
   where
 	json = JSON.start command (actionItemWorkTreeFile i) (Just key)
 

Types/ActionItem.hs

@@ -1,6 +1,6 @@
 {- items that a command can act on
  -
- - Copyright 2016 Joey Hess <id@joeyh.name>
+ - Copyright 2016-2019 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -14,36 +14,45 @@ import Types.Transfer
 import Git.FilePath
 
 data ActionItem 
-	= ActionItemAssociatedFile AssociatedFile
+	= ActionItemAssociatedFile AssociatedFile Key
-	| ActionItemKey
+	| ActionItemKey Key
-	| ActionItemBranchFilePath BranchFilePath
+	| ActionItemBranchFilePath BranchFilePath Key
 	| ActionItemFailedTransfer Transfer TransferInfo
 
 class MkActionItem t where
 	mkActionItem :: t -> ActionItem
 
-instance MkActionItem AssociatedFile where
+instance MkActionItem (AssociatedFile, Key) where
-	mkActionItem = ActionItemAssociatedFile
+	mkActionItem = uncurry ActionItemAssociatedFile
+
+instance MkActionItem (Key, AssociatedFile) where
+	mkActionItem = uncurry $ flip ActionItemAssociatedFile
 
 instance MkActionItem Key where
-	mkActionItem _ = ActionItemKey
+	mkActionItem = ActionItemKey
 
-instance MkActionItem BranchFilePath where
+instance MkActionItem (BranchFilePath, Key) where
-	mkActionItem = ActionItemBranchFilePath
+	mkActionItem = uncurry ActionItemBranchFilePath
 
 instance MkActionItem (Transfer, TransferInfo) where
 	mkActionItem = uncurry ActionItemFailedTransfer
 
-actionItemDesc :: ActionItem -> Key -> String
+actionItemDesc :: ActionItem -> String
-actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f))) _ = f
+actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f)) _) = f
-actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing)) k = serializeKey k
+actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing) k) = serializeKey k
-actionItemDesc ActionItemKey k = serializeKey k
+actionItemDesc (ActionItemKey k) = serializeKey k
-actionItemDesc (ActionItemBranchFilePath bfp) _ = descBranchFilePath bfp
+actionItemDesc (ActionItemBranchFilePath bfp _) = descBranchFilePath bfp
-actionItemDesc (ActionItemFailedTransfer _ i) k =
+actionItemDesc (ActionItemFailedTransfer t i) = actionItemDesc $
-	actionItemDesc (ActionItemAssociatedFile (associatedFile i)) k
+	ActionItemAssociatedFile (associatedFile i) (transferKey t)
+
+actionItemKey :: ActionItem -> Key
+actionItemKey (ActionItemAssociatedFile _ k) = k
+actionItemKey (ActionItemKey k) = k
+actionItemKey (ActionItemBranchFilePath _ k) = k
+actionItemKey (ActionItemFailedTransfer t _) = transferKey t
 
 actionItemWorkTreeFile :: ActionItem -> Maybe FilePath
-actionItemWorkTreeFile (ActionItemAssociatedFile (AssociatedFile af)) = af
+actionItemWorkTreeFile (ActionItemAssociatedFile (AssociatedFile af) _) = af
 actionItemWorkTreeFile _ = Nothing
 
 actionItemTransferDirection :: ActionItem -> Maybe Direction