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

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE ScopedTypeVariables #-}
   3
   4 -- | The test monad
   5 module Test.Cabal.Monad (
   6     -- * High-level runners
   7     setupAndCabalTest,
   8     setupTest,
   9     cabalTest,
  10     cabalTest',
  11     -- * The monad
  12     TestM,
  13     runTestM,
  14     -- * Helper functions
  15     programPathM,
  16     requireProgramM,
  17     isAvailableProgram,
  18     hackageRepoToolProgram,
  19     gitProgram,
  20     cabalProgram,
  21     diffProgram,
  22     python3Program,
  23     requireSuccess,
  24     initWorkDir,
  25     recordLog,
  26     -- * The test environment
  27     TestEnv(..),
  28     getTestEnv,
  29     -- * Recording mode
  30     RecordMode(..),
  31     testRecordMode,
  32     -- * Derived values from 'TestEnv'
  33     testCurrentDir,
  34     testWorkDir,
  35     testPrefixDir,
  36     testLibInstallDir,
  37     testDistDir,
  38     testPackageDbDir,
  39     testRepoDir,
  40     testKeysDir,
  41     testSourceCopyDir,
  42     testCabalDir,
  43     testStoreDir,
  44     testUserCabalConfigFile,
  45     testActualFile,
  46     -- * Skipping tests
  47     skip,
  48     skipIO,
  49     skipIf,
  50     skipIfIO,
  51     skipUnless,
  52     skipUnlessIO,
  53     -- * Known broken tests
  54     expectedBroken,
  55     unexpectedSuccess,
  56     -- * Arguments (TODO: move me)
  57     CommonArgs(..),
  58     renderCommonArgs,
  59     commonArgParser,
  60     -- * Version Constants
  61     cabalVersionLibrary,
  62 ) where
  63
  64 import Test.Cabal.Script
  65 import Test.Cabal.Plan
  66 import Test.Cabal.OutputNormalizer
  67 import Test.Cabal.TestCode
  68
  69 import Distribution.Pretty (prettyShow)
  70 import Distribution.Simple.Compiler
  71     ( PackageDBStack, PackageDB(..), compilerFlavor
  72     , Compiler, compilerVersion, showCompilerIdWithAbi )
  73 import Distribution.System
  74 import Distribution.Simple.Program.Db
  75 import Distribution.Simple.Program
  76 import Distribution.Simple.Configure
  77     ( configCompilerEx )
  78 import qualified Distribution.Simple.Utils as U (cabalVersion)
  79 import Distribution.Text
  80
  81 import Test.Utils.TempTestDir (removeDirectoryRecursiveHack)
  82 import Distribution.Verbosity
  83 import Distribution.Version
  84
  85 #if !MIN_VERSION_base(4,11,0)
  86 import Data.Monoid ((<>))
  87 #endif
  88 import Data.Monoid (mempty)
  89 import qualified Control.Exception as E
  90 import Control.Monad
  91 import Control.Monad.Trans.Reader
  92 import Control.Monad.IO.Class
  93 import Data.Maybe
  94 import Control.Applicative
  95 import System.Directory
  96 import System.Exit
  97 import System.FilePath
  98 import System.IO
  99 import System.IO.Error (isDoesNotExistError)
 100 import Distribution.Simple.Utils hiding (info)
 101 import System.Process hiding (env)
 102 import Options.Applicative
 103 import Test.Cabal.Run
 104 import qualified Data.ByteString.Char8 as C
 105 import Data.List
 106 import GHC.Stack
 107
 108 data CommonArgs = CommonArgs {
 109         argCabalInstallPath    :: Maybe FilePath,
 110         argGhcPath             :: Maybe FilePath,
 111         argHackageRepoToolPath :: Maybe FilePath,
 112         argHaddockPath         :: Maybe FilePath,
 113         argKeepTmpFiles        :: Bool,
 114         argAccept              :: Bool,
 115         argSkipSetupTests      :: Bool
 116     }
 117
 118 commonArgParser :: Parser CommonArgs
 119 commonArgParser = CommonArgs
 120     <$> optional (option str
 121         ( help "Path to cabal-install executable to test. If omitted, tests involving cabal-install are skipped!"
 122        <> long "with-cabal"
 123        <> metavar "PATH"
 124         ))
 125     <*> optional (option str
 126         ( help "GHC to ask Cabal to use via --with-ghc flag"
 127        <> short 'w'
 128        <> long "with-ghc"
 129        <> metavar "PATH"
 130         ))
 131     <*> optional (option str
 132         ( help "Path to hackage-repo-tool to use for repository manipulation"
 133        <> long "with-hackage-repo-tool"
 134        <> metavar "PATH"
 135         ))
 136     <*> optional (option str
 137         ( help "Path to haddock to use for --with-haddock flag"
 138        <> long "with-haddock"
 139        <> metavar "PATH"
 140         ))
 141     <*> switch
 142         ( long "keep-tmp-files"
 143        <> help "Keep temporary files"
 144         )
 145     <*> switch
 146         ( long "accept"
 147        <> help "Accept output"
 148         )
 149     <*> switch (long "skip-setup-tests" <> help "Skip setup tests")
 150
 151 renderCommonArgs :: CommonArgs -> [String]
 152 renderCommonArgs args =
 153     maybe [] (\x -> ["--with-cabal",             x]) (argCabalInstallPath    args) ++
 154     maybe [] (\x -> ["--with-ghc",               x]) (argGhcPath             args) ++
 155     maybe [] (\x -> ["--with-haddock",           x]) (argHaddockPath         args) ++
 156     maybe [] (\x -> ["--with-hackage-repo-tool", x]) (argHackageRepoToolPath args) ++
 157     (if argAccept args then ["--accept"] else []) ++
 158     (if argKeepTmpFiles args then ["--keep-tmp-files"] else []) ++
 159     (if argSkipSetupTests args then ["--skip-setup-tests"] else [])
 160
 161 data TestArgs = TestArgs {
 162         testArgDistDir    :: FilePath,
 163         testArgPackageDb  :: [FilePath],
 164         testArgScriptPath :: FilePath,
 165         testCommonArgs    :: CommonArgs
 166     }
 167
 168 testArgParser :: Parser TestArgs
 169 testArgParser = TestArgs
 170     <$> option str
 171         ( help "Build directory of cabal-testsuite"
 172        <> long "builddir"
 173        <> metavar "DIR")
 174     <*> many (option str
 175         ( help "Package DB which contains Cabal and Cabal-syntax"
 176        <> long "extra-package-db"
 177        <> metavar "DIR"))
 178     <*> argument str ( metavar "FILE")
 179     <*> commonArgParser
 180
 181 skipIO :: String -> IO ()
 182 skipIO reason = do
 183     putStrLn ("SKIP " ++ reason)
 184     E.throwIO (TestCodeSkip reason)
 185
 186 skip :: String -> TestM ()
 187 skip = liftIO . skipIO
 188
 189 skipIfIO :: String -> Bool -> IO ()
 190 skipIfIO reason b = when b (skipIO reason)
 191
 192 skipIf :: String -> Bool -> TestM ()
 193 skipIf reason b = when b (skip reason)
 194
 195 skipUnlessIO :: String -> Bool -> IO ()
 196 skipUnlessIO reason b = unless b (skipIO reason)
 197
 198 skipUnless :: String -> Bool -> TestM ()
 199 skipUnless reason b = unless b (skip reason)
 200
 201 expectedBroken :: Int -> TestM a
 202 expectedBroken t = liftIO $ do
 203     putStrLn "EXPECTED FAIL"
 204     E.throwIO (TestCodeKnownFail t)
 205
 206 unexpectedSuccess :: TestM a
 207 unexpectedSuccess = liftIO $ do
 208     putStrLn "UNEXPECTED OK"
 209     E.throwIO TestCodeUnexpectedOk
 210
 211
 212 trySkip :: IO a -> IO (Either String a)
 213 trySkip m = fmap Right m `E.catch` \e -> case e of
 214     TestCodeSkip msg -> return (Left msg)
 215     _                -> E.throwIO e
 216
 217 setupAndCabalTest :: TestM () -> IO ()
 218 setupAndCabalTest m = do
 219     r1 <- trySkip (setupTest m)
 220     r2 <- trySkip (cabalTest' "cabal" m)
 221     case (r1, r2) of
 222         (Left msg1, Left msg2) -> E.throwIO (TestCodeSkip (msg1 ++ "; " ++ msg2))
 223         _                      -> return ()
 224
 225 setupTest :: TestM () -> IO ()
 226 setupTest m = runTestM "" $ do
 227     env <- getTestEnv
 228     skipIf "setup test" (testSkipSetupTests env)
 229     m
 230
 231 cabalTest :: TestM () -> IO ()
 232 cabalTest = cabalTest' ""
 233
 234 cabalTest' :: String -> TestM () -> IO ()
 235 cabalTest' mode m = runTestM mode $ do
 236     skipUnless "no cabal-install" =<< isAvailableProgram cabalProgram
 237     withReaderT (\nenv -> nenv { testCabalInstallAsSetup = True }) m
 238
 239 type TestM = ReaderT TestEnv IO
 240
 241 gitProgram :: Program
 242 gitProgram = simpleProgram "git"
 243
 244 hackageRepoToolProgram :: Program
 245 hackageRepoToolProgram = simpleProgram "hackage-repo-tool"
 246
 247 cabalProgram :: Program
 248 cabalProgram = (simpleProgram "cabal") {
 249         -- Do NOT search for executable named cabal, it's probably
 250         -- not the one you were intending to test
 251         programFindLocation = \_ _ -> return Nothing
 252     }
 253
 254 diffProgram :: Program
 255 diffProgram = simpleProgram "diff"
 256
 257 python3Program :: Program
 258 python3Program = simpleProgram "python3"
 259
 260 -- | Run a test in the test monad according to program's arguments.
 261 runTestM :: String -> TestM a -> IO a
 262 runTestM mode m =
 263     liftIO $ (canonicalizePath =<< getTemporaryDirectory) >>= \systemTmpDir ->
 264        -- canonicalizePath: cabal-install is inconsistent w.r.t. looking through
 265        -- symlinks. We canonicalize here to avoid such issues when the temporary
 266        -- directory contains symlinks. See #9763.
 267     execParser (info testArgParser Data.Monoid.mempty) >>= \args ->
 268     withTempDirectoryEx verbosity (defaultTempFileOptions { optKeepTempFiles = argKeepTmpFiles (testCommonArgs args) })
 269                                systemTmpDir
 270                                "cabal-testsuite" $ \tmp_dir -> do
 271     let dist_dir = testArgDistDir args
 272         (script_dir0, script_filename) = splitFileName (testArgScriptPath args)
 273
 274         stripped = stripExtension ".test.hs" script_filename
 275                <|> stripExtension ".multitest.hs" script_filename
 276         script_base = fromMaybe (dropExtensions script_filename) stripped
 277
 278     -- Canonicalize this so that it is stable across working directory changes
 279     script_dir <- canonicalizePath script_dir0
 280     senv <- mkScriptEnv verbosity
 281     -- Add test suite specific programs
 282     let program_db0 =
 283             addKnownPrograms
 284                 ([gitProgram, hackageRepoToolProgram, cabalProgram, diffProgram, python3Program] ++ builtinPrograms)
 285                 (runnerProgramDb senv)
 286     -- Reconfigure according to user flags
 287     let cargs = testCommonArgs args
 288
 289     -- Reconfigure GHC
 290     (comp, platform, program_db2) <- case argGhcPath cargs of
 291         Nothing -> return (runnerCompiler senv, runnerPlatform senv, program_db0)
 292         Just ghc_path -> do
 293             -- All the things that get updated paths from
 294             -- configCompilerEx.  The point is to make sure
 295             -- we reconfigure these when we need them.
 296             let program_db1 = unconfigureProgram "ghc"
 297                             . unconfigureProgram "ghc-pkg"
 298                             . unconfigureProgram "hsc2hs"
 299                             . unconfigureProgram "haddock"
 300                             . unconfigureProgram "hpc"
 301                             . unconfigureProgram "runghc"
 302                             . unconfigureProgram "gcc"
 303                             . unconfigureProgram "ld"
 304                             . unconfigureProgram "ar"
 305                             . unconfigureProgram "strip"
 306                             $ program_db0
 307             -- TODO: this actually leaves a pile of things unconfigured.
 308             -- Optimal strategy for us is to lazily configure them, so
 309             -- we don't pay for things we don't need.  A bit difficult
 310             -- to do in the current design.
 311             configCompilerEx
 312                 (Just (compilerFlavor (runnerCompiler senv)))
 313                 (Just ghc_path)
 314                 Nothing
 315                 program_db1
 316                 verbosity
 317
 318     (configuredGhcProg, _) <- requireProgram verbosity ghcProgram program_db2
 319
 320     program_db3 <-
 321         reconfigurePrograms verbosity
 322             ([("cabal", p)   | p <- maybeToList (argCabalInstallPath cargs)] ++
 323              [("hackage-repo-tool", p)
 324                              | p <- maybeToList (argHackageRepoToolPath cargs)] ++
 325              [("haddock", p) | p <- maybeToList (argHaddockPath cargs)])
 326             [] -- --prog-options not supported ATM
 327             program_db2
 328     -- configCompilerEx only marks some programs as known, so to pick
 329     -- them up we must configure them
 330     program_db <- configureAllKnownPrograms verbosity program_db3
 331
 332     let db_stack = [GlobalPackageDB]
 333         env = TestEnv {
 334                     testSourceDir = script_dir,
 335                     testTmpDir = tmp_dir,
 336                     testSubName = script_base,
 337                     testMode = mode,
 338                     testProgramDb = program_db,
 339                     testPlatform = platform,
 340                     testCompiler = comp,
 341                     testCompilerPath = programPath configuredGhcProg,
 342                     testPackageDBStack = db_stack,
 343                     testVerbosity = verbosity,
 344                     testMtimeChangeDelay = Nothing,
 345                     testScriptEnv = senv,
 346                     testSetupPath = dist_dir </> "build" </> "setup" </> "setup",
 347                     testPackageDbPath = case testArgPackageDb args of [] -> Nothing; xs -> Just xs,
 348                     testSkipSetupTests =  argSkipSetupTests (testCommonArgs args),
 349                     testHaveCabalShared = runnerWithSharedLib senv,
 350                     testEnvironment =
 351                         -- Try to avoid Unicode output
 352                         [ ("LC_ALL", Just "C")
 353                         -- Hermetic builds (knot-tied)
 354                         , ("HOME", Just (testHomeDir env))
 355                         -- Set CABAL_DIR in addition to HOME, since HOME has no
 356                         -- effect on Windows.
 357                         , ("CABAL_DIR", Just (testCabalDir env))
 358                         , ("CABAL_CONFIG", Just (testUserCabalConfigFile env))
 359                         ],
 360                     testShouldFail = False,
 361                     testRelativeCurrentDir = ".",
 362                     testHavePackageDb = False,
 363                     testHaveRepo = False,
 364                     testCabalInstallAsSetup = False,
 365                     testCabalProjectFile = Nothing,
 366                     testPlan = Nothing,
 367                     testRecordDefaultMode = DoNotRecord,
 368                     testRecordUserMode = Nothing,
 369                     testMaybeStoreDir = Nothing
 370                 }
 371     let go = do cleanup
 372                 r <- withSourceCopy m
 373                 check_expect (argAccept (testCommonArgs args))
 374                 return r
 375     runReaderT go env
 376   where
 377     verbosity = normal -- TODO: configurable
 378
 379     cleanup = do
 380         env <- getTestEnv
 381         onlyIfExists . removeDirectoryRecursiveHack verbosity $ testWorkDir env
 382         -- NB: it's important to initialize this ourselves, as
 383         -- the default configuration hardcodes Hackage, which we do
 384         -- NOT want to assume for these tests (no test should
 385         -- hit Hackage.)
 386         liftIO $ createDirectoryIfMissing True (testCabalDir env)
 387         ghc_path <- programPathM ghcProgram
 388         liftIO $ writeFile (testUserCabalConfigFile env)
 389                $ unlines [ "with-compiler: " ++ ghc_path ]
 390
 391     check_expect accept = do
 392         env <- getTestEnv
 393         actual_raw <- liftIO $ readFileOrEmpty (testActualFile env)
 394         expect <- liftIO $ readFileOrEmpty (testExpectFile env)
 395         norm_env <- mkNormalizerEnv
 396         let actual = normalizeOutput norm_env actual_raw
 397         when (words actual /= words expect) $ do
 398             -- First try whitespace insensitive diff
 399             let actual_fp = testNormalizedActualFile env
 400                 expect_fp = testNormalizedExpectFile env
 401             liftIO $ writeFile actual_fp actual
 402             liftIO $ writeFile expect_fp expect
 403             liftIO $ putStrLn "Actual output differs from expected:"
 404             b <- diff ["-uw"] expect_fp actual_fp
 405             unless b . void $ diff ["-u"] expect_fp actual_fp
 406             if accept
 407                 then do liftIO $ putStrLn "Accepting new output."
 408                         liftIO $ writeFileNoCR (testExpectFile env) actual
 409                 else liftIO $ exitWith (ExitFailure 1)
 410
 411 readFileOrEmpty :: FilePath -> IO String
 412 readFileOrEmpty f = readFile f `E.catch` \e ->
 413                                     if isDoesNotExistError e
 414                                         then return ""
 415                                         else E.throwIO e
 416
 417 -- | Run an IO action, and suppress a "does not exist" error.
 418 onlyIfExists :: MonadIO m => IO () -> m ()
 419 onlyIfExists m =
 420     liftIO $ E.catch m $ \(e :: IOError) ->
 421         unless (isDoesNotExistError e) $ E.throwIO e
 422
 423 -- | Make a hermetic copy of the test directory.
 424 --
 425 -- This requires the test repository to be a Git checkout, because
 426 -- we use the Git metadata to figure out what files to copy into the
 427 -- hermetic copy.
 428 withSourceCopy :: TestM a -> TestM a
 429 withSourceCopy m = do
 430     env <- getTestEnv
 431     initWorkDir
 432     let curdir  = testSourceDir env
 433         dest = testSourceCopyDir env
 434     fs <- getSourceFiles
 435     when (null fs)
 436       (error (unlines [ "withSourceCopy: No files to copy from " ++ curdir
 437                       , "You need to \"git add\" any files before they are copied by the testsuite."]))
 438     forM_ fs $ \f -> do
 439         unless (isTestFile f) $ liftIO $ do
 440             putStrLn ("Copying " ++ (curdir </> f) ++ " to " ++ (dest </> f))
 441             createDirectoryIfMissing True (takeDirectory (dest </> f))
 442             d <- liftIO $ doesDirectoryExist (curdir </> f)
 443             if d
 444               then
 445                 copyDirectoryRecursive normal (curdir </> f) (dest </> f)
 446               else
 447                 copyFile (curdir </> f) (dest </> f)
 448     m
 449
 450
 451 -- NB: Keep this synchronized with partitionTests
 452 isTestFile :: FilePath -> Bool
 453 isTestFile f =
 454     case takeExtensions f of
 455         ".test.hs"      -> True
 456         ".multitest.hs" -> True
 457         _               -> False
 458
 459
 460 initWorkDir :: TestM ()
 461 initWorkDir = do
 462     env <- getTestEnv
 463     liftIO $ createDirectoryIfMissing True (testWorkDir env)
 464
 465
 466
 467 getSourceFiles :: TestM [FilePath]
 468 getSourceFiles = do
 469     env <- getTestEnv
 470     configured_prog <- requireProgramM gitProgram
 471     r <- liftIO $ run (testVerbosity env)
 472                  (Just $ testSourceDir env)
 473                  (testEnvironment env)
 474                  (programPath configured_prog)
 475                  ["ls-files", "--cached", "--modified"]
 476                  Nothing
 477     recordLog r
 478     _ <- requireSuccess r
 479     return (lines $ resultOutput r)
 480
 481 recordLog :: Result -> TestM ()
 482 recordLog res = do
 483     env <- getTestEnv
 484     let mode = testRecordMode env
 485     initWorkDir
 486     liftIO $ C.appendFile (testWorkDir env </> "test.log")
 487                          (C.pack $ "+ " ++ resultCommand res ++ "\n"
 488                             ++ resultOutput res ++ "\n\n")
 489     liftIO . C.appendFile (testActualFile env) . C.pack $
 490         case mode of
 491             RecordAll    -> unlines (lines (resultOutput res))
 492             RecordMarked -> getMarkedOutput (resultOutput res)
 493             DoNotRecord  -> ""
 494
 495 ------------------------------------------------------------------------
 496 -- * Subprocess run results
 497
 498 requireSuccess :: Result -> TestM Result
 499 requireSuccess r@Result { resultCommand = cmd
 500                         , resultExitCode = exitCode
 501                         , resultOutput = output } = withFrozenCallStack $ do
 502     env <- getTestEnv
 503     when (exitCode /= ExitSuccess && not (testShouldFail env)) $
 504         assertFailure $ "Command " ++ cmd ++ " failed.\n" ++
 505         "Output:\n" ++ output ++ "\n"
 506     when (exitCode == ExitSuccess && testShouldFail env) $
 507         assertFailure $ "Command " ++ cmd ++ " succeeded.\n" ++
 508         "Output:\n" ++ output ++ "\n"
 509     return r
 510
 511 assertFailure :: String -> m ()
 512 assertFailure msg = withFrozenCallStack $ error msg
 513
 514
 515
 516 -- | Runs 'diff' with some arguments on two files, outputting the
 517 -- diff to stderr, and returning true if the two files differ
 518 diff :: [String] -> FilePath -> FilePath -> TestM Bool
 519 diff args path1 path2 = do
 520     diff_path <- programPathM diffProgram
 521     (_,_,_,h) <- liftIO $
 522         createProcess (proc diff_path (args ++ [path1, path2])) {
 523                 std_out = UseHandle stderr
 524             }
 525     r <- liftIO $ waitForProcess h
 526     return (r /= ExitSuccess)
 527
 528 -- | Write a file with no CRs, always.
 529 writeFileNoCR :: FilePath -> String -> IO ()
 530 writeFileNoCR f s =
 531     withFile f WriteMode $ \h -> do
 532         hSetNewlineMode h noNewlineTranslation
 533         hPutStr h s
 534
 535 mkNormalizerEnv :: TestM NormalizerEnv
 536 mkNormalizerEnv = do
 537     env <- getTestEnv
 538     ghc_pkg_program <- requireProgramM ghcPkgProgram
 539     -- Arguably we should use Cabal's APIs but I am too lazy
 540     -- to remember what it is
 541     list_out <- liftIO $ readProcess (programPath ghc_pkg_program)
 542                       ["list", "--global", "--simple-output"] ""
 543     tmpDir <- liftIO $ getTemporaryDirectory
 544
 545     canonicalizedTestTmpDir <- liftIO $ canonicalizePath (testTmpDir env)
 546
 547     -- 'cabal' is configured in the package-db, but doesn't specify how to find the program version
 548     -- Thus we find the program location, if it exists, and query for the program version for
 549     -- output normalisation.
 550     cabalVersionM <- do
 551         cabalProgM <- needProgramM "cabal"
 552         case cabalProgM of
 553             Nothing -> pure Nothing
 554             Just cabalProg -> do
 555                 liftIO (findProgramVersion "--numeric-version" id (testVerbosity env) (programPath cabalProg))
 556
 557     return NormalizerEnv {
 558         normalizerRoot
 559             = (if buildOS == Windows
 560               then joinDrive "\\" . dropDrive
 561               else id)
 562                 $ addTrailingPathSeparator (testSourceDir env),
 563         normalizerTmpDir
 564             = (if buildOS == Windows
 565               then joinDrive "\\" . dropDrive
 566               else id)
 567                 $ addTrailingPathSeparator (testTmpDir env),
 568         normalizerCanonicalTmpDir
 569             = (if buildOS == Windows
 570               then joinDrive "\\" . dropDrive
 571               else id)
 572                 $ addTrailingPathSeparator canonicalizedTestTmpDir,
 573         normalizerGblTmpDir
 574             = (if buildOS == Windows
 575               then joinDrive "\\" . dropDrive
 576               else id)
 577                 $ addTrailingPathSeparator tmpDir,
 578         normalizerGhcVersion
 579             = compilerVersion (testCompiler env),
 580         normalizerGhcPath
 581             = testCompilerPath env,
 582         normalizerKnownPackages
 583             = mapMaybe simpleParse (words list_out),
 584         normalizerPlatform
 585             = testPlatform env,
 586         normalizerCabalVersion
 587             = cabalVersionLibrary,
 588         normalizerCabalInstallVersion
 589             = cabalVersionM
 590     }
 591
 592 cabalVersionLibrary :: Version
 593 cabalVersionLibrary = U.cabalVersion
 594
 595 requireProgramM :: Program -> TestM ConfiguredProgram
 596 requireProgramM program = do
 597     env <- getTestEnv
 598     (configured_program, _) <- liftIO $
 599         requireProgram (testVerbosity env) program (testProgramDb env)
 600     return configured_program
 601
 602 needProgramM :: String -> TestM (Maybe ConfiguredProgram)
 603 needProgramM program = do
 604     env <- getTestEnv
 605     return $ lookupProgramByName program (testProgramDb env)
 606
 607 programPathM :: Program -> TestM FilePath
 608 programPathM program = do
 609     fmap programPath (requireProgramM program)
 610
 611 isAvailableProgram :: Program -> TestM Bool
 612 isAvailableProgram program = do
 613     env <- getTestEnv
 614     case lookupProgram program (testProgramDb env) of
 615         Just _ -> return True
 616         Nothing -> do
 617             -- It might not have been configured. Try to configure.
 618             progdb <- liftIO $ configureProgram (testVerbosity env) program (testProgramDb env)
 619             case lookupProgram program progdb of
 620                 Just _  -> return True
 621                 Nothing -> return False
 622
 623
 624 getMarkedOutput :: String -> String -- trailing newline
 625 getMarkedOutput out = unlines (go (lines out) False)
 626   where
 627     go [] _ = []
 628     go (x:xs) True
 629         | "-----END CABAL OUTPUT-----"   `isPrefixOf` x
 630                     =     go xs False
 631         | otherwise = x : go xs True
 632     go (x:xs) False
 633         -- NB: Windows has extra goo at the end
 634         | "-----BEGIN CABAL OUTPUT-----" `isPrefixOf` x
 635                     = go xs True
 636         | otherwise = go xs False
 637
 638
 639 data TestEnv = TestEnv
 640     -- UNCHANGING:
 641
 642     {
 643     -- | Path to the test directory, as specified by path to test
 644     -- script.
 645       testSourceDir     :: FilePath
 646     -- | Somewhere to stow temporary files needed by the test.
 647     , testTmpDir        :: FilePath
 648
 649     -- | Test sub-name, used to qualify dist/database directory to avoid
 650     -- conflicts.
 651     , testSubName       :: String
 652     -- | Test mode, further qualifies multiple invocations of the
 653     -- same test source code.
 654     , testMode          :: String
 655     -- | Program database to use when we want ghc, ghc-pkg, etc.
 656     , testProgramDb     :: ProgramDb
 657     -- | Compiler we are running tests for
 658     , testCompiler      :: Compiler
 659     , testCompilerPath  :: FilePath
 660     -- | Platform we are running tests on
 661     , testPlatform      :: Platform
 662     -- | Package database stack (actually this changes lol)
 663     , testPackageDBStack :: PackageDBStack
 664     -- | How verbose to be
 665     , testVerbosity     :: Verbosity
 666     -- | How long we should 'threadDelay' to make sure the file timestamp is
 667     -- updated correctly for recompilation tests.  Nothing if we haven't
 668     -- calibrated yet.
 669     , testMtimeChangeDelay :: Maybe Int
 670     -- | Script environment for runghc
 671     , testScriptEnv :: ScriptEnv
 672     -- | Setup script path
 673     , testSetupPath :: FilePath
 674     -- | Setup package-db path which contains Cabal and Cabal-syntax for cabal-install to
 675     -- use when compiling custom setups, plus the store with possible dependencies of those setup packages.
 676     , testPackageDbPath :: Maybe [FilePath]
 677     -- | Skip Setup tests?
 678     , testSkipSetupTests :: Bool
 679     -- | Do we have shared libraries for the Cabal-under-tests?
 680     -- This is used for example to determine whether we can build
 681     -- detailed-0.9 tests dynamically, since they link against Cabal-under-test.
 682     , testHaveCabalShared :: Bool
 683
 684     -- CHANGING:
 685
 686     -- | Environment override
 687     , testEnvironment   :: [(String, Maybe String)]
 688     -- | When true, we invert the meaning of command execution failure
 689     , testShouldFail    :: Bool
 690     -- | The current working directory, relative to 'testSourceDir'
 691     , testRelativeCurrentDir :: FilePath
 692     -- | Says if we've initialized the per-test package DB
 693     , testHavePackageDb  :: Bool
 694     -- | Says if we've setup a repository
 695     , testHaveRepo :: Bool
 696     -- | Says if we're testing cabal-install as setup
 697     , testCabalInstallAsSetup :: Bool
 698     -- | Says what cabal.project file to use (probed)
 699     , testCabalProjectFile :: Maybe FilePath
 700     -- | Cached record of the plan metadata from a new-build
 701     -- invocation; controlled by 'withPlan'.
 702     , testPlan :: Maybe Plan
 703     -- | If user mode is not set, this is the record mode we default to.
 704     , testRecordDefaultMode :: RecordMode
 705     -- | User explicitly set record mode.  Not implemented ATM.
 706     , testRecordUserMode :: Maybe RecordMode
 707     -- | Path to the storedir used by the test, if not the default
 708     , testMaybeStoreDir      :: Maybe FilePath
 709     }
 710     deriving Show
 711
 712 testRecordMode :: TestEnv -> RecordMode
 713 testRecordMode env = fromMaybe (testRecordDefaultMode env) (testRecordUserMode env)
 714
 715 data RecordMode = DoNotRecord | RecordMarked | RecordAll
 716     deriving (Show, Eq, Ord)
 717
 718 getTestEnv :: TestM TestEnv
 719 getTestEnv = ask
 720
 721 ------------------------------------------------------------------------
 722 -- * Directories
 723
 724 -- | The absolute path to the root of the package directory; it's
 725 -- where the Cabal file lives.  This is what you want the CWD of cabal
 726 -- calls to be.
 727 testCurrentDir :: TestEnv -> FilePath
 728 testCurrentDir env = testSourceCopyDir env </> testRelativeCurrentDir env
 729
 730 testName :: TestEnv -> String
 731 testName env = testSubName env <.> testMode env
 732
 733 -- | The absolute path to the directory containing all the
 734 -- files for ALL tests associated with a test (respecting
 735 -- subtests.)  To clean, you ONLY need to delete this directory.
 736 testWorkDir :: TestEnv -> FilePath
 737 testWorkDir env = testTmpDir env </> (testName env <.> "dist")
 738
 739 -- | The absolute prefix where installs go.
 740 testPrefixDir :: TestEnv -> FilePath
 741 testPrefixDir env = testWorkDir env </> "usr"
 742
 743 -- | The absolute path where library installs go.
 744 testLibInstallDir :: TestEnv -> FilePath
 745 testLibInstallDir env = libDir </> compilerDir
 746   where
 747     platform@(Platform _ os) = testPlatform env
 748     libDir = case os of
 749       Windows -> testPrefixDir env
 750       _ -> testPrefixDir env </> "lib"
 751     compilerDir = prettyShow platform ++ "-" ++ showCompilerIdWithAbi (testCompiler env)
 752
 753 -- | The absolute path to the build directory that should be used
 754 -- for the current package in a test.
 755 testDistDir :: TestEnv -> FilePath
 756 testDistDir env = testWorkDir env </> "work" </> testRelativeCurrentDir env </> "dist"
 757
 758 -- | The absolute path to the shared package database that should
 759 -- be used by all packages in this test.
 760 testPackageDbDir :: TestEnv -> FilePath
 761 testPackageDbDir env = testWorkDir env </> "packagedb"
 762
 763 -- | The absolute prefix where our simulated HOME directory is.
 764 testHomeDir :: TestEnv -> FilePath
 765 testHomeDir env = testWorkDir env </> "home"
 766
 767 -- | The absolute prefix of our local secure repository, which we
 768 -- use to simulate "external" packages
 769 testRepoDir :: TestEnv -> FilePath
 770 testRepoDir env = testWorkDir env </> "repo"
 771
 772 -- | The absolute prefix of keys for the test.
 773 testKeysDir :: TestEnv -> FilePath
 774 testKeysDir env = testWorkDir env </> "keys"
 775
 776 -- | If 'withSourceCopy' is used, where the source files go.
 777 testSourceCopyDir :: TestEnv -> FilePath
 778 testSourceCopyDir env = testTmpDir env
 779
 780 -- | The user cabal directory
 781 testCabalDir :: TestEnv -> FilePath
 782 testCabalDir env = testHomeDir env </> ".cabal"
 783
 784 testStoreDir :: TestEnv -> FilePath
 785 testStoreDir env = case testMaybeStoreDir env of
 786                       Just dir -> dir
 787                       Nothing -> testCabalDir env </> "store"
 788
 789 -- | The user cabal config file
 790 testUserCabalConfigFile :: TestEnv -> FilePath
 791 testUserCabalConfigFile env = testCabalDir env </> "config"
 792
 793 -- | The file where the expected output of the test lives
 794 testExpectFile :: TestEnv -> FilePath
 795 testExpectFile env = testSourceDir env </> testName env <.> "out"
 796
 797 -- | Where we store the actual output
 798 testActualFile :: TestEnv -> FilePath
 799 testActualFile env = testWorkDir env </> testName env <.> "comp.out"
 800
 801 -- | Where we will write the normalized actual file (for diffing)
 802 testNormalizedActualFile :: TestEnv -> FilePath
 803 testNormalizedActualFile env = testActualFile env <.> "normalized"
 804
 805 -- | Where we will write the normalized expected file (for diffing)
 806 testNormalizedExpectFile :: TestEnv -> FilePath
 807 testNormalizedExpectFile env = testWorkDir env </> testName env <.> "out.normalized"