diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs index 03e7562f58..f025adfa94 100644 --- 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 5206b35888..7440b92272 100644 --- 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 4e7b49c7cc..b76bb3a568 100644 --- 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