summaryrefslogtreecommitdiff
path: root/Remote/Glacier.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-11-25 13:27:20 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-11-25 13:27:20 -0400
commite3a9347879c65e550c3b1c2b0824a04b3a8ea58f (patch)
tree85c07f0ac88f4dc5977e469e3da79d81ba585bb6 /Remote/Glacier.hs
parent51edf7c2c16b124ec8f49c31454da5813c825506 (diff)
progress bars for glacier uploads
Diffstat (limited to 'Remote/Glacier.hs')
-rw-r--r--Remote/Glacier.hs69
1 files changed, 40 insertions, 29 deletions
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index 8a54b542e..4cdbff99a 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -21,9 +21,12 @@ import Remote.Helper.Encryptable
import qualified Remote.Helper.AWS as AWS
import Crypto
import Creds
+import Meters
import Annex.Content
import qualified Annex
+import System.Process
+
type Vault = String
type Archive = FilePath
@@ -80,35 +83,43 @@ glacierSetup u c = do
]
store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
-store r k _f _p
+store r k _f m
| keySize k == Just 0 = do
warning "Cannot store empty files in Glacier."
return False
| otherwise = do
- src <- inRepo $ gitAnnexLocation k
- storeHelper r k src
+ src <- inRepo $ gitAnnexLocation k
+ metered (Just m) k $ \meterupdate ->
+ storeHelper r k $ streamMeteredFile src meterupdate
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
+storeEncrypted r (cipher, enck) k m = do
+ f <- inRepo $ gitAnnexLocation k
+ metered (Just m) k $ \meterupdate ->
+ storeHelper r enck $ \h ->
+ encrypt cipher (feedFile f)
+ (readBytes $ meteredWrite meterupdate h)
+
+storeHelper :: Remote -> Key -> (Handle -> IO ()) -> Annex Bool
+storeHelper r k feeder = go =<< glacierEnv c u
+ where
+ c = fromJust $ config r
+ u = uuid r
+ params = glacierParams c
[ Param "archive"
, Param "upload"
, Param "--name", Param $ archive r k
, Param $ remoteVault r
- , File file
+ , Param "-"
]
+ go Nothing = return False
+ go (Just e) = do
+ showOutput
+ let p = (proc "glacier" (toCommand params)) { env = Just e }
+ liftIO $ catchBoolIO $
+ withHandle StdinHandle createProcessSuccess p $ \h -> do
+ feeder h
+ return True
retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
retrieve r k _f d = retrieveHelper r k d
@@ -155,11 +166,11 @@ checkPresent r k = do
go =<< glacierEnv (fromJust $ config r) (uuid r)
where
go Nothing = return $ Left "cannot check glacier"
- go (Just env) = do
+ go (Just e) = do
{- glacier checkpresent outputs the archive name to stdout if
- it's present. -}
v <- liftIO $ catchMsgIO $
- readProcessEnv "glacier" (toCommand params) (Just env)
+ readProcessEnv "glacier" (toCommand params) (Just e)
case v of
Right s -> do
let probablypresent = key2file k `elem` lines s
@@ -167,7 +178,7 @@ checkPresent r k = do
then ifM (Annex.getFlag "trustglacier")
( return $ Right True, untrusted )
else return $ Right False
- Left e -> return $ Left e
+ Left err -> return $ Left err
params =
[ Param "archive"
@@ -187,18 +198,18 @@ checkPresent r k = do
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
+glacierAction r params = 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)
+ go (Just e) = liftIO $
+ boolSystemEnv "glacier" (glacierParams c params) (Just e)
+glacierParams :: RemoteConfig -> [CommandParam] -> [CommandParam]
+glacierParams c params = datacenter:params
+ where
datacenter = Param $ "--region=" ++
(fromJust $ M.lookup "datacenter" c)
@@ -207,8 +218,8 @@ 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
+ e <- liftIO getEnvironment
+ return $ Just $ (uk, user):(pk, pass):e
creds = AWS.creds u
(uk, pk) = credPairEnvironment creds