implement resuming of paused transfers

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

5 files changed, 36 insertions, 12 deletions

diff --git a/Assistant.hs b/Assistant.hs
index 075254dbc..350996977 100644
--- a/Assistant.hs
+++ b/Assistant.hs
@@ -155,7 +155,7 @@ startAssistant assistant daemonize webappwaiter = do
 			mapM_ startthread
 				[ watch $ commitThread st changechan commitchan transferqueue dstatus
 #ifdef WITH_WEBAPP
-				, assist $ webAppThread (Just st) dstatus scanremotes transferqueue Nothing webappwaiter
+				, assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots Nothing webappwaiter
 #endif
 				, assist $ pushThread st dstatus commitchan pushmap
 				, assist $ pushRetryThread st dstatus pushmap
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)
diff --git a/Command/WebApp.hs b/Command/WebApp.hs
index 2b18d1b83..c8a7c7f59 100644
--- a/Command/WebApp.hs
+++ b/Command/WebApp.hs
@@ -13,6 +13,7 @@ import Assistant
 import Assistant.DaemonStatus
 import Assistant.ScanRemotes
 import Assistant.TransferQueue
+import Assistant.TransferSlots
 import Assistant.Threads.WebApp
 import Utility.WebApp
 import Utility.Daemon (checkDaemon, lockPidFile)
@@ -89,9 +90,10 @@ firstRun = do
 	dstatus <- atomically . newTMVar =<< newDaemonStatus
 	scanremotes <- newScanRemoteMap
 	transferqueue <- newTransferQueue
+	transferslots <- newTransferSlots
 	v <- newEmptyMVar
 	let callback a = Just $ a v
-	webAppThread Nothing dstatus scanremotes transferqueue
+	webAppThread Nothing dstatus scanremotes transferqueue transferslots
 		(callback signaler) (callback mainthread)
 	where
 		signaler v = do