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.

2 files changed, 10 insertions, 2 deletions

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