Stackage/Test.hs · stackage

1module Stackage.Test

2 ( runTestSuites

3 ) where

4

5import Control.Monad (foldM, unless, when)

6import qualified Data.Map as Map

7import qualified Data.Set as Set

8import Stackage.Config

9import Stackage.Types

10import Stackage.Util

11import System.Directory (createDirectory, removeFile)

12import System.Exit (ExitCode (ExitSuccess))

13import System.FilePath ((<.>), (</>))

14import System.IO (IOMode (WriteMode, AppendMode),

15 withBinaryFile)

16import System.Process (runProcess, waitForProcess)

17

18runTestSuites :: InstallInfo -> IO ()

19runTestSuites ii = do

20 let testdir = "runtests"

21 rm_r testdir

22 createDirectory testdir

23 allPass <- foldM (runTestSuite testdir) True $ Map.toList $ iiPackages ii

24 unless allPass $ error $ "There were failures, please see the logs in " ++ testdir

25

26runTestSuite :: FilePath -> Bool -> (PackageName, Version) -> IO Bool

27runTestSuite testdir prevPassed pair@(packageName, _) = do

28 passed <- do

29 ph1 <- getHandle WriteMode $ \handle -> runProcess "cabal" ["unpack", package] (Just testdir) Nothing Nothing (Just handle) (Just handle)

30 ec1 <- waitForProcess ph1

31 if (ec1 /= ExitSuccess)

32 then return False

33 else do

34 ph2 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["-s", "../../cabal-dev", "configure", "--enable-tests"] (Just dir) Nothing Nothing (Just handle) (Just handle)

35 ec2 <- waitForProcess ph2

36 if (ec2 /= ExitSuccess)

37 then return False

38 else do

39 ph3 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["build"] (Just dir) Nothing Nothing (Just handle) (Just handle)

40 ec3 <- waitForProcess ph3

41 if (ec3 /= ExitSuccess)

42 then return False

43 else do

44 ph4 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["test"] (Just dir) Nothing Nothing (Just handle) (Just handle)

45 ec4 <- waitForProcess ph4

46 if (ec4 /= ExitSuccess)

47 then return False

48 else do

49 ph5 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["haddock"] (Just dir) Nothing Nothing (Just handle) (Just handle)

50 ec5 <- waitForProcess ph5

51 return $ ec5 == ExitSuccess

52 let expectedFailure = packageName `Set.member` expectedFailures

53 if passed

54 then do

55 removeFile logfile

56 when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."

57 else putStrLn $ "Test suite failed: " ++ package

58 rm_r dir

59 return $! prevPassed && (passed || expectedFailure)

60 where

61 logfile = testdir </> package <.> "log"

62 dir = testdir </> package

63 getHandle mode = withBinaryFile logfile mode

64 package = packageVersionString pair