summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2013-12-10 23:19:18 -0400
committerGravatar Joey Hess <joey@kitenet.net>2013-12-10 23:19:18 -0400
commitf864a68220a0d77b5b6a5c3f4f25743e8e76aae0 (patch)
tree3e9006aa151b5c8e2ba8562aeefbd6db23cde69f
parent180115645b86580d9077e95504b029152de15fa2 (diff)
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.
-rw-r--r--Assistant/TransferSlots.hs15
-rw-r--r--Assistant/TransferrerPool.hs46
-rw-r--r--Command/TransferKeys.hs49
-rw-r--r--GitAnnex.hs6
-rw-r--r--Utility/Process.hs12
-rw-r--r--doc/todo/windows_support.mdwn4
6 files changed, 52 insertions, 80 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
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
diff --git a/GitAnnex.hs b/GitAnnex.hs
index 61d8b918a..5b69a2d9d 100644
--- a/GitAnnex.hs
+++ b/GitAnnex.hs
@@ -1,6 +1,6 @@
{- git-annex main program
-
- - Copyright 2010 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -23,9 +23,7 @@ import qualified Command.Get
import qualified Command.FromKey
import qualified Command.DropKey
import qualified Command.TransferKey
-#ifndef mingw32_HOST_OS
import qualified Command.TransferKeys
-#endif
import qualified Command.ReKey
import qualified Command.Reinject
import qualified Command.Fix
@@ -129,9 +127,7 @@ cmds = concat
, Command.FromKey.def
, Command.DropKey.def
, Command.TransferKey.def
-#ifndef mingw32_HOST_OS
, Command.TransferKeys.def
-#endif
, Command.ReKey.def
, Command.Fix.def
, Command.Fsck.def
diff --git a/Utility/Process.hs b/Utility/Process.hs
index 03cbe9558..1945e4b9d 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -26,12 +26,12 @@ module Utility.Process (
withHandle,
withBothHandles,
withQuietOutput,
- withNullHandle,
createProcess,
startInteractiveProcess,
stdinHandle,
stdoutHandle,
stderrHandle,
+ devNull,
) where
import qualified System.Process
@@ -280,20 +280,18 @@ withQuietOutput
:: CreateProcessRunner
-> CreateProcess
-> IO ()
-withQuietOutput creator p = withNullHandle $ \nullh -> do
+withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do
let p' = p
{ std_out = UseHandle nullh
, std_err = UseHandle nullh
}
creator p' $ const $ return ()
-withNullHandle :: (Handle -> IO a) -> IO a
-withNullHandle = withFile devnull WriteMode
- where
+devNull :: FilePath
#ifndef mingw32_HOST_OS
- devnull = "/dev/null"
+devNull = "/dev/null"
#else
- devnull = "NUL"
+devNull = "NUL"
#endif
{- Extract a desired handle from createProcess's tuple.
diff --git a/doc/todo/windows_support.mdwn b/doc/todo/windows_support.mdwn
index 62a2cc62a..b6156bf03 100644
--- a/doc/todo/windows_support.mdwn
+++ b/doc/todo/windows_support.mdwn
@@ -17,10 +17,6 @@ now! --[[Joey]]
may be unsafe.
* `git annex assistant` has not been tested, is probably quite incomplete
and/or buggy.
-* Assistant is known to not transfer any files.
- (transferrer doesn't built yet)
- Need a createPipe for windows. See the mkAnonPipe in
- System.Process source. (cbits/runProcess.c)
* No XMPP support (needs a lot of C libraries which are available in
cygwin, but pkg-config does not list them once installed).
* Doesn't daemonize. Maybe use