diff options
| -rw-r--r-- | Assistant/TransferSlots.hs | 15 | ||||
| -rw-r--r-- | Assistant/TransferrerPool.hs | 46 | ||||
| -rw-r--r-- | Command/TransferKeys.hs | 49 | ||||
| -rw-r--r-- | GitAnnex.hs | 6 | ||||
| -rw-r--r-- | Utility/Process.hs | 12 | ||||
| -rw-r--r-- | doc/todo/windows_support.mdwn | 4 |
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 |