{-# LANGUAGE CPP #-}
import Control.Applicative ((<|>)
#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,0))
#else
, (<$>), (<*>)
#endif
)
import Control.Concurrent.Async (concurrently)
import Control.Monad
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.Directory
import System.Directory (doesDirectoryExist, listDirectory)
import System.FilePath ((</>))
-- for warning
import System.IO (hPutStrLn, stderr)
import SimpleCmd (error', {-warning-})
import SimpleCmdArgs
import Paths_pkgtreediff (version)
main :: IO ()
main =
simpleCmdArgs (Just version) "Package tree comparison tool"
"pkgtreediff compares the packages in two OS trees" $
compareDirs <$> recursiveOpt <*> ignoreVR <*> ignoreArch <*> modeOpt <*> strArg "URL/DIR1" <*> strArg "URL/DIR2"
data Mode = AutoSummary | NoSummary | ShowSummary | Added | Deleted | Updated
deriving Eq
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 for >" <> show summaryThreshold <> " changes)") <|>
flagWith AutoSummary NoSummary 'S' "no-summary" "Do not display summary"
ignoreArch :: Parser Bool
ignoreArch = switchWith 'A' "ignore-arch" "Ignore arch differences"
data Ignore = IgnoreNone | IgnoreRelease | IgnoreVersion
deriving Eq
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"
summaryThreshold :: Int
summaryThreshold = 20
compareDirs :: Bool -> Ignore -> Bool -> Mode -> String -> String -> IO ()
compareDirs recursive ignore igArch mode 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!"
let (isUrl1,isUrl2) = (isHttp t1, isHttp t2)
mmgr <- if isUrl1 || isUrl2 then Just <$> httpManager else return Nothing
concurrently (readPackages isUrl1 mmgr t1) (readPackages isUrl2 mmgr t2)
readPackages isUrl mmgr loc = do
fs <- (if isUrl then httpPackages recursive (fromJust mmgr) else dirPackages) loc
let ps = map ((if igArch then binToPkg else id) . readPkg) fs
return $ (if igArch then nub else id) 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 (not <$> \ f -> "/" `T.isPrefixOf` f || "?" `T.isPrefixOf` f || f == "../") <$> httpDirectory mgr url
else error' $ "Could not get " <> url
if recurse && all isDir fs then concatMapM (httpPackages False mgr) (map ((url </>) . T.unpack) fs) else return fs
dirPackages dir = do
fs <- sort <$> listDirectory dir
alldirs <- mapM doesDirectoryExist fs
if recursive && and alldirs then concatMapM dirPackages (map (dir </>) fs) else return $ map T.pack fs
isHttp :: String -> Bool
isHttp loc = "http:" `isPrefixOf` loc || "https:" `isPrefixOf` loc
isDir = ("/" `T.isSuffixOf`)
type Name = Text
type Arch = Text
data VersionRelease = VerRel Text Text
deriving Eq
-- 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
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
-- from simple-cmd-0.2.0
warning :: String -> IO ()
warning = hPutStrLn stderr
-- 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}