roll ChunkedEncryptable into Special and improve interface

Allow disabling progress displays, for eg, rsync.
This commit is contained in:
Joey Hess 2014-08-03 15:35:23 -04:00
parent e1e5853c94
commit 4b16989e98
13 changed files with 245 additions and 240 deletions

View file

@ -76,7 +76,7 @@ perform rs ks = do
where
desc r' k = intercalate "; " $ map unwords
[ [ "key size", show (keySize k) ]
, [ show (chunkConfig (Remote.config r')) ]
, [ show (getChunkConfig (Remote.config r')) ]
, ["encryption", fromMaybe "none" (M.lookup "encryption" (Remote.config r'))]
]

View file

@ -25,7 +25,6 @@ import Config
import Config.Cost
import qualified Remote.Helper.Ssh as Ssh
import Remote.Helper.Special
import Remote.Helper.ChunkedEncryptable
import Remote.Helper.Messages
import Utility.Hash
import Utility.UserInfo
@ -74,12 +73,16 @@ gen r u c gc = do
, availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable
, readonly = False
}
return $ Just $ encryptableRemote c
return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ store this buprepo)
(simplyPrepare $ retrieve buprepo)
this
where
buprepo = fromMaybe (error "missing buprepo") $ remoteAnnexBupRepo gc
specialcfg = (specialRemoteCfg c)
-- chunking would not improve bup
{ chunkConfig = NoChunks
}
bupSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
bupSetup mu _ c = do

View file

@ -22,7 +22,6 @@ import qualified Git
import Config
import Config.Cost
import Remote.Helper.Special
import Remote.Helper.ChunkedEncryptable
import Annex.Ssh
import Annex.UUID
@ -42,7 +41,7 @@ gen r u c gc = do
if ddarLocal ddarrepo
then nearlyCheapRemoteCost
else expensiveRemoteCost
return $ Just $ encryptableRemote c
return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ store ddarrepo)
(simplyPrepare $ retrieve ddarrepo)
(this cst)
@ -71,6 +70,10 @@ gen r u c gc = do
, readonly = False
}
ddarrepo = fromMaybe (error "missing ddarrepo") $ remoteAnnexDdarRepo gc
specialcfg = (specialRemoteCfg c)
-- chunking would not improve ddar
{ chunkConfig = NoChunks
}
ddarSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
ddarSetup mu _ c = do

View file

@ -20,7 +20,6 @@ import Config.Cost
import Config
import Utility.FileMode
import Remote.Helper.Special
import Remote.Helper.ChunkedEncryptable
import qualified Remote.Directory.LegacyChunked as Legacy
import Annex.Content
import Annex.UUID
@ -37,8 +36,8 @@ remote = RemoteType {
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc = do
cst <- remoteCost gc cheapRemoteCost
let chunkconfig = chunkConfig c
return $ Just $ chunkedEncryptableRemote c
let chunkconfig = getChunkConfig c
return $ Just $ specialRemote c
(prepareStore dir chunkconfig)
(retrieve dir chunkconfig)
Remote {

View file

@ -14,7 +14,7 @@ import qualified Data.ByteString as S
import Common.Annex
import Utility.FileMode
import Remote.Helper.ChunkedEncryptable
import Remote.Helper.Special
import qualified Remote.Helper.Chunked.Legacy as Legacy
import Annex.Perms
import Utility.Metered

View file

@ -15,7 +15,6 @@ import Types.CleanupActions
import qualified Git
import Config
import Remote.Helper.Special
import Remote.Helper.ChunkedEncryptable
import Utility.Metered
import Logs.Transfer
import Logs.PreferredContent.Raw
@ -43,7 +42,7 @@ gen r u c gc = do
Annex.addCleanup (RemoteCleanup u) $ stopExternal external
cst <- getCost external r gc
avail <- getAvailability external r gc
return $ Just $ chunkedEncryptableRemote c
return $ Just $ specialRemote c
(simplyPrepare $ store external)
(simplyPrepare $ retrieve external)
Remote {

View file

@ -18,7 +18,6 @@ import qualified Git
import Config
import Config.Cost
import Remote.Helper.Special
import Remote.Helper.ChunkedEncryptable
import qualified Remote.Helper.AWS as AWS
import Creds
import Utility.Metered
@ -40,7 +39,7 @@ remote = RemoteType {
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
where
new cst = Just $ encryptableRemote c
new cst = Just $ specialRemote' specialcfg c
(prepareStore this)
(prepareRetrieve this)
this
@ -66,6 +65,10 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
availability = GloballyAvailable,
remotetype = remote
}
specialcfg = (specialRemoteCfg c)
-- Disabled until jobList gets support for chunks.
{ chunkConfig = NoChunks
}
glacierSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
glacierSetup mu mcreds c = do

View file

@ -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

View file

@ -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)

View file

@ -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)

View file

@ -18,7 +18,6 @@ import Config
import Config.Cost
import Annex.UUID
import Remote.Helper.Special
import Remote.Helper.ChunkedEncryptable
import Utility.Env
type Action = String
@ -35,7 +34,7 @@ remote = RemoteType {
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc = do
cst <- remoteCost gc expensiveRemoteCost
return $ Just $ chunkedEncryptableRemote c
return $ Just $ specialRemote c
(simplyPrepare $ store hooktype)
(simplyPrepare $ retrieve hooktype)
Remote {

View file

@ -25,7 +25,6 @@ import qualified Git
import Config
import Config.Cost
import Remote.Helper.Special
import Remote.Helper.ChunkedEncryptable
import qualified Remote.Helper.AWS as AWS
import Creds
import Utility.Metered
@ -45,7 +44,7 @@ remote = RemoteType {
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
where
new cst = Just $ chunkedEncryptableRemote c
new cst = Just $ specialRemote c
(prepareStore this)
(prepareRetrieve this)
this

View file

@ -28,7 +28,6 @@ import Config
import Config.Cost
import Remote.Helper.Special
import Remote.Helper.Encryptable
import Remote.Helper.Chunked
import qualified Remote.Helper.Chunked.Legacy as Legacy
import Crypto
import Creds
@ -122,7 +121,7 @@ storeHelper r k baseurl user pass b = catchBoolIO $ do
where
tmpurl = tmpLocation baseurl k
keyurl = davLocation baseurl k
chunkconfig = chunkConfig $ config r
chunkconfig = getChunkConfig $ config r
finalizer srcurl desturl = do
void $ tryNonAsync (deleteDAV desturl user pass)
mkdirRecursiveDAV (urlParent desturl) user pass
@ -220,7 +219,7 @@ withStoredFiles r k baseurl user pass onerr a = case chunkconfig of
else a chunks
where
keyurl = davLocation baseurl k ++ keyFile k
chunkconfig = chunkConfig $ config r
chunkconfig = getChunkConfig $ config r
davAction :: Remote -> a -> ((DavUrl, DavUser, DavPass) -> Annex a) -> Annex a
davAction r unconfigured action = do