From 72f94cc42eca1a6aaa7cc95daf423915761805ff Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 29 Mar 2011 17:20:22 -0400 Subject: progress --- Remote/S3.hs | 114 +++++++++++++++++++++++++++++------------------------------ 1 file changed, 57 insertions(+), 57 deletions(-) (limited to 'Remote/S3.hs') 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 -- cgit v1.2.3