@@ -1,104 +0,0 @@
1−import Control.Monad (when, unless, foldM)
2−import Data.List (sort)
3−import qualified Data.Map as Map
4−import qualified Data.Set as Set
5−import Data.Version (showVersion)
6−import Stackage.HaskellPlatform
7−import Stackage.LoadDatabase
8−import Stackage.NarrowDatabase
9−import Stackage.Types
10−import Stackage.Util
11−import Stackage.Config
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−main :: IO ()
22−main = do
23− hp <- loadHaskellPlatform
24− let allPackages = Map.union stablePackages $ identsToRanges (hplibs hp)
25− pdb <- loadPackageDB (extraCore `Set.union` Set.map (\(PackageIdentifier p _) -> p) (hpcore hp)) allPackages
26− final <- narrowPackageDB pdb $ Set.fromList $ Map.keys allPackages
27− let simpleList = map (\(PackageName p, v) -> p ++ "-" ++ showVersion v) $ Map.toList final
28− writeFile "to-install.txt" $ unlines simpleList
29−
30− rm_r "cabal-dev"
31−
32− dryRun' <- readProcess "cabal-dev" ("install":"--dry-run":"-fnetwork23":simpleList) ""
33− writeFile "dry-run.txt" dryRun'
34− let dryRun = sort $ drop 2 $ lines dryRun'
35− let mismatches = getMismatches dryRun simpleList
36− if null mismatches
37− then do
38− putStrLn "No mismatches, good to go!"
39− ph <- withBinaryFile "build.log" WriteMode $ \handle -> runProcess "cabal-dev" ("install":"-fnetwork23":simpleList) Nothing Nothing Nothing (Just handle) (Just handle)
40− ec <- waitForProcess ph
41− unless (ec == ExitSuccess) $ exitWith ec
42− putStrLn "Environment built, beginning individual test suites"
43− let testdir = "runtests"
44− rm_r testdir
45− createDirectory testdir
46− allPass <- foldM (runTestSuite testdir) True $ zip simpleList $ Map.toList final
47− if allPass
48− then putStrLn "All test suites pass"
49− else putStrLn "There were failures, please see the logs in runtests"
50− else do
51− putStrLn "Found the following mismtaches"
52− mapM_ print mismatches
53−
54−rm_r :: FilePath -> IO ()
55−rm_r fp = do
56− exists <- doesDirectoryExist fp
57− when exists $ removeDirectoryRecursive fp
58−
59−runTestSuite :: FilePath -> Bool -> (String, (PackageName, Version)) -> IO Bool
60−runTestSuite testdir prevPassed (package, (packageName, _)) = do
61− passed <- do
62− ph1 <- getHandle WriteMode $ \handle -> runProcess "cabal-dev" ["unpack", package] (Just testdir) Nothing Nothing (Just handle) (Just handle)
63− ec1 <- waitForProcess ph1
64− if (ec1 /= ExitSuccess)
65− then return False
66− else do
67− putStrLn dir
68− ph2 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["-s", "../../cabal-dev", "configure", "--enable-tests"] (Just dir) Nothing Nothing (Just handle) (Just handle)
69− ec2 <- waitForProcess ph2
70− if (ec2 /= ExitSuccess)
71− then return False
72− else do
73− ph3 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["build"] (Just dir) Nothing Nothing (Just handle) (Just handle)
74− ec3 <- waitForProcess ph3
75− if (ec3 /= ExitSuccess)
76− then return False
77− else do
78− ph4 <- getHandle AppendMode $ \handle -> runProcess "cabal-dev" ["test"] (Just dir) Nothing Nothing (Just handle) (Just handle)
79− ec4 <- waitForProcess ph4
80− return $ ec4 == ExitSuccess
81− let expectedFailure = packageName `Set.member` expectedFailures
82− if passed
83− then do
84− removeFile logfile
85− when expectedFailure $ putStrLn $ package ++ " passed, but I didn't think it would."
86− else putStrLn $ "Test suite failed: " ++ package
87− rm_r dir
88− return $! prevPassed && (passed || expectedFailure)
89− where
90− logfile = testdir </> package <.> "log"
91− dir = testdir </> package
92− getHandle mode = withBinaryFile logfile mode
93−
94−getMismatches :: [String] -> [String] -> [Mismatch]
95−getMismatches =
96− go
97− where
98− go [] y = map OnlySimpleList y
99− go x [] = map OnlyDryRun x
100− go (x:xs) (y:ys) =
101− case compare x y of
102− EQ -> go xs ys
103− LT -> OnlyDryRun x : go xs (y:ys)
104− GT -> OnlySimpleList y : go (x:xs) ys