From 438dbe3b660063919073571d04bb7776c10cece2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 4 Jun 2020 12:13:26 -0400 Subject: [PATCH] convert to withCreateProcess for async exception safety This handles all sites where checkSuccessProcess/ignoreFailureProcess is used, except for one: Git.Command.pipeReadLazy That one will be significantly more work to convert to bracketing. (Also skipped Command.Assistant.autoStart, but it does not need to shut down the processes it started on exception because they are git-annex assistant daemons..) forceSuccessProcess is done, except for createProcessSuccess. All call sites of createProcessSuccess will need to be converted to bracketing. (process pools still todo also) --- Annex/YoutubeDl.hs | 16 +++++++---- Assistant/Restart.hs | 6 ++-- Assistant/Threads/RemoteControl.hs | 25 +++++++++++------ Git/CatFile.hs | 12 ++++---- Git/Command.hs | 18 +++++++----- Git/Fsck.hs | 44 ++++++++++++++++-------------- Git/UpdateIndex.hs | 22 +++++++++------ Remote/Bup.hs | 14 +++++++--- Remote/Ddar.hs | 14 +++++++--- Remote/Glacier.hs | 8 ++++-- Utility/Gpg.hs | 13 +++++---- Utility/Lsof.hs | 13 ++++++--- Utility/Process.hs | 7 ----- 13 files changed, 125 insertions(+), 87 deletions(-) diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs index 64ca3fbf42..6868f53174 100644 --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -205,12 +205,14 @@ youtubeDlFileNameHtmlOnly' url uo , Param "--no-warnings" , Param "--no-playlist" ] - (Nothing, Just o, Just e, pid) <- liftIO $ createProcess - (proc "youtube-dl" (toCommand opts)) - { std_out = CreatePipe - , std_err = CreatePipe - } - output <- liftIO $ fmap fst $ + let p = (proc "youtube-dl" (toCommand opts)) + { std_out = CreatePipe + , std_err = CreatePipe + } + liftIO $ withCreateProcess p waitproc + + waitproc Nothing (Just o) (Just e) pid = do + output <- fmap fst $ hGetContentsStrict o `concurrently` hGetContentsStrict e @@ -218,6 +220,8 @@ youtubeDlFileNameHtmlOnly' url uo return $ case (ok, lines output) of (True, (f:_)) | not (null f) -> Right f _ -> nomedia + waitproc _ _ _ _ = error "internal" + nomedia = Left "no media in url" youtubeDlOpts :: [CommandParam] -> Annex [CommandParam] diff --git a/Assistant/Restart.hs b/Assistant/Restart.hs index ef8477ead1..ec34c52181 100644 --- a/Assistant/Restart.hs +++ b/Assistant/Restart.hs @@ -113,7 +113,5 @@ assistantListening url = catchBoolIO $ do startAssistant :: FilePath -> IO () startAssistant repo = void $ forkIO $ do program <- programPath - (_, _, _, pid) <- - createProcess $ - (proc program ["assistant"]) { cwd = Just repo } - void $ checkSuccessProcess pid + let p = (proc program ["assistant"]) { cwd = Just repo } + withCreateProcess p $ \_ _ _ pid -> void $ checkSuccessProcess pid diff --git a/Assistant/Threads/RemoteControl.hs b/Assistant/Threads/RemoteControl.hs index 5a0339eef4..51f5e4b9b4 100644 --- a/Assistant/Threads/RemoteControl.hs +++ b/Assistant/Threads/RemoteControl.hs @@ -32,20 +32,27 @@ remoteControlThread = namedThread "RemoteControl" $ do (cmd, params) <- liftIO $ toBatchCommand (program, [Param "remotedaemon", Param "--foreground"]) let p = proc cmd (toCommand params) - (Just toh, Just fromh, _, pid) <- liftIO $ createProcess p + bracket (setup p) cleanup (go p) + where + setup p = liftIO $ createProcess $ p { std_in = CreatePipe , std_out = CreatePipe } - - urimap <- liftIO . newMVar =<< liftAnnex getURIMap + cleanup = liftIO . cleanupProcess - controller <- asIO $ remoteControllerThread toh - responder <- asIO $ remoteResponderThread fromh urimap + go p (Just toh, Just fromh, _, pid) = do + urimap <- liftIO . newMVar =<< liftAnnex getURIMap - -- run controller and responder until the remotedaemon dies - liftIO $ void $ tryNonAsync $ controller `concurrently` responder - debug ["remotedaemon exited"] - liftIO $ forceSuccessProcess p pid + controller <- asIO $ remoteControllerThread toh + responder <- asIO $ remoteResponderThread fromh urimap + + -- run controller and responder until the remotedaemon dies + liftIO $ void $ tryNonAsync $ + controller `concurrently` responder + debug ["remotedaemon exited"] + liftIO $ forceSuccessProcess p pid + go _ _ = error "internal" + -- feed from the remoteControl channel into the remotedaemon remoteControllerThread :: Handle -> Assistant () diff --git a/Git/CatFile.hs b/Git/CatFile.hs index 1769e5788a..cd4d8576e1 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -180,14 +180,16 @@ querySingle o r repo reader = assertLocal repo $ , std_in = Inherit , std_out = CreatePipe } - pid <- createProcess p' - let h = stdoutHandle pid - output <- reader h - hClose h - ifM (checkSuccessProcess (processHandle pid)) + withCreateProcess p' go + where + go _ (Just outh) _ pid = do + output <- reader outh + hClose outh + ifM (checkSuccessProcess pid) ( return (Just output) , return Nothing ) + go _ _ _ _ = error "internal" querySize :: Ref -> Repo -> IO (Maybe FileSize) querySize r repo = maybe Nothing (readMaybe . takeWhile (/= '\n')) diff --git a/Git/Command.hs b/Git/Command.hs index 15157a08a5..27688e2ca1 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -1,6 +1,6 @@ {- running git commands - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -70,13 +70,17 @@ pipeReadStrict = pipeReadStrict' S.hGetContents {- The reader action must be strict. -} pipeReadStrict' :: (Handle -> IO a) -> [CommandParam] -> Repo -> IO a -pipeReadStrict' reader params repo = assertLocal repo $ - withHandle StdoutHandle (createProcessChecked ignoreFailureProcess) p $ \h -> do - output <- reader h - hClose h - return output +pipeReadStrict' reader params repo = assertLocal repo $ withCreateProcess p go where - p = gitCreateProcess params repo + p = (gitCreateProcess params repo) + { std_out = CreatePipe } + + go _ (Just outh) _ pid = do + output <- reader outh + hClose outh + void $ waitForProcess pid + return output + go _ _ _ _ = error "internal" {- Runs a git command, feeding it an input, and returning its output, - which is expected to be fairly small, since it's all read into memory diff --git a/Git/Fsck.hs b/Git/Fsck.hs index 69a9e9f81e..5206b35888 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -77,27 +77,31 @@ findBroken batchmode r = do then toBatchCommand (command, params) else return (command, params) - p@(_, _, _, pid) <- createProcess $ - (proc command' (toCommand params')) - { std_out = CreatePipe - , std_err = CreatePipe - } - (o1, o2) <- concurrently - (parseFsckOutput maxobjs r (stdoutHandle p)) - (parseFsckOutput maxobjs r (stderrHandle p)) - fsckok <- checkSuccessProcess pid - case mappend o1 o2 of - FsckOutput badobjs truncated - | S.null badobjs && not fsckok -> return FsckFailed - | otherwise -> return $ FsckFoundMissing badobjs truncated - NoFsckOutput - | not fsckok -> return FsckFailed - | otherwise -> return noproblem - -- If all fsck output was duplicateEntries warnings, - -- the repository is not broken, it just has some unusual - -- tree objects in it. So ignore nonzero exit status. - AllDuplicateEntriesWarning -> return noproblem + let p = (proc command' (toCommand params')) + { std_out = CreatePipe + , std_err = CreatePipe + } + withCreateProcess p go where + go _ (Just outh) (Just errh) pid = do + (o1, o2) <- concurrently + (parseFsckOutput maxobjs r outh) + (parseFsckOutput maxobjs r errh) + fsckok <- checkSuccessProcess pid + case mappend o1 o2 of + FsckOutput badobjs truncated + | S.null badobjs && not fsckok -> return FsckFailed + | otherwise -> return $ FsckFoundMissing badobjs truncated + NoFsckOutput + | not fsckok -> return FsckFailed + | otherwise -> return noproblem + -- If all fsck output was duplicateEntries warnings, + -- the repository is not broken, it just has some + -- unusual tree objects in it. So ignore nonzero + -- exit status. + AllDuplicateEntriesWarning -> return noproblem + go _ _ _ _ = error "internal" + maxobjs = 10000 noproblem = FsckFoundMissing S.empty False diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index b562bff13e..5d8bbf7135 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -136,15 +136,7 @@ indexPath = toInternalGitPath . getTopFilePath {- Refreshes the index, by checking file stat information. -} refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool -refreshIndex repo feeder = do - (Just h, _, _, p) <- createProcess (gitCreateProcess params repo) - { std_in = CreatePipe } - feeder $ \f -> do - hPutStr h f - hPutStr h "\0" - hFlush h - hClose h - checkSuccessProcess p +refreshIndex repo feeder = withCreateProcess p go where params = [ Param "update-index" @@ -153,3 +145,15 @@ refreshIndex repo feeder = do , Param "-z" , Param "--stdin" ] + + p = (gitCreateProcess params repo) + { std_in = CreatePipe } + + go (Just h) _ _ pid = do + feeder $ \f -> do + hPutStr h f + hPutStr h "\0" + hFlush h + hClose h + checkSuccessProcess pid + go _ _ _ _ = error "internal" diff --git a/Remote/Bup.hs b/Remote/Bup.hs index fda1527115..f51e9e6708 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -164,10 +164,16 @@ store r buprepo = byteStorer $ \k b p -> do retrieve :: BupRepo -> Retriever retrieve buprepo = byteRetriever $ \k sink -> do let params = bupParams "join" buprepo [Param $ bupRef k] - let p = proc "bup" (toCommand params) - (_, Just h, _, pid) <- liftIO $ createProcess $ p { std_out = CreatePipe } - liftIO (hClose h >> forceSuccessProcess p pid) - `after` (sink =<< liftIO (L.hGetContents h)) + let p = (proc "bup" (toCommand params)) + { std_out = CreatePipe } + bracketIO (createProcess p) cleanupProcess (go sink p) + where + go sink p (_, Just h, _, pid) = do + () <- sink =<< liftIO (L.hGetContents h) + liftIO $ do + hClose h + forceSuccessProcess p pid + go _ _ _ = error "internal" {- Cannot revert having stored a key in bup, but at least the data for the - key will be used for deltaing data of other keys stored later. diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index 2cf597660e..de9fe1870a 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -157,10 +157,16 @@ ddarExtractRemoteCall cs ddarrepo k = retrieve :: DdarRepo -> Retriever retrieve ddarrepo = byteRetriever $ \k sink -> do (cmd, params) <- ddarExtractRemoteCall NoConsumeStdin ddarrepo k - let p = (proc cmd $ toCommand params) { std_out = CreatePipe } - (_, Just h, _, pid) <- liftIO $ createProcess p - liftIO (hClose h >> forceSuccessProcess p pid) - `after` (sink =<< liftIO (L.hGetContents h)) + let p = (proc cmd $ toCommand params) + { std_out = CreatePipe } + bracketIO (createProcess p) cleanupProcess (go sink p) + where + go sink p (_, Just h, _, pid) = do + () <- sink =<< liftIO (L.hGetContents h) + liftIO $ do + hClose h + forceSuccessProcess p pid + go _ _ _ = error "internal" remove :: DdarRepo -> Remover remove ddarrepo key = do diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index dfba203b6c..a996170a3e 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -185,14 +185,15 @@ retrieve' r k sink = go =<< glacierEnv c gc u ] go Nothing = giveup "cannot retrieve from glacier" go (Just environ) = do - let cmd = (proc "glacier" (toCommand params)) + let p = (proc "glacier" (toCommand params)) { env = Just environ , std_out = CreatePipe } - (_, Just h, _, pid) <- liftIO $ createProcess cmd + bracketIO (createProcess p) cleanupProcess (go' p) + go' p (_, Just h, _, pid) = do let cleanup = liftIO $ do hClose h - forceSuccessProcess cmd pid + forceSuccessProcess p pid flip finally cleanup $ do -- Glacier cannot store empty files, so if -- the output is empty, the content is not @@ -200,6 +201,7 @@ retrieve' r k sink = go =<< glacierEnv c gc u whenM (liftIO $ hIsEOF h) $ giveup "Content is not available from glacier yet. Recommend you wait up to 4 hours, and then run this command again." sink =<< liftIO (L.hGetContents h) + go' _ _ = error "internal" remove :: Remote -> Remover remove r k = unlessM go $ diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index a371082b56..404fcf362e 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -171,16 +171,19 @@ pipeLazy (GpgCmd cmd) params feeder reader = do , std_out = CreatePipe , std_err = Inherit } - bracket (setup p) (cleanup p) go + bracket (setup p) cleanup (go p) where setup = liftIO . createProcess - cleanup p (_, _, _, pid) = liftIO $ forceSuccessProcess p pid - go p = do - let (to, from) = ioHandles p + cleanup = liftIO . cleanupProcess + + go p (Just to, Just from, _, pid) = do liftIO $ void $ forkIO $ do feeder to hClose to - reader from + r <- reader from + liftIO $ forceSuccessProcess p pid + return r + go _ _ = error "internal" {- Finds gpg public keys matching some string. (Could be an email address, - a key id, or a name; See the section 'HOW TO SPECIFY A USER ID' of diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs index 22d4a0ebfb..5803dcd7f3 100644 --- a/Utility/Lsof.hs +++ b/Utility/Lsof.hs @@ -49,11 +49,16 @@ queryDir path = query ["+d", path] - Note: If lsof is not available, this always returns [] ! -} query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)] -query opts = - withHandle StdoutHandle (createProcessChecked checkSuccessProcess) p $ - parse <$$> hGetContentsStrict +query opts = withCreateProcess p go where - p = proc "lsof" ("-F0can" : opts) + p = (proc "lsof" ("-F0can" : opts)) + { std_out = CreatePipe } + + go _ (Just outh) _ pid = do + r <- parse <$> hGetContentsStrict outh + void $ waitForProcess pid + return r + go _ _ _ _ = error "internal" type LsofParser = String -> [(FilePath, LsofOpenMode, ProcessInfo)] diff --git a/Utility/Process.hs b/Utility/Process.hs index 83229a8051..d7e84c7fd4 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -20,7 +20,6 @@ module Utility.Process ( forceSuccessProcess, forceSuccessProcess', checkSuccessProcess, - ignoreFailureProcess, createProcessSuccess, createProcessChecked, createBackgroundProcess, @@ -53,7 +52,6 @@ import System.Log.Logger import Control.Monad.IO.Class import Control.Concurrent import qualified Control.Exception as E -import Control.Monad import qualified Data.ByteString as S type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a @@ -135,11 +133,6 @@ checkSuccessProcess pid = do code <- waitForProcess pid return $ code == ExitSuccess -ignoreFailureProcess :: ProcessHandle -> IO Bool -ignoreFailureProcess pid = do - void $ waitForProcess pid - return True - -- | Runs createProcess, then an action on its handles, and then -- forceSuccessProcess. createProcessSuccess :: CreateProcessRunner