diff options
author | Joey Hess <joey@kitenet.net> | 2014-08-02 16:47:21 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2014-08-02 16:59:07 -0400 |
commit | d162d2f7735dceda7645e1e3ec347cbd8625b748 (patch) | |
tree | 90d991e84e83955233131285ca74a96698127ebd | |
parent | 81b339034e8871f211ede2cf3bdb7319ad16caed (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.
-rw-r--r-- | Remote/Glacier.hs | 82 | ||||
-rw-r--r-- | Remote/Helper/ChunkedEncryptable.hs | 22 |
2 files changed, 50 insertions, 54 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) diff --git a/Remote/Helper/ChunkedEncryptable.hs b/Remote/Helper/ChunkedEncryptable.hs index 1267f5b59..e60771551 100644 --- a/Remote/Helper/ChunkedEncryptable.hs +++ b/Remote/Helper/ChunkedEncryptable.hs @@ -22,6 +22,7 @@ module Remote.Helper.ChunkedEncryptable ( storeKeyDummy, retreiveKeyFileDummy, chunkedEncryptableRemote, + encryptableRemote, module X ) where @@ -32,7 +33,7 @@ import Crypto import Config.Cost import Utility.Metered import Remote.Helper.Chunked as X -import Remote.Helper.Encryptable as X +import Remote.Helper.Encryptable as X hiding (encryptableRemote) import Annex.Content import Annex.Exception @@ -90,14 +91,18 @@ storeKeyDummy _ _ _ = return False retreiveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool retreiveKeyFileDummy _ _ _ _ = return False +type RemoteModifier = RemoteConfig -> Preparer Storer -> Preparer Retriever -> Remote -> Remote + -- Modifies a base Remote to support both chunking and encryption. -chunkedEncryptableRemote - :: RemoteConfig - -> Preparer Storer - -> Preparer Retriever - -> Remote - -> Remote -chunkedEncryptableRemote c preparestorer prepareretriever baser = encr +chunkedEncryptableRemote :: RemoteModifier +chunkedEncryptableRemote c = chunkedEncryptableRemote' (chunkConfig c) c + +-- Modifies a base Remote to support encryption, but not chunking. +encryptableRemote :: RemoteModifier +encryptableRemote = chunkedEncryptableRemote' NoChunks + +chunkedEncryptableRemote' :: ChunkConfig -> RemoteModifier +chunkedEncryptableRemote' chunkconfig c preparestorer prepareretriever baser = encr where encr = baser { storeKey = \k _f p -> cip >>= storeKeyGen k p @@ -113,7 +118,6 @@ chunkedEncryptableRemote c preparestorer prepareretriever baser = encr (extractCipher c) } cip = cipherKey c - chunkconfig = chunkConfig c gpgopts = getGpgEncParams encr safely a = catchNonAsyncAnnex a (\e -> warning (show e) >> return False) |