export CreateProcess fields from Utility.Process

update code to avoid cwd and env redefinition warnings
This commit is contained in:
Joey Hess 2014-06-10 19:20:14 -04:00
parent 6eb5e6c135
commit a44fd2c019
31 changed files with 458 additions and 480 deletions

View file

@ -22,7 +22,6 @@ module Annex.Ssh (
import qualified Data.Map as M import qualified Data.Map as M
import Data.Hash.MD5 import Data.Hash.MD5
import System.Process (cwd)
import System.Exit import System.Exit
import Common.Annex import Common.Annex

View file

@ -122,15 +122,15 @@ installNautilus _ = noop
cleanEnvironment :: IO (Maybe [(String, String)]) cleanEnvironment :: IO (Maybe [(String, String)])
cleanEnvironment = clean <$> getEnvironment cleanEnvironment = clean <$> getEnvironment
where where
clean env clean environ
| null vars = Nothing | null vars = Nothing
| otherwise = Just $ catMaybes $ map (restoreorig env) env | otherwise = Just $ catMaybes $ map (restoreorig environ) environ
| otherwise = Nothing | otherwise = Nothing
where where
vars = words $ fromMaybe "" $ vars = words $ fromMaybe "" $
lookup "GIT_ANNEX_STANDLONE_ENV" env lookup "GIT_ANNEX_STANDLONE_ENV" environ
restoreorig oldenv p@(k, _v) restoreorig oldenviron p@(k, _v)
| k `elem` vars = case lookup ("ORIG_" ++ k) oldenv of | k `elem` vars = case lookup ("ORIG_" ++ k) oldenviron of
(Just v') (Just v')
| not (null v') -> Just (k, v') | not (null v') -> Just (k, v')
_ -> Nothing _ -> Nothing

View file

@ -24,7 +24,6 @@ import qualified Annex
import qualified Git import qualified Git
import Control.Concurrent import Control.Concurrent
import System.Process (cwd)
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
import System.Posix (signalProcess, sigTERM) import System.Posix (signalProcess, sigTERM)
#else #else

View file

@ -22,7 +22,6 @@ import qualified Types.Remote as Remote
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.Async import Control.Concurrent.Async
import System.Process (std_in, std_out)
import Network.URI import Network.URI
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Set as S import qualified Data.Set as S

View file

@ -15,7 +15,6 @@ import Utility.Batch
import qualified Command.TransferKeys as T import qualified Command.TransferKeys as T
import Control.Concurrent.STM hiding (check) import Control.Concurrent.STM hiding (check)
import System.Process (create_group, std_in, std_out)
import Control.Exception (throw) import Control.Exception (throw)
import Control.Concurrent import Control.Concurrent

View file

@ -116,11 +116,11 @@ defaultRepositoryPath :: Bool -> IO FilePath
defaultRepositoryPath firstrun = do defaultRepositoryPath firstrun = do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
home <- myHomeDir home <- myHomeDir
cwd <- liftIO getCurrentDirectory currdir <- liftIO getCurrentDirectory
if home == cwd && firstrun if home == currdir && firstrun
then inhome then inhome
else ifM (legit cwd <&&> canWrite cwd) else ifM (legit currdir <&&> canWrite currdir)
( return cwd ( return currdir
, inhome , inhome
) )
#else #else

View file

@ -381,7 +381,7 @@ sshAuthTranscript sshinput opts input = case inputAuthMethod sshinput of
login = getLogin sshinput login = getLogin sshinput
geti f = maybe "" T.unpack (f sshinput) geti f = maybe "" T.unpack (f sshinput)
go extraopts env = processTranscript' "ssh" (extraopts ++ opts) env $ go extraopts environ = processTranscript' "ssh" (extraopts ++ opts) environ $
Just (fromMaybe "" input) Just (fromMaybe "" input)
setupAskPass = do setupAskPass = do
@ -392,8 +392,8 @@ sshAuthTranscript sshinput opts input = case inputAuthMethod sshinput of
Just pass -> withTmpFile "ssh" $ \passfile h -> do Just pass -> withTmpFile "ssh" $ \passfile h -> do
hClose h hClose h
writeFileProtected passfile pass writeFileProtected passfile pass
env <- getEnvironment environ <- getEnvironment
let env' = addEntries let environ' = addEntries
[ ("SSH_ASKPASS", program) [ ("SSH_ASKPASS", program)
, (sshAskPassEnv, passfile) , (sshAskPassEnv, passfile)
-- ssh does not use SSH_ASKPASS -- ssh does not use SSH_ASKPASS
@ -401,8 +401,8 @@ sshAuthTranscript sshinput opts input = case inputAuthMethod sshinput of
-- there is no controlling -- there is no controlling
-- terminal. -- terminal.
, ("DISPLAY", ":0") , ("DISPLAY", ":0")
] env ] environ
go [passwordprompts 1] (Just env') go [passwordprompts 1] (Just environ')
passwordprompts :: Int -> String passwordprompts :: Int -> String
passwordprompts = sshOpt "NumberOfPasswordPrompts" . show passwordprompts = sshOpt "NumberOfPasswordPrompts" . show

View file

@ -38,7 +38,6 @@ import Utility.Env
import Network.Protocol.XMPP import Network.Protocol.XMPP
import qualified Data.Text as T import qualified Data.Text as T
import System.Posix.Types import System.Posix.Types
import System.Process (std_in, std_out, std_err)
import Control.Concurrent import Control.Concurrent
import System.Timeout import System.Timeout
import qualified Data.ByteString as B import qualified Data.ByteString as B
@ -112,15 +111,15 @@ xmppPush cid gitpush = do
tmpdir <- gettmpdir tmpdir <- gettmpdir
installwrapper tmpdir installwrapper tmpdir
env <- liftIO getEnvironment environ <- liftIO getEnvironment
path <- liftIO getSearchPath path <- liftIO getSearchPath
let myenv = addEntries let myenviron = addEntries
[ ("PATH", intercalate [searchPathSeparator] $ tmpdir:path) [ ("PATH", intercalate [searchPathSeparator] $ tmpdir:path)
, (relayIn, show inf) , (relayIn, show inf)
, (relayOut, show outf) , (relayOut, show outf)
, (relayControl, show controlf) , (relayControl, show controlf)
] ]
env environ
inh <- liftIO $ fdToHandle readpush inh <- liftIO $ fdToHandle readpush
outh <- liftIO $ fdToHandle writepush outh <- liftIO $ fdToHandle writepush
@ -132,7 +131,7 @@ xmppPush cid gitpush = do
{- This can take a long time to run, so avoid running it in the {- This can take a long time to run, so avoid running it in the
- Annex monad. Also, override environment. -} - Annex monad. Also, override environment. -}
g <- liftAnnex gitRepo g <- liftAnnex gitRepo
r <- liftIO $ gitpush $ g { gitEnv = Just myenv } r <- liftIO $ gitpush $ g { gitEnv = Just myenviron }
liftIO $ do liftIO $ do
mapM_ killThread [t1, t2] mapM_ killThread [t1, t2]

View file

@ -28,9 +28,9 @@ start :: [FilePath] -> CommandStart
start [] = do start [] = do
-- Like git status, when run without a directory, behave as if -- Like git status, when run without a directory, behave as if
-- given the path to the top of the repository. -- given the path to the top of the repository.
cwd <- liftIO getCurrentDirectory currdir <- liftIO getCurrentDirectory
top <- fromRepo Git.repoPath top <- fromRepo Git.repoPath
start' [relPathDirToFile cwd top] start' [relPathDirToFile currdir top]
start locs = start' locs start locs = start' locs
start' :: [FilePath] -> CommandStart start' :: [FilePath] -> CommandStart

View file

@ -27,8 +27,8 @@ check = do
when (b == Annex.Branch.name) $ error $ when (b == Annex.Branch.name) $ error $
"cannot uninit when the " ++ Git.fromRef b ++ " branch is checked out" "cannot uninit when the " ++ Git.fromRef b ++ " branch is checked out"
top <- fromRepo Git.repoPath top <- fromRepo Git.repoPath
cwd <- liftIO getCurrentDirectory currdir <- liftIO getCurrentDirectory
whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath cwd)) $ whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $
error "can only run uninit from the top of the git repository" error "can only run uninit from the top of the git repository"
where where
current_branch = Git.Ref . Prelude.head . lines <$> revhead current_branch = Git.Ref . Prelude.head . lines <$> revhead

View file

@ -34,7 +34,6 @@ import Annex.Version
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
import System.Process (env, std_out, std_err, cwd)
import Network.Socket (HostName) import Network.Socket (HostName)
import System.Environment (getArgs) import System.Environment (getArgs)

View file

@ -23,9 +23,9 @@ type Attr = String
- values and returns a handle. -} - values and returns a handle. -}
checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle
checkAttrStart attrs repo = do checkAttrStart attrs repo = do
cwd <- getCurrentDirectory currdir <- getCurrentDirectory
h <- CoProcess.rawMode =<< gitCoProcessStart True params repo h <- CoProcess.rawMode =<< gitCoProcessStart True params repo
return (h, attrs, cwd) return (h, attrs, currdir)
where where
params = params =
[ Param "check-attr" [ Param "check-attr"
@ -38,7 +38,7 @@ checkAttrStop (h, _, _) = CoProcess.stop h
{- Gets an attribute of a file. -} {- Gets an attribute of a file. -}
checkAttr :: CheckAttrHandle -> Attr -> FilePath -> IO String checkAttr :: CheckAttrHandle -> Attr -> FilePath -> IO String
checkAttr (h, attrs, cwd) want file = do checkAttr (h, attrs, currdir) want file = do
pairs <- CoProcess.query h send (receive "") pairs <- CoProcess.query h send (receive "")
let vals = map snd $ filter (\(attr, _) -> attr == want) pairs let vals = map snd $ filter (\(attr, _) -> attr == want) pairs
case vals of case vals of
@ -83,8 +83,8 @@ checkAttr (h, attrs, cwd) want file = do
- so use relative filenames. -} - so use relative filenames. -}
oldgit = Git.BuildVersion.older "1.7.7" oldgit = Git.BuildVersion.older "1.7.7"
file' file'
| oldgit = absPathFrom cwd file | oldgit = absPathFrom currdir file
| otherwise = relPathDirToFile cwd $ absPathFrom cwd file | otherwise = relPathDirToFile currdir $ absPathFrom currdir file
oldattrvalue attr l = end bits !! 0 oldattrvalue attr l = end bits !! 0
where where
bits = split sep l bits = split sep l

View file

@ -9,8 +9,6 @@
module Git.Command where module Git.Command where
import System.Process (std_out, env)
import Common import Common
import Git import Git
import Git.Types import Git.Types

View file

@ -9,7 +9,6 @@ module Git.Config where
import qualified Data.Map as M import qualified Data.Map as M
import Data.Char import Data.Char
import System.Process (cwd, env)
import Control.Exception.Extensible import Control.Exception.Extensible
import Common import Common

View file

@ -37,8 +37,8 @@ get = do
case wt of case wt of
Nothing -> return r Nothing -> return r
Just d -> do Just d -> do
cwd <- getCurrentDirectory curr <- getCurrentDirectory
unless (d `dirContains` cwd) $ unless (d `dirContains` curr) $
setCurrentDirectory d setCurrentDirectory d
return $ addworktree wt r return $ addworktree wt r
where where
@ -57,8 +57,8 @@ get = do
configure Nothing (Just r) = Git.Config.read r configure Nothing (Just r) = Git.Config.read r
configure (Just d) _ = do configure (Just d) _ = do
absd <- absPath d absd <- absPath d
cwd <- getCurrentDirectory curr <- getCurrentDirectory
r <- newFrom $ Local { gitdir = absd, worktree = Just cwd } r <- newFrom $ Local { gitdir = absd, worktree = Just curr }
Git.Config.read r Git.Config.read r
configure Nothing Nothing = error "Not in a git repository." configure Nothing Nothing = error "Not in a git repository."

View file

@ -23,7 +23,6 @@ import Utility.Batch
import qualified Git.Version import qualified Git.Version
import qualified Data.Set as S import qualified Data.Set as S
import System.Process (std_out, std_err)
import Control.Concurrent.Async import Control.Concurrent.Async
type MissingObjects = S.Set Sha type MissingObjects = S.Set Sha

View file

@ -132,8 +132,8 @@ typeChanged' ps l repo = do
-- git diff returns filenames relative to the top of the git repo; -- git diff returns filenames relative to the top of the git repo;
-- convert to filenames relative to the cwd, like git ls-files. -- convert to filenames relative to the cwd, like git ls-files.
let top = repoPath repo let top = repoPath repo
cwd <- getCurrentDirectory currdir <- getCurrentDirectory
return (map (\f -> relPathDirToFile cwd $ top </> f) fs, cleanup) return (map (\f -> relPathDirToFile currdir $ top </> f) fs, cleanup)
where where
prefix = [Params "diff --name-only --diff-filter=T -z"] prefix = [Params "diff --name-only --diff-filter=T -z"]
suffix = Param "--" : (if null l then [File "."] else map File l) suffix = Param "--" : (if null l then [File "."] else map File l)

View file

@ -24,9 +24,6 @@ import Git.Command
import qualified Git.UpdateIndex import qualified Git.UpdateIndex
import qualified Data.Map as M import qualified Data.Map as M
#ifndef mingw32_HOST_OS
import System.Process
#endif
{- Queable actions that can be performed in a git repository. {- Queable actions that can be performed in a git repository.
-} -}

View file

@ -30,7 +30,6 @@ import Git.FilePath
import Git.Sha import Git.Sha
import Control.Exception (bracket) import Control.Exception (bracket)
import System.Process (std_in)
{- Streamers are passed a callback and should feed it lines in the form {- Streamers are passed a callback and should feed it lines in the form
- read by update-index, and generated by ls-tree. -} - read by update-index, and generated by ls-tree. -}

View file

@ -142,8 +142,8 @@ gitAnnexLocation' key r crippled
{- Calculates a symlink to link a file to an annexed object. -} {- Calculates a symlink to link a file to an annexed object. -}
gitAnnexLink :: FilePath -> Key -> Git.Repo -> IO FilePath gitAnnexLink :: FilePath -> Key -> Git.Repo -> IO FilePath
gitAnnexLink file key r = do gitAnnexLink file key r = do
cwd <- getCurrentDirectory currdir <- getCurrentDirectory
let absfile = fromMaybe whoops $ absNormPathUnix cwd file let absfile = fromMaybe whoops $ absNormPathUnix currdir file
loc <- gitAnnexLocation' key r False loc <- gitAnnexLocation' key r False
return $ relPathDirToFile (parentDir absfile) loc return $ relPathDirToFile (parentDir absfile) loc
where where

View file

@ -28,7 +28,6 @@ import Annex.Exception
import Creds import Creds
import Control.Concurrent.STM import Control.Concurrent.STM
import System.Process (std_in, std_out, std_err)
import System.Log.Logger (debugM) import System.Log.Logger (debugM)
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L

View file

@ -55,7 +55,6 @@ import Creds
import Control.Concurrent import Control.Concurrent
import Control.Concurrent.MSampleVar import Control.Concurrent.MSampleVar
import System.Process (std_in, std_err)
import qualified Data.Map as M import qualified Data.Map as M
import Control.Exception.Extensible import Control.Exception.Extensible
@ -467,12 +466,12 @@ fsckOnRemote r params
| otherwise = return $ do | otherwise = return $ do
program <- readProgramFile program <- readProgramFile
r' <- Git.Config.read r r' <- Git.Config.read r
env <- getEnvironment environ <- getEnvironment
let env' = addEntries let environ' = addEntries
[ ("GIT_WORK_TREE", Git.repoPath r') [ ("GIT_WORK_TREE", Git.repoPath r')
, ("GIT_DIR", Git.localGitDir r') , ("GIT_DIR", Git.localGitDir r')
] env ] environ
batchCommandEnv program (Param "fsck" : params) $ Just env' batchCommandEnv program (Param "fsck" : params) $ Just environ'
{- The passed repair action is run in the Annex monad of the remote. -} {- The passed repair action is run in the Annex monad of the remote. -}
repairRemote :: Git.Repo -> Annex Bool -> Annex (IO Bool) repairRemote :: Git.Repo -> Annex Bool -> Annex (IO Bool)

View file

@ -27,8 +27,6 @@ import Annex.Content
import Annex.UUID import Annex.UUID
import Utility.Env import Utility.Env
import System.Process
type Vault = String type Vault = String
type Archive = FilePath type Archive = FilePath

View file

@ -79,15 +79,15 @@ hookEnv :: Action -> Key -> Maybe FilePath -> IO (Maybe [(String, String)])
hookEnv action k f = Just <$> mergeenv (fileenv f ++ keyenv) hookEnv action k f = Just <$> mergeenv (fileenv f ++ keyenv)
where where
mergeenv l = addEntries l <$> getEnvironment mergeenv l = addEntries l <$> getEnvironment
env s v = ("ANNEX_" ++ s, v) envvar s v = ("ANNEX_" ++ s, v)
keyenv = catMaybes keyenv = catMaybes
[ Just $ env "KEY" (key2file k) [ Just $ envvar "KEY" (key2file k)
, Just $ env "ACTION" action , Just $ envvar "ACTION" action
, env "HASH_1" <$> headMaybe hashbits , envvar "HASH_1" <$> headMaybe hashbits
, env "HASH_2" <$> headMaybe (drop 1 hashbits) , envvar "HASH_2" <$> headMaybe (drop 1 hashbits)
] ]
fileenv Nothing = [] fileenv Nothing = []
fileenv (Just file) = [env "FILE" file] fileenv (Just file) = [envvar "FILE" file]
hashbits = map takeDirectory $ splitPath $ hashDirMixed k hashbits = map takeDirectory $ splitPath $ hashDirMixed k
lookupHook :: HookName -> Action -> Annex (Maybe String) lookupHook :: HookName -> Action -> Annex (Maybe String)
@ -155,5 +155,5 @@ checkPresent r h k = do
findkey s = key2file k `elem` lines s findkey s = key2file k `elem` lines s
check Nothing = error $ action ++ " hook misconfigured" check Nothing = error $ action ++ " hook misconfigured"
check (Just hook) = do check (Just hook) = do
env <- hookEnv action k Nothing environ <- hookEnv action k Nothing
findkey <$> readProcessEnv "sh" ["-c", hook] env findkey <$> readProcessEnv "sh" ["-c", hook] environ

View file

@ -20,7 +20,6 @@ import Utility.ThreadScheduler
import Control.Concurrent.Chan import Control.Concurrent.Chan
import Control.Concurrent.Async import Control.Concurrent.Async
import System.Process (std_in, std_out, std_err)
transport :: Transport transport :: Transport
transport r url h@(TransportHandle g s) ichan ochan = do transport r url h@(TransportHandle g s) ichan ochan = do

816
Test.hs

File diff suppressed because it is too large Load diff

View file

@ -16,7 +16,6 @@ import Control.Concurrent.Async
import System.Posix.Process import System.Posix.Process
#endif #endif
import qualified Control.Exception as E import qualified Control.Exception as E
import System.Process (env)
{- Runs an operation, at batch priority. {- Runs an operation, at batch priority.
- -

View file

@ -37,8 +37,8 @@ data CoProcessSpec = CoProcessSpec
} }
start :: Int -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle start :: Int -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle
start numrestarts cmd params env = do start numrestarts cmd params environ = do
s <- start' $ CoProcessSpec numrestarts cmd params env s <- start' $ CoProcessSpec numrestarts cmd params environ
newMVar s newMVar s
start' :: CoProcessSpec -> IO CoProcessState start' :: CoProcessSpec -> IO CoProcessState

View file

@ -15,7 +15,6 @@ import Utility.Process
import Utility.FileSystemEncoding import Utility.FileSystemEncoding
import Utility.Misc import Utility.Misc
import System.Process
import Data.List import Data.List
import Data.Char import Data.Char
import Control.Applicative import Control.Applicative

View file

@ -10,7 +10,7 @@
module Utility.Process ( module Utility.Process (
module X, module X,
CreateProcess, CreateProcess(..),
StdHandle(..), StdHandle(..),
readProcess, readProcess,
readProcessEnv, readProcessEnv,

View file

@ -9,7 +9,6 @@ module Utility.SafeCommand where
import System.Exit import System.Exit
import Utility.Process import Utility.Process
import System.Process (env)
import Data.String.Utils import Data.String.Utils
import Control.Applicative import Control.Applicative
import System.FilePath import System.FilePath