hackager 1.0.0 → 1.0.1
raw patch · 10 files changed
+1093/−1 lines, 10 filesdep ~base
Dependency ranges changed: base
Files
- TODO.md +1/−0
- hackager.cabal +9/−1
- src/Build.hs +169/−0
- src/BuildManager.hs +71/−0
- src/BuildTools.hs +152/−0
- src/HackageMonad.hs +327/−0
- src/Record.hs +37/−0
- src/RecordOptions.hs +149/−0
- src/Report.hs +129/−0
- src/Utils.hs +49/−0
TODO.md view
@@ -2,4 +2,5 @@ * 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
@@ -1,5 +1,5 @@ Name: hackager-Version: 1.0.0+Version: 1.0.1 Synopsis: Hackage testing tool Description: Hackager is a program for compiling the entirety of Hackage as a way of@@ -23,6 +23,14 @@ Executable hackager Main-Is: Hackager.hs+ Other-Modules: Build+ BuildManager+ BuildTools+ HackageMonad+ Record+ RecordOptions+ Report+ Utils HS-Source-Dirs: src Ghc-Options: -threaded Build-Depends: base >= 2 && < 5,
+ src/Build.hs view
@@ -0,0 +1,169 @@+-- | Operations on a single package.+module Build (+ PkgProcessor,+ buildPkg,+ statPkg+ ) where++import Control.Monad.State+import Data.List+import Distribution.Package+import Distribution.Text+import System.Directory+import System.FilePath++import BuildTools+import HackageMonad+import Utils++-- | 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++ name <- getName+ depFlags <- getDepFlags+ pkgFlags <- getPkgFlags+ basicFlags <- getBasicCabalFlags++ let cabalLog = name </> "logs.build" </> p <.> "cabal.log"+ deplog = name </> "logs.build" </> p <.> "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++ -- try installing package dependencies+ xDeps <- runCabalResults False depArgs+ case xDeps of+ Right _ -> do+ let summaryName = name </> "logs.build" </> p <.> "summary"+ logName = name </> "logs.build" </> p <.> "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 (concat 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 ++ ")"+ name <- getName+ basicFlags <- getBasicCabalFlags+ fs <- getPkgFlags+ let summaryName = name </> "logs.stats" </> pkg <.> "summary"+ logName = name </> "logs.stats" </> pkg <.> "log"+ resultName = name </> "logs.stats" </> pkg <.> "result"+ args = basicFlags ++ fs +++ [ "install", "--dry-run", pkg+ , "--build-summary=" ++ summaryName+ , "--build-log=" ++ logName+ ]++ -- 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 | thisP == 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+ notUpdated [] = False+ notUpdated (x : xs) = if "Stderr: Run 'cabal update'" `isPrefixOf` x+ then True+ else notUpdated xs++ listHeaderPrefix = "In order, the following would be installed"+ noPackagesPrefix = "No packages to be installed."+ mangleLine l = case simpleParse 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+ return [ "--remote-build-reporting=none"+ , "--ghc"+ , "--with-ghc=" ++ ghc+ , "--with-ghc-pkg=" ++ ghcPkg+ ]+
+ src/BuildManager.hs view
@@ -0,0 +1,71 @@+-- | Handle building a set of packages (usually all of Hackage)+module BuildManager (+ getPackages,+ tryBuildingPackages+ ) where++import Control.Concurrent+import Control.Monad+import Control.Monad.State++import Build+import BuildTools+import HackageMonad+import Utils++-- | Get a list of all packages on hackage.+getPackages :: Hkg [PkgName]+getPackages = 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: " ++ concat 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+ rmTempDir+ 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 []) >> return ()+ ((i, p) : ps) -> do+ liftIO $ putMVar mpkgs ps+ pkgFun n i p+ go+
+ src/BuildTools.hs view
@@ -0,0 +1,152 @@+-- | Various tools and utility functions to do wtih building.+module BuildTools (+ die, info, warn,+ Child, forkChild, waitForChildren,+ setupDir, initialisePackageConf,+ runCabal, runCabalResults, runGhcPkg+ ) where++import Control.Concurrent+import Control.Monad.State+import Control.Exception+import System.Directory+import System.Exit+import System.FilePath+import System.IO+import System.Process++import HackageMonad+import Utils++-- | Print message to stdout.+info :: String -> Hkg ()+info msg = getIOLock >> liftIO (putStrLn msg) >> releaseIOLock++-- | Print message to stderr.+warn :: String -> Hkg ()+warn msg = getIOLock >> liftIO (hPutStrLn stderr msg) >> releaseIOLock++-- | Exit with error message.+die :: String -> Hkg a+die err = do+ getIOLock+ liftIO $ hPutStrLn stderr err+ releaseIOLock+ liftIO $ exitWith (ExitFailure 1)++-- | Children process signal+type Child = MVar ()++-- | Fork a child and return an MVar that singals 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++-- | Setup the needed directory structure+setupDir:: Hkg ()+setupDir = do+ name <- getName+ exists <- liftIO $ doesDirectoryExist name+ if exists+ then die (show name ++ " already exists, not overwriting")+ else liftIO $ do+ createDirectory name+ createDirectory (name </> "logs.stats")+ createDirectory (name </> "logs.build")++-- | 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")++-- | Run cabal.+runCabal :: [String] -> Hkg ExitCode+runCabal args = do+ cabal <- getCabal+ x <- liftIO $ rawSystem cabal args+ return x++-- | 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+ r <- runCmdGetResults errFail cabal args+ return r++-- | Run ghc-pkg.+runGhcPkg :: [String] -> Hkg ExitCode+runGhcPkg args = do+ ghcPkg <- getGhcPkg+ x <- liftIO $ rawSystem ghcPkg args+ return x++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,327 @@+-- | Monad for Hackage Test. Just a simple state passing monad with appropriate+-- getter and setters.+module HackageMonad (+ PkgName, Hkg, HkgState, startState,++ getTempPackageConf, getScratchDir, rmScratchDir, rmTempDir,++ setName, getName,+ getCabal, setCabal, getGhc, setGhc, getGhcPkg, setGhcPkg,+ getDepFlags, setDepFlags, getPkgFlags, setPkgFlags, addPkg, getPkgs,+ setThreads, getThreads,++ addInstall, addInstalledPackage, addInstallablePackage,+ addNotInstallablePackage, addFailPackage, getInstallablePackages,+ buildSucceeded, buildFailed, buildDepsFailed,++ getIOLock, releaseIOLock,++ dumpStats, dumpResults+ ) 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 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_name :: FilePath,+ st_dir :: FilePath,+ st_cabal :: FilePath,+ st_ghc :: FilePath,+ st_ghcPkg :: FilePath,+ 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_name = "",+ st_dir = "",+ st_cabal = "",+ st_ghc = "",+ st_ghcPkg = "",+ 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++setName :: FilePath -> Hkg ()+setName name = do+ dir <- liftIO getCurrentDirectory+ modify $ \st -> st { st_name = name, st_dir = dir </> name }++getName :: Hkg FilePath+getName = get >>= \st -> return $ st_name st++getDir :: Hkg FilePath+getDir = get >>= \st -> return $ st_dir st++getTempPackageConf :: PkgName -> Hkg FilePath+getTempPackageConf p = getDir >>= \dir -> return+ $ dir </> "scratch" </> p <.> "package.conf"++getScratchDir :: PkgName -> Hkg FilePath+getScratchDir p = getDir >>= \dir -> return $ dir </> "scratch" </> p++rmScratchDir :: PkgName -> Hkg ()+rmScratchDir p = do+ dir <- getDir+ liftIO . ignoreException $+ removeDirectoryRecursive (dir </> "scratch" </> p)++rmTempDir :: Hkg ()+rmTempDir = do+ dir <- getDir+ liftIO . ignoreException $ removeDirectoryRecursive (dir </> "scratch")++setCabal :: FilePath -> Hkg ()+setCabal ci = modify $ \st -> st { st_cabal = ci }++getCabal :: Hkg FilePath+getCabal = get >>= \st -> return $ st_cabal st++setGhc :: FilePath -> Hkg ()+setGhc ghc = modify $ \st -> st { st_ghc = ghc }++getGhc :: Hkg FilePath+getGhc = get >>= \st -> return $ st_ghc st++setGhcPkg :: FilePath -> Hkg ()+setGhcPkg ghcPkg = modify $ \st -> st {st_ghcPkg = ghcPkg }++getGhcPkg :: Hkg FilePath+getGhcPkg = get >>= \st -> return $ st_ghcPkg st++setDepFlags :: String -> Hkg ()+setDepFlags depFlags = modify $ \st -> st { st_depFlags = parseFlags depFlags }++getDepFlags :: Hkg [String]+getDepFlags = get >>= \st -> return $ st_depFlags st++setPkgFlags :: String -> Hkg ()+setPkgFlags pkgFlags = modify $ \st -> st { st_pkgFlags = parseFlags pkgFlags }++getPkgFlags :: Hkg [String]+getPkgFlags = get >>= \st -> return $ st_pkgFlags st++addPkg :: String -> Hkg ()+addPkg p = modify $ \st -> st {st_pkgs = Set.insert p (st_pkgs st) }++getPkgs :: Hkg [String]+getPkgs = do+ st <- get+ return $ Set.toList (st_pkgs st)++setThreads :: Int -> Hkg ()+setThreads n = modify $ \st -> st { st_threads = n }++getThreads :: Hkg Int+getThreads = get >>= \st -> return $ st_threads st++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++getIOLock :: Hkg ()+getIOLock = do+ st <- get+ _ <- takeMVar $ st_iolock st+ return ()++releaseIOLock :: Hkg ()+releaseIOLock = do+ st <- get+ putMVar (st_iolock st) ()++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 = reverse $ sort $ 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 <- getName+ 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++ liftIO $ writeFile (st_name st </> "buildable")+ (unlines $ Set.toList bpkgs)+ liftIO $ writeFile (st_name st </> "buildFailed")+ (unlines $ Set.toList fpkgs)+ liftIO $ writeFile (st_name st </> "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+
+ src/Record.hs view
@@ -0,0 +1,37 @@+-- | Record tool. Build all of hackage.+module Record (+ record,+ recordHelp+ ) where++import Control.Monad.State+import System.Exit+import System.IO++import BuildManager+import BuildTools+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+ setupDir+ ps' <- case ps of+ [] -> getPackages+ _ -> return ps+ tryBuildingPackages ps'+
+ src/RecordOptions.hs view
@@ -0,0 +1,149 @@+-- | 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+import System.IO++import BuildTools+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] [-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"+ , " 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"+ ]+ 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 getName "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"+ setName 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 "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 <- getName+ 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+ when (not b) $ badflag $ prog ++ " executable doesn't exist"+ p <- liftIO $ getPermissions f+ when (not $ 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+import System.FilePath+import System.IO++import HackageMonad (PkgName)+import Utils++-- | Run the reporting tool.+report :: [String] -> IO ()+report args = do+ 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+ when (not n1exists) $ die ("'" ++ name1 ++ "' doesn't exists")+ n2exists <- doesDirectoryExist name2+ when (not 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 Control.Exception+import Data.List+import Prelude hiding (catch)+import System.IO.Error hiding (catch)++-- | Handle an IO exception.+catchIO :: IO a -> (IOException -> IO a) -> IO a+catchIO = 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 `catch` \e -> if isEOFError e then io' else 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 (concat . intersperse " " . 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) ' '+