summaryrefslogtreecommitdiff
path: root/Remote/Helper
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2014-08-03 15:35:23 -0400
committerGravatar Joey Hess <joey@kitenet.net>2014-08-03 15:40:01 -0400
commitb87dfe5ddfb3686ab0088c09e6e70bd7275a1f16 (patch)
tree67218881a26ab597dada971414376201610bb1a8 /Remote/Helper
parent38880b605f2bb22a9e1547e3407676b4bd89935c (diff)
roll ChunkedEncryptable into Special and improve interface
Allow disabling progress displays, for eg, rsync.
Diffstat (limited to 'Remote/Helper')
-rw-r--r--Remote/Helper/Chunked.hs6
-rw-r--r--Remote/Helper/ChunkedEncryptable.hs212
-rw-r--r--Remote/Helper/Special.hs223
3 files changed, 221 insertions, 220 deletions
diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs
index a7c43801a..2e9467b2a 100644
--- a/Remote/Helper/Chunked.hs
+++ b/Remote/Helper/Chunked.hs
@@ -8,7 +8,7 @@
module Remote.Helper.Chunked (
ChunkSize,
ChunkConfig(..),
- chunkConfig,
+ getChunkConfig,
storeChunks,
removeChunks,
retrieveChunks,
@@ -39,8 +39,8 @@ noChunks :: ChunkConfig -> Bool
noChunks NoChunks = True
noChunks _ = False
-chunkConfig :: RemoteConfig -> ChunkConfig
-chunkConfig m =
+getChunkConfig :: RemoteConfig -> ChunkConfig
+getChunkConfig m =
case M.lookup "chunksize" m of
Nothing -> case M.lookup "chunk" m of
Nothing -> NoChunks
diff --git a/Remote/Helper/ChunkedEncryptable.hs b/Remote/Helper/ChunkedEncryptable.hs
deleted file mode 100644
index 9c6ba98a2..000000000
--- a/Remote/Helper/ChunkedEncryptable.hs
+++ /dev/null
@@ -1,212 +0,0 @@
-{- Remotes that support both chunking and encryption.
- -
- - Copyright 2014 Joey Hess <joey@kitenet.net>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-{-# LANGUAGE RankNTypes #-}
-
-module Remote.Helper.ChunkedEncryptable (
- Preparer,
- Storer,
- Retriever,
- simplyPrepare,
- ContentSource,
- checkPrepare,
- resourcePrepare,
- fileStorer,
- byteStorer,
- fileRetriever,
- byteRetriever,
- storeKeyDummy,
- retreiveKeyFileDummy,
- chunkedEncryptableRemote,
- encryptableRemote,
- module X
-) where
-
-import Common.Annex
-import Types.StoreRetrieve
-import Types.Remote
-import Crypto
-import Config.Cost
-import Utility.Metered
-import Remote.Helper.Chunked as X
-import Remote.Helper.Encryptable as X hiding (encryptableRemote)
-import Annex.Content
-import Annex.Exception
-
-import qualified Data.ByteString.Lazy as L
-import Control.Exception (bracket)
-
--- Use when nothing needs to be done to prepare a helper.
-simplyPrepare :: helper -> Preparer helper
-simplyPrepare helper _ a = a $ Just helper
-
--- Use to run a check when preparing a helper.
-checkPrepare :: (Key -> Annex Bool) -> helper -> Preparer helper
-checkPrepare checker helper k a = ifM (checker k)
- ( a (Just helper)
- , a Nothing
- )
-
--- Use to acquire a resource when preparing a helper.
-resourcePrepare :: (Key -> (r -> Annex Bool) -> Annex Bool) -> (r -> helper) -> Preparer helper
-resourcePrepare withr helper k a = withr k $ \r ->
- a (Just (helper r))
-
--- A Storer that expects to be provided with a file containing
--- the content of the key to store.
-fileStorer :: (Key -> FilePath -> MeterUpdate -> Annex Bool) -> Storer
-fileStorer a k (FileContent f) m = a k f m
-fileStorer a k (ByteContent b) m = withTmp k $ \f -> do
- liftIO $ L.writeFile f b
- a k f m
-
--- A Storer that expects to be provided with a L.ByteString of
--- the content to store.
-byteStorer :: (Key -> L.ByteString -> MeterUpdate -> Annex Bool) -> Storer
-byteStorer a k c m = withBytes c $ \b -> a k b m
-
--- A Retriever that writes the content of a Key to a provided file.
--- It is responsible for updating the progress meter as it retrieves data.
-fileRetriever :: (FilePath -> Key -> MeterUpdate -> Annex ()) -> Retriever
-fileRetriever a k m callback = do
- f <- prepTmp k
- a f k m
- callback (FileContent f)
-
--- A Retriever that generates a lazy ByteString containing the Key's
--- content, and passes it to a callback action which will fully consume it
--- before returning.
-byteRetriever :: (Key -> (L.ByteString -> Annex Bool) -> Annex Bool) -> Retriever
-byteRetriever a k _m callback = a k (callback . ByteContent)
-
-{- The base Remote that is provided to chunkedEncryptableRemote
- - needs to have storeKey and retreiveKeyFile methods, but they are
- - never actually used (since chunkedEncryptableRemote replaces
- - them). Here are some dummy ones.
- -}
-storeKeyDummy :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool
-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 :: 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
- , retrieveKeyFile = \k _f d p -> cip >>= retrieveKeyFileGen k d p
- , retrieveKeyFileCheap = \k d -> cip >>= maybe
- (retrieveKeyFileCheap baser k d)
- (\_ -> return False)
- , removeKey = \k -> cip >>= removeKeyGen k
- , hasKey = \k -> cip >>= hasKeyGen k
- , cost = maybe
- (cost baser)
- (const $ cost baser + encryptedRemoteCostAdj)
- (extractCipher c)
- }
- cip = cipherKey c
- gpgopts = getGpgEncParams encr
-
- safely a = catchNonAsyncAnnex a (\e -> warning (show e) >> return False)
-
- -- chunk, then encrypt, then feed to the storer
- storeKeyGen k p enc =
- safely $ preparestorer k $ safely . go
- where
- go (Just storer) = sendAnnex k rollback $ \src ->
- metered (Just p) k $ \p' ->
- storeChunks (uuid baser) chunkconfig k src p'
- (storechunk enc storer)
- (hasKey baser)
- go Nothing = return False
- rollback = void $ removeKey encr k
-
- storechunk Nothing storer k content p = storer k content p
- storechunk (Just (cipher, enck)) storer k content p =
- withBytes content $ \b ->
- encrypt gpgopts cipher (feedBytes b) $
- readBytes $ \encb ->
- storer (enck k) (ByteContent encb) p
-
- -- call retriever to get chunks; decrypt them; stream to dest file
- retrieveKeyFileGen k dest p enc =
- safely $ prepareretriever k $ safely . go
- where
- go (Just retriever) = metered (Just p) k $ \p' ->
- retrieveChunks retriever (uuid baser) chunkconfig
- enck k dest p' (sink dest enc)
- go Nothing = return False
- enck = maybe id snd enc
-
- removeKeyGen k enc = removeChunks remover (uuid baser) chunkconfig enck k
- where
- enck = maybe id snd enc
- remover = removeKey baser
-
- hasKeyGen k enc = hasKeyChunks checker (uuid baser) chunkconfig enck k
- where
- enck = maybe id snd enc
- checker = hasKey baser
-
-{- Sink callback for retrieveChunks. Stores the file content into the
- - provided Handle, decrypting it first if necessary.
- -
- - If the remote did not store the content using chunks, no Handle
- - will be provided, and it's up to us to open the destination file.
- -
- - Note that when neither chunking nor encryption is used, and the remote
- - provides FileContent, that file only needs to be renamed
- - into place. (And it may even already be in the right place..)
- -}
-sink
- :: FilePath
- -> Maybe (Cipher, EncKey)
- -> Maybe Handle
- -> Maybe MeterUpdate
- -> ContentSource
- -> Annex Bool
-sink dest enc mh mp content = do
- case (enc, mh, content) of
- (Nothing, Nothing, FileContent f)
- | f == dest -> noop
- | otherwise -> liftIO $ moveFile f dest
- (Just (cipher, _), _, ByteContent b) ->
- decrypt cipher (feedBytes b) $
- readBytes write
- (Just (cipher, _), _, FileContent f) -> do
- withBytes content $ \b ->
- decrypt cipher (feedBytes b) $
- readBytes write
- liftIO $ nukeFile f
- (Nothing, _, FileContent f) -> do
- withBytes content write
- liftIO $ nukeFile f
- (Nothing, _, ByteContent b) -> write b
- return True
- where
- write b = case mh of
- Just h -> liftIO $ b `streamto` h
- Nothing -> liftIO $ bracket opendest hClose (b `streamto`)
- streamto b h = case mp of
- Just p -> meteredWrite p h b
- Nothing -> L.hPut h b
- opendest = openBinaryFile dest WriteMode
-
-withBytes :: ContentSource -> (L.ByteString -> Annex a) -> Annex a
-withBytes (ByteContent b) a = a b
-withBytes (FileContent f) a = a =<< liftIO (L.readFile f)
diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs
index 7fc421f46..2bcb7d530 100644
--- a/Remote/Helper/Special.hs
+++ b/Remote/Helper/Special.hs
@@ -1,20 +1,51 @@
-{- common functions for special remotes
+{- helpers for special remotes
-
- - Copyright 2011 Joey Hess <joey@kitenet.net>
+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
-module Remote.Helper.Special where
-
-import qualified Data.Map as M
+module Remote.Helper.Special (
+ findSpecialRemotes,
+ gitConfigSpecialRemote,
+ Preparer,
+ Storer,
+ Retriever,
+ simplyPrepare,
+ ContentSource,
+ checkPrepare,
+ resourcePrepare,
+ fileStorer,
+ byteStorer,
+ fileRetriever,
+ byteRetriever,
+ storeKeyDummy,
+ retreiveKeyFileDummy,
+ SpecialRemoteCfg(..),
+ specialRemoteCfg,
+ specialRemote,
+ specialRemote',
+ module X
+) where
import Common.Annex
+import Types.StoreRetrieve
import Types.Remote
+import Crypto
+import Config.Cost
+import Utility.Metered
+import Remote.Helper.Chunked as X
+import Remote.Helper.Encryptable as X hiding (encryptableRemote)
+import Annex.Content
+import Annex.Exception
import qualified Git
import qualified Git.Command
import qualified Git.Construct
+import qualified Data.ByteString.Lazy as L
+import Control.Exception (bracket)
+import qualified Data.Map as M
+
{- Special remotes don't have a configured url, so Git.Repo does not
- automatically generate remotes for them. This looks for a different
- configuration key instead.
@@ -38,3 +69,185 @@ gitConfigSpecialRemote u c k v = do
[Param "config", Param (configsetting a), Param b]
remotename = fromJust (M.lookup "name" c)
configsetting s = "remote." ++ remotename ++ "." ++ s
+
+-- Use when nothing needs to be done to prepare a helper.
+simplyPrepare :: helper -> Preparer helper
+simplyPrepare helper _ a = a $ Just helper
+
+-- Use to run a check when preparing a helper.
+checkPrepare :: (Key -> Annex Bool) -> helper -> Preparer helper
+checkPrepare checker helper k a = ifM (checker k)
+ ( a (Just helper)
+ , a Nothing
+ )
+
+-- Use to acquire a resource when preparing a helper.
+resourcePrepare :: (Key -> (r -> Annex Bool) -> Annex Bool) -> (r -> helper) -> Preparer helper
+resourcePrepare withr helper k a = withr k $ \r ->
+ a (Just (helper r))
+
+-- A Storer that expects to be provided with a file containing
+-- the content of the key to store.
+fileStorer :: (Key -> FilePath -> MeterUpdate -> Annex Bool) -> Storer
+fileStorer a k (FileContent f) m = a k f m
+fileStorer a k (ByteContent b) m = withTmp k $ \f -> do
+ liftIO $ L.writeFile f b
+ a k f m
+
+-- A Storer that expects to be provided with a L.ByteString of
+-- the content to store.
+byteStorer :: (Key -> L.ByteString -> MeterUpdate -> Annex Bool) -> Storer
+byteStorer a k c m = withBytes c $ \b -> a k b m
+
+-- A Retriever that writes the content of a Key to a provided file.
+-- It is responsible for updating the progress meter as it retrieves data.
+fileRetriever :: (FilePath -> Key -> MeterUpdate -> Annex ()) -> Retriever
+fileRetriever a k m callback = do
+ f <- prepTmp k
+ a f k m
+ callback (FileContent f)
+
+-- A Retriever that generates a lazy ByteString containing the Key's
+-- content, and passes it to a callback action which will fully consume it
+-- before returning.
+byteRetriever :: (Key -> (L.ByteString -> Annex Bool) -> Annex Bool) -> Retriever
+byteRetriever a k _m callback = a k (callback . ByteContent)
+
+{- The base Remote that is provided to specialRemote needs to have
+ - storeKey and retreiveKeyFile methods, but they are never
+ - actually used (since specialRemote replaces them).
+ - Here are some dummy ones.
+ -}
+storeKeyDummy :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool
+storeKeyDummy _ _ _ = return False
+retreiveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
+retreiveKeyFileDummy _ _ _ _ = return False
+
+type RemoteModifier = RemoteConfig -> Preparer Storer -> Preparer Retriever -> Remote -> Remote
+
+data SpecialRemoteCfg = SpecialRemoteCfg
+ { chunkConfig :: ChunkConfig
+ , displayProgress :: Bool
+ }
+
+specialRemoteCfg :: RemoteConfig -> SpecialRemoteCfg
+specialRemoteCfg c = SpecialRemoteCfg (getChunkConfig c) True
+
+-- Modifies a base Remote to support both chunking and encryption,
+-- which special remotes typically should support.
+specialRemote :: RemoteModifier
+specialRemote c = specialRemote' (specialRemoteCfg c) c
+
+specialRemote' :: SpecialRemoteCfg -> RemoteModifier
+specialRemote' cfg c preparestorer prepareretriever baser = encr
+ where
+ encr = baser
+ { storeKey = \k _f p -> cip >>= storeKeyGen k p
+ , retrieveKeyFile = \k _f d p -> cip >>= retrieveKeyFileGen k d p
+ , retrieveKeyFileCheap = \k d -> cip >>= maybe
+ (retrieveKeyFileCheap baser k d)
+ (\_ -> return False)
+ , removeKey = \k -> cip >>= removeKeyGen k
+ , hasKey = \k -> cip >>= hasKeyGen k
+ , cost = maybe
+ (cost baser)
+ (const $ cost baser + encryptedRemoteCostAdj)
+ (extractCipher c)
+ }
+ cip = cipherKey c
+ gpgopts = getGpgEncParams encr
+
+ safely a = catchNonAsyncAnnex a (\e -> warning (show e) >> return False)
+
+ -- chunk, then encrypt, then feed to the storer
+ storeKeyGen k p enc =
+ safely $ preparestorer k $ safely . go
+ where
+ go (Just storer) = sendAnnex k rollback $ \src ->
+ displayprogress p k $ \p' ->
+ storeChunks (uuid baser) chunkconfig k src p'
+ (storechunk enc storer)
+ (hasKey baser)
+ go Nothing = return False
+ rollback = void $ removeKey encr k
+
+ storechunk Nothing storer k content p = storer k content p
+ storechunk (Just (cipher, enck)) storer k content p =
+ withBytes content $ \b ->
+ encrypt gpgopts cipher (feedBytes b) $
+ readBytes $ \encb ->
+ storer (enck k) (ByteContent encb) p
+
+ -- call retriever to get chunks; decrypt them; stream to dest file
+ retrieveKeyFileGen k dest p enc =
+ safely $ prepareretriever k $ safely . go
+ where
+ go (Just retriever) = displayprogress p k $ \p' ->
+ retrieveChunks retriever (uuid baser) chunkconfig
+ enck k dest p' (sink dest enc)
+ go Nothing = return False
+ enck = maybe id snd enc
+
+ removeKeyGen k enc = removeChunks remover (uuid baser) chunkconfig enck k
+ where
+ enck = maybe id snd enc
+ remover = removeKey baser
+
+ hasKeyGen k enc = hasKeyChunks checker (uuid baser) chunkconfig enck k
+ where
+ enck = maybe id snd enc
+ checker = hasKey baser
+
+ chunkconfig = chunkConfig cfg
+
+ displayprogress p k a
+ | displayProgress cfg = metered (Just p) k a
+ | otherwise = a p
+
+{- Sink callback for retrieveChunks. Stores the file content into the
+ - provided Handle, decrypting it first if necessary.
+ -
+ - If the remote did not store the content using chunks, no Handle
+ - will be provided, and it's up to us to open the destination file.
+ -
+ - Note that when neither chunking nor encryption is used, and the remote
+ - provides FileContent, that file only needs to be renamed
+ - into place. (And it may even already be in the right place..)
+ -}
+sink
+ :: FilePath
+ -> Maybe (Cipher, EncKey)
+ -> Maybe Handle
+ -> Maybe MeterUpdate
+ -> ContentSource
+ -> Annex Bool
+sink dest enc mh mp content = do
+ case (enc, mh, content) of
+ (Nothing, Nothing, FileContent f)
+ | f == dest -> noop
+ | otherwise -> liftIO $ moveFile f dest
+ (Just (cipher, _), _, ByteContent b) ->
+ decrypt cipher (feedBytes b) $
+ readBytes write
+ (Just (cipher, _), _, FileContent f) -> do
+ withBytes content $ \b ->
+ decrypt cipher (feedBytes b) $
+ readBytes write
+ liftIO $ nukeFile f
+ (Nothing, _, FileContent f) -> do
+ withBytes content write
+ liftIO $ nukeFile f
+ (Nothing, _, ByteContent b) -> write b
+ return True
+ where
+ write b = case mh of
+ Just h -> liftIO $ b `streamto` h
+ Nothing -> liftIO $ bracket opendest hClose (b `streamto`)
+ streamto b h = case mp of
+ Just p -> meteredWrite p h b
+ Nothing -> L.hPut h b
+ opendest = openBinaryFile dest WriteMode
+
+withBytes :: ContentSource -> (L.ByteString -> Annex a) -> Annex a
+withBytes (ByteContent b) a = a b
+withBytes (FileContent f) a = a =<< liftIO (L.readFile f)