From 0d378285e709833f87547fd6fedc4e8b2f4884c4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 20 Nov 2012 16:43:58 -0400 Subject: Amazon Glacier special remote; 100% working --- Remote/Glacier.hs | 235 +++++++++++++++++++++++++++++++++++++++++++++++++++ Remote/Helper/AWS.hs | 21 +++++ Remote/List.hs | 2 + Remote/S3.hs | 24 ++---- Remote/WebDAV.hs | 8 +- 5 files changed, 264 insertions(+), 26 deletions(-) create mode 100644 Remote/Glacier.hs create mode 100644 Remote/Helper/AWS.hs (limited to 'Remote') diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs new file mode 100644 index 000000000..fb5ff8e6a --- /dev/null +++ b/Remote/Glacier.hs @@ -0,0 +1,235 @@ +{- Amazon Glacier remotes. + - + - Copyright 2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Remote.Glacier (remote) where + +import qualified Data.ByteString.Lazy.Char8 as L +import qualified Data.Map as M +import System.Environment + +import Common.Annex +import Types.Remote +import Types.Key +import qualified Git +import Config +import Remote.Helper.Special +import Remote.Helper.Encryptable +import qualified Remote.Helper.AWS as AWS +import Crypto +import Creds +import Annex.Content +import qualified Annex + +type Vault = String +type Archive = FilePath + +remote :: RemoteType +remote = RemoteType { + typename = "glacier", + enumerate = findSpecialRemotes "glacier", + generate = gen, + setup = glacierSetup +} + +gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote +gen r u c = do + cst <- remoteCost r expensiveRemoteCost + return $ gen' r u c cst +gen' :: Git.Repo -> UUID -> Maybe RemoteConfig -> Int -> Remote +gen' r u c cst = + encryptableRemote c + (storeEncrypted this) + (retrieveEncrypted this) + this + where + this = Remote { + uuid = u, + cost = cst, + name = Git.repoDescribe r, + storeKey = store this, + retrieveKeyFile = retrieve this, + retrieveKeyFileCheap = retrieveCheap this, + removeKey = remove this, + hasKey = checkPresent this, + hasKeyCheap = False, + whereisKey = Nothing, + config = c, + repo = r, + localpath = Nothing, + readonly = False, + remotetype = remote + } + +glacierSetup :: UUID -> RemoteConfig -> Annex RemoteConfig +glacierSetup u c = do + c' <- encryptionSetup c + let fullconfig = c' `M.union` defaults + genVault fullconfig u + gitConfigSpecialRemote u fullconfig "glacier" "true" + setRemoteCredPair fullconfig (AWS.creds u) + where + remotename = fromJust (M.lookup "name" c) + defvault = remotename ++ "-" ++ fromUUID u + defaults = M.fromList + [ ("datacenter", "us-east-1") + , ("vault", defvault) + ] + +store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool +store r k _f _p + | keySize k == Just 0 = do + warning "Cannot store empty files in Glacier." + return False + | otherwise = do + src <- inRepo $ gitAnnexLocation k + storeHelper r k src + +storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool +storeEncrypted r (cipher, enck) k _p = + -- With current glacier-cli UI, have to encrypt to a temp file. + withTmp enck $ \tmp -> do + f <- inRepo $ gitAnnexLocation k + liftIO $ encrypt cipher (feedFile f) $ + readBytes $ L.writeFile tmp + storeHelper r enck tmp + +{- Glacier cannot store empty files. So empty keys are handled by + - doing nothing on storage, and re-creating the empty file on retrieve. -} +storeHelper :: Remote -> Key -> FilePath -> Annex Bool +storeHelper r k file = do + showOutput + glacierAction r + [ Param "archive" + , Param "upload" + , Param "--name", Param $ archive r k + , Param $ remoteVault r + , File file + ] + +retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool +retrieve r k _f d = retrieveHelper r k d + +retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool +retrieveCheap _ _ _ = return False + +retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> Annex Bool +retrieveEncrypted r (cipher, enck) _k d = do + withTmp enck $ \tmp -> do + ok <- retrieveHelper r enck tmp + if ok + then liftIO $ decrypt cipher (feedFile tmp) $ + readBytes $ \content -> do + L.writeFile d content + return True + else return False + +retrieveHelper :: Remote -> Key -> FilePath -> Annex Bool +retrieveHelper r k file = do + showOutput + ok <- glacierAction r + [ Param "archive" + , Param "retrieve" + , Param "-o", File file + , Param $ remoteVault r + , Param $ archive r k + ] + unless ok $ + showLongNote "Recommend you wait up to 4 hours, and then run this command again." + return ok + +remove :: Remote -> Key -> Annex Bool +remove r k = glacierAction r + [ Param "archive" + , Param "delete" + , Param $ remoteVault r + , Param $ archive r k + ] + +checkPresent :: Remote -> Key -> Annex (Either String Bool) +checkPresent r k = do + showAction $ "checking " ++ name r + go =<< glacierEnv (fromJust $ config r) (uuid r) + where + go Nothing = return $ Left "cannot check glacier" + go (Just env) = do + {- glacier checkpresent outputs the archive name to stdout if + - it's present. -} + v <- liftIO $ catchMsgIO $ + readProcessEnv "glacier" (toCommand params) (Just env) + case v of + Right s -> do + let probablypresent = key2file k `elem` lines s + if probablypresent + then ifM (Annex.getFlag "trustglacier") + ( return $ Right True, untrusted ) + else return $ Right False + Left e -> return $ Left e + + params = + [ Param "archive" + , Param "checkpresent" + , Param $ remoteVault r + , Param $ archive r k + ] + + untrusted = do + showLongNote $ unlines + [ "Glacier's inventory says it has a copy." + , "However, the inventory could be out of date, if it was recently removed." + , "(Use --trust-glacier if you're sure it's still in Glacier.)" + , "" + ] + return $ Right False + +glacierAction :: Remote -> [CommandParam] -> Annex Bool +glacierAction r params = do + when (isNothing $ config r) $ + error $ "Missing configuration for special remote " ++ name r + runGlacier (fromJust $ config r) (uuid r) params + +runGlacier :: RemoteConfig -> UUID -> [CommandParam] -> Annex Bool +runGlacier c u params = go =<< glacierEnv c u + where + go Nothing = return False + go (Just env) = liftIO $ + boolSystemEnv "glacier" (datacenter:params) (Just env) + + datacenter = Param $ "--region=" ++ + (fromJust $ M.lookup "datacenter" c) + +glacierEnv :: RemoteConfig -> UUID -> Annex (Maybe [(String, String)]) +glacierEnv c u = go =<< getRemoteCredPair "glacier" c creds + where + go Nothing = return Nothing + go (Just (user, pass)) = do + env <- liftIO getEnvironment + return $ Just $ (uk, user):(pk, pass):env + + creds = AWS.creds u + (uk, pk) = credPairEnvironment creds + +remoteVault :: Remote -> Vault +remoteVault = vault . fromJust . config + +vault :: RemoteConfig -> Vault +vault = fromJust . M.lookup "vault" + +archive :: Remote -> Key -> Archive +archive r k = fileprefix ++ key2file k + where + fileprefix = M.findWithDefault "" "fileprefix" $ fromJust $ config r + +-- glacier vault create will succeed even if the vault already exists. +genVault :: RemoteConfig -> UUID -> Annex () +genVault c u = unlessM (runGlacier c u params) $ + error "Failed creating glacier vault." + where + params = + [ Param "vault" + , Param "create" + , Param $ vault c + ] diff --git a/Remote/Helper/AWS.hs b/Remote/Helper/AWS.hs new file mode 100644 index 000000000..a988a0b15 --- /dev/null +++ b/Remote/Helper/AWS.hs @@ -0,0 +1,21 @@ +{- Amazon Web Services common infrastructure. + - + - Copyright 2011,2012 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Remote.Helper.AWS where + +import Common.Annex +import Creds + +creds :: UUID -> CredPairStorage +creds u = CredPairStorage + { credPairFile = fromUUID u + , credPairEnvironment = ("AWS_ACCESS_KEY_ID", "AWS_SECRET_ACCESS_KEY") + , credPairRemoteKey = Just "s3creds" + } + +setCredsEnv :: CredPair -> IO () +setCredsEnv p = setEnvCredPair p $ creds undefined diff --git a/Remote/List.hs b/Remote/List.hs index a25533bb1..3179456eb 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -32,6 +32,7 @@ import qualified Remote.Web #ifdef WITH_WEBDAV import qualified Remote.WebDAV #endif +import qualified Remote.Glacier import qualified Remote.Hook remoteTypes :: [RemoteType] @@ -47,6 +48,7 @@ remoteTypes = #ifdef WITH_WEBDAV , Remote.WebDAV.remote #endif + , Remote.Glacier.remote , Remote.Hook.remote ] diff --git a/Remote/S3.hs b/Remote/S3.hs index ca4161c15..400f3e027 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -module Remote.S3 (remote, setCredsEnv) where +module Remote.S3 (remote) where import Network.AWS.AWSConnection import Network.AWS.S3Object @@ -22,6 +22,7 @@ import qualified Git import Config import Remote.Helper.Special import Remote.Helper.Encryptable +import qualified Remote.Helper.AWS as AWS import Crypto import Creds import Meters @@ -84,7 +85,7 @@ s3Setup u c = handlehost $ M.lookup "host" c use fullconfig = do gitConfigSpecialRemote u fullconfig "s3" "true" - setRemoteCredPair fullconfig (s3Creds u) + setRemoteCredPair fullconfig (AWS.creds u) defaulthost = do c' <- encryptionSetup c @@ -261,28 +262,13 @@ s3ConnectionRequired c u = maybe (error "Cannot connect to S3") return =<< s3Connection c u s3Connection :: RemoteConfig -> UUID -> Annex (Maybe AWSConnection) -s3Connection c u = go =<< getRemoteCredPair c creds +s3Connection c u = go =<< getRemoteCredPair "S3" c (AWS.creds u) where - go Nothing = do - warning $ "Set both " ++ s3AccessKey ++ " and " ++ s3SecretKey ++ " to use S3" - return Nothing + go Nothing = return Nothing go (Just (ak, sk)) = return $ Just $ AWSConnection host port ak sk - creds = s3Creds u - (s3AccessKey, s3SecretKey) = credPairEnvironment creds - 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 - -s3Creds :: UUID -> CredPairStorage -s3Creds u = CredPairStorage - { credPairFile = fromUUID u - , credPairEnvironment = ("AWS_ACCESS_KEY_ID", "AWS_SECRET_ACCESS_KEY") - , credPairRemoteKey = Just "s3creds" - } - -setCredsEnv :: (String, String) -> IO () -setCredsEnv creds = setEnvCredPair creds $ s3Creds undefined diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 84f675bbd..b303dbe59 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -321,13 +321,7 @@ noProps :: XML.Document noProps = XML.parseText_ XML.def $ LT.pack "\n" getCreds :: RemoteConfig -> UUID -> Annex (Maybe CredPair) -getCreds c u = maybe missing (return . Just) =<< getRemoteCredPair c creds - where - creds = davCreds u - (loginvar, passwordvar) = credPairEnvironment creds - missing = do - warning $ "Set both " ++ loginvar ++ " and " ++ passwordvar ++ " to use webdav" - return Nothing +getCreds c u = getRemoteCredPair "webdav" c (davCreds u) davCreds :: UUID -> CredPairStorage davCreds u = CredPairStorage -- cgit v1.2.3