webapp: S3 and Glacier forms now have a select list of all currently-supported AWS regions.

4 files changed, 51 insertions, 2 deletions

diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index edb9225aa..0a41b0083 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -8,6 +8,7 @@
 module Remote.Glacier (remote, jobList) where
 
 import qualified Data.Map as M
+import qualified Data.Text as T
 import System.Environment
 
 import Common.Annex
@@ -73,7 +74,7 @@ glacierSetup u c = do
 	remotename = fromJust (M.lookup "name" c)
 	defvault = remotename ++ "-" ++ fromUUID u
 	defaults = M.fromList
-		[ ("datacenter", "us-east-1")
+		[ ("datacenter", T.unpack $ AWS.defaultRegion AWS.Glacier)
 		, ("vault", defvault)
 		]
 
diff --git a/Remote/Helper/AWS.hs b/Remote/Helper/AWS.hs
index a988a0b15..1d80ff1b4 100644
--- a/Remote/Helper/AWS.hs
+++ b/Remote/Helper/AWS.hs
@@ -5,11 +5,16 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE OverloadedStrings, TupleSections #-}
+
 module Remote.Helper.AWS where
 
 import Common.Annex
 import Creds
 
+import qualified Data.Map as M
+import Data.Text (Text)
+
 creds :: UUID -> CredPairStorage
 creds u = CredPairStorage
 	{ credPairFile = fromUUID u
@@ -19,3 +24,43 @@ creds u = CredPairStorage
 
 setCredsEnv :: CredPair -> IO ()
 setCredsEnv p = setEnvCredPair p $ creds undefined
+
+data Service = S3 | Glacier
+	deriving (Eq)
+
+type Region = Text
+
+regionMap :: Service -> M.Map Text Region
+regionMap = M.fromList . regionInfo
+
+defaultRegion :: Service -> Region
+defaultRegion = snd . Prelude.head . regionInfo
+
+{- S3 and Glacier use different names for some regions. Ie, "us-east-1"
+ - cannot be used with S3, while "US" cannot be used with Glacier. Dunno why.
+ - Also, Glacier is not yet available in all regions. -}
+regionInfo :: Service -> [(Text, Region)]
+regionInfo service = map (\(t, r) -> (t, fromServiceRegion r)) $ 
+	filter (matchingService . snd) $
+	concatMap (\(t, l) -> map (t,) l) regions
+  where
+	regions =
+		[ ("US East (N. Virginia)", [S3Region "US", GlacierRegion "us-east-1"])
+		, ("US West (Oregon)", [BothRegion "us-west-2"])
+		, ("US West (N. California)", [BothRegion "us-west-1"])
+		, ("EU (Ireland)", [S3Region "EU", GlacierRegion "eu-west-1"])
+		, ("Asia Pacific (Singapore)", [S3Region "ap-southeast-1"])
+		, ("Asia Pacific (Tokyo)", [BothRegion "ap-northeast-1"])
+		, ("Asia Pacific (Sydney)", [S3Region "ap-southeast-2"])
+		, ("South America (São Paulo)", [S3Region "sa-east-1"])
+		]
+
+	fromServiceRegion (BothRegion s) = s
+	fromServiceRegion (S3Region s) = s
+	fromServiceRegion (GlacierRegion s) = s
+
+	matchingService (BothRegion _) = True
+	matchingService (S3Region _) = service == S3
+	matchingService (GlacierRegion _) = service == Glacier
+
+data ServiceRegion = BothRegion Region | S3Region Region | GlacierRegion Region
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 512b3f778..e50145f61 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -11,6 +11,7 @@ import Network.AWS.AWSConnection
 import Network.AWS.S3Object
 import Network.AWS.S3Bucket hiding (size)
 import Network.AWS.AWSResult
+import qualified Data.Text as T
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.Map as M
 import Data.Char
@@ -68,7 +69,7 @@ s3Setup u c = handlehost $ M.lookup "host" c
 	remotename = fromJust (M.lookup "name" c)
 	defbucket = remotename ++ "-" ++ fromUUID u
 	defaults = M.fromList
-		[ ("datacenter", "US")
+		[ ("datacenter", T.unpack $ AWS.defaultRegion AWS.S3)
 		, ("storageclass", "STANDARD")
 		, ("host", defaultAmazonS3Host)
 		, ("port", show defaultAmazonS3Port)
diff --git a/debian/changelog b/debian/changelog
index 2a68d50c2..cfcf3de00 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -11,6 +11,8 @@ git-annex (3.20121128) UNRELEASED; urgency=low
   * Allow `git annex drop --from web`; of course this does not remove
     any file from the web, but it does make git-annex remove all urls
     associated with a file.
+  * webapp: S3 and Glacier forms now have a select list of all
+    currently-supported AWS regions.
 
  -- Joey Hess <joeyh@debian.org>  Wed, 28 Nov 2012 13:31:07 -0400