diff options
| -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 | ||||
| -rw-r--r-- | Remote/Bup.hs | 1 | ||||
| -rw-r--r-- | Remote/Directory.hs | 1 | ||||
| -rw-r--r-- | Remote/Git.hs | 1 | ||||
| -rw-r--r-- | Remote/Hook.hs | 1 | ||||
| -rw-r--r-- | Remote/Rsync.hs | 1 | ||||
| -rw-r--r-- | Remote/S3.hs | 1 | ||||
| -rw-r--r-- | Remote/Web.hs | 1 | ||||
| -rw-r--r-- | Types/Remote.hs | 2 |
13 files changed, 33 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]) diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 3dfedfec6..e3ba7fe9b 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -64,6 +64,7 @@ gen r u c = do then Just buprepo else Nothing , remotetype = remote + , readonly = False } bupSetup :: UUID -> RemoteConfig -> Annex RemoteConfig diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 2e7d8c6ad..0ec564ca1 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -54,6 +54,7 @@ gen r u c = do config = Nothing, repo = r, localpath = Just dir, + readonly = False, remotetype = remote } where diff --git a/Remote/Git.hs b/Remote/Git.hs index 9f81c689d..a9e3c3c9f 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -98,6 +98,7 @@ gen r u _ = new <$> remoteCost r defcst then Just $ Git.repoPath r else Nothing , repo = r + , readonly = False , remotetype = remote } diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 5bd091efa..c73a8deb8 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -50,6 +50,7 @@ gen r u c = do config = Nothing, localpath = Nothing, repo = r, + readonly = False, remotetype = remote } diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 86e9771f9..ff3b473fa 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -61,6 +61,7 @@ gen r u c = do , localpath = if rsyncUrlIsPath $ rsyncUrl o then Just $ rsyncUrl o else Nothing + , readonly = False , remotetype = remote } diff --git a/Remote/S3.hs b/Remote/S3.hs index d1e592b0d..4efdb3071 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -61,6 +61,7 @@ gen' r u c cst = config = c, repo = r, localpath = Nothing, + readonly = False, remotetype = remote } diff --git a/Remote/Web.hs b/Remote/Web.hs index 54b93c1fe..2001e6ce8 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -49,6 +49,7 @@ gen r _ _ = config = Nothing, localpath = Nothing, repo = r, + readonly = True, remotetype = remote } diff --git a/Types/Remote.hs b/Types/Remote.hs index a65919605..5e2e566e5 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -66,6 +66,8 @@ data RemoteA a = Remote { repo :: Git.Repo, -- a Remote can be assocated with a specific local filesystem path localpath :: Maybe FilePath, + -- a Remote can be known to be readonly + readonly :: Bool, -- the type of the remote remotetype :: RemoteTypeA a } |