debian 1.0 → 1.2
raw patch · 10 files changed
+3/−2382 lines, 10 filesdep −Unixutilssetup-changed
Dependencies removed: Unixutils
Files
- Linspire/Debian/AptImage.hs +0/−191
- Linspire/Debian/ChangeLog.hs +0/−105
- Linspire/Debian/Config.hs +0/−324
- Linspire/Debian/DistroCache.hs +0/−125
- Linspire/Debian/OSImage.hs +0/−488
- Linspire/Debian/Repository.hs +0/−879
- Linspire/Debian/SourceTree.hs +0/−260
- Setup.hs +0/−0
- debian.cabal +2/−9
- debian/control +1/−1
− Linspire/Debian/AptImage.hs
@@ -1,191 +0,0 @@--- |The AptImage object represents a partial OS image which is capable--- of running apt-get, and thus obtaining repository info and source--- code packages.-module Linspire.Debian.AptImage - (AptImage,- prepareAptEnv, -- [Style] -> FilePath -> Maybe Repository -> SourcesList -> IO AptImage- updateAptEnv, -- [Style] -> AptImage -> IO AptImage- aptGetSource, -- [Style] -> FilePath -> AptImage -> PkgName -> Maybe DebianVersion -> IO SourceTree- getAvailable) -- [Style] -> OSImage -> [String] -> IO [Paragraph]- where--import Data.List-import Data.Maybe-import System.Directory-import System.IO--import Linspire.Unix.FilePath-import Linspire.Unix.Directory-import Linspire.Unix.Misc-import Linspire.Unix.Progress as Progress-import qualified Linspire.Debian.ChangeLog as ChangeLog-import Linspire.Debian.Control-import Linspire.Debian.Version-import Linspire.Debian.Relation-import Linspire.Debian.SourcesList as SourcesList-import Linspire.Debian.SourceTree as SourceTree--data AptImage = Apt FilePath [DebSource]---- |Create a skeletal enviroment sufficient to run apt-get.-prepareAptEnv :: [Style] -> FilePath -> [DebSource] -> IO AptImage-prepareAptEnv style root sources =- do- let os = Apt root sources- createDirectoryIfMissing True (root ++ "/var/lib/apt/lists/partial")- createDirectoryIfMissing True (root ++ "/var/lib/apt/lists/partial")- createDirectoryIfMissing True (root ++ "/var/cache/apt/archives/partial")- createDirectoryIfMissing True (root ++ "/var/lib/dpkg")- createDirectoryIfMissing True (root ++ "/etc/apt")- writeFileIfMissing True (root ++ "/var/lib/dpkg/status") ""- -- We need to create the local pool before updating so the- -- sources.list will be valid.- let sourceListText = consperse "\n" (map show sources) ++ "\n"- -- ePut ("writeFile " ++ (root ++ "/etc/apt/sources.list") ++ "\n" ++ sourceListText)- writeFile (root ++ "/etc/apt/sources.list") sourceListText- updateAptEnv style os--updateAptEnv :: [Style] -> AptImage -> IO AptImage-updateAptEnv style os@(Apt root _) =- do- systemTask updateStyle ("apt-get" ++ aptOpts os ++ " update")- return os- where- updateStyle = addStyles [Start ("Updating apt-get environment (" ++ root ++ ")"),- Error "Failure preparing apt-get environment"] style---- |Retrieve a source package via apt-get.-aptGetSource :: [Style] -> FilePath -> AptImage -> PkgName -> Maybe DebianVersion -> IO SourceTree-aptGetSource style dir root package version =- do- ready <- SourceTree.findTrees dir >>= mapM latestChange >>= return . map ChangeLog.version- newest <- getAvailable availableStyle root [package] >>=- return . listToMaybe . map parseDebianVersion . catMaybes . map (fieldValue "Version")- let version' = maybe newest Just version- case (version', ready) of- (Nothing, _) -> error ("No available versions of " ++ package)- (Just requested, [available]) | requested == available -> SourceTree.findTree dir- (Just requested, []) ->- do- runAptGet aptGetStyle root dir "source" [(package, Just requested)]- trees <- SourceTree.findTrees dir- case trees of- [tree] -> return tree- _ -> error "apt-get source failed"- (Just requested, _) ->- do- -- One or more incorrect versions are available, remove them- removeRecursiveSafely dir- runAptGet aptGetStyle root dir "source" [(package, Just requested)]- trees <- SourceTree.findTrees dir- case trees of- [tree] -> return tree- _ -> error "apt-get source failed"- where- availableStyle = setStyles [Start ("Finding available versions of " ++ package ++ " in APT pool")] style- aptGetStyle = setStyles [Start ("Retrieving APT source for " ++ package)] style---runAptGet :: [Style] -> AptImage -> FilePath -> String -> [(PkgName, Maybe DebianVersion)] -> IO TimeDiff-runAptGet style root dir command packages =- do- createDirectoryIfMissing True dir- systemTask aptGetStyle (consperse " " ("cd" : dir : "&&" : "apt-get" : aptOpts root : command : map formatPackage packages))- where- formatPackage (name, Nothing) = name- formatPackage (name, Just version) = name ++ "=" ++ show version- aptGetStyle = setStyles [Error "apt-get failed"] style--getAvailable :: [Style] -> AptImage -> [String] -> IO [Paragraph]-getAvailable style root names =- do- Control available <- getSourceInfo style root names- return $ sortBy cmp available- where- cmp p1 p2 =- compare v2 v1 -- Flip args to get newest first- where- v1 = maybe Nothing (Just . parseDebianVersion) (fieldValue "Version" p1)- v2 = maybe Nothing (Just . parseDebianVersion) (fieldValue "Version" p2)---- |Function to get information about source packages using apt-cache showsrc.-getSourceInfo :: [Style] -> AptImage -> [PkgName] -> IO Control-getSourceInfo style os@(Apt root _) packages =- runAptCache (addStyles [Start ("getSourceInfo " ++ consperse " " packages ++ " in " ++ root)] style) os "showsrc" packages---- |Function to get information about binary packages using apt-cache show.-getBinaryInfo :: [Style] -> AptImage -> [PkgName] -> IO Control-getBinaryInfo style root packages =- runAptCache (addStyles [Start "getBinaryInfo"] style) root "show" packages---- We get different files in \/var\/lib\/apt\/lists depending on whether we run--- apt-get update in or out of the changeroot. Depending on that we need to--- use a different sources.list to query the cache.--- FIXME: it would be nice to not use temporary files here, but--- waitForProcess hangs below.--- FIXME: Uniquify the list of packages-runAptCache :: [Style] -> AptImage -> String -> [PkgName] -> IO Control--- |apt-cache will fail if called with no package names-runAptCache _ _ _ [] = return (Control [])-runAptCache style os@(Apt root _) command packages =- do- let opts = aptOpts os- let cmd = consperse " " ("apt-cache" : opts : command : packages)- -- FIXME: don't use a temporary file here, but waitForProcess is hanging-{- (_, outh, _, handle) <- runInteractiveCommand cmd- control <- parseControlFromHandle ("getPackageInfo " ++ command) outh- exitcode <- waitForProcess handle- return $ either (error "Parse error in apt-cache output") id control -}- let tmp = "/tmp/output"- systemTask runStyle (cmd ++ " > " ++ tmp)- control <- parseControlFromFile tmp- -- If this file is not removed here, its contents may be- -- replaced by a subsequent call before the parseControlFromFile- -- is executed. Seriously!- removeFile tmp- return $ either (error "Parse error in apt-cache output") id control- where- runStyle = addStyles [Start ("Running apt-cache " ++ command ++ {- " " ++ show packages ++ -}- " in " ++ root)] style--{--aptSourcesList :: AptImage -> [DebSource]-aptSourcesList (Apt _ sources) = sources- -- DistroCache.sources distro ++ maybe [] (DistroCache.localPool distro . topDir) repo--}--aptOpts :: AptImage -> String-aptOpts (Apt root _) =- (" -o=Dir::State::status=" ++ root ++ "/var/lib/dpkg/status" ++- " -o=Dir::State::Lists=" ++ root ++ "/var/lib/apt/lists" ++- " -o=Dir::Cache::Archives=" ++ root ++ "/var/cache/apt/archives" ++- " -o=Dir::Etc::SourceList=" ++ root ++ "/etc/apt/sources.list")--{--aptDist :: AptImage -> String-aptDist (Apt _ sources) = DistroCache.dist distro--}--writeFileIfMissing :: Bool -> FilePath -> String -> IO ()-writeFileIfMissing mkdirs path text =- do- exists <- doesFileExist path- case exists of- False ->- do- if mkdirs then- createDirectoryIfMissing True (parentPath path) else- return ()- writeFile path text- True ->- return ()--parentPath :: FilePath -> FilePath-parentPath path = fst (splitFileName path)---- |The mighty consperse function-consperse :: [a] -> [[a]] -> [a]-consperse sep items = concat (intersperse sep items)--ePut :: String -> IO ()-ePut s = hPutStrLn stderr s
− Linspire/Debian/ChangeLog.hs
@@ -1,105 +0,0 @@--- |Module for handling the Debian changelog file format--- <http://www.debian.org/doc/debian-policy/ch-source.html#s-dpkgchangelog>------ Author: David Fox-{-- |package (version) distribution(s); urgency=urgency- | [optional blank line(s), stripped]- | * change details- | more change details- | [blank line(s), included in output of dpkg-parsechangelog]- | * even more change details- | [optional blank line(s), stripped]- | -- maintainer name <email address>[two spaces] date--}-module Linspire.Debian.ChangeLog- (ChangeLogEntry(Entry),- -- * Accessors- package,- Linspire.Debian.ChangeLog.version,- dists,- urgency,- comments,- who,- date,- -- * read, show- parse, -- String -> [ChangeLogEntry]- showHeader, -- ChangeLogEntry -> String- -- * Helper- getRFC822Date -- IO String- ) where--import Data.List-import Data.Maybe-import Linspire.Debian.Version-import System.IO-import System.Process-import Text.Regex---- |A changelog is a series of ChangeLogEntries-data ChangeLogEntry = Entry {package :: String, -- Package name- version :: DebianVersion, -- Version number- dists :: [String], -- distributions- urgency :: String, -- urgency- comments :: String, -- comments- who :: String, -- who- date :: String} -- date--instance Show ChangeLogEntry where- show (Entry package version dists urgency details who date) =- package ++ " (" ++ show version ++ ") " ++ consperse " " dists ++ "; urgency=" ++ urgency ++ "\n\n" ++- details ++ "\n\n -- " ++ who ++ " " ++ date ++ "\n\n"---- |Show just the top line of a changelog entry (for debugging output.)-showHeader :: ChangeLogEntry -> String-showHeader (Entry package version dists urgency _ _ _) =- package ++ " (" ++ show version ++ ") " ++ consperse " " dists ++ "; urgency=" ++ urgency ++ "..."---- |Parse a Debian Changelog and return a list of entries-parse :: String -> [ChangeLogEntry]-parse text =- case matchRegexAll entryRE text of- Nothing -> []- Just (_, _, remaining, submatches) ->- case submatches of- [name, version, dists, urgency, _, _, details, _, _, _, _, who, date, _] ->- let entry =- Entry name - (parseDebianVersion version)- (words dists)- urgency- details- who- date in- entry : parse remaining- _ -> error "Parse error in changelog"- where- entryRE = mkRegex (header ++ blankLines ++ details ++ blankLines ++ signature)-- header = package ++ version ++ dists ++ urgency-- package = "^([^ \t(]*)" ++ optWhite- version = "\\(([^)]*)\\)" ++ optWhite- dists = "([^;]*);" ++ optWhite- urgency = "urgency=([^\n]*)\n" ++ blankLines- details = "(" ++ prefixedLine ++ "(" ++ blankLines ++ prefixedLine ++ ")*)"- signature = "( -- ([^\n]*) (...............................))[ \t]*\n" ++ blankLines-- prefixedLine = " [^\n]*\n"- blankLines = "(" ++ optWhite ++ "\n)*"- optWhite = "[ \t]*"---- FIXME: The %z formatting directive (rfc-822 conformant timezone)--- isn't working:--- date = getClockTime >>= toCalendarTime >>=--- return . formatCalendarTime defaultTimeLocale "%a, %d %b %Y %T %z"-getRFC822Date :: IO String-getRFC822Date =- do (_, stdout, _, handle) <- runInteractiveCommand "date -R"- date <- hGetContents stdout >>= return . lines >>= return . listToMaybe- waitForProcess handle- return $ maybe (error "Error running 'date -R'") id date---- |The mighty consperse function-consperse :: [a] -> [[a]] -> [a]-consperse sep items = concat (intersperse sep items)
− Linspire/Debian/Config.hs
@@ -1,324 +0,0 @@--- |The 'Config' module implements both command line and configuration--- file option handling. It converts the command line parameters into--- Flag objects, and then expands any Include, Use, or Config flags.--- Every command line parameter has an equivalent format that can--- appear in the configuration file. Using Debian conventions, a--- command line option such as------ --some-option=value------ could appear in a configuration using this syntax:------ Some-Option: value------ This is the format used in Debian Control files, and is similar to--- the format described in RFC-922. Note that a value in a control--- file can be continued onto multiple lines by prefixing the extra--- lines with whitespace, as described here:--- <http://www.debian.org/doc/debian-policy/ch-controlfields.html>------ See the documentation of the Flag datatype below for a description--- of the features this module supports.------ Author: David Fox <david.fox@linspire.com>-module Linspire.Debian.Config- (Flag(Use, Name, Include, Param),- computeConfig, -- String -> [OptDescr Flag] -> Maybe String -> IO [[Flag]]- findParams, -- [Flag] -> String -> [String]- findParam, -- [Flag] -> String -> Maybe String- findBool) -- [Flag] -> String -> Bool- where--import Control.Exception-import Control.Monad-import Data.Char(isDigit)-import Data.List-import Data.Maybe-import System.Directory-import System.Environment as Environment-import System.Console.GetOpt-import Text.Regex-import Linspire.Debian.Control---- |The command line arguments are converted to a list of 'Flag'--- objects, and this list is then expanded by the 'computeConfig'--- function and the result (due to the operation of 'Use') is a list--- of Flag lists.-data Flag- = Include FilePath |- -- ^ Any --include or --config flag is converted to an Include- -- object, where the value is a filename containing- -- configuration information. If no --config option is given,- -- default locations will be used as described in the- -- 'computeConfig' function.- Name String |- -- ^ This option has no command line equivalent, it is used to- -- assign a name to a paragraph which can be referred to by a- -- Use flag.- Use [String] |- -- ^ The --use flag is used to refer to one or more named paragraphs.- -- Referring to a single named paragraph causes the parameters in that- -- paragraph to be added to the set of parameters we are computing.- -- If several paragraphs are named, a copy the current set of parameters- -- is created for each named paragraph, and the result is several sets- -- of parameters. This is what causes the result of the computeConfig- -- function to be a list of Flag lists.- Param String String- -- ^ Any other named parameter (No command line equivalent)- deriving Eq---- |Display a flag in (pseudo) RFC-922 format.-instance Show Flag where- show (Include x) = "Include: " ++ x- show (Name x) = "Name: " ++ x- show (Use xs) = "Use: " ++ consperse " " xs- show (Param name value) = name ++ ": " ++ value--instance Read Flag where- readsPrec _ =- let re = mkRegex "^([^ \t:]+):([^\n]*(\n[ \t].*)*)($|\n)" in- (\ s ->- case matchRegexAll re s of- Just (_, _, after, [name, value, _, _]) ->- case name of- "Include" -> [(Include (stripWS value), after)]- "Config" -> [(Include (stripWS value), after)]- "Name" -> [(Name (stripWS value), after)]- "Use" -> [(Use (words value), after)]- _ -> [(Param (stripWS name) (stripWS value), after)]- _ -> error ("Parse error reading flag: '" ++ s ++ "'"))---- |Find the configuration file or directory we will use, if any.--- This is the first that exists among those that are mentioned on the--- command line, the one in $HOME, and the one in \/etc.-configPath :: String -> [Flag] -> IO [FilePath]-configPath appName flags =- do- home <- try (getEnv "HOME") >>=- return . either- (\ _ -> [])- (\ path -> [path ++ "/." ++ appName ++ ".d",- path ++ "/." ++ appName ++ ".conf"])- let etc = ["/etc/" ++ appName ++ ".d", "/etc/" ++ appName ++ ".conf"]- -- FIXME: If $HOME/.appname is a directory, look inside for config- -- FIXME: If $HOME/.appname.d exists, read all the files starting with- -- digits that don't look like backup files. Same for /etc/appname- -- and /etc/appname.d.- let candidates = (findConfigs flags ++ home ++ etc)- existant <- filterM exists candidates- return $ maybeToList (listToMaybe existant)- where- exists path = do- fileExists <- doesFileExist path- dirExists <- doesDirectoryExist path- return (fileExists || dirExists)---- |Find the value of the --include and (synonymous) --config flags-findConfigs :: [Flag] -> [FilePath]-findConfigs [] = []-findConfigs (Include path : etc) = path : findConfigs etc-findConfigs (_ : etc) = findConfigs etc---- |Return the configuration information computed from the command--- line and the configuration files. Each list of flags represents a--- paragraph in the control file, which may be named using the Name:--- flag and referred to using the Use: flag.-computeConfig :: String -> [OptDescr Flag] -> Maybe String -> IO [[Flag]]-computeConfig appName options global =- do- args <- Environment.getArgs- -- Convert the command line arguments to flags. Any arguments- -- not recognized by getOpt is treated as implicit "--use"- -- parameter.- commandLineFlags <-- case getOpt Permute customizedOptions args of- (o, [], []) -> return o- (o, extra, []) -> return (o ++ [Use extra])- (_, _, errs) -> ioError (userError (concat errs ++ usageInfo header customizedOptions))- -- Compute the configuration file path and then load and expand it.- configFlags <- configPath appName commandLineFlags >>= tryPaths >>= expandIncludes- -- Compute the set of global flags.- let globalFlags =- case (configFlags, global) of- -- No configuration info was found- ([], _) -> []- -- Use the first section of the configuration file- (section : _, Nothing) -> section- -- Use a named section of the configuration file- (sections, Just name) -> maybe (head sections) id (find (elem (Name name)) sections)- -- ePut ("configFlags: " ++ show configFlags)- -- ePut ("commandLineFlags: " ++ show commandLineFlags)- sequence <- expandSections [commandLineFlags ++ globalFlags] configFlags- return sequence- where- customizedOptions = optSpecs appName options- header = "Usage: " ++ appName ++ " [OPTION...]"---- Load a list of configuration files.-tryPaths :: [FilePath] -> IO [[Flag]]-tryPaths paths = do- -- My.ePut ("tryPaths " ++ show paths ++ "\n")- flags <- mapM tryPath paths >>= return . mergeControls >>= return . flagsOfControl- return flags- where- -- Each paragraph of the control file becomes a list of flags- flagsOfControl (Control paragraphs) = map (\ (Paragraph fields) -> (map flagOfField fields)) paragraphs- flagOfField (Field (name, value)) = read (name ++ ": " ++ value)- tryPath path =- do- isDir <- doesDirectoryExist path- case isDir of- False -> do- try (parseControlFromFile path) >>=- either (\ _ -> return (Right (Control []))) return >>=- either (\ _ -> return (Control [])) return- True -> do- getDirectoryContents path >>=- return . map ((path ++ "/") ++) . sort . filter isConfigPart >>=- mapM tryPath >>=- return . mergeControls- isConfigPart "" = False- isConfigPart s | isDigit (head s) && head (reverse s) /= '~' = True- isConfigPart _ = False- ---- Load a list of configuration files.-expandIncludes :: [[Flag]] -> IO [[Flag]]-expandIncludes flags =- do- -- ePut ("flags: " ++ show flags)- let paths = concat (map includePaths flags)- -- ePut (concat (map (("Include: " ++) . (++ "\n")) paths))- case paths of- [] -> return flags- _ ->- do- newflags <- tryPaths paths- return (flags ++ newflags)- where- includePaths (Include path : etc) = path : includePaths etc- includePaths (_ : etc) = includePaths etc- includePaths [] = []---- |Expand occurrences of --use in a list of flag lists.-expandSections :: [[Flag]] -> [[Flag]] -> IO [[Flag]]-expandSections toExpand expansions =- do- expanded <- mapM (expandSection [] expansions) toExpand- return (concat expanded)- where- expandSection :: [String] -> [[Flag]] -> [Flag] -> IO [[Flag]]- expandSection stack expansions toExpand =- do- -- ePut ("stack: " ++ show stack)- -- ePut ("toExpand: " ++ show toExpand)- -- ePut ("expansions: " ++ show expansions)- let (useFlags, otherFlags) = partition isUse toExpand- -- ePut ("useFlags: " ++ show useFlags)- let sequences = map getNames useFlags- -- ePut ("sequences: " ++ show sequences)- -- A sequence of name lists- let (sequence :: [[String]]) = cartesianProduct sequences- -- ePut ("sequence: " ++ show sequence)- -- map (elem stack) (concat sequence)- let (newstack :: [String]) = nub $ stack ++ concat sequence- case filter (flip elem $ stack) (concat sequence) of- [] -> return ()- l -> error ("Use loop: " ++ show (nub l))- -- ePut ("newstack: " ++ show newstack)- -- A sequence of flag lists- let (sequence' :: [[[Flag]]]) = map (expandNames expansions stack) sequence- -- ePut ("sequence': " ++ show sequence')- case sequence' of- [] ->- return [otherFlags]- _ ->- do- let sequence'' = map (++ otherFlags) (map concat sequence')- -- ePut ("sequence'': " ++ show sequence'')- result <- mapM (expandSection newstack expansions) sequence''- -- ePut ("result: " ++ show result)- return (concat result)-- isUse (Use _) = True- isUse _ = False- getNames (Use names) = names- getNames _ = []-- -- FIXME: use the stack to prevent infinite recursion- expandNames expansions stack names =- map (expandName expansions stack) names- expandName expansions stack name =- maybe (error ("Section '" ++ name ++ "' not found.")) id (find (elem (Name name)) expansions)---- |Command line option specifications. The caller passes in a list of--- options, and three additional standard options are added here:--- --config <path> - specify the path to a configuration file--- --include <path> - pull in options from a file--- --use 'name1 name2 ...' - pull in some named sections-optSpecs :: String -> [OptDescr Flag] -> [OptDescr Flag]-optSpecs appName specs =- specs ++- [Option ['c'] ["config","include"] (ReqArg Include "PATH")- (consperse "\n"- ["Location of additional configuration files or directories.",- "This option may be given multiple times, but only the first",- "one that exists is use. In addition, if none exist or none",- "are supplied, four additional paths are tried, in this order:",- "'/etc/" ++ appName ++ ".d', '/etc/" ++ appName ++ ".conf', '$HOME/." ++ appName ++ ".d',",- "and '$HOME/." ++ appName ++ ".conf'. If the configuration path",- "specifies a directory all the files in the directory that begin",- "with digits are read in lexical order and merged. If it is a",- "regular file, it is read and the result is used."]),- Option [] ["use"] (ReqArg (Use . words) "NAME")- (consperse "\n"- ["Used to refer to a sequence of named section of the configuration",- "file. The parameters defined in the section with the line",- "'Name: NAME' will be substituted for this argument. Each of the",- "elements will be expanded and executed in sequence."])]---- |Return all values of a string paramter in a flag list.-findParams :: [Flag] -> String -> [String]-findParams (Param name value : etc) sought | name == sought = value : (findParams etc sought)-findParams (_ : etc) sought = findParams etc sought-findParams [] _ = []---- |Return the value of a string paramter in a flag list.-findParam :: [Flag] -> String -> Maybe String-findParam (Param name value : _) sought | name == sought = Just value-findParam (_ : etc) sought = findParam etc sought-findParam [] _ = Nothing---- |Return the value of a boolean paramter in a flag list.-findBool :: [Flag] -> String -> Bool-findBool flags sought = maybe False (\ _ -> True) (findParam flags sought)---- |The mighty consperse function-consperse :: [a] -> [[a]] -> [a]-consperse sep items = concat (intersperse sep items)---- |cartesianProduct [[1,2,3], [4,5],[6]] -> [[1,4,6],[1,5,6],[2,4,6],[2,5,6],[3,4,6],[3,5,6]]-cartesianProduct [] = []-cartesianProduct [xs] = map (: []) xs-cartesianProduct (xs : yss) =- distribute xs (cartesianProduct yss)- where distribute xs yss = concat (map (\ x -> map (x :) yss) xs)---- Example:------ let (optSpecs :: [OptDescr Flag]) =--- [Option [] ["verbose"] (ReqArg (Param "Verbose") "NUMBER")--- "Specify the amount of debugging output",--- Option ['n'] ["dry-run"] (NoArg (Param "Dry-Run" "yes"))--- "Test run, don't modify the repository."]--- flags <- computeConfig "myapp" optSpecs Nothing >>= return . head--- let dryRun = findBool flags "Dry-Run"--- verbose = maybe 0 read (findParam flags "Verbose")------- When this is executed, it will load either the configuration file--- ~/.myapp.conf, /etc/myapp.conf, or some configuration file--- specified using the --config command line app. The top section of--- the configuration file will be merged with the command line flags.--- Then those flags are expanded using the rules described in the--- definition of the Flag datatype, and the result is returned.
− Linspire/Debian/DistroCache.hs
@@ -1,125 +0,0 @@--- |A DistroCache is a distribution (a list of DebSource) with a name--- and a directory which it can use to download and store files. It--- is the basis for several of the other Debian modules.------ Author: David Fox <david.fox@linspire.com>-module Linspire.Debian.DistroCache- (DistroCache,- -- * Constructors- distroFromConfig, -- FilePath -> String -> IO DistroCache- distroFromConfig', -- FilePath -> String -> DistroCache- makeDistro, -- FilePath -> String -> [DebSource] -> DistroCache- -- * Accessors- dist, -- DistroCache -> String- aptDir, -- DistroCache -> String -> FilePath- aptRootDir, -- DistroCache -> FilePath- sources, -- DistroCache -> [DebSource],- sourcesPath, -- DistroCache -> FilePath- poolRoot, -- DistroCache -> FilePath- localPool, -- DistroCache -> FilePath -> [DebSource]- cleanRoot, -- DistroCache -> String -> FilePath- dirtyRoot) -- DistroCache -> String -> FilePath- where--import Control.Monad-import Data.List-import Data.Maybe-import System.Directory-import System.IO-import Text.Regex-import Linspire.Unix.FilePath-import Linspire.Debian.SourcesList---- FIXME: we should have a flag to indicate whether we have--- verified the files that distroFromConfig creates.-data DistroCache =- Distro {top :: FilePath, -- ^ The autobuilder cache directory- dist :: String, -- ^ Name of the distro.- sources :: [DebSource]} -- ^ The contents of the sources.list file.--instance Eq DistroCache where- Distro a b _ == Distro c d _ = a == c && b == d--distDir :: DistroCache -> FilePath-distDir (Distro top dist _) = top ++ "/dists/" ++ dist---- |The directory where package's source deb is downloaded to.-aptDir :: DistroCache -> String -> FilePath-aptDir distro package = distDir distro ++ "/apt/" ++ package---- |The partial environment for performing apt-gets-aptRootDir :: DistroCache -> FilePath-aptRootDir distro = distDir distro ++ "/aptEnv"--sourcesPath :: DistroCache -> FilePath-sourcesPath distro = distDir distro ++ "/sources"--localPool :: DistroCache -> FilePath -> [DebSource]-localPool distro dir = - parseSourcesList ("\ndeb file://" ++ dir ++ " " ++ dist distro ++ " main" ++- "\ndeb-src file://" ++ dir ++ " " ++ dist distro ++ " main\n")--poolRoot :: DistroCache -> FilePath-poolRoot distro = distDir distro ++ "/upload-env"--dirtyRoot :: DistroCache -> String -> FilePath-dirtyRoot distro strictness = distDir distro ++ "/build-" ++ strictness--cleanRoot :: DistroCache -> String -> FilePath-cleanRoot distro strictness = distDir distro ++ "/clean-" ++ strictness---- |Given the text for a source list in the config file, return--- a Distro object. This is an IO operation because we may--- need to create the sources.list files.-distroFromConfig :: FilePath -> String -> IO DistroCache-distroFromConfig top text =- do- let distro@(Distro _ dist _) = distroFromConfig' top text- let dir = distDir distro- distExists <- doesFileExist (sourcesPath distro)- case distExists of- True ->- do- fileSources <- readFile (sourcesPath distro) >>= return . parseSourcesList- case fileSources == (sources distro) of- True -> return distro- False ->- do- ePut ("Sources for '" ++ dist ++ "' don't match sources from the configuration file" ++- ":\n\n" ++ sourcesPath distro ++ ":\n\n" ++- consperse "\n" (map show fileSources) ++- "\n\nConfiguration file:\n\n" ++- consperse "\n" (map show (sources distro)) ++ "\n\n" ++- "This means it is possible that everything in\n" ++- dir ++ " is invalid.")- -- removeRecursiveSafely dir- error ("Please remove " ++ dir ++ " and restart.")- False ->- do- createDirectoryIfMissing True dir- writeFile (sourcesPath distro) (consperse "\n" (map show (sources distro)) ++ "\n")- return distro---- |Create Distro info from an entry in the config file, which--- includes a dist name and the lines of the sources.list file.--- This also creates the basic -distroFromConfig' :: FilePath -> String -> DistroCache-distroFromConfig' top text =- -- FIXME: This regexp is too permissive - it will match almost anything- let re = mkRegex "^[ \t\n]*([^ \t\n]+)[ \t\n]+(.*)$" in- case matchRegex re text of- Just [dist, sources] -> Distro top dist (parseSourcesList sources)- _ -> error "Syntax error in sources text"---- |This is unsafe in the sense that we don't know that the--- directories have been created and the sources.list files--- have been written.-makeDistro :: FilePath -> String -> [DebSource] -> DistroCache-makeDistro top dist sources = Distro top dist sources--ePut :: String -> IO ()-ePut s = hPutStrLn stderr s---- |The mighty consperse function-consperse :: [a] -> [[a]] -> [a]-consperse sep items = concat (intersperse sep items)
− Linspire/Debian/OSImage.hs
@@ -1,488 +0,0 @@--- |Module to handle Debian OS images, AKA build environments or change roots.------ Author: David Fox <david.fox@linspire.com>-module Linspire.Debian.OSImage- (OSImage, -- (export abstract to assure consistency)- EnvRoot(EnvRoot),- -- * Creation- prepareEnv, -- [Style] -> EnvRoot -> DistroCache -> Maybe Repository -> Bool -> Bool -> IO OSImage- syncEnv, -- [Style] -> OSImage -> OSImage -> IO TimeDiff- chrootEnv, -- OSImage -> EnvRoot -> OSImage- -- * Modification- updateEnv, -- [Style] -> OSImage -> IO OSImage- neuterEnv, -- [Style] -> OSImage -> IO OSImage- restoreEnv, -- OSImage -> IO OSImage- -- * Queries- osRoot, -- OSImage -> EnvRoot- osDistro,- osSources, -- OSImage -> [DebSource]- osArch, -- OSImage -> String- osLocalRepository, -- OSImage -> Maybe Repository- getSourceInfo, -- [Style] -> OSImage -> [PkgName] -> IO Control- getBinaryInfo, -- [Style] -> OSImage -> [PkgName] -> IO Control- getAvailable, -- [Style] -> OSImage -> [String] -> IO [Paragraph]- buildEssential, -- OSImage -> Bool -> IO Relations- buildArch, -- EnvRoot -> IO String- -- * Removal- removeEnv, -- OSImage -> IO ()- -- * Helper- chrootPool -- DistroCache -> [DebSource]- ) where--import Control.Exception-import Data.List-import qualified Data.Map as Map-import System.Cmd-import System.Directory-import System.Exit-import System.IO-import System.Posix.Files-import System.Process-import Text.Regex--import Linspire.Unix.Directory as Unix-import Linspire.Unix.FilePath-import Linspire.Debian.Control-import Linspire.Debian.DistroCache as DistroCache-import Linspire.Debian.Relation-import Linspire.Debian.Repository as Repository-import Linspire.Debian.SourcesList-import Linspire.Debian.Version-import Linspire.Unix.Misc-import Linspire.Unix.Progress as Progress---- |This type represents an OS image located at root built from a--- particular distro using a particular architecture. If a Repository--- argument is given, that repository will be copied into the--- environment and kept in sync, and lines will be added to--- sources.list to point to it.-data OSImage = OS EnvRoot DistroCache Architecture (Maybe Repository)-type Architecture = String---- |The root directory of an OS image.-data EnvRoot = EnvRoot FilePath--instance Show EnvRoot where- show (EnvRoot path) = path---- |A directory inside of an OS image.-data EnvPath = EnvPath EnvRoot FilePath--instance Show EnvPath where- show (EnvPath root path) = show root ++ path---- |Create or update an image. FIXME: Make sure there is no--- ".incomplete" flag next to the directory-prepareEnv :: [Style] -> EnvRoot -> DistroCache -> Maybe Repository -> Bool -> Bool -> IO OSImage-prepareEnv style root distro repo flush pgp =- do- exists <- doesFileExist (show root ++ "/etc/apt/sources.list")- case flush || not exists of- True -> - do- Unix.removeRecursiveSafely (show root)- buildEnv failStyle root distro repo pgp >>=- neuterEnv failStyle >>=- syncPool style- False ->- do- let os = OS root distro "i386" repo- try (updateEnv style os) >>=- -- At one point I removed and re-created the- -- environment if anything went wrong trying to update- -- it. This is often the wrong thing to do, since it- -- might be caused by a glitch in networking.- either (\ e -> error (updateError root e)) return- where- failStyle = Progress.removeStyle (Start "") style- updateError root e = ("OSImage.updateEnv failed: " ++ show e ++- "\n (You may need to remove " ++ show root ++ ")")--prepareDevs :: FilePath -> IO ()-prepareDevs root = do- mapM_ prepareDev - ([(root ++ "/dev/null", "c", 1, 3),- (root ++ "/dev/zero", "c", 1, 5),- (root ++ "/dev/full", "c", 1, 7),- (root ++ "/dev/console", "c", 5, 1),- (root ++ "/dev/random", "c", 1, 8),- (root ++ "/dev/urandom", "c", 1, 9)] ++- (map (\ n -> (root ++ "/dev/loop" ++ show n, "b", 7, n)) [0..7]) ++- (map (\ n -> (root ++ "/dev/loop/" ++ show n, "b", 7, n)) [0..7]))- where- prepareDev (path, typ, major, minor) = do- createDirectoryIfMissing True (fst (splitFileName path))- let cmd = "mknod " ++ path ++ " " ++ typ ++ " " ++ show major ++ " " ++ show minor- exists <- doesFileExist path- if not exists then- system cmd else- return ExitSuccess---- Create a new clean build environment in root.clean--- FIXME: create an ".incomplete" flag and remove it when build-env succeeds-buildEnv :: [Style] -> EnvRoot -> DistroCache -> Maybe Repository -> Bool -> IO OSImage-buildEnv style root distro repo pgp =- do- let extra = ["makedev", "build-essential"] ++ (if pgp then ["pgp"] else [])- -- We can't create the environment if the sources.list has any- -- file:// URIs because they can't yet be visible inside the- -- environment. So we grep them out, create the environment, and- -- then add them back in.- systemTask buildStyle ("build-env -o " ++ show root ++- " -s " ++ DistroCache.sourcesPath distro ++- " with '" ++ consperse " " extra ++ "'")- let os = OS root distro "i386" repo- let sourceListText = osSources os- -- ePut ("writeFile2 " ++ (show root ++ "/etc/apt/sources.list") ++ "\n" ++ (formatSources sourceListText))- writeFile (show root ++ "/etc/apt/sources.list") (consperse "\n" (map show sourceListText) ++ "\n")- updateEnv style os- where- buildStyle = setStyles [Start ("Creating clean build environment (" ++ DistroCache.dist distro ++ ")"),- Error "Could not create build environment."] style---- |Update an existing build environment - run apt-get update--- and dist-upgrade.-updateEnv :: [Style] -> OSImage -> IO OSImage-updateEnv style os@(OS root _ _ _) =- do- verifySources os- prepareDevs (show root)- syncPool style os- syncSSH- return os- where- verifySources os =- do- let correct = osSources os- let sourcesPath = show root ++ "/etc/apt/sources.list"- installed <- readFile sourcesPath >>= return . parseSourcesList- if correct /= installed then do- ePut ("Sources in " ++ sourcesPath ++ " don't match configuration for " ++ (show . dist . osDistro) os ++ ":\n\n" ++- consperse "\n" (map show correct))- error ("Sources.list mismatch for " ++ (show . dist . osDistro) os) else- return () - syncSSH = systemTask syncSSHStyle ("rsync -aHxSpDt --delete ~/.ssh/ " ++ show root ++ "/root/.ssh && " ++- "chown -R root.root " ++ show root ++ "/root/.ssh")- syncSSHStyle = addStyles [Start "Copying SSH parameters",- Error "Could copy SSH parameters", Output Dots] style---- These are the sources.list lines for the local pool when viewed--- from inside the changeroot.-chrootPool :: DistroCache -> [DebSource]-chrootPool distro = DistroCache.localPool distro "/work/localpool"--chrootEnv :: OSImage -> EnvRoot -> OSImage-chrootEnv (OS _ a b c) dst = (OS dst a b c)---- Sync the environment from the clean copy. All this does besides--- performing the proper rsync command is to make sure the destination--- directory exists, otherwise rsync will fail. Not sure why the 'work'--- subdir is appended. There must have been a reason at one point.-syncEnv :: [Style] -> OSImage -> OSImage -> IO OSImage-syncEnv style src dst =- do- createDirectoryIfMissing True (show (osRoot dst) ++ "/work")- systemTask (setStyles [Start "Copying clean build environment",- Error "Could not sync with clean build environment"] style)- ("rsync -aHxSpDt --delete '" ++ show (osRoot src) ++ "/' '" ++ show (osRoot dst) ++ "'")- return dst---- |To "neuter" an executable is to replace it with a hard link to--- \/bin\/true in such a way that the operation can be reversed. This--- is done in order to make it safe to install files into it when it--- isn't "live". If this operation fails it is assumed that the--- image is damaged, so it is removed.-neuterEnv :: [Style] -> OSImage -> IO OSImage-neuterEnv style os@(OS root _ _ _) =- do- msg style ("Neutering OS image (" ++ stripDist (show root) ++ ")...")- result <- try $ mapM_ (neuterFile os) neuterFiles- either (\ e -> error $ "Failed to neuter environment " ++ show root ++ ": " ++ show e)- (\ _ -> return os)- result--neuterFiles :: [(FilePath, Bool)]-neuterFiles = [("/sbin/start-stop-daemon", True),- ("/usr/sbin/invoke-rc.d", True),- ("/sbin/init",True),- ("/usr/sbin/policy-rc.d", False)]---- neuter_file from build-env.ml-neuterFile :: OSImage -> (FilePath, Bool) -> IO ()-neuterFile (OS root _ _ _) (file, mustExist) =- do- -- putStrLn ("Neutering file " ++ file)- exists <- doesFileExist (show fullPath)- if exists then- neuterExistantFile else- if mustExist then- error ("Can't neuter nonexistant file: " ++ show fullPath) else- return () -- putStrLn "File doesn't exist, nothing to do"-- where- neuterExistantFile =- do- sameFile <- sameInode (show fullPath) (show binTrue)- if sameFile then- return () else -- putStrLn "File already neutered"- neuterUnneuteredFile- neuterUnneuteredFile =- do- hasReal <- doesFileExist (show fullPath ++ ".real")- if hasReal then- neuterFileWithRealVersion else- neuterFileWithoutRealVersion- createLink (show binTrue) (show fullPath)- neuterFileWithRealVersion =- do- sameCksum <- sameMd5sum (show fullPath) (show fullPath ++ ".real")- if sameCksum then- removeFile (show fullPath) else- error (file ++ " and " ++ file ++ ".real differ (in " ++ show root ++ ")")- - neuterFileWithoutRealVersion = renameFile (show fullPath) (show fullPath ++ ".real")-- fullPath = EnvPath root file- binTrue = EnvPath root "/bin/true"---- |Reverse the neuterEnv operation.-restoreEnv :: OSImage -> IO OSImage-restoreEnv os@(OS root _ _ _) =- do- hPutStr stderr "De-neutering OS image..."- result <- try $ mapM_ (restoreFile os) neuterFiles- either (\ e -> error $ "damaged environment " ++ show root ++ ": " ++ show e ++ "\n please remove it.")- (\ _ -> return os) result---- check_and_restore from build-env.ml-restoreFile :: OSImage -> (FilePath, Bool) -> IO ()-restoreFile (OS root _ _ _) (file, mustExist) =- do- exists <- doesFileExist (show fullPath)- if exists then- restoreExistantFile else- if mustExist then- error ("Can't restore nonexistant file: " ++ show fullPath) else- return ()- where- restoreExistantFile =- do- isTrue <- sameInode (show fullPath) (show binTrue)- hasReal <- doesFileExist (show fullPath ++ ".real")- case (isTrue, hasReal) of- (True, True) ->- do- removeFile (show fullPath)- renameFile (show fullPath ++ ".real") (show fullPath)- (False, _) -> error "Can't restore file not linked to /bin/true"- (_, False) -> error "Can't restore file with no .real version"-- fullPath = EnvPath root file- binTrue = EnvPath root "/bin/true"---------------------------------------osRoot :: OSImage -> EnvRoot-osRoot (OS root _ _ _) = root--osDistro :: OSImage -> DistroCache-osDistro (OS _ distro _ _) = distro--osSources :: OSImage -> [DebSource]-osSources (OS _ distro _ repo) =- DistroCache.sources distro ++- maybe [] (\ _ -> chrootPool distro) repo--osDist :: OSImage -> String-osDist (OS _ distro _ _) = DistroCache.dist distro---- FIXME: Compute this with dpkg-architecture and save this in the OSImage-osArch :: OSImage -> String-osArch (OS _ _ arch _) = arch--osLocalRepository :: OSImage -> Maybe Repository-osLocalRepository (OS _ _ _ repo) = repo---- |Debian Status file (not currently used)-{--type StatusMap = Map.Map String (Maybe Paragraph)--getStatusFile :: OSImage -> IO StatusMap-getStatusFile (OS root _ _ _ _) =- parseControlFromFile (show root ++ "/var/lib/dpkg/status") >>=- return . either (error . show) id >>=- return . statusMake--statusFind :: String -> StatusMap -> Maybe Paragraph-statusFind name map = Map.findWithDefault Nothing name map--statusMake :: Control -> StatusMap-statusMake (Control control) =- Map.fromList (map makepair control)- where- makepair paragraph =- case lookupP "Package" paragraph of- Just (Field (_, name)) -> (stripWS name, Just paragraph)- _ -> error "A status file entry has no Package field"--}---- |Function to get information about source packages using apt-cache showsrc.-getSourceInfo :: [Style] -> OSImage -> [PkgName] -> IO Control-getSourceInfo style root packages =- runAptCache (addStyles [Start ("getSourceInfo " ++ consperse " " packages ++ " in " ++ osDist root)] style) root "showsrc" packages---- |Function to get information about binary packages using apt-cache show.-getBinaryInfo :: [Style] -> OSImage -> [PkgName] -> IO Control-getBinaryInfo style root packages =- runAptCache (addStyles [Start "getBinaryInfo"] style) root "show" packages---- We get different files in \/var\/lib\/apt\/lists depending on whether we run--- apt-get update in or out of the changeroot. Depending on that we need to--- use a different sources.list to query the cache.--- FIXME: it would be nice to not use temporary files here, but--- waitForProcess hangs below.--- FIXME: Uniquify the list of packages-runAptCache :: [Style] -> OSImage -> String -> [PkgName] -> IO Control--- |apt-cache will fail if called with no package names-runAptCache _ _ _ [] = return (Control [])-runAptCache style os command packages =- do- let opts = aptOpts os- let cmd = consperse " " ("apt-cache" : opts : command : packages)- -- FIXME: don't use a temporary file here, but waitForProcess is hanging-{- (_, outh, _, handle) <- runInteractiveCommand cmd- control <- parseControlFromHandle ("getPackageInfo " ++ command) outh- exitcode <- waitForProcess handle- return $ either (error "Parse error in apt-cache output") id control -}- let tmp = "/tmp/output"- systemTask runStyle (cmd ++ " > " ++ tmp)- control <- parseControlFromFile tmp- -- If this file is not removed here, its contents may be- -- replaced by a subsequent call before the parseControlFromFile- -- is executed. Seriously!- removeFile tmp- return $ either (error "Parse error in apt-cache output") id control- where- runStyle = addStyles [Start ("Running apt-cache " ++ command ++ {- " " ++ show packages ++ -}- " in " ++ osDist os)] style--getAvailable :: [Style] -> OSImage -> [String] -> IO [Paragraph]-getAvailable style os names =- do- Control available <- getSourceInfo style os names- return $ sortBy cmp available- where- cmp p1 p2 =- compare v2 v1 -- Flip args to get newest first- where- v1 = maybe Nothing (Just . parseDebianVersion) (fieldValue "Version" p1)- v2 = maybe Nothing (Just . parseDebianVersion) (fieldValue "Version" p2)--aptOpts :: OSImage -> String-aptOpts (OS root _ _ _) =- (" -o=Dir::State::status=" ++ show root ++ "/var/lib/dpkg/status" ++- " -o=Dir::State::Lists=" ++ show root ++ "/var/lib/apt/lists" ++- " -o=Dir::Cache::Archives=" ++ show root ++ "/var/cache/apt/archives" ++- " -o=Dir::Etc::SourceList=" ++ show root ++ "/etc/apt/sources.list")---- |Build the dependency relations for the build essential packages.--- For this to work the build-essential package must be installed in--- the OSImage.-buildEssential :: OSImage -> Bool -> IO Relations-buildEssential _ True = return []-buildEssential (OS root _ _ _) False =- do- essential <-- readFile (show root ++ "/usr/share/build-essential/essential-packages-list") >>=- return . lines >>= return . dropWhile (/= "") >>= return . tail >>=- return . parseRelations . (consperse ", ") >>=- return . (either (error "parse error in /usr/share/build-essential/essential-packages-list") id)- let re = mkRegex "^[^ \t]"- relationText <-- readFile (show root ++ "/usr/share/build-essential/list") >>=- return . lines >>=- return . dropWhile (/= "BEGIN LIST OF PACKAGES") >>= return . tail >>=- return . takeWhile (/= "END LIST OF PACKAGES") >>=- return . filter ((/= Nothing) . (matchRegex re))- -- ePut ("buildEssentialText: " ++ consperse ", " relationText)- let buildEssential = parseRelations (consperse ", " relationText)- let buildEssential' = either (\ l -> error ("parse error in /usr/share/build-essential/list:\n" ++ show l)) id buildEssential- return (essential ++ buildEssential')--buildArch :: OSImage -> IO String-buildArch (OS root _ _ _) =- processOutput ("export LOGNAME=root; chroot " ++ show root ++ " dpkg-architecture") >>=- return . lines . fst >>=- return . map (mapSnd (drop 1) . break (== '=')) >>=- return . Map.fromList >>=- Map.lookup "DEB_BUILD_ARCH"--processOutput :: String -> IO (String, ExitCode)-processOutput command =- do- (_, outh, _, handle) <- runInteractiveCommand command- output <- hGetContents outh- exitCode <- waitForProcess handle- return (output, exitCode)---- |Remove an image. The removeRecursiveSafely function is used to--- ensure that any file systems mounted inside the image are unmounted--- instead of destroyed.-removeEnv :: OSImage -> IO ()-removeEnv (OS root _ _ _) =- do- hPutStr stderr "Removing build environment..."- Unix.removeRecursiveSafely (show root)- hPutStrLn stderr "done."--{-- -- mapM_ (createDirectoryIfMissing True . (++ "/dists") . show) copies- -- syncCopies style repo--}--syncPool :: [Style] -> OSImage -> IO OSImage-syncPool _ os@(OS _ _ _ Nothing) = return os-syncPool style os@(OS root _ _ (Just repo)) =- do- createDirectoryIfMissing True (show root ++ "/work")- systemTask syncStyle - ("rsync -aHxSpDt --delete '" ++- topDir repo ++ "/' '" ++- show root ++ "/work/localpool'")- updateLists style os- return os- where- syncStyle = setStyles [Start ("Syncing local pool from " ++ topDir repo ++ " -> " ++ show root),- Error "Failure syncing local pool"] style--updateLists :: [Style] -> OSImage -> IO TimeDiff-updateLists style (OS root _ _ _) =- systemTask updateStyle- ("chroot " ++ show root ++ " bash -c 'unset LANG; apt-get update && apt-get -y dist-upgrade'")- where- updateStyle = addStyles [Start ("Updating environment (" ++ stripDist (show root) ++ ")"),- Error "Could not update environment", Output Dots] style--sameInode :: FilePath -> FilePath -> IO Bool-sameInode a b =- do- aStatus <- getFileStatus a- bStatus <- getFileStatus b- return (deviceID aStatus == deviceID bStatus && fileID aStatus == fileID bStatus)--sameMd5sum :: FilePath -> FilePath -> IO Bool-sameMd5sum a b =- do- asum <- md5sum a- bsum <- md5sum b- return (asum == bsum)---- |The mighty consperse function-consperse :: [a] -> [[a]] -> [a]-consperse sep items = concat (intersperse sep items)--mapSnd :: (b -> c) -> (a, b) -> (a, c)-mapSnd f (a, b) = (a, f b)--ePut :: String -> IO ()-ePut s = hPutStrLn stderr s
− Linspire/Debian/Repository.hs
@@ -1,879 +0,0 @@--- |A repository is a the directory heirarchy that is used by the apt--- packages to retrieve packages. It is set of source packages. It--- also implies the set of binary packages which were produced along--- with the source packages. It could also be derived from the deb--- and deb-src lines contained in a sources.list file, or from the--- path to a sources.list file.------ Author: David Fox <david.fox@linspire.com>-module Linspire.Debian.Repository- (Repository(Repo),- fromPath, -- FilePath -> Repository- topDir, -- Repository -> FilePath- prepare, -- [Style] -> Bool -> Bool -> FilePath -> IO Repository- -- update, -- [Style] -> Bool -> Repository -> IO Repository- flush, -- Repository -> IO Repository- findLive, -- Repository -> IO [FilePath]- uploadLocal, -- [Style] -> Repository -> FilePath -> IO Repository- uploadAll, -- [Style] -> Bool -> Repository -> Maybe String -> IO Repository- Layout(Pool, Flat),- layout, -- Repository -> IO Layout,- PackageID, -- (Name, Dist, Arch, Version)- Arch(Arch),- parsePackage, -- String -> PackageID- createSkeleton, -- Bool -> FilePath -> Layout -> IO Repository- createDists, -- [String] -> Repository -> IO Repository- scanIncoming, -- [Style] -> Bool -> Repository -> IO [Bool]- removePackage, -- Bool -> Repository -> PackageID -> IO Repository- removeTrumped, -- [Style] -> Bool -> Repository -> IO Repository- removeGarbage, -- [Style] -> Bool -> Repository -> IO Repository- parseChangesFilename, -- String -> (String, String, String, String)- bool) -- bool :: a -> a -> Bool -> a- where--import Control.Exception-import Control.Monad-import Data.List-import Data.Maybe-import qualified Data.Set as Set-import System.Cmd-import System.Directory-import System.Exit-import System.IO-import qualified System.Posix.Files as Posix.Files-import System.Process-import Text.ParserCombinators.Parsec.Error-import Text.Regex--import Linspire.Unix.FilePath-import Linspire.Debian.Control-import Linspire.Debian.Version-import qualified Linspire.Unix.Directory as Unix-import qualified Linspire.Unix.Misc as Unix-import Linspire.Unix.Progress as Progress--data Repository =- Repo- FilePath -- the location of the repository files- Layout -- Flat or Pool, how the repository is laid out- Bool -- Is the repository in a consistent state?--fromPath :: FilePath -> Layout -> Repository-fromPath dir layout = Repo dir layout False--topDir :: Repository -> FilePath-topDir (Repo dir _ _) = dir--prepare :: [Style] -> Bool -> Bool -> FilePath -> Layout -> [String] -> IO Repository-prepare _ dryRun reset dir layout dists = do- repo <- createSkeleton dryRun dir layout >>= createDists dryRun dists- if reset then flush dryRun repo else return repo--flush :: Bool -> Repository -> IO Repository-flush dryRun repo@(Repo dir layout _) =- do- dists <- getDists repo- Unix.removeRecursiveSafely dir -?- (dryRun, "")- createSkeleton dryRun dir layout >>= createDists dryRun dists---- |Update a repository. This means making sure the Sources.gz and--- Packages.gz files are up-to-date with respect to the packages in--- the pool. This only makes sense for a repository where we assume--- that all the packages are supposed to be in a single dist, i.e. the--- local repository used to hold the results of the autobuilder.-{--update :: [Style] -> Bool -> Repository -> IO Repository-update style True repo = flush repo >>= update style False-update _ False repo@(Repo _ _ True) = return repo-update style False (Repo _ Pool False) = error "Unimplemented: update for Pool layout"-update style False (Repo dir Flat False) =- do- -- FIXME: We should see what architectures are present and create- -- a directory for each. Unfortunately, apt-get update fails if- -- the Packages file for its architecture doesn't exist. Maybe we- -- need to change the sources.list when packages show up in the- -- local pool?- createDirectoryIfMissing True (dir ++ "/dists/source")- createDirectoryIfMissing True (dir ++ "/dists/binary-i386")- let scanCmd = ("cd " ++ dir ++ " && " ++- "dpkg-scanpackages dists /dev/null | gzip > dists/binary-i386/Packages.gz && " ++ - "dpkg-scansources dists /dev/null | gzip > dists/source/Sources.gz")- systemTask updateStyle scanCmd- return $ Repo dir Flat True- where- updateStyle = addStyles [Start ("updating repository at " ++ dir)] style--}--uploadAll :: [Style] -> Bool -> Repository -> Maybe String -> IO Repository-uploadAll style dryRun repo host =- do- let dir = topDir repo- files <- getDirectoryContents dir- let changes = map base . concat . groupByNames . catMaybes . map parseChangesFilename . filter (isSuffixOf ".changes") $ files- let upload = map base . catMaybes $ map parseChangesFilename (filter (isSuffixOf ".upload") files)- -- Eliminate any packages already uploaded- let changes' = Set.toList (Set.difference (Set.fromList changes) (Set.fromList upload))- -- Reconstruct the full pathname of the .changes files- let changes'' = map (\ base -> dir ++ "/" ++ base ++ ".changes") changes'- case changes'' of- [] -> ePut "Nothing to upload."- _ -> mapM_ (dupload style dryRun host) changes''- return repo- where- -- newest = map (head . reverse . (sortBy compareVersions))- -- compareVersions (_, a, _, _) (_, b, _, _) = compare (parseDebianVersion a) (parseDebianVersion b)- groupByNames = groupBy equalNames . sortBy compareNames- compareNames (a, _, _, _) (b, _, _, _) = compare a b- equalNames a b = compareNames a b == EQ- -- Reconstruct the .changes or .upload filename without the extension- base :: (String, String, Arch, String) -> String- base (n, v, (Arch a), _) = n ++ "_" ++ v ++ "_" ++ a---- |Run dupload on a changes file with an optional host (--to)--- argument.-dupload :: [Style] -> Bool -> Maybe String -> FilePath -> IO TimeDiff-dupload style dryRun host changesFile =- systemTask style' (if dryRun then ("echo " ++ cmd) else cmd)- where- cmd = ("dupload" ++ maybe "" (" --to " ++) host ++ " " ++ changesFile)- style' = setStyles [Start "Uploading", Error "dupload failed", Output Indented] style---- |Install a package into a local repository.-uploadLocal :: [Style] -> Repository -> FilePath -> IO Repository-uploadLocal style repo changesFile =- do- -- My.ePut ("uploadLocal " ++ show changesFile)- let buildDirParent = parentPath changesFile- -- My.ePut (" dir=" ++ show buildDirParent)- changes <- parseControlFromFile changesFile- case changes of- Right (Control [paragraph]) ->- case fieldValue "Files" paragraph of- Just fileList ->- let paths = map ((buildDirParent ++ "/") ++) (map fifth (parseChangesList fileList)) in- linkFiles style repo (changesFile : paths)- _ -> error "couldn't find either Distribution or Files section in .changes file"- _ -> error "invalid .changes file format"- where fifth (_, _, _, _, x) = x---- |Move some files into the local repository incoming directory.-linkFiles :: [Style] -> Repository -> [FilePath] -> IO Repository-linkFiles style repo@(Repo dir _ _) paths =- do- mapM install paths- result <- scanIncoming style False repo- if all id result then- return repo else- error "Local upload failed"- where- install path =- do- removeIfExists (dest path)- Posix.Files.createLink path (dest path)- -- Posix.Files.removeLink path- dest path = dir ++ "/incoming/" ++ snd (splitFileName path)- removeIfExists path =- do- exists <- doesFileExist path- if exists then Posix.Files.removeLink path else return ()- -- updateStyle = addStyles [Start "Update local pool - after upload"] style--parseChangesFile :: FilePath -> IO (Either ParseError Control)-parseChangesFile path =- do- ePut ("-> " ++ path)- parseControlFromFile path--parseChangesList :: String -> [(String, String, String, String, FilePath)]-parseChangesList text =- -- md5sum size section priority name- case (text, matchRegexAll re text) of- ("", _) -> []- (_, Just (_, _, remaining, [md5sum, size, section, priority, filename])) ->- (md5sum, size, section, priority, filename) : parseChangesList remaining- _ -> error ("Parse error in Files section of changes file: '" ++ text)- where- re = mkRegex ("^[ \t\n]*" ++ g ++w++ g ++w++ g ++w++ g ++w++ g ++ "[ \t\n]*")- g = "(" ++ t ++ ")"- t = "[^ \t\n]+"- w = "[ \t]+"-------------------------- FROM newdist ----------------------------- Name, Dist, Arch, Version-data PackageID = PackageID String Dist Arch DebianVersion-data Layout = Flat | Pool-newtype Arch = Arch String-newtype Dist = Dist String--instance Show Layout where- show Flat = "Flat"- show Pool = "Pool"--instance Show PackageID where- show (PackageID name (Dist dist) (Arch arch) version) = name ++ "=" ++ show version ++ ", dist=" ++ dist ++ ", arch=" ++ arch--instance Show Arch where- show (Arch arch) = arch--instance Show Dist where- show (Dist arch) = arch--layout :: Repository -> IO Layout-layout repo =- do- exists <- doesDirectoryExist (topDir repo ++ "/pool")- return $ case exists of False -> Flat; True -> Pool---- |Parse a string in the form <packagename>=<versionnumber>-parsePackage :: String -> Maybe PackageID-parsePackage s =- case splitRegex (mkRegex "[,=]") s of- [dist, arch, name, version] -> Just (PackageID name (Dist dist) (Arch arch) (parseDebianVersion version))- _ -> Nothing---- |If the repository already exists we must look at it to determine--- the layout, otherwise use the layout argument.-computeLayout :: FilePath -> Layout -> IO Layout-computeLayout root layout =- do- isPool <- doesDirectoryExist (root ++ "/pool")- isFlat <- doesDirectoryExist root - case (isPool, isFlat) of- (True, _) -> return Pool- (False, True) -> return Flat- (False, False) -> return layout---- |Create the directories which will hold the repository.-createSkeleton :: Bool -> FilePath -> Layout -> IO Repository-createSkeleton dryRun root layout =- do- layout' <- computeLayout root layout- mapM_ initDir ([("dists", 0o40755),- ("incoming", 0o41755),- ("removed", 0o40750),- ("reject", 0o40750)] ++- case layout' of- Pool -> [("pool", 0o40755),- ("installed", 0o40755)]- Flat -> [])- return $ Repo root layout' True- where- initDir (name, mode) = - do- let path = root ++ "/" ++ name- createDirectoryIfMissing True path -?- (dryRun, "")- Posix.Files.setFileMode path mode -?- (dryRun, "")--createDists :: Bool -> [String] -> Repository -> IO Repository-createDists dryRun dists (Repo root layout False) = do- repo' <- createSkeleton dryRun root layout- createDists dryRun dists repo'-createDists dryRun dists repo@(Repo root _ True) = do- mapM_ initDir ((map (\ dist -> ("dists/" ++ dist ++ "/main/source", 0o040755)) dists) ++- (map (\ dist -> ("dists/" ++ dist ++ "/main/binary-i386", 0o040755)) dists))- mapM_ initFile (map (\ dist -> root ++ "/dists/" ++ dist ++ "/main/source/Sources") dists ++- map (\ dist -> root ++ "/dists/" ++ dist ++ "/main/binary-i386/Packages") dists)- return repo- where- initDir (name, mode) = - do- let path = root ++ "/" ++ name- createDirectoryIfMissing True path -?- (dryRun, "")- Posix.Files.setFileMode path mode -?- (dryRun, "")- initFile path =- do- exists <- doesFileExist (path ++ ".gz")- if not (exists || dryRun) then do- writeFile path ""- system ("gzip < " ++ path ++ " > " ++ path ++ ".gz") else- return ExitSuccess---- |Find the .changes files in the incoming directory and try to--- process each.-scanIncoming :: [Style] -> Bool -> Repository -> IO [Bool]-scanIncoming style dryRun repo@(Repo root _ _) =- do- changesFiles <- getDirectoryContents (root ++ "/incoming") >>=- return . filter (isSuffixOf ".changes")- let changesPaths = map ((root ++ "/incoming/") ++) changesFiles- changes <- mapM parseChangesFile changesPaths- mapM tryUpload (zip changes changesFiles)- where- tryUpload (Right changes, changesFile) =- try (installPackage style dryRun repo changesFile changes) >>=- either (\ e -> do ePut (" rejected: " ++ changesFile ++ "\n " ++ show e); return False)- (\ _ -> do ePut (" accepted: " ++ changesFile); return True)- tryUpload (Left e, changesFile) =- do- renameFileWithBackup - (root ++ "/incoming/" ++ changesFile)- (root ++ "/reject/" ++ changesFile)- ePut ("Couldn't parse " ++ changesFile ++ ": " ++ show e)- return False--{--data SubDir = SubDir [String] -- path elements--show0 (SubDir l) = concat (intersperse "/" l)-show1 dir = show0 dir ++ "/"-show2 dir = "/" ++ show0 dir-show3 dir = "/" ++ show0 dir ++ "/"-show4 [] = ""-show4 dir = show1 dir--}---- |Install a source package into the repository. This means--- 1. getting the list of files from the .changes file,------ 2. verifying the file checksums,------ 3. removing any existing version and perhaps other versions which--- were listed in the remove list,------ 4. updating the Packages and Sources files, and------ 5. moving the files from the incoming directory to the proper--- place in the package pool.-installPackage :: [Style] -> Bool -> Repository -> FilePath -> Control -> IO Repository-installPackage style dryRun repo@(Repo root layout True) changesFile (Control [changes]) =- do- -- FIXME - if the upload seems incomplete (missing files, short- -- files) we should leave it here, but if it seems incorrect- -- (bad checksums for files that seem long enough) we should- -- move it to reject.- mapM_ (verifyFile root) uploadFiles- verifyInstall repo root poolDir uploadFiles- -- Build the control file entries for the package- (sourceInfo, binaryInfo) <- buildControl root source poolDir uploadFiles- -- Add our "Build-Info" field- sourceInfo' <-- case sourceInfo of- Control [Paragraph paragraph] ->- return $ Control [Paragraph (paragraph ++ - maybe [] (\ s -> [Field ("Build-Info", s)])- (fieldValue "Build-Info" changes))]- _ -> error "Invalid sourceInfo"- -- already exist.- -- Write out the modified control files- writeControl dryRun root source poolDir sourceInfo' binaryInfo- -- Move the files out of incoming- mapM_ (installFile dryRun root poolDir) uploadFiles- let changesDir = case layout of Pool -> root ++ "/installed"; Flat -> root- renameFileWithBackup changesPath (changesDir ++ "/" ++ changesFile) -?- (dryRun, " installing " ++ changesFile)- updatePackageLists style dryRun root dist buildArch sourceInfo' binaryInfo- return repo- where- poolDir = case layout of- Flat -> ""- Pool -> "pool/main/" ++ prefixDir ++ "/" ++ source- prefixDir = if isPrefixOf "lib" source then- take (min 4 (length source)) source else- take (min 1 (length source)) source- uploadFiles = parseChangesList (getField changes "Files")- -- version = parseDebianVersion $ getField changes "Version"- source = getField changes "Source"- dist = Dist $ getField changes "Distribution"- changesPath = root ++ "/incoming/" ++ changesFile- buildArch = case parseChangesFilename changesFile of- Nothing -> error ("Invalid changes filename: " ++ changesFile)- Just (_, _, x, _) -> x- getField para name = maybe (error ("Missing field: " ++ name)) id (fieldValue name para)-installPackage _ _ _ _ (Control _) = error "Invalid changes file"---- |Make sure that none of the files we are about to install are--- already in the repository (other than uncollected garbage.)-verifyInstall :: Repository -> FilePath -> FilePath -> [(String, String, String, String, FilePath)] -> IO ()-verifyInstall repo root poolDir uploadFiles =- do- let moves = map (installPaths root poolDir) uploadFiles- -- If none of the files exist we have nothing to worry about.- exists <- mapM doesFileExist (map snd moves)- case exists of- [] -> return ()- _ -> do- -- Now we have to look at all the dists to see if- -- any of these files are present. This is the same- -- operation removeGarbage does.- live <- findLive repo- case Set.toList (Set.intersection (Set.fromList live) (Set.fromList (map snd moves))) of- [] -> return ()- files -> error ("Uploaded files already exist in repository:\n " ++ consperse "\n " files)---- filename name version arch ext-parseChangesFilename :: String -> Maybe (String, String, Arch, String)-parseChangesFilename name =- case matchRegex (mkRegex "^([^_]*)_(.*)_([^.]*)\\.(changes|upload)$") name of- Just [name, version, arch, ext] -> Just (name, version, Arch arch, ext)- _ -> error ("Invalid .changes file name: " ++ name)---- text md5sum size name-parseSourcesFileList :: String -> [(String, Int, String)]-parseSourcesFileList text =- catMaybes $ map parseSourcesFiles (lines text)- where- parseSourcesFiles line =- case words line of- [md5sum, size, name] -> Just (md5sum, read size, name)- [] -> Nothing- _ -> error ("Invalid line in Files list: '" ++ line ++ "'")---- |Remove the version of the package from a dist's package lists.--- Note that the package's files are not removed, they may still be--- referenced in other dists.-removePackage :: Bool -> Repository -> PackageID -> IO Repository-removePackage dryRun repo package@(PackageID name dist arch version) =- do- ePut (" Repository.removePackage (" ++ consperse " " [name, show dist, show version] ++ ")")- Control sources <- getSources repo dist- Control packages <- getPackages repo dist arch- case partition testSource sources of- ([], _) ->- -- We didn't find a source package, maybe it is a binary package- case partition testBinary packages of- ([], _) -> do- ePut (" Package not found: " ++ show package)- return repo- ([remove], _) ->- case fieldValue "Source" remove of- Nothing -> do- ePut " Binary package has no 'Source' field"- return repo- Just name -> do- ePut (" Removing binary package version: " ++ show package)- removePackage dryRun repo (PackageID name dist arch version)- (remove, _) -> do- ePut (" Multiple packages found: " ++ consperse "\n\n" (map show remove))- return repo- (remove, keep) -> do- -- We found one or more source packages to remove, rewrite Sources with- -- only the keep packages.- case remove of (_ : _ : _) -> ePut ("WARNING: multiple " ++ show package ++ " found"); _ -> return ()- ePut (" Removing source package version: " ++ show package)- putSources repo dist (Control keep) -?- (dryRun, (""))- case partition testBinaryBySource packages of- ([], _) -> do- ePut (" No binary packages found for " ++ show package)- return repo- (remove, keep) -> do- ePut (" Removing binary package versions: " ++ show (catMaybes (map binaryVersion remove)))- putPackages repo dist arch (Control keep) -?- (dryRun, (""))- return repo- where- -- Is this the source package we are looking for?- testSource paragraph =- case (fieldValue "Package" paragraph, fieldValue "Version" paragraph) of- (Just a, Just b) -> a == name && b == show version- _ -> False- -- Is this binary packages part of the source package we are looking for?- testBinaryBySource paragraph =- case (fieldValue "Source" paragraph, fieldValue "Version" paragraph) of- (Just a, Just b) -> a == name && b == show version- _ -> False- -- Is this the binary package we are looking for?- testBinary paragraph =- case (fieldValue "Package" paragraph, fieldValue "Version" paragraph) of- (Just a, Just b) -> a == name && b == show version- _ -> False-{-- removeBinaryP paragraph =- case (fieldValue "Source" paragraph, fieldValue "Version" paragraph) of- (Just a, Just b) -> a == name && b == version- _ -> False- sourceVersion paragraph =- case (fieldValue "Package" paragraph, fieldValue "Version" paragraph) of- (Just a, Just b) -> Just (a, b)- _ -> Nothing--}- binaryVersion paragraph =- case (fieldValue "Binary" paragraph, fieldValue "Version" paragraph) of- (Just a, Just b) -> Just (a, b)- _ -> Nothing- -- For debugging- nameversion paragraph = (fieldValue "Package" paragraph, fieldValue "Version" paragraph)---- |Get the contents of the Sources file for a dist-getSources :: Repository -> Dist -> IO Control-getSources repo dist =- do- exists <- doesFileExist (sourcesPath repo dist)- case exists of- False -> return (Control [])- True -> do- let path = sourcesPath repo dist- Control paragraphs <- parseControlFromFile path >>= - either (error ("Error reading " ++ sourcesPath repo dist)) return- return (Control paragraphs)--putSources :: Repository -> Dist -> Control -> IO ()-putSources repo dist control = rewriteFile (sourcesPath repo dist) (show control)---- |Return the name of the Sources file for a dist-sourcesPath :: Repository -> Dist -> FilePath-sourcesPath (Repo root _ _) dist = root ++ "/dists/" ++ show dist ++ "/main/source/Sources"--getPackages :: Repository -> Dist -> Arch -> IO Control-getPackages repo dist arch =- do- exists <- doesFileExist path- case exists of- False -> return (Control [])- True -> parseControlFromFile path >>=- either (error ("Error reading " ++ path)) return- where- path = (packagesPath repo dist arch)--putPackages :: Repository -> Dist -> Arch -> Control -> IO ()-putPackages repo dist arch control =- do- rewriteFile (packagesPath repo dist arch) (show control)--packagesPath :: Repository -> Dist -> Arch -> FilePath-packagesPath (Repo root _ _) dist arch = root ++ "/dists/" ++ show dist ++ "/main/binary-" ++ show arch ++ "/Packages"---- |Add a package to the source and binary package lists.-updatePackageLists :: [Style] -> Bool -> FilePath -> Dist -> Arch -> Control -> Control -> IO ()-updatePackageLists style dryRun root dist buildArch sourceInfo binaryInfo =- do- append' sourceStyle (sourcesDir dist) "Sources" (show sourceInfo)- -- Add the packages to the package list for the build architecture- append' binaryStyle (archDir dist buildArch) "Packages" (show binaryInfo)- where- sourcesDir dist = root ++ "/dists/" ++ show dist ++ "/main/source"- archDir dist arch = root ++ "/dists/" ++ show dist ++ "/main/binary-" ++ show arch- -- Append text to a file with a separating newline- -- (This version of append is dying on gzip, claiming that the- -- Sources file is locked, presumably by appendFile. Odd.)- append _ dir name text =- do- createDirectoryIfMissing True dir -?- (dryRun, "") -- ("create directory " ++ dir)- let path = dir ++ "/" ++ name- exists <- doesFileExist path- if exists then- appendFile path ("\n" ++ text) -?- (dryRun, " append package info " ++ path) else- writeFile path text -?- (dryRun, " write package info " ++ path)- Unix.gzip path -?- (dryRun, " gzip package info " ++ path)- -- system ("ls -l " ++ path ++ " " ++ path ++ ".gz 1>&2")- return ()- append' style dir name text = do- createDirectoryIfMissing True dir -?- (dryRun, "") -- ("create directory " ++ dir)- let path = dir ++ "/" ++ name- newtext <- empty path >>= return . bool "\n" "" >>= return . (++ text)- writeFile (path ++ ".new") newtext- let cmd = ("cat " ++ path ++ ".new >> " ++ path ++- " && gzip < " ++ path ++ " > " ++ path ++ ".gz")- systemTask style cmd- removeFile (path ++ ".new")- return ()- empty path = doesFileExist path >>= bool (return True) (readFile path >>= return . (== ""))- sourceStyle = setStyles [Start ("Updating repository " ++ show dist ++ " source indices"),- Error ("Failure updating repository " ++ show dist ++ " source indices")] style- binaryStyle = setStyles [Start ("Updating repository " ++ show dist ++ " binary indices"),- Error ("Failure updating repository " ++ show dist ++ " binary indices")] style---- |Verify the checksum of a file. (We could verify the size too at--- some point.)-verifyFile :: FilePath -> (String, String, String, String, FilePath) -> IO ()-verifyFile root (md5sum, _ {- size -}, _, _, name) =- do- let path = root ++ "/incoming/" ++ name- exists <- doesFileExist path- case exists of- False -> error ("Missing file: " ++ path) - True ->- do- sum <- Unix.md5sum path- case sum == md5sum of- True -> return ()- False -> error ("checksum mismatch on " ++ path ++ ":\n expected: " ++ md5sum ++ "\n actual: " ++ sum)---- |Return the path where a file is to be installed.-installPaths :: FilePath -> FilePath -> (String, String, String, String, FilePath) -> (FilePath, FilePath)-installPaths root dir (_, _, _, _, name) =- (root +/+ "incoming" +/+ name, root +/+ dir +/+ name)---- |Install one of the files listed in the .changes file into the--- pool.-installFile :: Bool -> FilePath -> FilePath -> (String, String, String, String, FilePath) -> IO ()-installFile dryRun root dir (_, _, _, _, name) =- do- -- This is used as the Directory attribute- let src = root +/+ "incoming" +/+ name- let dst = root +/+ dir +/+ name- createDirectoryIfMissing True (root +/+ dir) -?- (dryRun, "" {- "create directory " ++ show dir -})- removeFileIf dst -?- (dryRun, "" {- "remove existing file " ++ dst -})- Posix.Files.createLink src dst -?- (dryRun, (" installing " ++ dst) {- "link new name " ++ dst -})- Posix.Files.removeLink src -?- (dryRun, "" {- "unlink old name " ++ src -})- where- removeFileIf path = - doesFileExist path >>=- (\ exists -> if exists then removeFile path else return ())--writeControl :: Bool -> FilePath -> String -> FilePath -> Control -> Control -> IO ()-writeControl dryRun root source dir sourceInfo binaryInfo = do- createDirectoryIfMissing True (root +/+ dir) -?- (dryRun, "") -- "create directory " ++ dir- writeFile (root +/+ dir +/+ source ++ ".package") (show binaryInfo) -?- (dryRun, "") -- "write .package file for " ++ source- writeFile (root +/+ dir +/+ source ++ ".source") (show sourceInfo) -?- (dryRun, "") -- "write .source file for " ++ source---- |Write the info which belongs in the Packages and Sources files.-buildControl :: FilePath -> String -> FilePath -> [(String, String, String, String, FilePath)] -> IO (Control, Control)-buildControl root source dir files =- do- let debs = filter (isSuffixOf ".deb" . name) files- let dsc = filter (isSuffixOf ".dsc" . name) files- case (dsc, debs) of- ([dscTuple], (_ : _)) ->- do- binaryInfo <- mapM doPackage debs >>= return . mergeControls- sourceInfo <- mapM (doSource dscTuple) dsc >>= return . mergeControls- return (sourceInfo, binaryInfo)- ([_], _) ->- error "Package contains no debs"- (_, _) ->- error "Package must contain exactly 1 .dsc file"- where- name (_, _, _, _, x) = x- doPackage (md5sum, size, _, _, name) =- do- let debpath = root ++ "/incoming/" ++ name- info <- getControl debpath- case info of- Control [info] ->- do- let newfields = [Field ("Source", " " ++ source),- Field ("Filename", " " ++ dir +/+ name),- Field ("Size", " " ++ size),- Field ("MD5sum", " " ++ md5sum)]- return $ Control [appendFields newfields info]- _ -> error ("Invalid control file in " ++ debpath)- doSource (md5sum, size, _, _, dscName) (_, _, section, priority, name) =- do- let dscpath = root ++ "/incoming/" ++ name- dsc <- parseControlFromFile dscpath >>= either (error ("couldn't parse " ++ dscpath)) return- case dsc of- Control [info] ->- do- let info' = renameField "Source" "Package" info- let info'' = modifyField "Files" (++ "\n " ++ md5sum ++ " " ++ size ++ " " ++ dscName) info'- let info''' = raiseFields (== "Package") info''- let newfields = [Field ("Priority", " " ++ priority),- Field ("Section", " " ++ section),- Field ("Directory", " " ++ dir)]- return $ Control [appendFields newfields info''']- _ -> error ("Invalid .dsc file: " ++ dscpath)---- |Remove any packages from a dist which are trumped by newer packages.--- These packages are not garbage because they can still be installed by--- explicitly giving their version number to apt.-removeTrumped :: [Style] -> Bool -> Repository -> IO Repository-removeTrumped style dryRun repo =- do- dists <- getDists repo >>= return . map Dist- victims <- mapM (findTrumped style repo) dists >>= return . concat- case victims of- [] -> do- ePut "removeTrumped: nothing to remove"- return repo- _ -> do- ePut "removeTrumped:"- foldM (removePackage dryRun) repo victims---- |Return a list of packages in a dist which are trumped by some--- newer version.-findTrumped :: [Style] -> Repository -> Dist -> IO [PackageID]-findTrumped _ (Repo _ _ False) _ = error "Invalid repository"-findTrumped _ (Repo dir _ True) dist =- do- ePut ("findTrumped " ++ show dist)- packages <- return (dir ++ "/dists/" ++ show dist ++ "/main/source/Sources") >>=- parseControlFromFile >>=- return . either (error "control file parse error") id >>=- return . (\ (Control p) -> p) >>=- return . map makePackage- let (groups :: [[PackageID]]) = groupByName packages- mapM_ ePut (catMaybes (map formatGroup groups))- return . concat . (map older) $ groups- where- makePackage p = case (fieldValue "Package" p, fieldValue "Version" p) of- (Just n, Just v) -> (PackageID n dist arch (parseDebianVersion v))- _ -> error ("Invalid Sources paragraph: " ++ show p)- groupByName = groupBy equalNames . sortBy compareNames- equalNames a b = compareNames a b == EQ- compareNames (PackageID a _ _ _) (PackageID b _ _ _) = compare a b- older :: [PackageID] -> [PackageID]- older = tail . reverse . (sortBy compareVersions)- compareVersions (PackageID _ _ _ a) (PackageID _ _ _ b) = compare a b- arch = Arch "i386"- formatGroup [] = Nothing- formatGroup [_] = Nothing- formatGroup (newest@(PackageID _ dist _ _) : other) =- Just ("Trumped by " ++ formatPackage newest ++ " in " ++ show dist ++ ":\n " ++ consperse "\n " (map formatPackage other))- formatPackage (PackageID name _ arch version) = name ++ "=" ++ show version ++ "[" ++ show arch ++ "]"---- |Collect files that no longer appear in any package index and move--- them to the removed directory. The .changes files are treated--- specially: they don't appear in any index files, but the package--- they belong to can be constructed from their name.-removeGarbage :: [Style] -> Bool -> Repository -> IO Repository-removeGarbage style dryRun repo@(Repo dir layout True) =- do- ePut ("removeGarbage in " ++ dir ++ " (layout=" ++ show layout ++ ", dryRun=" ++ show dryRun ++ ")")- allFiles1 <- poolFiles repo- allFiles2 <- changesFilePaths repo- let allFiles = allFiles1 ++ allFiles2- -- ePut ("allFiles:\n " ++ consperse "\n " (sort allFiles) ++ "\n")- liveFiles <- findLive repo- -- ePut ("liveFiles:\n " ++ consperse "\n " (sort liveFiles) ++ "\n")- let deadFiles = Set.toList (Set.difference (Set.fromList allFiles) (Set.fromList liveFiles))- ePut ("Removing:\n " ++ consperse "\n " (sort deadFiles) ++ "\n")- mapM_ (moveToRemoved dryRun) deadFiles- return repo- where- poolFiles (Repo dir Flat _) = getDirectoryContents dir >>= filterM (doesFileExist . ((dir ++ "/") ++))- poolFiles (Repo dir Pool _) = - getSubPaths (dir ++ "/pool") >>=- mapM getSubPaths >>= return . concat >>=- mapM getSubPaths >>= return . concat >>=- mapM getSubPaths >>= return . concat- changesFilePaths (Repo dir Pool _) = getDirectoryPaths (dir ++ "/installed")- -- In this case we already got the .changes files from the top directory- changesFilePaths (Repo _ Flat _) = return []- getSubPaths path = - do- isDir <- doesDirectoryExist path- case isDir of- False -> return [path]- True -> getDirectoryPaths path- getDirectoryPaths dir = getDirectoryContents dir >>= return . filter filterDots >>= return . map ((dir ++ "/") ++)- filterDots "." = False- filterDots ".." = False- filterDots _ = True- -- upload files only appear when we dupload from a flat repository to another.- moveToRemoved True file = do- ePut ("renameFile " ++ file ++ " " ++ dir ++ "/removed/" ++ snd (splitFileName file))- return ()- moveToRemoved False file = do- ePut ("renameFile " ++ file ++ " " ++ dir ++ "/removed/" ++ snd (splitFileName file))- renameFile file (dir ++ "/removed/" ++ snd (splitFileName file))-removeGarbage style dryRun (Repo dir layout False) =- createSkeleton dryRun dir layout >>= removeGarbage style dryRun--findLive :: Repository -> IO [FilePath]-findLive (Repo _ _ False) = error "Invalid operation on unverified repository"-findLive repo@(Repo dir layout True) =- do- dists <- getDists repo >>= return . map Dist- sourcePackages <- mapM packagesOfIndex (map sourceIndexPath dists) >>= return . concat- binaryPackages <- mapM packagesOfIndex (map binaryIndexPath dists) >>= return . concat- let sourceFiles = map ((dir ++ "/") ++) . map (\ (_, _, name) -> name) . concat . map filesOfSourcePackage $ sourcePackages- let binaryFiles = map ((dir ++ "/") ++) . catMaybes $ map (fieldValue "Filename") binaryPackages- let changesFiles = map (changesFilePath layout) $ sourcePackages- let uploadFiles = map ((dir ++ "/") ++) . map uploadFilePath $ sourcePackages- return $ sourceFiles ++ binaryFiles ++ changesFiles ++ uploadFiles- where- sourceIndexPath dist = dir ++ "/dists/" ++ show dist ++ "/main/source/Sources"- binaryIndexPath dist = dir ++ "/dists/" ++ show dist ++ "/main/binary-" ++ show arch ++ "/Packages"- packagesOfIndex :: FilePath -> IO [Paragraph]- packagesOfIndex path = - parseControlFromFile path >>=- return . either (error ("Bad index file: " ++ path)) id >>=- return . (\ (Control p) -> p)- filesOfSourcePackage :: Paragraph -> [(String, Int, String)]- filesOfSourcePackage package =- let dir = sourcePackageDirectory package in- map (\ (a, b, name) -> (a, b, dir ++ name)) (maybe [] parseSourcesFileList (fieldValue "Files" package))- sourcePackageDirectory package =- case fieldValue "Directory" package of- Nothing -> ""- Just "" -> ""- Just s -> s ++ "/"- changesFilePath Flat package = ((dir ++ "/") ++) . changesFileName $ package- changesFilePath Pool package = ((dir ++ "/installed/") ++) . changesFileName $ package- changesFileName package = - consperse "_" [fromJust (fieldValue "Package" package),- fromJust (fieldValue "Version" package),- show arch] ++ ".changes"- uploadFilePath package = ((dir ++ "/") ++) . uploadFileName $ package- uploadFileName package =- consperse "_" [fromJust (fieldValue "Package" package),- fromJust (fieldValue "Version" package),- show arch] ++ ".upload"- arch = Arch "i386"--getDists :: Repository -> IO [String]-getDists (Repo dir _ _) =- getDirectoryContents (dir ++ "/dists") >>= filterM isDist- where- isDist "." = return False- isDist ".." = return False- isDist name = doesFileExist $ dir ++ "/dists/" ++ name ++ "/main/source/Sources.gz"--getControl :: FilePath -> IO Control-getControl path =- do- let cmd = "ar p " ++ path ++ " control.tar.gz | tar xzO ./control"- -- let cmd = "dpkg-deb --info " ++ path ++ " control"- (_, outh, _, handle) <- runInteractiveCommand cmd- control <- parseControlFromHandle cmd outh- exitcode <- waitForProcess handle- case exitcode of- ExitSuccess -> return $ either (error ("Failure reading contol info from " ++ path)) id control- ExitFailure _ -> error ("Failure running " ++ cmd)---- |Back-up and rewrite a file-rewriteFile :: FilePath -> String -> IO ()-rewriteFile path text =- do- backupFile path- writeFile path text- Unix.gzip path--type DryRunFn = IO () -> (Bool, String) -> IO ()---- |If this is a dry run (dryRun params is True) do *not* evaluate f,--- but instead print a message.-(-?-) :: DryRunFn-(-?-) f (dryRun, "") = if dryRun then return () else f-(-?-) f (dryRun, msg) =- do- hPutStrLn stderr msg- if dryRun then return () else f-infixr 9 -?---renameFileWithBackup :: FilePath -> FilePath -> IO ()-renameFileWithBackup src dst =- do- removeIfExists (dst ++ "~")- renameIfExists dst (dst ++ "~")- System.Directory.renameFile src dst- where- removeIfExists path =- do exists <- doesFileExist path- if exists then removeFile path else return ()- renameIfExists src dst =- do exists <- doesFileExist src- if exists then System.Directory.renameFile src dst else return ()--backupFile :: FilePath -> IO ()-backupFile path =- do- removeIfExists (path ++ "~")- System.Directory.renameFile path (path ++ "~")- where- removeIfExists path =- do exists <- doesFileExist path- if exists then removeFile path else return ()--parentPath :: FilePath -> FilePath-parentPath path = fst (splitFileName path)--ePut :: String -> IO ()-ePut s = hPutStrLn stderr s--bool :: a -> a -> Bool -> a-bool _ t True = t-bool f _ False = f---- |The mighty consperse function-consperse :: [a] -> [[a]] -> [a]-consperse sep items = concat (intersperse sep items)
− Linspire/Debian/SourceTree.hs
@@ -1,260 +0,0 @@--- |Type to represent an unpacked debian source tree. In order to--- support Debian's .orig.tar.gz mechanism, the source tree root--- directory is contained inside another parent directory.------ Author: David Fox-module Linspire.Debian.SourceTree - (SourceTree(SourceTreeWithParent, SourceTreeNoParent),- -- * Accessor- parent, -- SourceTree -> FilePath- path, -- SourceTree -> FilePath- -- * Constructors- -- makeTree, -- FilePath -> SourceTree- findTrees, -- FilePath -> IO [SourceTree]- findTree, -- FilePath -> IO SourceTree- copy, -- [Style] -> SourceTree -> FilePath -> IO SourceTree- chroot, -- FilePath -> FilePath -> SourceTree -> SourceTree- -- * Inquiry- controlFile, -- SourceTree -> IO Control- latestChange, -- SourceTree -> IO ChangeLogEntry- findChanges, -- SourceTree -> IO Paths.EnvPath- -- * Modify- addLogEntry, -- SourceTree -> ChangeLogEntry -> IO ()- -- * Helper- findOrigTar, -- Paragraph -> Maybe FilePath- packageName -- Control -> String- ) where--import Control.Exception-import Control.Monad-import Data.List-import Data.Maybe-import System.Directory-import System.IO-import Text.Regex-import Linspire.Unix.Progress as Progress-import Linspire.Debian.ChangeLog as ChangeLog-import Linspire.Debian.Control-import Linspire.Debian.Version-import Linspire.Unix.FilePath--data SourceTree- = SourceTreeWithParent FilePath String |- SourceTreeNoParent FilePath- deriving Show-{--instance Show SourceTree where- show (SourceTree (Just parent) name) = "SourceTree (Just \"" ++ parent ++ "\") \"" ++ name ++ "\""- show (SourceTree Nothing path)- show (No reason) = "No - " ++ reason--}---- |Return the location of the source tree. If the parent--- is Nothing the path is assumed to be an absolute pathname,--- otherwise it should be a directory name.-path :: SourceTree -> FilePath-path (SourceTreeWithParent parent subdir) = parent ++ "/" ++ subdir-path (SourceTreeNoParent dir) = dir---- |Return the location of the source tree's parent directory--- if that directory is controlled by the source tree.-parent :: SourceTree -> FilePath-parent (SourceTreeWithParent parent _) = parent-parent (SourceTreeNoParent _) = error "Source tree doesn't own its parent"--{--makeTree :: FilePath -> SourceTree-makeTree path = SourceTree Nothing path--}---- |Examine a directory and return any SourceTree objects that can be--- found there. The directory should either contain a debian--- directory with the proper control files, or it should contain a--- .orig.tar.gz file and a directory containing such a debian--- directory.-findTrees :: FilePath -> IO [SourceTree]-findTrees dir =- do- names <- doesDirectoryExist dir >>= bool (return []) (getDirectoryContents dir)- let top = SourceTreeNoParent dir- topValid <- valid top- case topValid of- True -> return [top]- False -> filterM valid (map (SourceTreeWithParent dir) names)--bool :: a -> a -> Bool -> a-bool x _ False = x-bool _ x True = x--findTree :: FilePath -> IO SourceTree-findTree dir =- do- trees <- findTrees dir- case trees of- [tree] -> return tree- [] -> error ("No SourceTree found in " ++ dir)- _ -> error ("Multiple SourceTrees found in " ++ dir)-{-- case trees of- [] -> error ("No Debian source tree found in " ++ dir)- [tree] -> return tree- case elem "debian" names of- True ->- do- trees <- filterM isSourceTree names- case trees of- [name] -> return $ SourceTree (Just dir) name- [] -> error ("No Debian source tree found in " ++ dir)- names -> error ("Multiple Debian source trees found in " ++ dir ++ ": " ++ show names)- where- isSourceTree dir = doesFileExist (dir ++ "/debian/changelog")--}--valid :: SourceTree -> IO Bool-valid tree =- mapM doesFileExist- [path tree ++ "/debian/changelog", -- A debian source tree- path tree ++ "/series"] >>= -- A quilt patches directory- return . any id--chroot :: FilePath -> FilePath -> SourceTree -> SourceTree-chroot oldRoot newRoot (SourceTreeWithParent parent name) =- case changePrefix oldRoot newRoot parent of- Nothing -> error ("Can't change prefix of parent " ++ parent ++ " from " ++ oldRoot ++ " to " ++ newRoot)- Just result -> SourceTreeWithParent result name-chroot oldRoot newRoot (SourceTreeNoParent path) =- case changePrefix oldRoot newRoot path of- Nothing -> error ("Can't change prefix of path " ++ path ++ " from " ++ oldRoot ++ " to " ++ newRoot)- Just result -> SourceTreeNoParent result---- examples--- copy (SourceTree (Just "/tmp/skipjack/apt/haskell-hsql") "haskell-hsql-1.6") "/tmp/marlin/clean-lax/work/build/haskell-hsql" ->--- rsync -aHxSpDt --delete '/tmp/skipjack/apt/haskell-hsql/' '/tmp/marlin/clean-lax/work/build/haskell-hsql'---- |Copy a source tree. The resulting tree will be a sub-directory of--- the dest filepath. If the parent directory contains a .orig.tar.gz--- file that is copied too.-copy :: [Style] -> SourceTree -> FilePath -> IO SourceTree-copy style source dest =- do- -- ePut ("copy " ++ show source ++ " " ++ show dest)- createDirectoryIfMissing True dest- systemTask copyStyle ("rsync -aHxSpDt --delete " ++ src source ++ " '" ++ dest ++ "'")-- log <- readFile (path source ++ "/debian/changelog") >>= return . ChangeLog.parse- let origTar =- case log of- (entry : _) ->- path source ++ "/../" ++- ChangeLog.package entry ++ "_" ++- Linspire.Debian.Version.version (ChangeLog.version entry) ++ ".orig.tar.gz"- [] -> error "Couldn't find changelog entry" - exists <- doesFileExist origTar- case exists of- False -> return noTimeDiff -- ePut ("No " ++ origTar ++ " found.")- True -> systemTask tarballStyle ("cp -p " ++ origTar ++ " " ++ dest)- -- ePut (" -> " ++ show (newTree source))- return $ newTree source- where- src (SourceTreeWithParent parent _) = "'" ++ parent ++ "/'" - src (SourceTreeNoParent path) = "'" ++ path ++ "'" - newTree (SourceTreeWithParent _ name) = SourceTreeWithParent dest name- newTree (SourceTreeNoParent path) = SourceTreeWithParent dest (baseName path)- copyStyle = setStyles [Start ("Copying clean source (" ++ stripDist dest ++ ")"),- Error ("Could not copy source tree from " ++ path source ++ " to " ++ dest)] style- tarballStyle = setStyles [Start ("Copying original tarball"),- Error ("Could not copy original tarball from " ++ path source ++ " to " ++ dest)] style---- |Return the contents of debian\/control. -controlFile :: SourceTree -> IO Control-controlFile source =- do- let controlPath = (path source ++ "/debian/control")- result <- parseControlFromFile controlPath- case result of- -- A valid control file must have a source paragraph and at- -- least one binary paragraph.- Right control@(Control (_ : _ : _)) -> return control- Right control -> error ("Invalid control file: " ++ show control)- Left e -> error ("Couldn't read control file: " ++ show e)--latestChange :: SourceTree -> IO ChangeLogEntry-latestChange tree =- do- let changelog = path tree ++ "/debian/changelog"- text <- try $ readFile changelog- let entries = either (error ("Error reading changelog in " ++ changelog)) ChangeLog.parse text- case entries of- [] -> error ("Empty changelog: " ++ changelog)- (entry : _) -> return entry---- |Find the .changes file which is generated by a successful run of--- dpkg-buildpackage.-findChanges :: SourceTree -> IO FilePath-findChanges source =- do- buildFiles <- getDirectoryContents (parent source)- let changesFileList = filter isChangesFile buildFiles- case changesFileList of- [] -> error ("No .changes file in " ++ parent source)- [name] -> return $ parent source ++ "/" ++ name- names -> error ("Multiple .changes files to upload: " ++ show names)- where- isChangesFile name = maybe False (\ _ -> True) (matchRegex changesRE name)- changesRE = mkRegex "\\.changes$"---- |Rewrite the changelog with an added entry.-addLogEntry :: SourceTree -> ChangeLogEntry -> IO ()-addLogEntry source entry =- do- let changelogPath = path source ++ "/debian/changelog"- original <- readFile changelogPath- -- date <- getRFC822Date- let newtext = show entry- -- ePut ("Adding changelog entry:\n" ++ show entry)-- -- This is delicate - we unlink the file here while its contents- -- are still being read into the the lazy list 'text'. If we- -- don't remove the file before writing it, text ends up looking- -- like an empty list.- removeFile changelogPath- writeFile changelogPath (newtext ++ original)---- |Get the name of the .orig.tar.gz file of a source package by--- examining the Files section of a paragraph from a Sources.gz, or as--- output by apt-cache showsrc.-findOrigTar :: Paragraph -> Maybe FilePath-findOrigTar control =- maybe Nothing (\ (Field (_, value)) ->- find (isSuffixOf ".orig.tar.gz") (parseFiles (stripWS value)))- (lookupP "Files" control)- where- -- Parse the three-field "Files" entry of section output by apt-cache showsrc:- -- md5sum size name- parseFiles text =- case (text, matchRegexAll re text) of- ("", _) -> []- (_, Just (_, _, remaining, [filename])) ->- filename : parseFiles remaining- _ -> error ("Parse error in Files section of changes file: '" ++ text)- re = mkRegex ("^[ \t\n]*" ++ t ++ w ++ t ++ w ++ "(" ++ t ++ ")" ++ "[ \t\n]*")- t = "[^ \t\n]+"- w = "[ \t]+"---- |Get the source package name from the control file.-packageName :: Control -> String-packageName (Control (paragraph : _)) =- maybe (error "Missing Source field in control file") id (fieldValue "Source" paragraph)-packageName _ = error "Invalid control file"--changePrefix :: (Eq a) => [a] -> [a] -> [a] -> Maybe [a]-changePrefix old new s = maybe Nothing (Just . (new ++)) (Linspire.Debian.SourceTree.dropPrefix old s)--dropPrefix :: (Eq a) => [a] -> [a] -> Maybe [a]-dropPrefix prefix s =- case isPrefixOf prefix s of- True -> Just (drop (length prefix) s)- False -> Nothing--ePut :: String -> IO ()-ePut s = hPutStrLn stderr s
Setup.hs view
debian.cabal view
@@ -1,12 +1,12 @@ name: debian-version: 1.0+version: 1.2 license: BSD3 license-file: debian/copyright author: Jeremy Shaw maintainer: Jeremy Shaw <jeremy@n-heptane.com> stability: volitile tested-with: GHC-build-depends: base, parsec, mtl, network, unix, Unixutils, regex-compat+build-depends: base, parsec, mtl, network, unix, regex-compat synopsis: A set of modules for working with debian control files and packages description: Modules for parsing debian control files, resolving depedencies, comparing version numbers, and other useful stuff.@@ -14,25 +14,18 @@ extensions: FlexibleInstances ghc-options: -O2 -funbox-strict-fields exposed-modules: - Linspire.Debian.AptImage,- Linspire.Debian.ChangeLog,- Linspire.Debian.Config, Linspire.Debian.Control, Linspire.Debian.Control.Common, Linspire.Debian.Control.String, Linspire.Debian.Control.ByteString, Linspire.Debian.Control.PrettyPrint, Linspire.Debian.Dependencies,- Linspire.Debian.DistroCache,- Linspire.Debian.OSImage, Linspire.Debian.Package, Linspire.Debian.PackageDeprecated, Linspire.Debian.Relation, Linspire.Debian.Relation.Common, Linspire.Debian.Relation.String, Linspire.Debian.Relation.ByteString,- Linspire.Debian.Repository,- Linspire.Debian.SourceTree, Linspire.Debian.SourcesList, Linspire.Debian.Version, Linspire.Debian.Version.Common,
debian/control view
@@ -1,7 +1,7 @@ Source: haskell-debian Priority: optional Maintainer: Jeremy Shaw <jeremy.shaw@linspireinc.com>-Build-Depends: debhelper (>= 4.0.0), ghc6 (>= 6.4.1), haskell-devscripts (>= 0.5.11+DARCS), libghc6-cabal-dev (>=1.1.3), libghc6-unixutils-dev (>= 1.2), libghc6-unixutils-prof (>= 1.2), ghc6-prof, libghc6-network-dev, libghc6-hunit-dev, libghc6-mtl-dev+Build-Depends: debhelper (>= 4.0.0), ghc6 (>= 6.4.1), haskell-devscripts (>= 0.5.11+DARCS), libghc6-cabal-dev (>=1.1.3), ghc6-prof, libghc6-network-dev, libghc6-hunit-dev, libghc6-mtl-dev Build-Depends-Indep: haddock, hugs (>= 98.200503.08) Standards-Version: 3.7.2.1 Section: devel