diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/select-rpms.cabal b/select-rpms.cabal new file mode 100644 --- /dev/null +++ b/select-rpms.cabal @@ -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 +maintainer: Jens Petersen +copyright: 2024 Jens Petersen +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 diff --git a/src/SelectRPMs.hs b/src/SelectRPMs.hs new file mode 100644 --- /dev/null +++ b/src/SelectRPMs.hs @@ -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)