port transferkeys to windows; make stopping in progress transfers work too (probably)

transferkeys had used special FDs for communication, but that would be
quite annoying to do in Windows.

Instead, use stdin and stdout. But, to avoid commands like rsync stomping
on them and messing up the communications channel, they're duplicated to a
different handle; stdin is replaced with a null handle, and stdout is
replaced with a copy of stderr. This should all work in windows too.

Stopping in progress transfers may work on windows.. if the types unify
anyway. ;) May need some more porting.

2 files changed, 23 insertions, 38 deletions

diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs
index 4852c36f8..da92bbf0b 100644
--- a/Assistant/TransferSlots.hs
+++ b/Assistant/TransferSlots.hs
@@ -38,6 +38,8 @@ import qualified Control.Concurrent.MSemN as MSemN
 #ifndef mingw32_HOST_OS
 import System.Posix.Process (getProcessGroupIDOf)
 import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL)
+#else
+import System.Win32.Console (generateConsoleCtrlEvent, cTRL_C_EVENT, cTRL_BREAK_EVENT)
 #endif
 
 type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()))
@@ -252,18 +254,21 @@ cancelTransfer pause t = do
 	signalthread tid
 		| pause = throwTo tid PauseTransfer
 		| otherwise = killThread tid
+	{- In order to stop helper processes like rsync,
+	 - kill the whole process group of the process
+	 - running the transfer. -}
 	killproc pid = void $ tryIO $ do
 #ifndef mingw32_HOST_OS
-		{- In order to stop helper processes like rsync,
-		 - kill the whole process group of the process
-		 - running the transfer. -}
 		g <- getProcessGroupIDOf pid
 		void $ tryIO $ signalProcessGroup sigTERM g
-		threadDelay 50000 -- 0.05 second grace period
+		graceperiod
 		void $ tryIO $ signalProcessGroup sigKILL g
 #else
-		error "TODO: cancelTransfer not implemented on Windows"
+		void $ tryIO $ generateConsoleCtrlEvent cTRL_C_EVENT pid
+		graceperiod
+		void $ tryIO $ generateConsoleCtrlEvent cTRL_BREAK_EVENT pid
 #endif
+	graceperiod = threadDelay 50000 -- 0.05 second
 
 {- Start or resume a transfer. -}
 startTransfer :: Transfer -> Assistant ()
diff --git a/Assistant/TransferrerPool.hs b/Assistant/TransferrerPool.hs
index 8ebe81f60..e7aa72924 100644
--- a/Assistant/TransferrerPool.hs
+++ b/Assistant/TransferrerPool.hs
@@ -5,8 +5,6 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP #-}
-
 module Assistant.TransferrerPool where
 
 import Assistant.Common
@@ -14,12 +12,10 @@ import Assistant.Types.TransferrerPool
 import Logs.Transfer
 import Utility.Batch
 
-#ifndef mingw32_HOST_OS
 import qualified Command.TransferKeys as T
-#endif
 
 import Control.Concurrent.STM
-import System.Process (create_group)
+import System.Process (create_group, std_in, std_out)
 import Control.Exception (throw)
 import Control.Concurrent
 
@@ -44,46 +40,30 @@ withTransferrer program batchmaker pool a = do
  - 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
+{- Starts a new git-annex transferkeys process, setting up handles
  - that will be used to communicate with it. -}
 mkTransferrer :: FilePath -> BatchCommandMaker -> IO Transferrer
 mkTransferrer program batchmaker = 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 runs as a batch job. -}
-	let (program', params') = batchmaker (program, params)
+	let (program', params') = batchmaker (program, [Param "transferkeys"])
 	{- 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
+	(Just writeh, Just readh, _, pid) <- createProcess
+		(proc program' $ toCommand params')
+		{ create_group = True
+		, std_in = CreatePipe
+		, std_out = CreatePipe
+		}
+	fileEncoding readh
+	fileEncoding writeh
 	return $ Transferrer
-		{ transferrerRead = myreadh
-		, transferrerWrite = mywriteh
+		{ transferrerRead = readh
+		, transferrerWrite = writeh
 		, 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 -> BatchCommandMaker -> Transferrer -> IO Transferrer