mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

WIP

Browse source 
for https://git-annex.branchable.com/bugs/Buggy_external_special_remote_stalls_after_7245a9e/
This commit is contained in:
Joey Hess 2020-11-17 17:31:08 -04:00
parent 3dda21d292
commit aafae46bcb
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
4 changed files with 88 additions and 38 deletions
Download patch file Download diff file Expand all files Collapse all files

60
Utility/Metered.hs
View file

@ -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,12 @@ 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 = unlessM (hIsEOF h) $ do
cancelOnExit ph (hGetLine 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 +308,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 +322,32 @@ 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 = unlessM (hIsEOF h) $
cancelOnExit ph (hGetLine 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"