per-IA-item content directories

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)
+exprParser :: GroupMap -> M.Map UUID RemoteConfig -> Maybe UUID -> String -> [Either String (Token MatchFiles)]
-parseToken checkpresent groupmap t
+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 $
+		either badexpr return $
-			map (parseToken (limitPresent $ Just u) m)
+			parsedToMatcher $ exprParser gm rc (Just u) expr
-				(tokenizeMatcher expr)
 	badexpr e = error $ "bad annex.largefiles configuration: " ++ e

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 :: RepoConfig -> Maybe Remote.RemoteConfig -> AForm WebApp WebApp RepoConfig
-editRepositoryAForm def = 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 config
-			let repoInfo = getRepoInfo mremote (M.lookup uuid m)
 			$(widgetFile "configurators/editrepository")
   where
-	{- Makes a toplevel archive or public directory, so the user can
+	{- Makes any special directory associated with the repository.
-	 - get on with using it. This is done both when displaying the form,
+	 - This is done both when displaying the form, as well as after
-	 - as well as after it's posted, because the user may not post the form,
+	 - it's posted, because the user may not post the form,
-	 - but may see that the repo is set up to use the archive
+	 - but may see that the repo is set up to use the directory. -}
-	 - directory. -}
+	checkdirectories cfg repoconfig = case repoGroup cfg of
-	checkdirectories cfg
+		RepoGroupStandard gr -> case specialDirectory repoconfig gr of
-		| repoGroup cfg == RepoGroupStandard SmallArchiveGroup = go "archive"
+			Just d -> liftAnnex $ inRepo $ \g ->
-		| repoGroup cfg == RepoGroupStandard FullArchiveGroup = go "archive"
+				createDirectoryIfMissing True $
-		| repoGroup cfg == RepoGroupStandard PublicGroup = go "public"
+					Git.repoPath g </> d
-		| otherwise = noop
+			Nothing -> noop
-	  where
+		_ -> noop
-		go d = liftAnnex $ inRepo $ \g ->
-			createDirectoryIfMissing True $
-				Git.repoPath g </> d
 
 getRepoInfo :: Maybe Remote.Remote -> Maybe Remote.RemoteConfig -> Widget
 getRepoInfo (Just r) (Just c) = case M.lookup "type" c of

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|
+<div>
+  Each item stored in the Internet Archive must have a unique name.
+<div>
+  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
+{- Convert a description into a bucket item name, which will also be
- - used as the repository name.
+ - 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

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|
-<a .btn data-toggle="collapse" data-target="#help">
+<div>
-  Help
+  When you sign up for a Rsync.net account, you should receive an #
-<div #help .collapse>
+  email from them with the host name and user name to put here.
-  <div>
+<div>
-    When you sign up for a Rsync.net account, you should receive an #
+  The host name will be something like "usw-s001.rsync.net", and the #
-    email from them with the host name and user name to put here.
+  user name something like "7491"
-  <div>
-    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

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}&nbsp;&nbsp;<span>^{note}</span>|]
 
+{- 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|
+<a .btn data-toggle="collapse" data-target="##{ident}">
+  #{toggle}
+<div ##{ident} .collapse>
+  ^{note}
+|]
+
 data EnableEncryption = SharedEncryption | NoEncryption
 	deriving (Eq)
 

Limit.hs

@@ -1,6 +1,6 @@
 {- user-specified limits on files to act on
  -
- - Copyright 2011,2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2013 Joey Hess <joey@kitenet.net>
  -
  - 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 ()

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 -> M.Map UUID RemoteConfig -> UUID -> String -> FileMatcher
-makeMatcher groupmap u s
+makeMatcher groupmap configmap u expr
-	| s == "standard" = standardMatcher groupmap u
+	| 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 :: GroupMap -> M.Map UUID RemoteConfig -> UUID -> FileMatcher
-standardMatcher m u = maybe matchAll (makeMatcher m u . preferredContent) $
+standardMatcher groupmap configmap u = 
-	getStandardGroup =<< u `M.lookup` groupsByUUID m
+	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
+checkPreferredContentExpression expr
-	| s == "standard" = Nothing
+	| expr == "standard" = Nothing
-	| otherwise = case parsedToMatcher vs of
+	| otherwise = case parsedToMatcher tokens of
 		Left e -> Just e
 		Right _ -> Nothing
   where
-	vs = map (parseToken (limitPresent Nothing) emptyGroupMap)
+	tokens = exprParser emptyGroupMap M.empty Nothing expr
-		(tokenizeMatcher s)
 
 {- 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. -}

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 :: Maybe RemoteConfig -> StandardGroup -> String
-descStandardGroup ClientGroup = "client: a repository on your computer"
+descStandardGroup _ ClientGroup = "client: a repository on your computer"
-descStandardGroup TransferGroup = "transfer: distributes files to clients"
+descStandardGroup _ TransferGroup = "transfer: distributes files to clients"
-descStandardGroup BackupGroup = "full backup: backs up all files"
+descStandardGroup _ BackupGroup = "full backup: backs up all files"
-descStandardGroup IncrementalBackupGroup = "incremental backup: backs up files not backed up elsewhere"
+descStandardGroup _ IncrementalBackupGroup = "incremental backup: backs up files not backed up elsewhere"
-descStandardGroup SmallArchiveGroup = "small archive: archives files located in \"archive\" directories"
+descStandardGroup _ SmallArchiveGroup = "small archive: archives files located in \"archive\" directories"
-descStandardGroup FullArchiveGroup = "full archive: archives all files not archived elsewhere"
+descStandardGroup _ FullArchiveGroup = "full archive: archives all files not archived elsewhere"
-descStandardGroup SourceGroup = "file source: moves files on to other repositories"
+descStandardGroup _ SourceGroup = "file source: moves files on to other repositories"
-descStandardGroup ManualGroup = "manual mode: only stores files you manually choose"
+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 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

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
+  * webapp: Display some additional information about a repository on
-    page.
+    its edit page.
   * Automatically register public urls for files uploaded to the
     Internet Archive.
 

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
+There's a special "inpreferreddir" keyword you can use in a
-expression of a special remote. This means that the content is preferred
+preferred content expression of a special remote. This means that the
-if it's in a directory (located anywhere in the tree) with a special name.
+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
+publically accessed. Only files in a directory with a particular name
-stored in a public repository.
+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
 

templates/configurators/addia.hamlet

@@ -1,21 +1,20 @@
 <div .span9 .hero-unit>
   <h2>
-    Adding an Internet Archive repository
+    Adding an Internet Archive item
   <p>
     <a href="http://archive.org/">The Internet Archive</a> allows anyone #
-    to publically archive their information, for free.
+    to publically archive their information, for free. All you need to #
-  <p>
+    get started is to #
-    All you need to do is #
     <a href="http://archive.org/account/login.createaccount.php">
       Create an account
   <p>
-    To protect your pirvacy, only files located in a public folder #
+    The Internet Archive stores "items". An item can be a single file, or #
-    will be sent to the Internet Archive by default.
+    a related group of files. You can make as many different items as you #
+    like.
   <p>
-    Note that you cannot remove information once it has been sent to the #
+    By default, only files that you place in a special directory #
-    Internet Archive. So before you continue, please make sure you want #
+    will be uploaded to your Internet Archive item. Any other files #
-    to make your files public, and that your files conform to the #
+    in your repository will remain private.
-    <a href="http://archive.org/about/terms.php">Terms of Use</a>.
   <p>
     <form method="post" .form-horizontal enctype=#{enctype}>
       <fieldset>
@@ -23,11 +22,11 @@
         ^{webAppFormAuthToken}
         <div .form-actions>
           <button .btn .btn-primary type=submit onclick="$('#workingmodal').modal('show');">
-            Add Internet Archive repository
+            Add Internet Archive item
 <div .modal .fade #workingmodal>
   <div .modal-header>
     <h3>
-      Making repository ...
+      Making item ...
   <div .modal-body>
     <p>
-      Setting up your Internet Archive repository. This could take a minute.
+      Setting up your Internet Archive item. This could take a minute.

templates/documentation/repogroup.hamlet

@@ -50,7 +50,7 @@
     If you configure a repository that can be viwed by the public, #
     but you don't want all your files to show up there, you can #
     configure it to be a <b>public repository</b>. Then only files #
-    located in a "public" directory will be sent to it.
+    located in a particular directory will be sent to it.
   <p>
     Finally, repositories can be configured to be in <b>manual mode</b>. This #
     prevents content being automatically synced to the repository, but #