diff options
| -rw-r--r-- | Assistant/Threads/PairListener.hs | 12 | ||||
| -rw-r--r-- | Command/Dead.hs | 4 | ||||
| -rw-r--r-- | Logs/Group.hs | 8 | ||||
| -rw-r--r-- | Logs/PreferredContent.hs | 38 | ||||
| -rw-r--r-- | Logs/UUIDBased.hs | 12 | ||||
| -rw-r--r-- | Types/StandardGroups.hs | 37 | ||||
| -rw-r--r-- | debian/changelog | 3 | ||||
| -rw-r--r-- | doc/assistant/repogroups.png | bin | 0 -> 18490 bytes | |||
| -rw-r--r-- | doc/design/assistant/blog/day_102__very_high_level_programming.mdwn | 37 | ||||
| -rw-r--r-- | doc/preferred_content.mdwn | 46 |
10 files changed, 181 insertions, 16 deletions
diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 9ce369032..9875dcb8a 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -17,6 +17,7 @@ import Assistant.DaemonStatus import Assistant.WebApp import Assistant.WebApp.Types import Assistant.Alert +import Utility.ThreadScheduler import Network.Multicast import Network.Socket @@ -27,12 +28,17 @@ thisThread :: ThreadName thisThread = "PairListener" pairListenerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> UrlRenderer -> NamedThread -pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $ do - sock <- multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort - go sock [] [] +pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $ + runEvery (Seconds 1) $ void $ tryIO $ do + sock <- getsock + go sock [] [] where thread = NamedThread thisThread + {- Note this can crash if there's no network interface, + - or only one like lo that doesn't support multicast. -} + getsock = multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort + go sock reqs cache = getmsg sock [] >>= \msg -> case readish msg of Nothing -> go sock reqs cache Just m -> do diff --git a/Command/Dead.hs b/Command/Dead.hs index 192551e20..34595769f 100644 --- a/Command/Dead.hs +++ b/Command/Dead.hs @@ -11,6 +11,9 @@ import Common.Annex import Command import qualified Remote import Logs.Trust +import Logs.Group + +import qualified Data.Set as S def :: [Command] def = [command "dead" (paramRepeating paramRemote) seek @@ -29,4 +32,5 @@ start ws = do perform :: UUID -> CommandPerform perform uuid = do trustSet uuid DeadTrusted + groupSet uuid S.empty next $ return True diff --git a/Logs/Group.hs b/Logs/Group.hs index 09d431e63..56363f857 100644 --- a/Logs/Group.hs +++ b/Logs/Group.hs @@ -10,6 +10,7 @@ module Logs.Group ( groupSet, lookupGroups, groupMap, + getStandardGroup ) where import qualified Data.Map as M @@ -21,6 +22,7 @@ import qualified Annex.Branch import qualified Annex import Logs.UUIDBased import Types.Group +import Types.StandardGroups {- Filename of group.log. -} groupLog :: FilePath @@ -64,3 +66,9 @@ makeGroupMap byuuid = GroupMap byuuid bygroup bygroup = M.fromListWith S.union $ concat $ map explode $ M.toList byuuid explode (u, s) = map (\g -> (g, S.singleton u)) (S.toList s) + +{- If a repository is in exactly one standard group, returns it. -} +getStandardGroup :: S.Set Group -> Maybe StandardGroup +getStandardGroup s = case catMaybes $ map toStandardGroup $ S.toList s of + [g] -> Just g + _ -> Nothing diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs index 1f0c6a6fe..9bb915983 100644 --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -11,9 +11,11 @@ module Logs.PreferredContent ( preferredContentMap, preferredContentMapRaw, checkPreferredContentExpression, + setStandardGroup, ) where import qualified Data.Map as M +import qualified Data.Set as S import Data.Either import Data.Time.Clock.POSIX @@ -27,6 +29,7 @@ import Annex.UUID import Git.FilePath import Types.Group import Logs.Group +import Types.StandardGroups {- Filename of preferred-content.log. -} preferredContentLog :: FilePath @@ -61,7 +64,8 @@ preferredContentMap = do case cached of Just m -> return m Nothing -> do - m <- simpleMap . parseLog (Just . makeMatcher groupmap) + m <- simpleMap + . parseLogWithUUID ((Just .) . makeMatcher groupmap) <$> Annex.Branch.get preferredContentLog Annex.changeState $ \s -> s { Annex.preferredcontentmap = Just m } return m @@ -74,17 +78,28 @@ preferredContentMapRaw = simpleMap . parseLog Just - because the configuration is shared amoung repositories and newer - versions of git-annex may add new features. Instead, parse errors - result in a Matcher that will always succeed. -} -makeMatcher :: GroupMap -> String -> Utility.Matcher.Matcher MatchFiles -makeMatcher groupmap s - | null (lefts tokens) = Utility.Matcher.generate $ rights tokens - | otherwise = Utility.Matcher.generate [] +makeMatcher :: GroupMap -> UUID -> String -> Utility.Matcher.Matcher MatchFiles +makeMatcher groupmap u s + | s == "standard" = standardMatcher groupmap u + | null (lefts tokens) = Utility.Matcher.generate $ rights tokens + | otherwise = matchAll where tokens = map (parseToken groupmap) (tokenizeMatcher s) +{- Standard matchers are pre-defined for some groups. If none is defined, + - or a repository is in multiple groups with standard matchers, match all. -} +standardMatcher :: GroupMap -> UUID -> Utility.Matcher.Matcher MatchFiles +standardMatcher m u = maybe matchAll (makeMatcher m u . preferredContent) $ + getStandardGroup =<< u `M.lookup` groupsByUUID m + +matchAll :: Utility.Matcher.Matcher MatchFiles +matchAll = Utility.Matcher.generate [] + {- Checks if an expression can be parsed, if not returns Just error -} checkPreferredContentExpression :: String -> Maybe String -checkPreferredContentExpression s = - case lefts $ map (parseToken emptyGroupMap) (tokenizeMatcher s) of +checkPreferredContentExpression s + | s == "standard" = Nothing + | otherwise = case lefts $ map (parseToken emptyGroupMap) (tokenizeMatcher s) of [] -> Nothing l -> Just $ unwords $ map ("Parse failure: " ++) l @@ -113,3 +128,12 @@ tokenizeMatcher :: String -> [String] tokenizeMatcher = filter (not . null ) . concatMap splitparens . words where splitparens = segmentDelim (`elem` "()") + +{- Puts a UUID in a standard group, and sets its preferred content to use + - the standard expression for that group, unless something is already set. -} +setStandardGroup :: UUID -> StandardGroup -> Annex () +setStandardGroup u g = do + groupSet u $ S.singleton $ fromStandardGroup g + m <- preferredContentMap + unless (isJust $ M.lookup u m) $ + preferredContentSet u "standard" diff --git a/Logs/UUIDBased.hs b/Logs/UUIDBased.hs index 847d49923..674ac2184 100644 --- a/Logs/UUIDBased.hs +++ b/Logs/UUIDBased.hs @@ -17,6 +17,7 @@ module Logs.UUIDBased ( LogEntry(..), TimeStamp(..), parseLog, + parseLogWithUUID, showLog, changeLog, addLog, @@ -56,15 +57,18 @@ showLog shower = unlines . map showpair . M.toList unwords [fromUUID k, shower v] parseLog :: (String -> Maybe a) -> String -> Log a -parseLog parser = M.fromListWith best . mapMaybe parse . lines +parseLog = parseLogWithUUID . const + +parseLogWithUUID :: (UUID -> String -> Maybe a) -> String -> Log a +parseLogWithUUID parser = M.fromListWith best . mapMaybe parse . lines where parse line | null ws = Nothing - | otherwise = parser (unwords info) >>= makepair + | otherwise = parser u (unwords info) >>= makepair where - makepair v = Just (toUUID u, LogEntry ts v) + makepair v = Just (u, LogEntry ts v) ws = words line - u = Prelude.head ws + u = toUUID $ Prelude.head ws t = Prelude.last ws ts | tskey `isPrefixOf` t = diff --git a/Types/StandardGroups.hs b/Types/StandardGroups.hs new file mode 100644 index 000000000..32e2cb3af --- /dev/null +++ b/Types/StandardGroups.hs @@ -0,0 +1,37 @@ +{- git-annex standard repository groups + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Types.StandardGroups where + +data StandardGroup = ClientGroup | TransferGroup | ArchiveGroup | BackupGroup + deriving (Eq, Ord, Enum, Bounded, Show) + +fromStandardGroup :: StandardGroup -> String +fromStandardGroup ClientGroup = "client" +fromStandardGroup TransferGroup = "transfer" +fromStandardGroup ArchiveGroup = "archive" +fromStandardGroup BackupGroup = "backup" + +toStandardGroup :: String -> Maybe StandardGroup +toStandardGroup "client" = Just ClientGroup +toStandardGroup "transfer" = Just TransferGroup +toStandardGroup "archive" = Just ArchiveGroup +toStandardGroup "backup" = Just BackupGroup +toStandardGroup _ = Nothing + +descStandardGroup :: StandardGroup -> String +descStandardGroup ClientGroup = "client: a repository on your computer" +descStandardGroup TransferGroup = "transfer: distributes files to clients" +descStandardGroup ArchiveGroup = "archive: collects files that are not archived elsewhere" +descStandardGroup BackupGroup = "backup: collects all files" + +{- See doc/preferred_content.mdwn for explanations of these expressions. -} +preferredContent :: StandardGroup -> String +preferredContent ClientGroup = "exclude=*/archive/*" +preferredContent TransferGroup = "not inallgroup=client and " ++ preferredContent ClientGroup +preferredContent ArchiveGroup = "not copies=archive:1" +preferredContent BackupGroup = "" -- all content is preferred diff --git a/debian/changelog b/debian/changelog index 0fc4cda17..73e33ea8d 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,6 +1,9 @@ git-annex (3.20121010) UNRELEASED; urgency=low * Renamed --ingroup to --inallgroup. + * Standard groups changed to client, transfer, archive, and backup. + Each of these has its own standard preferred content setting. + * dead: Remove dead repository from all groups. -- Joey Hess <joeyh@debian.org> Wed, 10 Oct 2012 12:59:25 -0400 diff --git a/doc/assistant/repogroups.png b/doc/assistant/repogroups.png Binary files differnew file mode 100644 index 000000000..441a75084 --- /dev/null +++ b/doc/assistant/repogroups.png diff --git a/doc/design/assistant/blog/day_102__very_high_level_programming.mdwn b/doc/design/assistant/blog/day_102__very_high_level_programming.mdwn new file mode 100644 index 000000000..4e29cc65d --- /dev/null +++ b/doc/design/assistant/blog/day_102__very_high_level_programming.mdwn @@ -0,0 +1,37 @@ +## today + +Came up with four groups of repositories that it makes sense to +define standard preferred content expressions for. + +[[!format haskell """ + preferredContent :: StandardGroup -> String + preferredContent ClientGroup = "exclude=*/archive/*" + preferredContent TransferGroup = "not inallgroup=client and " ++ preferredContent ClientGroup + preferredContent ArchiveGroup = "not copies=archive:1" + preferredContent BackupGroup = "" -- all content is preferred +"""]] + +[[preferred_content]] has the details about these groups, but +as I was writing those three preferred content expressions, +I realized they are some of the highest level programming I've ever done, +in a way. + +Anyway, these make for a very simple repository configuration UI: + +[[!img /assistant/repogroups.png alt="form with simple select box"]] + +## yesterday (forgot to post this) + +Got the assistant honoring preferred content settings. Although so far that +only determines what it transfers. Additional work will be needed to make +content be dropped when it stops being preferred. + +---- + +Added a "configure" link next to each repository on the repository config +page. This will go to a form to allow setting things like repository +descriptions, groups, and preferred content settings. + +---- + +Cut a release. diff --git a/doc/preferred_content.mdwn b/doc/preferred_content.mdwn index 7c7d11267..c130a07e6 100644 --- a/doc/preferred_content.mdwn +++ b/doc/preferred_content.mdwn @@ -28,10 +28,52 @@ The equivilant preferred content expression looks like this: So, just remove the dashes, basically. +## file matching + Note that while --include and --exclude match files relative to the current directory, preferred content expressions always match files relative to the -top of the git repository. Perhaps you put files into `out/` directories +top of the git repository. Perhaps you put files into `archive` directories when you're done with them. Then you could configure your laptop to prefer to not retain those files, like this: - exclude=*/out/* + exclude=*/archive/* + +## standard expressions + +git-annex comes with some standard preferred content expressions, that can +be used with repositories that are in some pre-defined groups. To make a +repository use one of these, just set its preferred content expression +to "standard", and put it in one of these groups: + +### client + +All content is preferred, unless it's in a "archive" directory. + +`exclude=*/archive/*` + +### transfer + +Use for repositories that are used to transfer data between other +repositories, but do not need to retain data themselves. For +example, a repository on a server, or in the cloud, or a small +USB drive used in a sneakernet. + +The preferred content expression for these causes them to get and retain +data until all clients have a copy. + +`not inallgroup=client and exclude=*/archive/*` + +### archive + +All content is preferred, unless it's already been archived somewhere else. + +`not copies=archive:1` + +Note that if you want to archive multiple copies (not a bad idea!), +you should instead configure all your archive repositories with a +version of the above preferred content expression with a larger +number of copies. + +### backup + +All content is preferred. |
