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
data VersionTag
= VersionTag { extraNumber :: Maybe Int
, vendorTag :: (String, Int)
, releaseTag :: Maybe (String, Int)
} deriving (Show, Eq)
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
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]+)"
getTag :: String -> DebianVersion -> Maybe VersionTag
getTag vendor version = snd (parseTag vendor version)
dropTag :: String -> DebianVersion -> DebianVersion
dropTag vendor version = fst (parseTag vendor version)
setTag :: (String -> String)
-> String
-> Maybe String
-> Maybe Int
-> Maybe DebianVersion
-> [DebianVersion]
-> DebianVersion
-> Either String DebianVersion
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
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
(sourceUpstreamVersion, sourceTag) = parseTag vendor sourceVersion
allTags = catMaybes (map snd (filter (\ (v, _) -> v == sourceUpstreamVersion) (map (parseTag vendor) allVersions)))
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)}
fixReleaseName release tag@(VersionTag {vendorTag = (vendorName, vendorBuild)}) =
case (release, releaseTag tag) of
(Just relName, Just (oldRelName, _)) | relName == oldRelName -> tag
(Just relName, _) -> tag {vendorTag = (vendorName, vendorBuild+1), releaseTag = Just (relName, 1)}
(Nothing, Just _) -> tag {releaseTag = Nothing}
(Nothing, Nothing) -> tag {vendorTag = (vendorName, vendorBuild+1)}
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}
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) }
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
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]*)$"
setRevision :: DebianVersion -> Maybe String -> DebianVersion
setRevision ver rev = buildDebianVersion (epoch ver) (version ver) rev
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