2011-09-18 21:47:49 +00:00
|
|
|
{- user-specified limits on files to act on
|
|
|
|
-
|
2019-09-19 15:32:12 +00:00
|
|
|
- Copyright 2011-2019 Joey Hess <id@joeyh.name>
|
2011-09-18 21:47:49 +00:00
|
|
|
-
|
2019-03-13 19:48:14 +00:00
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
2011-09-18 21:47:49 +00:00
|
|
|
-}
|
|
|
|
|
|
|
|
module Limit where
|
|
|
|
|
2016-01-20 20:36:33 +00:00
|
|
|
import Annex.Common
|
2011-10-04 02:24:57 +00:00
|
|
|
import qualified Annex
|
2011-09-18 21:47:49 +00:00
|
|
|
import qualified Utility.Matcher
|
2011-09-19 00:14:18 +00:00
|
|
|
import qualified Remote
|
2011-10-04 04:40:47 +00:00
|
|
|
import Annex.Content
|
2015-12-15 19:34:28 +00:00
|
|
|
import Annex.WorkTree
|
2015-07-31 20:00:13 +00:00
|
|
|
import Annex.Action
|
2012-10-05 20:52:44 +00:00
|
|
|
import Annex.UUID
|
2019-01-23 16:39:02 +00:00
|
|
|
import Annex.Magic
|
2019-09-19 15:32:12 +00:00
|
|
|
import Annex.Link
|
2012-09-23 17:50:31 +00:00
|
|
|
import Logs.Trust
|
2015-04-30 18:02:56 +00:00
|
|
|
import Annex.NumCopies
|
2017-02-24 19:16:56 +00:00
|
|
|
import Types.Key
|
2012-10-03 21:04:52 +00:00
|
|
|
import Types.TrustLevel
|
2012-10-08 19:18:58 +00:00
|
|
|
import Types.Group
|
2013-05-25 03:07:26 +00:00
|
|
|
import Types.FileMatcher
|
2014-02-13 06:24:30 +00:00
|
|
|
import Types.MetaData
|
2016-02-27 14:55:02 +00:00
|
|
|
import Annex.MetaData
|
2014-02-13 06:24:30 +00:00
|
|
|
import Logs.MetaData
|
2012-10-01 22:25:11 +00:00
|
|
|
import Logs.Group
|
2014-01-22 20:35:32 +00:00
|
|
|
import Logs.Unused
|
2014-02-06 16:43:56 +00:00
|
|
|
import Logs.Location
|
|
|
|
import Git.Types (RefDate(..))
|
2014-02-21 22:34:34 +00:00
|
|
|
import Utility.Glob
|
2012-09-25 20:48:24 +00:00
|
|
|
import Utility.HumanTime
|
2012-10-08 17:39:18 +00:00
|
|
|
import Utility.DataUnits
|
2011-09-18 21:47:49 +00:00
|
|
|
|
2014-02-11 05:35:11 +00:00
|
|
|
import Data.Time.Clock.POSIX
|
|
|
|
import qualified Data.Set as S
|
|
|
|
import qualified Data.Map as M
|
2013-05-26 22:14:03 +00:00
|
|
|
|
2011-09-19 00:41:51 +00:00
|
|
|
{- Checks if there are user-specified limits. -}
|
|
|
|
limited :: Annex Bool
|
2012-12-06 17:22:16 +00:00
|
|
|
limited = (not . Utility.Matcher.isEmpty) <$> getMatcher'
|
2011-09-19 00:41:51 +00:00
|
|
|
|
2011-09-18 21:47:49 +00:00
|
|
|
{- Gets a matcher for the user-specified limits. The matcher is cached for
|
|
|
|
- speed; once it's obtained the user-specified limits can't change. -}
|
2014-01-18 18:51:55 +00:00
|
|
|
getMatcher :: Annex (MatchInfo -> Annex Bool)
|
2011-09-19 05:03:16 +00:00
|
|
|
getMatcher = Utility.Matcher.matchM <$> getMatcher'
|
2011-09-19 02:40:31 +00:00
|
|
|
|
2014-01-18 18:51:55 +00:00
|
|
|
getMatcher' :: Annex (Utility.Matcher.Matcher (MatchInfo -> Annex Bool))
|
2014-03-29 18:43:34 +00:00
|
|
|
getMatcher' = go =<< Annex.getState Annex.limit
|
|
|
|
where
|
|
|
|
go (CompleteMatcher matcher) = return matcher
|
|
|
|
go (BuildingMatcher l) = do
|
|
|
|
let matcher = Utility.Matcher.generate (reverse l)
|
|
|
|
Annex.changeState $ \s ->
|
|
|
|
s { Annex.limit = CompleteMatcher matcher }
|
|
|
|
return matcher
|
2011-09-18 21:47:49 +00:00
|
|
|
|
2011-09-18 22:21:42 +00:00
|
|
|
{- Adds something to the limit list, which is built up reversed. -}
|
2014-01-18 18:51:55 +00:00
|
|
|
add :: Utility.Matcher.Token (MatchInfo -> Annex Bool) -> Annex ()
|
2011-09-19 05:57:12 +00:00
|
|
|
add l = Annex.changeState $ \s -> s { Annex.limit = prepend $ Annex.limit s }
|
2012-10-29 02:09:09 +00:00
|
|
|
where
|
2014-03-29 18:43:34 +00:00
|
|
|
prepend (BuildingMatcher ls) = BuildingMatcher $ l:ls
|
2012-10-29 02:09:09 +00:00
|
|
|
prepend _ = error "internal"
|
2011-09-18 21:47:49 +00:00
|
|
|
|
2019-05-14 17:08:51 +00:00
|
|
|
{- Adds a new syntax token. -}
|
|
|
|
addSyntaxToken :: String -> Annex ()
|
|
|
|
addSyntaxToken = either error add . Utility.Matcher.syntaxToken
|
2011-09-20 04:49:40 +00:00
|
|
|
|
|
|
|
{- Adds a new limit. -}
|
2014-03-29 18:43:34 +00:00
|
|
|
addLimit :: Either String (MatchFiles Annex) -> Annex ()
|
2016-11-16 01:29:54 +00:00
|
|
|
addLimit = either giveup (\l -> add $ Utility.Matcher.Operation $ l S.empty)
|
2011-09-18 21:47:49 +00:00
|
|
|
|
|
|
|
{- Add a limit to skip files that do not match the glob. -}
|
2011-12-22 17:53:06 +00:00
|
|
|
addInclude :: String -> Annex ()
|
2012-10-04 19:48:59 +00:00
|
|
|
addInclude = addLimit . limitInclude
|
|
|
|
|
2014-03-29 18:43:34 +00:00
|
|
|
limitInclude :: MkLimit Annex
|
2016-01-25 20:16:18 +00:00
|
|
|
limitInclude glob = Right $ const $ matchGlobFile glob
|
2011-12-22 17:53:06 +00:00
|
|
|
|
|
|
|
{- Add a limit to skip files that match the glob. -}
|
2011-09-19 00:14:18 +00:00
|
|
|
addExclude :: String -> Annex ()
|
2012-10-04 19:48:59 +00:00
|
|
|
addExclude = addLimit . limitExclude
|
|
|
|
|
2014-03-29 18:43:34 +00:00
|
|
|
limitExclude :: MkLimit Annex
|
2016-01-25 20:16:18 +00:00
|
|
|
limitExclude glob = Right $ const $ not <$$> matchGlobFile glob
|
2014-02-21 22:34:34 +00:00
|
|
|
|
2016-01-25 20:16:18 +00:00
|
|
|
matchGlobFile :: String -> MatchInfo -> Annex Bool
|
2014-02-21 22:34:34 +00:00
|
|
|
matchGlobFile glob = go
|
2016-02-03 20:29:34 +00:00
|
|
|
where
|
|
|
|
cglob = compileGlob glob CaseSensative -- memoized
|
|
|
|
go (MatchingFile fi) = pure $ matchGlob cglob (matchFile fi)
|
2019-04-30 15:58:06 +00:00
|
|
|
go (MatchingInfo p) = matchGlob cglob <$> getInfo (providedFilePath p)
|
support findred and --branch with file matching options
* findref: Support file matching options: --include, --exclude,
--want-get, --want-drop, --largerthan, --smallerthan, --accessedwithin
* Commands supporting --branch now apply file matching options --include,
--exclude, --want-get, --want-drop to filenames from the branch.
Previously, combining --branch with those would fail to match anything.
* add, import, findref: Support --time-limit.
This commit was sponsored by Jake Vosloo on Patreon.
2018-12-09 17:38:35 +00:00
|
|
|
go (MatchingKey _ (AssociatedFile Nothing)) = pure False
|
|
|
|
go (MatchingKey _ (AssociatedFile (Just af))) = pure $ matchGlob cglob af
|
2016-02-03 20:29:34 +00:00
|
|
|
|
2019-09-19 15:32:12 +00:00
|
|
|
addMimeType :: String -> Annex ()
|
|
|
|
addMimeType = addMagicLimit "mimetype" getMagicMimeType providedMimeType
|
|
|
|
|
|
|
|
addMimeEncoding :: String -> Annex ()
|
|
|
|
addMimeEncoding = addMagicLimit "mimeencoding" getMagicMimeEncoding providedMimeEncoding
|
|
|
|
|
|
|
|
addMagicLimit :: String -> (Magic -> FilePath -> Annex (Maybe String)) -> (ProvidedInfo -> OptInfo String) -> String -> Annex ()
|
|
|
|
addMagicLimit limitname querymagic selectprovidedinfo glob = do
|
|
|
|
magic <- liftIO initMagicMime
|
|
|
|
addLimit $ matchMagic limitname querymagic' selectprovidedinfo magic glob
|
|
|
|
where
|
|
|
|
querymagic' magic f = liftIO (isPointerFile f) >>= \case
|
|
|
|
-- Avoid getting magic of a pointer file, which would
|
|
|
|
-- wrongly be detected as text.
|
|
|
|
Just _ -> return Nothing
|
|
|
|
-- When the file is an annex symlink, get magic of the
|
|
|
|
-- object file.
|
|
|
|
Nothing -> isAnnexLink f >>= \case
|
|
|
|
Just k -> withObjectLoc k $ querymagic magic
|
|
|
|
Nothing -> querymagic magic f
|
|
|
|
|
|
|
|
matchMagic :: String -> (Magic -> FilePath -> Annex (Maybe String)) -> (ProvidedInfo -> OptInfo String) -> Maybe Magic -> MkLimit Annex
|
2019-04-30 15:58:06 +00:00
|
|
|
matchMagic _limitname querymagic selectprovidedinfo (Just magic) glob = Right $ const go
|
2016-02-03 20:29:34 +00:00
|
|
|
where
|
|
|
|
cglob = compileGlob glob CaseSensative -- memoized
|
support findred and --branch with file matching options
* findref: Support file matching options: --include, --exclude,
--want-get, --want-drop, --largerthan, --smallerthan, --accessedwithin
* Commands supporting --branch now apply file matching options --include,
--exclude, --want-get, --want-drop to filenames from the branch.
Previously, combining --branch with those would fail to match anything.
* add, import, findref: Support --time-limit.
This commit was sponsored by Jake Vosloo on Patreon.
2018-12-09 17:38:35 +00:00
|
|
|
go (MatchingKey _ _) = pure False
|
2019-09-19 15:32:12 +00:00
|
|
|
go (MatchingFile fi) = catchBoolIO $
|
2019-01-23 16:39:02 +00:00
|
|
|
maybe False (matchGlob cglob)
|
2019-04-30 15:58:06 +00:00
|
|
|
<$> querymagic magic (currFile fi)
|
|
|
|
go (MatchingInfo p) =
|
|
|
|
matchGlob cglob <$> getInfo (selectprovidedinfo p)
|
|
|
|
matchMagic limitname _ _ Nothing _ =
|
|
|
|
Left $ "unable to load magic database; \""++limitname++"\" cannot be used"
|
2011-09-19 00:14:18 +00:00
|
|
|
|
2019-09-19 16:20:35 +00:00
|
|
|
addUnlocked :: Annex ()
|
|
|
|
addUnlocked = addLimit $ Right $ const $ matchLockStatus False
|
|
|
|
|
|
|
|
addLocked :: Annex ()
|
|
|
|
addLocked = addLimit $ Right $ const $ matchLockStatus True
|
|
|
|
|
|
|
|
matchLockStatus :: Bool -> MatchInfo -> Annex Bool
|
|
|
|
matchLockStatus _ (MatchingKey _ _) = pure False
|
|
|
|
matchLockStatus _ (MatchingInfo _) = pure False
|
|
|
|
matchLockStatus wantlocked (MatchingFile fi) = liftIO $ do
|
|
|
|
islocked <- isPointerFile (currFile fi) >>= \case
|
|
|
|
Just _key -> return False
|
|
|
|
Nothing -> isSymbolicLink
|
|
|
|
<$> getSymbolicLinkStatus (currFile fi)
|
|
|
|
return (islocked == wantlocked)
|
|
|
|
|
2011-09-19 00:14:18 +00:00
|
|
|
{- Adds a limit to skip files not believed to be present
|
2014-02-06 16:43:56 +00:00
|
|
|
- in a specfied repository. Optionally on a prior date. -}
|
2011-09-19 00:14:18 +00:00
|
|
|
addIn :: String -> Annex ()
|
2019-08-01 04:17:02 +00:00
|
|
|
addIn s = do
|
|
|
|
u <- Remote.nameToUUID name
|
|
|
|
hereu <- getUUID
|
|
|
|
addLimit $ if u == hereu && null date
|
|
|
|
then use inhere
|
|
|
|
else use (inuuid u)
|
2012-10-29 02:09:09 +00:00
|
|
|
where
|
2014-02-06 16:43:56 +00:00
|
|
|
(name, date) = separate (== '@') s
|
2019-08-01 04:17:02 +00:00
|
|
|
use a = Right $ checkKey . a
|
2014-03-13 22:51:44 +00:00
|
|
|
inuuid u notpresent key
|
2014-02-06 16:43:56 +00:00
|
|
|
| null date = do
|
|
|
|
us <- Remote.keyLocations key
|
|
|
|
return $ u `elem` us && u `S.notMember` notpresent
|
|
|
|
| otherwise = do
|
|
|
|
us <- loggedLocationsHistorical (RefDate date) key
|
|
|
|
return $ u `elem` us
|
2012-10-29 02:09:09 +00:00
|
|
|
inhere notpresent key
|
|
|
|
| S.null notpresent = inAnnex key
|
|
|
|
| otherwise = do
|
|
|
|
u <- getUUID
|
|
|
|
if u `S.member` notpresent
|
|
|
|
then return False
|
|
|
|
else inAnnex key
|
2011-09-19 00:23:08 +00:00
|
|
|
|
2012-10-19 20:09:21 +00:00
|
|
|
{- Limit to content that is currently present on a uuid. -}
|
2016-02-03 17:23:34 +00:00
|
|
|
limitPresent :: Maybe UUID -> MatchFiles Annex
|
|
|
|
limitPresent u _ = checkKey $ \key -> do
|
2012-10-19 20:09:21 +00:00
|
|
|
hereu <- getUUID
|
2013-04-03 07:52:41 +00:00
|
|
|
if u == Just hereu || isNothing u
|
2012-10-19 20:09:21 +00:00
|
|
|
then inAnnex key
|
|
|
|
else do
|
|
|
|
us <- Remote.keyLocations key
|
|
|
|
return $ maybe False (`elem` us) u
|
|
|
|
|
2013-04-26 03:44:55 +00:00
|
|
|
{- Limit to content that is in a directory, anywhere in the repository tree -}
|
2016-02-03 17:23:34 +00:00
|
|
|
limitInDir :: FilePath -> MatchFiles Annex
|
|
|
|
limitInDir dir = const go
|
2014-01-18 18:51:55 +00:00
|
|
|
where
|
2016-01-25 20:16:18 +00:00
|
|
|
go (MatchingFile fi) = checkf $ matchFile fi
|
support findred and --branch with file matching options
* findref: Support file matching options: --include, --exclude,
--want-get, --want-drop, --largerthan, --smallerthan, --accessedwithin
* Commands supporting --branch now apply file matching options --include,
--exclude, --want-get, --want-drop to filenames from the branch.
Previously, combining --branch with those would fail to match anything.
* add, import, findref: Support --time-limit.
This commit was sponsored by Jake Vosloo on Patreon.
2018-12-09 17:38:35 +00:00
|
|
|
go (MatchingKey _ (AssociatedFile Nothing)) = return False
|
|
|
|
go (MatchingKey _ (AssociatedFile (Just af))) = checkf af
|
2019-04-30 15:58:06 +00:00
|
|
|
go (MatchingInfo p) = checkf =<< getInfo (providedFilePath p)
|
2016-01-25 20:16:18 +00:00
|
|
|
checkf = return . elem dir . splitPath . takeDirectory
|
2013-04-26 03:44:55 +00:00
|
|
|
|
2011-09-19 00:23:08 +00:00
|
|
|
{- Adds a limit to skip files not believed to have the specified number
|
|
|
|
- of copies. -}
|
|
|
|
addCopies :: String -> Annex ()
|
2012-10-04 19:48:59 +00:00
|
|
|
addCopies = addLimit . limitCopies
|
|
|
|
|
2014-03-29 18:43:34 +00:00
|
|
|
limitCopies :: MkLimit Annex
|
2017-01-31 22:40:42 +00:00
|
|
|
limitCopies want = case splitc ':' want of
|
2018-06-04 16:12:56 +00:00
|
|
|
-- Note that in case of a group having the same name as a trust
|
|
|
|
-- level, it's parsed as a trust level, not as a group.
|
2013-04-03 03:40:13 +00:00
|
|
|
[v, n] -> case parsetrustspec v of
|
2013-04-03 21:44:34 +00:00
|
|
|
Just checker -> go n $ checktrust checker
|
2019-01-09 19:00:43 +00:00
|
|
|
Nothing -> go n $ checkgroup (toGroup v)
|
2012-10-04 19:48:59 +00:00
|
|
|
[n] -> go n $ const $ return True
|
|
|
|
_ -> Left "bad value for copies"
|
2012-10-29 02:09:09 +00:00
|
|
|
where
|
|
|
|
go num good = case readish num of
|
|
|
|
Nothing -> Left "bad number for copies"
|
2014-01-18 18:51:55 +00:00
|
|
|
Just n -> Right $ \notpresent -> checkKey $
|
unify exception handling into Utility.Exception
Removed old extensible-exceptions, only needed for very old ghc.
Made webdav use Utility.Exception, to work after some changes in DAV's
exception handling.
Removed Annex.Exception. Mostly this was trivial, but note that
tryAnnex is replaced with tryNonAsync and catchAnnex replaced with
catchNonAsync. In theory that could be a behavior change, since the former
caught all exceptions, and the latter don't catch async exceptions.
However, in practice, nothing in the Annex monad uses async exceptions.
Grepping for throwTo and killThread only find stuff in the assistant,
which does not seem related.
Command.Add.undo is changed to accept a SomeException, and things
that use it for rollback now catch non-async exceptions, rather than
only IOExceptions.
2014-08-08 01:55:44 +00:00
|
|
|
go' n good notpresent
|
|
|
|
go' n good notpresent key = do
|
2012-10-29 02:09:09 +00:00
|
|
|
us <- filter (`S.notMember` notpresent)
|
|
|
|
<$> (filterM good =<< Remote.keyLocations key)
|
|
|
|
return $ length us >= n
|
2013-04-03 21:44:34 +00:00
|
|
|
checktrust checker u = checker <$> lookupTrust u
|
2012-10-29 02:09:09 +00:00
|
|
|
checkgroup g u = S.member g <$> lookupGroups u
|
2013-04-03 03:40:13 +00:00
|
|
|
parsetrustspec s
|
2018-04-13 19:16:07 +00:00
|
|
|
| "+" `isSuffixOf` s = (<=) <$> readTrustLevel (beginning s)
|
2013-04-03 03:40:13 +00:00
|
|
|
| otherwise = (==) <$> readTrustLevel s
|
2011-11-28 21:37:15 +00:00
|
|
|
|
2014-01-21 22:46:39 +00:00
|
|
|
{- Adds a limit to match files that need more copies made. -}
|
|
|
|
addLackingCopies :: Bool -> String -> Annex ()
|
|
|
|
addLackingCopies approx = addLimit . limitLackingCopies approx
|
|
|
|
|
2014-03-29 18:43:34 +00:00
|
|
|
limitLackingCopies :: Bool -> MkLimit Annex
|
2014-01-21 22:46:39 +00:00
|
|
|
limitLackingCopies approx want = case readish want of
|
|
|
|
Just needed -> Right $ \notpresent mi -> flip checkKey mi $
|
unify exception handling into Utility.Exception
Removed old extensible-exceptions, only needed for very old ghc.
Made webdav use Utility.Exception, to work after some changes in DAV's
exception handling.
Removed Annex.Exception. Mostly this was trivial, but note that
tryAnnex is replaced with tryNonAsync and catchAnnex replaced with
catchNonAsync. In theory that could be a behavior change, since the former
caught all exceptions, and the latter don't catch async exceptions.
However, in practice, nothing in the Annex monad uses async exceptions.
Grepping for throwTo and killThread only find stuff in the assistant,
which does not seem related.
Command.Add.undo is changed to accept a SomeException, and things
that use it for rollback now catch non-async exceptions, rather than
only IOExceptions.
2014-08-08 01:55:44 +00:00
|
|
|
go mi needed notpresent
|
2014-01-21 22:46:39 +00:00
|
|
|
Nothing -> Left "bad value for number of lacking copies"
|
Add and use numcopiesneeded preferred content expression.
* Add numcopiesneeded preferred content expression.
* Client, transfer, incremental backup, and archive repositories
now want to get content that does not yet have enough copies.
This means the asssistant will make copies of files that don't yet
meet the configured numcopies, even to places that would not normally want
the file.
For example, if numcopies is 4, and there are 2 client repos and
2 transfer repos, and 2 removable backup drives, the file will be sent
to both transfer repos in order to make 4 copies. Once a removable drive
get a copy of the file, it will be dropped from one transfer repo or the
other (but not both).
Another example, numcopies is 3 and there is a client that has a backup
removable drive and two small archive repos. Normally once one of the small
archives has a file, it will not be put into the other one. But, to satisfy
numcopies, the assistant will duplicate it into the other small archive
too, if the backup repo is not available to receive the file.
I notice that these examples are fairly unlikely setups .. the old behavior
was not too bad, but it's nice to finally have it really correct.
.. Almost. I have skipped checking the annex.numcopies .gitattributes
out of fear it will be too slow.
This commit was sponsored by Florian Schlegel.
2014-01-20 21:34:58 +00:00
|
|
|
where
|
unify exception handling into Utility.Exception
Removed old extensible-exceptions, only needed for very old ghc.
Made webdav use Utility.Exception, to work after some changes in DAV's
exception handling.
Removed Annex.Exception. Mostly this was trivial, but note that
tryAnnex is replaced with tryNonAsync and catchAnnex replaced with
catchNonAsync. In theory that could be a behavior change, since the former
caught all exceptions, and the latter don't catch async exceptions.
However, in practice, nothing in the Annex monad uses async exceptions.
Grepping for throwTo and killThread only find stuff in the assistant,
which does not seem related.
Command.Add.undo is changed to accept a SomeException, and things
that use it for rollback now catch non-async exceptions, rather than
only IOExceptions.
2014-08-08 01:55:44 +00:00
|
|
|
go mi needed notpresent key = do
|
2014-01-21 22:46:39 +00:00
|
|
|
NumCopies numcopies <- if approx
|
|
|
|
then approxNumCopies
|
|
|
|
else case mi of
|
|
|
|
MatchingFile fi -> getGlobalFileNumCopies $ matchFile fi
|
support findred and --branch with file matching options
* findref: Support file matching options: --include, --exclude,
--want-get, --want-drop, --largerthan, --smallerthan, --accessedwithin
* Commands supporting --branch now apply file matching options --include,
--exclude, --want-get, --want-drop to filenames from the branch.
Previously, combining --branch with those would fail to match anything.
* add, import, findref: Support --time-limit.
This commit was sponsored by Jake Vosloo on Patreon.
2018-12-09 17:38:35 +00:00
|
|
|
MatchingKey _ _ -> approxNumCopies
|
2019-04-30 15:58:06 +00:00
|
|
|
MatchingInfo {} -> approxNumCopies
|
2014-01-21 22:46:39 +00:00
|
|
|
us <- filter (`S.notMember` notpresent)
|
|
|
|
<$> (trustExclude UnTrusted =<< Remote.keyLocations key)
|
|
|
|
return $ numcopies - length us >= needed
|
|
|
|
approxNumCopies = fromMaybe defaultNumCopies <$> getGlobalNumCopies
|
Add and use numcopiesneeded preferred content expression.
* Add numcopiesneeded preferred content expression.
* Client, transfer, incremental backup, and archive repositories
now want to get content that does not yet have enough copies.
This means the asssistant will make copies of files that don't yet
meet the configured numcopies, even to places that would not normally want
the file.
For example, if numcopies is 4, and there are 2 client repos and
2 transfer repos, and 2 removable backup drives, the file will be sent
to both transfer repos in order to make 4 copies. Once a removable drive
get a copy of the file, it will be dropped from one transfer repo or the
other (but not both).
Another example, numcopies is 3 and there is a client that has a backup
removable drive and two small archive repos. Normally once one of the small
archives has a file, it will not be put into the other one. But, to satisfy
numcopies, the assistant will duplicate it into the other small archive
too, if the backup repo is not available to receive the file.
I notice that these examples are fairly unlikely setups .. the old behavior
was not too bad, but it's nice to finally have it really correct.
.. Almost. I have skipped checking the annex.numcopies .gitattributes
out of fear it will be too slow.
This commit was sponsored by Florian Schlegel.
2014-01-20 21:34:58 +00:00
|
|
|
|
2014-01-22 20:35:32 +00:00
|
|
|
{- Match keys that are unused.
|
|
|
|
-
|
|
|
|
- This has a nice optimisation: When a file exists,
|
|
|
|
- its key is obviously not unused.
|
|
|
|
-}
|
2014-03-29 18:43:34 +00:00
|
|
|
limitUnused :: MatchFiles Annex
|
2014-01-22 20:35:32 +00:00
|
|
|
limitUnused _ (MatchingFile _) = return False
|
support findred and --branch with file matching options
* findref: Support file matching options: --include, --exclude,
--want-get, --want-drop, --largerthan, --smallerthan, --accessedwithin
* Commands supporting --branch now apply file matching options --include,
--exclude, --want-get, --want-drop to filenames from the branch.
Previously, combining --branch with those would fail to match anything.
* add, import, findref: Support --time-limit.
This commit was sponsored by Jake Vosloo on Patreon.
2018-12-09 17:38:35 +00:00
|
|
|
limitUnused _ (MatchingKey k _) = S.member k <$> unusedKeys
|
2019-04-30 15:58:06 +00:00
|
|
|
limitUnused _ (MatchingInfo p) = do
|
|
|
|
k <- getInfo (providedKey p)
|
2016-01-25 20:16:18 +00:00
|
|
|
S.member k <$> unusedKeys
|
2014-01-22 20:35:32 +00:00
|
|
|
|
2016-02-02 19:18:17 +00:00
|
|
|
{- Limit that matches any version of any file or key. -}
|
2015-06-16 21:03:34 +00:00
|
|
|
limitAnything :: MatchFiles Annex
|
|
|
|
limitAnything _ _ = return True
|
|
|
|
|
2016-02-02 19:18:17 +00:00
|
|
|
{- Limit that never matches. -}
|
|
|
|
limitNothing :: MatchFiles Annex
|
|
|
|
limitNothing _ _ = return False
|
|
|
|
|
2012-10-08 19:18:58 +00:00
|
|
|
{- Adds a limit to skip files not believed to be present in all
|
|
|
|
- repositories in the specified group. -}
|
2012-10-10 16:59:45 +00:00
|
|
|
addInAllGroup :: String -> Annex ()
|
2015-12-04 18:57:28 +00:00
|
|
|
addInAllGroup groupname = addLimit $ limitInAllGroup groupMap groupname
|
|
|
|
|
|
|
|
limitInAllGroup :: Annex GroupMap -> MkLimit Annex
|
|
|
|
limitInAllGroup getgroupmap groupname = Right $ \notpresent mi -> do
|
|
|
|
m <- getgroupmap
|
2019-01-09 19:00:43 +00:00
|
|
|
let want = fromMaybe S.empty $ M.lookup (toGroup groupname) $ uuidsByGroup m
|
2015-12-04 18:57:28 +00:00
|
|
|
if S.null want
|
|
|
|
then return True
|
2012-10-29 02:09:09 +00:00
|
|
|
-- optimisation: Check if a wanted uuid is notpresent.
|
2015-12-04 18:57:28 +00:00
|
|
|
else if not (S.null (S.intersection want notpresent))
|
|
|
|
then return False
|
|
|
|
else checkKey (check want) mi
|
|
|
|
where
|
|
|
|
check want key = do
|
|
|
|
present <- S.fromList <$> Remote.keyLocations key
|
|
|
|
return $ S.null $ want `S.difference` present
|
2012-10-08 19:18:58 +00:00
|
|
|
|
2011-11-28 21:37:15 +00:00
|
|
|
{- Adds a limit to skip files not using a specified key-value backend. -}
|
|
|
|
addInBackend :: String -> Annex ()
|
2012-10-04 19:48:59 +00:00
|
|
|
addInBackend = addLimit . limitInBackend
|
|
|
|
|
2014-03-29 18:43:34 +00:00
|
|
|
limitInBackend :: MkLimit Annex
|
2014-01-18 18:51:55 +00:00
|
|
|
limitInBackend name = Right $ const $ checkKey check
|
2012-10-29 02:09:09 +00:00
|
|
|
where
|
2017-02-24 19:16:56 +00:00
|
|
|
check key = pure $ keyVariety key == variety
|
2019-01-11 20:34:04 +00:00
|
|
|
variety = parseKeyVariety (encodeBS name)
|
2012-09-25 20:48:24 +00:00
|
|
|
|
2017-02-27 19:02:38 +00:00
|
|
|
{- Adds a limit to skip files not using a secure hash. -}
|
|
|
|
addSecureHash :: Annex ()
|
|
|
|
addSecureHash = addLimit $ Right limitSecureHash
|
|
|
|
|
|
|
|
limitSecureHash :: MatchFiles Annex
|
|
|
|
limitSecureHash _ = checkKey $ pure . cryptographicallySecure . keyVariety
|
|
|
|
|
2012-10-08 17:39:18 +00:00
|
|
|
{- Adds a limit to skip files that are too large or too small -}
|
|
|
|
addLargerThan :: String -> Annex ()
|
|
|
|
addLargerThan = addLimit . limitSize (>)
|
|
|
|
|
|
|
|
addSmallerThan :: String -> Annex ()
|
|
|
|
addSmallerThan = addLimit . limitSize (<)
|
|
|
|
|
2014-03-29 18:43:34 +00:00
|
|
|
limitSize :: (Maybe Integer -> Maybe Integer -> Bool) -> MkLimit Annex
|
2012-10-08 17:39:18 +00:00
|
|
|
limitSize vs s = case readSize dataUnits s of
|
|
|
|
Nothing -> Left "bad size"
|
2013-03-29 20:17:13 +00:00
|
|
|
Just sz -> Right $ go sz
|
2012-10-29 02:09:09 +00:00
|
|
|
where
|
2014-10-09 18:53:13 +00:00
|
|
|
go sz _ (MatchingFile fi) = lookupFileKey fi >>= check fi sz
|
support findred and --branch with file matching options
* findref: Support file matching options: --include, --exclude,
--want-get, --want-drop, --largerthan, --smallerthan, --accessedwithin
* Commands supporting --branch now apply file matching options --include,
--exclude, --want-get, --want-drop to filenames from the branch.
Previously, combining --branch with those would fail to match anything.
* add, import, findref: Support --time-limit.
This commit was sponsored by Jake Vosloo on Patreon.
2018-12-09 17:38:35 +00:00
|
|
|
go sz _ (MatchingKey key _) = checkkey sz key
|
2019-04-30 15:58:06 +00:00
|
|
|
go sz _ (MatchingInfo p) =
|
|
|
|
getInfo (providedFileSize p)
|
|
|
|
>>= \sz' -> return (Just sz' `vs` Just sz)
|
2014-01-18 18:51:55 +00:00
|
|
|
checkkey sz key = return $ keySize key `vs` Just sz
|
2014-04-17 22:03:39 +00:00
|
|
|
check _ sz (Just key) = checkkey sz key
|
2013-03-29 20:17:13 +00:00
|
|
|
check fi sz Nothing = do
|
2015-02-06 20:03:02 +00:00
|
|
|
filesize <- liftIO $ catchMaybeIO $ getFileSize (currFile fi)
|
2013-03-29 20:17:13 +00:00
|
|
|
return $ filesize `vs` Just sz
|
2012-10-08 17:39:18 +00:00
|
|
|
|
2014-02-13 06:24:30 +00:00
|
|
|
addMetaData :: String -> Annex ()
|
|
|
|
addMetaData = addLimit . limitMetaData
|
|
|
|
|
2014-03-29 18:43:34 +00:00
|
|
|
limitMetaData :: MkLimit Annex
|
2016-02-27 14:55:02 +00:00
|
|
|
limitMetaData s = case parseMetaDataMatcher s of
|
2014-02-13 06:24:30 +00:00
|
|
|
Left e -> Left e
|
2016-02-27 14:55:02 +00:00
|
|
|
Right (f, matching) -> Right $ const $ checkKey (check f matching)
|
2014-02-13 06:24:30 +00:00
|
|
|
where
|
2016-02-27 14:55:02 +00:00
|
|
|
check f matching k = not . S.null
|
|
|
|
. S.filter matching
|
2014-02-21 22:34:34 +00:00
|
|
|
. metaDataValues f <$> getCurrentMetaData k
|
2014-02-13 06:24:30 +00:00
|
|
|
|
2018-08-01 19:20:18 +00:00
|
|
|
addTimeLimit :: Duration -> Annex ()
|
|
|
|
addTimeLimit duration = do
|
2012-09-25 20:48:24 +00:00
|
|
|
start <- liftIO getPOSIXTime
|
2018-08-01 19:20:18 +00:00
|
|
|
let cutoff = start + durationToPOSIXTime duration
|
2012-10-05 20:52:44 +00:00
|
|
|
addLimit $ Right $ const $ const $ do
|
2012-09-25 20:48:24 +00:00
|
|
|
now <- liftIO getPOSIXTime
|
|
|
|
if now > cutoff
|
|
|
|
then do
|
2018-08-01 19:20:18 +00:00
|
|
|
warning $ "Time limit (" ++ fromDuration duration ++ ") reached!"
|
2015-07-31 20:00:13 +00:00
|
|
|
shutdown True
|
2012-09-25 20:48:24 +00:00
|
|
|
liftIO $ exitWith $ ExitFailure 101
|
|
|
|
else return True
|
2012-10-17 20:01:09 +00:00
|
|
|
|
2018-08-01 19:20:18 +00:00
|
|
|
addAccessedWithin :: Duration -> Annex ()
|
|
|
|
addAccessedWithin duration = do
|
|
|
|
now <- liftIO getPOSIXTime
|
|
|
|
addLimit $ Right $ const $ checkKey $ check now
|
|
|
|
where
|
|
|
|
check now k = inAnnexCheck k $ \f ->
|
|
|
|
liftIO $ catchDefaultIO False $ do
|
|
|
|
s <- getFileStatus f
|
|
|
|
let accessed = realToFrac (accessTime s)
|
|
|
|
let delta = now - accessed
|
|
|
|
return $ delta <= secs
|
|
|
|
secs = fromIntegral (durationSeconds duration)
|
|
|
|
|
2014-01-18 18:51:55 +00:00
|
|
|
lookupFileKey :: FileInfo -> Annex (Maybe Key)
|
2015-12-15 19:34:28 +00:00
|
|
|
lookupFileKey = lookupFile . currFile
|
2014-01-18 18:51:55 +00:00
|
|
|
|
|
|
|
checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool
|
|
|
|
checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a
|
support findred and --branch with file matching options
* findref: Support file matching options: --include, --exclude,
--want-get, --want-drop, --largerthan, --smallerthan, --accessedwithin
* Commands supporting --branch now apply file matching options --include,
--exclude, --want-get, --want-drop to filenames from the branch.
Previously, combining --branch with those would fail to match anything.
* add, import, findref: Support --time-limit.
This commit was sponsored by Jake Vosloo on Patreon.
2018-12-09 17:38:35 +00:00
|
|
|
checkKey a (MatchingKey k _) = a k
|
2019-04-30 15:58:06 +00:00
|
|
|
checkKey a (MatchingInfo p) = a =<< getInfo (providedKey p)
|
|
|
|
|