diff options
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 |