never executed always true always false
1 {-# LANGUAGE ForeignFunctionInterface, CPP #-}
2
3 module Distribution.Client.Utils ( MergeResult(..)
4 , mergeBy, duplicates, duplicatesBy
5 , readMaybe
6 , inDir, withEnv, withEnvOverrides
7 , logDirChange, withExtraPathEnv
8 , determineNumJobs, numberOfProcessors
9 , removeExistingFile
10 , withTempFileName
11 , makeAbsoluteToCwd
12 , makeRelativeToCwd, makeRelativeToDir
13 , makeRelativeCanonical
14 , filePathToByteString
15 , byteStringToFilePath, tryCanonicalizePath
16 , canonicalizePathNoThrow
17 , moreRecentFile, existsAndIsMoreRecentThan
18 , tryFindAddSourcePackageDesc
19 , tryFindPackageDesc
20 , relaxEncodingErrors
21 , ProgressPhase (..)
22 , progressMessage
23 , cabalInstallVersion)
24 where
25
26 import Prelude ()
27 import Distribution.Client.Compat.Prelude
28
29 import Distribution.Compat.Environment
30 import Distribution.Compat.Time ( getModTime )
31 import Distribution.Simple.Setup ( Flag(..) )
32 import Distribution.Version
33 import Distribution.Simple.Utils ( die', findPackageDesc, noticeNoWrap )
34 import qualified Data.ByteString.Lazy as BS
35 import Data.Bits
36 ( (.|.), shiftL, shiftR )
37 import System.FilePath
38 import Control.Monad
39 ( zipWithM_ )
40 import Data.List
41 ( groupBy )
42 import Foreign.C.Types ( CInt(..) )
43 import qualified Control.Exception as Exception
44 ( finally, bracket )
45 import System.Directory
46 ( canonicalizePath, doesFileExist, getCurrentDirectory
47 , removeFile, setCurrentDirectory )
48 import System.IO
49 ( Handle, hClose, openTempFile
50 , hGetEncoding, hSetEncoding
51 )
52 import System.IO.Unsafe ( unsafePerformIO )
53
54 import GHC.IO.Encoding
55 ( recover, TextEncoding(TextEncoding) )
56 import GHC.IO.Encoding.Failure
57 ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) )
58
59 #if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)
60 import qualified System.Directory as Dir
61 import qualified System.IO.Error as IOError
62 #endif
63
64
65
66 -- | Generic merging utility. For sorted input lists this is a full outer join.
67 --
68 mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
69 mergeBy cmp = merge
70 where
71 merge [] ys = [ OnlyInRight y | y <- ys]
72 merge xs [] = [ OnlyInLeft x | x <- xs]
73 merge (x:xs) (y:ys) =
74 case x `cmp` y of
75 GT -> OnlyInRight y : merge (x:xs) ys
76 EQ -> InBoth x y : merge xs ys
77 LT -> OnlyInLeft x : merge xs (y:ys)
78
79 data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b
80
81 duplicates :: Ord a => [a] -> [[a]]
82 duplicates = duplicatesBy compare
83
84 duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]]
85 duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp
86 where
87 eq a b = case cmp a b of
88 EQ -> True
89 _ -> False
90 moreThanOne (_:_:_) = True
91 moreThanOne _ = False
92
93 -- | Like 'removeFile', but does not throw an exception when the file does not
94 -- exist.
95 removeExistingFile :: FilePath -> IO ()
96 removeExistingFile path = do
97 exists <- doesFileExist path
98 when exists $
99 removeFile path
100
101 -- | A variant of 'withTempFile' that only gives us the file name, and while
102 -- it will clean up the file afterwards, it's lenient if the file is
103 -- moved\/deleted.
104 --
105 withTempFileName :: FilePath
106 -> String
107 -> (FilePath -> IO a) -> IO a
108 withTempFileName tmpDir template action =
109 Exception.bracket
110 (openTempFile tmpDir template)
111 (\(name, _) -> removeExistingFile name)
112 (\(name, h) -> hClose h >> action name)
113
114 -- | Executes the action in the specified directory.
115 --
116 -- Warning: This operation is NOT thread-safe, because current
117 -- working directory is a process-global concept.
118 inDir :: Maybe FilePath -> IO a -> IO a
119 inDir Nothing m = m
120 inDir (Just d) m = do
121 old <- getCurrentDirectory
122 setCurrentDirectory d
123 m `Exception.finally` setCurrentDirectory old
124
125 -- | Executes the action with an environment variable set to some
126 -- value.
127 --
128 -- Warning: This operation is NOT thread-safe, because current
129 -- environment is a process-global concept.
130 withEnv :: String -> String -> IO a -> IO a
131 withEnv k v m = do
132 mb_old <- lookupEnv k
133 setEnv k v
134 m `Exception.finally` (case mb_old of
135 Nothing -> unsetEnv k
136 Just old -> setEnv k old)
137
138 -- | Executes the action with a list of environment variables and
139 -- corresponding overrides, where
140 --
141 -- * @'Just' v@ means \"set the environment variable's value to @v@\".
142 -- * 'Nothing' means \"unset the environment variable\".
143 --
144 -- Warning: This operation is NOT thread-safe, because current
145 -- environment is a process-global concept.
146 withEnvOverrides :: [(String, Maybe FilePath)] -> IO a -> IO a
147 withEnvOverrides overrides m = do
148 mb_olds <- traverse lookupEnv envVars
149 traverse_ (uncurry update) overrides
150 m `Exception.finally` zipWithM_ update envVars mb_olds
151 where
152 envVars :: [String]
153 envVars = map fst overrides
154
155 update :: String -> Maybe FilePath -> IO ()
156 update var Nothing = unsetEnv var
157 update var (Just val) = setEnv var val
158
159 -- | Executes the action, increasing the PATH environment
160 -- in some way
161 --
162 -- Warning: This operation is NOT thread-safe, because the
163 -- environment variables are a process-global concept.
164 withExtraPathEnv :: [FilePath] -> IO a -> IO a
165 withExtraPathEnv paths m = do
166 oldPathSplit <- getSearchPath
167 let newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit)
168 oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit
169 -- TODO: This is a horrible hack to work around the fact that
170 -- setEnv can't take empty values as an argument
171 mungePath p | p == "" = "/dev/null"
172 | otherwise = p
173 setEnv "PATH" newPath
174 m `Exception.finally` setEnv "PATH" oldPath
175
176 -- | Log directory change in 'make' compatible syntax
177 logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a
178 logDirChange _ Nothing m = m
179 logDirChange l (Just d) m = do
180 l $ "cabal: Entering directory '" ++ d ++ "'\n"
181 m `Exception.finally`
182 (l $ "cabal: Leaving directory '" ++ d ++ "'\n")
183
184 foreign import ccall "getNumberOfProcessors" c_getNumberOfProcessors :: IO CInt
185
186 -- The number of processors is not going to change during the duration of the
187 -- program, so unsafePerformIO is safe here.
188 numberOfProcessors :: Int
189 numberOfProcessors = fromEnum $ unsafePerformIO c_getNumberOfProcessors
190
191 -- | Determine the number of jobs to use given the value of the '-j' flag.
192 determineNumJobs :: Flag (Maybe Int) -> Int
193 determineNumJobs numJobsFlag =
194 case numJobsFlag of
195 NoFlag -> 1
196 Flag Nothing -> numberOfProcessors
197 Flag (Just n) -> n
198
199 -- | Given a relative path, make it absolute relative to the current
200 -- directory. Absolute paths are returned unmodified.
201 makeAbsoluteToCwd :: FilePath -> IO FilePath
202 makeAbsoluteToCwd path | isAbsolute path = return path
203 | otherwise = do cwd <- getCurrentDirectory
204 return $! cwd </> path
205
206 -- | Given a path (relative or absolute), make it relative to the current
207 -- directory, including using @../..@ if necessary.
208 makeRelativeToCwd :: FilePath -> IO FilePath
209 makeRelativeToCwd path =
210 makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory
211
212 -- | Given a path (relative or absolute), make it relative to the given
213 -- directory, including using @../..@ if necessary.
214 makeRelativeToDir :: FilePath -> FilePath -> IO FilePath
215 makeRelativeToDir path dir =
216 makeRelativeCanonical <$> canonicalizePath path <*> canonicalizePath dir
217
218 -- | Given a canonical absolute path and canonical absolute dir, make the path
219 -- relative to the directory, including using @../..@ if necessary. Returns
220 -- the original absolute path if it is not on the same drive as the given dir.
221 makeRelativeCanonical :: FilePath -> FilePath -> FilePath
222 makeRelativeCanonical path dir
223 | takeDrive path /= takeDrive dir = path
224 | otherwise = go (splitPath path) (splitPath dir)
225 where
226 go (p:ps) (d:ds) | p == d = go ps ds
227 go [] [] = "./"
228 go ps ds = joinPath (replicate (length ds) ".." ++ ps)
229
230 -- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is
231 -- encoded as a little-endian 'Word32'.
232 filePathToByteString :: FilePath -> BS.ByteString
233 filePathToByteString p =
234 BS.pack $ foldr conv [] codepts
235 where
236 codepts :: [Word32]
237 codepts = map (fromIntegral . ord) p
238
239 conv :: Word32 -> [Word8] -> [Word8]
240 conv w32 rest = b0:b1:b2:b3:rest
241 where
242 b0 = fromIntegral $ w32
243 b1 = fromIntegral $ w32 `shiftR` 8
244 b2 = fromIntegral $ w32 `shiftR` 16
245 b3 = fromIntegral $ w32 `shiftR` 24
246
247 -- | Reverse operation to 'filePathToByteString'.
248 byteStringToFilePath :: BS.ByteString -> FilePath
249 byteStringToFilePath bs | bslen `mod` 4 /= 0 = unexpected
250 | otherwise = go 0
251 where
252 unexpected = "Distribution.Client.Utils.byteStringToFilePath: unexpected"
253 bslen = BS.length bs
254
255 go i | i == bslen = []
256 | otherwise = (chr . fromIntegral $ w32) : go (i+4)
257 where
258 w32 :: Word32
259 w32 = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24)
260 b0 = fromIntegral $ BS.index bs i
261 b1 = fromIntegral $ BS.index bs (i + 1)
262 b2 = fromIntegral $ BS.index bs (i + 2)
263 b3 = fromIntegral $ BS.index bs (i + 3)
264
265 -- | Workaround for the inconsistent behaviour of 'canonicalizePath'. Always
266 -- throws an error if the path refers to a non-existent file.
267 tryCanonicalizePath :: FilePath -> IO FilePath
268 tryCanonicalizePath path = do
269 ret <- canonicalizePath path
270 #if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)
271 exists <- liftM2 (||) (doesFileExist ret) (Dir.doesDirectoryExist ret)
272 unless exists $
273 IOError.ioError $ IOError.mkIOError IOError.doesNotExistErrorType "canonicalizePath"
274 Nothing (Just ret)
275 #endif
276 return ret
277
278 -- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws
279 -- an exception, returns the path argument unmodified.
280 canonicalizePathNoThrow :: FilePath -> IO FilePath
281 canonicalizePathNoThrow path = do
282 canonicalizePath path `catchIO` (\_ -> return path)
283
284 --------------------
285 -- Modification time
286
287 -- | Like Distribution.Simple.Utils.moreRecentFile, but uses getModTime instead
288 -- of getModificationTime for higher precision. We can't merge the two because
289 -- Distribution.Client.Time uses MIN_VERSION macros.
290 moreRecentFile :: FilePath -> FilePath -> IO Bool
291 moreRecentFile a b = do
292 exists <- doesFileExist b
293 if not exists
294 then return True
295 else do tb <- getModTime b
296 ta <- getModTime a
297 return (ta > tb)
298
299 -- | Like 'moreRecentFile', but also checks that the first file exists.
300 existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool
301 existsAndIsMoreRecentThan a b = do
302 exists <- doesFileExist a
303 if not exists
304 then return False
305 else a `moreRecentFile` b
306
307 -- | Sets the handler for encoding errors to one that transliterates invalid
308 -- characters into one present in the encoding (i.e., \'?\').
309 -- This is opposed to the default behavior, which is to throw an exception on
310 -- error. This function will ignore file handles that have a Unicode encoding
311 -- set. It's a no-op for versions of `base` less than 4.4.
312 relaxEncodingErrors :: Handle -> IO ()
313 relaxEncodingErrors handle = do
314 maybeEncoding <- hGetEncoding handle
315 case maybeEncoding of
316 Just (TextEncoding name decoder encoder) | not ("UTF" `isPrefixOf` name) ->
317 let relax x = x { recover = recoverEncode TransliterateCodingFailure }
318 in hSetEncoding handle (TextEncoding name decoder (fmap relax encoder))
319 _ ->
320 return ()
321
322 -- |Like 'tryFindPackageDesc', but with error specific to add-source deps.
323 tryFindAddSourcePackageDesc :: Verbosity -> FilePath -> String -> IO FilePath
324 tryFindAddSourcePackageDesc verbosity depPath err = tryFindPackageDesc verbosity depPath $
325 err ++ "\n" ++ "Failed to read cabal file of add-source dependency: "
326 ++ depPath
327
328 -- |Try to find a @.cabal@ file, in directory @depPath@. Fails if one cannot be
329 -- found, with @err@ prefixing the error message. This function simply allows
330 -- us to give a more descriptive error than that provided by @findPackageDesc@.
331 tryFindPackageDesc :: Verbosity -> FilePath -> String -> IO FilePath
332 tryFindPackageDesc verbosity depPath err = do
333 errOrCabalFile <- findPackageDesc depPath
334 case errOrCabalFile of
335 Right file -> return file
336 Left _ -> die' verbosity err
337
338 -- | Phase of building a dependency. Represents current status of package
339 -- dependency processing. See #4040 for details.
340 data ProgressPhase
341 = ProgressDownloading
342 | ProgressDownloaded
343 | ProgressStarting
344 | ProgressBuilding
345 | ProgressHaddock
346 | ProgressInstalling
347 | ProgressCompleted
348
349 progressMessage :: Verbosity -> ProgressPhase -> String -> IO ()
350 progressMessage verbosity phase subject = do
351 noticeNoWrap verbosity $ phaseStr ++ subject ++ "\n"
352 where
353 phaseStr = case phase of
354 ProgressDownloading -> "Downloading "
355 ProgressDownloaded -> "Downloaded "
356 ProgressStarting -> "Starting "
357 ProgressBuilding -> "Building "
358 ProgressHaddock -> "Haddock "
359 ProgressInstalling -> "Installing "
360 ProgressCompleted -> "Completed "
361
362 cabalInstallVersion :: Version
363 cabalInstallVersion = mkVersion [3,5]