diff --git a/Linspire/Debian/AptImage.hs b/Linspire/Debian/AptImage.hs deleted file mode 100644 --- a/Linspire/Debian/AptImage.hs +++ /dev/null @@ -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 diff --git a/Linspire/Debian/ChangeLog.hs b/Linspire/Debian/ChangeLog.hs deleted file mode 100644 --- a/Linspire/Debian/ChangeLog.hs +++ /dev/null @@ -1,105 +0,0 @@ --- |Module for handling the Debian changelog file format --- --- --- 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 [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) diff --git a/Linspire/Debian/Config.hs b/Linspire/Debian/Config.hs deleted file mode 100644 --- a/Linspire/Debian/Config.hs +++ /dev/null @@ -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: --- --- --- See the documentation of the Flag datatype below for a description --- of the features this module supports. --- --- Author: David Fox -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 - specify the path to a configuration file --- --include - 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. diff --git a/Linspire/Debian/DistroCache.hs b/Linspire/Debian/DistroCache.hs deleted file mode 100644 --- a/Linspire/Debian/DistroCache.hs +++ /dev/null @@ -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 -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) diff --git a/Linspire/Debian/OSImage.hs b/Linspire/Debian/OSImage.hs deleted file mode 100644 --- a/Linspire/Debian/OSImage.hs +++ /dev/null @@ -1,488 +0,0 @@ --- |Module to handle Debian OS images, AKA build environments or change roots. --- --- Author: David Fox -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 diff --git a/Linspire/Debian/Repository.hs b/Linspire/Debian/Repository.hs deleted file mode 100644 --- a/Linspire/Debian/Repository.hs +++ /dev/null @@ -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 -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 = -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) diff --git a/Linspire/Debian/SourceTree.hs b/Linspire/Debian/SourceTree.hs deleted file mode 100644 --- a/Linspire/Debian/SourceTree.hs +++ /dev/null @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs diff --git a/debian.cabal b/debian.cabal --- a/debian.cabal +++ b/debian.cabal @@ -1,12 +1,12 @@ name: debian -version: 1.0 +version: 1.2 license: BSD3 license-file: debian/copyright author: Jeremy Shaw maintainer: Jeremy Shaw 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, diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -1,7 +1,7 @@ Source: haskell-debian Priority: optional Maintainer: Jeremy Shaw -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