debian-3.14: Debian/VersionPolicy.hs
-- |This module contains functions governing the assignment of version
-- numbers, patterned after Ubuntu version number policy:
--
-- (1) To distinguish packages which have been pulled out of one vendor's
-- repository to build for another, we add a vendor name and a build
-- number, so version "1.2-3" becomes "1.2-3vendorname1". Subsequent
-- builds (perhaps due to changes in build dependencies) would be numbered
-- "1.2-3vendorname2" and so on.
--
-- (2) In addition, packages which are backported, (i.e. built for a
-- non-development release such as Debian etch or Ubuntu feisty) need
-- another tag to distinguish them from the version that would go into
-- the development release (sid or, as of this writing, heron.) So if
-- we pulled the source for version "1.2-3vendorname4" out of our pool
-- to build for feisty, it would become "1.2-3vendorname4~feisty1".
--
-- (3) The first two policies combine if we
-- are building a package pulled directly from the other vendor into
-- our feisty pool, then "1.2-3" would become 1.2-3vendorname0~feisty1.
-- Subsequent builds of "1.2-3" (perhaps due to changes in build
-- dependencies) would get increasing build numbers,
-- "1.2-3vendorname0~feisty2" etc.
--
-- (4) If the original version number does not end with a digit, a "0" is
-- inserted before the vendor name to facilitate parsing of these tags.
--
-- (5) Finally, an additional tag format is supported for the benefit of
-- one autobuilder client, where before the vendor name an "r" and an
-- integer are inserted.
module Debian.VersionPolicy
( VersionTag
, parseTag
, getTag
, dropTag
, setTag
, appendTag
, tagCmp
, tagMax
, bumpTag
, newTag
, compareSourceAndDist
) where
import Debian.Version
import Text.Regex
import Data.List
import Data.Maybe
-- |We implement two types of version number tags. One has the format
-- @r<releasenumber>vendor<buildnumber>~release<buildnumber>@
-- the other simply
-- @vendor<buildnumber>~release<buildnumber>@
-- There are notes from a meeting that explains why ReleaseTagBuild is
-- more future friendly, but it is also more ugly.
data VersionTag
= VersionTag { extraNumber :: Maybe Int -- The number following the "r" (do not
-- use in new applications.)
, vendorTag :: (String, Int) -- The vendor name and build number
, releaseTag :: Maybe (String, Int) -- The release name and build number
} deriving (Show, Eq)
-- | Parse a Debian revision string (the portion of the version number
-- following the final dash) into a prefix and a VersionTag.
parseTag :: String -> DebianVersion -> (DebianVersion, Maybe VersionTag)
parseTag vendor version =
let (e, v, r) = evr version in
let (prefix, tag) =
case r of
Nothing -> (Nothing, Nothing)
Just s ->
case matchRegex re s of
Nothing -> (Just s, Nothing)
Just [prefix1, prefix2, buildNo, "", _, _, _, _] ->
(Just (prefix1 ++ prefix2),
Just (VersionTag { extraNumber = Nothing
, vendorTag = (vendor, read buildNo)
, releaseTag = Nothing }))
Just [prefix1, prefix2, buildNo, _, releaseName, _, _, releaseNo] ->
(Just (prefix1 ++ prefix2),
Just (VersionTag { extraNumber = Nothing
, vendorTag = (vendor, read buildNo)
, releaseTag = Just (releaseName, read releaseNo) }))
Just result -> error $ "Internal error: " ++ show result in
-- Try to parse the r5 from the end of the prefix.
let (prefix', tag') =
case (maybe Nothing (matchRegex extraRE) prefix, tag) of
(Just [prefix1, prefix2, digits], Just tag) ->
(Just (prefix1 ++ prefix2), Just (tag {extraNumber = Just (read digits)}))
_ -> (prefix, tag) in
(buildDebianVersion e v (if prefix' == Just "0" then Nothing else prefix'), tag')
where
re = mkRegex (prefixRE ++ digitsRE ++ vendorRE ++ "(" ++ releaseRE ++ ")?$")
prefixRE = "^(.*[^0-9])?"
digitsRE = "([0-9]+)"
vendorRE = vendor ++ "([0-9]+)"
releaseRE = "~(([^0-9]+)|(bpo[0-9]+\\+))([0-9]+)"
extraRE = mkRegex "^(.*)([0-9]+)r([0-9]+)"
-- | The tag returned by splitTag
getTag :: String -> DebianVersion -> Maybe VersionTag
getTag vendor version = snd (parseTag vendor version)
-- | The prefix returned by splitTag
dropTag :: String -> DebianVersion -> DebianVersion
dropTag vendor version = fst (parseTag vendor version)
-- |Modify a version number by adding or changing the vendor tag. The
-- result will be newer than the distVersion (the newest already
-- uploaded version.) It will also be different from (though not
-- necessarily newer than) any of the elements of allVersions
setTag :: (String -> String)
-- ^ The release name alias function. As an example, this would map
-- the repository etch to the tag bpo40+, as specified by Debian policy.
-> String
-- ^ The vendor tag
-> Maybe String
-- ^ The build release, or Nothing if this is a development release
-> Maybe Int
-- ^ Use old "r0vendor1" format
-> Maybe DebianVersion
-- ^ The newst version that is already present in the dist. We need
-- to generate a version number newer than this.
-> [DebianVersion]
-- ^ All the versions that are currently available in the pool. The
-- result must not be a member of this list.
-> DebianVersion
-- ^ The version number that appears in the newest change log
-- entry of the source package. The result will be this number
-- with a version tag added. If this version is older than the
-- current version with its tag stripped, the package cannot be
-- built.
-> Either String DebianVersion
-- ^ The modified version number
{-setTag alias vendor release extra distVersion allVersions sourceVersion =
error ("vendor=" ++ show vendor ++ ", release=" ++ show release ++ ", extra=" ++ show extra ++ ", distVersion=" ++ show distVersion ++ ", allVersions=" ++ show allVersions ++ ", sourceVersion=" ++ show sourceVersion)-}
setTag alias vendor release extra distVersion allVersions sourceVersion =
let oldTag =
case maybe Nothing (Just . parseTag vendor) distVersion of
Nothing -> Right Nothing
Just (distUpstreamVersion, distTag) ->
case compare sourceUpstreamVersion distUpstreamVersion of
LT -> Left ("Source version " ++ show sourceVersion ++
" is too old to trump uploaded version " ++ show distUpstreamVersion)
GT -> Right Nothing
EQ -> Right distTag in
either Left (Right . appendTag alias sourceUpstreamVersion . Just . findAvailableTag . newTag) oldTag
where
-- The new tag must
-- 1) be newer than the old tag
-- 2) be at least as new as the tag in the source code changelog.
-- 3) have the appropriate releaseTag
-- The oldTag may not have an appropriate releaseTag, because the
-- distribution may have recently switched from development to
-- non-development. In that case we will have to bump the
-- vendor build number, not the release build number, and then
-- add the release tag.
newTag Nothing =
VersionTag {vendorTag = (vendor, 1), releaseTag = maybe Nothing (\ relName -> Just (relName, 1)) release, extraNumber = extra}
newTag (Just distTag) =
let distTag' = fixReleaseName release (bumpTag distTag) in
let sourceTag' = maybe Nothing (Just . setReleaseName release) sourceTag in
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)))
-- Repeatedly increment candidate until it differs from the
-- elements of all. Note that this is not the same as taking
-- the maximum element and incrementing it, the value we want
-- only needs to be not less than candidate.
findAvailableTag :: VersionTag -> VersionTag
findAvailableTag candidate =
if elem candidate allTags then findAvailableTag (bumpTag candidate) else candidate
tagCmp (Just tagA) (Just tagB) =
let (_, a) = vendorTag tagA
(_, b) = vendorTag tagB in
case compare a b of
EQ -> case (releaseTag tagA, releaseTag tagB) of
(Just (_, a), Just (_, b)) -> compare a b
(Nothing, Nothing) -> EQ
(Nothing, _) -> LT
(_, Nothing) -> GT
x -> x
tagCmp Nothing Nothing = EQ
tagCmp Nothing _ = LT
tagCmp _ Nothing = GT
tagMax :: [Maybe VersionTag] -> Maybe VersionTag
tagMax tags = head (sortBy (flip tagCmp) tags)
bumpTag tag@(VersionTag {releaseTag = Just (relName, relBuild)}) = tag {releaseTag = Just (relName, relBuild + 1)}
bumpTag tag@(VersionTag {vendorTag = (name, build), releaseTag = Nothing}) = tag {vendorTag = (name, build + 1)}
-- If one of the version number candidates has the wrong release name
-- this function fixes it, ensuring that the new tag isn't trumped by
-- the old.
fixReleaseName release tag@(VersionTag {vendorTag = (vendorName, vendorBuild)}) =
case (release, releaseTag tag) of
(Just relName, Just (oldRelName, _)) | relName == oldRelName -> tag
-- If the release name doesn't match we need to bump the vendor build
(Just relName, _) -> tag {vendorTag = (vendorName, vendorBuild+1), releaseTag = Just (relName, 1)}
-- Removing an existing release tag always increases the version
(Nothing, Just _) -> tag {releaseTag = Nothing}
(Nothing, Nothing) -> tag {vendorTag = (vendorName, vendorBuild+1)}
-- This is similer to fixReleaseName, but we don't require the result to
-- trump the argument. This is applied to the source package version number,
-- which is not necessarily present in the dist.
setReleaseName release tag =
case (release, releaseTag tag) of
(Just relName, Just (oldRelName, _)) | relName == oldRelName -> tag
(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 }
newTag vendor (Just name) extra = VersionTag { extraNumber = extra, vendorTag = (vendor, 0), releaseTag = Just (name, 1) }
-- | Format a tag as a string.
showTag :: (String -> String) -> VersionTag -> String
showTag alias (VersionTag { extraNumber = extra
, vendorTag = (vendor, vendorBuildNumber)
, releaseTag = releaseInfo }) =
maybe "" (("r" ++) . show) extra ++
vendor ++ show vendorBuildNumber ++
maybe "" (\ (relname, relbuild) -> "~" ++ alias relname ++ show relbuild) releaseInfo
-- | Append a vendor tag to a string containing the revision portion
-- of a debian version number.
appendTag :: (String -> String) -> DebianVersion -> Maybe VersionTag -> DebianVersion
appendTag _ ver Nothing = ver
appendTag alias ver (Just tag) =
case revision ver of
Nothing -> setRevision ver (Just ("0" ++ showTag alias tag))
Just rev -> case matchRegex numericSuffixRE rev of
Just [_, ""] -> setRevision ver (Just (rev ++ "0" ++ showTag alias tag))
Just [_, _] -> setRevision ver (Just (rev ++ showTag alias tag))
_ -> error "internal error"
where numericSuffixRE = mkRegex "^(.*[^0-9])?([0-9]*)$"
-- | Change the revision part of a Debian version number. (This may
-- belong in Debian.Version.)
setRevision :: DebianVersion -> Maybe String -> DebianVersion
setRevision ver rev = buildDebianVersion (epoch ver) (version ver) rev
-- Compare the version seen in the source code changelog to a version
-- seen in the distribution. Since the autobuilder adds tags to the
-- version number of the packages it builds, the distribution version
-- may have been built from the source version even if they differ.
-- Specifically, we must assume that if the version matches when we
-- strip off one or both sections of the tag on the distribution
-- version number.
compareSourceAndDist vendor s d =
let (verS, tagS) = parseTag vendor s
(verD, tagD) = parseTag vendor d in
let venS = maybe Nothing (Just . vendorTag) tagS
venD = maybe Nothing (Just . vendorTag) tagD
relS = maybe Nothing releaseTag tagS
relD = maybe Nothing releaseTag tagD in
case () of
_ | verS /= verD -> compare verS verD
| isNothing venS && isJust venD -> EQ
| isNothing relS && isJust relD -> EQ
| True -> compare s d