record transfer information on local git remotes
In order to record a semi-useful filename associated with the key, this required plumbing the filename all the way through to the remotes' storeKey and retrieveKeyFile. Note that there is potential for deadlock here, narrowly avoided. Suppose the repos are A and B. A sends file foo to B, and at the same time, B gets file foo from A. So, A locks its upload transfer info file, and then locks B's download transfer info file. At the same time, B is taking the two locks in the opposite order. This is only not a deadlock because the lock code does not wait, and aborts. So one of A or B's transfers will be aborted and the other transfer will continue. Whew!
This commit is contained in:
parent
8c10f37714
commit
7225c2bfc0
16 changed files with 107 additions and 76 deletions
|
@ -108,8 +108,8 @@ bupSplitParams r buprepo k src = do
|
|||
return $ bupParams "split" buprepo
|
||||
(os ++ [Param "-n", Param (bupRef k), src])
|
||||
|
||||
store :: Git.Repo -> BupRepo -> Key -> Annex Bool
|
||||
store r buprepo k = do
|
||||
store :: Git.Repo -> BupRepo -> Key -> AssociatedFile -> Annex Bool
|
||||
store r buprepo k _f = do
|
||||
src <- inRepo $ gitAnnexLocation k
|
||||
params <- bupSplitParams r buprepo k (File src)
|
||||
liftIO $ boolSystem "bup" params
|
||||
|
@ -122,11 +122,11 @@ storeEncrypted r buprepo (cipher, enck) k = do
|
|||
withEncryptedHandle cipher (L.readFile src) $ \h ->
|
||||
pipeBup params (Just h) Nothing
|
||||
|
||||
retrieve :: BupRepo -> Key -> FilePath -> Annex Bool
|
||||
retrieve buprepo k f = do
|
||||
retrieve :: BupRepo -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
||||
retrieve buprepo k _f d = do
|
||||
let params = bupParams "join" buprepo [Param $ bupRef k]
|
||||
liftIO $ catchBoolIO $ do
|
||||
tofile <- openFile f WriteMode
|
||||
tofile <- openFile d WriteMode
|
||||
pipeBup params Nothing (Just tofile)
|
||||
|
||||
retrieveCheap :: BupRepo -> Key -> FilePath -> Annex Bool
|
||||
|
|
|
@ -122,8 +122,8 @@ withCheckedFiles check (Just _) d k a = go $ locations d k
|
|||
withStoredFiles :: ChunkSize -> FilePath -> Key -> ([FilePath] -> IO Bool) -> IO Bool
|
||||
withStoredFiles = withCheckedFiles doesFileExist
|
||||
|
||||
store :: FilePath -> ChunkSize -> Key -> Annex Bool
|
||||
store d chunksize k = do
|
||||
store :: FilePath -> ChunkSize -> Key -> AssociatedFile -> Annex Bool
|
||||
store d chunksize k _f = do
|
||||
src <- inRepo $ gitAnnexLocation k
|
||||
metered k $ \meterupdate ->
|
||||
storeHelper d chunksize k $ \dests ->
|
||||
|
@ -242,8 +242,8 @@ storeHelper d chunksize key a = prep <&&> check <&&> go
|
|||
preventWrite dir
|
||||
return (not $ null stored)
|
||||
|
||||
retrieve :: FilePath -> ChunkSize -> Key -> FilePath -> Annex Bool
|
||||
retrieve d chunksize k f = metered k $ \meterupdate ->
|
||||
retrieve :: FilePath -> ChunkSize -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
||||
retrieve d chunksize k _ f = metered k $ \meterupdate ->
|
||||
liftIO $ withStoredFiles chunksize d k $ \files ->
|
||||
catchBoolIO $ do
|
||||
meteredWriteFile' meterupdate f files feeder
|
||||
|
|
|
@ -21,6 +21,7 @@ import qualified Git.Config
|
|||
import qualified Git.Construct
|
||||
import qualified Annex
|
||||
import Logs.Presence
|
||||
import Logs.Transfer
|
||||
import Annex.UUID
|
||||
import qualified Annex.Content
|
||||
import qualified Annex.BranchState
|
||||
|
@ -219,14 +220,19 @@ dropKey r key
|
|||
]
|
||||
|
||||
{- Tries to copy a key's content from a remote's annex to a file. -}
|
||||
copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool
|
||||
copyFromRemote r key file
|
||||
copyFromRemote :: Git.Repo -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
||||
copyFromRemote r key file dest
|
||||
| not $ Git.repoIsUrl r = guardUsable r False $ do
|
||||
params <- rsyncParams r
|
||||
loc <- liftIO $ gitAnnexLocation key r
|
||||
rsyncOrCopyFile params loc file
|
||||
| Git.repoIsSsh r = rsyncHelper =<< rsyncParamsRemote r True key file
|
||||
| Git.repoIsHttp r = Annex.Content.downloadUrl (keyUrls r key) file
|
||||
u <- getUUID
|
||||
-- run copy from perspective of remote
|
||||
liftIO $ onLocal r $ do
|
||||
ensureInitialized
|
||||
loc <- inRepo $ gitAnnexLocation key
|
||||
upload u key file $
|
||||
rsyncOrCopyFile params loc dest
|
||||
| Git.repoIsSsh r = rsyncHelper =<< rsyncParamsRemote r True key dest
|
||||
| Git.repoIsHttp r = Annex.Content.downloadUrl (keyUrls r key) dest
|
||||
| otherwise = error "copying from non-ssh, non-http repo not supported"
|
||||
|
||||
copyFromRemoteCheap :: Git.Repo -> Key -> FilePath -> Annex Bool
|
||||
|
@ -236,23 +242,25 @@ copyFromRemoteCheap r key file
|
|||
liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True
|
||||
| Git.repoIsSsh r =
|
||||
ifM (Annex.Content.preseedTmp key file)
|
||||
( copyFromRemote r key file
|
||||
( copyFromRemote r key Nothing file
|
||||
, return False
|
||||
)
|
||||
| otherwise = return False
|
||||
|
||||
{- Tries to copy a key's content to a remote's annex. -}
|
||||
copyToRemote :: Git.Repo -> Key -> Annex Bool
|
||||
copyToRemote r key
|
||||
copyToRemote :: Git.Repo -> Key -> AssociatedFile -> Annex Bool
|
||||
copyToRemote r key file
|
||||
| not $ Git.repoIsUrl r = guardUsable r False $ commitOnCleanup r $ do
|
||||
keysrc <- inRepo $ gitAnnexLocation key
|
||||
params <- rsyncParams r
|
||||
u <- getUUID
|
||||
-- run copy from perspective of remote
|
||||
liftIO $ onLocal r $ do
|
||||
ensureInitialized
|
||||
Annex.Content.saveState True `after`
|
||||
Annex.Content.getViaTmp key
|
||||
(rsyncOrCopyFile params keysrc)
|
||||
download u key file $
|
||||
Annex.Content.saveState True `after`
|
||||
Annex.Content.getViaTmp key
|
||||
(rsyncOrCopyFile params keysrc)
|
||||
| Git.repoIsSsh r = commitOnCleanup r $ do
|
||||
keysrc <- inRepo $ gitAnnexLocation key
|
||||
rsyncHelper =<< rsyncParamsRemote r False key keysrc
|
||||
|
|
|
@ -59,14 +59,14 @@ encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r =
|
|||
cost = cost r + encryptedRemoteCostAdj
|
||||
}
|
||||
where
|
||||
store k = cip k >>= maybe
|
||||
(storeKey r k)
|
||||
store k f = cip k >>= maybe
|
||||
(storeKey r k f)
|
||||
(`storeKeyEncrypted` k)
|
||||
retrieve k f = cip k >>= maybe
|
||||
(retrieveKeyFile r k f)
|
||||
(\enck -> retrieveKeyFileEncrypted enck k f)
|
||||
retrieveCheap k f = cip k >>= maybe
|
||||
(retrieveKeyFileCheap r k f)
|
||||
retrieve k f d = cip k >>= maybe
|
||||
(retrieveKeyFile r k f d)
|
||||
(\enck -> retrieveKeyFileEncrypted enck k d)
|
||||
retrieveCheap k d = cip k >>= maybe
|
||||
(retrieveKeyFileCheap r k d)
|
||||
(\_ -> return False)
|
||||
withkey a k = cip k >>= maybe (a k) (a . snd)
|
||||
cip = cipherKey c
|
||||
|
|
|
@ -27,8 +27,8 @@ addHooks' r Nothing Nothing = r
|
|||
addHooks' r starthook stophook = r'
|
||||
where
|
||||
r' = r
|
||||
{ storeKey = \k -> wrapper $ storeKey r k
|
||||
, retrieveKeyFile = \k f -> wrapper $ retrieveKeyFile r k f
|
||||
{ storeKey = \k f -> wrapper $ storeKey r k f
|
||||
, retrieveKeyFile = \k f d -> wrapper $ retrieveKeyFile r k f d
|
||||
, retrieveKeyFileCheap = \k f -> wrapper $ retrieveKeyFileCheap r k f
|
||||
, removeKey = \k -> wrapper $ removeKey r k
|
||||
, hasKey = \k -> wrapper $ hasKey r k
|
||||
|
|
|
@ -101,8 +101,8 @@ runHook hooktype hook k f a = maybe (return False) run =<< lookupHook hooktype h
|
|||
return False
|
||||
)
|
||||
|
||||
store :: String -> Key -> Annex Bool
|
||||
store h k = do
|
||||
store :: String -> Key -> AssociatedFile -> Annex Bool
|
||||
store h k _f = do
|
||||
src <- inRepo $ gitAnnexLocation k
|
||||
runHook h "store" k (Just src) $ return True
|
||||
|
||||
|
@ -112,8 +112,8 @@ storeEncrypted h (cipher, enck) k = withTmp enck $ \tmp -> do
|
|||
liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp
|
||||
runHook h "store" enck (Just tmp) $ return True
|
||||
|
||||
retrieve :: String -> Key -> FilePath -> Annex Bool
|
||||
retrieve h k f = runHook h "retrieve" k (Just f) $ return True
|
||||
retrieve :: String -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
||||
retrieve h k _f d = runHook h "retrieve" k (Just d) $ return True
|
||||
|
||||
retrieveCheap :: String -> Key -> FilePath -> Annex Bool
|
||||
retrieveCheap _ _ _ = return False
|
||||
|
|
|
@ -99,8 +99,8 @@ rsyncUrls o k = map use annexHashes
|
|||
use h = rsyncUrl o </> h k </> rsyncEscape o (f </> f)
|
||||
f = keyFile k
|
||||
|
||||
store :: RsyncOpts -> Key -> Annex Bool
|
||||
store o k = rsyncSend o k <=< inRepo $ gitAnnexLocation k
|
||||
store :: RsyncOpts -> Key -> AssociatedFile -> Annex Bool
|
||||
store o k _f = rsyncSend o k <=< inRepo $ gitAnnexLocation k
|
||||
|
||||
storeEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> Annex Bool
|
||||
storeEncrypted o (cipher, enck) k = withTmp enck $ \tmp -> do
|
||||
|
@ -108,8 +108,8 @@ storeEncrypted o (cipher, enck) k = withTmp enck $ \tmp -> do
|
|||
liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp
|
||||
rsyncSend o enck tmp
|
||||
|
||||
retrieve :: RsyncOpts -> Key -> FilePath -> Annex Bool
|
||||
retrieve o k f = untilTrue (rsyncUrls o k) $ \u -> rsyncRemote o
|
||||
retrieve :: RsyncOpts -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
||||
retrieve o k _ f = untilTrue (rsyncUrls o k) $ \u -> rsyncRemote o
|
||||
-- use inplace when retrieving to support resuming
|
||||
[ Param "--inplace"
|
||||
, Param u
|
||||
|
@ -117,11 +117,11 @@ retrieve o k f = untilTrue (rsyncUrls o k) $ \u -> rsyncRemote o
|
|||
]
|
||||
|
||||
retrieveCheap :: RsyncOpts -> Key -> FilePath -> Annex Bool
|
||||
retrieveCheap o k f = ifM (preseedTmp k f) ( retrieve o k f , return False )
|
||||
retrieveCheap o k f = ifM (preseedTmp k f) ( retrieve o k undefined f , return False )
|
||||
|
||||
retrieveEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
|
||||
retrieveEncrypted o (cipher, enck) _ f = withTmp enck $ \tmp -> do
|
||||
ifM (retrieve o enck tmp)
|
||||
ifM (retrieve o enck undefined tmp)
|
||||
( liftIO $ catchBoolIO $ do
|
||||
withDecryptedContent cipher (L.readFile tmp) $ L.writeFile f
|
||||
return True
|
||||
|
|
10
Remote/S3.hs
10
Remote/S3.hs
|
@ -113,8 +113,8 @@ s3Setup u c = handlehost $ M.lookup "host" c
|
|||
-- be human-readable
|
||||
M.delete "bucket" defaults
|
||||
|
||||
store :: Remote -> Key -> Annex Bool
|
||||
store r k = s3Action r False $ \(conn, bucket) -> do
|
||||
store :: Remote -> Key -> AssociatedFile -> Annex Bool
|
||||
store r k _f = s3Action r False $ \(conn, bucket) -> do
|
||||
dest <- inRepo $ gitAnnexLocation k
|
||||
res <- liftIO $ storeHelper (conn, bucket) r k dest
|
||||
s3Bool res
|
||||
|
@ -149,12 +149,12 @@ storeHelper (conn, bucket) r k file = do
|
|||
xheaders = filter isxheader $ M.assocs $ fromJust $ config r
|
||||
isxheader (h, _) = "x-amz-" `isPrefixOf` h
|
||||
|
||||
retrieve :: Remote -> Key -> FilePath -> Annex Bool
|
||||
retrieve r k f = s3Action r False $ \(conn, bucket) -> do
|
||||
retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
||||
retrieve r k _f d = s3Action r False $ \(conn, bucket) -> do
|
||||
res <- liftIO $ getObject conn $ bucketKey r bucket k
|
||||
case res of
|
||||
Right o -> do
|
||||
liftIO $ L.writeFile f $ obj_data o
|
||||
liftIO $ L.writeFile d $ obj_data o
|
||||
return True
|
||||
Left e -> s3Warning e
|
||||
|
||||
|
|
|
@ -51,21 +51,21 @@ gen r _ _ =
|
|||
remotetype = remote
|
||||
}
|
||||
|
||||
downloadKey :: Key -> FilePath -> Annex Bool
|
||||
downloadKey key file = get =<< getUrls key
|
||||
downloadKey :: Key -> AssociatedFile -> FilePath -> Annex Bool
|
||||
downloadKey key _file dest = get =<< getUrls key
|
||||
where
|
||||
get [] = do
|
||||
warning "no known url"
|
||||
return False
|
||||
get urls = do
|
||||
showOutput -- make way for download progress bar
|
||||
downloadUrl urls file
|
||||
downloadUrl urls dest
|
||||
|
||||
downloadKeyCheap :: Key -> FilePath -> Annex Bool
|
||||
downloadKeyCheap _ _ = return False
|
||||
|
||||
uploadKey :: Key -> Annex Bool
|
||||
uploadKey _ = do
|
||||
uploadKey :: Key -> AssociatedFile -> Annex Bool
|
||||
uploadKey _ _ = do
|
||||
warning "upload to web not supported"
|
||||
return False
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue