summaryrefslogtreecommitdiff
path: root/Remote/Glacier.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2014-08-02 16:47:21 -0400
committerGravatar Joey Hess <joey@kitenet.net>2014-08-02 16:59:07 -0400
commitd162d2f7735dceda7645e1e3ec347cbd8625b748 (patch)
tree90d991e84e83955233131285ca74a96698127ebd /Remote/Glacier.hs
parent81b339034e8871f211ede2cf3bdb7319ad16caed (diff)
convert glacier to new ChunkedEncryptable API (but do not support chunking)
Chunking would complicate the assistant's code that checks when a pending retrieval of a key from glacier is done. It would perhaps be nice to support it to allow resuming, but not right now. Converting to the new API still simplifies the code.
Diffstat (limited to 'Remote/Glacier.hs')
-rw-r--r--Remote/Glacier.hs82
1 files changed, 37 insertions, 45 deletions
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index bf8f05061..9b428bd80 100644
--- a/Remote/Glacier.hs
+++ b/Remote/Glacier.hs
@@ -9,6 +9,7 @@ module Remote.Glacier (remote, jobList) where
import qualified Data.Map as M
import qualified Data.Text as T
+import qualified Data.ByteString.Lazy as L
import Common.Annex
import Types.Remote
@@ -17,13 +18,12 @@ import qualified Git
import Config
import Config.Cost
import Remote.Helper.Special
-import Remote.Helper.Encryptable
+import Remote.Helper.ChunkedEncryptable
import qualified Remote.Helper.AWS as AWS
import Crypto
import Creds
import Utility.Metered
import qualified Annex
-import Annex.Content
import Annex.UUID
import Utility.Env
@@ -42,16 +42,16 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remot
gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
where
new cst = Just $ encryptableRemote c
- (storeEncrypted this)
- (retrieveEncrypted this)
+ (prepareStore this)
+ (prepareRetrieve this)
this
where
this = Remote {
uuid = u,
cost = cst,
name = Git.repoDescribe r,
- storeKey = store this,
- retrieveKeyFile = retrieve this,
+ storeKey = storeKeyDummy,
+ retrieveKeyFile = retreiveKeyFileDummy,
retrieveKeyFileCheap = retrieveCheap this,
removeKey = remove this,
hasKey = checkPresent this,
@@ -89,38 +89,18 @@ glacierSetup' enabling u c = do
, ("vault", defvault)
]
-store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
-store r k _f p
+prepareStore :: Remote -> Preparer Storer
+prepareStore r = checkPrepare nonEmpty (byteStorer $ store r)
+
+nonEmpty :: Key -> Annex Bool
+nonEmpty k
| keySize k == Just 0 = do
warning "Cannot store empty files in Glacier."
return False
- | otherwise = sendAnnex k (void $ remove r k) $ \src ->
- metered (Just p) k $ \meterupdate ->
- storeHelper r k $ streamMeteredFile src meterupdate
-
-storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
-storeEncrypted r (cipher, enck) k p = sendAnnex k (void $ remove r enck) $ \src ->
- metered (Just p) k $ \meterupdate ->
- storeHelper r enck $ \h ->
- encrypt (getGpgEncParams r) cipher (feedFile src)
- (readBytes $ meteredWrite meterupdate h)
-
-retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
-retrieve r k _f d p = metered (Just p) k $ \meterupdate ->
- retrieveHelper r k $
- readBytes $ meteredWriteFile meterupdate d
-
-retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
-retrieveCheap _ _ _ = return False
-
-retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
-retrieveEncrypted r (cipher, enck) k d p = metered (Just p) k $ \meterupdate ->
- retrieveHelper r enck $ readBytes $ \b ->
- decrypt cipher (feedBytes b) $
- readBytes $ meteredWriteFile meterupdate d
+ | otherwise = return True
-storeHelper :: Remote -> Key -> (Handle -> IO ()) -> Annex Bool
-storeHelper r k feeder = go =<< glacierEnv c u
+store :: Remote -> Key -> L.ByteString -> MeterUpdate -> Annex Bool
+store r k b p = go =<< glacierEnv c u
where
c = config r
u = uuid r
@@ -133,14 +113,18 @@ storeHelper r k feeder = go =<< glacierEnv c u
]
go Nothing = return False
go (Just e) = do
- let p = (proc "glacier" (toCommand params)) { env = Just e }
+ let cmd = (proc "glacier" (toCommand params)) { env = Just e }
liftIO $ catchBoolIO $
- withHandle StdinHandle createProcessSuccess p $ \h -> do
- feeder h
+ withHandle StdinHandle createProcessSuccess cmd $ \h -> do
+ meteredWrite p h b
return True
-retrieveHelper :: Remote -> Key -> (Handle -> IO ()) -> Annex Bool
-retrieveHelper r k reader = go =<< glacierEnv c u
+prepareRetrieve :: Remote -> Preparer Retriever
+prepareRetrieve r = simplyPrepare $ fileRetriever $ \d k p ->
+ retrieve r k (readBytes (meteredWriteFile p d))
+
+retrieve :: Remote -> Key -> (Handle -> IO ()) -> Annex ()
+retrieve r k reader = go =<< glacierEnv c u
where
c = config r
u = uuid r
@@ -151,29 +135,33 @@ retrieveHelper r k reader = go =<< glacierEnv c u
, Param $ getVault $ config r
, Param $ archive r k
]
- go Nothing = return False
+ go Nothing = error "cannot retrieve from glacier"
go (Just e) = do
- let p = (proc "glacier" (toCommand params)) { env = Just e }
+ let cmd = (proc "glacier" (toCommand params)) { env = Just e }
ok <- liftIO $ catchBoolIO $
- withHandle StdoutHandle createProcessSuccess p $ \h ->
+ withHandle StdoutHandle createProcessSuccess cmd $ \h ->
ifM (hIsEOF h)
( return False
, do
reader h
return True
)
- unless ok later
- return ok
- later = showLongNote "Recommend you wait up to 4 hours, and then run this command again."
+ unless ok $ do
+ showLongNote "Recommend you wait up to 4 hours, and then run this command again."
+ error "not yet available"
remove :: Remote -> Key -> Annex Bool
remove r k = glacierAction r
[ Param "archive"
+
, Param "delete"
, Param $ getVault $ config r
, Param $ archive r k
]
+retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
+retrieveCheap _ _ _ = return False
+
checkPresent :: Remote -> Key -> Annex (Either String Bool)
checkPresent r k = do
showAction $ "checking " ++ name r
@@ -261,6 +249,10 @@ genVault c u = unlessM (runGlacier c u params) $
-
- A complication is that `glacier job list` will display the encrypted
- keys when the remote is encrypted.
+ -
+ - Dealing with encrypted chunked keys would be tricky. However, there
+ - seems to be no benefit to using chunking with glacier, so chunking is
+ - not supported.
-}
jobList :: Remote -> [Key] -> Annex ([Key], [Key])
jobList r keys = go =<< glacierEnv (config r) (uuid r)