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.

1 files changed, 23 insertions, 26 deletions

diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs
index 5ac9454aa..6d8db4ef2 100644
--- a/Command/TransferKeys.hs
+++ b/Command/TransferKeys.hs
@@ -16,39 +16,21 @@ import Logs.Location
 import Logs.Transfer
 import qualified Remote
 import Types.Key
-import qualified Option
+
+import GHC.IO.Handle
 
 data TransferRequest = TransferRequest Direction Remote Key AssociatedFile
 
 def :: [Command]
-def = [withOptions options $
-	command "transferkeys" paramNothing seek
+def = [command "transferkeys" paramNothing seek
 	SectionPlumbing "transfers keys"]
 
-options :: [Option]
-options = [readFdOption, writeFdOption]
-
-readFdOption :: Option
-readFdOption = Option.field [] "readfd" paramNumber "read from this fd"
-
-writeFdOption :: Option
-writeFdOption = Option.field [] "writefd" paramNumber "write to this fd"
-
 seek :: [CommandSeek]
-seek = [withField readFdOption convertFd $ \readh ->
-	withField writeFdOption convertFd $ \writeh ->
-	withNothing $ start readh writeh]
-
-convertFd :: Maybe String -> Annex (Maybe Handle)
-convertFd Nothing = return Nothing
-convertFd (Just s) = liftIO $ 
-	case readish s of
-		Nothing -> error "bad fd"
-		Just fd -> Just <$> fdToHandle fd
-
-start :: Maybe Handle -> Maybe Handle -> CommandStart
-start readh writeh = do
-	runRequests (fromMaybe stdin readh) (fromMaybe stdout writeh) runner
+seek = [withNothing start]
+
+start :: CommandStart
+start = withHandles $ \(readh, writeh) -> do
+	runRequests readh writeh runner
 	stop
   where
 	runner (TransferRequest direction remote key file)
@@ -61,6 +43,21 @@ start readh writeh = do
 		| otherwise = download (Remote.uuid remote) key file forwardRetry $ \p ->
 			getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p
 
+{- stdin and stdout are connected with the caller, to be used for
+ - communication with it. But doing a transfer might involve something
+ - that tries to read from stdin, or write to stdout. To avoid that, close
+ - stdin, and duplicate stderr to stdout. Return two new handles
+ - that are duplicates of the original (stdin, stdout). -}
+withHandles :: ((Handle, Handle) -> Annex a) -> Annex a
+withHandles a = do
+	readh <- liftIO $ hDuplicate stdin
+	writeh <- liftIO $ hDuplicate stdout
+	liftIO $ do
+		nullh <- openFile devNull ReadMode
+		nullh `hDuplicateTo` stdin
+		stderr `hDuplicateTo` stdout
+	a (readh, writeh)
+
 runRequests
 	:: Handle
 	-> Handle