support enabling IA repositories

Assistant/WebApp/Configurators/AWS.hs

@@ -156,11 +156,17 @@ postAddGlacierR = glacierConfigurator $ do
 		setStandardGroup (Remote.uuid r) SmallArchiveGroup
 
 getEnableS3R :: UUID -> Handler RepHtml
-getEnableS3R = postEnableS3R
+getEnableS3R uuid = do
+	m <- liftAnnex readRemoteLog
+	let host = fromMaybe "" $ M.lookup "host" $
+		fromJust $ M.lookup uuid m
+	if S3.isIAHost host
+		then redirect $ EnableIAR uuid
+		else postEnableS3R uuid
 
 postEnableS3R :: UUID -> Handler RepHtml
 #ifdef WITH_S3
-postEnableS3R = awsConfigurator . enableAWSRemote S3.remote
+postEnableS3R uuid = awsConfigurator $ enableAWSRemote S3.remote uuid
 #else
 postEnableS3R _ = error "S3 not supported by this build"
 #endif

Assistant/WebApp/Configurators/IA.hs

@@ -17,11 +17,11 @@ import qualified Remote.S3 as S3
 import qualified Remote
 import Types.StandardGroups
 import Logs.PreferredContent
+import Logs.Remote
 
 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
@@ -83,6 +83,11 @@ iaInputAForm = IAInput
 	mediatypes :: [(Text, MediaType)]
 	mediatypes = map (\t -> (T.pack $ showMediaType t, t)) [minBound..]
 
+iaCredsAForm :: AForm WebApp WebApp AWS.AWSCreds
+iaCredsAForm = AWS.AWSCreds
+        <$> accessKeyIDFieldWithHelp
+        <*> AWS.secretAccessKeyField
+
 accessKeyIDFieldWithHelp :: AForm WebApp WebApp Text
 accessKeyIDFieldWithHelp = AWS.accessKeyIDField help
   where
@@ -106,7 +111,7 @@ postAddIAR = iaConfigurator $ do
 				M.fromList $ catMaybes
 					[ Just $ configureEncryption NoEncryption
 					, Just ("type", "S3")
-					, Just ("host", iaHost)
+					, Just ("host", S3.iaHost)
 					, Just ("bucket", escapeHeader name)
 					, Just ("x-archive-meta-title", escapeHeader $ T.unpack $ itemDescription input)
 					, if mediaType input == MediaOmitted
@@ -129,20 +134,32 @@ getEnableIAR = postEnableIAR
 
 postEnableIAR :: UUID -> Handler RepHtml
 #ifdef WITH_S3
-postEnableIAR = iaConfigurator . AWS.enableAWSRemote S3.remote
+postEnableIAR = iaConfigurator . enableIARemote
 #else
 postEnableIAR _ = error "S3 not supported by this build"
 #endif
 
+enableIARemote :: UUID -> Widget
+enableIARemote uuid = do
+	((result, form), enctype) <- lift $
+		runFormPost $ renderBootstrap iaCredsAForm
+	case result of
+		FormSuccess creds -> lift $ do
+			m <- liftAnnex readRemoteLog
+			let name = fromJust $ M.lookup "name" $
+				fromJust $ M.lookup uuid m
+			AWS.makeAWSRemote S3.remote creds name (const noop) M.empty
+		_ -> do
+			description <- liftAnnex $
+				T.pack <$> Remote.prettyUUID uuid
+			$(widgetFile "configurators/enableia")
+
 {- 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 " " "-"
+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"

Remote/S3.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Remote.S3 (remote) where
+module Remote.S3 (remote, iaHost, isIAHost) where
 
 import Network.AWS.AWSConnection
 import Network.AWS.S3Object
@@ -15,6 +15,7 @@ import qualified Data.Text as T
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.Map as M
 import Data.Char
+import Network.Socket (HostName)
 
 import Common.Annex
 import Types.Remote
@@ -81,7 +82,7 @@ s3Setup u c = handlehost $ M.lookup "host" c
 		
 	handlehost Nothing = defaulthost
 	handlehost (Just h)
-		| ".archive.org" `isSuffixOf` map toLower h = archiveorg
+		| isIAHost h = archiveorg
 		| otherwise = defaulthost
 
 	use fullconfig = do
@@ -270,3 +271,10 @@ s3Connection c u = go =<< getRemoteCredPairFor "S3" c (AWS.creds u)
 		case reads s of
 		[(p, _)] -> p
 		_ -> error $ "bad S3 port value: " ++ s
+
+{- Hostname to use for archive.org S3. -}
+iaHost :: HostName
+iaHost = "s3.us.archive.org"
+
+isIAHost :: HostName -> Bool
+isIAHost h = ".archive.org" `isSuffixOf` map toLower h

templates/configurators/enableia.hamlet

@@ -0,0 +1,22 @@
+<div .span9 .hero-unit>
+  <h2>
+    Enabling #{description}
+  <p>
+    To use this Internet Archive repository, you need an Access Key ID, and a #
+    Secret Access Key. These access keys will be stored in a file that #
+    only you can access.
+  <p>
+    <form method="post" .form-horizontal enctype=#{enctype}>
+      <fieldset>
+        ^{form}
+        ^{webAppFormAuthToken}
+        <div .form-actions>
+          <button .btn .btn-primary type=submit onclick="$('#workingmodal').modal('show');">
+            Enable Internet Archive repository
+<div .modal .fade #workingmodal>
+  <div .modal-header>
+    <h3>
+      Enabling repository ...
+  <div .modal-body>
+    <p>
+      Enabling this Internet Archive repository. This could take a minute.