add a configurator for S3

Assistant/MakeRemote.hs

@@ -55,13 +55,10 @@ addRemote a = do
 	void remoteListRefresh
 	maybe (error "failed to add remote") return =<< Remote.byName (Just name)
 
-{- Inits a rsync special remote, and returns the name of the remote. -}
+{- Inits a rsync special remote, and returns its name. -}
 makeRsyncRemote :: String -> String -> Annex String
-makeRsyncRemote name location = makeRemote name location $ const $ do
+makeRsyncRemote name location = makeRemote name location $
-	(u, c) <- Command.InitRemote.findByName name
+	const $ void $ makeSpecialRemote name Rsync.remote config
-	c' <- R.setup Rsync.remote u $ M.union config c
-	describeUUID u name
-	configSet u c'
 	where
 		config = M.fromList
 			[ ("encryption", "shared")
@@ -69,6 +66,15 @@ makeRsyncRemote name location = makeRemote name location $ const $ do
 			, ("type", "rsync")
 			]
 
+{- Inits a special remote, and returns its name. -}
+makeSpecialRemote :: String -> RemoteType -> R.RemoteConfig -> Annex String
+makeSpecialRemote name remotetype config = do
+	(u, c) <- Command.InitRemote.findByName name
+	c' <- R.setup remotetype u $ M.union config c
+	describeUUID u name
+	configSet u c'
+	return name
+
 {- Returns the name of the git remote it created. If there's already a
  - remote at the location, returns its name. -}
 makeGitRemote :: String -> String -> Annex String
@@ -86,7 +92,7 @@ makeRemote basename location a = do
 	r <- fromRepo id
 	if not (any samelocation $ Git.remotes r)
 		then do
-			let name = uniqueRemoteName r basename 0
+			let name = uniqueRemoteName basename 0 r
 			a name
 			return name
 		else return basename
@@ -95,10 +101,10 @@ makeRemote basename location a = do
 
 {- Generate an unused name for a remote, adding a number if
  - necessary. -}
-uniqueRemoteName :: Git.Repo -> String -> Int -> String
+uniqueRemoteName :: String -> Int -> Git.Repo -> String
-uniqueRemoteName r basename n
+uniqueRemoteName basename n r
 	| null namecollision = name
-	| otherwise = uniqueRemoteName r basename (succ n)
+	| otherwise = uniqueRemoteName basename (succ n) r
 	where
 		namecollision = filter samename (Git.remotes r)
 		samename x = Git.remoteName x == Just name

Assistant/Threads/WebApp.hs

@@ -20,6 +20,7 @@ import Assistant.WebApp.Configurators
 import Assistant.WebApp.Configurators.Local
 import Assistant.WebApp.Configurators.Ssh
 import Assistant.WebApp.Configurators.Pairing
+import Assistant.WebApp.Configurators.S3
 import Assistant.WebApp.Documentation
 import Assistant.WebApp.OtherRepos
 import Assistant.ThreadedMonad

Assistant/WebApp/Configurators/S3.hs

@@ -0,0 +1,95 @@
+{- git-annex assistant webapp configurator for Amazon S3
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+
+module Assistant.WebApp.Configurators.S3 where
+
+import Assistant.Common
+import Assistant.MakeRemote
+import Assistant.Sync
+import Assistant.WebApp
+import Assistant.WebApp.Types
+import Assistant.WebApp.SideBar
+import Assistant.ThreadedMonad
+import Utility.Yesod
+import qualified Remote.S3 as S3
+
+import Yesod
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Map as M
+
+data S3Input = S3Input
+	{ accessKeyID :: Text
+	, secretAccessKey :: Text
+	-- Free form text for datacenter because Amazon adds new ones.
+	, datacenter :: Text
+	, storageClass :: StorageClass
+	, repoName :: Text
+	}
+	deriving (Show)
+
+data StorageClass = StandardRedundancy | ReducedRedundancy
+	deriving (Eq, Enum, Bounded)
+
+instance Show StorageClass where
+	show StandardRedundancy = "STANDARD" 
+	show ReducedRedundancy = "REDUCED_REDUNDANCY"
+
+s3AForm :: AForm WebApp WebApp S3Input
+s3AForm = S3Input
+	<$> areq textField "Access Key ID" Nothing
+	<*> areq passwordField "Secret Access Key" Nothing
+	<*> areq textField "Datacenter" (Just "US")
+	<*> areq (selectFieldList storageclasses) "Storage class" (Just StandardRedundancy)
+	<*> areq textField "Repository name" (Just "S3")
+	where
+		storageclasses :: [(Text, StorageClass)]
+		storageclasses =
+			[ ("Standard redundancy", StandardRedundancy)
+			, ("Reduced redundancy (costs less)", ReducedRedundancy)
+			]
+
+getAddS3R :: Handler RepHtml
+getAddS3R = bootstrap (Just Config) $ do
+	sideBarDisplay
+	setTitle "Add an Amazon S3 repository"
+	((result, form), enctype) <- lift $
+		runFormGet $ renderBootstrap s3AForm
+	case result of
+		FormSuccess s3input -> lift $ do
+			let name = T.unpack $ repoName s3input
+			name' <- runAnnex name $
+				fromRepo $ uniqueRemoteName name 0
+			makeS3Remote s3input name'
+		_ -> showform form enctype
+	where
+		showform form enctype = do
+			let authtoken = webAppFormAuthToken
+			$(widgetFile "configurators/adds3")
+
+makeS3Remote :: S3Input -> String -> Handler ()
+makeS3Remote s3input name = do
+	webapp <- getYesod
+	let st = fromJust $ threadState webapp
+	liftIO $ do
+		S3.s3SetCredsEnv
+			( T.unpack $ accessKeyID s3input
+			, T.unpack $ secretAccessKey s3input
+			)
+		r <- runThreadState st $ addRemote $
+			makeSpecialRemote name S3.remote config
+		syncNewRemote st (daemonStatus webapp) (scanRemotes webapp) r
+	redirect RepositoriesR
+	where
+		config = M.fromList
+			[ ("encryption", "shared")
+			, ("type", "S3")
+			, ("datacenter", T.unpack $ datacenter s3input)
+			, ("storageclass", show $ storageClass s3input)
+			]

Assistant/WebApp/routes

@@ -15,7 +15,8 @@
 /config/repository/add/ssh/confirm/#SshData ConfirmSshR GET
 /config/repository/add/ssh/make/git/#SshData MakeSshGitR GET
 /config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET
-/config/repository/add/rsync.net AddRsyncNetR GET
+/config/repository/add/cloud/rsync.net AddRsyncNetR GET
+/config/repository/add/cloud/S3 AddS3R GET
 
 /config/repository/pair/start StartPairR GET
 /config/repository/pair/inprogress/#SecretReminder InprogressPairR GET

debian/changelog

@@ -14,7 +14,8 @@ git-annex (3.20120925) UNRELEASED; urgency=low
     Closes: #688833
   * S3: When using a shared cipher, S3 credentials are not stored encrypted
     in the git repository, as that would allow anyone with access to
-    the repository access to the S3 account.
+    the repository access to the S3 account. Instead, they're stored
+    in a 600 mode file in the local git repo.
 
  -- Joey Hess <joeyh@debian.org>  Mon, 24 Sep 2012 19:58:07 -0400
 

templates/configurators/adds3.hamlet

@@ -0,0 +1,38 @@
+<div .span9 .hero-unit>
+  <h2>
+    Adding an Amazon S3 repository
+  <p>
+    <a href="http://aws.amazon.com/s3/">Amazon S3</a> is a cloud storage #
+    provider. If you need a professional level of storage for your data, #
+    this is a good choice. #
+    <a href="http://aws.amazon.com/s3/pricing/">
+      Pricing details, including one year Free Usage Tier promotion
+  <p>
+    <i .icon-warning-sign></i> Do keep in mind that all your data #
+    will be synced to Amazon S3. You will be charged by Amazon for data #
+    uploaded to S3, as well as data downloaded from S3, and a monthly fee #
+    for data storage. #
+  <p>
+    All data will be encrypted before being sent to Amazon S3.
+  <p>
+    When you sign up to Amazon S3, they provide you with an Access #
+    Key ID, and a Secret Access Key. You will need to enter both below. #
+    These access keys will be stored in a file that only you can #
+    access. #
+    <a href="https://portal.aws.amazon.com/gp/aws/securityCredentials#id_block">
+      Look up your access keys
+  <p>
+    <form .form-horizontal enctype=#{enctype}>
+      <fieldset>
+        ^{form}
+        ^{authtoken}
+        <div .form-actions>
+          <button .btn .btn-primary type=submit onclick="$('#workingmodal').modal('show');">
+            Add S3 repository
+<div .modal .fade #workingmodal>
+  <div .modal-header>
+    <h3>
+      Making repository ...
+  <div .modal-body>
+    <p>
+      Setting up your Amazon S3 repository. This could take a minute.

templates/configurators/repositories.hamlet

@@ -61,10 +61,16 @@
         Works very well with git-annex.
 
       <h3>
+        <a href="@{AddS3R}">
           <i .icon-plus-sign></i> Amazon S3
       <p>
         Good choice for professional storage quality and low prices.
       
+      <h3>
+        <i .icon-plus-sign></i> Amazon Glacier
+      <p>
+        Low cost offline data archival.
+
       <h3>
         <i .icon-plus-sign></i> Box.com
       <p>