summaryrefslogtreecommitdiff
path: root/Remote
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-09-21 23:25:06 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-09-21 23:25:06 -0400
commitc048add74dc91609e98e3513b0d167c5c7c9048c (patch)
tree7ebd020d494e43c9eb154a0390bf6b1101d1a4d6 /Remote
parentee8789e9d74e74bb453925d46d1b0eed904e323f (diff)
hooked up git-annex-shell transferinfo
Finally done with progressbars!
Diffstat (limited to 'Remote')
-rw-r--r--Remote/Git.hs44
1 files changed, 43 insertions, 1 deletions
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 330fb3a13..a1c5b24b4 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -27,6 +27,7 @@ import qualified Annex
import Logs.Presence
import Logs.Transfer
import Annex.UUID
+import Annex.Exception
import qualified Annex.Content
import qualified Annex.BranchState
import qualified Annex.Branch
@@ -38,6 +39,7 @@ import Types.Key
import qualified Fields
import Control.Concurrent
+import System.Process (std_in, std_err)
remote :: RemoteType
remote = RemoteType {
@@ -247,9 +249,49 @@ copyFromRemote r key file dest
loc <- inRepo $ gitAnnexLocation key
upload u key file $
rsyncOrCopyFile params loc dest
- | Git.repoIsSsh r = rsyncHelper Nothing =<< rsyncParamsRemote r True key dest file
+ | Git.repoIsSsh r = feedprogressback $ \feeder ->
+ rsyncHelper (Just feeder)
+ =<< rsyncParamsRemote r True key dest file
| Git.repoIsHttp r = Annex.Content.downloadUrl (keyUrls r key) dest
| otherwise = error "copying from non-ssh, non-http repo not supported"
+ where
+ {- Feed local rsync's progress info back to the remote,
+ - by forking a feeder thread that runs
+ - git-annex-shell transferinfo at the same time
+ - git-annex-shell sendkey is running.
+ -
+ - Note that it actually waits for rsync to indicate
+ - progress before starting transferinfo, in order
+ - to ensure ssh connection caching works and reuses
+ - the connection set up for the sendkey.
+ -
+ - Also note that older git-annex-shell does not support
+ - transferinfo, so stderr is dropped and failure ignored.
+ -}
+ feedprogressback a = do
+ u <- getUUID
+ let fields = (Fields.remoteUUID, fromUUID u)
+ : maybe [] (\f -> [(Fields.associatedFile, f)]) file
+ Just (cmd, params) <- git_annex_shell r "transferinfo"
+ [Param $ key2file key] fields
+ v <- liftIO $ newEmptySampleVar
+ tid <- liftIO $ forkIO $ void $ tryIO $ do
+ bytes <- readSampleVar v
+ p <- createProcess $
+ (proc cmd (toCommand params))
+ { std_in = CreatePipe
+ , std_err = CreatePipe
+ }
+ hClose $ stderrHandle p
+ let h = stdinHandle p
+ let send b = do
+ hPutStrLn h $ show b
+ hFlush h
+ send bytes
+ forever $
+ send =<< readSampleVar v
+ let feeder = writeSampleVar v
+ bracketIO noop (const $ tryIO $ killThread tid) (a feeder)
copyFromRemoteCheap :: Git.Repo -> Key -> FilePath -> Annex Bool
copyFromRemoteCheap r key file