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