diff options
author | Joey Hess <joey@kitenet.net> | 2012-10-18 15:22:28 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-10-18 15:22:28 -0400 |
commit | 3e369ace228e984224c417c6f3524f0b4f5900ac (patch) | |
tree | 01811ab6f0a1d49bd83a66ddbe556c0406fa81e8 | |
parent | b9138b54db85610ce16d31ef1d1e74c18ee25b87 (diff) |
split
-rw-r--r-- | Assistant/Drop.hs | 60 | ||||
-rw-r--r-- | Assistant/Threads/TransferScanner.hs | 44 | ||||
-rw-r--r-- | doc/design/assistant/transfer_control.mdwn | 2 |
3 files changed, 63 insertions, 43 deletions
diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs new file mode 100644 index 000000000..b3dca3929 --- /dev/null +++ b/Assistant/Drop.hs @@ -0,0 +1,60 @@ +{- git-annex assistant dropping of unwanted content + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Drop where + +import Assistant.Common +import Logs.Location +import Logs.Trust +import qualified Remote +import qualified Command.Drop +import Command +import Annex.Wanted +import Config + +{- Drop from local or remote when allowed by the preferred content and + - numcopies settings. -} +handleDrops :: [Remote] -> Bool -> FilePath -> Key -> Annex () +handleDrops rs present f key = do + locs <- loggedLocations key + handleDrops' locs rs present f key + +handleDrops' :: [UUID] -> [Remote] -> Bool -> FilePath -> Key -> Annex () +handleDrops' locs rs present f key + | present = do + n <- getcopies + if checkcopies n + then go rs =<< dropl n + else go rs n + | otherwise = go rs =<< getcopies + where + getcopies = do + have <- length . snd <$> trustPartition UnTrusted locs + numcopies <- getNumCopies =<< numCopies f + return (have, numcopies) + checkcopies (have, numcopies) = have > numcopies + decrcopies (have, numcopies) = (have - 1, numcopies) + + go [] _ = noop + go (r:rest) n + | checkcopies n = dropr r n >>= go rest + | otherwise = noop + + checkdrop n@(_, numcopies) u a = + ifM (wantDrop u (Just f)) + ( ifM (doCommand $ a (Just numcopies)) + ( return $ decrcopies n + , return n + ) + , return n + ) + + dropl n = checkdrop n Nothing $ \numcopies -> + Command.Drop.startLocal f numcopies key + + dropr r n = checkdrop n (Just $ Remote.uuid r) $ \numcopies -> + Command.Drop.startRemote f numcopies key r diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index 6606bdc35..5eb3784bd 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -13,19 +13,17 @@ import Assistant.TransferQueue import Assistant.ThreadedMonad import Assistant.DaemonStatus import Assistant.Alert +import Assistant.Drop import Logs.Transfer import Logs.Location -import Logs.Trust import Logs.Web (webUUID) import qualified Remote import qualified Types.Remote as Remote import Utility.ThreadScheduler import qualified Git.LsFiles as LsFiles -import qualified Command.Drop import Command import Annex.Content import Annex.Wanted -import Config import qualified Data.Set as S @@ -127,7 +125,7 @@ expensiveScan st dstatus transferqueue rs = unless onlyweb $ do syncrs <- liftIO $ syncRemotes <$> getDaemonStatus dstatus present <- inAnnex key - handleDrops locs syncrs present f key + handleDrops' locs syncrs present f key let slocs = S.fromList locs let use a = return $ catMaybes $ map (a key slocs) syncrs @@ -144,44 +142,6 @@ genTransfer direction want key slocs r (r, Transfer direction (Remote.uuid r) key) | otherwise = Nothing -{- Drop from local or remote when allowed by the preferred content and - - numcopies settings. -} -handleDrops :: [UUID] -> [Remote] -> Bool -> FilePath -> Key -> Annex () -handleDrops locs rs present f key - | present = do - n <- getcopies - if checkcopies n - then go rs =<< dropl n - else go rs n - | otherwise = go rs =<< getcopies - where - getcopies = do - have <- length . snd <$> trustPartition UnTrusted locs - numcopies <- getNumCopies =<< numCopies f - return (have, numcopies) - checkcopies (have, numcopies) = have > numcopies - decrcopies (have, numcopies) = (have - 1, numcopies) - - go [] _ = noop - go (r:rest) n - | checkcopies n = dropr r n >>= go rest - | otherwise = noop - - checkdrop n@(_, numcopies) u a = - ifM (wantDrop u (Just f)) - ( ifM (doCommand $ a (Just numcopies)) - ( return $ decrcopies n - , return n - ) - , return n - ) - - dropl n = checkdrop n Nothing $ \numcopies -> - Command.Drop.startLocal f numcopies key - - dropr r n = checkdrop n (Just $ Remote.uuid r) $ \numcopies -> - Command.Drop.startRemote f numcopies key r - remoteHas :: Remote -> Key -> Annex Bool remoteHas r key = elem <$> pure (Remote.uuid r) diff --git a/doc/design/assistant/transfer_control.mdwn b/doc/design/assistant/transfer_control.mdwn index 54b7a30c2..390812320 100644 --- a/doc/design/assistant/transfer_control.mdwn +++ b/doc/design/assistant/transfer_control.mdwn @@ -32,7 +32,7 @@ the same content, this gets tricky. Let's assume there are not.) with this is an expensive scan. (The rest of the items below come from analizing the terminals used in preferred content expressions.) **done** 2. renaming of a file (ie, moved to `archive/`) -3. some other repository gets the file (`in`, `copies`) +3. we get a file (`in`, `copies`) 4. some other repository drops the file (`in`, `copies` .. However, it's unlikely that an expression would prefer content when *more* copies exisited, and want to drop it when less do. That's nearly a pathological |