cabal-testsuite/src/Test/Cabal/Prelude.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE NondecreasingIndentation #-}
   4 {-# LANGUAGE FlexibleContexts #-}
   5 {-# LANGUAGE CPP #-}
   6
   7 -- | Generally useful definitions that we expect most test scripts
   8 -- to use.
   9 module Test.Cabal.Prelude (
  10     module Test.Cabal.Prelude,
  11     module Test.Cabal.Monad,
  12     module Test.Cabal.Run,
  13     module System.FilePath,
  14     module Distribution.Utils.Path,
  15     module Control.Monad,
  16     module Control.Monad.IO.Class,
  17     module Distribution.Version,
  18     module Distribution.Simple.Program,
  19 ) where
  20
  21 import Test.Cabal.Script
  22 import Test.Cabal.Run
  23 import Test.Cabal.Monad
  24 import Test.Cabal.Plan
  25 import Test.Cabal.TestCode
  26
  27 import Distribution.Compat.Time (calibrateMtimeChangeDelay)
  28 import Distribution.Simple.Compiler (PackageDBStackCWD, PackageDBCWD, PackageDBX(..))
  29 import Distribution.Simple.PackageDescription (readGenericPackageDescription)
  30 import Distribution.Simple.Program.Types
  31 import Distribution.Simple.Program.Db
  32 import Distribution.Simple.Program
  33 import Distribution.System (OS(Windows,Linux,OSX), Arch(JavaScript), buildOS, buildArch)
  34 import Distribution.Simple.Configure
  35     ( getPersistBuildConfig )
  36 import Distribution.Simple.Utils
  37     ( withFileContents, tryFindPackageDesc )
  38 import Distribution.Version
  39 import Distribution.Package
  40 import Distribution.Parsec (eitherParsec, simpleParsec)
  41 import Distribution.Types.UnqualComponentName
  42 import Distribution.Types.LocalBuildInfo
  43 import Distribution.PackageDescription
  44 import Test.Utils.TempTestDir (withTestDir)
  45 import Distribution.Verbosity (normal)
  46 import Distribution.Utils.Path
  47   ( makeSymbolicPath, relativeSymbolicPath, interpretSymbolicPathCWD )
  48
  49 import Distribution.Compat.Stack
  50
  51 import Text.Regex.TDFA ((=~))
  52
  53 import Control.Concurrent.Async (withAsync)
  54 import qualified Data.Aeson as JSON
  55 import qualified Data.ByteString.Lazy as BSL
  56 import Control.Monad (unless, when, void, forM_, foldM, liftM2, liftM4)
  57 import Control.Monad.Catch ( bracket_ )
  58 import Control.Monad.Trans.Reader (asks, withReaderT, runReaderT)
  59 import Control.Monad.IO.Class (MonadIO (..))
  60 import qualified Crypto.Hash.SHA256 as SHA256
  61 import qualified Data.ByteString.Base16 as Base16
  62 import qualified Data.ByteString.Char8 as C
  63 import Data.List (isInfixOf, stripPrefix, isPrefixOf, intercalate)
  64 import Data.Maybe (isJust, mapMaybe, fromMaybe)
  65 import System.Exit (ExitCode (..))
  66 import System.FilePath
  67 import Control.Concurrent (threadDelay)
  68 import qualified Data.Char as Char
  69 import System.Directory
  70 import Control.Retry (exponentialBackoff, limitRetriesByCumulativeDelay)
  71 import Network.Wait (waitTcpVerbose)
  72 import System.Environment
  73 import qualified System.FilePath.Glob as Glob (globDir1, compile)
  74 import System.Process
  75 import System.IO
  76
  77 #ifndef mingw32_HOST_OS
  78 import System.Posix.Resource
  79 #endif
  80
  81 ------------------------------------------------------------------------
  82 -- * Utilities
  83
  84
  85 runM :: FilePath -> [String] -> Maybe String -> TestM Result
  86 runM path args input = do
  87   env <- getTestEnv
  88   runM' (Just $ testCurrentDir env) path args input
  89
  90 runM' :: Maybe FilePath -> FilePath -> [String] -> Maybe String -> TestM Result
  91 runM' run_dir path args input = do
  92     env <- getTestEnv
  93     r <- liftIO $ run (testVerbosity env)
  94                  run_dir
  95                  (testEnvironment env)
  96                  path
  97                  args
  98                  input
  99     recordLog r
 100     requireSuccess r
 101
 102 runProgramM  :: Program -> [String] -> Maybe String -> TestM Result
 103 runProgramM prog args input = do
 104   env <- getTestEnv
 105   runProgramM' (Just $ testCurrentDir env) prog args input
 106
 107 runProgramM' :: Maybe FilePath -> Program -> [String] -> Maybe String -> TestM Result
 108 runProgramM' run_dir prog args input = do
 109     configured_prog <- requireProgramM prog
 110     -- TODO: Consider also using other information from
 111     -- ConfiguredProgram, e.g., env and args
 112     runM' run_dir (programPath configured_prog) args input
 113
 114 getLocalBuildInfoM :: TestM LocalBuildInfo
 115 getLocalBuildInfoM = do
 116     env <- getTestEnv
 117     liftIO $ getPersistBuildConfig Nothing (makeSymbolicPath $ testDistDir env)
 118
 119 ------------------------------------------------------------------------
 120 -- * Changing parameters
 121
 122 withDirectory :: FilePath -> TestM a -> TestM a
 123 withDirectory f = withReaderT
 124     (\env -> env { testRelativeCurrentDir = testRelativeCurrentDir env </> f })
 125
 126 withStoreDir :: FilePath -> TestM a -> TestM a
 127 withStoreDir fp =
 128   withReaderT (\env -> env { testMaybeStoreDir = Just fp })
 129
 130 -- We append to the environment list, as per 'getEffectiveEnvironment'
 131 -- which prefers the latest override.
 132 withEnv :: [(String, Maybe String)] -> TestM a -> TestM a
 133 withEnv e = withReaderT (\env -> env { testEnvironment = testEnvironment env ++ e })
 134
 135 -- | Prepend a directory to the PATH
 136 addToPath :: FilePath -> TestM a -> TestM a
 137 addToPath exe_dir action = do
 138   env <- getTestEnv
 139   path <- liftIO $ getEnv "PATH"
 140   let newpath = exe_dir ++ [searchPathSeparator] ++ path
 141   let new_env = (("PATH", Just newpath) : (testEnvironment env))
 142   withEnv new_env action
 143
 144
 145 -- HACK please don't use me
 146 withEnvFilter :: (String -> Bool) -> TestM a -> TestM a
 147 withEnvFilter p = withReaderT (\env -> env { testEnvironment = filter (p . fst) (testEnvironment env) })
 148
 149 ------------------------------------------------------------------------
 150 -- * Running Setup
 151
 152 marked_verbose :: String
 153 marked_verbose = "-vverbose +markoutput +nowrap"
 154
 155 setup :: String -> [String] -> TestM ()
 156 setup cmd args = void (setup' cmd args)
 157
 158 setup' :: String -> [String] -> TestM Result
 159 setup' = setup'' "."
 160
 161 setup''
 162   :: FilePath
 163   -- ^ Subdirectory to find the @.cabal@ file in.
 164   -> String
 165   -- ^ Command name
 166   -> [String]
 167   -- ^ Arguments
 168   -> TestM Result
 169 setup'' prefix cmd args = do
 170     env <- getTestEnv
 171     let work_dir = if testRelativeCurrentDir env == "." then Nothing else Just (testRelativeCurrentDir env)
 172     when ((cmd == "register" || cmd == "copy") && not (testHavePackageDb env)) $
 173         error "Cannot register/copy without using 'withPackageDb'"
 174     ghc_path     <- programPathM ghcProgram
 175     haddock_path <- programPathM haddockProgram
 176     let args' = case cmd of
 177             "configure" ->
 178                 -- If the package database is empty, setting --global
 179                 -- here will make us error loudly if we try to install
 180                 -- into a bad place.
 181                 [ "--global"
 182                 -- NB: technically unnecessary with Cabal, but
 183                 -- definitely needed for Setup, which doesn't
 184                 -- respect cabal.config
 185                 , "--with-ghc", ghc_path
 186                 , "--with-haddock", haddock_path
 187                 -- This avoids generating hashes in our package IDs,
 188                 -- which helps the test suite's expect tests.
 189                 , "--enable-deterministic"
 190                 -- These flags make the test suite run faster
 191                 -- Can't do this unless we LD_LIBRARY_PATH correctly
 192                 -- , "--enable-executable-dynamic"
 193                 -- , "--disable-optimization"
 194                 -- Specify where we want our installed packages to go
 195                 , "--prefix=" ++ testPrefixDir env
 196                 ] ++ packageDBParams (testPackageDBStack env)
 197                   ++ args
 198             _ -> args
 199     let rel_dist_dir = definitelyMakeRelative (testCurrentDir env) (testDistDir env)
 200         work_dir_arg = case work_dir of
 201                           Nothing -> []
 202                           Just wd -> ["--working-dir", wd]
 203         full_args = work_dir_arg ++ (cmd : [marked_verbose, "--distdir", rel_dist_dir] ++ args')
 204     defaultRecordMode RecordMarked $ do
 205     recordHeader ["Setup", cmd]
 206
 207     -- We test `cabal act-as-setup` when running cabal-tests.
 208     --
 209     -- `cabal` and `Setup.hs` do have different interface.
 210     --
 211     let pkgDir = makeSymbolicPath $ testTmpDir env </> testRelativeCurrentDir env </> prefix
 212     pdfile <- liftIO $ tryFindPackageDesc (testVerbosity env) (Just pkgDir)
 213     pdesc <- liftIO $ readGenericPackageDescription (testVerbosity env) (Just pkgDir) $ relativeSymbolicPath pdfile
 214     if testCabalInstallAsSetup env
 215     then if buildType (packageDescription pdesc) == Simple
 216          then runProgramM' (Just (testTmpDir env)) cabalProgram ("act-as-setup" : "--" : full_args) Nothing
 217          else fail "Using act-as-setup for not 'build-type: Simple' package"
 218     else do
 219         if buildType (packageDescription pdesc) == Simple
 220             then runM' (Just $ testTmpDir env) (testSetupPath env) (full_args) Nothing
 221             -- Run the Custom script!
 222             else do
 223               r <- liftIO $ runghc (testScriptEnv env)
 224                                    (Just $ testTmpDir env)
 225                                    (testEnvironment env)
 226                                    (testRelativeCurrentDir env </> prefix </> "Setup.hs")
 227                                    (full_args)
 228               recordLog r
 229               requireSuccess r
 230
 231     -- This code is very tempting (and in principle should be quick:
 232     -- after all we are loading the built version of Cabal), but
 233     -- actually it costs quite a bit in wallclock time (e.g. 54sec to
 234     -- 68sec on AllowNewer, working with un-optimized Cabal.)
 235     {-
 236     r <- liftIO $ runghc (testScriptEnv env)
 237                          (Just (testCurrentDir env))
 238                          (testEnvironment env)
 239                          "Setup.hs"
 240                          (cmd : ["-v", "--distdir", testDistDir env] ++ args')
 241     -- don't forget to check results...
 242     -}
 243
 244 definitelyMakeRelative :: FilePath -> FilePath -> FilePath
 245 definitelyMakeRelative base0 path0 =
 246     let go [] path = joinPath path
 247         go base [] = joinPath (replicate (length base) "..")
 248         go (x:xs) (y:ys)
 249             | x == y    = go xs ys
 250             | otherwise = go (x:xs) [] </> go [] (y:ys)
 251     -- NB: It's important to normalize, as otherwise if
 252     -- we see "foo/./bar" we'll incorrectly conclude that we need
 253     -- to go "../../.." to get out of it.
 254     in go (splitPath (normalise base0)) (splitPath (normalise path0))
 255
 256 -- | This abstracts the common pattern of configuring and then building.
 257 setup_build :: [String] -> TestM ()
 258 setup_build args = do
 259     setup "configure" args
 260     setup "build" []
 261     return ()
 262
 263 -- | This abstracts the common pattern of "installing" a package.
 264 setup_install :: [String] -> TestM ()
 265 setup_install args = do
 266     setup "configure" args
 267     setup "build" []
 268     setup "copy" []
 269     setup "register" []
 270     return ()
 271
 272 -- | This abstracts the common pattern of "installing" a package,
 273 -- with haddock documentation.
 274 setup_install_with_docs :: [String] -> TestM ()
 275 setup_install_with_docs args = do
 276     setup "configure" args
 277     setup "build" []
 278     setup "haddock" []
 279     setup "copy" []
 280     setup "register" []
 281     return ()
 282
 283 packageDBParams :: PackageDBStackCWD -> [String]
 284 packageDBParams dbs = "--package-db=clear"
 285                     : map (("--package-db=" ++) . convert) dbs
 286   where
 287     convert :: PackageDBCWD -> String
 288     convert  GlobalPackageDB         = "global"
 289     convert  UserPackageDB           = "user"
 290     convert (SpecificPackageDB path) = path
 291
 292 ------------------------------------------------------------------------
 293 -- * Running cabal
 294
 295 -- cabal cmd args
 296 cabal :: String -> [String] -> TestM ()
 297 cabal cmd args = void (cabal' cmd args)
 298
 299 -- cabal cmd args
 300 cabal' :: String -> [String] -> TestM Result
 301 cabal' = cabalG' []
 302
 303 cabalWithStdin :: String -> [String] -> String -> TestM Result
 304 cabalWithStdin cmd args input = cabalGArgs [] cmd args (Just input)
 305
 306 cabalG :: [String] -> String -> [String] -> TestM ()
 307 cabalG global_args cmd args = void (cabalG' global_args cmd args)
 308
 309 cabalG' :: [String] -> String -> [String] -> TestM Result
 310 cabalG' global_args cmd args = cabalGArgs global_args cmd args Nothing
 311
 312 cabalGArgs :: [String] -> String -> [String] -> Maybe String -> TestM Result
 313 cabalGArgs global_args cmd args input = do
 314     env <- getTestEnv
 315     let extra_args
 316           | cmd `elem`
 317               [ "v1-update"
 318               , "outdated"
 319               , "user-config"
 320               , "man"
 321               , "v1-freeze"
 322               , "check"
 323               , "gen-bounds"
 324               , "get", "unpack"
 325               , "info"
 326               , "init"
 327               , "haddock-project"
 328               ]
 329           = [ ]
 330
 331           -- new-build commands are affected by testCabalProjectFile
 332           | cmd `elem` ["v2-sdist", "path"]
 333           = [ "--project-file=" ++ fp | Just fp <- [testCabalProjectFile env] ]
 334
 335           | cmd == "v2-clean" || cmd == "clean"
 336           = [ "--builddir", testDistDir env ]
 337             ++ [ "--project-file=" ++ fp | Just fp <- [testCabalProjectFile env] ]
 338
 339           | "v2-" `isPrefixOf` cmd
 340           = [ "--builddir", testDistDir env
 341             , "-j1" ]
 342             ++ [ "--project-file=" ++ fp | Just fp <- [testCabalProjectFile env] ]
 343             ++ ["--package-db=" ++ db | Just dbs <- [testPackageDbPath env], db <- dbs]
 344           | "v1-" `isPrefixOf` cmd
 345           = [ "--builddir", testDistDir env ]
 346             ++ install_args
 347           | otherwise
 348           = [ "--builddir", testDistDir env ]
 349             ++ ["--package-db=" ++ db | Just dbs <- [testPackageDbPath env], db <- dbs]
 350             ++ install_args
 351
 352         install_args
 353           | cmd == "v1-install" || cmd == "v1-build" = [ "-j1" ]
 354           | otherwise                                = []
 355
 356         global_args' =
 357             [ "--store-dir=" ++ storeDir | Just storeDir <- [testMaybeStoreDir env] ]
 358             ++ global_args
 359
 360         cabal_args = global_args'
 361                   ++ [ cmd, marked_verbose ]
 362                   ++ extra_args
 363                   ++ args
 364     defaultRecordMode RecordMarked $ do
 365     recordHeader ["cabal", cmd]
 366     cabal_raw' cabal_args input
 367
 368 cabal_raw' :: [String] -> Maybe String -> TestM Result
 369 cabal_raw' cabal_args input = runProgramM cabalProgram cabal_args input
 370
 371 withProjectFile :: FilePath -> TestM a -> TestM a
 372 withProjectFile fp m =
 373     withReaderT (\env -> env { testCabalProjectFile = Just fp }) m
 374
 375 -- | Assuming we've successfully configured a new-build project,
 376 -- read out the plan metadata so that we can use it to do other
 377 -- operations.
 378 withPlan :: TestM a -> TestM a
 379 withPlan m = do
 380     env0 <- getTestEnv
 381     let filepath = testDistDir env0 </> "cache" </> "plan.json"
 382     mplan <- JSON.eitherDecode `fmap` liftIO (BSL.readFile filepath)
 383     case mplan of
 384         Left err   -> fail $ "withPlan: cannot decode plan " ++ err
 385         Right plan -> withReaderT (\env -> env { testPlan = Just plan }) m
 386
 387 -- | Run an executable from a package.  Requires 'withPlan' to have
 388 -- been run so that we can find the dist dir.
 389 runPlanExe :: String {- package name -} -> String {- component name -}
 390            -> [String] -> TestM ()
 391 runPlanExe pkg_name cname args = void $ runPlanExe' pkg_name cname args
 392
 393 -- | Run an executable from a package.  Requires 'withPlan' to have
 394 -- been run so that we can find the dist dir.  Also returns 'Result'.
 395 runPlanExe' :: String {- package name -} -> String {- component name -}
 396             -> [String] -> TestM Result
 397 runPlanExe' pkg_name cname args = do
 398     exePath <- planExePath pkg_name cname
 399     defaultRecordMode RecordAll $ do
 400     recordHeader [pkg_name, cname]
 401     runM exePath args Nothing
 402
 403 planExePath :: String {- package name -} -> String {- component name -}
 404             -> TestM FilePath
 405 planExePath pkg_name cname = do
 406     Just plan <- testPlan `fmap` getTestEnv
 407     let distDirOrBinFile = planDistDir plan (mkPackageName pkg_name)
 408                                (CExeName (mkUnqualComponentName cname))
 409         exePath = case distDirOrBinFile of
 410           DistDir dist_dir -> dist_dir </> "build" </> cname </> cname
 411           BinFile bin_file -> bin_file
 412     return exePath
 413
 414 ------------------------------------------------------------------------
 415 -- * Running ghc-pkg
 416
 417 withPackageDb :: TestM a -> TestM a
 418 withPackageDb m = do
 419     env <- getTestEnv
 420     let db_path = testPackageDbDir env
 421     if testHavePackageDb env
 422         then m
 423         else withReaderT (\nenv ->
 424                             nenv { testPackageDBStack
 425                                     = testPackageDBStack env
 426                                    ++ [SpecificPackageDB db_path]
 427                                 , testHavePackageDb = True
 428                                 } )
 429                $ do ghcPkg "init" [db_path]
 430                     m
 431
 432 -- | Don't pass `--package-db` to cabal-install, so it won't find the specific version of
 433 -- `Cabal` which you have configured the testsuite to run with. You probably don't want to use
 434 -- this unless you are testing the `--package-db` flag itself.
 435 noCabalPackageDb :: TestM a -> TestM a
 436 noCabalPackageDb m = withReaderT (\nenv -> nenv { testPackageDbPath = Nothing }) m
 437
 438 ghcPkg :: String -> [String] -> TestM ()
 439 ghcPkg cmd args = void (ghcPkg' cmd args)
 440
 441 ghcPkg' :: String -> [String] -> TestM Result
 442 ghcPkg' cmd args = do
 443     env <- getTestEnv
 444     unless (testHavePackageDb env) $
 445         error "Must initialize package database using withPackageDb"
 446     -- NB: testDBStack already has the local database
 447     ghcConfProg <- requireProgramM ghcProgram
 448     let db_stack = testPackageDBStack env
 449         extraArgs = ghcPkgPackageDBParams
 450                         (fromMaybe
 451                             (error "ghc-pkg: cannot detect version")
 452                             (programVersion ghcConfProg))
 453                         db_stack
 454     recordHeader ["ghc-pkg", cmd]
 455     runProgramM ghcPkgProgram (cmd : extraArgs ++ args) Nothing
 456
 457 ghcPkgPackageDBParams :: Version -> PackageDBStackCWD -> [String]
 458 ghcPkgPackageDBParams version dbs = concatMap convert dbs where
 459     convert :: PackageDBCWD -> [String]
 460     -- Ignoring global/user is dodgy but there's no way good
 461     -- way to give ghc-pkg the correct flags in this case.
 462     convert  GlobalPackageDB         = []
 463     convert  UserPackageDB           = []
 464     convert (SpecificPackageDB path)
 465         | version >= mkVersion [7,6]
 466         = ["--package-db=" ++ path]
 467         | otherwise
 468         = ["--package-conf=" ++ path]
 469
 470 ------------------------------------------------------------------------
 471 -- * Running other things
 472
 473 -- | Run an executable that was produced by cabal.  The @exe_name@
 474 -- is precisely the name of the executable section in the file.
 475 runExe :: String -> [String] -> TestM ()
 476 runExe exe_name args = void (runExe' exe_name args)
 477
 478 runExe' :: String -> [String] -> TestM Result
 479 runExe' exe_name args = do
 480     env <- getTestEnv
 481     defaultRecordMode RecordAll $ do
 482     recordHeader [exe_name]
 483     runM (testDistDir env </> "build" </> exe_name </> exe_name) args Nothing
 484
 485 -- | Run an executable that was installed by cabal.  The @exe_name@
 486 -- is precisely the name of the executable.
 487 runInstalledExe :: String -> [String] -> TestM ()
 488 runInstalledExe exe_name args = void (runInstalledExe' exe_name args)
 489
 490 -- | Run an executable that was installed by cabal.  Use this
 491 -- instead of 'runInstalledExe' if you need to inspect the
 492 -- stdout/stderr output.
 493 runInstalledExe' :: String -> [String] -> TestM Result
 494 runInstalledExe' exe_name args = do
 495     env <- getTestEnv
 496     defaultRecordMode RecordAll $ do
 497     recordHeader [exe_name]
 498     runM (testPrefixDir env </> "bin" </> exe_name) args Nothing
 499
 500 -- | Run a shell command in the current directory.
 501 shell :: String -> [String] -> TestM Result
 502 shell exe args = runM exe args Nothing
 503
 504 ------------------------------------------------------------------------
 505 -- * Repository manipulation
 506
 507 -- Workflows we support:
 508 --  1. Test comes with some packages (directories in repository) which
 509 --  should be in the repository and available for depsolving/installing
 510 --  into global store.
 511 --
 512 -- Workflows we might want to support in the future
 513 --  * Regression tests may want to test on Hackage index.  They will
 514 --  operate deterministically as they will be pinned to a timestamp.
 515 --  (But should we allow this? Have to download the tarballs in that
 516 --  case. Perhaps dep solver only!)
 517 --  * We might sdist a local package, and then upload it to the
 518 --  repository
 519 --  * Some of our tests involve old versions of Cabal.  This might
 520 --  be one of the rare cases where we're willing to grab the entire
 521 --  tarball.
 522 --
 523 -- Properties we want to hold:
 524 --  1. Tests can be run offline.  No dependence on hackage.haskell.org
 525 --  beyond what we needed to actually get the build of Cabal working
 526 --  itself
 527 --  2. Tests are deterministic.  Updates to Hackage should not cause
 528 --  tests to fail.  (OTOH, it's good to run tests on most recent
 529 --  Hackage index; some sort of canary test which is run nightly.
 530 --  Point is it should NOT be tied to cabal source code.)
 531 --
 532 -- Technical notes:
 533 --  * We depend on hackage-repo-tool binary.  It would better if it was
 534 --  libified into hackage-security but this has not been done yet.
 535 --
 536
 537 hackageRepoTool :: String -> [String] -> TestM ()
 538 hackageRepoTool cmd args = void $ hackageRepoTool' cmd args
 539
 540 hackageRepoTool' :: String -> [String] -> TestM Result
 541 hackageRepoTool' cmd args = do
 542     recordHeader ["hackage-repo-tool", cmd]
 543     runProgramM hackageRepoToolProgram (cmd : args) Nothing
 544
 545 tar :: [String] -> TestM ()
 546 tar args = void $ tar' args
 547
 548 tar' :: [String] -> TestM Result
 549 tar' args = do
 550     recordHeader ["tar"]
 551     runProgramM tarProgram args Nothing
 552
 553 -- | Creates a tarball of a directory, such that if you
 554 -- archive the directory "/foo/bar/baz" to "mine.tgz", @tar tf@ reports
 555 -- @baz/file1@, @baz/file2@, etc.
 556 archiveTo :: FilePath -> FilePath -> TestM ()
 557 src `archiveTo` dst = do
 558     -- TODO: Consider using the @tar@ library?
 559     let (src_parent, src_dir) = splitFileName src
 560     -- TODO: --format ustar, like createArchive?
 561     -- --force-local is necessary for handling colons in Windows paths.
 562     tar $ ["-czf", dst]
 563        ++ ["-C", src_parent, src_dir]
 564
 565 infixr 4 `archiveTo`
 566
 567 -- | Given a directory (relative to the 'testCurrentDir') containing
 568 -- a series of directories representing packages, generate an
 569 -- external repository corresponding to all of these packages
 570 withRepo :: FilePath -> TestM a -> TestM a
 571 withRepo repo_dir m = do
 572     env <- getTestEnv
 573
 574     -- 1. Initialize repo directory
 575     let package_dir = testRepoDir env
 576     liftIO $ createDirectoryIfMissing True package_dir
 577
 578     -- 2. Create tarballs
 579     pkgs <- liftIO $ getDirectoryContents (testCurrentDir env </> repo_dir)
 580     forM_ pkgs $ \pkg -> do
 581         let srcPath = testCurrentDir env </> repo_dir </> pkg
 582         let destPath = package_dir </> pkg
 583         isPreferredVersionsFile <- liftIO $
 584             -- validate this is the "magic" 'preferred-versions' file
 585             -- and perform a sanity-check whether this is actually a file
 586             -- and not a package that happens to have the same name.
 587             if pkg == "preferred-versions"
 588                 then doesFileExist srcPath
 589                 else return False
 590         case pkg of
 591             '.':_ -> return ()
 592             _
 593                 | isPreferredVersionsFile ->
 594                     liftIO $ copyFile srcPath destPath
 595                 | otherwise -> archiveTo
 596                     srcPath
 597                     (destPath <.> "tar.gz")
 598
 599     -- 3. Wire it up in .cabal/config
 600     -- TODO: libify this
 601     let package_cache = testCabalDir env </> "packages"
 602     liftIO $ appendFile (testUserCabalConfigFile env)
 603            $ unlines [ "repository test-local-repo"
 604                      , "  url: " ++ repoUri env
 605                      , "remote-repo-cache: " ++ package_cache ]
 606     liftIO $ print $ testUserCabalConfigFile env
 607     liftIO $ print =<< readFile (testUserCabalConfigFile env)
 608
 609     -- 4. Update our local index
 610     -- Note: this doesn't do anything for file+noindex repositories.
 611     cabal "v2-update" ["-z"]
 612
 613     -- 5. Profit
 614     withReaderT (\env' -> env' { testHaveRepo = True }) m
 615     -- TODO: Arguably should undo everything when we're done...
 616   where
 617     repoUri env ="file+noindex://" ++ (if isWindows
 618                                         then map (\x -> case x of
 619                                             '\\' -> '/'
 620                                             _ -> x)
 621                                         else id) (testRepoDir env)
 622
 623 -- | Given a directory (relative to the 'testCurrentDir') containing
 624 -- a series of directories representing packages, generate an
 625 -- remote repository corresponding to all of these packages
 626 withRemoteRepo :: FilePath -> TestM a -> TestM a
 627 withRemoteRepo repoDir m = do
 628
 629     -- we rely on the presence of python3 for a simple http server
 630     skipUnless "no python3" =<< isAvailableProgram python3Program
 631     -- we rely on hackage-repo-tool to set up the secure repository
 632     skipUnless "no hackage-repo-tool" =<< isAvailableProgram hackageRepoToolProgram
 633
 634     env <- getTestEnv
 635
 636     let workDir = testRepoDir env
 637
 638     -- 1. Initialize repo and repo_keys directory
 639     let keysDir = workDir </> "keys"
 640     let packageDir = workDir </> "package"
 641
 642     liftIO $ createDirectoryIfMissing True packageDir
 643     liftIO $ createDirectoryIfMissing True keysDir
 644
 645     -- 2. Create tarballs
 646     entries <- liftIO $ getDirectoryContents (testCurrentDir env </> repoDir)
 647     forM_ entries $ \entry -> do
 648         let srcPath = testCurrentDir env </> repoDir </> entry
 649         let destPath = packageDir </> entry
 650         isPreferredVersionsFile <- liftIO $
 651             -- validate this is the "magic" 'preferred-versions' file
 652             -- and perform a sanity-check whether this is actually a file
 653             -- and not a package that happens to have the same name.
 654             if entry == "preferred-versions"
 655                 then doesFileExist srcPath
 656                 else return False
 657         case entry of
 658             '.' : _ -> return ()
 659             _
 660                 | isPreferredVersionsFile ->
 661                       liftIO $ copyFile srcPath destPath
 662                 | otherwise ->
 663                   archiveTo srcPath (destPath <.> "tar.gz")
 664
 665     -- 3. Create keys and bootstrap repository
 666     hackageRepoTool "create-keys" $ ["--keys", keysDir ]
 667     hackageRepoTool "bootstrap" $ ["--keys", keysDir, "--repo", workDir]
 668
 669     -- 4. Wire it up in .cabal/config
 670     let package_cache = testCabalDir env </> "packages"
 671     -- In the following we launch a python http server to serve the remote
 672     -- repository. When the http server is ready we proceed with the tests.
 673     -- NOTE 1: it's important that both the http server and cabal use the
 674     -- same hostname ("localhost"), otherwise there could be a mismatch
 675     -- (depending on the details of the host networking settings).
 676     -- NOTE 2: here we use a fixed port (8000). This can cause problems in
 677     -- case multiple tests are running concurrently or other another
 678     -- process on the developer machine is using the same port.
 679     liftIO $ do
 680         appendFile (testUserCabalConfigFile env) $
 681             unlines [ "repository repository.localhost"
 682                     , "  url: http://localhost:8000/"
 683                     , "  secure: True"
 684                     , "  root-keys:"
 685                     , "  key-threshold: 0"
 686                     , "remote-repo-cache: " ++ package_cache ]
 687         putStrLn $ testUserCabalConfigFile env
 688         putStrLn =<< readFile (testUserCabalConfigFile env)
 689
 690         withAsync
 691           (flip runReaderT env $ python3 ["-m", "http.server", "-d", workDir, "--bind", "localhost", "8000"])
 692           (\_ -> do
 693             -- wait for the python webserver to come up with a exponential
 694             -- backoff starting from 50ms, up to a maximum wait of 60s
 695             _ <- waitTcpVerbose putStrLn (limitRetriesByCumulativeDelay 60000000 $ exponentialBackoff 50000) "localhost" "8000"
 696             r <- runReaderT m (env { testHaveRepo = True })
 697             -- Windows fails to kill the python server when the function above
 698             -- is complete, so we kill it directly via CMD.
 699             when (buildOS == Windows) $ void $ createProcess_ "kill python" $ System.Process.shell "taskkill /F /IM python3.exe"
 700             pure r
 701             )
 702
 703
 704
 705 -- | Record a header to help identify the output to the expect
 706 -- log.  Unlike the 'recordLog', we don't record all arguments;
 707 -- just enough to give you an idea of what the command might have
 708 -- been.  (This is because the arguments may not be deterministic,
 709 -- so we don't want to spew them to the log.)
 710 recordHeader :: [String] -> TestM ()
 711 recordHeader args = do
 712     env <- getTestEnv
 713     let mode = testRecordMode env
 714         str_header = "# " ++ intercalate " " args ++ "\n"
 715         rec_header = C.pack str_header
 716     case mode of
 717         DoNotRecord -> return ()
 718         _ -> do
 719             initWorkDir
 720             liftIO $ putStr str_header
 721             liftIO $ C.appendFile (testWorkDir env </> "test.log") rec_header
 722             liftIO $ C.appendFile (testActualFile env) rec_header
 723
 724
 725 ------------------------------------------------------------------------
 726 -- * Test helpers
 727
 728 ------------------------------------------------------------------------
 729 -- * Subprocess run results
 730 assertFailure :: WithCallStack (String -> m a)
 731 assertFailure msg = withFrozenCallStack $ error msg
 732
 733 assertExitCode :: MonadIO m => WithCallStack (ExitCode -> Result -> m ())
 734 assertExitCode code result =
 735   when (code /= resultExitCode result) $
 736     assertFailure $ "Expected exit code: "
 737                  ++ show code
 738                  ++ "\nActual: "
 739                  ++ show (resultExitCode result)
 740
 741 assertEqual :: (Eq a, Show a, MonadIO m) => WithCallStack (String -> a -> a -> m ())
 742 assertEqual s x y =
 743     withFrozenCallStack $
 744       when (x /= y) $
 745         error (s ++ ":\nExpected: " ++ show x ++ "\nActual: " ++ show y)
 746
 747 assertNotEqual :: (Eq a, Show a, MonadIO m) => WithCallStack (String -> a -> a -> m ())
 748 assertNotEqual s x y =
 749     withFrozenCallStack $
 750       when (x == y) $
 751         error (s ++ ":\nGot both: " ++ show x)
 752
 753 assertBool :: MonadIO m => WithCallStack (String -> Bool -> m ())
 754 assertBool s x =
 755     withFrozenCallStack $
 756       unless x $ error s
 757
 758 shouldExist :: MonadIO m => WithCallStack (FilePath -> m ())
 759 shouldExist path =
 760     withFrozenCallStack $
 761     liftIO $ doesFileExist path >>= assertBool (path ++ " should exist")
 762
 763 shouldNotExist :: MonadIO m => WithCallStack (FilePath -> m ())
 764 shouldNotExist path =
 765     withFrozenCallStack $
 766     liftIO $ doesFileExist path >>= assertBool (path ++ " should exist") . not
 767
 768 shouldDirectoryExist :: MonadIO m => WithCallStack (FilePath -> m ())
 769 shouldDirectoryExist path =
 770     withFrozenCallStack $
 771     liftIO $ doesDirectoryExist path >>= assertBool (path ++ " should exist")
 772
 773 shouldDirectoryNotExist :: MonadIO m => WithCallStack (FilePath -> m ())
 774 shouldDirectoryNotExist path =
 775     withFrozenCallStack $
 776     liftIO $ doesDirectoryExist path >>= assertBool (path ++ " should exist") . not
 777
 778 assertRegex :: MonadIO m => String -> String -> Result -> m ()
 779 assertRegex msg regex r =
 780     withFrozenCallStack $
 781     let out = resultOutput r
 782     in assertBool (msg ++ ",\nactual output:\n" ++ out)
 783        (out =~ regex)
 784
 785 fails :: TestM a -> TestM a
 786 fails = withReaderT (\env -> env { testShouldFail = not (testShouldFail env) })
 787
 788 defaultRecordMode :: RecordMode -> TestM a -> TestM a
 789 defaultRecordMode mode = withReaderT (\env -> env {
 790     testRecordDefaultMode = mode
 791     })
 792
 793 recordMode :: RecordMode -> TestM a -> TestM a
 794 recordMode mode = withReaderT (\env -> env {
 795     testRecordUserMode = Just mode
 796     })
 797
 798 assertOutputContains :: MonadIO m => WithCallStack (String -> Result -> m ())
 799 assertOutputContains needle result =
 800     withFrozenCallStack $
 801     unless (needle `isInfixOf` (concatOutput output)) $
 802     assertFailure $ " expected: " ++ needle
 803   where output = resultOutput result
 804
 805 assertOutputDoesNotContain :: MonadIO m => WithCallStack (String -> Result -> m ())
 806 assertOutputDoesNotContain needle result =
 807     withFrozenCallStack $
 808     when (needle `isInfixOf` (concatOutput output)) $
 809     assertFailure $ "unexpected: " ++ needle
 810   where output = resultOutput result
 811
 812 assertFindInFile :: MonadIO m => WithCallStack (String -> FilePath -> m ())
 813 assertFindInFile needle path =
 814     withFrozenCallStack $
 815     liftIO $ withFileContents path
 816                  (\contents ->
 817                   unless (needle `isInfixOf` contents)
 818                          (assertFailure ("expected: " ++ needle ++ "\n" ++
 819                                          " in file: " ++ path)))
 820
 821 assertFileDoesContain :: MonadIO m => WithCallStack (FilePath -> String -> m ())
 822 assertFileDoesContain path needle =
 823     withFrozenCallStack $
 824     liftIO $ withFileContents path
 825                  (\contents ->
 826                   unless (needle `isInfixOf` contents)
 827                          (assertFailure ("expected: " ++ needle ++ "\n" ++
 828                                          " in file: " ++ path)))
 829
 830 assertFileDoesNotContain :: MonadIO m => WithCallStack (FilePath -> String -> m ())
 831 assertFileDoesNotContain path needle =
 832     withFrozenCallStack $
 833     liftIO $ withFileContents path
 834                  (\contents ->
 835                   when (needle `isInfixOf` contents)
 836                        (assertFailure ("expected: " ++ needle ++ "\n" ++
 837                                        " in file: " ++ path)))
 838
 839 -- | Assert that at least one of the given paths contains the given search string.
 840 assertAnyFileContains :: MonadIO m => WithCallStack ([FilePath] -> String -> m ())
 841 assertAnyFileContains paths needle = do
 842     let findOne found path =
 843             if found
 844                then pure found
 845                else withFileContents path $ \contents ->
 846                    pure $! needle `isInfixOf` contents
 847     foundNeedle <- liftIO $ foldM findOne False paths
 848     withFrozenCallStack $
 849       unless foundNeedle $
 850         assertFailure $
 851           "expected: " <>
 852           needle <>
 853           "\nin one of:\n" <>
 854           unlines (map ("* " <>) paths)
 855
 856 -- | Assert that none of the given paths contains the given search string.
 857 assertNoFileContains :: MonadIO m => WithCallStack ([FilePath] -> String -> m ())
 858 assertNoFileContains paths needle =
 859     liftIO $
 860       forM_ paths $
 861         \path ->
 862           assertFileDoesNotContain path needle
 863
 864 -- | Replace line breaks with spaces, correctly handling "\r\n".
 865 concatOutput :: String -> String
 866 concatOutput = unwords . lines . filter ((/=) '\r')
 867
 868 -- | The directory where script build artifacts are expected to be cached
 869 getScriptCacheDirectory :: FilePath -> TestM FilePath
 870 getScriptCacheDirectory script = do
 871     cabalDir <- testCabalDir `fmap` getTestEnv
 872     hashinput <- liftIO $ canonicalizePath script
 873     let hash = C.unpack . Base16.encode . C.take 26 . SHA256.hash . C.pack $ hashinput
 874     return $ cabalDir </> "script-builds" </> hash
 875
 876 ------------------------------------------------------------------------
 877 -- * Globs
 878
 879 -- | Match a glob from a root directory and return the results.
 880 matchGlob :: MonadIO m => FilePath -> String -> m [FilePath]
 881 matchGlob root glob = do
 882   liftIO $ Glob.globDir1 (Glob.compile glob) root
 883
 884 -- | Assert that a glob matches at least one path in the given root directory.
 885 --
 886 -- The matched paths are returned for further validation.
 887 assertGlobMatches :: MonadIO m => WithCallStack (FilePath -> String -> m [FilePath])
 888 assertGlobMatches root glob = do
 889   results <- matchGlob root glob
 890   withFrozenCallStack $
 891     when (null results) $
 892       assertFailure $
 893         "Expected glob " <> show glob <> " to match in " <> show root
 894   pure results
 895
 896 -- | Assert that a glob matches no paths in the given root directory.
 897 assertGlobDoesNotMatch :: MonadIO m => WithCallStack (FilePath -> String -> m ())
 898 assertGlobDoesNotMatch root glob = do
 899   results <- matchGlob root glob
 900   withFrozenCallStack $
 901     unless (null results) $
 902       assertFailure $
 903         "Expected glob "
 904           <> show glob
 905           <> " to not match any paths in "
 906           <> show root
 907           <> ", but the following matches were found:"
 908           <> unlines (map ("* " <>) results)
 909
 910 -- | Assert that a glob matches a path in the given root directory.
 911 --
 912 -- The root directory is determined from the `TestEnv` with a function like `testDistDir`.
 913 --
 914 -- The matched paths are returned for further validation.
 915 assertGlobMatchesTestDir :: WithCallStack ((TestEnv -> FilePath) -> String -> TestM [FilePath])
 916 assertGlobMatchesTestDir rootSelector glob = do
 917   root <- asks rootSelector
 918   assertGlobMatches root glob
 919
 920 -- | Assert that a glob matches a path in the given root directory.
 921 --
 922 -- The root directory is determined from the `TestEnv` with a function like `testDistDir`.
 923 assertGlobDoesNotMatchTestDir :: WithCallStack ((TestEnv -> FilePath) -> String -> TestM ())
 924 assertGlobDoesNotMatchTestDir rootSelector glob = do
 925   root <- asks rootSelector
 926   assertGlobDoesNotMatch root glob
 927
 928 ------------------------------------------------------------------------
 929 -- * Skipping tests
 930
 931 testCompilerWithArgs :: [String] -> TestM Bool
 932 testCompilerWithArgs args = do
 933     env <- getTestEnv
 934     ghc_path <- programPathM ghcProgram
 935     let prof_test_hs = testWorkDir env </> "Prof.hs"
 936     liftIO $ writeFile prof_test_hs "module Prof where"
 937     r <- liftIO $ run (testVerbosity env) (Just $ testCurrentDir env)
 938                       (testEnvironment env) ghc_path (["-c", prof_test_hs] ++ args)
 939                       Nothing
 940     return (resultExitCode r == ExitSuccess)
 941
 942 hasProfiledLibraries, hasProfiledSharedLibraries, hasSharedLibraries :: TestM Bool
 943 hasProfiledLibraries = testCompilerWithArgs ["-prof"]
 944 hasProfiledSharedLibraries = testCompilerWithArgs ["-prof", "-dynamic"]
 945 hasSharedLibraries = testCompilerWithArgs ["-dynamic"]
 946
 947 skipIfNoSharedLibraries :: TestM ()
 948 skipIfNoSharedLibraries = skipUnless "no shared libraries" =<< hasSharedLibraries
 949
 950 skipIfNoProfiledLibraries :: TestM ()
 951 skipIfNoProfiledLibraries = skipUnless "no profiled libraries" =<< hasProfiledLibraries
 952
 953 -- | Check if the GHC that is used for compiling package tests has
 954 -- a shared library of the cabal library under test in its database.
 955 --
 956 -- An example where this is needed is if you want to dynamically link
 957 -- detailed-0.9 test suites, since those depend on the Cabal library unde rtest.
 958 hasCabalShared :: TestM Bool
 959 hasCabalShared = do
 960   env <- getTestEnv
 961   return (testHaveCabalShared env)
 962
 963
 964 anyCabalVersion :: WithCallStack ( String -> TestM Bool )
 965 anyCabalVersion = isCabalVersion any
 966
 967 allCabalVersion :: WithCallStack ( String -> TestM Bool )
 968 allCabalVersion = isCabalVersion all
 969
 970 -- Used by cabal-install tests to determine which Cabal library versions are
 971 -- available. Given a version range, and a predicate on version ranges,
 972 -- are there any installed packages Cabal library
 973 -- versions which satisfy these.
 974 isCabalVersion :: WithCallStack (((Version -> Bool) -> [Version] -> Bool) -> String -> TestM Bool)
 975 isCabalVersion decide range = do
 976   env <- getTestEnv
 977   cabal_pkgs <- ghcPkg_raw' $ ["--global", "list", "Cabal", "--simple"] ++ ["--package-db=" ++ db | Just dbs <- [testPackageDbPath env], db <- dbs]
 978   let pkg_versions :: [PackageIdentifier] = mapMaybe simpleParsec (words (resultOutput cabal_pkgs))
 979   vr <- case eitherParsec range of
 980           Left err -> fail err
 981           Right vr -> return vr
 982   return $ decide (`withinRange` vr)  (map pkgVersion pkg_versions)
 983
 984 -- | Skip a test unless any available Cabal library version matches the predicate.
 985 skipUnlessAnyCabalVersion :: String -> TestM ()
 986 skipUnlessAnyCabalVersion range = skipUnless ("needs any Cabal " ++ range) =<< anyCabalVersion range
 987
 988 -- | Skip a test if any available Cabal library version matches the predicate.
 989 skipIfAnyCabalVersion :: String -> TestM ()
 990 skipIfAnyCabalVersion range = skipIf ("incompatible with Cabal " ++ range) =<< anyCabalVersion range
 991
 992 -- | Skip a test unless all Cabal library versions match the predicate.
 993 skipUnlessAllCabalVersion :: String -> TestM ()
 994 skipUnlessAllCabalVersion range = skipUnless ("needs all Cabal " ++ range) =<< allCabalVersion range
 995
 996 -- | Skip a test if all the Cabal library version matches a predicate.
 997 skipIfAllCabalVersion :: String -> TestM ()
 998 skipIfAllCabalVersion range = skipIf ("incompatible with Cabal " ++ range) =<< allCabalVersion range
 999
1000 isGhcVersion :: WithCallStack (String -> TestM Bool)
1001 isGhcVersion range = do
1002     ghc_program <- requireProgramM ghcProgram
1003     v <- case programVersion ghc_program of
1004         Nothing -> error $ "isGhcVersion: no ghc version for "
1005                         ++ show (programLocation ghc_program)
1006         Just v -> return v
1007     vr <- case eitherParsec range of
1008         Left err -> fail err
1009         Right vr -> return vr
1010     return (v `withinRange` vr)
1011
1012 skipUnlessGhcVersion :: String -> TestM ()
1013 skipUnlessGhcVersion range = skipUnless ("needs ghc " ++ range) =<< isGhcVersion range
1014
1015 skipIfGhcVersion :: String -> TestM ()
1016 skipIfGhcVersion range = skipIf ("incompatible with ghc " ++ range) =<< isGhcVersion range
1017
1018 skipUnlessJavaScript :: IO ()
1019 skipUnlessJavaScript = skipUnlessIO "needs the JavaScript backend" isJavaScript
1020
1021 skipIfJavaScript :: IO ()
1022 skipIfJavaScript = skipIfIO "incompatible with the JavaScript backend" isJavaScript
1023
1024 isWindows :: Bool
1025 isWindows = buildOS == Windows
1026
1027 isCI :: IO Bool
1028 isCI = isJust <$> lookupEnv "CI"
1029
1030 isOSX :: Bool
1031 isOSX = buildOS == OSX
1032
1033 isLinux :: Bool
1034 isLinux = buildOS == Linux
1035
1036 isJavaScript :: Bool
1037 isJavaScript = buildArch == JavaScript
1038   -- should probably be `hostArch` but Cabal doesn't distinguish build platform
1039   -- and host platform
1040
1041 skipIfWindows :: String -> IO ()
1042 skipIfWindows why = skipIfIO ("Windows " <> why) isWindows
1043
1044 skipUnlessWindows :: IO ()
1045 skipUnlessWindows = skipIfIO "Only interesting in Windows" (not isWindows)
1046
1047 skipIfOSX :: String -> IO ()
1048 skipIfOSX why = skipIfIO ("OSX " <> why) isOSX
1049
1050 skipIfCI :: IssueID -> IO ()
1051 skipIfCI ticket = skipIfIO ("CI, see #" <> show ticket) =<< isCI
1052
1053 skipIfCIAndWindows :: IssueID -> IO ()
1054 skipIfCIAndWindows ticket = skipIfIO ("Windows CI, see #" <> show ticket) . (isWindows &&) =<< isCI
1055
1056 skipIfCIAndOSX :: IssueID -> IO ()
1057 skipIfCIAndOSX ticket = skipIfIO ("OSX CI, see #" <> show ticket) . (isOSX &&) =<< isCI
1058
1059 expectBrokenIfWindows :: IssueID -> TestM a -> TestM a
1060 expectBrokenIfWindows ticket = expectBrokenIf isWindows ticket
1061
1062 expectBrokenIfWindowsCI :: IssueID -> TestM a -> TestM a
1063 expectBrokenIfWindowsCI ticket m = do
1064     ci <- liftIO isCI
1065     expectBrokenIf (isWindows && ci) ticket m
1066
1067 expectBrokenIfWindowsCIAndGhc :: String -> IssueID -> TestM a -> TestM a
1068 expectBrokenIfWindowsCIAndGhc range ticket m = do
1069     ghcVer <- isGhcVersion range
1070     ci <- liftIO isCI
1071     expectBrokenIf (isWindows && ghcVer && ci) ticket m
1072
1073 expectBrokenIfWindowsAndGhc :: String -> IssueID -> TestM a -> TestM a
1074 expectBrokenIfWindowsAndGhc range ticket m = do
1075     ghcVer <- isGhcVersion range
1076     expectBrokenIf (isWindows && ghcVer) ticket m
1077
1078 expectBrokenIfOSXAndGhc :: String -> IssueID -> TestM a -> TestM a
1079 expectBrokenIfOSXAndGhc range ticket m = do
1080     ghcVer <- isGhcVersion range
1081     expectBrokenIf (isOSX && ghcVer) ticket m
1082
1083 expectBrokenIfGhc :: String -> IssueID -> TestM a -> TestM a
1084 expectBrokenIfGhc range ticket m = do
1085     ghcVer <- isGhcVersion range
1086     expectBrokenIf ghcVer ticket m
1087
1088 flakyIfCI :: IssueID -> TestM a -> TestM a
1089 flakyIfCI ticket m = do
1090     ci <- liftIO isCI
1091     flakyIf ci ticket m
1092
1093 flakyIfWindows :: IssueID -> TestM a -> TestM a
1094 flakyIfWindows ticket m = flakyIf isWindows ticket m
1095
1096 getOpenFilesLimit :: TestM (Maybe Integer)
1097 #ifdef mingw32_HOST_OS
1098 -- No MS-specified limit, was determined experimentally on Windows 10 Pro x64,
1099 -- matches other online reports from other versions of Windows.
1100 getOpenFilesLimit = return (Just 2048)
1101 #else
1102 getOpenFilesLimit = liftIO $ do
1103     ResourceLimits { softLimit } <- getResourceLimit ResourceOpenFiles
1104     case softLimit of
1105         ResourceLimit n | n >= 0 && n <= 4096 -> return (Just n)
1106         _                                     -> return Nothing
1107 #endif
1108
1109 -- | If you want to use a Custom setup with new-build, it needs to
1110 -- be 1.20 or later.  Ordinarily, Cabal can go off and build a
1111 -- sufficiently recent Cabal if necessary, but in our test suite,
1112 -- by default, we try to avoid doing so (since that involves a
1113 -- rather lengthy build process), instead using the boot Cabal if
1114 -- possible.  But some GHCs don't have a recent enough boot Cabal!
1115 -- You'll want to exclude them in that case.
1116 --
1117 hasNewBuildCompatBootCabal :: TestM Bool
1118 hasNewBuildCompatBootCabal = isGhcVersion ">= 7.9"
1119
1120 -- * Programs
1121
1122 git :: String -> [String] -> TestM ()
1123 git cmd args = void $ git' cmd args
1124
1125 git' :: String -> [String] -> TestM Result
1126 git' cmd args = do
1127     recordHeader ["git", cmd]
1128     runProgramM gitProgram (cmd : args) Nothing
1129
1130 gcc :: [String] -> TestM ()
1131 gcc args = void $ gcc' args
1132
1133 gcc' :: [String] -> TestM Result
1134 gcc' args = do
1135     recordHeader ["gcc"]
1136     runProgramM gccProgram args Nothing
1137
1138 ghc :: [String] -> TestM ()
1139 ghc args = void $ ghc' args
1140
1141 ghc' :: [String] -> TestM Result
1142 ghc' args = do
1143     recordHeader ["ghc"]
1144     runProgramM ghcProgram args Nothing
1145
1146 ghcPkg_raw' :: [String] -> TestM Result
1147 ghcPkg_raw' args = do
1148   recordHeader ["ghc-pkg"]
1149   runProgramM ghcPkgProgram args Nothing
1150
1151
1152 python3 :: [String] -> TestM ()
1153 python3 args = void $ python3' args
1154
1155 python3' :: [String] -> TestM Result
1156 python3' args = do
1157     recordHeader ["python3"]
1158     runProgramM python3Program args Nothing
1159
1160
1161 -- | Look up the 'InstalledPackageId' of a package name.
1162 getIPID :: String -> TestM String
1163 getIPID pn = do
1164     r <- ghcPkg' "field" ["--global", pn, "id"]
1165     -- Don't choke on warnings from ghc-pkg
1166     case mapMaybe (stripPrefix "id: ") (lines (resultOutput r)) of
1167         -- ~/.cabal/store may contain multiple versions of single package
1168         -- we pick first one. It should work
1169         (x:_) -> return (takeWhile (not . Char.isSpace) x)
1170         _     -> error $ "could not determine id of " ++ pn
1171
1172 -- | Delay a sufficient period of time to permit file timestamp
1173 -- to be updated.
1174 delay :: TestM ()
1175 delay = do
1176     env <- getTestEnv
1177     is_old_ghc <- isGhcVersion "< 7.7"
1178     -- For old versions of GHC, we only had second-level precision,
1179     -- so we need to sleep a full second.  Newer versions use
1180     -- millisecond level precision, so we only have to wait
1181     -- the granularity of the underlying filesystem.
1182     -- TODO: cite commit when GHC got better precision; this
1183     -- version bound was empirically generated.
1184     liftIO . threadDelay $
1185         if is_old_ghc
1186             then 1000000
1187             else fromMaybe
1188                     (error "Delay must be enclosed by withDelay")
1189                     (testMtimeChangeDelay env)
1190
1191 -- | Calibrate file modification time delay, if not
1192 -- already determined.
1193 withDelay :: TestM a -> TestM a
1194 withDelay m = do
1195     env <- getTestEnv
1196     case testMtimeChangeDelay env of
1197         Nothing -> do
1198             -- Figure out how long we need to delay for recompilation tests
1199             (_, mtimeChange) <- liftIO $ calibrateMtimeChangeDelay
1200             withReaderT (\nenv -> nenv { testMtimeChangeDelay = Just mtimeChange }) m
1201         Just _ -> m
1202
1203 -- | Create a symlink for the duration of the provided action. If the symlink
1204 -- already exists, it is deleted.
1205 withSymlink :: FilePath -> FilePath -> TestM a -> TestM a
1206 #if defined(mingw32_HOST_OS) && !MIN_VERSION_directory(1,3,1)
1207 withSymlink _oldpath _newpath _act =
1208   error "Test.Cabal.Prelude.withSymlink: does not work on Windows with directory <1.3.1!"
1209 #else
1210 withSymlink oldpath newpath0 act = do
1211   liftIO $ hPutStrLn stderr $ "Symlinking " <> oldpath <> " <== " <> newpath0
1212   env <- getTestEnv
1213   let newpath = testCurrentDir env </> newpath0
1214   symlinkExists <- liftIO $ doesFileExist newpath
1215   when symlinkExists $ liftIO $ removeFile newpath
1216   bracket_ (liftIO $ createFileLink oldpath newpath)
1217            (liftIO $ pure ()) act
1218 #endif
1219
1220 writeSourceFile :: FilePath -> String -> TestM ()
1221 writeSourceFile fp s = do
1222     cwd <- fmap testCurrentDir getTestEnv
1223     liftIO $ writeFile (cwd </> fp) s
1224
1225 copySourceFileTo :: FilePath -> FilePath -> TestM ()
1226 copySourceFileTo src dest = do
1227     cwd <- fmap testCurrentDir getTestEnv
1228     liftIO $ copyFile (cwd </> src) (cwd </> dest)
1229
1230 -- | Work around issue #4515 (store paths exceeding the Windows path length
1231 -- limit) by creating a temporary directory for the new-build store. This
1232 -- function creates a directory immediately under the current drive on Windows.
1233 -- The directory must be passed to new- commands with --store-dir.
1234 withShorterPathForNewBuildStore :: TestM a -> TestM a
1235 withShorterPathForNewBuildStore test =
1236   withTestDir normal "cabal-test-store" (\f -> withStoreDir f test)
1237
1238 -- | Find where a package locates in the store dir. This works only if there is exactly one 1 ghc version
1239 -- and exactly 1 directory for the given package in the store dir.
1240 findDependencyInStore :: String -- ^package name prefix
1241                       -> TestM FilePath -- ^package dir
1242 findDependencyInStore pkgName = do
1243     storeDir <- testStoreDir <$> getTestEnv
1244     liftIO $ do
1245       storeDirForGhcVersion:_ <- listDirectory storeDir
1246       packageDirs <- listDirectory (storeDir </> storeDirForGhcVersion)
1247       -- Ideally, we should call 'hashedInstalledPackageId' from 'Distribution.Client.PackageHash'.
1248       -- But 'PackageHashInputs', especially 'PackageHashConfigInputs', is too hard to construct.
1249       let pkgName' =
1250               if buildOS == OSX
1251               then filter (not . flip elem "aeiou") pkgName
1252                   -- simulates the way 'hashedInstalledPackageId' uses to compress package name
1253               else pkgName
1254       let libDir = case filter (pkgName' `isPrefixOf`) packageDirs of
1255                       [] -> error $ "Could not find " <> pkgName' <> " when searching for " <> pkgName' <> " in\n" <> show packageDirs
1256                       (dir:_) -> dir
1257       pure (storeDir </> storeDirForGhcVersion </> libDir)