roll ChunkedEncryptable into Special and improve interface
Allow disabling progress displays, for eg, rsync.
This commit is contained in:
Joey Hess
parent
e1e5853c94
commit
4b16989e98
13 changed files with 245 additions and 240 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue