git-annex (5.20131127) unstable; urgency=low

  * webapp: Detect when upgrades are available, and upgrade if the user
    desires.
    (Only when git-annex is installed using the prebuilt binaries
    from git-annex upstream, not from eg Debian.)
  * assistant: Detect when the git-annex binary is modified or replaced,
    and either prompt the user to restart the program, or automatically
    restart it.
  * annex.autoupgrade configures both the above upgrade behaviors.
  * Added support for quvi 0.9. Slightly suboptimal due to limitations in its
    interface compared with the old version.
  * Bug fix: annex.version did not get set on automatic upgrade to v5 direct
    mode repo, so the upgrade was performed repeatedly, slowing commands down.
  * webapp: Fix bug that broke switching between local repositories
    that use the new guarded direct mode.
  * Android: Fix stripping of the git-annex binary.
  * Android: Make terminal app show git-annex version number.
  * Android: Re-enable XMPP support.
  * reinject: Allow to be used in direct mode.
  * Futher improvements to git repo repair. Has now been tested in tens
    of thousands of intentionally damaged repos, and successfully
    repaired them all.
  * Allow use of --unused in bare repository.

# imported from the archive

1 files changed, 95 insertions, 0 deletions

diff --git a/Assistant/TransferrerPool.hs b/Assistant/TransferrerPool.hs
new file mode 100644
index 000000000..bb4648731
--- /dev/null
+++ b/Assistant/TransferrerPool.hs
@@ -0,0 +1,95 @@
+{- A pool of "git-annex transferkeys" processes
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Assistant.TransferrerPool where
+
+import Assistant.Common
+import Assistant.Types.TransferrerPool
+import Logs.Transfer
+
+#ifndef mingw32_HOST_OS
+import qualified Command.TransferKeys as T
+#endif
+
+import Control.Concurrent.STM
+import System.Process (create_group)
+import Control.Exception (throw)
+import Control.Concurrent
+
+{- Runs an action with a Transferrer from the pool. -}
+withTransferrer :: FilePath -> TransferrerPool -> (Transferrer -> IO a) -> IO a
+withTransferrer program pool a = do
+	t <- maybe (mkTransferrer program) (checkTransferrer program)
+		=<< atomically (tryReadTChan pool)
+	v <- tryNonAsync $ a t
+	unlessM (putback t) $
+		void $ forkIO $ stopTransferrer t
+	either throw return v
+  where
+  	putback t = atomically $ ifM (isEmptyTChan pool)
+		( do
+			writeTChan pool t
+			return True
+		, return False
+		)
+
+{- Requests that a Transferrer perform a Transfer, and waits for it to
+ - finish. -}
+performTransfer :: Transferrer -> Transfer -> AssociatedFile -> IO Bool
+performTransfer transferrer t f = catchBoolIO $ do
+#ifndef mingw32_HOST_OS
+	T.sendRequest t f (transferrerWrite transferrer)
+	T.readResponse (transferrerRead transferrer)
+#else
+	error "TODO performTransfer not implemented on Windows"
+#endif
+
+{- Starts a new git-annex transferkeys process, setting up a pipe
+ - that will be used to communicate with it. -}
+mkTransferrer :: FilePath -> IO Transferrer
+mkTransferrer program = do
+#ifndef mingw32_HOST_OS
+	(myread, twrite) <- createPipe
+	(tread, mywrite) <- createPipe
+	mapM_ (\fd -> setFdOption fd CloseOnExec True) [myread, mywrite]
+	let params =
+		[ Param "transferkeys"
+		, Param "--readfd", Param $ show tread
+		, Param "--writefd", Param $ show twrite
+		]
+	{- It's put into its own group so that the whole group can be
+	 - killed to stop a transfer. -}
+	(_, _, _, pid) <- createProcess (proc program $ toCommand params)
+		{ create_group = True }
+	closeFd twrite
+	closeFd tread
+	myreadh <- fdToHandle myread
+	mywriteh <- fdToHandle mywrite
+	fileEncoding myreadh
+	fileEncoding mywriteh
+	return $ Transferrer
+		{ transferrerRead = myreadh
+		, transferrerWrite = mywriteh
+		, transferrerHandle = pid
+		}
+#else
+	error "TODO mkTransferrer not implemented on Windows"
+#endif
+
+{- Checks if a Transferrer is still running. If not, makes a new one. -}
+checkTransferrer :: FilePath -> Transferrer -> IO Transferrer
+checkTransferrer program t = maybe (return t) (const $ mkTransferrer program)
+	=<< getProcessExitCode (transferrerHandle t)
+
+{- Closing the fds will stop the transferrer. -}
+stopTransferrer :: Transferrer -> IO ()
+stopTransferrer t = do
+	hClose $ transferrerRead t
+	hClose $ transferrerWrite t
+	void $ waitForProcess $ transferrerHandle t