diff options
| -rw-r--r-- | Remote.hs | 4 | ||||
| -rw-r--r-- | Remote/Git.hs | 11 | ||||
| -rw-r--r-- | Remote/S3.hs | 114 | ||||
| -rw-r--r-- | doc/walkthrough/using_Amazon_S3.mdwn | 2 |
4 files changed, 66 insertions, 65 deletions
@@ -53,7 +53,7 @@ remoteTypes = ] {- Builds a list of all available Remotes. - - Since doing so can be expensive, the list is cached in the Annex. -} + - Since doing so can be expensive, the list is cached. -} genList :: Annex [Remote Annex] genList = do rs <- Annex.getState Annex.remotes @@ -130,7 +130,7 @@ remoteLog = do getConfigs :: [Remote Annex] -> Annex [Remote Annex] getConfigs rs = do m <- readRemoteLog - return $ map (get m) rs + return $ map (get m) rs where get m r = r { config = M.lookup (uuid r) m } diff --git a/Remote/Git.hs b/Remote/Git.hs index 85bd04a23..e5f2aa62d 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -14,7 +14,7 @@ import Control.Exception.Extensible import Control.Monad.State (liftIO) import qualified Data.Map as M import System.Cmd.Utils -import Control.Monad (filterM, liftM) +import Control.Monad (filterM, liftM, when) import Data.String.Utils import Maybe @@ -50,18 +50,19 @@ gen = do - cached UUID value. -} let cheap = filter (not . Git.repoIsUrl) allremotes let expensive = filter Git.repoIsUrl allremotes - expensive_todo <- filterM cachedUUID expensive + expensive_todo <- filterM noCachedUUID expensive let skip = filter (`notElem` expensive_todo) expensive let todo = cheap++expensive_todo - showNote $ "getting UUID for " ++ (join ", " $ - map Git.repoDescribe expensive_todo) + when (not $ null 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 + noCachedUUID r = liftM null $ getUUID r genRemote :: Git.Repo -> Annex (Maybe (Remote Annex)) genRemote r = do 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 diff --git a/doc/walkthrough/using_Amazon_S3.mdwn b/doc/walkthrough/using_Amazon_S3.mdwn index 5f2766868..e0d229662 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 mys3 (checking bucket) (creating bucket) ok + initremote mys3 (checking bucket) (creating bucket in US) ok The configuration for the S3 remote is stored in git. So to make a different repository use the same S3 remote is easy: |