summaryrefslogtreecommitdiff
path: root/Assistant/WebApp
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-08-12 12:11:20 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-08-12 12:11:20 -0400
commitb6b8f6da9ce18c92cd5c813e07f06d392731bf86 (patch)
tree897f688c4f75c0364ca01216207eae63c5d00729 /Assistant/WebApp
parent37eed5d8d0a3affad6a6a7d0cbbfb1c1e706e635 (diff)
implement resuming of paused transfers
Currently waits for a new transfer slot to open up, which probably needs to change..
Diffstat (limited to 'Assistant/WebApp')
-rw-r--r--Assistant/WebApp/DashBoard.hs35
1 files changed, 26 insertions, 9 deletions
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
index 73d9d229a..0e871d373 100644
--- a/Assistant/WebApp/DashBoard.hs
+++ b/Assistant/WebApp/DashBoard.hs
@@ -17,6 +17,7 @@ import Assistant.WebApp.Configurators
import Assistant.DaemonStatus
import Assistant.TransferQueue
import Assistant.TransferSlots
+import qualified Assistant.Threads.Transferrer as Transferrer
import Utility.NotificationBroadcaster
import Utility.Yesod
import Logs.Transfer
@@ -39,9 +40,7 @@ import System.Posix.Process (getProcessGroupIDOf)
transfersDisplay :: Bool -> Widget
transfersDisplay warnNoScript = do
webapp <- lift getYesod
- current <- lift $ runAnnex [] $
- M.toList . currentTransfers
- <$> liftIO (getDaemonStatus $ daemonStatus webapp)
+ current <- lift $ M.toList <$> getCurrentTransfers
queued <- liftIO $ getTransferQueue $ transferQueue webapp
let ident = "transfers"
autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
@@ -155,9 +154,6 @@ getCancelTransferR t = cancelTransfer False t >> redirectBack
postCancelTransferR :: Transfer -> Handler ()
postCancelTransferR t = cancelTransfer False t
-startTransfer :: Transfer -> Handler ()
-startTransfer t = liftIO $ putStrLn "start"
-
pauseTransfer :: Transfer -> Handler ()
pauseTransfer = cancelTransfer True
@@ -165,14 +161,13 @@ cancelTransfer :: Bool -> Transfer-> Handler ()
cancelTransfer pause t = do
webapp <- getYesod
let dstatus = daemonStatus webapp
+ m <- getCurrentTransfers
liftIO $ do
{- remove queued transfer -}
void $ dequeueTransfer (transferQueue webapp) dstatus t
{- stop running transfer -}
- maybe noop (stop dstatus) =<< running dstatus
+ maybe noop (stop dstatus) (M.lookup t m)
where
- running dstatus = M.lookup t . currentTransfers
- <$> getDaemonStatus dstatus
stop dstatus info = do
{- When there's a thread associated with the
- transfer, it's killed first, to avoid it
@@ -197,3 +192,25 @@ cancelTransfer pause t = do
void $ tryIO $ signalProcessGroup sigTERM g
threadDelay 100000 -- 0.1 second grace period
void $ tryIO $ signalProcessGroup sigKILL g
+
+startTransfer :: Transfer -> Handler ()
+startTransfer t = do
+ m <- getCurrentTransfers
+ maybe noop resume (M.lookup t m)
+ -- TODO: handle starting a queued transfer
+ where
+ resume info = maybe (start info) signalthread $ transferTid info
+ signalthread tid = liftIO $ throwTo tid ResumeTransfer
+ start info = do
+ webapp <- getYesod
+ let dstatus = daemonStatus webapp
+ let slots = transferSlots webapp
+ {- This transfer was being run by another process,
+ - forget that old pid, and start a new one. -}
+ liftIO $ updateTransferInfo dstatus t $ info
+ { transferPid = Nothing }
+ liftIO $ Transferrer.transferThread dstatus slots t info
+
+getCurrentTransfers :: Handler TransferMap
+getCurrentTransfers = currentTransfers
+ <$> (liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)