summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-08-29 14:14:57 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-08-29 14:14:57 -0400
commit93037580b61a17df5e6f849e206cbae0f0116e1b (patch)
tree6d1e320e0479aec7ac629ce2a04f0ab552c29d47 /Assistant
parentc59ba80b5b49fb79f71dddde97e2f92959161f9b (diff)
fix resume button
Change alterTransferInfo to not merge in old values, including transferPaused.
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/DaemonStatus.hs13
-rw-r--r--Assistant/WebApp/DashBoard.hs19
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