diff options
| -rw-r--r-- | Remote.hs | 21 | ||||
| -rw-r--r-- | Remote/Git.hs | 16 | ||||
| -rw-r--r-- | Remote/S3.hs | 147 | ||||
| -rw-r--r-- | RemoteClass.hs | 7 | ||||
| -rw-r--r-- | doc/walkthrough/using_Amazon_S3.mdwn | 4 |
5 files changed, 106 insertions, 89 deletions
@@ -31,7 +31,6 @@ module Remote ( import Control.Monad.State (liftIO) import Control.Monad (when, liftM) import Data.List -import Data.String.Utils import qualified Data.Map as M import Data.Maybe @@ -42,7 +41,6 @@ import qualified Annex import Trust import LocationLog import Locations -import Messages import Utility import qualified Remote.Git @@ -54,19 +52,6 @@ remoteTypes = , Remote.S3.remote ] -{- Runs the generators of each type of Remote -} -runGenerators :: Annex [Remote Annex] -runGenerators = do - (actions, expensive) <- collect ([], []) $ map generator remoteTypes - when (not $ null expensive) $ - showNote $ "getting UUID for " ++ join ", " expensive - sequence actions - where - collect v [] = return v - collect (actions, expensive) (x:xs) = do - (a, e) <- x - collect (a++actions, e++expensive) xs - {- Builds a list of all available Remotes. - Since doing so can be expensive, the list is cached in the Annex. -} genList :: Annex [Remote Annex] @@ -74,9 +59,9 @@ genList = do rs <- Annex.getState Annex.remotes if null rs then do - rs' <- runGenerators - rs'' <- getConfigs rs' - Annex.changeState $ \s -> s { Annex.remotes = rs'' } + l <- mapM generator remoteTypes + rs' <- getConfigs (concat l) + Annex.changeState $ \s -> s { Annex.remotes = rs' } return rs' else return rs diff --git a/Remote/Git.hs b/Remote/Git.hs index 2d7a0c8ff..85bd04a23 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -15,6 +15,8 @@ import Control.Monad.State (liftIO) import qualified Data.Map as M import System.Cmd.Utils import Control.Monad (filterM, liftM) +import Data.String.Utils +import Maybe import RemoteClass import Types @@ -37,7 +39,7 @@ remote = RemoteType { setup = error "not supported" } -gen :: Annex (RemoteGenerator Annex) +gen :: Annex [Remote Annex] gen = do g <- Annex.gitRepo allremotes <- filterM remoteNotIgnored $ Git.remotes g @@ -52,18 +54,20 @@ gen = do let skip = filter (`notElem` expensive_todo) expensive let todo = cheap++expensive_todo - let actions = map genRemote skip ++ - map (\r -> genRemote =<< tryGitConfigRead r) todo - return (actions, map Git.repoDescribe expensive_todo) + showNote $ "getting UUID for " ++ (join ", " $ + map Git.repoDescribe expensive_todo) + done <- mapM tryGitConfigRead todo + generated <- mapM genRemote $ skip ++ done + return $ catMaybes generated where cachedUUID r = liftM null $ getUUID r -genRemote :: Git.Repo -> Annex (Remote Annex) +genRemote :: Git.Repo -> Annex (Maybe (Remote Annex)) genRemote r = do u <- getUUID r c <- remoteCost r - return Remote { + return $ Just $ Remote { uuid = u, cost = c, name = Git.repoDescribe r, 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 + +-} diff --git a/RemoteClass.hs b/RemoteClass.hs index 825197a4b..e16cbdbb0 100644 --- a/RemoteClass.hs +++ b/RemoteClass.hs @@ -14,17 +14,12 @@ import Data.Map as M import Key -{- A remote generator identifies configured remotes, and returns an action - - that can be run to set up each remote, and a list of names of remotes - - that are not cheap to set up. -} -type RemoteGenerator a = ([a (Remote a)], [String]) - {- There are different types of remotes. -} data RemoteType a = RemoteType { -- human visible type name typename :: String, -- generates remotes of this type - generator :: a (RemoteGenerator a), + generator :: a [Remote a], -- initializes or changes a remote setup :: String -> M.Map String String -> a (M.Map String String) } diff --git a/doc/walkthrough/using_Amazon_S3.mdwn b/doc/walkthrough/using_Amazon_S3.mdwn index 34c843b18..5f2766868 100644 --- a/doc/walkthrough/using_Amazon_S3.mdwn +++ b/doc/walkthrough/using_Amazon_S3.mdwn @@ -13,7 +13,7 @@ First, export your S3 credentials: Next, create the S3 remote. # git annex initremote mys3 type=S3 encryption=none - initremote (creating bucket mys3-291d2fdc-5990-11e0-909a-002170d25c55...) ok + initremote mys3 (checking bucket) (creating bucket) ok The configuration for the S3 remote is stored in git. So to make a different repository use the same S3 remote is easy: @@ -21,7 +21,7 @@ repository use the same S3 remote is easy: # cd /media/usb/annex # git pull laptop master # git annex initremote mys3 - initremote ok + initremote mys3 (checking bucket) ok Now the remote can be used like any other remote. |