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.

3 files changed, 92 insertions, 45 deletions

diff --git a/debian/changelog b/debian/changelog
index d26e007c..086c82c0 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,5 +1,7 @@
 propellor (4.0.6) UNRELEASED; urgency=medium
 
+  * Fix bug that sometimes made --spin fail with 
+    "fatal: Couldn't find remote ref HEAD"
   * Display error and warning messages to stderr, not stdout.
 
  -- Joey Hess <id@joeyh.name>  Sun, 18 Jun 2017 16:19:41 -0400
diff --git a/doc/todo/spin_failure_HEAD.mdwn b/doc/todo/spin_failure_HEAD.mdwn
index af525f61..f838e469 100644
--- a/doc/todo/spin_failure_HEAD.mdwn
+++ b/doc/todo/spin_failure_HEAD.mdwn
@@ -51,7 +51,6 @@ Sending privdata (73139 bytes) to kite.kitenet.net ... done
 [2017-06-18 16:27:13 EDT] received marked GITPUSH
 [2017-06-18 16:27:13 EDT] command line:  GitPush 11 12
 16:27:13.953638 pkt-line.c:80           packet:        fetch< 3a3c8a731d169a2768dd243581803dcb7b275049 HEAD\0multi_ack thin-pack side-band side-band-64k ofs-delta shallow deepen-since deepen-not deepen-relative no-progress include-tag multi_ack_detailed symref=HEAD:refs/heads/joeyconfig agent=git/2.11.0
-16:27:13.953638 pkt-line.c:80           packet:        fetch< 3a3c8a731d169a2768dd243581803dcb7b275049 HEAD\0multi_ack thin-pack side-band side-band-64k ofs-delta shallow deepen-since deepen-not deepen-relative no-progress include-tag multi_ack_detailed symref=HEAD:refs/heads/joeyconfig agent=git/2.11.0
 16:27:13.953781 pkt-line.c:80           packet:        fetch< 86b077b7a21efd5484dfaeee3c31fc5f3c151f6c refs/heads/confpairs
 16:27:13.953789 pkt-line.c:80           packet:        fetch< e03e4bf0f1e557f87d1fe7e01a6de7866296fce6 refs/heads/d-i
 16:27:13.953795 pkt-line.c:80           packet:        fetch< 3a3c8a731d169a2768dd243581803dcb7b275049 refs/heads/joeyconfig
@@ -94,7 +93,35 @@ Sending privdata (73139 bytes) to kite.kitenet.net ... done
 > > * Could be in gitPushHelper, perhaps it's failing to write
 > >   some of the first lines somehow?
 > > * Could be something on the remote side is consuming stdin
-> >   that is not supposed to, and eats some of the protocol.a
+> >   that is not supposed to, and eats some of the protocol.
+> > 
 > > 
 > > I added debug dumping to gitPushHelper, and it seems to be
-> > reading the same truncated data.
+> > reading the same truncated data, so it seems the problem is not there.
+> > 
+> > Aha! The problem comes from stdin/stdInput confusion here:
+
+		req NeedGitPush gitPushMarker $ \_ -> do
+			hin <- dup stdInput
+			hout <- dup stdOutput
+			hClose stdin
+			hClose stdout
+
+> > A line read from stdin just before the dup gets the first line of the protocol
+> > as expected. But reading from stdInput starts with a later line. 
+> > Apparently data is being buffered in the stdin Handle, so gitPushHelper,
+> > which reads from the Fd, does not see it.
+> >
+> > Here's a simple test case. Feeding this 2 lines on stdin will
+> > print the first and then fail with "hGetLine: end of file".
+> > The second line is lost in the buffer. This test case behaves
+> > like that reliably, so I'm surprised propellor only fails sometimes.
+
+	main = do
+	        l <- hGetLine stdin
+	        print l
+	        bob <- fdToHandle stdInput
+	        l2 <- hGetLine bob
+	        print l2
+
+> > [[fixed|done]] --[[Joey]]
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