diff options
author | Joey Hess <joey@kitenet.net> | 2014-03-29 14:43:34 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2014-03-29 14:43:34 -0400 |
commit | 9d7ce6bff0c9dcf66983eb100927fc7776c447f9 (patch) | |
tree | b3cf2fe44d25b092b16f08ba3680bf5719dc3a6c | |
parent | bce30628d5e6df5b64c482bc5fe161576efaaa79 (diff) |
reorg matcher types; no non-type code changes
-rw-r--r-- | Annex.hs | 13 | ||||
-rw-r--r-- | Annex/FileMatcher.hs | 17 | ||||
-rw-r--r-- | Assistant/Threads/Watcher.hs | 7 | ||||
-rw-r--r-- | Limit.hs | 46 | ||||
-rw-r--r-- | Logs.hs | 4 | ||||
-rw-r--r-- | Logs/PreferredContent.hs | 18 | ||||
-rw-r--r-- | Types/FileMatcher.hs | 21 | ||||
-rw-r--r-- | Types/Limit.hs | 20 |
8 files changed, 72 insertions, 74 deletions
@@ -10,7 +10,6 @@ module Annex ( Annex, AnnexState(..), - PreferredContentMap, new, run, eval, @@ -62,7 +61,6 @@ import Types.LockPool import Types.MetaData import Types.DesktopNotify import Types.CleanupActions -import qualified Utility.Matcher import qualified Data.Map as M import qualified Data.Set as S import Utility.Quvi (QuviVersion) @@ -81,9 +79,6 @@ newtype Annex a = Annex { runAnnex :: ReaderT (MVar AnnexState) IO a } Applicative ) -type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a) -type PreferredContentMap = M.Map UUID (Utility.Matcher.Matcher (S.Set UUID -> MatchInfo -> Annex Bool)) - -- internal state storage data AnnexState = AnnexState { repo :: Git.Repo @@ -104,9 +99,10 @@ data AnnexState = AnnexState , forcebackend :: Maybe String , globalnumcopies :: Maybe NumCopies , forcenumcopies :: Maybe NumCopies - , limit :: Matcher (MatchInfo -> Annex Bool) + , limit :: ExpandableMatcher Annex , uuidmap :: Maybe UUIDMap - , preferredcontentmap :: Maybe PreferredContentMap + , preferredcontentmap :: Maybe (FileMatcherMap Annex) + , requiredcontentmap :: Maybe (FileMatcherMap Annex) , shared :: Maybe SharedRepository , forcetrust :: TrustMap , trustmap :: Maybe TrustMap @@ -146,9 +142,10 @@ newState c r = AnnexState , forcebackend = Nothing , globalnumcopies = Nothing , forcenumcopies = Nothing - , limit = Left [] + , limit = BuildingMatcher [] , uuidmap = Nothing , preferredcontentmap = Nothing + , requiredcontentmap = Nothing , shared = Nothing , forcetrust = M.empty , trustmap = Nothing diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs index ae1bbb77b..da6a5e0e9 100644 --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -13,7 +13,6 @@ import Common.Annex import Limit import Utility.Matcher import Types.Group -import Types.Limit import Logs.Group import Logs.Remote import Annex.UUID @@ -25,12 +24,10 @@ import Types.Remote (RemoteConfig) import Data.Either import qualified Data.Set as S -type FileMatcher = Matcher MatchFiles - -checkFileMatcher :: FileMatcher -> FilePath -> Annex Bool +checkFileMatcher :: (FileMatcher Annex) -> FilePath -> Annex Bool checkFileMatcher matcher file = checkMatcher matcher Nothing (Just file) S.empty True -checkMatcher :: FileMatcher -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Bool -> Annex Bool +checkMatcher :: (FileMatcher Annex) -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Bool -> Annex Bool checkMatcher matcher mkey afile notpresent def | isEmpty matcher = return def | otherwise = case (mkey, afile) of @@ -48,15 +45,15 @@ fileMatchInfo file = do , relFile = file } -matchAll :: FileMatcher +matchAll :: FileMatcher Annex matchAll = generate [] -parsedToMatcher :: [Either String (Token MatchFiles)] -> Either String FileMatcher +parsedToMatcher :: [Either String (Token (MatchFiles Annex))] -> Either String (FileMatcher Annex) parsedToMatcher parsed = case partitionEithers parsed of ([], vs) -> Right $ generate vs (es, _) -> Left $ unwords $ map ("Parse failure: " ++) es -exprParser :: FileMatcher -> FileMatcher -> GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [Either String (Token MatchFiles)] +exprParser :: FileMatcher Annex -> FileMatcher Annex -> GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [Either String (Token (MatchFiles Annex))] exprParser matchstandard matchgroupwanted groupmap configmap mu expr = map parse $ tokenizeMatcher expr where @@ -69,7 +66,7 @@ exprParser matchstandard matchgroupwanted groupmap configmap mu expr = preferreddir = fromMaybe "public" $ M.lookup "preferreddir" =<< (`M.lookup` configmap) =<< mu -parseToken :: FileMatcher -> FileMatcher -> MkLimit -> MkLimit -> GroupMap -> String -> Either String (Token MatchFiles) +parseToken :: FileMatcher Annex -> FileMatcher Annex -> MkLimit Annex -> MkLimit Annex -> GroupMap -> String -> Either String (Token (MatchFiles Annex)) parseToken matchstandard matchgroupwanted checkpresent checkpreferreddir groupmap t | t `elem` tokens = Right $ token t | t == "standard" = call matchstandard @@ -106,7 +103,7 @@ tokenizeMatcher = filter (not . null ) . concatMap splitparens . words {- Generates a matcher for files large enough (or meeting other criteria) - to be added to the annex, rather than directly to git. -} -largeFilesMatcher :: Annex FileMatcher +largeFilesMatcher :: Annex (FileMatcher Annex) largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig where go Nothing = return matchAll diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 8a8e8faf0..97ccf083e 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -35,6 +35,7 @@ import Annex.CatFile import Annex.CheckIgnore import Annex.Link import Annex.FileMatcher +import Types.FileMatcher import Annex.ReplaceFile import Git.Types import Config @@ -196,7 +197,7 @@ runHandler handler file filestatus = void $ do | otherwise = f {- Small files are added to git as-is, while large ones go into the annex. -} -add :: FileMatcher -> FilePath -> Assistant (Maybe Change) +add :: FileMatcher Annex -> FilePath -> Assistant (Maybe Change) add bigfilematcher file = ifM (liftAnnex $ checkFileMatcher bigfilematcher file) ( pendingAddChange file , do @@ -205,7 +206,7 @@ add bigfilematcher file = ifM (liftAnnex $ checkFileMatcher bigfilematcher file) madeChange file AddFileChange ) -onAdd :: FileMatcher -> Handler +onAdd :: FileMatcher Annex -> Handler onAdd matcher file filestatus | maybe False isRegularFile filestatus = unlessIgnored file $ @@ -218,7 +219,7 @@ shouldRestage ds = scanComplete ds || forceRestage ds {- In direct mode, add events are received for both new files, and - modified existing files. -} -onAddDirect :: Bool -> FileMatcher -> Handler +onAddDirect :: Bool -> FileMatcher Annex -> Handler onAddDirect symlinkssupported matcher file fs = do v <- liftAnnex $ catKeyFile file case (v, fs) of @@ -20,7 +20,6 @@ import Types.TrustLevel import Types.Key import Types.Group import Types.FileMatcher -import Types.Limit import Types.MetaData import Logs.MetaData import Logs.Group @@ -45,21 +44,20 @@ getMatcher :: Annex (MatchInfo -> Annex Bool) getMatcher = Utility.Matcher.matchM <$> getMatcher' getMatcher' :: Annex (Utility.Matcher.Matcher (MatchInfo -> Annex Bool)) -getMatcher' = do - m <- Annex.getState Annex.limit - case m of - Right r -> return r - Left l -> do - let matcher = Utility.Matcher.generate (reverse l) - Annex.changeState $ \s -> - s { Annex.limit = Right matcher } - return matcher +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 {- Adds something to the limit list, which is built up reversed. -} add :: Utility.Matcher.Token (MatchInfo -> Annex Bool) -> Annex () add l = Annex.changeState $ \s -> s { Annex.limit = prepend $ Annex.limit s } where - prepend (Left ls) = Left $ l:ls + prepend (BuildingMatcher ls) = BuildingMatcher $ l:ls prepend _ = error "internal" {- Adds a new token. -} @@ -67,21 +65,21 @@ addToken :: String -> Annex () addToken = add . Utility.Matcher.token {- Adds a new limit. -} -addLimit :: Either String MatchFiles -> Annex () +addLimit :: Either String (MatchFiles Annex) -> Annex () addLimit = either error (\l -> add $ Utility.Matcher.Operation $ l S.empty) {- Add a limit to skip files that do not match the glob. -} addInclude :: String -> Annex () addInclude = addLimit . limitInclude -limitInclude :: MkLimit +limitInclude :: MkLimit Annex limitInclude glob = Right $ const $ return . matchGlobFile glob {- Add a limit to skip files that match the glob. -} addExclude :: String -> Annex () addExclude = addLimit . limitExclude -limitExclude :: MkLimit +limitExclude :: MkLimit Annex limitExclude glob = Right $ const $ return . not . matchGlobFile glob matchGlobFile :: String -> (MatchInfo -> Bool) @@ -119,10 +117,10 @@ addIn s = addLimit =<< mk else inAnnex key {- Limit to content that is currently present on a uuid. -} -limitPresent :: Maybe UUID -> MkLimit +limitPresent :: Maybe UUID -> MkLimit Annex limitPresent u _ = Right $ matchPresent u -matchPresent :: Maybe UUID -> MatchFiles +matchPresent :: Maybe UUID -> MatchFiles Annex matchPresent u _ = checkKey $ \key -> do hereu <- getUUID if u == Just hereu || isNothing u @@ -132,7 +130,7 @@ matchPresent u _ = checkKey $ \key -> do return $ maybe False (`elem` us) u {- Limit to content that is in a directory, anywhere in the repository tree -} -limitInDir :: FilePath -> MkLimit +limitInDir :: FilePath -> MkLimit Annex limitInDir dir = const $ Right $ const go where go (MatchingFile fi) = return $ elem dir $ splitPath $ takeDirectory $ matchFile fi @@ -143,7 +141,7 @@ limitInDir dir = const $ Right $ const go addCopies :: String -> Annex () addCopies = addLimit . limitCopies -limitCopies :: MkLimit +limitCopies :: MkLimit Annex limitCopies want = case split ":" want of [v, n] -> case parsetrustspec v of Just checker -> go n $ checktrust checker @@ -169,7 +167,7 @@ limitCopies want = case split ":" want of addLackingCopies :: Bool -> String -> Annex () addLackingCopies approx = addLimit . limitLackingCopies approx -limitLackingCopies :: Bool -> MkLimit +limitLackingCopies :: Bool -> MkLimit Annex limitLackingCopies approx want = case readish want of Just needed -> Right $ \notpresent mi -> flip checkKey mi $ handle mi needed notpresent @@ -191,7 +189,7 @@ limitLackingCopies approx want = case readish want of - This has a nice optimisation: When a file exists, - its key is obviously not unused. -} -limitUnused :: MatchFiles +limitUnused :: MatchFiles Annex limitUnused _ (MatchingFile _) = return False limitUnused _ (MatchingKey k) = S.member k <$> unusedKeys @@ -202,7 +200,7 @@ addInAllGroup groupname = do m <- groupMap addLimit $ limitInAllGroup m groupname -limitInAllGroup :: GroupMap -> MkLimit +limitInAllGroup :: GroupMap -> MkLimit Annex limitInAllGroup m groupname | S.null want = Right $ const $ const $ return True | otherwise = Right $ \notpresent -> checkKey $ check notpresent @@ -219,7 +217,7 @@ limitInAllGroup m groupname addInBackend :: String -> Annex () addInBackend = addLimit . limitInBackend -limitInBackend :: MkLimit +limitInBackend :: MkLimit Annex limitInBackend name = Right $ const $ checkKey check where check key = pure $ keyBackendName key == name @@ -231,7 +229,7 @@ addLargerThan = addLimit . limitSize (>) addSmallerThan :: String -> Annex () addSmallerThan = addLimit . limitSize (<) -limitSize :: (Maybe Integer -> Maybe Integer -> Bool) -> MkLimit +limitSize :: (Maybe Integer -> Maybe Integer -> Bool) -> MkLimit Annex limitSize vs s = case readSize dataUnits s of Nothing -> Left "bad size" Just sz -> Right $ go sz @@ -249,7 +247,7 @@ limitSize vs s = case readSize dataUnits s of addMetaData :: String -> Annex () addMetaData = addLimit . limitMetaData -limitMetaData :: MkLimit +limitMetaData :: MkLimit Annex limitMetaData s = case parseMetaData s of Left e -> Left e Right (f, v) -> @@ -35,6 +35,7 @@ topLevelUUIDBasedLogs = , trustLog , groupLog , preferredContentLog + , requiredContentLog , scheduleLog ] @@ -70,6 +71,9 @@ groupLog = "group.log" preferredContentLog :: FilePath preferredContentLog = "preferred-content.log" +requiredContentLog :: FilePath +requiredContentLog = "required-content.log" + groupPreferredContentLog :: FilePath groupPreferredContentLog = "group-preferred-content.log" diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs index 5580c062d..480ac2e6d 100644 --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -28,14 +28,14 @@ import qualified Annex.Branch import qualified Annex import Logs import Logs.UUIDBased -import qualified Utility.Matcher +import Utility.Matcher hiding (tokens) import Annex.FileMatcher import Annex.UUID -import Types.Limit import Types.Group import Types.Remote (RemoteConfig) import Logs.Group import Logs.Remote +import Types.FileMatcher import Types.StandardGroups import Limit @@ -50,12 +50,12 @@ isPreferredContent mu notpresent mkey afile def = do Just matcher -> checkMatcher matcher mkey afile notpresent def {- The map is cached for speed. -} -preferredContentMap :: Annex Annex.PreferredContentMap +preferredContentMap :: Annex (FileMatcherMap Annex) preferredContentMap = maybe preferredContentMapLoad return =<< Annex.getState Annex.preferredcontentmap {- Loads the map, updating the cache. -} -preferredContentMapLoad :: Annex Annex.PreferredContentMap +preferredContentMapLoad :: Annex (FileMatcherMap Annex) preferredContentMapLoad = do groupmap <- groupMap configmap <- readRemoteLog @@ -75,11 +75,11 @@ makeMatcher -> M.Map Group PreferredContentExpression -> UUID -> PreferredContentExpression - -> FileMatcher + -> FileMatcher Annex makeMatcher groupmap configmap groupwantedmap u = go True True where go expandstandard expandgroupwanted expr - | null (lefts tokens) = Utility.Matcher.generate $ rights tokens + | null (lefts tokens) = generate $ rights tokens | otherwise = unknownMatcher u where tokens = exprParser matchstandard matchgroupwanted groupmap configmap (Just u) expr @@ -102,10 +102,10 @@ makeMatcher groupmap configmap groupwantedmap u = go True True - - This avoid unwanted/expensive changes to the content, until the problem - is resolved. -} -unknownMatcher :: UUID -> FileMatcher -unknownMatcher u = Utility.Matcher.generate [present] +unknownMatcher :: UUID -> FileMatcher Annex +unknownMatcher u = generate [present] where - present = Utility.Matcher.Operation $ matchPresent (Just u) + present = Operation $ matchPresent (Just u) {- Checks if an expression can be parsed, if not returns Just error -} checkPreferredContentExpression :: PreferredContentExpression -> Maybe String diff --git a/Types/FileMatcher.hs b/Types/FileMatcher.hs index e2d4eadc1..03a86a38c 100644 --- a/Types/FileMatcher.hs +++ b/Types/FileMatcher.hs @@ -7,7 +7,12 @@ module Types.FileMatcher where +import Types.UUID (UUID) import Types.Key (Key) +import Utility.Matcher (Matcher, Token) + +import qualified Data.Map as M +import qualified Data.Set as S data MatchInfo = MatchingFile FileInfo @@ -17,3 +22,19 @@ data FileInfo = FileInfo { relFile :: FilePath -- may be relative to cwd , matchFile :: FilePath -- filepath to match on; may be relative to top } + +type FileMatcherMap a = M.Map UUID (Utility.Matcher.Matcher (S.Set UUID -> MatchInfo -> a Bool)) + +type MkLimit a = String -> Either String (MatchFiles a) + +type AssumeNotPresent = S.Set UUID + +type MatchFiles a = AssumeNotPresent -> MatchInfo -> a Bool + +type FileMatcher a = Matcher (MatchFiles a) + +-- This is a matcher that can have tokens added to it while it's being +-- built, and once complete is compiled to an unchangable matcher. +data ExpandableMatcher a + = BuildingMatcher [Token (MatchInfo -> a Bool)] + | CompleteMatcher (Matcher (MatchInfo -> a Bool)) diff --git a/Types/Limit.hs b/Types/Limit.hs deleted file mode 100644 index 2b009a758..000000000 --- a/Types/Limit.hs +++ /dev/null @@ -1,20 +0,0 @@ -{- types for limits - - - - Copyright 2013 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE CPP #-} - -module Types.Limit where - -import Common.Annex -import Types.FileMatcher - -import qualified Data.Set as S - -type MkLimit = String -> Either String MatchFiles - -type AssumeNotPresent = S.Set UUID -type MatchFiles = AssumeNotPresent -> MatchInfo -> Annex Bool |