File: IntegrationTests.hs

package info (click to toggle)
haskell-cabal-install 1.24.0.1-3
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 2,700 kB
  • ctags: 31
  • sloc: haskell: 33,085; sh: 573; ansic: 36; makefile: 5
file content (310 lines) | stat: -rw-r--r-- 12,691 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
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
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
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
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
{-# LANGUAGE CPP #-}
-- | Groups black-box tests of cabal-install and configures them to test
-- the correct binary.
--
-- This file should do nothing but import tests from other modules and run
-- them with the path to the correct cabal-install binary.
module Main
       where

-- Modules from Cabal.
import Distribution.Compat.CreatePipe (createPipe)
import Distribution.Compat.Environment (setEnv)
import Distribution.Compat.Internal.TempFile (createTempDirectory)
import Distribution.Simple.Configure (findDistPrefOrDefault)
import Distribution.Simple.Program.Builtin (ghcPkgProgram)
import Distribution.Simple.Program.Db
        (defaultProgramDb, requireProgram, setProgramSearchPath)
import Distribution.Simple.Program.Find
        (ProgramSearchPathEntry(ProgramSearchPathDir), defaultProgramSearchPath)
import Distribution.Simple.Program.Types
        ( Program(..), simpleProgram, programPath)
import Distribution.Simple.Setup ( Flag(..) )
import Distribution.Simple.Utils ( findProgramVersion, copyDirectoryRecursive )
import Distribution.Verbosity (normal)

-- Third party modules.
import Control.Concurrent.Async (withAsync, wait)
import Control.Exception (bracket)
import Data.Maybe (fromMaybe)
import System.Directory
        ( canonicalizePath
        , findExecutable
        , getDirectoryContents
        , getTemporaryDirectory
        , doesDirectoryExist
        , removeDirectoryRecursive
        , doesFileExist )
import System.FilePath
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit (testCase, Assertion, assertFailure)
import Control.Monad ( filterM, forM, unless, when )
import Data.List (isPrefixOf, isSuffixOf, sort)
import Data.IORef (newIORef, writeIORef, readIORef)
import System.Exit (ExitCode(..))
import System.IO (withBinaryFile, IOMode(ReadMode))
import System.Process (runProcess, waitForProcess)
import Text.Regex.Posix ((=~))
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
import           Data.ByteString (ByteString)

#if MIN_VERSION_base(4,6,0)
import System.Environment ( getExecutablePath )
#endif

-- | Test case.
data TestCase = TestCase
    { tcName :: String -- ^ Name of the shell script
    , tcBaseDirectory :: FilePath
    , tcCategory :: String
    , tcShouldX :: String
    , tcStdOutPath :: Maybe FilePath -- ^ File path of "golden standard output"
    , tcStdErrPath :: Maybe FilePath -- ^ File path of "golden standard error"
    }

-- | Test result.
data TestResult = TestResult
    { trExitCode :: ExitCode
    , trStdOut :: ByteString
    , trStdErr :: ByteString
    , trWorkingDirectory :: FilePath
    }

-- | Cabal executable
cabalProgram :: Program
cabalProgram = (simpleProgram "cabal") {
    programFindVersion = findProgramVersion "--numeric-version" id
  }

-- | Convert test result to string.
testResultToString :: TestResult -> String
testResultToString testResult =
    exitStatus ++ "\n" ++ workingDirectory ++ "\n\n" ++ stdOut ++ "\n\n" ++ stdErr
  where
    exitStatus = "Exit status: " ++ show (trExitCode testResult)
    workingDirectory = "Working directory: " ++ (trWorkingDirectory testResult)
    stdOut = "<stdout> was:\n" ++ C8.unpack (trStdOut testResult)
    stdErr = "<stderr> was:\n" ++ C8.unpack (trStdErr testResult)

-- | Returns the command that was issued, the return code, and the output text
run :: FilePath -> String -> [String] -> IO TestResult
run cwd path args = do
  -- path is relative to the current directory; canonicalizePath makes it
  -- absolute, so that runProcess will find it even when changing directory.
  path' <- canonicalizePath path

  (pid, hReadStdOut, hReadStdErr) <- do
    -- Create pipes for StdOut and StdErr
    (hReadStdOut, hWriteStdOut) <- createPipe
    (hReadStdErr, hWriteStdErr) <- createPipe
    -- Run the process
    pid <- runProcess path' args (Just cwd) Nothing Nothing (Just hWriteStdOut) (Just hWriteStdErr)
    -- Return the pid and read ends of the pipes
    return (pid, hReadStdOut, hReadStdErr)
  -- Read subprocess output using asynchronous threads; we need to
  -- do this aynchronously to avoid deadlocks due to buffers filling
  -- up.
  withAsync (B.hGetContents hReadStdOut) $ \stdOutAsync -> do
    withAsync (B.hGetContents hReadStdErr) $ \stdErrAsync -> do
      -- Wait for the subprocess to terminate
      exitcode <- waitForProcess pid
      -- We can now be sure that no further output is going to arrive,
      -- so we wait for the results of the asynchronous reads.
      stdOut <- wait stdOutAsync
      stdErr <- wait stdErrAsync
      -- Done
      return $ TestResult exitcode stdOut stdErr cwd

-- | Get a list of all names in a directory, excluding all hidden or
-- system files/directories such as '.', '..'  or any files/directories
-- starting with a '.'.
listDirectory :: FilePath -> IO [String]
listDirectory directory = do
  fmap (filter notHidden) $ getDirectoryContents directory
  where
    notHidden = not . isHidden
    isHidden name = "." `isPrefixOf` name

-- | List a directory as per 'listDirectory', but return an empty list
-- in case the directory does not exist.
listDirectoryLax :: FilePath -> IO [String]
listDirectoryLax directory = do
  d <- doesDirectoryExist directory
  if d then
    listDirectory directory
  else
    return [ ]

pathIfExists :: FilePath -> IO (Maybe FilePath)
pathIfExists p = do
  e <- doesFileExist p
  if e then
    return $ Just p
    else
      return Nothing

fileMatchesString :: FilePath -> ByteString -> IO Bool
fileMatchesString p s = do
  withBinaryFile p ReadMode $ \h -> do
    expected <- (C8.lines . normalizeLinebreaks) `fmap` B.hGetContents h -- Strict
    let actual = C8.lines $ normalizeLinebreaks s
    return $ length expected == length actual &&
             and (zipWith matches expected actual)
  where
    matches :: ByteString -> ByteString -> Bool
    matches pattern line
        | C8.pack "RE:" `B.isPrefixOf` pattern = line =~ C8.drop 3 pattern
        | otherwise                            = line == pattern

    -- This is a bit of a hack, but since we're comparing
    -- *text* output, we should be OK.
    normalizeLinebreaks = B.filter (not . ((==) 13))

mustMatch :: TestResult -> String -> ByteString -> Maybe FilePath -> Assertion
mustMatch _          _          _      Nothing         =  return ()
mustMatch testResult handleName actual (Just expected) = do
  m <- fileMatchesString expected actual
  unless m $ assertFailure $
      "<" ++ handleName ++ "> did not match file '"
      ++ expected ++ "'.\n" ++ testResultToString testResult

discoverTestCategories :: FilePath -> IO [String]
discoverTestCategories directory = do
  names <- listDirectory directory
  fmap sort $ filterM (\name -> doesDirectoryExist $ directory </> name) names

discoverTestCases :: FilePath -> String -> String -> IO [TestCase]
discoverTestCases baseDirectory category shouldX = do
  -- Find the names of the shell scripts
  names <- fmap (filter isTestCase) $ listDirectoryLax directory
  -- Fill in TestCase for each script
  forM (sort names) $ \name -> do
    stdOutPath <- pathIfExists $ directory </> name `replaceExtension` ".out"
    stdErrPath <- pathIfExists $ directory </> name `replaceExtension` ".err"
    return $ TestCase { tcName = name
                      , tcBaseDirectory = baseDirectory
                      , tcCategory = category
                      , tcShouldX = shouldX
                      , tcStdOutPath = stdOutPath
                      , tcStdErrPath = stdErrPath
                      }
  where
    directory = baseDirectory </> category </> shouldX
    isTestCase name = ".sh" `isSuffixOf` name

createTestCases :: [TestCase] -> (TestCase -> Assertion) -> IO [TestTree]
createTestCases testCases mk =
  return $ (flip map) testCases $ \tc -> testCase (tcName tc ++ suffix tc) $ mk tc
  where
    suffix tc = case (tcStdOutPath tc, tcStdErrPath tc) of
      (Nothing, Nothing) -> " (ignoring stdout+stderr)"
      (Just _ , Nothing) -> " (ignoring stderr)"
      (Nothing, Just _ ) -> " (ignoring stdout)"
      (Just _ , Just _ ) -> ""

runTestCase :: (TestResult -> Assertion) -> TestCase -> IO ()
runTestCase assertResult tc = do
  doRemove <- newIORef False
  bracket createWorkDirectory (removeWorkDirectory doRemove) $ \workDirectory -> do
    -- Run
    let scriptDirectory = workDirectory </> tcShouldX tc
    sh <- fmap (fromMaybe $ error "Cannot find 'sh' executable") $ findExecutable "sh"
    testResult <- run scriptDirectory sh [ "-e", tcName tc]
    -- Assert that we got what we expected
    assertResult testResult
    mustMatch testResult "stdout" (trStdOut testResult) (tcStdOutPath tc)
    mustMatch testResult "stderr" (trStdErr testResult) (tcStdErrPath tc)
    -- Only remove working directory if test succeeded
    writeIORef doRemove True
  where
    createWorkDirectory = do
      -- Create the temporary directory
      tempDirectory <- getTemporaryDirectory
      workDirectory <- createTempDirectory tempDirectory "cabal-install-test"
      -- Copy all the files from the category into the working directory.
      copyDirectoryRecursive normal
        (tcBaseDirectory tc </> tcCategory tc)
        workDirectory
      -- Done
      return workDirectory
    removeWorkDirectory doRemove workDirectory = do
        remove <- readIORef doRemove
        when remove $ removeDirectoryRecursive workDirectory

makeShouldXTests :: FilePath -> String -> String -> (TestResult -> Assertion) -> IO [TestTree]
makeShouldXTests baseDirectory category shouldX assertResult = do
  testCases <- discoverTestCases baseDirectory category shouldX
  createTestCases testCases $ \tc ->
      runTestCase assertResult tc

makeShouldRunTests :: FilePath -> String -> IO [TestTree]
makeShouldRunTests baseDirectory category = do
  makeShouldXTests baseDirectory category "should_run" $ \testResult -> do
    case trExitCode testResult of
      ExitSuccess ->
        return () -- We're good
      ExitFailure _ ->
        assertFailure $ "Unexpected exit status.\n\n" ++ testResultToString testResult

makeShouldFailTests :: FilePath -> String -> IO [TestTree]
makeShouldFailTests baseDirectory category = do
  makeShouldXTests baseDirectory category "should_fail" $ \testResult -> do
    case trExitCode testResult of
      ExitSuccess ->
        assertFailure $ "Unexpected exit status.\n\n" ++ testResultToString testResult
      ExitFailure _ ->
        return () -- We're good

discoverCategoryTests :: FilePath -> String -> IO [TestTree]
discoverCategoryTests baseDirectory category = do
  srTests <- makeShouldRunTests baseDirectory category
  sfTests <- makeShouldFailTests baseDirectory category
  return [ testGroup "should_run" srTests
         , testGroup "should_fail" sfTests
         ]

main :: IO ()
main = do
  -- Find executables and build directories, etc.
  distPref <- guessDistDir
  buildDir <- canonicalizePath (distPref </> "build/cabal")
  let programSearchPath = ProgramSearchPathDir buildDir : defaultProgramSearchPath
  (cabal, _) <- requireProgram normal cabalProgram (setProgramSearchPath programSearchPath defaultProgramDb)
  (ghcPkg, _) <- requireProgram normal ghcPkgProgram defaultProgramDb
  baseDirectory <- canonicalizePath $ "tests" </> "IntegrationTests"
  -- Set up environment variables for test scripts
  setEnv "GHC_PKG" $ programPath ghcPkg
  setEnv "CABAL" $ programPath cabal
  -- Define default arguments
  setEnv "CABAL_ARGS" $ "--config-file=config-file"
  setEnv "CABAL_ARGS_NO_CONFIG_FILE" " "
  -- Discover all the test caregories
  categories <- discoverTestCategories baseDirectory
  -- Discover tests in each category
  tests <- forM categories $ \category -> do
    categoryTests <- discoverCategoryTests baseDirectory category
    return (category, categoryTests)
  -- Map into a test tree
  let testTree = map (\(category, categoryTests) -> testGroup category categoryTests) tests
  -- Run the tests
  defaultMain $ testGroup "Integration Tests" $ testTree

-- See this function in Cabal's PackageTests. If you update this,
-- update its copy in cabal-install.  (Why a copy here? I wanted
-- to try moving this into the Cabal library, but to do this properly
-- I'd have to BC'ify getExecutablePath, and then it got hairy, so
-- I aborted and did something simple.)
guessDistDir :: IO FilePath
guessDistDir = do
#if MIN_VERSION_base(4,6,0)
    exe_path <- canonicalizePath =<< getExecutablePath
    let dist0 = dropFileName exe_path </> ".." </> ".."
    b <- doesFileExist (dist0 </> "setup-config")
#else
    let dist0 = error "no path"
        b = False
#endif
    -- Method (2)
    if b then canonicalizePath dist0
         else findDistPrefOrDefault NoFlag >>= canonicalizePath