1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
|
{-# LANGUAGE OverloadedStrings #-}
module ProcessUtils
( ExitCode(ExitFailure,ExitSuccess)
, systemEnv
, readPipe
, readProcessWithErrorH
, runExternal
, SpawnError(..)
, spawnDetached
) where
import GHC.IO.Exception ( ioException, IOErrorType(..) )
import System.FilePath
import System.Directory
import System.Process
import System.Posix.Signals
import System.Posix.Process
import System.Process.Internals (runGenProcess_,defaultSignal)
import System.Environment
import Data.Maybe ( isNothing, fromMaybe, isJust, fromJust )
import System.IO.Error ( mkIOError, ioeSetErrorString )
import System.Exit ( ExitCode(..) )
import System.IO
import Control.Applicative
import Control.Exception (bracket)
import qualified Data.ByteString as S
import ControlMaybe (handleIO,handleIO_)
import System.Posix.Files (fileAccess)
import System.Posix.User (getRealUserID,getEffectiveUserID)
import DotLock (dotlock_disable)
-- | systemEnv
-- This is like System.Process.system except that it lets you set
-- some environment variables.
systemEnv :: [(String, String)] -> String -> IO ExitCode
systemEnv _ "" =
ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command")
systemEnv vars cmd = do
env0 <- getEnvironment
let env1 = filter (isNothing . flip lookup vars . fst) env0
env = vars ++ env1
syncProcess "system" $ (shell cmd) {env=Just env}
where
-- This is a non-exported function from System.Process
syncProcess fun c = do
-- The POSIX version of system needs to do some manipulation of signal
-- handlers. Since we're going to be synchronously waiting for the child,
-- we want to ignore ^C in the parent, but handle it the default way
-- in the child (using SIG_DFL isn't really correct, it should be the
-- original signal handler, but the GHC RTS will have already set up
-- its own handler and we don't want to use that).
old_int <- installHandler sigINT Ignore Nothing
old_quit <- installHandler sigQUIT Ignore Nothing
(_,_,_,p) <- runGenProcess_ fun c
(Just defaultSignal) (Just defaultSignal)
r <- waitForProcess p
_ <- installHandler sigINT old_int Nothing
_ <- installHandler sigQUIT old_quit Nothing
return r
-- | readPipe
--
-- This is like System.Process.readProcess but instead of a single
-- command with arguments, you pass it a list which it then executes
-- piping the the output from the prior command into the input for
-- the next command. Like readProcess the next parameter is a string
-- which is sent as input into the initial standard in.
--
-- > readPipe [("grep",["HostConfig"]),("wc",["-l"]) =<< readFile "input"
--
-- is equivalent to shell code:
--
-- > grep HostConfig input | wc -l
--
readPipe :: [(FilePath,[String])] -> String -> IO String
readPipe [(cmd,args)] input = readProcess cmd args input
readPipe ((cmd,args):xs) stdin0 = do
let p = (shell cmd) { std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
, cmdspec = RawCommand cmd args
}
(Just sinh,Just sout,Just serr, ph) <- createProcess p
hPutStr sinh stdin0
hClose sinh
readPipe0 xs sout
where
readPipe0 :: [(FilePath,[String])] -> Handle -> IO String
readPipe0 ((cmd,args):xs) stdin0 = do
let p = (shell cmd)
{ std_in = UseHandle stdin0
, std_out = CreatePipe
, std_err = CreatePipe
, cmdspec = RawCommand cmd args
}
(Nothing,Just sout,Just serr, ph) <- createProcess p
readPipe0 xs sout
readPipe0 [] h = hGetContents h
readProcessWithErrorH :: FilePath -> [String] -> String -> Handle -> IO String
readProcessWithErrorH cmd args stdin erH = do
let p = (shell cmd) { std_in = CreatePipe
, std_out = CreatePipe
, std_err = UseHandle erH
, cmdspec = RawCommand cmd args
}
bracket (createProcess p)
(\(Just sinh,Just sout,_, ph) ->
mapM_ hClose [sinh,sout] )
(\(Just sinh,Just sout,_, ph) -> do
hPutStr sinh stdin
hClose sinh
hGetContents sout )
-- | run an external command.
--
-- Arguments:
--
-- [ cmd ] command to run
--
-- [ input ] input to command (if any)
--
-- Returns:
--
-- [ code ] exit code returned by command
--
-- [ output ] captured stdout of command
--
-- [ err ] captured stderr of command
runExternal :: String -> Maybe String -> IO (Int,(S.ByteString,S.ByteString))
runExternal cmd input = do
cwd <- getCurrentDirectory
{-
putStr $ takeFileName cwd ++ "> " ++ cmd
++ case input of
Nothing -> "\n"
Just s -> " <<EOF\n" ++ s ++ "EOF\n"
-}
let p = (shell cmd) { std_in = maybe Inherit (const CreatePipe) input
, std_out = CreatePipe
, std_err = CreatePipe }
(mb_in,mb_out,mb_err,process) <- createProcess p
case mb_in of
Nothing -> return ()
Just hin -> hPutStr hin (fromMaybe "" input) >> hClose hin
out <- case mb_out of
Just hout -> S.hGetContents hout
Nothing -> return ""
err <- case mb_err of
Just herr -> S.hGetContents herr
Nothing -> return ""
code <- do
c <- waitForProcess process
return $ case c of
ExitSuccess -> 0
ExitFailure x -> x
return (code,(out,err))
data SpawnError = SpawnOK | SpawnUIDCheck | SpawnBadAccess IOError | SpawnWaitPID | SpawnFork
deriving (Eq,Show)
spawnDetached :: FilePath -> [String] -> Maybe [(String,String)] -> IO SpawnError
spawnDetached filepath args env = do
uidcheck <- (==) <$> getRealUserID <*> getEffectiveUserID
if not uidcheck then return SpawnUIDCheck else do
accesscheck <- do
handleIO (return . Just . SpawnBadAccess) $ do
b <- fileAccess filepath False False True
if not b then return $ Just $ SpawnBadAccess (userError $ "No execute permission on "++filepath)
else return Nothing
if isJust accesscheck then return (fromJust accesscheck) else do
handleIO_ (return SpawnFork) $ do
pid <- forkProcess $ do
dotlock_disable -- Disable dotlock atexit handler.
-- This wouldn't be neccessary if we used exec*
-- instead of fork.
-- clean up secure memory:
-- gcry_control (GCRYCTL_TERM_SECMEM);
-- if (setsid() == -1 || chdir ("/")) _exit (1);
-- Double fork to let init take over the new child.
handleIO_ (exitImmediately $ ExitFailure 1) $ do
pid2 <- forkProcess $ executeFile filepath False args env
exitImmediately ExitSuccess
exitImmediately ExitSuccess
handleIO_ (return SpawnWaitPID) $ do
_ <- getProcessStatus True False pid
return SpawnOK
|
