Remotes can now be made read-only, by setting remote.<name>.annex-readonly

2 files changed, 31 insertions, 1 deletions

diff --git a/Remote/Helper/ReadOnly.hs b/Remote/Helper/ReadOnly.hs
new file mode 100644
index 000000000..cd92a083c
--- /dev/null
+++ b/Remote/Helper/ReadOnly.hs
@@ -0,0 +1,29 @@
+{- Adds readonly support to remotes.
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Helper.ReadOnly (adjustReadOnly) where
+
+import Common.Annex
+import Types.Remote
+
+{- Adds support for read-only remotes, by replacing the
+ - methods that write to a remote with dummies that fail.
+ -
+ - Note that disabling git pushes to remotes is not handled here.
+ -}
+adjustReadOnly :: Remote -> Remote
+adjustReadOnly r
+	| remoteAnnexReadOnly (gitconfig r) = r
+		{ storeKey = \_ _ _ -> failbool
+		, removeKey = \_ -> failbool
+		, repairRepo = Nothing
+		}
+	| otherwise = r
+  where
+	failbool = do
+		warning "this remote is readonly"
+		return False
diff --git a/Remote/List.hs b/Remote/List.hs
index d01d23944..cc7019850 100644
--- a/Remote/List.hs
+++ b/Remote/List.hs
@@ -18,6 +18,7 @@ import Types.Remote
 import Types.GitConfig
 import Annex.UUID
 import Remote.Helper.Hooks
+import Remote.Helper.ReadOnly
 import qualified Git
 import qualified Git.Config
 
@@ -89,7 +90,7 @@ remoteGen m t r = do
 	let gc = extractRemoteGitConfig g (Git.repoDescribe r)
 	let c = fromMaybe M.empty $ M.lookup u m
 	mrmt <- generate t r u c gc
-	return $ addHooks <$> mrmt
+	return $ adjustReadOnly . addHooks <$> mrmt
 
 {- Updates a local git Remote, re-reading its git config. -}
 updateRemote :: Remote -> Annex (Maybe Remote)