diff --git a/Annex/Drop.hs b/Annex/Drop.hs index 558b885073..40b6add142 100644 --- a/Annex/Drop.hs +++ b/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 diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index ac44601f73..328a395d62 100644 --- a/CmdLine/Seek.hs +++ b/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 - let bfp = mkActionItem $ BranchFilePath b (LsTree.file i) - maybe noop (\k -> keyaction (k, bfp)) - =<< catKey (LsTree.sha i) + forM_ l $ \i -> catKey (LsTree.sha i) >>= \case + Nothing -> noop + Just k -> + 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 diff --git a/Command/Drop.hs b/Command/Drop.hs index 71879205e0..d54dc82239 100644 --- a/Command/Drop.hs +++ b/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 diff --git a/Command/Find.hs b/Command/Find.hs index 263bdd68f7..4eae0f035b 100644 --- a/Command/Find.hs +++ b/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 diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 11f9863312..f372aea168 100644 --- a/Command/Fsck.hs +++ b/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 ] diff --git a/Command/Get.hs b/Command/Get.hs index e71cb554eb..783b1cb30a 100644 --- a/Command/Get.hs +++ b/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 diff --git a/Command/Info.hs b/Command/Info.hs index d18134cf9c..afff5642de 100644 --- a/Command/Info.hs +++ b/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 - (ActionItemAssociatedFile (associatedFile i)) - (transferKey t) + , actionItemDesc $ mkActionItem + (transferKey t, associatedFile i) , if transferDirection t == Upload then "to" else "from" , maybe (fromUUID $ transferUUID t) Remote.name $ M.lookup (transferUUID t) uuidmap diff --git a/Command/MetaData.hs b/Command/MetaData.hs index 78ccabcdc5..9e87f4733e 100644 --- a/Command/MetaData.hs +++ b/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 diff --git a/Command/Mirror.hs b/Command/Mirror.hs index d5c7f47789..291d5d74b9 100644 --- a/Command/Mirror.hs +++ b/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 diff --git a/Command/Move.hs b/Command/Move.hs index c11a0e4303..65150258c1 100644 --- a/Command/Move.hs +++ b/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 afile k (mkActionItem afile) +start fromto removewhen f k = start' fromto removewhen afile k ai where afile = AssociatedFile (Just f) + ai = mkActionItem (k, afile) startKey :: FromToHereOptions -> RemoveWhen -> (Key, ActionItem) -> CommandStart startKey fromto removewhen = diff --git a/Command/Sync.hs b/Command/Sync.hs index fd83f354e4..70c19f213f 100644 --- a/Command/Sync.hs +++ b/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 diff --git a/Command/Whereis.hs b/Command/Whereis.hs index 2282385147..4a863fea69 100644 --- a/Command/Whereis.hs +++ b/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) diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index 9df008a6d2..58e035c1a0 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -31,8 +31,8 @@ describeTransfer :: Transfer -> TransferInfo -> String describeTransfer t info = unwords [ show $ transferDirection t , show $ transferUUID t - , actionItemDesc - (ActionItemAssociatedFile (associatedFile info)) + , actionItemDesc $ ActionItemAssociatedFile + (associatedFile info) (transferKey t) , show $ bytesComplete info ] diff --git a/Messages.hs b/Messages.hs index 729b891c9e..94dbb301e3 100644 --- a/Messages.hs +++ b/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) diff --git a/Types/ActionItem.hs b/Types/ActionItem.hs index bee7156088..dbcaf0982f 100644 --- a/Types/ActionItem.hs +++ b/Types/ActionItem.hs @@ -1,6 +1,6 @@ {- items that a command can act on - - - Copyright 2016 Joey Hess + - Copyright 2016-2019 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -14,36 +14,45 @@ import Types.Transfer import Git.FilePath data ActionItem - = ActionItemAssociatedFile AssociatedFile - | ActionItemKey - | ActionItemBranchFilePath BranchFilePath + = ActionItemAssociatedFile AssociatedFile Key + | ActionItemKey Key + | ActionItemBranchFilePath BranchFilePath Key | ActionItemFailedTransfer Transfer TransferInfo class MkActionItem t where mkActionItem :: t -> ActionItem -instance MkActionItem AssociatedFile where - mkActionItem = ActionItemAssociatedFile +instance MkActionItem (AssociatedFile, Key) where + mkActionItem = uncurry ActionItemAssociatedFile + +instance MkActionItem (Key, AssociatedFile) where + mkActionItem = uncurry $ flip ActionItemAssociatedFile instance MkActionItem Key where - mkActionItem _ = ActionItemKey + mkActionItem = ActionItemKey -instance MkActionItem BranchFilePath where - mkActionItem = ActionItemBranchFilePath +instance MkActionItem (BranchFilePath, Key) where + mkActionItem = uncurry ActionItemBranchFilePath instance MkActionItem (Transfer, TransferInfo) where mkActionItem = uncurry ActionItemFailedTransfer -actionItemDesc :: ActionItem -> Key -> String -actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f))) _ = f -actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing)) k = serializeKey k -actionItemDesc ActionItemKey k = serializeKey k -actionItemDesc (ActionItemBranchFilePath bfp) _ = descBranchFilePath bfp -actionItemDesc (ActionItemFailedTransfer _ i) k = - actionItemDesc (ActionItemAssociatedFile (associatedFile i)) k +actionItemDesc :: ActionItem -> String +actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f)) _) = f +actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing) k) = serializeKey k +actionItemDesc (ActionItemKey k) = serializeKey k +actionItemDesc (ActionItemBranchFilePath bfp _) = descBranchFilePath bfp +actionItemDesc (ActionItemFailedTransfer t i) = actionItemDesc $ + 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