PackageTester.hs 7.52 KB
Newer Older
1
{-# LANGUAGE ScopedTypeVariables #-}
2
3
4
5
6
7
module PackageTests.PackageTester (
        PackageSpec(..),
        Success(..),
        Result(..),
        cabal_configure,
        cabal_build,
8
        cabal_test,
9
        cabal_bench,
10
11
        cabal_install,
        unregister,
tibbe's avatar
tibbe committed
12
13
        run,
        assertBuildSucceeded,
tibbe's avatar
tibbe committed
14
15
16
        assertBuildFailed,
        assertTestSucceeded,
        assertInstallSucceeded,
17
18
        assertOutputContains,
        assertOutputDoesNotContain
19
20
21
    ) where

import qualified Control.Exception.Extensible as E
22
import System.Environment (getEnv)
23
24
25
import System.Directory
import System.FilePath
import System.IO
26
import System.IO.Error (isDoesNotExistError)
tibbe's avatar
tibbe committed
27
import System.Process hiding (cwd)
28
29
30
31
32
import System.Exit
import Control.Monad
import Data.List
import Data.Maybe
import qualified Data.ByteString.Char8 as C
tibbe's avatar
tibbe committed
33
import Test.HUnit
34

tibbe's avatar
tibbe committed
35
import Distribution.Compat.CreatePipe (createPipe)
36
37
38
39
40
41
42

data PackageSpec =
    PackageSpec {
        directory  :: FilePath,
        configOpts :: [String]
    }

43
44
45
46
47
48
49
data Success = Failure
             | ConfigureSuccess
             | BuildSuccess
             | InstallSuccess
             | TestSuccess
             | BenchSuccess
             deriving (Eq, Show)
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79

data Result = Result {
        successful :: Bool,
        success    :: Success,
        outputText :: String
    }
    deriving Show

nullResult :: Result
nullResult = Result True Failure ""

recordRun :: (String, ExitCode, String) -> Success -> Result -> Result
recordRun (cmd, exitCode, exeOutput) thisSucc res =
    res {
        successful = successful res && exitCode == ExitSuccess,
        success = if exitCode == ExitSuccess then thisSucc
                                             else success res,
        outputText =
            (if null $ outputText res then "" else outputText res ++ "\n") ++
                cmd ++ "\n" ++ exeOutput
    }

cabal_configure :: PackageSpec -> IO Result
cabal_configure spec = do
    res <- doCabalConfigure spec
    record spec res
    return res

doCabalConfigure :: PackageSpec -> IO Result
doCabalConfigure spec = do
tibbe's avatar
tibbe committed
80
    cleanResult@(_, _, _) <- cabal spec ["clean"]
81
    requireSuccess cleanResult
82
83
    ghc <- getGHC
    res <- cabal spec $ ["configure", "--user", "-w", ghc] ++ configOpts spec
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
    return $ recordRun res ConfigureSuccess nullResult

doCabalBuild :: PackageSpec -> IO Result
doCabalBuild spec = do
    configResult <- doCabalConfigure spec
    if successful configResult
        then do
            res <- cabal spec ["build"]
            return $ recordRun res BuildSuccess configResult
        else
            return configResult

cabal_build :: PackageSpec -> IO Result
cabal_build spec = do
    res <- doCabalBuild spec
    record spec res
    return res

unregister :: String -> IO ()
unregister libraryName = do
104
105
    ghcPkg <- getGHCPkg
    res@(_, _, output) <- run Nothing ghcPkg ["unregister", "--user", libraryName]
106
107
108
109
110
111
112
113
114
115
    if "cannot find package" `isInfixOf` output
        then return ()
        else requireSuccess res

-- | Install this library in the user area
cabal_install :: PackageSpec -> IO Result
cabal_install spec = do
    buildResult <- doCabalBuild spec
    res <- if successful buildResult
        then do
116
            res <- cabal spec ["install"]
117
118
119
120
121
122
            return $ recordRun res InstallSuccess buildResult
        else
            return buildResult
    record spec res
    return res

ttuegel's avatar
ttuegel committed
123
124
125
cabal_test :: PackageSpec -> [String] -> IO Result
cabal_test spec extraArgs = do
    res <- cabal spec $ "test" : extraArgs
126
127
128
129
    let r = recordRun res TestSuccess nullResult
    record spec r
    return r

130
131
132
133
134
135
136
cabal_bench :: PackageSpec -> [String] -> IO Result
cabal_bench spec extraArgs = do
    res <- cabal spec $ "bench" : extraArgs
    let r = recordRun res BenchSuccess nullResult
    record spec r
    return r

137
138
-- | Returns the command that was issued, the return code, and hte output text
cabal :: PackageSpec -> [String] -> IO (String, ExitCode, String)
139
140
cabal spec cabalArgs = do
    wd <- getCurrentDirectory
141
142
    ghc <- getGHC
    r <- run (Just $ directory spec) ghc
143
             [ "--make"
144
145
-- HPC causes trouble -- see #1012
--             , "-fhpc"
tibbe's avatar
tibbe committed
146
             , "-package-conf " ++ wd </> "../dist/package.conf.inplace"
147
148
149
150
             , "Setup.hs"
             ]
    requireSuccess r
    run (Just $ directory spec) (wd </> directory spec </> "Setup") cabalArgs
151
152
153
154
155

-- | Returns the command that was issued, the return code, and hte output text
run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String)
run cwd cmd args = do
    -- Posix-specific
tibbe's avatar
tibbe committed
156
157
    (readh, writeh) <- createPipe
    pid <- runProcess cmd args cwd Nothing Nothing (Just writeh) (Just writeh)
158
159

    -- fork off a thread to start consuming the output
tibbe's avatar
tibbe committed
160
161
    output <- suckH [] readh
    hClose readh
162
163
164
165
166
167
168

    -- wait on the process
    ex <- waitForProcess pid
    let fullCmd = intercalate " " $ cmd:args
    return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd,
        ex, output)
  where
tibbe's avatar
tibbe committed
169
    suckH output h = do
170
171
        eof <- hIsEOF h
        if eof
tibbe's avatar
tibbe committed
172
            then return (reverse output)
173
174
            else do
                c <- hGetChar h
tibbe's avatar
tibbe committed
175
                suckH (c:output) h
176
177

requireSuccess :: (String, ExitCode, String) -> IO ()
178
179
180
181
requireSuccess (cmd, exitCode, output) =
    unless (exitCode == ExitSuccess) $
        assertFailure $ "Command " ++ cmd ++ " failed.\n" ++
        "output: " ++ output
182
183
184
185
186

record :: PackageSpec -> Result -> IO ()
record spec res = do
    C.writeFile (directory spec </> "test-log.txt") (C.pack $ outputText res)

187
188
------------------------------------------------------------------------
-- Test helpers
tibbe's avatar
tibbe committed
189
190
191
192
193
194
195

assertBuildSucceeded :: Result -> Assertion
assertBuildSucceeded result = unless (successful result) $
    assertFailure $
    "expected: \'setup build\' should succeed\n" ++
    "  output: " ++ outputText result

tibbe's avatar
tibbe committed
196
197
198
199
200
201
assertBuildFailed :: Result -> Assertion
assertBuildFailed result = when (successful result) $
    assertFailure $
    "expected: \'setup build\' should fail\n" ++
    "  output: " ++ outputText result

tibbe's avatar
tibbe committed
202
203
204
205
206
assertTestSucceeded :: Result -> Assertion
assertTestSucceeded result = unless (successful result) $
    assertFailure $
    "expected: \'setup test\' should succeed\n" ++
    "  output: " ++ outputText result
tibbe's avatar
tibbe committed
207
208
209
210
211
212
213
214
215
216
217
218
219
220

assertInstallSucceeded :: Result -> Assertion
assertInstallSucceeded result = unless (successful result) $
    assertFailure $
    "expected: \'setup install\' should succeed\n" ++
    "  output: " ++ outputText result

assertOutputContains :: String -> Result -> Assertion
assertOutputContains needle result =
    unless (needle `isInfixOf` (intercalate " " $ lines output)) $
    assertFailure $
    " expected: " ++ needle ++
    "in output: " ++ output
  where output = outputText result
221

222
223
224
225
226
227
228
229
assertOutputDoesNotContain :: String -> Result -> Assertion
assertOutputDoesNotContain needle result =
    when (needle `isInfixOf` (intercalate " " $ lines output)) $
    assertFailure $
    "unexpected: " ++ needle ++
    " in output: " ++ output
  where output = outputText result

230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
------------------------------------------------------------------------
-- Finding ghc and related tools
--
-- To allow the test suite to be run using other GHC versions than the
-- one symlinked as ghc, we look in the environment for GHC and
-- GHC_PKG.

lookupEnv :: String -> IO (Maybe String)
lookupEnv name =
    (fmap Just $ getEnv name)
    `E.catch` \ (e :: IOError) ->
        if isDoesNotExistError e
        then return Nothing
        else E.throw e

getGHC :: IO String
getGHC = fromMaybe "ghc" `fmap` lookupEnv "GHC"

getGHCPkg :: IO String
249
250
251
252
getGHCPkg = do
    ghc <- getGHC
    -- Somewhat brittle, but better than nothing.
    return $ "ghc-pkg" ++ drop 3 ghc