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