cabal-testsuite/main/cabal-tests.hs

   1 {-# LANGUAGE CPP                      #-}
   2 {-# LANGUAGE NondecreasingIndentation #-}
   3 {-# LANGUAGE PatternGuards            #-}
   4 {-# LANGUAGE ScopedTypeVariables      #-}
   5
   6 import Test.Cabal.Workdir
   7 import Test.Cabal.Script
   8 import Test.Cabal.Server
   9 import Test.Cabal.Monad
  10 import Test.Cabal.TestCode
  11
  12 import Distribution.Verbosity        (normal, verbose, Verbosity)
  13 import Distribution.Simple.Utils     (getDirectoryContentsRecursive)
  14
  15 import Options.Applicative
  16 import Control.Concurrent.MVar
  17 import Control.Concurrent
  18 import Control.Concurrent.Async
  19 import Control.Exception
  20 import Control.Monad
  21 import GHC.Conc (numCapabilities)
  22 import Data.List
  23 import Text.Printf
  24 import qualified System.Clock as Clock
  25 import System.IO
  26 import System.FilePath
  27 import System.Exit
  28 import System.Process (callProcess, showCommandForUser)
  29
  30 #if !MIN_VERSION_base(4,12,0)
  31 import Data.Monoid ((<>))
  32 #endif
  33 #if !MIN_VERSION_base(4,8,0)
  34 import Data.Monoid (mempty)
  35 #endif
  36
  37 -- | Record for arguments that can be passed to @cabal-tests@ executable.
  38 data MainArgs = MainArgs {
  39         mainArgThreads :: Int,
  40         mainArgTestPaths :: [String],
  41         mainArgHideSuccesses :: Bool,
  42         mainArgVerbose :: Bool,
  43         mainArgQuiet   :: Bool,
  44         mainArgDistDir :: Maybe FilePath,
  45         mainCommonArgs :: CommonArgs
  46     }
  47
  48 -- | optparse-applicative parser for 'MainArgs'
  49 mainArgParser :: Parser MainArgs
  50 mainArgParser = MainArgs
  51     <$> option auto
  52         ( help "Number of threads to run"
  53        <> short 'j'
  54        <> showDefault
  55        <> value numCapabilities
  56        <> metavar "INT")
  57     <*> many (argument str (metavar "FILE"))
  58     <*> switch
  59         ( long "hide-successes"
  60        <> help "Do not print test cases as they are being run"
  61         )
  62     <*> switch
  63         ( long "verbose"
  64        <> short 'v'
  65        <> help "Be verbose"
  66         )
  67     <*> switch
  68         ( long "quiet"
  69        <> short 'q'
  70        <> help "Only output stderr on failure"
  71         )
  72     <*> optional (option str
  73         ( help "Dist directory we were built with"
  74        <> long "builddir"
  75        <> metavar "DIR"))
  76     <*> commonArgParser
  77
  78 main :: IO ()
  79 main = do
  80     -- By default, stderr is not buffered.  This isn't really necessary
  81     -- for us, and it causes problems on Windows, see:
  82     -- https://github.com/appveyor/ci/issues/1364
  83     hSetBuffering stderr LineBuffering
  84
  85     -- Parse arguments.  N.B. 'helper' adds the option `--help`.
  86     args <- execParser $ info (mainArgParser <**> helper) mempty
  87     let verbosity = if mainArgVerbose args then verbose else normal
  88
  89     -- To run our test scripts, we need to be able to run Haskell code
  90     -- linked against the Cabal library under test.  The most efficient
  91     -- way to get this information is by querying the *host* build
  92     -- system about the information.
  93     --
  94     -- Fortunately, because we are using a Custom setup, our Setup
  95     -- script is bootstrapped against the Cabal library we're testing
  96     -- against, so can use our dependency on Cabal to read out the build
  97     -- info *for this package*.
  98     --
  99     -- NB: Currently assumes that per-component build is NOT turned on
 100     -- for Custom.
 101     dist_dir <- case mainArgDistDir args of
 102                   Just dist_dir -> return dist_dir
 103                   Nothing -> guessDistDir
 104     when (verbosity >= verbose) $
 105         hPutStrLn stderr $ "Using dist dir: " ++ dist_dir
 106     -- Get ready to go!
 107     senv <- mkScriptEnv verbosity
 108
 109     let runTest :: (Maybe cwd -> [unusedEnv] -> FilePath -> [String] -> IO result)
 110                 -> FilePath
 111                 -> IO result
 112         runTest runner path
 113             = runner Nothing [] path $
 114                 ["--builddir", dist_dir, path] ++ renderCommonArgs (mainCommonArgs args)
 115
 116     case mainArgTestPaths args of
 117         [path] -> do
 118             -- Simple runner
 119             (real_path, real_args) <- runTest (runnerCommand senv) path
 120             hPutStrLn stderr $ showCommandForUser real_path real_args
 121             callProcess real_path real_args
 122             hPutStrLn stderr "OK"
 123         user_paths -> do
 124             -- Read out tests from filesystem
 125             hPutStrLn stderr $ "threads: " ++ show (mainArgThreads args)
 126
 127             test_scripts <- if null user_paths
 128                                 then findTests
 129                                 else return user_paths
 130             -- NB: getDirectoryContentsRecursive is lazy IO, but it
 131             -- doesn't handle directories disappearing gracefully. Fix
 132             -- this!
 133             (single_tests, multi_tests) <- evaluate (partitionTests test_scripts)
 134             let all_tests = multi_tests ++ single_tests
 135                 margin = maximum (map length all_tests) + 2
 136             hPutStrLn stderr $ "tests to run: " ++ show (length all_tests)
 137
 138             -- TODO: Get parallelization out of multitests by querying
 139             -- them for their modes and then making a separate worker
 140             -- for each.  But for now, just run them earlier to avoid
 141             -- them straggling at the end
 142             work_queue <- newMVar all_tests
 143             unexpected_fails_var  <- newMVar []
 144             unexpected_passes_var <- newMVar []
 145             skipped_var <- newMVar []
 146
 147             chan <- newChan
 148             let logAll msg = writeChan chan (ServerLogMsg AllServers msg)
 149                 logEnd = writeChan chan ServerLogEnd
 150             -- NB: don't use withAsync as we do NOT want to cancel this
 151             -- on an exception
 152             async_logger <- async (withFile "cabal-tests.log" WriteMode $ outputThread verbosity chan)
 153
 154             -- Make sure we pump out all the logs before quitting
 155             (\m -> finally m (logEnd >> wait async_logger)) $ do
 156
 157             -- NB: Need to use withAsync so that if the main thread dies
 158             -- (due to ctrl-c) we tear down all of the worker threads.
 159             let go server = do
 160                     let split [] = return ([], Nothing)
 161                         split (y:ys) = return (ys, Just y)
 162                         logMeta msg = writeChan chan
 163                                     $ ServerLogMsg
 164                                         (ServerMeta (serverProcessId server))
 165                                         msg
 166                     mb_work <- modifyMVar work_queue split
 167                     case mb_work of
 168                         Nothing -> return ()
 169                         Just path -> do
 170                             when (verbosity >= verbose) $
 171                                 logMeta $ "Running " ++ path
 172                             start <- getTime
 173                             r <- runTest (runOnServer server) path
 174                             end <- getTime
 175                             let time = end - start
 176                                 code = serverResultTestCode r
 177
 178                             unless (mainArgHideSuccesses args && code == TestCodeOk) $ do
 179                                 logMeta $
 180                                     path ++ replicate (margin - length path) ' ' ++ displayTestCode code ++
 181                                     if time >= 0.01
 182                                         then printf " (%.2fs)" time
 183                                         else ""
 184
 185                             when (code == TestCodeFail) $ do
 186                                 let description
 187                                       | mainArgQuiet args = serverResultStderr r
 188                                       | otherwise =
 189                                        "$ " ++ serverResultCommand r ++ "\n" ++
 190                                        "stdout:\n" ++ serverResultStdout r ++ "\n" ++
 191                                        "stderr:\n" ++ serverResultStderr r ++ "\n"
 192                                 logMeta $
 193                                           description
 194                                        ++ "*** unexpected failure for " ++ path ++ "\n\n"
 195                                 modifyMVar_ unexpected_fails_var $ \paths ->
 196                                     return (path:paths)
 197
 198                             when (code == TestCodeUnexpectedOk) $
 199                                 modifyMVar_ unexpected_passes_var $ \paths ->
 200                                     return (path:paths)
 201
 202                             when (isTestCodeSkip code) $
 203                                 modifyMVar_ skipped_var $ \paths ->
 204                                     return (path:paths)
 205
 206                             go server
 207
 208             -- Start as many threads as requested by -j to spawn
 209             -- GHCi servers and start running tests off of the
 210             -- run queue.
 211             replicateConcurrently_ (mainArgThreads args) (withNewServer chan senv go)
 212
 213             unexpected_fails  <- takeMVar unexpected_fails_var
 214             unexpected_passes <- takeMVar unexpected_passes_var
 215             skipped           <- takeMVar skipped_var
 216
 217             -- print summary
 218             let sl = show . length
 219                 testSummary =
 220                   sl all_tests ++ " tests, " ++ sl skipped ++ " skipped, "
 221                     ++ sl unexpected_passes ++ " unexpected passes, "
 222                     ++ sl unexpected_fails ++ " unexpected fails."
 223             logAll testSummary
 224
 225             -- print failed or unexpected ok
 226             if null (unexpected_fails ++ unexpected_passes)
 227             then logAll "OK"
 228             else do
 229                 unless (null unexpected_passes) . logAll $
 230                     "UNEXPECTED OK: " ++ intercalate " " unexpected_passes
 231                 unless (null unexpected_fails) . logAll $
 232                     "UNEXPECTED FAIL: " ++ intercalate " " unexpected_fails
 233                 exitFailure
 234
 235 findTests :: IO [FilePath]
 236 findTests = getDirectoryContentsRecursive "."
 237
 238 partitionTests :: [FilePath] -> ([FilePath], [FilePath])
 239 partitionTests = go [] []
 240   where
 241     go ts ms [] = (ts, ms)
 242     go ts ms (f:fs) =
 243         -- NB: Keep this synchronized with isTestFile
 244         case takeExtensions f of
 245             ".test.hs"      -> go (f:ts) ms fs
 246             ".multitest.hs" -> go ts (f:ms) fs
 247             _               -> go ts ms     fs
 248
 249 outputThread :: Verbosity -> Chan ServerLogMsg -> Handle -> IO ()
 250 outputThread verbosity chan log_handle = go ""
 251   where
 252     go prev_hdr = do
 253         v <- readChan chan
 254         case v of
 255             ServerLogEnd -> return ()
 256             ServerLogMsg t msg -> do
 257                 let ls = lines msg
 258                     pre s c
 259                         | verbosity >= verbose
 260                         -- Didn't use printf as GHC 7.4
 261                         -- doesn't understand % 7s.
 262                         = replicate (7 - length s) ' ' ++ s ++ " " ++ c : " "
 263                         | otherwise = ""
 264                     hdr = case t of
 265                             AllServers   -> ""
 266                             ServerMeta s -> pre s ' '
 267                             ServerIn   s -> pre s '<'
 268                             ServerOut  s -> pre s '>'
 269                             ServerErr  s -> pre s '!'
 270                     ws = replicate (length hdr) ' '
 271                     mb_hdr l | hdr == prev_hdr = ws ++ l
 272                              | otherwise = hdr ++ l
 273                     ls' = case ls of
 274                             [] -> []
 275                             r:rs ->
 276                                 mb_hdr r : map (ws ++) rs
 277                     logmsg = unlines ls'
 278                 hPutStr stderr logmsg
 279                 hPutStr log_handle logmsg
 280                 go hdr
 281
 282 -- Cribbed from tasty
 283 type Time = Double
 284
 285 getTime :: IO Time
 286 getTime = do
 287     t <- Clock.getTime Clock.Monotonic
 288     let ns = realToFrac $ Clock.toNanoSecs t
 289     return $ ns / 10 ^ (9 :: Int)