aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Annex/Drop.hs48
-rw-r--r--Annex/FileMatcher.hs29
-rw-r--r--Annex/Wanted.hs17
-rw-r--r--Assistant/Drop.hs1
-rw-r--r--Assistant/Threads/TransferScanner.hs4
-rw-r--r--Assistant/TransferQueue.hs4
-rw-r--r--Assistant/TransferSlots.hs18
-rw-r--r--Command/Copy.hs4
-rw-r--r--Command/Drop.hs2
-rw-r--r--Command/Get.hs2
-rw-r--r--Command/Sync.hs4
-rw-r--r--Limit/Wanted.hs4
-rw-r--r--Logs/PreferredContent.hs6
13 files changed, 79 insertions, 64 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
diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs
index 3020b0f4f..faff37a23 100644
--- a/Assistant/Drop.hs
+++ b/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
diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs
index 60f6dc28b..6aefb2920 100644
--- a/Assistant/Threads/TransferScanner.hs
+++ b/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)
diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs
index 6d8e72852..86dd36d04 100644
--- a/Assistant/TransferQueue.hs
+++ b/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
diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs
index cb5d61a39..6fc8c3fd7 100644
--- a/Assistant/TransferSlots.hs
+++ b/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
diff --git a/Command/Copy.hs b/Command/Copy.hs
index 395992ed0..e2bd1fce4 100644
--- a/Command/Copy.hs
+++ b/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)
diff --git a/Command/Drop.hs b/Command/Drop.hs
index bf832e8d5..d17302035 100644
--- a/Command/Drop.hs
+++ b/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
diff --git a/Command/Get.hs b/Command/Get.hs
index cdb85af94..fb2145fdd 100644
--- a/Command/Get.hs
+++ b/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
diff --git a/Command/Sync.hs b/Command/Sync.hs
index 9db3c7ad7..5763709ac 100644
--- a/Command/Sync.hs
+++ b/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 []
diff --git a/Limit/Wanted.hs b/Limit/Wanted.hs
index 7e9278202..01b8da6b3 100644
--- a/Limit/Wanted.hs
+++ b/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)
diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs
index 2a9aed36b..4b25ea094 100644
--- a/Logs/PreferredContent.hs
+++ b/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
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-11 00:03:19 +0000