roll ChunkedEncryptable into Special and improve interface
Allow disabling progress displays, for eg, rsync.
This commit is contained in:
parent
e1e5853c94
commit
4b16989e98
13 changed files with 245 additions and 240 deletions
|
@ -76,7 +76,7 @@ perform rs ks = do
|
||||||
where
|
where
|
||||||
desc r' k = intercalate "; " $ map unwords
|
desc r' k = intercalate "; " $ map unwords
|
||||||
[ [ "key size", show (keySize k) ]
|
[ [ "key size", show (keySize k) ]
|
||||||
, [ show (chunkConfig (Remote.config r')) ]
|
, [ show (getChunkConfig (Remote.config r')) ]
|
||||||
, ["encryption", fromMaybe "none" (M.lookup "encryption" (Remote.config r'))]
|
, ["encryption", fromMaybe "none" (M.lookup "encryption" (Remote.config r'))]
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
|
@ -25,7 +25,6 @@ import Config
|
||||||
import Config.Cost
|
import Config.Cost
|
||||||
import qualified Remote.Helper.Ssh as Ssh
|
import qualified Remote.Helper.Ssh as Ssh
|
||||||
import Remote.Helper.Special
|
import Remote.Helper.Special
|
||||||
import Remote.Helper.ChunkedEncryptable
|
|
||||||
import Remote.Helper.Messages
|
import Remote.Helper.Messages
|
||||||
import Utility.Hash
|
import Utility.Hash
|
||||||
import Utility.UserInfo
|
import Utility.UserInfo
|
||||||
|
@ -74,12 +73,16 @@ gen r u c gc = do
|
||||||
, availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable
|
, availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable
|
||||||
, readonly = False
|
, readonly = False
|
||||||
}
|
}
|
||||||
return $ Just $ encryptableRemote c
|
return $ Just $ specialRemote' specialcfg c
|
||||||
(simplyPrepare $ store this buprepo)
|
(simplyPrepare $ store this buprepo)
|
||||||
(simplyPrepare $ retrieve buprepo)
|
(simplyPrepare $ retrieve buprepo)
|
||||||
this
|
this
|
||||||
where
|
where
|
||||||
buprepo = fromMaybe (error "missing buprepo") $ remoteAnnexBupRepo gc
|
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 :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||||
bupSetup mu _ c = do
|
bupSetup mu _ c = do
|
||||||
|
|
|
@ -22,7 +22,6 @@ import qualified Git
|
||||||
import Config
|
import Config
|
||||||
import Config.Cost
|
import Config.Cost
|
||||||
import Remote.Helper.Special
|
import Remote.Helper.Special
|
||||||
import Remote.Helper.ChunkedEncryptable
|
|
||||||
import Annex.Ssh
|
import Annex.Ssh
|
||||||
import Annex.UUID
|
import Annex.UUID
|
||||||
|
|
||||||
|
@ -42,7 +41,7 @@ gen r u c gc = do
|
||||||
if ddarLocal ddarrepo
|
if ddarLocal ddarrepo
|
||||||
then nearlyCheapRemoteCost
|
then nearlyCheapRemoteCost
|
||||||
else expensiveRemoteCost
|
else expensiveRemoteCost
|
||||||
return $ Just $ encryptableRemote c
|
return $ Just $ specialRemote' specialcfg c
|
||||||
(simplyPrepare $ store ddarrepo)
|
(simplyPrepare $ store ddarrepo)
|
||||||
(simplyPrepare $ retrieve ddarrepo)
|
(simplyPrepare $ retrieve ddarrepo)
|
||||||
(this cst)
|
(this cst)
|
||||||
|
@ -71,6 +70,10 @@ gen r u c gc = do
|
||||||
, readonly = False
|
, readonly = False
|
||||||
}
|
}
|
||||||
ddarrepo = fromMaybe (error "missing ddarrepo") $ remoteAnnexDdarRepo gc
|
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 :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||||
ddarSetup mu _ c = do
|
ddarSetup mu _ c = do
|
||||||
|
|
|
@ -20,7 +20,6 @@ import Config.Cost
|
||||||
import Config
|
import Config
|
||||||
import Utility.FileMode
|
import Utility.FileMode
|
||||||
import Remote.Helper.Special
|
import Remote.Helper.Special
|
||||||
import Remote.Helper.ChunkedEncryptable
|
|
||||||
import qualified Remote.Directory.LegacyChunked as Legacy
|
import qualified Remote.Directory.LegacyChunked as Legacy
|
||||||
import Annex.Content
|
import Annex.Content
|
||||||
import Annex.UUID
|
import Annex.UUID
|
||||||
|
@ -37,8 +36,8 @@ remote = RemoteType {
|
||||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
||||||
gen r u c gc = do
|
gen r u c gc = do
|
||||||
cst <- remoteCost gc cheapRemoteCost
|
cst <- remoteCost gc cheapRemoteCost
|
||||||
let chunkconfig = chunkConfig c
|
let chunkconfig = getChunkConfig c
|
||||||
return $ Just $ chunkedEncryptableRemote c
|
return $ Just $ specialRemote c
|
||||||
(prepareStore dir chunkconfig)
|
(prepareStore dir chunkconfig)
|
||||||
(retrieve dir chunkconfig)
|
(retrieve dir chunkconfig)
|
||||||
Remote {
|
Remote {
|
||||||
|
|
|
@ -14,7 +14,7 @@ import qualified Data.ByteString as S
|
||||||
|
|
||||||
import Common.Annex
|
import Common.Annex
|
||||||
import Utility.FileMode
|
import Utility.FileMode
|
||||||
import Remote.Helper.ChunkedEncryptable
|
import Remote.Helper.Special
|
||||||
import qualified Remote.Helper.Chunked.Legacy as Legacy
|
import qualified Remote.Helper.Chunked.Legacy as Legacy
|
||||||
import Annex.Perms
|
import Annex.Perms
|
||||||
import Utility.Metered
|
import Utility.Metered
|
||||||
|
|
|
@ -15,7 +15,6 @@ import Types.CleanupActions
|
||||||
import qualified Git
|
import qualified Git
|
||||||
import Config
|
import Config
|
||||||
import Remote.Helper.Special
|
import Remote.Helper.Special
|
||||||
import Remote.Helper.ChunkedEncryptable
|
|
||||||
import Utility.Metered
|
import Utility.Metered
|
||||||
import Logs.Transfer
|
import Logs.Transfer
|
||||||
import Logs.PreferredContent.Raw
|
import Logs.PreferredContent.Raw
|
||||||
|
@ -43,7 +42,7 @@ gen r u c gc = do
|
||||||
Annex.addCleanup (RemoteCleanup u) $ stopExternal external
|
Annex.addCleanup (RemoteCleanup u) $ stopExternal external
|
||||||
cst <- getCost external r gc
|
cst <- getCost external r gc
|
||||||
avail <- getAvailability external r gc
|
avail <- getAvailability external r gc
|
||||||
return $ Just $ chunkedEncryptableRemote c
|
return $ Just $ specialRemote c
|
||||||
(simplyPrepare $ store external)
|
(simplyPrepare $ store external)
|
||||||
(simplyPrepare $ retrieve external)
|
(simplyPrepare $ retrieve external)
|
||||||
Remote {
|
Remote {
|
||||||
|
|
|
@ -18,7 +18,6 @@ import qualified Git
|
||||||
import Config
|
import Config
|
||||||
import Config.Cost
|
import Config.Cost
|
||||||
import Remote.Helper.Special
|
import Remote.Helper.Special
|
||||||
import Remote.Helper.ChunkedEncryptable
|
|
||||||
import qualified Remote.Helper.AWS as AWS
|
import qualified Remote.Helper.AWS as AWS
|
||||||
import Creds
|
import Creds
|
||||||
import Utility.Metered
|
import Utility.Metered
|
||||||
|
@ -40,7 +39,7 @@ remote = RemoteType {
|
||||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
||||||
gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
|
gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
|
||||||
where
|
where
|
||||||
new cst = Just $ encryptableRemote c
|
new cst = Just $ specialRemote' specialcfg c
|
||||||
(prepareStore this)
|
(prepareStore this)
|
||||||
(prepareRetrieve this)
|
(prepareRetrieve this)
|
||||||
this
|
this
|
||||||
|
@ -66,6 +65,10 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
|
||||||
availability = GloballyAvailable,
|
availability = GloballyAvailable,
|
||||||
remotetype = remote
|
remotetype = remote
|
||||||
}
|
}
|
||||||
|
specialcfg = (specialRemoteCfg c)
|
||||||
|
-- Disabled until jobList gets support for chunks.
|
||||||
|
{ chunkConfig = NoChunks
|
||||||
|
}
|
||||||
|
|
||||||
glacierSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
glacierSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||||
glacierSetup mu mcreds c = do
|
glacierSetup mu mcreds c = do
|
||||||
|
|
|
@ -8,7 +8,7 @@
|
||||||
module Remote.Helper.Chunked (
|
module Remote.Helper.Chunked (
|
||||||
ChunkSize,
|
ChunkSize,
|
||||||
ChunkConfig(..),
|
ChunkConfig(..),
|
||||||
chunkConfig,
|
getChunkConfig,
|
||||||
storeChunks,
|
storeChunks,
|
||||||
removeChunks,
|
removeChunks,
|
||||||
retrieveChunks,
|
retrieveChunks,
|
||||||
|
@ -39,8 +39,8 @@ noChunks :: ChunkConfig -> Bool
|
||||||
noChunks NoChunks = True
|
noChunks NoChunks = True
|
||||||
noChunks _ = False
|
noChunks _ = False
|
||||||
|
|
||||||
chunkConfig :: RemoteConfig -> ChunkConfig
|
getChunkConfig :: RemoteConfig -> ChunkConfig
|
||||||
chunkConfig m =
|
getChunkConfig m =
|
||||||
case M.lookup "chunksize" m of
|
case M.lookup "chunksize" m of
|
||||||
Nothing -> case M.lookup "chunk" m of
|
Nothing -> case M.lookup "chunk" m of
|
||||||
Nothing -> NoChunks
|
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.
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
module Remote.Helper.Special where
|
module Remote.Helper.Special (
|
||||||
|
findSpecialRemotes,
|
||||||
import qualified Data.Map as M
|
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 Common.Annex
|
||||||
|
import Types.StoreRetrieve
|
||||||
import Types.Remote
|
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
|
||||||
import qualified Git.Command
|
import qualified Git.Command
|
||||||
import qualified Git.Construct
|
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
|
{- Special remotes don't have a configured url, so Git.Repo does not
|
||||||
- automatically generate remotes for them. This looks for a different
|
- automatically generate remotes for them. This looks for a different
|
||||||
- configuration key instead.
|
- configuration key instead.
|
||||||
|
@ -38,3 +69,185 @@ gitConfigSpecialRemote u c k v = do
|
||||||
[Param "config", Param (configsetting a), Param b]
|
[Param "config", Param (configsetting a), Param b]
|
||||||
remotename = fromJust (M.lookup "name" c)
|
remotename = fromJust (M.lookup "name" c)
|
||||||
configsetting s = "remote." ++ remotename ++ "." ++ s
|
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)
|
||||||
|
|
|
@ -18,7 +18,6 @@ import Config
|
||||||
import Config.Cost
|
import Config.Cost
|
||||||
import Annex.UUID
|
import Annex.UUID
|
||||||
import Remote.Helper.Special
|
import Remote.Helper.Special
|
||||||
import Remote.Helper.ChunkedEncryptable
|
|
||||||
import Utility.Env
|
import Utility.Env
|
||||||
|
|
||||||
type Action = String
|
type Action = String
|
||||||
|
@ -35,7 +34,7 @@ remote = RemoteType {
|
||||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
||||||
gen r u c gc = do
|
gen r u c gc = do
|
||||||
cst <- remoteCost gc expensiveRemoteCost
|
cst <- remoteCost gc expensiveRemoteCost
|
||||||
return $ Just $ chunkedEncryptableRemote c
|
return $ Just $ specialRemote c
|
||||||
(simplyPrepare $ store hooktype)
|
(simplyPrepare $ store hooktype)
|
||||||
(simplyPrepare $ retrieve hooktype)
|
(simplyPrepare $ retrieve hooktype)
|
||||||
Remote {
|
Remote {
|
||||||
|
|
|
@ -25,7 +25,6 @@ import qualified Git
|
||||||
import Config
|
import Config
|
||||||
import Config.Cost
|
import Config.Cost
|
||||||
import Remote.Helper.Special
|
import Remote.Helper.Special
|
||||||
import Remote.Helper.ChunkedEncryptable
|
|
||||||
import qualified Remote.Helper.AWS as AWS
|
import qualified Remote.Helper.AWS as AWS
|
||||||
import Creds
|
import Creds
|
||||||
import Utility.Metered
|
import Utility.Metered
|
||||||
|
@ -45,7 +44,7 @@ remote = RemoteType {
|
||||||
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
||||||
gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
|
gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
|
||||||
where
|
where
|
||||||
new cst = Just $ chunkedEncryptableRemote c
|
new cst = Just $ specialRemote c
|
||||||
(prepareStore this)
|
(prepareStore this)
|
||||||
(prepareRetrieve this)
|
(prepareRetrieve this)
|
||||||
this
|
this
|
||||||
|
|
|
@ -28,7 +28,6 @@ import Config
|
||||||
import Config.Cost
|
import Config.Cost
|
||||||
import Remote.Helper.Special
|
import Remote.Helper.Special
|
||||||
import Remote.Helper.Encryptable
|
import Remote.Helper.Encryptable
|
||||||
import Remote.Helper.Chunked
|
|
||||||
import qualified Remote.Helper.Chunked.Legacy as Legacy
|
import qualified Remote.Helper.Chunked.Legacy as Legacy
|
||||||
import Crypto
|
import Crypto
|
||||||
import Creds
|
import Creds
|
||||||
|
@ -122,7 +121,7 @@ storeHelper r k baseurl user pass b = catchBoolIO $ do
|
||||||
where
|
where
|
||||||
tmpurl = tmpLocation baseurl k
|
tmpurl = tmpLocation baseurl k
|
||||||
keyurl = davLocation baseurl k
|
keyurl = davLocation baseurl k
|
||||||
chunkconfig = chunkConfig $ config r
|
chunkconfig = getChunkConfig $ config r
|
||||||
finalizer srcurl desturl = do
|
finalizer srcurl desturl = do
|
||||||
void $ tryNonAsync (deleteDAV desturl user pass)
|
void $ tryNonAsync (deleteDAV desturl user pass)
|
||||||
mkdirRecursiveDAV (urlParent 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
|
else a chunks
|
||||||
where
|
where
|
||||||
keyurl = davLocation baseurl k ++ keyFile k
|
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 :: Remote -> a -> ((DavUrl, DavUser, DavPass) -> Annex a) -> Annex a
|
||||||
davAction r unconfigured action = do
|
davAction r unconfigured action = do
|
||||||
|
|
Loading…
Reference in a new issue