implement resuming of paused transfers

Currently waits for a new transfer slot to open up, which probably needs to
change..

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)