From 271ea499789410e7c5c1352abe835af0a5001c38 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 26 Aug 2012 15:39:02 -0400 Subject: [PATCH] add support for readonly remotes Currently only the web special remote is readonly, but it'd be possible to also have readonly drives, or other remotes. These are handled in the assistant by only downloading from them, and never trying to upload to them. --- Assistant/DaemonStatus.hs | 8 +++++++- Assistant/Threads/Pusher.hs | 10 ++++++++-- Assistant/Threads/TransferScanner.hs | 2 ++ Assistant/TransferQueue.hs | 3 ++- Assistant/WebApp/Configurators.hs | 10 +++++----- Remote/Bup.hs | 1 + Remote/Directory.hs | 1 + Remote/Git.hs | 1 + Remote/Hook.hs | 1 + Remote/Rsync.hs | 1 + Remote/S3.hs | 1 + Remote/Web.hs | 1 + Types/Remote.hs | 2 ++ 13 files changed, 33 insertions(+), 9 deletions(-) diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 4077eec880..8e3b48777d 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 73bf24ede7..6bf8de2dfe 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 b4ceac17d9..a76453b53e 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 18719de8ee..fe2c667f9e 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 67939fffb1..ad29459a95 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 3dfedfec60..e3ba7fe9bf 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 2e7d8c6ad5..0ec564ca1a 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 9f81c689d8..a9e3c3c9fe 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 5bd091efac..c73a8deb8e 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 86e9771f9c..ff3b473fa9 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 d1e592b0d4..4efdb30715 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 54b93c1fe9..2001e6ce8e 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 a659196053..5e2e566e59 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 }