diff --git a/HACKING.md b/HACKING.md new file mode 100644 --- /dev/null +++ b/HACKING.md @@ -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. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,93 @@ +# Hackager [![Hackage version](https://img.shields.io/hackage/v/hackager.svg?style=flat)](https://hackage.haskell.org/package/hackager) [![Build Status](https://img.shields.io/travis/dterei/hackager.svg?style=flat)](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] [] + +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 ' 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +import Distribution.Simple + +main :: IO () +main = defaultMain + diff --git a/TODO.md b/TODO.md new file mode 100644 --- /dev/null +++ b/TODO.md @@ -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... + diff --git a/hackager.cabal b/hackager.cabal new file mode 100644 --- /dev/null +++ b/hackager.cabal @@ -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 +Maintainer: David Terei +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 + diff --git a/src/Build.hs b/src/Build.hs new file mode 100644 --- /dev/null +++ b/src/Build.hs @@ -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 + diff --git a/src/BuildManager.hs b/src/BuildManager.hs new file mode 100644 --- /dev/null +++ b/src/BuildManager.hs @@ -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 + diff --git a/src/BuildTools.hs b/src/BuildTools.hs new file mode 100644 --- /dev/null +++ b/src/BuildTools.hs @@ -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 + diff --git a/src/HackageMonad.hs b/src/HackageMonad.hs new file mode 100644 --- /dev/null +++ b/src/HackageMonad.hs @@ -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) + diff --git a/src/Hackager.hs b/src/Hackager.hs new file mode 100644 --- /dev/null +++ b/src/Hackager.hs @@ -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] []" + , "" + , "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 ' for more information on a" + ++ " specific command" + ] + exitWith exitCode + diff --git a/src/Parallel.hs b/src/Parallel.hs new file mode 100644 --- /dev/null +++ b/src/Parallel.hs @@ -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 diff --git a/src/Record.hs b/src/Record.hs new file mode 100644 --- /dev/null +++ b/src/Record.hs @@ -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' + diff --git a/src/RecordOptions.hs b/src/RecordOptions.hs new file mode 100644 --- /dev/null +++ b/src/RecordOptions.hs @@ -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) + diff --git a/src/Report.hs b/src/Report.hs new file mode 100644 --- /dev/null +++ b/src/Report.hs @@ -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 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------'" + ] + 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) + diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -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) ' ' +