@@ -1,3 +1,5 @@
1+import Control.Monad (when, unless, foldM)
2+import Data.List (sort)
1import qualified Data.Map as Map
3import qualified Data.Map as Map
2import qualified Data.Set as Set
4import qualified Data.Set as Set
3import Data.Version (showVersion)
5import Data.Version (showVersion)
@@ -7,13 +9,112 @@ import Stackage.NarrowDatabase
7import Stackage.PackageList
9import Stackage.PackageList
8import Stackage.Types
10import Stackage.Types
9import Stackage.Util
11import Stackage.Util
12+import System.Directory (doesDirectoryExist, removeDirectoryRecursive, removeFile, createDirectory)
13+import System.Process (readProcess, waitForProcess, runProcess)
14+import System.Exit (ExitCode (ExitSuccess), exitWith)
15+import System.FilePath ((</>), (<.>))
16+import System.IO (IOMode (WriteMode, AppendMode), withBinaryFile)
18+data Mismatch = OnlyDryRun String | OnlySimpleList String
21+extraCore :: Set PackageName
22+extraCore = Set.singleton $ PackageName "binary"
24+-- Test suites which are expected to fail for some reason. The test suite
25+-- will still be run and logs kept, but a failure will not indicate an
26+-- error in our package combination.
27+expectedFailures :: Set PackageName
28+expectedFailures = Set.fromList $ map PackageName
29+ [ -- Requires an old version of WAI and Warp for tests
31+ -- Requires a special hspec-meta which is not yet available from
11main :: IO ()
36main :: IO ()
13 userPackages <- loadPackageList "package-list.txt"
38 userPackages <- loadPackageList "package-list.txt"
14 hp <- loadHaskellPlatform
39 hp <- loadHaskellPlatform
15 let allPackages = Map.union userPackages $ identsToRanges (hplibs hp)
40 let allPackages = Map.union userPackages $ identsToRanges (hplibs hp)
16− pdb <- loadPackageDB (Set.map (\(PackageIdentifier p _) -> p) (hpcore hp)) allPackages
41+ pdb <- loadPackageDB (extraCore `Set.union` Set.map (\(PackageIdentifier p _) -> p) (hpcore hp)) allPackages
17 final <- narrowPackageDB pdb $ Set.fromList $ Map.keys allPackages
42 final <- narrowPackageDB pdb $ Set.fromList $ Map.keys allPackages
18− putStr "cabal-dev install -fnetwork23 --enable-tests "
43+ let simpleList = map (\(PackageName p, v) -> p ++ "-" ++ showVersion v) $ Map.toList final
19− mapM_ (\(PackageName p, v) -> putStr $ p ++ "-" ++ showVersion v ++ " ") $ Map.toList final
44+ writeFile "to-install.txt" $ unlines simpleList
48+ dryRun' <- readProcess "cabal-dev" ("install":"--dry-run":"-fnetwork23":simpleList) ""
49+ writeFile "dry-run.txt" dryRun'
50+ let dryRun = sort $ drop 2 $ lines dryRun'
51+ let mismatches = getMismatches dryRun simpleList
54+ putStrLn "No mismatches, good to go!"
55+ ph <- withBinaryFile "build.log" WriteMode $ \handle -> runProcess "cabal-dev" ("install":"-fnetwork23":simpleList) Nothing Nothing Nothing (Just handle) (Just handle)
56+ ec <- waitForProcess ph
57+ unless (ec == ExitSuccess) $ exitWith ec
58+ putStrLn "Environment built, beginning individual test suites"
59+ let testdir = "runtests"
61+ createDirectory testdir
62+ allPass <- foldM (runTestSuite testdir) True $ zip simpleList $ Map.toList final
64+ then putStrLn "All test suites pass"
65+ else putStrLn "There were failures, please see the logs in runtests"
67+ putStrLn "Found the following mismtaches"
68+ mapM_ print mismatches
70+rm_r :: FilePath -> IO ()
72+ exists <- doesDirectoryExist fp
73+ when exists $ removeDirectoryRecursive fp
75+runTestSuite :: FilePath -> Bool -> (String, (PackageName, Version)) -> IO Bool
76+runTestSuite testdir prevPassed (package, (packageName, _)) = do
78+ ph1 <- getHandle WriteMode $ \handle -> runProcess "cabal-dev" ["unpack", package] (Just testdir) Nothing Nothing (Just handle) (Just handle)
79+ ec1 <- waitForProcess ph1
80+ if (ec1 /= ExitSuccess)
84+ ph2 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["-s", "../../cabal-dev", "configure", "--enable-tests"] (Just dir) Nothing Nothing (Just handle) (Just handle)
85+ ec2 <- waitForProcess ph2
86+ if (ec2 /= ExitSuccess)
89+ ph3 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["build"] (Just dir) Nothing Nothing (Just handle) (Just handle)
90+ ec3 <- waitForProcess ph3
91+ if (ec3 /= ExitSuccess)
94+ ph4 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["test"] (Just dir) Nothing Nothing (Just handle) (Just handle)
95+ ec4 <- waitForProcess ph4
96+ return $ ec4 == ExitSuccess
97+ let expectedFailure = packageName `Set.member` expectedFailures
101+ when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
102+ else putStrLn $ "Test suite failed: " ++ package
104+ return $! prevPassed && (passed || expectedFailure)
106+ logfile = testdir </> package <.> "log"
107+ dir = testdir </> package
108+ getHandle mode = withBinaryFile logfile mode
110+getMismatches :: [String] -> [String] -> [Mismatch]
114+ go [] y = map OnlySimpleList y
115+ go x [] = map OnlyDryRun x
119+ LT -> OnlyDryRun x : go xs (y:ys)
120+ GT -> OnlySimpleList y : go (x:xs) ys