select-rpms (empty) → 0.1.0
raw patch · 5 files changed
+475/−0 lines, 5 filesdep +Globdep +basedep +directory
Dependencies added: Glob, base, directory, extra, filepath, rpm-nvr, safe, simple-cmd, simple-cmd-args, simple-prompt
Files
- ChangeLog.md +5/−0
- LICENSE +21/−0
- README.md +16/−0
- select-rpms.cabal +57/−0
- src/SelectRPMs.hs +376/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Release history for select-rpms++## 0.1.0 (2024-08-14)+- initial release for fbrnch and koji-tool+- original code was taken from koji-tool Install
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2024 Jens Petersen++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,16 @@+# select-rpms++A Haskell library for selecting a subset of RPM (sub)packages.++Most of the code originated in koji-tool Install.hs.++See the library haddock documentation and usage in+[koji-tool](https://hackage.haskell.org/package/koji-tool)+and [fbrnch](https://hackage.haskell.org/package/fbrnch) for examples.+++## Contribute++select-rpms is distributed under the MIT license.++See https://github.com/juhp/select-rpms
+ select-rpms.cabal view
@@ -0,0 +1,57 @@+cabal-version: 2.2+name: select-rpms+version: 0.1.0+synopsis: Select a subset of RPM packages+description:+ A library for selecting a subset of RPM (sub)packages.+license: MIT+license-file: LICENSE+author: Jens Petersen <juhpetersen@gmail.com>+maintainer: Jens Petersen <juhpetersen@gmail.com>+copyright: 2024 Jens Petersen <juhpetersen@gmail.com>+category: Distribution+homepage: https://github.com/juhp/select-rpms+bug-reports: https://github.com/juhp/select-rpms/issues+build-type: Simple+extra-doc-files: README.md+ ChangeLog.md+tested-with: GHC == 8.10.7+ || == 9.0.2+ || == 9.2.8+ || == 9.4.8+ || == 9.6.6+ || == 9.8.2++source-repository head+ type: git+ location: https://github.com/juhp/select-rpms.git++library+ build-depends: base < 5,+ directory,+ extra >= 1.7.11,+ filepath,+ Glob,+ rpm-nvr,+ safe,+ simple-cmd,+ simple-cmd-args >= 0.1.8,+ simple-prompt >= 0.2+ default-language: Haskell2010+ exposed-modules: SelectRPMs+ hs-source-dirs: src++ ghc-options: -Wall+ if impl(ghc >= 8.0)+ ghc-options: -Wcompat+ -Widentities+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wredundant-constraints+ if impl(ghc >= 8.2)+ ghc-options: -fhide-source-paths+ if impl(ghc >= 8.4)+ ghc-options: -Wmissing-export-lists+ -Wpartial-fields+ if impl(ghc >= 8.10)+ ghc-options: -Wunused-packages
+ src/SelectRPMs.hs view
@@ -0,0 +1,376 @@+{-# LANGUAGE TupleSections #-}++module SelectRPMs (+ Select(..),+ selectDefault,+ selectRpmsOption,+ installArgs,+ checkSelection,+ rpmsToNVRAs,+ Existence(..),+ ExistNVRA,+ Yes(..),+ ExistingStrategy(..),+ decideRPMs,+ nvraToRPM,+ groupOnArch,+ PkgMgr(..),+ installRPMs+ )+where++import Control.Monad.Extra (forM_, mapMaybeM, unless, when)+import Data.Either (partitionEithers)+import Data.List.Extra (foldl', groupOnKey, isInfixOf, nubOrd, nubSort, sort,+ (\\))+import Data.RPM.NVRA (NVRA(..), readNVRA, showNVRA)+import Safe (headMay)+import SimpleCmd (cmd_, cmdMaybe, error', sudo_, (+-+))+import SimpleCmdArgs (Parser, flagLongWith', many, strOptionWith, (<|>))+import SimplePrompt (yesNoDefault)+import System.Directory+import System.FilePath ((</>), (<.>))+import System.FilePath.Glob (compile, isLiteral, match)++-- | The Select type specifies the subpackage selection+data Select = All -- ^ all packages+ | Ask -- ^ interactive prompting+ | PkgsReq+ [String] -- ^ include matches+ [String] -- ^ except matches+ [String] -- ^ exclude+ [String] -- ^ added+ deriving Eq++-- | default package selection+selectDefault :: Select+selectDefault = PkgsReq [] [] [] []++-- | optparse-applicative Parser for Select+selectRpmsOption :: Parser Select+selectRpmsOption =+ flagLongWith' All "all" "all subpackages [default if not installed]" <|>+ flagLongWith' Ask "ask" "ask for each subpackage" <|>+ PkgsReq+ <$> many (strOptionWith 'p' "package" "SUBPKG" "select subpackage (glob) matches")+ <*> many (strOptionWith 'e' "except" "SUBPKG" "select subpackages not matching (glob)")+ <*> many (strOptionWith 'x' "exclude" "SUBPKG" "deselect subpackage (glob): overrides -p and -e")+ <*> many (strOptionWith 'i' "include" "SUBPKG" "additional subpackage (glob) to install: overrides -x")++-- | alternative CLI args option parsing to Select packages+installArgs :: String -> Select+installArgs cs =+ case words cs of+ ["-a"] -> All+ ["--all"] -> All+ ["-A"] -> Ask+ ["--ask"] -> Ask+ ws -> installPairs [] [] [] [] ws+ where+ installPairs :: [String] -> [String] -> [String] -> [String]+ -> [String] -> Select+ installPairs incl except excl add [] = PkgsReq incl except excl add+ installPairs incl except excl add (w:ws)+ | w `elem` ["-p","--package"] =+ case ws of+ [] -> error' "--install opts: --package missing value"+ (w':ws') -> checkPat w' $+ installPairs (w':incl) except excl add ws'+ | w `elem` ["-e","--except"] =+ case ws of+ [] -> error' "--install opts: --except missing value"+ (w':ws') -> checkPat w' $+ installPairs incl (w':except) excl add ws'+ | w `elem` ["-x","--exclude"] =+ case ws of+ [] -> error' "--install opts: --exclude missing value"+ (w':ws') -> checkPat w' $+ installPairs incl except (w':excl) add ws'+ | w `elem` ["-i","--include"] =+ case ws of+ [] -> error' "--install opts: --include missing value"+ (w':ws') -> checkPat w' $+ installPairs incl except excl (w':add) ws'+ | otherwise = error' "invalid --install opts"++ checkPat w' f =+ if null w'+ then error' "empty pattern!"+ else f++-- FIXME explain if/why this is actually needed (used by koji-tool install)+-- | check package Select is not empty+checkSelection :: Monad m => Select -> m ()+checkSelection (PkgsReq ps es xs is) =+ forM_ (ps ++ es ++ xs ++ is) $ \s ->+ when (null s) $ error' "empty package pattern not allowed"+checkSelection _ = return ()++-- | converts a list of RPM files to NVRA's, filtering out debug subpackages+rpmsToNVRAs :: [String] -> [NVRA]+rpmsToNVRAs = sort . map readNVRA . filter notDebugPkg++-- | how to handle already installed packages: re-install or skip+data ExistingStrategy = ExistingNoReinstall | ExistingSkip++-- | sets prompt default behaviour for yes/no questions+data Yes = No | Yes+ deriving Eq++-- | current state of a package NVR+data Existence = ExistingNVR -- ^ NVR is already installed+ | ChangedNVR -- ^ NVR is different to installed package+ | NotInstalled -- ^ package is not currently installed+ deriving (Eq, Ord, Show)++-- | combines Existence state with an NVRA+type ExistNVRA = (Existence, NVRA)++-- FIXME determine and add missing internal deps+-- | decide list of NVRs based on a Select selection (using a package prefix)+decideRPMs :: Yes -- ^ prompt default choice+ -> Bool -- ^ enable list mode which just display the package list+ -> Maybe ExistingStrategy -- ^ optional existing install strategy+ -> Select -- ^ specifies package Select choices+ -> String -- ^ package set prefix: allows abbreviated Select+ -> [NVRA] -- ^ list of packages to select from+ -> IO [ExistNVRA] -- ^ returns list of selected packages+decideRPMs yes listmode mstrategy select prefix nvras = do+ classified <- mapMaybeM installExists (filter isBinaryRpm nvras)+ if listmode+ then do+ case select of+ PkgsReq subpkgs exceptpkgs exclpkgs addpkgs ->+ mapM_ printInstalled $+ selectRPMs prefix (subpkgs,exceptpkgs,exclpkgs,addpkgs) classified+ _ -> mapM_ printInstalled classified+ return []+ else+ case select of+ All -> promptPkgs yes classified+ Ask -> mapMaybeM (rpmPrompt yes) classified+ PkgsReq subpkgs exceptpkgs exclpkgs addpkgs ->+ promptPkgs yes $+ selectRPMs prefix (subpkgs,exceptpkgs,exclpkgs,addpkgs) classified+ where+ installExists :: NVRA -> IO (Maybe ExistNVRA)+ installExists nvra = do+ -- FIXME this will fail for noarch changes+ -- FIXME check kernel+ minstalled <- cmdMaybe "rpm" ["-q", rpmName nvra <.> rpmArch nvra]+ let existence =+ case minstalled of+ Nothing -> NotInstalled+ Just installed ->+ if showNVRA nvra `elem` lines installed+ then ExistingNVR+ else ChangedNVR+ return $+ case mstrategy of+ Just ExistingSkip | existence /= NotInstalled -> Nothing+ Just ExistingNoReinstall | existence == ExistingNVR -> Nothing+ _ -> Just (existence, nvra)++-- FIXME move to submodule?+selectRPMs :: String+ -- (subpkgs,except,exclpkgs,addpkgs)+ -> ([String],[String],[String],[String])+ -> [ExistNVRA] -> [ExistNVRA]+selectRPMs prefix (subpkgs,exceptpkgs,exclpkgs,addpkgs) rpms =+ let excluded = matchingRPMs prefix exclpkgs rpms+ included = matchingRPMs prefix addpkgs rpms+ matching =+ if null subpkgs && null exceptpkgs+ then defaultRPMs rpms+ else matchingRPMs prefix subpkgs rpms+ nonmatching = nonMatchingRPMs prefix exceptpkgs rpms+ in nubSort $ ((matching ++ nonmatching) \\ excluded) ++ included++isBinaryRpm :: NVRA -> Bool+isBinaryRpm = (/= "src") . rpmArch++renderInstalled :: ExistNVRA -> String+renderInstalled (exist, nvra) =+ case exist of+ ExistingNVR -> '='+ ChangedNVR -> '^'+ NotInstalled -> '+'+ : showNVRA nvra++printInstalled :: ExistNVRA -> IO ()+printInstalled = putStrLn . renderInstalled++promptPkgs :: Yes -> [ExistNVRA]+ -> IO [ExistNVRA]+promptPkgs _ [] = error' "no rpms found"+promptPkgs yes classified = do+ mapM_ printInstalled classified+ ok <- prompt yes "install above"+ return $ if ok then classified else []++prompt :: Yes -> String -> IO Bool+prompt yes str = do+ if yes == Yes+ then return True+ else yesNoDefault True str++rpmPrompt :: Yes -> ExistNVRA -> IO (Maybe ExistNVRA)+rpmPrompt yes epn = do+ ok <- prompt yes $ renderInstalled epn+ return $+ if ok+ then Just epn+ else Nothing++defaultRPMs :: [ExistNVRA] -> [ExistNVRA]+defaultRPMs rpms =+ let installed = filter ((/= NotInstalled) . fst) rpms+ in if null installed+ then rpms+ else installed++matchingRPMs :: String -> [String] -> [ExistNVRA] -> [ExistNVRA]+matchingRPMs prefix subpkgs rpms =+ nubSort . mconcat $+ flip map (nubOrd subpkgs) $ \ pkgpat ->+ case getMatches pkgpat of+ [] -> if headMay pkgpat /= Just '*'+ then+ case getMatches (prefix ++ '-' : pkgpat) of+ [] -> error' $ "no subpackage match for " ++ pkgpat+ result -> result+ else error' $ "no subpackage match for " ++ pkgpat+ result -> result+ where+ getMatches :: String -> [ExistNVRA]+ getMatches pkgpat =+ filter (match (compile pkgpat) . rpmName . snd) rpms++nonMatchingRPMs :: String -> [String] -> [ExistNVRA] -> [ExistNVRA]+nonMatchingRPMs _ [] _ = []+nonMatchingRPMs prefix subpkgs rpms =+ -- FIXME somehow determine unused excludes+ nubSort $ foldl' (exclude (nubOrd subpkgs)) [] rpms+ where+ rpmnames = map (rpmName . snd) rpms++ exclude :: [String] -> [ExistNVRA] -> ExistNVRA+ -> [ExistNVRA]+ exclude [] acc rpm = acc ++ [rpm]+ exclude (pat:pats) acc rpm =+ if checkMatch (rpmName (snd rpm))+ then acc+ else exclude pats acc rpm+ where+ checkMatch :: String -> Bool+ checkMatch rpmname =+ let comppat = compile pat+ in if isLiteral comppat+ then pat == rpmname ||+ pat `notElem` rpmnames &&+ (prefix ++ '-' : pat) == rpmname+ else match comppat rpmname++notDebugPkg :: String -> Bool+notDebugPkg p =+ not ("-debuginfo-" `isInfixOf` p || "-debugsource-" `isInfixOf` p)++-- | whether a package needs to be reinstalled or installed+data InstallType = ReInstall+ | Install++-- | package manager+data PkgMgr = DNF3 | DNF5 | RPM | OSTREE+ deriving Eq++-- FIXME support options per build: install ibus imsettings -i plasma+-- (or don't error if multiple packages)+-- | do installation of packages+installRPMs :: Bool -- ^ dry-run+ -> Bool -- ^ debug output+ -> Maybe PkgMgr -- ^ optional specify package manager+ -> Yes -- ^ prompt default choice+ -> [(FilePath,[ExistNVRA])] -- ^ list of rpms to install with path+ -> IO ()+installRPMs _ _ _ _ [] = return ()+installRPMs dryrun debug mmgr yes classifieds = do+ case installTypes (concatMap zipDir classifieds) of+ ([],is) -> doInstall Install is+ (ris,is) -> do+ doInstall ReInstall (ris ++ is) -- include any new deps+ doInstall Install is -- install any non-deps+ where+ zipDir :: (FilePath,[ExistNVRA]) -> [(FilePath,ExistNVRA)]+ zipDir (dir, rpms) = map (dir,) rpms++ installTypes :: [(FilePath,ExistNVRA)]+ -> ([(FilePath,NVRA)],[(FilePath,NVRA)])+ installTypes = partitionEithers . map partExist+ where+ partExist :: (FilePath,ExistNVRA)+ -> Either (FilePath,NVRA) (FilePath,NVRA)+ partExist (d,(e,n)) = (if e == ExistingNVR then Left else Right) (d,n)++ doInstall :: InstallType -> [(FilePath,NVRA)] -> IO ()+ doInstall inst dirpkgs =+ unless (null dirpkgs) $ do+ mgr <-+ case mmgr of+ Just m -> return m+ Nothing -> do+ ostree <- doesDirectoryExist "/sysroot/ostree"+ if ostree+ then return OSTREE+ else do+ mdnf5 <- findExecutable "dnf5"+ return $ maybe DNF3 (const DNF5) mdnf5+ let pkgmgr =+ case mgr of+ DNF3 -> "dnf-3"+ DNF5 -> "dnf5"+ RPM -> "rpm"+ OSTREE -> "rpm-ostree"+ com =+ case inst of+ ReInstall -> reinstallCommand mgr+ Install -> installCommand mgr+ in+ if dryrun+ then mapM_ putStrLn $ ("would" +-+ unwords (pkgmgr : com) ++ ":") : map showRpmFile dirpkgs+ else do+ when debug $ mapM_ (putStrLn . showRpmFile) dirpkgs+ (case mgr of+ OSTREE -> cmd_+ _ -> sudo_) pkgmgr $+ com ++ map showRpmFile dirpkgs ++ ["--assumeyes" | yes == Yes && mgr `elem` [DNF3,DNF5]]++ reinstallCommand :: PkgMgr -> [String]+ reinstallCommand mgr =+ case mgr of+ DNF3 -> ["reinstall"]+ DNF5 -> ["reinstall"]+ RPM -> ["-Uvh","--replacepkgs"]+ OSTREE -> ["install"]++ installCommand :: PkgMgr -> [String]+ installCommand mgr =+ case mgr of+ DNF3 -> ["localinstall"]+ DNF5 -> ["install"]+ RPM -> ["-ivh"]+ OSTREE -> ["install"]++-- FIXME replace with export from rpm-nvr+-- | render a NVRA as rpm file+nvraToRPM :: NVRA -> FilePath+nvraToRPM nvra = showNVRA nvra <.> "rpm"++-- | render path and NVRA are rpm filepath+showRpmFile :: (FilePath,NVRA) -> FilePath+showRpmFile (dir,nvra) = dir </> nvraToRPM nvra++-- | group rpms by arch (subdirs)+groupOnArch :: FilePath -- ^ prefix directory (eg "RPMS")+ -> [ExistNVRA]+ -> [(FilePath,[ExistNVRA])]+groupOnArch dir = groupOnKey (\(_,p) -> dir </> rpmArch p)