From d1da9cf221aeea5c7ac8a313a18b559791a04f12 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 18 Jul 2012 15:30:26 -0400 Subject: [PATCH] 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. --- Annex/Branch.hs | 4 +- Annex/UUID.hs | 6 +- Backend/SHA.hs | 17 +- Build/Configure.hs | 4 +- Command/Fsck.hs | 2 + Command/Map.hs | 11 +- Common.hs | 3 +- Config.hs | 6 +- Git/Branch.hs | 2 - Git/CatFile.hs | 12 +- Git/CheckAttr.hs | 4 - Git/Command.hs | 29 +- Git/Config.hs | 14 +- Git/Queue.hs | 17 +- Git/Ref.hs | 5 +- Git/UpdateIndex.hs | 7 +- Remote/Bup.hs | 6 +- Remote/Git.hs | 14 +- Remote/Hook.hs | 17 +- Remote/Rsync.hs | 1 + System/Cmd/.Utils.hs.swp | Bin 36864 -> 0 bytes System/Cmd/Utils.hs | 568 ----------------------- Utility/CoProcess.hs | 14 +- Utility/Gpg.hs | 39 +- Utility/INotify.hs | 8 +- Utility/Lsof.hs | 7 +- Utility/Process.hs | 40 ++ Utility/SafeCommand.hs | 49 +- Utility/TempFile.hs | 2 +- doc/todo/assistant_threaded_runtime.mdwn | 3 + git-annex.cabal | 6 +- test.hs | 1 + 32 files changed, 178 insertions(+), 740 deletions(-) delete mode 100644 System/Cmd/.Utils.hs.swp delete mode 100644 System/Cmd/Utils.hs create mode 100644 Utility/Process.hs diff --git a/Annex/Branch.hs b/Annex/Branch.hs index e551bfcd01..8e7f45a4ad 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 517840fbad..1d2175bcb6 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 cf61139e00..a1dd1cf648 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 cf6623b226..9468e1704d 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 10cca489b1..0e3cc934c3 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 0773f68283..f69b88a5d6 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" [] [] diff --git a/Common.hs b/Common.hs index 7f07781ce9..04ec1e044e 100644 --- a/Common.hs +++ b/Common.hs @@ -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 diff --git a/Config.hs b/Config.hs index e66947e2cc..84f6125c63 100644 --- a/Config.hs +++ b/Config.hs @@ -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 6f3d251863..4d239d8fc5 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 e8f362685d..e667b20879 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 7636ea6411..6b321f8b8f 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 9a09300e24..038824f268 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 c9e4f9a2dc..2347501131 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 ddcf135197..4e6f05c2e0 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 3052d0a6ef..ee2f021871 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 abdc4bcbe3..6de0c3adab 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 0d1b606d3d..9da374174b 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 d80f580fc5..a9a6d6004e 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 9e8d3c620d..cad6e2fc94 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 29bceb2db8..ee516a8a59 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 deleted file mode 100644 index 65e9e77e4437e33e567a27e7f34f6b8301ca5f47..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 36864 zcmeI53zTFnT26r%!i0tpEy7@r{c2>Jf1y0>pX zW_A{3A=m@o_TyI7ty_=3>i_Gn>e;ntX11wQ(imGc8bJ`BaIp6md zgV%~hzI!I@f!jeoKMQukC?DkW)8SBful@Xoyq|$u0=*LGl|ZiqdL_^+fnEvpN}yK)y%Ok^K(7RPC2){Rz|A|(iQMad z(9320Uu*#1dA8%+1Yd-|g1>}Uz%Pz;oPU5T;B7Dke+;)Cfu0W^h8*<6orhy9fZO0( za2>o3rr}laLU7=7f8;nfz+Cyc-vNW>EdS+E9U-s%=Ud=A5lhY@0Dd$)BdL&l&)qLRAYF-eg9cRAi1)ifi{|1~@UNv7TL@%8o zl&VeEyy~EN*$}->yYtSfQlXmn3TpT6tvkkNcJG!i)bT04DpkFFs#2=X&2L!0d+X#( zcK77WfV%i%)qX8IJUu?zadr3ZZJF)kJBhn{V4z#J)l{kGZS(V9DxDq}>>7gNI#Esd z^FtHfUazdOzF!Wbr?k)9?O}_O^67rP*gaK!IqNTTaV+pF-7iayPL!NeE^5A1FRG$j z&6mBfYyNA?=0mP7l?}NzK@EgUXGMZ6eYG>AW%t5G71jfC-aWSkKiET)Fip7oh2h{qY+s>U@Roa+DGG3_u07KND}KIF_7YtK zN>$vw+`I&og4XHg-MULwr~psp+;Um&*PpD8eo{C!ijpmQTO`5)UnK*nS}7mbD}_Os z&4ruv4J1({7x$bC+zNdmto9?fya2i3icDMd>ZFz;g+aA2pk6UVVy4-uzH->7&hA^| z)pLF4I?h(4o8m#;s`3`xN{vF(1xwilzH~NsQ3PV%SEc$!#}V1+mg*ENrJZvdp{Ex8 zMi6I(>moVbKqApc=h9B=ldDD*uQ=rv$gScrlrF3SJzqcBjP5A%L=+&Eg-i|`6)&Gw zYRoN_8;Ig*ui{l^yeqG6NHw&V z`MNIOt>?RRI<0Rq7kD-0H|n(pwI8Z{DXf*B^;*d7)|Wv~3EcK{=P| zB`>7xMoraHfqizUobcz;Fy{q*X=ldssEg3wsQNoDryDh@$Qv)y5y~b;|Dcpxx4#q_ zGK0p*bS9e_8J-v*WM>L0$_690>F(*K*yv*tr0-TX92%|& zr=7#o+ZoACG%}&we4gs`tImjDsUSamw2v%~+o783dzhwi6})ffxovDax=Fq*S5K(Y8{Y18(Z?NUJ>QHCEKU!j7^ks zUX`-qZ=)LDzC(>qO$;h#i;}QfuV^OjtiM;!6G!~oV!*Ifm$1zbsgVJ-e(lYm!L zVeKHTF|7Mk$hKjn)~;W-Zr#wj4Qo$PYRAm53V#Y7j=V{z}@C%E6qnt-j@AZ(gIj^)=It22%riW6Aq|3>pq^X;!#%#HiQ??u( zXX$IY&*{-N?@>`WP&?a3r$@F9Z_f^&o|(vGcS&iFWwP5xXJ*vc7AME*2x`NHN1V7bgXF-+qFpxO9Z*1V^(#a6B$#IuH*)R zTdm8JI9ZuvL?f+{_l!{_N;rC@JZRCc$*t&D(a1<|W=twH%1Fu--|I2b*HU5tnX!l( zBIBQJKxwC=j8(IyHz|)=YKE5PCQ~0TD$PL(#Np0b*ysx~69}VF%M>*NtR@u`7I~Q2 z#g1n!NVSKy+Ba#DDzZ5681!r*$Ri_+)=(!*#7YJH>sQj|m+Wm94bj?Hsfpq3<2#1O zN7cyGlv>4<4`J*Ex#CdWos(W=Bw#E)RD~|B3Z=5=i2i>Gdh5H;ZAJed=H<)i`fq{@ zAPc9!bK#puI?gBIeQ*_s4dAWta!A2L==~4E9dJ9m4HjS?)`J7TLFd070vLjypyOW; z&xb?cJLveIfY(C?j)uF?>AwnBLm5s5(e=NN9{=C)b$ADy3n#!Ka4&lNJ#ZU*5k3QN zgbQFB90|YTnSTjCg9qS#xDli*u7ciQuLOD}&?|vn2^{h>qfo2qrc zX2Ner|3-sbE{L6dPl?SfJ)>2NFrAsJV$C_=XlN!=nW@q4@w(nf>`9nKjDakOBL<#Z zHcv;xp_rH^scwH(8@7_Cu=999fHgC(o6Y`1 z%j}xaliFIc|KQBw2%V{7Lx}@7+lhH{wZcE!K2y!swZDkDvLAY5^iWJMh0d7>lT-VQmQ&-5ZmOC_4HEkyTTgnHWM+Xp3Ti%ll%0 zta_*sp(3%afu)R~Ls|I)G( zF=KJL|Cr{v5^=Xl1t@C2>z}^sIQ2yHlpbL1m8gTw>ZZ6?o`}?6OCrtsMeeU4of+1i zBsbIy&!S72tRNWYQCxMkNq_ZnI?Hl5u^5@$4=S3h=xv2k5Z2QU4bG~sQkAqsZS{$4 zsv*WOo>F1w&{{cqZj}!hjoIdmnr%#NtaFBH*W`|Anrv9ZXj?L7oZ~UqiV-$cr3z-; z5^672JZ+X24R$KCB~nv$`y#y^+HTb^R%Y9D`{mxUj7LV5yO(iGn}ztYY1tPGiJES3 zAF)Ab?QoE+m?Dsts+%O{d2C5o!Z9jztf4$UD{yUNv~69sGX#617HF)-6II4MJ3g`y zsP*!`C{%~ceI(e(n66nn9=FbEICQw%$P_QfJlBu%gvxsr%sB1Si9=3|b+ zHrL`D*n2RV>!E1%@p8NFF}Yx(v2b7~2F(_}9|`7|ki_dI==7}<(oQ923NlR){r~H% zAE#M&7X4p*_8&plza4IYcfvd1EwB$RhgZUj;0|>DYvD5R!G+hrVekmL{td7XM&Sr} z0Db@4@Kv}G{t-S0IS{{qemDUh!Vd5td;rdZov;~R4u``JunF7@pM&?nKG*}N!lT#) zZh%W+2ERs%XKxLRub*^d7h#EpH4EKIx_&<@j6~)XHw-niuv1JYwSCZ&x38RJDDT`)VUnXZFnUa^wTH!MFJJ1?e2U_LoG1R&0sPvZNa+<}n{JXf; zTgq$c=*w37G#)@>SPi<=yD^7VTI^xAFKcTVhMl@6@#0(4Xmri0S|y&z>wZB~i;ZGQ zgP2O$_8*Uh_Ki&kSuZybpFe4ov6jsHcnlmm)ln#q%g9$eJ3{d_akW@6%B$8t2eoS1 zpJ@91qWO0Vj2@b1krWPW zKfVlZ7?OnOl<22;28zz86=N1K?H#b}SO>4PqnFf`cxOfr)DhUKkx!(iSn`c|)-;Y- zH^TxUz7WQWDGk#@456O&*&dPiwspGr@sTf0= zQSfXKUH_x-TDTY{;Fa(TGW-enI9v&Dg;_Wao)6E4AEWQz2{*#u!VWkRZb$F`7&M?C z{tI3IYw$jJ4Ll$2MZdouE`?LzA@utn!F_NqTmhHBcGw0RU_Ja0{r~fD12kYQ+>gKh zC!qmr;Y#c-mjXRR{-VZUKG}~wtuhj%PdV##Ppf>Q?aH>Nb-Z-ZGFs-ntuuvW^qyAP z(<}i#v8TPbFy@_)r8#Nt~B0a6Li?7?`p;d|s8E>bI zo%^+)lr^%ogy?Jew1V&~L$^jje_q1u*6O0eHXS?|!j8?5>DJ`1)L}*w?-Og#!qSZO zt7@FvjC+N#zR2b;Z9ZdjjOS0ro5Sde7aQ7x`$g<)+?X%R!*{Zn(N=7wDp|WuFAbJ^mN> zAl#SOghS58utmt0J~7*I-$q%!oVE@lZT=x)W7g(C+=sA}bayz>`oAofeic1b^#2Mk ze}~S0CCtOw@KQ*_bKnqo0G0iFh5 z!8Y(-coT%M4UU03umyYpu7X)O8?rD1zriN(0DKre1ac0*QScLN13!ju!>w=?Tnf8k z3k<;ta2&iCr0$*ocO0`{HWw>HIkC_ear+watL${cq-~a_=rty2QE%7O+la;dADQc& z8s_%o7x?7GUo9^R5`H~w<Xmb@!B=ar9!-ixh&u3)ubWvHiBi&D8eG zbbHUm$0}&sqpU6Hk*(gWFtBfVa{I(CH9VFboz}+oux-CC%NcpG^6G7WvVU`zxRiiqn zlUmv8)q$!J%pJNqavMKxJ-3kgMf0!e2F_Nus)%76&upV*oxr-NuXdU-qIb)9fLlK= zv*MLl@IqX-I$zYJU#-X?Ji2S*HEA_oxreh!ATHOgYleD>FZN2;s}kZVnWeY47)!*B zaR3VS2){5<)t*_P4a#c3bBSY!=oN zj;Qj}?7i+7)XgqOy=E76J*D;|cJxsTxCOH#ReP0+2(atJ%|$x1bjW8pmBEYlIkp`b zz~)A?TDO0BVRH9`ii$(+!g=5v8n4%_R-sua!)Le8IaD_jx7&4G|ATs;BW*?;S+#G0 zlW6ler)bxkBt{CrQ+wWw(jl;vuVtao3NR=c0gIWyp%J(;&|t zDY}8)d$QC#wiyC{ESz;|S@`2t#rIayZ?^QvwSa|yp`pAt+nC#?QiPtBjU$r9v|jv@ zNCQTNOl+GONTy4^_P3o)EiEtu?4IvY~Br{K|}j7;Tw$We<&bI6#+aMybXfty`!!3(1PCha~v}}Uw znv8M62)kahmDTlHX7X{;@MQge9XkI{tp2};_di0%{~){%u7N2y3=W0+(d&Nzx4^%^ z+u;%r-Cy+nqv0;}{SU!Ka6U}KOW>#I`r_|@H8kLK*aRoR1`t1he+Kadkn;d91M&Hn zvjP4T9!1apHQWRrgUcZYa!$Z0uoea&1>Z#fzY$&!TVWg?M#uj&dM^ue>> z>F_1={lAARL3{&tf!F|kh@SshxE#)a{r# zYeDu2eD@Ii6<{A+4kyD);d$^)^m;i5@C|S_oD9c;ocZ?%b@fw_I{UHI+X4OABkAmm zmCJT$-@i&PGGS?t(^NEP^_x1J*y5N~tY-g|?x`wOoHB<#)%{|0tdALd;z@+Q3&)C) zj5aEWdz#5?RgA3lA{ojbG%vAb8)dV8D2q0efz&i6gG7UgrX13`n28qJ9G>gG zb_|a~>4@#&MBkMQEg@U9;kH!bYohsf#Ej=YEpHCY1fiC)LFfXAC)C|+5bCL6gpi_b zEB2Q1v>&VqLaNY)76U}o9qc24*J3(v}^2|0r6Qt4%wI zso$m@M2oga^R#vl{oOL+u3gBP`SYNhk%;f_vi1;U)6ymoxi10u*O*V)DvQu4`?)=O zVr^zg7>F_0W_^qA!`zRuebUWU|p*=yH1T8REXg8q1&=#i}d@8m_+|IdS?LG=88 z1<~{6-2XaE!Ex|Qbo!e>&i&sFvd;f=^!S_L-LM@}a2LA!ZSY-?_5E?^gX7^wboGCN zx5EOQ2M?jEi~jy4kTd_zgemBU=fd~V(XWOx;W=;w91fpFNB^+Z*N@@#QFQbFh3nuN zcrRQ4C&TmLm+0s>!<%6zybN9hvY-DpxE3yiSHsKTKJ@ZiMK=doudl)>@C>*Gz5HDu z=k;Fz=R*!=;c)mByi+JCu9fATpc^yT@+fYVO#IjCvTGU5@dMTtGOUlru3! zNtJU#L`Ov_?`#VP#fKmg>rE-j?l)r=+vbLQl+Q6&9LL?fY~Qt>^d#G{UbQ2WmEad} zgsVbd?{ZQV28GUene93nlhQ7+n6qNu_N+UQBroBjyO_*jWa!9Va-Frd?CzXqRC2eH z+v%I>Jw4`BA-f}JsjNkLvnCy0u;xZzHgB%q*-{hph~5RK`l4@4Y}xrF^VW9R7@u*{ zmYzPgNuPHXZ+w<<#N>e`Hoe$gsmWohQI1wz0^CYsqDi&q#+=(V#*y6E=4C}%=A%*i z(H9a?Oi^~eq*BS}>QznSC;^^k`@FoHe&xzC~gnTu! zbz+O+B;xv_`EI7!=1EgGX%g*hyt>hw67Ph3CxVkGmG}dTU~1MURR~QDiwh0T2=OR?C8ksv^|1Jls@U6*x8ukh#8Od zmF=8;9GLUWwV}+5mLa${Sw*Lf&s#FX_JK<2rgTo+{@^VPw%Ua0aB?`f&kq#H0y{FI zWz%V2;t2Y9HAy>##)pjQ6td0VS$OP;$Pd$yisiP(sZXTMXC5iM2Prrh!( zo+{cgCNd+gX2I6>bAFzH(McAFwOfgHiQ@}hlgUK%NS}&g5kmT6M<|KW?QRK~a9}q~ zL|pEk2r4TRI-GUdM1kbcJc|_y?INb@b9KhBopV5oqz*|UchP^*^a^p)tz5=g`>*1l zWDm77<4*fzOHZQg%2IP4C5@j6rTyMaNLohT$7&F&ZQR@F zt(^!A{Y3zKn_^6Ghh2FCu!^Jq3j)OO=PyvRc$AaYA3#Jo;oxA83TA? kXMxq-cZm2{p|^=Vjz23t9QrXmIpM%msg~Kl`=31fKh*qing9R* diff --git a/System/Cmd/Utils.hs b/System/Cmd/Utils.hs deleted file mode 100644 index a81126146b..0000000000 --- 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 - -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 - 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 9fa8d864fe..d3b0c46efc 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 e13afe5d48..26ac688e3a 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 bf87f4e71b..55233ef762 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 0061dfe574..ebd273b2e1 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 0000000000..9f79efa813 --- /dev/null +++ b/Utility/Process.hs @@ -0,0 +1,40 @@ +{- System.Process enhancements + - + - Copyright 2012 Joey Hess + - + - 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 5f6a53e715..47280a40b1 100644 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -1,6 +1,6 @@ {- safely running shell commands - - - Copyright 2010-2011 Joey Hess + - Copyright 2010-2012 Joey Hess - - 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 4dcbf1cca4..62e0fc8596 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 edfa51669f..412f52ae81 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 3f237ce70e..e58bd4d957 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 diff --git a/test.hs b/test.hs index 9de73264ee..a377057c28 100644 --- a/test.hs +++ b/test.hs @@ -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(..))