From dcd77ee5551eaa562ae5a80319c641f29dc4a534 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Tue, 9 Jul 2024 14:26:30 -0400
Subject: [PATCH] fix p2phttp server to not get stuck

Process 1 command, then stop. Hopefully each of the Handlers will only
need 1 command.
---
 P2P/Http/State.hs |  4 +---
 P2P/Protocol.hs   | 31 +++++++++++++++++++++++++------
 2 files changed, 26 insertions(+), 9 deletions(-)

diff --git a/P2P/Http/State.hs b/P2P/Http/State.hs
index f11ef112c2..b8b0c54d1b 100644
--- a/P2P/Http/State.hs
+++ b/P2P/Http/State.hs
@@ -131,9 +131,7 @@ withLocalP2PConnections a = do
 					(const True) h2 h1
 					(ConnIdent (Just "http client"))
 				runst <- liftIO $ mkrunst connparams
-				-- TODO is this right? It needs to exit
-				-- when the client stops sending messages.
-				let server = P2P.serveAuthed
+				let server = P2P.serveOneCommandAuthed
 					(connectionServerMode connparams)
 					(connectionServerUUID connparams)
 				let protorunner = void $
diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs
index 1225801a01..9dcbdba016 100644
--- a/P2P/Protocol.hs
+++ b/P2P/Protocol.hs
@@ -42,6 +42,7 @@ import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Set as S
 import Data.Char
+import Data.Maybe
 import Data.Time.Clock.POSIX
 import Control.Applicative
 import Control.DeepSeq
@@ -472,7 +473,14 @@ data ServerHandler a
 
 -- Server loop, getting messages from the client and handling them
 serverLoop :: (Message -> Proto (ServerHandler a)) -> Proto (Maybe a)
-serverLoop a = do
+serverLoop a = serveOneMessage a serverLoop
+
+-- Get one message from the client and handle it.
+serveOneMessage
+	:: (Message -> Proto (ServerHandler a))
+	-> ((Message -> Proto (ServerHandler a)) -> Proto (Maybe a)) 
+	-> Proto (Maybe a)
+serveOneMessage a cont = do
 	mcmd <- net receiveMessage
 	case mcmd of
 		-- When the client sends ERROR to the server, the server
@@ -480,16 +488,16 @@ serverLoop a = do
 		-- is in, and so not possible to recover.
 		Just (ERROR _) -> return Nothing
 		-- When the client sends an unparsable message, the server
-		-- responds with an error message, and loops. This allows
+		-- responds with an error message, and continues. This allows
 		-- expanding the protocol with new messages.
 		Nothing -> do
 			net $ sendMessage (ERROR "unknown command")
-			serverLoop a
+			cont a
 		Just cmd -> do
 			v <- a cmd
 			case v of
 				ServerGot r -> return (Just r)
-				ServerContinue -> serverLoop a
+				ServerContinue -> cont a
 				-- If the client sends an unexpected message,
 				-- the server will respond with ERROR, and
 				-- always continues processing messages.
@@ -501,7 +509,7 @@ serverLoop a = do
 				-- support some new feature, and fall back.
 				ServerUnexpected -> do
 					net $ sendMessage (ERROR "unexpected command")
-					serverLoop a
+					cont a
 
 -- | Serve the protocol, with an unauthenticated peer. Once the peer
 -- successfully authenticates, returns their UUID.
@@ -530,7 +538,18 @@ data ServerMode
 
 -- | Serve the protocol, with a peer that has authenticated.
 serveAuthed :: ServerMode -> UUID -> Proto ()
-serveAuthed servermode myuuid = void $ serverLoop handler
+serveAuthed servermode myuuid = void $ serverLoop $
+	serverHandler servermode myuuid
+
+-- | Serve a single command in the protocol, the same as serveAuthed,
+-- but without looping to handle the next command.
+serveOneCommandAuthed :: ServerMode -> UUID -> Proto ()
+serveOneCommandAuthed servermode myuuid = fromMaybe () <$>
+	serveOneMessage (serverHandler servermode myuuid) 
+		(const $ pure Nothing)
+
+serverHandler :: ServerMode -> UUID -> Message -> Proto (ServerHandler ())
+serverHandler servermode myuuid = handler
   where
 	handler (VERSION theirversion) = do
 		let v = min theirversion maxProtocolVersion