[Lsb-messages] /var/www/bzr/lsb/devel/repogen r202: Track package types as its own data type, rather than as strings.
Jeff Licquia
licquia at linuxfoundation.org
Fri Jun 14 18:56:45 UTC 2013
------------------------------------------------------------
revno: 202
committer: Jeff Licquia <licquia at linuxfoundation.org>
branch nick: repogen
timestamp: Fri 2013-06-14 14:56:45 -0400
message:
Track package types as its own data type, rather than as strings.
modified:
Package.hs
-------------- next part --------------
=== modified file 'Package.hs'
--- a/Package.hs 2013-06-14 18:01:26 +0000
+++ b/Package.hs 2013-06-14 18:56:45 +0000
@@ -14,19 +14,24 @@
import Data.Maybe
import Data.List
import Data.List.Split
+import Data.Tuple
import System.FilePath
-- Type definitions
data PackageType = Rpm | Deb deriving (Eq, Show)
+data PackageArch = X86 | IA64 | X86_64 | PPC32 | PPC64 | S390 | S390X |
+ All | Source
+ deriving (Eq, Show)
+
data Package = Package { path :: FilePath,
pkgtype :: PackageType,
name :: String,
epoch :: String,
version :: String,
release :: String,
- arch :: String } deriving (Show)
+ arch :: PackageArch } deriving (Show)
instance Eq Package where
x == y = (pkgtype x == pkgtype y) &&
@@ -36,6 +41,27 @@
(release x == release y) &&
(arch x == arch y)
+-- Manage architecture conversions. Note that Debian does not support
+-- some architectures, and we do not support Debian source packages here.
+
+rpmArchNames = [ (X86, "i486"), (IA64, "ia64"), (PPC32, "ppc"),
+ (PPC64, "ppc64"), (S390, "s390"), (S390X, "s390x"),
+ (X86_64, "x86_64"), (All, "noarch"), (Source, "src") ]
+debArchNames = [ (X86, "i386"), (IA64, "ia64"), (PPC32, "powerpc"),
+ (S390, "s390"), (X86_64, "amd64"), (All, "all") ]
+
+archRpmName :: PackageArch -> String
+archRpmName s = fromJust $ lookup s rpmArchNames
+
+archDebName :: PackageArch -> Maybe String
+archDebName s = lookup s debArchNames
+
+archFromRpm :: String -> Maybe PackageArch
+archFromRpm s = lookup s (map swap rpmArchNames)
+
+archFromDeb :: String -> Maybe PackageArch
+archFromDeb s = lookup s (map swap debArchNames)
+
-- Helper functions for constructing Packages.
hasUnderscore :: String -> Bool
@@ -51,37 +77,34 @@
| otherwise = Nothing
where ext = takeExtension path
-packageArchFromPath :: FilePath -> Maybe String
+packageArchFromPath :: FilePath -> Maybe PackageArch
packageArchFromPath path
| packageTypeFromPath path == Just Deb && hasUnderscore noExtension
- = Just (underscoreToEnd noExtension)
+ = archFromDeb (underscoreToEnd noExtension)
| packageTypeFromPath path == Just Rpm && hasExtension noExtension
- = Just (tail $ takeExtension noExtension)
+ = archFromRpm (tail $ takeExtension noExtension)
| otherwise
= Nothing
where noExtension = dropExtension path
-packageNEVRAFromPath :: FilePath -> Maybe [String]
-packageNEVRAFromPath path
- | pkgtype == Just Deb && '_' `elem` path && isJust arch
+packageNEVRFromPath :: FilePath -> Maybe [String]
+packageNEVRFromPath path
+ | pkgtype == Just Deb && '_' `elem` path
= let deb_elements = splitOn "_" $ takeFileName path
in Just [head $ deb_elements,
"0",
head $ splitOn "-" $ deb_elements !! 1,
- last $ splitOn "-" $ deb_elements !! 1,
- fromJust arch]
- | pkgtype == Just Rpm && '-' `elem` path && isJust arch
+ last $ splitOn "-" $ deb_elements !! 1]
+ | pkgtype == Just Rpm && '-' `elem` path
= let shortFileName = (iterate dropExtension $ takeFileName path) !! 2
rpm_elements = splitOn "-" shortFileName
in Just [intercalate "-" $ init $ init $ rpm_elements,
"0",
last $ init $ rpm_elements,
- last $ rpm_elements,
- fromJust arch]
+ last $ rpm_elements]
| otherwise
= Nothing
where pkgtype = packageTypeFromPath path
- arch = packageArchFromPath path
-- It turns out that names can be tricky. Debian packages have more
-- strict naming requirements than RPMs, so certain names have to be
@@ -113,31 +136,21 @@
packageFromPath :: FilePath -> Maybe Package
packageFromPath path
- | isJust maybeNEVRA && isJust maybePkgType
+ | isJust maybeNEVR && isJust maybePkgType && isJust maybePkgArch
= Just Package {
path=path,
pkgtype=fromJust maybePkgType,
- name=(fromJust maybeNEVRA) !! 0,
- epoch=(fromJust maybeNEVRA) !! 1,
- version=(fromJust maybeNEVRA) !! 2,
- release=(fromJust maybeNEVRA) !! 3,
- arch=(fromJust maybeNEVRA) !! 4 }
+ name=(fromJust maybeNEVR) !! 0,
+ epoch=(fromJust maybeNEVR) !! 1,
+ version=(fromJust maybeNEVR) !! 2,
+ release=(fromJust maybeNEVR) !! 3,
+ arch=fromJust maybePkgArch
+ }
| otherwise
= Nothing
- where maybeNEVRA = packageNEVRAFromPath path
+ where maybeNEVR = packageNEVRFromPath path
maybePkgType = packageTypeFromPath path
-
--- Debian does not support some of the architectures RPM does.
--- These functions report on architecture support.
-
-rpmArchNames = ["i486", "ia64", "ppc", "s390", "x86_64", "noarch"]
-debArchNames = ["i386", "ia64", "powerpc", "s390", "amd64", "all"]
-
-archRpmToDeb :: String -> Maybe String
-archRpmToDeb s = lookup s $ zip rpmArchNames debArchNames
-
-archDebToRpm :: String -> Maybe String
-archDebToRpm s = lookup s $ zip debArchNames rpmArchNames
+ maybePkgArch = packageArchFromPath path
-- We generate Debian packages from RPMs. This function generates
-- information about what a generated Debian package should look like.
@@ -152,9 +165,9 @@
epoch=epoch p,
version=version p,
release=release p,
- arch=fromJust cvtArch }
+ arch=arch p }
| otherwise = Nothing
- where cvtArch = archRpmToDeb $ arch p
+ where cvtArch = archDebName $ arch p
-- Given a Debian package, do the reverse of derivedDeb: figure out
-- which RPM it came from.
@@ -169,8 +182,7 @@
epoch=epoch p,
version=version p,
release=release p,
- arch=maybe debArch id $ archDebToRpm debArch }
- where debArch = arch p
+ arch=arch p }
-- Convert a generic Package to its other type.
@@ -188,9 +200,9 @@
fileNameFromPackage :: Package -> FilePath
fileNameFromPackage p
| pkgtype p == Deb
- = name p ++ "_" ++ version p ++ "-" ++ release p ++ "_" ++ arch p ++ ".deb"
+ = name p ++ "_" ++ version p ++ "-" ++ release p ++ "_" ++ (fromJust $ archDebName $ arch p) ++ ".deb"
| otherwise
- = name p ++ "-" ++ version p ++ "-" ++ release p ++ "." ++ arch p ++ ".rpm"
+ = name p ++ "-" ++ version p ++ "-" ++ release p ++ "." ++ (archRpmName $ arch p) ++ ".rpm"
packageRecalcPath :: Package -> Package
packageRecalcPath p = Package {
More information about the lsb-messages
mailing list