mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

add PreferredContentExpression type

Browse source
This commit is contained in:
Joey Hess 2014-01-01 19:58:02 -04:00
parent 255637ffa2
commit f0a6de1ca2
2 changed files with 8 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
Logs/PreferredContent.hs
View file

@ -37,7 +37,7 @@ import Logs.Remote
import Types.StandardGroups import Types.StandardGroups
{- Changes the preferred content configuration of a remote. -} {- Changes the preferred content configuration of a remote. -}
preferredContentSet :: UUID -> String -> Annex () preferredContentSet :: UUID -> PreferredContentExpression -> Annex ()
preferredContentSet uuid@(UUID _) val = do preferredContentSet uuid@(UUID _) val = do
ts <- liftIO getPOSIXTime ts <- liftIO getPOSIXTime
Annex.Branch.change preferredContentLog $ Annex.Branch.change preferredContentLog $
@ -71,7 +71,7 @@ preferredContentMapLoad = do
Annex.changeState $ \s -> s { Annex.preferredcontentmap = Just m } Annex.changeState $ \s -> s { Annex.preferredcontentmap = Just m }
return m return m
preferredContentMapRaw :: Annex (M.Map UUID String) preferredContentMapRaw :: Annex (M.Map UUID PreferredContentExpression)
preferredContentMapRaw = simpleMap . parseLog Just preferredContentMapRaw = simpleMap . parseLog Just
<$> Annex.Branch.get preferredContentLog <$> Annex.Branch.get preferredContentLog
@ -79,7 +79,7 @@ preferredContentMapRaw = simpleMap . parseLog Just
- because the configuration is shared among repositories and newer - because the configuration is shared among repositories and newer
- versions of git-annex may add new features. Instead, parse errors - versions of git-annex may add new features. Instead, parse errors
- result in a Matcher that will always succeed. -} - result in a Matcher that will always succeed. -}
makeMatcher :: GroupMap -> M.Map UUID RemoteConfig -> UUID -> String -> FileMatcher makeMatcher :: GroupMap -> M.Map UUID RemoteConfig -> UUID -> PreferredContentExpression -> FileMatcher
makeMatcher groupmap configmap u expr makeMatcher groupmap configmap u expr
| expr == "standard" = standardMatcher groupmap configmap u | expr == "standard" = standardMatcher groupmap configmap u
| null (lefts tokens) = Utility.Matcher.generate $ rights tokens | null (lefts tokens) = Utility.Matcher.generate $ rights tokens
@ -95,7 +95,7 @@ standardMatcher groupmap configmap u =
getStandardGroup =<< u `M.lookup` groupsByUUID groupmap getStandardGroup =<< u `M.lookup` groupsByUUID groupmap
{- Checks if an expression can be parsed, if not returns Just error -} {- Checks if an expression can be parsed, if not returns Just error -}
checkPreferredContentExpression :: String -> Maybe String checkPreferredContentExpression :: PreferredContentExpression -> Maybe String
checkPreferredContentExpression expr checkPreferredContentExpression expr
| expr == "standard" = Nothing | expr == "standard" = Nothing
| otherwise = case parsedToMatcher tokens of | otherwise = case parsedToMatcher tokens of

6
Types/StandardGroups.hs
View file

@ -12,6 +12,8 @@ import Types.Remote (RemoteConfig)
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe import Data.Maybe
type PreferredContentExpression = String
data StandardGroup data StandardGroup
= ClientGroup = ClientGroup
| TransferGroup | TransferGroup
@ -71,7 +73,7 @@ associatedDirectory Nothing PublicGroup = Just "public"
associatedDirectory _ _ = Nothing associatedDirectory _ _ = Nothing
{- See doc/preferred_content.mdwn for explanations of these expressions. -} {- See doc/preferred_content.mdwn for explanations of these expressions. -}
preferredContent :: StandardGroup -> String preferredContent :: StandardGroup -> PreferredContentExpression
preferredContent ClientGroup = lastResort $ preferredContent ClientGroup = lastResort $
"(exclude=*/archive/* and exclude=archive/*) or (" ++ notArchived ++ ")" "(exclude=*/archive/* and exclude=archive/*) or (" ++ notArchived ++ ")"
preferredContent TransferGroup = lastResort $ preferredContent TransferGroup = lastResort $
@ -92,5 +94,5 @@ notArchived = "not (copies=archive:1 or copies=smallarchive:1)"
{- Most repositories want any content that is only on untrusted {- Most repositories want any content that is only on untrusted
- or dead repositories. -} - or dead repositories. -}
lastResort :: String -> String lastResort :: String -> PreferredContentExpression
lastResort s = "(" ++ s ++ ") or (not copies=semitrusted+:1)" lastResort s = "(" ++ s ++ ") or (not copies=semitrusted+:1)"