PackageTester.hs 28.5 KB
Newer Older
1
{-# LANGUAGE ScopedTypeVariables #-}
2
3
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE CPP #-}
4

tibbe's avatar
tibbe committed
5
module PackageTests.PackageTester
6
    ( PackageSpec
ttuegel's avatar
ttuegel committed
7
    , SuiteConfig(..)
8
    , TestConfig(..)
tibbe's avatar
tibbe committed
9
    , Result(..)
10
11
12
13
    , TestM
    , runTestM

    -- * Paths
Edward Z. Yang's avatar
Edward Z. Yang committed
14
15
16
17
18
    , ghcPath
    , withGhcPath
    , ghcPkgPath
    , withGhcPkgPath

19
20
21
22
    , packageDir
    , distDir
    , relativeDistDir
    , sharedDBPath
23
    , getWithGhcPath
Edward Z. Yang's avatar
Edward Z. Yang committed
24
    , prefixDir
tibbe's avatar
tibbe committed
25
26

    -- * Running cabal commands
27
    , cabal
28
    , cabal'
tibbe's avatar
tibbe committed
29
30
    , cabal_build
    , cabal_install
31
    , ghcPkg
32
    , ghcPkg'
tibbe's avatar
tibbe committed
33
    , compileSetup
34
    , shell
tibbe's avatar
tibbe committed
35
    , run
36
    , runExe
37
    , runExe'
38
39
    , runInstalledExe
    , runInstalledExe'
40
41
42
43
44
45
46
47
48
49
50
51
    , rawRun
    , rawCompileSetup
    , withPackage
    , withEnv
    , withPackageDb

    -- * Polymorphic versions of HUnit functions
    , assertFailure
    , assertEqual
    , assertBool
    , shouldExist
    , shouldNotExist
tibbe's avatar
tibbe committed
52
53

    -- * Test helpers
54
55
    , shouldFail
    , whenGhcVersion
tibbe's avatar
tibbe committed
56
57
    , assertOutputContains
    , assertOutputDoesNotContain
58
    , assertFindInFile
59
    , concatOutput
60
    , ghcFileModDelay
61
    , withSymlink
62

63
64
65
66
    -- * Test trees
    , TestTreeM
    , runTestTree
    , testTree
67
    , testTreeSteps
68
    , testTreeSub
Edward Z. Yang's avatar
Edward Z. Yang committed
69
    , testTreeSubSteps
70
71
72
    , testTree'
    , groupTests
    , mapTestTrees
73
74
75
76
    , testWhen
    , testUnless
    , unlessWindows
    , hasSharedLibraries
Edward Z. Yang's avatar
Edward Z. Yang committed
77
    , hasCabalForGhc
78

79
80
81
82
83
84
85
    , getPersistBuildConfig

    -- Common utilities
    , module System.FilePath
    , module Data.List
    , module Control.Monad.IO.Class
    , module Text.Regex.Posix
86
87
    ) where

88
89
import PackageTests.Options

90
91
92
import Distribution.Compat.CreatePipe (createPipe)
import Distribution.Simple.Compiler (PackageDBStack, PackageDB(..))
import Distribution.Simple.Program.Run (getEffectiveEnvironment)
Edward Z. Yang's avatar
Edward Z. Yang committed
93
94
95
import Distribution.Simple.Program.Types
import Distribution.Simple.Program.Db
import Distribution.Simple.Program
96
import Distribution.System (OS(Windows), buildOS)
97
98
99
100
101
102
103
104
105
106
107
108
109
110
import Distribution.Simple.Utils
    ( printRawCommandAndArgsAndEnv, withFileContents )
import Distribution.Simple.Configure
    ( getPersistBuildConfig )
import Distribution.Verbosity (Verbosity)
import Distribution.Simple.BuildPaths (exeExtension)

import Distribution.Simple.Utils (cabalVersion)
import Distribution.Text (display)

import qualified Test.Tasty.HUnit as HUnit
import Text.Regex.Posix

import qualified Control.Exception as E
tibbe's avatar
tibbe committed
111
import Control.Monad
112
import Control.Monad.Trans.Class (lift)
113
import Control.Monad.Trans.Reader
114
import Control.Monad.Trans.Writer
115
import Control.Monad.IO.Class
tibbe's avatar
tibbe committed
116
117
import qualified Data.ByteString.Char8 as C
import Data.List
118
119
120
121
122
123
import Data.Version
import System.Directory
    ( doesFileExist, canonicalizePath, createDirectoryIfMissing
    , removeDirectoryRecursive, getPermissions, setPermissions
    , setOwnerExecutable )
import System.Exit
124
import System.FilePath
125
import System.IO
126
import System.IO.Error (isDoesNotExistError)
127
import System.Process (runProcess, waitForProcess, showCommandForUser)
128
import Control.Concurrent (threadDelay)
129
import Test.Tasty (TestTree, askOption, testGroup)
130

131
132
133
134
135
136
#ifndef mingw32_HOST_OS
import Control.Monad.Catch ( bracket_ )
import System.Directory    ( removeFile )
import System.Posix.Files  ( createSymbolicLink )
#endif

137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
-- | Our test monad maintains an environment recording the global test
-- suite configuration 'SuiteConfig', and the local per-test
-- configuration 'TestConfig'.
type TestM = ReaderT (SuiteConfig, TestConfig) IO

-- | Run a test in the test monad.
runTestM :: SuiteConfig -> FilePath -> Maybe String -> TestM a -> IO ()
runTestM suite name subname m = do
    let test = TestConfig {
                    testMainName = name,
                    testSubName = subname,
                    testShouldFail = False,
                    testCurrentPackage = ".",
                    testPackageDb = False,
                    testEnvironment = []
               }
153
    void (runReaderT (cleanup >> m) (suite, test))
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
  where
    -- TODO: option not to clean up dist dirs; this should be
    -- harmless!
    cleanup = do
        onlyIfExists . removeDirectoryRecursive =<< topDir

-- | Run an IO action, and suppress a "does not exist" error.
onlyIfExists :: MonadIO m => IO () -> m ()
onlyIfExists m = liftIO $
                 E.catch m $ \(e :: IOError) ->
                    if isDoesNotExistError e
                        then return ()
                        else E.throwIO e

-- cleaning up:
--  cabal clean will clean up dist directory, but we also need to zap
--  Setup etc.
--
-- Suggestion: just copy the files somewhere else!

-- | Global configuration for the entire test suite.
ttuegel's avatar
ttuegel committed
175
data SuiteConfig = SuiteConfig
Edward Z. Yang's avatar
Edward Z. Yang committed
176
177
178
179
180
181
    -- | The programs used to build the Cabal under test.
    -- Invariant: ghc and ghc-pkg are configured.
    { bootProgramsConfig :: ProgramDb
    -- | The programs that are requested using @--with-compiler@
    -- and @--with-hc-pkg@ to Cabal the under-test.
    -- Invariant: ghc and ghc-pkg are configured.
182
    , withProgramDb :: ProgramDb
183
184
    -- | The build directory that was used to build Cabal (used
    -- to compile Setup scripts.)
ttuegel's avatar
ttuegel committed
185
    , cabalDistPref :: FilePath
Edward Z. Yang's avatar
Edward Z. Yang committed
186
187
188
189
190
    -- | The package database stack which makes the *built*
    -- Cabal well-formed.  In general, this is going to be
    -- the package DB stack from the LBI you used to build
    -- Cabal, PLUS the inplace database (since you also want Cabal).
    -- TODO: I forgot what this comment means:
191
192
    -- We don't add these by default because then you have to
    -- link against Cabal which makes the build go longer.
enolan's avatar
enolan committed
193
    , packageDBStack :: PackageDBStack
Edward Z. Yang's avatar
Edward Z. Yang committed
194
195
196
197
198
199
    -- | The package database stack for 'withGhcPath'.  This
    -- is ignored if @'withGhcPath' suite == 'ghcPath' suite@.
    -- We don't assume this includes the inplace database (since
    -- Cabal would have been built with the wrong version of GHC,
    -- so the databases aren't compatible anyway.)
    , withGhcDBStack :: PackageDBStack
200
201
202
203
    -- | How verbose should we be
    , suiteVerbosity :: Verbosity
    -- | The absolute current working directory
    , absoluteCWD :: FilePath
204
205
206
    -- | How long we should 'threadDelay' to make sure the file timestamp is
    -- updated correctly for recompilation tests.
    , mtimeChangeDelay :: Int
ttuegel's avatar
ttuegel committed
207
208
    }

Edward Z. Yang's avatar
Edward Z. Yang committed
209
getProgram :: ProgramDb -> Program -> ConfiguredProgram
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
210
211
getProgram progdb program = prog
    where Just prog = lookupProgram program progdb -- invariant!
Edward Z. Yang's avatar
Edward Z. Yang committed
212
213
214
215
216

getBootProgram :: SuiteConfig -> Program -> ConfiguredProgram
getBootProgram suite = getProgram (bootProgramsConfig suite)

getWithProgram :: SuiteConfig -> Program -> ConfiguredProgram
217
getWithProgram suite = getProgram (withProgramDb suite)
Edward Z. Yang's avatar
Edward Z. Yang committed
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266

ghcProg :: SuiteConfig -> ConfiguredProgram
ghcProg suite = getBootProgram suite ghcProgram

withGhcProg :: SuiteConfig -> ConfiguredProgram
withGhcProg suite = getWithProgram suite ghcProgram

withGhcPkgProg :: SuiteConfig -> ConfiguredProgram
withGhcPkgProg suite = getWithProgram suite ghcPkgProgram

programVersion' :: ConfiguredProgram -> Version
programVersion' prog = version
    where Just version = programVersion prog -- invariant!

ghcPath :: SuiteConfig -> FilePath
ghcPath = programPath . ghcProg

-- Basically you should never use these two...

ghcPkgProg :: SuiteConfig -> ConfiguredProgram
ghcPkgProg suite = getBootProgram suite ghcPkgProgram

ghcPkgPath :: SuiteConfig -> FilePath
ghcPkgPath = programPath . ghcPkgProg

ghcVersion :: SuiteConfig -> Version
ghcVersion = programVersion' . ghcProg

withGhcPath :: SuiteConfig -> FilePath
withGhcPath = programPath . withGhcProg

withGhcVersion :: SuiteConfig -> Version
withGhcVersion = programVersion' . withGhcProg

-- Ditto...
withGhcPkgPath :: SuiteConfig -> FilePath
withGhcPkgPath = programPath . withGhcPkgProg

-- Selects the correct database stack to pass to the Cabal under
-- test as the "database stack" to use for testing.  This may be
-- something different if the GHC we want Cabal to use is different
-- from the GHC Cabal was built with.
testDBStack :: SuiteConfig -> PackageDBStack
testDBStack suite
    | withGhcPath suite == ghcPath suite
    = packageDBStack suite
    | otherwise
    = withGhcDBStack suite

267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
data TestConfig = TestConfig
    -- | Test name, MUST be the directory the test packages live in
    -- relative to tests/PackageTests
    { testMainName :: FilePath
    -- | Test sub-name, used to qualify dist/database directory to avoid
    -- conflicts.
    , testSubName :: Maybe String
    -- | This gets modified sometimes
    , testShouldFail :: Bool
    -- | The "current" package, ala current directory
    , testCurrentPackage :: PackageSpec
    -- | Says if we've initialized the per-test package DB
    , testPackageDb :: Bool
    -- | Environment override
    , testEnvironment :: [(String, Maybe String)]
    }
283

284
285
-- | A package that can be built.
type PackageSpec = FilePath
286

tibbe's avatar
tibbe committed
287
------------------------------------------------------------------------
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
-- * Directories

simpleSetupPath :: TestM FilePath
simpleSetupPath = do
    (suite, _) <- ask
    return (absoluteCWD suite </> "tests/Setup")

-- | The absolute path to the directory containing the files for
-- this tests; usually @Check.hs@ and any test packages.
testDir :: TestM FilePath
testDir = do
    (suite, test) <- ask
    return $ absoluteCWD suite </> "tests/PackageTests" </> testMainName test

-- | The absolute path to the root of the package directory; it's
-- where the Cabal file lives.  This is what you want the CWD of cabal
-- calls to be.
packageDir :: TestM FilePath
packageDir = do
    (_, test) <- ask
    test_dir <- testDir
    return $ test_dir </> testCurrentPackage test

-- | The absolute path to the directory containing all the
-- files for ALL tests associated with a test (respecting
-- subtests.)  To clean, you ONLY need to delete this directory.
topDir :: TestM FilePath
topDir = do
    test_dir <- testDir
    (_, test) <- ask
    return $ test_dir </>
                case testSubName test of
                    Nothing -> "dist-test"
                    Just n -> "dist-test." ++ n

prefixDir :: TestM FilePath
prefixDir = do
    top_dir <- topDir
    return $ top_dir </> "usr"

-- | The absolute path to the build directory that should be used
-- for the current package in a test.
distDir :: TestM FilePath
distDir = do
    top_dir <- topDir
    (_, test) <- ask
    return $ top_dir </> testCurrentPackage test </> "dist"

definitelyMakeRelative :: FilePath -> FilePath -> FilePath
definitelyMakeRelative base0 path0 =
    let go [] path = joinPath path
        go base [] = joinPath (replicate (length base) "..")
        go (".":xs) ys = go xs ys
        go xs (".":ys) = go xs ys
        go (x:xs) (y:ys)
            | x == y    = go xs ys
            | otherwise = go (x:xs) [] </> go [] (y:ys)
    in go (splitPath base0) (splitPath path0)

-- hpc is stupid and doesn't understand absolute paths.
relativeDistDir :: TestM FilePath
relativeDistDir = do
    dist_dir0 <- distDir
    pkg_dir <- packageDir
    return $ definitelyMakeRelative pkg_dir dist_dir0

-- | The absolute path to the shared package database that should
-- be used by all packages in this test.
sharedDBPath :: TestM FilePath
sharedDBPath = do
    top_dir <- topDir
    return $ top_dir </> "packagedb"
360

361
362
363
364
365
getWithGhcPath :: TestM FilePath
getWithGhcPath = do
    (suite, _) <- ask
    return $ withGhcPath suite

366
367
368
------------------------------------------------------------------------
-- * Running cabal

369
370
371
372
373
cabal :: String -> [String] -> TestM ()
cabal cmd extraArgs0 = void (cabal' cmd extraArgs0)

cabal' :: String -> [String] -> TestM Result
cabal' cmd extraArgs0 = do
374
375
376
377
378
379
380
381
382
383
    (suite, test) <- ask
    prefix_dir <- prefixDir
    when ((cmd == "register" || cmd == "copy") && not (testPackageDb test)) $
        error "Cannot register/copy without using 'withPackageDb'"
    let extraArgs1 = case cmd of
            "configure" ->
                -- If the package database is empty, setting --global
                -- here will make us error loudly if we try to install
                -- into a bad place.
                [ "--global"
384
385
386
387
388
389
                , "--with-ghc", withGhcPath suite
                -- This improves precision but it increases the number
                -- of flags one has to specify and I don't like that;
                -- Cabal is going to configure it and usually figure
                -- out the right location in any case.
                -- , "--with-ghc-pkg", withGhcPkgPath suite
390
391
392
393
394
395
                -- These flags make the test suite run faster
                -- Can't do this unless we LD_LIBRARY_PATH correctly
                -- , "--enable-executable-dynamic"
                , "--disable-optimization"
                -- Specify where we want our installed packages to go
                , "--prefix=" ++ prefix_dir
396
397
                ] -- Only add the LBI package stack if the GHC version
                  -- matches.
Edward Z. Yang's avatar
Edward Z. Yang committed
398
                  ++ packageDBParams (testDBStack suite)
399
400
401
402
                  ++ extraArgs0
            _ -> extraArgs0
    -- This is a horrible hack to make hpc work correctly
    dist_dir <- relativeDistDir
403
    let extraArgs = ["-v", "--distdir", dist_dir] ++ extraArgs1
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
    doCabal (cmd:extraArgs)

-- | This abstracts the common pattern of configuring and then building.
cabal_build :: [String] -> TestM ()
cabal_build args = do
    cabal "configure" args
    cabal "build" []
    return ()

-- | This abstracts the common pattern of "installing" a package.
cabal_install :: [String] -> TestM ()
cabal_install args = do
    cabal "configure" args
    cabal "build" []
    cabal "copy" []
    cabal "register" []
    return ()

-- | Determines what Setup executable to run and runs it
doCabal :: [String]  -- ^ extra arguments
      -> TestM Result
doCabal cabalArgs = do
    pkg_dir <- packageDir
    customSetup <- liftIO $ doesFileExist (pkg_dir </> "Setup.hs")
    if customSetup
        then do
            compileSetup
            -- TODO make this less racey
            let path = pkg_dir </> "Setup"
            run (Just pkg_dir) path cabalArgs
        else do
            -- Use shared Setup executable (only for Simple build types).
            path <- simpleSetupPath
            run (Just pkg_dir) path cabalArgs
438

enolan's avatar
enolan committed
439
packageDBParams :: PackageDBStack -> [String]
440
441
442
packageDBParams dbs = "--package-db=clear"
                    : map (("--package-db=" ++) . convert) dbs
  where
enolan's avatar
enolan committed
443
444
445
446
447
    convert :: PackageDB -> String
    convert  GlobalPackageDB         = "global"
    convert  UserPackageDB           = "user"
    convert (SpecificPackageDB path) = path

448
449
450
451
452
453
454
455
456
457
458
------------------------------------------------------------------------
-- * Compiling setup scripts

compileSetup :: TestM ()
compileSetup = do
    (suite, test) <- ask
    pkg_path <- packageDir
    liftIO $ rawCompileSetup (suiteVerbosity suite) suite (testEnvironment test) pkg_path

rawCompileSetup :: Verbosity -> SuiteConfig -> [(String, Maybe String)] -> FilePath -> IO ()
rawCompileSetup verbosity suite e path = do
459
460
    -- NB: Use 'ghcPath', not 'withGhcPath', since we need to be able to
    -- link against the Cabal library which was built with 'ghcPath'.
Edward Z. Yang's avatar
Edward Z. Yang committed
461
    -- Ditto with packageDBStack.
462
463
464
    r <- rawRun verbosity (Just path) (ghcPath suite) e $
        [ "--make"] ++
        ghcPackageDBParams (ghcVersion suite) (packageDBStack suite) ++
465
        [ "-hide-package Cabal"
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
        -- This mostly works, UNLESS you've installed a
        -- version of Cabal with the SAME version number.
        -- Then old GHCs will incorrectly select the installed
        -- version (because it prefers the FIRST package it finds.)
        -- It also semi-works to not specify "-hide-all-packages"
        -- at all, except if there's a later version of Cabal
        -- installed GHC will prefer that.
        , "-package Cabal-" ++ display cabalVersion
        , "-O0"
        , "Setup.hs" ]
    unless (resultExitCode r == ExitSuccess) $
        error $
        "could not build shared Setup executable\n" ++
        "  ran: " ++ resultCommand r ++ "\n" ++
        "  output:\n" ++ resultOutput r ++ "\n\n"

ghcPackageDBParams :: Version -> PackageDBStack -> [String]
ghcPackageDBParams ghc_version dbs
    | ghc_version >= Version [7,6] []
    = "-clear-package-db" : map convert dbs
    | otherwise
    = concatMap convertLegacy dbs
  where
    convert :: PackageDB -> String
    convert  GlobalPackageDB         = "-global-package-db"
    convert  UserPackageDB           = "-user-package-db"
    convert (SpecificPackageDB path) = "-package-db=" ++ path
493

494
495
496
    convertLegacy :: PackageDB -> [String]
    convertLegacy (SpecificPackageDB path) = ["-package-conf=" ++ path]
    convertLegacy _ = []
497

498
499
500
------------------------------------------------------------------------
-- * Running ghc-pkg

501
502
503
504
505
ghcPkg :: String -> [String] -> TestM ()
ghcPkg cmd args = void (ghcPkg' cmd args)

ghcPkg' :: String -> [String] -> TestM Result
ghcPkg' cmd args = do
506
507
508
    (config, test) <- ask
    unless (testPackageDb test) $
        error "Must initialize package database using withPackageDb"
Edward Z. Yang's avatar
Edward Z. Yang committed
509
510
511
512
    -- NB: testDBStack already has the local database
    let db_stack = testDBStack config
        extraArgs = ghcPkgPackageDBParams (withGhcVersion config) db_stack
    run Nothing (withGhcPkgPath config) (cmd : extraArgs ++ args)
513
514
515
516
517
518
519
520
521
522
523
524
525

ghcPkgPackageDBParams :: Version -> PackageDBStack -> [String]
ghcPkgPackageDBParams version dbs = concatMap convert dbs where
    convert :: PackageDB -> [String]
    -- Ignoring global/user is dodgy but there's no way good
    -- way to give ghc-pkg the correct flags in this case.
    convert  GlobalPackageDB         = []
    convert  UserPackageDB           = []
    convert (SpecificPackageDB path)
        | version >= Version [7,6] []
        = ["--package-db=" ++ path]
        | otherwise
        = ["--package-conf=" ++ path]
526

527
528
529
------------------------------------------------------------------------
-- * Running other things

530
531
532
533
534
535
536
-- | Run an executable that was produced by cabal.  The @exe_name@
-- is precisely the name of the executable section in the file.
runExe :: String -> [String] -> TestM ()
runExe exe_name args = void (runExe' exe_name args)

runExe' :: String -> [String] -> TestM Result
runExe' exe_name args = do
537
538
539
    dist_dir <- distDir
    let exe = dist_dir </> "build" </> exe_name </> exe_name
    run Nothing exe args
540

541
542
543
544
545
546
547
548
549
550
551
-- | Run an executable that was installed by cabal.  The @exe_name@
-- is precisely the name of the executable.
runInstalledExe :: String -> [String] -> TestM ()
runInstalledExe exe_name args = void (runInstalledExe' exe_name args)

runInstalledExe' :: String -> [String] -> TestM Result
runInstalledExe' exe_name args = do
    usr <- prefixDir
    let exe = usr </> "bin" </> exe_name
    run Nothing exe args

552
553
554
555
556
shell :: String -> [String] -> TestM Result
shell exe args = do
    pkg_dir <- packageDir
    run (Just pkg_dir) exe args

557
558
run :: Maybe FilePath -> String -> [String] -> TestM Result
run mb_cwd path args = do
559
    verbosity <- getVerbosity
560
561
562
563
564
565
566
    (_, test) <- ask
    r <- liftIO $ rawRun verbosity mb_cwd path (testEnvironment test) args
    record r
    requireSuccess r

rawRun :: Verbosity -> Maybe FilePath -> String -> [(String, Maybe String)] -> [String] -> IO Result
rawRun verbosity mb_cwd path envOverrides args = do
567
568
    -- path is relative to the current directory; canonicalizePath makes it
    -- absolute, so that runProcess will find it even when changing directory.
refold's avatar
refold committed
569
    path' <- do pathExists <- doesFileExist path
570
571
572
573
574
                exePathExists <- doesFileExist (path <.> exeExtension)
                case () of
                 _ | pathExists    -> canonicalizePath path
                   | exePathExists -> canonicalizePath (path <.> exeExtension)
                   | otherwise     -> return path
Neil Vice's avatar
Neil Vice committed
575
576
577
    menv <- getEffectiveEnvironment envOverrides

    printRawCommandAndArgsAndEnv verbosity path' args menv
tibbe's avatar
tibbe committed
578
    (readh, writeh) <- createPipe
579
    pid <- runProcess path' args mb_cwd menv Nothing (Just writeh) (Just writeh)
580

581
    out <- hGetContents readh
582
    void $ E.evaluate (length out) -- force the output
tibbe's avatar
tibbe committed
583
    hClose readh
584

585
586
    -- wait for the program to terminate
    exitcode <- waitForProcess pid
587
588
589
590
591
592
    return Result {
            resultExitCode = exitcode,
            resultDirectory = mb_cwd,
            resultCommand = showCommandForUser path' args,
            resultOutput = out
        }
593

594
------------------------------------------------------------------------
595
-- * Subprocess run results
tibbe's avatar
tibbe committed
596

597
598
599
600
601
602
data Result = Result
    { resultExitCode :: ExitCode
    , resultDirectory :: Maybe FilePath
    , resultCommand :: String
    , resultOutput :: String
    } deriving Show
tibbe's avatar
tibbe committed
603

604
605
606
607
608
609
610
611
612
613
614
615
requireSuccess :: Result -> TestM Result
requireSuccess r@Result { resultCommand = cmd
                        , resultExitCode = exitCode
                        , resultOutput = output } = do
    (_, test) <- ask
    when (exitCode /= ExitSuccess && not (testShouldFail test)) $
        assertFailure $ "Command " ++ cmd ++ " failed.\n" ++
        "Output:\n" ++ output ++ "\n"
    when (exitCode == ExitSuccess && testShouldFail test) $
        assertFailure $ "Command " ++ cmd ++ " succeeded.\n" ++
        "Output:\n" ++ output ++ "\n"
    return r
616

617
618
record :: Result -> TestM ()
record res = do
619
    log_dir <- topDir
620
    (suite, _) <- ask
621
622
    liftIO $ createDirectoryIfMissing True log_dir
    liftIO $ C.appendFile (log_dir </> "test.log")
623
624
                         (C.pack $ "+ " ++ resultCommand res ++ "\n"
                            ++ resultOutput res ++ "\n\n")
625
    let test_sh = log_dir </> "test.sh"
626
627
628
629
630
631
632
633
634
635
636
637
638
639
    b <- liftIO $ doesFileExist test_sh
    when (not b) . liftIO $ do
        -- This is hella racey but this is not that security important
        C.appendFile test_sh
            (C.pack $ "#/bin/sh\nset -ev\n" ++
                      "cd "++ show (absoluteCWD suite) ++"\n")
        perms <- getPermissions test_sh
        setPermissions test_sh (setOwnerExecutable True perms)

    liftIO $ C.appendFile test_sh
                (C.pack
                  (case resultDirectory res of
                    Nothing -> resultCommand res
                    Just d -> "(cd " ++ show d ++ " && " ++ resultCommand res ++ ")\n"))
640

641
642
------------------------------------------------------------------------
-- * Test helpers
643

644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
assertFailure :: MonadIO m => String -> m ()
assertFailure = liftIO . HUnit.assertFailure

assertEqual :: (Eq a, Show a, MonadIO m) => String -> a -> a -> m ()
assertEqual s x y = liftIO $ HUnit.assertEqual s x y

assertBool :: MonadIO m => String -> Bool -> m ()
assertBool s x = liftIO $ HUnit.assertBool s x

shouldExist :: MonadIO m => FilePath -> m ()
shouldExist path = liftIO $ doesFileExist path >>= assertBool (path ++ " should exist")

shouldNotExist :: MonadIO m => FilePath -> m ()
shouldNotExist path =
    liftIO $ doesFileExist path >>= assertBool (path ++ " should exist") . not

shouldFail :: TestM a -> TestM a
shouldFail = withReaderT (\(suite, test) -> (suite, test { testShouldFail = not (testShouldFail test) }))

whenGhcVersion :: (Version -> Bool) -> TestM () -> TestM ()
whenGhcVersion p m = do
    (suite, _) <- ask
Edward Z. Yang's avatar
Edward Z. Yang committed
666
    when (p (withGhcVersion suite)) m
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688

withPackage :: FilePath -> TestM a -> TestM a
withPackage f = withReaderT (\(suite, test) -> (suite, test { testCurrentPackage = f }))

-- TODO: Really should accumulate... but I think to do this
-- properly we can't just append
withEnv :: [(String, Maybe String)] -> TestM a -> TestM a
withEnv e m = do
    (_, test0) <- ask
    when (not (null (testEnvironment test0)))
        $ error "nested withEnv (not yet) supported"
    withReaderT (\(suite, test) -> (suite, test { testEnvironment = e })) m

withPackageDb :: TestM a -> TestM a
withPackageDb m = do
    (_, test0) <- ask
    db_path <- sharedDBPath
    if testPackageDb test0
        then m
        else withReaderT (\(suite, test) ->
                            (suite { packageDBStack
                                        = packageDBStack suite
Edward Z. Yang's avatar
Edward Z. Yang committed
689
690
691
692
                                       ++ [SpecificPackageDB db_path]
                                   , withGhcDBStack
                                        = withGhcDBStack suite
                                       ++ [SpecificPackageDB db_path]},
693
694
695
696
697
                             test { testPackageDb = True }))
               $ do ghcPkg "init" [db_path]
                    m

assertOutputContains :: MonadIO m => String -> Result -> m ()
tibbe's avatar
tibbe committed
698
assertOutputContains needle result =
refold's avatar
refold committed
699
    unless (needle `isInfixOf` (concatOutput output)) $
tibbe's avatar
tibbe committed
700
    assertFailure $
refold's avatar
refold committed
701
702
    " expected: " ++ needle ++ "\n" ++
    " in output: " ++ output ++ ""
703
  where output = resultOutput result
704

705
assertOutputDoesNotContain :: MonadIO m => String -> Result -> m ()
706
assertOutputDoesNotContain needle result =
refold's avatar
refold committed
707
    when (needle `isInfixOf` (concatOutput output)) $
708
709
710
    assertFailure $
    "unexpected: " ++ needle ++
    " in output: " ++ output
711
712
713
714
715
716
717
718
719
  where output = resultOutput result

assertFindInFile :: MonadIO m => String -> FilePath -> m ()
assertFindInFile needle path =
    liftIO $ withFileContents path
                 (\contents ->
                  unless (needle `isInfixOf` contents)
                         (assertFailure ("expected: " ++ needle ++ "\n" ++
                                         " in file: " ++ path)))
720

refold's avatar
refold committed
721
722
723
724
-- | Replace line breaks with spaces, correctly handling "\r\n".
concatOutput :: String -> String
concatOutput = unwords . lines . filter ((/=) '\r')

725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
-- | Delay a sufficient period of time to permit file timestamp
-- to be updated.
ghcFileModDelay :: TestM ()
ghcFileModDelay = do
    (suite, _) <- ask
    -- For old versions of GHC, we only had second-level precision,
    -- so we need to sleep a full second.  Newer versions use
    -- millisecond level precision, so we only have to wait
    -- the granularity of the underlying filesystem.
    -- TODO: cite commit when GHC got better precision; this
    -- version bound was empirically generated.
    let delay | withGhcVersion suite < Version [7,7] []
              = 1000000 -- 1s
              | otherwise
              = mtimeChangeDelay suite
    liftIO $ threadDelay delay

742
743
744
745
746
747
748
749
750
751
752
753
754
755
-- | Create a symlink for the duration of the provided action. If the symlink
-- already exists, it is deleted. Does not work on Windows.
withSymlink :: FilePath -> FilePath -> TestM a -> TestM a
#ifdef mingw32_HOST_OS
withSymlink _oldpath _newpath _act =
  error "PackageTests.PackageTester.withSymlink: does not work on Windows!"
#else
withSymlink oldpath newpath act = do
  symlinkExists <- liftIO $ doesFileExist newpath
  when symlinkExists $ liftIO $ removeFile newpath
  bracket_ (liftIO $ createSymbolicLink oldpath newpath)
           (liftIO $ removeFile newpath) act
#endif

756
757
758
------------------------------------------------------------------------
-- * Test trees

759
760
761
-- | Monad for creating test trees. The option --enable-all-tests determines
-- whether to filter tests with 'testWhen' and 'testUnless'.
type TestTreeM = WriterT [TestTree] (Reader OptionEnableAllTests)
762
763

runTestTree :: String -> TestTreeM () -> TestTree
764
765
runTestTree name ts = askOption $
                      testGroup name . runReader (execWriterT ts)
766

767
768
769
770
testTree :: SuiteConfig -> String -> TestM a -> TestTreeM ()
testTree config name m =
    testTree' $ HUnit.testCase name $ runTestM config name Nothing m

771
772
773
774
775
testTreeSteps :: SuiteConfig -> String -> ((String -> TestM ()) -> TestM a) -> TestTreeM ()
testTreeSteps config name f =
    testTree' . HUnit.testCaseSteps name
              $ \step -> runTestM config name Nothing (f (liftIO . step))

776
777
778
testTreeSub :: SuiteConfig -> String -> String -> TestM a -> TestTreeM ()
testTreeSub config name sub_name m =
    testTree' $ HUnit.testCase (name </> sub_name) $ runTestM config name (Just sub_name) m
779

Edward Z. Yang's avatar
Edward Z. Yang committed
780
781
782
783
784
785
testTreeSubSteps :: SuiteConfig -> String -> String
                 -> ((String -> TestM ()) -> TestM a)
                 -> TestTreeM ()
testTreeSubSteps config name sub_name f =
    testTree' . HUnit.testCaseSteps (name </> sub_name)
              $ \step -> runTestM config name (Just sub_name) (f (liftIO . step))
786

787
788
789
testTree' :: TestTree -> TestTreeM ()
testTree' tc = tell [tc]

790
-- | Create a test group from the output of the given action.
791
792
793
groupTests :: String -> TestTreeM () -> TestTreeM ()
groupTests name = censor (\ts -> [testGroup name ts])

794
-- | Apply a function to each top-level test tree.
795
796
797
mapTestTrees :: (TestTree -> TestTree) -> TestTreeM a -> TestTreeM a
mapTestTrees = censor . map

798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
testWhen :: Bool -> TestTreeM () -> TestTreeM ()
testWhen c test = do
  OptionEnableAllTests enableAll <- lift ask
  when (enableAll || c) test

testUnless :: Bool -> TestTreeM () -> TestTreeM ()
testUnless = testWhen . not

unlessWindows :: TestTreeM () -> TestTreeM ()
unlessWindows = testUnless (buildOS == Windows)

hasSharedLibraries :: SuiteConfig -> Bool
hasSharedLibraries config =
    buildOS /= Windows || withGhcVersion config < Version [7,8] []

Edward Z. Yang's avatar
Edward Z. Yang committed
813
814
815
816
hasCabalForGhc :: SuiteConfig -> Bool
hasCabalForGhc config =
    withGhcPath config == ghcPath config

817
------------------------------------------------------------------------
tibbe's avatar
tibbe committed
818
-- Verbosity
819

820
821
getVerbosity :: TestM Verbosity
getVerbosity = fmap (suiteVerbosity . fst) ask