progress

1 files changed, 57 insertions, 57 deletions

diff --git a/Remote/S3.hs b/Remote/S3.hs
index 16b3992da..887b19e73 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -7,6 +7,7 @@
 
 module Remote.S3 (remote) where
 
+import Control.Exception.Extensible (IOException)
 import Network.AWS.AWSConnection
 import Network.AWS.S3Object
 import Network.AWS.S3Bucket
@@ -15,10 +16,9 @@ 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 (filterM, when)
 import Control.Monad.State (liftIO)
 import System.Environment
-import Data.Char
 
 import RemoteClass
 import Types
@@ -62,17 +62,21 @@ genRemote r = do
 		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
-			}
+			return $ Just $ newremote u c
+	where
+		newremote u c = this
+			where
+				this = Remote {
+					uuid = u,
+					cost = c,
+					name = Git.repoDescribe r,
+			 		storeKey = s3Store this,
+					retrieveKeyFile = error "TODO retrievekey",
+					removeKey = error "TODO removekey",
+					hasKey = s3CheckPresent this,
+					hasKeyCheap = False,
+					config = Nothing
+				}
 
 s3Connection :: M.Map String String -> IO AWSConnection
 s3Connection c = do
@@ -93,10 +97,10 @@ s3Setup u c = do
 	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"
+		Just _ -> error "encryption keys not yet supported"
 	let fullconfig = M.union c defaults
 
-	-- check bucket location to see if the bucket exists
+	-- check bucket location to see if the bucket exists, and create it
 	let datacenter = fromJust $ M.lookup "datacenter" fullconfig
 	conn <- liftIO $ s3Connection fullconfig
 	showNote "checking bucket"
@@ -105,7 +109,7 @@ s3Setup u c = do
 		Right _ -> return ()
 		Left err@(NetworkError _) -> error $ prettyReqError err
 		Left (AWSError _ _) -> do
-			showNote "creating bucket"
+			showNote $ "creating bucket in " ++ datacenter
 			res <- liftIO $ createBucketIn conn bucket datacenter
 			case res of
 				Right _ -> return ()
@@ -113,12 +117,13 @@ s3Setup u c = do
 
 	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]
+		Git.run g "config" [Param (configsetting "annex-s3"), Param "true"]
+		Git.run g "config" [Param (configsetting "annex-uuid"), Param u]
 	return fullconfig
 	where
-		name = fromJust (M.lookup "name" c)
-		bucket = name ++ "-" ++ u
+		remotename = fromJust (M.lookup "name" c)
+		bucket = remotename ++ "-" ++ u
+		configsetting s = "remote." ++ remotename ++ "." ++ s
 		defaults = M.fromList
 			[ ("datacenter", "US")
 			, ("storageclass", "STANDARD")
@@ -127,44 +132,39 @@ s3Setup u c = do
 			, ("bucket", bucket)
 			]
 
-{-
+s3Action :: Remote Annex -> ((AWSConnection, String) -> Annex a) -> Annex a
+s3Action r a = do
+	when (config r == Nothing) $
+		error $ "Missing configuration for special remote " ++ name r
+	conn <- liftIO $ s3Connection (fromJust $ config r)
+	let bucket = fromJust $ M.lookup "bucket" $ fromJust $ config r
+	a (conn, bucket)
+
+s3File :: Key -> FilePath
+s3File k = show k
 
-{- 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
- - also creating the bucket. -}
-getS3UUID :: Git.Repo -> Annex UUID
-getS3UUID r = withS3Connection r disable $ \(c, b) -> do
-	res <- liftIO $
-		getObject c $ S3Object b uuidfile "" [] L.empty
+s3CheckPresent :: Remote Annex -> Key -> Annex (Either IOException Bool)
+s3CheckPresent r k = s3Action r $ \(conn, bucket) -> do
+	let object = S3Object bucket (s3File k) "" [] L.empty
+	showNote ("checking " ++ name r ++ "...")
+	res <- liftIO $ getObjectInfo conn object
 	case res of
-		Right o -> return $ L.unpack $ obj_data o
-		Left _ -> do
-			location <- getS3Config r "s3-datacenter" (Just "EU")
-			-- bucket may already exist, or not
-			_ <- liftIO $ createBucketIn c b location
-			u <- getUUID r
-			res' <- liftIO $ sendObject c $
-				S3Object b uuidfile "" [] $
-					L.pack u
-			case res' of
-				Right _ -> return u
-				Left e -> do
-					warning $ prettyReqError e
-					disable
-					
-	where
-		uuidfile = "git-annex-uuid"
-		disable = return "" -- empty uuid will disable this remote
+		Right _ -> return $ Right True
+		Left (AWSError _ _) -> return $ Right False
+		Left e -> return $ Left (error $ prettyReqError e)
 
-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
+s3Store :: Remote Annex -> Key -> Annex Bool
+s3Store r k = s3Action r $ \(conn, bucket) -> do
+	let object = setStorageClass storageclass $
+		S3Object bucket (s3File k) "" [] (error "read content here")
+	res <- liftIO $ sendObject conn object
+	case res of
+		Right _ -> return True
+		Left e -> do
+			warning $ prettyReqError e
+			return False
 	where
-		envvar = "ANNEX_" ++ map (\c -> if c == '-' then '_' else toUpper c) s
-
--}
+		storageclass =
+			case fromJust $ M.lookup "storageclass" $ fromJust $ config r of
+				"REDUCED_REDUNDANCY" -> REDUCED_REDUNDANCY
+				_ -> STANDARD