Utils.hs 12 KB
Newer Older
1
{-# LANGUAGE ForeignFunctionInterface, CPP #-}
2
3
4

module Distribution.Client.Utils ( MergeResult(..)
                                 , mergeBy, duplicates, duplicatesBy
5
                                 , readMaybe
6
                                 , inDir, withEnv, logDirChange
7
                                 , withExtraPathEnv
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
8
                                 , determineNumJobs, numberOfProcessors
9
                                 , removeExistingFile
10
                                 , withTempFileName
11
12
13
                                 , makeAbsoluteToCwd
                                 , makeRelativeToCwd, makeRelativeToDir
                                 , filePathToByteString
14
                                 , byteStringToFilePath, tryCanonicalizePath
15
                                 , canonicalizePathNoThrow
16
                                 , moreRecentFile, existsAndIsMoreRecentThan
17
18
                                 , tryFindAddSourcePackageDesc
                                 , tryFindPackageDesc
19
                                 , relaxEncodingErrors)
20
       where
Duncan Coutts's avatar
Duncan Coutts committed
21

22
23
24
import Prelude ()
import Distribution.Client.Compat.Prelude

25
import Distribution.Compat.Environment
26
import Distribution.Compat.Exception   ( catchIO )
27
import Distribution.Compat.Time ( getModTime )
28
import Distribution.Simple.Setup       ( Flag(..) )
29
import Distribution.Simple.Utils       ( die, findPackageDesc )
30
31
32
import qualified Data.ByteString.Lazy as BS
import Data.Bits
         ( (.|.), shiftL, shiftR )
33
import System.FilePath
34
import Data.List
35
         ( groupBy )
36
37
import Data.Word
         ( Word8, Word32)
38
import Foreign.C.Types ( CInt(..) )
39
import qualified Control.Exception as Exception
40
         ( finally, bracket )
41
import System.Directory
42
43
         ( canonicalizePath, doesFileExist, getCurrentDirectory
         , removeFile, setCurrentDirectory )
44
import System.IO
45
         ( Handle, hClose, openTempFile
46
47
48
49
#if MIN_VERSION_base(4,4,0)
         , hGetEncoding, hSetEncoding
#endif
         )
50
51
import System.IO.Unsafe ( unsafePerformIO )

52
#if MIN_VERSION_base(4,4,0)
53
54
55
56
import GHC.IO.Encoding
         ( recover, TextEncoding(TextEncoding) )
import GHC.IO.Encoding.Failure
         ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) )
57
#endif
58

59
#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)
60
import Prelude hiding (ioError)
61
import System.Directory (doesDirectoryExist)
62
import System.IO.Error (ioError, mkIOError, doesNotExistErrorType)
63
64
#endif

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
-- | Generic merging utility. For sorted input lists this is a full outer join.
--
mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
mergeBy cmp = merge
  where
    merge []     ys     = [ OnlyInRight y | y <- ys]
    merge xs     []     = [ OnlyInLeft  x | x <- xs]
    merge (x:xs) (y:ys) =
      case x `cmp` y of
        GT -> OnlyInRight   y : merge (x:xs) ys
        EQ -> InBoth      x y : merge xs     ys
        LT -> OnlyInLeft  x   : merge xs  (y:ys)

data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b

duplicates :: Ord a => [a] -> [[a]]
duplicates = duplicatesBy compare

duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]]
duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp
  where
    eq a b = case cmp a b of
               EQ -> True
               _  -> False
    moreThanOne (_:_:_) = True
    moreThanOne _       = False
91

92
93
94
95
96
97
98
99
-- | Like 'removeFile', but does not throw an exception when the file does not
-- exist.
removeExistingFile :: FilePath -> IO ()
removeExistingFile path = do
  exists <- doesFileExist path
  when exists $
    removeFile path

100
101
102
103
104
105
106
107
108
109
110
111
112
-- | A variant of 'withTempFile' that only gives us the file name, and while
-- it will clean up the file afterwards, it's lenient if the file is
-- moved\/deleted.
--
withTempFileName :: FilePath
                 -> String
                 -> (FilePath -> IO a) -> IO a
withTempFileName tmpDir template action =
  Exception.bracket
    (openTempFile tmpDir template)
    (\(name, _) -> removeExistingFile name)
    (\(name, h) -> hClose h >> action name)

113
-- | Executes the action in the specified directory.
114
115
116
--
-- Warning: This operation is NOT thread-safe, because current
-- working directory is a process-global concept.
refold's avatar
refold committed
117
inDir :: Maybe FilePath -> IO a -> IO a
118
119
120
121
122
inDir Nothing m = m
inDir (Just d) m = do
  old <- getCurrentDirectory
  setCurrentDirectory d
  m `Exception.finally` setCurrentDirectory old
123

124
125
126
127
128
129
130
131
132
133
134
135
136
-- | Executes the action with an environment variable set to some
-- value.
--
-- Warning: This operation is NOT thread-safe, because current
-- environment is a process-global concept.
withEnv :: String -> String -> IO a -> IO a
withEnv k v m = do
  mb_old <- lookupEnv k
  setEnv k v
  m `Exception.finally` (case mb_old of
    Nothing -> unsetEnv k
    Just old -> setEnv k old)

137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
-- | Executes the action, increasing the PATH environment
-- in some way
--
-- Warning: This operation is NOT thread-safe, because the
-- environment variables are a process-global concept.
withExtraPathEnv :: [FilePath] -> IO a -> IO a
withExtraPathEnv paths m = do
  oldPathSplit <- getSearchPath
  let newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit)
      oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit
      -- TODO: This is a horrible hack to work around the fact that
      -- setEnv can't take empty values as an argument
      mungePath p | p == ""   = "/dev/null"
                  | otherwise = p
  setEnv "PATH" newPath
  m `Exception.finally` setEnv "PATH" oldPath

154
155
156
157
158
159
160
161
-- | Log directory change in 'make' compatible syntax
logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a
logDirChange _ Nothing m = m
logDirChange l (Just d) m = do
  l $ "cabal: Entering directory '" ++ d ++ "'\n"
  m `Exception.finally`
    (l $ "cabal: Leaving directory '" ++ d ++ "'\n")

162
163
164
165
166
167
foreign import ccall "getNumberOfProcessors" c_getNumberOfProcessors :: IO CInt

-- The number of processors is not going to change during the duration of the
-- program, so unsafePerformIO is safe here.
numberOfProcessors :: Int
numberOfProcessors = fromEnum $ unsafePerformIO c_getNumberOfProcessors
168

169
170
171
172
173
174
175
176
-- | Determine the number of jobs to use given the value of the '-j' flag.
determineNumJobs :: Flag (Maybe Int) -> Int
determineNumJobs numJobsFlag =
  case numJobsFlag of
    NoFlag        -> 1
    Flag Nothing  -> numberOfProcessors
    Flag (Just n) -> n

177
178
179
180
181
182
-- | Given a relative path, make it absolute relative to the current
-- directory. Absolute paths are returned unmodified.
makeAbsoluteToCwd :: FilePath -> IO FilePath
makeAbsoluteToCwd path | isAbsolute path = return path
                       | otherwise       = do cwd <- getCurrentDirectory
                                              return $! cwd </> path
183

184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
-- | Given a path (relative or absolute), make it relative to the current
-- directory, including using @../..@ if necessary.
makeRelativeToCwd :: FilePath -> IO FilePath
makeRelativeToCwd path =
    makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory

-- | Given a path (relative or absolute), make it relative to the given
-- directory, including using @../..@ if necessary.
makeRelativeToDir :: FilePath -> FilePath -> IO FilePath
makeRelativeToDir path dir =
    makeRelativeCanonical <$> canonicalizePath path <*> canonicalizePath dir

-- | Given a canonical absolute path and canonical absolute dir, make the path
-- relative to the directory, including using @../..@ if necessary. Returns
-- the original absolute path if it is not on the same drive as the given dir.
makeRelativeCanonical :: FilePath -> FilePath -> FilePath
makeRelativeCanonical path dir
  | takeDrive path /= takeDrive dir = path
  | otherwise                       = go (splitPath path) (splitPath dir)
  where
    go (p:ps) (d:ds) | p == d = go ps ds
    go    []     []           = "./"
    go    ps     ds           = joinPath (replicate (length ds) ".." ++ ps)

208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
-- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is
-- encoded as a little-endian 'Word32'.
filePathToByteString :: FilePath -> BS.ByteString
filePathToByteString p =
  BS.pack $ foldr conv [] codepts
  where
    codepts :: [Word32]
    codepts = map (fromIntegral . ord) p

    conv :: Word32 -> [Word8] -> [Word8]
    conv w32 rest = b0:b1:b2:b3:rest
      where
        b0 = fromIntegral $ w32
        b1 = fromIntegral $ w32 `shiftR` 8
        b2 = fromIntegral $ w32 `shiftR` 16
        b3 = fromIntegral $ w32 `shiftR` 24

-- | Reverse operation to 'filePathToByteString'.
byteStringToFilePath :: BS.ByteString -> FilePath
byteStringToFilePath bs | bslen `mod` 4 /= 0 = unexpected
                        | otherwise = go 0
  where
    unexpected = "Distribution.Client.Utils.byteStringToFilePath: unexpected"
    bslen = BS.length bs

    go i | i == bslen = []
         | otherwise = (chr . fromIntegral $ w32) : go (i+4)
      where
        w32 :: Word32
        w32 = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24)
        b0 = fromIntegral $ BS.index bs i
        b1 = fromIntegral $ BS.index bs (i + 1)
        b2 = fromIntegral $ BS.index bs (i + 2)
        b3 = fromIntegral $ BS.index bs (i + 3)
242

243
244
-- | Workaround for the inconsistent behaviour of 'canonicalizePath'. Always
-- throws an error if the path refers to a non-existent file.
245
246
247
tryCanonicalizePath :: FilePath -> IO FilePath
tryCanonicalizePath path = do
  ret <- canonicalizePath path
248
#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)
249
250
  exists <- liftM2 (||) (doesFileExist ret) (doesDirectoryExist ret)
  unless exists $
251
252
    ioError $ mkIOError doesNotExistErrorType "canonicalizePath"
                        Nothing (Just ret)
253
254
#endif
  return ret
255
256
257
258
259
260

-- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws
-- an exception, returns the path argument unmodified.
canonicalizePathNoThrow :: FilePath -> IO FilePath
canonicalizePathNoThrow path = do
  canonicalizePath path `catchIO` (\_ -> return path)
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283

--------------------
-- Modification time

-- | Like Distribution.Simple.Utils.moreRecentFile, but uses getModTime instead
-- of getModificationTime for higher precision. We can't merge the two because
-- Distribution.Client.Time uses MIN_VERSION macros.
moreRecentFile :: FilePath -> FilePath -> IO Bool
moreRecentFile a b = do
  exists <- doesFileExist b
  if not exists
    then return True
    else do tb <- getModTime b
            ta <- getModTime a
            return (ta > tb)

-- | Like 'moreRecentFile', but also checks that the first file exists.
existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool
existsAndIsMoreRecentThan a b = do
  exists <- doesFileExist a
  if not exists
    then return False
    else a `moreRecentFile` b
284
285
286
287
288

-- | Sets the handler for encoding errors to one that transliterates invalid
-- characters into one present in the encoding (i.e., \'?\').
-- This is opposed to the default behavior, which is to throw an exception on
-- error. This function will ignore file handles that have a Unicode encoding
289
-- set. It's a no-op for versions of `base` less than 4.4.
290
291
relaxEncodingErrors :: Handle -> IO ()
relaxEncodingErrors handle = do
292
#if MIN_VERSION_base(4,4,0)
293
294
295
296
297
  maybeEncoding <- hGetEncoding handle
  case maybeEncoding of
    Just (TextEncoding name decoder encoder) | not ("UTF" `isPrefixOf` name) ->
      let relax x = x { recover = recoverEncode TransliterateCodingFailure }
      in hSetEncoding handle (TextEncoding name decoder (fmap relax encoder))
298
    _ ->
299
#endif
300
      return ()
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316

-- |Like 'tryFindPackageDesc', but with error specific to add-source deps.
tryFindAddSourcePackageDesc :: FilePath -> String -> IO FilePath
tryFindAddSourcePackageDesc depPath err = tryFindPackageDesc depPath $
    err ++ "\n" ++ "Failed to read cabal file of add-source dependency: "
    ++ depPath

-- |Try to find a @.cabal@ file, in directory @depPath@. Fails if one cannot be
-- found, with @err@ prefixing the error message. This function simply allows
-- us to give a more descriptive error than that provided by @findPackageDesc@.
tryFindPackageDesc :: FilePath -> String -> IO FilePath
tryFindPackageDesc depPath err = do
    errOrCabalFile <- findPackageDesc depPath
    case errOrCabalFile of
        Right file -> return file
        Left _ -> die err