export CreateProcess fields from Utility.Process
update code to avoid cwd and env redefinition warnings
This commit is contained in:
parent
6eb5e6c135
commit
a44fd2c019
31 changed files with 458 additions and 480 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -9,8 +9,6 @@
|
|||
|
||||
module Git.Command where
|
||||
|
||||
import System.Process (std_out, env)
|
||||
|
||||
import Common
|
||||
import Git
|
||||
import Git.Types
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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."
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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.
|
||||
-}
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -27,8 +27,6 @@ import Annex.Content
|
|||
import Annex.UUID
|
||||
import Utility.Env
|
||||
|
||||
import System.Process
|
||||
|
||||
type Vault = String
|
||||
type Archive = FilePath
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
-
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -10,7 +10,7 @@
|
|||
|
||||
module Utility.Process (
|
||||
module X,
|
||||
CreateProcess,
|
||||
CreateProcess(..),
|
||||
StdHandle(..),
|
||||
readProcess,
|
||||
readProcessEnv,
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue