Internet Archive!
* Add public repository group. * webapp: Can now set up Internet Archive repositories. TODO: Enabling IA repositories.
This commit is contained in:
Joey Hess
parent
04d8a26afe
commit
2810807ca5
16 changed files with 248 additions and 27 deletions
|
|
@ -63,7 +63,7 @@ extractCreds i = AWSCreds (accessKeyID i) (secretAccessKey i)
|
|||
|
||||
s3InputAForm :: AForm WebApp WebApp AWSInput
|
||||
s3InputAForm = AWSInput
|
||||
<$> accessKeyIDField
|
||||
<$> accessKeyIDFieldWithHelp
|
||||
<*> secretAccessKeyField
|
||||
<*> datacenterField AWS.S3
|
||||
<*> areq (selectFieldList storageclasses) "Storage class" (Just StandardRedundancy)
|
||||
|
|
@ -78,7 +78,7 @@ s3InputAForm = AWSInput
|
|||
|
||||
glacierInputAForm :: AForm WebApp WebApp AWSInput
|
||||
glacierInputAForm = AWSInput
|
||||
<$> accessKeyIDField
|
||||
<$> accessKeyIDFieldWithHelp
|
||||
<*> secretAccessKeyField
|
||||
<*> datacenterField AWS.Glacier
|
||||
<*> pure StandardRedundancy
|
||||
|
|
@ -87,11 +87,14 @@ glacierInputAForm = AWSInput
|
|||
|
||||
awsCredsAForm :: AForm WebApp WebApp AWSCreds
|
||||
awsCredsAForm = AWSCreds
|
||||
<$> accessKeyIDField
|
||||
<$> accessKeyIDFieldWithHelp
|
||||
<*> secretAccessKeyField
|
||||
|
||||
accessKeyIDField :: AForm WebApp WebApp Text
|
||||
accessKeyIDField = areq (textField `withNote` help) "Access Key ID" Nothing
|
||||
accessKeyIDField :: Widget -> AForm WebApp WebApp Text
|
||||
accessKeyIDField help = areq (textField `withNote` help) "Access Key ID" Nothing
|
||||
|
||||
accessKeyIDFieldWithHelp :: AForm WebApp WebApp Text
|
||||
accessKeyIDFieldWithHelp = accessKeyIDField help
|
||||
where
|
||||
help = [whamlet|
|
||||
<a href="https://portal.aws.amazon.com/gp/aws/securityCredentials#id_block">
|
||||
|
|
|
|||
|
|
@ -147,12 +147,12 @@ 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 $ checkarchivedirectory curr
|
||||
lift $ checkdirectories curr
|
||||
((result, form), enctype) <- lift $
|
||||
runFormPost $ renderBootstrap $ editRepositoryAForm curr
|
||||
case result of
|
||||
FormSuccess input -> lift $ do
|
||||
checkarchivedirectory input
|
||||
checkdirectories input
|
||||
setRepoConfig uuid mremote curr input
|
||||
redirect DashboardR
|
||||
_ -> showform form enctype curr
|
||||
|
|
@ -161,16 +161,17 @@ editForm new uuid = page "Configure repository" (Just Configuration) $ do
|
|||
let istransfer = repoGroup curr == RepoGroupStandard TransferGroup
|
||||
$(widgetFile "configurators/editrepository")
|
||||
|
||||
{- Makes a toplevel archive 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,
|
||||
{- 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. -}
|
||||
checkarchivedirectory cfg
|
||||
| repoGroup cfg == RepoGroupStandard SmallArchiveGroup = go
|
||||
| repoGroup cfg == RepoGroupStandard FullArchiveGroup = go
|
||||
checkdirectories cfg
|
||||
| repoGroup cfg == RepoGroupStandard SmallArchiveGroup = go "archive"
|
||||
| repoGroup cfg == RepoGroupStandard FullArchiveGroup = go "archive"
|
||||
| repoGroup cfg == RepoGroupStandard PublicGroup = go "public"
|
||||
| otherwise = noop
|
||||
where
|
||||
go = liftAnnex $ inRepo $ \g ->
|
||||
go d = liftAnnex $ inRepo $ \g ->
|
||||
createDirectoryIfMissing True $
|
||||
Git.repoPath g </> "archive"
|
||||
Git.repoPath g </> d
|
||||
|
|
|
|||
148
Assistant/WebApp/Configurators/IA.hs
Normal file
148
Assistant/WebApp/Configurators/IA.hs
Normal file
|
|
@ -0,0 +1,148 @@
|
|||
{- git-annex assistant webapp configurators for Internet Archive
|
||||
-
|
||||
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP, FlexibleContexts, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
|
||||
|
||||
module Assistant.WebApp.Configurators.IA where
|
||||
|
||||
import Assistant.WebApp.Common
|
||||
import qualified Assistant.WebApp.Configurators.AWS as AWS
|
||||
#ifdef WITH_S3
|
||||
import qualified Remote.S3 as S3
|
||||
#endif
|
||||
import qualified Remote
|
||||
import Types.StandardGroups
|
||||
import Logs.PreferredContent
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Map as M
|
||||
import Data.Char
|
||||
import Network.Socket (HostName)
|
||||
import Network.URI
|
||||
|
||||
iaConfigurator :: Widget -> Handler RepHtml
|
||||
iaConfigurator = page "Add an Internet Archive repository" (Just Configuration)
|
||||
|
||||
data IAInput = IAInput
|
||||
{ accessKeyID :: Text
|
||||
, secretAccessKey :: Text
|
||||
, mediaType :: MediaType
|
||||
, itemDescription :: Text
|
||||
}
|
||||
|
||||
extractCreds :: IAInput -> AWS.AWSCreds
|
||||
extractCreds i = AWS.AWSCreds (accessKeyID i) (secretAccessKey i)
|
||||
|
||||
{- IA defines only a few media types currently, or the media type
|
||||
- may be omitted
|
||||
-
|
||||
- We add a few other common types, mapped to what we've been told
|
||||
- is the closest match.
|
||||
-}
|
||||
data MediaType = MediaImages | MediaAudio | MediaMovies | MediaText | MediaSoftware | MediaOmitted
|
||||
deriving (Eq, Ord, Enum, Bounded)
|
||||
|
||||
{- Format a MediaType for entry into the IA metadata -}
|
||||
formatMediaType :: MediaType -> String
|
||||
formatMediaType MediaText = "texts"
|
||||
formatMediaType MediaImages = "image"
|
||||
formatMediaType MediaSoftware = "software"
|
||||
formatMediaType MediaMovies = "movies"
|
||||
formatMediaType MediaAudio = "audio"
|
||||
formatMediaType MediaOmitted = ""
|
||||
|
||||
{- A default collection to use for each Mediatype, where one is known. -}
|
||||
collectionMediaType :: MediaType -> Maybe String
|
||||
collectionMediaType MediaText = Just "opensource"
|
||||
collectionMediaType MediaImages = Just "ourmedia"
|
||||
collectionMediaType MediaSoftware = Nothing
|
||||
collectionMediaType MediaMovies = Just "opensource_movies"
|
||||
collectionMediaType MediaAudio = Just "opensource_audio"
|
||||
collectionMediaType MediaOmitted = Nothing
|
||||
|
||||
{- Format a MediaType for user display. -}
|
||||
showMediaType :: MediaType -> String
|
||||
showMediaType MediaText = "texts"
|
||||
showMediaType MediaImages = "photos & images"
|
||||
showMediaType MediaSoftware = "software"
|
||||
showMediaType MediaMovies = "videos & movies"
|
||||
showMediaType MediaAudio = "audio & music"
|
||||
showMediaType MediaOmitted = "other"
|
||||
|
||||
iaInputAForm :: AForm WebApp WebApp IAInput
|
||||
iaInputAForm = IAInput
|
||||
<$> accessKeyIDFieldWithHelp
|
||||
<*> AWS.secretAccessKeyField
|
||||
<*> areq (selectFieldList mediatypes) "Media Type" (Just MediaOmitted)
|
||||
<*> areq textField "Description" Nothing
|
||||
where
|
||||
mediatypes :: [(Text, MediaType)]
|
||||
mediatypes = map (\t -> (T.pack $ showMediaType t, t)) [minBound..]
|
||||
|
||||
accessKeyIDFieldWithHelp :: AForm WebApp WebApp Text
|
||||
accessKeyIDFieldWithHelp = AWS.accessKeyIDField help
|
||||
where
|
||||
help = [whamlet|
|
||||
<a href="http://archive.org/account/s3.php">
|
||||
Get Internet Archive access keys
|
||||
|]
|
||||
|
||||
getAddIAR :: Handler RepHtml
|
||||
getAddIAR = postAddIAR
|
||||
|
||||
postAddIAR :: Handler RepHtml
|
||||
#ifdef WITH_S3
|
||||
postAddIAR = iaConfigurator $ do
|
||||
((result, form), enctype) <- lift $
|
||||
runFormPost $ renderBootstrap iaInputAForm
|
||||
case result of
|
||||
FormSuccess input -> lift $ do
|
||||
let name = escapeBucket $ T.unpack $ itemDescription input
|
||||
AWS.makeAWSRemote S3.remote (extractCreds input) name setgroup $
|
||||
M.fromList $ catMaybes
|
||||
[ Just $ configureEncryption NoEncryption
|
||||
, Just ("type", "S3")
|
||||
, Just ("host", iaHost)
|
||||
, Just ("bucket", escapeHeader name)
|
||||
, Just ("x-archive-meta-title", escapeHeader $ T.unpack $ itemDescription 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")
|
||||
]
|
||||
_ -> $(widgetFile "configurators/addia")
|
||||
where
|
||||
setgroup r = liftAnnex $
|
||||
setStandardGroup (Remote.uuid r) PublicGroup
|
||||
#else
|
||||
postAddIAR = error "S3 not supported by this build"
|
||||
#endif
|
||||
|
||||
getEnableIAR :: UUID -> Handler RepHtml
|
||||
getEnableIAR = postEnableIAR
|
||||
|
||||
postEnableIAR :: UUID -> Handler RepHtml
|
||||
#ifdef WITH_S3
|
||||
postEnableIAR = iaConfigurator . AWS.enableAWSRemote S3.remote
|
||||
#else
|
||||
postEnableIAR _ = error "S3 not supported by this build"
|
||||
#endif
|
||||
|
||||
{- Convert a description into a bucket name, which will also be
|
||||
- used as the repository name.
|
||||
- IA seems to need only lower case, and no spaces. -}
|
||||
escapeBucket :: String -> String
|
||||
escapeBucket = map toLower . replace " " "-"
|
||||
|
||||
{- IA S3 API likes headers to be URI escaped, escaping spaces looks ugly. -}
|
||||
escapeHeader :: String -> String
|
||||
escapeHeader = escapeURIString (\c -> isUnescapedInURI c && c /= ' ')
|
||||
|
||||
iaHost :: HostName
|
||||
iaHost = "s3.us.archive.org"
|
||||
Loading…
Add table
Add a link
Reference in a new issue