pkgtreediff 0.4 → 0.4.1
raw patch · 8 files changed
+507/−374 lines, 8 filesdep +extradep +kojidep +pkgtreediffsetup-changed
Dependencies added: extra, koji, pkgtreediff
Files
- CHANGELOG.md +6/−0
- Main.hs +0/−324
- README.md +54/−38
- Setup.hs +0/−2
- TODO +2/−2
- pkgtreediff.cabal +22/−8
- src/Distribution/RPM/PackageTreeDiff.hs +171/−0
- src/Main.hs +252/−0
CHANGELOG.md view
@@ -1,5 +1,11 @@ # Changelog +## 0.4.1 (2021-04-19)+- expose a library in Distribution.RPM.PackageTreeDiff (@juhp)+- full correct rpm version comparison (ie handling ^ and ~) (@juhp)+- new koji://tag@koji.hub method (@TristanCacqueray)+- rst summary output format (@TristanCacqueray)+ ## 0.4 (2020-03-13) - support files of lists of rpms - support commands for getting package NVRs
− Main.hs
@@ -1,324 +0,0 @@-{-# LANGUAGE CPP #-}--import Control.Applicative (-#if (defined(MIN_VERSION_simple_cmd_args) && MIN_VERSION_simple_cmd_args(0,1,3))-#else- (<|>),-#endif-#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,0))-#else- (<$>), (<*>)-#endif- )-import Control.Concurrent.Async (concurrently)-import Control.Monad-import Data.Char-import Data.List-import Data.Maybe-#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,11,0))-#else-import Data.Semigroup ((<>))-#endif-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.IO as T--import Network.HTTP.Client (managerResponseTimeout, newManager,- responseTimeoutMicro)-import Network.HTTP.Client.TLS (tlsManagerSettings)-import Network.HTTP.Directory-import System.Directory (doesDirectoryExist, getDirectoryContents)-import System.FilePath ((</>))-import System.FilePath.Glob (compile, match)--#if (defined(MIN_VERSION_simple_cmd) && MIN_VERSION_simple_cmd(0,2,0))-#else--- for warning-import System.IO (hPutStrLn, stderr)-#endif--import SimpleCmd (cmd, error',-#if (defined(MIN_VERSION_simple_cmd) && MIN_VERSION_simple_cmd(0,2,0))- warning-#endif- )-import SimpleCmdArgs--import Paths_pkgtreediff (version)--data Mode = AutoSummary | NoSummary | ShowSummary | Added | Deleted | Updated- deriving Eq--data Ignore = IgnoreNone | IgnoreRelease | IgnoreVersion- deriving Eq--main :: IO ()-main =- simpleCmdArgs (Just version) "Package tree comparison tool"- "pkgtreediff compares the packages in two OS trees or instances" $- compareDirs <$> recursiveOpt <*> ignoreVR <*> ignoreArch <*> modeOpt <*> optional patternOpt <*> timeoutOpt <*> strArg "URL|DIR|FILE|CMD1" <*> strArg "URL|DIR|FILE|CMD2"- where- modeOpt :: Parser Mode- modeOpt =- flagWith' Added 'N' "new" "Show only added packages" <|>- flagWith' Deleted 'D' "deleted" "Show only removed packages" <|>- flagWith' Updated 'U' "updated" "Show only updated packages" <|>- flagWith' ShowSummary 's' "show-summary" ("Show summary of changes (default when >" <> show summaryThreshold <> " changes)") <|>- flagWith AutoSummary NoSummary 'S' "no-summary" "Do not display summary"-- ignoreArch :: Parser Bool- ignoreArch = switchWith 'A' "ignore-arch" "Ignore arch differences"-- ignoreVR :: Parser Ignore- ignoreVR =- flagWith' IgnoreRelease 'R' "ignore-release" "Only show version changes (ignore release)" <|>- flagWith IgnoreNone IgnoreVersion 'V' "ignore-version" "Only show package changes (ignore version-release)"-- recursiveOpt :: Parser Bool- recursiveOpt = switchWith 'r' "recursive" "Recursive down into subdirectories"-- patternOpt :: Parser String- patternOpt = strOptionWith 'p' "pattern" "PKGPATTERN" "Limit packages to glob matches"-- timeoutOpt :: Parser Int- timeoutOpt = optionalWith auto 't' "timeout" "SECONDS" "Maximum seconds to wait for http response before timing out (default 30)" 30--summaryThreshold :: Int-summaryThreshold = 20--data SourceType = URL | Dir | File | Cmd- deriving Eq--sourceType :: String -> IO SourceType-sourceType s =- if isHttp s then return URL- else do- dir <- doesDirectoryExist s- if dir then return Dir- else if ' ' `elem` s then return Cmd- else return File- where- isHttp :: String -> Bool- isHttp loc = "http:" `isPrefixOf` loc || "https:" `isPrefixOf` loc--compareDirs :: Bool -> Ignore -> Bool -> Mode -> Maybe String -> Int -> String -> String -> IO ()-compareDirs recursive ignore igArch mode mpattern timeout tree1 tree2 = do- (ps1,ps2) <- getTrees tree1 tree2- let diff = diffPkgs ignore ps1 ps2- mapM_ T.putStrLn . mapMaybe (showPkgDiff mode) $ diff- when (mode /= NoSummary && isDefault mode) $- when (mode == ShowSummary || length diff > summaryThreshold) $ do- putStrLn ""- putStrLn "Summary"- let diffsum = summary diff- putStrLn $ "Updated: " <> show (updateSum diffsum)- putStrLn $ "Added: " <> show (newSum diffsum)- putStrLn $ "Deleted: " <> show (delSum diffsum)- putStrLn $ "Arch changed: " <> show (archSum diffsum)- putStrLn $ "Total packages: " <> show (length ps1) <> " -> " <> show (length ps2)- where- getTrees :: String -> String -> IO ([Package],[Package])- getTrees t1 t2 = do- when (t1 == t2) $ warning "Comparing the same tree!"- src1 <- sourceType t1- src2 <- sourceType t2- mmgr <- if src1 == URL || src2 == URL- then do- let ms = responseTimeoutMicro $ timeout * 1000000- Just <$> newManager tlsManagerSettings {managerResponseTimeout = ms}- else return Nothing- let act1 = readPackages src1 mmgr t1- act2 = readPackages src2 mmgr t2- if (src1,src2) == (Cmd,Cmd)- then do- ps1 <- act1- ps2 <- act2- return (ps1,ps2)- else concurrently act1 act2-- readPackages source mmgr loc = do- fs <- case source of- URL -> httpPackages True (fromJust mmgr) loc- Dir -> dirPackages True loc- File -> filePackages loc- Cmd -> cmdPackages $ words loc- let ps = map ((if igArch then binToPkg else id) . readPkg) $ filter (maybe (const True) (match . compile) mpattern . T.unpack) fs- return $ sort (nub ps)-- binToPkg :: Package -> Package- binToPkg (Pkg n vr _) = Pkg n vr Nothing-- httpPackages recurse mgr url = do- exists <- httpExists mgr url- fs <- if exists- then filter (\ f -> "/" `T.isSuffixOf` f || ".rpm" `T.isSuffixOf` f) <$> httpDirectory mgr url- else error' $ "Could not get " <> url- if (recurse || recursive) && all isDir fs then concatMapM (httpPackages False mgr) (map ((url </>) . T.unpack) fs) else return $ filter (not . isDir) fs-- dirPackages recurse dir = do- -- can replace with listDirectory after dropping ghc7- -- should really filter out ".rpm" though not common- fs <- sort . filter (".rpm" `isSuffixOf`) <$> getDirectoryContents dir- alldirs <- mapM doesDirectoryExist fs- if (recurse || recursive) && and alldirs then concatMapM (dirPackages False) (map (dir </>) fs) else return $ filter (not . isDir) $ map T.pack fs-- isDir = ("/" `T.isSuffixOf`)-- filePackages file =- filter (not . T.isPrefixOf (T.pack "gpg-pubkey-")) . T.words <$> T.readFile file-- cmdPackages [] = error' "No command prefix given"- cmdPackages (c:args) =- -- use words since container seems to append '\r'- filter (not . T.isPrefixOf (T.pack "gpg-pubkey-")) . T.words . T.pack <$> cmd c args--type Name = Text-type Arch = Text--data VersionRelease = VerRel Text Text- deriving Eq--instance Ord VersionRelease where- compare (VerRel v1 r1) (VerRel v2 r2) =- case rpmVerCompare v1 v2 of- EQ -> rpmVerCompare r1 r2- o -> o--data VerChunk = TxtChunk Text | IntChunk Int- deriving (Eq,Ord)--verChunk :: Text -> VerChunk-verChunk t | T.all isDigit t = (IntChunk . read . T.unpack) t-verChunk t = TxtChunk t--rpmVerCompare :: Text -> Text -> Ordering-rpmVerCompare v1 v2 | v1 == v2 = EQ-rpmVerCompare v1 v2 =- compare (verList v1) (verList v2)- where- verList :: Text -> [VerChunk]- verList = map verChunk . filter (T.all isAlphaNum) . T.groupBy (\ c1 c2 -> generalCategory c1 == generalCategory c2)---- eqVR True ignore release-eqVR :: Ignore -> VersionRelease -> VersionRelease -> Bool-eqVR IgnoreNone vr vr' = vr == vr'-eqVR IgnoreRelease (VerRel v _) (VerRel v' _) = v == v'-eqVR IgnoreVersion _ _ = True--verRel :: Package -> Text-verRel = txtVerRel . pkgVerRel- where- txtVerRel (VerRel v r) = v <> "-" <> r--data Package = Pkg {pkgName :: Name, pkgVerRel :: VersionRelease, pkgMArch :: Maybe Arch}- deriving (Eq, Ord)--pkgIdent :: Package -> Text-pkgIdent p = pkgName p <> appendArch p--pkgDetails :: Package -> Text-pkgDetails p = verRel p <> appendArch p--appendArch :: Package -> Text-appendArch p = maybe "" ("." <>) (pkgMArch p)--showPkg :: Package -> Text-showPkg p = pkgIdent p <> " " <> verRel p--readPkg :: Text -> Package-readPkg t =- if compnts < 3 then error' $ T.unpack $ "Malformed rpm package name: " <> t- else Pkg name (VerRel ver rel) (Just arch)- where- compnts = length pieces- (nvr',arch) = T.breakOnEnd "." $ fromMaybe t $ T.stripSuffix ".rpm" t- pieces = reverse $ T.splitOn "-" $ T.dropEnd 1 nvr'- (rel:ver:emaN) = pieces- name = T.intercalate "-" $ reverse emaN--data PackageDiff = PkgUpdate Package Package- | PkgAdd Package- | PkgDel Package- | PkgArch Package Package- deriving Eq--isDefault :: Mode -> Bool-isDefault m = m `elem` [AutoSummary, NoSummary, ShowSummary]--showPkgDiff :: Mode -> PackageDiff -> Maybe Text-showPkgDiff Added (PkgAdd p) = Just $ showPkg p-showPkgDiff Deleted (PkgDel p) = Just $ showPkg p-showPkgDiff Updated (PkgUpdate p1 p2) = Just $ showPkgUpdate p1 p2-showPkgDiff Updated (PkgArch p1 p2) = Just $ showArchChange p1 p2-showPkgDiff mode (PkgAdd p) | isDefault mode = Just $ "+ " <> showPkg p-showPkgDiff mode (PkgDel p) | isDefault mode = Just $ "- " <> showPkg p-showPkgDiff mode (PkgUpdate p1 p2) | isDefault mode = Just $ showPkgUpdate p1 p2-showPkgDiff mode (PkgArch p1 p2) | isDefault mode = Just $ "! " <> showArchChange p1 p2-showPkgDiff _ _ = Nothing--showPkgUpdate :: Package -> Package -> Text-showPkgUpdate p p' =- pkgIdent p <> ": " <> verRel p <> " -> " <> verRel p'--showArchChange :: Package -> Package -> Text-showArchChange p p' =- pkgName p <> ": " <> pkgDetails p <> " -> " <> pkgDetails p'--diffPkgs :: Ignore -> [Package] -> [Package] -> [PackageDiff]-diffPkgs _ [] [] = []-diffPkgs ignore (p:ps) [] = PkgDel p : diffPkgs ignore ps []-diffPkgs ignore [] (p:ps) = PkgAdd p : diffPkgs ignore [] ps-diffPkgs ignore (p1:ps1) (p2:ps2) =- case compareNames p1 p2 of- LT -> PkgDel p1 : diffPkgs ignore ps1 (p2:ps2)- EQ -> let diff = diffPkg ignore p1 p2- diffs = diffPkgs ignore ps1 ps2- in if isJust diff then fromJust diff : diffs else diffs- GT -> PkgAdd p2 : diffPkgs ignore (p1:ps1) ps2--diffPkg :: Ignore -> Package-> Package-> Maybe PackageDiff-diffPkg ignore p1 p2 | pkgIdent p1 == pkgIdent p2 =- if eqVR ignore (pkgVerRel p1) (pkgVerRel p2)- then Nothing- else Just $ PkgUpdate p1 p2---diffPkg ignore p1 p2 | pkgName p1 == pkgName p2 =--- diffPkg ignore True (Pkg n1 v1) (Pkg n2 v2)-diffPkg _ p1 p2 | pkgName p1 == pkgName p2 && pkgIdent p1 /= pkgIdent p2 = Just $ PkgArch p1 p2-diffPkg _ _ _ = Nothing--compareNames :: Package -> Package -> Ordering-compareNames p1 p2 = compare (pkgName p1) (pkgName p2)---- infixr 4 <.>--- (<.>) :: Text -> Text -> Text--- s <.> t = s <> "." <> t--#if (defined(MIN_VERSION_simple_cmd) && MIN_VERSION_simple_cmd(0,2,0))-#else-warning :: String -> IO ()-warning = hPutStrLn stderr-#endif---- borrowed straight from extra:Control.Monad.Extra--- | A version of 'concatMap' that works with a monadic predicate.-concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]-{-# INLINE concatMapM #-}-concatMapM op = foldr f (return [])- where f x xs = do x' <- op x; if null x' then xs else do xs' <- xs; return $ x'++xs'--data DiffSum = DS {updateSum, newSum, delSum, archSum :: Int}--emptyDS :: DiffSum-emptyDS = DS 0 0 0 0--summary :: [PackageDiff] -> DiffSum-summary =- foldl' countDiff emptyDS- where- countDiff :: DiffSum -> PackageDiff -> DiffSum- countDiff ds pd =- case pd of- PkgUpdate {} -> ds {updateSum = updateSum ds + 1}- PkgAdd _ -> ds {newSum = newSum ds + 1}- PkgDel _ -> ds {delSum = delSum ds + 1}- PkgArch {} -> ds {archSum = archSum ds + 1}
README.md view
@@ -4,28 +4,30 @@ [](LICENSE) [](http://stackage.org/lts/package/pkgtreediff) [](http://stackage.org/nightly/package/pkgtreediff)-[](https://travis-ci.org/juhp/pkgtreediff) `pkgtreediff` compares the NVRs (name-version-release) of RPM packages in OS package trees and/or installations: - An OS tree can be referenced by an url or directory containing a tree of rpm files.-- A file containing a list(s) of rpm NVRs can also be compared+- A file containing a list(s) of rpm NVRs can also be compared. - Commands can also be used to get installed RPMs, eg: - `"rpm -qa"` - `"ssh myhost rpm -qa"` - `"podman run --rm myimage rpm -qa"`+- A koji tag: koji://tag@KojiHubUrl (or koji://tag@fedora) ## Usage examples ### Containers -Compare the content of two rpm based containers (new added packages in fedora:31)+Compare the content of two rpm based containers (new added packages in fedora:34) ```bash session-$ pkgtreediff --new "podman run --rm fedora:30 rpm -qa" "podman run --rm fedora:31 rpm -qa"-libgomp.x86_64 9.2.1-1.fc31-tss2.x86_64 1331-2.fc31-yum.noarch 4.2.9-5.fc31+$ pkgtreediff --new "podman run --rm fedora:33 rpm -qa" "podman run --rm fedora:34 rpm -qa"+dejavu-sans-fonts.noarch 2.37-16.fc34+fonts-filesystem.noarch 2.0.5-5.fc34+langpacks-core-en_GB.noarch 3.0-12.fc34+langpacks-core-font-en.noarch 3.0-12.fc34+langpacks-en_GB.noarch 3.0-12.fc34 ``` ### Package trees@@ -33,42 +35,36 @@ Package source changes between Fedora 30 and 31 Server at GA (ignoring release bumps): ```bash session-$ pkgtreediff --ignore-release https://dl.fedoraproject.org/pub/fedora/linux/releases/{30,31}/Server/source/tree/Packages/-- 389-ds-base.src 1.4.1.2-2.fc30-- GConf2.src 3.2.6-25.fc30-- GeoIP.src 1.6.12-5.fc30-- GeoIP-GeoLite-data.src 2018.06-3.fc30-- ImageMagick.src 6.9.10.28-1.fc30-ModemManager.src: 1.10.0-1.fc30 -> 1.10.6-2.fc31-NetworkManager.src: 1.16.0-1.fc30 -> 1.20.4-1.fc31-- ORBit2.src 2.14.19-21.fc30-- OpenEXR.src 2.2.0-16.fc30+$ pkgtreediff --ignore-release https://dl.fedoraproject.org/pub/fedora/linux/releases/{32,33}/Server/source/tree/Packages/+ModemManager.src: 1.12.8-1.fc32 -> 1.14.2-1.fc33+NetworkManager.src: 1.22.10-1.fc32 -> 1.26.2-2.fc33+PackageKit.src: 1.1.13-2.fc32 -> 1.2.1-1.fc33+abrt.src: 2.14.0-2.fc32 -> 2.14.4-6.fc33+adwaita-icon-theme.src: 3.36.0-1.fc32 -> 3.38.0-1.fc33+alsa-lib.src: 1.2.2-2.fc32 -> 1.2.3.2-5.fc33+alsa-sof-firmware.src: 1.4.2-4.fc32 -> 1.5-2.fc33+anaconda.src: 32.24.7-1.fc32 -> 33.25.4-1.fc33 :-- compface.src 1.5.2-27.fc30-- comps-extras.src 24-5.fc30-+ conmon.src 2.0.1-1.fc31-container-selinux.src: 2.95-1.gite3ebc68.fc30 -> 2.117.0-1.gitbfde70a.fc31-- container-storage-setup.src 0.11.0-5.dev.git413b408.fc30-+ containerd.src 1.2.6-2.20190627gitd68b593.fc31+gobject-introspection.src: 1.64.1-1.fc32 -> 1.66.1-1.fc33++ google-carlito-fonts.src 1.103-0.15.20130920.fc33+- google-crosextra-caladea-fonts.src 1.002-0.14.20130214.fc32+- google-crosextra-carlito-fonts.src 1.103-0.12.20130920.fc32+gpgme.src: 1.13.1-6.fc32 -> 1.14.0-2.fc33 : :-zchunk.src: 1.1.1-3.fc30 -> 1.1.2-3.fc31-zd1211-firmware.src: 1.5-4.fc30 -> 1.5-5.fc31-- zerofree.src 1.1.1-3.fc30-- zfs-fuse.src 0.7.2.2-11.fc30-- zile.src 2.4.14-3.fc30-zip.src: 3.0-24.fc30 -> 3.0-25.fc31-zlib.src: 1.2.11-15.fc30 -> 1.2.11-19.fc31-zram.src: 0.3-1.fc30 -> 0.4-1.fc31-zstd.src: 1.3.8-2.fc30 -> 1.4.2-1.fc31-- zziplib.src 0.13.69-5.fc30+xkeyboard-config.src: 2.29-1.fc32 -> 2.30-3.fc33+xxhash.src: 0.7.3-1.fc32 -> 0.8.0-1.fc33+yelp.src: 3.36.0-1.fc32 -> 3.38.1-1.fc33+yelp-xsl.src: 3.36.0-1.fc32 -> 3.38.1-1.fc33+- zram.src 0.4-1.fc32+zstd.src: 1.4.4-2.fc32 -> 1.4.5-5.fc33 Summary-Updated: 918-Added: 17-Deleted: 765+Updated: 340+Added: 27+Deleted: 32 Arch changed: 0-Total packages: 1690 -> 942+Total packages: 937 -> 932 ``` ### Hosts@@ -81,9 +77,29 @@ Any types of sources can be compared, together with the use of flags. +### Koji++Compare koji tags using the `koji://tag@kojihub` syntax:++```+pkgtreediff koji://dist-c8-updates-build@centos koji://dist-c8_1-updates-build@centos+```++Please avoid using koji tag to compare full releases as it is more efficient to+query URL or CMD trees.+ ## Builds+pkgtreediff is packaged in Fedora. -Builds are available in+Older builds are also available in [copr](https://copr.fedorainfracloud.org/coprs/petersen/pkgtreediff/) for Fedora, EPEL, and OpenSuSE ([more details](https://copr.fedorainfracloud.org/coprs/petersen/pkgtreediff/monitor/detailed)).++## RPM version ordering+RPM version ordering is somewhat involved+<https://blog.jasonantman.com/2014/07/how-yum-and-rpm-compare-versions/>.+For example "1.2.1^rc1" < "1.2.1" (similarly for tilde).++pkgtreediff tries to implement the rpmvercmp() algorithm,+but it has not been verified to behave identically.
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
TODO view
@@ -1,9 +1,9 @@ - compare buildsys list-tagged packages...-- refactor to library - compare with installed packages (--installed?) - deb trees? - compare container images, ostrees - --ignore-disttag - massage fedora mirror urls-+- support epochs in file package list+- diff isos - "--query-format"
pkgtreediff.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: pkgtreediff-version: 0.4+version: 0.4.1 synopsis: Package tree diff tool description: Tool for comparing RPM packages and versions in OS dist trees or instances. homepage: https://github.com/juhp/pkgtreediff@@ -9,38 +9,52 @@ license-file: LICENSE author: Jens Petersen maintainer: juhpetersen@gmail.com-copyright: 2019-2020 Jens Petersen-category: Util+copyright: 2019-2021 Jens Petersen+category: Utility build-type: Simple extra-doc-files: README.md , CHANGELOG.md , TODO-tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5,- GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3+tested-with: GHC == 8.8.4, GHC == 8.10.4,+ GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5 source-repository head type: git location: https://github.com/juhp/pkgtreediff.git executable pkgtreediff- main-is: Main.hs+ main-is: src/Main.hs other-modules: Paths_pkgtreediff build-depends: async , base < 5 , directory+ , extra , filepath+ , koji , Glob , http-client >= 0.5.0 , http-client-tls , http-directory >= 0.1.4 && (< 0.1.6 || >= 0.1.8)+ , pkgtreediff , simple-cmd >= 0.1.4 , simple-cmd-args , text if impl(ghc<8.0) build-depends: semigroups - ghc-options: -Wall+ ghc-options: -Wall -threaded+ default-language: Haskell2010 +library+ build-depends: base < 5+ exposed-modules: Distribution.RPM.PackageTreeDiff+ hs-source-dirs: src++ build-depends: base < 5+ , text+ if impl(ghc<8.0)+ build-depends: semigroups++ ghc-options: -Wall default-language: Haskell2010- default-extensions: OverloadedStrings
+ src/Distribution/RPM/PackageTreeDiff.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++-- | A library for pkgtreediff for comparing trees of rpm packages+module Distribution.RPM.PackageTreeDiff+ (RpmPackage(..),+ readRpmPkg,+ showRpmPkg,+ rpmPkgIdent,+ appendArch,+ dropRpmArch,+ rpmPkgVerRel,+ RpmPackageDiff(..),+ diffPkgs,+ diffPkg,+ Ignore(..),+ Mode(..),+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Data.Char+import Data.Maybe+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup ((<>))+#endif+import Data.Text (Text)+import qualified Data.Text as T++-- | Mode describes the kind of summary generated by compareDirs+data Mode = AutoSummary | NoSummary | ShowSummary | Added | Deleted | Updated | RST+ deriving Eq++-- | Ignore describes how comparison is done+data Ignore = IgnoreNone -- ^ do not ignore version or release+ | IgnoreRelease -- ^ ignore differences in release+ | IgnoreVersion -- ^ ignore differences in version+ deriving Eq++type Name = Text+type Arch = Text++data VersionRelease = VerRel Text Text+ deriving Eq++instance Ord VersionRelease where+ compare (VerRel v1 r1) (VerRel v2 r2) =+ case rpmVerCompare v1 v2 of+ EQ -> rpmVerCompare r1 r2+ o -> o++data VerChunk = TildeChunk Int | CaretChunk Int | TxtChunk Text | IntChunk Int+ deriving (Eq,Ord,Show)++data RpmCharCategory = RpmTilde | RpmCaret | RpmOther | RpmLatin | RpmDigit+ deriving Eq++verChunk :: Text -> VerChunk+verChunk t | T.all isDigit t = (IntChunk . read . T.unpack) t+verChunk t | T.all (== '~') t = (TildeChunk . T.length) t+verChunk t | T.all (== '^') t = (CaretChunk . T.length) t+verChunk t = TxtChunk t++rpmVerCompare :: Text -> Text -> Ordering+rpmVerCompare v1 v2 | v1 == v2 = EQ+rpmVerCompare v1 v2 =+ compareChunks (verList v1) (verList v2)+ where+ compareChunks [] [] = EQ+ compareChunks (c:cs) (c':cs') | c == c' = compareChunks cs cs'+ compareChunks ((TildeChunk n):_) ((TildeChunk n'):_) = compare n' n+ compareChunks ((CaretChunk n):_) ((CaretChunk n'):_) = compare n' n+ compareChunks ((TildeChunk _):_) _ = LT+ compareChunks _ ((TildeChunk _):_) = GT+ compareChunks ((CaretChunk _):_) _ = LT+ compareChunks _ ((CaretChunk _):_) = GT+ compareChunks _ [] = GT+ compareChunks [] _ = LT+ compareChunks (c:_) (c':_) = compare c c'++verList :: Text -> [VerChunk]+verList = map verChunk . filter (T.all (/= '.')) . T.groupBy (\ c1 c2 -> rpmCategory c1 == rpmCategory c2)++latinChars :: [Char]+latinChars = ['A'..'Z'] ++ ['a'..'z']++rpmCategory :: Char -> RpmCharCategory+rpmCategory c | isDigit c = RpmDigit+rpmCategory c | c `elem` latinChars = RpmLatin+rpmCategory '~' = RpmTilde+rpmCategory '^' = RpmCaret+rpmCategory _ = RpmOther++-- eqVR True ignore release+eqVR :: Ignore -> VersionRelease -> VersionRelease -> Bool+eqVR IgnoreNone vr vr' = vr == vr'+eqVR IgnoreRelease (VerRel v _) (VerRel v' _) = v == v'+eqVR IgnoreVersion _ _ = True++-- | Text for the version-release of an RpmPackage+rpmPkgVerRel :: RpmPackage -> Text+rpmPkgVerRel = txtVerRel . rpmVerRel+ where+ txtVerRel (VerRel v r) = v <> T.singleton '-' <> r++-- | RPM package with name, version-release, and maybe architecture+data RpmPackage = RpmPkg {rpmName :: Name, rpmVerRel :: VersionRelease, rpmMArch :: Maybe Arch}+ deriving (Eq, Ord)++-- | Text identifier for an RPM package identified by name and arch+rpmPkgIdent :: RpmPackage -> Text+rpmPkgIdent p = rpmName p <> appendArch p++-- | Helper to add an arch suffix+appendArch :: RpmPackage -> Text+appendArch p = maybe "" ("." <>) (rpmMArch p)++-- | drop arch from RpmPackage+dropRpmArch :: RpmPackage -> RpmPackage+dropRpmArch (RpmPkg n vr _) = RpmPkg n vr Nothing++-- | Render an RpmPackage+showRpmPkg :: RpmPackage -> Text+showRpmPkg p = rpmPkgIdent p <> T.pack " " <> rpmPkgVerRel p++-- | Parse an RpmPackage+readRpmPkg :: Text -> RpmPackage+readRpmPkg t =+ if compnts < 3 then error $ "Malformed rpm package name: " ++ T.unpack t+ else RpmPkg name (VerRel ver rel) (Just arch)+ where+ compnts = length pieces+ (nvr',arch) = T.breakOnEnd "." $ fromMaybe t $ T.stripSuffix ".rpm" t+ pieces = reverse $ T.splitOn "-" $ T.dropEnd 1 nvr'+ (rel:ver:emaN) = pieces+ name = T.intercalate "-" $ reverse emaN++-- | RpmPackageDiff type encodes how a particular rpm package differs between trees+data RpmPackageDiff = PkgUpdate RpmPackage RpmPackage+ | PkgAdd RpmPackage+ | PkgDel RpmPackage+ | PkgArch RpmPackage RpmPackage+ deriving Eq++-- | Compare two lists of packages NVRs+diffPkgs :: Ignore -> [RpmPackage] -> [RpmPackage] -> [RpmPackageDiff]+diffPkgs _ [] [] = []+diffPkgs ignore (p:ps) [] = PkgDel p : diffPkgs ignore ps []+diffPkgs ignore [] (p:ps) = PkgAdd p : diffPkgs ignore [] ps+diffPkgs ignore (p1:ps1) (p2:ps2) =+ case compareNames p1 p2 of+ LT -> PkgDel p1 : diffPkgs ignore ps1 (p2:ps2)+ EQ -> let diff = diffPkg ignore p1 p2+ diffs = diffPkgs ignore ps1 ps2+ in if isJust diff then fromJust diff : diffs else diffs+ GT -> PkgAdd p2 : diffPkgs ignore (p1:ps1) ps2++-- | Compare two rpms of a package+diffPkg :: Ignore -> RpmPackage-> RpmPackage-> Maybe RpmPackageDiff+diffPkg ignore p1 p2 | rpmPkgIdent p1 == rpmPkgIdent p2 =+ if eqVR ignore (rpmVerRel p1) (rpmVerRel p2)+ then Nothing+ else Just $ PkgUpdate p1 p2+--diffPkg ignore p1 p2 | rpmName p1 == rpmName p2 =+-- diffPkg ignore True (RpmPkg n1 v1) (RpmPkg n2 v2)+diffPkg _ p1 p2 | rpmName p1 == rpmName p2 && rpmPkgIdent p1 /= rpmPkgIdent p2 = Just $ PkgArch p1 p2+diffPkg _ _ _ = Nothing++compareNames :: RpmPackage -> RpmPackage -> Ordering+compareNames p1 p2 = compare (rpmName p1) (rpmName p2)
+ src/Main.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++import Control.Applicative (+#if !MIN_VERSION_simple_cmd_args(0,1,3)+ (<|>),+#endif+#if !MIN_VERSION_base(4,8,0)+ (<$>), (<*>)+#endif+ )+import Control.Concurrent.Async (concurrently)+import Control.Monad+import Control.Monad.Extra (concatMapM)+import Data.List+import Data.Maybe+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup ((<>))+#endif+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Network.HTTP.Client (managerResponseTimeout, newManager,+ responseTimeoutMicro)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Directory+import SimpleCmdArgs+import System.Directory (doesDirectoryExist, getDirectoryContents)+import System.FilePath ((</>))+import System.FilePath.Glob (compile, match)+#if !MIN_VERSION_simple_cmd(0,2,0)+-- for warning+import System.IO (hPutStrLn, stderr)+#endif++import SimpleCmd (cmd, error',+#if MIN_VERSION_simple_cmd(0,2,0)+ warning+#endif+ )++import qualified Distribution.Koji as Koji++import Distribution.RPM.PackageTreeDiff+import Paths_pkgtreediff (version)++main :: IO ()+main =+ simpleCmdArgs (Just version) "Package tree comparison tool"+ "pkgtreediff compares the packages in two OS trees or instances" $+ compareDirs <$> recursiveOpt <*> ignoreVR <*> ignoreArch <*> modeOpt <*> optional patternOpt <*> timeoutOpt <*> sourceArg "1" <*> sourceArg "2"+ where+ sourceArg :: String -> Parser String+ sourceArg pos = strArg ("URL|DIR|FILE|KOJITAG|CMD" <> pos)++ modeOpt :: Parser Mode+ modeOpt =+ flagWith' Added 'N' "new" "Show only added packages" <|>+ flagWith' Deleted 'D' "deleted" "Show only removed packages" <|>+ flagWith' Updated 'U' "updated" "Show only updated packages" <|>+ flagWith' ShowSummary 's' "show-summary" ("Show summary of changes (default when >" <> show summaryThreshold <> " changes)") <|>+ flagWith' RST 'R' "rst" "Print summary in ReSTructured Text format" <|>+ flagWith AutoSummary NoSummary 'S' "no-summary" "Do not display summary"++ ignoreArch :: Parser Bool+ ignoreArch = switchWith 'A' "ignore-arch" "Ignore arch differences"++ ignoreVR :: Parser Ignore+ ignoreVR =+ flagWith' IgnoreRelease 'R' "ignore-release" "Only show version changes (ignore release)" <|>+ flagWith IgnoreNone IgnoreVersion 'V' "ignore-version" "Only show package changes (ignore version-release)"++ recursiveOpt :: Parser Bool+ recursiveOpt = switchWith 'r' "recursive" "Recursive down into subdirectories"++ patternOpt :: Parser String+ patternOpt = strOptionWith 'p' "pattern" "PKGPATTERN" "Limit packages to glob matches"++ timeoutOpt :: Parser Int+ timeoutOpt = optionalWith auto 't' "timeout" "SECONDS" "Maximum seconds to wait for http response before timing out (default 30)" 30++-- | The threshold for the number of differences for compareDirs to auto-output a summary+summaryThreshold :: Int+summaryThreshold = 20++data SourceType = URL | Tag | Dir | File | Cmd+ deriving Eq++-- >>> kojiUrlTag "koji://tag@fedora"+-- Just ("tag", "https://koji.fedoraproject.org/kojihub")+kojiUrlTag :: String -> Maybe (String, String)+kojiUrlTag s = if not (isKojiScheme s)+ then Nothing+ else case elemIndex '@' s of+ Just pos -> Just (drop (length kojiScheme) $ take pos s, hubUrl $ drop (pos+1) s)+ Nothing -> Nothing+ where+ kojiScheme = "koji://"+ isKojiScheme loc = kojiScheme `isPrefixOf` loc+ hubUrl "fedora" = Koji.fedoraKojiHub+ hubUrl "centos" = Koji.centosKojiHub+ hubUrl loc = loc++sourceType :: String -> IO SourceType+sourceType s+ | isHttp s = return URL+ | isKoji s = return Tag+ | otherwise = do+ dir <- doesDirectoryExist s+ if dir then return Dir+ else if ' ' `elem` s then return Cmd+ else return File+ where+ isKoji :: String -> Bool+ isKoji loc = isJust (kojiUrlTag loc)+ isHttp :: String -> Bool+ isHttp loc = "http:" `isPrefixOf` loc || "https:" `isPrefixOf` loc++-- | Frontend for the pkgtreediff tool+compareDirs :: Bool -> Ignore -> Bool -> Mode -> Maybe String -> Int -> String -> String -> IO ()+compareDirs recursive ignore igArch mode mpattern timeout tree1 tree2 = do+ (ps1,ps2) <- getTrees tree1 tree2+ let diff = diffPkgs ignore ps1 ps2+ if mode /= RST+ then mapM_ T.putStrLn . mapMaybe (showPkgDiff mode) $ diff+ else printRST diff+ when (mode /= NoSummary && isDefault mode) $+ when (mode == ShowSummary || length diff > summaryThreshold) $ do+ putStrLn ""+ (if mode /= RST then putStrLn else printRSTHeader) "Summary"+ let diffsum = summary diff+ putStrLn $ "Updated: " <> show (updateSum diffsum)+ putStrLn $ "Added: " <> show (newSum diffsum)+ putStrLn $ "Deleted: " <> show (delSum diffsum)+ putStrLn $ "Arch changed: " <> show (archSum diffsum)+ putStrLn $ "Total packages: " <> show (length ps1) <> " -> " <> show (length ps2)+ where+ printRSTHeader name = do+ putStrLn ""+ putStrLn name+ putStrLn $ replicate (length name) '~'+ putStrLn ""+ printRSTElem = T.putStrLn . mappend "- "+ printRSTDiffElem = printRSTElem . T.drop 2+ printRST diff = do+ printRSTHeader "Updated"+ mapM_ printRSTElem $ mapMaybe (showPkgDiff mode) [x | x@(PkgUpdate _ _) <- diff]+ printRSTHeader "Added"+ mapM_ printRSTDiffElem $ mapMaybe (showPkgDiff mode) [x | x@(PkgAdd _) <- diff]+ printRSTHeader "Removed"+ mapM_ printRSTDiffElem $ mapMaybe (showPkgDiff mode) [x | x@(PkgDel _) <- diff]+ getTrees :: String -> String -> IO ([RpmPackage],[RpmPackage])+ getTrees t1 t2 = do+ when (t1 == t2) $ warning "Comparing the same tree!"+ src1 <- sourceType t1+ src2 <- sourceType t2+ mmgr <- if src1 == URL || src2 == URL+ then do+ let ms = responseTimeoutMicro $ timeout * 1000000+ Just <$> newManager tlsManagerSettings {managerResponseTimeout = ms}+ else return Nothing+ let act1 = readPackages src1 mmgr t1+ act2 = readPackages src2 mmgr t2+ if (src1,src2) == (Cmd,Cmd)+ then do+ ps1 <- act1+ ps2 <- act2+ return (ps1,ps2)+ else concurrently act1 act2++ readPackages source mmgr loc = do+ fs <- case source of+ URL -> httpPackages True (fromJust mmgr) loc+ Tag -> kojiPackages (fromJust (kojiUrlTag loc))+ Dir -> dirPackages True loc+ File -> filePackages loc+ Cmd -> cmdPackages $ words loc+ let ps = map ((if igArch then dropRpmArch else id) . readRpmPkg) $ filter (maybe (const True) (match . compile) mpattern . T.unpack) fs+ return $ sort (nub ps)++ httpPackages recurse mgr url = do+ exists <- httpExists mgr url+ fs <- if exists+ then filter (\ f -> "/" `T.isSuffixOf` f || ".rpm" `T.isSuffixOf` f) <$> httpDirectory mgr url+ else error' $ "Could not get " <> url+ if (recurse || recursive) && all isDir fs then concatMapM (httpPackages False mgr) (map ((url </>) . T.unpack) fs) else return $ filter (not . isDir) fs++ dirPackages recurse dir = do+ -- can replace with listDirectory after dropping ghc7+ -- should really filter out ".rpm" though not common+ fs <- sort . filter (".rpm" `isSuffixOf`) <$> getDirectoryContents dir+ alldirs <- mapM doesDirectoryExist fs+ if (recurse || recursive) && and alldirs then concatMapM (dirPackages False) (map (dir </>) fs) else return $ filter (not . isDir) $ map T.pack fs++ isDir = ("/" `T.isSuffixOf`)++ filePackages file =+ filter (not . T.isPrefixOf (T.pack "gpg-pubkey-")) . T.words <$> T.readFile file++ cmdPackages [] = error' "No command prefix given"+ cmdPackages (c:args) =+ -- use words since container seems to append '\r'+ filter (not . T.isPrefixOf (T.pack "gpg-pubkey-")) . T.words . T.pack <$> cmd c args++ kojiPackages (tag, kojiUrl) = map (T.pack . Koji.kbNvr) <$> Koji.kojiListTaggedBuilds kojiUrl True tag++isDefault :: Mode -> Bool+isDefault m = m `elem` [AutoSummary, NoSummary, ShowSummary, RST]++showPkgDiff :: Mode -> RpmPackageDiff -> Maybe Text+showPkgDiff Added (PkgAdd p) = Just $ showRpmPkg p+showPkgDiff Deleted (PkgDel p) = Just $ showRpmPkg p+showPkgDiff Updated (PkgUpdate p1 p2) = Just $ showPkgUpdate p1 p2+showPkgDiff Updated (PkgArch p1 p2) = Just $ showArchChange p1 p2+showPkgDiff mode (PkgAdd p) | isDefault mode = Just $ "+ " <> showRpmPkg p+showPkgDiff mode (PkgDel p) | isDefault mode = Just $ "- " <> showRpmPkg p+showPkgDiff mode (PkgUpdate p1 p2) | isDefault mode = Just $ showPkgUpdate p1 p2+showPkgDiff mode (PkgArch p1 p2) | isDefault mode = Just $ "! " <> showArchChange p1 p2+showPkgDiff _ _ = Nothing++showPkgUpdate :: RpmPackage -> RpmPackage -> Text+showPkgUpdate p p' =+ rpmPkgIdent p <> ": " <> rpmPkgVerRel p <> " -> " <> rpmPkgVerRel p'++showArchChange :: RpmPackage -> RpmPackage -> Text+showArchChange p p' =+ rpmName p <> ": " <> rpmDetails p <> " -> " <> rpmDetails p'+ where+ rpmDetails :: RpmPackage -> Text+ rpmDetails pkg = rpmPkgVerRel pkg <> appendArch pkg++data DiffSum = DS {updateSum, newSum, delSum, archSum :: Int}++emptyDS :: DiffSum+emptyDS = DS 0 0 0 0++summary :: [RpmPackageDiff] -> DiffSum+summary =+ foldl' countDiff emptyDS+ where+ countDiff :: DiffSum -> RpmPackageDiff -> DiffSum+ countDiff ds pd =+ case pd of+ PkgUpdate {} -> ds {updateSum = updateSum ds + 1}+ PkgAdd _ -> ds {newSum = newSum ds + 1}+ PkgDel _ -> ds {delSum = delSum ds + 1}+ PkgArch {} -> ds {archSum = archSum ds + 1}++#if !MIN_VERSION_simple_cmd(0,2,0)+warning :: String -> IO ()+warning = hPutStrLn stderr+#endif