initremote now creates buckets

1 files changed, 90 insertions, 57 deletions

diff --git a/Remote/S3.hs b/Remote/S3.hs
index 489114b12..16b3992da 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -13,12 +13,12 @@ import Network.AWS.S3Bucket
 import Network.AWS.AWSResult
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.Map as M
+import Data.Maybe
 import Data.String.Utils
 import Control.Monad (filterM, liftM, when)
 import Control.Monad.State (liftIO)
 import System.Environment
 import Data.Char
-import Messages
 
 import RemoteClass
 import Types
@@ -26,6 +26,8 @@ import qualified GitRepo as Git
 import qualified Annex
 import UUID
 import Config
+import Utility
+import Messages
 
 remote :: RemoteType Annex
 remote = RemoteType {
@@ -34,21 +36,14 @@ remote = RemoteType {
 	setup = s3Setup
 }
 
-gen :: Annex (RemoteGenerator Annex)
+gen :: Annex [Remote Annex]
 gen = do
 	g <- Annex.gitRepo
-	remotes <- filterM remoteNotIgnored $ findS3Remotes g
-	todo <- filterM cachedUUID remotes
-	let ok = filter (`notElem` todo) remotes
-	
-	let actions = map (\r -> genRemote r =<< getUUID r) ok ++
-		map (\r -> genRemote r =<< getS3UUID r) todo
-	return (actions, map Git.repoDescribe todo)
-
-	where
-		cachedUUID r = liftM null $ getUUID r
+	l <- filterM remoteNotIgnored $ findS3Remotes g
+	generated <- mapM genRemote l
+	return $ catMaybes generated
 
-{- S3 remotes have a remote.<name>.annex-s3-bucket config setting.
+{- S3 remotes have a remote.<name>.annex-s3 config setting.
  - Git.Repo does not normally generate remotes for things that
  - have no configured url, so the Git.Repo objects have to be
  - constructed as coming from an unknown location. -}
@@ -58,56 +53,81 @@ findS3Remotes r = map construct remotepairs
 		remotepairs = M.toList $ filterremotes $ Git.configMap r
 		filterremotes = M.filterWithKey (\k _ -> s3remote k)
 		construct (k,_) = Git.repoRemoteNameSet Git.repoFromUnknown k
-		s3remote k = startswith "remote." k && endswith ".annex-s3-bucket" k
+		s3remote k = startswith "remote." k && endswith ".annex-s3" k
 
-genRemote :: Git.Repo -> UUID -> Annex (Remote Annex)
-genRemote r u = do
-	c <- remoteCost r
-	return Remote {
-		uuid = u,
-		cost = c,
-		name = Git.repoDescribe r,
-		storeKey = error "TODO",
-		retrieveKeyFile = error "TODO",
-		removeKey = error "TODO",
-		hasKey = error "TODO",
-		hasKeyCheap = False,
-		config = Nothing
-	}
+genRemote :: Git.Repo -> Annex (Maybe (Remote Annex))
+genRemote r = do
+	u <- getUUID r
+	if (u == "")
+		then return Nothing
+		else do
+			c <- remoteCost r
+			return $ Just $ Remote {
+				uuid = u,
+				cost = c,
+				name = Git.repoDescribe r,
+				storeKey = error "TODO",
+				retrieveKeyFile = error "TODO",
+				removeKey = error "TODO",
+				hasKey = error "TODO",
+				hasKeyCheap = False,
+				config = Nothing
+			}
 
-s3Connection :: Git.Repo -> Annex (Maybe AWSConnection)
-s3Connection r = do
-	host <- getS3Config r "s3-host" (Just defaultAmazonS3Host)
-	port <- getS3Config r "s3-port" (Just $ show defaultAmazonS3Port)
-	accesskey <- getS3Config r "s3-access-key-id" Nothing
-	secretkey <- getS3Config r "s3-secret-access-key" Nothing
-	case reads port of
-		[(p, _)] -> return $ Just $ AWSConnection host p accesskey secretkey
-		_ -> error $ "bad S3 port value: " ++ port
-
-withS3Connection :: Git.Repo -> Annex a -> ((AWSConnection, String) -> Annex a) -> Annex a
-withS3Connection r def a = do
-	c <- s3Connection r
-	case c of
-		Nothing -> def
-		Just c' -> do
-			b <- getConfig r "s3-bucket" ""
-			a (c', b)
-
-getS3Config :: Git.Repo -> String -> Maybe String-> Annex String
-getS3Config r s def = do
-	e <- liftIO $ catch (liftM Just $ getEnv envvar) (const $ return def)
-	v <- case e of
-		Nothing -> getConfig r s ""
-		Just d -> getConfig r s d
-	when (null v) $ error $ "set " ++ envvar ++ " or " ++ remoteConfig r s
-	return v
+s3Connection :: M.Map String String -> IO AWSConnection
+s3Connection c = do
+	ak <- getEnvKey "AWS_ACCESS_KEY_ID"
+	sk <- getEnvKey "AWS_SECRET_ACCESS_KEY"
+	return $ AWSConnection host port ak sk
 	where
-		envvar = "ANNEX_" ++ map (\c -> if c == '-' then '_' else toUpper c) s
+		host = fromJust $ (M.lookup "host" c)
+		port = let s = fromJust $ (M.lookup "port" c) in
+			case reads s of
+			[(p, _)] -> p
+			_ -> error $ "bad S3 port value: " ++ s
+		getEnvKey s = catch (getEnv s) (error $ "Set " ++ s)
 
 s3Setup :: UUID -> M.Map String String -> Annex (M.Map String String)
 s3Setup u c = do
-	return c
+	-- verify configuration is sane
+	case M.lookup "encryption" c of
+		Nothing -> error "Specify encryption=key or encryption=none"
+		Just "none" -> return ()
+		Just k -> error "encryption keys not yet supported"
+	let fullconfig = M.union c defaults
+
+	-- check bucket location to see if the bucket exists
+	let datacenter = fromJust $ M.lookup "datacenter" fullconfig
+	conn <- liftIO $ s3Connection fullconfig
+	showNote "checking bucket"
+	loc <- liftIO $ getBucketLocation conn bucket 
+	case loc of
+		Right _ -> return ()
+		Left err@(NetworkError _) -> error $ prettyReqError err
+		Left (AWSError _ _) -> do
+			showNote "creating bucket"
+			res <- liftIO $ createBucketIn conn bucket datacenter
+			case res of
+				Right _ -> return ()
+				Left err -> error $ prettyReqError err
+
+	g <- Annex.gitRepo
+	liftIO $ do
+		Git.run g "config" [Param ("remote." ++ name ++ ".annex-s3"), Param "true"]
+		Git.run g "config" [Param ("remote." ++ name ++ ".annex-uuid"), Param u]
+	return fullconfig
+	where
+		name = fromJust (M.lookup "name" c)
+		bucket = name ++ "-" ++ u
+		defaults = M.fromList
+			[ ("datacenter", "US")
+			, ("storageclass", "STANDARD")
+			, ("host", defaultAmazonS3Host)
+			, ("port", show defaultAmazonS3Port)
+			, ("bucket", bucket)
+			]
+
+{-
 
 {- The UUID of a S3 bucket is stored in a file "git-annex-uuid" in the
  - bucket. Gets the UUID, or if there is none, sets a new UUID, possibly
@@ -135,3 +155,16 @@ getS3UUID r = withS3Connection r disable $ \(c, b) -> do
 	where
 		uuidfile = "git-annex-uuid"
 		disable = return "" -- empty uuid will disable this remote
+
+getS3Config :: Git.Repo -> String -> Maybe String-> Annex String
+getS3Config r s def = do
+	e <- liftIO $ catch (liftM Just $ getEnv envvar) (const $ return def)
+	v <- case e of
+		Nothing -> getConfig r s ""
+		Just d -> getConfig r s d
+	when (null v) $ error $ "set " ++ envvar ++ " or " ++ remoteConfig r s
+	return v
+	where
+		envvar = "ANNEX_" ++ map (\c -> if c == '-' then '_' else toUpper c) s
+
+-}