add readonly mode to serve P2P protocol

This will be used by git-annex-shell when configured to be readonly.

This commit was sponsored by Nick Daly on Patreon.

2 files changed, 33 insertions, 18 deletions

diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs
index f762c3783..a00d24416 100644
--- a/P2P/Protocol.hs
+++ b/P2P/Protocol.hs
@@ -351,10 +351,13 @@ serveAuth myuuid = serverLoop handler
 				return ServerContinue
 	handler _ = return ServerUnexpected
 
+data ServerMode = ServeReadOnly | ServeReadWrite
+
 -- | Serve the protocol, with a peer that has authenticated.
-serveAuthed :: UUID -> Proto ()
-serveAuthed myuuid = void $ serverLoop handler
+serveAuthed :: ServerMode -> UUID -> Proto ()
+serveAuthed servermode myuuid = void $ serverLoop handler
   where
+	readonlyerror = net $ sendMessage (ERROR "this repository is read-only; write access denied")
 	handler (LOCKCONTENT key) = do
 		local $ tryLockContent key $ \locked -> do
 			sendSuccess locked
@@ -367,27 +370,39 @@ serveAuthed myuuid = void $ serverLoop handler
 	handler (CHECKPRESENT key) = do
 		sendSuccess =<< local (checkContentPresent key)
 		return ServerContinue
-	handler (REMOVE key) = do
-		sendSuccess =<< local (removeContent key)
-		return ServerContinue
-	handler (PUT af key) = do
-		have <- local $ checkContentPresent key
-		if have
-			then net $ sendMessage ALREADY_HAVE
-			else do
-				let sizer = tmpContentSize key
-				let storer = storeContent key af
-				ok <- receiveContent nullMeterUpdate sizer storer PUT_FROM
-				when ok $
-					local $ setPresent key myuuid
-		return ServerContinue
+	handler (REMOVE key) = case servermode of
+		ServeReadWrite -> do
+			sendSuccess =<< local (removeContent key)
+			return ServerContinue
+		ServeReadOnly -> do
+			readonlyerror
+			return ServerContinue
+	handler (PUT af key) = case servermode of
+		ServeReadWrite -> do
+			have <- local $ checkContentPresent key
+			if have
+				then net $ sendMessage ALREADY_HAVE
+				else do
+					let sizer = tmpContentSize key
+					let storer = storeContent key af
+					ok <- receiveContent nullMeterUpdate sizer storer PUT_FROM
+					when ok $
+						local $ setPresent key myuuid
+			return ServerContinue
+		ServeReadOnly -> do
+			readonlyerror
+			return ServerContinue
 	handler (GET offset key af) = do
 		void $ sendContent af key offset nullMeterUpdate
 		-- setPresent not called because the peer may have
 		-- requested the data but not permanently stored it.
 		return ServerContinue
 	handler (CONNECT service) = do
-		net $ relayService service
+		let goahead = net $ relayService service
+		case (servermode, service) of
+			(ServeReadWrite, _) -> goahead
+			(ServeReadOnly, UploadPack) -> goahead
+			(ServeReadOnly, ReceivePack) -> readonlyerror
 		-- After connecting to git, there may be unconsumed data
 		-- from the git processes hanging around (even if they
 		-- exited successfully), so stop serving this connection.
diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs
index 623ff03e3..133aba1ec 100644
--- a/RemoteDaemon/Transport/Tor.hs
+++ b/RemoteDaemon/Transport/Tor.hs
@@ -128,7 +128,7 @@ serveClient th u r q = bracket setup cleanup start
 	authed conn theiruuid = 
 		bracket watchChangedRefs (liftIO . maybe noop stopWatchingChangedRefs) $ \crh -> do
 			v' <- runFullProto (Serving theiruuid crh) conn $
-				P2P.serveAuthed u
+				P2P.serveAuthed P2P.ServeReadWrite u
 			case v' of
 				Right () -> return ()
 				Left e -> liftIO $ debugM "remotedaemon" ("Tor connection error: " ++ e)