diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/Ssh.hs | 9 | ||||
| -rw-r--r-- | Assistant/TransferSlots.hs | 15 | ||||
| -rw-r--r-- | Assistant/TransferrerPool.hs | 13 |
3 files changed, 28 insertions, 9 deletions
diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index f316aa500..1dc982ba6 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -12,6 +12,7 @@ import Utility.Tmp import Utility.UserInfo import Utility.Shell import Utility.Rsync +import Utility.FileMode import Git.Remote import Data.Text (Text) @@ -233,12 +234,8 @@ setupSshKeyPair sshkeypair sshdata = do sshdir <- sshDir createDirectoryIfMissing True $ parentDir $ sshdir </> sshprivkeyfile - unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $ do - h <- fdToHandle =<< - createFile (sshdir </> sshprivkeyfile) - (unionFileModes ownerWriteMode ownerReadMode) - hPutStr h (sshPrivKey sshkeypair) - hClose h + unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $ + writeFileProtected (sshdir </> sshprivkeyfile) (sshPrivKey sshkeypair) unlessM (doesFileExist $ sshdir </> sshpubkeyfile) $ writeFile (sshdir </> sshpubkeyfile) (sshPubKey sshkeypair) diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 36d557c3d..cb66e845a 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Assistant.TransferSlots where import Assistant.Common @@ -32,8 +34,10 @@ import qualified Data.Map as M import qualified Control.Exception as E import Control.Concurrent import qualified Control.Concurrent.MSemN as MSemN -import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL) +#ifndef mingw32_HOST_OS import System.Posix.Process (getProcessGroupIDOf) +import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL) +#endif type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Transferrer -> Assistant ())) @@ -247,13 +251,18 @@ 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 void $ tryIO $ signalProcessGroup sigKILL g +#else + error "TODO: cancelTransfer not implemented on Windows" +#endif {- Start or resume a transfer. -} startTransfer :: Transfer -> Assistant () diff --git a/Assistant/TransferrerPool.hs b/Assistant/TransferrerPool.hs index d9104f74d..bb4648731 100644 --- a/Assistant/TransferrerPool.hs +++ b/Assistant/TransferrerPool.hs @@ -5,12 +5,17 @@ - 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) @@ -38,13 +43,18 @@ withTransferrer program 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 - 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] @@ -68,6 +78,9 @@ mkTransferrer program = do , 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 |