diff --git a/Linspire/Debian/AptImage.hs b/Linspire/Debian/AptImage.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/AptImage.hs @@ -0,0 +1,191 @@ +-- |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 new file mode 100644 --- /dev/null +++ b/Linspire/Debian/ChangeLog.hs @@ -0,0 +1,105 @@ +-- |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 new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Config.hs @@ -0,0 +1,324 @@ +-- |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/Control.hs b/Linspire/Debian/Control.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Control.hs @@ -0,0 +1,29 @@ +-- |A module for working with Debian control files +module Linspire.Debian.Control + ( -- * Types + Control'(..) + , Paragraph'(..) + , Field'(..) + , Control + , Paragraph + , Field + , ControlParser + , ControlFunctions(..) + -- * Control File Parser + , pControl + -- * Helper Functions + , mergeControls + , fieldValue + , removeField + , prependFields + , appendFields + , renameField + , modifyField + , raiseFields + ) where + +import Control.Monad +import Data.List +import Text.ParserCombinators.Parsec +import System.IO +import Linspire.Debian.Control.String diff --git a/Linspire/Debian/Control/ByteString.hs b/Linspire/Debian/Control/ByteString.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Control/ByteString.hs @@ -0,0 +1,340 @@ +module Linspire.Debian.Control.ByteString + ( Control'(..) + , Paragraph'(..) + , Field'(..) + , Control + , Paragraph + , Field + , ControlFunctions(..) + -- * Helper Functions + , mergeControls + , fieldValue + , removeField + , prependFields + , appendFields + , renameField + , modifyField + , raiseFields + ) where + +-- Standard GHC modules + +import Control.Monad.State + +import Data.Char(chr,ord) +import Data.List +import Data.Maybe +import Data.Word + +import Foreign.C.String (CString, CStringLen) +import Foreign.C.Types (CSize) +import Foreign.ForeignPtr +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable (Storable(..)) + +import System.IO.Unsafe +import System.Environment + +import Text.ParserCombinators.Parsec.Error +import Text.ParserCombinators.Parsec.Pos + +-- Third Party Modules + +import qualified Data.ByteString as B +import qualified Data.ByteString.Base as BB +import qualified Data.ByteString.Char8 as C + +import Linspire.Debian.Control.Common + +-- Local Modules + +-- import ByteStreamParser + +-- * Types +{- +newtype Control = Control [Paragraph] +newtype Paragraph = Paragraph [Field] +newtype Field = Field (C.ByteString, C.ByteString) +-} + +type Control = Control' C.ByteString +type Paragraph = Paragraph' C.ByteString +type Field = Field' C.ByteString +-- * Control Parser + +type ControlParser a = Parser C.ByteString a + +pKey :: ControlParser C.ByteString +pKey = notEmpty $ pTakeWhile (\c -> (c /= ':') && (c /= '\n')) + +pValue :: ControlParser C.ByteString +pValue = pTakeWhile2 (\a b -> not (endOfValue a b)) + where + endOfValue :: Char -> Maybe Char -> Bool + endOfValue '\n' Nothing = True + endOfValue '\n' (Just ' ') = False + endOfValue '\n' (Just '\t') = False + endOfValue '\n' (Just '#') = False + endOfValue '\n' _ = True + endOfValue _ _ = False + +pField :: ControlParser Field +pField = + do k <- pKey + pChar ':' + v <- pValue +-- pChar '\n' + (pChar '\n' >> return ()) <|> pEOF + return (Field (k,v)) + +pComment :: ControlParser Field +pComment = + do c1 <- pChar '#' + text <- pTakeWhile2 (\ a b -> not (endOfComment a b)) + return . Comment $ (B.append (B.singleton . c2w $ c1) text) + where + endOfComment '\n' Nothing = True + endOfComment '\n' (Just '#') = False + endOfComment '\n' _ = True + endOfComment _ _ = False + +pParagraph :: ControlParser Paragraph +pParagraph = + do f <- pMany1 (pComment <|> pField) + pSkipMany (pChar '\n') + return (Paragraph f) + +pControl :: ControlParser Control +pControl = + do pSkipMany (pChar '\n') + c <- pMany pParagraph + return (Control c) + + +-- parseControlFromFile :: FilePath -> IO (Either String Control) + +instance ControlFunctions C.ByteString where + parseControlFromFile fp = + do c <- C.readFile fp + case parse pControl c of + Nothing -> return (Left (newErrorMessage (Message ("Failed to parse " ++ fp)) (newPos fp 0 0))) + (Just (cntl,_)) -> return (Right cntl) + parseControlFromHandle sourceName handle = + do c <- C.hGetContents handle + case parse pControl c of + Nothing -> return (Left (newErrorMessage (Message ("Failed to parse " ++ sourceName)) (newPos sourceName 0 0))) + (Just (cntl,_)) -> return (Right cntl) + lookupP fieldName (Paragraph fields) = + let pFieldName = C.pack fieldName in + find (\ (Field (fieldName',_)) -> fieldName' == pFieldName) fields + -- NOTE: probably inefficient + stripWS = C.reverse . strip . C.reverse . strip + where strip = C.dropWhile (flip elem " \t") + +{- +main = + do [fp] <- getArgs + C.readFile fp >>= \c -> maybe (putStrLn "failed.") (print . length . fst) (parse pControl c) +-} +-- * Helper Functions + +-- | 'takeWhile', applied to a predicate @p@ and a ByteString @xs@, +-- returns the longest prefix (possibly empty) of @xs@ of elements that +-- satisfy @p@. +takeWhile2 :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> B.ByteString +takeWhile2 f ps = BB.unsafeTake (findIndex2OrEnd (\w1 w2 -> not (f w1 w2)) ps) ps +{-# INLINE takeWhile2 #-} + +break2 :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Maybe (B.ByteString, B.ByteString) +break2 p ps = case findIndex2OrEnd p ps of n -> Just (BB.unsafeTake n ps, BB.unsafeDrop n ps) + +span2 :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Maybe (B.ByteString, B.ByteString) +span2 p ps = break2 (\a b -> not (p a b)) ps + + +-- | 'findIndexOrEnd' is a variant of findIndex, that returns the length +-- of the string if no element is found, rather than Nothing. + +findIndex2OrEnd :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Int +findIndex2OrEnd k (BB.PS x s l) = unsafePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0 + where + go a b | a `seq` b `seq` False = undefined + go ptr n | n >= l = return l + | otherwise = do w1 <- peek ptr + w2 <- if (n + 1 < l) then (peek (ptr `plusPtr` 1) >>= return . Just) else return Nothing + if k w1 w2 + then return n + else go (ptr `plusPtr` 1) (n+1) + + +{- +findIndex2OrEnd :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Int +findIndex2OrEnd k (B.PS x s l) = unsafePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0 + where + go a b | a `seq` b `seq` False = undefined + go ptr n | n >= l = return l + | otherwise = do w1 <- peek ptr + case (w2c w1) of + '\n' -> + if (n + 1 < l) + then do w2 <- peek (ptr `plusPtr` 1) + case (w2c w2) of + ' ' -> go (ptr `plusPtr` 2) (n + 2) + _ -> return n + else return l -- go (ptr `plusPtr` 1) (n + 1) + _ -> go (ptr `plusPtr` 1) (n + 1) +-} +{- + w2 <- if (n + 1 < l) then (peek (ptr `plusPtr` 1) >>= return . Just) else return Nothing + if k w1 w2 + then return n + else go (ptr `plusPtr` 1) (n+1) +-} +{-# INLINE findIndex2OrEnd #-} + +-- | The 'findIndex' function takes a predicate and a 'ByteString' and +-- returns the index of the first element in the ByteString +-- satisfying the predicate. +findIndex2 :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Maybe Int +findIndex2 k (BB.PS x s l) = unsafePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0 + where + go a b | a `seq` b `seq` False = undefined + go ptr n | n >= l = return Nothing + | otherwise = do w1 <- peek ptr + w2 <- if (n + 1 < l) then (peek (ptr `plusPtr` 1) >>= return . Just) else return Nothing + if k w1 w2 + then return (Just n) + else go (ptr `plusPtr` 1) (n+1) +{-# INLINE findIndex2 #-} + +-- Copied from ByteStream because they are not exported + +w2c :: Word8 -> Char +w2c = chr . fromIntegral + +c2w :: Char -> Word8 +c2w = fromIntegral . ord + +-- * Parser + +data Result a + = Ok a + | Fail + | Empty + deriving Show + +m2r :: Maybe a -> Result a +m2r (Just a) = Ok a +m2r Nothing = Empty + +r2m :: Result a -> Maybe a +r2m (Ok a) = Just a +r2m _ = Nothing + +newtype Parser state a = Parser { unParser :: (state -> Result (a, state)) } + +instance Monad (Parser state) where + return a = Parser (\s -> Ok (a,s)) + m >>= f = + Parser $ \state -> + let r = (unParser m) state in + case r of + Ok (a,state') -> + case unParser (f a) $ state' of + Empty -> Fail + o -> o + Empty -> Empty + Fail -> Fail + +instance MonadPlus (Parser state) where + mzero = Parser (const Empty) + mplus (Parser p1) (Parser p2) = + Parser (\s -> case p1 s of + Empty -> p2 s + o -> o + ) + +-- Parser (\s -> maybe (p2 s) (Just) (p1 s)) + + +pSucceed :: a -> Parser state a +pSucceed = return + +pFail :: Parser state a +pFail = Parser (const Empty) + + +(<|>) :: Parser state a -> Parser state a -> Parser state a +(<|>) = mplus + + +satisfy :: (Char -> Bool) -> Parser C.ByteString Char +satisfy f = + Parser $ \bs -> + if C.null bs + then Empty + else let (s,ss) = (C.head bs, C.tail bs) in + if (f s) + then Ok (s,ss) + else Empty + +pChar :: Char -> Parser C.ByteString Char +pChar c = satisfy ((==) c) + + +try :: Parser state a -> Parser state a +try (Parser p) = + Parser $ \bs -> case (p bs) of + Fail -> Empty + o -> o + +pEOF :: Parser C.ByteString () +pEOF = + Parser $ \bs -> if C.null bs then Ok ((),bs) else Empty + +pTakeWhile2 :: (Char -> Maybe Char -> Bool) -> Parser C.ByteString C.ByteString +pTakeWhile2 f = + Parser $ \bs -> m2r (span2 (\w1 w2 -> f (w2c w1) (fmap w2c w2)) bs) + +pTakeWhile :: (Char -> Bool) -> Parser C.ByteString C.ByteString +pTakeWhile f = + Parser $ \bs -> Ok (B.span (\w -> f (w2c w)) bs) + +pSkipWhile :: (Char -> Bool) -> Parser C.ByteString () +pSkipWhile p = + Parser $ \bs -> Ok ((), C.dropWhile p bs) + +pMany :: Parser st a -> Parser st [a] +pMany p + = scan id + where + scan f = do x <- p + scan (\tail -> f (x:tail)) + <|> return (f []) + +notEmpty :: Parser st C.ByteString -> Parser st C.ByteString +notEmpty (Parser p) = + Parser $ \s -> case p s of + o@(Ok (a, s)) -> + if C.null a + then Empty + else o + x -> x + +pMany1 :: Parser st a -> Parser st [a] +pMany1 p = + do x <- p + xs <- pMany p + return (x:xs) + +pSkipMany :: Parser st a -> Parser st () +pSkipMany p = scan + where + scan = (p >> scan) <|> return () + +pSkipMany1 :: Parser st a -> Parser st () +pSkipMany1 p = p >> pSkipMany p + +parse :: Parser state a -> state -> Maybe (a, state) +parse p s = r2m ((unParser p) s) diff --git a/Linspire/Debian/Control/Common.hs b/Linspire/Debian/Control/Common.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Control/Common.hs @@ -0,0 +1,88 @@ +module Linspire.Debian.Control.Common + ( -- * Types + Control'(..) + , Paragraph'(..) + , Field'(..) + , ControlFunctions(..) + , mergeControls + , fieldValue + , removeField + , prependFields + , appendFields + , renameField + , modifyField + , raiseFields, + ) + where + +import Text.ParserCombinators.Parsec +import System.IO +import Data.List + +newtype Control' a + = Control { unControl :: [Paragraph' a] } + +newtype Paragraph' a + = Paragraph [Field' a] + +-- |NOTE: we do not strip the leading or trailing whitespace in the +-- name or value +data Field' a + = Field (a, a) + | Comment a + deriving Eq + +class ControlFunctions a where + -- |'parseControlFromFile' @filepath@ is a simple wrapper function + -- that parses @filepath@ using 'pControl' + parseControlFromFile :: FilePath -> IO (Either ParseError (Control' a)) + -- |'parseControlFromHandle' @sourceName@ @handle@ - @sourceName@ is only used for error reporting + parseControlFromHandle :: String -> Handle -> IO (Either ParseError (Control' a)) + -- | 'lookupP' @fieldName paragraph@ looks up a 'Field' in a 'Paragraph'. + -- @N.B.@ trailing and leading whitespace is /not/ stripped. + lookupP :: String -> (Paragraph' a) -> Maybe (Field' a) + -- |Strip the trailing and leading space and tab characters from a + -- string. Folded whitespace is /not/ unfolded. This should probably + -- be moved to someplace more general purpose. + stripWS :: a -> a + +mergeControls :: [Control' a] -> Control' a +mergeControls controls = + Control (concatMap unControl controls) + +fieldValue :: (ControlFunctions a) => String -> Paragraph' a -> Maybe a +fieldValue fieldName paragraph = + fmap value (lookupP fieldName paragraph) + where value (Field (_, val)) = stripWS val + +removeField :: (Eq a) => a -> Paragraph' a -> Paragraph' a +removeField toRemove (Paragraph fields) = + Paragraph (filter remove fields) + where + remove (Field (name,_)) = name == toRemove + +prependFields :: [Field' a] -> Paragraph' a -> Paragraph' a +prependFields newfields (Paragraph fields) = Paragraph (newfields ++ fields) + +appendFields :: [Field' a] -> Paragraph' a -> Paragraph' a +appendFields newfields (Paragraph fields) = Paragraph (fields ++ newfields) + +renameField :: (Eq a) => a -> a -> Paragraph' a -> Paragraph' a +renameField oldname newname (Paragraph fields) = + Paragraph (map rename fields) + where + rename (Field (name, value)) | name == oldname = Field (newname, value) + rename field = field + +modifyField :: (Eq a) => a -> (a -> a) -> Paragraph' a -> Paragraph' a +modifyField name f (Paragraph fields) = + Paragraph (map modify fields) + where + modify (Field (name', value)) | name' == name = Field (name, f value) + modify field = field + +raiseFields :: (Eq a) => (a -> Bool) -> Paragraph' a -> Paragraph' a +-- ^ Move selected fields to the beginning of a paragraph. +raiseFields f (Paragraph fields) = + let (a, b) = partition f' fields in Paragraph (a ++ b) + where f' (Field (name, _)) = f name diff --git a/Linspire/Debian/Control/PrettyPrint.hs b/Linspire/Debian/Control/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Control/PrettyPrint.hs @@ -0,0 +1,27 @@ +module Linspire.Debian.Control.PrettyPrint where + +import qualified Data.ByteString.Char8 as C +import Text.PrettyPrint.HughesPJ + +import Linspire.Debian.Control.Common + +ppControl :: (ToText a) => Control' a -> Doc +ppControl (Control paragraph) = + fsep (map ppParagraph paragraph) + +ppParagraph :: (ToText a) => Paragraph' a -> Doc +ppParagraph (Paragraph fields) = + fsep (map ppField fields) + +ppField :: (ToText a) => Field' a -> Doc +ppField (Field (n,v)) = totext n <> text ":" <> totext v + + +class ToText a where + totext :: a -> Doc + +instance ToText String where + totext = text + +instance ToText C.ByteString where + totext = text . C.unpack diff --git a/Linspire/Debian/Control/String.hs b/Linspire/Debian/Control/String.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Control/String.hs @@ -0,0 +1,110 @@ +module Linspire.Debian.Control.String + ( -- * Types + Control'(..) + , Paragraph'(..) + , Field'(..) + , Control + , Paragraph + , Field + , ControlParser + , ControlFunctions(..) + -- * Control File Parser + , pControl + -- * Helper Functions + , mergeControls + , fieldValue + , removeField + , prependFields + , appendFields + , renameField + , modifyField + , raiseFields + ) where + +import Control.Monad +import Data.List +import Text.ParserCombinators.Parsec +import System.IO +import Linspire.Debian.Control.Common + +-- |This may have bad performance issues +instance Show (Control' String) where + show (Control paragraph) = concat (intersperse "\n" (map show paragraph)) + +instance Show (Paragraph' String) where + show (Paragraph fields) = unlines (map show fields) + +instance Show (Field' String) where + show (Field (name,value)) = name ++":"++ value + show (Comment text) = text + +type Field = Field' String +type Control = Control' String +type Paragraph = Paragraph' String + +-- * ControlFunctions + +instance ControlFunctions String where + parseControlFromFile filepath = + parseFromFile pControl filepath + parseControlFromHandle sourceName handle = + hGetContents handle >>= return . parse pControl sourceName + lookupP fieldName (Paragraph paragraph) = + find hasFieldName paragraph + where hasFieldName (Field (fieldName',_)) = fieldName == fieldName' + hasFieldName _ = False + stripWS = reverse . strip . reverse . strip + where strip = dropWhile (flip elem " \t") + +-- * Control File Parser + +type ControlParser a = CharParser () a + +-- |A parser for debian control file. This parser handles control files +-- that end without a newline as well as ones that have several blank +-- lines at the end. It is very liberal and does not attempt validate +-- the fields in any way. All trailing, leading, and folded whitespace +-- is preserved in the field values. See 'stripWS'. +pControl :: ControlParser Control +pControl = + do many $ char '\n' + sepEndBy pParagraph pBlanks >>= return . Control + +pParagraph :: ControlParser Paragraph +pParagraph = many1 (pComment <|> pField) >>= return . Paragraph + +-- |We are liberal in that we allow *any* field to have folded white +-- space, even though the specific restricts that to a few fields. +pField :: ControlParser Field +pField = + do c1 <- noneOf "#\n" + fieldName <- many1 $ noneOf ":\n" + char ':' + fieldValue <- many fcharfws + (char '\n' >> return ()) <|> eof + return $ Field (c1 : fieldName, fieldValue) + +pComment :: ControlParser Field +pComment = + do char '#' + text <- many (satisfy (not . ((==) '\n'))) + char '\n' + return $ Comment ("#" ++ text ++ "\n") + +fcharfws :: ControlParser Char +fcharfws = fchar <|> (try $ lookAhead (string "\n ") >> char '\n') <|> (try $ lookAhead (string "\n\t") >> char '\n') <|> (try $ lookAhead (string "\n#") >> char '\n') + +fchar :: ControlParser Char +fchar = satisfy (/='\n') + +fws :: ControlParser String +fws = + try $ do char '\n' + ws <- many1 (char ' ') + c <- many1 (satisfy (not . ((==) '\n'))) + return $ '\n' : (ws ++ c) + +-- |We go with the assumption that 'blank lines' mean lines that +-- consist of entirely of zero or more whitespace characters. +pBlanks :: ControlParser String +pBlanks = many1 (oneOf " \n") diff --git a/Linspire/Debian/Dependencies.hs b/Linspire/Debian/Dependencies.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Dependencies.hs @@ -0,0 +1,270 @@ +module Linspire.Debian.Dependencies +{- + ( solve + , State + , binaryDepends + , search + , bj' + , bt + , CSP(..) + ) -} where + +import Data.List +import Data.Maybe +import Data.Tree +import qualified Data.Map as Map + +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Char8 as C + +import Linspire.Debian.Control.ByteString +import Linspire.Debian.Control.PrettyPrint +-- import qualified Linspire.Debian.Control as SC +import Linspire.Debian.Relation.ByteString +import Linspire.Debian.Package +import Linspire.Debian.Version + +-- * Basic CSP Types and Functions + +data Status + = Remaining AndRelation + | MissingDep Relation + | Complete + deriving (Show, Eq) + +type State a = (Status, [a]) + +complete :: State a -> Bool +complete (Complete, _) = True +complete _ = False + +data CSP a + = CSP { pnm :: PackageNameMap a + , relations :: Relations + , depFunction :: (a -> Relations) + , conflicts :: a -> Relations + , packageVersion :: a -> (String, DebianVersion) + } + +-- * Test CSP + +-- |TODO addProvides -- see DQL.Exec +controlCSP :: Control -> Relations -> (Paragraph -> Relations) -> CSP Paragraph +controlCSP (Control paragraphs) rels depF = + CSP { pnm = packageNameMap getName paragraphs + , relations = rels + , depFunction = depF + , conflicts = conflicts' + , packageVersion = packageVersionParagraph + } + where + getName :: Paragraph -> String + getName p = case lookupP "Package" p of Nothing -> error "Missing Package field" ; (Just (Field (_,n))) -> C.unpack (stripWS n) + conflicts' :: Paragraph -> Relations + conflicts' p = + case lookupP "Conflicts" p of + Nothing -> [] + Just (Field (_, c)) -> either (error . show) id (parseRelations c) + +testCSP :: FilePath -> (Paragraph -> Relations) -> String -> (CSP Paragraph -> IO a) -> IO a +testCSP controlFile depf relationStr cspf = + do c' <- parseControlFromFile controlFile + case c' of + Left e -> error (show e) + Right control@(Control paragraphs) -> + case parseRelations relationStr of + Left e -> error (show e) + Right r -> + cspf (controlCSP control r depf) + +depF :: Paragraph -> Relations +depF p = + let preDepends = + case lookupP "Pre-Depends" p of + Nothing -> [] + Just (Field (_,pd)) -> + either (error . show) id (parseRelations pd) + depends = + case lookupP "Depends" p of + Nothing -> [] + Just (Field (_,pd)) -> + either (error . show) id (parseRelations pd) + in + preDepends ++ depends + +sidPackages = "/var/lib/apt/lists/ftp.debian.org_debian_dists_unstable_main_binary-i386_Packages" + +test rel labeler = + testCSP sidPackages depF rel (mapM_ (\ (_,p) -> mapM_ (print . packageVersionParagraph) p ) . take 1 . search labeler) + +-- TODO: add better errors +packageVersionParagraph :: Paragraph -> (String, DebianVersion) +packageVersionParagraph p = + case lookupP "Package" p of + Nothing -> error $ "Paragraph missing Package field" + (Just (Field (_, name))) -> + case lookupP "Version" p of + Nothing -> error $ "Paragraph missing Version field" + (Just (Field (_, version))) -> (C.unpack (stripWS name), parseDebianVersion (C.unpack version)) + + + +conflict :: CSP p -> p -> p -> Bool +conflict csp p1 p2 = + let (name1, version1) = (packageVersion csp) p1 + (name2, version2) = (packageVersion csp) p2 + in + if name1 == name2 + then version1 /= version2 + else + any (conflict' (name1, version1)) (concat $ (conflicts csp) p2) || + any (conflict' (name2, version2)) (concat $ (conflicts csp) p1) + +-- |JAS: deal with 'Provides' (can a package provide more than one package?) +conflict' :: (String, DebianVersion) -> Relation -> Bool +conflict' (pName, pVersion) rel@(Rel pkgName mVersionReq _) = + (pName == pkgName) && (checkVersionReq mVersionReq (Just pVersion)) + + + +-- * Tree Helper Functions + +mkTree :: a -> [Tree a] -> Tree a +mkTree = Node + +label :: Tree a -> a +label = rootLabel + +initTree :: (a -> [a]) -> a -> Tree a +initTree f a = Node a (map (initTree f) (f a)) + +mapTree :: (a -> b) -> Tree a -> Tree b +mapTree = fmap + +foldTree :: (a -> [b] -> b) -> Tree a -> b +foldTree f (Node a ts) = f a (map (foldTree f) ts) + +zipTreesWith :: (a -> b -> c) -> Tree a -> Tree b -> Tree c +zipTreesWith f (Node a ts) (Node b us) = + Node (f a b) (zipWith (zipTreesWith f) ts us) + +prune :: (a -> Bool) -> Tree a -> Tree a +prune p = foldTree f + where f a ts = Node a (filter (not . p . label) ts) + +leaves :: Tree a -> [a] +leaves = foldTree f + where f leaf [] = [leaf] + f _ ts = concat ts + +inhTree :: (b -> a -> b) -> b -> Tree a -> Tree b +inhTree f b (Node a ts) = Node b' (map (inhTree f b') ts) + where b' = f b a + +distrTree :: (a -> [b]) -> b -> Tree a -> Tree b +distrTree f b (Node a ts) = Node b (zipWith (distrTree f) (f a) ts) + +-- * mkSearchTree + +-- TODO: might want to leave markers about what relation we are satisfying? +mkSearchTree :: forall a. CSP a -> Tree (State a) +mkSearchTree csp = + Node (Remaining (relations csp),[]) (andRelation ([],[]) (relations csp)) + where + andRelation :: ([a],AndRelation) -> AndRelation -> [Tree (State a)] + andRelation (candidates,[]) [] = [Node (Complete, candidates) []] + andRelation (candidates,remaining) [] = andRelation (candidates, []) remaining + andRelation (candidates, remaining) (or:ors) = + orRelation (candidates, ors ++ remaining) or + orRelation :: ([a],AndRelation) -> OrRelation -> [Tree (State a)] + orRelation acc or = + concat (fmap (relation acc) or) + relation :: ([a],AndRelation) -> Relation -> [Tree (State a)] + relation acc@(candidates,_) rel = + let packages = lookupPackageByRel (pnm csp) (packageVersion csp) rel in + case packages of + [] -> [Node (MissingDep rel, candidates) []] + _ -> map (package acc) packages + package :: ([a],AndRelation) -> a -> Tree (State a) + package (candidates, remaining) package = + if ((packageVersion csp) package) `elem` (map (packageVersion csp) candidates) + then if null remaining + then Node (Complete, candidates) [] + else Node (Remaining remaining, candidates) (andRelation (candidates, []) remaining) + else Node (Remaining remaining, (package : candidates)) (andRelation ((package : candidates), remaining) ((depFunction csp) package)) + + +-- |earliestInconsistency does what it sounds like +-- the 'reverse as' is because the vars are order high to low, but we +-- want to find the lowest numbered (aka, eariest) inconsistency ?? +-- +earliestInconsistency :: CSP a -> State a -> Maybe ((String, DebianVersion), (String, DebianVersion)) +earliestInconsistency _ (_,[]) = Nothing +earliestInconsistency _ (_,[p]) = Nothing +earliestInconsistency csp (_,(p:ps)) = + case find ((conflict csp) p) (reverse ps) of + Nothing -> Nothing + (Just conflictingPackage) -> Just ((packageVersion csp) p, (packageVersion csp) conflictingPackage) + +-- * Conflict Set + +type ConflictSet = ([(String, DebianVersion)],[Relation]) -- ^ conflicting packages and relations that require non-existant packages + +isConflict :: ConflictSet -> Bool +isConflict ([],[]) = False +isConflict _ = True + +solutions :: Tree (State a, ConflictSet) -> [State a] +solutions = filter complete . map fst . leaves . prune (isConflict . snd) + +type Labeler a = CSP a -> Tree (State a) -> Tree (State a, ConflictSet) + +search :: Labeler a -> CSP a -> [State a] +search labeler csp = (solutions . (labeler csp) . mkSearchTree) csp + +-- * Backtracking Labeler + +bt :: Labeler a +bt csp = mapTree f + where + f s@(status,_) = + case status of + (MissingDep rel) -> (s, ([], [rel])) + _ -> + (s, + case (earliestInconsistency csp) s of + Nothing -> ([],[]) + Just (a,b) -> ([a,b], [])) + +-- * BackJumping Solver + +{-|bj - backjumping labeler + +If the node already has a conflict set, then leave it alone. + +Otherwise, the conflictset for the node is the combination of the +conflict sets of its direct children. +-} +bj :: CSP p -> Tree (State p, ConflictSet) -> Tree (State p, ConflictSet) +bj csp = foldTree f + where f (s, cs) ts + | isConflict cs = mkTree (s, cs) ts +-- | isConflict cs' = mkTree (s, cs') [] -- prevent space leak + | otherwise = mkTree (s, cs') ts + where cs' = + let set = combine csp (map label ts) [] in + set `seq` set -- prevent space leak + +unionCS :: [ConflictSet] -> ConflictSet +unionCS css = foldr (\(c1, m1) (c2, m2) -> ((c1 `union` c2), (m1 `union` m2))) ([],[]) css + +combine :: CSP p -> [(State p, ConflictSet)] -> [ConflictSet] -> ConflictSet +combine _ [] acc = unionCS acc +combine csp ((s,cs@(c,m)):ns) acc + | (not (lastvar `elem` c)) && null m = cs + | null c && null m = ([],[]) -- is this case ever used? + | otherwise = combine csp ns ((c, m):acc) + where lastvar = + let (_,(p:_)) = s in (packageVersion csp) p + + diff --git a/Linspire/Debian/DistroCache.hs b/Linspire/Debian/DistroCache.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/DistroCache.hs @@ -0,0 +1,125 @@ +-- |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 new file mode 100644 --- /dev/null +++ b/Linspire/Debian/OSImage.hs @@ -0,0 +1,488 @@ +-- |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/Package.hs b/Linspire/Debian/Package.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Package.hs @@ -0,0 +1,54 @@ +-- |Functions for dealing with source and binary packages in an abstract-way +module Linspire.Debian.Package where + +-- Standard GHC Modules + +import qualified Data.Map as Map + +-- Local Modules + +import Linspire.Debian.Version +import Linspire.Debian.Control +import Linspire.Debian.Relation + +type PackageNameMap a = Map.Map String [a] + +-- |'packageNameMap' creates a map from a package name to all the versions of that package +-- NOTE: Provides are not included in the map +-- NOTE: the sort order is random -- this is perhaps a bug +-- see also: 'addProvides' +packageNameMap :: (a -> String) -> [a] -> PackageNameMap a +packageNameMap getName packages = foldl (\m p -> Map.insertWith (++) (getName p) [p] m) Map.empty packages + +-- |'addProvides' finds packages that Provide other packages and adds +-- them to the PackageNameMap. They will be adde to the end of the +-- list, so that real packages have 'higher priority' than virtual +-- packages. +-- NOTE: Does not check for duplication or multiple use +addProvides :: (p -> [PkgName]) -> [p] -> PackageNameMap p -> PackageNameMap p +addProvides providesf ps pnm = + let provides = findProvides providesf ps in + foldl (\m (packageName, package) -> Map.insertWith (flip (++)) packageName [package] m) pnm provides + +-- |'findProvides' +findProvides :: forall p. (p -> [PkgName]) -> [p] -> [(PkgName, p)] +findProvides providesf packages = foldl addProvides [] packages + where addProvides :: [(PkgName, p)] -> p -> [(PkgName, p)] + addProvides providesList package = + foldl (\pl pkgName -> (pkgName, package): pl) providesList (providesf package) + +-- |'lookupPackageByRel' returns all the packages that satisfy the specified relation +-- TODO: Add architecture check +lookupPackageByRel :: PackageNameMap a -> (a -> (String, DebianVersion)) -> Relation -> [a] +lookupPackageByRel pm packageVersionF (Rel pkgName mVerReq mArch) = + case Map.lookup pkgName pm of + Nothing -> [] + Just packages -> filter filterVer packages + where filterVer p = + case mVerReq of + Nothing -> True + Just verReq -> + let (pName, pVersion) = packageVersionF p + in if pName /= pkgName + then False -- package is a virtual package, hence we can not do a version req + else checkVersionReq mVerReq (Just pVersion) diff --git a/Linspire/Debian/PackageDeprecated.hs b/Linspire/Debian/PackageDeprecated.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/PackageDeprecated.hs @@ -0,0 +1,131 @@ +-- |Experimental module for representing a single package , highly likely to change in incompatible ways. +module Linspire.Debian.PackageDeprecated where + +-- Standard GHC Modules + +import qualified Data.Map as Map + +-- Local Modules + +import Linspire.Debian.Version +import Linspire.Debian.Control +import Linspire.Debian.Relation +import Linspire.Debian.Package + +-- Simple Package Representation + +-- |A package with a name and list of dependencies +data Package + = Package { pName :: String + , pVersion :: Maybe DebianVersion + , pDepends :: Relations + , pPreDepends :: Relations + , pConflicts ::Relations + , pReplaces :: Relations + , pProvides :: Relations +-- , pParagraph :: Paragraph + } + deriving Show + +instance Eq Package where + p1 == p2 = (pName p1 == pName p2) && (pVersion p1 == pVersion p2) + +-- |FIXME: we do not deal with Provides\/virtual packages yet +paragraphToPackages :: Paragraph -> Package +paragraphToPackages p = + Package { pName = + case lookupP "Package" p of + Nothing -> error $ "Paragraph does not have Package field: " ++ (show p) + Just (Field (_,a)) -> stripWS a + , pVersion = + case lookupP "Version" p of + Nothing -> error $ "Version not found for " ++ show p + Just (Field (_,a)) -> Just (parseDebianVersion (stripWS a)) + , pDepends = tryParseRel $ lookupP "Depends" p + , pPreDepends = tryParseRel $ lookupP "Pre-Depends" p + , pConflicts = tryParseRel $ lookupP "Conflicts" p + , pReplaces = tryParseRel $ lookupP "Replaces" p + , pProvides = tryParseRel $ lookupP "Provides" p +-- , pParagraph = p + } + +type ProvidesMap = Map.Map String [Package] + +{- +findProvides :: [Package] -> ProvidesMap +findProvides packages = foldl addProvides Map.empty packages + where addProvides :: ProvidesMap -> Package -> ProvidesMap + addProvides pm package = + foldl (\m [(Rel pkgName Nothing Nothing)] -> Map.insertWith (++) pkgName [package] m) pm (pProvides package) +-} + +findProvides :: [Package] -> [(PkgName, Package)] +findProvides packages = foldl addProvides [] packages + where addProvides :: [(PkgName, Package)] -> Package -> [(PkgName, Package)] + addProvides providesList package = + foldl (\pl [(Rel pkgName Nothing Nothing)] ->(pkgName, package): pl) providesList (pProvides package) + +-- |Architecture ? +makeVirtualPackages :: ProvidesMap -> [Package] +makeVirtualPackages pm = + Map.foldWithKey mVP [] pm + where mVP vpName packages virtualPackages + = (Package { pName = vpName + , pVersion = Nothing + , pDepends = [map mkDepend packages] -- or depends on things that provide it + , pPreDepends = [] + , pConflicts = [] + , pReplaces = [] + , pProvides = [] +-- , pParagraph = Paragraph [] + } ) : virtualPackages + mkDepend package = + let name = pName package + rel = fmap EEQ (pVersion package) + in Rel name rel Nothing +{- +-- |Does not check for duplication or multiple use +addProvides :: [Package] -> PackageNameMap -> PackageNameMap +addProvides ps pnm = + let provides = findProvides ps in + foldl (\m (packageName, package) -> Map.insertWith (flip (++)) packageName [package] m) pnm provides +-- ++ (makeVirtualPackages (findProvides ps)) + + +tryParseRel :: Maybe Field -> Relations +tryParseRel Nothing = [] +tryParseRel (Just (Field (_, relStr))) = either (error . show) id (parseRelations relStr) +-} + +controlToPackageNameMap :: Control -> (Paragraph -> Package) -> PackageNameMap Package +controlToPackageNameMap (Control p) p2p = + let packages = (map p2p p) in + addProvides (map (\ (Rel pkgName _ _) -> pkgName) . concat . pProvides) packages (packageNameMap pName packages) + +packagesToPackageNameMap :: [Package] -> PackageNameMap Package +packagesToPackageNameMap packages = + addProvides (map (\ (Rel pkgName _ _) -> pkgName) . concat . pProvides) packages (packageNameMap pName packages) + +-- |TODO: Add architecture check +lookupPackageByRel :: PackageNameMap Package -> Relation -> [Package] +lookupPackageByRel pm (Rel pkgName mVerReq mArch) = + case Map.lookup pkgName pm of + Nothing -> [] + Just packages -> filter filterVer packages + where filterVer p = + case mVerReq of + Nothing -> True + Just verReq -> + if (pName p) /= pkgName + then False -- package is a virtual package, hence we can not do a version req + else checkVersionReq mVerReq (pVersion p) + + +{- + Nothing -> Nothing + Just packages -> Just $ filter (\p -> checkVersionReq mVerReq (pVersion p)) packages +-} + +tryParseRel :: Maybe Field -> Relations +tryParseRel Nothing = [] +tryParseRel (Just (Field (_, relStr))) = either (error . show) id (parseRelations relStr) diff --git a/Linspire/Debian/Relation.hs b/Linspire/Debian/Relation.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Relation.hs @@ -0,0 +1,25 @@ +-- |A module for working with debian relationships +module Linspire.Debian.Relation + ( -- * Types + PkgName + , AndRelation + , OrRelation + , Relations + , Relation(..) + , ArchitectureReq(..) + , VersionReq(..) + -- * Helper Functions + , checkVersionReq + -- * Relation Parser + , RelParser + , ParseRelations(..) + ) where + +-- Standard GHC Modules + +import Data.List +import Text.ParserCombinators.Parsec + +-- Local Modules + +import Linspire.Debian.Relation.String diff --git a/Linspire/Debian/Relation/ByteString.hs b/Linspire/Debian/Relation/ByteString.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Relation/ByteString.hs @@ -0,0 +1,41 @@ +-- |A module for working with debian relationships +module Linspire.Debian.Relation.ByteString + ( -- * Types + PkgName + , AndRelation + , OrRelation + , Relations + , Relation(..) + , ArchitectureReq(..) + , VersionReq(..) + -- * Helper Functions + , checkVersionReq + -- * Relation Parser + , RelParser + , ParseRelations(..) + ) where + +-- Standard GHC Modules + +import Data.List +import Text.ParserCombinators.Parsec + +-- 3rd Party Modules + +import qualified Data.ByteString.Char8 as C + +-- Local Modules + +import Linspire.Debian.Relation.Common +import Linspire.Debian.Relation.String +import Linspire.Debian.Version + +-- * ParseRelations + +-- For now we just wrap the string version +instance ParseRelations C.ByteString where + parseRelations byteStr = + let str = C.unpack byteStr in + case parse pRelations str str of + Right relations -> Right (filter (/= []) relations) + x -> x diff --git a/Linspire/Debian/Relation/Common.hs b/Linspire/Debian/Relation/Common.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Relation/Common.hs @@ -0,0 +1,86 @@ +module Linspire.Debian.Relation.Common where + +-- Standard GHC Modules + +import Data.List +import Text.ParserCombinators.Parsec + +-- Local Modules + +import Linspire.Debian.Version + +-- Datatype for relations + +type PkgName = String + +type Relations = AndRelation +type AndRelation = [OrRelation] +type OrRelation = [Relation] + +data Relation = Rel PkgName (Maybe VersionReq) (Maybe ArchitectureReq) + deriving Eq + + +class ParseRelations a where + -- |'parseRelations' parse a debian relation (i.e. the value of a + -- Depends field). Return a parsec error or a value of type + -- 'Relations' + parseRelations :: a -> Either ParseError Relations + + +instance Show Relation where + show (Rel name ver arch) = + name ++ maybe "" show ver ++ maybe "" show arch + +instance Ord Relation where + compare (Rel pkgName1 mVerReq1 mArch1) (Rel pkgName2 mVerReq2 mArch2) = + case compare pkgName1 pkgName2 of + LT -> LT + GT -> GT + EQ -> compare mVerReq1 mVerReq2 + +data ArchitectureReq + = ArchOnly [String] + | ArchExcept [String] + deriving Eq + +instance Show ArchitectureReq where + show (ArchOnly arch) = " [" ++ concat (intersperse " " arch) ++ "]" + show (ArchExcept arch) = " [!" ++ concat (intersperse " !" arch) ++ "]" + +data VersionReq + = SLT DebianVersion + | LTE DebianVersion + | EEQ DebianVersion + | GRE DebianVersion + | SGR DebianVersion + deriving Eq + +instance Show VersionReq where + show (SLT v) = " (<< " ++ show v ++ ")" + show (LTE v) = " (<= " ++ show v ++ ")" + show (EEQ v) = " (= " ++ show v ++ ")" + show (GRE v) = " (>= " ++ show v ++ ")" + show (SGR v) = " (>> " ++ show v ++ ")" + +-- |@FIXME:@ This instance is currently incomplete and only handles the case +-- where two version requirements are equal. +instance Ord VersionReq where + compare r1 r2 = + if r1 == r2 + then EQ + else + case (r1, r2) of + (EEQ v1, EEQ v2) -> compare v1 v2 + (a,b) -> error $ "Ord VersionReq does not handle (" ++ show a ++", "++ show b++")" + + +-- |Check if a version number satisfies a version requirement. +checkVersionReq :: Maybe VersionReq -> Maybe DebianVersion -> Bool +checkVersionReq Nothing _ = True +checkVersionReq _ Nothing = False +checkVersionReq (Just (SLT v1)) (Just v2) = v2 < v1 +checkVersionReq (Just (LTE v1)) (Just v2) = v2 <= v1 +checkVersionReq (Just (EEQ v1)) (Just v2) = v2 == v1 +checkVersionReq (Just (GRE v1)) (Just v2) = v2 >= v1 +checkVersionReq (Just (SGR v1)) (Just v2) = v2 > v1 diff --git a/Linspire/Debian/Relation/String.hs b/Linspire/Debian/Relation/String.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Relation/String.hs @@ -0,0 +1,111 @@ +-- |A module for working with debian relationships +module Linspire.Debian.Relation.String + ( -- * Types + PkgName + , AndRelation + , OrRelation + , Relations + , Relation(..) + , ArchitectureReq(..) + , VersionReq(..) + -- * Helper Functions + , checkVersionReq + -- * Relation Parser + , RelParser + , ParseRelations(..) + , pRelations + ) where + +-- Standard GHC Modules + +import Data.List +import Text.ParserCombinators.Parsec + +-- Local Modules + +import Linspire.Debian.Relation.Common +import Linspire.Debian.Version + +-- * ParseRelations + +instance ParseRelations String where + parseRelations str = + case parse pRelations str str of + Right relations -> Right (filter (/= []) relations) + x -> x + +-- * Relation Parser + +type RelParser a = CharParser () a + +pRelations :: RelParser Relations +pRelations = sepBy pOrRelation (char ',') + +pOrRelation :: RelParser OrRelation +pOrRelation = sepBy pRelation (char '|') + +whiteChar = oneOf [' ','\t','\n'] + +pRelation :: RelParser Relation +pRelation = + do skipMany whiteChar + pkgName <- many1 (noneOf [' ',',','|','\t','\n']) + skipMany whiteChar + mVerReq <- pMaybeVerReq + skipMany whiteChar + mArch <- pMaybeArch + return $ Rel pkgName mVerReq mArch + +pMaybeVerReq :: RelParser (Maybe VersionReq) +pMaybeVerReq = + do char '(' + skipMany whiteChar + op <- pVerReq + skipMany whiteChar + version <- many1 (noneOf [' ',')','\t','\n']) + skipMany whiteChar + char ')' + return $ Just (op (parseDebianVersion version)) + <|> + do return $ Nothing + +pVerReq = + do char '<' + (do char '<' <|> char ' ' <|> char '\t' + return $ SLT + <|> + do char '=' + return $ LTE) + <|> + do string "=" + return $ EEQ + <|> + do char '>' + (do char '=' + return $ GRE + <|> + do char '>' <|> char ' ' <|> char '\t' + return $ SGR) + +pMaybeArch :: RelParser (Maybe ArchitectureReq) +pMaybeArch = + do char '[' + (do archs <- pArchExcept + char ']' + return (Just (ArchExcept archs)) + <|> + do archs <- pArchOnly + char ']' + return (Just (ArchOnly archs)) + ) + <|> + return Nothing + +-- Some packages (e.g. coreutils) have architecture specs like [!i386 +-- !hppa], even though this doesn't really make sense: once you have +-- one !, anything else you include must also be (implicitly) a !. +pArchExcept :: RelParser [String] +pArchExcept = sepBy (char '!' >> many1 (noneOf [']',' '])) (skipMany1 whiteChar) + +pArchOnly :: RelParser [String] +pArchOnly = sepBy (many1 (noneOf [']',' '])) (skipMany1 whiteChar) diff --git a/Linspire/Debian/Repository.hs b/Linspire/Debian/Repository.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Repository.hs @@ -0,0 +1,879 @@ +-- |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 new file mode 100644 --- /dev/null +++ b/Linspire/Debian/SourceTree.hs @@ -0,0 +1,260 @@ +-- |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/Linspire/Debian/SourcesList.hs b/Linspire/Debian/SourcesList.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/SourcesList.hs @@ -0,0 +1,201 @@ +module Linspire.Debian.SourcesList + (DebSource(DebSource), + SourceType(Deb, DebSrc), + parseSourceLine, -- String -> DebSource + parseSourcesList, -- String -> [DebSource] + quoteWords, -- String -> [String] + archFiles) -- FilePath -> Maybe String -> DebSource -> [FilePath] + where + +import Control.Exception +import Data.List +import Network.URI + +{- + +deb uri distribution [component1] [componenent2] [...] + +The URI for the deb type must specify the base of the Debian +distribution, from which APT will find the information it needs. + +distribution can specify an exact path, in which case the components +must be omitted and distribution must end with a slash (/). + +If distribution does not specify an exact path, at least one component +must be present. + +Distribution may also contain a variable, $(ARCH), which expands to +the Debian architecture (i386, m68k, powerpc, ...) used on the +system. + +The rest of the line can be marked as a comment by using a #. + +Additional Notes: + + + Lines can begin with leading white space. + + + If the dist ends with slash (/), then it must be an absolute path + and it is an error to specify components after it. + +-} + +data SourceType + = Deb | DebSrc + deriving Eq + +instance Show SourceType where + show Deb = "deb" + show DebSrc = "deb-src" + +data DebSource + = DebSource + { sourceType :: SourceType + , sourceUri :: URI + , sourceDist :: Either String (String, [String]) -- ^ Either (ExactPath) (Distribution, [Section]) + } + deriving Eq + +instance Show DebSource where + show (DebSource thetype theuri thedist) = + (show thetype) ++" "++ (uriToString id theuri " ") ++ + case thedist of + Left exactPath -> escape exactPath + Right (dist, sections) -> + (escape dist) ++ " " ++ concat (intersperse " " (map escape sections)) + where escape = escapeURIString isAllowedInURI + +-- |quoteWords - similar to words, but with special handling of +-- double-quotes and brackets. +-- +-- The handling double quotes and [] is supposed to match: +-- apt-0.6.44.2\/apt-pkg\/contrib\/strutl.cc:ParseQuoteWord() +-- +-- The behaviour can be defined as: +-- +-- Break the string into space seperated words ignoring spaces that +-- appear between \"\" or []. Strip trailing and leading white space +-- around words. Strip out double quotes, but leave the square +-- brackets intact. +quoteWords :: String -> [String] +quoteWords [] = [] +quoteWords s = quoteWords' Nothing (dropWhile (==' ') s) + where + quoteWords' :: Maybe Char -> String -> [String] + quoteWords' Nothing [] = [] + quoteWords' Nothing str = + case break (flip elem " [\"") str of + ([],[]) -> [] + (w, []) -> [w] + (w, (' ':rest)) -> w : (quoteWords' Nothing (dropWhile (==' ') rest)) + (w, ('"':rest)) -> + case break (== '"') rest of + (w',('"':rest)) -> + case quoteWords' Nothing rest of + [] -> [w ++ w'] + (w'':ws) -> ((w ++ w' ++ w''): ws) + (w',[]) -> error ("quoteWords: missing \" in the string: " ++ s) + (w, ('[':rest)) -> + case break (== ']') rest of + (w',(']':rest)) -> + case quoteWords' Nothing rest of + [] -> [w ++ "[" ++ w' ++ "]"] + (w'':ws) -> ((w ++ "[" ++ w' ++ "]" ++ w''): ws) + (w',[]) -> error ("quoteWords: missing ] in the string: " ++ s) + +stripLine :: String -> String +stripLine = takeWhile (/= '#') . dropWhile (== ' ') + +sourceLines :: String -> [String] +sourceLines = filter (not . null) . map stripLine . lines + +-- |parseSourceLine -- parses a source line +-- the argument must be a non-empty, valid source line with comments stripped +-- see: 'sourceLines' +parseSourceLine :: String -> DebSource +parseSourceLine str = + case quoteWords str of + (theTypeStr : theUriStr : theDistStr : sectionStrs) -> + let theType = case unEscapeString theTypeStr of + "deb" -> Deb + "deb-src" -> DebSrc + o -> error ("parseSourceLine: invalid type " ++ o ++ " in line:\n" ++ str) + theUri = case parseURI theUriStr of + Nothing -> error ("parseSourceLine: invalid uri " ++ theUriStr ++ " in the line:\n" ++ str) + Just u -> u + theDist = unEscapeString theDistStr + in + case last theDist of + '/' -> if null sectionStrs + then DebSource { sourceType = theType, sourceUri = theUri, sourceDist = Left theDist } + else error ("parseSourceLine: Dist is an exact path, so sections are not allowed on the line:\n" ++ str) + _ -> if null sectionStrs + then error ("parseSourceLine: Dist is not an exact path, so at least one section is required on the line:\n" ++ str) + else DebSource { sourceType = theType, sourceUri = theUri, sourceDist = Right (theDist, map unEscapeString sectionStrs) } + _ -> error ("parseSourceLine: invalid line in sources.list:\n" ++ str) + +parseSourcesList :: String -> [DebSource] +parseSourcesList = map parseSourceLine . sourceLines + +-- |Return the list of files that apt-get update would write into +-- \/var\/lib\/apt\/lists when it processed the given list of DebSource. +-- FIXME: remove the root argument from this and just return the names. +archFiles :: FilePath -> Maybe String -> DebSource -> [FilePath] +archFiles root (Just arch) deb@(DebSource Deb _ _) = + map (++ ("_binary-" ++ arch ++ "_Packages")) (archFiles' root deb) +archFiles root Nothing deb@(DebSource DebSrc _ _) = + map (++ "_source_Sources") (archFiles' root deb) +archFiles _ _ _ = [] -- error? + +archFiles' :: FilePath -> DebSource -> [FilePath] +archFiles' root deb = + let uri = sourceUri deb + distro = sourceDist deb in + let scheme = uriScheme uri + auth = uriAuthority uri + path = uriPath uri in + let userpass = maybe "" uriUserInfo auth + reg = maybeOfString $ maybe "" uriRegName auth + port = maybe "" uriPort auth in + let (user, pass) = break (== ':') userpass in + let user' = maybeOfString user + pass' = maybeOfString pass in + let uriText = prefix scheme user' pass' reg port path in + -- what about dist? + either (\ exact -> [root ++ (escapeURIString (/= '@') ("/var/lib/apt/lists/" ++ uriText ++ escape exact))]) + (\ (dist, sections) -> + map (\ section -> root ++ (escapeURIString (/= '@') + ("/var/lib/apt/lists/" ++ + uriText ++ + "_dists_" ++ escape dist ++ "_" ++ + escape section))) + sections) + distro + where + -- If user is given and password is not, the user name is + -- added to the file name. Otherwise it is not. Really. + prefix "http:" (Just user) Nothing (Just host) port path = + user ++ host ++ port ++ escape path + prefix "http:" _ _ (Just host) port path = + host ++ port ++ escape path + prefix "ftp:" _ _ (Just host) _ path = + host ++ escape path + prefix "file:" Nothing Nothing Nothing "" path = + escape path + prefix "ssh:" (Just user) Nothing (Just host) port path = + user ++ host ++ port ++ escape path + prefix "ssh" _ _ (Just host) port path = + host ++ port ++ escape path + prefix _ _ _ _ _ _ = error ("invalid DebSource: " ++ show deb) + maybeOfString "" = Nothing + maybeOfString s = Just s + escape s = consperse "_" (wordsBy (== '/') s) + +-- |The mighty consperse function +consperse :: [a] -> [[a]] -> [a] +consperse sep items = concat (intersperse sep items) + +wordsBy :: Eq a => (a -> Bool) -> [a] -> [[a]] +wordsBy p s = + case (break p s) of + (s, []) -> [s] + (h, t) -> h : wordsBy p (drop 1 t) diff --git a/Linspire/Debian/Version.hs b/Linspire/Debian/Version.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Version.hs @@ -0,0 +1,17 @@ +-- |A module for parsing, comparing, and (eventually) modifying debian version +-- numbers. +module Linspire.Debian.Version + (DebianVersion -- |Exported abstract because the internal representation is likely to change + , parseDebianVersion + , epoch + , version + , revision + , buildDebianVersion + , evr + ) where + +import Data.Char +import Text.ParserCombinators.Parsec + +import Linspire.Debian.Version.Common +import Linspire.Debian.Version.String diff --git a/Linspire/Debian/Version/ByteString.hs b/Linspire/Debian/Version/ByteString.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Version/ByteString.hs @@ -0,0 +1,17 @@ +module Linspire.Debian.Version.ByteString + ( ParseDebianVersion(..) + ) where + +import Text.ParserCombinators.Parsec + +import qualified Data.ByteString.Char8 as C + +import Linspire.Debian.Version.Common +import Linspire.Debian.Version.Internal + +instance ParseDebianVersion C.ByteString where + parseDebianVersion byteStr = + let str = C.unpack byteStr in + case parse parseDV str str of + Left e -> error (show e) + Right dv -> DebianVersion str dv diff --git a/Linspire/Debian/Version/Common.hs b/Linspire/Debian/Version/Common.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Version/Common.hs @@ -0,0 +1,168 @@ +-- |A module for parsing, comparing, and (eventually) modifying debian version +-- numbers. +module Linspire.Debian.Version.Common + (DebianVersion -- |Exported abstract because the internal representation is likely to change + , ParseDebianVersion(..) + , evr -- DebianVersion -> (Maybe Int, String, Maybe String) + , epoch + , version + , revision + , buildDebianVersion + , parseDV + ) where + +import qualified Control.Exception(try) +import Data.Char +import Text.ParserCombinators.Parsec +import Text.Regex + +import Linspire.Debian.Version.Internal + +instance Show DebianVersion where + show (DebianVersion s _) = s + +instance Eq DebianVersion where + (DebianVersion _ v1) == (DebianVersion _ v2) = v1 == v2 + +instance Ord DebianVersion where + compare (DebianVersion _ v1) (DebianVersion _ v2) = compare v1 v2 + +-- * Ord instance + +-- make ~ less than everything, and everything else higher that letters +order :: Char -> Int +order c + | isDigit c = 0 + | isAlpha c = ord c + | c == '~' = -1 + | otherwise = (ord c) + 256 + +-- |We have to do this wackiness because ~ is less than the empty string +compareNonNumeric :: [Char] -> [Char] -> Ordering +compareNonNumeric "" "" = EQ +compareNonNumeric "" ('~':cs) = GT +compareNonNumeric ('~':cs) "" = LT +compareNonNumeric "" _ = LT +compareNonNumeric _ "" = GT +compareNonNumeric (c1:cs1) (c2:cs2) = + if (order c1) == (order c2) + then compareNonNumeric cs1 cs2 + else compare (order c1) (order c2) + +instance Eq NonNumeric where + (NonNumeric s1 n1) == (NonNumeric s2 n2) = + case compareNonNumeric s1 s2 of + EQ -> n1 == n2 + o -> False + +instance Ord NonNumeric where + compare (NonNumeric s1 n1) (NonNumeric s2 n2) = + case compareNonNumeric s1 s2 of + EQ -> compare n1 n2 + o -> o + +instance Eq Numeric where + (Numeric n1 mnn1) == (Numeric n2 mnn2) = + case compare n1 n2 of + EQ -> case compareMaybeNonNumeric mnn1 mnn2 of + EQ -> True + _ -> False + _ -> False + +compareMaybeNonNumeric :: Maybe NonNumeric -> Maybe NonNumeric -> Ordering +compareMaybeNonNumeric mnn1 mnn2 = + case (mnn1, mnn2) of + (Nothing, Nothing) -> EQ + (Just (NonNumeric nn _), Nothing) -> compareNonNumeric nn "" + (Nothing, Just (NonNumeric nn _)) -> compareNonNumeric "" nn + (Just nn1, Just nn2) -> compare nn1 nn2 + +instance Ord Numeric where + compare (Numeric n1 mnn1) (Numeric n2 mnn2) = + case compare n1 n2 of + EQ -> compareMaybeNonNumeric mnn1 mnn2 + o -> o + +-- * Parser + +class ParseDebianVersion a where + parseDebianVersion :: a-> DebianVersion +-- |Convert a string to a debian version number. May throw an +-- exception if the string is unparsable -- but I am not sure if that +-- can currently happen. Are there any invalid version strings? +-- Perhaps ones with underscore, or something? + +showNN :: NonNumeric -> String +showNN (NonNumeric s n) = s ++ showN n + +showN :: Found Numeric -> String +showN (Found (Numeric n nn)) = show n ++ maybe "" showNN nn +showN (Simulated _) = "" + +parseDV :: CharParser () (Found Int, NonNumeric, Found NonNumeric) +parseDV = + do skipMany $ oneOf " \t" + e <- parseEpoch + upstreamVersion <- parseNonNumeric True True + debianRevision <- option (Simulated (NonNumeric "" (Simulated (Numeric 0 Nothing)))) (char '-' >> parseNonNumeric True False >>= return . Found) + return (e, upstreamVersion, debianRevision) + +parseEpoch :: CharParser () (Found Int) +parseEpoch = + option (Simulated 0) (try (many1 digit >>= \d -> char ':' >> return (Found (read d)))) + + +parseNonNumeric :: Bool -> Bool -> CharParser () NonNumeric +parseNonNumeric zeroOk upstream = + do nn <- (if zeroOk then many else many1) ((noneOf "-0123456789") <|> (if upstream then upstreamDash else pzero)) + n <- parseNumeric upstream + return $ NonNumeric nn n + where + upstreamDash :: CharParser () Char + upstreamDash = try $ do char '-' + lookAhead $ (many (noneOf "- \n\t") >> char '-') + return '-' + +parseNumeric :: Bool -> CharParser () (Found Numeric) +parseNumeric upstream = + do n <- many1 (satisfy isDigit) + nn <- option Nothing (parseNonNumeric False upstream >>= return . Just) + return $ Found (Numeric (read n) nn) + <|> + return (Simulated (Numeric 0 Nothing)) + +compareTest :: String -> String -> Ordering +compareTest str1 str2 = + let v1 = either (error . show) id $ parse parseDV str1 str1 + v2 = either (error . show) id $ parse parseDV str2 str2 + in + compare v1 v2 + +-- |Split a DebianVersion into its three components: epoch, version, +-- revision. It is not safe to use the parsed version number for +-- this because you will lose information, such as leading zeros. +evr :: DebianVersion -> (Maybe Int, String, Maybe String) +evr (DebianVersion s _) = + let re = mkRegex "^(([0-9]+):)?(([^-]*)|((.*)-([^-]*)))$" in + -- ( ) ( ( )) + -- ( e ) ( v ) (v2) ( r ) + case matchRegex re s of + Just ["", _, _, v, "", _, _] -> (Nothing, v, Nothing) + Just ["", _, _, _, _, v, r] -> (Nothing, v, Just r) + Just [_, e, _, v, "", _, _] -> (Just (read e), v, Nothing) + Just [_, e, _, _, _, v, r] -> (Just (read e), v, Just r) + -- I really don't think this can happen. + _ -> error ("Invalid Debian Version String: " ++ s) + +epoch v = case evr v of (x, _, _) -> x +version v = case evr v of (_, x, _) -> x +revision v = case evr v of (_, _, x) -> x + +-- Build a Debian version number from epoch, version, revision +buildDebianVersion :: Maybe Int -> String -> Maybe String -> DebianVersion +buildDebianVersion epoch version revision = + either (error . show) (DebianVersion str) $ parse parseDV str str + where + str = (maybe "" (\ n -> show n ++ ":") epoch ++ + version ++ + maybe "" (\ s -> "-" ++ s) revision) diff --git a/Linspire/Debian/Version/Internal.hs b/Linspire/Debian/Version/Internal.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Version/Internal.hs @@ -0,0 +1,33 @@ +module Linspire.Debian.Version.Internal + ( DebianVersion(..) + , Numeric(..) + , NonNumeric(..) + , Found(..) + ) + where +-- Currently we store the original version string in the data-type so +-- that we can faithfully reproduce it quickly. Currently we do not +-- have any way to modify a version number -- so this works fine. May +-- have to change later. +data DebianVersion + = DebianVersion String (Found Int, NonNumeric, Found NonNumeric) + +data NonNumeric + = NonNumeric String (Found Numeric) + deriving Show + +data Numeric + = Numeric Int (Maybe NonNumeric) + deriving Show + + +data Found a + = Found { unFound :: a } + | Simulated { unFound :: a } + deriving Show + +instance (Eq a) => Eq (Found a) where + f1 == f2 = (unFound f1) == (unFound f2) + +instance (Ord a) => Ord (Found a) where + compare f1 f2 = compare (unFound f1) (unFound f2) diff --git a/Linspire/Debian/Version/String.hs b/Linspire/Debian/Version/String.hs new file mode 100644 --- /dev/null +++ b/Linspire/Debian/Version/String.hs @@ -0,0 +1,14 @@ +module Linspire.Debian.Version.String + ( ParseDebianVersion(..) + ) where + +import Text.ParserCombinators.Parsec + +import Linspire.Debian.Version.Common +import Linspire.Debian.Version.Internal + +instance ParseDebianVersion String where + parseDebianVersion str = + case parse parseDV str str of + Left e -> error (show e) + Right dv -> DebianVersion str dv diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,21 @@ +#!/usr/bin/runhaskell + +import Distribution.Simple +import Distribution.PackageDescription +import Distribution.Simple.LocalBuildInfo +import System.Exit +import System.Cmd +import System.Directory +import Control.Exception + +withCurrentDirectory :: FilePath -> IO a -> IO a +withCurrentDirectory path f = do + cur <- getCurrentDirectory + setCurrentDirectory path + finally f (setCurrentDirectory cur) + +runTestScript :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ExitCode +runTestScript args flag pd lbi = withCurrentDirectory "tests" (system "runhaskell Main.hs") + +main :: IO () +main = defaultMainWithHooks defaultUserHooks{runTests = runTestScript} diff --git a/debian.cabal b/debian.cabal new file mode 100644 --- /dev/null +++ b/debian.cabal @@ -0,0 +1,45 @@ +name: debian +version: 1.0 +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 +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. +category: System +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, + Linspire.Debian.Version.String, + Linspire.Debian.Version.ByteString +other-modules: + Linspire.Debian.Version.Internal +extra-source-files: + tests/Dependencies.hs tests/Main.hs tests/SourcesList.hs tests/Versions.hs debian/changelog + debian/compat debian/control debian/copyright debian/haskell-debian-doc.docs debian/rules diff --git a/debian/changelog b/debian/changelog new file mode 100644 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,139 @@ +haskell-debian (1.2) unstable; urgency=low + + * Cleanup in preperation for upload to hackageDB + + -- Jeremy Shaw Tue, 3 Apr 2007 11:13:06 -0700 + +haskell-debian (1.1.1) unstable; urgency=low + + * Handle '#' comments + * fix quoteWords in SourcesList to handle case where last + character in string is a quote character + * Remove dependency on missingh + * Dependency changes for GHC 6.6 + + -- David Fox Tue, 27 Feb 2007 05:59:05 -0800 + +haskell-debian (1.1) unstable; urgency=low + + * Deprecated Package data-type and updated a bunch of code + to remove usage of Package type + + Add Linspire.Debian.Control.PrettyPrinter + + Major update to Linsipre.Debian.Dependencies + - No longer cares what data-type is used to store the package + information. + + Major update to Linsipre.Debian.Package + - moved a bunch of stuff to PackageDeprecated + - remaining functions now package data-type independent + * Added Linspire.Debian and Linspire.Debian.DistroSpec + * Add raiseFields to Control + * Remove Tag management code from Version module (it will stay + in the autobuilder source code.) + * Fix Control parser so it can handle blank lines at the + beginning of a file. + + -- David Fox Sat, 21 Oct 2006 18:48:24 -0400 + +haskell-debian (1.0.14) unstable; urgency=low + + * Create multiple dists in the local repository, manage it + using scanIncoming et. al. + + -- David Fox Thu, 17 Aug 2006 21:41:09 -0700 + +haskell-debian (1.0.13) unstable; urgency=low + + * Repository API cleanup + * Allow a quilt 'patches' directory to be a SourceTree + * Remove DistrCache.localPoolDir function, all the distros + should share a localpool to avoid version number conflicts. + + -- David Fox Thu, 17 Aug 2006 12:40:06 -0700 + +haskell-debian (1.0.12) unstable; urgency=low + + * Add Config module, fix bug in ssh url formatting. + + -- David Fox Wed, 16 Aug 2006 09:34:00 -0700 + +haskell-debian (1.0.11) unstable; urgency=low + + * Add DistroCache, Repository, AptImage, and OSImage modules. + + -- David Fox Sat, 12 Aug 2006 08:21:28 -0700 + +haskell-debian (1.0.10) unstable; urgency=low + + * Add SourceTree, and ChangeLog modules. + + -- David Fox Tue, 8 Aug 2006 15:49:43 -0700 + +haskell-debian (1.0.9) unstable; urgency=low + + * Add Linspire.Debian.Control.modifyField + + -- David Fox Tue, 8 Aug 2006 10:29:38 -0700 + +haskell-debian (1.0.8) unstable; urgency=low + + * Add setTag, changeTag, getTag, dropTag, splitTag. + + -- David Fox Sat, 5 Aug 2006 07:02:17 -0700 + +haskell-debian (1.0.7) unstable; urgency=low + + * Add ByteString based versions of Control, Relation, Version (JS) + * Fix reading of zero length Control file fields (DSF) + * add a show method for Relations (DSF) + * Support revisions containing "-" (JS) + * Support (nonstandard) multi-line build dependencies (DSF) + * Fix pretty printing of ArchExpect type (JS) + * Fix compare for version numbers (JS) + * Accept tab as the beginning of continuation line + * Version number unit tests + + -- David Fox Fri, 9 Jun 2006 14:45:24 -0700 + +haskell-debian (1.0.6) unstable; urgency=low + + * cleaned up to match our emerging standard for debianized haskell libraries (JS) + + -- David Fox Wed, 17 May 2006 10:59:08 -0700 + +haskell-debian (1.0.5) unstable; urgency=low + + * Fix bug introduced in 1.0.4 where version 1.0.4 < 1.0.4-. + + -- David Fox Fri, 12 May 2006 06:11:56 -0700 + +haskell-debian (1.0.4) unstable; urgency=low + + * Add accessors for the version components, modify data structure so + we get revision Nothing when there is no dash in the version string. + + -- David Fox Wed, 10 May 2006 06:37:58 -0700 + +haskell-debian (1.0.3) unstable; urgency=low + + * Version bump to help with autobuilder development + + -- David Fox Tue, 9 May 2006 16:06:49 -0700 + +haskell-debian (1.0.2) unstable; urgency=low + + * Export parseControlFromHandle + + -- David Fox Tue, 9 May 2006 14:11:42 -0700 + +haskell-debian (1.0.1) unstable; urgency=low + + * Jeremy added parseControlFromHandle + + -- David Fox Tue, 9 May 2006 13:40:48 -0700 + +haskell-debian (1.0.0) unstable; urgency=low + + * Initial Release. + + -- Jeremy Shaw Tue, 4 Apr 2006 16:15:35 -0700 + diff --git a/debian/compat b/debian/compat new file mode 100644 --- /dev/null +++ b/debian/compat @@ -0,0 +1,1 @@ +4 diff --git a/debian/control b/debian/control new file mode 100644 --- /dev/null +++ b/debian/control @@ -0,0 +1,43 @@ +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-Indep: haddock, hugs (>= 98.200503.08) +Standards-Version: 3.7.2.1 +Section: devel + +Package: libghc6-debian-dev +Section: devel +Architecture: any +Depends: ${haskell:Depends}, libghc6-unixutils-dev (>= 1.2), libghc6-network-dev, libghc6-hunit-dev, libghc6-mtl-dev +Suggests: haskell-debian-doc +Description: GHC library for dealing with debian control files and packages + Modules for parsing debian control files, resolving + depedencies, comparing version numbers, and other useful stuff. + +Package: libghc6-debian-prof +Section: devel +Architecture: any +Depends: ${haskell:Depends}, libghc6-unixutils-prof (>= 1.2), libghc6-network-dev, libghc6-hunit-dev, libghc6-mtl-dev +Suggests: haskell-debian-doc +Description: GHC library for dealing with debian control files and packages + Modules for parsing debian control files, resolving + depedencies, comparing version numbers, and other useful stuff. + . + This package contains the profiling enabled libraries. + +Package: libhugs-debian +Section: devel +Architecture: all +Depends: ${haskell:Depends} +Suggests: haskell-debian-doc +Description: GHC library for dealing with debian control files and packages + Modules for parsing debian control files, resolving + depedencies, comparing version numbers, and other useful stuff. + +Package: haskell-debian-doc +Section: doc +Architecture: all +Description: Documentation for Haskell Debian library + Modules for parsing debian control files, resolving + depedencies, comparing version numbers, and other useful stuff. diff --git a/debian/copyright b/debian/copyright new file mode 100644 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,26 @@ +Copyright (c) 2006, Jeremy Shaw +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The names of the author may not be used to endorse or promote + products derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/debian/haskell-debian-doc.docs b/debian/haskell-debian-doc.docs new file mode 100644 --- /dev/null +++ b/debian/haskell-debian-doc.docs @@ -0,0 +1,1 @@ +dist/doc/html diff --git a/debian/rules b/debian/rules new file mode 100644 --- /dev/null +++ b/debian/rules @@ -0,0 +1,91 @@ +#!/usr/bin/make -f +# -*- makefile -*- +# Sample debian/rules that uses debhelper. +# This file was originally written by Joey Hess and Craig Small. +# As a special exception, when this file is copied by dh-make into a +# dh-make output file, you may use that output file without restriction. +# This special exception was added by Craig Small in version 0.37 of dh-make. + +# Uncomment this to turn on verbose mode. +#export DH_VERBOSE=1 + +build: build-stamp +build-stamp: + dh_testdir + + # Add here commands to compile the package. + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp + + # Add here commands to clean up after the build process. + if [ -x setup ] && [ -e .setup-config ] ; then ./setup clean ; fi + rm -rf setup Setup.hi Setup.ho Setup.o .*config* dist html + make clean + + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + dh_installdirs -a + + # Add here commands to install the package into debian/tmp + dh_haskell -a + +build-indep: build-indep-stamp +build-indep-stamp: + dh_testdir + +install-indep: build-indep + dh_testdir + dh_testroot + dh_clean -k + dh_installdirs -i + + dh_haskell -i + ./Setup.hs test + ./Setup.hs haddock + +# Build architecture-independent files here. +binary-indep: build-indep install-indep + dh_testdir + dh_testroot + dh_installchangelogs -i + dh_installdocs -i + dh_installexamples -i + dh_installman -i + dh_link -i + dh_strip -i + dh_compress -i + dh_fixperms -i + dh_installdeb -i + dh_shlibdeps -i + dh_gencontrol -i + dh_md5sums -i + dh_builddeb -i + +# Build architecture-dependent files here. +binary-arch: build install + dh_testdir + dh_testroot + dh_installchangelogs -a + dh_installdocs -a + dh_installexamples -a + dh_installman -a + dh_link -a + dh_strip -a + dh_compress -a + dh_fixperms -a + dh_installdeb -a + dh_shlibdeps -a + dh_gencontrol -a + dh_md5sums -a + dh_builddeb -a + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install build-indep install-indep diff --git a/tests/Dependencies.hs b/tests/Dependencies.hs new file mode 100644 --- /dev/null +++ b/tests/Dependencies.hs @@ -0,0 +1,180 @@ +module Dependencies where + +import Control.Arrow +import Test.HUnit + +import Linspire.Debian.Control.String +import Linspire.Debian.Dependencies hiding (packageVersionParagraph) +import Linspire.Debian.Relation +import Linspire.Debian.Version +import Linspire.Debian.Package + + +packageA = + [ ("Package", " a") + , ("Version", " 1.0") + , ("Depends", " b") + ] + +packageB = + [ ("Package", " b") + , ("Version", " 1.0") + ] + +packageC = + [ ("Package", " c") + , ("Version", " 1.0") + , ("Depends", " doesNotExist") + ] + +packageD = + [ ("Package", " d") + , ("Version", " 1.0") + , ("Depends", " e | f, g | h") + ] + +packageE = + [ ("Package", " e") + , ("Version", " 1.0") + ] + +packageF = + [ ("Package", " f") + , ("Version", " 1.0") + ] + +packageG = + [ ("Package", " g") + , ("Version", " 1.0") + ] + +packageH = + [ ("Package", " h") + , ("Version", " 1.0") + ] + +packageI = + [ ("Package", " i") + , ("Version", " 1.0") + , ("Depends", " k") + ] + +packageJ = + [ ("Package", " j") + , ("Version", " 1.0") + , ("Provides", " k") + ] + +packageK = + [ ("Package", " k") + , ("Version", " 1.0") + ] + + + +control + = [ packageA + , packageB + , packageC + , packageD + , packageE + , packageF + , packageG + , packageH + , packageI + , packageJ + , packageK + ] + +depends p = + case lookup "Depends" p of + Nothing -> [] + (Just v) -> either (error . show) id (parseRelations v) + +mkCSP :: [[(String, String)]] -> String -> ([(String, String)] -> Relations) -> CSP [(String, String)] +mkCSP paragraphs relStr depF = + CSP { pnm = addProvides providesF paragraphs $ packageNameMap getName paragraphs + , relations = either (error . show) id (parseRelations relStr) + , depFunction = depF + , conflicts = conflicts' + , packageVersion = packageVersionParagraph + } + where + getName :: [(String, String)] -> String + getName p = case lookup "Package" p of Nothing -> error "Missing Package field" ; (Just n) -> stripWS n + conflicts' :: [(String, String)] -> Relations + conflicts' p = + case lookup "Conflicts" p of + Nothing -> [] + (Just c) -> either (error . show) id (parseRelations c) + + providesF :: [(String, String)] -> [String] + providesF p = + case lookup "Provides" p of + Nothing -> [] + (Just v) -> + parseCommaList v + +parseCommaList :: String -> [String] +parseCommaList str = + words $ map (\c -> if c == ',' then ' ' else c) str + +packageVersionParagraph :: [(String, String)] -> (String, DebianVersion) +packageVersionParagraph p = + case lookup "Package" p of + Nothing -> error $ "Could not find Package in " ++ show p + (Just n) -> + case lookup "Version" p of + Nothing -> error $ "Could not find Package in " ++ show p + (Just v) -> + (stripWS n, parseDebianVersion v) + +mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)] +mapSnd f = map (second f) + +test1 = + let csp = mkCSP control "a" depends + expected = [ (Complete, [packageB, packageA])] + in + TestCase (assertEqual "test1" expected (search bt csp)) + +missing1 = + let csp = mkCSP control "c" depends + expected = [] + in + TestCase (assertEqual "missing1" expected (search bt csp)) + +ors1 = + let csp = mkCSP control "d" depends + expected = [ (Complete, [packageG, packageE, packageD]) + , (Complete, [packageH, packageE, packageD]) + , (Complete, [packageG, packageF, packageD]) + , (Complete, [packageH, packageF, packageD]) + ] + in + TestCase (assertEqual "ors1" expected (search bt csp)) + +provides1 = + let csp = mkCSP control "i" depends + expected = [ (Complete, [packageK, packageI]) + , (Complete, [packageJ, packageI]) + ] + in + TestCase (assertEqual "provides1" expected (search bt csp)) + +provides2 = + let csp = mkCSP control "k" depends + expected = [ (Complete, [packageK]) + , (Complete, [packageJ]) + ] + in + TestCase (assertEqual "provides2" expected (search bt csp)) + +dependencyTests = + [ test1 + , missing1 + , ors1 + , provides1 + , provides2 + ] +-- runTestText putTextToShowS test1 >>= \(c,st) -> putStrLn (st "") diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,14 @@ +module Main where + +import Test.HUnit +import System.Exit +import Versions +import SourcesList + +main = + do (c,st) <- runTestText putTextToShowS (TestList (versionTests ++ sourcesListTests)) + putStrLn (st "") + case (failures c) + (errors c) of + 0 -> return () + n -> exitFailure + diff --git a/tests/SourcesList.hs b/tests/SourcesList.hs new file mode 100644 --- /dev/null +++ b/tests/SourcesList.hs @@ -0,0 +1,44 @@ +module SourcesList where + +import Test.HUnit + +import Linspire.Debian.SourcesList + +-- * Unit Tests + +-- TODO: add test cases that test for unterminated double-quote or bracket +testQuoteWords :: Test +testQuoteWords = + test [ assertEqual "Space seperate words, no quoting" ["hello", "world","!"] (quoteWords " hello world ! ") + , assertEqual "Space seperate words, double quotes" ["hello world","!"] (quoteWords " hel\"lo world\" ! ") + , assertEqual "Space seperate words, square brackets" ["hel[lo worl]d","!"] (quoteWords " hel[lo worl]d ! ") + , assertEqual "Space seperate words, square-bracket at end" ["hel[lo world]"] (quoteWords " hel[lo world]") + , assertEqual "Space seperate words, double quote at end" ["hello world"] (quoteWords " hel\"lo world\"") + ] + +testSourcesList :: Test +testSourcesList = + test [ assertEqual "valid sources.list" validSourcesListExpected (unlines . map show . parseSourcesList $ validSourcesListStr) ] + where + validSourcesListStr = + unlines $ [ " # A comment only line " + , " deb ftp://ftp.debian.org/debian unstable main contrib non-free # typical deb line" + , " deb-src ftp://ftp.debian.org/debian unstable main contrib non-free # typical deb-src line" + , "" + , "# comment line" + , "deb http://pkg-kde.alioth.debian.org/kde-3.5.0/ ./ # exact path" + , "deb http://ftp.debian.org/whee \"space dist\" main" + , "deb http://ftp.debian.org/whee dist space%20section" + ] + validSourcesListExpected = + unlines $ [ "deb ftp://ftp.debian.org/debian unstable main contrib non-free" + , "deb-src ftp://ftp.debian.org/debian unstable main contrib non-free" + , "deb http://pkg-kde.alioth.debian.org/kde-3.5.0/ ./" + , "deb http://ftp.debian.org/whee space%20dist main" + , "deb http://ftp.debian.org/whee dist space%20section" + ] + invalidSourcesListStr1 = "deb http://pkg-kde.alioth.debian.org/kde-3.5.0/ ./ main contrib non-free # exact path with sections" + + +sourcesListTests = + [ testQuoteWords, testSourcesList ] diff --git a/tests/Versions.hs b/tests/Versions.hs new file mode 100644 --- /dev/null +++ b/tests/Versions.hs @@ -0,0 +1,111 @@ +module Versions where + +import Test.HUnit + +import Linspire.Debian.Version + +-- * Implicit Values + +implicit1 = + TestCase (assertEqual "1.0 == 1.0-" EQ (compare (parseDebianVersion "1.0") (parseDebianVersion "1.0-"))) + +implicit2 = + TestCase (assertEqual "1.0 == 1.0-0" EQ (compare (parseDebianVersion "1.0") (parseDebianVersion "1.0-0"))) + +implicit3 = + TestCase (assertEqual "1.0 == 0:1.0-0" EQ (compare (parseDebianVersion "1.0") (parseDebianVersion "0:1.0-0"))) + +implicit4 = + TestCase (assertEqual "1.0 == 1.0-" EQ (compare (parseDebianVersion "1.0") (parseDebianVersion "1.0-"))) + +implicit5 = + TestCase (assertEqual "apple = apple0" EQ (compare (parseDebianVersion "apple") (parseDebianVersion "apple0"))) + +implicit6 = + TestCase (assertEqual "apple = apple0-" EQ (compare (parseDebianVersion "apple") (parseDebianVersion "apple0-"))) + +implicit7 = + TestCase (assertEqual "apple = apple0-0" EQ (compare (parseDebianVersion "apple") (parseDebianVersion "apple0-0"))) + +-- * epoch, version, revision + +epoch1 = + TestCase (assertEqual "epoch 0:0" (Just 0) (epoch $ parseDebianVersion "0:0")) + +epoch2 = + TestCase (assertEqual "epoch 0" Nothing(epoch $ parseDebianVersion "0")) + +epoch3 = + TestCase (assertEqual "epoch 1:0" (Just 1) (epoch $ parseDebianVersion "1:0")) + +version1 = + TestCase (assertEqual "version apple" "apple" (version $ parseDebianVersion "apple")) + +version2 = + TestCase (assertEqual "version apple0" "apple0" (version $ parseDebianVersion "apple0")) + +version3 = + TestCase (assertEqual "version apple1" "apple1" (version $ parseDebianVersion "apple1")) + +revision1 = + TestCase (assertEqual "revision 1.0" Nothing (revision $ parseDebianVersion "1.0")) + +revision2 = + TestCase (assertEqual "revision 1.0-" (Just "") (revision $ parseDebianVersion "1.0-")) + +revision3 = + TestCase (assertEqual "revision 1.0-0" (Just "0") (revision $ parseDebianVersion "1.0-0")) + +revision4 = + TestCase (assertEqual "revision 1.0-apple" (Just "apple") (revision $ parseDebianVersion "1.0-apple")) + + +-- * Ordering + +compareV str1 str2 = compare (parseDebianVersion str1) (parseDebianVersion str2) + +order1 = + TestCase (assertEqual "1:1-1 > 0:1-1" GT (compareV "1:1-1" "0:1-1")) + +order2 = + TestCase (assertEqual "1-1-1 > 1-1" GT (compareV "1-1-1" "1-1")) + +-- * Dashes in upstream version + +dash1 = + TestCase (assertEqual "version of upstream-version-revision" "upstream-version" (version (parseDebianVersion "upstream-version-revision"))) + +dash2 = + TestCase (assertEqual "revision of upstream-version-revision" (Just "revision") (revision (parseDebianVersion "upstream-version-revision"))) + +-- * Insignificant Zero's + +zero1 = + TestCase (assertEqual "0.09 = 0.9" EQ (compareV "0.09" "0.9")) + +-- * Tests + +versionTests = + [ TestLabel "implicit1" implicit1 + , TestLabel "implicit2" implicit2 + , TestLabel "implicit3" implicit3 + , TestLabel "implicit4" implicit4 + , TestLabel "implicit5" implicit5 + , TestLabel "implicit5" implicit6 + , TestLabel "implicit5" implicit7 + , TestLabel "epoch1" epoch1 + , TestLabel "epoch2" epoch2 + , TestLabel "epoch3" epoch3 + , TestLabel "version1" version1 + , TestLabel "version2" version2 + , TestLabel "version3" version3 + , TestLabel "revision1" revision1 + , TestLabel "revision2" revision2 + , TestLabel "revision3" revision3 + , TestLabel "revision4" revision4 + , TestLabel "order1" order1 + , TestLabel "order2" order2 + , dash1 + , dash2 + , zero1 + ]