diff options
| -rw-r--r-- | Assistant/Monad.hs | 2 | ||||
| -rw-r--r-- | Assistant/ScanRemotes.hs | 37 | ||||
| -rw-r--r-- | Assistant/Sync.hs | 3 | ||||
| -rw-r--r-- | Assistant/Threads/TransferScanner.hs | 8 | ||||
| -rw-r--r-- | Assistant/Types/ScanRemotes.hs | 25 |
5 files changed, 45 insertions, 30 deletions
diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs index c13d3a372..47a464d9e 100644 --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -28,7 +28,7 @@ import Control.Monad.Base (liftBase, MonadBase) import Common.Annex import Assistant.Types.ThreadedMonad import Assistant.DaemonStatus -import Assistant.ScanRemotes +import Assistant.Types.ScanRemotes import Assistant.TransferQueue import Assistant.TransferSlots import Assistant.Types.Pushes diff --git a/Assistant/ScanRemotes.hs b/Assistant/ScanRemotes.hs index 661c98095..f367ab745 100644 --- a/Assistant/ScanRemotes.hs +++ b/Assistant/ScanRemotes.hs @@ -7,39 +7,32 @@ module Assistant.ScanRemotes where -import Common.Annex +import Assistant.Common +import Assistant.Types.ScanRemotes import qualified Types.Remote as Remote import Data.Function import Control.Concurrent.STM import qualified Data.Map as M -data ScanInfo = ScanInfo - { scanPriority :: Int - , fullScan :: Bool - } - -type ScanRemoteMap = TMVar (M.Map Remote ScanInfo) - -{- The TMVar starts empty, and is left empty when there are no remotes - - to scan. -} -newScanRemoteMap :: IO ScanRemoteMap -newScanRemoteMap = atomically newEmptyTMVar - {- Blocks until there is a remote or remotes that need to be scanned. - - The list has higher priority remotes listed first. -} -getScanRemote :: ScanRemoteMap -> IO [(Remote, ScanInfo)] -getScanRemote v = atomically $ - reverse . sortBy (compare `on` scanPriority . snd) . M.toList - <$> takeTMVar v +getScanRemote :: Assistant [(Remote, ScanInfo)] +getScanRemote = do + v <- getAssistant scanRemoteMap + liftIO $ atomically $ + reverse . sortBy (compare `on` scanPriority . snd) . M.toList + <$> takeTMVar v {- Adds new remotes that need scanning. -} -addScanRemotes :: ScanRemoteMap -> Bool -> [Remote] -> IO () -addScanRemotes _ _ [] = noop -addScanRemotes v full rs = atomically $ do - m <- fromMaybe M.empty <$> tryTakeTMVar v - putTMVar v $ M.unionWith merge (M.fromList $ zip rs (map info rs)) m +addScanRemotes :: Bool -> [Remote] -> Assistant () +addScanRemotes _ [] = noop +addScanRemotes full rs = do + v <- getAssistant scanRemoteMap + liftIO $ atomically $ do + m <- fromMaybe M.empty <$> tryTakeTMVar v + putTMVar v $ M.unionWith merge (M.fromList $ zip rs (map info rs)) m where info r = ScanInfo (-1 * Remote.cost r) full merge x y = ScanInfo diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index b16382d82..0bb49973a 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -41,8 +41,7 @@ reconnectRemotes notifypushes rs = void $ do alertWhile (syncAlert rs) $ do (ok, diverged) <- sync =<< liftAnnex (inRepo Git.Branch.current) - scanremotes <- getAssistant scanRemoteMap - liftIO $ addScanRemotes scanremotes diverged rs + addScanRemotes diverged rs return ok where (gitremotes, _specialremotes) = diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index 3e99b60f5..ec0bc0d9b 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -8,6 +8,7 @@ module Assistant.Threads.TransferScanner where import Assistant.Common +import Assistant.Types.ScanRemotes import Assistant.ScanRemotes import Assistant.TransferQueue import Assistant.DaemonStatus @@ -36,7 +37,7 @@ transferScannerThread = NamedThread "TransferScanner" $ do where go scanned = do liftIO $ threadDelaySeconds (Seconds 2) - (rs, infos) <- unzip <$> getScanRemote <<~ scanRemoteMap + (rs, infos) <- unzip <$> getScanRemote if any fullScan infos || any (`S.notMember` scanned) rs then do expensiveScan rs @@ -56,10 +57,7 @@ transferScannerThread = NamedThread "TransferScanner" $ do - and then the system (or us) crashed, and that info was - lost. -} - startupScan = do - scanremotes <- getAssistant scanRemoteMap - liftIO . addScanRemotes scanremotes True - =<< syncRemotes <$> daemonStatus + startupScan = addScanRemotes True =<< syncRemotes <$> daemonStatus {- This is a cheap scan for failed transfers involving a remote. -} failedTransferScan :: Remote -> Assistant () diff --git a/Assistant/Types/ScanRemotes.hs b/Assistant/Types/ScanRemotes.hs new file mode 100644 index 000000000..d2f0c588f --- /dev/null +++ b/Assistant/Types/ScanRemotes.hs @@ -0,0 +1,25 @@ +{- git-annex assistant remotes needing scanning + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.ScanRemotes where + +import Common.Annex + +import Control.Concurrent.STM +import qualified Data.Map as M + +data ScanInfo = ScanInfo + { scanPriority :: Int + , fullScan :: Bool + } + +type ScanRemoteMap = TMVar (M.Map Remote ScanInfo) + +{- The TMVar starts empty, and is left empty when there are no remotes + - to scan. -} +newScanRemoteMap :: IO ScanRemoteMap +newScanRemoteMap = atomically newEmptyTMVar |