fix alterTransferInfo

don't want to stomp over fields other than the ones being changed

3 files changed, 10 insertions, 16 deletions

diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs
index 18dc7342a..24ac0ffb0 100644
--- a/Assistant/DaemonStatus.hs
+++ b/Assistant/DaemonStatus.hs
@@ -192,9 +192,8 @@ adjustTransfersSTM dstatus a = do
 	putTMVar dstatus $ s { currentTransfers = a (currentTransfers s) }
 
 {- 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 (const info) t
+alterTransferInfo :: DaemonStatusHandle -> Transfer -> (TransferInfo -> TransferInfo) -> IO ()
+alterTransferInfo dstatus t a = updateTransferInfo' dstatus $ M.adjust a t
 
 {- Updates a transfer's info. Adds the transfer to the map if necessary,
  - or if already present, updates it while preserving the old transferTid
diff --git a/Assistant/Threads/TransferPoller.hs b/Assistant/Threads/TransferPoller.hs
index 8839045df..79bcb98b5 100644
--- a/Assistant/Threads/TransferPoller.hs
+++ b/Assistant/Threads/TransferPoller.hs
@@ -42,7 +42,7 @@ transferPollerThread st dstatus = do
 					fromIntegral . fileSize
 						<$> getFileStatus f
 				when (bytesComplete info /= sz && isJust sz) $
-					alterTransferInfo dstatus t info
-						{ bytesComplete = sz }
+					alterTransferInfo dstatus t $
+						\i -> i { bytesComplete = sz }
 			{- can't poll uploads -}
 			| otherwise = noop
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
index f9fad1bf6..1b052d84f 100644
--- a/Assistant/WebApp/DashBoard.hs
+++ b/Assistant/WebApp/DashBoard.hs
@@ -182,16 +182,15 @@ cancelTransfer pause t = do
 	where
 		stop dstatus info = do
 			{- When there's a thread associated with the
-			 - transfer, it's killed first, to avoid it
+			 - transfer, it's signaled first, to avoid it
 			 - displaying any alert about the transfer having
 			 - failed when the transfer process is killed. -}
 			maybe noop signalthread $ transferTid info
 			maybe noop killproc $ transferPid info
 			if pause
 				then void $
-					alterTransferInfo dstatus t $ info
-						{ transferPaused = True
-						, transferPid = Nothing }
+					alterTransferInfo dstatus t $ \i -> i
+						{ transferPaused = True }
 				else void $
 					removeTransfer dstatus t
 		signalthread tid
@@ -211,18 +210,18 @@ startTransfer t = do
 	m <- getCurrentTransfers
 	maybe startqueued go (M.lookup t m)
 	where
-		go info = maybe (start info) (resume info) $ transferTid info
+		go info = maybe (start info) resume $ transferTid info
 		startqueued = do
 			webapp <- getYesod
 			let dstatus = daemonStatus webapp
 			let q = transferQueue webapp
 			is <- liftIO $ map snd <$> getMatchingTransfers q dstatus (== t)
 			maybe noop start $ headMaybe is
-		resume info tid = do
+		resume tid = do
 			webapp <- getYesod
 			let dstatus = daemonStatus webapp
 			liftIO $ do
-				alterTransferInfo dstatus t $ info
+				alterTransferInfo dstatus t $ \i -> i
 					{ transferPaused = False }
 				throwTo tid ResumeTransfer
 		start info = do
@@ -230,10 +229,6 @@ startTransfer t = do
 			let st = fromJust $ threadState webapp
 			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 $ alterTransferInfo dstatus t $ info
-				{ transferPid = Nothing, transferPaused = False }
 			liftIO $ inImmediateTransferSlot dstatus slots $ do
 				program <- readProgramFile
 				Transferrer.startTransfer st dstatus program t info