From 5112650348f6bf04cebe1fb97ed900b24e4aaac1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 23 Jan 2014 16:37:08 -0400 Subject: 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 +++++++---------- 3 files changed, 54 insertions(+), 40 deletions(-) (limited to 'Annex') diff --git a/Annex/Drop.hs b/Annex/Drop.hs index 09ca822a3..61b0cf9e1 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 c144920cf..158f3e787 100644 --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -1,6 +1,6 @@ {- git-annex file matching - - - Copyright 2012, 2013 Joey Hess + - Copyright 2012-2014 Joey Hess - - 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 04dcc1c1c..42f813bbb 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 -- cgit v1.2.3