diff options
Diffstat (limited to 'Annex')
| -rw-r--r-- | Annex/Drop.hs | 48 | ||||
| -rw-r--r-- | Annex/FileMatcher.hs | 29 | ||||
| -rw-r--r-- | Annex/Wanted.hs | 17 |
3 files changed, 54 insertions, 40 deletions
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 <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 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 |