Re: Debian haskell packaging: We're way behind

[Ian Lynagh <igloo@earth.li>]

On Thu, Jan 15, 2009 at 12:47:39PM -0600, John Goerzen wrote:
> 
> 4) Being able to rebuild binaries on a mass scale when the packages they
> depend upon are rebuilt, or when GHC itself is rebuilt

The attached Build.hs may be a good starting point (I used it for
building extralibs). No warranty etc.


Thanks
Ian

{-
cp ~/unstable64/ghc6/new/*.deb /home/ian/public_html/haskell_deb_archive/
cp ~/unstable64/haskell-utils/new/*.deb /home/ian/public_html/haskell_deb_archive/

find /home/ian/public_html/haskell_deb_archive/ -type f \( \! -name "ghc6*" -a \! -name "haskell-utils*" \) -exec rm {} \;

Either:
for i in packages/*; do cd $i; dpkg-source -x *.dsc; cd ../..; done
Or:
for i in packages/*/*; do ( cd $i && fakeroot debian/rules clean ) ; done

./Build packages/*/*/ 2>&1 | tee log
runghc Build.hs packages/*/*/ 2>&1 | tee log
runghc -f/home/ian/ghc/6.8-branch/ghc/compiler/stage2/ghc-inplace Build.hs packages/*/*/ 2>&1 | tee log
-}

-- We make no attempt at efficiency here. In particular, after building
-- any package we re-sort the whole list of packages to be built.

-- We assume that each package appears only in the arguments, and that
-- there are no overlaps with packages that come with GHC.

module Main (main) where

import Control.Monad
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Version
import Data.List
import Data.Ord
import System.Cmd
import System.Environment
import System.Exit
import System.IO

type Command = String -- XXX security!
type PackageName = String
type Directory = FilePath
data Package = Package GenericPackageDescription Directory deriving Show
data PackageDeps = PackageDeps Package [PackageName] deriving Show

-- XXX Can we get this from somewhere sensible?
packagesThatComeWithGHC :: [PackageName]
packagesThatComeWithGHC = [
    "array", "base", "bytestring",
    "Cabal", "containers", "directory", "filepath",
    "haskell98", "hpc", "old-locale", "old-time", "packedstring",
    "pretty", "process", "random", "readline",
    "template-haskell", "unix", "Win32"
    ]

extraPackagesDone :: [PackageName]
extraPackagesDone = []

archiveDir :: Directory
archiveDir = "/home/ian/public_html/haskell_deb_archive/"

main :: IO ()
main = do hSetBuffering stdout LineBuffering
          dirs <- getArgs
          buildAll (packagesThatComeWithGHC ++ extraPackagesDone) dirs

buildAll :: [PackageName] -> [Directory] -> IO ()
buildAll prebuilt dirs
 = do let verbosity = flagToVerbosity Nothing
      packages <- mapM (mkPackage verbosity) dirs
      let packageDepss = map mkPackagesDeps packages
          packageDepss' = foldr markBuilts packageDepss prebuilt
      doBuilds [] [] packageDepss'

mkPackage :: Verbosity -> Directory -> IO Package
mkPackage verbosity dir
    = do fp <- findPackageDesc verbosity dir
         pd <- readPackageDescription verbosity (dir ++ "/" ++ fp)
         return (Package pd dir)

mkPackagesDeps :: Package -> PackageDeps
mkPackagesDeps p@(Package gpd _) = PackageDeps p ps
    where pd = flattenPackageDescription gpd
          ps = nub $ map getDepPackageName $ buildDepends pd

getDepPackageName :: Dependency -> PackageName
getDepPackageName (Dependency pn _) = pn

markBuilts :: PackageName -> [PackageDeps] -> [PackageDeps]
markBuilts pn = sortPackageDeps . map (markBuilt pn)

markBuilt :: PackageName -> PackageDeps -> PackageDeps
markBuilt pn (PackageDeps pd pns) = PackageDeps pd (delete pn pns)

sortPackageDeps :: [PackageDeps] -> [PackageDeps]
sortPackageDeps = sortBy (comparing numDeps)
    where numDeps (PackageDeps _ deps) = length deps

doBuilds :: [PackageName] -- Done (in reverse order)
         -> [PackageName] -- Failed (in reverse order)
         -> [PackageDeps] -- To build
         -> IO ()
doBuilds done fails pds
 = do printStatus fails pds
      case pds of
          (PackageDeps (Package gpd dir) []):pds' ->
              do built <- doBuild dir
                 let pn = packageName $ packageDescription gpd
                 if built
                   then doBuilds (pn:done) fails $ markBuilts pn pds'
                   else doBuilds done (pn:fails) pds'
          _ -> putStrLn ("Done: " ++ unwords (reverse done))

-- XXX We trust dir to not be nasty
doBuild :: Directory -> IO Bool
doBuild dir = runCommands
    [
     -- so that we know when to make changelog entries.
     -- Get the package ready to be built
     inChroot $ inDir dir $ withTools "debian/rules update-generated-files",
     "find " ++ dir ++ "/../ -name \"*.dsc\" -exec rm {} \\;",
     -- Running setup-ghc clean outside the chroot might fail due to
     -- (presumably) libc differences, so we make the source package in
     -- the chroot
     inChroot $ inDir dir "dpkg-buildpackage -S -rfakeroot -us -uc",
     -- Make a clean build result directory
     "rm -rf buildres",
     "mkdir buildres",
     -- Get the archive ready
     inDir archiveDir "dpkg-scanpackages . . > Packages",
     inDir archiveDir "gzip -f Packages",
     -- Make sure pbuilder knows about the archive
     asRoot "pbuilder update",
     -- Go for it!
     asRoot ("pbuilder build --buildresult buildres " ++ dir ++ "/../*.dsc"),
     -- And put the result in the archive
     "mv buildres/* " ++ archiveDir
    ]

inChrootLocation :: FilePath
inChrootLocation = "/home/ian/debian_packages/extralibs"

inChroot :: Command -> Command
inChroot c = "dchroot -c unstable64 'cd " ++ inChrootLocation
        ++ " && " ++ c ++ "'"

withTools :: Command -> Command
withTools c = "PATH=/home/ian/debian_packages/extralibs/tools:$PATH " ++ c

inDir :: Directory -> Command -> Command
inDir dir c = "cd " ++ dir ++ " && " ++ c

asRoot :: Command -> Command
asRoot cmd = "sudo " ++ cmd

runCommands :: [Command] -> IO Bool
runCommands [] = return True
{-
runCommands (c:cs) = do putStrLn c
                        runCommands cs
-}
runCommands (c:cs) = do putStrLn ("Executing: " ++ c)
                        res <- system c
                        case res of
                            ExitSuccess -> do putStrLn "Success"
                                              runCommands cs
                            _ -> do putStrLn "Failed"
                                    return False

printStatus :: [PackageName] -> [PackageDeps] -> IO ()
printStatus fails pds
 = do let nullFails = null fails
          nullPds = null pds
      unless nullFails $ putStrLn ("Failed: " ++ unwords fails)
      unless nullPds $ do putStrLn "Still to do:"
                          mapM_ (putStrLn . f) pds
      unless (nullFails && nullPds) $ putStrLn "---"
    where f (PackageDeps (Package gpd _) deps)
              = let pn = packageName $ packageDescription gpd
                in case length deps of
                   0 -> "Ready: " ++ pn
                   1 ->          "1 dep for "  ++ pn ++ ": " ++ unwords deps
                   n -> show n ++ " deps for " ++ pn ++ ": " ++ unwords deps

packageName :: PackageDescription -> PackageName
packageName pd = pkgName $ package pd