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 (callProcess, 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             callProcess real_path real_args
 242             hPutStrLn stderr "OK"
 243         user_paths -> do
 244             -- Read out tests from filesystem
 245             hPutStrLn stderr $ "threads: " ++ show (mainArgThreads args)
 246
 247             test_scripts <- if null user_paths
 248                                 then findTests
 249                                 else return user_paths
 250             -- NB: getDirectoryContentsRecursive is lazy IO, but it
 251             -- doesn't handle directories disappearing gracefully. Fix
 252             -- this!
 253             (single_tests, multi_tests) <- evaluate (partitionTests test_scripts)
 254             let all_tests = multi_tests ++ single_tests
 255                 margin = maximum (map length all_tests) + 2
 256             hPutStrLn stderr $ "tests to run: " ++ show (length all_tests)
 257
 258             -- TODO: Get parallelization out of multitests by querying
 259             -- them for their modes and then making a separate worker
 260             -- for each.  But for now, just run them earlier to avoid
 261             -- them straggling at the end
 262             work_queue <- newMVar all_tests
 263             unexpected_fails_var  <- newMVar []
 264             unexpected_passes_var <- newMVar []
 265             skipped_var <- newMVar []
 266
 267             chan <- newChan
 268             let logAll msg = writeChan chan (ServerLogMsg AllServers msg)
 269                 logEnd = writeChan chan ServerLogEnd
 270             -- NB: don't use withAsync as we do NOT want to cancel this
 271             -- on an exception
 272             async_logger <- async (withFile "cabal-tests.log" WriteMode $ outputThread verbosity chan)
 273
 274             -- Make sure we pump out all the logs before quitting
 275             (\m -> finally m (logEnd >> wait async_logger)) $ do
 276
 277             -- NB: Need to use withAsync so that if the main thread dies
 278             -- (due to ctrl-c) we tear down all of the worker threads.
 279             let go server = do
 280                     let split [] = return ([], Nothing)
 281                         split (y:ys) = return (ys, Just y)
 282                         logMeta msg = writeChan chan
 283                                     $ ServerLogMsg
 284                                         (ServerMeta (serverProcessId server))
 285                                         msg
 286                     mb_work <- modifyMVar work_queue split
 287                     case mb_work of
 288                         Nothing -> return ()
 289                         Just path -> do
 290                             when (verbosity >= verbose) $
 291                                 logMeta $ "Running " ++ path
 292                             start <- getTime
 293                             r <- runTest (runOnServer server) path
 294                             end <- getTime
 295                             let time = end - start
 296                                 code = serverResultTestCode r
 297
 298                             unless (mainArgHideSuccesses args && code == TestCodeOk) $ do
 299                                 logMeta $
 300                                     path ++ replicate (margin - length path) ' ' ++ displayTestCode code ++
 301                                     if time >= 0.01
 302                                         then printf " (%.2fs)" time
 303                                         else ""
 304
 305                             when (code == TestCodeFail) $ do
 306                                 let description
 307                                       | mainArgQuiet args = serverResultStderr r
 308                                       | otherwise =
 309                                        "$ " ++ serverResultCommand r ++ "\n" ++
 310                                        "stdout:\n" ++ serverResultStdout r ++ "\n" ++
 311                                        "stderr:\n" ++ serverResultStderr r ++ "\n"
 312                                 logMeta $
 313                                           description
 314                                        ++ "*** unexpected failure for " ++ path ++ "\n\n"
 315                                 modifyMVar_ unexpected_fails_var $ \paths ->
 316                                     return (path:paths)
 317
 318                             when (code == TestCodeUnexpectedOk) $
 319                                 modifyMVar_ unexpected_passes_var $ \paths ->
 320                                     return (path:paths)
 321
 322                             when (isTestCodeSkip code) $
 323                                 modifyMVar_ skipped_var $ \paths ->
 324                                     return (path:paths)
 325
 326                             go server
 327
 328             -- Start as many threads as requested by -j to spawn
 329             -- GHCi servers and start running tests off of the
 330             -- run queue.
 331             replicateConcurrently_ (mainArgThreads args) (withNewServer chan senv go)
 332
 333             unexpected_fails  <- takeMVar unexpected_fails_var
 334             unexpected_passes <- takeMVar unexpected_passes_var
 335             skipped           <- takeMVar skipped_var
 336
 337             -- print summary
 338             let sl = show . length
 339                 testSummary =
 340                   sl all_tests ++ " tests, " ++ sl skipped ++ " skipped, "
 341                     ++ sl unexpected_passes ++ " unexpected passes, "
 342                     ++ sl unexpected_fails ++ " unexpected fails."
 343             logAll testSummary
 344
 345             -- print failed or unexpected ok
 346             if null (unexpected_fails ++ unexpected_passes)
 347             then logAll "OK"
 348             else do
 349                 unless (null unexpected_passes) . logAll $
 350                     "UNEXPECTED OK: " ++ intercalate " " unexpected_passes
 351                 unless (null unexpected_fails) . logAll $
 352                     "UNEXPECTED FAIL: " ++ intercalate " " unexpected_fails
 353                 exitFailure
 354
 355 findTests :: IO [FilePath]
 356 findTests = getDirectoryContentsRecursive "."
 357
 358 partitionTests :: [FilePath] -> ([FilePath], [FilePath])
 359 partitionTests = go [] []
 360   where
 361     go ts ms [] = (ts, ms)
 362     go ts ms (f:fs) =
 363         -- NB: Keep this synchronized with isTestFile
 364         case takeExtensions f of
 365             ".test.hs"      -> go (f:ts) ms fs
 366             ".multitest.hs" -> go ts (f:ms) fs
 367             _               -> go ts ms     fs
 368
 369 outputThread :: Verbosity -> Chan ServerLogMsg -> Handle -> IO ()
 370 outputThread verbosity chan log_handle = go ""
 371   where
 372     go prev_hdr = do
 373         v <- readChan chan
 374         case v of
 375             ServerLogEnd -> return ()
 376             ServerLogMsg t msg -> do
 377                 let ls = lines msg
 378                     pre s c
 379                         | verbosity >= verbose
 380                         -- Didn't use printf as GHC 7.4
 381                         -- doesn't understand % 7s.
 382                         = replicate (7 - length s) ' ' ++ s ++ " " ++ c : " "
 383                         | otherwise = ""
 384                     hdr = case t of
 385                             AllServers   -> ""
 386                             ServerMeta s -> pre s ' '
 387                             ServerIn   s -> pre s '<'
 388                             ServerOut  s -> pre s '>'
 389                             ServerErr  s -> pre s '!'
 390                     ws = replicate (length hdr) ' '
 391                     mb_hdr l | hdr == prev_hdr = ws ++ l
 392                              | otherwise = hdr ++ l
 393                     ls' = case ls of
 394                             [] -> []
 395                             r:rs ->
 396                                 mb_hdr r : map (ws ++) rs
 397                     logmsg = unlines ls'
 398                 hPutStr stderr logmsg
 399                 hPutStr log_handle logmsg
 400                 go hdr
 401
 402 -- Cribbed from tasty
 403 type Time = Double
 404
 405 getTime :: IO Time
 406 getTime = do
 407     t <- Clock.getTime Clock.Monotonic
 408     let ns = realToFrac $ Clock.toNanoSecs t
 409     return $ ns / 10 ^ (9 :: Int)