From a76078a78e4dc353e7b4e99a250ddd3d83f74ba3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Aug 2012 15:45:00 -0400 Subject: 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. --- Assistant/DaemonStatus.hs | 13 +++++++---- Assistant/Threads/TransferWatcher.hs | 7 +----- Assistant/Threads/Transferrer.hs | 43 ++++++++++++++++++------------------ Assistant/WebApp/DashBoard.hs | 11 ++++++--- 4 files changed, 40 insertions(+), 34 deletions(-) (limited to 'Assistant') 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 -- cgit v1.2.3