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

-- You can set the following VERBOSE environment variable to control
-- the verbosity of the output generated by this module.
tibbe's avatar
tibbe committed
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
module PackageTests.PackageTester
    ( PackageSpec(..)
    , Success(..)
    , Result(..)

    -- * Running cabal commands
    , cabal_configure
    , cabal_build
    , cabal_test
    , cabal_bench
    , cabal_install
    , unregister
    , compileSetup
    , run

    -- * Test helpers
    , assertBuildSucceeded
    , assertBuildFailed
    , assertTestSucceeded
    , assertInstallSucceeded
    , assertOutputContains
    , assertOutputDoesNotContain
27
28
29
    ) where

import qualified Control.Exception.Extensible as E
tibbe's avatar
tibbe committed
30
31
32
33
import Control.Monad
import qualified Data.ByteString.Char8 as C
import Data.List
import Data.Maybe
34
import System.Directory (canonicalizePath, doesFileExist, getCurrentDirectory)
35
import System.Environment (getEnv)
tibbe's avatar
tibbe committed
36
import System.Exit (ExitCode(ExitSuccess))
37
38
import System.FilePath
import System.IO
39
import System.IO.Error (isDoesNotExistError)
tibbe's avatar
tibbe committed
40
41
import System.Process (runProcess, waitForProcess)
import Test.HUnit (Assertion, assertFailure)
42

refold's avatar
refold committed
43
import Distribution.Simple.BuildPaths (exeExtension)
tibbe's avatar
tibbe committed
44
import Distribution.Compat.CreatePipe (createPipe)
45
46
47
import Distribution.ReadE (readEOrFail)
import Distribution.Verbosity (Verbosity, deafening, flagToVerbosity, normal,
                               verbose)
48

tibbe's avatar
tibbe committed
49
50
51
data PackageSpec = PackageSpec
    { directory  :: FilePath
    , configOpts :: [String]
52
53
    }

54
55
56
57
58
59
60
data Success = Failure
             | ConfigureSuccess
             | BuildSuccess
             | InstallSuccess
             | TestSuccess
             | BenchSuccess
             deriving (Eq, Show)
61

62
63
64
65
66
data Result = Result
    { successful :: Bool
    , success    :: Success
    , outputText :: String
    } deriving Show
67
68
69
70

nullResult :: Result
nullResult = Result True Failure ""

tibbe's avatar
tibbe committed
71
72
73
------------------------------------------------------------------------
-- * Running cabal commands

74
75
recordRun :: (String, ExitCode, String) -> Success -> Result -> Result
recordRun (cmd, exitCode, exeOutput) thisSucc res =
76
77
78
79
    res { successful = successful res && exitCode == ExitSuccess
        , success    = if exitCode == ExitSuccess then thisSucc
                       else success res
        , outputText =
80
            (if null $ outputText res then "" else outputText res ++ "\n") ++
81
82
            cmd ++ "\n" ++ exeOutput
        }
83

tibbe's avatar
tibbe committed
84
85
86
cabal_configure :: PackageSpec -> FilePath -> IO Result
cabal_configure spec ghcPath = do
    res <- doCabalConfigure spec ghcPath
87
88
89
    record spec res
    return res

tibbe's avatar
tibbe committed
90
91
92
doCabalConfigure :: PackageSpec -> FilePath -> IO Result
doCabalConfigure spec ghcPath = do
    cleanResult@(_, _, _) <- cabal spec ["clean"] ghcPath
93
    requireSuccess cleanResult
tibbe's avatar
tibbe committed
94
95
96
    res <- cabal spec
           (["configure", "--user", "-w", ghcPath] ++ configOpts spec)
           ghcPath
97
98
    return $ recordRun res ConfigureSuccess nullResult

tibbe's avatar
tibbe committed
99
100
101
doCabalBuild :: PackageSpec -> FilePath -> IO Result
doCabalBuild spec ghcPath = do
    configResult <- doCabalConfigure spec ghcPath
102
103
    if successful configResult
        then do
tibbe's avatar
tibbe committed
104
            res <- cabal spec ["build", "-v"] ghcPath
105
106
107
108
            return $ recordRun res BuildSuccess configResult
        else
            return configResult

tibbe's avatar
tibbe committed
109
110
111
cabal_build :: PackageSpec -> FilePath -> IO Result
cabal_build spec ghcPath = do
    res <- doCabalBuild spec ghcPath
112
113
114
    record spec res
    return res

tibbe's avatar
tibbe committed
115
116
117
unregister :: String -> FilePath -> IO ()
unregister libraryName ghcPkgPath = do
    res@(_, _, output) <- run Nothing ghcPkgPath ["unregister", "--user", libraryName]
118
119
120
121
122
    if "cannot find package" `isInfixOf` output
        then return ()
        else requireSuccess res

-- | Install this library in the user area
tibbe's avatar
tibbe committed
123
124
125
cabal_install :: PackageSpec -> FilePath -> IO Result
cabal_install spec ghcPath = do
    buildResult <- doCabalBuild spec ghcPath
126
127
    res <- if successful buildResult
        then do
tibbe's avatar
tibbe committed
128
            res <- cabal spec ["install"] ghcPath
129
130
131
132
133
134
            return $ recordRun res InstallSuccess buildResult
        else
            return buildResult
    record spec res
    return res

tibbe's avatar
tibbe committed
135
136
137
cabal_test :: PackageSpec -> [String] -> FilePath -> IO Result
cabal_test spec extraArgs ghcPath = do
    res <- cabal spec ("test" : extraArgs) ghcPath
138
139
140
141
    let r = recordRun res TestSuccess nullResult
    record spec r
    return r

tibbe's avatar
tibbe committed
142
143
144
cabal_bench :: PackageSpec -> [String] -> FilePath -> IO Result
cabal_bench spec extraArgs ghcPath = do
    res <- cabal spec ("bench" : extraArgs) ghcPath
145
146
147
148
    let r = recordRun res BenchSuccess nullResult
    record spec r
    return r

tibbe's avatar
tibbe committed
149
150
compileSetup :: FilePath -> FilePath -> IO ()
compileSetup packageDir ghcPath = do
151
    wd <- getCurrentDirectory
tibbe's avatar
tibbe committed
152
    r <- run (Just $ packageDir) ghcPath
153
         [ "--make"
154
-- HPC causes trouble -- see #1012
155
156
157
158
--       , "-fhpc"
         , "-package-conf " ++ wd </> "../dist/package.conf.inplace"
         , "Setup.hs"
         ]
159
    requireSuccess r
160

Mikhail Glushenkov's avatar
Typo.    
Mikhail Glushenkov committed
161
-- | Returns the command that was issued, the return code, and the output text.
tibbe's avatar
tibbe committed
162
163
cabal :: PackageSpec -> [String] -> FilePath -> IO (String, ExitCode, String)
cabal spec cabalArgs ghcPath = do
164
165
166
    customSetup <- doesFileExist (directory spec </> "Setup.hs")
    if customSetup
        then do
tibbe's avatar
tibbe committed
167
            compileSetup (directory spec) ghcPath
168
169
            path <- canonicalizePath $ directory spec </> "Setup"
            run (Just $ directory spec) path cabalArgs
170
        else do
171
172
173
            -- Use shared Setup executable (only for Simple build types).
            path <- canonicalizePath "Setup"
            run (Just $ directory spec) path cabalArgs
174
175
176

-- | Returns the command that was issued, the return code, and hte output text
run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String)
177
178
run cwd path args = do
    verbosity <- getVerbosity
179
180
    -- 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
181
    path' <- do pathExists <- doesFileExist path
182
                canonicalizePath (if pathExists then path else path <.> exeExtension)
refold's avatar
refold committed
183
    printRawCommandAndArgs verbosity path' args
tibbe's avatar
tibbe committed
184
    (readh, writeh) <- createPipe
refold's avatar
refold committed
185
    pid <- runProcess path' args cwd Nothing Nothing (Just writeh) (Just writeh)
186
187

    -- fork off a thread to start consuming the output
188
    out <- suckH [] readh
tibbe's avatar
tibbe committed
189
    hClose readh
190

191
192
    -- wait for the program to terminate
    exitcode <- waitForProcess pid
refold's avatar
refold committed
193
    let fullCmd = unwords (path' : args)
194
    return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd, exitcode, out)
195
  where
tibbe's avatar
tibbe committed
196
    suckH output h = do
197
198
        eof <- hIsEOF h
        if eof
tibbe's avatar
tibbe committed
199
            then return (reverse output)
200
201
            else do
                c <- hGetChar h
tibbe's avatar
tibbe committed
202
                suckH (c:output) h
203

204
205
206
-- Copied from Distribution/Simple/Utils.hs
printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
printRawCommandAndArgs verbosity path args
207
208
209
    | verbosity >= deafening = print (path, args)
    | verbosity >= verbose   = putStrLn $ unwords (path : args)
    | otherwise              = return ()
210

211
requireSuccess :: (String, ExitCode, String) -> IO ()
212
213
214
215
requireSuccess (cmd, exitCode, output) =
    unless (exitCode == ExitSuccess) $
        assertFailure $ "Command " ++ cmd ++ " failed.\n" ++
        "output: " ++ output
216
217
218
219
220

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

221
------------------------------------------------------------------------
tibbe's avatar
tibbe committed
222
-- * Test helpers
tibbe's avatar
tibbe committed
223
224
225
226
227
228
229

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

tibbe's avatar
tibbe committed
230
231
232
233
234
235
assertBuildFailed :: Result -> Assertion
assertBuildFailed result = when (successful result) $
    assertFailure $
    "expected: \'setup build\' should fail\n" ++
    "  output: " ++ outputText result

tibbe's avatar
tibbe committed
236
237
238
239
240
assertTestSucceeded :: Result -> Assertion
assertTestSucceeded result = unless (successful result) $
    assertFailure $
    "expected: \'setup test\' should succeed\n" ++
    "  output: " ++ outputText result
tibbe's avatar
tibbe committed
241
242
243
244
245
246
247
248
249

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 =
refold's avatar
refold committed
250
    unless (needle `isInfixOf` (concatOutput output)) $
tibbe's avatar
tibbe committed
251
    assertFailure $
refold's avatar
refold committed
252
253
    " expected: " ++ needle ++ "\n" ++
    " in output: " ++ output ++ ""
tibbe's avatar
tibbe committed
254
  where output = outputText result
255

256
257
assertOutputDoesNotContain :: String -> Result -> Assertion
assertOutputDoesNotContain needle result =
refold's avatar
refold committed
258
    when (needle `isInfixOf` (concatOutput output)) $
259
260
261
262
263
    assertFailure $
    "unexpected: " ++ needle ++
    " in output: " ++ output
  where output = outputText result

refold's avatar
refold committed
264
265
266
267
-- | Replace line breaks with spaces, correctly handling "\r\n".
concatOutput :: String -> String
concatOutput = unwords . lines . filter ((/=) '\r')

268
------------------------------------------------------------------------
tibbe's avatar
tibbe committed
269
-- Verbosity
270
271
272
273
274
275
276
277
278

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

279
280
281
282
-- TODO: Convert to a "-v" flag instead.
getVerbosity :: IO Verbosity
getVerbosity = do
    maybe normal (readEOrFail flagToVerbosity) `fmap` lookupEnv "VERBOSE"