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

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

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

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
+					]

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