debian 3.31 → 3.32
raw patch · 6 files changed
+25/−283 lines, 6 files
Files
- Debian/Changes.hs +10/−166
- Debian/GenBuildDeps.hs +0/−34
- Debian/VersionPolicy.hs +0/−76
- Distribution/Package/Debian.hs +7/−6
- debian.cabal +1/−1
- debian/changelog +7/−0
Debian/Changes.hs view
@@ -1,54 +1,22 @@ -- |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+ ( ChangesFile(..) , ChangedFileSpec(..)+ , changesFileName , ChangeLogEntry(..)- ) -} where+ , parseLog+ , parseEntry+ , parseChanges+ ) 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 Debian.Version import System.Posix.Types+import Text.Regex -- |A file generated by dpkg-buildpackage describing the result of a -- package build@@ -66,6 +34,8 @@ -- |An entry in the list of files generated by the build. data ChangedFileSpec = ChangedFileSpec { changedFileMD5sum :: String+ , changedFileSHA1sum :: String+ , changedFileSHA256sum :: String , changedFileSize :: FileOffset , changedFileSection :: SubSection , changedFilePriority :: String@@ -168,129 +138,3 @@ 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 ()--}
Debian/GenBuildDeps.hs view
@@ -146,40 +146,6 @@ verts = map fst vertPairs vertPairs = zip [0..] packages -{---- |Given an ordering function representing the dependencies on a--- list of packages, return a triple: One ready package, the packages--- that depend on the ready package directly or indirectly, and all--- the other packages.-buildable :: Show a => (a -> a -> Ordering) -> [a] -> Either [(a, a)] (a, [a], [a])-buildable cmp packages =- case partition (\ x -> reachable hasDep x == [x]) verts of- ([], _) -> Left (map ofEdge (cycleEdges hasDep))- (thisReady : moreReady, allBlocked) ->- let (deps, other) = partition (\ x -> elem x (reachable isDep thisReady)) allBlocked in- Right (ofVertex thisReady, map ofVertex deps, map ofVertex (moreReady ++ other))- where- allDeps x = (ofVertex x, map ofVertex (filter (/= x) (reachable hasDep x)))- isDep = buildG (0, length packages - 1) edges'- edges' = map (\ (a, b) -> (b, a)) edges- hasDep = buildG (0, length packages - 1) edges- edges :: [(Int, Int)]- edges =- nub (foldr f [] (tails vertPairs))- where f [] edges = edges- f (x : xs) edges = catMaybes (map (toEdge x) xs) ++ edges- toEdge (xv, xa) (yv, ya) =- case cmp xa ya of- EQ -> Nothing- LT -> Just (yv, xv)- GT -> Just (xv, yv)- ofEdge (a, b) = (ofVertex a, ofVertex b)- ofVertex n = fromJust (Map.findWithDefault Nothing n (Map.fromList (zip [0..] (map Just packages))))- verts :: [Int]- verts = map fst vertPairs- vertPairs = zip [0..] packages--}- cycleEdges g = filter (`elem` (edges g)) (Set.toList (Set.intersection
Debian/VersionPolicy.hs view
@@ -162,33 +162,6 @@ case tagMax [Just distTag', sourceTag'] of Nothing -> error $ "Internal error" Just tag -> tag-{-- case (release, sourceTag, distTag') of- (_, _, VersionTag {vendorTag = (distVendorName, distVendorBuild)})- | distVendorName /= vendor -> - error $ "Vendor name mismatch: " ++ show (vendor, distVendorName)- (_, Just (VersionTag {vendorTag = (sourceVendorName, sourceVendorBuild)}), _)- | sourceVendorName /= vendor -> - error $ "Vendor name mismatch: " ++ show (vendor, sourceVendorName)- (Just relName, _, VersionTag {releaseTag = Just (distRelName, distRelBuild)})- | relName /= undefined ->- undefined-- let candidate1 = fixTag sourceTag in- let candidate2 = setRelease release (bumpTag' distTag) in- let candidate' = tagMax candidate - case (tagMax [sourceTag, Just (bumpTag vendor release extra distTag)]) of- - let candidate = maybe Nothing (Just . fixTag) (tagMax [sourceTag, Just (bumpTag vendor release extra distTag)]) in- appendTag alias sourceUpstreamVersion (findAvailableTag candidate)- -- Change a tag so it is appropriate for the release, adding or- -- removing the release tag.- fixTag tag = case (releaseTag tag, release) of - (Just _, Nothing) -> tag {releaseTag = Nothing}- (Nothing, Just rel) -> tag {releaseTag = Just (rel, 1)}- (Just (oldRel, oldBuild), Just newRel) | oldRel /= newRel -> tag {releaseTag = Just (newRel, 1)}- (Just (_, build), Just rel) -> tag {releaseTag = Just (rel, build)}--} (sourceUpstreamVersion, sourceTag) = parseTag vendor sourceVersion -- All the tags of existing packages whose upstream version matches the source allTags = catMaybes (map snd (filter (\ (v, _) -> v == sourceUpstreamVersion) (map (parseTag vendor) allVersions)))@@ -241,55 +214,6 @@ (Just relName, Just _) -> tag {releaseTag = Just (relName, 1)} (Just relName, Nothing) -> tag {releaseTag = Just (relName, 1)} (Nothing, _) -> tag {releaseTag = Nothing}- ---- Return a tag that is--- 1) slightly newer than the dist tag--- 2) at least as new as the sourceTag--- 3) has the appropriate releaseTag-{--nextTag vendor release extra sourceTag distTag =- (fixRelease release sourceTag) (fixRelease release distTag)-@(VendorTag {vendorTag = (sourceVendor, sourceBuild)}) distTag@(VendorTag {vendorTag = (distVendor, distBuild)}) =- case (release, releaseTag sourceTag, releaseTag distTag) of- _ | vendor /= sourceVendor || vendor /= distVendor -> -- This really shouldn't happen- error $ "Vendor tags do not match: (" ++ vendor ++ ", " ++ sourceVendor ++ ", " ++ distVendor ++ ")"- (Just relName, Just (sourceRel, sourceRelBuild), _) | relName /= sourceRel -> - (Nothing, _, _) | sourceBuild > distBuild -> - -> - where- fixRelease Nothing tag@(VendorTag {vendorTag = (vendor, build), releaseTag = Just (relName, relBuild)}) = tag {vendorTag = (vendor, build+1), releaseTag = Nothing}- fixRelease (Just name) tag@(VendorTag {vendorTag = (vendor, build), releaseTag = Nothing})---- |Return a tag which is slightly newer than the argument. This needs to work--- even if the release changes.-bumpTag newVendor release extra (Just tag@(VendorTag {vendorTag = (oldVendor, vendorBuild)})) =- case (release, releaseTag tag) of- _ | newVendor /= oldVendor -> error $ "Illegal vendor change: " ++ oldVendor ++ " -> " ++ newVendor- (Just newName, Just (oldName, oldBuild)) | oldName == newName -> tag {releaseTag = Just (oldName, oldBuild + 1)}- -- It is odd for the release name to change, but we can just- -- bump the vendor build number to be safe- (Just newName, Just (oldName, oldBuild)) -> tag {vendorTag = (oldVendor, vendorBuild+1), releaseTag = Just (newName, 1)}- -- It is also odd for a release to switch from non-development- -- to development. So be it.- (Nothing, Just (oldName, oldBuild)) -> tag {vendorTag = (oldVendor, vendorBuild+1), releaseTag = Nothing }- -- - (Just newName, Nothing) -> tag {vendorTag = (- (Nothing, Just (relName, relBuild)) ->- - case release of- Nothing -> tag { vendorTag = let (vendor, build) = vendorTag tag in (vendor, build + 1) }- Just name -> tag { releaseTag = case releaseTag tag of - Nothing -> Just (name, 1)- Just (name, build) -> Just (name, build + 1) }-bumpTag vendor release extra Nothing = newTag vendor release extra---- |Return a tag which is slightly newer, keeping the the same release.-bumpTag' tag@(VersionTag {vendorTag = (vendor, build), releaseTag = release}) =- case releaseTag of- Nothing -> tag {vendorTag = (vendor, build+1)}- Just (name, relBuild) -> tag {releaseTag = Just (name, relBuild + 1)}--} -- Create a tag which is one click newer. newTag vendor Nothing extra = VersionTag { extraNumber = extra, vendorTag = (vendor, 1), releaseTag = Nothing }
Distribution/Package/Debian.hs view
@@ -53,7 +53,7 @@ import Distribution.Simple.Register (writeInstalledConfig) --import Distribution.Simple.Setup (defaultRegisterFlags) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))-import Distribution.Simple.PackageIndex (fromList)+import Distribution.Simple.PackageIndex (PackageIndex,fromList) import Distribution.Simple.Utils (die, setupMessage) import Distribution.PackageDescription (GenericPackageDescription(..), PackageDescription(..),@@ -116,7 +116,8 @@ (rpmVerbosity flags) installed <- installedPackages case finalizePackageDescription (rpmConfigurationsFlags flags)- (Just installed) buildOS buildArch (compilerId compiler) [] genPkgDesc of+ (Nothing :: Maybe (PackageIndex PackageIdentifier))+ buildOS buildArch (compilerId compiler) [] genPkgDesc of Left e -> die $ "finalize failed: " ++ show e Right (pd, _) -> return (compiler, pd) @@ -602,7 +603,7 @@ -- the rules for building haskell packages. debianBuildDeps :: D.Relations debianBuildDeps =- [[D.Rel "debhelper" (Just (D.GRE (parseDebianVersion "5.0"))) Nothing],+ [[D.Rel "debhelper" (Just (D.GRE (parseDebianVersion "7.0"))) 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]] ++ @@ -618,9 +619,9 @@ "" -> "" text -> let text' = text ++ "\n" ++- list "" ("\nAuthor: " ++) (author pkgDesc) ++- list "" ("\nUpstream-Maintainer: " ++) (maintainer pkgDesc) ++- list "" ("\nUrl: " ++) (pkgUrl pkgDesc) in+ list "" ("\n Author: " ++) (author pkgDesc) +++ list "" ("\n Upstream-Maintainer: " ++) (maintainer pkgDesc) +++ list "" ("\n Url: " ++) (pkgUrl pkgDesc) in "\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."
debian.cabal view
@@ -1,5 +1,5 @@ Name: debian-Version: 3.31+Version: 3.32 License: BSD3 License-File: debian/copyright Author: David Fox
debian/changelog view
@@ -1,3 +1,10 @@+haskell-debian (3.32) unstable; urgency=low++ * Add fields to Debian.Changes.ChangedFileSpec for SHA1 and SHA256+ checksums.++ -- David Fox <dsf@seereason.com> Fri, 03 Apr 2009 07:14:59 -0700+ haskell-debian (3.31) unstable; urgency=low * update to use newer haskell-devscripts which includes hlibrary.mk