generalized Annex.Wanted
this should make it easy to use from inside the assistant, where everything is an AssociatedFile.
This commit is contained in:
parent
acb8721072
commit
fee40dd374
5 changed files with 28 additions and 33 deletions
|
@ -8,43 +8,33 @@
|
||||||
module Annex.Wanted where
|
module Annex.Wanted where
|
||||||
|
|
||||||
import Common.Annex
|
import Common.Annex
|
||||||
import qualified Remote
|
|
||||||
import Annex.Content
|
|
||||||
import Logs.PreferredContent
|
import Logs.PreferredContent
|
||||||
import Git.FilePath
|
import Git.FilePath
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
import Annex.UUID
|
import Annex.UUID
|
||||||
|
import Types.Remote
|
||||||
|
|
||||||
import qualified Data.Set as S
|
import qualified Data.Set as S
|
||||||
|
|
||||||
checkAuto :: (Bool -> Annex Bool) -> Annex Bool
|
{- Check if a file is preferred content for the local repository. -}
|
||||||
checkAuto a = Annex.getState Annex.auto >>= a
|
wantGet :: AssociatedFile -> Annex Bool
|
||||||
|
wantGet Nothing = return True
|
||||||
{- A file's content should be gotten if it's not already present.
|
wantGet (Just file) = do
|
||||||
- In auto mode, only get files that are preferred content. -}
|
|
||||||
shouldGet :: FilePath -> Key -> Bool -> Annex Bool
|
|
||||||
shouldGet file key auto = (not <$> inAnnex key) <&&> want
|
|
||||||
where
|
|
||||||
want
|
|
||||||
| auto = do
|
|
||||||
fp <- inRepo $ toTopFilePath file
|
fp <- inRepo $ toTopFilePath file
|
||||||
isPreferredContent Nothing S.empty fp
|
isPreferredContent Nothing S.empty fp
|
||||||
| otherwise = return True
|
|
||||||
|
|
||||||
{- A file's content should be sent to a remote.
|
{- Check if a file is preferred content for a remote. -}
|
||||||
- In auto mode, only send files that are preferred content of the remote. -}
|
wantSend :: UUID -> AssociatedFile -> Annex Bool
|
||||||
shouldSend :: Remote -> FilePath -> Bool -> Annex Bool
|
wantSend _ Nothing = return True
|
||||||
shouldSend _ _ False = return True
|
wantSend to (Just file) = do
|
||||||
shouldSend to file True = do
|
|
||||||
fp <- inRepo $ toTopFilePath file
|
fp <- inRepo $ toTopFilePath file
|
||||||
isPreferredContent (Just $ Remote.uuid to) S.empty fp
|
isPreferredContent (Just to) S.empty fp
|
||||||
|
|
||||||
{- A file's content should be dropped normally.
|
{- Check if a file can be dropped, maybe from a remote.
|
||||||
- (This does not check numcopies though.)
|
- Don't drop files that are preferred content. -}
|
||||||
- In auto mode, hold on to preferred content. -}
|
wantDrop :: Maybe UUID -> AssociatedFile -> Annex Bool
|
||||||
shouldDrop :: Maybe Remote -> FilePath -> Bool -> Annex Bool
|
wantDrop _ Nothing = return True
|
||||||
shouldDrop _ _ False = return True
|
wantDrop from (Just file) = do
|
||||||
shouldDrop from file True = do
|
|
||||||
fp <- inRepo $ toTopFilePath file
|
fp <- inRepo $ toTopFilePath file
|
||||||
u <- maybe getUUID (return . Remote.uuid) from
|
u <- maybe getUUID (return . id) from
|
||||||
not <$> isPreferredContent (Just u) (S.singleton u) fp
|
not <$> isPreferredContent (Just u) (S.singleton u) fp
|
||||||
|
|
|
@ -22,6 +22,7 @@ module Command (
|
||||||
numCopies,
|
numCopies,
|
||||||
autoCopies,
|
autoCopies,
|
||||||
autoCopiesWith,
|
autoCopiesWith,
|
||||||
|
checkAuto,
|
||||||
module ReExported
|
module ReExported
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
@ -137,3 +138,7 @@ autoCopiesWith file key vs a = do
|
||||||
if length have `vs` needed
|
if length have `vs` needed
|
||||||
then a numcopiesattr
|
then a numcopiesattr
|
||||||
else stop
|
else stop
|
||||||
|
|
||||||
|
checkAuto :: Annex Bool -> Annex Bool
|
||||||
|
checkAuto checker = ifM (Annex.getState Annex.auto)
|
||||||
|
( checker , return True )
|
||||||
|
|
|
@ -31,5 +31,5 @@ start to from file (key, backend) = autoCopies file key (<) $
|
||||||
Command.Move.start to from False file (key, backend)
|
Command.Move.start to from False file (key, backend)
|
||||||
where
|
where
|
||||||
shouldCopy = case to of
|
shouldCopy = case to of
|
||||||
Nothing -> checkAuto $ shouldGet file key
|
Nothing -> checkAuto $ wantGet (Just file)
|
||||||
Just r -> checkAuto $ shouldSend r file
|
Just r -> checkAuto $ wantSend (Remote.uuid r) (Just file)
|
||||||
|
|
|
@ -32,7 +32,7 @@ seek = [withField fromOption Remote.byName $ \from ->
|
||||||
|
|
||||||
start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
|
start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
|
||||||
start from file (key, _) = autoCopiesWith file key (>) $ \numcopies ->
|
start from file (key, _) = autoCopiesWith file key (>) $ \numcopies ->
|
||||||
stopUnless (checkAuto $ shouldDrop from file) $
|
stopUnless (checkAuto $ wantDrop (Remote.uuid <$> from) (Just file)) $
|
||||||
case from of
|
case from of
|
||||||
Nothing -> startLocal file numcopies key
|
Nothing -> startLocal file numcopies key
|
||||||
Just remote -> do
|
Just remote -> do
|
||||||
|
|
|
@ -24,7 +24,7 @@ seek = [withField Command.Move.fromOption Remote.byName $ \from ->
|
||||||
withFilesInGit $ whenAnnexed $ start from]
|
withFilesInGit $ whenAnnexed $ start from]
|
||||||
|
|
||||||
start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
|
start :: Maybe Remote -> FilePath -> (Key, Backend) -> CommandStart
|
||||||
start from file (key, _) = stopUnless (checkAuto $ shouldGet file key) $
|
start from file (key, _) = stopUnless ((not <$> inAnnex key) <&&> checkAuto (wantGet $ Just file)) $
|
||||||
autoCopies file key (<) $
|
autoCopies file key (<) $
|
||||||
case from of
|
case from of
|
||||||
Nothing -> go $ perform key file
|
Nothing -> go $ perform key file
|
||||||
|
|
Loading…
Add table
Reference in a new issue