diff options
| -rw-r--r-- | Assistant/DaemonStatus.hs | 13 | ||||
| -rw-r--r-- | Assistant/WebApp/DashBoard.hs | 19 | ||||
| -rw-r--r-- | Logs/Transfer.hs | 8 |
3 files changed, 23 insertions, 17 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 diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index 46ca98403..642ee7ea1 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -214,14 +214,6 @@ readTransferInfo mpid s = (bits, filebits) = splitAt 1 $ lines s filename = join "\n" filebits -{- Preserves the old transferTid and transferPaused values, - - which are not written to disk. -} -mergeTransferInfo :: TransferInfo -> TransferInfo -> TransferInfo -mergeTransferInfo new old = new - { transferTid = maybe (transferTid new) Just (transferTid old) - , transferPaused = transferPaused new || transferPaused old - } - parsePOSIXTime :: String -> Maybe POSIXTime parsePOSIXTime s = utcTimeToPOSIXSeconds <$> parseTime defaultTimeLocale "%s%Qs" s |