diff options
author | Joey Hess <joey@kitenet.net> | 2012-08-12 12:11:20 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-08-12 12:11:20 -0400 |
commit | b6b8f6da9ce18c92cd5c813e07f06d392731bf86 (patch) | |
tree | 897f688c4f75c0364ca01216207eae63c5d00729 /Assistant | |
parent | 37eed5d8d0a3affad6a6a7d0cbbfb1c1e706e635 (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')
-rw-r--r-- | Assistant/Threads/WebApp.hs | 5 | ||||
-rw-r--r-- | Assistant/WebApp.hs | 2 | ||||
-rw-r--r-- | Assistant/WebApp/DashBoard.hs | 35 |
3 files changed, 32 insertions, 10 deletions
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 7343c39fe..e203d50ba 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -21,6 +21,7 @@ import Assistant.ThreadedMonad import Assistant.DaemonStatus import Assistant.ScanRemotes import Assistant.TransferQueue +import Assistant.TransferSlots import Utility.WebApp import Utility.FileMode import Utility.TempFile @@ -43,15 +44,17 @@ webAppThread -> DaemonStatusHandle -> ScanRemoteMap -> TransferQueue + -> TransferSlots -> Maybe (IO String) -> Maybe (Url -> FilePath -> IO ()) -> IO () -webAppThread mst dstatus scanremotes transferqueue postfirstrun onstartup = do +webAppThread mst dstatus scanremotes transferqueue transferslots postfirstrun onstartup = do webapp <- WebApp <$> pure mst <*> pure dstatus <*> pure scanremotes <*> pure transferqueue + <*> pure transferslots <*> (pack <$> genRandomToken) <*> getreldir mst <*> pure $(embed "static") diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs index 4418a4d98..721257294 100644 --- a/Assistant/WebApp.hs +++ b/Assistant/WebApp.hs @@ -15,6 +15,7 @@ import Assistant.ThreadedMonad import Assistant.DaemonStatus import Assistant.ScanRemotes import Assistant.TransferQueue +import Assistant.TransferSlots import Assistant.Alert import Utility.NotificationBroadcaster import Utility.WebApp @@ -36,6 +37,7 @@ data WebApp = WebApp , daemonStatus :: DaemonStatusHandle , scanRemotes :: ScanRemoteMap , transferQueue :: TransferQueue + , transferSlots :: TransferSlots , secretToken :: Text , relDir :: Maybe FilePath , getStatic :: Static 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) |