mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

pausing tweaks

Browse source
This commit is contained in:
Joey Hess 2012-08-29 15:13:12 -04:00
parent 93037580b6
commit 9e54355e8b
1 changed files with 6 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

10
Assistant/WebApp/DashBoard.hs
View file

@ -175,8 +175,9 @@ cancelTransfer pause t = do
let dstatus = daemonStatus webapp let dstatus = daemonStatus webapp
m <- getCurrentTransfers m <- getCurrentTransfers
liftIO $ do liftIO $ do
{- remove queued transfer -} unless pause $
void $ dequeueTransfer (transferQueue webapp) dstatus t {- remove queued transfer -}
void $ dequeueTransfer (transferQueue webapp) dstatus t
{- stop running transfer -} {- stop running transfer -}
maybe noop (stop dstatus) (M.lookup t m) maybe noop (stop dstatus) (M.lookup t m)
where where
@ -190,7 +191,8 @@ cancelTransfer pause t = do
if pause if pause
then void $ then void $
alterTransferInfo dstatus t $ info alterTransferInfo dstatus t $ info
{ transferPaused = True } { transferPaused = True
, transferPid = Nothing }
else void $ else void $
removeTransfer dstatus t removeTransfer dstatus t
signalthread tid signalthread tid
@ -202,7 +204,7 @@ cancelTransfer pause t = do
killproc pid = do killproc pid = do
g <- getProcessGroupIDOf pid g <- getProcessGroupIDOf pid
void $ tryIO $ signalProcessGroup sigTERM g void $ tryIO $ signalProcessGroup sigTERM g
threadDelay 100000 -- 0.1 second grace period threadDelay 50000 -- 0.05 second grace period
void $ tryIO $ signalProcessGroup sigKILL g void $ tryIO $ signalProcessGroup sigKILL g
startTransfer :: Transfer -> Handler () startTransfer :: Transfer -> Handler ()