split ScanRemotes and lifted

This commit is contained in:
Joey Hess 2012-10-29 19:14:30 -04:00
parent 86cb3faf51
commit 0c584bf70d
5 changed files with 45 additions and 30 deletions

View file

@ -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