Monad.hs 14.8 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
{-# LANGUAGE ScopedTypeVariables #-}

-- | The test monad
module Test.Cabal.Monad (
    -- * High-level runners
    setupAndCabalTest,
    setupTest,
    cabalTest,
    -- * The monad
    TestM,
    runTestM,
12
13
14
    -- * Helper functions
    programPathM,
    requireProgramM,
15
16
17
    isAvailableProgram,
    hackageRepoToolProgram,
    cabalProgram,
18
19
20
21
22
23
    -- * The test environment
    TestEnv(..),
    getTestEnv,
    -- * Derived values from 'TestEnv'
    testCurrentDir,
    testWorkDir,
Edward Z. Yang's avatar
Edward Z. Yang committed
24
    testPrefixDir,
25
26
    testDistDir,
    testPackageDbDir,
27
    testHomeDir,
28
29
    testSandboxDir,
    testSandboxConfigFile,
30
31
32
    testRepoDir,
    testKeysDir,
    testUserCabalConfigFile,
33
34
35
36
37
    -- * Skipping tests
    skip,
    skipIf,
    skipUnless,
    skipExitCode,
38
39
40
41
42
    -- * Known broken tests
    expectedBroken,
    unexpectedSuccess,
    expectedBrokenExitCode,
    unexpectedSuccessExitCode,
43
44
45
46
47
48
49
50
    -- whenHasSharedLibraries,
    -- * Arguments (TODO: move me)
    CommonArgs(..),
    renderCommonArgs,
    commonArgParser,
) where

import Test.Cabal.Script
51
import Test.Cabal.Plan
52
53
54

import Distribution.Simple.Compiler (PackageDBStack, PackageDB(..), compilerFlavor)
import Distribution.Simple.Program.Db
55
import Distribution.Simple.Program
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
import Distribution.Simple.Configure
    ( getPersistBuildConfig, configCompilerEx )
import Distribution.Types.LocalBuildInfo

import Distribution.Verbosity

import qualified Control.Exception as E
import Control.Monad
import Control.Monad.Trans.Reader
import Control.Monad.IO.Class
import Data.Maybe
import Control.Applicative
import Data.Monoid
import System.Directory
import System.Exit
import System.FilePath
import System.IO.Error (isDoesNotExistError)
import Options.Applicative

data CommonArgs = CommonArgs {
76
77
78
79
        argCabalInstallPath    :: Maybe FilePath,
        argGhcPath             :: Maybe FilePath,
        argHackageRepoToolPath :: Maybe FilePath,
        argSkipSetupTests      :: Bool
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
    }

commonArgParser :: Parser CommonArgs
commonArgParser = CommonArgs
    <$> optional (option str
        ( help "Path to cabal-install executable to test"
       <> long "with-cabal"
       <> metavar "PATH"
        ))
    <*> optional (option str
        ( help "GHC to ask Cabal to use via --with-ghc flag"
       <> short 'w'
       <> long "with-ghc"
       <> metavar "PATH"
        ))
95
    <*> optional (option str
96
97
98
        ( help "Path to hackage-repo-tool to use for repository manipulation"
       <> long "with-hackage-repo-tool"
       <> metavar "PATH"
99
        ))
100
101
102
103
    <*> switch (long "skip-setup-tests" <> help "Skip setup tests")

renderCommonArgs :: CommonArgs -> [String]
renderCommonArgs args =
104
105
106
    maybe [] (\x -> ["--with-cabal",             x]) (argCabalInstallPath    args) ++
    maybe [] (\x -> ["--with-ghc",               x]) (argGhcPath             args) ++
    maybe [] (\x -> ["--with-hackage-repo-tool", x]) (argHackageRepoToolPath args) ++
107
108
109
    (if argSkipSetupTests args then ["--skip-setup-tests"] else [])

data TestArgs = TestArgs {
110
        testArgDistDir    :: FilePath,
111
        testArgScriptPath :: FilePath,
112
        testCommonArgs    :: CommonArgs
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
    }

testArgParser :: Parser TestArgs
testArgParser = TestArgs
    <$> option str
        ( help "Build directory of cabal-testsuite"
       <> long "builddir"
       <> metavar "DIR")
    <*> argument str ( metavar "FILE")
    <*> commonArgParser

skip :: TestM ()
skip = liftIO $ do
    putStrLn "SKIP"
    exitWith (ExitFailure skipExitCode)

skipIf :: Bool -> TestM ()
skipIf b = when b skip

skipUnless :: Bool -> TestM ()
skipUnless b = unless b skip

135
136
137
138
139
140
141
142
143
144
expectedBroken :: TestM ()
expectedBroken = liftIO $ do
    putStrLn "EXPECTED FAIL"
    exitWith (ExitFailure expectedBrokenExitCode)

unexpectedSuccess :: TestM ()
unexpectedSuccess = liftIO $ do
    putStrLn "UNEXPECTED OK"
    exitWith (ExitFailure unexpectedSuccessExitCode)

145
146
147
skipExitCode :: Int
skipExitCode = 64

148
149
150
151
152
153
expectedBrokenExitCode :: Int
expectedBrokenExitCode = 65

unexpectedSuccessExitCode :: Int
unexpectedSuccessExitCode = 66

154
setupAndCabalTest :: TestM () -> IO ()
155
156
157
158
159
160
161
162
163
164
165
166
167
setupAndCabalTest m = do
    runTestM $ do
        env <- getTestEnv
        have_cabal <- isAvailableProgram cabalProgram
        skipIf (testSkipSetupTests env && not have_cabal)
        when (not (testSkipSetupTests env)) $ do
            liftIO $ putStrLn "Test with Setup:"
            m
    runTestM $ do
        have_cabal <- isAvailableProgram cabalProgram
        when have_cabal $ do
            liftIO $ putStrLn "Test with cabal-install:"
            withReaderT (\nenv -> nenv { testCabalInstallAsSetup = True }) m
168
169
170
171
172
173
174
175
176

setupTest :: TestM () -> IO ()
setupTest m = runTestM $ do
    env <- getTestEnv
    skipIf (testSkipSetupTests env)
    m

cabalTest :: TestM () -> IO ()
cabalTest m = runTestM $ do
177
    skipUnless =<< isAvailableProgram cabalProgram
178
    withReaderT (\nenv -> nenv { testCabalInstallAsSetup = True }) m
179
180
181

type TestM = ReaderT TestEnv IO

182
183
184
185
186
187
188
189
190
hackageRepoToolProgram :: Program
hackageRepoToolProgram = simpleProgram "hackage-repo-tool"

cabalProgram :: Program
cabalProgram = (simpleProgram "cabal") {
        -- Do NOT search for executable named cabal
        programFindLocation = \_ _ -> return Nothing
    }

191
192
193
194
195
196
197
198
199
200
201
202
-- | Run a test in the test monad according to program's arguments.
runTestM :: TestM () -> IO ()
runTestM m = do
    args <- execParser (info testArgParser mempty)
    let dist_dir = testArgDistDir args
        (script_dir0, script_filename) = splitFileName (testArgScriptPath args)
        script_base = dropExtensions script_filename
    -- Canonicalize this so that it is stable across working directory changes
    script_dir <- canonicalizePath script_dir0
    lbi <- getPersistBuildConfig dist_dir
    let verbosity = normal -- TODO: configurable
    senv <- mkScriptEnv verbosity lbi
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
    -- Add test suite specific programs
    let program_db0 =
            addKnownPrograms
                ([hackageRepoToolProgram, cabalProgram] ++ builtinPrograms)
                (withPrograms lbi)
    -- Reconfigure according to user flags
    let cargs = testCommonArgs args
    program_db1 <-
        reconfigurePrograms verbosity
            ([("cabal", p) | p <- maybeToList (argCabalInstallPath cargs)] ++
             [("ghc",   p) | p <- maybeToList (argGhcPath cargs)] ++
             [("hackage-repo-tool", p)
                           | p <- maybeToList (argHackageRepoToolPath cargs)])
            [] -- --prog-options not supported ATM
            program_db0

    -- Reconfigure the rest of GHC
    program_db <- case argGhcPath cargs of
        Nothing -> return program_db1
222
        Just ghc_path -> do
223
224
225
226
227
228
229
230
231
232
233
234
235
236
            -- All the things that get updated paths from
            -- configCompilerEx.  The point is to make sure
            -- we reconfigure these when we need them.
            let program_db2 = unconfigureProgram "ghc"
                            . unconfigureProgram "ghc-pkg"
                            . unconfigureProgram "hsc2hs"
                            . unconfigureProgram "haddock"
                            . unconfigureProgram "hpc"
                            . unconfigureProgram "runghc"
                            . unconfigureProgram "gcc"
                            . unconfigureProgram "ld"
                            . unconfigureProgram "ar"
                            . unconfigureProgram "strip"
                            $ program_db1
237
238
239
240
241
            (_, _, program_db) <-
                configCompilerEx
                    (Just (compilerFlavor (compiler lbi)))
                    (Just ghc_path)
                    Nothing
242
                    program_db2
243
                    verbosity
244
245
246
247
248
249
250
251
252
253
254
255
256
257
            -- TODO: this actually leaves a pile of things unconfigured.
            -- Optimal strategy for us is to lazily configure them, so
            -- we don't pay for things we don't need.  A bit difficult
            -- to do in the current design.
            return program_db

    let db_stack =
            case argGhcPath (testCommonArgs args) of
                Nothing -> withPackageDB lbi
                -- Can't use the build package db stack since they
                -- are all for the wrong versions!  TODO: Make
                -- this configurable
                Just _  -> [GlobalPackageDB]
        env = TestEnv {
258
259
260
261
262
263
264
265
266
                    testSourceDir = script_dir,
                    testSubName = script_base,
                    testProgramDb = program_db,
                    testPackageDBStack = db_stack,
                    testVerbosity = verbosity,
                    testMtimeChangeDelay = Nothing,
                    testScriptEnv = senv,
                    testSetupPath = dist_dir </> "setup" </> "setup",
                    testSkipSetupTests =  argSkipSetupTests (testCommonArgs args),
267
268
269
270
271
                    testEnvironment =
                        -- Try to avoid Unicode output
                        [ ("LC_ALL", Just "C")
                        -- Hermetic builds (knot-tied)
                        , ("HOME", Just (testHomeDir env))],
272
273
274
                    testShouldFail = False,
                    testRelativeCurrentDir = ".",
                    testHavePackageDb = False,
275
                    testHaveSandbox = False,
276
                    testHaveRepo = False,
277
                    testCabalInstallAsSetup = False,
278
279
                    testCabalProjectFile = "cabal.project",
                    testPlan = Nothing
280
281
282
283
                }
    runReaderT (cleanup >> m) env
  where
    cleanup = do
284
        env <- getTestEnv
285
286
287
288
289
290
        onlyIfExists . removeDirectoryRecursive $ testWorkDir env
        -- NB: it's important to initialize this ourselves, as
        -- the default configuration hardcodes Hackage, which we do
        -- NOT want to assume for these tests (no test should
        -- hit Hackage.)
        liftIO $ createDirectoryIfMissing True (testHomeDir env </> ".cabal")
291
        ghc_path <- programPathM ghcProgram
292
        liftIO $ writeFile (testUserCabalConfigFile env)
293
294
295
296
297
298
299
300
301
302
303
304
               $ unlines [ "with-compiler: " ++ ghc_path ]

requireProgramM :: Program -> TestM ConfiguredProgram
requireProgramM program = do
    env <- getTestEnv
    (configured_program, _) <- liftIO $
        requireProgram (testVerbosity env) program (testProgramDb env)
    return configured_program

programPathM :: Program -> TestM FilePath
programPathM program = do
    fmap programPath (requireProgramM program)
305

306
307
308
309
310
311
312
313
314
315
316
317
isAvailableProgram :: Program -> TestM Bool
isAvailableProgram program = do
    env <- getTestEnv
    case lookupProgram program (testProgramDb env) of
        Just _ -> return True
        Nothing -> do
            -- It might not have been configured. Try to configure.
            progdb <- liftIO $ configureProgram (testVerbosity env) program (testProgramDb env)
            case lookupProgram program progdb of
                Just _  -> return True
                Nothing -> return False

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
360
361
362
-- | 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

data TestEnv = TestEnv
    -- UNCHANGING:

    {
    -- | Path to the test directory, as specified by path to test
    -- script.
      testSourceDir     :: FilePath
    -- | Test sub-name, used to qualify dist/database directory to avoid
    -- conflicts.
    , testSubName       :: String
    -- | Program database to use when we want ghc, ghc-pkg, etc.
    , testProgramDb     :: ProgramDb
    -- | Package database stack (actually this changes lol)
    , testPackageDBStack :: PackageDBStack
    -- | How verbose to be
    , testVerbosity     :: Verbosity
    -- | How long we should 'threadDelay' to make sure the file timestamp is
    -- updated correctly for recompilation tests.  Nothing if we haven't
    -- calibrated yet.
    , testMtimeChangeDelay :: Maybe Int
    -- | Script environment for runghc
    , testScriptEnv :: ScriptEnv
    -- | Setup script path
    , testSetupPath :: FilePath
    -- | Skip Setup tests?
    , testSkipSetupTests :: Bool

    -- CHANGING:

    -- | Environment override
    , testEnvironment   :: [(String, Maybe String)]
    -- | When true, we invert the meaning of command execution failure
    , testShouldFail    :: Bool
    -- | The current working directory, relative to 'testSourceDir'
    , testRelativeCurrentDir :: FilePath
    -- | Says if we've initialized the per-test package DB
    , testHavePackageDb  :: Bool
363
364
    -- | Says if we're working in a sandbox
    , testHaveSandbox :: Bool
365
366
    -- | Says if we've setup a repository
    , testHaveRepo :: Bool
367
368
    -- | Says if we're testing cabal-install as setup
    , testCabalInstallAsSetup :: Bool
369
370
    -- | Says what cabal.project file to use (probed)
    , testCabalProjectFile :: FilePath
371
372
373
    -- | Cached record of the plan metadata from a new-build
    -- invocation; controlled by 'withPlan'.
    , testPlan :: Maybe Plan
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
    }

getTestEnv :: TestM TestEnv
getTestEnv = ask

------------------------------------------------------------------------
-- * Directories

-- | 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.
testCurrentDir :: TestEnv -> FilePath
testCurrentDir env = testSourceDir env </> testRelativeCurrentDir env

-- | 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.
testWorkDir :: TestEnv -> FilePath
testWorkDir env =
    testSourceDir env </> (testSubName env ++ ".dist")

Edward Z. Yang's avatar
Edward Z. Yang committed
395
396
397
-- | The absolute prefix where installs go.
testPrefixDir :: TestEnv -> FilePath
testPrefixDir env = testWorkDir env </> "usr"
398
399
400
401

-- | The absolute path to the build directory that should be used
-- for the current package in a test.
testDistDir :: TestEnv -> FilePath
402
testDistDir env = testWorkDir env </> "work" </> testRelativeCurrentDir env </> "dist"
403
404
405
406
407

-- | The absolute path to the shared package database that should
-- be used by all packages in this test.
testPackageDbDir :: TestEnv -> FilePath
testPackageDbDir env = testWorkDir env </> "packagedb"
408
409
410
411

-- | The absolute prefix where our simulated HOME directory is.
testHomeDir :: TestEnv -> FilePath
testHomeDir env = testWorkDir env </> "home"
412
413
414
415
416
417
418
419

-- | The absolute prefix of our sandbox directory
testSandboxDir :: TestEnv -> FilePath
testSandboxDir env = testWorkDir env </> "sandbox"

-- | The sandbox configuration file
testSandboxConfigFile :: TestEnv -> FilePath
testSandboxConfigFile env = testWorkDir env </> "cabal.sandbox.config"
420
421
422
423
424
425
426
427
428
429
430
431
432
433

-- | The absolute prefix of our local secure repository, which we
-- use to simulate "external" packages
testRepoDir :: TestEnv -> FilePath
testRepoDir env = testWorkDir env </> "repo"

-- | The absolute prefix of keys for the test.
testKeysDir :: TestEnv -> FilePath
testKeysDir env = testWorkDir env </> "keys"

-- | The user cabal config file
-- TODO: Not obviously working on Windows
testUserCabalConfigFile :: TestEnv -> FilePath
testUserCabalConfigFile env = testHomeDir env </> ".cabal" </> "config"