converted reads from stderr to use hGetLineUntilExitOrEOF

These are all unlikely to suffer from the inherited stderr fd problem,
but who knows, it could happen.

diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs
index 03e7562f586e0b09f0ea8f8956f1b674f5b98acc..f025adfa9495d97dbc2f6c876e157e959053e2f5 100644 (file)
--- a/Annex/YoutubeDl.hs
+++ b/Annex/YoutubeDl.hs
@@ -225,16 +225,19 @@ youtubeDlFileNameHtmlOnly' url uo
                liftIO $ withCreateProcess p waitproc
        
        waitproc Nothing (Just o) (Just e) pid = do
-               output <- fmap fst $ 
-                       hGetContentsStrict o
-                               `concurrently`
-                       hGetContentsStrict e
+               errt <- async $ discardstderr pid e
+               output <- hGetContentsStrict o
                ok <- liftIO $ checkSuccessProcess pid
+               wait errt
                return $ case (ok, lines output) of
                        (True, (f:_)) | not (null f) -> Right f
                        _ -> nomedia
        waitproc _ _ _ _ = error "internal"
 
+       discardstderr pid e = hGetLineUntilExitOrEOF pid e >>= \case
+               Nothing -> return ()
+               Just _ -> discardstderr pid e
+
        nomedia = Left "no media in url"
 
 youtubeDlOpts :: [CommandParam] -> Annex [CommandParam]

diff --git a/Git/Fsck.hs b/Git/Fsck.hs
index 5206b358888c6027d6cd2a0296a86e0c5348017e..7440b92272a5673442fff7cb263bb3a045b1d387 100644 (file)
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -85,8 +85,8 @@ findBroken batchmode r = do
   where
        go _ (Just outh) (Just errh) pid = do
                (o1, o2) <- concurrently
-                       (parseFsckOutput maxobjs r outh)
-                       (parseFsckOutput maxobjs r errh)
+                       (parseFsckOutput maxobjs r outh pid)
+                       (parseFsckOutput maxobjs r errh pid)
                fsckok <- checkSuccessProcess pid
                case mappend o1 o2 of
                        FsckOutput badobjs truncated
@@ -121,9 +121,9 @@ knownMissing (FsckFoundMissing s _) = s
 findMissing :: [Sha] -> Repo -> IO MissingObjects
 findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs
 
-parseFsckOutput :: Int -> Repo -> Handle -> IO FsckOutput
-parseFsckOutput maxobjs r h = do
-       ls <- lines <$> hGetContents h
+parseFsckOutput :: Int -> Repo -> Handle -> ProcessHandle -> IO FsckOutput
+parseFsckOutput maxobjs r h pid = do
+       ls <- getlines []
        if null ls
                then return NoFsckOutput
                else if all ("duplicateEntries" `isInfixOf`) ls
@@ -133,6 +133,10 @@ parseFsckOutput maxobjs r h = do
                                let !truncated = length shas > maxobjs
                                missingobjs <- findMissing (take maxobjs shas) r
                                return $ FsckOutput missingobjs truncated
+  where
+       getlines c = hGetLineUntilExitOrEOF pid h >>= \case
+               Nothing -> return (reverse c)
+               Just l -> getlines (l:c)
 
 isMissing :: Sha -> Repo -> IO Bool
 isMissing s r = either (const True) (const False) <$> tryIO dump

diff --git a/Utility/MagicWormhole.hs b/Utility/MagicWormhole.hs
index 4e7b49c7cc4aa262f0fe3488625bc24fb20c7430..b76bb3a568ef6b22597f7eb816486907b7aab4c0 100644 (file)
--- a/Utility/MagicWormhole.hs
+++ b/Utility/MagicWormhole.hs
@@ -113,23 +113,28 @@ sendFile f (CodeObserver observer) ps = do
        -- Work around stupid stdout buffering behavior of python.
        -- See https://github.com/warner/magic-wormhole/issues/108
        environ <- addEntry "PYTHONUNBUFFERED" "1" <$> getEnvironment
-       runWormHoleProcess p { env = Just environ} $ \_hin hout herr -> do
-               (inout, inerr) <- findcode hout `concurrently` findcode herr
+       runWormHoleProcess p { env = Just environ} $ \_hin hout herr ph -> do
+               (inout, inerr) <- concurrently
+                       (findcode ph hout)
+                       (findcode ph herr)
                return (inout || inerr)
   where
        p = wormHoleProcess (Param "send" : ps ++ [File f])
-       findcode h = findcode' =<< words <$> hGetContents h
+       findcode ph h = findcode' =<< getwords ph h []
        findcode' [] = return False
        findcode' (w:ws) = case mkCode w of
                Just code -> do
                        _ <- tryPutMVar observer code
                        return True
                Nothing -> findcode' ws
+       getwords ph h c = hGetLineUntilExitOrEOF ph h >>= \case
+               Nothing -> return $ concatMap words $ reverse c
+               Just l -> getwords ph h (l:c)
 
 -- | Receives a file. Once the receive is under way, the Code will be
 -- read from the CodeProducer, and fed to wormhole on stdin.
 receiveFile :: FilePath -> CodeProducer -> WormHoleParams -> IO Bool
-receiveFile f (CodeProducer producer) ps = runWormHoleProcess p $ \hin _hout _herr -> do
+receiveFile f (CodeProducer producer) ps = runWormHoleProcess p $ \hin _hout _herr _ph -> do
        Code c <- readMVar producer
        hPutStrLn hin c
        hFlush hin
@@ -145,7 +150,7 @@ receiveFile f (CodeProducer producer) ps = runWormHoleProcess p $ \hin _hout _he
 wormHoleProcess :: WormHoleParams -> CreateProcess
 wormHoleProcess = proc "wormhole" . toCommand
 
-runWormHoleProcess :: CreateProcess -> (Handle -> Handle -> Handle -> IO Bool) ->  IO Bool
+runWormHoleProcess :: CreateProcess -> (Handle -> Handle -> Handle -> ProcessHandle -> IO Bool) ->  IO Bool
 runWormHoleProcess p consumer =
        withCreateProcess p' go `catchNonAsync` const (return False)
   where
@@ -155,7 +160,7 @@ runWormHoleProcess p consumer =
                , std_err = CreatePipe
                }
        go (Just hin) (Just hout) (Just herr) pid =
-               consumer hin hout herr <&&> waitbool pid
+               consumer hin hout herr pid <&&> waitbool pid
        go _ _ _ _ = error "internal"
        waitbool pid = do
                r <- waitForProcess pid