diff --git a/Debian/Changes.hs b/Debian/Changes.hs --- a/Debian/Changes.hs +++ b/Debian/Changes.hs @@ -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 () --} diff --git a/Debian/GenBuildDeps.hs b/Debian/GenBuildDeps.hs --- a/Debian/GenBuildDeps.hs +++ b/Debian/GenBuildDeps.hs @@ -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 diff --git a/Debian/VersionPolicy.hs b/Debian/VersionPolicy.hs --- a/Debian/VersionPolicy.hs +++ b/Debian/VersionPolicy.hs @@ -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 } diff --git a/Distribution/Package/Debian.hs b/Distribution/Package/Debian.hs --- a/Distribution/Package/Debian.hs +++ b/Distribution/Package/Debian.hs @@ -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." diff --git a/debian.cabal b/debian.cabal --- a/debian.cabal +++ b/debian.cabal @@ -1,5 +1,5 @@ Name: debian -Version: 3.31 +Version: 3.32 License: BSD3 License-File: debian/copyright Author: David Fox diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ +haskell-debian (3.32) unstable; urgency=low + + * Add fields to Debian.Changes.ChangedFileSpec for SHA1 and SHA256 + checksums. + + -- David Fox 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