Internet Archive!

* Add public repository group. * webapp: Can now set up Internet Archive repositories. TODO: Enabling IA repositories.
2013-04-25 12:23:36 -04:00 · 2013-04-25 12:23:36 -04:00 · 2810807ca5
commit 2810807ca5
parent 04d8a26afe
16 changed files with 248 additions and 27 deletions
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@ -22,6 +22,7 @@ import Assistant.WebApp.Configurators.Local
 import Assistant.WebApp.Configurators.Ssh
 import Assistant.WebApp.Configurators.Pairing
 import Assistant.WebApp.Configurators.AWS
+import Assistant.WebApp.Configurators.IA
 import Assistant.WebApp.Configurators.WebDAV
 import Assistant.WebApp.Configurators.XMPP
 import Assistant.WebApp.Configurators.Preferences
--- a/Assistant/WebApp/Configurators.hs
+++ b/Assistant/WebApp/Configurators.hs
@ -36,5 +36,9 @@ getAddRepositoryR = page "Add Repository" (Just Configuration) $ do
 makeMiscRepositories :: Widget
 makeMiscRepositories = $(widgetFile "configurators/addrepository/misc")

-makeCloudRepositories :: Bool -> Widget
-makeCloudRepositories onlyTransfer = $(widgetFile "configurators/addrepository/cloud")
+makeCloudRepositories :: Widget
+makeCloudRepositories = $(widgetFile "configurators/addrepository/cloud")
+
+makeArchiveRepositories :: Widget
+makeArchiveRepositories = $(widgetFile "configurators/addrepository/archive")
+
--- a/Assistant/WebApp/Configurators/AWS.hs
+++ b/Assistant/WebApp/Configurators/AWS.hs
@ -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">
--- a/Assistant/WebApp/Configurators/Edit.hs
+++ b/Assistant/WebApp/Configurators/Edit.hs
@ -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
--- a/Assistant/WebApp/Configurators/IA.hs
+++ b/Assistant/WebApp/Configurators/IA.hs
@ -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"
--- a/Assistant/WebApp/routes
+++ b/Assistant/WebApp/routes
@ -40,6 +40,7 @@
 /config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET
 /config/repository/add/cloud/rsync.net AddRsyncNetR GET POST
 /config/repository/add/cloud/S3 AddS3R GET POST
+/config/repository/add/cloud/IA AddIAR GET POST
 /config/repository/add/cloud/glacier AddGlacierR GET POST
 /config/repository/add/cloud/box.com AddBoxComR GET POST

@ -58,6 +59,7 @@
 /config/repository/enable/rsync/#UUID EnableRsyncR GET POST
 /config/repository/enable/directory/#UUID EnableDirectoryR GET
 /config/repository/enable/S3/#UUID EnableS3R GET POST
+/config/repository/enable/IA/#UUID EnableIAR GET POST
 /config/repository/enable/glacier/#UUID EnableGlacierR GET POST
 /config/repository/enable/webdav/#UUID EnableWebDAVR GET POST

--- a/Types/StandardGroups.hs
+++ b/Types/StandardGroups.hs
@ -16,6 +16,7 @@ data StandardGroup
 	| FullArchiveGroup
 	| SourceGroup
 	| ManualGroup
+	| PublicGroup
 	| UnwantedGroup
 	deriving (Eq, Ord, Enum, Bounded, Show)

@ -28,6 +29,7 @@ fromStandardGroup SmallArchiveGroup = "smallarchive"
 fromStandardGroup FullArchiveGroup = "archive"
 fromStandardGroup SourceGroup = "source"
 fromStandardGroup ManualGroup = "manual"
+fromStandardGroup PublicGroup = "public"
 fromStandardGroup UnwantedGroup = "unwanted"

 toStandardGroup :: String -> Maybe StandardGroup
@ -39,6 +41,7 @@ toStandardGroup "smallarchive" = Just SmallArchiveGroup
 toStandardGroup "archive" = Just FullArchiveGroup
 toStandardGroup "source" = Just SourceGroup
 toStandardGroup "manual" = Just ManualGroup
+toStandardGroup "public" = Just PublicGroup
 toStandardGroup "unwanted" = Just UnwantedGroup
 toStandardGroup _ = Nothing

@ -51,6 +54,7 @@ descStandardGroup SmallArchiveGroup = "small archive: archives files located in
 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"

 {- See doc/preferred_content.mdwn for explanations of these expressions. -}
@ -67,6 +71,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 UnwantedGroup = "exclude=*"

 notArchived :: String
--- a/debian/changelog
+++ b/debian/changelog
@ -31,6 +31,8 @@ git-annex (4.20130418) UNRELEASED; urgency=low
  * assistant: Sanitize XMPP presence information logged for debugging.
  * initremote: If two existing remotes have the same name,
    prefer the one with a higher trust level.
+  * Add public repository group.
+  * webapp: Can now set up Internet Archive repositories.

 -- Joey Hess <joeyh@debian.org>  Thu, 18 Apr 2013 16:22:48 -0400

--- a/doc/preferred_content.mdwn
+++ b/doc/preferred_content.mdwn
@ -166,6 +166,14 @@ reached an archive repository.

 `present and ($client)`

+### 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.
+
+`include=*/public/* or include=public/*`
+
 ### unwanted

 Use for repositories that you don't want to exist. This will result
--- a/templates/configurators/addia.hamlet
+++ b/templates/configurators/addia.hamlet
@ -0,0 +1,33 @@
+<div .span9 .hero-unit>
+  <h2>
+    Adding an Internet Archive repository
+  <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 #
+    <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.
+  <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>.
+  <p>
+    <form method="post" .form-horizontal enctype=#{enctype}>
+      <fieldset>
+        ^{form}
+        ^{webAppFormAuthToken}
+        <div .form-actions>
+          <button .btn .btn-primary type=submit onclick="$('#workingmodal').modal('show');">
+            Add Internet Archive repository
+<div .modal .fade #workingmodal>
+  <div .modal-header>
+    <h3>
+      Making repository ...
+  <div .modal-body>
+    <p>
+      Setting up your Internet Archive repository. This could take a minute.
--- a/templates/configurators/addrepository.hamlet
+++ b/templates/configurators/addrepository.hamlet
@ -11,4 +11,9 @@
      <h2>
        Store your data in the cloud

-      ^{makeCloudRepositories False}
+      ^{makeCloudRepositories}
+
+      <h2>
+        Archive your data
+
+      ^{makeArchiveRepositories}
--- a/templates/configurators/addrepository/archive.hamlet
+++ b/templates/configurators/addrepository/archive.hamlet
@ -0,0 +1,11 @@
+<h3>
+  <a href="@{AddGlacierR}">
+    <i .icon-plus-sign></i> Amazon Glacier
+<p>
+  Low cost offline data archival.
+
+<h3>
+  <a href="@{AddIAR}">
+    <i .icon-plus-sign></i> Internet Archive
+<p>
+  Free archival of public data.
--- a/templates/configurators/addrepository/cloud.hamlet
+++ b/templates/configurators/addrepository/cloud.hamlet
@ -16,13 +16,6 @@
 <p>
  Good choice for professional quality storage.

-$if not onlyTransfer
-  <h3>
-    <a href="@{AddGlacierR}">
-      <i .icon-plus-sign></i> Amazon Glacier
-  <p>
-    Low cost offline data archival.
-
 <h3>
  <a href="@{AddSshR}">
    <i .icon-plus-sign></i> Remote server
--- a/templates/configurators/pairing/xmpp/end.hamlet
+++ b/templates/configurators/pairing/xmpp/end.hamlet
@ -29,4 +29,4 @@
  ^{cloudRepoList}
  <h2>
    Add a cloud repository
-  ^{makeCloudRepositories True}
+  ^{makeCloudRepositories}
--- a/templates/configurators/xmpp/needcloudrepo.hamlet
+++ b/templates/configurators/xmpp/needcloudrepo.hamlet
@ -14,4 +14,4 @@
  ^{cloudRepoList}
  <h2>
    Add a cloud repository
-  ^{makeCloudRepositories True}
+  ^{makeCloudRepositories}
--- a/templates/documentation/repogroup.hamlet
+++ b/templates/documentation/repogroup.hamlet
@ -46,6 +46,11 @@
    <b>source repositories</b>. Repositories in this group only retain #
    files until they can be moved to some other repository, like a client #
    or transfer repository.
+  <p>
+    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.
  <p>
    Finally, repositories can be configured to be in <b>manual mode</b>. This #
    prevents content being automatically synced to the repository, but #