diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/ScanRemotes.hs | 27 | ||||
| -rw-r--r-- | Assistant/Sync.hs | 19 | ||||
| -rw-r--r-- | Assistant/Threads/TransferScanner.hs | 44 | ||||
| -rw-r--r-- | Assistant/TransferQueue.hs | 4 |
4 files changed, 61 insertions, 33 deletions
diff --git a/Assistant/ScanRemotes.hs b/Assistant/ScanRemotes.hs index 524dc200b..2920e89c3 100644 --- a/Assistant/ScanRemotes.hs +++ b/Assistant/ScanRemotes.hs @@ -14,9 +14,12 @@ import Data.Function import Control.Concurrent.STM import qualified Data.Map as M -type Priority = Int +data ScanInfo = ScanInfo + { scanPriority :: Int + , fullScan :: Bool + } -type ScanRemoteMap = TMVar (M.Map Remote Priority) +type ScanRemoteMap = TMVar (M.Map Remote ScanInfo) {- The TMVar starts empty, and is left empty when there are no remotes - to scan. -} @@ -25,21 +28,23 @@ newScanRemoteMap = atomically newEmptyTMVar {- Blocks until there is a remote that needs to be scanned. - Processes higher priority remotes first. -} -getScanRemote :: ScanRemoteMap -> IO Remote +getScanRemote :: ScanRemoteMap -> IO (Remote, ScanInfo) getScanRemote v = atomically $ do m <- takeTMVar v - let l = reverse $ map fst $ sortBy (compare `on` snd) $ M.toList m + let l = reverse $ sortBy (compare `on` scanPriority . snd) $ M.toList m case l of [] -> retry -- should never happen - (newest:_) -> do - let m' = M.delete newest m + (ret@(r, _):_) -> do + let m' = M.delete r m unless (M.null m') $ putTMVar v m' - return newest + return ret {- Adds new remotes that need scanning to the map. -} -addScanRemotes :: ScanRemoteMap -> [Remote] -> IO () -addScanRemotes _ [] = noop -addScanRemotes v rs = atomically $ do +addScanRemotes :: ScanRemoteMap -> [Remote] -> Bool -> IO () +addScanRemotes _ [] _ = noop +addScanRemotes v rs full = atomically $ do m <- fromMaybe M.empty <$> tryTakeTMVar v - putTMVar v $ M.union m $ M.fromList $ map (\r -> (r, Remote.cost r)) rs + putTMVar v $ M.union (M.fromList $ zip rs (map info rs)) m + where + info r = ScanInfo (Remote.cost r) full diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index 42f82e9ab..6a586e097 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -26,10 +26,11 @@ import qualified Data.Map as M {- Syncs with remotes that may have been disconnected for a while. - - - After getting git in sync, queues a scan for file transfers. - - To avoid doing that expensive scan unnecessarily, it's only run - - if the git-annex branches of the remotes have diverged from the - - local git-annex branch. + - First gets git in sync, and then prepares any necessary file transfers. + - + - An expensive full scan is queued when the git-annex branches of the + - remotes have diverged from the local git-annex branch. Otherwise, + - it's sufficient to requeue failed transfers. -} reconnectRemotes :: ThreadName -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> [Remote] -> IO () reconnectRemotes _ _ _ _ [] = noop @@ -38,16 +39,14 @@ reconnectRemotes threadname st dstatus scanremotes rs = void $ sync =<< runThreadState st (inRepo Git.Branch.current) where sync (Just branch) = do - haddiverged <- manualPull st (Just branch) rs - when haddiverged $ - addScanRemotes scanremotes rs + diverged <- manualPull st (Just branch) rs + addScanRemotes scanremotes rs diverged now <- getCurrentTime pushToRemotes threadname now st Nothing rs {- No local branch exists yet, but we can try pulling. -} sync Nothing = do - haddiverged <- manualPull st Nothing rs - when haddiverged $ - addScanRemotes scanremotes rs + diverged <- manualPull st Nothing rs + addScanRemotes scanremotes rs diverged return True {- Updates the local sync branch, then pushes it to all remotes, in diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index 6bef2a6f1..b3222edb4 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -30,24 +30,45 @@ thisThread = "TransferScanner" 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] - void $ alertWhile dstatus (scanAlert r) $ - scan st dstatus transferqueue r - liftIO $ debug thisThread ["finished scan of", show r] + (r, info) <- getScanRemote scanremotes + scanned <- runThreadState st $ inRepo $ + checkTransferScanned $ Remote.uuid r + if not scanned || fullScan info + then do + 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] + runThreadState st $ inRepo $ + transferScanned $ Remote.uuid r + else failedTransferScan st dstatus transferqueue r -{- This is a naive scan through the git work tree. +{- This is a cheap scan for failed transfers involving a remote. -} +failedTransferScan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO () +failedTransferScan st dstatus transferqueue r = do + ts <- runThreadState st $ + getFailedTransfers $ Remote.uuid r + go ts + where + go [] = noop + go ((t, info):ts) = do + queueTransferWhenSmall + transferqueue dstatus (associatedFile info) t r + void $ runThreadState st $ inRepo $ + liftIO . tryIO . removeFile . failedTransferFile t + go ts + +{- This is a expensive scan through the full git work tree. - - The scan is blocked when the transfer queue gets too large. -} -scan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO Bool -scan st dstatus transferqueue r = do +expensiveScan :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Remote -> IO Bool +expensiveScan st dstatus transferqueue r = do g <- runThreadState st $ fromRepo id files <- LsFiles.inRepo [] g go files - inRepo $ transferScanned $ uuid r return True where - go [] = return () + go [] = noop go (f:fs) = do v <- runThreadState st $ whenAnnexed check f case v of @@ -67,8 +88,7 @@ scan st dstatus transferqueue r = do | otherwise = return Nothing u = Remote.uuid r - enqueue f t = queueTransferAt smallsize Later transferqueue dstatus (Just f) t r - smallsize = 10 + enqueue f t = queueTransferWhenSmall transferqueue dstatus (Just f) t r {- Look directly in remote for the key when it's cheap; - otherwise rely on the location log. -} diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index aa6192527..18719de8e 100644 --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -13,6 +13,7 @@ module Assistant.TransferQueue ( queueTransfers, queueTransfer, queueTransferAt, + queueTransferWhenSmall, getNextTransfer, dequeueTransfer, ) where @@ -115,6 +116,9 @@ queueTransferAt wantsz schedule q dstatus f t remote = do else retry -- blocks until queuesize changes enqueue schedule q dstatus t (stubInfo f remote) +queueTransferWhenSmall :: TransferQueue -> DaemonStatusHandle -> AssociatedFile -> Transfer -> Remote -> IO () +queueTransferWhenSmall = queueTransferAt 10 Later + {- Blocks until a pending transfer is available from the queue, - and removes it. - |