@@ -1,3 +1,5 @@
1+import Control.Monad (when, unless, foldM)
2+import Data.List (sort)
13import qualified Data.Map as Map
24import qualified Data.Set as Set
35import Data.Version (showVersion)
@@ -7,13 +9,112 @@ import Stackage.NarrowDatabase
79import Stackage.PackageList
810import Stackage.Types
911import 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)
17+
18+data Mismatch = OnlyDryRun String | OnlySimpleList String
19+ deriving Show
20+
21+extraCore :: Set PackageName
22+extraCore = Set.singleton $ PackageName "binary"
23+
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
30+ "HTTP"
31+ -- Requires a special hspec-meta which is not yet available from
32+ -- Hackage.
33+ , "hspec"
34+ ]
1035
1136main :: IO ()
1237main = do
1338 userPackages <- loadPackageList "package-list.txt"
1439 hp <- loadHaskellPlatform
1540 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
1742 final <- narrowPackageDB pdb $ Set.fromList $ Map.keys allPackages
18− putStr "cabal-dev install -fnetwork23 --enable-tests "
19− mapM_ (\(PackageName p, v) -> putStr $ p ++ "-" ++ showVersion v ++ " ") $ Map.toList final
43+ let simpleList = map (\(PackageName p, v) -> p ++ "-" ++ showVersion v) $ Map.toList final
44+ writeFile "to-install.txt" $ unlines simpleList
45+
46+ rm_r "cabal-dev"
47+
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
52+ if null mismatches
53+ then do
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"
60+ rm_r testdir
61+ createDirectory testdir
62+ allPass <- foldM (runTestSuite testdir) True $ zip simpleList $ Map.toList final
63+ if allPass
64+ then putStrLn "All test suites pass"
65+ else putStrLn "There were failures, please see the logs in runtests"
66+ else do
67+ putStrLn "Found the following mismtaches"
68+ mapM_ print mismatches
69+
70+rm_r :: FilePath -> IO ()
71+rm_r fp = do
72+ exists <- doesDirectoryExist fp
73+ when exists $ removeDirectoryRecursive fp
74+
75+runTestSuite :: FilePath -> Bool -> (String, (PackageName, Version)) -> IO Bool
76+runTestSuite testdir prevPassed (package, (packageName, _)) = do
77+ passed <- 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)
81+ then return False
82+ else do
83+ putStrLn dir
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)
87+ then return False
88+ else do
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)
92+ then return False
93+ else do
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
98+ if passed
99+ then do
100+ removeFile logfile
101+ when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
102+ else putStrLn $ "Test suite failed: " ++ package
103+ rm_r dir
104+ return $! prevPassed && (passed || expectedFailure)
105+ where
106+ logfile = testdir </> package <.> "log"
107+ dir = testdir </> package
108+ getHandle mode = withBinaryFile logfile mode
109+
110+getMismatches :: [String] -> [String] -> [Mismatch]
111+getMismatches =
112+ go
113+ where
114+ go [] y = map OnlySimpleList y
115+ go x [] = map OnlyDryRun x
116+ go (x:xs) (y:ys) =
117+ case compare x y of
118+ EQ -> go xs ys
119+ LT -> OnlyDryRun x : go xs (y:ys)
120+ GT -> OnlySimpleList y : go (x:xs) ys