summaryrefslogtreecommitdiff
path: root/Remote/S3.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2011-03-29 16:21:21 -0400
committerGravatar Joey Hess <joey@kitenet.net>2011-03-29 16:21:21 -0400
commit475f7073613b7164302e3f826f60929cf4cd38f0 (patch)
tree8ce447a9549ede25e27fce04568955440ad539d7 /Remote/S3.hs
parente62f9816ab29dceb5489d520b9cf569ede2ffb52 (diff)
initremote now creates buckets
Diffstat (limited to 'Remote/S3.hs')
-rw-r--r--Remote/S3.hs147
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
+
+-}