Merge branch 'ssh-hates-me'

Annex/ExternalAddonProcess.hs

@@ -53,7 +53,7 @@ startExternalAddonProcess basecmd pid = do
 			Left _ -> runerr cmdpath
 	
 	started cmd errrelayer pall@(Just hin, Just hout, Just herr, ph) = do
-		stderrelay <- async $ errrelayer herr
+		stderrelay <- async $ errrelayer ph herr
 		let shutdown forcestop = do
 			-- Close the process's stdin, to let it know there
 			-- are no more requests, so it will exit.

CHANGELOG

@@ -9,6 +9,9 @@ git-annex (8.20201117) UNRELEASED; urgency=medium
     and for easier scripting.
   * init: When writing hook scripts, set all execute bits, not only
     the user execute bit.
+  * Fix hang when an external special remote program exited but
+    the stderr pipe to it was left open, due to a daemon having inherited
+    the file descriptor.
 
  -- Joey Hess <id@joeyh.name>  Mon, 16 Nov 2020 09:38:32 -0400
 

Messages/Progress.hs

@@ -140,11 +140,11 @@ mkOutputHandlerQuiet = OutputHandler
 	<$> pure True
 	<*> mkStderrEmitter
 
-mkStderrRelayer :: Annex (Handle -> IO ())
+mkStderrRelayer :: Annex (ProcessHandle -> Handle -> IO ())
 mkStderrRelayer = do
 	quiet <- commandProgressDisabled
 	emitter <- mkStderrEmitter
-	return $ \h -> avoidProgress quiet h emitter
+	return $ \ph h -> avoidProgress quiet ph h emitter
 
 {- Generates an IO action that can be used to emit stderr.
  -

Utility/Metered.hs

@@ -49,7 +49,6 @@ import Common
 import Utility.Percentage
 import Utility.DataUnits
 import Utility.HumanTime
-import Utility.ThreadScheduler
 import Utility.SimpleProtocol as Proto
 
 import qualified Data.ByteString.Lazy as L
@@ -266,7 +265,7 @@ commandMeterExitCode progressparser oh meter meterupdate cmd params =
 commandMeterExitCode' :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO (Maybe ExitCode)
 commandMeterExitCode' progressparser oh mmeter meterupdate cmd params mkprocess = 
 	outputFilter cmd params mkprocess Nothing
-		(feedprogress mmeter zeroBytesProcessed [])
+		(const $ feedprogress mmeter zeroBytesProcessed [])
 		handlestderr
   where
 	feedprogress sendtotalsize prev buf h = do
@@ -291,9 +290,11 @@ commandMeterExitCode' progressparser oh mmeter meterupdate cmd params mkprocess
 							meterupdate bytes
 						feedprogress sendtotalsize' bytes buf' h
 
-	handlestderr h = unlessM (hIsEOF h) $ do
-		stderrHandler oh =<< hGetLine h
-		handlestderr h
+	handlestderr ph h = hGetLineUntilExitOrEOF ph h >>= \case
+		Just l -> do
+			stderrHandler oh l
+			handlestderr ph h
+		Nothing -> return ()
 
 {- Runs a command, that may display one or more progress meters on
  - either stdout or stderr, and prevents the meters from being displayed.
@@ -306,8 +307,8 @@ demeterCommand oh cmd params = demeterCommandEnv oh cmd params Nothing
 demeterCommandEnv :: OutputHandler -> FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
 demeterCommandEnv oh cmd params environ = do
 	ret <- outputFilter cmd params id environ
-		(\outh -> avoidProgress True outh stdouthandler)
-		(\errh -> avoidProgress True errh $ stderrHandler oh)
+		(\ph outh -> avoidProgress True ph outh stdouthandler)
+		(\ph errh -> avoidProgress True ph errh $ stderrHandler oh)
 	return $ case ret of
 		Just ExitSuccess -> True
 		_ -> False
@@ -320,44 +321,31 @@ demeterCommandEnv oh cmd params environ = do
  - filter out lines that contain \r (typically used to reset to the
  - beginning of the line when updating a progress display).
  -}
-avoidProgress :: Bool -> Handle -> (String -> IO ()) -> IO ()
-avoidProgress doavoid h emitter = unlessM (hIsEOF h) $ do
-	s <- hGetLine h
-	unless (doavoid && '\r' `elem` s) $
-		emitter s
-	avoidProgress doavoid h emitter
+avoidProgress :: Bool -> ProcessHandle -> Handle -> (String -> IO ()) -> IO ()
+avoidProgress doavoid ph h emitter = hGetLineUntilExitOrEOF ph h >>= \case
+	Just s -> do
+		unless (doavoid && '\r' `elem` s) $
+			emitter s
+		avoidProgress doavoid ph h emitter
+	Nothing -> return ()
 
 outputFilter
 	:: FilePath
 	-> [CommandParam]
 	-> (CreateProcess -> CreateProcess)
 	-> Maybe [(String, String)]
-	-> (Handle -> IO ())
-	-> (Handle -> IO ())
+	-> (ProcessHandle -> Handle -> IO ())
+	-> (ProcessHandle -> Handle -> IO ())
 	-> IO (Maybe ExitCode)
 outputFilter cmd params mkprocess environ outfilter errfilter = 
 	catchMaybeIO $ withCreateProcess p go
   where
-	go _ (Just outh) (Just errh) pid = do
-		outt <- async $ tryIO (outfilter outh) >> hClose outh
-		errt <- async $ tryIO (errfilter errh) >> hClose errh
-		ret <- waitForProcess pid
-
-		-- Normally, now that the process has exited, the threads
-		-- will finish processing its output and terminate.
-		-- But, just in case the process did something evil like
-		-- forking to the background while inheriting stderr,
-		-- it's possible that the threads will not finish, which
-		-- would result in a deadlock. So, wait a few seconds
-		-- maximum for them to finish and then cancel them.
-		-- (One program that has behaved this way in the past is
-		-- openssh.)
-		void $ tryNonAsync $ race_
-			(wait outt >> wait errt)
-			(threadDelaySeconds (Seconds 2))
-		cancel outt
-		cancel errt
-
+	go _ (Just outh) (Just errh) ph = do
+		outt <- async $ tryIO (outfilter ph outh) >> hClose outh
+		errt <- async $ tryIO (errfilter ph errh) >> hClose errh
+		ret <- waitForProcess ph
+		wait outt
+		wait errt
 		return ret
 	go _ _ _ _ = error "internal"
 	

Utility/Process.hs

@@ -6,7 +6,7 @@
  - License: BSD-2-clause
  -}
 
-{-# LANGUAGE CPP, Rank2Types #-}
+{-# LANGUAGE CPP, Rank2Types, LambdaCase #-}
 {-# OPTIONS_GHC -fno-warn-tabs #-}
 
 module Utility.Process (
@@ -24,6 +24,7 @@ module Utility.Process (
 	withCreateProcess,
 	waitForProcess,
 	cleanupProcess,
+	hGetLineUntilExitOrEOF,
 	startInteractiveProcess,
 	stdinHandle,
 	stdoutHandle,
@@ -229,3 +230,92 @@ cleanupProcess (mb_stdin, mb_stdout, mb_stderr, pid) = do
 	maybe (return ()) hClose mb_stderr
 	void $ waitForProcess pid
 #endif
+
+{- | Like hGetLine, reads a line from the Handle. Returns Nothing if end of
+ - file is reached, or the handle is closed, or if the process has exited
+ - and there is nothing more buffered to read from the handle.
+ -
+ - This is useful to protect against situations where the process might
+ - have transferred the handle being read to another process, and so
+ - the handle could remain open after the process has exited. That is a rare
+ - situation, but can happen. Consider a the process that started up a
+ - daemon, and the daemon inherited stderr from it, rather than the more
+ - usual behavior of closing the file descriptor. Reading from stderr
+ - would block past the exit of the process.
+ -
+ - In that situation, this will detect when the process has exited,
+ - and avoid blocking forever. But will still return anything the process
+ - buffered to the handle before exiting.
+ -
+ - Note on newline mode: This ignores whatever newline mode is configured
+ - for the handle, because there is no way to query that. On Windows,
+ - it will remove any \r coming before the \n. On other platforms,
+ - it does not treat \r specially.
+ -}
+hGetLineUntilExitOrEOF :: ProcessHandle -> Handle -> IO (Maybe String)
+hGetLineUntilExitOrEOF ph h = go []
+  where
+	go buf = do
+		ready <- waitforinputorerror smalldelay
+		if ready
+			then getloop buf go
+			else getProcessExitCode ph >>= \case
+				-- Process still running, wait longer.
+				Nothing -> go buf
+				-- Process is done. It's possible
+				-- that it output something and exited
+				-- since the prior hWaitForInput,
+				-- so check one more time for any buffered
+				-- output.
+				Just _ -> finalcheck buf
+
+	finalcheck buf = do
+		ready <- waitforinputorerror 0
+		if ready
+			then getloop buf finalcheck
+			-- No remaining buffered input, though the handle
+			-- may not be EOF if something else is keeping it
+			-- open. Treated the same as EOF.
+			else eofwithnolineend buf
+
+	-- On exception, proceed as if there was input;
+	-- EOF and any encoding issues are dealt with
+	-- when reading from the handle.
+	waitforinputorerror t = hWaitForInput h t
+		`catchNonAsync` const (pure True)
+
+	getchar = 
+		catcherr EOF $
+			-- If the handle is closed, reading from it is
+			-- an IllegalOperation.
+			catcherr IllegalOperation $
+				Just <$> hGetChar h
+	  where
+		catcherr t = catchIOErrorType t (const (pure Nothing))
+
+	getloop buf cont =
+		getchar >>= \case
+			Just c
+				| c == '\n' -> return (Just (gotline buf))
+				| otherwise -> cont (c:buf)
+			Nothing -> eofwithnolineend buf
+
+#ifndef mingw32_HOST_OS
+	gotline buf = reverse buf
+#else
+	gotline ('\r':buf) = reverse buf
+	gotline buf = reverse buf
+#endif
+
+	eofwithnolineend buf = return $
+		if null buf 
+			then Nothing -- no line read
+			else Just (reverse buf)
+
+	-- Tenth of a second delay. If the process exits with the FD being
+	-- held open, will wait up to twice this long before returning.
+	-- This delay could be made smaller. However, that is an unusual
+	-- case, and making it too small would cause lots of wakeups while
+	-- waiting for output. Bearing in mind that this could be run on
+	-- many processes at the same time.
+	smalldelay = 100 -- milliseconds

doc/bugs/Buggy_external_special_remote_stalls_after_7245a9e/comment_4_746ffcf575f91bc3d156b279bcdf8ae2._comment

@@ -0,0 +1,20 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 4"""
+ date="2020-11-18T17:23:21Z"
+ content="""
+Seems the problem with hWaitForInput happens when running it concurrently
+with hGetLine on the same handle. When I run it sequentially, it does seem
+to work. Ok.. I was able to implement hGetLineUntilExitOrEOF that seems to
+work.
+
+I've converted it to use that, and the test case for this bug is fixed.
+Also, the sleep based workaround
+in [[!commit aa492bc65904a19f22ffdfc20d7a5e7052e2f54d]] is removed,
+and it uses hGetLineUntilExitOrEOF instead.
+
+However, I still want to do the audit of other things that pipe stderr.
+Some of them don't do line based input, so will need a different function
+than hGetLineUntilExitOrEOF. Leaving this bug open until that audit is
+done.
+"""]]