finish making rsync support chunking
This breaks gcrypt, which relies on some internals of the rsync remote. To fix next..
This commit is contained in:
parent
6c450aad1d
commit
f5f961215b
3 changed files with 37 additions and 38 deletions
|
@ -22,6 +22,7 @@ module Crypto (
|
||||||
describeCipher,
|
describeCipher,
|
||||||
decryptCipher,
|
decryptCipher,
|
||||||
encryptKey,
|
encryptKey,
|
||||||
|
isEncKey,
|
||||||
feedFile,
|
feedFile,
|
||||||
feedBytes,
|
feedBytes,
|
||||||
readBytes,
|
readBytes,
|
||||||
|
@ -150,9 +151,15 @@ type EncKey = Key -> Key
|
||||||
encryptKey :: Mac -> Cipher -> EncKey
|
encryptKey :: Mac -> Cipher -> EncKey
|
||||||
encryptKey mac c k = stubKey
|
encryptKey mac c k = stubKey
|
||||||
{ keyName = macWithCipher mac c (key2file k)
|
{ keyName = macWithCipher mac c (key2file k)
|
||||||
, keyBackendName = "GPG" ++ showMac mac
|
, keyBackendName = encryptedBackendNamePrefix ++ showMac mac
|
||||||
}
|
}
|
||||||
|
|
||||||
|
encryptedBackendNamePrefix :: String
|
||||||
|
encryptedBackendNamePrefix = "GPG"
|
||||||
|
|
||||||
|
isEncKey :: Key -> Bool
|
||||||
|
isEncKey k = encryptedBackendNamePrefix `isPrefixOf` keyBackendName k
|
||||||
|
|
||||||
type Feeder = Handle -> IO ()
|
type Feeder = Handle -> IO ()
|
||||||
type Reader m a = Handle -> m a
|
type Reader m a = Handle -> m a
|
||||||
|
|
||||||
|
|
|
@ -299,7 +299,7 @@ store r rsyncopts (cipher, enck) k p
|
||||||
| otherwise = unsupportedUrl
|
| otherwise = unsupportedUrl
|
||||||
where
|
where
|
||||||
gpgopts = getGpgEncParams r
|
gpgopts = getGpgEncParams r
|
||||||
storersync = Remote.Rsync.storeEncrypted rsyncopts gpgopts (cipher, enck) k p
|
storersync = undefined -- Remote.Rsync.storeEncrypted rsyncopts gpgopts (cipher, enck) k p
|
||||||
storeshell = withTmp enck $ \tmp ->
|
storeshell = withTmp enck $ \tmp ->
|
||||||
ifM (spoolencrypted $ readBytes $ \b -> catchBoolIO $ L.writeFile tmp b >> return True)
|
ifM (spoolencrypted $ readBytes $ \b -> catchBoolIO $ L.writeFile tmp b >> return True)
|
||||||
( Ssh.rsyncHelper (Just p)
|
( Ssh.rsyncHelper (Just p)
|
||||||
|
@ -323,7 +323,7 @@ retrieve r rsyncopts (cipher, enck) k d p
|
||||||
a >>= \b ->
|
a >>= \b ->
|
||||||
decrypt cipher (feedBytes b)
|
decrypt cipher (feedBytes b)
|
||||||
(readBytes $ meteredWriteFile meterupdate d)
|
(readBytes $ meteredWriteFile meterupdate d)
|
||||||
retrieversync = Remote.Rsync.retrieveEncrypted rsyncopts (cipher, enck) k d p
|
retrieversync = undefined -- Remote.Rsync.retrieveEncrypted rsyncopts (cipher, enck) k d p
|
||||||
retrieveshell = withTmp enck $ \tmp ->
|
retrieveshell = withTmp enck $ \tmp ->
|
||||||
ifM (Ssh.rsyncHelper (Just p) =<< Ssh.rsyncParamsRemote False r Download enck tmp Nothing)
|
ifM (Ssh.rsyncHelper (Just p) =<< Ssh.rsyncParamsRemote False r Download enck tmp Nothing)
|
||||||
( liftIO $ catchBoolIO $ do
|
( liftIO $ catchBoolIO $ do
|
||||||
|
|
|
@ -9,8 +9,6 @@
|
||||||
|
|
||||||
module Remote.Rsync (
|
module Remote.Rsync (
|
||||||
remote,
|
remote,
|
||||||
storeEncrypted,
|
|
||||||
retrieveEncrypted,
|
|
||||||
remove,
|
remove,
|
||||||
checkPresent,
|
checkPresent,
|
||||||
withRsyncScratchDir,
|
withRsyncScratchDir,
|
||||||
|
@ -27,7 +25,6 @@ import Annex.Content
|
||||||
import Annex.UUID
|
import Annex.UUID
|
||||||
import Annex.Ssh
|
import Annex.Ssh
|
||||||
import Remote.Helper.Special
|
import Remote.Helper.Special
|
||||||
import Remote.Helper.Encryptable
|
|
||||||
import Remote.Rsync.RsyncUrl
|
import Remote.Rsync.RsyncUrl
|
||||||
import Crypto
|
import Crypto
|
||||||
import Utility.Rsync
|
import Utility.Rsync
|
||||||
|
@ -37,8 +34,8 @@ import Utility.PID
|
||||||
import Annex.Perms
|
import Annex.Perms
|
||||||
import Logs.Transfer
|
import Logs.Transfer
|
||||||
import Types.Creds
|
import Types.Creds
|
||||||
|
import Types.Key (isChunkKey)
|
||||||
|
|
||||||
import qualified Data.ByteString.Lazy as L
|
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
|
||||||
remote :: RemoteType
|
remote :: RemoteType
|
||||||
|
@ -56,15 +53,15 @@ gen r u c gc = do
|
||||||
fromMaybe (error "missing rsyncurl") $ remoteAnnexRsyncUrl gc
|
fromMaybe (error "missing rsyncurl") $ remoteAnnexRsyncUrl gc
|
||||||
let o = genRsyncOpts c gc transport url
|
let o = genRsyncOpts c gc transport url
|
||||||
let islocal = rsyncUrlIsPath $ rsyncUrl o
|
let islocal = rsyncUrlIsPath $ rsyncUrl o
|
||||||
return $ Just $ encryptableRemote c
|
return $ Just $ specialRemote' specialcfg c
|
||||||
(storeEncrypted o $ getGpgEncParams (c,gc))
|
(simplyPrepare $ store o)
|
||||||
(retrieveEncrypted o)
|
(simplyPrepare $ retrieve o)
|
||||||
Remote
|
Remote
|
||||||
{ uuid = u
|
{ uuid = u
|
||||||
, cost = cst
|
, cost = cst
|
||||||
, name = Git.repoDescribe r
|
, name = Git.repoDescribe r
|
||||||
, storeKey = store o
|
, storeKey = storeKeyDummy
|
||||||
, retrieveKeyFile = retrieve o
|
, retrieveKeyFile = retreiveKeyFileDummy
|
||||||
, retrieveKeyFileCheap = retrieveCheap o
|
, retrieveKeyFileCheap = retrieveCheap o
|
||||||
, removeKey = remove o
|
, removeKey = remove o
|
||||||
, hasKey = checkPresent r o
|
, hasKey = checkPresent r o
|
||||||
|
@ -82,6 +79,10 @@ gen r u c gc = do
|
||||||
, availability = if islocal then LocallyAvailable else GloballyAvailable
|
, availability = if islocal then LocallyAvailable else GloballyAvailable
|
||||||
, remotetype = remote
|
, remotetype = remote
|
||||||
}
|
}
|
||||||
|
where
|
||||||
|
specialcfg = (specialRemoteCfg c)
|
||||||
|
-- Rsync displays its own progress.
|
||||||
|
{ displayProgress = False }
|
||||||
|
|
||||||
genRsyncOpts :: RemoteConfig -> RemoteGitConfig -> [CommandParam] -> RsyncUrl -> RsyncOpts
|
genRsyncOpts :: RemoteConfig -> RemoteGitConfig -> [CommandParam] -> RsyncUrl -> RsyncOpts
|
||||||
genRsyncOpts c gc transport url = RsyncOpts
|
genRsyncOpts c gc transport url = RsyncOpts
|
||||||
|
@ -139,32 +140,17 @@ rsyncSetup mu _ c = do
|
||||||
gitConfigSpecialRemote u c' "rsyncurl" url
|
gitConfigSpecialRemote u c' "rsyncurl" url
|
||||||
return (c', u)
|
return (c', u)
|
||||||
|
|
||||||
store :: RsyncOpts -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
store :: RsyncOpts -> Storer
|
||||||
store o k _f p = sendAnnex k (void $ remove o k) $ rsyncSend o p k False
|
store = fileStorer . rsyncSend
|
||||||
|
|
||||||
storeEncrypted :: RsyncOpts -> [CommandParam] -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
|
retrieve :: RsyncOpts -> Retriever
|
||||||
storeEncrypted o gpgOpts (cipher, enck) k p = withTmp enck $ \tmp ->
|
retrieve o = fileRetriever $ \f k p ->
|
||||||
sendAnnex k (void $ remove o enck) $ \src -> do
|
unlessM (rsyncRetrieve o k f (Just p)) $
|
||||||
liftIO $ encrypt gpgOpts cipher (feedFile src) $
|
error "rsync failed"
|
||||||
readBytes $ L.writeFile tmp
|
|
||||||
rsyncSend o p enck True tmp
|
|
||||||
|
|
||||||
retrieve :: RsyncOpts -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
|
|
||||||
retrieve o k _ f p = rsyncRetrieve o k f (Just p)
|
|
||||||
|
|
||||||
retrieveCheap :: RsyncOpts -> Key -> FilePath -> Annex Bool
|
retrieveCheap :: RsyncOpts -> Key -> FilePath -> Annex Bool
|
||||||
retrieveCheap o k f = ifM (preseedTmp k f) ( rsyncRetrieve o k f Nothing , return False )
|
retrieveCheap o k f = ifM (preseedTmp k f) ( rsyncRetrieve o k f Nothing , return False )
|
||||||
|
|
||||||
retrieveEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
|
|
||||||
retrieveEncrypted o (cipher, enck) _ f p = withTmp enck $ \tmp ->
|
|
||||||
ifM (rsyncRetrieve o enck tmp (Just p))
|
|
||||||
( liftIO $ catchBoolIO $ do
|
|
||||||
decrypt cipher (feedFile tmp) $
|
|
||||||
readBytes $ L.writeFile f
|
|
||||||
return True
|
|
||||||
, return False
|
|
||||||
)
|
|
||||||
|
|
||||||
remove :: RsyncOpts -> Key -> Annex Bool
|
remove :: RsyncOpts -> Key -> Annex Bool
|
||||||
remove o k = do
|
remove o k = do
|
||||||
ps <- sendParams
|
ps <- sendParams
|
||||||
|
@ -238,8 +224,8 @@ withRsyncScratchDir a = do
|
||||||
removeDirectoryRecursive d
|
removeDirectoryRecursive d
|
||||||
|
|
||||||
rsyncRetrieve :: RsyncOpts -> Key -> FilePath -> Maybe MeterUpdate -> Annex Bool
|
rsyncRetrieve :: RsyncOpts -> Key -> FilePath -> Maybe MeterUpdate -> Annex Bool
|
||||||
rsyncRetrieve o k dest callback =
|
rsyncRetrieve o k dest meterupdate =
|
||||||
showResumable $ untilTrue (rsyncUrls o k) $ \u -> rsyncRemote Download o callback
|
showResumable $ untilTrue (rsyncUrls o k) $ \u -> rsyncRemote Download o meterupdate
|
||||||
-- use inplace when retrieving to support resuming
|
-- use inplace when retrieving to support resuming
|
||||||
[ Param "--inplace"
|
[ Param "--inplace"
|
||||||
, Param u
|
, Param u
|
||||||
|
@ -274,8 +260,8 @@ rsyncRemote direction o callback params = do
|
||||||
- (When we have the right hash directory structure, we can just
|
- (When we have the right hash directory structure, we can just
|
||||||
- pass --include=X --include=X/Y --include=X/Y/file --exclude=*)
|
- pass --include=X --include=X/Y --include=X/Y/file --exclude=*)
|
||||||
-}
|
-}
|
||||||
rsyncSend :: RsyncOpts -> MeterUpdate -> Key -> Bool -> FilePath -> Annex Bool
|
rsyncSend :: RsyncOpts -> Key -> FilePath -> MeterUpdate -> Annex Bool
|
||||||
rsyncSend o callback k canrename src = withRsyncScratchDir $ \tmp -> do
|
rsyncSend o k src meterupdate = withRsyncScratchDir $ \tmp -> do
|
||||||
let dest = tmp </> Prelude.head (keyPaths k)
|
let dest = tmp </> Prelude.head (keyPaths k)
|
||||||
liftIO $ createDirectoryIfMissing True $ parentDir dest
|
liftIO $ createDirectoryIfMissing True $ parentDir dest
|
||||||
ok <- liftIO $ if canrename
|
ok <- liftIO $ if canrename
|
||||||
|
@ -285,7 +271,7 @@ rsyncSend o callback k canrename src = withRsyncScratchDir $ \tmp -> do
|
||||||
else createLinkOrCopy src dest
|
else createLinkOrCopy src dest
|
||||||
ps <- sendParams
|
ps <- sendParams
|
||||||
if ok
|
if ok
|
||||||
then showResumable $ rsyncRemote Upload o (Just callback) $ ps ++
|
then showResumable $ rsyncRemote Upload o (Just meterupdate) $ ps ++
|
||||||
[ Param "--recursive"
|
[ Param "--recursive"
|
||||||
, partialParams
|
, partialParams
|
||||||
-- tmp/ to send contents of tmp dir
|
-- tmp/ to send contents of tmp dir
|
||||||
|
@ -293,3 +279,9 @@ rsyncSend o callback k canrename src = withRsyncScratchDir $ \tmp -> do
|
||||||
, Param $ rsyncUrl o
|
, Param $ rsyncUrl o
|
||||||
]
|
]
|
||||||
else return False
|
else return False
|
||||||
|
where
|
||||||
|
{- If the key being sent is encrypted or chunked, the file
|
||||||
|
- containing its content is a temp file, and so can be
|
||||||
|
- renamed into place. Otherwise, the file is the annexed
|
||||||
|
- object file, and has to be copied or hard linked into place. -}
|
||||||
|
canrename = isEncKey k || isChunkKey k
|
||||||
|
|
Loading…
Reference in a new issue