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.

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 :: ServerMode -> UUID -> Proto ()
-serveAuthed myuuid = void $ serverLoop handler
+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,10 +370,15 @@ serveAuthed myuuid = void $ serverLoop handler
 	handler (CHECKPRESENT key) = do
 		sendSuccess =<< local (checkContentPresent key)
 		return ServerContinue
-	handler (REMOVE key) = do
+	handler (REMOVE key) = case servermode of
+		ServeReadWrite -> do
 			sendSuccess =<< local (removeContent key)
 			return ServerContinue
-	handler (PUT af key) = do
+		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
@@ -381,13 +389,20 @@ serveAuthed myuuid = void $ serverLoop handler
 					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.

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)