diff options
| -rw-r--r-- | Assistant/DaemonStatus.hs | 22 | ||||
| -rw-r--r-- | Assistant/Threads/TransferPoller.hs | 3 | ||||
| -rw-r--r-- | Assistant/Threads/TransferWatcher.hs | 2 | ||||
| -rw-r--r-- | Logs/Transfer.hs | 8 |
4 files changed, 22 insertions, 13 deletions
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 8e3b48777..a07d19124 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -191,19 +191,21 @@ adjustTransfersSTM dstatus a = do s <- takeTMVar dstatus putTMVar dstatus $ s { currentTransfers = a (currentTransfers s) } -{- Updates a transfer's info. - - Preserves the transferTid and transferPaused values, - - which are not written to disk. -} +{- 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 + +{- Updates a transfer's info. Adds the transfer to the map if necessary. -} updateTransferInfo :: DaemonStatusHandle -> Transfer -> TransferInfo -> IO () -updateTransferInfo dstatus t info = +updateTransferInfo dstatus t info = updateTransferInfo' dstatus $ + M.insertWith' mergeTransferInfo t info + +updateTransferInfo' :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> IO () +updateTransferInfo' dstatus a = notifyTransfer dstatus `after` modifyDaemonStatus_ dstatus go where - go s = s { currentTransfers = update (currentTransfers s) } - update m = M.insertWith' merge t info m - merge new old = new - { transferTid = maybe (transferTid new) Just (transferTid old) - , transferPaused = transferPaused new || transferPaused old - } + go s = s { currentTransfers = a (currentTransfers s) } {- Removes a transfer from the map, and returns its info. -} removeTransfer :: DaemonStatusHandle -> Transfer -> IO (Maybe TransferInfo) diff --git a/Assistant/Threads/TransferPoller.hs b/Assistant/Threads/TransferPoller.hs index d720bcc45..12394373f 100644 --- a/Assistant/Threads/TransferPoller.hs +++ b/Assistant/Threads/TransferPoller.hs @@ -41,8 +41,7 @@ transferPollerThread st dstatus = do sz <- catchMaybeIO $ fromIntegral . fileSize <$> getFileStatus f - when (bytesComplete info /= sz && isJust sz) $ do - putStrLn $ "download size " ++ show sz + when (bytesComplete info /= sz && isJust sz) $ updateTransferInfo dstatus t info { bytesComplete = sz } {- can't poll uploads -} diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs index fe8af9aad..31116a724 100644 --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -64,7 +64,7 @@ onAdd st dstatus file _ = case parseTransferFile file of ] r <- headMaybe . filter (sameuuid t) . knownRemotes <$> getDaemonStatus dstatus - updateTransferInfo dstatus t info + alterTransferInfo dstatus t info { transferRemote = r } sameuuid t r = Remote.uuid r == transferUUID t diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index a10ffa7d7..b8938ee69 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -215,6 +215,14 @@ 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 |