initremote now creates buckets
This commit is contained in:
Joey Hess
parent
e62f9816ab
commit
475f707361
5 changed files with 106 additions and 89 deletions
147
Remote/S3.hs
147
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)
|
||||
l <- filterM remoteNotIgnored $ findS3Remotes g
|
||||
generated <- mapM genRemote l
|
||||
return $ catMaybes generated
|
||||
|
||||
where
|
||||
cachedUUID r = liftM null $ getUUID r
|
||||
|
||||
{- 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
|
||||
|
||||
-}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue