1{-# LANGUAGE CPP #-}
2module Common where
3
4import qualified Control.Exception as Exception
5import qualified Compat.TempFile as Compat
6import Control.Monad            ( when )
7import Data.Char                ( isSpace )
8import Data.List                ( foldl' )
9import System.IO
10#if defined(mingw32_HOST_OS)
11import Control.Concurrent       ( threadDelay )
12import System.IO.Error          ( isPermissionError )
13#endif
14import System.Process           ( createProcess, waitForProcess
15                                , proc, CreateProcess(..), StdStream(..) )
16import System.Exit              ( ExitCode(..), exitWith )
17import System.Directory         ( removeFile )
18
19die :: String -> IO a
20die s = hPutStr stderr s >> exitWith (ExitFailure 1)
21
22default_compiler :: String
23default_compiler = "cc"
24
25------------------------------------------------------------------------
26-- Write the output files.
27
28writeBinaryFile :: FilePath -> String -> IO ()
29writeBinaryFile fp str = withBinaryFile fp WriteMode $ \h -> hPutStr h str
30
31rawSystemL :: FilePath -> FilePath -> String -> Bool -> FilePath -> [String] -> IO ()
32rawSystemL outDir outBase action flg prog args = withResponseFile outDir outBase args $ \rspFile -> do
33  let cmdLine = prog++" "++unwords args
34  when flg $ hPutStrLn stderr ("Executing: (@" ++ rspFile ++ ") " ++ cmdLine)
35  (_ ,_ ,progerr ,ph) <- createProcess (proc prog ['@':rspFile])
36  -- Because of the response files being written and removed after the process
37  -- terminates we now need to use process jobs here to correctly wait for all
38  -- child processes to terminate.  Not doing so would causes a race condition
39  -- between the last child dieing and not holding a lock on the response file
40  -- and the response file getting deleted.
41    { std_err = CreatePipe
42#if MIN_VERSION_process(1,5,0)
43    , use_process_jobs = True
44#endif
45    }
46  exitStatus <- waitForProcess ph
47  case exitStatus of
48    ExitFailure exitCode ->
49      do errdata <- maybeReadHandle progerr
50         die $ action ++ " failed "
51                      ++ "(exit code "    ++ show exitCode ++ ")\n"
52                      ++ "rsp file was: " ++ show rspFile ++ "\n"
53                      ++ "command was: "  ++ cmdLine ++ "\n"
54                      ++ "error: "        ++ errdata ++ "\n"
55    _                    -> return ()
56
57
58rawSystemWithStdOutL :: FilePath -> FilePath -> String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
59rawSystemWithStdOutL outDir outBase action flg prog args outFile = withResponseFile outDir outBase args $ \rspFile -> do
60  let cmdLine = prog++" "++unwords args++" >"++outFile
61  when flg (hPutStrLn stderr ("Executing: (@" ++ rspFile ++ ") " ++ cmdLine))
62  hOut <- openFile outFile WriteMode
63  (_ ,_ ,progerr , process) <-
64    -- We use createProcess here instead of runProcess since we need to specify
65    -- a custom CreateProcess structure to turn on use_process_jobs when
66    -- available.
67    createProcess
68      (proc prog  ['@':rspFile])
69         { std_out = UseHandle hOut, std_err = CreatePipe
70#if MIN_VERSION_process(1,5,0)
71         , use_process_jobs = True
72#endif
73         }
74  exitStatus <- waitForProcess process
75  hClose hOut
76  case exitStatus of
77    ExitFailure exitCode ->
78      do errdata <- maybeReadHandle progerr
79         die $ action ++ " failed "
80                      ++ "(exit code "    ++ show exitCode ++ ")\n"
81                      ++ "rsp file was: " ++ show rspFile ++ "\n"
82                      ++ "output file:"   ++ show outFile ++ "\n"
83                      ++ "command was: "  ++ cmdLine ++ "\n"
84                      ++ "error: "        ++ errdata ++ "\n"
85    _                    -> return ()
86
87maybeReadHandle :: Maybe Handle -> IO String
88maybeReadHandle Nothing  = return "<no data>"
89maybeReadHandle (Just h) = hGetContents h
90
91-- delay the cleanup of generated files until the end; attempts to
92-- get around intermittent failure to delete files which has
93-- just been exec'ed by a sub-process (Win32 only.)
94finallyRemove :: FilePath -> IO a -> IO a
95finallyRemove fp act =
96  Exception.bracket_ (return fp)
97           (noisyRemove fp)
98           act
99 where
100  max_retries :: Int
101  max_retries = 5
102
103  noisyRemove :: FilePath -> IO ()
104  noisyRemove fpath =
105    catchIO (removeFileInternal max_retries fpath)
106            (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e))
107  removeFileInternal _retries path = do
108#if defined(mingw32_HOST_OS)
109  -- On Windows we have to retry the delete a couple of times.
110  -- The reason for this is that a FileDelete command just marks a
111  -- file for deletion. The file is really only removed when the last
112  -- handle to the file is closed. Unfortunately there are a lot of
113  -- system services that can have a file temporarily opened using a shared
114  -- read-only lock, such as the built in AV and search indexer.
115  --
116  -- We can't really guarantee that these are all off, so what we can do is
117  -- whenever after an rm the file still exists to try again and wait a bit.
118    res <- Exception.try $ removeFile path
119    case res of
120      Right a -> return a
121      Left ex | isPermissionError ex && _retries > 1 -> do
122                  let retries' = _retries - 1
123                  threadDelay ((max_retries - retries') * 200)
124                  removeFileInternal retries' path
125              | otherwise -> Exception.throw ex
126#else
127    removeFile path
128#endif
129
130catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
131catchIO = Exception.catch
132
133onlyOne :: String -> IO a
134onlyOne what = die ("Only one "++what++" may be specified\n")
135
136-- response file handling borrowed from cabal's at Distribution.Simple.Program.ResponseFile
137
138withTempFile :: FilePath -- ^ Temp dir to create the file in
139             -> FilePath -- ^ Name of the hsc file being processed or template
140             -> String   -- ^ Template for temp file
141             -> Int      -- ^ Random seed for tmp name
142             -> (FilePath -> Handle -> IO a) -> IO a
143withTempFile tmpDir _outBase template _seed action = do
144  Exception.bracket
145    (Compat.openTempFile tmpDir template)
146    (\(name, handle) -> finallyRemove name $ hClose handle)
147    (uncurry action)
148
149withResponseFile ::
150     FilePath           -- ^ Working directory to create response file in.
151  -> FilePath           -- ^ Template for response file name.
152  -> [String]           -- ^ Arguments to put into response file.
153  -> (FilePath -> IO a)
154  -> IO a
155withResponseFile workDir outBase arguments f =
156  withTempFile workDir outBase "hsc2hscall.rsp" (length arguments) $ \responseFileName hf -> do
157    let responseContents = unlines $ map escapeResponseFileArg arguments
158    hPutStr hf responseContents
159    hClose hf
160    f responseFileName
161
162-- Support a gcc-like response file syntax.  Each separate
163-- argument and its possible parameter(s), will be separated in the
164-- response file by an actual newline; all other whitespace,
165-- single quotes, double quotes, and the character used for escaping
166-- (backslash) are escaped.  The called program will need to do a similar
167-- inverse operation to de-escape and re-constitute the argument list.
168escapeResponseFileArg :: String -> String
169escapeResponseFileArg = reverse . foldl' escape []
170  where
171    escape :: String -> Char -> String
172    escape cs c =
173      case c of
174        '\\'          -> c:'\\':cs
175        '\''          -> c:'\\':cs
176        '"'           -> c:'\\':cs
177        _ | isSpace c -> c:'\\':cs
178          | otherwise -> c:cs
179