run full transfer scan on all remotes at startup
Or when a remote first becomes available after startup.
This commit is contained in:
parent
9fafddc7eb
commit
e58d19b533
3 changed files with 39 additions and 17 deletions
|
@ -41,9 +41,9 @@ getScanRemote v = atomically $ do
|
||||||
return ret
|
return ret
|
||||||
|
|
||||||
{- Adds new remotes that need scanning to the map. -}
|
{- Adds new remotes that need scanning to the map. -}
|
||||||
addScanRemotes :: ScanRemoteMap -> [Remote] -> Bool -> IO ()
|
addScanRemotes :: ScanRemoteMap -> Bool -> [Remote] -> IO ()
|
||||||
addScanRemotes _ [] _ = noop
|
addScanRemotes _ _ [] = noop
|
||||||
addScanRemotes v rs full = atomically $ do
|
addScanRemotes v full rs = atomically $ do
|
||||||
m <- fromMaybe M.empty <$> tryTakeTMVar v
|
m <- fromMaybe M.empty <$> tryTakeTMVar v
|
||||||
putTMVar v $ M.unionWith merge (M.fromList $ zip rs (map info rs)) m
|
putTMVar v $ M.unionWith merge (M.fromList $ zip rs (map info rs)) m
|
||||||
where
|
where
|
||||||
|
|
|
@ -40,13 +40,13 @@ reconnectRemotes threadname st dstatus scanremotes rs = void $
|
||||||
where
|
where
|
||||||
sync (Just branch) = do
|
sync (Just branch) = do
|
||||||
diverged <- manualPull st (Just branch) rs
|
diverged <- manualPull st (Just branch) rs
|
||||||
addScanRemotes scanremotes rs diverged
|
addScanRemotes scanremotes diverged rs
|
||||||
now <- getCurrentTime
|
now <- getCurrentTime
|
||||||
pushToRemotes threadname now st Nothing rs
|
pushToRemotes threadname now st Nothing rs
|
||||||
{- No local branch exists yet, but we can try pulling. -}
|
{- No local branch exists yet, but we can try pulling. -}
|
||||||
sync Nothing = do
|
sync Nothing = do
|
||||||
diverged <- manualPull st Nothing rs
|
diverged <- manualPull st Nothing rs
|
||||||
addScanRemotes scanremotes rs diverged
|
addScanRemotes scanremotes diverged rs
|
||||||
return True
|
return True
|
||||||
|
|
||||||
{- Updates the local sync branch, then pushes it to all remotes, in
|
{- Updates the local sync branch, then pushes it to all remotes, in
|
||||||
|
|
|
@ -29,17 +29,36 @@ thisThread = "TransferScanner"
|
||||||
-}
|
-}
|
||||||
transferScannerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> TransferQueue -> IO ()
|
transferScannerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> TransferQueue -> IO ()
|
||||||
transferScannerThread st dstatus scanremotes transferqueue = do
|
transferScannerThread st dstatus scanremotes transferqueue = do
|
||||||
|
startupScan
|
||||||
runEvery (Seconds 2) $ do
|
runEvery (Seconds 2) $ do
|
||||||
(r, info) <- getScanRemote scanremotes
|
(r, info) <- getScanRemote scanremotes
|
||||||
scanned <- runThreadState st $ inRepo $
|
scanned <- runThreadState st $ inRepo $
|
||||||
checkTransferScanned $ Remote.uuid r
|
checkTransferScanned $ Remote.uuid r
|
||||||
if not scanned || fullScan info
|
if not scanned || fullScan info
|
||||||
then do
|
then expensiveScan st dstatus transferqueue r
|
||||||
liftIO $ debug thisThread ["starting scan of", show r]
|
|
||||||
void $ alertWhile dstatus (scanAlert r) $
|
|
||||||
expensiveScan st dstatus transferqueue r
|
|
||||||
liftIO $ debug thisThread ["finished scan of", show r]
|
|
||||||
else failedTransferScan st dstatus transferqueue r
|
else failedTransferScan st dstatus transferqueue r
|
||||||
|
where
|
||||||
|
{- All remotes are scanned in full on startup, for multiple
|
||||||
|
- reasons, including:
|
||||||
|
-
|
||||||
|
- * This may be the first run, and there may be remotes
|
||||||
|
- already in place, that need to be synced.
|
||||||
|
- * We may have run before, and scanned a remote, but
|
||||||
|
- only been in a subdirectory of the git remote, and so
|
||||||
|
- not synced it all.
|
||||||
|
- * We may have run before, and had transfers queued,
|
||||||
|
- and then the system (or us) crashed, and that info was
|
||||||
|
- lost.
|
||||||
|
-
|
||||||
|
- But not all remotes may be available now. So all
|
||||||
|
- prior indications that remotes have been scanned
|
||||||
|
- are first removed.
|
||||||
|
-}
|
||||||
|
startupScan = do
|
||||||
|
removeDirectoryRecursive
|
||||||
|
=<< runThreadState st (fromRepo transferScannedDir)
|
||||||
|
addScanRemotes scanremotes True
|
||||||
|
=<< knownRemotes <$> getDaemonStatus dstatus
|
||||||
|
|
||||||
{- This is a cheap scan for failed transfers involving a remote. -}
|
{- This is a cheap scan for failed transfers involving a remote. -}
|
||||||
failedTransferScan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO ()
|
failedTransferScan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO ()
|
||||||
|
@ -77,14 +96,17 @@ failedTransferScan st dstatus transferqueue r = do
|
||||||
{- This is a expensive scan through the full git work tree.
|
{- This is a expensive scan through the full git work tree.
|
||||||
-
|
-
|
||||||
- The scan is blocked when the transfer queue gets too large. -}
|
- The scan is blocked when the transfer queue gets too large. -}
|
||||||
expensiveScan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO Bool
|
expensiveScan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO ()
|
||||||
expensiveScan st dstatus transferqueue r = do
|
expensiveScan st dstatus transferqueue r = do
|
||||||
g <- runThreadState st $ fromRepo id
|
liftIO $ debug thisThread ["starting scan of", show r]
|
||||||
files <- LsFiles.inRepo [] g
|
void $ alertWhile dstatus (scanAlert r) $ do
|
||||||
go files
|
g <- runThreadState st $ fromRepo id
|
||||||
runThreadState st $ inRepo $
|
files <- LsFiles.inRepo [] g
|
||||||
transferScanned $ Remote.uuid r
|
go files
|
||||||
return True
|
runThreadState st $ inRepo $
|
||||||
|
transferScanned $ Remote.uuid r
|
||||||
|
return True
|
||||||
|
liftIO $ debug thisThread ["finished scan of", show r]
|
||||||
where
|
where
|
||||||
go [] = noop
|
go [] = noop
|
||||||
go (f:fs) = do
|
go (f:fs) = do
|
||||||
|
|
Loading…
Add table
Reference in a new issue