hackager (empty) → 0.2.0.0
raw patch · 16 files changed
+1364/−0 lines, 16 filesdep +Cabaldep +basedep +containerssetup-changed
Dependencies added: Cabal, base, containers, directory, filepath, mtl, process
Files
- HACKING.md +28/−0
- LICENSE +31/−0
- README.md +93/−0
- Setup.hs +5/−0
- TODO.md +6/−0
- hackager.cabal +44/−0
- src/Build.hs +190/−0
- src/BuildManager.hs +87/−0
- src/BuildTools.hs +88/−0
- src/HackageMonad.hs +344/−0
- src/Hackager.hs +52/−0
- src/Parallel.hs +28/−0
- src/Record.hs +36/−0
- src/RecordOptions.hs +154/−0
- src/Report.hs +129/−0
- src/Utils.hs +49/−0
+ HACKING.md view
@@ -0,0 +1,28 @@+# Hacking on Hackager++Source files:++ * `Hackager.hs` -- Main entry point, parses command line arguments.+ * `Record.hs` -- Entry point for record (build) mode.+ * `HackageMonad.hs` -- Monad and support for build mode. Monad is `Hkg`, a+ state monad with state `HkgState`.+ * `RecordOptions.hs` -- Parses command line flags for record mode.+ * `BuildManager.hs` -- Orchestrates building all packages.+ * `Build.hs` -- Handles building a single package.+ * `BuildTools.hs` -- Wrappers to run various external build tools.++ * `Report.hs` -- Entry point for report mode.++ * `Parallel.hs` -- Handles parallelizing Hackager.+ * `Utils.hs` -- Misc functions.++Building Process:++ 1) Parse command line flags+ 2) Get list of packages to build, either from command line or all of hackage.+ 3) Create the needed build directory structure.+ 4) Run `cabal install --dry-run` on each package first to see if installable.+ 5) Run `cabal install` for each installable package. Do so in a new and+ temporary package configuration.+ 6) Dump all results.+
+ LICENSE view
@@ -0,0 +1,31 @@+The Glasgow Haskell Compiler License++Copyright 2002, The University Court of the University of Glasgow. +All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.
+ README.md view
@@ -0,0 +1,93 @@+# Hackager [](https://hackage.haskell.org/package/hackager) [](https://travis-ci.org/dterei/hackager)++Hackager is a tool to compile all of the Haskell Hackage package+repository. This is useful for testing Haskell compilers.++## Using+Hackager consists of one tool that supports multiple commands.++''hackager'' is invoked with the following options:++~~~~ {.sh}+$ usage: hackager [--version] [--help] <command> [<args>]++The valid hackager commands are:+ record Try building all of hackage and record results+ report Compare two 'record' runs and display results++See 'hackager help <command>' for more information on a specific command+~~~~++''hackager record'' has the following options:++~~~~ {.sh}+usage: hackager record -o NAME [-c CABAL] [-g GHC] [-p GHC-PKG] [-d DEP-FLAGS]+ [-f PKG-FLAGS] [-n THREADS] [PKGS...]++ NAME A name by which the results of this hackager run will+ be referred, e.g. \"ghc-7.6.1\"+ CABAL The path to the cabal program to use+ GHC The path to the ghc program to use+ GHC-PKG The path to the ghc-pkg program to use+ DEP-FLAGS The flags to use when compiling dependencies of a package+ e.g. \"--ghc-option=-XFoo\"+ PKG-FLAGS The flags to use when compiling a package+ e.g. \"--ghc-option=-XBar\"+ THREADS Number of threads to use to build in parallel+ PKGS A list of packages to build. If not specified all of+ hackage is built+~~~~++For example, here is a run with GHC, no special options and using 4+threads (note that this generally takes a long time, i.e. a few days):++~~~ {.sh}+$ hackager record -o normal -n 4+~~~~++Then another run, this time using ''-XAlternativeLayoutRule'' to+compile each package (but not the build dependencies of the package):++~~~~ {.sh}+$ hackager record -o altern -f "--ghc-option=-XAlternativeLayoutRule" -n 4+~~~~++And finally a comparison of the results:++~~~~ {.sh}+$ hackager report normal altern++ normal+ Buildable Build failed Deps failed Not tried+altern Buildable 628 0 0 0+ Build failed 73 215 0 0+ Deps failed 0 0 170 0+ Not tried 0 0 0 0+~~~~++These results mean that 73 packages became unbuildable when the+alternative layout rule is used.++## Caution++Hackager can cause arbitrary code to run on your machine. For example:+ * TemplateHaskell is run at compile time and can execute arbitrary+ code+ * Package configure scripts will be run+ * Custom Setup.hs programs will be run++## Get involved!++We are happy to receive bug reports, fixes, documentation+enhancements, and other improvements.++Please report bugs via the+[github issue tracker](http://github.com/dterei/Hackager/issues).++Master [git repository](http://github.com/dterei/Hackager):++* `git clone git://github.com/dterei/Hackager.git`++## Licensing++This library is BSD-licensed.
+ Setup.hs view
@@ -0,0 +1,5 @@+import Distribution.Simple++main :: IO ()+main = defaultMain+
+ TODO.md view
@@ -0,0 +1,6 @@+# Hackager ToDo List++* Improve error handling when cabal fails (especially 'cabal list')+* Move to another method than 'cabal list' to get package list+* Ability to kill when running...+
+ hackager.cabal view
@@ -0,0 +1,44 @@+Name: hackager+Version: 0.2.0.0+Synopsis: Hackage testing tool+Description:+ Hackager is a program for compiling the entirety of Hackage as a way of+ testing a Haskell compiler.+Category: Compiler, GHC, Testing+Author: The GHC Team, David Terei <code@davidterei.com>+Maintainer: David Terei <code@davidterei.com>+Homepage: https://github.com/dterei/Hackager+Bug-Reports: https://github.com/dterei/Hackager/issues+License: BSD3+License-File: LICENSE+Stability: Stable++Build-Type: Simple+Extra-Source-Files: README.md, TODO.md, HACKING.md+Cabal-Version: >= 1.6++Source-Repository head+ Type: git+ Location: git://github.com/dterei/Hackager.git++Executable hackager+ Main-Is: Hackager.hs+ Other-Modules: Build+ BuildManager+ BuildTools+ HackageMonad+ Parallel+ Record+ RecordOptions+ Report+ Utils+ HS-Source-Dirs: src+ Ghc-Options: -threaded -Wall+ Build-Depends: base >= 2 && < 5,+ Cabal,+ containers,+ directory,+ filepath,+ mtl,+ process+
+ src/Build.hs view
@@ -0,0 +1,190 @@+-- | Operations on a single package.+module Build (+ PkgProcessor,+ buildPkg,+ statPkg+ ) where++import Control.Monad.State+import Data.Char (toUpper)+import Data.List+import Distribution.Package+import Distribution.Text+import System.Directory+import System.FilePath+import System.Exit (ExitCode(..))++import BuildTools+import HackageMonad+import Utils++-- | Setup a package database.+initialisePackageConf :: FilePath -> Hkg ()+initialisePackageConf fp = do+ liftIO . ignoreException $ removeFile fp+ liftIO . ignoreException $ removeDirectoryRecursive fp+ x <- runGhcPkg ["init", fp]+ case x of+ ExitSuccess -> return ()+ _ -> die ("Initialising package database in " ++ show fp ++ " failed")++-- | Type of a function that processes packages (and can be parallelized)+type PkgProcessor = Int -> Int -> PkgName -> Hkg ()++-- | Build a single package.+buildPkg :: PkgProcessor+buildPkg npkgs i p = do+ info $ "===> Building package " ++ p ++ " (" ++ show i ++ " of "+ ++ show npkgs ++ ")"++ tmpPackageConf <- getTempPackageConf p+ initialisePackageConf tmpPackageConf++ scratchDir <- getScratchDir p+ liftIO . ignoreException $ removeDirectoryRecursive scratchDir++ rpath <- getRunPath+ depFlags <- getDepFlags+ pkgFlags <- getPkgFlags+ basicFlags <- getBasicCabalFlags++ let -- we may generate thousands of files, so group by package first letter+ -- for easier browsing.+ groupDir = rpath </> "logs.build" </> [toUpper $ head p]+ pkgPath = groupDir </> p+ cabalLog = pkgPath <.> "cabal.log"+ deplog = pkgPath </> "$pkgid.depends.log"+ comFlags = basicFlags +++ [ "--prefix=" ++ scratchDir+ -- This is the package database that we+ -- want cabal to register into:+ , "--package-db=" ++ tmpPackageConf+ -- But cabal can't be trusted to put its+ -- --package-conf flag after ours, so we need+ -- to repeat the package.conf we want to+ -- register into again:+ , "--ghc-pkg-option=--package-conf=" ++ tmpPackageConf+ -- Only we want to display info to the user+ ]+ depArgs = [ "install", p+ , "--only-dependencies"+ , "--build-log=" ++ deplog+ ] ++ comFlags ++ depFlags++ -- create directory structure+ liftIO $ ignoreException $ createDirectory groupDir+ liftIO $ createDirectory pkgPath++ -- try installing package dependencies+ xDeps <- runCabalResults False depArgs+ case xDeps of+ Right _ -> do+ let summaryName = pkgPath <.> "summary"+ logName = pkgPath <.> "log"+ pkgArgs = [ "install", p+ , "--build-summary=" ++ summaryName+ , "--build-log=" ++ logName+ ]+ ++ comFlags ++ pkgFlags++ -- try installing package+ xPkg <- runCabalResults False pkgArgs+ case xPkg of+ Right _ -> buildSucceeded p+ Left (_, out) -> toFile cabalLog out >>+ buildFailed p++ Left (_, out) -> toFile cabalLog out >>+ buildDepsFailed p++ -- clean up+ rmScratchDir p++ where+ toFile f strs = liftIO $ appendFile f (unlines strs)++-- | Find out what would happen if we installed the package. Running+-- cabal-install in dry-run mode may tell us:+-- * The package is uninstallable+-- * The package is already installed+-- * The package is installable, and which other packages we would have to+-- install in order to install it+-- * Something we don't understand+statPkg :: PkgProcessor+statPkg npkgs i pkg = do+ info $ "===> Getting stats for: " ++ pkg ++ " (" ++ show i ++ " of "+ ++ show npkgs ++ ")"++ rpath <- getRunPath+ basicFlags <- getBasicCabalFlags+ pkgFlags <- getPkgFlags++ let resultDir = rpath </> "logs.stats" </> [toUpper $ head pkg]+ resultName = resultDir </> pkg <.> "result"+ args = basicFlags ++ pkgFlags +++ [ "install", "--dry-run", "--reinstall", "--global"+ , pkg ]++ -- create directory structure+ liftIO $ ignoreException $ createDirectory resultDir++ -- Ideally cabal would have written out some+ -- sort of log, but it seems not to do so in dry-run+ -- mode, so we do so ourselves+ e <- runCabalResults True args+ case e of+ Left (ec, ls) -> do+ let resultsLines = "FAILED"+ : ("Exit code: " ++ show ec)+ : ls+ liftIO $ writeFile resultName $ unlines resultsLines+ addNotInstallablePackage pkg+ info $ "===> " ++ pkg ++ " is not installable, skipping!"+ when (notUpdated resultsLines) $+ die "===> Errror: You need to run 'cabal update' first!"++ Right ls -> do+ let resultsLines = "SUCCEEDED" : ls+ liftIO $ writeFile resultName $ unlines resultsLines+ case break (listHeaderPrefix `isPrefixOf`) ls of+ (_, _ : ls1) -> do+ ls2 <- mapM mangleLine ls1+ case reverse ls2 of+ thisP : otherPs | toU thisP == toU pkg -> do+ addInstallablePackage pkg+ mapM_ addInstall otherPs++ _ -> die ("Installing " ++ show pkg +++ " doesn't end by installing it")++ _ | any (noPackagesPrefix `isPrefixOf`) ls+ -> addInstalledPackage pkg++ | otherwise+ -> do warn $ "Don't understand result for " ++ show pkg+ addFailPackage pkg++ where+ toU = map toUpper+ notUpdated = any (isPrefixOf "Stderr: Run 'cabal update'")++ listHeaderPrefix = "In order, the following would be installed"+ noPackagesPrefix = "No packages to be installed."+ mangleLine l = case simpleParse . takeWhile (/= ' ') $ l of+ Nothing ->+ die ("Unparseable line: " ++ show l)+ Just (PackageIdentifier (PackageName pn) _) ->+ return pn++-- | Get the default cabal flags to use.+getBasicCabalFlags :: Hkg [String]+getBasicCabalFlags = do+ ghc <- getGhc+ ghcPkg <- getGhcPkg+ cFlags <- getCabalFlags+ return $ [ "--remote-build-reporting=none"+ , "--ghc"+ , "--with-ghc=" ++ ghc+ , "--with-ghc-pkg=" ++ ghcPkg+ ] ++ cFlags+
+ src/BuildManager.hs view
@@ -0,0 +1,87 @@+-- | Handle building a set of packages (usually all of Hackage)+module BuildManager (+ setupBuildDir,+ getAllHackage,+ tryBuildingPackages+ ) where++import Control.Concurrent+import Control.Monad+import Control.Monad.State+import System.Directory+import System.FilePath++import Build+import BuildTools+import HackageMonad+import Parallel+import Utils++-- | Setup the needed directory structure.+setupBuildDir:: Hkg ()+setupBuildDir = do+ rpath <- getRunPath+ exists <- liftIO $ doesDirectoryExist rpath+ if exists+ then die (show rpath ++ " already exists, not overwriting")+ else liftIO $ do+ createDirectory rpath+ createDirectory (rpath </> "logs.stats")+ createDirectory (rpath </> "logs.build")++-- | Get a list of all packages on hackage.+getAllHackage :: Hkg [PkgName]+getAllHackage = do+ info "===> Grabbing a list of all packages on hackage..."+ m <- runCabalResults False ["list", "--simple-output", "-v0"]+ -- m: abc 0.0.1+ -- abc 0.0.2+ -- dff 0.1.2+ -- ...+ case m of+ Left (_, out) -> die $ "Failed to get package list: " ++ unlines out+ Right xs ->+ let ls = map (takeWhile (' ' /=)) xs+ ps = uniq $ filter (not . null) ls+ in return ps++-- | Loop over given packages and try to build each of them, recording the+-- results.+tryBuildingPackages :: [PkgName] -> Hkg ()+tryBuildingPackages ps = do+ let n = length ps+ info $ "===> Testing against " ++ show n ++ " packages..."+ runOnAllPkgs ps statPkg+ dumpStats n+ psAll <- getInstallablePackages+ runOnAllPkgs psAll buildPkg+ dumpResults+ rmAllScratch+ info $ "===> Hackager finished! (" ++ show n ++ " packages tested)"++-- | Run in parallel a PkgProcessor function over the given list+-- of packages with the specified number of threads.+runOnAllPkgs :: [PkgName] -> PkgProcessor -> Hkg ()+runOnAllPkgs pkgs pkgFun = do+ nthreads <- getThreads+ mpkgs <- liftIO . newMVar $ zip [1..] pkgs+ let runner = builder pkgFun (length pkgs) mpkgs+ children <- replicateM nthreads $ forkChild runner+ waitForChildren children+ info ""+ info ""++-- | Function to go through a package list and build them. Thread safe so can+-- be forked as child processes.+builder :: PkgProcessor -> Int -> MVar [(Int, PkgName)] -> Hkg ()+builder pkgFun n mpkgs = go+ where+ go = do+ pkgs <- liftIO $ takeMVar mpkgs+ case pkgs of+ [] -> liftIO $ putMVar mpkgs []+ ((i, p) : ps) -> do+ liftIO $ putMVar mpkgs ps+ pkgFun n i p+ go+
+ src/BuildTools.hs view
@@ -0,0 +1,88 @@+-- | Wrappers to run various build tools needed.+module BuildTools (+ runCabal, runCabalResults, runGhcPkg+ ) where++import Control.Concurrent+import Control.Monad.State+import Control.Exception+import System.Exit (ExitCode(..))+import System.IO+import System.Process++import HackageMonad+import Utils++-- | Run cabal.+runCabal :: [String] -> Hkg ExitCode+runCabal args = do+ cabal <- getCabal+ liftIO $ rawSystem cabal args++-- | Run cabal returning the resulting output or error code+-- * Bool: Treat any stderr output as evidence that cabal failed+-- * [String]: The cabal arguments+runCabalResults :: Bool -> [String] -> Hkg (Either (ExitCode, [String]) [String])+runCabalResults errFail args = do+ cabal <- getCabal+ runCmdGetResults errFail cabal args++-- | Run ghc-pkg.+runGhcPkg :: [String] -> Hkg ExitCode+runGhcPkg args = do+ ghcPkg <- getGhcPkg+ liftIO $ rawSystem ghcPkg args++data StdLine = Stdout String | Stderr String++-- | Run a cmd returning the fullresults.+-- * Bool: Treat any stderr output as evidence the cmd failed+-- * FilePath: The program to run+-- * [String]: The program arguments+runCmdGetResults :: Bool -> FilePath -> [String]+ -> Hkg (Either (ExitCode, [String]) [String])+runCmdGetResults errFail prog args = liftIO $ do+ (hIn, hOut, hErr, ph) <- runInteractiveProcess prog args Nothing Nothing+ hClose hIn+ linesMVar <- newEmptyMVar+ lineMVar <- newEmptyMVar+ let getLines h c = do l <- hGetLine h+ putMVar lineMVar (Just (c l))+ getLines h c++ writeLines :: Int -- how many of stdout and stderr are till open+ -> [StdLine] -> IO ()+ writeLines 0 ls = putMVar linesMVar (reverse ls)+ writeLines n ls = do mLine <- takeMVar lineMVar+ case mLine of+ Just line -> writeLines n (line : ls)+ Nothing -> writeLines (n - 1) ls++ _ <- forkIO $ (hSetBuffering hOut LineBuffering >>+ getLines hOut Stdout `onEndOfFile` return ())+ `finally`+ putMVar lineMVar Nothing++ _ <- forkIO $ (hSetBuffering hErr LineBuffering >>+ getLines hErr Stderr `onEndOfFile` return ())+ `finally`+ putMVar lineMVar Nothing++ _ <- forkIO $ writeLines 2 []++ ec <- waitForProcess ph+ ls <- takeMVar linesMVar+ return $ case (ec, errFail && any isStderr ls) of+ (ExitSuccess, False) -> Right $ map stripResultLine ls+ _ -> Left (ec, map mkResultLine ls)++ where+ isStderr (Stdout _) = False+ isStderr (Stderr _) = True++ stripResultLine (Stdout l) = l+ stripResultLine (Stderr l) = l++ mkResultLine (Stdout l) = "Stdout: " ++ l+ mkResultLine (Stderr l) = "Stderr: " ++ l+
+ src/HackageMonad.hs view
@@ -0,0 +1,344 @@+-- | Monad for Hackage Test. Just a simple state passing monad with appropriate+-- getter and setters.+module HackageMonad (+ PkgName, Hkg, HkgState, startState,++ getTempPackageConf, getScratchDir, rmScratchDir, rmAllScratch,++ setRunPath, getRunPath, getCabal, setCabal, getGhc, setGhc, getGhcPkg,+ setGhcPkg, getCabalFlags, setCabalFlags, getDepFlags, setDepFlags,+ getPkgFlags, setPkgFlags, addPkg, getPkgs,++ setThreads, getThreads,++ addInstall, addInstalledPackage, addInstallablePackage,+ addNotInstallablePackage, addFailPackage, getInstallablePackages,+ buildSucceeded, buildFailed, buildDepsFailed,++ dumpStats, dumpResults,++ info, warn, die+ ) where++import Control.Concurrent (MVar, newMVar)+import qualified Control.Concurrent as C+import Control.Monad.State+import Data.Function+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import System.Directory+import System.FilePath+import System.Exit (exitWith, ExitCode(..))+import System.IO++import Utils++type PkgName = String++type Hkg = StateT HkgState IO++-- | The state of Hackager+data HkgState = HkgState {+ -- These are set based on the command line flags+ st_dir :: FilePath,+ st_cabal :: FilePath,+ st_ghc :: FilePath,+ st_ghcPkg :: FilePath,+ st_cabFlags :: [String],+ st_depFlags :: [String],+ st_pkgFlags :: [String],+ st_threads :: Int,+ st_pkgs :: Set PkgName,++ -- These are set by the stats-collection pass:+ st_installedPackages :: MVar (Set PkgName),+ st_installablePackages :: MVar (Set PkgName),+ st_notInstallablePackages :: MVar (Set PkgName),+ st_failPackages :: MVar (Set PkgName),+ st_installCounts :: MVar (Map PkgName Int),++ -- These are set by the installation pass:+ st_buildablePackages :: MVar (Set PkgName),+ st_buildFailurePackages :: MVar (Set PkgName),+ st_buildDepFailurePackages :: MVar (Set PkgName),++ -- internal locks for making stdout thread safe+ st_iolock :: MVar ()+ }++startState :: IO HkgState+startState = do+ ipkgs <- newMVar Set.empty+ apkgs <- newMVar Set.empty+ npkgs <- newMVar Set.empty+ fpkgs <- newMVar Set.empty+ count <- newMVar Map.empty+ bbpkgs <- newMVar Set.empty+ bfpkgs <- newMVar Set.empty+ bdpkgs <- newMVar Set.empty+ iolock <- newMVar ()+ return HkgState {+ st_dir = "",+ st_cabal = "",+ st_ghc = "",+ st_ghcPkg = "",+ st_cabFlags = [],+ st_depFlags = [],+ st_pkgFlags = [],+ st_threads = 1,+ st_pkgs = Set.empty,+ st_installedPackages = ipkgs,+ st_installablePackages = apkgs,+ st_notInstallablePackages = npkgs,+ st_failPackages = fpkgs,+ st_installCounts = count,+ st_buildablePackages = bbpkgs,+ st_buildFailurePackages = bfpkgs,+ st_buildDepFailurePackages = bdpkgs,+ st_iolock = iolock+ }++------------------------------------------------+-- Helpers++setRunPath :: FilePath -> Hkg ()+setRunPath name = do+ dir <- liftIO getCurrentDirectory+ modify $ \st -> st { st_dir = dir </> name }++getRunPath :: Hkg FilePath+getRunPath = gets st_dir++getTempPackageConf :: PkgName -> Hkg FilePath+getTempPackageConf p = (<.> "package.conf") <$> getScratchDir p++getScratchDir :: PkgName -> Hkg FilePath+getScratchDir p = (</> "scratch" </> p) <$> getRunPath++rmScratchDir :: PkgName -> Hkg ()+rmScratchDir p = do+ dir <- getRunPath+ liftIO . ignoreException $+ removeDirectoryRecursive (dir </> "scratch" </> p)++rmAllScratch :: Hkg ()+rmAllScratch = do+ dir <- getRunPath+ liftIO . ignoreException $ removeDirectoryRecursive (dir </> "scratch")++setCabal :: FilePath -> Hkg ()+setCabal ci = modify $ \st -> st { st_cabal = ci }++getCabal :: Hkg FilePath+getCabal = gets st_cabal++setGhc :: FilePath -> Hkg ()+setGhc ghc = modify $ \st -> st { st_ghc = ghc }++getGhc :: Hkg FilePath+getGhc = gets st_ghc++setGhcPkg :: FilePath -> Hkg ()+setGhcPkg ghcPkg = modify $ \st -> st { st_ghcPkg = ghcPkg }++getGhcPkg :: Hkg FilePath+getGhcPkg = gets st_ghcPkg++setCabalFlags :: String -> Hkg ()+setCabalFlags cf = modify $ \st -> st { st_cabFlags = parseFlags cf }++getCabalFlags :: Hkg [String]+getCabalFlags = gets st_cabFlags++setDepFlags :: String -> Hkg ()+setDepFlags depFlags = modify $ \st -> st { st_depFlags = parseFlags depFlags }++getDepFlags :: Hkg [String]+getDepFlags = gets st_depFlags++setPkgFlags :: String -> Hkg ()+setPkgFlags pkgFlags = modify $ \st -> st { st_pkgFlags = parseFlags pkgFlags }++getPkgFlags :: Hkg [String]+getPkgFlags = gets st_pkgFlags++addPkg :: String -> Hkg ()+addPkg p = modify $ \st -> st { st_pkgs = Set.insert p (st_pkgs st) }++getPkgs :: Hkg [String]+getPkgs = gets $ Set.toList . st_pkgs++setThreads :: Int -> Hkg ()+setThreads n = modify $ \st -> st { st_threads = n }++getThreads :: Hkg Int+getThreads = gets st_threads++parseFlags :: String -> [String]+parseFlags str =+ case reads str of+ [(flags, "")] -> flags+ _ -> words str++addInstall :: PkgName -> Hkg ()+addInstall pn = do+ st <- get+ ics <- takeMVar $ st_installCounts st+ let ics' = Map.insertWith (+) pn 1 ics+ putMVar (st_installCounts st) ics'++addInstalledPackage :: PkgName -> Hkg ()+addInstalledPackage pkg = do+ st <- get+ s <- takeMVar $ st_installedPackages st+ putMVar (st_installedPackages st) $ Set.insert pkg s++addInstallablePackage :: PkgName -> Hkg ()+addInstallablePackage pkg = do+ st <- get+ s <- takeMVar $ st_installablePackages st+ putMVar (st_installablePackages st) $ Set.insert pkg s++getInstallablePackages :: Hkg [PkgName]+getInstallablePackages = do+ st <- get+ s <- takeMVar $ st_installablePackages st+ return $ Set.toList s++addNotInstallablePackage :: PkgName -> Hkg ()+addNotInstallablePackage pkg = do+ st <- get+ s <- takeMVar $ st_notInstallablePackages st+ putMVar (st_notInstallablePackages st) $ Set.insert pkg s ++addFailPackage :: PkgName -> Hkg ()+addFailPackage pkg = do+ st <- get+ s <- takeMVar $ st_failPackages st+ putMVar (st_failPackages st) $ Set.insert pkg s++buildSucceeded :: PkgName -> Hkg ()+buildSucceeded pkg = do+ st <- get+ s <- takeMVar $ st_buildablePackages st+ putMVar (st_buildablePackages st) $ Set.insert pkg s++buildFailed :: PkgName -> Hkg ()+buildFailed pkg = do+ st <- get+ s <- takeMVar $ st_buildFailurePackages st+ putMVar (st_buildFailurePackages st) $ Set.insert pkg s++buildDepsFailed :: PkgName -> Hkg ()+buildDepsFailed pkg = do+ st <- get+ s <- takeMVar $ st_buildDepFailurePackages st+ putMVar (st_buildDepFailurePackages st) $ Set.insert pkg s++dumpStats :: Int -> Hkg ()+dumpStats n = do+ st <- get+ ipkgs <- readMVar $ st_installedPackages st+ apkgs <- readMVar $ st_installablePackages st+ npkgs <- readMVar $ st_notInstallablePackages st+ fpkgs <- readMVar $ st_failPackages st+ count <- readMVar $ st_installCounts st++ let fullHistogram = sortBy (flip compare) (map swap $ Map.assocs count)+ (manyHistogram, fewHistogram) = span ((>= 10) . fst) fullHistogram+ total = sum $ map fst fullHistogram+ summaryTable = [ ["Num packages" , show n] + , ["Installed packages" , show $ Set.size ipkgs]+ , ["Installable packages" , show $ Set.size apkgs]+ , ["Uninstallable packages" , show $ Set.size npkgs]+ , ["Failed packages" , show $ Set.size fpkgs]+ , ["Total reinstallations" , show total]+ ]++ name <- getRunPath+ liftIO $ do+ writeFile (name </> "stats.full")+ (unlines $ showCompleteHistogram fullHistogram)+ writeFile (name </> "stats.many")+ (unlines $ showCompleteHistogram manyHistogram)+ writeFile (name </> "stats.few")+ (unlines $ showSummaryHistogram fewHistogram)+ writeFile (name </> "stats.summary")+ (unlines $ showTable [rpad, rpad] summaryTable)+ writeFile (name </> "installed-packages")+ (unlines $ Set.toList ipkgs)+ writeFile (name </> "installable-packages")+ (unlines $ Set.toList apkgs)+ writeFile (name </> "uninstallable-packages")+ (unlines $ Set.toList npkgs)+ writeFile (name </> "fail-packages")+ (unlines $ Set.toList fpkgs)+ writeFile (name </> "install-counts")+ (unlines $ map show $ Map.assocs count)++ where+ showCompleteHistogram hist = showTable [rpad, rpad]+ [ [show count, pkg]+ | (count, pkg) <- hist ]+ showSummaryHistogram hist =+ let hist' = groupBy (on (==) fst) hist+ hist'' = [ [show $ fst $ head histogramRow,+ show $ length histogramRow]+ | histogramRow <- hist' ]+ in showTable [rpad, rpad]+ (["Number of reinstallations",+ "Number of packages"] :+ hist'')++dumpResults :: Hkg ()+dumpResults = do+ st <- get+ bpkgs <- readMVar $ st_buildablePackages st+ fpkgs <- readMVar $ st_buildFailurePackages st+ dpkgs <- readMVar $ st_buildDepFailurePackages st+ rpath <- getRunPath++ liftIO $ writeFile (rpath </> "buildable")+ (unlines $ Set.toList bpkgs)+ liftIO $ writeFile (rpath </> "buildFailed")+ (unlines $ Set.toList fpkgs)+ liftIO $ writeFile (rpath </> "buildDepsFailed")+ (unlines $ Set.toList dpkgs)++takeMVar :: MVar a -> Hkg a+takeMVar m = liftIO $ C.takeMVar m++putMVar :: MVar a -> a -> Hkg ()+putMVar m v = liftIO $ C.putMVar m v++readMVar :: MVar a -> Hkg a+readMVar m = liftIO $ C.readMVar m++-- | Print message to stdout.+info :: String -> Hkg ()+info msg = do+ l <- st_iolock <$> get+ void $ takeMVar l+ liftIO (putStrLn msg)+ putMVar l ()++-- | Print message to stderr.+warn :: String -> Hkg ()+warn msg = do+ l <- st_iolock <$> get+ void $ takeMVar l+ liftIO $ hPutStrLn stderr msg+ putMVar l ()++-- | Exit with error message.+die :: String -> Hkg a+die err = do+ l <- st_iolock <$> get+ void $ takeMVar l+ liftIO $ hPutStrLn stderr err+ putMVar l ()+ liftIO $ exitWith (ExitFailure 1)+
+ src/Hackager.hs view
@@ -0,0 +1,52 @@+-- | Hackage Test. Build all of hackage.+module Main (main) where++import System.Environment+import System.Exit++import Record+import Report++-- | Hackage Test (IO)+main :: IO ()+main = do+ args <- getArgs+ case args of+ ("record" : args') -> record args'+ ("report" : args') -> report args'+ ("help" : args') -> help args'+ ["--version"] -> version+ ["--help" ] -> usageInfo ExitSuccess+ [ ] -> usageInfo (ExitFailure 1)+ x:_ -> putStrLn ("hackager: '" ++ x ++ "' is not a hackager"+ ++ " command. See 'hackager --help'.")+ >> exitWith (ExitFailure 1)++-- | Hackager version+version :: IO ()+version = putStrLn "hackager version 1.0.0"++-- | The help command+help :: [String] -> IO ()+help [ ] = usageInfo ExitSuccess+help ["record"] = recordHelp ExitSuccess+help ["report"] = reportHelp ExitSuccess+help [x ] = putStrLn ("Command '" ++ x ++ "' doesn't exist")+ >> exitWith (ExitFailure 1)+help _ = usageInfo (ExitFailure 1)++-- | Print usage information and exit+usageInfo :: ExitCode -> IO ()+usageInfo exitCode = do+ mapM_ putStrLn+ [ "usage: hackager [--version] [--help] <command> [<args>]"+ , ""+ , "The valid hackager commands are:"+ , " record Try building all of hackage and record results"+ , " report Compare two 'record' runs and display results"+ , ""+ , "See 'hackager help <command>' for more information on a"+ ++ " specific command"+ ]+ exitWith exitCode+
+ src/Parallel.hs view
@@ -0,0 +1,28 @@+-- | Tools for running hackager on many cores.+module Parallel (+ Child, forkChild, waitForChildren,+ ) where++import Control.Concurrent+import Control.Monad.State+import Control.Exception++import HackageMonad++-- | Children process signal+type Child = MVar ()++-- | Fork a child and return an MVar that signals when the child is done.+forkChild :: Hkg () -> Hkg Child+forkChild hkg = do+ mvar <- liftIO newEmptyMVar+ st <- get+ _ <- liftIO $ forkIO (evalStateT hkg st `finally` putMVar mvar ())+ return mvar++-- | Wait on a list of children to finish processing+waitForChildren :: [Child] -> Hkg ()+waitForChildren [] = return ()+waitForChildren (child : children) = do+ liftIO $ takeMVar child+ waitForChildren children
+ src/Record.hs view
@@ -0,0 +1,36 @@+-- | Record tool. Build all of hackage.+module Record (+ record,+ recordHelp+ ) where++import Control.Monad.State+import System.Exit+import System.IO++import BuildManager+import HackageMonad+import RecordOptions++-- | Run the recording tool.+record :: [String] -> IO ()+record args = do+ st <- startState+ evalStateT (recordST args) st++-- | Hackage Test (Monad).+recordST :: [String] -> Hkg ()+recordST args = do+ liftIO $ hSetBuffering stdout NoBuffering+ case args of+ [ ] -> liftIO $ recordHelp (ExitFailure 1)+ ["--help"] -> liftIO $ recordHelp ExitSuccess+ _ -> do+ processArgs args+ ps <- getPkgs+ setupBuildDir+ ps' <- case ps of+ [] -> getAllHackage+ _ -> return ps+ tryBuildingPackages ps'+
+ src/RecordOptions.hs view
@@ -0,0 +1,154 @@+-- | Parse all the option flags for the record command.+module RecordOptions (+ recordHelp,+ processArgs+ ) where++import Control.Monad.State+import Data.Char (isDigit)+import System.Directory+import System.Exit (exitWith, ExitCode(..))+import System.IO++import HackageMonad++-- | Print usage information and exit+recordHelp :: ExitCode -> IO ()+recordHelp exitCode = do+ let out = case exitCode of+ ExitSuccess -> putStrLn+ ExitFailure 1 -> putStrLn+ ExitFailure _ -> hPutStrLn stderr+ mapM_ out+ [ "usage: hackager record -o NAME [-c CABAL] [-g GHC] [-p GHC-PKG] [-a CABAL-FLAGS]"+ , " [-d DEP-FLAGS] [-f PKG-FLAGS] [-n THREADS] [PKGS...]"+ , ""+ , " NAME A name by which the results of this hackager run will"+ , " be referred, e.g. \"ghc-6.12.1\""+ , " CABAL The path to the cabal program to use"+ , " GHC The path to the ghc program to use"+ , " GHC-PKG The path to the ghc-pkg program to use"+ , " CABAL-FLAGS Flags to pass to cabal during building"+ , " e.g. -a [\"--ghc-option=-XFoo\",\"--ghc-option=-XBar\"]"+ , " DEP-FLAGS The flags to use when compiling dependencies of a package"+ , " e.g. -d [\"--ghc-option=-XFoo\",\"--ghc-option=-XBar\"]"+ , " PKG-FLAGS The flags to use when compiling a package"+ , " e.g. -f [\"--ghc-option=-XFoo\",\"--ghc-option=-XBar\"]"+ , " THREADS Number of threads to use to build in parallel"+ , " PKGS A list of packages to build. If not specified all of"+ , " hackage is built"+ ]+ exitWith exitCode++-- | Parse all the option flags for the record command.+processArgs :: [String] -> Hkg ()+processArgs [] = validateFlags+processArgs (('-':x):y:args) = processOpt x y >> processArgs args+processArgs args = parsePackages args >> validateFlags++-- | Parse an individual option flag+processOpt :: String -> String -> Hkg ()+processOpt "o" name = do+ checkNotSet getRunPath "output directory is already set"+ checkNotOption name "the output directory is invalid"+ exists <- liftIO $ doesDirectoryExist name+ when exists $ die "The specified output directory already exists"+ setRunPath name++processOpt "c" cabal = do+ checkNotSet getCabal "cabal program is already set"+ checkNotOption cabal "cabal program is invalid"+ checkExecutable cabal "cabal"+ setCabal cabal++processOpt "g" ghc = do+ checkNotSet getGhc "ghc program is already set"+ checkNotOption ghc "ghc program is invalid"+ checkExecutable ghc "ghc"+ setGhc ghc++processOpt "a" cflags = do+ checkNotSet getCabalFlags "cabal flags already set"+ setCabalFlags cflags++processOpt "p" ghcpkg = do+ checkNotSet getGhcPkg "ghc-pkg program is already set"+ checkNotOption ghcpkg "ghc-pkg is invalid"+ checkExecutable ghcpkg "ghc-pkg"+ setGhcPkg ghcpkg++processOpt "d" depflags = do+ checkNotSet getDepFlags "dependency flags already set"+ setDepFlags depflags++processOpt "f" pkgflags = do+ checkNotSet getPkgFlags "package flags already set"+ setPkgFlags pkgflags++processOpt "n" threads = do+ let n = toInt threads+ case n of+ Just n' -> setThreads n'+ Nothing -> badflag "invalid thread number"++processOpt o _ = badflag $ "Unknown option '-" ++ o ++ "'"++-- | Parse the package list at the end+parsePackages :: [String] -> Hkg ()+parsePackages [] = return ()+parsePackages (x:xs) = do+ checkNotOption x $ "package '" ++ x ++ "' is not a valid package name"+ addPkg x+ parsePackages xs++-- | Validate all the flags needed have been set and are valid+validateFlags :: Hkg ()+validateFlags = do+ n <- getRunPath+ when (n == "") $ badflag "output directory not set"+ setExecutable getCabal setCabal "cabal"+ setExecutable getGhc setGhc "ghc"+ setExecutable getGhcPkg setGhcPkg "ghc-pkg"++-- | Set the executable to what's on the PATH if not set+setExecutable :: Hkg FilePath -> (FilePath -> Hkg ()) -> String -> Hkg ()+setExecutable getx setx name = do+ x <- getx+ when (x == "") $ do+ ci <- liftIO $ findExecutable name+ case ci of+ Nothing -> badflag $ "can't find " ++ name ++ " executable"+ Just ci' -> setx ci'++-- | Make sure a file exists and is executable+checkExecutable :: String -> String -> Hkg ()+checkExecutable f prog = do+ b <- liftIO $ doesFileExist f+ unless b $ badflag $ prog ++ " executable doesn't exist"+ p <- liftIO $ getPermissions f+ unless (executable p) $ badflag $ prog ++ " file is not executable"++-- | Make sure a flag hasn't been set before+checkNotSet :: Hkg [a] -> String -> Hkg ()+checkNotSet getter errmsg = do+ val <- getter+ case val of+ [] -> return ()+ _ -> badflag errmsg++-- | Check that a value isn't an option+checkNotOption :: String -> String -> Hkg ()+checkNotOption ('-':_) errmsg = badflag errmsg+checkNotOption _ _ = return ()++-- | Parse a string to an int+toInt :: String -> Maybe Int+toInt str | all isDigit str = Just $ read str+ | otherwise = Nothing++-- | Throw an error message in the face of a bad flag+badflag :: String -> Hkg ()+badflag errmsg = liftIO $ do+ hPutStrLn stderr errmsg+ recordHelp (ExitFailure 129)+
+ src/Report.hs view
@@ -0,0 +1,129 @@+-- | Reporting tool. Perform a comparision of two Hackage Test runs.+module Report (+ report,+ reportHelp+ ) where++import Control.Monad+import Data.Set (Set)+import qualified Data.Set as Set+import System.Directory+import System.Exit (exitWith, ExitCode(..))+import System.FilePath+import System.IO++import HackageMonad (PkgName)+import Utils++-- | Run the reporting tool.+report :: [String] -> IO ()+report args =+ case args of+ [name1, name2] -> generate name1 name2+ ["--help" ] -> reportHelp ExitSuccess+ [ ] -> reportHelp (ExitFailure 1)+ _ -> reportHelp (ExitFailure 1)++-- | Print usage information and exit+reportHelp :: ExitCode -> IO ()+reportHelp exitCode = do+ mapM_ putStrLn+ [ "usage: hackager report <name1> <name2>"+ , ""+ , " name1 The name of the first result"+ , " name2 The name of the second result"+ , ""+ , "The two results are then compared with each other, the output"+ , "is placed in the folder 'compare---<name1>---<name2>'"+ ]+ exitWith exitCode++-- | Generate a Hackager comparison report+generate :: String -> String -> IO ()+generate name1 name2 = do+ let compName = "compare---" ++ name1 ++ "---" ++ name2++ -- check valid input and outputs+ n1exists <- doesDirectoryExist name1+ unless n1exists $ die ("'" ++ name1 ++ "' doesn't exists")+ n2exists <- doesDirectoryExist name2+ unless n2exists $ die ("'" ++ name2 ++ "' doesn't exists")+ exists <- doesDirectoryExist compName+ when exists $ die ("The directoy '" ++ compName +++ "' already exists, won't overwrite")++ ba1 <- readPkgList (name1 </> "buildable")+ ba2 <- readPkgList (name2 </> "buildable")+ bF1 <- readPkgList (name1 </> "buildFailed")+ bF2 <- readPkgList (name2 </> "buildFailed")+ dF1 <- readPkgList (name1 </> "buildDepsFailed")+ dF2 <- readPkgList (name2 </> "buildDepsFailed")++ let all1 = ba1 `Set.union` bF1 `Set.union` dF1+ all2 = ba2 `Set.union` bF2 `Set.union` dF2+ -- Work out what was not tried by one build or the other+ nt1 = all2 `Set.difference` all1+ nt2 = all1 `Set.difference` all2++ ba1_ba2 = ba1 `Set.intersection` ba2+ ba1_bF2 = ba1 `Set.intersection` bF2+ ba1_dF2 = ba1 `Set.intersection` dF2+ ba1_nt2 = ba1 `Set.intersection` nt2+ bF1_ba2 = bF1 `Set.intersection` ba2+ bF1_bF2 = bF1 `Set.intersection` bF2+ bF1_dF2 = bF1 `Set.intersection` dF2+ bF1_nt2 = bF1 `Set.intersection` nt2+ dF1_ba2 = dF1 `Set.intersection` ba2+ dF1_bF2 = dF1 `Set.intersection` bF2+ dF1_dF2 = dF1 `Set.intersection` dF2+ dF1_nt2 = dF1 `Set.intersection` nt2+ nt1_ba2 = nt1 `Set.intersection` ba2+ nt1_bF2 = nt1 `Set.intersection` bF2+ nt1_dF2 = nt1 `Set.intersection` dF2+ nt1_nt2 = nt1 `Set.intersection` nt2++ num s = show (Set.size s)+ padders = [rpad, rpad, lpad, lpad, lpad, lpad]+ table = [["", "", name1, "", "", ""],+ ["", "", "Buildable", "Build failed", "Deps failed", "Not tried"],+ [name2, "Buildable", num ba1_ba2, num bF1_ba2, num dF1_ba2, num nt1_ba2],+ ["", "Build failed", num ba1_bF2, num bF1_bF2, num dF1_bF2, num nt1_bF2],+ ["", "Deps failed", num ba1_dF2, num bF1_dF2, num dF1_dF2, num nt1_dF2],+ ["", "Not tried", num ba1_nt2, num bF1_nt2, num dF1_nt2, num nt1_nt2]]++ createDirectory compName+ mapM_ (writeResultFile compName)+ [ ("buildable-buildable" , ba1_ba2)+ , ("buildable-buildFailed" , ba1_bF2)+ , ("buildable-depsFailed" , ba1_dF2)+ , ("buildable-notTried" , ba1_nt2)+ , ("buildFailed-buildable" , bF1_ba2)+ , ("buildFailed-buildFailed" , bF1_bF2)+ , ("buildFailed-depsFailed" , bF1_dF2)+ , ("buildFailed-notTried" , bF1_nt2)+ , ("depsFailed-buildable" , dF1_ba2)+ , ("depsFailed-buildFailed" , dF1_bF2)+ , ("depsFailed-depsFailed" , dF1_dF2)+ , ("depsFailed-notTried" , dF1_nt2)+ , ("notTried-buildable" , nt1_ba2)+ , ("notTried-buildFailed" , nt1_bF2)+ , ("notTried-depsFailed" , nt1_dF2)+ , ("notTried-notTried" , nt1_nt2)+ ]+ writeFile (compName </> "summary") (unlines $ showTable padders table)+ mapM_ putStrLn $ showTable padders table++-- | Write results to a file+writeResultFile :: FilePath -> (FilePath, Set PkgName) -> IO ()+writeResultFile dir (f, set) = writeFile (dir </> f) (unlines $ Set.toList set)++-- | Read a list of packages from the file specified+readPkgList :: FilePath -> IO (Set PkgName)+readPkgList fp = do xs <- readFile fp+ return $ Set.fromList $ lines xs++-- | Exit with an error+die :: String -> IO a+die err = do hPutStrLn stderr err+ exitWith (ExitFailure 1)+
+ src/Utils.hs view
@@ -0,0 +1,49 @@+-- | Utility functions.+module Utils (+ catchIO, ignoreException, onEndOfFile,+ showTable, uniq, swap, lpad, rpad+ ) where++import qualified Control.Exception as E+import Data.List+import Prelude+import System.IO.Error++-- | Handle an IO exception.+catchIO :: IO a -> (E.IOException -> IO a) -> IO a+catchIO = E.catch++-- | Ignore any IO exception that arises.+ignoreException :: IO () -> IO ()+ignoreException io = io `catchIO` \_ -> return ()++-- | Perform some IO and execute the second argument on an EOF exception.+onEndOfFile :: IO a -> IO a -> IO a+onEndOfFile io io' =+ io `E.catch` \e -> if isEOFError e then io' else E.throwIO e++-- | Filter out adjacent duplicate elements.+uniq :: Eq a => [a] -> [a]+uniq (x : y : xs)+ | x == y = uniq (x : xs)+uniq (x : xs) = x : uniq xs+uniq [] = []++-- | Swap elements of a tuple.+swap :: (a, b) -> (b, a)+swap (x, y) = (y, x)++-- | Show output in a tabular format.+showTable :: [Int -> String -> String] -> [[String]] -> [String]+showTable padders xss =+ let lengths = map (maximum . map length) $ transpose xss+ in map (unwords . zipWith3 id padders lengths) xss++-- | Pad the string with spaces before it.+lpad :: Int -> String -> String+lpad n s = replicate (n - length s) ' ' ++ s++-- | Pad the string with spaces after it.+rpad :: Int -> String -> String+rpad n s = s ++ replicate (n - length s) ' '+