cabal-testsuite/main/cabal-tests.hs

   1 {-# LANGUAGE CPP                      #-}
   2 {-# LANGUAGE NondecreasingIndentation #-}
   3 {-# LANGUAGE PatternGuards            #-}
   4 {-# LANGUAGE ScopedTypeVariables      #-}
   5 {-# LANGUAGE TypeApplications         #-}
   6
   7 import Test.Cabal.Workdir
   8 import Test.Cabal.Script
   9 import Test.Cabal.Server
  10 import Test.Cabal.Monad
  11 import Test.Cabal.TestCode
  12
  13 import Distribution.Verbosity        (normal, verbose, Verbosity)
  14 import Distribution.Simple.Utils     (getDirectoryContentsRecursive)
  15 import Distribution.Simple.Program
  16 import Distribution.Utils.Path       (getSymbolicPath)
  17
  18 import Options.Applicative
  19 import Control.Concurrent.MVar
  20 import Control.Concurrent
  21 import Control.Concurrent.Async
  22 import Control.Exception
  23 import Control.Monad
  24 import GHC.Conc (numCapabilities)
  25 import Data.List
  26 import Text.Printf
  27 import qualified System.Clock as Clock
  28 import System.IO
  29 import System.FilePath
  30 import System.Exit
  31 import System.Process (readProcessWithExitCode, showCommandForUser)
  32 import System.Directory
  33 import Distribution.Pretty
  34 import Data.Maybe
  35
  36
  37 {- Note [Testsuite package environments]
  38
  39 There are three different package environments which are used when running the
  40 testsuite.
  41
  42 1. Environment used to compile `cabal-tests` executable
  43 2. Environment used to run test scripts "setup.test.hs"
  44 3. Environment made available to tests themselves via `./Setup configure`
  45
  46 These are all distinct from each other and should be specified separately.
  47
  48 Where are these environments specified:
  49
  50 1. The build-depends on `cabal-tests` executable in `cabal-testsuite.cabal`
  51 2. The build-depends of `test-runtime-deps` executable in `cabal-testsuite.cabal`
  52    These dependencies are injected in a special module (`Test.Cabal.ScriptEnv0`) which
  53    then is consulted in `Test.Cabal.Monad` in order to pass the right environmnet.
  54    This is the mechanism by which the `./Setup` tests have access to the in-tree
  55    `Cabal`, `Cabal-syntax` and `Cabal-hooks` libraries.
  56 3. No specification, only the `GlobalPackageDb` is available (see
  57    `testPackageDBStack`) unless the test itself augments the environment with
  58    `withPackageDb`.
  59
  60 At the moment, `cabal-install` tests always use the bootstrap cabal, which is a
  61 bit confusing but `cabal-install` is not flexible enough to be given additional
  62 package databases (yet).
  63
  64 -}
  65
  66 -- | Record for arguments that can be passed to @cabal-tests@ executable.
  67 data MainArgs = MainArgs {
  68         mainArgThreads :: Int,
  69         mainArgTestPaths :: [String],
  70         mainArgHideSuccesses :: Bool,
  71         mainArgVerbose :: Bool,
  72         mainArgQuiet   :: Bool,
  73         mainArgDistDir :: Maybe FilePath,
  74         mainArgCabalSpec :: Maybe CabalLibSpec,
  75         mainCommonArgs :: CommonArgs
  76     }
  77
  78 data CabalLibSpec = BootCabalLib | InTreeCabalLib FilePath FilePath | SpecificCabalLib String FilePath
  79
  80 cabalLibSpecParser :: Parser CabalLibSpec
  81 cabalLibSpecParser = bootParser <|> intreeParser <|> specificParser
  82   where
  83     bootParser = flag' BootCabalLib (long "boot-cabal-lib")
  84     intreeParser = InTreeCabalLib <$> strOption (long "intree-cabal-lib" <> metavar "ROOT")
  85                                   <*> option str ( help "Test TMP" <> long "test-tmp" )
  86     specificParser = SpecificCabalLib <$> strOption (long "specific-cabal-lib" <> metavar "VERSION")
  87                                       <*> option str ( help "Test TMP" <> long "test-tmp" )
  88
  89
  90 -- | optparse-applicative parser for 'MainArgs'
  91 mainArgParser :: Parser MainArgs
  92 mainArgParser = MainArgs
  93     <$> option auto
  94         ( help "Number of threads to run"
  95        <> short 'j'
  96        <> showDefault
  97        <> value numCapabilities
  98        <> metavar "INT")
  99     <*> many (argument str (metavar "FILE"))
 100     <*> switch
 101         ( long "hide-successes"
 102        <> help "Do not print test cases as they are being run"
 103         )
 104     <*> switch
 105         ( long "verbose"
 106        <> short 'v'
 107        <> help "Be verbose"
 108         )
 109     <*> switch
 110         ( long "quiet"
 111        <> short 'q'
 112        <> help "Only output stderr on failure"
 113         )
 114     <*> optional (option str
 115         ( help "Dist directory we were built with"
 116        <> long "builddir"
 117        <> metavar "DIR"))
 118     <*> optional cabalLibSpecParser
 119     <*> commonArgParser
 120
 121 -- Unpack and build a specific released version of Cabal and Cabal-syntax libraries
 122 buildCabalLibsProject :: String -> Verbosity -> Maybe FilePath -> FilePath -> IO [FilePath]
 123 buildCabalLibsProject projString verb mbGhc dir = do
 124   let prog_db = userSpecifyPaths [("ghc", path) | Just path <- [mbGhc] ]  defaultProgramDb
 125   (cabal, _) <- requireProgram verb (simpleProgram "cabal") prog_db
 126   (ghc, _) <- requireProgram verb ghcProgram prog_db
 127
 128   let storeRoot = dir </> "store"
 129   let pv = fromMaybe (error "no ghc version") (programVersion ghc)
 130   let final_package_db = dir </> "dist-newstyle" </> "packagedb" </> "ghc-" ++ prettyShow pv
 131   createDirectoryIfMissing True dir
 132   writeFile (dir </> "cabal.project-test") projString
 133
 134   runProgramInvocation verb
 135     ((programInvocation cabal
 136       ["--store-dir", storeRoot
 137       , "--project-file=" ++ dir </> "cabal.project-test"
 138       , "build"
 139       , "-w", programPath ghc
 140       , "Cabal", "Cabal-syntax", "Cabal-hooks"
 141       ] ) { progInvokeCwd = Just dir })
 142
 143   -- Determine the path to the packagedb in the store for this ghc version
 144   storesByGhc <- getDirectoryContents storeRoot
 145   case filter (prettyShow pv `isInfixOf`) storesByGhc of
 146     [] -> return [final_package_db]
 147     storeForGhc:_ -> do
 148       let storePackageDB = (storeRoot </> storeForGhc </> "package.db")
 149       return [storePackageDB, final_package_db]
 150
 151
 152
 153 buildCabalLibsSpecific :: String -> Verbosity -> Maybe FilePath -> FilePath -> IO [FilePath]
 154 buildCabalLibsSpecific ver verb mbGhc builddir_rel = do
 155   let prog_db = userSpecifyPaths [("ghc", path) | Just path <- [mbGhc] ]  defaultProgramDb
 156   (cabal, _) <- requireProgram verb (simpleProgram "cabal") prog_db
 157   dir <- canonicalizePath (builddir_rel </> "specific" </> ver)
 158   cgot <- doesDirectoryExist (dir </> "Cabal-" ++ ver)
 159   unless cgot $
 160     runProgramInvocation verb ((programInvocation cabal ["get", "Cabal-" ++ ver]) { progInvokeCwd = Just dir })
 161   csgot <- doesDirectoryExist (dir </> "Cabal-syntax-" ++ ver)
 162   unless csgot $
 163     runProgramInvocation verb ((programInvocation cabal ["get", "Cabal-syntax-" ++ ver]) { progInvokeCwd = Just dir })
 164   let hooksVerFromVer _ = "0.1"
 165       hooksVer = hooksVerFromVer ver
 166   chgot <- doesDirectoryExist (dir </> "Cabal-hooks-" ++ hooksVer)
 167   unless chgot $
 168     runProgramInvocation verb ((programInvocation cabal ["get", "Cabal-hooks-" ++ hooksVer]) { progInvokeCwd = Just dir })
 169   buildCabalLibsProject ("packages: Cabal-" ++ ver ++ " Cabal-syntax-" ++ ver ++ " Cabal-hooks-" ++ hooksVer) verb mbGhc dir
 170
 171
 172 buildCabalLibsIntree :: String -> Verbosity -> Maybe FilePath -> FilePath -> IO [FilePath]
 173 buildCabalLibsIntree root verb mbGhc builddir_rel = do
 174   dir <- canonicalizePath (builddir_rel </> "intree")
 175   buildCabalLibsProject ("packages: " ++ root </> "Cabal" ++ " " ++ root </> "Cabal-syntax" ++ " " ++ root </> "Cabal-hooks") verb mbGhc dir
 176
 177 main :: IO ()
 178 main = do
 179     -- By default, stderr is not buffered.  This isn't really necessary
 180     -- for us, and it causes problems on Windows, see:
 181     -- https://github.com/appveyor/ci/issues/1364
 182     hSetBuffering stderr LineBuffering
 183
 184     -- Parse arguments.  N.B. 'helper' adds the option `--help`.
 185     args <- execParser $ info (mainArgParser <**> helper) mempty
 186     let verbosity = if mainArgVerbose args then verbose else normal
 187
 188     pkg_dbs <-
 189       -- Not path to cabal-install so we're not going to run cabal-install tests so we
 190       -- can skip setting up a Cabal library to use with cabal-install.
 191       case argCabalInstallPath (mainCommonArgs args) of
 192         Nothing -> do
 193           when (isJust $ mainArgCabalSpec args)
 194                (putStrLn "Ignoring Cabal library specification as cabal-install tests are not running")
 195           return []
 196         -- Path to cabal-install is passed, so need to install the requested relevant version of Cabal
 197         -- library.
 198         Just {} ->
 199           case mainArgCabalSpec args of
 200             Nothing -> do
 201               putStrLn "No Cabal library specified, using boot Cabal library with cabal-install tests"
 202               return []
 203             Just BootCabalLib -> return []
 204             Just (InTreeCabalLib root build_dir) ->
 205               buildCabalLibsIntree root verbosity (argGhcPath (mainCommonArgs args)) build_dir
 206             Just (SpecificCabalLib ver build_dir) ->
 207               buildCabalLibsSpecific ver verbosity (argGhcPath (mainCommonArgs args)) build_dir
 208
 209     -- To run our test scripts, we need to be able to run Haskell code
 210     -- linked against the Cabal library under test.  The most efficient
 211     -- way to get this information is by querying the *host* build
 212     -- system about the information.
 213     --
 214     -- Fortunately, because we are using a Custom setup, our Setup
 215     -- script is bootstrapped against the Cabal library we're testing
 216     -- against, so can use our dependency on Cabal to read out the build
 217     -- info *for this package*.
 218     --
 219     -- NB: Currently assumes that per-component build is NOT turned on
 220     -- for Custom.
 221     dist_dir <- case mainArgDistDir args of
 222                   Just dist_dir -> return dist_dir
 223                   Nothing -> getSymbolicPath <$> guessDistDir
 224     when (verbosity >= verbose) $
 225         hPutStrLn stderr $ "Using dist dir: " ++ dist_dir
 226     -- Get ready to go!
 227     senv <- mkScriptEnv verbosity
 228
 229     let runTest :: (Maybe cwd -> [unusedEnv] -> FilePath -> [String] -> IO result)
 230                 -> FilePath
 231                 -> IO result
 232         runTest runner path
 233             = runner Nothing [] path $
 234                 ["--builddir", dist_dir, path] ++ ["--extra-package-db=" ++ pkg_db | pkg_db <- pkg_dbs] ++ renderCommonArgs (mainCommonArgs args)
 235
 236     case mainArgTestPaths args of
 237         [path] -> do
 238             -- Simple runner
 239             (real_path, real_args) <- runTest (runnerCommand senv) path
 240             hPutStrLn stderr $ showCommandForUser real_path real_args
 241             -- If the test was reported flaky, the `runghc` call will exit
 242             -- with exit code 1, and report `TestCodeFlaky` on the stderr output
 243             --
 244             -- This seems to be the only way to catch this case.
 245             --
 246             -- Sadly it means that stdout and stderr are not interleaved
 247             -- directly anymore.
 248             (e, out, err) <- readProcessWithExitCode real_path real_args ""
 249             putStrLn "# STDOUT:"
 250             putStrLn out
 251             putStrLn "# STDERR:"
 252             putStrLn err
 253             if "TestCodeFlaky" `isInfixOf` err
 254               then pure ()
 255               else throwIO e
 256             hPutStrLn stderr "OK"
 257         user_paths -> do
 258             -- Read out tests from filesystem
 259             hPutStrLn stderr $ "threads: " ++ show (mainArgThreads args)
 260
 261             test_scripts <- if null user_paths
 262                                 then findTests
 263                                 else return user_paths
 264             -- NB: getDirectoryContentsRecursive is lazy IO, but it
 265             -- doesn't handle directories disappearing gracefully. Fix
 266             -- this!
 267             (single_tests, multi_tests) <- evaluate (partitionTests test_scripts)
 268             let all_tests = multi_tests ++ single_tests
 269                 margin = maximum (map length all_tests) + 2
 270             hPutStrLn stderr $ "tests to run: " ++ show (length all_tests)
 271
 272             -- TODO: Get parallelization out of multitests by querying
 273             -- them for their modes and then making a separate worker
 274             -- for each.  But for now, just run them earlier to avoid
 275             -- them straggling at the end
 276             work_queue <- newMVar all_tests
 277             unexpected_fails_var  <- newMVar []
 278             unexpected_passes_var <- newMVar []
 279             skipped_var <- newMVar []
 280             flaky_pass_var <- newMVar []
 281             flaky_fail_var <- newMVar []
 282
 283             chan <- newChan
 284             let logAll msg = writeChan chan (ServerLogMsg AllServers msg)
 285                 logEnd = writeChan chan ServerLogEnd
 286             -- NB: don't use withAsync as we do NOT want to cancel this
 287             -- on an exception
 288             async_logger <- async (withFile "cabal-tests.log" WriteMode $ outputThread verbosity chan)
 289
 290             -- Make sure we pump out all the logs before quitting
 291             (\m -> finally m (logEnd >> wait async_logger)) $ do
 292
 293             -- NB: Need to use withAsync so that if the main thread dies
 294             -- (due to ctrl-c) we tear down all of the worker threads.
 295             let go server = do
 296                     let split [] = return ([], Nothing)
 297                         split (y:ys) = return (ys, Just y)
 298                         logMeta msg = writeChan chan
 299                                     $ ServerLogMsg
 300                                         (ServerMeta (serverProcessId server))
 301                                         msg
 302                     mb_work <- modifyMVar work_queue split
 303                     case mb_work of
 304                         Nothing -> return ()
 305                         Just path -> do
 306                             when (verbosity >= verbose) $
 307                                 logMeta $ "Running " ++ path
 308                             start <- getTime
 309                             r <- runTest (runOnServer server) path
 310                             end <- getTime
 311                             let time = end - start
 312                                 code = serverResultTestCode r
 313
 314                             unless (mainArgHideSuccesses args && code == TestCodeOk) $ do
 315                                 logMeta $
 316                                     path ++ replicate (margin - length path) ' ' ++ displayTestCode code ++
 317                                     if time >= 0.01
 318                                         then printf " (%.2fs)" time
 319                                         else ""
 320
 321                             when (code == TestCodeFail) $ do
 322                                 let description
 323                                       | mainArgQuiet args = serverResultStderr r
 324                                       | otherwise =
 325                                        "$ " ++ serverResultCommand r ++ "\n" ++
 326                                        "stdout:\n" ++ serverResultStdout r ++ "\n" ++
 327                                        "stderr:\n" ++ serverResultStderr r ++ "\n"
 328                                 logMeta $
 329                                           description
 330                                        ++ "*** unexpected failure for " ++ path ++ "\n\n"
 331                                 modifyMVar_ unexpected_fails_var $ \paths ->
 332                                     return (path:paths)
 333
 334                             when (isJust $ isTestCodeUnexpectedSuccess code) $
 335                                 modifyMVar_ unexpected_passes_var $ \paths ->
 336                                     return (path:paths)
 337
 338                             when (isTestCodeSkip code) $
 339                                 modifyMVar_ skipped_var $ \paths ->
 340                                     return (path:paths)
 341
 342                             case isTestCodeFlaky code of
 343                               NotFlaky  -> pure ()
 344                               Flaky b _ ->
 345                                 modifyMVar_ (if b then flaky_pass_var else flaky_fail_var) $ \paths ->
 346                                     return (path:paths)
 347
 348                             go server
 349
 350             -- Start as many threads as requested by -j to spawn
 351             -- GHCi servers and start running tests off of the
 352             -- run queue.
 353             replicateConcurrently_ (mainArgThreads args) (withNewServer chan senv go)
 354
 355             unexpected_fails  <- takeMVar unexpected_fails_var
 356             unexpected_passes <- takeMVar unexpected_passes_var
 357             skipped           <- takeMVar skipped_var
 358             flaky_passes      <- takeMVar flaky_pass_var
 359             flaky_fails       <- takeMVar flaky_fail_var
 360
 361             -- print summary
 362             let sl = show . length
 363                 testSummary =
 364                   sl all_tests ++ " tests, " ++ sl skipped ++ " skipped, "
 365                     ++ sl unexpected_passes ++ " unexpected passes, "
 366                     ++ sl unexpected_fails ++ " unexpected fails, "
 367                     ++ sl flaky_passes ++ " flaky passes, "
 368                     ++ sl flaky_fails ++ " flaky fails."
 369             logAll testSummary
 370
 371             -- print failed or unexpected ok
 372             if null (unexpected_fails ++ unexpected_passes)
 373             then logAll "OK"
 374             else do
 375                 unless (null unexpected_passes) . logAll $
 376                     "UNEXPECTED OK: " ++ intercalate " " unexpected_passes
 377                 unless (null unexpected_fails) . logAll $
 378                     "UNEXPECTED FAIL: " ++ intercalate " " unexpected_fails
 379                 exitFailure
 380
 381 findTests :: IO [FilePath]
 382 findTests = getDirectoryContentsRecursive "."
 383
 384 partitionTests :: [FilePath] -> ([FilePath], [FilePath])
 385 partitionTests = go [] []
 386   where
 387     go ts ms [] = (ts, ms)
 388     go ts ms (f:fs) =
 389         -- NB: Keep this synchronized with isTestFile
 390         case takeExtensions f of
 391             ".test.hs"      -> go (f:ts) ms fs
 392             ".multitest.hs" -> go ts (f:ms) fs
 393             _               -> go ts ms     fs
 394
 395 outputThread :: Verbosity -> Chan ServerLogMsg -> Handle -> IO ()
 396 outputThread verbosity chan log_handle = go ""
 397   where
 398     go prev_hdr = do
 399         v <- readChan chan
 400         case v of
 401             ServerLogEnd -> return ()
 402             ServerLogMsg t msg -> do
 403                 let ls = lines msg
 404                     pre s c
 405                         | verbosity >= verbose
 406                         -- Didn't use printf as GHC 7.4
 407                         -- doesn't understand % 7s.
 408                         = replicate (7 - length s) ' ' ++ s ++ " " ++ c : " "
 409                         | otherwise = ""
 410                     hdr = case t of
 411                             AllServers   -> ""
 412                             ServerMeta s -> pre s ' '
 413                             ServerIn   s -> pre s '<'
 414                             ServerOut  s -> pre s '>'
 415                             ServerErr  s -> pre s '!'
 416                     ws = replicate (length hdr) ' '
 417                     mb_hdr l | hdr == prev_hdr = ws ++ l
 418                              | otherwise = hdr ++ l
 419                     ls' = case ls of
 420                             [] -> []
 421                             r:rs ->
 422                                 mb_hdr r : map (ws ++) rs
 423                     logmsg = unlines ls'
 424                 hPutStr stderr logmsg
 425                 hPutStr log_handle logmsg
 426                 go hdr
 427
 428 -- Cribbed from tasty
 429 type Time = Double
 430
 431 getTime :: IO Time
 432 getTime = do
 433     t <- Clock.getTime Clock.Monotonic
 434     let ns = realToFrac $ Clock.toNanoSecs t
 435     return $ ns / 10 ^ (9 :: Int)