send notifications when the TransferQueue is changed
The fun part was making it move things from TransferQueue to currentTransfers entirely atomically. Which will avoid inconsistent display if the WebApp renders the current status at just the wrong time. STM to the rescue!
This commit is contained in:
parent
3cc1885793
commit
e31277d38a
5 changed files with 67 additions and 32 deletions
|
@ -11,6 +11,7 @@ import Assistant.Common
|
|||
import Assistant.ScanRemotes
|
||||
import Assistant.TransferQueue
|
||||
import Assistant.ThreadedMonad
|
||||
import Assistant.DaemonStatus
|
||||
import Logs.Transfer
|
||||
import Logs.Location
|
||||
import qualified Remote
|
||||
|
@ -25,20 +26,20 @@ thisThread = "TransferScanner"
|
|||
{- This thread waits until a remote needs to be scanned, to find transfers
|
||||
- that need to be made, to keep data in sync.
|
||||
-}
|
||||
transferScannerThread :: ThreadState -> ScanRemoteMap -> TransferQueue -> IO ()
|
||||
transferScannerThread st scanremotes transferqueue = do
|
||||
transferScannerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> TransferQueue -> IO ()
|
||||
transferScannerThread st dstatus scanremotes transferqueue = do
|
||||
runEvery (Seconds 2) $ do
|
||||
r <- getScanRemote scanremotes
|
||||
liftIO $ debug thisThread ["starting scan of", show r]
|
||||
scan st transferqueue r
|
||||
scan st dstatus transferqueue r
|
||||
liftIO $ debug thisThread ["finished scan of", show r]
|
||||
where
|
||||
|
||||
{- This is a naive scan through the git work tree.
|
||||
-
|
||||
- The scan is blocked when the transfer queue gets too large. -}
|
||||
scan :: ThreadState -> TransferQueue -> Remote -> IO ()
|
||||
scan st transferqueue r = do
|
||||
scan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO ()
|
||||
scan st dstatus transferqueue r = do
|
||||
g <- runThreadState st $ fromRepo id
|
||||
files <- LsFiles.inRepo [] g
|
||||
go files
|
||||
|
@ -63,7 +64,7 @@ scan st transferqueue r = do
|
|||
| otherwise = return Nothing
|
||||
|
||||
u = Remote.uuid r
|
||||
enqueue f t = queueTransferAt smallsize Later transferqueue (Just f) t r
|
||||
enqueue f t = queueTransferAt smallsize Later transferqueue dstatus (Just f) t r
|
||||
smallsize = 10
|
||||
|
||||
{- Look directly in remote for the key when it's cheap;
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue