per-IA-item content directories
This commit is contained in:
Joey Hess
parent
3c7f4d2bd1
commit
0ae8c82c53
12 changed files with 156 additions and 97 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue