diff options
Diffstat (limited to 'Assistant')
| -rw-r--r-- | Assistant/DaemonStatus.hs | 8 | ||||
| -rw-r--r-- | Assistant/Threads/Pusher.hs | 10 | ||||
| -rw-r--r-- | Assistant/Threads/TransferScanner.hs | 2 | ||||
| -rw-r--r-- | Assistant/TransferQueue.hs | 3 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators.hs | 10 |
5 files changed, 24 insertions, 9 deletions
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 4077eec88..8e3b48777 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -14,6 +14,7 @@ import Utility.ThreadScheduler import Utility.TempFile import Utility.NotificationBroadcaster import Logs.Transfer +import Logs.Trust import qualified Remote import Control.Concurrent.STM @@ -81,8 +82,13 @@ modifyDaemonStatus dstatus a = do sendNotification $ changeNotifier s return b +{- Remotes ordered by cost, with dead ones thrown out. -} calcKnownRemotes :: Annex [Remote] -calcKnownRemotes = concat . Remote.byCost <$> Remote.enabledRemoteList +calcKnownRemotes = do + rs <- concat . Remote.byCost <$> Remote.enabledRemoteList + alive <- snd <$> trustPartition DeadTrusted (map Remote.uuid rs) + let good r = Remote.uuid r `elem` alive + return $ filter good rs {- Updates the cached ordered list of remotes from the list in Annex - state. -} diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index 73bf24ede..6bf8de2df 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -16,6 +16,7 @@ import Assistant.DaemonStatus import Assistant.Sync import Utility.ThreadScheduler import qualified Remote +import qualified Types.Remote as Remote import Data.Time.Clock @@ -51,8 +52,8 @@ pushThread st dstatus commitchan pushmap = do now <- getCurrentTime if shouldPush now commits then do - remotes <- filter (not . Remote.specialRemote) . - knownRemotes <$> getDaemonStatus dstatus + remotes <- filter pushable . knownRemotes + <$> getDaemonStatus dstatus unless (null remotes) $ void $ alertWhile dstatus (pushAlert remotes) $ pushToRemotes thisThread now st (Just pushmap) remotes @@ -63,6 +64,11 @@ pushThread st dstatus commitchan pushmap = do , "commits" ] refillCommits commitchan commits + where + pushable r + | Remote.specialRemote r = False + | Remote.readonly r = False + | otherwise = True {- Decide if now is a good time to push to remotes. - diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index b4ceac17d..a76453b53 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -16,6 +16,7 @@ import Assistant.Alert import Logs.Transfer import Logs.Location import qualified Remote +import qualified Types.Remote as Remote import Utility.ThreadScheduler import qualified Git.LsFiles as LsFiles import Command @@ -122,6 +123,7 @@ expensiveScan st dstatus transferqueue rs = do , use $ check Download True ) check direction want key locs r + | direction == Upload && Remote.readonly r = Nothing | (Remote.uuid r `elem` locs) == want = Just $ (r, Transfer direction (Remote.uuid r) key) | otherwise = Nothing diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index 18719de8e..fe2c667f9 100644 --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -23,6 +23,7 @@ import Assistant.DaemonStatus import Logs.Transfer import Types.Remote import qualified Remote +import qualified Types.Remote as Remote import Control.Concurrent.STM import qualified Data.Map as M @@ -78,7 +79,7 @@ queueTransfers schedule q dstatus k f direction = do -- can be uploaded to, in order to ensure all -- remotes can access the content. Currently, -- send to every remote we can. - | otherwise = return rs + | otherwise = return $ filter (not . Remote.readonly) rs gentransfer r = Transfer { transferDirection = direction , transferKey = k diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs index 67939fffb..ad29459a9 100644 --- a/Assistant/WebApp/Configurators.hs +++ b/Assistant/WebApp/Configurators.hs @@ -12,12 +12,12 @@ module Assistant.WebApp.Configurators where import Assistant.Common import Assistant.WebApp import Assistant.WebApp.SideBar +import Assistant.DaemonStatus import Assistant.Threads.MountWatcher (handleMount) import Utility.Yesod import qualified Remote +import qualified Types.Remote as Remote import Remote.List -import Logs.Web (webUUID) -import Logs.Trust import Annex.UUID (getUUID) import Init import qualified Git @@ -60,11 +60,11 @@ getRepositoriesR = bootstrap (Just Config) $ do {- A numbered list of known repositories, including the current one. -} repoList :: Handler [(String, String)] repoList = do + rs <- filter (not . Remote.readonly) . knownRemotes <$> + (liftIO . getDaemonStatus =<< daemonStatus <$> getYesod) l <- runAnnex [] $ do u <- getUUID - rs <- map Remote.uuid <$> Remote.remoteList - rs' <- snd <$> trustPartition DeadTrusted rs - Remote.prettyListUUIDs $ filter (/= webUUID) $ nub $ u:rs' + Remote.prettyListUUIDs $ nub $ u:(map Remote.uuid rs) return $ zip counter l where counter = map show ([1..] :: [Int]) |