From 0ae8c82c537abd01ceda6a1fc19419a2bd3ce3a7 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 25 Apr 2013 23:44:55 -0400 Subject: [PATCH] per-IA-item content directories --- Annex/FileMatcher.hs | 26 +++++++++++---- Assistant/WebApp/Configurators/Edit.hs | 41 +++++++++++------------- Assistant/WebApp/Configurators/IA.hs | 25 +++++++++++---- Assistant/WebApp/Configurators/Ssh.hs | 17 ++++------ Assistant/WebApp/Form.hs | 12 +++++++ Limit.hs | 11 +++++-- Logs/PreferredContent.hs | 29 +++++++++-------- Types/StandardGroups.hs | 37 ++++++++++++++------- debian/changelog | 5 +-- doc/preferred_content.mdwn | 23 ++++++++----- templates/configurators/addia.hamlet | 25 +++++++-------- templates/documentation/repogroup.hamlet | 2 +- 12 files changed, 156 insertions(+), 97 deletions(-) diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs index 220fea286a..cbf6f873b8 100644 --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -14,9 +14,11 @@ import Limit import Utility.Matcher import Types.Group import Logs.Group +import Logs.Remote import Annex.UUID import qualified Annex import Git.FilePath +import Types.Remote (RemoteConfig) import Data.Either import qualified Data.Set as S @@ -45,10 +47,22 @@ parsedToMatcher parsed = case partitionEithers parsed of ([], vs) -> Right $ generate vs (es, _) -> Left $ unwords $ map ("Parse failure: " ++) es -parseToken :: MkLimit -> GroupMap -> String -> Either String (Token MatchFiles) -parseToken checkpresent groupmap t +exprParser :: GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [Either String (Token MatchFiles)] +exprParser groupmap configmap mu expr = + map parse $ tokenizeMatcher expr + where + parse = parseToken + (limitPresent mu) + (limitInDir preferreddir) + groupmap + preferreddir = fromMaybe "public" $ + M.lookup "preferreddir" =<< (`M.lookup` configmap) =<< mu + +parseToken :: MkLimit -> MkLimit -> GroupMap -> String -> Either String (Token MatchFiles) +parseToken checkpresent checkpreferreddir groupmap t | t `elem` tokens = Right $ token t | t == "present" = use checkpresent + | t == "inpreferreddir" = use checkpreferreddir | otherwise = maybe (Left $ "near " ++ show t) use $ M.lookup k $ M.fromList [ ("include", limitInclude) @@ -78,9 +92,9 @@ largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig where go Nothing = return matchAll go (Just expr) = do - m <- groupMap + gm <- groupMap + rc <- readRemoteLog u <- getUUID - either badexpr return $ parsedToMatcher $ - map (parseToken (limitPresent $ Just u) m) - (tokenizeMatcher expr) + either badexpr return $ + parsedToMatcher $ exprParser gm rc (Just u) expr badexpr e = error $ "bad annex.largefiles configuration: " ++ e diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index a2b055371d..b8853f0fa4 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -114,8 +114,8 @@ setRepoConfig uuid mremote oldc newc = do legalName = makeLegalName . T.unpack . repoName -editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig -editRepositoryAForm def = RepoConfig +editRepositoryAForm :: RepoConfig -> Maybe Remote.RemoteConfig -> AForm WebApp WebApp RepoConfig +editRepositoryAForm def remoteconfig = RepoConfig <$> areq textField "Name" (Just $ repoName def) <*> aopt textField "Description" (Just $ repoDescription def) <*> areq (selectFieldList groups `withNote` help) "Repository group" (Just $ repoGroup def) @@ -123,7 +123,7 @@ editRepositoryAForm def = RepoConfig where groups = customgroups ++ standardgroups standardgroups :: [(Text, RepoGroup)] - standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g)) + standardgroups = map (\g -> (T.pack $ descStandardGroup remoteconfig g , RepoGroupStandard g)) [minBound :: StandardGroup .. maxBound :: StandardGroup] customgroups :: [(Text, RepoGroup)] customgroups = case repoGroup def of @@ -153,34 +153,31 @@ editForm :: Bool -> UUID -> Handler RepHtml editForm new uuid = page "Configure repository" (Just Configuration) $ do mremote <- liftAnnex $ Remote.remoteFromUUID uuid curr <- liftAnnex $ getRepoConfig uuid mremote - lift $ checkdirectories curr + config <- M.lookup uuid <$> liftAnnex readRemoteLog + lift $ checkdirectories curr config ((result, form), enctype) <- lift $ - runFormPost $ renderBootstrap $ editRepositoryAForm curr + runFormPost $ renderBootstrap $ editRepositoryAForm curr config case result of FormSuccess input -> lift $ do - checkdirectories input + checkdirectories input config setRepoConfig uuid mremote curr input redirect DashboardR _ -> do let istransfer = repoGroup curr == RepoGroupStandard TransferGroup - m <- liftAnnex readRemoteLog - let repoInfo = getRepoInfo mremote (M.lookup uuid m) + let repoInfo = getRepoInfo mremote config $(widgetFile "configurators/editrepository") where - {- Makes a toplevel archive or public directory, so the user can - - get on with using it. This is done both when displaying the form, - - as well as after it's posted, because the user may not post the form, - - but may see that the repo is set up to use the archive - - directory. -} - checkdirectories cfg - | repoGroup cfg == RepoGroupStandard SmallArchiveGroup = go "archive" - | repoGroup cfg == RepoGroupStandard FullArchiveGroup = go "archive" - | repoGroup cfg == RepoGroupStandard PublicGroup = go "public" - | otherwise = noop - where - go d = liftAnnex $ inRepo $ \g -> - createDirectoryIfMissing True $ - Git.repoPath g d + {- Makes any special directory associated with the repository. + - This is done both when displaying the form, as well as after + - it's posted, because the user may not post the form, + - but may see that the repo is set up to use the directory. -} + checkdirectories cfg repoconfig = case repoGroup cfg of + RepoGroupStandard gr -> case specialDirectory repoconfig gr of + Just d -> liftAnnex $ inRepo $ \g -> + createDirectoryIfMissing True $ + Git.repoPath g d + Nothing -> noop + _ -> noop getRepoInfo :: Maybe Remote.Remote -> Maybe Remote.RemoteConfig -> Widget getRepoInfo (Just r) (Just c) = case M.lookup "type" c of diff --git a/Assistant/WebApp/Configurators/IA.hs b/Assistant/WebApp/Configurators/IA.hs index ff7f741e89..321162d676 100644 --- a/Assistant/WebApp/Configurators/IA.hs +++ b/Assistant/WebApp/Configurators/IA.hs @@ -33,7 +33,7 @@ data IAInput = IAInput { accessKeyID :: Text , secretAccessKey :: Text , mediaType :: MediaType - , itemDescription :: Text + , itemName :: Text } extractCreds :: IAInput -> AWS.AWSCreds @@ -80,11 +80,21 @@ iaInputAForm = IAInput <$> accessKeyIDFieldWithHelp <*> AWS.secretAccessKeyField <*> areq (selectFieldList mediatypes) "Media Type" (Just MediaOmitted) - <*> areq textField "Description" Nothing + <*> areq (textField `withExpandableNote` ("Help", itemNameHelp)) "Item Name" Nothing where mediatypes :: [(Text, MediaType)] mediatypes = map (\t -> (T.pack $ showMediaType t, t)) [minBound..] +itemNameHelp :: Widget +itemNameHelp = [whamlet| +
+ Each item stored in the Internet Archive must have a unique name. +
+ Once you create the item, a special directory will appear # + with a name matching the item name. Files you put in that directory # + will be uploaded to your Internet Archive item. +|] + iaCredsAForm :: AForm WebApp WebApp AWS.AWSCreds iaCredsAForm = AWS.AWSCreds <$> accessKeyIDFieldWithHelp @@ -108,20 +118,21 @@ postAddIAR = iaConfigurator $ do runFormPost $ renderBootstrap iaInputAForm case result of FormSuccess input -> lift $ do - let name = escapeBucket $ T.unpack $ itemDescription input + let name = escapeBucket $ T.unpack $ itemName input AWS.makeAWSRemote S3.remote (extractCreds input) name setgroup $ M.fromList $ catMaybes [ Just $ configureEncryption NoEncryption , Just ("type", "S3") , Just ("host", S3.iaHost) , Just ("bucket", escapeHeader name) - , Just ("x-archive-meta-title", escapeHeader $ T.unpack $ itemDescription input) + , Just ("x-archive-meta-title", escapeHeader $ T.unpack $ itemName input) , if mediaType input == MediaOmitted then Nothing else Just ("x-archive-mediatype", formatMediaType $ mediaType input) , (,) <$> pure "x-archive-meta-collection" <*> collectionMediaType (mediaType input) -- Make item show up ASAP. , Just ("x-archive-interactive-priority", "1") + , Just ("preferreddir", name) ] _ -> $(widgetFile "configurators/addia") where @@ -156,11 +167,11 @@ enableIARemote uuid = do T.pack <$> Remote.prettyUUID uuid $(widgetFile "configurators/enableia") -{- Convert a description into a bucket name, which will also be - - used as the repository name. +{- Convert a description into a bucket item name, which will also be + - used as the repository name, and the preferreddir. - IA seems to need only lower case, and no spaces. -} escapeBucket :: String -> String -escapeBucket = map toLower . replace " " "" +escapeBucket = map toLower . replace " " "-" {- IA S3 API likes headers to be URI escaped, escaping spaces looks ugly. -} escapeHeader :: String -> String diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index af321a9724..6f6fded7d6 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -323,17 +323,14 @@ postAddRsyncNetR = do "That is not a rsync.net host name." _ -> showform UntestedServer where - hostnamefield = textField `withNote` help + hostnamefield = textField `withExpandableNote` ("Help", help) help = [whamlet| - - Help -
-
- When you sign up for a Rsync.net account, you should receive an # - email from them with the host name and user name to put here. -
- The host name will be something like "usw-s001.rsync.net", and the # - user name something like "7491" +
+ When you sign up for a Rsync.net account, you should receive an # + email from them with the host name and user name to put here. +
+ The host name will be something like "usw-s001.rsync.net", and the # + user name something like "7491" |] makeRsyncNet :: SshInput -> String -> (Remote -> Handler ()) -> Handler RepHtml diff --git a/Assistant/WebApp/Form.hs b/Assistant/WebApp/Form.hs index 9522f8a07a..4297064742 100644 --- a/Assistant/WebApp/Form.hs +++ b/Assistant/WebApp/Form.hs @@ -47,6 +47,18 @@ withNote field note = field { fieldView = newview } let fieldwidget = (fieldView field) theId name attrs val isReq in [whamlet|^{fieldwidget}  ^{note}|] +{- Note that the toggle string must be unique on the form. -} +withExpandableNote :: Field sub master v -> (String, GWidget sub master ()) -> Field sub master v +withExpandableNote field (toggle, note) = withNote field expandablenote + where + ident = "toggle_" ++ toggle + expandablenote = [whamlet| + + #{toggle} +
+ ^{note} +|] + data EnableEncryption = SharedEncryption | NoEncryption deriving (Eq) diff --git a/Limit.hs b/Limit.hs index 9ce9d591eb..679ebc1993 100644 --- a/Limit.hs +++ b/Limit.hs @@ -1,6 +1,6 @@ {- user-specified limits on files to act on - - - Copyright 2011,2012 Joey Hess + - Copyright 2011-2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -88,9 +88,9 @@ limitExclude glob = Right $ const $ return . not . matchglob glob - once. Also, we use regex-TDFA because it's less buggy in its support - of non-unicode characters. -} matchglob :: String -> Annex.FileInfo -> Bool -matchglob glob (Annex.FileInfo { Annex.matchFile = f }) = +matchglob glob fi = case cregex of - Right r -> case execute r f of + Right r -> case execute r (Annex.matchFile fi) of Right (Just _) -> True _ -> False Left _ -> error $ "failed to compile regex: " ++ regex @@ -138,6 +138,11 @@ limitPresent u _ = Right $ const $ check $ \key -> do handle _ Nothing = return False handle a (Just (key, _)) = a key +{- Limit to content that is in a directory, anywhere in the repository tree -} +limitInDir :: FilePath -> MkLimit +limitInDir dir = const $ Right $ const $ \fi -> return $ + any (== dir) $ splitPath $ takeDirectory $ Annex.matchFile fi + {- Adds a limit to skip files not believed to have the specified number - of copies. -} addCopies :: String -> Annex () diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs index d980cd373d..8005fc0d30 100644 --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -30,7 +30,9 @@ import qualified Utility.Matcher import Annex.FileMatcher import Annex.UUID import Types.Group +import Types.Remote (RemoteConfig) import Logs.Group +import Logs.Remote import Types.StandardGroups {- Filename of preferred-content.log. -} @@ -65,8 +67,9 @@ preferredContentMap = maybe preferredContentMapLoad return preferredContentMapLoad :: Annex Annex.PreferredContentMap preferredContentMapLoad = do groupmap <- groupMap + configmap <- readRemoteLog m <- simpleMap - . parseLogWithUUID ((Just .) . makeMatcher groupmap) + . parseLogWithUUID ((Just .) . makeMatcher groupmap configmap) <$> Annex.Branch.get preferredContentLog Annex.changeState $ \s -> s { Annex.preferredcontentmap = Just m } return m @@ -79,30 +82,30 @@ 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 -> UUID -> String -> FileMatcher -makeMatcher groupmap u s - | s == "standard" = standardMatcher groupmap u +makeMatcher :: GroupMap -> M.Map UUID RemoteConfig -> UUID -> String -> FileMatcher +makeMatcher groupmap configmap u expr + | expr == "standard" = standardMatcher groupmap configmap u | null (lefts tokens) = Utility.Matcher.generate $ rights tokens | otherwise = matchAll where - tokens = map (parseToken (limitPresent $ Just u) groupmap) (tokenizeMatcher s) + tokens = exprParser groupmap configmap (Just u) expr {- 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 -> FileMatcher -standardMatcher m u = maybe matchAll (makeMatcher m u . preferredContent) $ - getStandardGroup =<< u `M.lookup` groupsByUUID m +standardMatcher :: GroupMap -> M.Map UUID RemoteConfig -> UUID -> FileMatcher +standardMatcher groupmap configmap u = + maybe matchAll (makeMatcher groupmap configmap u . preferredContent) $ + getStandardGroup =<< u `M.lookup` groupsByUUID groupmap {- Checks if an expression can be parsed, if not returns Just error -} checkPreferredContentExpression :: String -> Maybe String -checkPreferredContentExpression s - | s == "standard" = Nothing - | otherwise = case parsedToMatcher vs of +checkPreferredContentExpression expr + | expr == "standard" = Nothing + | otherwise = case parsedToMatcher tokens of Left e -> Just e Right _ -> Nothing where - vs = map (parseToken (limitPresent Nothing) emptyGroupMap) - (tokenizeMatcher s) + tokens = exprParser emptyGroupMap M.empty Nothing expr {- 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. -} diff --git a/Types/StandardGroups.hs b/Types/StandardGroups.hs index 055dffe6e6..e7764d3871 100644 --- a/Types/StandardGroups.hs +++ b/Types/StandardGroups.hs @@ -7,6 +7,11 @@ module Types.StandardGroups where +import Types.Remote (RemoteConfig) + +import qualified Data.Map as M +import Data.Maybe + data StandardGroup = ClientGroup | TransferGroup @@ -45,17 +50,25 @@ toStandardGroup "public" = Just PublicGroup toStandardGroup "unwanted" = Just UnwantedGroup toStandardGroup _ = Nothing -descStandardGroup :: StandardGroup -> String -descStandardGroup ClientGroup = "client: a repository on your computer" -descStandardGroup TransferGroup = "transfer: distributes files to clients" -descStandardGroup BackupGroup = "full backup: backs up all files" -descStandardGroup IncrementalBackupGroup = "incremental backup: backs up files not backed up elsewhere" -descStandardGroup SmallArchiveGroup = "small archive: archives files located in \"archive\" directories" -descStandardGroup FullArchiveGroup = "full archive: archives all files not archived elsewhere" -descStandardGroup SourceGroup = "file source: moves files on to other repositories" -descStandardGroup ManualGroup = "manual mode: only stores files you manually choose" -descStandardGroup PublicGroup = "public: only stores files located in \"public\" directories" -descStandardGroup UnwantedGroup = "unwanted: remove content from this repository" +descStandardGroup :: Maybe RemoteConfig -> StandardGroup -> String +descStandardGroup _ ClientGroup = "client: a repository on your computer" +descStandardGroup _ TransferGroup = "transfer: distributes files to clients" +descStandardGroup _ BackupGroup = "full backup: backs up all files" +descStandardGroup _ IncrementalBackupGroup = "incremental backup: backs up files not backed up elsewhere" +descStandardGroup _ SmallArchiveGroup = "small archive: archives files located in \"archive\" directories" +descStandardGroup _ FullArchiveGroup = "full archive: archives all files not archived elsewhere" +descStandardGroup _ SourceGroup = "file source: moves files on to other repositories" +descStandardGroup _ ManualGroup = "manual mode: only stores files you manually choose" +descStandardGroup _ UnwantedGroup = "unwanted: remove content from this repository" +descStandardGroup c PublicGroup = "public: only stores files located in \"" ++ fromJust (specialDirectory c PublicGroup) ++ "\" directories" + +specialDirectory :: Maybe RemoteConfig -> StandardGroup -> Maybe FilePath +specialDirectory _ SmallArchiveGroup = Just "archive" +specialDirectory _ FullArchiveGroup = Just "archive" +specialDirectory (Just c) PublicGroup = Just $ + fromMaybe "public" $ M.lookup "preferreddir" c +specialDirectory Nothing PublicGroup = Just "public" +specialDirectory _ _ = Nothing {- See doc/preferred_content.mdwn for explanations of these expressions. -} preferredContent :: StandardGroup -> String @@ -71,7 +84,7 @@ preferredContent SmallArchiveGroup = lastResort $ preferredContent FullArchiveGroup = lastResort notArchived preferredContent SourceGroup = "not (copies=1)" preferredContent ManualGroup = "present and (" ++ preferredContent ClientGroup ++ ")" -preferredContent PublicGroup = "include=*/public/* or include=public/*" +preferredContent PublicGroup = "inpreferreddir" preferredContent UnwantedGroup = "exclude=*" notArchived :: String diff --git a/debian/changelog b/debian/changelog index 322f580234..4dde2760bc 100644 --- a/debian/changelog +++ b/debian/changelog @@ -32,11 +32,12 @@ git-annex (4.20130418) UNRELEASED; urgency=low * initremote: If two existing remotes have the same name, prefer the one with a higher trust level. * Add public repository group. + (And inpreferreddir to preferred content expressions.) * webapp: Can now set up Internet Archive repositories. * S3: Dropping content from the Internet Archive doesn't work, but their API indicates it does. Always refuse to drop from there. - * webapp: Display some additional information about a repository on its edit - page. + * webapp: Display some additional information about a repository on + its edit page. * Automatically register public urls for files uploaded to the Internet Archive. diff --git a/doc/preferred_content.mdwn b/doc/preferred_content.mdwn index de28d0729b..23081fc30c 100644 --- a/doc/preferred_content.mdwn +++ b/doc/preferred_content.mdwn @@ -72,14 +72,17 @@ Note that `not present` is a very bad thing to put in a preferred content expression. It'll make it prefer to get content that's not present, and drop content that is present! Don't go there.. -### difference: "inmydir" +### difference: "inpreferreddir" -There's a special "inmydir" keyword you can use in a preferred content -expression of a special remote. This means that the content is preferred -if it's in a directory (located anywhere in the tree) with a special name. +There's a special "inpreferreddir" keyword you can use in a +preferred content expression of a special remote. This means that the +content is preferred if it's in a directory (located anywhere in the tree) +with a special name. The name of the directory can be configured using -`git annex initremote $remote mydir=$dirname` +`git annex initremote $remote preferreddir=$dirname` + +(If no directory name is configured, it uses "public" by default.) ## standard expressions @@ -178,10 +181,14 @@ reached an archive repository. ### public This is used for publishing information to a repository that can be -publically accessed. Only files inside `public` directories will be -stored in a public repository. +publically accessed. Only files in a directory with a particular name +will be published. (The directory can be located anywhere in the +repository.) -`include=*/public/* or include=public/*` +The name of the directory can be configured using +`git annex initremote $remote preferreddir=$dirname` + +`inpreferreddir` ### unwanted diff --git a/templates/configurators/addia.hamlet b/templates/configurators/addia.hamlet index d6a70e71d8..f346dbe910 100644 --- a/templates/configurators/addia.hamlet +++ b/templates/configurators/addia.hamlet @@ -1,21 +1,20 @@

- Adding an Internet Archive repository + Adding an Internet Archive item

The Internet Archive allows anyone # - to publically archive their information, for free. -

- All you need to do is # + to publically archive their information, for free. All you need to # + get started is to # Create an account

- To protect your pirvacy, only files located in a public folder # - will be sent to the Internet Archive by default. + The Internet Archive stores "items". An item can be a single file, or # + a related group of files. You can make as many different items as you # + like.

- Note that you cannot remove information once it has been sent to the # - Internet Archive. So before you continue, please make sure you want # - to make your files public, and that your files conform to the # - Terms of Use. + By default, only files that you place in a special directory # + will be uploaded to your Internet Archive item. Any other files # + in your repository will remain private.

@@ -23,11 +22,11 @@ ^{webAppFormAuthToken}