koji-tool 0.9.2 → 0.9.3
raw patch · 13 files changed
+379/−238 lines, 13 filesdep ~simple-cmddep ~simple-cmd-args
Dependency ranges changed: simple-cmd, simple-cmd-args
Files
- ChangeLog.md +21/−3
- README.md +14/−6
- TODO +3/−1
- koji-tool.cabal +4/−4
- src/BuildlogSizes.hs +1/−1
- src/Builds.hs +32/−19
- src/Find.hs +107/−0
- src/Install.hs +124/−60
- src/Main.hs +19/−5
- src/Progress.hs +23/−15
- src/Quick.hs +0/−103
- src/Tasks.hs +30/−20
- src/User.hs +1/−1
ChangeLog.md view
@@ -1,12 +1,30 @@ # Version history of koji-tool +## 0.9.3 (2022-08-03)+- 'builds' for a package now use specified query options+- 'builds': add --install and --tasks options+- 'install': --exclude globs now filter --package globs+- 'install': update installed subpackages first then install any new subpkgs+- 'install': separate prompt logic for "install above" packages+- 'install': experimental support for rpm-ostree overlaying (--rpm-ostree)+- 'install': allow noarch tasks+- 'install': allow package filtering in --list mode+- 'install': --skip-existing to leave already installed subpackages untouched+- 'progress' records the largest finished build.log size+- 'progress': exclude srpm from max log sizes+- 'progress': show pkg name instead of "unknown" nvr early on+- 'progress': only use current time if task unfinished+- 'tasks': fix output url selection for scratch builds+- 'tasks': check build.log exists before getting its size+- make parsing of states strict for earlier errors+- error if koji userid not found+ ## 0.9.2 (2022-06-12)-- progress: print build duration+- tasks --install now takes install options string - install: place rpms in a nvr subdirectory-- progress: show duration of build and finished tasks - install: when downloading check if local files' timestamp within build time - progress: no longer quit after srpm build-- tasks --install now takes install options string+- progress: show duration of build and finished tasks ## 0.9.1 (2022-05-29) - 'find': add "install", "tail", "notail", and archs support
README.md view
@@ -23,7 +23,7 @@ ## Commands ```shellsession $ koji-tool --version-0.9.2+0.9.3 $ koji-tool --help Query and track Koji tasks, and install rpms from Koji. @@ -68,7 +68,8 @@ Usage: koji-tool builds [-H|--hub HUB] [(-u|--user USER) | (-M|--mine)] [(-L|--latest) | (-l|--limit INT)] [-s|--state STATE] [(-B|--before TIMESTAMP) | (-F|--from TIMESTAMP)]- [-t|--type TYPE] [-d|--details] [-D|--debug]+ [-T|--type TYPE] [(-d|--details) | (-t|--tasks)]+ [-i|--install INSTALLOPTS] [-D|--debug] [(-b|--build NVR/BUILDID) | (-p|--pattern NVRPAT) | PACKAGE] Query Koji builds (by default lists most recent builds)@@ -84,8 +85,10 @@ (building,complete,deleted,fail(ed),cancel(ed) -B,--before TIMESTAMP Builds completed before timedate [default: now] -F,--from TIMESTAMP Builds completed after timedate- -t,--type TYPE Select builds by type: all,image,maven,module,rpm,win- -d,--details Show more details of builds+ -T,--type TYPE Select builds by type: all,image,maven,module,rpm,win+ -d,--details Show more build details+ -t,--tasks Show details and tasks+ -i,--install INSTALLOPTS Install the package with 'install' options -D,--debug Pretty-print raw XML result -b,--build NVR/BUILDID Show build -p,--pattern NVRPAT Builds matching glob pattern@@ -251,7 +254,8 @@ $ koji-tool install --help Usage: koji-tool install [-n|--dry-run] [-D|--debug] [-y|--yes] [-H|--hub HUB] [-P|--packages-url URL] [-l|--list] [-L|--latest]- [-t|--check-remote-time] [-r|--rpm] [-N|--no-reinstall]+ [-t|--check-remote-time] [--rpm | --rpm-ostree | --dnf]+ [(-N|--no-reinstall) | (-S|--skip-existing)] [-b|--prefix SUBPKGPREFIX] [(-a|--all) | (-A|--ask) | [-p|--package SUBPKG] [-x|--exclude SUBPKG]] [-d|--disttag DISTTAG]@@ -269,8 +273,12 @@ -l,--list List builds -L,--latest Latest build -t,--check-remote-time Check remote rpm timestamps- -r,--rpm Use rpm instead of dnf+ --rpm Use rpm instead of dnf+ --rpm-ostree Use rpm-ostree instead of dnf+ --dnf Use dnf to install [default unless ostree] -N,--no-reinstall Do not reinstall existing NVRs+ -S,--skip-existing Ignore already installed subpackages (imples+ --no-reinstall) -b,--prefix SUBPKGPREFIX Prefix to use for subpackages [default: base package] -a,--all all subpackages -A,--ask ask for each subpackge [default if not installed]
TODO view
@@ -50,8 +50,10 @@ - % of previous build (or finished tasks) - mbs urls? - average build times? (cache or separate tool?)-- show log sizes for old finished builds - pick up user's new builds - screen mode inplace tui++- list binary packages (install does this, but not obvious)+- diff build command
koji-tool.cabal view
@@ -1,5 +1,5 @@ name: koji-tool-version: 0.9.2+version: 0.9.3 synopsis: Koji CLI tool for querying tasks and installing builds description: koji-tool is a CLI interface to Koji with commands to query@@ -36,9 +36,9 @@ BuildlogSizes Common DownloadDir+ Find Install Progress- Quick Tasks Time User@@ -55,8 +55,8 @@ koji >= 0.0.2, pretty-simple, rpm-nvr >= 0.1.2,- simple-cmd,- simple-cmd-args >= 0.1.7,+ simple-cmd >= 0.2.2,+ simple-cmd-args >= 0.1.8, text, time, utf8-string,
src/BuildlogSizes.hs view
@@ -81,7 +81,7 @@ buildlogSize child = do case lookupStruct "id" child :: Maybe Int of Nothing -> error "child taskid not found"- Just tid -> do+ Just tid -> whenJust (lookupStruct "arch" child) $ doGetBuildlogSize buildlog where
src/Builds.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns, CPP #-} -- SPDX-License-Identifier: BSD-3-Clause module Builds ( BuildReq(..),+ Details(..), buildsCmd, parseBuildState, fedoraKojiHub,@@ -26,6 +27,7 @@ import Text.Pretty.Simple import Common+import Install import qualified Tasks import Time import User@@ -43,12 +45,14 @@ capitalize "" = "" capitalize (h:t) = toUpper h : t --- FIXME show tail of build's build.log+data Details = DetailDefault | Detailed | DetailedTasks+ deriving Eq+ -- FIXME add --install buildsCmd :: Maybe String -> Maybe UserOpt -> Int -> [BuildState]- -> Maybe Tasks.BeforeAfter -> Maybe String -> Bool -> Bool- -> BuildReq -> IO ()-buildsCmd mhub museropt limit states mdate mtype details debug buildreq = do+ -> Maybe Tasks.BeforeAfter -> Maybe String -> Details+ -> Maybe Tasks.Select -> Bool -> BuildReq -> IO ()+buildsCmd mhub museropt limit !states mdate mtype details minstall debug buildreq = do when (hub /= fedoraKojiHub && museropt == Just UserSelf) $ error' "--mine currently only works with Fedora Koji: use --user instead" tz <- getCurrentTimeZone@@ -60,7 +64,7 @@ then InfoID (read bld) else InfoString bld mbld <- getBuild hub bldinfo- whenJust (mbld >>= maybeBuildResult) $ printBuild hub tz+ whenJust (mbld >>= maybeBuildResult) $ printBuild hub tz details minstall BuildPackage pkg -> do when (head pkg == '-') $ error' $ "bad combination: not a package: " ++ pkg@@ -70,13 +74,14 @@ case mpkgid of Nothing -> error' $ "no package id found for " ++ pkg Just pkgid -> do+ query <- setupQuery let fullquery = [("packageID", ValueInt pkgid),- commonBuildQueryOptions limit]+ commonBuildQueryOptions limit] ++ query when debug $ print fullquery builds <- listBuilds hub fullquery when debug $ mapM_ pPrintCompact builds- if details || length builds == 1- then mapM_ (printBuild hub tz) $ mapMaybe maybeBuildResult builds+ if details /= DetailDefault || length builds == 1+ then mapM_ (printBuild hub tz details minstall) $ mapMaybe maybeBuildResult builds else mapM_ putStrLn $ mapMaybe (shortBuildResult tz) builds _ -> do query <- setupQuery@@ -84,8 +89,8 @@ when debug $ print fullquery builds <- listBuilds hub fullquery when debug $ mapM_ pPrintCompact builds- if details || length builds == 1- then mapM_ (printBuild hub tz) $ mapMaybe maybeBuildResult builds+ if details /= DetailDefault || length builds == 1+ then mapM_ (printBuild hub tz details minstall) $ mapMaybe maybeBuildResult builds else mapM_ putStrLn $ mapMaybe (shortBuildResult tz) builds where hub = maybe fedoraKojiHub hubURL mhub@@ -147,12 +152,11 @@ buildinfoUrl hub bid = webUrl hub ++ "/buildinfo?buildID=" ++ show bid --- FIXME only 2 accessors data BuildResult = BuildResult {buildNVR :: NVR,- _buildState :: BuildState,+ buildState :: BuildState, _buildId :: Int,- _mtaskId :: Maybe Int,+ mbuildTaskId :: Maybe Int, _buildStartTime :: UTCTime, mbuildEndTime :: Maybe UTCTime }@@ -168,13 +172,22 @@ return $ BuildResult nvr state buildid mtaskid start mend -printBuild :: String -> TimeZone -> BuildResult -> IO ()-printBuild hub tz build = do+printBuild :: String -> TimeZone -> Details -> Maybe Tasks.Select+ -> BuildResult -> IO ()+printBuild hub tz details minstall build = do putStrLn "" let mendtime = mbuildEndTime build time <- maybe getCurrentTime return mendtime (mapM_ putStrLn . formatBuildResult hub (isJust mendtime) tz) (build {mbuildEndTime = Just time})- putStrLn $ buildOutputURL hub $ buildNVR build+ when (buildState build == BuildComplete) $+ putStrLn $ buildOutputURL hub $ buildNVR build+ whenJust (mbuildTaskId build) $ \taskid -> do+ when (details == DetailedTasks) $ do+ putStrLn ""+ Tasks.tasksCmd (Just hub) Nothing 7 [] [] Nothing Nothing False False Nothing False Nothing (Tasks.Parent taskid)+ whenJust minstall $ \installopts -> do+ putStrLn ""+ installCmd False False No (Just hub) Nothing False False False Nothing ExistingUpdate Nothing installopts Nothing ReqName [show taskid] formatBuildResult :: String -> Bool -> TimeZone -> BuildResult -> [String] formatBuildResult hub ended tz (BuildResult nvr state buildid mtaskid start mendtime) =@@ -207,7 +220,7 @@ "failed" -> BuildFailed "cancel" -> BuildCanceled "canceled" -> BuildCanceled- _ -> error' $! "unknown task state: " ++ s+ _ -> error' $! "unknown build state: " ++ s #endif getBuildState :: Struct -> Maybe BuildState@@ -222,4 +235,4 @@ mbld <- kojiLatestBuild hub tag pkg when debug $ print mbld tz <- getCurrentTimeZone- whenJust (mbld >>= maybeBuildResult) $ printBuild hub tz+ whenJust (mbld >>= maybeBuildResult) $ printBuild hub tz Detailed Nothing
+ src/Find.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE CPP #-}++-- SPDX-License-Identifier: BSD-3-Clause++module Find (+ findCmd,+ wordsList+ )+where++import Data.Char ( isDigit, isAsciiLower, isAsciiUpper )+import Data.List.Extra ((\\), dropSuffix, isSuffixOf)+import Distribution.Koji+ ( BuildState(BuildBuilding, BuildFailed, BuildComplete),+ TaskState(TaskOpen, TaskFailed, TaskClosed) )+import SimpleCmd (error')++import qualified Builds+import qualified Tasks+import User ( UserOpt(User, UserSelf) )++data Words = Mine | Limit | Failure | Complete | Current | Build | Detail+ | Install | Tail | NoTail | Arch+ deriving (Enum,Bounded)++findWords :: Words -> [String]+findWords Mine = ["my","mine"]+findWords Limit = ["last","latest"]+findWords Failure = ["fail","failure","failed"]+findWords Complete = ["complete","completed","completion",+ "close","closed",+ "finish","finished"]+findWords Current = ["current","building","open"]+findWords Build = ["build","builds"]+findWords Detail = ["detail","details","detailed"]+findWords Install = ["install"]+findWords Tail = ["tail"]+findWords NoTail = ["notail"]+findWords Arch = ["x86_64", "aarch64", "ppc64le", "s390x", "i686", "armv7hl"]++wordsList :: ([String] -> String) -> [String]+wordsList f =+ map (f . findWords) [minBound..] ++ ["PACKAGE","USER\\'s"]++allWords :: [String]+allWords = concatMap findWords [minBound..]++-- FIXME: arch+-- FIXME: method+-- FIXME: mlt (or mlft)+findCmd :: Maybe String -> Bool -> [String] -> IO ()+findCmd _ _ [] = error' $ "find handles these words:\n\n" +++ unlines (wordsList unwords)+findCmd mhub debug args = do+ let user = if hasWord Mine+ then Just UserSelf+ else case filter ("'s" `isSuffixOf`) args of+ [] -> Nothing+ [users] -> Just $ User (dropSuffix "'s" users)+ more -> error' $ "more than one user's given: " +++ unwords more+ archs = if hasWord Arch+ then filter (`elem` findWords Arch) args else []+ limit = if hasWord Limit then 1 else 10+ failure = hasWord Failure+ complete = hasWord Complete+ current = hasWord Current+ build = hasWord Build+ detail = hasWord Detail+ install = hasWord Install+ tail' = hasWord Tail+ notail = hasWord NoTail+ mpkg =+ case removeUsers (args \\ allWords) of+ [] -> Nothing+ -- FIXME allow pattern?+ [pkg] | all isPkgNameChar pkg -> Just pkg+ other ->+ error' $+ "you can only specify one package - too many unknown words: " +++ unwords other+ installation = if install then Just (Tasks.PkgsReq [] []) else Nothing+ if build+ then+ let states = [BuildFailed|failure] ++ [BuildComplete|complete] +++ [BuildBuilding|current]+ buildreq = maybe Builds.BuildQuery Builds.BuildPackage mpkg+ detailed = if detail then Builds.Detailed else Builds.DetailDefault+ in Builds.buildsCmd mhub user limit states Nothing (Just "rpm") detailed installation debug buildreq+ else+ let states = [TaskFailed|failure] ++ [TaskClosed|complete] +++ [TaskOpen|current]+ taskreq = maybe Tasks.TaskQuery Tasks.Package mpkg+ in Tasks.tasksCmd mhub user limit states archs Nothing Nothing detail debug Nothing ((tail' || failure) && not notail) installation taskreq+ where+ hasWord :: Words -> Bool+ hasWord word = any (`elem` findWords word) args++ removeUsers :: [String] -> [String]+ removeUsers = filter (not . ("'s" `isSuffixOf`))++-- [Char] generated by+-- sort . nub <$> cmd "dnf" ["repoquery", "--qf=%{name}", "*"]+-- "+-.0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"+isPkgNameChar :: Char -> Bool+isPkgNameChar c =+ isAsciiLower c || isAsciiUpper c || c `elem` "-.+_" || isDigit c
src/Install.hs view
@@ -6,6 +6,8 @@ Select(..), Request(..), installCmd,+ ExistingStrategy(..),+ PkgMgr(..), knownHubs, Yes(..), installArgs@@ -67,19 +69,24 @@ data Request = ReqName | ReqNV | ReqNVR deriving Eq +data PkgMgr = DNF | RPM | OSTREE+ deriving Eq++data ExistingStrategy = ExistingUpdate | ExistingNoReinstall | ExistingSkip+ -- FIXME --include devel, --exclude * -- FIXME specify tag or task -- FIXME support enterprise builds -- FIXME --arch (including src) -- FIXME --debuginfo -- FIXME --delete after installing--- FIXME --dnf to install selected packages using default dnf repo instead+-- FIXME way to install selected packages using default dnf repo instead -- FIXME offer to download subpackage deps -- FIXME is --check-remote-time really needed? installCmd :: Bool -> Bool -> Yes -> Maybe String -> Maybe String -> Bool- -> Bool -> Bool -> Bool -> Bool -> Maybe String -> Select- -> Maybe String -> Request -> [String] -> IO ()-installCmd dryrun debug yes mhuburl mpkgsurl listmode latest checkremotetime useRpm noreinstall mprefix select mdisttag request pkgbldtsks = do+ -> Bool -> Bool -> Maybe PkgMgr -> ExistingStrategy -> Maybe String+ -> Select -> Maybe String -> Request -> [String] -> IO ()+installCmd dryrun debug yes mhuburl mpkgsurl listmode latest checkremotetime mmgr existingStrategy mprefix select mdisttag request pkgbldtsks = do let huburl = maybe fedoraKojiHub hubURL mhuburl pkgsurl = fromMaybe (hubToPkgsURL huburl) mpkgsurl when debug $ do@@ -89,13 +96,13 @@ when debug printDlDir setNoBuffering buildrpms <- mapM (kojiRPMs huburl pkgsurl printDlDir) pkgbldtsks- installRPMs dryrun debug useRpm noreinstall yes buildrpms+ installRPMs dryrun debug mmgr existingStrategy yes buildrpms where kojiRPMs :: String -> String -> IO () -> String -> IO (FilePath, [(Existence,NVRA)]) kojiRPMs huburl pkgsurl printDlDir bldtask = case readMaybe bldtask of- Just taskid -> kojiTaskRPMs dryrun debug yes huburl pkgsurl listmode noreinstall mprefix select checkremotetime printDlDir taskid+ Just taskid -> kojiTaskRPMs dryrun debug yes huburl pkgsurl listmode existingStrategy mprefix select checkremotetime printDlDir taskid Nothing -> kojiBuildRPMs huburl pkgsurl printDlDir bldtask kojiBuildRPMs :: String -> String -> IO () -> String@@ -110,16 +117,19 @@ nvrs <- map readNVR <$> kojiBuildOSBuilds debug huburl listmode latest disttag request pkgbld if listmode then do- if select /= PkgsReq [] []- then error' "selects not supported for listing build" -- FIXME- else case nvrs of- [nvr] -> do- putStrLn (showNVR nvr)- putStrLn ""- bid <- kojiGetBuildID' huburl (showNVR nvr)- kojiGetBuildRPMs huburl nvr bid >>=- mapM_ putStrLn . sort . filter notDebugPkg- _ -> mapM_ (putStrLn . showNVR) nvrs+ case nvrs of+ [nvr] -> do+ putStrLn (showNVR nvr)+ putStrLn ""+ bid <- kojiGetBuildID' huburl (showNVR nvr)+ nvras <- sort . map readNVRA . filter notDebugPkg <$> kojiGetBuildRPMs huburl nvr bid+ when debug $ mapM_ (putStrLn . showNVRA) nvras+ let prefix = fromMaybe (nvrName nvr) mprefix+ rpms <- decideRpms yes listmode existingStrategy select prefix nvras+ mapM_ printInstalled rpms+ -- kojiGetBuildRPMs huburl nvr bid >>=+ -- mapM_ putStrLn . sort . filter notDebugPkg+ _ -> mapM_ (putStrLn . showNVR) nvrs return ("",[]) else case nvrs of@@ -130,7 +140,7 @@ nvras <- sort . map readNVRA . filter notDebugPkg <$> kojiGetBuildRPMs huburl nvr bid when debug $ mapM_ (putStrLn . showNVRA) nvras let prefix = fromMaybe (nvrName nvr) mprefix- dlRpms <- decideRpms yes listmode noreinstall select prefix nvras+ dlRpms <- decideRpms yes listmode existingStrategy select prefix nvras when debug $ mapM_ printInstalled dlRpms let subdir = showNVR nvr unless (dryrun || null dlRpms) $ do@@ -152,10 +162,10 @@ notDebugPkg p = not ("-debuginfo-" `isInfixOf` p || "-debugsource-" `isInfixOf` p) -kojiTaskRPMs :: Bool -> Bool -> Yes -> String -> String -> Bool -> Bool- -> Maybe String -> Select -> Bool -> IO () -> Int- -> IO (FilePath, [(Existence,NVRA)])-kojiTaskRPMs dryrun debug yes huburl pkgsurl listmode noreinstall mprefix select checkremotetime printDlDir taskid = do+kojiTaskRPMs :: Bool -> Bool -> Yes -> String -> String -> Bool+ -> ExistingStrategy -> Maybe String -> Select -> Bool -> IO ()+ -> Int -> IO (FilePath, [(Existence,NVRA)])+kojiTaskRPMs dryrun debug yes huburl pkgsurl listmode existingStrategy mprefix select checkremotetime printDlDir taskid = do mtaskinfo <- Koji.getTaskInfo huburl taskid True tasks <- case mtaskinfo of Nothing -> error' "failed to get taskinfo"@@ -170,7 +180,7 @@ _ -> error' $ "unsupport method: " ++ method sysarch <- cmd "rpm" ["--eval", "%{_arch}"] let (archtid,archtask) =- case find (\t -> lookupStruct "arch" t == Just sysarch) tasks of+ case find (\t -> let march = lookupStruct "arch" t in march `elem` [Just sysarch,Just "noarch"]) tasks of Nothing -> error' $ "no " ++ sysarch ++ " task found" Just task' -> case lookupStruct "id" task' of@@ -189,17 +199,17 @@ fromMaybe archtask mtaskinfo if listmode then do- drpms <- decideRpms yes listmode noreinstall select prefix nvras+ drpms <- decideRpms yes listmode existingStrategy select prefix nvras return ("",drpms) else if null nvras then do- (_, rpms) <- kojiTaskRPMs dryrun debug yes huburl pkgsurl True noreinstall mprefix select checkremotetime printDlDir archtid+ (_, rpms) <- kojiTaskRPMs dryrun debug yes huburl pkgsurl True existingStrategy mprefix select checkremotetime printDlDir archtid mapM_ printInstalled rpms return ("",[]) else do when debug $ print $ map showNVRA nvras- dlRpms <- decideRpms yes listmode noreinstall select prefix $+ dlRpms <- decideRpms yes listmode existingStrategy select prefix $ filter ((/= "src") . rpmArch) nvras when debug $ mapM_ printInstalled dlRpms let subdir = show archtid@@ -221,38 +231,38 @@ if null few then "0" else few in dropSuffix "packages" pkgsurl +/+ "work/tasks/" ++ lastFew +/+ show taskid' +/+ rpm -data Existence = NotInstalled | NVRInstalled | NVRChanged+data Existence = NVRInstalled | NVRChanged | NotInstalled deriving (Eq, Ord, Show) -decideRpms :: Yes -> Bool -> Bool -> Select -> String -> [NVRA]+-- FIXME ExistingStrategy isn't used, so output doesn't reflect it+decideRpms :: Yes -> Bool -> ExistingStrategy -> Select -> String -> [NVRA] -> IO [(Existence,NVRA)]-decideRpms yes listmode noreinstall select prefix nvras = do+decideRpms yes listmode existingStrategy select prefix nvras = do classified <- mapM installExists (filter isBinaryRpm nvras) if listmode- then mapM_ printInstalled classified >> return []+ then do+ case select of+ PkgsReq subpkgs exclpkgs -> do+ let install = selectRPMs False prefix (subpkgs,exclpkgs) classified+ mapM_ printInstalled install+ _ -> mapM_ printInstalled classified+ return [] else case select of All -> do- mapM_ printInstalled classified- ok <- prompt yes "install above"- return $ if ok then classified else []+ promptPkgs yes classified Ask -> mapMaybeM (rpmPrompt yes) classified PkgsReq [] [] -> if all ((== NotInstalled) . fst) classified && yes /= Yes- then decideRpms yes listmode noreinstall Ask prefix nvras+ then decideRpms yes listmode existingStrategy Ask prefix nvras else do let install = filter ((/= NotInstalled) . fst) classified if yes == Yes then return install- else do- mapM_ printInstalled install- ok <- prompt yes "install above"- return $ if ok then install else []+ else promptPkgs yes install PkgsReq subpkgs exclpkgs -> do let install = selectRPMs False prefix (subpkgs,exclpkgs) classified- mapM_ printInstalled install- ok <- prompt yes "install above"- return $ if ok then install else []+ promptPkgs yes install where installExists :: NVRA -> IO (Existence, NVRA) installExists nvra = do@@ -304,25 +314,46 @@ else match comppat rpmname selectRPMs recurse prefix (subpkgs,exclpkgs) rpms = let needed = selectRPMs recurse prefix (subpkgs,[]) rpms- excluded = selectRPMs recurse prefix ([], exclpkgs) rpms- in nub . sort $ needed ++ excluded+ excluded = selectRPMs recurse prefix (exclpkgs,[]) rpms+ in nub . sort $ needed \\ excluded +promptPkgs :: Yes -> [(Existence,NVRA)] -> IO [(Existence,NVRA)]+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 do+ putStr $ str ++ " [Y/n]: "+ inp <- trim <$> getLine+ case lower inp of+ "" -> return True+ "y" -> return True+ "yes" -> return True+ "n" -> return False+ "no" -> return False+ _ -> prompt yes str++promptChar :: Yes -> String -> IO Bool+promptChar yes str = do+ if yes == Yes+ then return True+ else do putStr $ str ++ " [y/n]: " c <- getChar unless (c == '\n') $ putStrLn "" case toLower c of 'y' -> return True 'n' -> return False- _ -> prompt yes str+ _ -> promptChar yes str rpmPrompt :: Yes -> (Existence,NVRA) -> IO (Maybe (Existence,NVRA)) rpmPrompt yes (exist,nvra) = do- ok <- prompt yes $ renderInstalled (exist,nvra)+ ok <- promptChar yes $ renderInstalled (exist,nvra) return $ if ok then Just (exist,nvra)@@ -407,25 +438,44 @@ hSetBuffering stdin NoBuffering hSetBuffering stdout NoBuffering -installRPMs :: Bool -> Bool -> Bool -> Bool -> Yes -> [(FilePath,[(Existence,NVRA)])]- -> IO ()+-- FIXME ExistingStrategy should move to decideRpms+installRPMs :: Bool -> Bool -> Maybe PkgMgr -> ExistingStrategy -> Yes+ -> [(FilePath,[(Existence,NVRA)])] -> IO () installRPMs _ _ _ _ _ [] = return ()-installRPMs dryrun debug rpm noreinstall yes classified =+installRPMs dryrun debug mmgr existingStrategy yes classified = forM_ (groupClasses classified) $ \(cl,dirpkgs) ->- unless (null dirpkgs) $- let pkgmgr = if rpm then "rpm" else "dnf"- mcom =- case cl of- NVRInstalled -> if noreinstall- then Nothing- else Just (if rpm then ["-Uvh","--replacepkgs"] else ["reinstall"])- _ -> Just (if rpm then ["-ivh"] else ["localinstall"])+ unless (null dirpkgs) $ do+ mgr <-+ case mmgr of+ Nothing -> do+ mostree <- findExecutable "rpm-ostree"+ return $ if isJust mostree then OSTREE else DNF+ Just m -> return m+ let pkgmgr =+ case mgr of+ DNF -> "dnf"+ RPM -> "rpm"+ OSTREE -> "rpm-ostree"+ mcom =+ case cl of+ NVRInstalled ->+ case existingStrategy of+ ExistingUpdate -> Just (reinstallCommand mgr)+ _ -> Nothing+ NVRChanged ->+ case existingStrategy of+ ExistingSkip -> Nothing+ _ -> Just (installCommand mgr)+ _ -> Just (installCommand mgr) in whenJust mcom $ \com ->- if dryrun- then mapM_ putStrLn $ ("would" +-+ unwords (pkgmgr : com) ++ ":") : map showRpmFile dirpkgs- else do- when debug $ mapM_ (putStrLn . showRpmFile) dirpkgs- sudo_ pkgmgr $ com ++ map showRpmFile dirpkgs ++ ["--assumeyes" | yes == Yes && not rpm]+ 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 == DNF] where groupClasses = groupSort . concatMap mapDir@@ -434,6 +484,20 @@ -> [(Existence,(FilePath,NVRA))] mapDir (dir,cls) = map (\(e,n) -> (e,(dir,n))) cls++ reinstallCommand :: PkgMgr -> [String]+ reinstallCommand mgr =+ case mgr of+ DNF -> ["reinstall"]+ RPM -> ["-Uvh","--replacepkgs"]+ OSTREE -> ["install"]++ installCommand :: PkgMgr -> [String]+ installCommand mgr =+ case mgr of+ DNF -> ["localinstall"]+ RPM -> ["-ivh"]+ OSTREE -> ["install"] showRpm :: NVRA -> FilePath showRpm nvra = showNVRA nvra <.> "rpm"
src/Main.hs view
@@ -15,7 +15,7 @@ import Install import qualified Paths_koji_tool import Progress-import Quick+import Find import Tasks main :: IO ()@@ -34,8 +34,10 @@ <*> many (parseBuildState <$> strOptionWith 's' "state" "STATE" "Filter builds by state (building,complete,deleted,fail(ed),cancel(ed)") <*> optional (Before <$> strOptionWith 'B' "before" "TIMESTAMP" "Builds completed before timedate [default: now]" <|> After <$> strOptionWith 'F' "from" "TIMESTAMP" "Builds completed after timedate")- <*> (fmap normalizeBuildType <$> optional (strOptionWith 't' "type" "TYPE" ("Select builds by type: " ++ intercalate "," kojiBuildTypes)))- <*> switchWith 'd' "details" "Show more details of builds"+ <*> (fmap normalizeBuildType <$> optional (strOptionWith 'T' "type" "TYPE" ("Select builds by type: " ++ intercalate "," kojiBuildTypes)))+ <*> (flagWith' Detailed 'd' "details" "Show more build details" <|>+ flagWith DetailDefault DetailedTasks 't' "tasks" "Show details and tasks")+ <*> optional (installArgs <$> strOptionWith 'i' "install" "INSTALLOPTS" "Install the package with 'install' options") <*> switchWith 'D' "debug" "Pretty-print raw XML result" <*> (BuildBuild <$> strOptionWith 'b' "build" "NVR/BUILDID" "Show build" <|> BuildPattern <$> strOptionWith 'p' "pattern" "NVRPAT" "Builds matching glob pattern" <|>@@ -60,6 +62,7 @@ <*> optional (TaskPackage <$> strOptionWith 'P' "only-package" "PKG" "Filter task results to specified package" <|> TaskNVR <$> strOptionWith 'N' "only-nvr" "PREFIX" "Filter task results by NVR prefix") <*> switchWith 'T' "tail" "Fetch the tail of build.log"+ -- FIXME any way to pass --help to install? <*> optional (installArgs <$> strOptionWith 'i' "install" "INSTALLOPTS" "Install the package with 'install' options") <*> (Build <$> strOptionWith 'b' "build" "BUILD" "List child tasks of build" <|> Pattern <$> strOptionWith 'p' "pattern" "NVRPAT" "Build tasks of matching pattern"@@ -86,8 +89,8 @@ <*> switchWith 'l' "list" "List builds" <*> switchWith 'L' "latest" "Latest build" <*> switchWith 't' "check-remote-time" "Check remote rpm timestamps"- <*> switchWith 'r' "rpm" "Use rpm instead of dnf"- <*> switchWith 'N' "no-reinstall" "Do not reinstall existing NVRs"+ <*> optional pkgMgrOpt+ <*> existingOpt <*> optional (strOptionWith 'b' "prefix" "SUBPKGPREFIX" "Prefix to use for subpackages [default: base package]") <*> selectOpt <*> optional disttagOpt@@ -156,3 +159,14 @@ readTaskReq :: String -> Maybe TaskReq readTaskReq cs = Just $ if all isDigit cs then Task (read cs) else Package cs++ pkgMgrOpt :: Parser PkgMgr+ pkgMgrOpt =+ flagLongWith' RPM "rpm" "Use rpm instead of dnf" <|>+ flagLongWith' OSTREE "rpm-ostree" "Use rpm-ostree instead of dnf" <|>+ flagLongWith' DNF "dnf" "Use dnf to install [default unless ostree]"++ existingOpt :: Parser ExistingStrategy+ existingOpt =+ flagWith' ExistingNoReinstall 'N' "no-reinstall" "Do not reinstall existing NVRs" <|>+ flagWith ExistingUpdate ExistingSkip 'S' "skip-existing" "Ignore already installed subpackages (imples --no-reinstall)"
src/Progress.hs view
@@ -52,6 +52,8 @@ btasks <- mapM kojiTaskinfoRecursive tasks loopBuildTasks debug waitdelay btasks +type BuildTask = (TaskID, UTCTime, Maybe UTCTime, Maybe Int, [TaskInfoSize])+ kojiTaskinfoRecursive :: TaskID -> IO BuildTask kojiTaskinfoRecursive tid = do mtaskinfo <- kojiGetTaskInfo fedoraKojiHub tid@@ -76,9 +78,8 @@ Nothing -> error' $ "task " ++ displayID tid ++ " has no start time" Just t -> t- return (tid, start, zip children (repeat Nothing))--type BuildTask = (TaskID, UTCTime, [TaskInfoSize])+ mend = lookupTime True taskinfo+ return (tid, start, mend, Nothing, zip children (repeat Nothing)) -- FIXME change to (TaskID,Struct,Size) type TaskInfoSize = (Struct,Maybe Int)@@ -99,7 +100,7 @@ threadDelay (fromEnum (fromIntegral (m * 60) :: Micro)) runProgress :: BuildTask -> IO BuildTask- runProgress (tid,start,tasks) =+ runProgress (tid,start,mend,msize,tasks) = case tasks of [] -> do state <- kojiGetTaskState fedoraKojiHub tid@@ -107,29 +108,36 @@ then do threadDelayMinutes waitdelay kojiTaskinfoRecursive tid- else return (tid, start, [])+ else return (tid, start, Nothing, msize, []) ((task,_):_) -> do when debug $ print task- current <- getCurrentTime- let mnvr = kojiTaskRequestNVR task- duration = diffUTCTime current start- logMsg $ maybe "<unknown>" showNVR mnvr ++ " (" ++ displayID tid ++ ") " ++ renderDuration True duration+ let epkgnvr = kojiTaskRequestPkgNVR task+ end <- maybe getCurrentTime return mend+ let duration = diffUTCTime end start+ logMsg $ either id showNVR epkgnvr ++ " (" ++ displayID tid ++ ")" +-+ maybe "" (\s -> show (s `div` 1000) ++ "kB,") msize +-+ renderDuration True duration sizes <- mapM buildlogSize tasks printLogSizes waitdelay sizes putStrLn "" let news = map (\(t,(s,_)) -> (t,s)) sizes- open = filter (\ (t,_) -> getTaskState t `elem` map Just openTaskStates) news+ (open,closed) = partition (\ (t,_) -> getTaskState t `elem` map Just openTaskStates) news+ mlargest = if not (any (\(t,_) -> lookupStruct "method" t /= Just ("buildSRPMFromSCM" :: String)) closed)+ then Nothing+ else maximum $ map snd closed+ mbiggest = case (mlargest,msize) of+ (Just large, Just size) -> Just $ max large size+ (Just large, Nothing) -> Just large+ (Nothing,_) -> msize if null open- then runProgress (tid,start,[])- else return (tid, start, open)+ then runProgress (tid,start,mend,mbiggest,[])+ else return (tid, start, mend, mbiggest, open) tasksOpen :: BuildTask -> Bool- tasksOpen (_,_,ts) = not (null ts)+ tasksOpen (_,_,_,_,ts) = not (null ts) updateBuildTask :: BuildTask -> IO BuildTask- updateBuildTask (tid,start,ts) = do+ updateBuildTask (tid,start,mend,msize,ts) = do news <- mapM updateTask ts- return (tid, start, news)+ return (tid, start, mend, msize, news) updateTask :: TaskInfoSize -> IO TaskInfoSize updateTask (task,size) = do
− src/Quick.hs
@@ -1,103 +0,0 @@-{-# LANGUAGE CPP #-}---- SPDX-License-Identifier: BSD-3-Clause--module Quick (- findCmd,- wordsList- )-where--import Data.Char ( isDigit, isAsciiLower, isAsciiUpper )-import Data.List.Extra ((\\), dropSuffix, isSuffixOf)-import Distribution.Koji-import SimpleCmd (error')--import qualified Builds-import qualified Tasks-import User--data Words = Mine | Limit | Failure | Complete | Current | Build | Detail- | Install | Tail | NoTail | Arch- deriving (Enum,Bounded)--findWords :: Words -> [String]-findWords Mine = ["my","mine"]-findWords Limit = ["last","latest"]-findWords Failure = ["fail","failure","failed"]-findWords Complete = ["complete","completed","completion",- "close","closed",- "finish","finished"]-findWords Current = ["current","building","open"]-findWords Build = ["build","builds"]-findWords Detail = ["detail","details","detailed"]-findWords Install = ["install"]-findWords Tail = ["tail"]-findWords NoTail = ["notail"]-findWords Arch = ["x86_64", "aarch64", "ppc64le", "s390x", "i686", "armv7hl"]--wordsList :: ([String] -> String) -> [String]-wordsList f =- map (f . findWords) [minBound..] ++ ["PACKAGE","USER\\'s"]--allWords :: [String]-allWords = concatMap findWords [minBound..]---- FIXME: arch--- FIXME: method--- FIXME: mlt (or mlft)-findCmd :: Maybe String -> Bool -> [String] -> IO ()-findCmd _ _ [] = error' $ "find handles these words:\n\n" ++- unlines (wordsList unwords)-findCmd mhub debug args = do- let user = if hasWord Mine- then Just UserSelf- else case filter ("'s" `isSuffixOf`) args of- [] -> Nothing- [users] -> Just $ User (dropSuffix "'s" users)- more -> error' $ "more than one user's given: " ++- unwords more- archs = if hasWord Arch- then filter (`elem` findWords Arch) args else []- limit = if hasWord Limit then 1 else 10- failure = hasWord Failure- complete = hasWord Complete- current = hasWord Current- build = hasWord Build- detail = hasWord Detail- install = hasWord Install- tail' = hasWord Tail- notail = hasWord NoTail- mpkg =- case removeUsers (args \\ allWords) of- [] -> Nothing- -- FIXME allow pattern?- [pkg] | all isPkgNameChar pkg -> Just pkg- other ->- error' $- "you can only specify one package - too many unknown words: " ++- unwords other- if build- then- let states = [BuildFailed|failure] ++ [BuildComplete|complete] ++- [BuildBuilding|current]- buildreq = maybe Builds.BuildQuery Builds.BuildPackage mpkg- in Builds.buildsCmd mhub user limit states Nothing (Just "rpm") detail debug buildreq- else- let states = [TaskFailed|failure] ++ [TaskClosed|complete] ++- [TaskOpen|current]- taskreq = maybe Tasks.TaskQuery Tasks.Package mpkg- in Tasks.tasksCmd mhub user limit states archs Nothing Nothing detail debug Nothing ((tail' || failure) && not notail) (if install then Just (Tasks.PkgsReq [] []) else Nothing) taskreq- where- hasWord :: Words -> Bool- hasWord word = any (`elem` findWords word) args-- removeUsers :: [String] -> [String]- removeUsers = filter (not . ("'s" `isSuffixOf`))---- [Char] generated by--- sort . nub <$> cmd "dnf" ["repoquery", "--qf=%{name}", "*"]--- "+-.0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"-isPkgNameChar :: Char -> Bool-isPkgNameChar c =- isAsciiLower c || isAsciiUpper c || c `elem` "-.+_" || isDigit c
src/Tasks.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, OverloadedStrings #-}+{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-} -- SPDX-License-Identifier: BSD-3-Clause @@ -71,10 +71,12 @@ -- --sibling -- FIXME --tail-size option (eg more that 4000B) -- FIXME --output-fields+-- FIXME default to 'build' for install or try 'build' after 'buildarch'?+-- FIXME parent tasks need not have limit tasksCmd :: Maybe String -> Maybe UserOpt -> Int -> [TaskState] -> [String] -> Maybe BeforeAfter -> Maybe String -> Bool -> Bool -> Maybe TaskFilter -> Bool -> Maybe Select -> TaskReq -> IO ()-tasksCmd mhub museropt limit states archs mdate mmethod details debug mfilter' tail' minstall taskreq = do+tasksCmd mhub museropt limit !states archs mdate mmethod details debug mfilter' tail' minstall taskreq = do when (hub /= fedoraKojiHub && museropt == Just UserSelf) $ error' "--mine currently only works with Fedora Koji: use --user instead" tz <- getCurrentTimeZone@@ -90,7 +92,7 @@ printTask hasparent tz res if hasparent then whenJust minstall $ \installopts ->- installCmd False debug No mhub Nothing False False False False False Nothing installopts Nothing ReqName [show taskid]+ installCmd False debug No mhub Nothing False False False Nothing ExistingUpdate Nothing installopts Nothing ReqName [show taskid] else tasksCmd (Just hub) museropt limit states archs mdate mmethod details debug mfilter' tail' minstall (Parent taskid) Build bld -> do when (isJust mdate || isJust mfilter') $@@ -137,7 +139,7 @@ (mapM_ (printTask detailed tz) . filterResults . mapMaybe maybeTaskResult) tasks whenJust minstall $ \args -> if exact- then installCmd False debug No mhub Nothing False False False False False Nothing args Nothing ReqName [show (i :: Int) | i <- mapMaybe (lookupStruct "id") tasks]+ then installCmd False debug No mhub Nothing False False False Nothing ExistingUpdate Nothing args Nothing ReqName [show (i :: Int) | i <- mapMaybe (lookupStruct "id") tasks] else error' "cannot install more than one task" where hub = maybe fedoraKojiHub hubURL mhub@@ -325,8 +327,8 @@ findOutputURL :: String -> TaskResult -> IO (Maybe String) findOutputURL hub task = case outputUrl hub task PackagesOutput of- Just burl -> urlExistsOr burl $- urlExistsOr (taskOutputUrl task) $ return Nothing+ Just burl -> urlExistsOr (taskOutputUrl task) $+ urlExistsOr burl $ return Nothing Nothing -> urlExistsOr (taskOutputUrl task) $ return Nothing where urlExistsOr :: String -> IO (Maybe String) -> IO (Maybe String)@@ -355,23 +357,31 @@ logFile BuildLog = "build.log" buildlogSize :: Bool -> Bool -> String -> TaskResult -> IO ()-buildlogSize debug tail' hub task = do+buildlogSize _debug tail' hub task = do murl <- findOutputURL hub task whenJust murl $ \ url -> do let buildlog = url +/+ logFile BuildLog- putStr $ buildlog ++ " "- msize <- httpFileSize' buildlog- whenJust msize $ \size -> do- fprintLn ("(" % commas % "kB)") (size `div` 1000)- -- FIXME check if short build.log ends with srpm- file <-- if size < 1500- then do- putStrLn $ url +/+ logFile RootLog- return RootLog- else return BuildLog- when tail' $ displayLog url file- when debug $ putStrLn buildlog+ exists <- httpExists' buildlog+ if exists+ then do+ putStr $ buildlog ++ " "+ msize <- httpFileSize' buildlog+ case msize of+ Nothing -> putChar '\n'+ Just size -> do+ fprintLn ("(" % commas % "kB)") (size `div` 1000)+ -- FIXME check if short build.log ends with srpm+ file <-+ if size < 1500+ then do+ putStrLn $ url +/+ logFile RootLog+ return RootLog+ else return BuildLog+ when tail' $ displayLog url file+ else do+ let rootlog = url +/+ logFile RootLog+ whenM (httpExists' rootlog) $+ putStrLn rootlog where displayLog :: String -> LogFile -> IO () displayLog url file = do
src/User.hs view
@@ -37,5 +37,5 @@ else error' "Cannot determine Koji user: kerberos klist not installed - try --user" _ -> error' $ "Do not know how to determine Koji user for " ++ server muserid <- kojiGetUserID server user- when (isNothing muserid) $ warning "userid not found"+ when (isNothing muserid) $ error' "userid not found" return muserid