diff options
| author |  Joey Hess <joey@kitenet.net> | 2012-07-18 15:30:26 -0400 |
|---|---|---|
| committer | Joey Hess <joey@kitenet.net> | 2012-07-18 18:00:24 -0400 |
| commit | d1da9cf221aeea5c7ac8a313a18b559791a04f12 (patch) | |
| tree | fe8d7e42efb89441d14ab8d5d71bb8f0f007330b | |
| parent | fc5652c811a9a644bb8964b3b8c13df24f2ec7c7 (diff) | |
switch from System.Cmd.Utils to System.Process
Test suite now passes with -threaded!
I traced back all the hangs with -threaded to System.Cmd.Utils. It seems
it's just crappy/unsafe/outdated, and should not be used. System.Process
seems to be the cool new thing, so converted all the code to use it
instead.
In the process, --debug stopped printing commands it runs. I may try to
bring that back later.
Note that even SafeSystem was switched to use System.Process. Since that
was a modified version of code from System.Cmd.Utils, it needed to be
converted too. I also got rid of nearly all calls to forkProcess,
and all calls to executeFile, which I'm also doubtful about working
well with -threaded.
| -rw-r--r-- | Annex/Branch.hs | 4 | ||||
| -rw-r--r-- | Annex/UUID.hs | 6 | ||||
| -rw-r--r-- | Backend/SHA.hs | 17 | ||||
| -rw-r--r-- | Build/Configure.hs | 4 | ||||
| -rw-r--r-- | Command/Fsck.hs | 2 | ||||
| -rw-r--r-- | Command/Map.hs | 11 | ||||
| -rw-r--r-- | Common.hs | 3 | ||||
| -rw-r--r-- | Config.hs | 6 | ||||
| -rw-r--r-- | Git/Branch.hs | 2 | ||||
| -rw-r--r-- | Git/CatFile.hs | 12 | ||||
| -rw-r--r-- | Git/CheckAttr.hs | 4 | ||||
| -rw-r--r-- | Git/Command.hs | 29 | ||||
| -rw-r--r-- | Git/Config.hs | 14 | ||||
| -rw-r--r-- | Git/Queue.hs | 17 | ||||
| -rw-r--r-- | Git/Ref.hs | 5 | ||||
| -rw-r--r-- | Git/UpdateIndex.hs | 7 | ||||
| -rw-r--r-- | Remote/Bup.hs | 6 | ||||
| -rw-r--r-- | Remote/Git.hs | 14 | ||||
| -rw-r--r-- | Remote/Hook.hs | 17 | ||||
| -rw-r--r-- | Remote/Rsync.hs | 1 | ||||
| -rw-r--r-- | System/Cmd/.Utils.hs.swp | bin | 36864 -> 0 bytes | |||
| -rw-r--r-- | System/Cmd/Utils.hs | 568 | ||||
| -rw-r--r-- | Utility/CoProcess.hs | 14 | ||||
| -rw-r--r-- | Utility/Gpg.hs | 39 | ||||
| -rw-r--r-- | Utility/INotify.hs | 8 | ||||
| -rw-r--r-- | Utility/Lsof.hs | 7 | ||||
| -rw-r--r-- | Utility/Process.hs | 40 | ||||
| -rw-r--r-- | Utility/SafeCommand.hs | 49 | ||||
| -rw-r--r-- | Utility/TempFile.hs | 2 | ||||
| -rw-r--r-- | doc/todo/assistant_threaded_runtime.mdwn | 3 | ||||
| -rw-r--r-- | git-annex.cabal | 6 | ||||
| -rw-r--r-- | test.hs | 1 |
32 files changed, 178 insertions, 740 deletions
diff --git a/Annex/Branch.hs b/Annex/Branch.hs index e551bfcd0..8e7f45a4a 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -164,9 +164,7 @@ get' staleok file = fromcache =<< getCache file fromjournal Nothing | staleok = withIndex frombranch | otherwise = withIndexUpdate $ frombranch >>= cache - frombranch = do - liftIO $ putStrLn $ "frombranch " ++ file - L.unpack <$> catFile fullname file + frombranch = L.unpack <$> catFile fullname file cache content = do setCache file content return content diff --git a/Annex/UUID.hs b/Annex/UUID.hs index 517840fba..1d2175bcb 100644 --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -20,6 +20,8 @@ module Annex.UUID ( removeRepoUUID, ) where +import System.Process + import Common.Annex import qualified Git import qualified Git.Config @@ -32,8 +34,10 @@ configkey = annexConfig "uuid" {- Generates a UUID. There is a library for this, but it's not packaged, - so use the command line tool. -} genUUID :: IO UUID -genUUID = pOpen ReadFromPipe command params $ liftM toUUID . hGetLine +genUUID = gen . lines <$> readProcess command params [] where + gen [] = error $ "no output from " ++ command + gen (l:_) = toUUID l command = SysConfig.uuid params -- request a random uuid be generated diff --git a/Backend/SHA.hs b/Backend/SHA.hs index cf61139e0..a1dd1cf64 100644 --- a/Backend/SHA.hs +++ b/Backend/SHA.hs @@ -12,6 +12,7 @@ import qualified Annex import Types.Backend import Types.Key import Types.KeySource +import System.Process import qualified Build.SysConfig as SysConfig import Data.Digest.Pure.SHA @@ -53,14 +54,16 @@ shaN shasize file filesize = do showAction "checksum" case shaCommand shasize filesize of Left sha -> liftIO $ sha <$> L.readFile file - Right command -> liftIO $ runcommand command + Right command -> liftIO $ parse command . lines <$> + readProcess command (toCommand [File file]) "" where - runcommand command = - pOpen ReadFromPipe command (toCommand [File file]) $ \h -> do - sha <- fst . separate (== ' ') <$> hGetLine h - if null sha - then error $ command ++ " parse error" - else return sha + parse command [] = bad command + parse command (l:_) + | null sha = bad command + | otherwise = sha + where + sha = fst $ separate (== ' ') l + bad command = error $ command ++ " parse error" shaCommand :: SHASize -> Integer -> Either (L.ByteString -> String) String shaCommand shasize filesize diff --git a/Build/Configure.hs b/Build/Configure.hs index cf6623b22..9468e1704 100644 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -4,7 +4,7 @@ module Build.Configure where import System.Directory import Data.List -import System.Cmd.Utils +import System.Process import Control.Applicative import System.FilePath @@ -71,7 +71,7 @@ getVersionString = do getGitVersion :: Test getGitVersion = do - (_, s) <- pipeFrom "git" ["--version"] + s <- readProcess "git" ["--version"] "" let version = unwords $ drop 2 $ words $ head $ lines s return $ Config "gitversion" (StringConfig version) diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 10cca489b..0e3cc934c 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -7,6 +7,8 @@ module Command.Fsck where +import System.Posix.Process (getProcessID) + import Common.Annex import Command import qualified Annex diff --git a/Command/Map.hs b/Command/Map.hs index 0773f6828..f69b88a5d 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -9,6 +9,7 @@ module Command.Map where import Control.Exception.Extensible import qualified Data.Map as M +import System.Process import Common.Annex import Command @@ -198,9 +199,13 @@ tryScan r case result of Left _ -> return Nothing Right r' -> return $ Just r' - pipedconfig cmd params = safely $ - pOpen ReadFromPipe cmd (toCommand params) $ - Git.Config.hRead r + pipedconfig cmd params = safely $ do + (_, Just h, _, pid) <- + createProcess (proc cmd $ toCommand params) + { std_out = CreatePipe } + r' <- Git.Config.hRead r h + forceSuccessProcess pid cmd $ toCommand params + return r' configlist = onRemote r (pipedconfig, Nothing) "configlist" [] [] @@ -13,16 +13,15 @@ import Data.String.Utils as X import System.Path as X import System.FilePath as X import System.Directory as X -import System.Cmd.Utils as X hiding (safeSystem) import System.IO as X hiding (FilePath) import System.Posix.Files as X import System.Posix.IO as X -import System.Posix.Process as X hiding (executeFile) import System.Exit as X import Utility.Misc as X import Utility.Exception as X import Utility.SafeCommand as X +import Utility.Process as X import Utility.Path as X import Utility.Directory as X import Utility.Monad as X @@ -7,6 +7,8 @@ module Config where +import System.Process + import Common.Annex import qualified Git import qualified Git.Config @@ -56,7 +58,7 @@ remoteCost r def = do cmd <- getRemoteConfig r "cost-command" "" (fromMaybe def . readish) <$> if not $ null cmd - then liftIO $ snd <$> pipeFrom "sh" ["-c", cmd] + then liftIO $ readProcess "sh" ["-c", cmd] "" else getRemoteConfig r "cost" "" cheapRemoteCost :: Int @@ -116,4 +118,4 @@ getHttpHeaders = do cmd <- getConfig (annexConfig "http-headers-command") "" if null cmd then fromRepo $ Git.Config.getList "annex.http-headers" - else lines . snd <$> liftIO (pipeFrom "sh" ["-c", cmd]) + else lines <$> liftIO (readProcess "sh" ["-c", cmd] "") diff --git a/Git/Branch.hs b/Git/Branch.hs index 6f3d25186..4d239d8fc 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -76,9 +76,7 @@ commit message branch parentrefs repo = do sha <- getSha "commit-tree" $ pipeWriteRead (map Param $ ["commit-tree", show tree] ++ ps) message repo - print ("got", sha) run "update-ref" [Param $ show branch, Param $ show sha] repo - print ("update-ref done", sha) return sha where ps = concatMap (\r -> ["-p", show r]) parentrefs diff --git a/Git/CatFile.hs b/Git/CatFile.hs index e8f362685..e667b2087 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -50,16 +50,11 @@ catObjectDetails :: CatFileHandle -> Ref -> IO (Maybe (L.ByteString, Sha)) catObjectDetails h object = CoProcess.query h send receive where send to = do - putStrLn "catObjectDetails send start" fileEncoding to hPutStrLn to $ show object - putStrLn $ "catObjectDetails send done " ++ show object receive from = do - putStrLn "catObjectDetails read header start" fileEncoding from - putStrLn "catObjectDetails read header start2" header <- hGetLine from - putStrLn "catObjectDetails read header done" case words header of [sha, objtype, size] | length sha == shaSize && @@ -72,14 +67,9 @@ catObjectDetails h object = CoProcess.query h send receive | header == show object ++ " missing" -> dne | otherwise -> error $ "unknown response from git cat-file " ++ show (header, object) readcontent bytes from sha = do - putStrLn "readcontent start" content <- S.hGet from bytes - putStrLn "readcontent end" c <- hGetChar from - putStrLn "readcontent newline read" when (c /= '\n') $ error "missing newline from git cat-file" return $ Just (L.fromChunks [content], Ref sha) - dne = do - putStrLn "dne" - return Nothing + dne = return Nothing diff --git a/Git/CheckAttr.hs b/Git/CheckAttr.hs index 7636ea641..6b321f8b8 100644 --- a/Git/CheckAttr.hs +++ b/Git/CheckAttr.hs @@ -44,15 +44,11 @@ checkAttr (h, attrs, cwd) want file = do _ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file where send to = do - putStrLn "checkAttr send start" fileEncoding to hPutStr to $ file' ++ "\0" - putStrLn "checkAttr send end" receive from = forM attrs $ \attr -> do - putStrLn "checkAttr receive start" fileEncoding from l <- hGetLine from - putStrLn "checkAttr receive end" return (attr, attrvalue attr l) {- Before git 1.7.7, git check-attr worked best with - absolute filenames; using them worked around some bugs diff --git a/Git/Command.hs b/Git/Command.hs index 9a09300e2..038824f26 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -7,10 +7,8 @@ module Git.Command where -import qualified Data.Text.Lazy as L -import qualified Data.Text.Lazy.IO as L -import Control.Concurrent -import Control.Exception (finally) +import System.Process +import System.Posix.Process (getAnyProcessStatus) import Common import Git @@ -44,31 +42,18 @@ run subcommand params repo = assertLocal repo $ -} pipeRead :: [CommandParam] -> Repo -> IO String pipeRead params repo = assertLocal repo $ do - (_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine params repo + (_, Just h, _, _) <- createProcess + (proc "git" $ toCommand $ gitCommandLine params repo) + { std_out = CreatePipe } fileEncoding h hGetContents h -{- Runs a git subcommand, feeding it input. - - You should call either getProcessStatus or forceSuccess on the PipeHandle. -} -pipeWrite :: [CommandParam] -> L.Text -> Repo -> IO PipeHandle -pipeWrite params s repo = assertLocal repo $ do - (p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo) - L.hPutStr h s - hClose h - return p - {- Runs a git subcommand, feeding it input, and returning its output, - which is expected to be fairly small, since it's all read into memory - strictly. -} pipeWriteRead :: [CommandParam] -> String -> Repo -> IO String -pipeWriteRead params s repo = assertLocal repo $ do - (p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine params repo) - fileEncoding to - fileEncoding from - _ <- forkIO $ finally (hPutStr to s) (hClose to) - c <- hGetContentsStrict from - forceSuccess p - return c +pipeWriteRead params s repo = assertLocal repo $ + readProcess "git" (toCommand $ gitCommandLine params repo) s {- Reads null terminated output of a git command (as enabled by the -z - parameter), and splits it. -} diff --git a/Git/Config.hs b/Git/Config.hs index c9e4f9a2d..234750113 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -9,6 +9,7 @@ module Git.Config where import qualified Data.Map as M import Data.Char +import System.Process import Common import Git @@ -39,7 +40,7 @@ reRead :: Repo -> IO Repo reRead = read' {- Cannot use pipeRead because it relies on the config having been already - - read. Instead, chdir to the repo. + - read. Instead, chdir to the repo and run git config. -} read' :: Repo -> IO Repo read' repo = go repo @@ -47,9 +48,14 @@ read' repo = go repo go Repo { location = Local { gitdir = d } } = git_config d go Repo { location = LocalUnknown d } = git_config d go _ = assertLocal repo $ error "internal" - git_config d = bracketCd d $ - pOpen ReadFromPipe "git" ["config", "--null", "--list"] $ - hRead repo + git_config d = do + (_, Just h, _, pid) + <- createProcess (proc "git" params) + { std_out = CreatePipe, cwd = Just d } + repo' <- hRead repo h + forceSuccessProcess pid "git" params + return repo' + params = ["config", "--null", "--list"] {- Reads git config from a handle and populates a repo with it. -} hRead :: Repo -> Handle -> IO Repo diff --git a/Git/Queue.hs b/Git/Queue.hs index ddcf13519..4e6f05c2e 100644 --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -19,7 +19,7 @@ module Git.Queue ( import qualified Data.Map as M import System.IO -import System.Cmd.Utils +import System.Process import Data.String.Utils import Utility.SafeCommand @@ -148,11 +148,14 @@ runAction :: Repo -> Action -> IO () runAction repo (UpdateIndexAction streamers) = -- list is stored in reverse order Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers -runAction repo action@(CommandAction {}) = - pOpen WriteToPipe "xargs" ("-0":"git":params) feedxargs +runAction repo action@(CommandAction {}) = do + (Just h, _, _, pid) <- createProcess (proc "xargs" params) + { std_in = CreatePipe } + fileEncoding h + hPutStr h $ join "\0" $ getFiles action + hClose h + forceSuccessProcess pid "xargs" params where - params = toCommand $ gitCommandLine + params = "-0":"git":baseparams + baseparams = toCommand $ gitCommandLine (Param (getSubcommand action):getParams action) repo - feedxargs h = do - fileEncoding h - hPutStr h $ join "\0" $ getFiles action diff --git a/Git/Ref.hs b/Git/Ref.hs index 3052d0a6e..ee2f02187 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -40,10 +40,7 @@ exists ref = runBool "show-ref" {- Get the sha of a fully qualified git ref, if it exists. -} sha :: Branch -> Repo -> IO (Maybe Sha) -sha branch repo = do - r <- process <$> showref repo - print r - return r +sha branch repo = process <$> showref repo where showref = pipeRead [Param "show-ref", Param "--hash", -- get the hash diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index abdc4bcbe..6de0c3ada 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -17,7 +17,7 @@ module Git.UpdateIndex ( stageSymlink ) where -import System.Cmd.Utils +import System.Process import Common import Git @@ -37,12 +37,13 @@ pureStreamer !s = \streamer -> streamer s {- Streams content into update-index from a list of Streamers. -} streamUpdateIndex :: Repo -> [Streamer] -> IO () streamUpdateIndex repo as = do - (p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo) + (Just h, _, _, p) <- createProcess (proc "git" ps) { std_in = CreatePipe } fileEncoding h forM_ as (stream h) hClose h - forceSuccess p + forceSuccessProcess p "git" ps where + ps = toCommand $ gitCommandLine params repo params = map Param ["update-index", "-z", "--index-info"] stream h a = a (streamer h) streamer h s = do diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 0d1b606d3..9da374174 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -136,9 +136,11 @@ retrieveEncrypted :: BupRepo -> (Cipher, Key) -> Key -> FilePath -> Annex Bool retrieveEncrypted buprepo (cipher, enck) _ f = do let params = bupParams "join" buprepo [Param $ bupRef enck] liftIO $ catchBoolIO $ do - (pid, h) <- hPipeFrom "bup" $ toCommand params + (_, Just h, _, pid) + <- createProcess (proc "bup" $ toCommand params) + { std_out = CreatePipe } withDecryptedContent cipher (L.hGetContents h) $ L.writeFile f - forceSuccess pid + forceSuccessProcess pid "bup" $ toCommand params return True remove :: Key -> Annex Bool diff --git a/Remote/Git.hs b/Remote/Git.hs index d80f580fc..a9a6d6004 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -9,6 +9,7 @@ module Remote.Git (remote, repoAvail) where import qualified Data.Map as M import Control.Exception.Extensible +import System.Process import Common.Annex import Utility.CopyFile @@ -126,17 +127,20 @@ tryGitConfigRead r safely a = either (const $ return r) return =<< liftIO (try a :: IO (Either SomeException Git.Repo)) - pipedconfig cmd params = safely $ - pOpen ReadFromPipe cmd (toCommand params) $ - Git.Config.hRead r + pipedconfig cmd params = safely $ do + (_, Just h, _, pid) <- + createProcess (proc cmd $ toCommand params) + { std_out = CreatePipe } + r' <- Git.Config.hRead r h + forceSuccessProcess pid cmd $ toCommand params + return r' geturlconfig headers = do s <- Url.get (Git.repoLocation r ++ "/config") headers withTempFile "git-annex.tmp" $ \tmpfile h -> do hPutStr h s hClose h - pOpen ReadFromPipe "git" ["config", "--null", "--list", "--file", tmpfile] $ - Git.Config.hRead r + pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile] store = observe $ \r' -> do g <- gitRepo diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 9e8d3c620..cad6e2fc9 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -9,7 +9,6 @@ module Remote.Hook (remote) where import qualified Data.ByteString.Lazy as L import qualified Data.Map as M -import System.Exit import System.Environment import Common.Annex @@ -136,17 +135,5 @@ checkPresent r h k = do findkey s = show k `elem` lines s check Nothing = error "checkpresent hook misconfigured" check (Just hook) = do - (frompipe, topipe) <- createPipe - pid <- forkProcess $ do - _ <- dupTo topipe stdOutput - closeFd frompipe - executeFile "sh" True ["-c", hook] - =<< hookEnv k Nothing - closeFd topipe - fromh <- fdToHandle frompipe - reply <- hGetContentsStrict fromh - hClose fromh - s <- getProcessStatus True False pid - case s of - Just (Exited ExitSuccess) -> return $ findkey reply - _ -> error "checkpresent hook failed" + env <- hookEnv k Nothing + findkey <$> readProcessEnv "sh" ["-c", hook] env diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 29bceb2db..ee516a8a5 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -9,6 +9,7 @@ module Remote.Rsync (remote) where import qualified Data.ByteString.Lazy as L import qualified Data.Map as M +import System.Posix.Process (getProcessID) import Common.Annex import Types.Remote diff --git a/System/Cmd/.Utils.hs.swp b/System/Cmd/.Utils.hs.swp Binary files differdeleted file mode 100644 index 65e9e77e4..000000000 --- a/System/Cmd/.Utils.hs.swp +++ /dev/null diff --git a/System/Cmd/Utils.hs b/System/Cmd/Utils.hs deleted file mode 100644 index a81126146..000000000 --- a/System/Cmd/Utils.hs +++ /dev/null @@ -1,568 +0,0 @@ --- arch-tag: Command utilities main file -{-# LANGUAGE CPP #-} -{- -Copyright (C) 2004-2006 John Goerzen <jgoerzen@complete.org> - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- | - Module : System.Cmd.Utils - Copyright : Copyright (C) 2004-2006 John Goerzen - License : GNU GPL, version 2 or above - - Maintainer : John Goerzen <jgoerzen@complete.org> - Stability : provisional - Portability: portable to platforms with POSIX process\/signal tools - -Command invocation utilities. - -Written by John Goerzen, jgoerzen\@complete.org - -Please note: Most of this module is not compatible with Hugs. - -Command lines executed will be logged using "System.Log.Logger" at the -DEBUG level. Failure messages will be logged at the WARNING level in addition -to being raised as an exception. Both are logged under -\"System.Cmd.Utils.funcname\" -- for instance, -\"System.Cmd.Utils.safeSystem\". If you wish to suppress these messages -globally, you can simply run: - -> updateGlobalLogger "System.Cmd.Utils.safeSystem" -> (setLevel CRITICAL) - -See also: 'System.Log.Logger.updateGlobalLogger', -"System.Log.Logger". - -It is possible to set up pipelines with these utilities. Example: - -> (pid1, x1) <- pipeFrom "ls" ["/etc"] -> (pid2, x2) <- pipeBoth "grep" ["x"] x1 -> putStr x2 -> ... the grep output is displayed ... -> forceSuccess pid2 -> forceSuccess pid1 - -Remember, when you use the functions that return a String, you must not call -'forceSuccess' until after all data from the String has been consumed. Failure -to wait will cause your program to appear to hang. - -Here is an example of the wrong way to do it: - -> (pid, x) <- pipeFrom "ls" ["/etc"] -> forceSuccess pid -- Hangs; the called program hasn't terminated yet -> processTheData x - -You must instead process the data before calling 'forceSuccess'. - -When using the hPipe family of functions, this is probably more obvious. - -Most of this module will be incompatible with Windows. --} - - -module System.Cmd.Utils(-- * High-Level Tools - PipeHandle(..), - safeSystem, -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) - forceSuccess, -#ifndef __HUGS__ - posixRawSystem, - forkRawSystem, - -- ** Piping with lazy strings - pipeFrom, - pipeLinesFrom, - pipeTo, - pipeBoth, - -- ** Piping with handles - hPipeFrom, - hPipeTo, - hPipeBoth, -#endif -#endif - -- * Low-Level Tools - PipeMode(..), -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ - pOpen, pOpen3, pOpen3Raw -#endif -#endif - ) -where - --- FIXME - largely obsoleted by 6.4 - convert to wrappers. - -import System.Exit -import System.Cmd -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -import System.Posix.IO -import System.Posix.Process -import System.Posix.Signals -import qualified System.Posix.Signals -#endif -import System.Posix.Types -import System.IO -import System.IO.Error -import Control.Concurrent(forkIO) -import Control.Exception(finally) - -data PipeMode = ReadFromPipe | WriteToPipe - -logbase :: String -logbase = "System.Cmd.Utils" - -{- | Return value from 'pipeFrom', 'pipeLinesFrom', 'pipeTo', or -'pipeBoth'. Contains both a ProcessID and the original command that was -executed. If you prefer not to use 'forceSuccess' on the result of one -of these pipe calls, you can use (processID ph), assuming ph is your 'PipeHandle', -as a parameter to 'System.Posix.Process.getProcessStatus'. -} -data PipeHandle = - PipeHandle { processID :: ProcessID, - phCommand :: FilePath, - phArgs :: [String], - phCreator :: String -- ^ Function that created it - } - deriving (Eq, Show) - -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ -{- | Like 'pipeFrom', but returns data in lines instead of just a String. -Shortcut for calling lines on the result from 'pipeFrom'. - -Note: this function logs as pipeFrom. - -Not available on Windows. -} -pipeLinesFrom :: FilePath -> [String] -> IO (PipeHandle, [String]) -pipeLinesFrom fp args = - do (pid, c) <- pipeFrom fp args - return $ (pid, lines c) -#endif -#endif - -logRunning :: String -> FilePath -> [String] -> IO () -logRunning func fp args = return () --debugM (logbase ++ "." ++ func) (showCmd fp args) - -warnFail :: [Char] -> FilePath -> [String] -> [Char] -> IO t -warnFail funcname fp args msg = - let m = showCmd fp args ++ ": " ++ msg - in do putStrLn m - fail m - -ddd s a = do - putStrLn $ s ++ " start" - r <- a - putStrLn $ s ++ " end" - return r - -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ -{- | Read data from a pipe. Returns a Handle and a 'PipeHandle'. - -When done, you must hClose the handle, and then use either 'forceSuccess' or -getProcessStatus on the 'PipeHandle'. Zombies will result otherwise. - -This function logs as pipeFrom. - -Not available on Windows or with Hugs. --} -hPipeFrom :: FilePath -> [String] -> IO (PipeHandle, Handle) -hPipeFrom fp args = - ddd (show ("hPipeFrom", fp, args)) $ do - pipepair <- createPipe - let childstuff = do dupTo (snd pipepair) stdOutput - closeFd (fst pipepair) - executeFile fp True args Nothing - p <- try (forkProcess childstuff) - -- parent - pid <- case p of - Right x -> return x - Left e -> warnFail "pipeFrom" fp args $ - "Error in fork: " ++ show e - closeFd (snd pipepair) - h <- fdToHandle (fst pipepair) - return (PipeHandle pid fp args "pipeFrom", h) -#endif -#endif - -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ -{- | Read data from a pipe. Returns a lazy string and a 'PipeHandle'. - -ONLY AFTER the string has been read completely, You must call either -'System.Posix.Process.getProcessStatus' or 'forceSuccess' on the 'PipeHandle'. -Zombies will result otherwise. - -Not available on Windows. --} -pipeFrom :: FilePath -> [String] -> IO (PipeHandle, String) -pipeFrom fp args = - do (pid, h) <- hPipeFrom fp args - c <- hGetContents h - return (pid, c) -#endif -#endif - -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ -{- | Write data to a pipe. Returns a 'PipeHandle' and a new Handle to write -to. - -When done, you must hClose the handle, and then use either 'forceSuccess' or -getProcessStatus on the 'PipeHandle'. Zombies will result otherwise. - -This function logs as pipeTo. - -Not available on Windows. --} -hPipeTo :: FilePath -> [String] -> IO (PipeHandle, Handle) -hPipeTo fp args = - ddd "hPipeTo" $ do - pipepair <- createPipe - let childstuff = do dupTo (fst pipepair) stdInput - closeFd (snd pipepair) - executeFile fp True args Nothing - p <- try (forkProcess childstuff) - -- parent - pid <- case p of - Right x -> return x - Left e -> warnFail "pipeTo" fp args $ - "Error in fork: " ++ show e - closeFd (fst pipepair) - h <- fdToHandle (snd pipepair) - return (PipeHandle pid fp args "pipeTo", h) -#endif -#endif - -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ -{- | Write data to a pipe. Returns a ProcessID. - -You must call either -'System.Posix.Process.getProcessStatus' or 'forceSuccess' on the ProcessID. -Zombies will result otherwise. - -Not available on Windows. --} -pipeTo :: FilePath -> [String] -> String -> IO PipeHandle -pipeTo fp args message = - do (pid, h) <- hPipeTo fp args - finally (hPutStr h message) - (hClose h) - return pid -#endif -#endif - -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ -{- | Like a combination of 'hPipeTo' and 'hPipeFrom'; returns -a 3-tuple of ('PipeHandle', Data From Pipe, Data To Pipe). - -When done, you must hClose both handles, and then use either 'forceSuccess' or -getProcessStatus on the 'PipeHandle'. Zombies will result otherwise. - -Hint: you will usually need to ForkIO a thread to handle one of the Handles; -otherwise, deadlock can result. - -This function logs as pipeBoth. - -Not available on Windows. --} -hPipeBoth :: FilePath -> [String] -> IO (PipeHandle, Handle, Handle) -hPipeBoth fp args = - ddd (show ("hPipeBoth", fp, args)) $ do - frompair <- createPipe - topair <- createPipe - let childstuff = do dupTo (snd frompair) stdOutput - closeFd (fst frompair) - dupTo (fst topair) stdInput - closeFd (snd topair) - executeFile fp True args Nothing - p <- try (forkProcess childstuff) - -- parent - pid <- case p of - Right x -> return x - Left e -> warnFail "pipeBoth" fp args $ - "Error in fork: " ++ show e - closeFd (snd frompair) - closeFd (fst topair) - fromh <- fdToHandle (fst frompair) - toh <- fdToHandle (snd topair) - return (PipeHandle pid fp args "pipeBoth", fromh, toh) -#endif -#endif - -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ -{- | Like a combination of 'pipeTo' and 'pipeFrom'; forks an IO thread -to send data to the piped program, and simultaneously returns its output -stream. - -The same note about checking the return status applies here as with 'pipeFrom'. - -Not available on Windows. -} -pipeBoth :: FilePath -> [String] -> String -> IO (PipeHandle, String) -pipeBoth fp args message = - do (pid, fromh, toh) <- hPipeBoth fp args - forkIO $ finally (hPutStr toh message) - (hClose toh) - c <- hGetContents fromh - return (pid, c) -#endif -#endif - -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -{- | Uses 'System.Posix.Process.getProcessStatus' to obtain the exit status -of the given process ID. If the process terminated normally, does nothing. -Otherwise, raises an exception with an appropriate error message. - -This call will block waiting for the given pid to terminate. - -Not available on Windows. -} -forceSuccess :: PipeHandle -> IO () -forceSuccess (PipeHandle pid fp args funcname) = - let warnfail = warnFail funcname - in do status <- getProcessStatus True False pid - case status of - Nothing -> warnfail fp args $ "Got no process status" - Just (Exited (ExitSuccess)) -> return () - Just (Exited (ExitFailure fc)) -> - cmdfailed funcname fp args fc - Just (Terminated sig) -> - warnfail fp args $ "Terminated by signal " ++ show sig - Just (Stopped sig) -> - warnfail fp args $ "Stopped by signal " ++ show sig -#endif - -{- | Invokes the specified command in a subprocess, waiting for the result. -If the command terminated successfully, return normally. Otherwise, -raises a userError with the problem. - -Implemented in terms of 'posixRawSystem' where supported, and System.Posix.rawSystem otherwise. --} -safeSystem :: FilePath -> [String] -> IO () -safeSystem command args = - ddd "safeSystem" $ do -#if defined(__HUGS__) || defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__) - ec <- rawSystem command args - case ec of - ExitSuccess -> return () - ExitFailure fc -> cmdfailed "safeSystem" command args fc -#else - ec <- posixRawSystem command args - case ec of - Exited ExitSuccess -> return () - Exited (ExitFailure fc) -> cmdfailed "safeSystem" command args fc - Terminated s -> cmdsignalled "safeSystem" command args s - Stopped s -> cmdsignalled "safeSystem" command args s -#endif - -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ -{- | Invokes the specified command in a subprocess, waiting for the result. -Return the result status. Never raises an exception. Only available -on POSIX platforms. - -Like system(3), this command ignores SIGINT and SIGQUIT and blocks SIGCHLD -during its execution. - -Logs as System.Cmd.Utils.posixRawSystem -} -posixRawSystem :: FilePath -> [String] -> IO ProcessStatus -posixRawSystem program args = - ddd "posixRawSystem" $ do - oldint <- installHandler sigINT Ignore Nothing - oldquit <- installHandler sigQUIT Ignore Nothing - let sigset = addSignal sigCHLD emptySignalSet - oldset <- getSignalMask - blockSignals sigset - childpid <- forkProcess (childaction oldint oldquit oldset) - - mps <- getProcessStatus True False childpid - restoresignals oldint oldquit oldset - let retval = case mps of - Just x -> x - Nothing -> error "Nothing returned from getProcessStatus" - return retval - - where childaction oldint oldquit oldset = - do restoresignals oldint oldquit oldset - executeFile program True args Nothing - restoresignals oldint oldquit oldset = - do installHandler sigINT oldint Nothing - installHandler sigQUIT oldquit Nothing - setSignalMask oldset - -#endif -#endif - -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ -{- | Invokes the specified command in a subprocess, without waiting for -the result. Returns the PID of the subprocess -- it is YOUR responsibility -to use getProcessStatus or getAnyProcessStatus on that at some point. Failure -to do so will lead to resource leakage (zombie processes). - -This function does nothing with signals. That too is up to you. - -Logs as System.Cmd.Utils.forkRawSystem -} -forkRawSystem :: FilePath -> [String] -> IO ProcessID -forkRawSystem program args = ddd "forkRawSystem" $ - do - forkProcess childaction - where - childaction = executeFile program True args Nothing - -#endif -#endif - -cmdfailed :: String -> FilePath -> [String] -> Int -> IO a -cmdfailed funcname command args failcode = do - let errormsg = "Command " ++ command ++ " " ++ (show args) ++ - " failed; exit code " ++ (show failcode) - let e = userError (errormsg) - putStrLn errormsg - ioError e - -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ -cmdsignalled :: String -> FilePath -> [String] -> Signal -> IO a -cmdsignalled funcname command args failcode = do - let errormsg = "Command " ++ command ++ " " ++ (show args) ++ - " failed due to signal " ++ (show failcode) - let e = userError (errormsg) - putStrLn errormsg - ioError e -#endif -#endif - -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ -{- | Open a pipe to the specified command. - -Passes the handle on to the specified function. - -The 'PipeMode' specifies what you will be doing. That is, specifing 'ReadFromPipe' -sets up a pipe from stdin, and 'WriteToPipe' sets up a pipe from stdout. - -Not available on Windows. - -} -pOpen :: PipeMode -> FilePath -> [String] -> - (Handle -> IO a) -> IO a -pOpen pm fp args func = ddd "pOpen" $ - do - pipepair <- createPipe - case pm of - ReadFromPipe -> do - let callfunc _ = do - closeFd (snd pipepair) - h <- fdToHandle (fst pipepair) - x <- func h - hClose h - return $! x - pOpen3 Nothing (Just (snd pipepair)) Nothing fp args - callfunc (closeFd (fst pipepair)) - WriteToPipe -> do - let callfunc _ = do - closeFd (fst pipepair) - h <- fdToHandle (snd pipepair) - x <- func h - hClose h - return $! x - pOpen3 (Just (fst pipepair)) Nothing Nothing fp args - callfunc (closeFd (snd pipepair)) -#endif -#endif - -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ -{- | Runs a command, redirecting things to pipes. - -Not available on Windows. - -Note that you may not use the same fd on more than one item. If you -want to redirect stdout and stderr, dup it first. --} -pOpen3 :: Maybe Fd -- ^ Send stdin to this fd - -> Maybe Fd -- ^ Get stdout from this fd - -> Maybe Fd -- ^ Get stderr from this fd - -> FilePath -- ^ Command to run - -> [String] -- ^ Command args - -> (ProcessID -> IO a) -- ^ Action to run in parent - -> IO () -- ^ Action to run in child before execing (if you don't need something, set this to @return ()@) -- IGNORED IN HUGS - -> IO a -pOpen3 pin pout perr fp args func childfunc = ddd (show ("pOpen3", fp, args)) $ - do pid <- pOpen3Raw pin pout perr fp args childfunc - putStrLn "got pid" - retval <- func $! pid - putStrLn "got retval" - let rv = seq retval retval - forceSuccess (PipeHandle (seq retval pid) fp args "pOpen3") - putStrLn "process finished" - return rv -#endif -#endif - -#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)) -#ifndef __HUGS__ -{- | Runs a command, redirecting things to pipes. - -Not available on Windows. - -Returns immediately with the PID of the child. Using 'waitProcess' on it -is YOUR responsibility! - -Note that you may not use the same fd on more than one item. If you -want to redirect stdout and stderr, dup it first. --} -pOpen3Raw :: Maybe Fd -- ^ Send stdin to this fd - -> Maybe Fd -- ^ Get stdout from this fd - -> Maybe Fd -- ^ Get stderr from this fd - -> FilePath -- ^ Command to run - -> [String] -- ^ Command args - -> IO () -- ^ Action to run in child before execing (if you don't need something, set this to @return ()@) -- IGNORED IN HUGS - -> IO ProcessID -pOpen3Raw pin pout perr fp args childfunc = - let mayberedir Nothing _ = return () - mayberedir (Just fromfd) tofd = do - dupTo fromfd tofd - closeFd fromfd - return () - childstuff = do - mayberedir pin stdInput - mayberedir pout stdOutput - mayberedir perr stdError - childfunc - executeFile fp True args Nothing -{- - realfunc p = do - System.Posix.Signals.installHandler - System.Posix.Signals.sigPIPE - System.Posix.Signals.Ignore - Nothing - func p --} - in - ddd "pOpen3Raw" $ - do - p <- try (forkProcess childstuff) - pid <- case p of - Right x -> return x - Left e -> fail ("Error in fork: " ++ (show e)) - return pid - -#endif -#endif - -showCmd :: FilePath -> [String] -> String -showCmd fp args = fp ++ " " ++ show args diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs index 9fa8d864f..d3b0c46ef 100644 --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -13,23 +13,25 @@ module Utility.CoProcess ( query ) where -import System.Cmd.Utils +import System.Process import Common -type CoProcessHandle = (PipeHandle, Handle, Handle) +type CoProcessHandle = (ProcessHandle, Handle, Handle, FilePath, [String]) start :: FilePath -> [String] -> IO CoProcessHandle -start command params = hPipeBoth command params +start command params = do + (from, to, _err, pid) <- runInteractiveProcess command params Nothing Nothing + return (pid, to, from, command, params) stop :: CoProcessHandle -> IO () -stop (pid, from, to) = do +stop (pid, from, to, command, params) = do hClose to hClose from - forceSuccess pid + forceSuccessProcess pid command params query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b -query (_, from, to) send receive = do +query (_, from, to, _, _) send receive = do _ <- send to hFlush to receive from diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index e13afe5d4..26ac688e3 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -11,9 +11,9 @@ import qualified Data.ByteString.Lazy as L import System.Posix.Types import Control.Applicative import Control.Concurrent -import Control.Exception (finally, bracket) -import System.Exit +import Control.Exception (bracket) import System.Posix.Env (setEnv, unsetEnv, getEnv) +import System.Process import Common @@ -39,18 +39,30 @@ stdParams params = do readStrict :: [CommandParam] -> IO String readStrict params = do params' <- stdParams params - pOpen ReadFromPipe "gpg" params' hGetContentsStrict + (_, Just from, _, pid) + <- createProcess (proc "gpg" params') + { std_out = CreatePipe } + hSetBinaryMode from True + r <- hGetContentsStrict from + forceSuccessProcess pid "gpg" params' + return r {- Runs gpg, piping an input value to it, and returning its stdout, - strictly. -} pipeStrict :: [CommandParam] -> String -> IO String pipeStrict params input = do params' <- stdParams params - (pid, fromh, toh) <- hPipeBoth "gpg" params' - _ <- forkIO $ finally (hPutStr toh input) (hClose toh) - output <- hGetContentsStrict fromh - forceSuccess pid - return output + (Just to, Just from, _, pid) + <- createProcess (proc "gpg" params') + { std_in = CreatePipe + , std_out = CreatePipe } + hSetBinaryMode to True + hSetBinaryMode from True + hPutStr to input + hClose to + r <- hGetContentsStrict from + forceSuccessProcess pid "gpg" params' + return r {- Runs gpg with some parameters, first feeding it a passphrase via - --passphrase-fd, then feeding it an input, and passing a handle @@ -70,17 +82,14 @@ passphraseHandle params passphrase a b = do let passphrasefd = [Param "--passphrase-fd", Param $ show pfd] params' <- stdParams $ passphrasefd ++ params - (pid, fromh, toh) <- hPipeBoth "gpg" params' - pid2 <- forkProcess $ do - L.hPut toh =<< a - hClose toh - exitSuccess + (Just toh, Just fromh, _, pid) <- createProcess (proc "gpg" params') + { std_in = CreatePipe, std_out = CreatePipe } + L.hPut toh =<< a hClose toh ret <- b fromh -- cleanup - forceSuccess pid - _ <- getProcessStatus True False pid2 + forceSuccessProcess pid "gpg" params' closeFd frompipe return ret diff --git a/Utility/INotify.hs b/Utility/INotify.hs index bf87f4e71..55233ef76 100644 --- a/Utility/INotify.hs +++ b/Utility/INotify.hs @@ -10,6 +10,7 @@ module Utility.INotify where import Common hiding (isDirectory) import Utility.ThreadLock import Utility.Types.DirWatcher +import System.Process import System.INotify import qualified System.Posix.Files as Files @@ -160,12 +161,9 @@ tooManyWatches hook dir = do querySysctl :: Read a => [CommandParam] -> IO (Maybe a) querySysctl ps = do - v <- catchMaybeIO $ hPipeFrom "sysctl" $ toCommand ps + v <- catchMaybeIO $ readProcess "sysctl" (toCommand ps) [] case v of Nothing -> return Nothing - Just (pid, h) -> do - val <- parsesysctl <$> hGetContentsStrict h - void $ getProcessStatus True False $ processID pid - return val + Just s -> return $ parsesysctl s where parsesysctl s = readish =<< lastMaybe (words s) diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs index 0061dfe57..ebd273b2e 100644 --- a/Utility/Lsof.hs +++ b/Utility/Lsof.hs @@ -12,6 +12,7 @@ module Utility.Lsof where import Common import System.Posix.Types +import System.Process data LsofOpenMode = OpenReadWrite | OpenReadOnly | OpenWriteOnly | OpenUnknown deriving (Show, Eq) @@ -34,10 +35,8 @@ queryDir path = query ["+d", path] -} query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)] query opts = do - (pid, s) <- pipeFrom "lsof" ("-F0can" : opts) - let !r = parse s - void $ getProcessStatus True False $ processID pid - return r + (_, s, _) <- readProcessWithExitCode "lsof" ("-F0can" : opts) [] + return $ parse s {- Parsing null-delimited output like: - diff --git a/Utility/Process.hs b/Utility/Process.hs new file mode 100644 index 000000000..9f79efa81 --- /dev/null +++ b/Utility/Process.hs @@ -0,0 +1,40 @@ +{- System.Process enhancements + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Utility.Process where + +import System.Process +import System.Exit +import System.IO + +import Utility.Misc + +{- Waits for a ProcessHandle, and throws an exception if the process + - did not exit successfully. -} +forceSuccessProcess :: ProcessHandle -> String -> [String] -> IO () +forceSuccessProcess pid cmd args = do + code <- waitForProcess pid + case code of + ExitSuccess -> return () + ExitFailure n -> error $ + cmd ++ " " ++ show args ++ " exited " ++ show n + +{- Like readProcess, but allows specifying the environment, and does + - not mess with stdin. -} +readProcessEnv :: FilePath -> [String] -> Maybe [(String, String)] -> IO String +readProcessEnv cmd args environ = do + (_, Just h, _, pid) + <- createProcess (proc cmd args) + { std_in = Inherit + , std_out = CreatePipe + , std_err = Inherit + , env = environ + } + output <- hGetContentsStrict h + hClose h + forceSuccessProcess pid cmd args + return output diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs index 5f6a53e71..47280a40b 100644 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -1,6 +1,6 @@ {- safely running shell commands - - - Copyright 2010-2011 Joey Hess <joey@kitenet.net> + - Copyright 2010-2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -8,11 +8,8 @@ module Utility.SafeCommand where import System.Exit -import qualified System.Posix.Process -import System.Posix.Process hiding (executeFile) -import System.Posix.Signals +import System.Process import Data.String.Utils -import System.Log.Logger import Control.Applicative {- A type for parameters passed to a shell command. A command can @@ -42,7 +39,7 @@ boolSystem :: FilePath -> [CommandParam] -> IO Bool boolSystem command params = boolSystemEnv command params Nothing boolSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool -boolSystemEnv command params env = dispatch <$> safeSystemEnv command params env +boolSystemEnv command params environ = dispatch <$> safeSystemEnv command params environ where dispatch ExitSuccess = True dispatch _ = False @@ -51,41 +48,13 @@ boolSystemEnv command params env = dispatch <$> safeSystemEnv command params env safeSystem :: FilePath -> [CommandParam] -> IO ExitCode safeSystem command params = safeSystemEnv command params Nothing -{- SIGINT(ctrl-c) is allowed to propigate and will terminate the program. -} +{- Unlike many implementations of system, SIGINT(ctrl-c) is allowed + - to propigate and will terminate the program. -} safeSystemEnv :: FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO ExitCode -safeSystemEnv command params env = do - putStrLn "safeSystemEnv start" - -- Going low-level because all the high-level system functions - -- block SIGINT etc. We need to block SIGCHLD, but allow - -- SIGINT to do its default program termination. - let sigset = addSignal sigCHLD emptySignalSet - oldint <- installHandler sigINT Default Nothing - oldset <- getSignalMask - blockSignals sigset - childpid <- forkProcess $ childaction oldint oldset - mps <- getProcessStatus True False childpid - restoresignals oldint oldset - case mps of - Just (Exited code) -> do - putStrLn "safeSystemEnv end" - return code - _ -> error $ "unknown error running " ++ command - where - restoresignals oldint oldset = do - _ <- installHandler sigINT oldint Nothing - setSignalMask oldset - childaction oldint oldset = do - restoresignals oldint oldset - executeFile command True (toCommand params) env - -{- executeFile with debug logging -} -executeFile :: FilePath -> Bool -> [String] -> Maybe [(String, String)] -> IO () -executeFile c path p e = do - putStrLn "executeFile start" - --debugM "Utility.SafeCommand.executeFile" $ - -- "Running: " ++ c ++ " " ++ show p ++ " " ++ maybe "" show e - System.Posix.Process.executeFile c path p e - putStrLn "executeFile end" +safeSystemEnv command params environ = do + (_, _, _, pid) <- createProcess (proc command $ toCommand params) + { env = environ } + waitForProcess pid {- Escapes a filename or other parameter to be safely able to be exposed to - the shell. -} diff --git a/Utility/TempFile.hs b/Utility/TempFile.hs index 4dcbf1cca..62e0fc859 100644 --- a/Utility/TempFile.hs +++ b/Utility/TempFile.hs @@ -9,7 +9,7 @@ module Utility.TempFile where import Control.Exception (bracket) import System.IO -import System.Posix.Process hiding (executeFile) +import System.Posix.Process import System.Directory import Utility.Exception diff --git a/doc/todo/assistant_threaded_runtime.mdwn b/doc/todo/assistant_threaded_runtime.mdwn index edfa51669..412f52ae8 100644 --- a/doc/todo/assistant_threaded_runtime.mdwn +++ b/doc/todo/assistant_threaded_runtime.mdwn @@ -23,6 +23,9 @@ git-annex does not otherwise use threads, so this is surprising. --[[Joey]] > I've spent a lot of time debugging this, and trying to fix it, in the > "threaded" branch. There are still deadlocks. --[[Joey]] +>> Fixed, by switching from `System.Cmd.Utils` to `System.Process` +>> --[[Joey]] + --- It would be possible to not use the threaded runtime. Instead, we could diff --git a/git-annex.cabal b/git-annex.cabal index 3f237ce70..e58bd4d95 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -40,11 +40,12 @@ Executable git-annex unix, containers, utf8-string, network, mtl, bytestring, old-locale, time, pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP, base == 4.5.*, monad-control, transformers-base, lifted-base, - IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance + IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process -- Need to list this because it's generated from a .hsc file. Other-Modules: Utility.Touch C-Sources: Utility/libdiskfree.c Extensions: CPP + GHC-Options: -threaded if flag(S3) Build-Depends: hS3 @@ -65,10 +66,11 @@ Test-Suite test unix, containers, utf8-string, network, mtl, bytestring, old-locale, time, pcre-light, extensible-exceptions, dataenc, SHA, process, json, HTTP, base == 4.5.*, monad-control, transformers-base, lifted-base, - IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance + IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process Other-Modules: Utility.Touch C-Sources: Utility/libdiskfree.c Extensions: CPP + GHC-Options: -threaded source-repository head type: git @@ -14,6 +14,7 @@ import Test.QuickCheck import System.Posix.Directory (changeWorkingDirectory) import System.Posix.Files import System.Posix.Env +import System.Posix.Process import Control.Exception.Extensible import qualified Data.Map as M import System.IO.HVFS (SystemFS(..)) |