per-IA-item content directories

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

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

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

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