cabal-install/src/Distribution/Client/Utils.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE ScopedTypeVariables #-}
   3
   4 module Distribution.Client.Utils
   5   ( MergeResult (..)
   6   , mergeBy
   7   , duplicates
   8   , duplicatesBy
   9   , readMaybe
  10   , inDir
  11   , withEnv
  12   , withEnvOverrides
  13   , logDirChange
  14   , withExtraPathEnv
  15   , determineNumJobs
  16   , numberOfProcessors
  17   , removeExistingFile
  18   , withTempFileName
  19   , makeAbsoluteToCwd
  20   , makeRelativeToCwd
  21   , makeRelativeToDir
  22   , makeRelativeCanonical
  23   , filePathToByteString
  24   , byteStringToFilePath
  25   , tryCanonicalizePath
  26   , canonicalizePathNoThrow
  27   , moreRecentFile
  28   , existsAndIsMoreRecentThan
  29   , tryFindAddSourcePackageDesc
  30   , tryFindPackageDesc
  31   , relaxEncodingErrors
  32   , ProgressPhase (..)
  33   , progressMessage
  34   , pvpize
  35   , incVersion
  36   , getCurrentYear
  37   , listFilesRecursive
  38   , listFilesInside
  39   , safeRead
  40   , hasElem
  41   , occursOnlyOrBefore
  42   , giveRTSWarning
  43   ) where
  44
  45 import Distribution.Client.Compat.Prelude
  46 import Prelude ()
  47
  48 import qualified Control.Exception as Exception
  49   ( finally
  50   )
  51 import qualified Control.Exception.Safe as Safe
  52   ( bracket
  53   )
  54 import Control.Monad
  55   ( zipWithM_
  56   )
  57 import Data.Bits
  58   ( shiftL
  59   , shiftR
  60   , (.|.)
  61   )
  62 import qualified Data.ByteString.Lazy as BS
  63 import Data.List
  64   ( elemIndex
  65   , groupBy
  66   )
  67 import Distribution.Compat.Environment
  68 import Distribution.Compat.Time (getModTime)
  69 import Distribution.Simple.Setup (Flag (..))
  70 import Distribution.Simple.Utils (dieWithException, findPackageDesc, noticeNoWrap)
  71 import Distribution.Version
  72 import System.Directory
  73   ( canonicalizePath
  74   , doesDirectoryExist
  75   , doesFileExist
  76   , getCurrentDirectory
  77   , getDirectoryContents
  78   , removeFile
  79   , setCurrentDirectory
  80   )
  81 import System.FilePath
  82 import System.IO
  83   ( Handle
  84   , hClose
  85   , hGetEncoding
  86   , hSetEncoding
  87   , openTempFile
  88   )
  89 import System.IO.Unsafe (unsafePerformIO)
  90
  91 import Data.Time (utcToLocalTime)
  92 import Data.Time.Calendar (toGregorian)
  93 import Data.Time.Clock.POSIX (getCurrentTime)
  94 import Data.Time.LocalTime (getCurrentTimeZone, localDay)
  95 import GHC.Conc.Sync (getNumProcessors)
  96 import GHC.IO.Encoding
  97   ( TextEncoding (TextEncoding)
  98   , recover
  99   )
 100 import GHC.IO.Encoding.Failure
 101   ( CodingFailureMode (TransliterateCodingFailure)
 102   , recoverEncode
 103   )
 104 #if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)
 105 import qualified System.Directory as Dir
 106 import qualified System.IO.Error as IOError
 107 #endif
 108 import qualified Data.Set as Set
 109 import Distribution.Client.Errors
 110
 111 -- | Generic merging utility. For sorted input lists this is a full outer join.
 112 mergeBy :: forall a b. (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
 113 mergeBy cmp = merge
 114   where
 115     merge :: [a] -> [b] -> [MergeResult a b]
 116     merge [] ys = [OnlyInRight y | y <- ys]
 117     merge xs [] = [OnlyInLeft x | x <- xs]
 118     merge (x : xs) (y : ys) =
 119       case x `cmp` y of
 120         GT -> OnlyInRight y : merge (x : xs) ys
 121         EQ -> InBoth x y : merge xs ys
 122         LT -> OnlyInLeft x : merge xs (y : ys)
 123
 124 data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b
 125
 126 duplicates :: Ord a => [a] -> [[a]]
 127 duplicates = duplicatesBy compare
 128
 129 duplicatesBy :: forall a. (a -> a -> Ordering) -> [a] -> [[a]]
 130 duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp
 131   where
 132     eq :: a -> a -> Bool
 133     eq a b = case cmp a b of
 134       EQ -> True
 135       _ -> False
 136     moreThanOne (_ : _ : _) = True
 137     moreThanOne _ = False
 138
 139 -- | Like 'removeFile', but does not throw an exception when the file does not
 140 -- exist.
 141 removeExistingFile :: FilePath -> IO ()
 142 removeExistingFile path = do
 143   exists <- doesFileExist path
 144   when exists $
 145     removeFile path
 146
 147 -- | A variant of 'withTempFile' that only gives us the file name, and while
 148 -- it will clean up the file afterwards, it's lenient if the file is
 149 -- moved\/deleted.
 150 withTempFileName
 151   :: FilePath
 152   -> String
 153   -> (FilePath -> IO a)
 154   -> IO a
 155 withTempFileName tmpDir template action =
 156   Safe.bracket
 157     (openTempFile tmpDir template)
 158     (\(name, _) -> removeExistingFile name)
 159     (\(name, h) -> hClose h >> action name)
 160
 161 -- | Executes the action in the specified directory.
 162 --
 163 -- Warning: This operation is NOT thread-safe, because current
 164 -- working directory is a process-global concept.
 165 inDir :: Maybe FilePath -> IO a -> IO a
 166 inDir Nothing m = m
 167 inDir (Just d) m = do
 168   old <- getCurrentDirectory
 169   setCurrentDirectory d
 170   m `Exception.finally` setCurrentDirectory old
 171
 172 -- | Executes the action with an environment variable set to some
 173 -- value.
 174 --
 175 -- Warning: This operation is NOT thread-safe, because current
 176 -- environment is a process-global concept.
 177 withEnv :: String -> String -> IO a -> IO a
 178 withEnv k v m = do
 179   mb_old <- lookupEnv k
 180   setEnv k v
 181   m `Exception.finally` setOrUnsetEnv k mb_old
 182
 183 -- | Executes the action with a list of environment variables and
 184 -- corresponding overrides, where
 185 --
 186 -- * @'Just' v@ means \"set the environment variable's value to @v@\".
 187 -- * 'Nothing' means \"unset the environment variable\".
 188 --
 189 -- Warning: This operation is NOT thread-safe, because current
 190 -- environment is a process-global concept.
 191 withEnvOverrides :: [(String, Maybe FilePath)] -> IO a -> IO a
 192 withEnvOverrides overrides m = do
 193   mb_olds <- traverse lookupEnv envVars
 194   traverse_ (uncurry setOrUnsetEnv) overrides
 195   m `Exception.finally` zipWithM_ setOrUnsetEnv envVars mb_olds
 196   where
 197     envVars :: [String]
 198     envVars = map fst overrides
 199
 200 setOrUnsetEnv :: String -> Maybe String -> IO ()
 201 setOrUnsetEnv var Nothing = unsetEnv var
 202 setOrUnsetEnv var (Just val) = setEnv var val
 203
 204 -- | Executes the action, increasing the PATH environment
 205 -- in some way
 206 --
 207 -- Warning: This operation is NOT thread-safe, because the
 208 -- environment variables are a process-global concept.
 209 withExtraPathEnv :: [FilePath] -> IO a -> IO a
 210 withExtraPathEnv paths m = do
 211   oldPathSplit <- getSearchPath
 212   let newPath :: String
 213       newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit)
 214       oldPath :: String
 215       oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit
 216       -- TODO: This is a horrible hack to work around the fact that
 217       -- setEnv can't take empty values as an argument
 218       mungePath p
 219         | p == "" = "/dev/null"
 220         | otherwise = p
 221   setEnv "PATH" newPath
 222   m `Exception.finally` setEnv "PATH" oldPath
 223
 224 -- | Log directory change in 'make' compatible syntax
 225 logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a
 226 logDirChange _ Nothing m = m
 227 logDirChange l (Just d) m = do
 228   l $ "cabal: Entering directory '" ++ d ++ "'\n"
 229   m
 230     `Exception.finally` l ("cabal: Leaving directory '" ++ d ++ "'\n")
 231
 232 -- The number of processors is not going to change during the duration of the
 233 -- program, so unsafePerformIO is safe here.
 234 numberOfProcessors :: Int
 235 numberOfProcessors = unsafePerformIO getNumProcessors
 236
 237 -- | Determine the number of jobs to use given the value of the '-j' flag.
 238 determineNumJobs :: Flag (Maybe Int) -> Int
 239 determineNumJobs numJobsFlag =
 240   case numJobsFlag of
 241     NoFlag -> 1
 242     Flag Nothing -> numberOfProcessors
 243     Flag (Just n) -> n
 244
 245 -- | Given a relative path, make it absolute relative to the current
 246 -- directory. Absolute paths are returned unmodified.
 247 makeAbsoluteToCwd :: FilePath -> IO FilePath
 248 makeAbsoluteToCwd path
 249   | isAbsolute path = return path
 250   | otherwise = do
 251       cwd <- getCurrentDirectory
 252       return $! cwd </> path
 253
 254 -- | Given a path (relative or absolute), make it relative to the current
 255 -- directory, including using @../..@ if necessary.
 256 makeRelativeToCwd :: FilePath -> IO FilePath
 257 makeRelativeToCwd path =
 258   makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory
 259
 260 -- | Given a path (relative or absolute), make it relative to the given
 261 -- directory, including using @../..@ if necessary.
 262 makeRelativeToDir :: FilePath -> FilePath -> IO FilePath
 263 makeRelativeToDir path dir =
 264   makeRelativeCanonical <$> canonicalizePath path <*> canonicalizePath dir
 265
 266 -- | Given a canonical absolute path and canonical absolute dir, make the path
 267 -- relative to the directory, including using @../..@ if necessary. Returns
 268 -- the original absolute path if it is not on the same drive as the given dir.
 269 makeRelativeCanonical :: FilePath -> FilePath -> FilePath
 270 makeRelativeCanonical path dir
 271   | takeDrive path /= takeDrive dir = path
 272   | otherwise = go (splitPath path) (splitPath dir)
 273   where
 274     go (p : ps) (d : ds) | p' == d' = go ps ds
 275       where
 276         (p', d') = (dropTrailingPathSeparator p, dropTrailingPathSeparator d)
 277     go [] [] = "./"
 278     go ps ds = joinPath (replicate (length ds) ".." ++ ps)
 279
 280 -- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is
 281 -- encoded as a little-endian 'Word32'.
 282 filePathToByteString :: FilePath -> BS.ByteString
 283 filePathToByteString p =
 284   BS.pack $ foldr conv [] codepts
 285   where
 286     codepts :: [Word32]
 287     codepts = map (fromIntegral . ord) p
 288
 289     conv :: Word32 -> [Word8] -> [Word8]
 290     conv w32 rest = b0 : b1 : b2 : b3 : rest
 291       where
 292         b0 = fromIntegral $ w32
 293         b1 = fromIntegral $ w32 `shiftR` 8
 294         b2 = fromIntegral $ w32 `shiftR` 16
 295         b3 = fromIntegral $ w32 `shiftR` 24
 296
 297 -- | Reverse operation to 'filePathToByteString'.
 298 byteStringToFilePath :: BS.ByteString -> FilePath
 299 byteStringToFilePath bs
 300   | bslen `mod` 4 /= 0 = unexpected
 301   | otherwise = go 0
 302   where
 303     unexpected = "Distribution.Client.Utils.byteStringToFilePath: unexpected"
 304     bslen = BS.length bs
 305
 306     go i
 307       | i == bslen = []
 308       | otherwise = (chr . fromIntegral $ w32) : go (i + 4)
 309       where
 310         w32 :: Word32
 311         w32 = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24)
 312         b0 = fromIntegral $ BS.index bs i
 313         b1 = fromIntegral $ BS.index bs (i + 1)
 314         b2 = fromIntegral $ BS.index bs (i + 2)
 315         b3 = fromIntegral $ BS.index bs (i + 3)
 316
 317 -- | Workaround for the inconsistent behaviour of 'canonicalizePath'. Always
 318 -- throws an error if the path refers to a non-existent file.
 319 {- FOURMOLU_DISABLE -}
 320 tryCanonicalizePath :: FilePath -> IO FilePath
 321 tryCanonicalizePath path = do
 322   ret <- canonicalizePath path
 323 #if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)
 324   exists <- liftM2 (||) (doesFileExist ret) (Dir.doesDirectoryExist ret)
 325   unless exists $
 326     IOError.ioError $ IOError.mkIOError IOError.doesNotExistErrorType "canonicalizePath"
 327                         Nothing (Just ret)
 328 #endif
 329   return ret
 330 {- FOURMOLU_ENABLE -}
 331
 332 -- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws
 333 -- an exception, returns the path argument unmodified.
 334 canonicalizePathNoThrow :: FilePath -> IO FilePath
 335 canonicalizePathNoThrow path = do
 336   canonicalizePath path `catchIO` (\_ -> return path)
 337
 338 --------------------
 339 -- Modification time
 340
 341 -- | Like Distribution.Simple.Utils.moreRecentFile, but uses getModTime instead
 342 -- of getModificationTime for higher precision. We can't merge the two because
 343 -- Distribution.Client.Time uses MIN_VERSION macros.
 344 moreRecentFile :: FilePath -> FilePath -> IO Bool
 345 moreRecentFile a b = do
 346   exists <- doesFileExist b
 347   if not exists
 348     then return True
 349     else do
 350       tb <- getModTime b
 351       ta <- getModTime a
 352       return (ta > tb)
 353
 354 -- | Like 'moreRecentFile', but also checks that the first file exists.
 355 existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool
 356 existsAndIsMoreRecentThan a b = do
 357   exists <- doesFileExist a
 358   if not exists
 359     then return False
 360     else a `moreRecentFile` b
 361
 362 -- | Sets the handler for encoding errors to one that transliterates invalid
 363 -- characters into one present in the encoding (i.e., \'?\').
 364 -- This is opposed to the default behavior, which is to throw an exception on
 365 -- error. This function will ignore file handles that have a Unicode encoding
 366 -- set. It's a no-op for versions of `base` less than 4.4.
 367 relaxEncodingErrors :: Handle -> IO ()
 368 relaxEncodingErrors handle = do
 369   maybeEncoding <- hGetEncoding handle
 370   case maybeEncoding of
 371     Just (TextEncoding name decoder encoder)
 372       | not ("UTF" `isPrefixOf` name) ->
 373           let relax x = x{recover = recoverEncode TransliterateCodingFailure}
 374            in hSetEncoding handle (TextEncoding name decoder (fmap relax encoder))
 375     _ ->
 376       return ()
 377
 378 -- | Like 'tryFindPackageDesc', but with error specific to add-source deps.
 379 tryFindAddSourcePackageDesc :: Verbosity -> FilePath -> String -> IO FilePath
 380 tryFindAddSourcePackageDesc verbosity depPath err =
 381   tryFindPackageDesc verbosity depPath $
 382     err
 383       ++ "\n"
 384       ++ "Failed to read cabal file of add-source dependency: "
 385       ++ depPath
 386
 387 -- | Try to find a @.cabal@ file, in directory @depPath@. Fails if one cannot be
 388 --  found, with @err@ prefixing the error message. This function simply allows
 389 --  us to give a more descriptive error than that provided by @findPackageDesc@.
 390 tryFindPackageDesc :: Verbosity -> FilePath -> String -> IO FilePath
 391 tryFindPackageDesc verbosity depPath err = do
 392   errOrCabalFile <- findPackageDesc depPath
 393   case errOrCabalFile of
 394     Right file -> return file
 395     Left _ -> dieWithException verbosity $ TryFindPackageDescErr err
 396
 397 -- | Phase of building a dependency. Represents current status of package
 398 -- dependency processing. See #4040 for details.
 399 data ProgressPhase
 400   = ProgressDownloading
 401   | ProgressDownloaded
 402   | ProgressStarting
 403   | ProgressBuilding
 404   | ProgressHaddock
 405   | ProgressInstalling
 406   | ProgressCompleted
 407
 408 progressMessage :: Verbosity -> ProgressPhase -> String -> IO ()
 409 progressMessage verbosity phase subject = do
 410   noticeNoWrap verbosity $ phaseStr ++ subject ++ "\n"
 411   where
 412     phaseStr = case phase of
 413       ProgressDownloading -> "Downloading  "
 414       ProgressDownloaded -> "Downloaded   "
 415       ProgressStarting -> "Starting     "
 416       ProgressBuilding -> "Building     "
 417       ProgressHaddock -> "Haddock      "
 418       ProgressInstalling -> "Installing   "
 419       ProgressCompleted -> "Completed    "
 420
 421 -- | Given a version, return an API-compatible (according to PVP) version range.
 422 --
 423 -- If the boolean argument denotes whether to use a desugared
 424 -- representation (if 'True') or the new-style @^>=@-form (if
 425 -- 'False').
 426 --
 427 -- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the
 428 -- same as @0.4.*@).
 429 pvpize :: Bool -> Version -> VersionRange
 430 pvpize False v = majorBoundVersion v
 431 pvpize True v =
 432   orLaterVersion v'
 433     `intersectVersionRanges` earlierVersion (incVersion 1 v')
 434   where
 435     v' = alterVersion (take 2) v
 436
 437 -- | Increment the nth version component (counting from 0).
 438 incVersion :: Int -> Version -> Version
 439 incVersion n = alterVersion (incVersion' n)
 440   where
 441     incVersion' 0 [] = [1]
 442     incVersion' 0 (v : _) = [v + 1]
 443     incVersion' m [] = replicate m 0 ++ [1]
 444     incVersion' m (v : vs) = v : incVersion' (m - 1) vs
 445
 446 -- | Returns the current calendar year.
 447 getCurrentYear :: IO Integer
 448 getCurrentYear = do
 449   u <- getCurrentTime
 450   z <- getCurrentTimeZone
 451   let l = utcToLocalTime z u
 452       (y, _, _) = toGregorian $ localDay l
 453   return y
 454
 455 -- | From System.Directory.Extra
 456 --   https://hackage.haskell.org/package/extra-1.7.9
 457 listFilesInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath]
 458 listFilesInside test dir = ifNotM (test $ dropTrailingPathSeparator dir) (pure []) $ do
 459   (dirs, files) <- partitionM doesDirectoryExist =<< listContents dir
 460   rest <- concatMapM (listFilesInside test) dirs
 461   pure $ files ++ rest
 462
 463 -- | From System.Directory.Extra
 464 --   https://hackage.haskell.org/package/extra-1.7.9
 465 listFilesRecursive :: FilePath -> IO [FilePath]
 466 listFilesRecursive = listFilesInside (const $ pure True)
 467
 468 -- | From System.Directory.Extra
 469 --   https://hackage.haskell.org/package/extra-1.7.9
 470 listContents :: FilePath -> IO [FilePath]
 471 listContents dir = do
 472   xs <- getDirectoryContents dir
 473   pure $ sort [dir </> x | x <- xs, not $ all (== '.') x]
 474
 475 -- | From Control.Monad.Extra
 476 --   https://hackage.haskell.org/package/extra-1.7.9
 477 ifM :: Monad m => m Bool -> m a -> m a -> m a
 478 ifM b t f = do b' <- b; if b' then t else f
 479
 480 -- | 'ifM' with swapped branches:
 481 --   @ifNotM b t f = ifM (not <$> b) t f@
 482 ifNotM :: Monad m => m Bool -> m a -> m a -> m a
 483 ifNotM = flip . ifM
 484
 485 -- | From Control.Monad.Extra
 486 --   https://hackage.haskell.org/package/extra-1.7.9
 487 concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
 488 {-# INLINE concatMapM #-}
 489 concatMapM op = foldr f (pure [])
 490   where
 491     f x xs = do x' <- op x; if null x' then xs else do { xs' <- xs; pure $ x' ++ xs' }
 492
 493 -- | From Control.Monad.Extra
 494 --   https://hackage.haskell.org/package/extra-1.7.9
 495 partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
 496 partitionM _ [] = pure ([], [])
 497 partitionM f (x : xs) = do
 498   res <- f x
 499   (as, bs) <- partitionM f xs
 500   pure ([x | res] ++ as, [x | not res] ++ bs)
 501
 502 safeRead :: Read a => String -> Maybe a
 503 safeRead s
 504   | [(x, "")] <- reads s = Just x
 505   | otherwise = Nothing
 506
 507 -- | @hasElem xs x = elem x xs@ except that @xs@ is turned into a 'Set' first.
 508 --   Use underapplied to speed up subsequent lookups, e.g. @filter (hasElem xs) ys@.
 509 --   Only amortized when used several times!
 510 --
 511 --   Time complexity \(O((n+m) \log(n))\) for \(m\) lookups in a list of length \(n\).
 512 --   (Compare this to 'elem''s \(O(nm)\).)
 513 --
 514 --   This is [Agda.Utils.List.hasElem](https://hackage.haskell.org/package/Agda-2.6.2.2/docs/Agda-Utils-List.html#v:hasElem).
 515 hasElem :: Ord a => [a] -> a -> Bool
 516 hasElem xs = (`Set.member` Set.fromList xs)
 517
 518 -- True if x occurs before y
 519 occursOnlyOrBefore :: Eq a => [a] -> a -> a -> Bool
 520 occursOnlyOrBefore xs x y = case (elemIndex x xs, elemIndex y xs) of
 521   (Just i, Just j) -> i < j
 522   (Just _, _) -> True
 523   _ -> False
 524
 525 giveRTSWarning :: String -> String
 526 giveRTSWarning "run" =
 527   "Your RTS options are applied to cabal, not the "
 528     ++ "executable. Use '--' to separate cabal options from your "
 529     ++ "executable options. For example, use 'cabal run -- +RTS -N "
 530     ++ "to pass the '-N' RTS option to your executable."
 531 giveRTSWarning "test" =
 532   "Some RTS options were found standalone, "
 533     ++ "which affect cabal and not the binary. "
 534     ++ "Please note that +RTS inside the --test-options argument "
 535     ++ "suffices if your goal is to affect the tested binary. "
 536     ++ "For example, use \"cabal test --test-options='+RTS -N'\" "
 537     ++ "to pass the '-N' RTS option to your binary."
 538 giveRTSWarning "bench" =
 539   "Some RTS options were found standalone, "
 540     ++ "which affect cabal and not the binary. Please note "
 541     ++ "that +RTS inside the --benchmark-options argument "
 542     ++ "suffices if your goal is to affect the benchmarked "
 543     ++ "binary. For example, use \"cabal test --benchmark-options="
 544     ++ "'+RTS -N'\" to pass the '-N' RTS option to your binary."
 545 giveRTSWarning _ =
 546   "Your RTS options are applied to cabal, not the "
 547     ++ "binary."