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.

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
 }