fix resume button

Change alterTransferInfo to not merge in old values, including
transferPaused.

2 files changed, 23 insertions, 9 deletions

diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs
index a07d19124..18dc7342a 100644
--- a/Assistant/DaemonStatus.hs
+++ b/Assistant/DaemonStatus.hs
@@ -194,12 +194,19 @@ adjustTransfersSTM dstatus a = do
 {- Alters a transfer's info, if the transfer is in the map. -}
 alterTransferInfo :: DaemonStatusHandle -> Transfer -> TransferInfo -> IO ()
 alterTransferInfo dstatus t info = updateTransferInfo' dstatus $
-	M.adjust (mergeTransferInfo info) t
+	M.adjust (const info) t
 
-{- Updates a transfer's info. Adds the transfer to the map if necessary. -}
+{- Updates a transfer's info. Adds the transfer to the map if necessary,
+ - or if already present, updates it while preserving the old transferTid
+ - and transferPaused values, which are not written to disk. -}
 updateTransferInfo :: DaemonStatusHandle -> Transfer -> TransferInfo -> IO ()
 updateTransferInfo dstatus t info = updateTransferInfo' dstatus $
-	M.insertWith' mergeTransferInfo t info
+	M.insertWith' merge t info
+	where
+		merge new old = new
+			{ transferTid = maybe (transferTid new) Just (transferTid old)
+			, transferPaused = transferPaused new || transferPaused old
+			}
 
 updateTransferInfo' :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> IO ()
 updateTransferInfo' dstatus a =
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
index b04897d86..849aa9d5f 100644
--- a/Assistant/WebApp/DashBoard.hs
+++ b/Assistant/WebApp/DashBoard.hs
@@ -45,6 +45,7 @@ transfersDisplay warnNoScript = do
 	queued <- liftIO $ getTransferQueue $ transferQueue webapp
 	let ident = "transfers"
 	autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
+	liftIO $ print ("current", current)
 	let transfers = simplifyTransfers $ current ++ queued
 	if null transfers
 		then ifM (lift $ showIntro <$> getWebAppState)
@@ -188,7 +189,7 @@ cancelTransfer pause t = do
 			maybe noop killproc $ transferPid info
 			if pause
 				then void $
-					updateTransferInfo dstatus t $ info
+					alterTransferInfo dstatus t $ info
 						{ transferPaused = True }
 				else void $
 					removeTransfer dstatus t
@@ -207,19 +208,25 @@ cancelTransfer pause t = do
 startTransfer :: Transfer -> Handler ()
 startTransfer t = do
 	m <- getCurrentTransfers
-	maybe noop resume (M.lookup t m)
+	maybe noop go (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
+		go info = maybe (start info) (resume info) $ transferTid info
+		resume info tid = do
+			webapp <- getYesod
+			let dstatus = daemonStatus webapp
+			liftIO $ do
+				alterTransferInfo dstatus t $ info
+					{ transferPaused = False }
+				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 $ alterTransferInfo dstatus t $ info
+				{ transferPid = Nothing, transferPaused = False }
 			liftIO $ inImmediateTransferSlot dstatus slots $ do
 				program <- readProgramFile
 				let a = Transferrer.doTransfer dstatus t info program