diff options
author | Joey Hess <joey@kitenet.net> | 2012-08-10 15:45:00 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-08-10 15:52:22 -0400 |
commit | a76078a78e4dc353e7b4e99a250ddd3d83f74ba3 (patch) | |
tree | 09624c51c139facc4681cb4a9cb3271097b0990e /Assistant | |
parent | d5e06e7b89133d8178b604724a41d4a392d577cd (diff) |
process group killing
This seems to work pretty well.
Handled the process groups like this:
- git-annex processes started by the assistant for transfers are run in their
own process groups.
- otherwise, rely on the shell to allocate a process group for git-annex
There is potentially a problem if some other program runs git-annex
directly (not using sh -c) The program and git-annex would then be in
the same process group. If that git-annex starts a transfer and it's
canceled, the program would also get killed. May or may not be a desired
result.
Also, the new updateTransferInfo probably closes a race where it was
possible for the thread id to not be recorded in the transfer info, if
the transfer info file from the transfer process is read first.
Diffstat (limited to 'Assistant')
-rw-r--r-- | Assistant/DaemonStatus.hs | 13 | ||||
-rw-r--r-- | Assistant/Threads/TransferWatcher.hs | 7 | ||||
-rw-r--r-- | Assistant/Threads/Transferrer.hs | 43 | ||||
-rw-r--r-- | Assistant/WebApp/DashBoard.hs | 11 |
4 files changed, 40 insertions, 34 deletions
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 230d2ed37..fae51ea61 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -183,12 +183,17 @@ adjustTransfersSTM dstatus a = do s <- takeTMVar dstatus putTMVar dstatus $ s { currentTransfers = a (currentTransfers s) } -{- Variant that does send notifications. -} -adjustTransfers :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> IO () -adjustTransfers dstatus a = +{- Updates a transfer's info. Preserves any transferTid value, which is not + - written to disk. -} +updateTransferInfo :: DaemonStatusHandle -> Transfer -> TransferInfo -> IO () +updateTransferInfo dstatus t info = notifyTransfer dstatus `after` modifyDaemonStatus_ dstatus go where - go s = s { currentTransfers = a (currentTransfers s) } + go s = s { currentTransfers = update (currentTransfers s) } + update m = M.insertWith' merge t info m + merge new old = case transferTid old of + Nothing -> new + Just _ -> new { transferTid = transferTid old } {- Removes a transfer from the map, and returns its info. -} removeTransfer :: DaemonStatusHandle -> Transfer -> IO (Maybe TransferInfo) diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs index 447ff2264..66c916990 100644 --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -14,8 +14,6 @@ import Logs.Transfer import Utility.DirWatcher import Utility.Types.DirWatcher -import Data.Map as M - thisThread :: ThreadName thisThread = "TransferWatcher" @@ -63,10 +61,7 @@ onAdd st dstatus file _ = case parseTransferFile file of [ "transfer starting:" , show t ] - adjustTransfers dstatus $ - M.insertWith' merge t info - -- preseve transferTid, which is not written to disk - merge new old = new { transferTid = transferTid old } + updateTransferInfo dstatus t info {- Called when a transfer information file is removed. -} onDel :: Handler diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index 6391d7189..c349acf44 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -18,9 +18,7 @@ import Logs.Location import Annex.Content import qualified Remote -import Data.Time.Clock.POSIX -import Data.Time.Clock -import qualified Data.Map as M +import System.Process (create_group) thisThread :: ThreadName thisThread = "Transferrer" @@ -70,12 +68,12 @@ shouldTransfer t info where key = transferKey t -{- A sepeate git-annex process is forked off to run a transfer. - - This allows killing the process if the user decides to cancel the - - transfer. +{- A sepeate git-annex process is forked off to run a transfer, + - running in its own process group. This allows killing it and all its + - children if the user decides to cancel the transfer. - - A thread is forked off to run the process, and the thread - - occupys one of the transfer slots. If all slots are in use, this will + - occupies one of the transfer slots. If all slots are in use, this will - block until one becomes available. The thread's id is also recorded in - the transfer info; the thread will also be killed when a transfer is - stopped, to avoid it displaying any alert about the transfer having @@ -87,24 +85,27 @@ transferThread dstatus slots t info = case (transferRemote info, associatedFile (Just remote, Just file) -> do tid <- inTransferSlot slots $ transferprocess remote file - now <- getCurrentTime - adjustTransfers dstatus $ - M.insertWith' const t info - { startedTime = Just $ utcTimeToPOSIXSeconds now - , transferTid = Just tid - } + updateTransferInfo dstatus t $ info { transferTid = Just tid } where direction = transferDirection t isdownload = direction == Download transferprocess remote file = void $ do - ok <- boolSystem "git-annex" - [ Param "copy" - , Param "--fast" - , Param $ if isdownload then "--from" else "--to" - , Param $ Remote.name remote - , File file - ] + (_, _, _, pid) + <- createProcess (proc command $ toCommand params) + { create_group = True } + status <- waitForProcess pid addAlert dstatus $ - makeAlertFiller ok $ + makeAlertFiller (status == ExitSuccess) $ transferFileAlert direction file + where + command = "git-annex" + params = + [ Param "copy" + , Param "--fast" + , Param $ if isdownload + then "--from" + else "--to" + , Param $ Remote.name remote + , File file + ] diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index a04861ed6..e2245bf6c 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -29,7 +29,8 @@ import Yesod import Text.Hamlet import qualified Data.Map as M import Control.Concurrent -import System.Posix.Signals (signalProcess, sigTERM, sigKILL) +import System.Posix.Signals (signalProcessGroup, sigTERM, sigKILL) +import System.Posix.Process (getProcessGroupIDOf) {- A display of currently running and queued transfers. - @@ -180,7 +181,11 @@ cancelTransfer t = do maybe noop killThread $ transferTid info maybe noop killproc $ transferPid info removeTransfer (daemonStatus webapp) t + {- In order to stop helper processes like rsync, + - kill the whole process group of the process running the + - transfer. -} killproc pid = do - void $ tryIO $ signalProcess sigTERM pid + g <- getProcessGroupIDOf pid + void $ tryIO $ signalProcessGroup sigTERM g threadDelay 100000 -- 0.1 second grace period - void $ tryIO $ signalProcess sigKILL pid + void $ tryIO $ signalProcessGroup sigKILL g |