summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Annex/UUID.hs2
-rw-r--r--Backend/SHA.hs1
-rw-r--r--Command/Map.hs13
-rw-r--r--Config.hs2
-rw-r--r--Git/Command.hs13
-rw-r--r--Git/Config.hs15
-rw-r--r--Git/Queue.hs13
-rw-r--r--Git/UpdateIndex.hs13
-rw-r--r--Remote/Bup.hs12
-rw-r--r--Remote/Git.hs13
-rw-r--r--Seek.hs4
-rw-r--r--Utility/CoProcess.hs12
-rw-r--r--Utility/Gpg.hs45
-rw-r--r--Utility/INotify.hs1
-rw-r--r--Utility/Lsof.hs9
-rw-r--r--Utility/Process.hs200
-rw-r--r--Utility/SafeCommand.hs3
17 files changed, 248 insertions, 123 deletions
diff --git a/Annex/UUID.hs b/Annex/UUID.hs
index 1d2175bcb..13cee865d 100644
--- a/Annex/UUID.hs
+++ b/Annex/UUID.hs
@@ -20,8 +20,6 @@ module Annex.UUID (
removeRepoUUID,
) where
-import System.Process
-
import Common.Annex
import qualified Git
import qualified Git.Config
diff --git a/Backend/SHA.hs b/Backend/SHA.hs
index a1dd1cf64..04b3e362a 100644
--- a/Backend/SHA.hs
+++ b/Backend/SHA.hs
@@ -12,7 +12,6 @@ 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
diff --git a/Command/Map.hs b/Command/Map.hs
index f69b88a5d..3dbdadbd6 100644
--- a/Command/Map.hs
+++ b/Command/Map.hs
@@ -9,7 +9,6 @@ module Command.Map where
import Control.Exception.Extensible
import qualified Data.Map as M
-import System.Process
import Common.Annex
import Command
@@ -199,13 +198,11 @@ tryScan r
case result of
Left _ -> return Nothing
Right r' -> return $ Just 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'
+ pipedconfig cmd params = safely $
+ withHandle StdoutHandle createProcessSuccess p $
+ Git.Config.hRead r
+ where
+ p = proc cmd $ toCommand params
configlist =
onRemote r (pipedconfig, Nothing) "configlist" [] []
diff --git a/Config.hs b/Config.hs
index 84f6125c6..1aa5a4ac5 100644
--- a/Config.hs
+++ b/Config.hs
@@ -7,8 +7,6 @@
module Config where
-import System.Process
-
import Common.Annex
import qualified Git
import qualified Git.Config
diff --git a/Git/Command.hs b/Git/Command.hs
index 038824f26..d7c983064 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -7,7 +7,6 @@
module Git.Command where
-import System.Process
import System.Posix.Process (getAnyProcessStatus)
import Common
@@ -41,12 +40,12 @@ run subcommand params repo = assertLocal repo $
- result unless reap is called.
-}
pipeRead :: [CommandParam] -> Repo -> IO String
-pipeRead params repo = assertLocal repo $ do
- (_, Just h, _, _) <- createProcess
- (proc "git" $ toCommand $ gitCommandLine params repo)
- { std_out = CreatePipe }
- fileEncoding h
- hGetContents h
+pipeRead params repo = assertLocal repo $
+ withHandle StdoutHandle createBackgroundProcess p $ \h -> do
+ fileEncoding h
+ hGetContents h
+ where
+ p = proc "git" $ toCommand $ gitCommandLine params repo
{- 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
diff --git a/Git/Config.hs b/Git/Config.hs
index 234750113..c82d6bb1b 100644
--- a/Git/Config.hs
+++ b/Git/Config.hs
@@ -9,7 +9,7 @@ module Git.Config where
import qualified Data.Map as M
import Data.Char
-import System.Process
+import System.Process (cwd)
import Common
import Git
@@ -48,14 +48,11 @@ 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 = 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"]
+ git_config d = withHandle StdoutHandle createProcessSuccess p $
+ hRead repo
+ where
+ params = ["config", "--null", "--list"]
+ p = (proc "git" params) { cwd = Just d }
{- 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 4e6f05c2e..f515ad104 100644
--- a/Git/Queue.hs
+++ b/Git/Queue.hs
@@ -19,7 +19,6 @@ module Git.Queue (
import qualified Data.Map as M
import System.IO
-import System.Process
import Data.String.Utils
import Utility.SafeCommand
@@ -148,13 +147,11 @@ runAction :: Repo -> Action -> IO ()
runAction repo (UpdateIndexAction streamers) =
-- list is stored in reverse order
Git.UpdateIndex.streamUpdateIndex repo $ reverse streamers
-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
+runAction repo action@(CommandAction {}) =
+ withHandle StdinHandle createProcessSuccess (proc "xargs" params) $ \h -> do
+ fileEncoding h
+ hPutStr h $ join "\0" $ getFiles action
+ hClose h
where
params = "-0":"git":baseparams
baseparams = toCommand $ gitCommandLine
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index 6de0c3ada..929448729 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -17,8 +17,6 @@ module Git.UpdateIndex (
stageSymlink
) where
-import System.Process
-
import Common
import Git
import Git.Types
@@ -36,12 +34,11 @@ pureStreamer !s = \streamer -> streamer s
{- Streams content into update-index from a list of Streamers. -}
streamUpdateIndex :: Repo -> [Streamer] -> IO ()
-streamUpdateIndex repo as = do
- (Just h, _, _, p) <- createProcess (proc "git" ps) { std_in = CreatePipe }
- fileEncoding h
- forM_ as (stream h)
- hClose h
- forceSuccessProcess p "git" ps
+streamUpdateIndex repo as =
+ withHandle StdinHandle createProcessSuccess (proc "git" ps) $ \h -> do
+ fileEncoding h
+ forM_ as (stream h)
+ hClose h
where
ps = toCommand $ gitCommandLine params repo
params = map Param ["update-index", "-z", "--index-info"]
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 9da374174..8a2c1afef 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -133,15 +133,13 @@ retrieveCheap :: BupRepo -> Key -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False
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
- (_, Just h, _, pid)
- <- createProcess (proc "bup" $ toCommand params)
- { std_out = CreatePipe }
+retrieveEncrypted buprepo (cipher, enck) _ f = liftIO $ catchBoolIO $
+ withHandle StdoutHandle createProcessSuccess p $ \h -> do
withDecryptedContent cipher (L.hGetContents h) $ L.writeFile f
- forceSuccessProcess pid "bup" $ toCommand params
return True
+ where
+ params = bupParams "join" buprepo [Param $ bupRef enck]
+ p = proc "bup" $ toCommand params
remove :: Key -> Annex Bool
remove _ = do
diff --git a/Remote/Git.hs b/Remote/Git.hs
index a9a6d6004..3412de89b 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -9,7 +9,6 @@ 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
@@ -127,13 +126,11 @@ tryGitConfigRead r
safely a = either (const $ return r) return
=<< liftIO (try a :: IO (Either SomeException Git.Repo))
- 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'
+ pipedconfig cmd params = safely $
+ withHandle StdoutHandle createProcessSuccess p $
+ Git.Config.hRead r
+ where
+ p = proc cmd $ toCommand params
geturlconfig headers = do
s <- Url.get (Git.repoLocation r ++ "/config") headers
diff --git a/Seek.hs b/Seek.hs
index 2cf0d8d46..3306a02fc 100644
--- a/Seek.hs
+++ b/Seek.hs
@@ -108,9 +108,9 @@ withNothing _ _ = error "This command takes no parameters."
prepFiltered :: (FilePath -> CommandStart) -> Annex [FilePath] -> Annex [CommandStart]
prepFiltered a fs = do
matcher <- Limit.getMatcher
- map (proc matcher) <$> fs
+ map (process matcher) <$> fs
where
- proc matcher f = do
+ process matcher f = do
ok <- matcher f
if ok then a f else return Nothing
diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs
index d3b0c46ef..67f861bb3 100644
--- a/Utility/CoProcess.hs
+++ b/Utility/CoProcess.hs
@@ -13,25 +13,23 @@ module Utility.CoProcess (
query
) where
-import System.Process
-
import Common
-type CoProcessHandle = (ProcessHandle, Handle, Handle, FilePath, [String])
+type CoProcessHandle = (ProcessHandle, Handle, Handle, CreateProcess)
start :: FilePath -> [String] -> IO CoProcessHandle
start command params = do
(from, to, _err, pid) <- runInteractiveProcess command params Nothing Nothing
- return (pid, to, from, command, params)
+ return (pid, to, from, proc command params)
stop :: CoProcessHandle -> IO ()
-stop (pid, from, to, command, params) = do
+stop (pid, from, to, p) = do
hClose to
hClose from
- forceSuccessProcess pid command params
+ forceSuccessProcess p pid
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 26ac688e3..eed77805c 100644
--- a/Utility/Gpg.hs
+++ b/Utility/Gpg.hs
@@ -13,7 +13,6 @@ import Control.Applicative
import Control.Concurrent
import Control.Exception (bracket)
import System.Posix.Env (setEnv, unsetEnv, getEnv)
-import System.Process
import Common
@@ -39,30 +38,21 @@ stdParams params = do
readStrict :: [CommandParam] -> IO String
readStrict params = do
params' <- stdParams params
- (_, Just from, _, pid)
- <- createProcess (proc "gpg" params')
- { std_out = CreatePipe }
- hSetBinaryMode from True
- r <- hGetContentsStrict from
- forceSuccessProcess pid "gpg" params'
- return r
+ withHandle StdoutHandle createProcessSuccess (proc "gpg" params') $ \h -> do
+ hSetBinaryMode h True
+ hGetContentsStrict h
{- 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
- (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
+ withBothHandles createProcessSuccess (proc "gpg" params') $ \(to, from) -> do
+ hSetBinaryMode to True
+ hSetBinaryMode from True
+ hPutStr to input
+ hClose to
+ hGetContentsStrict from
{- Runs gpg with some parameters, first feeding it a passphrase via
- --passphrase-fd, then feeding it an input, and passing a handle
@@ -82,16 +72,13 @@ passphraseHandle params passphrase a b = do
let passphrasefd = [Param "--passphrase-fd", Param $ show pfd]
params' <- stdParams $ passphrasefd ++ params
- (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
- forceSuccessProcess pid "gpg" params'
- closeFd frompipe
- return ret
+ closeFd frompipe `after`
+ withBothHandles createProcessSuccess (proc "gpg" params') go
+ where
+ go (to, from) = do
+ L.hPut to =<< a
+ hClose to
+ b from
{- Finds gpg public keys matching some string. (Could be an email address,
- a key id, or a name. -}
diff --git a/Utility/INotify.hs b/Utility/INotify.hs
index 55233ef76..66c0ab23d 100644
--- a/Utility/INotify.hs
+++ b/Utility/INotify.hs
@@ -10,7 +10,6 @@ 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
diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs
index ebd273b2e..ce6a16283 100644
--- a/Utility/Lsof.hs
+++ b/Utility/Lsof.hs
@@ -12,7 +12,6 @@ module Utility.Lsof where
import Common
import System.Posix.Types
-import System.Process
data LsofOpenMode = OpenReadWrite | OpenReadOnly | OpenWriteOnly | OpenUnknown
deriving (Show, Eq)
@@ -34,9 +33,11 @@ queryDir path = query ["+d", path]
- Note: If lsof is not available, this always returns [] !
-}
query :: [String] -> IO [(FilePath, LsofOpenMode, ProcessInfo)]
-query opts = do
- (_, s, _) <- readProcessWithExitCode "lsof" ("-F0can" : opts) []
- return $ parse s
+query opts =
+ withHandle StdoutHandle (createProcessChecked checkSuccessProcess) p $ \h -> do
+ parse <$> hGetContentsStrict h
+ where
+ p = proc "lsof" ("-F0can" : opts)
{- Parsing null-delimited output like:
-
diff --git a/Utility/Process.hs b/Utility/Process.hs
index 9f79efa81..9b57c3b7a 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -1,40 +1,202 @@
-{- System.Process enhancements
+{- System.Process enhancements, including additional ways of running
+ - processes, and logging.
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
-module Utility.Process where
+{-# LANGUAGE Rank2Types #-}
-import System.Process
+module Utility.Process (
+ module X,
+ CreateProcess,
+ StdHandle(..),
+ readProcessEnv,
+ forceSuccessProcess,
+ checkSuccessProcess,
+ createProcessSuccess,
+ createProcessChecked,
+ createBackgroundProcess,
+ withHandle,
+ withBothHandles,
+ createProcess,
+ runInteractiveProcess,
+ readProcess
+) where
+
+import qualified System.Process
+import System.Process as X hiding (CreateProcess(..), createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode, system, rawSystem, runInteractiveCommand, runProcess)
+import System.Process hiding (createProcess, runInteractiveProcess, readProcess, readProcessWithExitCode)
import System.Exit
import System.IO
+import System.Log.Logger
import Utility.Misc
+type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a
+
+data StdHandle = StdinHandle | StdoutHandle | StderrHandle
+ deriving (Eq)
+
+{- 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 =
+ withHandle StdoutHandle createProcessSuccess p $ \h -> do
+ output <- hGetContentsStrict h
+ hClose h
+ return output
+ where
+ p = (proc cmd args)
+ { std_out = CreatePipe
+ , env = environ
+ }
+
{- 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
+forceSuccessProcess :: CreateProcess -> ProcessHandle -> IO ()
+forceSuccessProcess p pid = do
code <- waitForProcess pid
case code of
ExitSuccess -> return ()
- ExitFailure n -> error $
- cmd ++ " " ++ show args ++ " exited " ++ show n
+ ExitFailure n -> error $ showCmd p ++ " 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
+{- Waits for a ProcessHandle and returns True if it exited successfully. -}
+checkSuccessProcess :: ProcessHandle -> IO Bool
+checkSuccessProcess pid = do
+ code <- waitForProcess pid
+ return $ code == ExitSuccess
+
+{- Runs createProcess, then an action on its handles, and then
+ - forceSuccessProcess. -}
+createProcessSuccess :: CreateProcessRunner
+createProcessSuccess p a = createProcessChecked (forceSuccessProcess p) p a
+
+{- Runs createProcess, then an action on its handles, and then
+ - an action on its exit code. -}
+createProcessChecked :: (ProcessHandle -> IO b) -> CreateProcessRunner
+createProcessChecked checker p a = do
+ t@(_, _, _, pid) <- createProcess p
+ r <- a t
+ _ <- checker pid
+ return r
+
+{- Leaves the process running, suitable for lazy streaming.
+ - Note: Zombies will result, and must be waited on. -}
+createBackgroundProcess :: CreateProcessRunner
+createBackgroundProcess p a = a =<< createProcess p
+
+{- Runs a CreateProcessRunner, on a CreateProcess structure, that
+ - is adjusted to pipe only from/to a single StdHandle, and passes
+ - the resulting Handle to an action. -}
+withHandle
+ :: StdHandle
+ -> CreateProcessRunner
+ -> CreateProcess
+ -> (Handle -> IO a)
+ -> IO a
+withHandle h creator p a = creator p' $ a . select
+ where
+ base = p
+ { std_in = Inherit
+ , std_out = Inherit
+ , std_err = Inherit
+ }
+ (select, p')
+ | h == StdinHandle =
+ (stdinHandle, base { std_in = CreatePipe })
+ | h == StdoutHandle =
+ (stdoutHandle, base { std_out = CreatePipe })
+ | h == StderrHandle =
+ (stderrHandle, base { std_err = CreatePipe })
+
+{- Like withHandle, but passes (stdin, stdout) handles to the action. -}
+withBothHandles
+ :: CreateProcessRunner
+ -> CreateProcess
+ -> ((Handle, Handle) -> IO a)
+ -> IO a
+withBothHandles creator p a = creator p' $ a . bothHandles
+ where
+ p' = p
+ { std_in = CreatePipe
, std_out = CreatePipe
, std_err = Inherit
- , env = environ
}
- output <- hGetContentsStrict h
- hClose h
- forceSuccessProcess pid cmd args
- return output
+
+{- Extract a desired handle from createProcess's tuple.
+ - These partial functions are safe as long as createProcess is run
+ - with appropriate parameters to set up the desired handle.
+ - Get it wrong and the runtime crash will always happen, so should be
+ - easily noticed. -}
+type HandleExtractor = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> Handle
+stdinHandle :: HandleExtractor
+stdinHandle (Just h, _, _, _) = h
+stdinHandle _ = error "expected stdinHandle"
+stdoutHandle :: HandleExtractor
+stdoutHandle (_, Just h, _, _) = h
+stdoutHandle _ = error "expected stdoutHandle"
+stderrHandle :: HandleExtractor
+stderrHandle (_, _, Just h, _) = h
+stderrHandle _ = error "expected stderrHandle"
+bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
+bothHandles (Just hin, Just hout, _, _) = (hin, hout)
+bothHandles _ = error "expected bothHandles"
+
+{- Debugging trace for a CreateProcess. -}
+debugProcess :: CreateProcess -> IO ()
+debugProcess p = do
+ debugM "Utility.Process" $ unwords
+ [ action ++ ":"
+ , showCmd p
+ , maybe "" show (env p)
+ ]
+ where
+ action
+ | piped (std_in p) && piped (std_out p) = "chat"
+ | piped (std_in p) = "feed"
+ | piped (std_out p) = "read"
+ | otherwise = "call"
+ piped Inherit = False
+ piped _ = True
+
+{- Shows the command that a CreateProcess will run. -}
+showCmd :: CreateProcess -> String
+showCmd = go . cmdspec
+ where
+ go (ShellCommand s) = s
+ go (RawCommand c ps) = c ++ " " ++ show ps
+
+{- Wrappers for System.Process functions that do debug logging.
+ -
+ - More could be added, but these are the only ones I usually need.
+ -}
+
+createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
+createProcess p = do
+ debugProcess p
+ System.Process.createProcess p
+
+runInteractiveProcess
+ :: FilePath
+ -> [String]
+ -> Maybe FilePath
+ -> Maybe [(String, String)]
+ -> IO (Handle, Handle, Handle, ProcessHandle)
+runInteractiveProcess f args c e = do
+ debugProcess $ (proc f args)
+ { std_in = CreatePipe
+ , std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+ System.Process.runInteractiveProcess f args c e
+
+readProcess
+ :: FilePath
+ -> [String]
+ -> String
+ -> IO String
+readProcess f args input = do
+ debugProcess $ (proc f args) { std_out = CreatePipe }
+ System.Process.readProcess f args input
diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs
index 47280a40b..19dd707b8 100644
--- a/Utility/SafeCommand.hs
+++ b/Utility/SafeCommand.hs
@@ -8,7 +8,8 @@
module Utility.SafeCommand where
import System.Exit
-import System.Process
+import Utility.Process
+import System.Process (env)
import Data.String.Utils
import Control.Applicative
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-30 05:46:52 +0000