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

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