packages feed

debian (empty) → 1.0

raw patch · 37 files changed

+4850/−0 lines, 37 filesdep +Unixutilsdep +basedep +mtlbuild-type:Customsetup-changed

Dependencies added: Unixutils, base, mtl, network, parsec, regex-compat, unix

Files

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