Fix bug that sometimes made --spin fail with "fatal: Couldn't find remote ref HEAD"

Tricky stdin buffering problem.

An easier fix would have been:

	hSetBuffering stdin NoBuffering

But that approach is less robust; even with NoBuffering, anything that
uses hLookAhead causes 1 byte of buffering. And, any reads from stdin
before hSetBuffering would still cause the problem. Instead, I used a
bigger hammer that will always work. It involves a bit more CPU work,
but this is data that is already being fed through ssh; copying it one
more time won't cause a measurable performance impact.

This commit was sponsored by Jack Hill on Patreon.

1 files changed, 60 insertions, 42 deletions

diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index d0ce4d03..cc5fa0e8 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -186,26 +186,8 @@ update forhost = do
 		writeFileProtected privfile
 
 	whenM hasGitRepo $
-		req NeedGitPush gitPushMarker $ \_ -> do
-			hin <- dup stdInput
-			hout <- dup stdOutput
-			hClose stdin
-			hClose stdout
-			-- Not using git pull because git 2.5.0 badly
-			-- broke its option parser.
-			unlessM (boolSystemNonConcurrent "git" (pullparams hin hout)) $
-				errorMessage "git fetch from client failed"
-			unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $
-				errorMessage "git merge from client failed"
+		gitPullFromUpdateServer
   where
-	pullparams hin hout =
-		[ Param "fetch"
-		, Param "--progress"
-		, Param "--upload-pack"
-		, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
-		, Param "."
-		]
-
 	-- When --spin --relay is run, get a privdata file
 	-- to be relayed to the target host.
 	privfile = maybe privDataLocal privDataRelay forhost
@@ -336,29 +318,6 @@ sendPrecompiled hn = void $ actionMessage "Uploading locally compiled propellor
 		, "rm -f " ++ remotetarball
 		]
 
--- Shim for git push over the propellor ssh channel.
--- Reads from stdin and sends it to hout;
--- reads from hin and sends it to stdout.
-gitPushHelper :: Fd -> Fd -> IO ()
-gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout
-  where
-	fromstdin = do
-		h <- fdToHandle hout
-		connect stdin h
-	tostdout = do
-		h <- fdToHandle hin
-		connect h stdout
-	connect fromh toh = do
-		b <- B.hGetSome fromh 40960
-		if B.null b
-			then do
-				hClose fromh
-				hClose toh
-			else do
-				B.hPut toh b
-				hFlush toh
-				connect fromh toh
-
 mergeSpin :: IO ()
 mergeSpin = do
 	branch <- getCurrentBranch
@@ -386,3 +345,62 @@ findLastNonSpinCommit = do
 
 spinCommitMessage :: String
 spinCommitMessage = "propellor spin"
+
+-- Stdin and stdout are connected to the updateServer over ssh.
+-- Request that it run git upload-pack, and connect that up to a git fetch
+-- to receive the data.
+gitPullFromUpdateServer :: IO ()
+gitPullFromUpdateServer = req NeedGitPush gitPushMarker $ \_ -> do
+	-- IO involving stdin can cause data to be buffered in the Handle
+	-- (even when it's set NoBuffering), but we need to pass a FD to 
+	-- git fetch containing all of stdin after the gitPushMarker,
+	-- including any that has been buffered.
+	--
+	-- To do so, create a pipe, and forward stdin, including any
+	-- buffered part, through it.
+	(pread, pwrite) <- System.Posix.IO.createPipe
+	hwrite <- fdToHandle pwrite
+	_ <- async $ stdin *>* hwrite
+	let hin = pread
+	hout <- dup stdOutput
+	hClose stdout
+	-- Not using git pull because git 2.5.0 badly
+	-- broke its option parser.
+	unlessM (boolSystemNonConcurrent "git" (fetchparams hin hout)) $
+		errorMessage "git fetch from client failed"
+	unlessM (boolSystemNonConcurrent "git" [Param "merge", Param "FETCH_HEAD"]) $
+		errorMessage "git merge from client failed"
+  where
+	fetchparams hin hout =
+		[ Param "fetch"
+		, Param "--progress"
+		, Param "--upload-pack"
+		, Param $ "./propellor --gitpush " ++ show hin ++ " " ++ show hout
+		, Param "."
+		]
+
+-- Shim for git push over the propellor ssh channel.
+-- Reads from stdin and sends it to hout;
+-- reads from hin and sends it to stdout.
+gitPushHelper :: Fd -> Fd -> IO ()
+gitPushHelper hin hout = void $ fromstdin `concurrently` tostdout
+  where
+	fromstdin = do
+		h <- fdToHandle hout
+		stdin *>* h
+	tostdout = do
+		h <- fdToHandle hin
+		h *>* stdout
+
+-- Forward data from one handle to another.
+(*>*) :: Handle -> Handle -> IO ()
+fromh *>* toh = do
+	b <- B.hGetSome fromh 40960
+	if B.null b
+		then do
+			hClose fromh
+			hClose toh
+		else do
+			B.hPut toh b
+			hFlush toh
+			fromh *>* toh