From 92f775eba051d796023798432c53bb0ac2c7b003 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 3 Jun 2020 15:48:09 -0400 Subject: [PATCH] convert to withCreateProcess for async exception safety Not yet 100% done, so far I've grepped for waitForProcess and converted everything that uses that to start the process with withCreateProcess. Except for some things like P2P.IO and Assistant.TransferrerPool, and Utility.CoProcess, that manage a pool of processes. See #2 in https://git-annex.branchable.com/todo/more_extensive_retries_to_mask_transient_failures/#comment-209f8a8c38e63fb3a704e1282cb269c7 for how those will need to be dealt with. checkSuccessProcess, ignoreFailureProcess, and forceSuccessProcess calls waitForProcess, so callers of them will also need to be dealt with, and have not been yet. --- Annex/Init.hs | 7 +++---- Annex/Ssh.hs | 17 +++++++++-------- Command/WebApp.hs | 9 +++++---- Git/GCrypt.hs | 12 ++++++------ Git/History.hs | 27 +++++++++++++++------------ RemoteDaemon/Transport/Ssh.hs | 20 +++++++++++--------- Test.hs | 4 ++-- Test/Framework.hs | 6 +++--- Utility/Process/Transcript.hs | 31 ++++++++++++++----------------- 9 files changed, 68 insertions(+), 65 deletions(-) diff --git a/Annex/Init.hs b/Annex/Init.hs index d7c1ebd9ed..29adf57340 100644 --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -301,15 +301,14 @@ autoEnableSpecialRemotes = do rp <- fromRawFilePath <$> fromRepo Git.repoPath cmd <- liftIO programPath liftIO $ withNullHandle $ \nullh -> do - let p = proc cmd + let p = (proc cmd [ "init" , "--autoenable" - ] - (Nothing, Nothing, Nothing, pid) <- createProcess $ p + ]) { std_out = UseHandle nullh , std_err = UseHandle nullh , std_in = UseHandle nullh , cwd = Just rp } - void $ waitForProcess pid + withCreateProcess p $ \_ _ _ pid -> void $ waitForProcess pid remotesChanged diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index 08af09d056..657c369631 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -258,19 +258,19 @@ prepSocket socketfile sshhost sshparams = do -- (Except there's an unlikely false positive where a forced -- ssh command exits 255.) tryssh extraps = liftIO $ withNullHandle $ \nullh -> do - let p = proc "ssh" $ concat + let p = (proc "ssh" $ concat [ extraps , toCommand sshparams , [fromSshHost sshhost, "true"] - ] - (Nothing, Nothing, Nothing, pid) <- createProcess $ p + ]) { std_out = UseHandle nullh , std_err = UseHandle nullh } - exitcode <- waitForProcess pid - return $ case exitcode of - ExitFailure 255 -> False - _ -> True + withCreateProcess p $ \_ _ _ pid -> do + exitcode <- waitForProcess pid + return $ case exitcode of + ExitFailure 255 -> False + _ -> True {- Find ssh socket files. - @@ -458,7 +458,8 @@ runSshOptions :: [String] -> String -> IO () runSshOptions args s = do let args' = toCommand (fromSshOptionsEnv s) ++ args let p = proc "ssh" args' - exitWith =<< waitForProcess . processHandle =<< createProcess p + exitcode <- withCreateProcess p $ \_ _ _ pid -> waitForProcess pid + exitWith exitcode {- When this env var is set, git-annex is being used as a ssh-askpass - program, and should read the password from the specified location, diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 95bd8af9d4..580a005ee4 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -220,14 +220,15 @@ openBrowser' mcmd htmlshim realurl outh errh = hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url hFlush stdout environ <- cleanEnvironment - (_, _, _, pid) <- createProcess p + let p' = p { env = environ , std_out = maybe Inherit UseHandle outh , std_err = maybe Inherit UseHandle errh } - exitcode <- waitForProcess pid - unless (exitcode == ExitSuccess) $ - hPutStrLn (fromMaybe stderr errh) "failed to start web browser" + withCreateProcess p' $ \_ _ _ pid -> do + exitcode <- waitForProcess pid + unless (exitcode == ExitSuccess) $ + hPutStrLn (fromMaybe stderr errh) "failed to start web browser" {- web.browser is a generic git config setting for a web browser program -} webBrowser :: Git.Repo -> Maybe FilePath diff --git a/Git/GCrypt.hs b/Git/GCrypt.hs index 5b5a2766e2..2c456213b0 100644 --- a/Git/GCrypt.hs +++ b/Git/GCrypt.hs @@ -66,12 +66,12 @@ probeRepo loc baserepo = do , Param "--check" , Param loc ] baserepo - (_, _, _, pid) <- createProcess p - code <- waitForProcess pid - return $ case code of - ExitSuccess -> Decryptable - ExitFailure 1 -> NotDecryptable - ExitFailure _ -> NotEncrypted + withCreateProcess p $ \_ _ _ pid -> do + code <- waitForProcess pid + return $ case code of + ExitSuccess -> Decryptable + ExitFailure 1 -> NotDecryptable + ExitFailure _ -> NotEncrypted type GCryptId = String diff --git a/Git/History.hs b/Git/History.hs index 1b7127229b..9c20e12095 100644 --- a/Git/History.hs +++ b/Git/History.hs @@ -50,19 +50,22 @@ data HistoryCommit = HistoryCommit {- Gets a History starting with the provided commit, and down to the - requested depth. -} getHistoryToDepth :: Integer -> Ref -> Repo -> IO (Maybe (History HistoryCommit)) -getHistoryToDepth n commit r = do - (_, Just inh, _, pid) <- createProcess (gitCreateProcess params r) - { std_out = CreatePipe } - !h <- fmap (truncateHistoryToDepth n) - . build Nothing - . map parsehistorycommit - . map L.toStrict - . L8.lines - <$> L.hGetContents inh - hClose inh - void $ waitForProcess pid - return h +getHistoryToDepth n commit r = withCreateProcess p go where + p = (gitCreateProcess params r) + { std_out = CreatePipe } + go _ (Just inh) _ pid = do + !h <- fmap (truncateHistoryToDepth n) + . build Nothing + . map parsehistorycommit + . map L.toStrict + . L8.lines + <$> L.hGetContents inh + hClose inh + void $ waitForProcess pid + return h + go _ _ _ _ = error "internal" + build h [] = fmap (mapHistory fst) h build _ (Nothing:_) = Nothing build Nothing (Just v:rest) = diff --git a/RemoteDaemon/Transport/Ssh.hs b/RemoteDaemon/Transport/Ssh.hs index e90f5d2227..fbfdc51a21 100644 --- a/RemoteDaemon/Transport/Ssh.hs +++ b/RemoteDaemon/Transport/Ssh.hs @@ -37,14 +37,15 @@ transportUsingCmd cmd params rr@(RemoteRepo r gc) url h@(TransportHandle (LocalR transportUsingCmd' :: FilePath -> [CommandParam] -> Transport transportUsingCmd' cmd params (RemoteRepo r gc) url transporthandle ichan ochan = - robustConnection 1 $ do - (Just toh, Just fromh, Just errh, pid) <- - createProcess (proc cmd (toCommand params)) - { std_in = CreatePipe - , std_out = CreatePipe - , std_err = CreatePipe - } - + robustConnection 1 $ withCreateProcess p go + where + p = (proc cmd (toCommand params)) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + + go (Just toh) (Just fromh) (Just errh) pid = do -- Run all threads until one finishes and get the status -- of the first to finish. Cancel the rest. status <- catchDefaultIO (Right ConnectionClosed) $ @@ -58,7 +59,8 @@ transportUsingCmd' cmd params (RemoteRepo r gc) url transporthandle ichan ochan void $ waitForProcess pid return $ either (either id id) id status - where + go _ _ _ _ = error "internal" + send msg = atomically $ writeTChan ochan msg fetch = do diff --git a/Test.hs b/Test.hs index 0873bb14ed..f6e7d0ce0e 100644 --- a/Test.hs +++ b/Test.hs @@ -135,8 +135,8 @@ runner opts pp <- Annex.Path.programPath Utility.Env.Set.setEnv subenv "1" True ps <- getArgs - (Nothing, Nothing, Nothing, pid) <- createProcess (proc pp ps) - exitcode <- waitForProcess pid + exitcode <- withCreateProcess (proc pp ps) $ + \_ _ _ pid -> waitForProcess pid unless (keepFailuresOption opts) finalCleanup exitWith exitcode runsubprocesstests (Just _) = isolateGitConfig $ do diff --git a/Test/Framework.hs b/Test/Framework.hs index 0b523e554b..bf3a16d287 100644 --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -458,9 +458,9 @@ setTestMode testmode = do ] runFakeSsh :: [String] -> IO () runFakeSsh ("-n":ps) = runFakeSsh ps -runFakeSsh (_host:cmd:[]) = do - (_, _, _, pid) <- createProcess (shell cmd) - exitWith =<< waitForProcess pid +runFakeSsh (_host:cmd:[]) = + withCreateProcess (shell cmd) $ + \_ _ _ pid -> exitWith =<< waitForProcess pid runFakeSsh ps = error $ "fake ssh option parse error: " ++ show ps getTestMode :: IO TestMode diff --git a/Utility/Process/Transcript.hs b/Utility/Process/Transcript.hs index c0ee0b1a16..c35093eee1 100644 --- a/Utility/Process/Transcript.hs +++ b/Utility/Process/Transcript.hs @@ -50,31 +50,28 @@ processTranscript'' cp input = do System.Posix.IO.setFdOption writef System.Posix.IO.CloseOnExec True readh <- System.Posix.IO.fdToHandle readf writeh <- System.Posix.IO.fdToHandle writef - p@(_, _, _, pid) <- createProcess $ cp - { std_in = if isJust input then CreatePipe else Inherit - , std_out = UseHandle writeh - , std_err = UseHandle writeh - } - hClose writeh + withCreateProcess cp $ \hin hout herr pid -> do + hClose writeh - get <- asyncreader readh - writeinput input p - transcript <- wait get + get <- asyncreader readh + writeinput input (hin, hout, herr, pid) + transcript <- wait get #else {- This implementation for Windows puts stderr after stdout. -} - p@(_, _, _, pid) <- createProcess $ cp + let cp' = cp { std_in = if isJust input then CreatePipe else Inherit , std_out = CreatePipe , std_err = CreatePipe } - - getout <- asyncreader (stdoutHandle p) - geterr <- asyncreader (stderrHandle p) - writeinput input p - transcript <- (++) <$> wait getout <*> wait geterr + withCreateProcess cp' \hin hout herr pid -> do + let p = (hin, hout, herr, pid) + getout <- asyncreader (stdoutHandle p) + geterr <- asyncreader (stderrHandle p) + writeinput input p + transcript <- (++) <$> wait getout <*> wait geterr #endif - code <- waitForProcess pid - return (transcript, code) + code <- waitForProcess pid + return (transcript, code) where asyncreader = async . hGetContentsStrict