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

per-IA-item content directories

Browse source
This commit is contained in:
Joey Hess 2013-04-25 23:44:55 -04:00
parent 3c7f4d2bd1
commit 0ae8c82c53
12 changed files with 156 additions and 97 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
Annex/FileMatcher.hs
View file

@ -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

41
Assistant/WebApp/Configurators/Edit.hs
View file

@ -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

25
Assistant/WebApp/Configurators/IA.hs
View file

@ -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
- 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

17
Assistant/WebApp/Configurators/Ssh.hs
View file

@ -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">
Help
<div #help .collapse>
<div>
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.
<div>
The host name will be something like "usw-s001.rsync.net", and the #
user name something like "7491"
<div>
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.
<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

12
Assistant/WebApp/Form.hs
View file

@ -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)

11
Limit.hs
View file

@ -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 ()

29
Logs/PreferredContent.hs
View file

@ -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. -}

37
Types/StandardGroups.hs
View file

@ -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

5
debian/changelog vendored
View file

@ -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.

23
doc/preferred_content.mdwn
View file

@ -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

25
templates/configurators/addia.hamlet
View file

@ -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.
<p>
All you need to do is #
to publically archive their information, for free. All you need to #
get started is to #
<a href="http://archive.org/account/login.createaccount.php">
Create an account
<p>
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.
<p>
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 #
<a href="http://archive.org/about/terms.php">Terms of Use</a>.
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.
<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.

2
templates/documentation/repogroup.hamlet
View file

@ -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 #