mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions 2

switch from System.Cmd.Utils to System.Process

Browse source 
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.
This commit is contained in:
Joey Hess 2012-07-18 15:30:26 -04:00
parent fc5652c811
commit d1da9cf221
32 changed files with 178 additions and 740 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
Annex/Branch.hs
View file

@ -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

6
Annex/UUID.hs
View file

@ -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

17
Backend/SHA.hs
View file

@ -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

4
Build/Configure.hs
View file

@ -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)

2
Command/Fsck.hs
View file

@ -7,6 +7,8 @@
module Command.Fsck where
import System.Posix.Process (getProcessID)
import Common.Annex
import Command
import qualified Annex

11
Command/Map.hs
View file

@ -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" [] []

3
Common.hs
View file

@ -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

6
Config.hs
View file

@ -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] "")

2
Git/Branch.hs
View file

@ -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

12
Git/CatFile.hs
View file

@ -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

4
Git/CheckAttr.hs
View file

@ -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

29
Git/Command.hs
View file

@ -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. -}

14
Git/Config.hs
View file

@ -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

17
Git/Queue.hs
View file

@ -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

5
Git/Ref.hs
View file

@ -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

7
Git/UpdateIndex.hs
View file

@ -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

6
Remote/Bup.hs
View file

@ -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

14
Remote/Git.hs
View file

@ -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

17
Remote/Hook.hs
View file

@ -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

1
Remote/Rsync.hs
View file

@ -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

BIN
System/Cmd/.Utils.hs.swp
View file

Binary file not shown.

568
System/Cmd/Utils.hs
View file

@ -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

14
Utility/CoProcess.hs
View file

@ -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

39
Utility/Gpg.hs
View file

@ -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

8
Utility/INotify.hs
View file

@ -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)

7
Utility/Lsof.hs
View file

@ -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:
-

40
Utility/Process.hs Normal file
View file

@ -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

49
Utility/SafeCommand.hs
View file

@ -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. -}

2
Utility/TempFile.hs
View file

@ -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

3
doc/todo/assistant_threaded_runtime.mdwn
View file

@ -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

6
git-annex.cabal
View file

@ -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

1
test.hs
View file

@ -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(..))