diff --git a/Debian/Apt/Dependencies.hs b/Debian/Apt/Dependencies.hs --- a/Debian/Apt/Dependencies.hs +++ b/Debian/Apt/Dependencies.hs @@ -12,19 +12,15 @@ -- test gutsyPackages "libc6" (\csp -> bt csp) -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 Debian.Control.ByteString ---import Debian.Control.PrettyPrint -import Debian.Relation.ByteString -import Debian.Apt.Package -import Debian.Version +import Data.List((++), foldr, concat, filter, map, any, elem, null, reverse, take, zipWith, find, union) +import Data.Maybe(Maybe(..)) +import Data.Tree(Tree(rootLabel, Node)) +import Debian.Apt.Package(PackageNameMap, packageNameMap, lookupPackageByRel) +import Debian.Control.ByteString(ControlFunctions(stripWS, lookupP, parseControlFromFile), Field'(Field), Control'(Control), Paragraph, Control) +import Debian.Relation.ByteString(ParseRelations(..), Relation(..), OrRelation, AndRelation, Relations, checkVersionReq) +import Debian.Version(DebianVersion, parseDebianVersion) -- * Basic CSP Types and Functions diff --git a/Debian/Apt/Index.hs b/Debian/Apt/Index.hs --- a/Debian/Apt/Index.hs +++ b/Debian/Apt/Index.hs @@ -23,12 +23,13 @@ import Data.List import qualified Data.Map as M import Data.Time -import Data.Generics import Debian.Apt.Methods import Debian.Control (formatControl) import Debian.Control.ByteString import Debian.Control.Common -import Debian.Repo.Types +--import Debian.Repo.Types +import Debian.Release +import Debian.Sources import Debian.URI import System.Directory import System.FilePath (()) @@ -44,7 +45,7 @@ -- what was actually found. data Compression = BZ2 | GZ | Uncompressed - deriving (Read, Show, Eq, Ord, Data, Typeable, Enum, Bounded) + deriving (Read, Show, Eq, Ord, Enum, Bounded) data CheckSums = CheckSums { md5sum :: Maybe String diff --git a/Debian/Changes.hs b/Debian/Changes.hs new file mode 100644 --- /dev/null +++ b/Debian/Changes.hs @@ -0,0 +1,296 @@ +-- |Changelog and changes file support. +module Debian.Changes +{- + (-- * read, show + parseLog -- String -> [ChangeLogEntry] + , parseEntry -- String -> Maybe (ChangeLogEntry, String) + , parseChanges -- String -> Maybe ChangeLogEntry + , showHeader -- ChangeLogEntry -> String + -- * Changes File + , findChangesFiles + --, Section + --, sectionName + --, subSectionName + --, load + , parseChangesFilename + , parseChangesFile + , save + , key + , matchKey + , base + , Debian.Repo.Changes.path + , name + --, poolDir -- PackageIndex -> ChangesFile -> FilePath + , poolDir' -- Release -> ChangesFile -> ChangedFileSpec -> FilePath + , uploadLocal + , ChangesFile(..) + , changesFileName + , ChangedFileSpec(..) + , ChangeLogEntry(..) + ) -} where + +--import Control.Monad.Trans +import Data.List (intercalate) +import Data.Maybe +import qualified Debian.Control.String as S +--import Debian.Repo.LocalRepository +--import Debian.Repo.Types +import Debian.Release +import Debian.Version +--import Extra.Files (replaceFile) +--import Extra.CIO (CIO) +--import System.FilePath(splitFileName, ()) +--import System.Directory +--import qualified System.Posix.Files as F +--import Text.ParserCombinators.Parsec +import Text.Regex + +--import qualified Debian.Control.ByteString as B +import Debian.URI() + +import System.Posix.Types + +-- |A file generated by dpkg-buildpackage describing the result of a +-- package build +data ChangesFile = + Changes { changeDir :: FilePath -- ^ The full pathname of the directory holding the .changes file. + , changePackage :: String -- ^ The package name parsed from the .changes file name + , changeVersion :: DebianVersion -- ^ The version number parsed from the .changes file name + , changeRelease :: ReleaseName -- ^ The Distribution field of the .changes file + , changeArch :: Arch -- ^ The architecture parsed from the .changes file name + , changeInfo :: S.Paragraph -- ^ The contents of the .changes file + , changeEntry :: ChangeLogEntry -- ^ The value of the Changes field of the .changes file + , changeFiles :: [ChangedFileSpec] -- ^ The parsed value of the Files attribute + } + +-- |An entry in the list of files generated by the build. +data ChangedFileSpec = + ChangedFileSpec { changedFileMD5sum :: String + , changedFileSize :: FileOffset + , changedFileSection :: SubSection + , changedFilePriority :: String + , changedFileName :: FilePath + } + +-- |A changelog is a series of ChangeLogEntries +data ChangeLogEntry = Entry { logPackage :: String + , logVersion :: DebianVersion + , logDists :: [ReleaseName] + , logUrgency :: String + , logComments :: String + , logWho :: String + , logDate :: String + } + +instance Show ChangesFile where + show = changesFileName + +changesFileName :: ChangesFile -> String +changesFileName changes = + changePackage changes ++ "_" ++ show (changeVersion changes) ++ "_" ++ archName (changeArch changes) ++ ".changes" + +instance Show ChangedFileSpec where + show file = changedFileMD5sum file ++ " " ++ + show (changedFileSize file) ++ " " ++ + sectionName (changedFileSection file) ++ " " ++ + changedFilePriority file ++ " " ++ + changedFileName file + +instance Show ChangeLogEntry where + show (Entry package version dists urgency details who date) = + package ++ " (" ++ show version ++ ") " ++ intercalate " " (map releaseName' dists) ++ "; urgency=" ++ urgency ++ "\n\n" ++ + details ++ " -- " ++ 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 ++ ") " ++ intercalate " " (map releaseName' dists) ++ "; urgency=" ++ urgency ++ "..." + +-- |Parse a Debian Changelog and return a lazy list of entries +parseLog :: String -> [Either String ChangeLogEntry] +parseLog text = + case parseEntry text of + Nothing -> [] + Just (Left message) -> [Left message] + Just (Right (entry, text')) -> Right entry : parseLog text' + +-- |Parse a single changelog entry, returning the entry and the remaining text. +parseEntry :: String -> Maybe (Either String (ChangeLogEntry, String)) +parseEntry text | dropWhile (\ x -> elem x " \t\n") text == "" = Nothing +parseEntry text = + case matchRegexAll entryRE text of + Nothing -> Just (Left ("Parse error in changelog:\n" ++ text)) + Just ("", _, remaining, [_, name, version, dists, urgency, _, details, _, _, _, _, _, who, date, _]) -> + let entry = + Entry name + (parseDebianVersion version) + (map parseReleaseName . words $ dists) + urgency + details + who + date in + Just (Right (entry, remaining)) + Just ("", _, _remaining, submatches) -> Just (Left ("Internal error 15, submatches=" ++ show submatches)) + Just (before, _, _, _) -> Just (Left ("Parse error in changelog at:\n" ++ show before ++ "\nin:\n" ++ text)) + where + entryRE = mkRegex $ bol ++ blankLines ++ headerRE ++ nonSigLines ++ blankLines ++ signature ++ blankLines + nonSigLines = "((( .*)|([ \t]*)\n)+)" + -- In the debian repository, sometimes the extra space in front of the + -- day-of-month is missing, sometimes an extra one is added. + signature = "( -- ([^\n]*) (..., ? ?.. ... .... ........ .....))[ \t]*\n" + +-- |Parse the changelog information that shows up in the .changes +-- file, i.e. a changelog entry with no signature. +parseChanges :: String -> Maybe ChangeLogEntry +parseChanges text = + case matchRegex changesRE text of + Nothing -> Nothing + Just [_, name, version, dists, urgency, _, details] -> + Just $ Entry name + (parseDebianVersion version) + (map parseReleaseName . words $ dists) + urgency + details + "" "" + Just x -> error $ "Unexpected match: " ++ show x + where + changesRE = mkRegexWithOpts (bol ++ blankLines ++ optWhite ++ headerRE ++ "(.*)$") False False + +headerRE = + package ++ version ++ dists ++ urgency + where + package = "([^ \t(]*)" ++ optWhite + version = "\\(([^)]*)\\)" ++ optWhite + dists = "([^;]*);" ++ optWhite + urgency = "urgency=([^\n]*)\n" ++ blankLines + +blankLines = blankLine ++ "*" +blankLine = "(" ++ optWhite ++ "\n)" +optWhite = "[ \t]*" +bol = "^" + +{- +findChangesFiles :: FilePath -> IO [ChangesFile] +findChangesFiles dir = + getDirectoryContents dir >>= + return . filter (isSuffixOf ".changes") >>= + mapM (load dir) >>= return . catMaybes + +load :: FilePath -> String -> IO (Maybe ChangesFile) +load dir file = + do + case parseChangesFilename file of + Just (name, ver, arch) -> + do + result <- parseChangesFile dir file + case result of + Right (S.Control changes) -> + -- The .changes file should be a single paragraph, + -- but there have been instances where extra newlines + -- are inserted. To be forgiving we will concat all + -- the paragraphs into one (rather than erroring out + -- or discarding all but the first paragraph.) + let changes' = mergeParagraphs changes in + case (S.fieldValue "Files" changes', + maybe Nothing parseChanges (S.fieldValue "Changes" changes'), + S.fieldValue "Distribution" changes') of + (Just text, Just entry, Just release) -> + do return . Just $ Changes { changeDir = dir + , changePackage = name + , changeVersion = ver + , changeRelease = parseReleaseName release + , changeArch = arch + , changeInfo = changes' + , changeEntry = entry + , changeFiles = parseFileList text } + _ -> return Nothing -- Missing 'Files', 'Changes', or 'Distribution' field in .changes + Left _error -> return Nothing + Nothing -> return Nothing -- Couldn't parse changes filename + +mergeParagraphs :: [S.Paragraph] -> S.Paragraph +mergeParagraphs paragraphs = + S.Paragraph . concat . map fieldsOf $ paragraphs + where fieldsOf (S.Paragraph fields) = fields + +save :: ChangesFile -> IO () +save changes = + replaceFile path (show (updateFiles (changeFiles changes) (changeInfo changes))) + where + path = changeDir changes ++ "/" ++ changesFileName changes + updateFiles files info = S.modifyField "Files" (const (showFileList files)) info + +key :: ChangesFile -> (String, DebianVersion, Arch) +key changes = (changePackage changes, changeVersion changes, changeArch changes) + +matchKey :: ChangesFile -> (String, DebianVersion, Arch) -> Bool +matchKey changes key = key == (changePackage changes, changeVersion changes, changeArch changes) + +base :: ChangesFile -> String +base changes = + changePackage changes ++ "_" ++ show (changeVersion changes) ++ "_" ++ archName (changeArch changes) + +name :: ChangesFile -> FilePath +name changes = base changes ++ ".changes" + +path :: ChangesFile -> FilePath +path changes = changeDir changes ++ "/" ++ name changes + +-- filename name version arch ext +parseChangesFilename :: String -> Maybe (String, DebianVersion, Arch) +parseChangesFilename name = + case matchRegex (mkRegex "^(.*/)?([^_]*)_(.*)_([^.]*)\\.changes$") name of + Just [_, name, version, arch] -> Just (name, parseDebianVersion version, Binary arch) + _ -> error ("Invalid .changes file name: " ++ name) + +parseChangesFile :: FilePath -> String -> IO (Either ParseError S.Control) +parseChangesFile dir file = S.parseControlFromFile (dir ++ "/" ++ file) + +parseFileList :: String -> [ChangedFileSpec] +parseFileList text = + -- md5sum size section priority name + case (text, matchRegexAll re text) of + ("", _) -> [] + (_, Just (_, _, remaining, [md5sum, size, section, priority, filename])) -> + ChangedFileSpec { changedFileMD5sum = md5sum + , changedFileSize = read size + , changedFileSection = parseSection section + , changedFilePriority = priority + , changedFileName = filename } : parseFileList 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]+" + +showFileList :: [ChangedFileSpec] -> String +showFileList files = concat (map (("\n " ++) . show) files) + +-- | Return the subdirectory in the pool where a source package would be +-- installed. +poolDir' :: Release -> ChangesFile -> ChangedFileSpec -> FilePath +poolDir' release changes file = + case S.fieldValue "Source" (changeInfo changes) of + Nothing -> error "No 'Source' field in .changes file" + Just source -> + case releaseRepo release of + LocalRepo repo -> poolDir repo (section . changedFileSection $ file) source + x -> error $ "Unexpected repository passed to poolDir': " ++ show x + +-- | Move a build result into a local repository's 'incoming' directory. +uploadLocal :: CIO m => LocalRepository -> ChangesFile -> m () +uploadLocal repo changesFile = + do let paths = map (\ file -> changeDir changesFile changedFileName file) (changeFiles changesFile) + mapM_ (liftIO . install (outsidePath root)) (Debian.Repo.Changes.path changesFile : paths) + where + root = repoRoot repo + -- Hard link a file into the incoming directory + install root path = + do removeIfExists (dest root path) + F.createLink path (dest root path) + -- F.removeLink path + dest root path = root ++ "/incoming/" ++ snd (splitFileName path) + removeIfExists path = + do exists <- doesFileExist path + if exists then F.removeLink path else return () +-} diff --git a/Debian/GenBuildDeps.hs b/Debian/GenBuildDeps.hs --- a/Debian/GenBuildDeps.hs +++ b/Debian/GenBuildDeps.hs @@ -68,7 +68,7 @@ -- BINARY should always be ignored when deciding whether to build. If the -- pair is (BINARY, Just SOURCE) it means that binary package BINARY should -- be ignored when deiciding whether to build package SOURCE. -newtype RelaxInfo = RelaxInfo [(BinPkgName, Maybe SrcPkgName)] +newtype RelaxInfo = RelaxInfo [(BinPkgName, Maybe SrcPkgName)] deriving Show -- |Remove any dependencies that are designated \"relaxed\" by relaxInfo. relaxDeps :: RelaxInfo -> [DepInfo] -> [DepInfo] diff --git a/Debian/Release.hs b/Debian/Release.hs new file mode 100644 --- /dev/null +++ b/Debian/Release.hs @@ -0,0 +1,52 @@ +module Debian.Release where + +import Debian.URI + +-- |A distribution (aka release) name. This type is expected to refer +-- to a subdirectory of the dists directory which is at the top level +-- of a repository. +data ReleaseName = ReleaseName { relName :: String } deriving (Eq, Ord, Read, Show) + +parseReleaseName :: String -> ReleaseName +parseReleaseName name = ReleaseName {relName = unEscapeString name} + +releaseName' :: ReleaseName -> String +releaseName' (ReleaseName {relName = s}) = escapeURIString isAllowedInURI s + +-- |The types of architecture that a package can have, either Source +-- or some type of binary architecture. +data Arch = Source | Binary String deriving (Read, Show, Eq, Ord) + +archName :: Arch -> String +archName Source = "source" +archName (Binary arch) = arch + +-- |A section of a repository such as main, contrib, non-free, +-- restricted. The indexes for a section are located below the +-- distribution directory. +newtype Section = Section String deriving (Read, Show, Eq, Ord) + +-- |A package's subsection is only evident in its control information, +-- packages from different subsections all reside in the same index. +data SubSection = SubSection { section :: Section, subSectionName :: String } deriving (Read, {-Show,-} Eq, Ord) + +sectionName :: SubSection -> String +sectionName (SubSection (Section "main") y) = y +sectionName (SubSection x y) = sectionName' x ++ "/" ++ y + +sectionName' :: Section -> String +sectionName' (Section s) = escapeURIString isAllowedInURI s + +sectionNameOfSubSection :: SubSection -> String +sectionNameOfSubSection = sectionName' . section + +-- |Parse the value that appears in the @Section@ field of a .changes file. +-- (Does this need to be unesacped?) +parseSection section = + case span (/= '/') section of + (x, "") -> SubSection (Section "main") x + ("main", y) -> SubSection (Section "main") y + (x, y) -> SubSection (Section x) (tail y) + +parseSection' name = + Section (unEscapeString name) diff --git a/Debian/Repo.hs b/Debian/Repo.hs deleted file mode 100644 --- a/Debian/Repo.hs +++ /dev/null @@ -1,38 +0,0 @@ --- |This is a set of modules tied together by the AptIO monad in --- IO.hs, which keeps track of the contents of all the Apt --- repositories which are queried in the course of execution. -module Debian.Repo - ( module Debian.Repo.AptImage - , module Debian.Repo.Cache - , module Debian.Repo.Changes - , module Debian.Repo.Dependencies - , module Debian.Repo.Insert - , module Debian.Repo.IO - , module Debian.Repo.LocalRepository - , module Debian.Repo.OSImage - , module Debian.Repo.Package - , module Debian.Repo.PackageIndex - , module Debian.Repo.Release - , module Debian.Repo.Repository - , module Debian.Repo.Slice - , module Debian.Repo.SourcesList - , module Debian.Repo.SourceTree - , module Debian.Repo.Types - ) where - -import Debian.Repo.AptImage -import Debian.Repo.Cache -import Debian.Repo.Changes -import Debian.Repo.Dependencies -import Debian.Repo.Insert -import Debian.Repo.IO -import Debian.Repo.LocalRepository -import Debian.Repo.OSImage -import Debian.Repo.Package -import Debian.Repo.PackageIndex -import Debian.Repo.Release -import Debian.Repo.Repository -import Debian.Repo.Slice -import Debian.Repo.SourcesList -import Debian.Repo.SourceTree -import Debian.Repo.Types diff --git a/Debian/Repo/AptImage.hs b/Debian/Repo/AptImage.hs deleted file mode 100644 --- a/Debian/Repo/AptImage.hs +++ /dev/null @@ -1,180 +0,0 @@ --- |The AptImage object represents a partial OS image which is capable --- of running apt-get, and thus obtaining repository info and source --- code packages. -module Debian.Repo.AptImage - ( prepareAptEnv - , updateAptEnv - , aptGetSource - ) where - -import Debian.Shell -import Debian.Repo.Cache -import Debian.Repo.Changes -import Debian.Repo.Package -import Debian.Repo.IO -import Debian.Repo.Slice -import Debian.Repo.SourceTree -import Debian.Repo.Types -import Debian.Relation -import Debian.Version - -import Control.Exception -import Control.Monad.State (get, put) -import Control.Monad.Trans -import Extra.CIO -import Data.List -import Data.Maybe -import Extra.Files -import Extra.List -import System.Unix.Directory -import System.Unix.Process -import System.Cmd -import System.Directory - -instance Show AptImage where - show apt = "AptImage " ++ relName (aptImageReleaseName apt) - -instance AptCache AptImage where - globalCacheDir = aptGlobalCacheDir - rootDir = aptImageRoot - aptArch = aptImageArch - aptBaseSliceList = aptImageSliceList - aptSourcePackages = aptImageSourcePackages - aptBinaryPackages = aptImageBinaryPackages - aptReleaseName = aptImageReleaseName - -instance Ord AptImage where - compare a b = compare (aptImageReleaseName a) (aptImageReleaseName b) - -instance Eq AptImage where - a == b = compare a b == EQ - -prepareAptEnv :: CIO m - => FilePath -- Put environment in a subdirectory of this - -> SourcesChangedAction -- What to do if environment already exists and sources.list is different - -> NamedSliceList -- The sources.list - -> AptIOT m AptImage -- The resulting environment -prepareAptEnv cacheDir sourcesChangedAction sources = - get >>= return . lookupAptImage (sliceListName sources) >>= - maybe (prepareAptEnv' cacheDir sourcesChangedAction sources) return - --- |Create a skeletal enviroment sufficient to run apt-get. -{-# NOINLINE prepareAptEnv' #-} -prepareAptEnv' :: CIO m => FilePath -> SourcesChangedAction -> NamedSliceList -> AptIOT m AptImage -prepareAptEnv' cacheDir sourcesChangedAction sources = - do let root = rootPath (cacheRootDir cacheDir (ReleaseName (sliceName (sliceListName sources)))) - --vPutStrLn 2 $ "prepareAptEnv " ++ sliceName (sliceListName sources) - io $ createDirectoryIfMissing True (root ++ "/var/lib/apt/lists/partial") - io $ createDirectoryIfMissing True (root ++ "/var/lib/apt/lists/partial") - io $ createDirectoryIfMissing True (root ++ "/var/cache/apt/archives/partial") - io $ createDirectoryIfMissing True (root ++ "/var/lib/dpkg") - io $ createDirectoryIfMissing True (root ++ "/etc/apt") - io $ writeFileIfMissing True (root ++ "/var/lib/dpkg/status") "" - io $ writeFileIfMissing True (root ++ "/var/lib/dpkg/diversions") "" - -- We need to create the local pool before updating so the - -- sources.list will be valid. - let sourceListText = show (sliceList sources) - -- ePut ("writeFile " ++ (root ++ "/etc/apt/sources.list") ++ "\n" ++ sourceListText) - io $ replaceFile (root ++ "/etc/apt/sources.list") sourceListText - arch <- io $ buildArchOfRoot - let os = AptImage { aptGlobalCacheDir = cacheDir - , aptImageRoot = EnvRoot root - , aptImageArch = arch - , aptImageReleaseName = ReleaseName . sliceName . sliceListName $ sources - , aptImageSliceList = sliceList sources - , aptImageSourcePackages = [] - , aptImageBinaryPackages = [] } - os' <- updateCacheSources sourcesChangedAction os >>= updateAptEnv - get >>= put . insertAptImage (sliceListName sources) os' - return os' - --- |Run apt-get update and then retrieve all the packages referenced --- by the sources.list. The source packages are sorted so that --- packages with the same name are together with the newest first. -{-# NOINLINE updateAptEnv #-} -updateAptEnv :: CIO m => AptImage -> AptIOT m AptImage -updateAptEnv os = - do - io $ system ("apt-get" ++ aptOpts os ++ " update >/dev/null 2>&1") - -- Make the loading of the package indexes lazy. - sourcePackages <- getSourcePackages os >>= return . sortBy cmp - binaryPackages <- getBinaryPackages os - return $ os { aptImageSourcePackages = sourcePackages - , aptImageBinaryPackages = binaryPackages } - where - cmp p1 p2 = - compare v2 v1 -- Flip args to get newest first - where - v1 = packageVersion . sourcePackageID $ p1 - v2 = packageVersion . sourcePackageID $ p2 - -getSourcePackages :: CIO m => AptImage -> AptIOT m [SourcePackage] -getSourcePackages os = - mapM (sourcePackagesOfIndex' os) indexes >>= return . concat - where - indexes = concat . map (sliceIndexes os) . slices . sourceSlices . aptImageSliceList $ os - -getBinaryPackages :: CIO m => AptImage -> AptIOT m [BinaryPackage] -getBinaryPackages os = - mapM (binaryPackagesOfIndex' os) indexes >>= return . concat - where - indexes = concat . map (sliceIndexes os) . slices . binarySlices . aptImageSliceList $ os - --- |Retrieve a source package via apt-get. -aptGetSource :: (AptCache t, CIO m) - => FilePath -- Where to put the source - -> t -- Where to apt-get from - -> PkgName -- The name of the package - -> Maybe DebianVersion -- The desired version, if Nothing get newest - -> m DebianBuildTree -- The resulting source tree -aptGetSource dir os package version = - do liftIO $ createDirectoryIfMissing True dir - ready <- findDebianBuildTrees dir - let newest = listToMaybe . map (packageVersion . sourcePackageID) . filter ((== package) . packageName . sourcePackageID) . aptSourcePackages $ os - let version' = maybe newest Just version - case (version', ready) of - (Nothing, _) -> - error ("No available versions of " ++ package ++ " in " ++ rootPath (rootDir os)) - (Just requested, [tree]) - | requested == (logVersion . entry $ tree) -> - return tree - (Just requested, []) -> - do runAptGet os dir "source" [(package, Just requested)] - trees <- findDebianBuildTrees dir - case trees of - [tree] -> return tree - _ -> error "apt-get source failed" - (Just requested, _) -> - do -- One or more incorrect versions are available, remove them - liftIO $ removeRecursiveSafely dir - vBOL 0 - vEPutStr 0 $ "Retrieving APT source for " ++ package - runAptGet os dir "source" [(package, Just requested)] - trees <- findDebianBuildTrees dir - case trees of - [tree] -> return tree - _ -> error "apt-get source failed" -{- - where - _availableStyle = setStyle (setStart (Just ("Finding available versions of " ++ package ++ " in APT pool"))) - aptGetStyle = setStyle (setStart (Just ("Retrieving APT source for " ++ package))) --} - -runAptGet :: (AptCache t, CIO m) => t -> FilePath -> String -> [(PkgName, Maybe DebianVersion)] -> m (Either String [Output]) -runAptGet os dir command packages = - mkdir >>= aptget - where - mkdir = liftIO . try . createDirectoryIfMissing True $ dir - aptget (Left e) = return . Left . show $ e - aptget (Right _) = runTaskAndTest (SimpleTask 0 cmd) - cmd = (consperse " " ("cd" : dir : "&&" : "apt-get" : aptOpts os : command : map formatPackage packages)) - formatPackage (name, Nothing) = name - formatPackage (name, Just version) = name ++ "=" ++ show version - -aptOpts :: AptCache t => t -> String -aptOpts os = - (" -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") - where root = rootPath . rootDir $ os diff --git a/Debian/Repo/Cache.hs b/Debian/Repo/Cache.hs deleted file mode 100644 --- a/Debian/Repo/Cache.hs +++ /dev/null @@ -1,292 +0,0 @@ --- |An AptCache represents a local cache of a remote repository. The --- cached information is usually downloaded by running "apt-get --- update", and appears in @\/var\/lib\/apt\/lists@. -module Debian.Repo.Cache - ( SourcesChangedAction(..) - , aptSourcePackagesSorted - , sliceIndexes - , cacheDistDir - , distDir - , aptDir - , cacheRootDir - , cacheSourcesPath - , sourcesPath - , sourceDir - , aptCacheFiles - , aptCacheFilesOfSlice - , archFiles - , buildArchOfEnv - , buildArchOfRoot - , updateCacheSources - , sourcePackages - , binaryPackages - ) where - -import Control.Monad.Trans -import qualified Data.ByteString.Lazy.Char8 as L -import Data.List -import Debian.Repo.IO -import Debian.Repo.Slice -import Debian.Repo.SourcesList -import Debian.Repo.Types -import Debian.URI -import Extra.CIO (CIO, vPutStr, vPutStrBl) -import Extra.Files (replaceFile) -import System.Unix.Directory -import System.Unix.Process -import System.Directory -import System.IO - --- The following are path functions which can be used while --- constructing instances of AptCache. Each is followed by a --- corresponding function that gives the same result when applied to --- an AptCache instance. - --- | A directory which will hold all the cached files for this --- NamedSliceList. -cacheDistDir :: FilePath -> ReleaseName -> FilePath -cacheDistDir cacheDir release = cacheDir ++ "/dists/" ++ relName release - -cacheRootDir :: FilePath -> ReleaseName -> EnvRoot -cacheRootDir cacheDir release = EnvRoot (cacheDistDir cacheDir release ++ "/aptEnv") - -distDir :: AptCache c => c -> FilePath -distDir cache = cacheDistDir (globalCacheDir cache) (aptReleaseName cache) - -aptDir :: AptCache c => c -> String -> FilePath -aptDir cache package = distDir cache ++ "/apt/" ++ package - --- | The path where a text of the SliceList is stored. -cacheSourcesPath :: FilePath -> ReleaseName -> FilePath -cacheSourcesPath cacheDir release = cacheDistDir cacheDir release ++ "/sources" - -sourcesPath :: AptCache c => c -> FilePath -sourcesPath cache = cacheSourcesPath (globalCacheDir cache) (aptReleaseName cache) - --- Additional functions which can only be used on already constructed --- instances of AptCache. - --- | A directory holding all files downloaded by apt-get source for a --- certain package -sourceDir :: AptCache t => t -> String -> FilePath -sourceDir c package = distDir c ++ "/apt/" ++ package - --- |Return all the named source packages sorted by version -aptSourcePackagesSorted :: AptCache t => t -> [String] -> [SourcePackage] -aptSourcePackagesSorted os names = - sortBy cmp . filterNames names . aptSourcePackages $ os - where - filterNames names packages = - filter (flip elem names . packageName . sourcePackageID) packages - cmp p1 p2 = - compare v2 v1 -- Flip args to get newest first - where - v1 = packageVersion . sourcePackageID $ p1 - v2 = packageVersion . sourcePackageID $ p2 - --- |Return a list of the index files that contain the packages of a --- slice. -sliceIndexes :: AptCache a => a -> Slice -> [PackageIndex] -sliceIndexes cache slice = - case (sourceDist . sliceSource $ slice) of - Left exact -> error $ "Can't handle exact path in sources.list: " ++ exact - Right (release, sections) -> map (makeIndex release) sections - where - makeIndex release section = - PackageIndex { packageIndexRelease = Release { releaseRepo = sliceRepo slice - , releaseInfo = findReleaseInfo release } - , packageIndexComponent = section - , packageIndexArch = case (sourceType . sliceSource $ slice) of - DebSrc -> Source - Deb -> aptArch cache } - findReleaseInfo release = - case filter ((==) release . releaseInfoName) (repoReleaseInfo (sliceRepo slice)) of - [x] -> x - [] -> error $ ("sliceIndexes: Invalid release name: " ++ releaseName' release ++ - "\n Available: " ++ (show . map releaseInfoName . repoReleaseInfo . sliceRepo $ slice)) - xs -> error $ "Internal error 5 - multiple releases named " ++ releaseName' release ++ "\n" ++ show xs - --- |Return the paths in the local cache of the index files of a slice list. -aptCacheFiles :: AptCache a => a -> SliceList -> [FilePath] -aptCacheFiles apt sources = concat . map (aptCacheFilesOfSlice apt) $ (slices sources) - --- |Return the paths in the local cache of the index files of a single slice. -aptCacheFilesOfSlice :: AptCache a => a -> Slice -> [FilePath] -aptCacheFilesOfSlice apt slice = archFiles (aptArch apt) (sliceSource slice) - --- |Return the list of files that apt-get update would write into --- \/var\/lib\/apt\/lists when it processed the given list of DebSource. -archFiles :: Arch -> DebSource -> [FilePath] -archFiles arch deb = - case (arch, deb) of - (Source, _) -> error "Invalid build architecture: Source" - (Binary _, deb@(DebSource DebSrc _ _)) -> - map (++ "_source_Sources") (archFiles' deb) - (Binary arch, deb@(DebSource Deb _ _)) -> - map (++ ("_binary-" ++ arch ++ "_Packages")) (archFiles' deb) - -archFiles' :: DebSource -> [FilePath] -archFiles' 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 -> [(escapeURIString (/= '@') ("/var/lib/apt/lists/" ++ uriText ++ escape exact))]) - (\ (dist, sections) -> - map (\ section -> - (escapeURIString (/= '@') ("/var/lib/apt/lists/" ++ uriText +?+ "dists_") ++ - releaseName' dist ++ "_" ++ sectionName' 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 = intercalate "_" (wordsBy (== '/') s) - -buildArchOfEnv :: EnvRoot -> IO Arch -buildArchOfEnv (EnvRoot root) = - do output <- lazyCommand cmd L.empty - case exitCodeOnly output of - [ExitSuccess] -> - case (words . L.unpack . stdoutOnly $ output) of - [] -> error $ "Invalid output from " ++ cmd - (arch : _) -> return (Binary arch) - _ -> error $ "Failure: " ++ cmd - where - cmd = "export LOGNAME=root; chroot " ++ show root ++ " dpkg-architecture -qDEB_BUILD_ARCH" - -buildArchOfRoot :: IO Arch -buildArchOfRoot = - do output <- lazyCommand cmd L.empty - case exitCodeOnly output of - [ExitSuccess] -> - case (words . L.unpack . stdoutOnly $ output) of - [] -> error $ "Invalid output from " ++ cmd - (arch : _) -> return (Binary arch) - _ -> error $ "Failure: " ++ cmd - where - cmd = "dpkg-architecture -qDEB_BUILD_ARCH" - -(+?+) :: String -> String -> String -(+?+) a ('_' : b) = a +?+ b -(+?+) "" b = b -(+?+) a b = - case last a of - '_' -> (init a) +?+ b - _ -> a ++ "_" ++ b - -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) - -data SourcesChangedAction = - SourcesChangedError | - UpdateSources | - RemoveRelease - --- |Change the sources.list of an AptCache object, subject to the --- value of sourcesChangedAction. -updateCacheSources :: (AptCache c, CIO m) => SourcesChangedAction -> c -> AptIOT m c -updateCacheSources sourcesChangedAction distro = - do - let baseSources = aptBaseSliceList distro - --let distro@(ReleaseCache _ dist _) = releaseFromConfig' top text - let dir = Debian.Repo.Cache.distDir distro - distExists <- liftIO $ doesFileExist (Debian.Repo.Cache.sourcesPath distro) - case distExists of - True -> - do - fileSources <- liftIO (readFile (Debian.Repo.Cache.sourcesPath distro)) >>= verifySourcesList Nothing . parseSourcesList - case (fileSources == baseSources, sourcesChangedAction) of - (True, _) -> return () - (False, SourcesChangedError) -> - do - lift (vPutStrBl 0 ("The sources.list in the existing '" ++ relName (aptReleaseName distro) ++ - "' build environment doesn't match the parameters passed to the autobuilder" ++ - ":\n\n" ++ Debian.Repo.Cache.sourcesPath distro ++ ":\n\n" ++ - show fileSources ++ - "\nRun-time parameters:\n\n" ++ - show baseSources ++ "\n" ++ - "It is likely that the build environment in\n" ++ - dir ++ " is invalid and should be rebuilt.")) - lift (vPutStr 0 "Remove it and continue (or exit)? [y/n]: ") - result <- liftIO $ hGetLine stdin - case result of - ('y' : _) -> - do - liftIO $ removeRecursiveSafely dir - liftIO $ createDirectoryIfMissing True dir - liftIO $ replaceFile (Debian.Repo.Cache.sourcesPath distro) (show baseSources) - _ -> - error ("Please remove " ++ dir ++ " and restart.") - (False, RemoveRelease) -> - do - lift (vPutStrBl 0 ("Removing suspect environment: " ++ dir)) - liftIO $ removeRecursiveSafely dir - liftIO $ createDirectoryIfMissing True dir - liftIO $ replaceFile (Debian.Repo.Cache.sourcesPath distro) (show baseSources) - (False, UpdateSources) -> - do - -- The sources.list has changed, but it should be - -- safe to update it. - lift (vPutStrBl 0 ("Updating environment with new sources.list: " ++ dir)) - liftIO $ removeFile (Debian.Repo.Cache.sourcesPath distro) - liftIO $ replaceFile (Debian.Repo.Cache.sourcesPath distro) (show baseSources) - False -> - do - liftIO $ createDirectoryIfMissing True dir - liftIO $ replaceFile (Debian.Repo.Cache.sourcesPath distro) (show baseSources) - return distro - --- | Return a sorted list of available source packages, newest version first. -sourcePackages :: AptCache a => a -> [String] -> [SourcePackage] -sourcePackages os names = - sortBy cmp . filterNames names . aptSourcePackages $ os - where - filterNames :: [String] -> [SourcePackage] -> [SourcePackage] - filterNames names packages = - filter (flip elem names . packageName . sourcePackageID) packages - cmp p1 p2 = - compare v2 v1 -- Flip args to get newest first - where - v1 = packageVersion . sourcePackageID $ p1 - v2 = packageVersion . sourcePackageID $ p2 - -binaryPackages :: AptCache a => a -> [String] -> [BinaryPackage] -binaryPackages os names = - sortBy cmp . filterNames names . aptBinaryPackages $ os - where - filterNames :: [String] -> [BinaryPackage] -> [BinaryPackage] - filterNames names packages = - filter (flip elem names . packageName . packageID) packages - cmp p1 p2 = - compare v2 v1 -- Flip args to get newest first - where - v1 = packageVersion . packageID $ p1 - v2 = packageVersion . packageID $ p2 diff --git a/Debian/Repo/Changes.hs b/Debian/Repo/Changes.hs deleted file mode 100644 --- a/Debian/Repo/Changes.hs +++ /dev/null @@ -1,292 +0,0 @@ --- |Basic types for the Apt library. -module Debian.Repo.Changes - (-- * read, show - parseLog -- String -> [ChangeLogEntry] - , parseEntry -- String -> Maybe (ChangeLogEntry, String) - , parseChanges -- String -> Maybe ChangeLogEntry - , showHeader -- ChangeLogEntry -> String - -- * Changes File - , findChangesFiles - --, Section - --, sectionName - --, subSectionName - --, load - , parseChangesFilename - , parseChangesFile - , save - , key - , matchKey - , base - , Debian.Repo.Changes.path - , name - --, poolDir -- PackageIndex -> ChangesFile -> FilePath - , poolDir' -- Release -> ChangesFile -> ChangedFileSpec -> FilePath - , uploadLocal - , ChangesFile(..) - , changesFileName - , ChangedFileSpec(..) - , ChangeLogEntry(..) - ) where - -import Control.Monad.Trans -import Data.List (isSuffixOf, intercalate) -import Data.Maybe -import qualified Debian.Control.String as S -import Debian.Repo.LocalRepository -import Debian.Repo.Types -import Debian.Version -import Extra.Files (replaceFile) -import Extra.CIO (CIO) -import System.FilePath(splitFileName, ()) -import System.Directory -import qualified System.Posix.Files as F -import Text.ParserCombinators.Parsec -import Text.Regex - -import qualified Debian.Control.ByteString as B -import Debian.URI() - -import System.Posix.Types - --- |A file generated by dpkg-buildpackage describing the result of a --- package build -data ChangesFile = - Changes { changeDir :: FilePath -- ^ The full pathname of the directory holding the .changes file. - , changePackage :: String -- ^ The package name parsed from the .changes file name - , changeVersion :: DebianVersion -- ^ The version number parsed from the .changes file name - , changeRelease :: ReleaseName -- ^ The Distribution field of the .changes file - , changeArch :: Arch -- ^ The architecture parsed from the .changes file name - , changeInfo :: S.Paragraph -- ^ The contents of the .changes file - , changeEntry :: ChangeLogEntry -- ^ The value of the Changes field of the .changes file - , changeFiles :: [ChangedFileSpec] -- ^ The parsed value of the Files attribute - } - --- |An entry in the list of files generated by the build. -data ChangedFileSpec = - ChangedFileSpec { changedFileMD5sum :: String - , changedFileSize :: FileOffset - , changedFileSection :: SubSection - , changedFilePriority :: String - , changedFileName :: FilePath - } - --- |A changelog is a series of ChangeLogEntries -data ChangeLogEntry = Entry { logPackage :: String - , logVersion :: DebianVersion - , logDists :: [ReleaseName] - , logUrgency :: String - , logComments :: String - , logWho :: String - , logDate :: String - } - -instance Show ChangesFile where - show = changesFileName - -changesFileName :: ChangesFile -> String -changesFileName changes = - changePackage changes ++ "_" ++ show (changeVersion changes) ++ "_" ++ archName (changeArch changes) ++ ".changes" - -instance Show ChangedFileSpec where - show file = changedFileMD5sum file ++ " " ++ - show (changedFileSize file) ++ " " ++ - sectionName (changedFileSection file) ++ " " ++ - changedFilePriority file ++ " " ++ - changedFileName file - -instance Show ChangeLogEntry where - show (Entry package version dists urgency details who date) = - package ++ " (" ++ show version ++ ") " ++ intercalate " " (map releaseName' dists) ++ "; urgency=" ++ urgency ++ "\n\n" ++ - details ++ " -- " ++ 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 ++ ") " ++ intercalate " " (map releaseName' dists) ++ "; urgency=" ++ urgency ++ "..." - --- |Parse a Debian Changelog and return a lazy list of entries -parseLog :: String -> [Either String ChangeLogEntry] -parseLog text = - case parseEntry text of - Nothing -> [] - Just (Left message) -> [Left message] - Just (Right (entry, text')) -> Right entry : parseLog text' - --- |Parse a single changelog entry, returning the entry and the remaining text. -parseEntry :: String -> Maybe (Either String (ChangeLogEntry, String)) -parseEntry text | dropWhile (\ x -> elem x " \t\n") text == "" = Nothing -parseEntry text = - case matchRegexAll entryRE text of - Nothing -> Just (Left ("Parse error in changelog:\n" ++ text)) - Just ("", _, remaining, [_, name, version, dists, urgency, _, details, _, _, _, _, _, who, date, _]) -> - let entry = - Entry name - (parseDebianVersion version) - (map parseReleaseName . words $ dists) - urgency - details - who - date in - Just (Right (entry, remaining)) - Just ("", _, _remaining, submatches) -> Just (Left ("Internal error 15, submatches=" ++ show submatches)) - Just (before, _, _, _) -> Just (Left ("Parse error in changelog at:\n" ++ show before ++ "\nin:\n" ++ text)) - where - entryRE = mkRegex $ bol ++ blankLines ++ headerRE ++ nonSigLines ++ blankLines ++ signature ++ blankLines - nonSigLines = "((( .*)|([ \t]*)\n)+)" - -- In the debian repository, sometimes the extra space in front of the - -- day-of-month is missing, sometimes an extra one is added. - signature = "( -- ([^\n]*) (..., ? ?.. ... .... ........ .....))[ \t]*\n" - --- |Parse the changelog information that shows up in the .changes --- file, i.e. a changelog entry with no signature. -parseChanges :: String -> Maybe ChangeLogEntry -parseChanges text = - case matchRegex changesRE text of - Nothing -> Nothing - Just [_, name, version, dists, urgency, _, details] -> - Just $ Entry name - (parseDebianVersion version) - (map parseReleaseName . words $ dists) - urgency - details - "" "" - Just x -> error $ "Unexpected match: " ++ show x - where - changesRE = mkRegexWithOpts (bol ++ blankLines ++ optWhite ++ headerRE ++ "(.*)$") False False - -headerRE = - package ++ version ++ dists ++ urgency - where - package = "([^ \t(]*)" ++ optWhite - version = "\\(([^)]*)\\)" ++ optWhite - dists = "([^;]*);" ++ optWhite - urgency = "urgency=([^\n]*)\n" ++ blankLines - -blankLines = blankLine ++ "*" -blankLine = "(" ++ optWhite ++ "\n)" -optWhite = "[ \t]*" -bol = "^" - -findChangesFiles :: FilePath -> IO [ChangesFile] -findChangesFiles dir = - getDirectoryContents dir >>= - return . filter (isSuffixOf ".changes") >>= - mapM (load dir) >>= return . catMaybes - -load :: FilePath -> String -> IO (Maybe ChangesFile) -load dir file = - do - case parseChangesFilename file of - Just (name, ver, arch) -> - do - result <- parseChangesFile dir file - case result of - Right (S.Control changes) -> - -- The .changes file should be a single paragraph, - -- but there have been instances where extra newlines - -- are inserted. To be forgiving we will concat all - -- the paragraphs into one (rather than erroring out - -- or discarding all but the first paragraph.) - let changes' = mergeParagraphs changes in - case (S.fieldValue "Files" changes', - maybe Nothing parseChanges (S.fieldValue "Changes" changes'), - S.fieldValue "Distribution" changes') of - (Just text, Just entry, Just release) -> - do return . Just $ Changes { changeDir = dir - , changePackage = name - , changeVersion = ver - , changeRelease = parseReleaseName release - , changeArch = arch - , changeInfo = changes' - , changeEntry = entry - , changeFiles = parseFileList text } - _ -> return Nothing -- Missing 'Files', 'Changes', or 'Distribution' field in .changes - Left _error -> return Nothing - Nothing -> return Nothing -- Couldn't parse changes filename - -mergeParagraphs :: [S.Paragraph] -> S.Paragraph -mergeParagraphs paragraphs = - S.Paragraph . concat . map fieldsOf $ paragraphs - where fieldsOf (S.Paragraph fields) = fields - -save :: ChangesFile -> IO () -save changes = - replaceFile path (show (updateFiles (changeFiles changes) (changeInfo changes))) - where - path = changeDir changes ++ "/" ++ changesFileName changes - updateFiles files info = S.modifyField "Files" (const (showFileList files)) info - -key :: ChangesFile -> (String, DebianVersion, Arch) -key changes = (changePackage changes, changeVersion changes, changeArch changes) - -matchKey :: ChangesFile -> (String, DebianVersion, Arch) -> Bool -matchKey changes key = key == (changePackage changes, changeVersion changes, changeArch changes) - -base :: ChangesFile -> String -base changes = - changePackage changes ++ "_" ++ show (changeVersion changes) ++ "_" ++ archName (changeArch changes) - -name :: ChangesFile -> FilePath -name changes = base changes ++ ".changes" - -path :: ChangesFile -> FilePath -path changes = changeDir changes ++ "/" ++ name changes - --- filename name version arch ext -parseChangesFilename :: String -> Maybe (String, DebianVersion, Arch) -parseChangesFilename name = - case matchRegex (mkRegex "^(.*/)?([^_]*)_(.*)_([^.]*)\\.changes$") name of - Just [_, name, version, arch] -> Just (name, parseDebianVersion version, Binary arch) - _ -> error ("Invalid .changes file name: " ++ name) - -parseChangesFile :: FilePath -> String -> IO (Either ParseError S.Control) -parseChangesFile dir file = S.parseControlFromFile (dir ++ "/" ++ file) - -parseFileList :: String -> [ChangedFileSpec] -parseFileList text = - -- md5sum size section priority name - case (text, matchRegexAll re text) of - ("", _) -> [] - (_, Just (_, _, remaining, [md5sum, size, section, priority, filename])) -> - ChangedFileSpec { changedFileMD5sum = md5sum - , changedFileSize = read size - , changedFileSection = parseSection section - , changedFilePriority = priority - , changedFileName = filename } : parseFileList 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]+" - -showFileList :: [ChangedFileSpec] -> String -showFileList files = concat (map (("\n " ++) . show) files) - --- | Return the subdirectory in the pool where a source package would be --- installed. -poolDir' :: Release -> ChangesFile -> ChangedFileSpec -> FilePath -poolDir' release changes file = - case S.fieldValue "Source" (changeInfo changes) of - Nothing -> error "No 'Source' field in .changes file" - Just source -> - case releaseRepo release of - LocalRepo repo -> poolDir repo (section . changedFileSection $ file) source - x -> error $ "Unexpected repository passed to poolDir': " ++ show x - --- | Move a build result into a local repository's 'incoming' directory. -uploadLocal :: CIO m => LocalRepository -> ChangesFile -> m () -uploadLocal repo changesFile = - do let paths = map (\ file -> changeDir changesFile changedFileName file) (changeFiles changesFile) - mapM_ (liftIO . install (outsidePath root)) (Debian.Repo.Changes.path changesFile : paths) - where - root = repoRoot repo - -- Hard link a file into the incoming directory - install root path = - do removeIfExists (dest root path) - F.createLink path (dest root path) - -- F.removeLink path - dest root path = root ++ "/incoming/" ++ snd (splitFileName path) - removeIfExists path = - do exists <- doesFileExist path - if exists then F.removeLink path else return () diff --git a/Debian/Repo/Dependencies.hs b/Debian/Repo/Dependencies.hs deleted file mode 100644 --- a/Debian/Repo/Dependencies.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, ScopedTypeVariables #-} --- |This dependency solver determines which binary packages to install --- in order to satisfy a set of dependency relations. It uses a brute --- force method, but tweaked to the point where it is usually able to --- complete on real-world inputs. --- --- Author: David Fox -module Debian.Repo.Dependencies - ( simplifyRelations - , solutions - , testArch - ) where - -import Debian.Control() -import qualified Debian.Control.String as S() -import Debian.Repo.Types -import Data.List -import qualified Data.Map as Map -import Data.Maybe -import Debian.Relation -import Extra.List (cartesianProduct) - -type Excuse = String - -type ProvidesMap = Map.Map String [BinaryPackage] - --- |A SimpleRelation just specifies a particular version of a package. --- The Nothing relation is always satisified. -type SimpleRelation = Maybe PkgVersion - --- |Each element is an or-list of specific package versions. -type SimpleRelations = [[SimpleRelation]] - -instance PackageVersion BinaryPackage where - pkgName = packageName . packageID - pkgVersion = packageVersion . packageID - --- Does this relation apply to this architecture? -testArch :: Arch -> Relation -> Bool -testArch _ (Rel _ _ Nothing) = True -testArch architecture (Rel _ _ (Just (ArchOnly archList))) = elem architecture (map Binary archList) -testArch architecture (Rel _ _ (Just (ArchExcept archList))) = not (elem architecture (map Binary archList)) - --- |Turn the expressive inequality style relations to a set of simple --- equality relations on only the packages in the available list. -simplifyRelations :: [BinaryPackage] - -> Relations - -> [String] -- ^ Given several alternative packages which satisfy - -- the relation, sort by name in this order. - -> Arch -- ^ The build architecture - -> SimpleRelations -simplifyRelations available relations preferred arch = - -- Sort the or-relations so that - -- 1. the packages named in the preferred list appear before other packages, - -- 2. the newest version appear before the older - map (sortBy prefOrder . reverse . sort) relationsSimplified - where - relationsSimplified = expandVirtual nameMap providesMap relationsOfArch - where - nameMap = listMap (map (\ package -> (packageName (packageID package), package)) available) - providesMap = - listMap (concat (map (\ package -> - let names = packageName (packageID package) : map provides (pProvides package) in - map (\ name -> (name, package)) names) available)) - provides [Rel name Nothing Nothing] = name - provides bzzt = error ("Invalid relation in Provides: " ++ show bzzt) - relationsOfArch = filter (/= []) (map (nub . filter (testArch arch)) relations) - prefOrder a b = compare (isPreferred a) (isPreferred b) - where isPreferred = maybe False (flip elem preferred . getName) - --- |Replace all relations by sets of equality relations on the exact --- package versions which are actually available in the current --- environment and satisfy the original relation. -expandVirtual :: ProvidesMap -> ProvidesMap -> Relations -> SimpleRelations -expandVirtual nameMap providesMap relations = - map (nub . concat . map expand) relations - where - -- A relation with no version or architecture requirement - -- can be satisfied by a provides or a real package. - expand (Rel name Nothing Nothing) = map eqRel (Map.findWithDefault [] name providesMap) - expand rel@(Rel name _ _) = map eqRel (filter (satisfies rel) (Map.findWithDefault [] name nameMap)) - eqRel :: BinaryPackage -> SimpleRelation - eqRel package = - Just (PkgVersion {getName = packageName p, getVersion = packageVersion p}) - where p = packageID package - -- Does this package satisfy the relation? - satisfies :: PackageVersion a => Relation -> a -> Bool - satisfies rel pkg = testRel (pkgVersion pkg) rel - --- Does this version satisfy the relation? -testRel _ (Rel _ Nothing _) = True -testRel ver1 (Rel _ (Just (LTE ver2)) _) = not (compare ver1 ver2 == GT) -testRel ver1 (Rel _ (Just (GRE ver2)) _) = not (compare ver1 ver2 == LT) -testRel ver1 (Rel _ (Just (SLT ver2)) _) = compare ver1 ver2 == LT -testRel ver1 (Rel _ (Just (EEQ ver2)) _) = compare ver1 ver2 == EQ -testRel ver1 (Rel _ (Just (SGR ver2)) _) = compare ver1 ver2 == GT - --- |Given a root and a dependency list, return a list of possible --- solutions to the dependency set. Each solution is a list of --- package versions which satisfy all the dependencies. Note that if --- a package is mentioned in two different clauses of the dependency --- list, both clauses must be satisfied: --- --- * a (>= 3.0), a (<< 4.0) | b (>= 2.0), c (>= 1.0) becomes --- --- * a (>= 3.0), a (<< 4.0), c (>= 1.0) OR a (>= 3.0), b (>= 2.0), c (>= 1.0) --- --- * [[a (>= 3.0)], [a (<< 4.0), b (>= 2.0)], [c (>= 1.0)]] becomes --- --- * [[a (>= 3.0), a (<< 4.0), c (>= 1.0)], [a (>= 3.0), b (>= 2.0), c (>= 1.0)]] --- --- So we can use each clause to eliminate packages which cannot --- satisfy the dependency set. -solutions :: [BinaryPackage] -- ^ The packages available to satisfy dependencies - -> SimpleRelations -- ^ The dependency relations to be satisfied - -> Int -- ^ Give up after this many solutions are computed - -> (Either String [(Int, [BinaryPackage])]) - -- ^ On success return the set of packages to install, - -- and the solution's sequence number. Also returns - -- the modified list of dependency relations, with all - -- inequalities replaced by equalities on the particular - -- versions of each package which are available. -solutions available relations limit = - -- Do any of the dependencies require packages that simply don't - -- exist? If so we don't have to search for solutions, there - -- aren't any. - case any (== []) relations of - True -> Left "Unsatisfiable dependencies" - False -> - -- Turn the And-of-Ors dependency list into Or-of-And-of-Ands. - -- Each element of the result represents a an alternative set of - -- constraints which a solution must satisfy. Each element of - -- the alternative is a list of relations on a single package, - -- all of which must be satisfied. - let alternatives = map (map nub . groupByName) (cartesianProduct relations) in - --let versions = map makeVersion available in - -- Find a set of packages that satisfies the dependencies - case solutions' 1 alternatives available of - -- Add more information about the failure to the error message. - Left message -> - let results = map (testAlternative available) (take 20 alternatives) in - let (errors :: [String]) = catMaybes (map (either Just (const Nothing)) results) in - Left (message ++ "\n" ++ intercalate "\n" errors) - Right x -> Right x - where - solutions' :: PackageVersion a => Int -> [[[SimpleRelation]]] -> [a] -> Either String [(Int, [a])] - solutions' _ [] _ = Left "All candidate solutions failed" - solutions' count (alternative : alternatives) available = - if count > limit then - Left ("No solutions found in first " ++ show limit ++ " candidates") else - case testAlternative available alternative of - Left _ -> - solutions' (count + 1) alternatives available - Right solution -> - Right ((count, solution) - : either (const []) id (solutions' (count + 1) alternatives available)) - --- |The alternative argument is a possible solution to the dependency --- problem. Each element of alternative represents the relations on a --- particular package. So each one needs to be satisfied for the --- alternative to be satisfied. -testAlternative :: PackageVersion a => [a] -> [[SimpleRelation]] -> Either Excuse [a] -testAlternative available alternative = - -- - if all (/= []) solution then - Right (map head solution) else - Left ("Couldn't satisfy these conditions:\n " ++ - intercalate "\n " (map show (mask (map (== []) solution) alternative))) - where - solution = map (testPackage available) alternative - mask bits elems = map fst (filter snd (zip elems bits)) - --- |Return the list of versions of a package that satisfy all of the --- relations. -testPackage :: PackageVersion a => [a] -> [SimpleRelation] -> [a] -testPackage available rels = foldl satisfies available rels - where - -- Which of these packages satisfy the relation? - satisfies :: PackageVersion a => [a] -> SimpleRelation -> [a] - satisfies available Nothing = available - satisfies available (Just pkg) = filter same available - where same x = pkgName x == pkgName pkg && pkgVersion x == pkgVersion pkg - -groupByName :: [SimpleRelation] -> [[SimpleRelation]] -groupByName relations = - groupBy (\ a b -> compareNames a b == EQ) (sortBy compareNames relations) - where compareNames a b = compare (maybe Nothing (Just . getName) a) (maybe Nothing (Just . getName) b) - --- Turn a list of (k, a) pairs into a map from k -> [a]. -listMap :: (Ord k) => [(k, a)] -> Map.Map k [a] -listMap pairs = - foldl insertPair Map.empty pairs - where insertPair m (k,a) = Map.insert k (a : (Map.findWithDefault [] k m)) m diff --git a/Debian/Repo/IO.hs b/Debian/Repo/IO.hs deleted file mode 100644 --- a/Debian/Repo/IO.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} --- |AptIO is an instance of the RWS monad used to manage the global --- state and output style parameters of clients of the Apt library, --- such as the autobuilder. -module Debian.Repo.IO - ( AptIOT - -- * AptIO Monad - , io - , tio - , runAptIO - , tryAB - -- * State - , IOState - , setRepoMap - , getRepoMap - , lookupRepository - , insertRepository - , lookupAptImage - , insertAptImage - , lookupSourcePackages - , insertSourcePackages - , lookupBinaryPackages - , insertBinaryPackages - , readParagraphs - , findRelease - , putRelease - , countTasks - ) where - -import qualified Debian.Control.ByteString as B -import Debian.Repo.Types - -import Control.Exception -import Control.Monad.RWS -import Control.Monad.Trans -import Data.Char -import Data.List -import qualified Data.Map as Map -import Data.Maybe -import Debian.URI -import Extra.TIO -import qualified System.IO as IO -import System.Posix.Files -import Text.Printf - -instance Ord FileStatus where - compare a b = compare (deviceID a, fileID a, modificationTime a) (deviceID b, fileID b, modificationTime b) - -instance Eq FileStatus where - a == b = compare a b == EQ - --- | A new monad to support the IO requirements of the autobuilder. --- This uses the RWS monad. The reader monad is used to store a flag --- indicating whether this is a dry run, and the style information --- associated with each output handle, including indentation, prefixing, --- and replacing the output with one dot per n output characters. --- The state monad stores information used to implement the current --- output style and includes state information about whether the console --- is at the beginning of a line, per-handle state information, and a --- cache of the repositories that have been verified. -type AptIOT = RWST () () IOState -type AptIO = AptIOT TIO - --- | This represents the state of the IO system. The 'bol' flag keeps --- track of whether we are at the beginning of line on the console. --- This is computed in terms of what we have sent to the console, but --- it should be remembered that the order that stdout and stderr are --- sent to the console may not be the same as the order in which they --- show up there. However, this appears to server our purposes for --- now. -data IOState - = IOState { repoMap :: Map.Map URI (Maybe Repository) -- ^ Map to look up known Repository objects - , releaseMap :: Map.Map (URI, ReleaseName) (Maybe Release) -- ^ Map to look up known Release objects - , aptImageMap :: Map.Map SliceName (Maybe AptImage) -- ^ Map to look up prepared AptImage objects - , sourcePackageMap :: Map.Map FilePath (Maybe (FileStatus, [SourcePackage])) - , binaryPackageMap :: Map.Map FilePath (Maybe (FileStatus, [BinaryPackage])) - } - --- |mark an action that should be run in the regular IO monad -io :: CIO m => IO a -> AptIOT m a -io = lift . liftIO - --- |mark an action that should be run in the terminal IO monad -tio :: CIO m => m a -> AptIOT m a -tio = lift - --- |Perform an AptIO monad task in the IO monad. -runAptIO :: CIO m => AptIOT m a -> m a -runAptIO action = (runRWST action) () initState >>= \ (a, _, _) -> return a - --- |Implementation of try for the AptIO monad. If the task throws --- an exception the initial state will be restored. -tryAB :: AptIO a -> AptIO (Either Exception a) -tryAB task = - do - state <- get - liftAB (try' state) task - where - try' state task = - do result <- tryTIO task - case result of - Left e -> return (Left e, state, ()) - Right (a, s, _) -> return (Right a, s, ()) - - liftAB :: (TIO (a, IOState, ()) -> TIO (b, IOState, ())) -> (AptIO a -> AptIO b) - liftAB f = {- AptIO . -} mapRWST f - --- |The initial output state - at the beginning of the line, no special handle --- state information, no repositories in the repository map. -initState :: IOState -initState = IOState { repoMap = Map.empty - , releaseMap = Map.empty - , aptImageMap = Map.empty - , sourcePackageMap = Map.empty - , binaryPackageMap = Map.empty - } - -setRepoMap :: Map.Map URI (Maybe Repository) -> IOState -> IOState -setRepoMap m state = state {repoMap = m} - -getRepoMap :: IOState -> Map.Map URI (Maybe Repository) -getRepoMap state = repoMap state - -lookupRepository :: URI -> IOState -> Maybe Repository -lookupRepository uri state = Map.findWithDefault Nothing uri (repoMap state) - -insertRepository :: URI -> Repository -> IOState -> IOState -insertRepository uri repo state = state {repoMap = Map.insert uri (Just repo) (repoMap state)} - -lookupAptImage :: SliceName -> IOState -> Maybe AptImage -lookupAptImage name state = Map.findWithDefault Nothing name (aptImageMap state) - -insertAptImage :: SliceName -> AptImage -> IOState -> IOState -insertAptImage name image state = state {aptImageMap = Map.insert name (Just image) (aptImageMap state)} - -lookupSourcePackages :: FilePath -> IOState -> Maybe (FileStatus, [SourcePackage]) -lookupSourcePackages key state = Map.findWithDefault Nothing key (sourcePackageMap state) - -insertSourcePackages :: FilePath -> (FileStatus, [SourcePackage]) -> IOState -> IOState -insertSourcePackages key packages state = state {sourcePackageMap = Map.insert key (Just packages) (sourcePackageMap state)} - -lookupBinaryPackages :: FilePath -> IOState -> Maybe (FileStatus, [BinaryPackage]) -lookupBinaryPackages key state = Map.findWithDefault Nothing key (binaryPackageMap state) - -insertBinaryPackages :: FilePath -> (FileStatus, [BinaryPackage]) -> IOState -> IOState -insertBinaryPackages key packages state = - state {binaryPackageMap = Map.insert key (Just packages) (binaryPackageMap state)} - -readParagraphs :: FilePath -> IO [B.Paragraph] -readParagraphs path = - do --IO.hPutStrLn IO.stderr ("OSImage.paragraphsFromFile " ++ path) -- Debugging output - h <- IO.openBinaryFile path IO.ReadMode - B.Control paragraphs <- B.parseControlFromHandle path h >>= return . (either (error . show) id) - IO.hClose h - --IO.hPutStrLn IO.stderr ("OSImage.paragraphsFromFile " ++ path ++ " done.") -- Debugging output - return paragraphs - -findRelease :: Repository -> ReleaseName -> IOState -> Maybe Release -findRelease repo dist state = - Map.findWithDefault Nothing (repoURI repo, dist) (releaseMap state) - -putRelease :: Repository -> ReleaseName -> Release -> IOState -> IOState -putRelease repo dist release state = - state {releaseMap = Map.insert (repoURI repo, dist) (Just release) (releaseMap state)} - --- | Perform a list of tasks with log messages. -countTasks :: CIO m => [(String, m a)] -> m [a] -countTasks tasks = - mapM (countTask (length tasks)) (zip [1..] tasks) - where - countTask :: CIO m => Int -> (Int, (String, m a)) -> m a - countTask count (index, (message, task)) = - (ePutStrBl (printf "[%2d of %2d] %s:" index count message)) >> - {- setStyle (addPrefix " ") -} task diff --git a/Debian/Repo/Insert.hs b/Debian/Repo/Insert.hs deleted file mode 100644 --- a/Debian/Repo/Insert.hs +++ /dev/null @@ -1,706 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- |Insert packages into a release, remove packages from a release. -module Debian.Repo.Insert - ( scanIncoming - , InstallResult(..) - , deleteTrumped - , deleteGarbage - , deleteSourcePackages - , resultToProblems - , showErrors - , explainError - ) where - -import Control.Exception (Exception(..)) -import Control.Monad -import Control.Monad.Trans -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as L -import Data.List (group, sort, intercalate, sortBy, groupBy, isSuffixOf, partition) -import Data.Maybe (catMaybes) -import qualified Data.Set as Set -import Debian.Control -import qualified Debian.Control.ByteString as B -import qualified Debian.Control.String as S -import Debian.Repo.Changes -import Debian.Repo.IO -import qualified Debian.Repo.Package as DRP -import Debian.Repo.PackageIndex -import Debian.Repo.Release -import Debian.Repo.Repository -import Debian.Repo.Types -import Debian.Version -import Extra.GPGSign (PGPKey) -import Extra.Either (partitionEithers, rights) -import Extra.Files (writeAndZipFileWithBackup) -import Extra.Misc (listDiff) -import Extra.CIO (CIO, vPutStr, vPutStrBl) -import System.FilePath(splitFileName, ()) -import qualified System.Unix.Misc as Unix -import System.Unix.Process -import System.Directory -import System.IO -import qualified System.Posix.Files as F -import System.Posix.Types (FileOffset) -import System.Process -import qualified Text.Format as F - -data InstallResult - = Ok - | Failed [Problem] -- Package can not currently be installed - | Rejected [Problem] -- Package can not ever be installed - deriving (Show, Eq) - -data Problem - = NoSuchRelease ReleaseName - | NoSuchSection ReleaseName [Section] - | ShortFile FilePath FileOffset FileOffset - | LongFile FilePath FileOffset FileOffset - | MissingFile FilePath - | BadChecksum FilePath String String - | OtherProblem Exception - deriving (Eq) - -instance Show Problem where - show (NoSuchRelease rel) = "NoSuchRelease " ++ releaseName' rel - show (NoSuchSection rel sect) = "NoSuchSection " ++ releaseName' rel ++ " " ++ show (map sectionName' sect) - show (ShortFile path a b) = "ShortFile " ++ path ++ " " ++ show a ++ " " ++ show b - show (LongFile path a b) = "LongFile " ++ path ++ " " ++ show a ++ " " ++ show b - show (MissingFile path) = "MissingFile " ++ path - show (BadChecksum path a b) = "BadChecksum " ++ path ++ " " ++ show a ++ " " ++ show b - show (OtherProblem s) = "OtherProblem " ++ show s - -nub :: (Ord a) => [a] -> [a] -nub = map head . group . sort - -mergeResults :: [InstallResult] -> InstallResult -mergeResults results = - doMerge Ok results - where - doMerge x [] = x - doMerge x (Ok : more) = doMerge x more - doMerge (Rejected p1) (Rejected p2 : more) = doMerge (Rejected (p1 ++ p2)) more - doMerge (Rejected p1) (Failed p2 : more) = doMerge (Rejected (p1 ++ p2)) more - doMerge (Failed p1) (Rejected p2 : more) = doMerge (Rejected (p1 ++ p2)) more - doMerge (Failed p1) (Failed p2 : more) = doMerge (Failed (p1 ++ p2)) more - doMerge Ok (x : more) = doMerge x more - -showErrors :: [InstallResult] -> String -showErrors errors = intercalate "\n" (map explainError (concat . map resultToProblems $ errors)) - -resultToProblems :: InstallResult -> [Problem] -resultToProblems Ok = [] -resultToProblems (Failed x) = x -resultToProblems (Rejected x) = x - -isError :: InstallResult -> Bool -isError Ok = False -isError _ = True - -plural "do" [_] = "does" -plural "do" _ = "do" - -plural "s" [_] = "" -plural "s" _ = "s" - -plural _ _ = "" - - -explainError :: Problem -> String -explainError (NoSuchRelease dist) = - ("\nThe distribution in the .changes file (" ++ releaseName' dist ++ ") does not exist. There\n" ++ - "are three common reasons this might happen:\n" ++ - " (1) The value in the latest debian/changelog entry is wrong\n" ++ - " (2) A new release needs to be created in the repository.\n" ++ - " newdist --root --create-release " ++ releaseName' dist ++ "\n" ++ - " (3) A new alias needs to be created in the repository (typically 'unstable', 'testing', or 'stable'.)\n" ++ - " newdist --root --create-alias " ++ releaseName' dist ++ "\n") -explainError (NoSuchSection dist components) = - ("\nThe component" ++ plural "s" components ++ " " ++ intercalate ", " (map sectionName' components) ++ - " in release " ++ releaseName' dist ++ " " ++ - plural "do" components ++ " not exist.\n" ++ - "either the 'Section' value in debian/control was wrong or the section needs to be created:" ++ - concat (map (\ component -> "\n newdist --root --create-section " ++ releaseName' dist ++ "," ++ sectionName' component) components)) -explainError (ShortFile path _ _) = - ("\nThe file " ++ path ++ "\n" ++ - "is shorter than it should be. This usually\n" ++ - "happens while the package is still being uploaded to the repository.") -explainError (LongFile path _ _) = - ("\nThe file " ++ path ++ - "\nis longer than it should be. This can happen when the --force-build\n" ++ - "option is used. In this case the --flush-pool option should help.") -explainError (BadChecksum path _ _) = - ("\nThe checksum of the file " ++ path ++ "\n" ++ - "is different from the value in the .changes file.\n" ++ - "This can happen when the --force-build option is used. In this case the\n" ++ - "--flush-pool option should help. It may also mean a hardware failure.") -explainError other = show other - --- | Find the .changes files in the incoming directory and try to --- process each. -scanIncoming :: CIO m => Bool -> Maybe PGPKey -> LocalRepository -> AptIOT m ([ChangesFile], [(ChangesFile, InstallResult)]) -scanIncoming createSections keyname repo@(LocalRepository root _ _) = - do releases <- findReleases repo - changes <- liftIO (findChangesFiles (outsidePath root "incoming")) - case changes of - [] -> lift $ vPutStrBl 0 "Nothing to install." - _ -> lift $ vPutStrBl 1 ("Changes:\n " ++ (intercalate "\n " . map show $ changes)) - results <- installPackages createSections keyname repo releases changes - case results of - [] -> return () - _ -> lift (vPutStrBl 0 ("Upload results:\n " ++ - (intercalate "\n " . map (uncurry showResult) $ (zip changes results)))) - let (bad, good) = partition (isError . snd) (zip changes results) - return (map fst good, bad) - where - showResult changes result = - changesFileName changes ++ ": " ++ - case result of - Ok -> "Ok" - Failed lst -> "Failed -\n " ++ (intercalate "\n " $ map show lst) - Rejected lst -> "Rejected -\n " ++ (intercalate "\n " $ map show lst) - --- | Install several packages into a repository. This means --- 1. getting the list of files from the .changes file, --- 2. verifying the file checksums, --- 3. deleting any existing version and perhaps other versions which --- were listed in the delete 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. -installPackages :: CIO m - => Bool -- ^ ok to create new releases and sections - -> Maybe PGPKey -- ^ key to sign repository with - -> LocalRepository -- ^ target repository - -> [Release] -- ^ Releases in target repository - -> [ChangesFile] -- ^ Package to be installed - -> AptIOT m [InstallResult] -- ^ Outcome of each source package -installPackages createSections keyname repo@(LocalRepository root layout _) releases changeFileList = - do live <- findLive repo >>= return . Set.fromList - (_, releases', results) <- foldM (installFiles root) (live, releases, []) changeFileList - let results' = reverse results - results'' <- lift $ updateIndexes root releases' results' - -- The install is done, now we will try to clean up incoming. - case elem Ok results'' of - False -> - return results'' - True -> - mapM_ (lift . uncurry (finish root (maybe Flat id layout))) (zip changeFileList results'') >> - mapM_ (lift . signRelease keyname) (catMaybes . map (findRelease releases) . nub . sort . map changeRelease $ changeFileList) >> - return results'' - where - -- Hard link the files of each package into the repository pool, - -- but don't unlink the files in incoming in case of subsequent - -- failure. - installFiles :: CIO m => EnvPath -> (Set.Set FilePath, [Release], [InstallResult]) -> ChangesFile -> AptIOT m (Set.Set FilePath, [Release], [InstallResult]) - installFiles root (live, releases, results) changes = - findOrCreateRelease releases (changeRelease changes) >>= - maybe (return (live, releases, Failed [NoSuchRelease (changeRelease changes)] : results)) installFiles' - where - installFiles' release = - let sections = nub . sort . map (section . changedFileSection) . changeFiles $ changes in - case (createSections, listDiff sections (releaseComponents release)) of - (_, []) -> installFiles'' release - (True, missing) -> - do lift $ vPutStrBl 0 ("Creating missing sections: " ++ intercalate " " (map sectionName' missing)) - release' <- case releaseRepo release of - LocalRepo repo -> prepareRelease repo (releaseName release) [] missing (releaseArchitectures release) - x -> error $ "Expected local release: " ++ show x - installFiles'' release' - (False, missing) -> - return (live, releases, Failed [NoSuchSection (releaseName release) missing] : results) - installFiles'' release' = - do let releases' = release' : filter ((/= releaseName release') . releaseName) releases - result <- mapM (installFile root release') (changeFiles changes) >>= return . mergeResults - let live' = - case result of - -- Add the successfully installed files to the live file set - Ok -> foldr Set.insert live (map (((outsidePath root) ) . poolDir' release' changes) (changeFiles changes)) - _ -> live - return (live', releases', result : results) -{- - release' <- - case (createSections, listDiff sections (releaseComponents release)) of - (_, []) -> return release - (True, missing) -> - vPutStrBl 0 ("Creating missing sections: " ++ show missing) >> - prepareRelease (releaseRepo release) (releaseName release) [] missing (releaseArchitectures release) - (False, missing) -> - error $ "Missing sections: " ++ show missing - let releases' = release' : filter ((/= releaseName release') . releaseName) releases - result <- mapM (installFile root release') (changeFiles changes) >>= return . mergeResults - let live' = - case result of - -- Add the successfully installed files to the live file set - Ok -> foldr Set.insert live (map (((show root) ) . poolDir' release changes) (changeFiles changes)) - _ -> live - return (live', releases', result : results) --} - installFile root release file = - do let dir = outsidePath root poolDir' release changes file - let src = outsidePath root "incoming" changedFileName file - let dst = dir changedFileName file - installed <- liftIO $ doesFileExist dst - available <- liftIO $ doesFileExist src - let indexed = Set.member dst live - case (available, indexed, installed) of - (False, _, _) -> -- Perhaps this file is about to be uploaded - return (Failed [MissingFile src]) - (True, False, False) -> -- This just needs to be installed - liftIO (createDirectoryIfMissing True dir) >> - liftIO (F.createLink src dst) >> - return Ok - (True, False, True) -> -- A garbage file is already present - lift (vPutStrBl 1 (" Replacing unlisted file: " ++ dst)) >> - liftIO (removeFile dst) >> - liftIO (F.createLink src dst) >> - return Ok - (True, True, False) -> -- Apparantly the repository is damaged. - return (Failed [OtherProblem $ (ErrorCall $ "Missing from repository: " ++ dst)]) - (True, True, True) -> -- Further inspection is required - do installedSize <- liftIO $ F.getFileStatus dst >>= return . F.fileSize - installedMD5sum <- liftIO $ Unix.md5sum dst - case () of - _ | changedFileSize file < installedSize -> - -- File may be in the process of being uploaded - return (Failed [ShortFile dst (changedFileSize file) installedSize]) - _ | changedFileSize file > installedSize -> - -- We could skip this size test and just do the checksum test, - -- but a file that is too long indicates a different type of - -- failure than a file with a checksum mismatch. - return (Rejected [LongFile dst (changedFileSize file) installedSize]) - _ | changedFileMD5sum file /= installedMD5sum -> - return (Rejected [BadChecksum dst (changedFileMD5sum file) installedMD5sum]) - _ -> return Ok -- The correct file is already installed - so be it. - - -- Update all the index files affected by the successful - -- installs. This is a time consuming operation, so we want to - -- do this all at once, rather than one package at a time - updateIndexes :: CIO m => EnvPath -> [Release] -> [InstallResult] -> m [InstallResult] - updateIndexes root releases results = - do vPutStrBl 1 "updateIndexes" - (pairLists :: [Either InstallResult [(PackageIndexLocal, B.Paragraph)]]) <- - mapM (uncurry $ buildInfo root releases) (zip changeFileList results) - let sortedByIndex = sortBy compareIndex (concat (keepRight pairLists)) - let groupedByIndex = undistribute (groupBy (\ a b -> compareIndex a b == EQ) sortedByIndex) - result <- addPackagesToIndexes groupedByIndex - case result of - Ok -> return $ map (either id (const Ok)) pairLists - problem -> return $ map (const problem) results - where - compareIndex :: (PackageIndexLocal, B.Paragraph) -> (PackageIndexLocal, B.Paragraph) -> Ordering - compareIndex (a, _) (b, _) = compare a b - -- Build the control information to be added to the package indexes. - buildInfo :: CIO m => EnvPath -> [Release] -> ChangesFile -> InstallResult -> m (Either InstallResult [(PackageIndexLocal, B.Paragraph)]) - buildInfo root releases changes Ok = - do vPutStrBl 1 $ " buildInfo " ++ changesFileName changes - case findRelease releases (changeRelease changes) of - Just release -> - do (info :: [Either InstallResult B.Paragraph]) <- mapM (fileInfo root release) indexFiles - case keepLeft info of - [] -> - let (pairs :: [([PackageIndexLocal], Either InstallResult B.Paragraph)]) = zip (indexLists release) info in - let (pairs' :: [([PackageIndexLocal], B.Paragraph)]) = - catMaybes $ map (\ (a, b) -> either (const Nothing) (\ b' -> Just (a, b')) b) pairs in - let (pairs'' :: [(PackageIndexLocal, B.Paragraph)]) = concat (map distribute pairs') in - return (Right pairs'') - results -> return (Left (mergeResults results)) - Nothing -> return . Left . Failed $ [NoSuchRelease (changeRelease changes)] - where - indexLists :: Release -> [[PackageIndexLocal]] - indexLists release = map (indexes release) indexFiles - indexes :: Release -> ChangedFileSpec -> [PackageIndexLocal] - indexes release file = map (PackageIndex release (section . changedFileSection $ file)) (archList release changes file) - indexFiles = dsc ++ debs - (debs :: [ChangedFileSpec]) = filter f files - where (f :: ChangedFileSpec -> Bool) = (isSuffixOf ".deb" . changedFileName) - (files :: [ChangedFileSpec]) = (changeFiles changes) - dsc = filter (isSuffixOf ".dsc" . changedFileName) (changeFiles changes) - -- (debs, nonDebs) = partition (isSuffixOf ".deb" . changedFileName) (changeFiles changes) - -- (indepDebs, archDebs) = partition (isSuffixOf "_all.deb" . changedFileName) debs - -- (dsc, other) = partition (isSuffixOf ".dsc" . changedFileName) nonDebs - --fileIndex release file = map (PackageIndex release (section . changedFileSection $ file)) (archList release changes file) - fileInfo :: CIO m => EnvPath -> Release -> ChangedFileSpec -> m (Either InstallResult B.Paragraph) - fileInfo root release file = - getControl >>= return . addFields - where - getControl :: CIO m => m (Either InstallResult B.Paragraph) - getControl = - do control <- - case isSuffixOf ".deb" . changedFileName $ file of - True -> getDebControl path - False -> liftIO $ S.parseControlFromFile path >>= return . either (Left . show) Right - case control of - Left message -> return . Left . Rejected $ [OtherProblem (ErrorCall message)] - Right (S.Control [info]) -> return (Right info) - Right (S.Control _) -> return . Left . Rejected $ [OtherProblem (ErrorCall "Invalid control file")] - addFields :: (Either InstallResult B.Paragraph) -> (Either InstallResult B.Paragraph) - addFields (Left result) = Left result - addFields (Right info) = - case isSuffixOf ".deb" . changedFileName $ file of - True -> addDebFields release changes file info - False -> addSourceFields release changes file info - -- | Extract the control file from a binary .deb. - getDebControl :: CIO m => FilePath -> m (Either String B.Control) - getDebControl path = - do let cmd = "ar p " ++ path ++ " control.tar.gz | tar xzO ./control" - (_, outh, _, handle) <- liftIO $ runInteractiveCommand cmd - control <- liftIO $ B.parseControlFromHandle cmd outh >>= return . either (Left . show) Right - exitcode <- liftIO $ waitForProcess handle - case exitcode of - ExitSuccess -> return control - ExitFailure n -> return . Left $ "Failure: " ++ cmd ++ " -> " ++ show n - path = outsidePath root ++ "/incoming/" ++ changedFileName file - buildInfo _ _ _ notOk = return . Left $ notOk - -- For a successful install this unlinks the files from INCOMING and - -- moves the .changes file into INSTALLED. For a failure it moves - -- all the files to REJECT. - finish root layout changes Ok = - do --vPutStrBl 1 stderr $ " finish Ok " ++ changesFileName changes - mapM (liftIO . removeFile . ((outsidePath root ++ "/incoming/") ++) . changedFileName) (changeFiles changes) - installChangesFile root layout changes - finish root _ changes (Rejected _) = - do --vPutStrBl 1 stderr $ " finish Rejected " ++ changesFileName changes - mapM (\ name -> liftIO (moveFile (outsidePath root ++ "/incoming/" ++ name) (outsidePath root ++ "/reject/" ++ name))) - (map changedFileName (changeFiles changes)) - liftIO (moveFile (outsidePath root ++ "/incoming/" ++ Debian.Repo.Changes.name changes) - (outsidePath root ++ "/reject/" ++ Debian.Repo.Changes.name changes)) - finish _ _ changes (Failed _) = - do vPutStrBl 1 $ " Finish Failed " ++ changesFileName changes - return () - installChangesFile :: CIO m => EnvPath -> Layout -> ChangesFile -> m () - installChangesFile root layout changes = - liftIO (moveFile (Debian.Repo.Changes.path changes) dst) - where dst = case layout of - Flat -> outsidePath root Debian.Repo.Changes.name changes - Pool -> outsidePath root ++ "/installed/" ++ Debian.Repo.Changes.name changes - findOrCreateRelease :: CIO m => [Release] -> ReleaseName -> AptIOT m (Maybe Release) - findOrCreateRelease releases name = - case createSections of - False -> return (findRelease releases name) - True -> do let release = findRelease releases name - case release of - Nothing -> - do newRelease <- prepareRelease repo name [] [parseSection' "main"] (repoArchList repo) - return (Just newRelease) - Just release -> return (Just release) - findRelease :: [Release] -> ReleaseName -> Maybe Release - findRelease releases name = - case filter (\ release -> elem name (releaseName release : releaseInfoAliases (releaseInfo release))) releases of - [] -> Nothing - [x] -> Just x - _ -> error $ "Internal error 16 - multiple releases named " ++ releaseName' name - -archList :: Release -> ChangesFile -> ChangedFileSpec -> [Arch] -archList release changes file = - case () of - _ | isSuffixOf "_all.deb" name -> releaseArchitectures release - _ | isSuffixOf ".deb" name -> [changeArch changes] - _ | isSuffixOf ".udeb" name -> [] - _ -> [Source] - where name = changedFileName file - -distribute :: ([a], b) -> [(a, b)] -distribute (ilist, p) = map (\ i -> (i, p)) ilist - -undistribute :: [[(a, b)]] -> [(a, [b])] -undistribute [] = [] -undistribute ([] : tail) = undistribute tail -undistribute (((index, info) : items) : tail) = - (index, info : map snd items) : undistribute tail - -keepRight :: [Either a b] -> [b] -keepRight xs = catMaybes $ map (either (const Nothing) Just) xs - -keepLeft :: [Either a b] -> [a] -keepLeft xs = catMaybes $ map (either Just (const Nothing)) xs - -addDebFields :: Release -> ChangesFile -> ChangedFileSpec -> B.Paragraph -> (Either InstallResult B.Paragraph) -addDebFields release changes file info = - let (binaryVersion :: DebianVersion) = - maybe (error $ "Missing 'Version' field") (parseDebianVersion . B.unpack) (B.fieldValue "Version" info) in - let (newfields :: [B.Field]) = - [B.Field (B.pack "Source", B.pack (" " ++ source ++ versionSuffix binaryVersion)), - B.Field (B.pack "Filename", B.pack (" " ++ poolDir' release changes file changedFileName file)), - B.Field (B.pack "Size", B.pack (" " ++ show (changedFileSize file))), - B.Field (B.pack "MD5sum", B.pack (" " ++ changedFileMD5sum file))] in - Right $ B.appendFields newfields info - where - versionSuffix :: DebianVersion -> String - versionSuffix binaryVersion = if binaryVersion /= sourceVersion then " (" ++ show sourceVersion ++ ")" else "" - source = maybe (error "Missing 'Source' field in .changes file") id (B.fieldValue "Source" (changeInfo changes)) - sourceVersion = changeVersion changes - - -addSourceFields :: Release -> ChangesFile -> ChangedFileSpec -> B.Paragraph -> (Either InstallResult B.Paragraph) -addSourceFields release changes file info = - let info' = B.renameField (B.pack "Source") (B.pack "Package") info in - let info'' = B.modifyField (B.pack "Files") (\ b -> (B.pack (B.unpack b ++ "\n " ++ changedFileMD5sum file ++ " " ++ - show (changedFileSize file) ++ " " ++ - changedFileName file))) info' in - let info''' = B.raiseFields (== (B.pack "Package")) info'' in - let newfields = [B.Field (B.pack "Priority", B.pack (" " ++ changedFilePriority file)), - B.Field (B.pack "Section", B.pack (" " ++ (sectionName (changedFileSection file)))), - B.Field (B.pack "Directory", B.pack (" " ++ poolDir' release changes file))] ++ - maybe [] (\ s -> [B.Field (B.pack "Build-Info", B.pack (" " ++ s))]) - (B.fieldValue "Build-Info" (changeInfo changes)) in - Right $ B.appendFields newfields info''' - -moveFile :: FilePath -> FilePath -> IO () -moveFile src dst = - do --vPutStrBl 1 stderr ("moveFile " ++ src ++ " " ++ dst) - doesFileExist dst >>= (flip when) (removeFile dst) - F.createLink src dst - removeFile src - --- |Add control information to several package indexes, making sure --- that that no duplicate package ids are inserted. -addPackagesToIndexes :: CIO m => [(PackageIndexLocal, [B.Paragraph])] -> m InstallResult -addPackagesToIndexes pairs = - do oldPackageLists <- mapM DRP.getPackages (map fst pairs) - case partitionEithers oldPackageLists of - ([], _) -> - do let (oldPackageLists' :: [[BinaryPackageLocal]]) = rights oldPackageLists - let (indexMemberFns :: [BinaryPackageLocal -> Bool]) = map indexMemberFn oldPackageLists' - -- if none of the new packages are already in the index, add them - case concat (map (uncurry filter) (zip indexMemberFns newPackageLists)) of - [] -> do mapM (liftIO . updateIndex) (zip3 indexes oldPackageLists' newPackageLists) - return Ok - dupes -> return $ Failed [OtherProblem (ErrorCall ("Duplicate packages: " ++ intercalate " " (map show dupes)))] - (bad, _) -> return $ Failed (map OtherProblem bad) -{- - do (oldPackageLists :: [[BinaryPackageLocal]]) <- mapM getPackages (map fst pairs) >>= return . rights - -- package membership predicates - let (indexMemberFns :: [BinaryPackageLocal -> Bool]) = map indexMemberFn oldPackageLists - -- if none of the new packages are already in the index, add them - case concat (map (uncurry filter) (zip indexMemberFns newPackageLists)) of - [] -> do mapM (liftIO . updateIndex) (zip3 indexes oldPackageLists newPackageLists) - return Ok - dupes -> return $ Failed [OtherProblem ("Duplicate packages: " ++ (intercalate " " (map show dupes)))] --} - where - updateIndex (index, oldPackages, newPackages) = DRP.putPackages index (oldPackages ++ newPackages) - indexes = map fst pairs - indexMemberFn :: [BinaryPackageLocal] -> BinaryPackageLocal -> Bool - indexMemberFn packages = - let set = Set.fromList . map packageID $ packages - in - \package -> Set.member (packageID package) set - newPackageLists = map (\ (index, info) -> map (DRP.toBinaryPackage index) info) pairs - --- | Delete 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. -deleteTrumped :: CIO m => Maybe PGPKey -> [Release] -> m [Release] -deleteTrumped _ [] = error "deleteTrumped called with empty release list" -deleteTrumped keyname releases = - case nub . map releaseRepo $ releases of - [_] -> - mapM findTrumped releases >>= - return . partitionEithers >>= - \ (bad, good) -> - case bad of - [] -> return (concat good) >>= - ifEmpty (vPutStr 0 "deleteTrumped: nothing to delete") >>= - deleteSourcePackages keyname - _ -> error $ "Error reading package lists" - [] -> error "internal error" - repos -> error ("Multiple repositories passed to deleteTrumped:\n " ++ - (intercalate "\n " $ map show repos) ++ "\n") - where - ifEmpty action [] = do action; return [] - ifEmpty _ x = return x - --- | Return a list of packages in a release which are trumped by some --- newer version. -findTrumped :: CIO m => Release -> m (Either String [PackageIDLocal]) -findTrumped release = - do - --ePutStr ("findTrumped " ++ show release) - packages <- mapM DRP.getPackages (sourceIndexList release) - case partitionEithers packages of - ([], packages') -> - do let groups = map newestFirst . groupByName . map packageID . concat $ packages' - mapM_ (vPutStrBl 0) (catMaybes . map formatGroup $ groups) - return . Right . concat . map tail $ groups - (bad, _) -> return (Left $ "Error reading source indexes: " ++ intercalate ", " (map show bad)) - where - groupByName = groupBy equalNames . sortBy compareNames - equalNames a b = packageName a == packageName b - compareNames a b = compare (packageName a) (packageName b) - newestFirst = sortBy (flip compareVersions) - compareVersions a b = compare (packageVersion a) (packageVersion b) - formatGroup [] = Nothing - formatGroup [_] = Nothing - formatGroup (newest : other) = - Just ("Trumped by " ++ F.format newest ++ " in " ++ F.format (packageIndex newest) ++ ":\n " ++ - intercalate "\n " (map F.format other)) - --- | 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. -deleteGarbage :: CIO m => LocalRepository -> AptIOT m LocalRepository -deleteGarbage repo = - case repoLayout repo of - Just layout -> - do - lift (vPutStrBl 0 ("deleteGarbage in " ++ outsidePath root ++ " (layout=" ++ show layout ++ ")")) - allFiles1 <- liftIO $ poolFiles root layout - allFiles2 <- liftIO $ changesFileList root layout - let allFiles = allFiles1 ++ allFiles2 - -- ePutStr ("allFiles:\n " ++ intercalate "\n " (sort allFiles) ++ "\n") - liveFiles <- findLive repo - -- ePutStr ("liveFiles:\n " ++ intercalate "\n " (sort liveFiles) ++ "\n") - let deadFiles = Set.toList (Set.difference (Set.fromList allFiles) (Set.fromList liveFiles)) - lift (vPutStrBl 0 ("Removing:\n " ++ intercalate "\n " (sort deadFiles) ++ "\n")) - mapM_ (liftIO . moveToRemoved root) deadFiles - return repo - _ -> error "Cannot remove files from an empty repository" - where - root = repoRoot repo - poolFiles root Flat = getDirectoryContents (outsidePath root) >>= - filterM (doesFileExist . ((outsidePath root ++ "/") ++)) - poolFiles root Pool = - getSubPaths (outsidePath root ++ "/pool") >>= - mapM getSubPaths >>= return . concat >>= - mapM getSubPaths >>= return . concat >>= - mapM getSubPaths >>= return . concat - changesFileList root Pool = getDirectoryPaths (outsidePath root ++ "/installed") - -- In this case we already got the .changes files from the top directory - changesFileList root Flat = getDirectoryPaths (outsidePath root) >>= return . filter (isSuffixOf ".changes") - 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 root file = - renameFile file (outsidePath root ++ "/removed/" ++ snd (splitFileName file)) - --- Repository Accessors and Inquiries - --- | Return a list of all the files in a release which are --- 'live', in the sense that they appear in some index files. -findLive :: CIO m => LocalRepository -> AptIOT m [FilePath] -findLive (LocalRepository _ Nothing _) = return [] -- Repository is empty -findLive repo@(LocalRepository root (Just layout) _) = - do releases <- findReleases repo - sourcePackages <- mapM (lift . DRP.releaseSourcePackages) releases >>= return . map (either (error . show) id) >>= return . concat - binaryPackages <- mapM (lift . DRP.releaseBinaryPackages) releases >>= return . map (either (error . show) id) >>= return . concat - let sourceFiles = map ((outsidePath root ++ "/") ++) . concat . map DRP.sourceFilePaths $ sourcePackages - let binaryFiles = - map ((outsidePath root ++ "/") ++) . map B.unpack . catMaybes $ map (B.fieldValue "Filename" . packageInfo) binaryPackages - let changesFiles = concat . map (changesFilePaths root layout releases) $ sourcePackages - let uploadFiles = concat . map (uploadFilePaths root releases) $ sourcePackages - return $ sourceFiles ++ binaryFiles ++ changesFiles ++ uploadFiles - where - changesFilePaths root Flat releases package = - map ((outsidePath root ++ "/") ++) . changesFileNames releases $ package - changesFilePaths root Pool releases package = - map ((outsidePath root ++ "/installed/") ++) . changesFileNames releases $ package - changesFileNames releases package = - map (\ arch -> intercalate "_" [packageName . sourcePackageID $ package, - show . packageVersion . sourcePackageID $ package, - archName arch] ++ ".changes") (nub (concat (architectures releases))) - uploadFilePaths root releases package = map ((outsidePath root ++ "/") ++) . uploadFileNames releases $ package - uploadFileNames releases package = - map (\ arch -> intercalate "_" [packageName . sourcePackageID $ package, - show . packageVersion . sourcePackageID $ package, - archName arch] ++ ".upload") (nub (concat (architectures releases))) - architectures releases = map head . group . sort . map releaseArchitectures $ releases - --- | Although the PackageID type could refer to source or binary --- packages, we only export the function to remove source packages. --- This is in order to avoid leaving around references to removed --- binary packages in the source index. -deleteSourcePackages :: CIO m => Maybe PGPKey -> [PackageIDLocal] -> m [Release] -deleteSourcePackages keyname packages = - mapM (deleteSourcePackagesFromIndex keyname) (map indexPair indexGroups) - where - indexGroups = group (sortBy compareIndex packages) - compareIndex a b = compare (packageIndex a) (packageIndex b) - indexPair group@(package : _) = (packageIndex package, group) - indexPair [] = error "internal error" - -deleteSourcePackagesFromIndex :: CIO m => Maybe PGPKey -> (PackageIndexLocal, [PackageIDLocal]) -> m Release -deleteSourcePackagesFromIndex keyname (index, packages) = - case (packageIndexArch index, packageIndexRelease index) of - (_, release@(Release {releaseRepo = LocalRepo repo})) -> - do -- ePutStr (" Repository.deleteSourcePackageFromIndex (" ++ show packages ++ ")") - (remove, keep) <- DRP.getPackages index >>= return . either (error . show) id >>= return . partition (testSource . packageID) - case (remove, keep) of - ([], _) -> - do vPutStrBl 0 ("Packages not found:\n " ++ intercalate "\n " (map F.format packages)) - vPutStrBl 2 ("Available in " ++ F.format index ++ ":\n " ++ intercalate "\n " (map F.format keep)) - return release - (remove, keep) -> - -- We found one or more source packages to remove - do vPutStrBl 0 ("Removing source packages from " ++ F.format index ++ ": " ++ intercalate " " (map (F.format . packageID) remove)) - mapM_ (deleteBinaryPackages root) binaryIndexes - putIndex root index keep - signRelease keyname release - return release - where - --release = packageIndexRelease index - --repo = releaseRepo release - root = repoRoot repo - binaryIndexes = filter (\ index -> packageIndexArch index /= Source) (packageIndexList release) - deleteBinaryPackages root binaryIndex = - do binaryPackages <- DRP.getPackages binaryIndex >>= return . either (error . show) id - case partition testBinary binaryPackages of - ([], _) -> return $ Right () - (remove, keep) -> - do vPutStrBl 0 ("Removing binary packages from " ++ F.format binaryIndex ++ ": " ++ intercalate " " (map (F.format . packageID) remove)) - putIndex root binaryIndex keep - -- Is this one of the source packages we are looking for? - testSource package = elem ((packageName package), (packageVersion package)) versions - testBinary = testSource . DRP.binaryPackageSourceID - putIndex :: CIO m => EnvPath -> PackageIndexLocal -> [BinaryPackageLocal] -> m (Either [String] ()) - putIndex root index packages = - let text = L.fromChunks (formatControl (B.Control (map packageInfo packages))) in - liftIO $ writeAndZipFileWithBackup (outsidePath root packageIndexPath index) text - -- This is not correct - we need to get the correct version numbers from the binary index file - -- binaryPackages = map (PackageID (PackageIndex release component arch)) versions - versions = zip (map packageName packages) (map packageVersion packages) - --archList = releaseArchitectures release - --component = packageIndexComponent index - (Binary _, _) -> error $ "Not a source index: " ++ show index - (_, release) -> error $ "Not a local release: " ++ show release - -instance F.Format PackageID where - format p = packageName p ++ "=" ++ show (packageVersion p) - -instance F.Format PackageIndex where - format i = - intercalate "/" [F.format (releaseRepo . packageIndexRelease $ i), - "dist", - (releaseName' . releaseInfoName . releaseInfo . packageIndexRelease $ i), - F.format (packageIndexComponent i), - F.format (packageIndexArch i)] - -instance F.Format Release where - format r = F.format (releaseRepo r) ++ " " ++ F.format (releaseInfo r) - -instance F.Format Repository where - format (LocalRepo r) = outsidePath (repoRoot r) - format (VerifiedRepo s _) = s - format (UnverifiedRepo s) = s - -instance F.Format ReleaseInfo where - format r = intercalate " " (releaseName' (releaseInfoName r) : map F.format (releaseInfoComponents r)) - -instance F.Format Section where - format (Section s) = s - -instance F.Format Arch where - format x@(Binary _) = "binary-" ++ archName x - format x = archName x - -instance F.Format BinaryPackage where - format p = F.format (packageID p) diff --git a/Debian/Repo/LocalRepository.hs b/Debian/Repo/LocalRepository.hs deleted file mode 100644 --- a/Debian/Repo/LocalRepository.hs +++ /dev/null @@ -1,151 +0,0 @@ -module Debian.Repo.LocalRepository where - -import qualified Debian.Control.ByteString as B -- required despite warning -import qualified Debian.Control.String as S -import Debian.Repo.IO -import Debian.Repo.Types ---import Debian.Release - -import Control.Monad.Trans -import Control.Monad.State (get, put) -import Extra.CIO -import Control.Monad -import qualified Data.ByteString.Char8 as B -import Data.List -import Data.Maybe -import Extra.Files -import Extra.List(partitionM) -import System.FilePath -import System.Unix.Directory -import System.Directory -import System.IO -import qualified System.Posix.Files as F -import Text.Regex - --- | Create or update the compatibility level file for a repository. -setRepositoryCompatibility :: LocalRepository -> IO () -setRepositoryCompatibility (LocalRepository root _ _) = - maybeWriteFile path text - where text = show libraryCompatibilityLevel ++ "\n" - path = outsidePath root compatibilityFile - --- | Return the subdirectory where a source package with the given --- section and name would be installed given the layout of the --- repository. -poolDir :: LocalRepository -> Section -> String -> FilePath -poolDir (LocalRepository _ (Just Pool) _) section source = - "pool/" ++ sectionName' section prefixDir source - where prefixDir = - if isPrefixOf "lib" source then - take (min 4 (length source)) source else - take (min 1 (length source)) source -poolDir (LocalRepository _ _ _) _ _ = "" - --- | Remove all the packages from the repository and then re-create --- the empty releases. -flushLocalRepository :: CIO m => LocalRepository -> AptIOT m LocalRepository -flushLocalRepository (LocalRepository path layout _) = - do liftIO $ removeRecursiveSafely (outsidePath path) - prepareLocalRepository path layout - --- | Create or verify the existance of the directories which will hold --- a repository on the local machine. Verify the index files for each of --- its existing releases. -prepareLocalRepository :: CIO m => EnvPath -> Maybe Layout -> AptIOT m LocalRepository -prepareLocalRepository root layout = - do lift (vPutStrBl 3 $ "Preparing local repository at " ++ outsidePath root) - mapM_ (liftIO . initDir) - [(".", 0o40755), - ("dists", 0o40755), - ("incoming", 0o41755), - ("removed", 0o40750), - ("reject", 0o40750)] - layout' <- lift (liftIO (computeLayout (outsidePath root))) >>= (return . maybe layout Just) - -- >>= return . maybe (maybe (error "No layout specified for new repository") id layout) id - mapM_ (liftIO . initDir) - (case layout' of - Just Pool -> [("pool", 0o40755), ("installed", 0o40755)] - Just Flat -> [] - Nothing -> []) - readLocalRepo root layout' - where - initDir (name, mode) = - do let path = outsidePath root name - filterM (\ f -> doesDirectoryExist f >>= return . not) [path] >>= - mapM_ (\ f -> createDirectoryIfMissing True f) - actualMode <- F.getFileStatus path >>= return . F.fileMode - when (mode /= actualMode) (F.setFileMode path mode) -{- notSymbolicLink root name = - getSymbolicLinkStatus (root ++ "/dists/" ++ name) >>= return . not . isSymbolicLink - hasReleaseFile root name = - doesFileExist (root ++ "/dists/" ++ name ++ "/Release") -} - -readLocalRepo :: CIO m => EnvPath -> Maybe Layout -> AptIOT m LocalRepository -readLocalRepo root layout = - do - state <- get - names <- liftIO (getDirectoryContents distDir) >>= - return . filter (\ x -> not . elem x $ [".", ".."]) - (links, dists) <- partitionM (liftIO . isSymLink . (distDir )) names - linkText <- mapM (liftIO . F.readSymbolicLink) (map (distDir ) links) - let aliasPairs = zip linkText links ++ map (\ dist -> (dist, dist)) dists - let distGroups = groupBy fstEq . sort $ aliasPairs - let aliases = map (checkAliases . partition (uncurry (==))) distGroups - releaseInfo <- mapM (lift . getReleaseInfo) aliases - let repo = LocalRepository { repoRoot = root - , repoLayout = layout - , repoReleaseInfoLocal = releaseInfo } - put (insertRepository (repoURI repo) (LocalRepo repo) state) - return repo - where - fstEq (a, _) (b, _) = a == b - checkAliases :: ([(String, String)], [(String, String)]) -> (ReleaseName, [ReleaseName]) - checkAliases ([(realName, _)], aliases) = (parseReleaseName realName, map (parseReleaseName . snd) aliases) - checkAliases _ = error "Symbolic link points to itself!" - getReleaseInfo :: CIO m => (ReleaseName, [ReleaseName]) -> m ReleaseInfo - getReleaseInfo (dist, aliases) = parseReleaseFile (releasePath dist) dist aliases - releasePath dist = distDir releaseName' dist ++ "/Release" - distDir = outsidePath root ++ "/dists" - -parseReleaseFile :: CIO m => FilePath -> ReleaseName -> [ReleaseName] -> m ReleaseInfo -parseReleaseFile path dist aliases = - do text <- liftIO (B.readFile path) - return $ parseRelease path text dist aliases - -parseRelease :: FilePath -> B.ByteString -> ReleaseName -> [ReleaseName] -> ReleaseInfo -parseRelease file text name aliases = - case either (error . show) id (B.parseControl file text) of - S.Control [] -> error $ "Empty release file: " ++ file - S.Control (info : _) -> makeReleaseInfo file info name aliases - -makeReleaseInfo :: FilePath -> B.Paragraph -> ReleaseName -> [ReleaseName] -> ReleaseInfo -makeReleaseInfo file info name aliases = - case (B.fieldValue "Architectures" info, B.fieldValue "Components" info) of - (Just archList, Just compList) -> - case (splitRegex re (B.unpack archList), splitRegex re (B.unpack compList)) of - (architectures@(_ : _), components@(_ : _)) -> - ReleaseInfo { releaseInfoName = name - , releaseInfoAliases = aliases - , releaseInfoArchitectures = map Binary architectures - , releaseInfoComponents = map Section components } - _ -> error $ "Invalid Architectures or Components field in Release file " ++ file - _ -> error $ "Missing Architectures or Components field in Release file " ++ file - where - re = mkRegex "[ ,]+" - -isSymLink path = F.getSymbolicLinkStatus path >>= return . F.isSymbolicLink - --- |Try to determine a repository's layout. -computeLayout :: FilePath -> IO (Maybe Layout) -computeLayout root = - do - -- If there are already .dsc files in the root directory - -- the repository layout is Flat. - isFlat <- getDirectoryContents root >>= return . (/= []) . catMaybes . map (matchRegex (mkRegex "\\.dsc$")) - -- If the pool directory already exists the repository layout is - -- Pool. - isPool <- doesDirectoryExist (root ++ "/pool") - case (isFlat, isPool) of - (True, _) -> return (Just Flat) - (False, True) -> return (Just Pool) - _ -> return Nothing diff --git a/Debian/Repo/OSImage.hs b/Debian/Repo/OSImage.hs deleted file mode 100644 --- a/Debian/Repo/OSImage.hs +++ /dev/null @@ -1,488 +0,0 @@ -module Debian.Repo.OSImage - ( OSImage(..) - , prepareEnv - , updateEnv - , syncPool - , chrootEnv - , syncEnv - , neuterEnv - , restoreEnv - , removeEnv - , buildEssential - ) where - -import Control.Monad.Trans -import Control.Exception -import Control.Monad -import qualified Data.ByteString.Lazy.Char8 as L -import Data.List -import Data.Maybe -import Debian.Extra.CIO (vMessage) -import Debian.Repo.Cache -import Debian.Repo.IO -import Debian.Repo.Package -import Debian.Relation -import Debian.Repo.Slice -import Debian.Repo.SourcesList -import Debian.Repo.Types -import Debian.Shell (timeTask, vOutput, runTaskAndTest, SimpleTask(..)) -import Extra.CIO (CIO, vPutStr, vPutStrBl, vBOL, ePutStr) -import Extra.Files (replaceFile) -import Extra.List (isSublistOf) -import Extra.Misc (sameInode, sameMd5sum) -import Extra.SSH (sshCopy) -import System.FilePath -import System.Unix.Directory -import System.Unix.Mount -import System.Unix.Process -import System.Cmd -import System.Directory -import qualified System.IO as IO -import System.Posix.Files -import System.Time -import Text.Regex - --- |This type represents an OS image located at osRoot built from a --- particular osBaseDistro using a particular osArch. If an --- osLocalRepo 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 { osGlobalCacheDir :: FilePath - , osRoot :: EnvRoot - , osBaseDistro :: SliceList - , osReleaseName :: ReleaseName - , osArch :: Arch - -- | The associated local repository, where packages we - -- build inside this image are first uploaded to. - , osLocalRepoMaster :: Maybe LocalRepository - -- |A copy of osLocalRepo which is inside the changeroot - --, osLocalRepoCopy :: Maybe LocalRepo - -- | Update and return a copy of the local repository - -- which is inside the changeroot. - , osSourcePackages :: [SourcePackage] - , osBinaryPackages :: [BinaryPackage] - } - -instance Show OSImage where - show os = intercalate " " ["OS {", - rootPath (osRoot os), - relName (osReleaseName os), - archName (osArch os), - show (osLocalRepoMaster os)] - -instance Ord OSImage where - compare a b = case compare (osRoot a) (osRoot b) of - EQ -> case compare (osBaseDistro a) (osBaseDistro b) of - EQ -> compare (osArch a) (osArch b) - x -> x - x -> x - -instance Eq OSImage where - a == b = compare a b == EQ - -instance AptCache OSImage where - globalCacheDir = osGlobalCacheDir - rootDir = osRoot - aptArch = osArch - -- aptSliceList = osFullDistro - aptBaseSliceList = osBaseDistro - aptSourcePackages = osSourcePackages - aptBinaryPackages = osBinaryPackages - aptReleaseName = osReleaseName - -instance AptBuildCache OSImage where - aptSliceList = osFullDistro - --- |The sources.list is the list associated with the distro name, plus --- the local sources where we deposit newly built packages. -osFullDistro :: OSImage -> SliceList -osFullDistro os = SliceList { slices = slices (osBaseDistro os) ++ slices (localSources os) } - -localSources :: OSImage -> SliceList -localSources os = - case osLocalRepoMaster os of - Nothing -> SliceList { slices = [] } - Just repo -> - let repo' = repoCD (EnvPath (envRoot (repoRoot repo)) "/work/localpool") repo in - let name = relName (osReleaseName os) in - let src = DebSource Deb (repoURI repo') (Right (parseReleaseName name, [parseSection' "main"])) - bin = DebSource DebSrc (repoURI repo') (Right (parseReleaseName name, [parseSection' "main"])) in - SliceList { slices = [Slice { sliceRepo = LocalRepo repo', sliceSource = src }, - Slice { sliceRepo = LocalRepo repo', sliceSource = bin }] } - --- |Change the root directory of a repository. FIXME: This should --- also sync the repository to ensure consistency. -repoCD :: EnvPath -> LocalRepository -> LocalRepository -repoCD path repo = repo { repoRoot = path } - -getSourcePackages :: CIO m => OSImage -> AptIOT m [SourcePackage] -getSourcePackages os = - mapM (sourcePackagesOfIndex' os) indexes >>= return . concat - where indexes = concat . map (sliceIndexes os) . slices . sourceSlices . aptSliceList $ os - -getBinaryPackages :: CIO m => OSImage -> AptIOT m [BinaryPackage] -getBinaryPackages os = - mapM (binaryPackagesOfIndex' os) indexes >>= return . concat - where indexes = concat . map (sliceIndexes os) . slices . binarySlices . aptSliceList $ os - --- |Create or update an OS image in which packages can be built. -prepareEnv :: CIO m - => FilePath - -> EnvRoot -- ^ The location where image is to be built - -> NamedSliceList -- ^ The sources.list - -> Maybe LocalRepository -- ^ The associated local repository, where newly - -- built packages are stored. This repository is - -- periodically copied into the build environment - -- so apt can access the packages in it. - -> Bool -- ^ If true, remove and rebuild the image - -> SourcesChangedAction -- ^ What to do if called with a sources.list that - -- differs from the previous call (unimplemented) - -> [String] -- ^ Extra packages to treat as essential - -> [String] -- ^ Packages to consider non-essential even if marked essential - -> [String] -- ^ Extra packages to install during the build - -> AptIOT m OSImage -prepareEnv cacheDir root distro repo flush _ifSourcesChanged extraEssential omitEssential extra = - do arch <- liftIO buildArchOfRoot - --vPutStrLn 0 $ "prepareEnv repo: " ++ show repo - let os = OS { osGlobalCacheDir = cacheDir - , osRoot = root - , osBaseDistro = sliceList distro - , osReleaseName = ReleaseName . sliceName . sliceListName $ distro - , osArch = arch - , osLocalRepoMaster = repo - , osSourcePackages = [] - , osBinaryPackages = [] } - update os >>= recreate arch os >>= lift . syncPool - where - update _ | flush = return $ Left "--flush option given" - update os = updateEnv os - recreate _ _ (Right os) = return os - recreate arch os (Left reason) = - do lift (vPutStrBl 0 $ "Removing and recreating build environment at " ++ rootPath root ++ ": " ++ reason) - lift (vPutStrBl 2 ("removeRecursiveSafely " ++ rootPath root)) - liftIO (removeRecursiveSafely (rootPath root)) - lift (vPutStrBl 2 ("createDirectoryIfMissing True " ++ show (distDir os))) - liftIO (createDirectoryIfMissing True (distDir os)) - lift (vPutStrBl 3 ("writeFile " ++ show (sourcesPath os) ++ " " ++ show (show . osBaseDistro $ os))) - liftIO (replaceFile (sourcesPath os) (show . osBaseDistro $ os)) - buildEnv cacheDir root distro arch repo extraEssential omitEssential extra >>= lift . neuterEnv >>= lift . syncPool - --- |Prepare a minimal \/dev directory -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 :: CIO m - => FilePath - -> EnvRoot - -> NamedSliceList - -> Arch - -> Maybe LocalRepository - -> [String] - -> [String] - -> [String] - -> AptIOT m OSImage -buildEnv cacheDir root distro arch repo extraEssential omitEssential extra = - do - -- 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. - (output, result) <- - liftIO (lazyCommand cmd L.empty) >>= - lift . vMessage 0 ("Creating clean build environment (" ++ sliceName (sliceListName distro) ++ ")") >>= - lift . vMessage 1 ("# " ++ cmd) >>= - lift . vOutput 1 >>= - return . collectStderr . mergeToStderr - case result of - -- It is fatal if we can't build the environment - [Result ExitSuccess] -> - do lift (ePutStr "done.\n") - let os = OS { osGlobalCacheDir = cacheDir - , osRoot = root - , osBaseDistro = sliceList distro - , osReleaseName = ReleaseName . sliceName . sliceListName $ distro - , osArch = arch - , osLocalRepoMaster = repo - , osSourcePackages = [] - , osBinaryPackages = [] } - let sourcesPath = rootPath root ++ "/etc/apt/sources.list" - -- Rewrite the sources.list with the local pool added. - liftIO $ replaceFile sourcesPath (show . aptSliceList $ os) - updateEnv os >>= either (error . show) return - failure -> - (lift . ePutStr . L.unpack $ output) >> - error ("Could not create build environment:\n " ++ cmd ++ " -> " ++ show failure) - where - cmd = ("unset LANG; build-env --allow-missing-indexes --immediate-configure-false " ++ - " -o " ++ rootPath root ++ " -s " ++ cacheSourcesPath cacheDir (ReleaseName (sliceName (sliceListName distro))) ++ - " --with '" ++ intercalate " " extra ++ "'" ++ - " --with-essential '" ++ intercalate " " extraEssential ++ "'" ++ - " --omit-essential '" ++ intercalate " " omitEssential ++ "'") - --- |Try to update an existing build environment: run apt-get update --- and dist-upgrade. -updateEnv :: CIO m => OSImage -> AptIOT m (Either String OSImage) -updateEnv os = - do verified <- verifySources os - case verified of - Left x -> return $ Left x - Right _ -> - do liftIO $ prepareDevs (rootPath root) - os' <- lift $ syncPool os - liftIO $ sshCopy (rootPath root) - source <- getSourcePackages os' - binary <- getBinaryPackages os' - return . Right $ os' {osSourcePackages = source, osBinaryPackages = binary} - where - verifySources :: CIO m => OSImage -> AptIOT m (Either String OSImage) - verifySources os = - do let correct = aptSliceList os - sourcesPath = rootPath root ++ "/etc/apt/sources.list" - text <- liftIO (try $ readFile sourcesPath) - installed <- - case text of - Left _ -> return Nothing - Right s -> verifySourcesList (Just root) (parseSourcesList s) >>= return . Just - case installed of - Nothing -> return $ Left ("No sources.list for " ++ relName (osReleaseName os) ++ " at " ++ sourcesPath) - Just installed - | installed /= correct -> - return $ Left ("Sources for " ++ relName (osReleaseName os) ++ " in " ++ sourcesPath ++ - " don't match computed configuration.\n\ncomputed:\n" ++ - show correct ++ "\ninstalled:\n" ++ - show installed) - _ -> return $ Right os - root = osRoot os - -chrootEnv :: OSImage -> EnvRoot -> OSImage -chrootEnv os dst = os {osRoot=dst} - --- 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 :: CIO m => OSImage -> OSImage -> m OSImage -syncEnv src dst = - mkdir >>= liftIO . umount >>= sync >>= either (error . show) (const (return dst)) -{- - either (return . Left . show) (const (liftIO doUmounts)) >>= - either (return . Left) (const . syncStyle . runCommand 1 $ cmd) >>= - either (error . show) (const (return dst)) --} - where - mkdir = liftIO (try (createDirectoryIfMissing True (rootPath (osRoot dst) ++ "/work"))) - umount (Left message) = return . Left . show $ message - umount (Right _) = - do srcResult <- umountBelow (rootPath (osRoot src)) - dstResult <- umountBelow (rootPath (osRoot dst)) - case filter (\ (_, (_, _, code)) -> code /= ExitSuccess) (srcResult ++ dstResult) of - [] -> return (Right ()) - failed -> return . Left $ "umount failure(s): " ++ show failed - sync (Left message) = return (Left message) - sync (Right _) = - runTaskAndTest (SimpleTask 1 cmd) >>= - vMessage 0 ("Copying clean build environment: " ++ - rootPath (osRoot src) ++ " -> " ++ rootPath (osRoot dst)) - cmd = ("rsync -aHxSpDt '--exclude=/work/build/**' --delete '" ++ rootPath (osRoot src) ++ - "/' '" ++ rootPath (osRoot dst) ++ "'") -{- - syncStyle = setStyle (setStart (Just ("Copying clean build environment: " ++ - rootPath (osRoot src) ++ " -> " ++ rootPath (osRoot dst))) . - setError (Just "Could not sync with clean build environment")) --} - --- |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 :: CIO m => OSImage -> m OSImage -neuterEnv os = - do - vBOL 0 >> vPutStr 0 ("Neutering OS image (" ++ stripDist (rootPath root) ++ ")...") - result <- liftIO $ try $ mapM_ (neuterFile os) neuterFiles - either (\ e -> error $ "Failed to neuter environment " ++ rootPath root ++ ": " ++ show e) - (\ _ -> return os) - result - where - root = osRoot os - -neuterFiles :: [(FilePath, Bool)] -neuterFiles = [("/sbin/start-stop-daemon", True), - ("/usr/sbin/invoke-rc.d", True), - ("/sbin/init",False), - ("/usr/sbin/policy-rc.d", False)] - --- neuter_file from build-env.ml -neuterFile :: OSImage -> (FilePath, Bool) -> IO () -neuterFile os (file, mustExist) = - do - -- putStrBl ("Neutering file " ++ file) - exists <- doesFileExist (outsidePath fullPath) - if exists then - neuterExistantFile else - if mustExist then - error ("Can't neuter nonexistant file: " ++ outsidePath fullPath) else - return () -- putStrBl "File doesn't exist, nothing to do" - - where - neuterExistantFile = - do - sameFile <- sameInode (outsidePath fullPath) (outsidePath binTrue) - if sameFile then - return () else -- putStrBl "File already neutered" - neuterUnneuteredFile - neuterUnneuteredFile = - do - hasReal <- doesFileExist (outsidePath fullPath ++ ".real") - if hasReal then - neuterFileWithRealVersion else - neuterFileWithoutRealVersion - createLink (outsidePath binTrue) (outsidePath fullPath) - neuterFileWithRealVersion = - do - sameCksum <- sameMd5sum (outsidePath fullPath) (outsidePath fullPath ++ ".real") - if sameCksum then - removeFile (outsidePath fullPath) else - error (file ++ " and " ++ file ++ ".real differ (in " ++ rootPath root ++ ")") - - neuterFileWithoutRealVersion = renameFile (outsidePath fullPath) (outsidePath fullPath ++ ".real") - - fullPath = EnvPath root file - binTrue = EnvPath root "/bin/true" - root = osRoot os - --- |Reverse the neuterEnv operation. -restoreEnv :: OSImage -> IO OSImage -restoreEnv os = - do - IO.hPutStr IO.stderr "De-neutering OS image..." - result <- try $ mapM_ (restoreFile os) neuterFiles - either (\ e -> error $ "damaged environment " ++ rootPath root ++ ": " ++ show e ++ "\n please remove it.") - (\ _ -> return os) result - where - root = osRoot os - --- check_and_restore from build-env.ml -restoreFile :: OSImage -> (FilePath, Bool) -> IO () -restoreFile os (file, mustExist) = - do - exists <- doesFileExist (outsidePath fullPath) - if exists then - restoreExistantFile else - if mustExist then - error ("Can't restore nonexistant file: " ++ outsidePath fullPath) else - return () - where - restoreExistantFile = - do - isTrue <- sameInode (outsidePath fullPath) (outsidePath binTrue) - hasReal <- doesFileExist (outsidePath fullPath ++ ".real") - case (isTrue, hasReal) of - (True, True) -> - do - removeFile (outsidePath fullPath) - renameFile (outsidePath fullPath ++ ".real") (outsidePath 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" - root = osRoot os - ------------------------------------ - --- |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 False = - do - essential <- - readFile (rootPath root ++ "/usr/share/build-essential/essential-packages-list") >>= - return . lines >>= return . dropWhile (/= "") >>= return . tail >>= return . filter (/= "sysvinit") >>= - return . parseRelations . (intercalate ", ") >>= - return . (either (error "parse error in /usr/share/build-essential/essential-packages-list") id) - let re = mkRegex "^[^ \t]" - relationText <- - readFile (rootPath 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: " ++ intercalate ", " relationText) - let buildEssential = parseRelations (intercalate ", " relationText) - let buildEssential' = either (\ l -> error ("parse error in /usr/share/build-essential/list:\n" ++ show l)) id buildEssential - return (essential ++ buildEssential') - where - root = osRoot os - --- |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 = - do - IO.hPutStr IO.stderr "Removing build environment..." - removeRecursiveSafely (rootPath root) - IO.hPutStrLn IO.stderr "done." - where - root = osRoot os - --- |Use rsync to synchronize the pool of locally built packages from --- outside the build environment to the location inside the environment --- where apt can see and install the packages. -syncPool :: CIO m => OSImage -> m OSImage -syncPool os = - case osLocalRepoMaster os of - Nothing -> return os - Just repo -> - liftIO (try (createDirectoryIfMissing True (rootPath root ++ "/work"))) >>= - either (return . Left . show) (const (rsync repo)) >>= - either (return . Left) (const (updateLists os)) >>= - either (error . show) (const (return os)) - where - rsync repo = - liftIO (lazyCommand (cmd repo) L.empty) >>= - vOutput 0 >>= - vMessage 1 ("Syncing local pool from " ++ outsidePath (repoRoot repo) ++ " -> " ++ rootPath root) >>= - checkResult (\ n -> return (Left $ "*** FAILURE syncing local pool: " ++ cmd repo ++ " -> " ++ show n)) (return (Right ())) - cmd repo = "rsync -aHxSpDt --delete '" ++ outsidePath (repoRoot repo) ++ "/' '" ++ rootPath root ++ "/work/localpool'" - root = osRoot os - -updateLists :: CIO m => OSImage -> m (Either String TimeDiff) -updateLists os = - do vMessage 1 ("Updating OSImage " ++ stripDist (rootPath root) ++ " ") () - vMessage 2 ("# " ++ cmd) () - ((_out, err, code), elapsed) <- liftIO . timeTask $ lazyCommand cmd L.empty >>= return . collectOutputUnpacked - return $ case code of - [ExitSuccess] -> Right elapsed - result -> Left $ "*** FAILURE: Could not update environment: " ++ cmd ++ " -> " ++ show result ++ "\n" ++ err - where - cmd = ("echo $PATH 1>&2 && /usr/sbin/chroot " ++ rootPath root ++ - " bash -c 'unset LANG; apt-get update && apt-get -y --force-yes dist-upgrade'") - root = osRoot os - -stripDist :: FilePath -> FilePath -stripDist path = maybe path (\ n -> drop (n + 7) path) (isSublistOf "/dists/" path) diff --git a/Debian/Repo/Package.hs b/Debian/Repo/Package.hs deleted file mode 100644 --- a/Debian/Repo/Package.hs +++ /dev/null @@ -1,332 +0,0 @@ -module Debian.Repo.Package - ( -- * Source and binary packages - sourceFilePaths - , binaryPackageSourceVersion - , binarySourceVersion - , sourcePackageBinaryNames - , sourceBinaryNames - , toSourcePackage - , toBinaryPackage - , binaryPackageSourceID - , sourcePackageBinaryIDs - , sourcePackagesOfIndex - , sourcePackagesOfIndex' - , binaryPackagesOfIndex - , binaryPackagesOfIndex' - , getPackages - , putPackages - , releaseSourcePackages - , releaseBinaryPackages - -- * Deprecated stuff for interfacing with Debian.Relation - ) where - -import Debian.Apt.Index (Compression(..), controlFromIndex) -import Debian.Control -import Debian.Repo.PackageIndex -import qualified Debian.Control.ByteString as B -import qualified Debian.Relation.ByteString as B -import Debian.Repo.IO ---import Debian.Shell -import Debian.Repo.Types -import Debian.URI -import Debian.Version - -import Control.Exception (Exception(..)) -import Control.Monad.Trans -import Control.Monad.State (get, put) -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.ByteString.Char8 as B -import Data.List -import Data.Maybe -import qualified Extra.Either as EE -import qualified Extra.Files as EF -import Extra.CIO (CIO(..)) ---import System.Directory -import System.FilePath(()) -import System.IO.Unsafe -import System.Posix ---import System.Unix.Process -import Text.Regex - -sourceFilePaths :: SourcePackage -> [FilePath] -sourceFilePaths package = - map ((sourceDirectory package) ) . map sourceFileName . sourcePackageFiles $ package - --- | Return the name and version number of the source package that --- generated this binary package. -binaryPackageSourceVersion :: BinaryPackage -> Maybe (String, DebianVersion) -binaryPackageSourceVersion package = - let binaryName = packageName . packageID $ package - binaryVersion = packageVersion . packageID $ package in - binarySourceVersion' binaryName binaryVersion (packageInfo package) - --- |Return the name and version number of the source package that --- generated this binary package. --- see also: 'binaryPackageSourceVersion' -binarySourceVersion :: B.Paragraph -> Maybe ((String, DebianVersion), (String, DebianVersion)) -binarySourceVersion paragraph = - let mBinaryName = fmap B.unpack $ fieldValue "Package" paragraph - mBinaryVersion = fmap (parseDebianVersion . B.unpack) $ fieldValue "Version" paragraph - in - case (mBinaryName, mBinaryVersion) of - (Just binaryName, Just binaryVersion) -> - fmap ((,) (binaryName, binaryVersion)) $ binarySourceVersion' binaryName binaryVersion paragraph - _ -> Nothing - -binarySourceVersion' :: (ControlFunctions a) => String -> DebianVersion -> Paragraph' a -> Maybe (String, DebianVersion) -binarySourceVersion' binaryName binaryVersion paragraph = - case (B.fieldValue "Source" paragraph) of - Just source -> - case matchRegex re (asString source) of - Just [name, _, ""] -> Just (name, binaryVersion) - Just [name, _, version] -> Just (name, parseDebianVersion version) - _ -> error "internal error" - Nothing -> - Just (asString binaryName, binaryVersion) - where - re = mkRegex "^[ ]*([^ (]*)[ ]*(\\([ ]*([^ )]*)\\))?[ ]*$" - -sourcePackageBinaryNames :: SourcePackage -> [String] -sourcePackageBinaryNames package = - sourceBinaryNames (sourceParagraph package) - -sourceBinaryNames :: B.Paragraph -> [String] -sourceBinaryNames paragraph = - case B.fieldValue "Binary" paragraph of - Just names -> splitRegex (mkRegex "[ ,]+") (B.unpack names) - _ -> error ("Source package info has no 'Binary' field:\n" ++ (B.unpack . formatParagraph $ paragraph)) - -toSourcePackage :: PackageIndex -> B.Paragraph -> SourcePackage -toSourcePackage index package = - case (B.fieldValue "Directory" package, - B.fieldValue "Files" package, - B.fieldValue "Package" package, - maybe Nothing (Just . parseDebianVersion . B.unpack) (B.fieldValue "Version" package)) of - (Just directory, Just files, Just name, Just version) -> - case parseSourcesFileList files of - Right files -> - SourcePackage - { sourcePackageID = - PackageID - { packageIndex = index - , packageName = B.unpack name - , packageVersion = version } - , sourceParagraph = package - , sourceDirectory = B.unpack directory - , sourcePackageFiles = files } - Left messages -> error $ "Invalid file list: " ++ show messages - _ -> error $ "Missing info in source package control information:\n" ++ B.unpack (formatParagraph package) - where - -- Parse the list of files in a paragraph of a Sources index. - parseSourcesFileList :: B.ByteString -> Either [String] [SourceFileSpec] - parseSourcesFileList text = - merge . catMaybes . map parseSourcesFiles . lines . B.unpack $ text - parseSourcesFiles line = - case words line of - [md5sum, size, name] -> Just (Right (SourceFileSpec md5sum (read size) name)) - [] -> Nothing - _ -> Just (Left ("Invalid line in Files list: '" ++ show line ++ "'")) - merge x = case partition (either (const True) (const False)) x of - (a, []) -> Left . catMaybes . map (either Just (const Nothing )) $ a - (_, a) -> Right . catMaybes . map (either (const Nothing) Just) $ a - -toBinaryPackage :: PackageIndex -> B.Paragraph -> BinaryPackage -toBinaryPackage index p = - case (B.fieldValue "Package" p, B.fieldValue "Version" p) of - (Just name, Just version) -> - BinaryPackage - { packageID = PackageID { packageIndex = index - , packageName = B.unpack name - , packageVersion = parseDebianVersion (B.unpack version) } - , packageInfo = p - , pDepends = tryParseRel $ B.lookupP "Depends" p - , pPreDepends = tryParseRel $ B.lookupP "Pre-Depends" p - , pConflicts = tryParseRel $ B.lookupP "Conflicts" p - , pReplaces = tryParseRel $ B.lookupP "Replaces" p - , pProvides = tryParseRel $ B.lookupP "Provides" p - } - _ -> error ("Invalid data in source index:\n " ++ packageIndexPath index) - -tryParseRel :: Maybe B.Field -> B.Relations -tryParseRel (Just (B.Field (_, relStr))) = either (error . show) id (B.parseRelations relStr) -tryParseRel _ = [] - --- | Parse the /Source/ field of a binary package's control --- information, this may specify a version number for the source --- package if it differs from the version number of the binary --- package. -binaryPackageSourceID :: BinaryPackage -> PackageID -binaryPackageSourceID package = - case maybe Nothing (matchRegex re . B.unpack) (B.fieldValue "Source" (packageInfo package)) of - Just [name, _, ""] -> PackageID { packageIndex = sourceIndex - , packageName = name - , packageVersion = packageVersion id } - Just [name, _, version] -> PackageID { packageIndex = sourceIndex - , packageName = name - , packageVersion = parseDebianVersion version } - _ -> error "Missing Source attribute in binary package info" - where - sourceIndex = PackageIndex release component Source - (PackageIndex release component _) = packageIndex id - id = packageID package - re = mkRegex "^[ ]*([^ (]*)[ ]*(\\([ ]*([^ )]*)\\))?[ ]*$" - -sourcePackageBinaryIDs :: Arch -> SourcePackage -> [PackageID] -sourcePackageBinaryIDs Source _ = error "invalid argument" -sourcePackageBinaryIDs arch package = - case (B.fieldValue "Version" info, B.fieldValue "Binary" info) of - (Just version, Just names) -> map (binaryID (parseDebianVersion (B.unpack version))) $ splitRegex (mkRegex "[ ,]+") (B.unpack names) - _ -> error ("Source package info has no 'Binary' field:\n" ++ (B.unpack . formatParagraph $ info)) - where - -- Note that this version number may be wrong - we need to - -- look at the Source field of the binary package info. - binaryID version name = PackageID { packageIndex = binaryIndex - , packageName = name - , packageVersion = version } - sourceIndex = packageIndex (sourcePackageID package) - binaryIndex = sourceIndex { packageIndexArch = arch } - info = sourceParagraph package - --- | Get the contents of a package index -getPackages :: CIO m => PackageIndex -> m (Either Exception [BinaryPackage]) -getPackages index = - liftIO (fileFromURI (uri {uriPath = uriPath uri packageIndexPath index ++ ".gz"})) >>= - return . either Left (\ s -> case controlFromIndex GZ (show uri) s of - Left e -> Left (ErrorCall (show e)) - Right (B.Control control) -> Right $ map (toBinaryPackage index) control) - where - uri = repoURI repo - release = packageIndexRelease index - repo = releaseRepo release - --- | Get the contents of a package index -binaryPackagesOfIndex :: CIO m => PackageIndex -> m (Either Exception [BinaryPackage]) -binaryPackagesOfIndex index = - case packageIndexArch index of - Source -> return (Right []) - _ -> getPackages index -- >>= return . either Left (Right . map (toBinaryPackage index . packageInfo)) - --- | Get the contents of a package index -sourcePackagesOfIndex :: CIO m => PackageIndex -> m (Either Exception [SourcePackage]) -sourcePackagesOfIndex index = - case packageIndexArch index of - Source -> getPackages index >>= return . either Left (Right . map (toSourcePackage index . packageInfo)) - _ -> return (Right []) - --- FIXME: assuming the index is part of the cache -sourcePackagesOfIndex' :: (AptCache a, CIO m) => a -> PackageIndex -> AptIOT m [SourcePackage] -sourcePackagesOfIndex' cache index = - do state <- get - let cached = lookupSourcePackages path state - status <- liftIO $ getFileStatus path - case cached of - Just (status', packages) | status == status' -> return packages - _ -> do paragraphs <- liftIO $ unsafeInterleaveIO (readParagraphs path) - let packages = map (toSourcePackage index) paragraphs - put (insertSourcePackages path (status, packages) state) - return packages - where - path = rootPath (rootDir cache) ++ indexCacheFile cache index - -indexCacheFile :: (AptCache a) => a -> PackageIndex -> FilePath -indexCacheFile apt index = - case (aptArch apt, packageIndexArch index) of - (Source, _) -> error "Invalid build architecture: Source" - (Binary _, Source) -> indexPrefix index ++ "_source_Sources" - (Binary _, Binary arch) -> indexPrefix index ++ "_binary-" ++ arch ++ "_Packages" - -indexPrefix :: PackageIndex -> FilePath -indexPrefix index = - (escapeURIString (/= '@') ("/var/lib/apt/lists/" ++ uriText +?+ "dists_") ++ - releaseName' distro ++ "_" ++ (sectionName' $ section)) - where - release = packageIndexRelease index - section = packageIndexComponent index - repo = releaseRepo release - uri = repoURI repo - distro = releaseInfoName . releaseInfo $ release - scheme = uriScheme uri - auth = uriAuthority uri - path = uriPath uri - userpass = maybe "" uriUserInfo auth - reg = maybeOfString $ maybe "" uriRegName auth - port = maybe "" uriPort auth - (user, pass) = break (== ':') userpass - user' = maybeOfString user - pass' = maybeOfString pass - uriText = prefix scheme user' pass' reg port path - -- 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 repo URI: " ++ (uriToString' . repoURI. releaseRepo . packageIndexRelease $ index)) - maybeOfString "" = Nothing - maybeOfString s = Just s - escape s = intercalate "_" (wordsBy (== '/') s) - 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) - -(+?+) :: String -> String -> String -(+?+) a ('_' : b) = a +?+ b -(+?+) "" b = b -(+?+) a b = - case last a of - '_' -> (init a) +?+ b - _ -> a ++ "_" ++ b - --- FIXME: assuming the index is part of the cache -binaryPackagesOfIndex' :: (AptCache a, CIO m) => a -> PackageIndex -> AptIOT m [BinaryPackage] -binaryPackagesOfIndex' cache index = - do state <- get - let cached = lookupBinaryPackages path state - status <- liftIO $ getFileStatus path - case cached of - Just (status', packages) | status == status' -> return packages - _ -> do paragraphs <- liftIO $ unsafeInterleaveIO (readParagraphs path) - let packages = map (toBinaryPackage index) paragraphs - put (insertBinaryPackages path (status, packages) state) - return packages - where - path = rootPath (rootDir cache) ++ indexCacheFile cache index - --- | Return a list of all source packages. -releaseSourcePackages :: CIO m => Release -> m (Either Exception [SourcePackage]) -releaseSourcePackages release = - mapM sourcePackagesOfIndex (sourceIndexList release) >>= return . test - where - test xs = case EE.partitionEithers xs of - ([], ok) -> Right (concat ok) - (bad, _) -> Left . ErrorCall $ intercalate ", " (map show bad) - --- | Return a list of all the binary packages for all supported architectures. -releaseBinaryPackages :: CIO m => Release -> m (Either Exception [BinaryPackage]) -releaseBinaryPackages release = - mapM binaryPackagesOfIndex (binaryIndexList release) >>= return . test - where - test xs = case EE.partitionEithers xs of - ([], ok) -> Right (concat ok) - (bad, _) -> Left . ErrorCall $ intercalate ", " (map show bad) - --- | Write a set of packages into a package index. -putPackages :: PackageIndexLocal -> [BinaryPackageLocal] -> IO (Either [String] ()) -putPackages index packages = - case releaseRepo release of - LocalRepo repo -> EF.writeAndZipFileWithBackup (outsidePath (repoRoot repo) packageIndexPath index) text - x -> error $ "Package.putPackages: Expected local repository, found " ++ show x - where - release = packageIndexRelease index - --repo = releaseRepo release - text = L.fromChunks [B.concat (intersperse (B.pack "\n") . map formatParagraph . map packageInfo $ packages)] diff --git a/Debian/Repo/PackageIndex.hs b/Debian/Repo/PackageIndex.hs deleted file mode 100644 --- a/Debian/Repo/PackageIndex.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Debian.Repo.PackageIndex - ( packageIndexName - , packageIndexPath - , packageIndexDir - , packageIndexPathList - , packageIndexDirList - , packageIndexList - , sourceIndexList - , binaryIndexList - , releaseDir - , showIndexBrief - , debSourceFromIndex - ) where - -import Data.List -import Debian.Repo.Types ---import Debian.Release -import System.FilePath(()) - -packageIndexName :: PackageIndex -> FilePath -packageIndexName index = - case packageIndexArch index of - Source -> "Sources" - _ -> "Packages" - -packageIndexPath :: PackageIndex -> FilePath -packageIndexPath index = packageIndexDir index ++ "/" ++ packageIndexName index - -packageIndexDir :: PackageIndex -> FilePath -packageIndexDir index = - case packageIndexArch index of - Source -> releaseDir (packageIndexRelease index) ++ "/" ++ sectionName' (packageIndexComponent index) ++ "/source" - _ -> (releaseDir (packageIndexRelease index) ++ "/" ++ - sectionName' (packageIndexComponent index) ++ - "/binary-" ++ archName (packageIndexArch index)) - -releaseDir release = "dists/" ++ (releaseName' . releaseName $ release) - -packageIndexPathList :: Release -> [FilePath] -packageIndexPathList release = map packageIndexPath . packageIndexList $ release - -packageIndexDirList :: Release -> [FilePath] -packageIndexDirList release = map packageIndexDir . packageIndexList $ release - -packageIndexList :: Release -> [PackageIndex] -packageIndexList release = sourceIndexList release ++ binaryIndexList release - -sourceIndexList :: Release -> [PackageIndex] -sourceIndexList release = - map componentIndex (releaseComponents release) - where componentIndex component = PackageIndex { packageIndexRelease = release - , packageIndexComponent = component - , packageIndexArch = Source } - -binaryIndexList :: Release -> [PackageIndex] -binaryIndexList release = - concat . map componentIndexes $ (releaseComponents release) - where - --componentIndexes :: Section -> [PackageIndex] - componentIndexes component = - map archIndex (filter (/= Source) (releaseArchitectures release)) - where - --archIndex :: Arch -> PackageIndex - archIndex arch = PackageIndex { packageIndexRelease = release - , packageIndexComponent = component - , packageIndexArch = arch } - -showIndexBrief :: PackageIndex -> String -showIndexBrief index = - (releaseName' . releaseName $ release) sectionName' (packageIndexComponent index) showArch (packageIndexArch index) - where release = packageIndexRelease index - showArch Source = "source" - showArch (Binary x) = "binary-" ++ x - -debSourceFromIndex :: PackageIndex -> DebSource -debSourceFromIndex index = - DebSource {sourceType = typ, - sourceUri = repoURI repo, - sourceDist = Right (dist, components)} - where - typ = case arch of Binary _ -> Deb; Source -> DebSrc - arch = packageIndexArch index - dist = releaseName release - components = releaseComponents release - repo = releaseRepo release - release = packageIndexRelease index diff --git a/Debian/Repo/Release.hs b/Debian/Repo/Release.hs deleted file mode 100644 --- a/Debian/Repo/Release.hs +++ /dev/null @@ -1,265 +0,0 @@ -module Debian.Repo.Release - ( lookupRelease - , insertRelease - , prepareRelease - , findReleases - , signRelease - , signReleases - , mergeReleases - ) where - -import qualified Debian.Control.String as S -import Debian.Repo.IO -import Debian.Repo.Types -import Debian.Repo.LocalRepository -import Debian.Repo.PackageIndex - -import Control.Monad.State -import qualified Data.ByteString.Lazy.Char8 as L -import Data.List -import Data.Maybe -import Data.Time ---import Data.Time.Clock.POSIX ---import System.Locale (defaultTimeLocale) -import qualified Extra.Files as EF -import qualified Extra.GPGSign as EG -import qualified Extra.Time as ET -import Extra.CIO (CIO, vPutStrBl) -import System.Directory -import System.Posix.Files -import qualified System.Posix.Files as F -import System.FilePath(()) -import System.Unix.Process - -lookupRelease :: CIO m => Repository -> ReleaseName -> AptIOT m (Maybe Release) -lookupRelease repo dist = get >>= return . findRelease repo dist - -insertRelease :: CIO m => Release -> AptIOT m Release -insertRelease release = - get >>= put . putRelease repo dist release >> return release - where dist = releaseInfoName (releaseInfo release) - repo = releaseRepo release - --- | Find or create a (local) release. -prepareRelease :: CIO m => LocalRepository -> ReleaseName -> [ReleaseName] -> [Section] -> [Arch] -> AptIOT m Release -prepareRelease repo dist aliases sections archList = - -- vPutStrLn 0 ("prepareRelease " ++ name ++ ": " ++ show repo ++ " sections " ++ show sections) >> - lookupRelease (LocalRepo repo) dist >>= maybe prepare (const prepare) -- return -- JAS - otherwise --create-section does not do anything - where - prepare = - do -- FIXME: errors get discarded in the mapM calls here - let release = Release (LocalRepo repo) (ReleaseInfo { releaseInfoName = dist - , releaseInfoAliases = aliases - , releaseInfoComponents = sections - , releaseInfoArchitectures = archList }) - -- vPutStrLn 0 ("packageIndexList: " ++ show (packageIndexList release)) - mapM (initIndex (outsidePath root)) (packageIndexList release) - mapM (initAlias (outsidePath root) dist) aliases - lift (writeRelease release) - -- This ought to be identical to repo, but the layout should be - -- something rather than Nothing. - repo' <- prepareLocalRepository root (repoLayout repo) - let release' = release { releaseRepo = LocalRepo repo' } - --vPutStrLn 0 $ "prepareRelease: prepareLocalRepository -> " ++ show repo' - insertRelease release' - initIndex root index = initIndexFile (root packageIndexDir index) (packageIndexName index) - initIndexFile dir name = - do io $ createDirectoryIfMissing True dir - io $ setFileMode dir 0o040755 - ensureIndex (dir name) - initAlias root dist alias = - io $ EF.prepareSymbolicLink (releaseName' dist) (root ++ "/dists/" ++ releaseName' alias) - root = repoRoot repo - --- | Make sure an index file exists. -ensureIndex :: CIO m => FilePath -> AptIOT m (Either [String] ()) -ensureIndex path = - do exists <- io $ doesFileExist path - case exists of - False -> io $ EF.writeAndZipFile path L.empty - True -> return $ Right () - -signReleases :: CIO m => Maybe EG.PGPKey -> [Release] -> m () -signReleases keyname releases = mapM_ (signRelease keyname) releases - -signRelease :: CIO m => Maybe EG.PGPKey -> Release -> m () -signRelease keyname release@(Release {releaseRepo = LocalRepo repo}) = - do let root = repoRoot repo - files <- writeRelease release - case keyname of - Nothing -> return () - Just key -> do results <- liftIO (EG.pgpSignFiles (outsidePath root) key files) - let failed = catMaybes $ map (\ (path, flag) -> if (not flag) then Just path else Nothing) (zip files results) - case failed of - [] -> return () - files -> vPutStrBl 0 ("Unable to sign:\n " ++ intercalate "\n " files) -signRelease _keyname _release = error $ "Attempt to sign non-local repository" - --- |Write out the @Release@ files that describe a 'Release'. -writeRelease :: CIO m => Release -> m [FilePath] -writeRelease release@(Release {releaseRepo = LocalRepo repo}) = - do let root = repoRoot repo - indexReleaseFiles <- liftIO $ writeIndexReleases (outsidePath root) release - masterReleaseFile <- writeMasterRelease (outsidePath root) release - return (masterReleaseFile : indexReleaseFiles) - where - writeIndexReleases root release = - mapM (writeIndex root) (packageIndexList release) - -- It should only be necessary to write these when the component - -- is created, not every time the index files are changed. But - -- for now we're doing it anyway. - writeIndex root index = - do let para = - S.Paragraph - [S.Field ("Archive", releaseName' . releaseInfoName . releaseInfo . packageIndexRelease $ index), - S.Field ("Component", sectionName' (packageIndexComponent index)), - S.Field ("Architecture", archName (packageIndexArch index)), - S.Field ("Origin", " Linspire"), - S.Field ("Label", " Freespire")] - let path = packageIndexDir index ++ "/Release" - EF.maybeWriteFile (root path) (show para) - return path - writeMasterRelease :: CIO m => FilePath -> Release -> m FilePath - writeMasterRelease root release = - do let paths = concat . map indexPaths $ (packageIndexList release) - (paths', sums,sizes) <- - liftIO (EG.cd root - (do paths' <- filterM doesFileExist paths - sums <- mapM md5sum paths' - sizes <- mapM (liftM F.fileSize . F.getFileStatus) paths' - return (paths', sums, sizes))) - let checksums = intercalate "\n" $ zipWith3 (formatFileInfo (fieldWidth sizes)) - sums sizes (map (drop (1 + length (releaseDir release))) paths') - timestamp <- liftIO (getCurrentTime >>= return . ET.formatDebianDate) - let para = S.Paragraph [S.Field ("Origin", " Linspire"), - S.Field ("Label", " Freespire"), - S.Field ("Suite", " " ++ (releaseName' . releaseInfoName . releaseInfo $ release)), - S.Field ("Codename", " " ++ (releaseName' . releaseInfoName . releaseInfo $ release)), - S.Field ("Date", " " ++ timestamp), - S.Field ("Architectures", " " ++ (intercalate " " . map archName . releaseInfoArchitectures . releaseInfo $ release)), - S.Field ("Components", " " ++ (intercalate " " . map sectionName' . releaseInfoComponents . releaseInfo $ release)), - S.Field ("Description", " Freespire 2.0 - Not Released"), - S.Field ("Md5Sum", "\n" ++ checksums)] - let path = "dists/" ++ (releaseName' . releaseInfoName . releaseInfo $ release) ++ "/Release" - liftIO $ EF.maybeWriteFile (root path) (show para) - return path - indexPaths index | packageIndexArch index == Source = - map ((packageIndexDir index) ) ["Sources", "Sources.gz", "Sources.bz2", "Sources.diff/Index", "Release"] - indexPaths index = - map ((packageIndexDir index) ) ["Packages", "Packages.gz", "Packages.bz2", "Packages.diff/Index", "Release"] - formatFileInfo fw sum size name = intercalate " " $ ["",sum, pad ' ' fw $ show size, name] - fieldWidth = ceiling . (logBase 10) . fromIntegral . maximum -writeRelease _release = error $ "Attempt to write release files to non-local repository" - -md5sum f = - do output <- System.Unix.Process.processOutput "/usr/bin/md5sum" [f] - return $ either (error $ "md5sum: missing file:" ++ f) - (takeWhile (/= ' ')) - output - -pad padchar padlen s = replicate p padchar ++ s - where p = padlen - length s - --- Merge a list of releases so each dist only appears once -mergeReleases :: [Release] -> [Release] -mergeReleases releases = - map (merge repos) . groupBy (==) . sortBy compare $ releases - where - repos = nub (map releaseRepo releases) - merge [repo] releases = - let aliases = map head . group . sort . concat . map (releaseInfoAliases . releaseInfo) $ releases - components = map head . group . sort . concat . map (releaseInfoComponents . releaseInfo) $ releases - architectures = map head . group . sort . concat . map (releaseInfoArchitectures . releaseInfo) $ releases in - Release { releaseRepo = repo - , releaseInfo = ReleaseInfo { releaseInfoName = (releaseInfoName . releaseInfo . head $ releases) - , releaseInfoAliases = aliases - , releaseInfoComponents = components - , releaseInfoArchitectures = architectures } } - merge _ _ = error "Cannot merge releases from different repositories" - --- | Find all the releases in a repository. -findReleases :: CIO m => LocalRepository -> AptIOT m [Release] -findReleases repo@(LocalRepository _ _ releases) = mapM (findLocalRelease repo) releases - -findLocalRelease :: CIO m => LocalRepository -> ReleaseInfo -> AptIOT m (Release) -findLocalRelease repo releaseInfo = - lookupRelease (LocalRepo repo) dist >>= maybe readRelease return - where - readRelease = - do let path = (outsidePath (repoRoot repo) ++ "/dists/" ++ releaseName' dist ++ "/Release") - info <- io $ S.parseControlFromFile path - case info of - Right (S.Control (paragraph : _)) -> - case (S.fieldValue "Components" paragraph, S.fieldValue "Architectures" paragraph) of - (Just components, Just architectures) -> - let release = Release (LocalRepo repo) - (ReleaseInfo - { releaseInfoName = dist - , releaseInfoAliases = releaseInfoAliases releaseInfo - , releaseInfoComponents = map parseSection' . words $ components - , releaseInfoArchitectures = map Binary . words $ architectures}) in - insertRelease release - _ -> - error $ "Invalid release file: " ++ path - _ -> error $ "Invalid release file: " ++ path - dist = releaseInfoName releaseInfo - -{- -CB: Here's my take on what needs to be done based on spelunking through the Debian repositories. - -Each component (main, contrib, non-free) has a Release file in the same directory as the Packages files. These are basically static, consisting of the following fields: - - $ cat /var/www/debian/dists/unstable/non-free/binary-i386/Release - Archive: unstable - Component: non-free - Origin: Debian - Label: Debian - Architecture: i386 - -Slightly different for Source: - - $ cat /var/www/debian/dists/unstable/non-free/source/Release - Archive: unstable - Component: non-free - Origin: Debian - Label: Debian - Architecture: source - -Also, if a dist has been released, then a version number is included: - - $ cat /var/www/debian/dists/sarge/non-free/source/Release - Archive: stable - Version: 3.1r4 - Component: non-free - Origin: Debian - Label: Debian - Architecture: source - -The top level release file is different. It has the md5sums of all the indices and release files in the distribution. We need to find out what we should put in for Origin and Label, but I think those are company and OS respectively, so Linspire and Freespire. It even has a codename... As before, the version in sarge has a Version number included. - -It is this top level Release file that is signed with gpg. - - $ head /var/www/debian/dists/unstable/Release - Origin: Debian - Label: Debian - Suite: unstable - Codename: sid - Date: Wed, 06 Dec 2006 20:13:03 UTC - Architectures: alpha amd64 arm hppa hurd-i386 i386 ia64 m68k mips mipsel powerpc s390 sparc - Components: main contrib non-free - Description: Debian Unstable - Not Released - MD5Sum: - 397f3216a3a881da263a2fb5e0f8f02e 19487683 main/binary-alpha/Packages - c3586c0dcdd6be9266a23537b386185d 5712614 main/binary-alpha/Packages.gz - 7acf2b8b938dde2c2e484425c806635a 4355026 main/binary-alpha/Packages.bz2 - dcf0d11800eb007c5435d83c853a241e 2038 main/binary-alpha/Packages.diff/Index - 3af8fbafe3e4538520989de964289712 83 main/binary-alpha/Release - 209177470d05f3a50b5217f64613ccca 19747688 main/binary-amd64/Packages - a73fd369c6baf422621bfa7170ff1594 5777320 main/binary-amd64/Packages.gz - 380e56b5acec9ac40f160ea97ea088ef 4403167 main/binary-amd64/Packages.bz2 - 43cbb8ba1631ab35ed94d43380299c38 2038 main/binary-amd64/Packages.diff/Index - ab89118658958350f14094b1bc666a62 83 main/binary-amd64/Release - d605623ac0d088a8bed287e0df128758 19323166 main/binary-arm/Packages - - --} diff --git a/Debian/Repo/Repository.hs b/Debian/Repo/Repository.hs deleted file mode 100644 --- a/Debian/Repo/Repository.hs +++ /dev/null @@ -1,321 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Debian.Repo.Repository - ( UploadFile(..) - , prepareRepository - , repoArchList - , readPkgVersion - , showPkgVersion - , invalidRevision - , verifyUploadURI - , uploadRemote - ) where - -import Control.Exception (Exception(..)) -import Control.Monad.Trans -import Control.Monad.State (get, put) -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as L -import Data.List -import Data.Maybe -import qualified Data.Set as Set -import qualified Debian.Control.ByteString as B -- required despite warning -import qualified Debian.Control.String as S -import Debian.Extra.CIO (tMessage, printOutput) -import Debian.Repo.Changes -import Debian.Repo.IO -import Debian.Repo.LocalRepository -import Debian.Repo.Types -import Debian.Shell -import Debian.URI -import Debian.Version -import Extra.Bool -import Extra.Either -import Extra.Files -import Extra.List ---import Extra.Net -import Extra.SSH -import Extra.CIO -import System.FilePath -import System.Unix.Process -import System.Cmd -import System.Directory -import qualified System.IO as IO -import System.IO.Unsafe -import System.Time -import Text.Regex - --- |The file produced by dupload when a package upload attempt is made. -data UploadFile = Upload FilePath String DebianVersion Arch - --- |This is a remote repository which we have queried to find out the --- names, sections, and supported architectures of its releases. ---data VerifiedRepo = VerifiedRepo URI [ReleaseInfo] - -{- instance Show VerifiedRepo where - show (VerifiedRepo uri _) = "Verified Repository " ++ show uri -- ++ " " ++ show dists -instance Ord VerifiedRepo where - compare a b = compare (repoURI a) (repoURI b) -instance Eq VerifiedRepo where - a == b = compare a b == EQ -} - --- |This is a repository whose structure we haven't examined --- to determine what release it contains. ---data UnverifiedRepo = UnverifiedRepo URI - -{- instance Show UnverifiedRepo where - show (UnverifiedRepo uri) = "Unverified Repository " ++ show uri -- ++ " (unverified)" -instance Ord UnverifiedRepo where - compare a b = compare (repoURI a) (repoURI b) -instance Eq UnverifiedRepo where - a == b = compare a b == EQ -} - --- | Prepare a repository, which may be remote or local depending on --- the URI. -prepareRepository :: CIO m => URI -> AptIOT m Repository -prepareRepository uri = - do state <- get - repo <- maybe newRepo return (lookupRepository uri state) - put (insertRepository uri repo state) - return repo - where - newRepo = - case uriScheme uri of - "file:" -> prepareLocalRepository (EnvPath (EnvRoot "") (uriPath uri)) Nothing >>= return . LocalRepo - -- FIXME: We only want to verifyRepository on demand. - -- Perhaps we want to use System.IO.Unsafe.unsafeInterleaveIO? - _ -> verifyRepository (UnverifiedRepo (show uri)) - -- _ -> return . Repository . UnverifiedRepo $ uri - -{-# NOINLINE verifyRepository #-} -verifyRepository :: CIO m => Repository -> AptIOT m Repository -verifyRepository (UnverifiedRepo uri) = - do --tio (vHPutStrBl IO.stderr 0 $ "Verifying repository " ++ show uri ++ "...") - -- Use unsafeInterleaveIO to avoid querying the repository - -- until the value is actually needed. - lift (vPutStrBl 2 ("verifyRepository " ++ uri)) - releaseInfo <- do lift (vPutChar 2 '*') - liftIO . unsafeInterleaveIO . getReleaseInfoRemote . fromJust . parseURI $ uri - {- tio (vHPutStrLn IO.stderr 0 $ "\n" {- -> VerifiedRepo " ++ show uri ++ " " ++ show releaseInfo -} ) -} - return $ VerifiedRepo uri releaseInfo -verifyRepository x = return x - --- |Get the list of releases of a remote repository. -getReleaseInfoRemote :: URI -> IO [ReleaseInfo] -getReleaseInfoRemote uri = - IO.hPutStr IO.stderr ("(verifying " ++ uriToString' uri ++ ".") >> - dirFromURI distsURI >>= - either (error . show) verify >>= return . catMaybes >>= - (\ result -> IO.hPutStr IO.stderr ")" >> return result) - where - distsURI = uri {uriPath = uriPath uri "dists/"} - verify names = - do let dists = map parseReleaseName names - releaseFiles <- mapM getReleaseFile dists - let releasePairs = zip3 (map getSuite releaseFiles) releaseFiles dists - return $ map (uncurry3 getReleaseInfo) releasePairs - releaseNameField releaseFile = case fmap B.unpack (B.fieldValue "Origin" releaseFile) of Just "Debian" -> "Codename"; _ -> "Suite" - getReleaseInfo :: Maybe B.ByteString -> B.Paragraph -> ReleaseName -> Maybe ReleaseInfo - getReleaseInfo Nothing _ _ = Nothing - getReleaseInfo (Just dist) _ relname | (parseReleaseName (B.unpack dist)) /= relname = Nothing - getReleaseInfo (Just dist) info _ = Just $ makeReleaseInfo "" info (parseReleaseName (B.unpack dist)) [] - getSuite releaseFile = B.fieldValue (releaseNameField releaseFile) releaseFile - getReleaseFile :: ReleaseName -> IO (S.Paragraph' B.ByteString) - getReleaseFile distName = - do IO.hPutChar IO.stderr '.' - release <- fileFromURI releaseURI >>= return . either Left (Right . B.concat . L.toChunks) - let control = either Left (either (Left . ErrorCall . show) Right . B.parseControl (show uri)) release - case control of - Right (B.Control [info]) -> return info - _ -> error ("Failed to get release info from dist " ++ show (relName distName) ++ ", uri " ++ show releaseURI) - where - releaseURI = distURI {uriPath = uriPath distURI "Release"} - distURI = distsURI {uriPath = uriPath distsURI releaseName' distName} - uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d - uncurry3 f (a, b, c) = f a b c - --- |Make sure we can access the upload uri without typing a password. -verifyUploadURI :: CIO m => Bool -> URI -> AptIOT m () -verifyUploadURI doExport uri = - case doExport of - True -> export - False -> verify - where - export = - do liftIO $ uncurry sshExport (uriDest uri) - verify - mkdir - verify = - do result <- liftIO $ uncurry sshVerify (uriDest uri) - case result of - False -> error $ "Unable to reach " ++ uriToString' uri ++ ", consider using --ssh-export" - True -> return () - mkdir - uriDest uri = - let auth = maybe (error "Internal error 8") id (uriAuthority uri) in - let port = - case uriPort auth of - (':' : number) -> Just (read number) - "" -> Nothing - x -> error $ "Internal error 9: invalid port " ++ x in - (uriUserInfo auth ++ uriRegName auth, port) - mkdir :: CIO m => AptIOT m () - mkdir = - case uriAuthority uri of - Nothing -> error $ "Internal error 7" - Just auth -> - do let cmd = "ssh " ++ uriUserInfo auth ++ uriRegName auth ++ uriPort auth ++ " mkdir -p " ++ uriPath uri ++ "/incoming" - result <- liftIO $ system cmd - case result of - ExitSuccess -> return () - _ -> error $ "Failure: " ++ cmd - --- | Upload all the packages in a local repository to a the incoming --- directory of a remote repository (using dupload.) -uploadRemote :: CIO m - => LocalRepository -- ^ Local repository holding the packages. - -> URI -- ^ URI of upload repository - -> AptIOT m [Either String ([Output], TimeDiff)] -uploadRemote repo uri = - do uploaded <- liftIO (uploadFind (outsidePath root)) >>= - return . Set.fromList . map uploadKey . rightOnly - (accepted, rejected) <- liftIO (findChangesFiles (outsidePath root)) >>= return . (\x -> (x, [])) >>= - return . accept (notUploaded uploaded) (\ x -> (x, "Already uploaded")) >>= - return . rejectOlder >>= - acceptM (liftIO . validRevision) (\ x -> (x, "Invalid revision")) - case rejected of - [] -> return () - _ -> lift (vPutStr 0 ("Rejected:\n " ++ consperse "\n " (map showReject rejected) ++ "\n")) - case accepted of - [] -> do lift (vPutStr 0 "Nothing to upload."); return [] - _ -> do mapM (lift . dupload uri (outsidePath root)) (map Debian.Repo.Changes.path accepted) - where - root = repoRoot repo - rejectOlder :: ([ChangesFile], [(ChangesFile, String)]) -> ([ChangesFile], [(ChangesFile, String)]) - rejectOlder (accept, reject) = - (accept', (map tag reject' ++ reject)) - where accept' = map head sortedGroups - reject' = concat . map tail $ sortedGroups - sortedGroups = map (sortBy compareVersions) (groupByNameAndDist accept) - tag x = (x, "Not the newest version in incoming") - compareVersions a b = compare (changeVersion b) (changeVersion a) - groupByNameAndDist = groupBy equalNameAndDist . sortBy compareNameAndDist - equalNameAndDist a b = compareNameAndDist a b == EQ - compareNameAndDist a b = - case compare (changePackage a) (changePackage b) of - EQ -> compare (changeRelease a) (changeRelease b) - x -> x - notUploaded uploaded changes = not . Set.member (Debian.Repo.Changes.key changes) $ uploaded - validRevision c = - do - let dscPath = changeDir c changePackage c ++ "_" ++ show (changeVersion c) ++ ".dsc" - doesFileExist dscPath >>= cond (S.parseControlFromFile dscPath >>= either (error . show) (checkRevision dscPath)) (return True) - where - checkRevision _dscPath (S.Control [p]) = - case maybe Nothing parseRevision (S.fieldValue "Revision" p) of - Nothing -> return False - Just (x, _) | x == invalidRevision -> return False - Just _ -> return True - checkRevision dscPath _ = error ("Invalid .dsc file: " ++ show dscPath) - showReject (changes, tag) = Debian.Repo.Changes.name changes ++ ": " ++ tag - -uploadKey :: UploadFile -> (String, DebianVersion, Arch) -uploadKey (Upload _ name ver arch) = (name, ver, arch) - -uploadLoad :: FilePath -> String -> (Either [String] UploadFile) -uploadLoad dir file = - case parseUploadFilename file of - Just (name, ver, arch) -> Right $ Upload dir name ver arch - Nothing -> Left ["Couldn't parse upload filename: " ++ file] - -uploadFind :: FilePath -> IO [Either [String] UploadFile] -uploadFind dir = - getDirectoryContents dir >>= - return . filter (isSuffixOf ".upload") >>= - return . map (uploadLoad dir) - -{- -base :: UploadFile -> String -base (Upload _ name ver arch) = name ++ "_" ++ show ver ++ "_" ++ show arch --} - --- filename name version arch ext -parseUploadFilename :: String -> Maybe (String, DebianVersion, Arch) -parseUploadFilename name = - case matchRegex (mkRegex "^(.*/)?([^_]*)_(.*)_([^.]*)\\.upload$") name of - Just [_, name, version, arch] -> Just (name, parseDebianVersion version, Binary arch) - _ -> error ("Invalid .upload file name: " ++ name) - -invalidRevision = "none" - --- | Parse the "Revision:" value describing the origin of the --- package's source and the dependency versions used to build it: --- Revision: dep1=ver1 dep2=ver2 ... -parseRevision :: String -> Maybe (String, [PkgVersion]) -parseRevision s = - case words s of - [] -> Nothing - (revision : buildDeps) -> Just (revision, map readPkgVersion buildDeps) - -showPkgVersion :: PkgVersion -> String -showPkgVersion v = show v - -readPkgVersion :: String -> PkgVersion -readPkgVersion s = case mapSnd (parseDebianVersion . (drop 1)) (span (/= '=') s) of - (n, v) -> PkgVersion { getName = n, getVersion = v } - -mapSnd f (a, b) = (a, f b) - -accept :: (a -> Bool) -> (a -> (a, String)) -> ([a], [(a, String)]) -> ([a], [(a, String)]) -accept p tag (accepted, rejected) = - (accepted', map tag rejected' ++ rejected) - where (accepted', rejected') = partition p accepted - -acceptM :: (Monad m) => (a -> m Bool) -> (a -> (a, String)) -> ([a], [(a, String)]) -> m ([a], [(a, String)]) -acceptM p tag (accept, reject) = - do (accept', reject') <- partitionM p accept - return (accept', (map tag reject' ++ reject)) - --- |Run dupload on a changes file with an optional host (--to) --- argument. -dupload :: CIO m - => URI -- user - -> FilePath -- The directory containing the .changes file - -> String -- The name of the .changes file to upload - -> m (Either String ([Output], TimeDiff)) -dupload uri dir changesFile = - case uriAuthority uri of - Nothing -> error ("Invalid Upload-URI: " ++ uriToString' uri) - Just auth -> - do - let config = ("package config;\n" ++ - "$cfg{'default'} = {\n" ++ - " fqdn => \"" ++ uriRegName auth ++ uriPort auth ++ "\",\n" ++ - " method => \"scpb\",\n" ++ - " login => \"" ++ init (uriUserInfo auth) ++ "\",\n" ++ - " incoming => \"" ++ uriPath uri ++ "/incoming\",\n" ++ - " dinstall_runs => 1,\n" ++ - "};\n\n" ++ - "$preupload{'changes'} = '';\n\n" ++ - "1;\n") - liftIO $ replaceFile (dir ++ "/dupload.conf") config - liftIO (lazyCommand (cmd changesFile) L.empty) >>= - tMessage ("Uploading " ++ show changesFile) >>= - printOutput >>= - dotOutput 128 >>= - (\ output -> timeTask (checkResult fail (return (Right output)) output)) >>= - (\ (result, elapsed) -> return (either Left (\ output -> Right (output, elapsed)) result)) - --style' $ runCommandQuietlyTimed (cmd changesFile) - where -{- - style' = setStyle (setStart (Just ("Uploading " ++ show changesFile)) . - setError (Just "dupload failed") . - setEcho True) --} - fail n = - ePutStrBl message >> return (Left message) - where message = "dupload failed: " ++ cmd changesFile ++ " -> " ++ show n - cmd file = "cd " ++ dir ++ " && dupload --to default -c " ++ file - -repoArchList :: Repo r => r -> [Arch] -repoArchList repo = - listIntersection (map releaseInfoArchitectures (repoReleaseInfo repo)) diff --git a/Debian/Repo/Slice.hs b/Debian/Repo/Slice.hs deleted file mode 100644 --- a/Debian/Repo/Slice.hs +++ /dev/null @@ -1,147 +0,0 @@ --- |Types that represent a "slice" of a repository, as defined by a --- list of DebSource. This is called a slice because some sections --- may be omitted, and because different repositories may be combined --- in the list. -module Debian.Repo.Slice - ( sourceSlices - , binarySlices - , inexactPathSlices - , releaseSlices - , appendSliceLists - , verifySourceLine - , verifySourcesList - , repoSources - , parseNamedSliceList - , parseNamedSliceList' - ) where - -import Control.Exception (throw) -import Control.Monad.Trans -import qualified Data.ByteString.Lazy.Char8 as L -import Data.List -import Data.Maybe -import Debian.Control ---import Debian.Extra.CIO (vMessage) -import Debian.Repo.IO -import Debian.Repo.LocalRepository -import Debian.Repo.Repository ---import Debian.Shell -import Debian.Repo.SourcesList -import Debian.Repo.Types -import Debian.URI ---import Extra.Net (webServerDirectoryContents) -import Extra.CIO (CIO, vPutStrBl) ---import System.Unix.Process ---import System.Directory -import Text.Regex - -sourceSlices :: SliceList -> SliceList -sourceSlices = SliceList . filter ((== DebSrc) . sourceType . sliceSource) . slices - -binarySlices :: SliceList -> SliceList -binarySlices = SliceList . filter ((== Deb) . sourceType . sliceSource) . slices - -inexactPathSlices :: SliceList -> SliceList -inexactPathSlices = SliceList . filter (either (const False) (const True) . sourceDist . sliceSource) . slices - -releaseSlices :: ReleaseName -> SliceList -> SliceList -releaseSlices release list = - SliceList . filter (isRelease . sourceDist . sliceSource) $ (slices list) - where isRelease = either (const False) (\ (x, _) -> x == release) - -appendSliceLists :: [SliceList] -> SliceList -appendSliceLists lists = - SliceList { slices = concat (map slices lists) } - --- |Examine the repository whose root is at the given URI and return a --- set of sources that includes all of its releases. This is used to --- ensure that a package we want to upload doesn't already exist in --- the repository. -repoSources :: CIO m => Maybe EnvRoot -> URI -> AptIOT m SliceList -repoSources chroot uri = - do lift (vPutStrBl 3 $ "repoSources " ++ uriToString' uri) - dirs <- lift (uriSubdirs chroot (uri {uriPath = uriPath uri ++ "/dists/"})) - lift (vPutStrBl 3 $ " dirs: " ++ show dirs) - releaseFiles <- mapM (lift . readRelease uri) dirs >>= return . catMaybes - let codenames = map (maybe Nothing (zap (flip elem dirs))) . map (fieldValue "Codename") $ releaseFiles - lift (vPutStrBl 3 $ " codenames: " ++ show (catMaybes codenames)) - let sections = map (maybe Nothing (Just . map parseSection' . splitRegex (mkRegex "[ \t,]+")) . fieldValue "Components") $ releaseFiles - lift (vPutStrBl 3 $ " sections: " ++ show (catMaybes codenames)) - let result = concat $ map sources . nubBy (\ (a, _) (b, _) -> a == b) . zip codenames $ sections - lift (vPutStrBl 2 $ "repoSources " ++ uriToString' uri ++ " ->\n [" ++ unwords (map show result) ++ "]") - mapM (verifyDebSource Nothing) result >>= (\ list -> return $ SliceList { slices = list }) - where - sources (Just codename, Just components@(_ : _)) = - [DebSource {sourceType = Deb, sourceUri = uri, sourceDist = Right (parseReleaseName codename, components)}, - DebSource {sourceType = DebSrc, sourceUri = uri, sourceDist = Right (parseReleaseName codename, components)}] - sources _ = [] - -- Compute the list of sections for each dist on a remote server. - zap p x = if p x then Just x else Nothing - --- |Return the list of releases in a repository, which is the --- list of directories in the dists subdirectory. Currently --- this is only known to work with Apache. Note that some of --- the returned directories may be symlinks. -uriSubdirs :: CIO m => (Maybe EnvRoot) -> URI -> m [String] -uriSubdirs root uri = - liftIO (dirFromURI uri') >>= either throw return - where - uri' = case uriScheme uri of - "file:" -> uri {uriPath = maybe "" rootPath root ++ (uriPath uri)} - _ -> uri - -readRelease :: CIO m => URI -> String -> m (Maybe Paragraph) -readRelease uri name = - do output <- liftIO (fileFromURI uri') - case output of - Left e -> throw e - Right s -> case parseControl (show uri') (L.unpack s) of - Right (Control [paragraph]) -> return (Just paragraph) - _ -> return Nothing - where - uri' = uri {uriPath = uriPath uri ++ "/dists/" ++ name ++ "/Release"} - -parseNamedSliceList :: CIO m => String -> AptIOT m (Maybe NamedSliceList) -parseNamedSliceList text = - case matchRegex re text of - Just [name, sources] -> - (verifySourcesList Nothing . parseSourcesList) sources >>= - \ sources -> return . Just $ NamedSliceList { sliceListName = SliceName name - , sliceList = sources } - _ -> return Nothing - where - re = mkRegexWithOpts "^[ \t\n]*([^ \t\n]+)[ \t\n]+(.*)$" False True - --- |Create ReleaseCache 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 -parseNamedSliceList' :: CIO m => String -> AptIOT m NamedSliceList -parseNamedSliceList' text = - -- FIXME: This regexp is too permissive - it will match almost anything - case matchRegex re text of - Just [name, sources] -> - do sources <- (verifySourcesList Nothing . parseSourcesList) sources - return $ NamedSliceList { sliceListName = SliceName name, sliceList = sources } - _ -> error "Syntax error in sources text" - where - re = mkRegexWithOpts "^[ \t\n]*([^ \t\n]+)[ \t\n]+(.*)$" False True - -verifySourcesList :: CIO m => Maybe EnvRoot -> [DebSource] -> AptIOT m SliceList -verifySourcesList chroot list = - mapM (verifyDebSource chroot) list >>= - (\ list -> return $ SliceList { slices = list }) - -verifySourceLine :: CIO m => Maybe EnvRoot -> String -> AptIOT m Slice -verifySourceLine chroot str = verifyDebSource chroot (parseSourceLine str) - -verifyDebSource :: CIO m => Maybe EnvRoot -> DebSource -> AptIOT m Slice -verifyDebSource chroot line = - do repo <- case uriScheme uri of - "file:" -> - let path = EnvPath (maybe (EnvRoot "") id chroot) (uriPath uri) in - prepareLocalRepository path Nothing >>= return . LocalRepo - _ -> - prepareRepository uri - return $ Slice { sliceRepo = repo, sliceSource = line } - where - uri = sourceUri line diff --git a/Debian/Repo/SourceTree.hs b/Debian/Repo/SourceTree.hs deleted file mode 100644 --- a/Debian/Repo/SourceTree.hs +++ /dev/null @@ -1,308 +0,0 @@ -module Debian.Repo.SourceTree - ( -- * Source Tree - SourceTreeC(..) - , DebianSourceTreeC(..) - , DebianBuildTreeC(..) - , SourceTree(..) - , DebianSourceTree(..) - , DebianBuildTree(..) - , findChanges - , SourcePackageStatus(..) - , buildDebs - , findSourceTree - , copySourceTree - , findDebianSourceTree - , copyDebianSourceTree - , findDebianSourceTrees - , findDebianBuildTree - , findDebianBuildTrees - , copyDebianBuildTree - , findOneDebianBuildTree - , explainSourcePackageStatus - , addLogEntry - --, findBuildChanges - ) where - -import Control.Exception -import Control.Monad.Trans -import qualified Data.ByteString.Lazy.Char8 as L -import Data.List -import Data.Maybe -import Debian.Control.String -import Debian.Extra.CIO (printOutput) -import Debian.Shell -import Debian.Repo.Changes -import Debian.Repo.OSImage -import Debian.Repo.Types -import Debian.Shell -import qualified Debian.Version as V -import Extra.Files (replaceFile, getSubDirectories) -import Extra.List (dropPrefix) -import Extra.CIO (CIO, setStyle, addPrefixes) -import System.Directory -import System.Environment -import System.IO -import System.Time -import System.Unix.Process - --- |Any directory containing source code. -class Show t => SourceTreeC t where - topdir :: t -> FilePath -- ^The top directory of the source tree - --- |A Debian source tree, which has a debian subdirectory containing --- at least a control file and a changelog. -class (Show t, SourceTreeC t) => DebianSourceTreeC t where - debdir :: t -> FilePath -- ^The directory containing the debian subdirectory - control :: t -> Control -- ^The contents of debian\/control - entry :: t -> ChangeLogEntry -- ^The latest entry from debian\/changelog - --- |A debian source tree plus a parent directory, which is where the --- binary and source deb packages appear after a build. -class (Show t, DebianSourceTreeC t) => DebianBuildTreeC t where - subdir :: t -> String -- ^The basename of debdir - --- |Any directory containing source code. -data SourceTree = - SourceTree {dir' :: FilePath} deriving Show - --- |A Debian source tree, which has a debian subdirectory containing --- at least a control file and a changelog. -data DebianSourceTree = - DebianSourceTree {tree' :: SourceTree, - control' :: Control, - entry' :: ChangeLogEntry} deriving Show - --- |A Debian source tree plus a parent directory, which is where the --- binary and source deb packages appear after a build. -data DebianBuildTree = - DebianBuildTree {topdir' :: FilePath, - subdir' :: String, - debTree' :: DebianSourceTree} deriving Show - -instance SourceTreeC SourceTree where - topdir = dir' - -instance SourceTreeC DebianSourceTree where - topdir = dir' . tree' - -instance DebianSourceTreeC DebianSourceTree where - debdir = dir' . tree' - control = control' - entry = entry' - -instance SourceTreeC DebianBuildTree where - topdir = topdir' - -instance DebianSourceTreeC DebianBuildTree where - debdir t = topdir' t ++ "/" ++ subdir' t - control = control' . debTree' - entry = entry' . debTree' - -instance DebianBuildTreeC DebianBuildTree where - subdir = subdir' - --- |Find the .changes file which is generated by a successful run of --- dpkg-buildpackage. -findChanges :: DebianBuildTree -> IO (Either String ChangesFile) -findChanges tree = - do let dir = topdir tree - result <- findChangesFiles dir - case result of - [cf] -> return (Right cf) - [] -> return (Left ("Couldn't find .changes file in " ++ dir)) - lst -> return (Left ("Multiple .changes files in " ++ dir ++ ": " ++ show lst)) - --- |Rewrite the changelog with an added entry. -addLogEntry :: DebianSourceTreeC t => ChangeLogEntry -> t -> IO () -addLogEntry entry debtree = - readFile changelogPath >>= replaceFile changelogPath . ((show entry) ++) - where - changelogPath = (debdir debtree) ++ "/debian/changelog" - --- |There are three possible results of a build: an upload consisting --- of only the architecture independent debs (Indep), one including --- both indep and binary debs (All), or with a failed build (None). -data SourcePackageStatus = All | Indep | None deriving (Show, Eq) - -explainSourcePackageStatus :: SourcePackageStatus -> String -explainSourcePackageStatus All = "All architecture dependent files for the current build architecture are present." -explainSourcePackageStatus Indep = "Some or all architecture-dependent files for the current build architecture are missing" -explainSourcePackageStatus None = "This version of the package is not present." - --- | Run dpkg-buildpackage in a source tree. -buildDebs :: (DebianBuildTreeC t, CIO m) => Bool -> [String] -> OSImage -> t -> SourcePackageStatus -> m (Either String TimeDiff) -buildDebs noClean setEnv buildOS buildTree status = - do - noSecretKey <- liftIO (getEnv "HOME" >>= return . (++ "/.gnupg") >>= doesDirectoryExist >>= return . not) - -- Unset LANG so perl doesn't complain about locales. - -- Set LOGNAME so dpkg-buildpackage doesn't die when it fails to - -- get the original user's login information - let buildcmd = - "dpkg-buildpackage -sa " - ++ (case status of Indep -> " -B "; _ -> "") - ++ (if noSecretKey then " -us -uc" else "") - ++ (if noClean then " -nc" else "") - let fullcmd = ("chroot " ++ root ++ - " bash -c \"unset LANG; export LOGNAME=root; " ++ - concat (map (\ x -> "export " ++ x ++ "; ") setEnv) ++ - "cd '" ++ fromJust (dropPrefix root path) ++ "' && " ++ - "chmod ugo+x debian/rules && " ++ - -- Try to build twice, some packages do configuration the first - -- time 'so that it is NEVER run during an automated build.' :-/ - "{ " ++ buildcmd ++ " || " ++ buildcmd ++ " ; } " - ++ "\"") - liftIO (lazyCommand fullcmd L.empty) >>= - setStyle (addPrefixes "[1] " "[2] ") . printOutput >>= - return . discardOutput >>= - timeTask . checkResult (\ n -> return (Left ("*** FAILURE: " ++ fullcmd ++ " -> " ++ show n))) (return (Right ())) >>= - \ (result, elapsed) -> return (either Left (const (Right elapsed)) result) - where - path = debdir buildTree - root = rootPath (rootDir buildOS) - --- |Make a copy of a source tree in a directory. -copySourceTree :: (SourceTreeC t, CIO m) => t -> FilePath -> m (Either String SourceTree) -copySourceTree tree dest = - liftIO (try (createDirectoryIfMissing True dest)) >>= - either (return . Left . show) (const (runTaskAndTest (SimpleTask 0 command))) >>= - return . either Left (const . Right . SourceTree $ dest) - --copyStyle $ systemTaskDR ("rsync -aHxSpDt --delete '" ++ outsidePath (topdir tree) ++ "/' '" ++ outsidePath dest ++ "'") - --return $ SourceTree dest - where - command = "rsync -aHxSpDt --delete '" ++ topdir tree ++ "/' '" ++ dest ++ "'" -{- - copyStyle = setStyle (setStart (Just ("Copying source tree (" ++ outsidePath dest ++ ")")) . - setError (Just ("Could not copy source tree from " ++ - outsidePath (topdir tree) ++ " to " ++ outsidePath dest))) --} - -copyDebianSourceTree :: (DebianSourceTreeC t, CIO m) => t -> FilePath -> m (Either String DebianSourceTree) -copyDebianSourceTree src dest = - copySourceTree src dest >>= - return . either Left (\ copy -> Right (DebianSourceTree copy (control src) (entry src))) - -copyDebianBuildTree :: (DebianBuildTreeC t, CIO m) => t -> FilePath -> m (Either String DebianBuildTree) -copyDebianBuildTree src dest = - copySource >>= copyTarball >>= makeTree - where - copySource = copySourceTree (SourceTree . topdir $ src) dest - copyTarball (Left message) = return (Left message) - copyTarball (Right copy) = - do exists <- liftIO $ doesFileExist origPath - case exists of - False -> return (Right copy) - True -> runCommand 0 cmd >>= return . either Left (const (Right copy)) - makeTree (Left message) = return (Left message) - makeTree (Right copy) = - return $ Right (DebianBuildTree (dir' copy) (subdir src) - (DebianSourceTree { tree' = SourceTree { dir' = dest ++ "/" ++ subdir src } - , control' = (control src) - , entry' = (entry src) })) -{- - do copy <- copySourceTree (SourceTree . topdir $ src) dest - exists <- io $ doesFileExist origPath - --io $ System.IO.hPutStrLn stderr ("doesFileExist " ++ show origPath ++ " -> " ++ show exists) - case exists of - True -> quietRunOutputOnError cmd - False -> return ([], noTimeDiff) - return $ DebianBuildTree (dir' copy) (subdir src) - (DebianSourceTree { tree' = SourceTree { dir' = dest { envPath = envPath dest ++ "/" ++ subdir src } } - , control' = (control src) - , entry' = (entry src) }) - where --} - cmd = ("cp -p " ++ origPath ++ " " ++ dest ++ "/") - origPath = topdir src ++ "/" ++ orig - orig = name ++ "_" ++ version ++ ".orig.tar.gz" - name = logPackage . entry $ src - version = V.version . logVersion . entry $ src - -findSourceTree :: CIO m => FilePath -> m (Either String SourceTree) -findSourceTree path = - do exists <- liftIO $ doesDirectoryExist path - case exists of - False -> return . Left $ "No such directory: " ++ path - True -> return . Right . SourceTree $ path - -findDebianSourceTree :: CIO m => FilePath -> m (Either String DebianSourceTree) -findDebianSourceTree path = - do --vPutStrLn 2 stderr $ "findDebianSourceTree " ++ show path - findSourceTree path >>= either (return . Left) findDebianSource - where - findDebianSource :: CIO m => SourceTree -> m (Either String DebianSourceTree) - findDebianSource tree@(SourceTree path) = - do let controlPath = path ++ "/debian/control" - changelogPath = path ++ "/debian/changelog" - control <- - liftIO (try . readFile $ controlPath) >>= - return . either (Left . (("Could not read control file: " ++ controlPath ++ ": ") ++) . show) - (either (const (Left $ "Parse error in control file: " ++ controlPath)) Right . - (parseControl controlPath)) - log <- liftIO (try . readFile $ changelogPath) >>= return . either (Left . ("Failure reading changelog: " ++) . show) (Right . parseLog) - case (control, log) of - (Right control, (Right (Right entry : _))) -> return . Right $ DebianSourceTree tree control entry - (Right _control, (Right (Left x : _))) -> return . Left $ "Bad changelog entry: " ++ changelogPath ++ " -> " ++ show x - (Right _control, (Right [])) -> return . Left $ "Empty changelog file: " ++ changelogPath - (Left control, _) -> return . Left $ "Bad control file: " ++ controlPath ++ " -> " ++ show control - (_, Left log) -> return . Left $ "Bad changelog: " ++ changelogPath ++ " -> " ++ show log - --- |Find a DebianBuildTree inside a directory. It finds all the --- DebianSourceTrees, and if they all have the same package name it --- returns the newest one according to the version numbers. If there --- are none, or there are trees with different package names, Nothing --- is returned. -findOneDebianBuildTree :: CIO m => FilePath -> m (Maybe DebianBuildTree) -findOneDebianBuildTree path = - do trees <- findDebianBuildTrees path - case nubBy eqNames trees of - [_] -> return $ listToMaybe (sortBy cmpVers trees) - _ -> return Nothing - where - eqNames tree1 tree2 = (logPackage . entry $ tree1) == (logPackage . entry $ tree2) - cmpVers tree1 tree2 = compare (logVersion . entry $ tree1) (logVersion . entry $ tree2) - --- |Find the DebianBuildTree in a particular subdirectory. -findDebianBuildTree :: CIO m => FilePath -> String -> m (Either String DebianBuildTree) -findDebianBuildTree path name = - findDebianSourceTree (path ++ "/" ++ name) >>= return . either Left (Right . DebianBuildTree path name) - - --- |Find all the debian source trees in a directory. -findDebianSourceTrees :: CIO m => FilePath -> m [(String, DebianSourceTree)] -findDebianSourceTrees path = - do dirs <- liftIO (try (getSubDirectories path)) >>= return . either (const []) id - trees <- mapM (\ dir -> findDebianSourceTree (path ++ "/" ++ dir)) dirs - return $ catRightSeconds $ zip dirs trees - --- |Find all the debian source trees in a directory. -findDebianBuildTrees :: CIO m => FilePath -> m [DebianBuildTree] -findDebianBuildTrees path = - do dirs <- (liftIO $ try (getSubDirectories path)) >>= return . either (const []) id - trees <- mapM (\ dir -> findDebianSourceTree (path ++ "/" ++ dir)) dirs - let trees' = catRightSeconds $ zip dirs trees - return $ map (\ (subdir, tree) -> DebianBuildTree path subdir tree) trees' - -catRightSeconds :: [(a, Either b c)] -> [(a, c)] -catRightSeconds [] = [] -catRightSeconds ((y, Right x) : more) = (y, x) : catRightSeconds more -catRightSeconds ((_, _) : more) = catRightSeconds more - --- |Construct the directory name that dpkg-buildpackage expects to find the --- source code in for this package: -. -{- -debDir :: DebianSourceTree -> String -debDir (DebianSourceTree _ _ entry) = logPackage entry ++ "-" ++ show (logVersion entry) --} - --- |Find the .changes file which is generated by a successful run of --- dpkg-buildpackage. -{- -findBuildChanges :: DebianBuildTree -> IO (Either String ChangesFile) -findBuildChanges tree = - do let dir = topdir tree - result <- findChangesFiles dir - case result of - [cf] -> return (Right cf) - [] -> return (Left ("Couldn't find .changes file in " ++ dir)) - lst -> return (Left ("Multiple .changes files in " ++ dir ++ ": " ++ show lst)) --} diff --git a/Debian/Repo/SourcesList.hs b/Debian/Repo/SourcesList.hs deleted file mode 100644 --- a/Debian/Repo/SourcesList.hs +++ /dev/null @@ -1,143 +0,0 @@ ---- | A DebSource represents a release of a remote repository and a ---- method for accessing that repository. -module Debian.Repo.SourcesList - (parseSourceLine, -- String -> DebSource - parseSourceLine', -- String -> Maybe DebSource - parseSourcesList, -- String -> [DebSource] - quoteWords -- String -> [String] - ) - where - -import Debian.URI -import Debian.Repo.Types - -import Data.List -import Data.Maybe - -{- - -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. - --} - --- |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' (dropWhile (==' ') s) - where - quoteWords' :: String -> [String] - quoteWords' [] = [] - quoteWords' str = - case break (flip elem " [\"") str of - ([],[]) -> [] - (w, []) -> [w] - (w, (' ':rest)) -> w : (quoteWords' (dropWhile (==' ') rest)) - (w, ('"':rest)) -> - case break (== '"') rest of - (w',('"':rest)) -> - case quoteWords' rest of - [] -> [w ++ w'] - (w'':ws) -> ((w ++ w' ++ w''): ws) - (_w',[]) -> error ("quoteWords: missing \" in the string: " ++ s) - _ -> error ("the impossible happened in SourcesList.quoteWords") - (w, ('[':rest)) -> - case break (== ']') rest of - (w',(']':rest)) -> - case quoteWords' rest of - [] -> [w ++ "[" ++ w' ++ "]"] - (w'':ws) -> ((w ++ "[" ++ w' ++ "]" ++ w''): ws) - (_w',[]) -> error ("quoteWords: missing ] in the string: " ++ s) - _ -> error ("the impossible happened in SourcesList.quoteWords") - _ -> error ("the impossible happened in SourcesList.quoteWords") - -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 sections = map parseSection' sectionStrs - 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 sections - 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 sections - 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 (parseReleaseName theDist, sections) } - _ -> error ("parseSourceLine: invalid line in sources.list:\n" ++ str) - -parseSourceLine' :: String -> Maybe DebSource -parseSourceLine' str = - case quoteWords str of - (theTypeStr : theUriStr : theDistStr : sectionStrs) -> - let sections = map parseSection' sectionStrs - theType = case unEscapeString theTypeStr of - "deb" -> Just Deb - "deb-src" -> Just DebSrc - _ -> Nothing - theUri = case parseURI theUriStr of - Nothing -> Nothing - Just u -> Just u - theDist = unEscapeString theDistStr - in - case (last theDist, theType, theUri) of - ('/', Just typ, Just uri) -> if null sections - then Just $ DebSource { sourceType = typ, sourceUri = uri, sourceDist = Left theDist } - else error ("parseSourceLine: Dist is an exact path, so sections are not allowed on the line:\n" ++ str) - (_, Just typ, Just uri) -> if null sections - then Nothing - else Just $ DebSource { sourceType = typ, sourceUri = uri, sourceDist = Right ((parseReleaseName theDist), sections) } - _ -> Nothing - _ -> Nothing - -parseSourcesList :: String -> [DebSource] -parseSourcesList = map parseSourceLine . sourceLines diff --git a/Debian/Repo/Types.hs b/Debian/Repo/Types.hs deleted file mode 100644 --- a/Debian/Repo/Types.hs +++ /dev/null @@ -1,410 +0,0 @@ -module Debian.Repo.Types - ( EnvRoot(..) - , EnvPath(..) - , outsidePath - , appendPath - , rootEnvPath - -- * Repository - , PackageVersion(..) - , PkgVersion(..) - , Repo(..) - , libraryCompatibilityLevel - , compatibilityFile - , Repository(..) - , LocalRepository(..) - , Layout(..) - -- * Release - , ReleaseName(..) - , parseReleaseName - , ReleaseInfo(..) - , Arch(..) - , archName - , Section(..) - , SubSection(..) - , sectionNameOfSubSection - , sectionName - , sectionName' - , parseSection - , parseSection' - , Release(..) - , releaseName' - , releaseName - , releaseComponents - , releaseArchitectures - -- * Each line of the sources.list represents a slice of a repository - , SourceType(..) - , DebSource(..) - , SliceName(..) - , Slice(..) - , SliceList(..) - , NamedSliceList(..) - -- * Package, Source and Binary Debs - , PackageIndex(..) - , PackageIndexLocal - , PackageID(..) - , BinaryPackage(..) - , SourcePackage(..) - , SourceFileSpec(..) - , PackageIDLocal - , BinaryPackageLocal - , SourcePackageLocal - -- * Cached OS Image - , AptCache(..) - , AptBuildCache(..) - , AptImage(..) - ) where - -import qualified Debian.Control.ByteString as B -import qualified Debian.Relation as B -import Debian.URI -import Debian.Version - -import Control.Exception (throw) -import qualified Data.ByteString.Lazy.Char8 as L -import Data.Char -import Data.List -import Data.Maybe -import Network.URI -import System.FilePath (()) -import System.Posix.Types ---import System.Unix.Process - --- |The root directory of an OS image. -data EnvRoot = EnvRoot { rootPath :: FilePath } deriving (Ord, Eq, Read, Show) - --- |A directory inside of an OS image. -data EnvPath = EnvPath { envRoot :: EnvRoot - , envPath :: FilePath - } deriving (Ord, Eq, Read, Show) - -outsidePath :: EnvPath -> FilePath -outsidePath path = rootPath (envRoot path) ++ envPath path - -appendPath :: FilePath -> EnvPath -> EnvPath -appendPath suff path = path { envPath = envPath path ++ suff } - -rootEnvPath :: FilePath -> EnvPath -rootEnvPath s = EnvPath { envRoot = EnvRoot "", envPath = s } - ---------------------- REPOSITORY ----------------------- - --- | The Repository type reprents any instance of the Repo class, so --- it might be local or remote. ---data Repository = forall a. (Repo a) => Repository a -data Repository - = LocalRepo LocalRepository - | VerifiedRepo URIString [ReleaseInfo] - | UnverifiedRepo URIString - deriving (Read, Show) - -instance Ord Repository where - compare a b = compare (repoURI a) (repoURI b) - -instance Eq Repository where - a == b = compare a b == EQ - -data LocalRepository - = LocalRepository - { repoRoot :: EnvPath - , repoLayout :: (Maybe Layout) - , repoReleaseInfoLocal :: [ReleaseInfo] - } deriving (Read, Show, Ord, Eq) - --- |The possible file arrangements for a repository. An empty --- repository does not yet have either of these attributes. -data Layout = Flat | Pool deriving (Eq, Ord, Read, Show) - -instance Repo Repository where - repoURI (LocalRepo (LocalRepository path _ _)) = fromJust . parseURI $ "file://" ++ envPath path - repoURI (VerifiedRepo uri _) = fromJust (parseURI uri) - repoURI (UnverifiedRepo uri) = fromJust (parseURI uri) -{- - repoURI (Repository a) = repoURI a - repositoryCompatibilityLevel (Repository a) = repositoryCompatibilityLevel a - repoReleaseInfo (Repository a) = repoReleaseInfo a --} - repoReleaseInfo (LocalRepo (LocalRepository _ _ info)) = info - repoReleaseInfo (VerifiedRepo _ info) = info - repoReleaseInfo (UnverifiedRepo _uri) = error "No release info for unverified repository" - -instance Repo LocalRepository where - repoURI (LocalRepository path _ _) = fromJust . parseURI $ "file://" ++ envPath path - repoReleaseInfo (LocalRepository _ _ info) = info - -class (Ord t, Eq t) => Repo t where - repoURI :: t -> URI - repositoryCompatibilityLevel :: t -> IO (Maybe Int) - repositoryCompatibilityLevel r = - fileFromURI uri' >>= either throw (return . parse . L.unpack) - where - uri' = uri {uriPath = uriPath uri compatibilityFile} - uri = repoURI r -{- - lazyCommand cmd L.empty >>= return . collectOutput >>= test cmd - where - cmd = "curl -s -g '" ++ uriToString id (repoURI r) "" compatibilityFile ++ "'" - test _ (out, _err, [ExitSuccess]) = return (parse (L.unpack out)) - test cmd (_, _, _) = error $ "*** FAILURE: " ++ cmd --} - parse :: String -> Maybe Int - parse text = case takeWhile isDigit text of - "" -> Nothing - s -> Just . read $ s - -- | This method returns a list of all the release in the - -- repository. This can be used to identify all of the files - -- in the repository that are not garbage. - repoReleaseInfo :: t -> [ReleaseInfo] - checkCompatibility :: t -> IO () - checkCompatibility repo = - do level <- repositoryCompatibilityLevel repo - case level of - Nothing -> return () - Just n | n >= libraryCompatibilityLevel -> return () - Just n -> error ("Compatibility error: repository level " ++ show n ++ - " < library level " ++ show libraryCompatibilityLevel ++ ", please upgrade.") - --- |The name of the file which holds the repository's compatibility --- level. -compatibilityFile :: FilePath -compatibilityFile = "repository-compat" - --- | The compatibility level of this library and any applications --- which use it. It is an error if we try to use a repository whose --- compatibility level is higher than this, a newer version of the --- library must be used. This value was increased from 1 to 2 due --- to a new version number tagging policy. -libraryCompatibilityLevel :: Int -libraryCompatibilityLevel = 2 - -class (Eq a, Ord a) => PackageVersion a where - pkgName :: a -> B.PkgName - pkgVersion :: a -> DebianVersion - --- |This is an old type which is still used to interface with the --- Debian.Relation module. -data PkgVersion = PkgVersion { getName :: B.PkgName - , getVersion :: DebianVersion - } deriving (Eq, Ord) - -instance PackageVersion PkgVersion where - pkgName = getName - pkgVersion = getVersion - -instance Show PkgVersion where - show v = getName v ++ "=" ++ show (getVersion v) - --------------------- RELEASE -------------------- - --- |A distribution (aka release) name. This type is expected to refer --- to a subdirectory of the dists directory which is at the top level --- of a repository. -data ReleaseName = ReleaseName { relName :: String } deriving (Eq, Ord, Read, Show) - -parseReleaseName :: String -> ReleaseName -parseReleaseName name = ReleaseName {relName = unEscapeString name} - -releaseName' :: ReleaseName -> String -releaseName' (ReleaseName {relName = s}) = escapeURIString isAllowedInURI s - --- FIXME: The lists here should be sets so that == and compare work properly. -data ReleaseInfo = ReleaseInfo { releaseInfoName :: ReleaseName - , releaseInfoAliases :: [ReleaseName] - , releaseInfoArchitectures :: [Arch] - , releaseInfoComponents :: [Section] - } deriving (Eq, Ord, Read, Show) - --- |The types of architecture that a package can have, either Source --- or some type of binary architecture. -data Arch = Source | Binary String deriving (Read, Show, Eq, Ord) - -archName :: Arch -> String -archName Source = "source" -archName (Binary arch) = arch - --- |A section of a repository such as main, contrib, non-free, --- restricted. The indexes for a section are located below the --- distribution directory. -newtype Section = Section String deriving (Read, Show, Eq, Ord) - --- |A package's subsection is only evident in its control information, --- packages from different subsections all reside in the same index. -data SubSection = SubSection { section :: Section, subSectionName :: String } deriving (Read, {-Show,-} Eq, Ord) - -sectionName :: SubSection -> String -sectionName (SubSection (Section "main") y) = y -sectionName (SubSection x y) = sectionName' x ++ "/" ++ y - -sectionName' :: Section -> String -sectionName' (Section s) = escapeURIString isAllowedInURI s - -sectionNameOfSubSection :: SubSection -> String -sectionNameOfSubSection = sectionName' . section - --- |Parse the value that appears in the @Section@ field of a .changes file. --- (Does this need to be unesacped?) -parseSection section = - case span (/= '/') section of - (x, "") -> SubSection (Section "main") x - ("main", y) -> SubSection (Section "main") y - (x, y) -> SubSection (Section x) (tail y) - -parseSection' name = - Section (unEscapeString name) - -data Release = Release { releaseRepo :: Repository - , releaseInfo :: ReleaseInfo - } deriving (Eq, Ord, Show) - -releaseName :: Release -> ReleaseName -releaseName = releaseInfoName . releaseInfo ---releaseAliases :: Release -> [ReleaseName] ---releaseAliases = releaseInfoAliases . releaseInfo -releaseComponents :: Release -> [Section] -releaseComponents = releaseInfoComponents . releaseInfo -releaseArchitectures :: Release -> [Arch] -releaseArchitectures = releaseInfoArchitectures . releaseInfo - ------------------ SLICES (SOURCES.LIST ENTRIES) --------------- - -data SourceType - = Deb | DebSrc - deriving (Eq, Ord) - -data DebSource - = DebSource - { sourceType :: SourceType - , sourceUri :: URI - , sourceDist :: Either String (ReleaseName, [Section]) - } deriving (Eq, Ord) - -instance Show SourceType where - show Deb = "deb" - show DebSrc = "deb-src" - -instance Show DebSource where - show (DebSource thetype theuri thedist) = - (show thetype) ++ " "++ uriToString id theuri " " ++ - (case thedist of - Left exactPath -> escape exactPath - Right (dist, sections) -> - releaseName' dist ++ " " ++ intercalate " " (map sectionName' sections)) - where escape = escapeURIString isAllowedInURI - --- |This is a name given to a combination of parts of one or more --- releases that can be specified by a sources.list file. -data SliceName = SliceName { sliceName :: String } deriving (Eq, Ord) - -data Slice - = Slice { sliceRepo :: Repository - , sliceSource :: DebSource - } deriving (Eq, Ord) - -data SliceList = SliceList {slices :: [Slice]} deriving (Eq, Ord) - -data NamedSliceList - = NamedSliceList { sliceList :: SliceList - , sliceListName :: SliceName - } deriving (Eq, Ord) - -instance Show Slice where - show = show . sliceSource - -instance Show SliceList where - show = concat . map ((++ "\n") . show) . slices - ----------------- PACKAGES AND PACKAGE INDEXES ------------- - --- |The PackageIndex type represents a file containing control --- information about debian packages, either source or binary. --- Though the control information for a binary package does not --- specify an architecture, the architecture here is that of --- the environment where the package information is cached. -data PackageIndex - = PackageIndex { packageIndexRelease :: Release - , packageIndexComponent :: Section - , packageIndexArch :: Arch - } deriving (Eq, Ord, Show) - -type PackageIndexLocal = PackageIndex - -instance Show BinaryPackage where - show p = packageName (packageID p) ++ "-" ++ show (packageVersion (packageID p)) - --- | The 'PackageID' type fully identifies a package by name, version, --- and a 'PackageIndex' which identifies the package's release, --- component and architecture. -data PackageID - = PackageID - { packageIndex :: PackageIndex - , packageName :: String - , packageVersion :: DebianVersion - } deriving (Eq, Ord, Show) - --- | The 'BinaryPackage' type adds to the 'PackageID' type the control --- information obtained from the package index. -data BinaryPackage - = BinaryPackage - { packageID :: PackageID - , packageInfo :: B.Paragraph - , pDepends :: B.Relations - , pPreDepends :: B.Relations - , pConflicts ::B.Relations - , pReplaces :: B.Relations - , pProvides :: B.Relations - } - -instance Ord BinaryPackage where - compare a b = compare (packageID a) (packageID b) - -instance Eq BinaryPackage where - a == b = (packageID a) == (packageID b) - -data SourcePackage - = SourcePackage - { sourcePackageID :: PackageID - , sourceParagraph :: B.Paragraph - , sourceDirectory :: String - , sourcePackageFiles :: [SourceFileSpec] - } - -data SourceFileSpec - = SourceFileSpec - { sourceFileMD5sum :: String - , sourceFileSize :: FileOffset - , sourceFileName :: FilePath - } - -type PackageIDLocal = PackageID -type BinaryPackageLocal = BinaryPackage -type SourcePackageLocal = SourcePackage - ----------------------- CACHED OS IMAGE --------------------- - -class (Ord t, Eq t, Show t) => AptCache t where - globalCacheDir :: t -> FilePath - -- | The directory you might chroot to. - rootDir :: t -> EnvRoot - -- | The sources.list without the local repository - aptBaseSliceList :: t -> SliceList - -- | The build architecture - aptArch :: t -> Arch - -- | Return the all source packages in this AptCache. - aptSourcePackages :: t -> [SourcePackage] - -- | Return the all binary packages for the architecture of this AptCache. - aptBinaryPackages :: t -> [BinaryPackage] - -- | Name of release - aptReleaseName :: t -> ReleaseName - -class AptCache t => AptBuildCache t where - -- | The sources.list - aptSliceList :: t -> SliceList - -data AptImage = - AptImage { aptGlobalCacheDir :: FilePath - , aptImageRoot :: EnvRoot - , aptImageArch :: Arch - , aptImageSliceList :: SliceList - , aptImageReleaseName :: ReleaseName - , aptImageSourcePackages :: [SourcePackage] - , aptImageBinaryPackages :: [BinaryPackage] - } diff --git a/Debian/Report.hs b/Debian/Report.hs --- a/Debian/Report.hs +++ b/Debian/Report.hs @@ -2,7 +2,7 @@ import Debian.Apt.Index (Fetcher, Compression(..), update, controlFromIndex') import Debian.Control.ByteString -import Debian.Repo.Types +import Debian.Sources import Debian.Version import Data.Maybe diff --git a/Debian/Shell.hs b/Debian/Shell.hs deleted file mode 100644 --- a/Debian/Shell.hs +++ /dev/null @@ -1,261 +0,0 @@ --- |This module probably belongs in haskell-unixutils. -module Debian.Shell - ( echoCommand - , echoProcess - , dotOutput - , vOutput - -- * Semi-obsolete - , runCommand - , runCommandQuietly - , runCommandTimed - , runCommandQuietlyTimed - , runCommandMsg - -- * Type Class - , ShellTask(..) - , SimpleTask(..) - , FullTask(..) - , commandTask - , processTask - , showCommand - , setStart - , setFinish - , setError - , runTask - , runTaskAndTest - , timeTask -{- - , timeTask' - , timeTask'' --} - , timeTaskAndTest - --, runCommandDots - , timeCommand - , showElapsed - , myTimeDiffToString - ) where - -import Control.Exception --- import Control.Monad -import Control.Monad.Trans --- import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as L -import Data.List -import Debian.Extra.CIO (dotOutput, printOutput, vMessage) -import Extra.CIO (CIO, ePutStrBl, vEPutStrBl, ePutStr, eBOL, ev, setStyle, addPrefixes) -import Prelude hiding (putStr) -import System.Locale -import System.Time -import System.Unix.Process -- as P -import Text.Printf - --- io = liftIO - --- There seems to be a bug in Haskell's TimeDiff code, --- sometimes tdPicosec returns a negative number. -myDiffClockTimes (TOD sa pa) (TOD sb pb) = - case pa >= pb of - True -> - noTimeDiff{ tdSec = fromIntegral (sa - sb) - -- FIXME: can handle just 68 years... - , tdPicosec = pa - pb - } - False -> - noTimeDiff{ tdSec = fromIntegral (sa - sb - 1) - -- FIXME: can handle just 68 years... - , tdPicosec = pa + 1000000000000 - pb - } - -echoCommand :: CIO m => String -> L.ByteString -> m [Output] -echoCommand command input = - ePutStrBl ("# " ++ command) >> - liftIO (lazyCommand command input) - --- |Echo the process arguments and then run the process -echoProcess :: CIO m => FilePath -> [String] -> L.ByteString -> m [Output] -echoProcess exec args input = - ePutStrBl (intercalate " " ("#" : exec : args)) >> - liftIO (lazyProcess exec args Nothing Nothing input) - -vOutput :: CIO m => Int -> [Output] -> m [Output] -vOutput v output = - do v' <- ev v - --lift (IO.hPutStr IO.stderr ("(ev=" ++ show (verbosity style) ++ "-" ++ show v ++ "=" ++ show ev ++ ")")) - case () of - _ | v' <= (-2) -> return output - | v' <= (-1) -> dotOutput 128 output - | True -> setStyle (addPrefixes "[1] " "[2] ") (printOutput output) - --- |Perform a task, print the elapsed time it took, and return the result. -showElapsed :: CIO m => String -> m a -> m a -showElapsed label f = - do (result, time) <- timeTask f - ePutStr (label ++ myTimeDiffToString time) - return result - --- This is a copy of a function Jeremy made private in Debian.Repo.IO. --- This probably means there is a standard replacement for it - must --- find out. -myTimeDiffToString diff = - do - case () of - _ | isPrefixOf "00:00:0" s -> drop 7 s ++ printf ".%03d" ms ++ " s." - _ | isPrefixOf "00:00:" s -> drop 6 s ++ printf ".%03d" ms ++ " s." - _ | isPrefixOf "00:" s -> drop 3 s - _ -> s - where - s = formatTimeDiff defaultTimeLocale "%T" diff - ms = ps2ms ps - ps2ms ps = quot (ps + 500000000) 1000000000 - ps = tdPicosec diff - --- |Run a command and return its result along with the amount of time it took. -timeCommand :: CIO m => m (Either String [Output]) -> m (Either String ([Output], TimeDiff)) -timeCommand result = - timeTask result >>= \ (result, elapsed) -> return (either Left (\ output -> Right (output, elapsed)) result) - --- |Not sure if this is a useful approach. -class ShellTask a where - command :: a -> Either String (FilePath, [String], Maybe FilePath, Maybe [(String, String)]) - input :: a -> L.ByteString -- The command input - input _ = L.empty - quietness :: a -> Int -- Verbosity level required for full output - quietness _ = 0 - introMsg :: a -> Maybe String -- Message printed before command starts - introMsg _ = Nothing - -- If failMsg or finishMsg are given, the command output will be forced - failMsg :: a -> Maybe (Int -> String) -- Message printed on failure - failMsg _ = Nothing - finishMsg :: a -> Maybe String -- Message printed on successful finish - finishMsg _ = Nothing - -data SimpleTask = SimpleTask Int String - -instance ShellTask SimpleTask where - command (SimpleTask _ s) = (Left s) - quietness (SimpleTask n _) = n - introMsg (SimpleTask _ _) = Nothing - -data FullTask = - FullTask { taskQuietness :: Int - , taskCommand :: Either String (FilePath, [String], Maybe FilePath, Maybe [(String, String)]) - , taskIntroMsg :: Maybe String - , taskFailMsg :: Maybe (Int -> String) - , taskFinishMsg :: Maybe String } - -commandTask command = - FullTask { taskQuietness = 0 - , taskCommand = Left command - , taskIntroMsg = Nothing - , taskFailMsg = Nothing - , taskFinishMsg = Nothing } - -processTask exec args path env = - FullTask { taskQuietness = 0 - , taskCommand = Right (exec, args, path, env) - , taskIntroMsg = Nothing - , taskFailMsg = Nothing - , taskFinishMsg = Nothing } - -setStart :: (Maybe String) -> FullTask -> FullTask -setStart s task = task {taskIntroMsg = s} - -setFinish :: (Maybe String) -> FullTask -> FullTask -setFinish s task = task {taskFinishMsg = s} - -setError :: (Maybe (Int -> String)) -> FullTask -> FullTask -setError s task = task {taskFailMsg = s} - -showCommand task = either id (\ (exec, args, _, _) -> intercalate " " ([exec] ++ args)) (command task) - -instance ShellTask FullTask where - quietness = taskQuietness - command = taskCommand - introMsg = taskIntroMsg - failMsg = taskFailMsg - finishMsg = taskFinishMsg - -runTask :: (ShellTask a, CIO m) => a -> m [Output] -runTask task = - liftIO (either (\ cmd -> lazyCommand cmd (input task)) - (\ (exec, args, path, env) -> lazyProcess exec args path env (input task)) (command task)) >>= - maybe return (vMessage 0) (introMsg task) >>= - vOutput 2 >>= - (\ output -> - (case (failMsg task, finishMsg task) of - (Nothing, Nothing) -> return output - _ -> checkResult (onFail task) (onFinish task) output >> return output)) - where - onFail :: (ShellTask a, CIO m) => a -> Int -> m () - onFail task n = maybe (return ()) (\ f -> vEPutStrBl 0 (f n)) (failMsg task) - onFinish :: (ShellTask a, CIO m) => a -> m () - onFinish task = maybe (return ()) (\ s -> vEPutStrBl 0 s) (finishMsg task) - -runTaskAndTest :: (ShellTask a, CIO m) => a -> m (Either String [Output]) -runTaskAndTest task = - do output <- runTask task - checkResult fail (ok output) output - where - fail n = return (Left (maybe ("*** FAILURE: " ++ showCommand task ++ " -> " ++ show n) (\ f -> f n) (failMsg task))) - ok output = return (Right output) - -{- --- |Run a task and return the elapsed time along with its result. -timeTask :: MonadIO m => a -> m (a, TimeDiff) -timeTask x = - do start <- liftIO getClockTime - result <- liftIO (evaluate x) - finish <- liftIO getClockTime - return (result, myDiffClockTimes finish start) - --- |Run a task and return the elapsed time along with its result. -timeTask' :: MonadIO m => m a -> m (a, TimeDiff) -timeTask' x = - do start <- liftIO getClockTime - result <- x >>= liftIO . evaluate - finish <- liftIO getClockTime - return (result, myDiffClockTimes finish start) - -timeTask'' :: (ShellTask a, CIO m) => a -> m ([Output], TimeDiff) -timeTask'' task = runTask task >>= timeTask --} - --- |Run a task and return the elapsed time along with its result. -timeTask :: MonadIO m => m a -> m (a, TimeDiff) -timeTask x = - do start <- liftIO getClockTime - result <- x >>= liftIO . evaluate - finish <- liftIO getClockTime - return (result, myDiffClockTimes finish start) - -timeTaskAndTest :: (ShellTask a, CIO m) => a -> m (Either String ([Output], TimeDiff)) -timeTaskAndTest task = - timeTask (runTaskAndTest task) >>= return . fixResult - where - fixResult (Left x, _) = Left x - fixResult (Right x, t) = Right (x, t) - --- Reimplementations of old functions - -runCommand :: CIO m => Int -> String -> m (Either String [Output]) -runCommand v cmd = runTaskAndTest (SimpleTask v cmd) - -runCommandTimed :: CIO m => Int -> String -> m (Either String ([Output], TimeDiff)) -runCommandTimed v cmd = timeCommand (runCommand v cmd) - -runCommandQuietly :: CIO m => String -> m (Either String [Output]) -runCommandQuietly = runCommand 1 - -runCommandQuietlyTimed :: CIO m => String -> m (Either String ([Output], TimeDiff)) -runCommandQuietlyTimed = runCommandTimed 1 - -runCommandMsg :: CIO m => Int -> Maybe String -> String -> (Int -> m (Either String ())) -> m (Either String ()) -runCommandMsg v start cmd fail = - -- If the program is run with -v -v, v0 will be 2, meaning quit verbose output. - -- The higher the v argument is the higher the v0 argument must be to achieve - -- the same verbosity, so the "effective verbosity" ev is v0 - v. - do eBOL >> - maybe (return ()) (vEPutStrBl v) start >> - vEPutStrBl (v+1) ("# " ++ cmd) >> - liftIO (lazyCommand cmd L.empty) >>= - vOutput (v+2) >>= - checkResult fail (return (Right ())) diff --git a/Debian/Sources.hs b/Debian/Sources.hs new file mode 100644 --- /dev/null +++ b/Debian/Sources.hs @@ -0,0 +1,161 @@ +module Debian.Sources where + +import Data.List (intercalate) +import Debian.Release +import Debian.URI + +data SourceType + = Deb | DebSrc + deriving (Eq, Ord) + +data DebSource + = DebSource + { sourceType :: SourceType + , sourceUri :: URI + , sourceDist :: Either String (ReleaseName, [Section]) + } deriving (Eq, Ord) + +instance Show SourceType where + show Deb = "deb" + show DebSrc = "deb-src" + +instance Show DebSource where + show (DebSource thetype theuri thedist) = + (show thetype) ++ " "++ uriToString id theuri " " ++ + (case thedist of + Left exactPath -> escape exactPath + Right (dist, sections) -> + releaseName' dist ++ " " ++ intercalate " " (map sectionName' sections)) + where escape = escapeURIString isAllowedInURI + +-- |This is a name given to a combination of parts of one or more +-- releases that can be specified by a sources.list file. +data SliceName = SliceName { sliceName :: String } deriving (Eq, Ord, Show) + +{- + +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. + +-} + +-- |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' (dropWhile (==' ') s) + where + quoteWords' :: String -> [String] + quoteWords' [] = [] + quoteWords' str = + case break (flip elem " [\"") str of + ([],[]) -> [] + (w, []) -> [w] + (w, (' ':rest)) -> w : (quoteWords' (dropWhile (==' ') rest)) + (w, ('"':rest)) -> + case break (== '"') rest of + (w',('"':rest)) -> + case quoteWords' rest of + [] -> [w ++ w'] + (w'':ws) -> ((w ++ w' ++ w''): ws) + (_w',[]) -> error ("quoteWords: missing \" in the string: " ++ s) + _ -> error ("the impossible happened in SourcesList.quoteWords") + (w, ('[':rest)) -> + case break (== ']') rest of + (w',(']':rest)) -> + case quoteWords' rest of + [] -> [w ++ "[" ++ w' ++ "]"] + (w'':ws) -> ((w ++ "[" ++ w' ++ "]" ++ w''): ws) + (_w',[]) -> error ("quoteWords: missing ] in the string: " ++ s) + _ -> error ("the impossible happened in SourcesList.quoteWords") + _ -> error ("the impossible happened in SourcesList.quoteWords") + +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 sections = map parseSection' sectionStrs + 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 sections + 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 sections + 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 (parseReleaseName theDist, sections) } + _ -> error ("parseSourceLine: invalid line in sources.list:\n" ++ str) + +parseSourceLine' :: String -> Maybe DebSource +parseSourceLine' str = + case quoteWords str of + (theTypeStr : theUriStr : theDistStr : sectionStrs) -> + let sections = map parseSection' sectionStrs + theType = case unEscapeString theTypeStr of + "deb" -> Just Deb + "deb-src" -> Just DebSrc + _ -> Nothing + theUri = case parseURI theUriStr of + Nothing -> Nothing + Just u -> Just u + theDist = unEscapeString theDistStr + in + case (last theDist, theType, theUri) of + ('/', Just typ, Just uri) -> if null sections + then Just $ DebSource { sourceType = typ, sourceUri = uri, sourceDist = Left theDist } + else error ("parseSourceLine: Dist is an exact path, so sections are not allowed on the line:\n" ++ str) + (_, Just typ, Just uri) -> if null sections + then Nothing + else Just $ DebSource { sourceType = typ, sourceUri = uri, sourceDist = Right ((parseReleaseName theDist), sections) } + _ -> Nothing + _ -> Nothing + +parseSourcesList :: String -> [DebSource] +parseSourcesList = map parseSourceLine . sourceLines diff --git a/Distribution/Package/Debian.hs b/Distribution/Package/Debian.hs --- a/Distribution/Package/Debian.hs +++ b/Distribution/Package/Debian.hs @@ -27,11 +27,11 @@ import Data.Version (showVersion) import Debian.Control import qualified Debian.Relation as D -import qualified Debian.Repo as D -import Debian.Time +import Debian.Release (parseReleaseName) +import Debian.Changes (ChangeLogEntry(..)) +import Debian.Time (getCurrentLocalRFC822Time) import Debian.Version import Debian.Version.String -import qualified Debian.Version as D import System.Cmd (system) import System.Directory import System.FilePath (()) @@ -215,7 +215,10 @@ else ("cabal-debian - No updates found for " ++ show path')) maybe (return ()) (\ _x -> replaceFile path' new) name ([], Nothing) -> return () - (missing, _) -> die $ "These debian packages need to be added to the build dependency list so the required cabal packages are available:\n " ++ intercalate "\n " (map fst missing) + (missing, _) -> + die ("These debian packages need to be added to the build dependency list so the required cabal packages are available:\n " ++ intercalate "\n " (map fst missing) ++ + "\nIf this is an obsolete package you may need to withdraw the old versions from the\n" ++ + "upstream repository, and uninstall and purge it from your local system.") where addDeps old = case partition (isPrefixOf "haskell:Depends=") (lines old) of @@ -393,7 +396,7 @@ changelogUpdate (tgtPfx "changelog") debianMaintainer pkgDesc date writeFile (tgtPfx "rules") (cdbsRules pkgDesc) getPermissions "debian/rules" >>= setPermissions "debian/rules" . (\ p -> p {executable = True}) - readFile "/usr/lib/haskell-utils/scripts/current/compat" >>= writeFile (tgtPfx "compat") + writeFile (tgtPfx "compat") "7" -- should this be hardcoded, or automatically read from /var/lib/dpkg/status? writeFile (tgtPfx "copyright") copyright -- The dev postinst and prerm files are generated by haskell-devscripts via cdbs. return () @@ -442,7 +445,8 @@ where header = ["#!/usr/bin/make -f", - "include /usr/share/cdbs/1/rules/hlibrary.mk"] + "include /usr/share/cdbs/1/rules/debhelper.mk", + "include /usr/share/cdbs/1/class/hlibrary.mk"] comments = ["# How to install an extra file into the documentation package", "#binary-fixup/libghc6-" ++ libName ++ "-doc::", @@ -550,8 +554,9 @@ Field ("Section", " " ++ "misc"), Field ("Maintainer", " " ++ debianMaintainer), Field ("Build-Depends", " " ++ showDeps' "Build-Depends:" debianBuildDeps), + Field ("Build-Depends-Indep", " " ++ showDeps' "Build-Depends-Indep:" debianBuildDepsIndep), --Field ("Build-Depends-Indep", " " ++ buildDepsIndep), - Field ("Standards-Version", " " ++ "3.7.2.2")] ++ + Field ("Standards-Version", " " ++ "3.8.1")] ++ list [] (\ s -> [Field ("Homepage", " " ++ s)]) (homepage pkgDesc)) executableSpec executable = Paragraph @@ -560,40 +565,53 @@ Field ("Section", " " ++ "misc"), -- No telling what the dependencies of an executable might -- be. The developer will have to fill them in - Field ("Depends", " " ++ showDeps [[D.Rel "${shlibs:Depends}" Nothing Nothing], [D.Rel "${haskell:Depends}" Nothing Nothing]]), + Field ("Depends", " " ++ showDeps [[D.Rel "${shlibs:Depends}" Nothing Nothing], + [D.Rel "${haskell:Depends}" Nothing Nothing], + [D.Rel "${misc:Depends}" Nothing Nothing]]), Field ("Description", " " ++ maybe debianDescription (const executableDescription) (library pkgDesc))] develLibrarySpecs = if isJust (library pkgDesc) then [librarySpec "any" "-dev"] else [] profileLibrarySpecs = if debLibProf flags && isJust (library pkgDesc) then [librarySpec "any" "-prof"] else [] - docLibrarySpecs = if isJust (library pkgDesc) then [librarySpec "any" "-doc"] else [] + docLibrarySpecs = if isJust (library pkgDesc) then [docSpecsParagraph] else [] + docSpecsParagraph = + Paragraph + [Field ("Package", " " ++ debianDocumentationPackageName (unPackageName . pkgName . package $ pkgDesc)), + Field ("Architecture", " " ++ "all"), + Field ("Section", " " ++ "doc"), + Field ("Depends", " " ++ showDeps' "Depends:" ([[D.Rel "${haskell:Depends}" Nothing Nothing], + [D.Rel "${misc:Depends}" Nothing Nothing]] ++ libraryDependencies "-doc")), + Field ("Description", " " ++ libraryDescription "-doc")] librarySpec arch suffix = Paragraph [Field ("Package", " " ++ prefix ++ map toLower (unPackageName . pkgName . package $ pkgDesc) ++ suffix), Field ("Architecture", " " ++ arch), Field ("Section", " " ++ "libdevel"), - Field ("Depends", " " ++ showDeps' "Depends:" ([[D.Rel "${haskell:Depends}" Nothing Nothing]] {- ++ libraryDependencies suffix -} )), + Field ("Depends", " " ++ showDeps' "Depends:" ([[D.Rel "${haskell:Depends}" Nothing Nothing], + [D.Rel "${misc:Depends}" Nothing Nothing]] ++ libraryDependencies suffix)), Field ("Description", " " ++ libraryDescription suffix)] where prefix = case suffix of "-dev" -> "libghc6-" "-prof" -> "libghc6-" - "-doc" -> docPrefix (unPackageName . pkgName . package $ pkgDesc) + -- "-doc" -> docPrefix (unPackageName . pkgName . package $ pkgDesc) _ -> error $ "Unknown suffix: " ++ suffix libraryDependencies :: String -> D.Relations - libraryDependencies "-dev" = concat . map (debianDependencies bundled compiler develDependencies) . allBuildDepends $ pkgDesc - libraryDependencies "-prof" = [[D.Rel (debianDevelPackageName (unPackageName . pkgName . package $ pkgDesc)) Nothing Nothing]] ++ - (concat . map (debianDependencies bundled compiler profilingDependencies) . allBuildDepends $ pkgDesc) - libraryDependencies "-doc" = [D.Rel "ghc6-doc" Nothing Nothing] : (concat . map (debianDependencies bundled compiler docDependencies) . allBuildDepends $ pkgDesc) + libraryDependencies "-dev" = [] + libraryDependencies "-prof" = [[D.Rel (debianDevelPackageName (unPackageName . pkgName . package $ pkgDesc)) Nothing Nothing]] + libraryDependencies "-doc" = [[D.Rel "ghc6-doc" Nothing Nothing]] libraryDependencies suffix = error $ "Unexpected library package name suffix: " ++ show suffix -- The haskell-cdbs package contains the hlibrary.mk file with -- the rules for building haskell packages. debianBuildDeps :: D.Relations debianBuildDeps = [[D.Rel "debhelper" (Just (D.GRE (parseDebianVersion "5.0"))) Nothing], - [D.Rel "haskell-cdbs" Nothing Nothing], - [D.Rel "ghc6" (Just (D.GRE (parseDebianVersion "6.8"))) Nothing], - [D.Rel "ghc6-doc" Nothing Nothing], - [D.Rel "haddock" Nothing Nothing]] ++ + [D.Rel "haskell-devscripts" (Just (D.GRE (parseDebianVersion "0.6.15+nmu7"))) Nothing], + [D.Rel "cdbs" Nothing Nothing], + [D.Rel "ghc6" (Just (D.GRE (parseDebianVersion "6.8"))) Nothing]] ++ (if debLibProf flags then [[D.Rel "ghc6-prof" Nothing Nothing]] else []) ++ (concat . map (debianDependencies bundled compiler buildDependencies) . allBuildDepends $ pkgDesc) + debianBuildDepsIndep :: D.Relations + debianBuildDepsIndep = + [[D.Rel "ghc6-doc" Nothing Nothing], + [D.Rel "haddock" Nothing Nothing]] debianDescription = (synopsis pkgDesc) ++ case description pkgDesc of @@ -603,12 +621,12 @@ list "" ("\nAuthor: " ++) (author pkgDesc) ++ list "" ("\nUpstream-Maintainer: " ++) (maintainer pkgDesc) ++ list "" ("\nUrl: " ++) (pkgUrl pkgDesc) in - "\n " ++ (trim . intercalate "\n " . map addDot . lines $ text') + "\n " ++ (trim . intercalate "\n " . map addDot . lines $ text') addDot line = if all (flip elem " \t") line then "." else line executableDescription = " " ++ "An executable built with the " ++ display (package pkgDesc) ++ " library." - libraryDescription "-prof" = debianDescription ++ "\n .\n This package contains the libraries compiled with profiling enabled." - libraryDescription "-dev" = debianDescription ++ "\n .\n This package contains the normal library files." - libraryDescription "-doc" = debianDescription ++ "\n .\n This package contains the documentation files." + libraryDescription "-prof" = debianDescription ++ "\n .\n This package contains the libraries compiled with profiling enabled." + libraryDescription "-dev" = debianDescription ++ "\n .\n This package contains the normal library files." + libraryDescription "-doc" = debianDescription ++ "\n .\n This package contains the documentation files." libraryDescription x = error $ "Unexpected library package name suffix: " ++ show x showDeps xss = intercalate ", " (map (intercalate " | " . map show) xss) @@ -639,13 +657,13 @@ changelog :: String -> PackageDescription -> String -> String changelog debianMaintainer pkgDesc date = - show (D.Entry { D.logPackage = debianSourcePackageName pkgDesc - , D.logVersion = debianVersionNumber pkgDesc - , D.logDists = [D.parseReleaseName "unstable"] - , D.logUrgency = "low" - , D.logComments = " * Debianization generated by cabal-debian\n\n" - , D.logWho = debianMaintainer - , D.logDate = date }) + show (Entry { logPackage = debianSourcePackageName pkgDesc + , logVersion = debianVersionNumber pkgDesc + , logDists = [parseReleaseName "unstable"] + , logUrgency = "low" + , logComments = " * Debianization generated by cabal-debian\n\n" + , logWho = debianMaintainer + , logDate = date }) unPackageName :: PackageName -> String unPackageName (PackageName s) = s diff --git a/Distribution/Package/Debian/Bundled.hs b/Distribution/Package/Debian/Bundled.hs --- a/Distribution/Package/Debian/Bundled.hs +++ b/Distribution/Package/Debian/Bundled.hs @@ -311,4 +311,4 @@ docPrefix "xhtml" = "libghc6-" docPrefix "xmonad" = "libghc6-" -} -docPrefix _ = "libghc6-" +docPrefix _ = "haskell-" diff --git a/Text/Format.hs b/Text/Format.hs deleted file mode 100644 --- a/Text/Format.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Text.Format where - -class Show a => Format a where - format :: a -> String - format = show diff --git a/debian.cabal b/debian.cabal --- a/debian.cabal +++ b/debian.cabal @@ -1,22 +1,17 @@ Name: debian -Version: 3.23 +Version: 3.31 License: BSD3 License-File: debian/copyright Author: David Fox Category: System Maintainer: david@seereason.com Homepage: http://src.seereason.com/ghc610/haskell-debian-3 -Build-Depends: base >= 3 && < 4, unix, Unixutils, Extra >= 0.4, directory, process, bytestring, - pretty, containers, old-time, old-locale, network, parsec, mtl, - regex-compat, time, regex-posix, bzlib, zlib, HaXml, filepath +Build-Depends: base >= 3 && < 4, bytestring, containers, directory, filepath, mtl, network, old-locale, parsec, pretty, process, regex-compat, regex-posix, time, unix, bzlib, Extra >= 0.4, HaXml, Unixutils, zlib Build-Type: Simple Synopsis: Modules for working with the Debian package system Description: - This library includes modules covering almost every aspect of the Debian - packaging system, including low level data types such as version numbers - and dependency relations, on up to the types necessary for computing and - installing build dependencies, building source and binary packages, - and inserting them into a repository. + This library includes modules covering some basic data types defined by + the Debian policy manual - version numbers, control file syntax, etc. ghc-options: -O2 -threaded -W Extensions: ExistentialQuantification Exposed-modules: @@ -24,6 +19,7 @@ Debian.Apt.Index, Debian.Apt.Methods, Debian.Apt.Package, + Debian.Changes, Debian.Control, Debian.Control.Common, Debian.Control.PrettyPrint, @@ -37,34 +33,17 @@ Debian.Relation.ByteString, Debian.Relation.Common, Debian.Relation.String, - Debian.Repo, - Debian.Repo.AptImage, - Debian.Repo.Cache, - Debian.Repo.Changes, - Debian.Repo.Dependencies, - Debian.Repo.Insert, - Debian.Repo.IO, - Debian.Repo.LocalRepository, - Debian.Repo.OSImage, - Debian.Repo.Package, - Debian.Repo.PackageIndex, - Debian.Repo.Release, - Debian.Repo.Repository, - Debian.Repo.Slice, - Debian.Repo.SourcesList, - Debian.Repo.SourceTree, - Debian.Repo.Types, - Debian.Shell, - Debian.Time, - Debian.URI, + Debian.Release, + Debian.Sources, Debian.Version, Debian.Version.Common, Debian.Version.String, Debian.Version.ByteString, Debian.VersionPolicy, Debian.Report, - Debian.Util.FakeChanges, - Text.Format + Debian.Time, + Debian.URI, + Debian.Util.FakeChanges other-modules: Debian.Version.Internal, Distribution.Package.Debian.Bundled, @@ -72,7 +51,7 @@ Distribution.Package.Debian.Main, Distribution.Package.Debian extra-source-files: - tests/Main.hs demos/Versions.hs debian/changelog + tests/Main.hs debian/changelog debian/compat debian/control debian/copyright debian/rules @@ -84,28 +63,11 @@ Main-is: utils/Report.hs ghc-options: -O2 -threaded -W -Executable: debian-versions -Main-is: demos/Versions.hs -ghc-options: -O2 -threaded -W - Executable: cabal-debian Main-is: utils/CabalDebian.hs ghc-options: -O2 -threaded -W Build-Depends: Cabal >= 1.6.0.1 --- For more complex build options see: --- http://www.haskell.org/ghc/docs/latest/html/Cabal/ - --- Debian.AptImage, Debian.Cache, Debian.Control, Debian.Control.ByteString, --- Debian.Dependencies, Debian.DryRun, Debian.GenBuildDeps, Debian.Index, --- Debian.IO, Debian.Shell, --- Debian.Local.Changes, Debian.Local.Index, Debian.Local.Insert, --- Debian.Local.Package, Debian.Local.Release, Debian.Local.Repo, Debian.OSImage, --- Debian.Package, Debian.Release, Debian.Repo, --- Debian.Slice, Debian.SourcesList, --- Debian.SourceTree, Debian.Types, Debian.UploadFile, , Debian.Apt.Index, Debian.Apt.Methods, Debian.Deb, Debian.Time, Debian.Util.FakeChanges, --- Debian.Apt.Dependencies, Debian.Apt.Package, --- Debian.Report, --- Debian.Types.AptCache, Debian.Types.AptImage, Debian.Types.DebSource, Debian.Types.OSImage, --- Debian.Types.Package, Debian.Types.PackageIndex, Debian.Types.Release, Debian.Types.ReleaseInfo, --- Debian.Types.Repo, Debian.Types.Slice, Debian.Types.SourceTree +Executable: apt-get-build-depends +Main-is: utils/AptGetBuildDeps.hs +ghc-options: -O2 -threaded -W diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,70 @@ +haskell-debian (3.31) unstable; urgency=low + + * update to use newer haskell-devscripts which includes hlibrary.mk + * change libghc6-*-doc to haskell-*-doc + * move haskell-*-doc to Section: doc + * build haskell-*-doc for Architecture 'all' instead of 'any' + * make ghc6-doc and haddock Build-Depends-Indep + * update Standards-Version to 3.8.1 + * depend on cdbs and haskell-devscripts instead of haskell-cdbs + * only use one space at the beginning of lines in the long description + * add ${misc:Depends} to Depends lines + + -- Jeremy Shaw Mon, 23 Mar 2009 20:18:41 -0500 + +haskell-debian (3.30) unstable; urgency=low + + * Move the modules for dealing with the repository into a new package + named haskell-debian-repo. The cabal-debian tool remains in this + package, so this split means that the repo package can change without + triggering massive rebuilding due to build dependencies on + cabal-debian. + + -- David Fox Wed, 18 Feb 2009 06:36:25 -0800 + +haskell-debian (3.29) unstable; urgency=low + + * Add System.Chroot to list of exported modules + * Reduce number of modules loaded by CabalDebian. + + -- David Fox Tue, 10 Feb 2009 17:06:47 -0800 + +haskell-debian (3.28) unstable; urgency=low + + * Add System.Chroot.useEnv, and use it to allow contact with the ssh + agent from inside of changeroots. + + -- David Fox Mon, 09 Feb 2009 11:18:59 -0800 + +haskell-debian (3.27) unstable; urgency=low + + * Added apt-get-build-deps. not librarized yet :( + + -- Jeremy Shaw Fri, 06 Feb 2009 18:52:36 -0600 + +haskell-debian (3.26) unstable; urgency=low + + * Improve the code that decides whether the sources.list has changed, + to avoid recreating the build environment as often. + + -- David Fox Thu, 05 Feb 2009 08:56:32 -0800 + +haskell-debian (3.25) unstable; urgency=low + + * Use State monad instead of RWS monad for AptIO + * Rename IOState to AptState + + -- David Fox Wed, 04 Feb 2009 09:34:24 -0800 + +haskell-debian (3.24) unstable; urgency=low + + * Use Data.Time instead of System.Time + * Fix code to compute the elapsed time for the dpkg-buildpackage. + * Restore some generated dependencies that got dropped out of + cabal-debian. + + -- David Fox Sat, 31 Jan 2009 08:45:51 -0800 + haskell-debian (3.23) unstable; urgency=low * Eliminate the use of EnvPath in most places, just use a regular diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -24,16 +24,7 @@ Package: libghc6-debian-dev Architecture: any Section: libdevel -Depends: ${haskell:Depends}, - ghc6, - libghc6-bzlib-dev, - libghc6-extra-dev, - libghc6-haxml-dev, - libghc6-unixutils-dev, - libghc6-zlib-dev -Conflicts: libghc6-debian-dev -Provides: libghc6-debian-dev -Replaces: libghc6-debian-dev +Depends: ${haskell:Depends} Description: Modules for working with the Debian package system This library includes modules covering almost every aspect of the Debian packaging system, including low level data types such as version numbers @@ -109,3 +100,9 @@ Section: devel Depends: ${shlibs:Depends}, ${haskell:Depends}, haskell-utils, haskell-cdbs, haskell-devscripts (>= 0.6.15), libghc6-cabal-prof Description: Tool for creating debianizations of Haskell packages based on the .cabal file. + +Package: apt-get-build-depends +Architecture: any +Section: devel +Depends: ${shlibs:Depends}, ${haskell:Depends}, haskell-utils, haskell-cdbs, haskell-devscripts (>= 0.6.15), libghc6-cabal-prof +Description: Tool which will parse the Build-Depends{-Indep} lines from debian/control and apt-get install the required packages diff --git a/demos/Versions.hs b/demos/Versions.hs deleted file mode 100644 --- a/demos/Versions.hs +++ /dev/null @@ -1,40 +0,0 @@ --- |Print the available version numbers of a package. -module Main where - -import Control.Exception (throw) -import Control.Monad.Trans -import Data.Maybe -import Debian.Repo.IO -import Debian.Repo.PackageIndex -import Debian.Repo.Package -import Debian.Repo.Release -import Debian.Repo.Repository -import Debian.Repo.Types -import Debian.URI -import Extra.CIO -import Extra.IO () -import Prelude hiding (putStrLn) - -main :: IO () -main = runAptIO main' - -main' :: AptIOT IO () -main' = - do repo <- prepareRepository (fromJust (parseURI uri)) - releases <- mapM insertRelease (map (Release repo) (repoReleaseInfo repo)) - let binaryIndexes = map (filter (\ i -> packageIndexArch i == arch)) (map binaryIndexList releases) - binaryPackages <- mapM packageLists binaryIndexes - liftIO (putStrLn ("\n" ++ show releases)) -{- - where - insert repo info = insertRelease repo --} - -packageLists :: [PackageIndex] -> AptIOT IO [[BinaryPackage]] -packageLists indexes = mapM packages indexes - -packages :: PackageIndex -> AptIOT IO [BinaryPackage] -packages index = liftIO (binaryPackagesOfIndex index) >>= return . either throw id - -uri = "http://deb.seereason.com/ubuntu/" -arch = Binary "i386" diff --git a/utils/AptGetBuildDeps.hs b/utils/AptGetBuildDeps.hs new file mode 100644 --- /dev/null +++ b/utils/AptGetBuildDeps.hs @@ -0,0 +1,39 @@ +module Main where + +import Control.Monad +import Data.ByteString.Char8 (ByteString) +import Debian.Control -- (Control(..),lookupP,parseControlFromFile) +import Debian.Relation +import System.Process +import System.Exit + +lookupBuildDeps :: FilePath -> IO [PkgName] +lookupBuildDeps fp = + do control <- parseControlFromFile fp + case control of + (Left e) -> error (show e) + (Right (Control (p:_))) -> + return $ ((lookupDepends "Build-Depends" p) ++ + (lookupDepends "Build-Depends-Indep" p)) + +lookupDepends :: String -> Paragraph' String -> [PkgName] +lookupDepends key paragraph = + case fieldValue key paragraph of + Nothing -> [] -- (Left $ "could not find key " ++ key) + (Just relationString) -> + case parseRelations relationString of + (Left e) -> error (show e) + (Right andRelations) -> + map pkgName (concatMap (take 1) andRelations) + where + pkgName :: Relation -> PkgName + pkgName (Rel name _ _) = name + + +aptGetInstall :: [PkgName] -> IO ExitCode +aptGetInstall pkgnames = + do (_,_,_,ph) <- createProcess $ proc "apt-get" ("install" : pkgnames) + waitForProcess ph + +main :: IO () +main = lookupBuildDeps "debian/control" >>= aptGetInstall >>= exitWith diff --git a/utils/Report.hs b/utils/Report.hs --- a/utils/Report.hs +++ b/utils/Report.hs @@ -5,7 +5,7 @@ import Data.List import Debian.Apt.Methods import Debian.Report -import Debian.Repo.SourcesList +import Debian.Sources import Extra.Exit import Extra.HaXml import System.Environment