build assistant and watcher on windows (doesn't work yet)

This commit is contained in:
Joey Hess 2013-11-12 14:54:02 -04:00
parent 472d9376b6
commit b9b5e3370d
7 changed files with 118 additions and 22 deletions

View file

@ -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)

View file

@ -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 ()

View file

@ -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