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 Data.Hash.MD5
import System.Process (cwd)
import System.Exit
import Common.Annex

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -38,7 +38,6 @@ import Utility.Env
import Network.Protocol.XMPP
import qualified Data.Text as T
import System.Posix.Types
import System.Process (std_in, std_out, std_err)
import Control.Concurrent
import System.Timeout
import qualified Data.ByteString as B
@ -112,15 +111,15 @@ xmppPush cid gitpush = do
tmpdir <- gettmpdir
installwrapper tmpdir
env <- liftIO getEnvironment
environ <- liftIO getEnvironment
path <- liftIO getSearchPath
let myenv = addEntries
let myenviron = addEntries
[ ("PATH", intercalate [searchPathSeparator] $ tmpdir:path)
, (relayIn, show inf)
, (relayOut, show outf)
, (relayControl, show controlf)
]
env
environ
inh <- liftIO $ fdToHandle readpush
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
- Annex monad. Also, override environment. -}
g <- liftAnnex gitRepo
r <- liftIO $ gitpush $ g { gitEnv = Just myenv }
r <- liftIO $ gitpush $ g { gitEnv = Just myenviron }
liftIO $ do
mapM_ killThread [t1, t2]

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -23,7 +23,6 @@ import Utility.Batch
import qualified Git.Version
import qualified Data.Set as S
import System.Process (std_out, std_err)
import Control.Concurrent.Async
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;
-- convert to filenames relative to the cwd, like git ls-files.
let top = repoPath repo
cwd <- getCurrentDirectory
return (map (\f -> relPathDirToFile cwd $ top </> f) fs, cleanup)
currdir <- getCurrentDirectory
return (map (\f -> relPathDirToFile currdir $ top </> f) fs, cleanup)
where
prefix = [Params "diff --name-only --diff-filter=T -z"]
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 Data.Map as M
#ifndef mingw32_HOST_OS
import System.Process
#endif
{- Queable actions that can be performed in a git repository.
-}

View file

@ -30,7 +30,6 @@ import Git.FilePath
import Git.Sha
import Control.Exception (bracket)
import System.Process (std_in)
{- Streamers are passed a callback and should feed it lines in the form
- 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. -}
gitAnnexLink :: FilePath -> Key -> Git.Repo -> IO FilePath
gitAnnexLink file key r = do
cwd <- getCurrentDirectory
let absfile = fromMaybe whoops $ absNormPathUnix cwd file
currdir <- getCurrentDirectory
let absfile = fromMaybe whoops $ absNormPathUnix currdir file
loc <- gitAnnexLocation' key r False
return $ relPathDirToFile (parentDir absfile) loc
where

View file

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

View file

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

View file

@ -27,8 +27,6 @@ import Annex.Content
import Annex.UUID
import Utility.Env
import System.Process
type Vault = String
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)
where
mergeenv l = addEntries l <$> getEnvironment
env s v = ("ANNEX_" ++ s, v)
envvar s v = ("ANNEX_" ++ s, v)
keyenv = catMaybes
[ Just $ env "KEY" (key2file k)
, Just $ env "ACTION" action
, env "HASH_1" <$> headMaybe hashbits
, env "HASH_2" <$> headMaybe (drop 1 hashbits)
[ Just $ envvar "KEY" (key2file k)
, Just $ envvar "ACTION" action
, envvar "HASH_1" <$> headMaybe hashbits
, envvar "HASH_2" <$> headMaybe (drop 1 hashbits)
]
fileenv Nothing = []
fileenv (Just file) = [env "FILE" file]
fileenv (Just file) = [envvar "FILE" file]
hashbits = map takeDirectory $ splitPath $ hashDirMixed k
lookupHook :: HookName -> Action -> Annex (Maybe String)
@ -155,5 +155,5 @@ checkPresent r h k = do
findkey s = key2file k `elem` lines s
check Nothing = error $ action ++ " hook misconfigured"
check (Just hook) = do
env <- hookEnv action k Nothing
findkey <$> readProcessEnv "sh" ["-c", hook] env
environ <- hookEnv action k Nothing
findkey <$> readProcessEnv "sh" ["-c", hook] environ

View file

@ -20,7 +20,6 @@ import Utility.ThreadScheduler
import Control.Concurrent.Chan
import Control.Concurrent.Async
import System.Process (std_in, std_out, std_err)
transport :: Transport
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
#endif
import qualified Control.Exception as E
import System.Process (env)
{- 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 numrestarts cmd params env = do
s <- start' $ CoProcessSpec numrestarts cmd params env
start numrestarts cmd params environ = do
s <- start' $ CoProcessSpec numrestarts cmd params environ
newMVar s
start' :: CoProcessSpec -> IO CoProcessState

View file

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

View file

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

View file

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