hooked up git-annex-shell transferinfo

Finally done with progressbars!

Command/TransferInfo.hs

@@ -11,24 +11,16 @@ import Common.Annex
 import Command
 import Annex.Content
 import Logs.Transfer
-import Types.Remote
 import Types.Key
+import qualified Fields
 
 def :: [Command]
-def = [noCommit $ command "transferinfo" paramdesc seek
+def = [noCommit $ command "transferinfo" paramKey seek
 	"updates sender on number of bytes of content received"]
 
 seek :: [CommandSeek]
 seek = [withWords start]
 
-paramdesc :: String
-paramdesc = paramKey `paramPair` paramUUID `paramPair` paramOptional paramFile
-
-start :: [String] -> CommandStart
-start (k:u:f:[]) = start' (file2key k) (toUUID u) (Just f) >> stop
-start (k:u:[]) = start' (file2key k) (toUUID u) Nothing >> stop
-start _ = error "wrong number of parameters"
-
 {- Security:
  - 
  - The transfer info file contains the user-supplied key, but
@@ -41,9 +33,14 @@ start _ = error "wrong number of parameters"
  - of the key is actually in progress, because this could be started
  - concurrently with sendkey, and win the race.
  -}
-start' :: Maybe Key -> UUID -> AssociatedFile -> Annex ()
-start' Nothing _ _ = error "bad key"
-start' (Just key) u file = whenM (inAnnex key) $ do
+start :: [String] -> CommandStart
+start (k:[]) = do
+	case (file2key k) of
+		Nothing -> error "bad key"
+		(Just key) -> whenM (inAnnex key) $ do
+			file <- Fields.getField Fields.associatedFile
+			u <- maybe (error "missing remoteuuid") toUUID
+				<$> Fields.getField Fields.remoteUUID
 			let t = Transfer
 				{ transferDirection = Upload
 				, transferUUID = u
@@ -58,3 +55,5 @@ start' (Just key) u file = whenM (inAnnex key) $ do
 				, tryIO $ removeFile tfile
 				, exitSuccess
 				]
+	stop
+start _ = error "wrong number of parameters"

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

Utility/Process.hs

@@ -17,6 +17,7 @@ module Utility.Process (
 	writeReadProcessEnv,
 	forceSuccessProcess,
 	checkSuccessProcess,
+	ignoreFailureProcess,
 	createProcessSuccess,
 	createProcessChecked,
 	createBackgroundProcess,
@@ -24,6 +25,9 @@ module Utility.Process (
 	withBothHandles,
 	createProcess,
 	runInteractiveProcess,
+	stdinHandle,
+	stdoutHandle,
+	stderrHandle,
 ) where
 
 import qualified System.Process
@@ -112,6 +116,9 @@ checkSuccessProcess pid = do
 	code <- waitForProcess pid
 	return $ code == ExitSuccess
 
+ignoreFailureProcess :: ProcessHandle -> IO ()
+ignoreFailureProcess = void . waitForProcess
+
 {- Runs createProcess, then an action on its handles, and then
  - forceSuccessProcess. -}
 createProcessSuccess :: CreateProcessRunner

doc/bugs/rsync_remote_shows_no_progress.mdwn

@@ -11,3 +11,5 @@ Please provide any additional information below.
 I looked in the source code and found some hints that the rsync progress should actually be evaluated and shown, I'm opening a bug report for this reason.
 
 [[!meta title="assistant: No progress bars for file uploads"]]
+
+> now upload progress bars work! [[done]] --[[Joey]]

doc/design/assistant/progressbars.mdwn

@@ -17,36 +17,14 @@ This is one of those potentially hidden but time consuming problems.
 ## uploads
 
 Each individual remote type needs to implement its own support for calling
-the ProgressCallback as the upload progresses.
-
-* git: Done, with one exception: `git-annex-shell sendkey` runs `rsync
-  --server --sender` and in that mode it does not report progress info.
-  So downloads initiated by other repos do not show progress in the repo
-  doing the uploading. 
-  
-  Maybe I should
-  write a proxy for the rsync wire protocol that can tell what chunk of the
-  file is being sent, and shim it in front of the rsync server? Sadly,
-  the protocol is insane.
-
-  Another idea: Invert things. Make `git-annex-shell sendkey` run 
-  `rsync -e 'cat'`, so it treats the incoming ssh connection as the server.
-  (cat probably won't really work; bidirectional pipe needed).
-  Run rsync in `--server` mode on the *client* side, piped to ssh.
-  Now the `git-annex` side doesn't have a progress bar (but it can poll the
-  file size and produce its own), `git-annex-shell` side does have a progress
-  bar.
-
-  Less crazy, but probably harder idea: Multiplex progress info from client
-  back to server over the ssh connection, and demultiplex at server end.
-  Or, use a separate ssh connection, and let ssh connection caching handle
-  the multiplexing.
+the MeterUpdate callback as the upload progresses.
 
+* git: **done**
 * rsync: **done**
 * directory: **done**
 * web: Not applicable; does not upload 
-* S3
-* bup
+* S3: TODO
+* bup: TODO
 * hook: Would require the hook interface to somehow do this, which seems
   too complicated. So skipping.
 

doc/git-annex-shell.mdwn

@@ -46,14 +46,14 @@ first "/~/" or "/~user/" is expanded to the specified home directory.
 
   This runs rsync in server mode to transfer out the content of a key.
 
-* transferinfo directory key uuid [file]
+* transferinfo directory key
 
   This is typically run at the same time as sendkey is sending a key
-  to the remote with the specified uuid.
+  to the remote. Using it is optional, but is used to update
+  progress information for the transfer of the key.
 
   It reads lines from standard input, each giving the number of bytes
-  that have been received so far. This is optional, but is used to update
-  progress information for the transfer of the key.
+  that have been received so far. 
 
 * commit directory