diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,36 @@ # Version history of koji-tool +## 1.0 (2023-04-24) +- 'builds': fix --install to use nvr instead of taskid +- 'install': allow installing from an ongoing build; add kojiGetBuildTaskRPMs +- 'install': change download dir to (xdg) ~/Downloads/koji-tool/ +- 'install': curl don't need/print progress for debug +- 'install': error if no rpms found +- 'install' now supports --arch option +- 'progress': correctly use parent taskid when given child id +- 'progress': drop redundant duplicate debug option +- 'progress': when given build don't query with state/method/user +- 'progress': improve size formatting +- 'progress': no longer hide archs nor repeat output when no progress +- 'tasks': improved request logic +- 'tasks': increase log tail size to 6000B +- 'tasks': bump root.log threshold to <4000 +- 'tasks': separate taskid errors for --user, time, and filter +- 'buildlog-sizes': handle ongoing builds and show build states +- 'buildlog-sizes': try appending a * to pattern: might be a package name +- DownloadDir: simplify the logic considerably +- Install installRPMs: revert to old 0.9.5 reinstall behavior +- base times off `create_time` rather than `start_time` +- getTasks factored from tasksCmd for progress; lookupTime changes + +## 0.9.6 (2022-11-05) +- install: completely rework subpackage selection logic +- install: separate --except from --exclude and rename --add to --include +- install: --no-reinstall and --skip-existing skip rpms before rpms selection +- install: show installed states with character symbol prefixes +- tasks: add --hw-info for hw_info.log and --grep to filter logs +- progress: back-off up to 5 times + ## 0.9.5 (2022-09-12) - 'install': fix determination of package name from srpm - 'progress': correctly determine NVR from srpm again diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -23,11 +23,12 @@ ## Commands ```shellsession $ koji-tool --version -0.9.5 +1.0 $ koji-tool --help Query and track Koji tasks, and install rpms from Koji. Usage: koji-tool [--version] COMMAND + see https://github.com/juhp/koji-tool#readme Available options: @@ -45,7 +46,8 @@ buildlog-sizes Show buildlog sizes for nvr patterns find Simple quick common queries using words like: [my, last, fail, complete, current, build, detail, - install, tail, notail, x86_64, PACKAGE, USER\'s] + install, tail, notail, hwinfo, x86_64, PACKAGE, + USER\'s] ``` ## koji-tool builds @@ -72,6 +74,7 @@ [-i|--install INSTALLOPTS] [-D|--debug] [(-b|--build NVR/BUILDID) | (-p|--pattern NVRPAT) | PACKAGE] + Query Koji builds (by default lists the most recent builds) Available options: @@ -135,11 +138,12 @@ [(-L|--latest) | (-l|--limit INT)] [-s|--state STATE] [-a|--arch ARCH] [(-B|--before TIMESTAMP) | (-F|--from TIMESTAMP)] - [-m|--method METHOD] [-d|--details] [-D|--debug] + [-m|--method METHOD] [-D|--debug] [(-P|--only-package PKG) | (-N|--only-nvr PREFIX)] - [-T|--tail] [-i|--install INSTALLOPTS] + [-d|--details] [-T|--tail] [--hw-info] [-g|--grep STRING] [(-b|--build BUILD) | (-p|--pattern NVRPAT) | PACKAGE|TASKID] + Query Koji tasks (by default lists the most recent buildArch tasks) Available options: @@ -156,12 +160,13 @@ -F,--from TIMESTAMP Tasks completed after timedate -m,--method METHOD Select tasks by method (default 'buildArch'): all,appliance,build,buildArch,buildContainer,buildMaven,buildNotification,buildSRPMFromSCM,chainbuild,chainmaven,createAppliance,createContainer,createImage,createLiveCD,createLiveMedia,createdistrepo,createrepo,dependantTask,distRepo,image,indirectionimage,livecd,livemedia,maven,newRepo,rebuildSRPM,runroot,tagBuild,tagNotification,vmExec,waitrepo,winbuild,wrapperRPM - -d,--details Show more details of builds -D,--debug Pretty-print raw XML result -P,--only-package PKG Filter task results to specified package -N,--only-nvr PREFIX Filter task results by NVR prefix + -d,--details Show more details of builds -T,--tail Fetch the tail of build.log - -i,--install INSTALLOPTS Install the package with 'install' options + --hw-info Fetch hw_info.log + -g,--grep STRING Filter matching log lines -b,--build BUILD List child tasks of build -p,--pattern NVRPAT Build tasks of matching pattern -h,--help Show this help text @@ -197,9 +202,16 @@ https://kojipkgs.fedoraproject.org/work/tasks/5316/86685316/build.log (13kB) ``` -It is also possible to install packages from a task using `--install "..."`. +It is also possible to install packages from a task using +`--install "SUBPKG OPTIONS"`. See the install command documentation below for more details. +Use `--tail` to show the tail of the build.log: it falls back to root.log +automatically if the build.log is considered too small. +Use `--hw-info` to display hw_info.log instead. +Also using the `--grep` option one can filter the log output for lines matching +the given string (accepts leading `^` and trailing `$`). + ## koji-tool install Download and install rpms from a Koji build or task. @@ -222,13 +234,13 @@ Use `--disttag` suffix to select a different Fedora version. ```shellsession -$ koji-tool install TASKID --exclude "*-devel" +$ koji-tool install TASKID --except "*-devel" ``` will install all the non-devel subpackages from the task. A more complex example: ```shellsession -$ koji-tool install google-noto-fonts --prefix google-noto -p 'sans-*-vf-fonts' -x 'sans-*-ui-vf-fonts' +$ koji-tool install google-noto-fonts --prefix google-noto --package 'sans-*-vf-fonts' --exclude 'sans-*-ui-vf-fonts' ``` installs all the Google Noto Sans variable fonts excluding UI faces. @@ -239,35 +251,42 @@ By default only installed subpackages are downloaded and updated, but the following options change the behavior: -`--package`: select subpackages by name or glob pattern (this doesn't work currently for multiple builds/tasks) +`--package`: select subpackages by name or glob pattern -`--exclude`: exclude subpackages by name or glob pattern +`--except`: select subpackages not matching name or glob pattern +`--exclude`: exclude subpackages by name or glob pattern (overrides --package and --except) + +`--include`: include subpackages by name or glob pattern (overrides --exclude) + `--all`: install all subpackages `--ask`: ask about each subpackage `--prefix`: override the subpackage prefix +Subpackage selection has only been tested so far for a single build/task. + ### Help ```shellsession $ 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] [--rpm | --rpm-ostree | --dnf] + [-a|--arch ARCH] [(-N|--no-reinstall) | (-S|--skip-existing)] [-b|--prefix SUBPKGPREFIX] [--all | --ask | [-p|--package SUBPKG] - [-a|--add SUBPKG] [-x|--exclude SUBPKG]] - [-d|--disttag DISTTAG] [(-R|--nvr) | (-V|--nv)] - PKG|NVR|TASKID... + [-e|--except SUBPKG] [-x|--exclude SUBPKG] + [-i|--include SUBPKG]] [-d|--disttag DISTTAG] + [(-R|--nvr) | (-V|--nv)] PKG|NVR|TASKID... + Install rpm packages directly from a Koji build task Available options: -n,--dry-run Don't actually download anything -D,--debug More detailed output - -y,--yes Assume yes to questions (implies --all if not - installed) + -y,--yes Assume yes to questions -H,--hub HUB KojiHub shortname or url (HUB = fedora, stream, rpmfusion, or URL) [default: fedora] -P,--packages-url URL KojiFiles packages url [default: Fedora] @@ -277,15 +296,17 @@ --rpm Use rpm instead of dnf --rpm-ostree Use rpm-ostree instead of dnf --dnf Use dnf to install [default unless ostree] + -a,--arch ARCH Task arch -N,--no-reinstall Do not reinstall existing NVRs -S,--skip-existing Ignore already installed subpackages (implies --no-reinstall) -b,--prefix SUBPKGPREFIX Prefix to use for subpackages [default: base package] - --all all subpackages - --ask ask for each subpackge [default if not installed] - -p,--package SUBPKG Subpackage (glob) to install - -a,--add SUBPKG Additional subpackage (glob) to install - -x,--exclude SUBPKG Subpackage (glob) not to install + --all all subpackages [default if not installed] + --ask ask for each subpackage + -p,--package SUBPKG select subpackage (glob) matches + -e,--except SUBPKG select subpackages not matching (glob) + -x,--exclude SUBPKG deselect subpackage (glob): overrides -p and -e + -i,--include SUBPKG additional subpackage (glob) to install: overrides -x -d,--disttag DISTTAG Select a disttag different to system -R,--nvr Give an N-V-R instead of package name -V,--nv Give an N-V instead of package name @@ -317,6 +338,7 @@ install tail notail +hwinfo x86_64 aarch64 ppc64le s390x i686 armv7hl PACKAGE USER\'s @@ -330,18 +352,25 @@ This is useful for monitoring the build progress of large packages that take a long time to complete for which some arch's may take considerably longer. +By default it shows progress of the user's builds. + ### Usage ```shellsession -$ koji-tool progress --mine -: -$ koji-tool progress 81148584 # ← Koji taskid +$ koji-tool progress : -23:19:19 vim-8.2.4068-1.fc36 (81148584) -aarch64 351kB [109,133 B/min] -armhfp 133kB [ 65,244 B/min] -ppc64le 493kB [141,598 B/min] TaskClosed -s390x 558kB [100,481 B/min] TaskClosed +$ koji-tool progress 93808251 # ← Koji taskid +21:39:41 webkitgtk-2.38.2-1.eln123 (93808251) 9h 32m +aarch64 87,669kB (16:50:31) 3h 55m TaskClosed +i386 88,120kB (16:33:14) 4h 21m TaskClosed +noarch 3kB (12:11:19) 3m 28s TaskClosed SRPM +ppc64le 85,853kB (21:25:42) +s390x 87,692kB (21:20:43) 9h 11m TaskClosed +x86_64 89,914kB (19:57:47) 7h 48m TaskClosed + +21:47:57 webkitgtk-2.38.2-1.eln123 (93808251) 89914kB, 9h 40m +ppc64le 88,117kB (21:47:21) [ 1,742 B/s] (1299s) + : ``` @@ -353,8 +382,9 @@ ## Build `cabal-rpm builddep && cabal install || stack install` -## History -The query, install, progress, buildlog-sizes were originally separate programs -and projects (koji-query, koji-install, koji-progress), -and merged together into koji-install (after 0.5) and renamed -to koji-tool. See the other original repos for their history. +## Contributing +koji-tool is distributed under a BSD license. + +Bug reports and contributions are welcomed: +please propose suggestions and changes at: +https://github.com/juhp/koji-tool/ diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,3 +1,8 @@ +use koji --profile ! + +'tasks' lists too many tasks for package +- eg koji-tool tasks -l2 ghc9.2 -a x86_64 -m buildarch + # hubs - hub configurations - determine urls for logs etc by parsing html @@ -27,10 +32,9 @@ ## tasks - determine username for non-Fedora -- build pattern - different hubs put builds in different locations - html output -- grep buildlog +- --rootlog ## builds - --show-tags @@ -56,5 +60,10 @@ - screen mode inplace tui +# install +- put package lists into Set's + +# misc - list binary packages (install does this, but not obvious) - diff build command +- diff root.log diff --git a/koji-tool.cabal b/koji-tool.cabal --- a/koji-tool.cabal +++ b/koji-tool.cabal @@ -1,5 +1,5 @@ name: koji-tool -version: 0.9.5 +version: 1.0 synopsis: Koji CLI tool for querying tasks and installing builds description: koji-tool is a CLI interface to Koji with commands to query @@ -10,7 +10,7 @@ license-file: LICENSE author: Jens Petersen maintainer: Jens Petersen -copyright: 2021-2022 Jens Petersen +copyright: 2021-2023 Jens Petersen category: Utility homepage: https://github.com/juhp/koji-tool bug-reports: https://github.com/juhp/koji-tool/issues @@ -19,11 +19,12 @@ ChangeLog.md TODO cabal-version: 1.18 -tested-with: GHC== 8.4.4 - || == 8.6.5 +tested-with: GHC== 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 + || == 9.2.7 + || == 9.4.4 source-repository head type: git diff --git a/src/BuildlogSizes.hs b/src/BuildlogSizes.hs --- a/src/BuildlogSizes.hs +++ b/src/BuildlogSizes.hs @@ -15,7 +15,7 @@ import Data.Char (isDigit) import Data.RPM.NVR -import Data.List (sortOn) +import Data.List.Extra (sortOn, splitOn) --import Data.Maybe #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) @@ -33,43 +33,62 @@ import SimpleCmdArgs -import Common (commonBuildQueryOptions) +import Common (commonBuildQueryOptions, getBuildState) -- FIXME split off arch suffix -- FIXME show build duration +-- FIXME allow buildid buildlogSizesCmd :: String -> IO () buildlogSizesCmd nvrpat = do - if all isDigit nvrpat -- check if taskid (not buildid) - then do - buildlogSizes (read nvrpat) + if all isDigit nvrpat -- taskid + then buildlogSizes (read nvrpat) else do -- find builds + let pat = + if '*' `notElem` nvrpat && length (splitOn "-" nvrpat) < 3 + then nvrpat ++ "*" + else nvrpat results <- listBuilds fedoraKojiHub - [("pattern", ValueString nvrpat), + [("pattern", ValueString pat), commonBuildQueryOptions 5] - mapM_ getResult results + if null results + then if '*' `notElem` pat + then buildlogSizesCmd $ nvrpat ++ "*" + else putStrLn $ "no NVRs found for pattern: " ++ pat + else mapM_ getResult results where getResult :: Struct -> IO () getResult bld = do putStrLn "" case lookupStruct "nvr" bld of Just nvr -> do - putStrLn nvr - nvrBuildlogSizes nvr - Nothing -> do - let mtid = - lookupStruct "task_id" bld <|> - (lookupStruct "extra" bld >>= lookupStruct "task_id") - case mtid :: Maybe Int of - Nothing -> error "no taskid found!" - Just tid -> buildlogSizes tid + putStrLn $ nvr ++ + maybe "" (\s -> " (" ++ show s ++ ")") (getBuildState bld) + ok <- nvrBuildlogSizes nvr + unless ok $ taskResult bld + Nothing -> taskResult bld -nvrBuildlogSizes :: String -> IO () -nvrBuildlogSizes bld = do - let (NVR n (VerRel v r)) = readNVR bld + taskResult :: Struct -> IO () + taskResult bld = do + let mtid = + lookupStruct "task_id" bld <|> + (lookupStruct "extra" bld >>= lookupStruct "task_id") + case mtid :: Maybe Int of + Nothing -> error "no taskid found!" + Just tid -> buildlogSizes tid + +nvrBuildlogSizes :: String -> IO Bool +nvrBuildlogSizes nvr = do + let (NVR n (VerRel v r)) = readNVR nvr logsdir = "https://kojipkgs.fedoraproject.org/packages" +/+ n +/+ v +/+ r +/+ "data/logs/" - archs <- map (T.unpack . noTrailingSlash) <$> httpDirectory' logsdir - forM_ archs $ \arch -> - doGetBuildlogSize (logsdir +/+ arch +/+ "build.log") arch + exists <- httpExists' logsdir + if exists + then do + archs <- map (T.unpack . noTrailingSlash) <$> httpDirectory' logsdir + forM_ archs $ \arch -> + doGetBuildlogSize (logsdir +/+ arch +/+ "build.log") arch + return True + else + return False buildlogSizes :: Int -> IO () buildlogSizes tid = do diff --git a/src/Builds.hs b/src/Builds.hs --- a/src/Builds.hs +++ b/src/Builds.hs @@ -6,7 +6,7 @@ BuildReq(..), Details(..), buildsCmd, - parseBuildState, + parseBuildState', fedoraKojiHub, kojiBuildTypes, latestCmd @@ -48,7 +48,6 @@ data Details = DetailDefault | Detailed | DetailedTasks deriving Eq --- FIXME add --install buildsCmd :: Maybe String -> Maybe UserOpt -> Int -> [BuildState] -> Maybe Tasks.BeforeAfter -> Maybe String -> Details -> Maybe Tasks.Select -> Bool -> BuildReq -> IO () @@ -64,7 +63,7 @@ then InfoID (read bld) else InfoString bld mbld <- getBuild hub bldinfo - whenJust (mbld >>= maybeBuildResult) $ printBuild hub tz details minstall + whenJust (mbld >>= maybeBuildResult) $ printBuild hub tz details debug minstall BuildPackage pkg -> do when (head pkg == '-') $ error' $ "bad combination: not a package: " ++ pkg @@ -81,7 +80,7 @@ builds <- listBuilds hub fullquery when debug $ mapM_ pPrintCompact builds if details /= DetailDefault || length builds == 1 - then mapM_ (printBuild hub tz details minstall) $ mapMaybe maybeBuildResult builds + then mapM_ (printBuild hub tz details debug minstall) $ mapMaybe maybeBuildResult builds else mapM_ putStrLn $ mapMaybe (shortBuildResult tz) builds _ -> do query <- setupQuery @@ -90,7 +89,7 @@ builds <- listBuilds hub fullquery when debug $ mapM_ pPrintCompact builds if details /= DetailDefault || length builds == 1 - then mapM_ (printBuild hub tz details minstall) $ mapMaybe maybeBuildResult builds + then mapM_ (printBuild hub tz details debug minstall) $ mapMaybe maybeBuildResult builds else mapM_ putStrLn $ mapMaybe (shortBuildResult tz) builds where hub = maybe fedoraKojiHub hubURL mhub @@ -100,7 +99,7 @@ nvr <- lookupStruct "nvr" bld state <- readBuildState <$> lookupStruct "state" bld let date = - case lookupTimes bld of + case lookupBuildTimes bld of Nothing -> "" Just (start,mend) -> compactZonedTime tz $ fromMaybe start mend @@ -163,7 +162,7 @@ maybeBuildResult :: Struct -> Maybe BuildResult maybeBuildResult st = do - (start,mend) <- lookupTimes st + (start,mend) <- lookupBuildTimes st buildid <- lookupStruct "build_id" st -- buildContainer has no task_id let mtaskid = lookupStruct "task_id" st @@ -172,9 +171,9 @@ return $ BuildResult nvr state buildid mtaskid start mend -printBuild :: String -> TimeZone -> Details -> Maybe Tasks.Select +printBuild :: String -> TimeZone -> Details -> Bool -> Maybe Tasks.Select -> BuildResult -> IO () -printBuild hub tz details minstall build = do +printBuild hub tz details debug minstall build = do putStrLn "" let mendtime = mbuildEndTime build time <- maybe getCurrentTime return mendtime @@ -184,10 +183,10 @@ 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) + Tasks.tasksCmd (Just hub) (Tasks.QueryOpts Nothing 7 [] [] Nothing Nothing False Nothing) False False 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] + installCmd False debug No (Just hub) Nothing False False False Nothing Nothing Nothing Nothing installopts Nothing ReqNVR [showNVR (buildNVR build)] formatBuildResult :: String -> Bool -> TimeZone -> BuildResult -> [String] formatBuildResult hub ended tz (BuildResult nvr state buildid mtaskid start mendtime) = @@ -209,9 +208,10 @@ #if !MIN_VERSION_koji(0,0,3) buildStateToValue :: BuildState -> Value buildStateToValue = ValueInt . fromEnum +#endif -parseBuildState :: String -> BuildState -parseBuildState s = +parseBuildState' :: String -> BuildState +parseBuildState' s = case lower s of "building" -> BuildBuilding "complete" -> BuildComplete @@ -220,11 +220,8 @@ "failed" -> BuildFailed "cancel" -> BuildCanceled "canceled" -> BuildCanceled - _ -> error' $! "unknown build state: " ++ s -#endif - -getBuildState :: Struct -> Maybe BuildState -getBuildState st = readBuildState <$> lookup "state" st + _ -> error' $! "unknown build state: " ++ s ++ + "\nknown states are: building, complete, deleted, failed, canceled" kojiBuildTypes :: [String] kojiBuildTypes = ["all", "image", "maven", "module", "rpm", "win"] @@ -235,4 +232,4 @@ mbld <- kojiLatestBuild hub tag pkg when debug $ print mbld tz <- getCurrentTimeZone - whenJust (mbld >>= maybeBuildResult) $ printBuild hub tz Detailed Nothing + whenJust (mbld >>= maybeBuildResult) $ printBuild hub tz Detailed debug Nothing diff --git a/src/Common.hs b/src/Common.hs --- a/src/Common.hs +++ b/src/Common.hs @@ -3,12 +3,14 @@ hubURL, commonQueryOptions, commonBuildQueryOptions, - webUrl + webUrl, + getBuildState ) where import Data.List.Extra (dropSuffix, isPrefixOf) -import Distribution.Koji (fedoraKojiHub, Value(..)) +import Distribution.Koji (fedoraKojiHub, Value(..), Struct, BuildState, + readBuildState) import SimpleCmd (error') -- mbox kojihub is locked @@ -38,3 +40,6 @@ webUrl :: String -> String webUrl = dropSuffix "hub" + +getBuildState :: Struct -> Maybe BuildState +getBuildState st = readBuildState <$> lookup "state" st diff --git a/src/DownloadDir.hs b/src/DownloadDir.hs --- a/src/DownloadDir.hs +++ b/src/DownloadDir.hs @@ -1,11 +1,10 @@ module DownloadDir ( - setDownloadDir) + setDownloadDir + ) where import Control.Monad -import SimpleCmd (error') -import System.Directory (createDirectoryIfMissing, - doesDirectoryExist, getHomeDirectory, +import System.Directory (createDirectoryIfMissing, getHomeDirectory, setCurrentDirectory) import System.Environment.XDG.UserDir (getUserDir) import System.FilePath @@ -15,32 +14,12 @@ setDownloadDir dryrun subdir = do home <- getHomeDirectory dlDir <- getUserDir "DOWNLOAD" - dirExists <- doesDirectoryExist dlDir - -- is this really necessary? - unless (dryrun || dirExists) $ - when (home == dlDir) $ - error' "HOME directory does not exist!" - let filesDir = dlDir subdir - filesExists <- doesDirectoryExist filesDir - dir <- - if filesExists - then setCWD filesDir - else - if dirExists - then setCWD dlDir - else do - if dryrun - then return dlDir - else do - createDirectoryIfMissing True dlDir - setCWD dlDir + let dir = dlDir subdir + unless dryrun $ do + createDirectoryIfMissing True dir + setCurrentDirectory dir let path = makeRelative home dir return $ putStrLn $ "Packages downloaded to " ++ if isRelative path then "~" path else path - where - setCWD :: FilePath -> IO FilePath - setCWD dir = do - setCurrentDirectory dir - return dir diff --git a/src/Find.hs b/src/Find.hs --- a/src/Find.hs +++ b/src/Find.hs @@ -20,7 +20,7 @@ import User ( UserOpt(User, UserSelf) ) data Words = Mine | Limit | Failure | Complete | Current | Build | Detail - | Install | Tail | NoTail | Arch + | Install | Tail | NoTail | Hwinfo | Arch deriving (Enum,Bounded) findWords :: Words -> [String] @@ -36,6 +36,7 @@ findWords Install = ["install"] findWords Tail = ["tail"] findWords NoTail = ["notail"] +findWords Hwinfo = ["hwinfo"] findWords Arch = ["x86_64", "aarch64", "ppc64le", "s390x", "i686", "armv7hl"] wordsList :: ([String] -> String) -> [String] @@ -46,7 +47,7 @@ allWords = concatMap findWords [minBound..] -- FIXME: time: today, yesterday, week --- FIXME: method +-- FIXME: methods -- FIXME: mlt (or mlft) -- FIXME: separate last and latest? findCmd :: Maybe String -> Bool -> [String] -> IO () @@ -71,6 +72,7 @@ install = hasWord Install tail' = hasWord Tail notail = hasWord NoTail + hwinfo = hasWord Hwinfo mpkg = case removeUsers (args \\ allWords) of [] -> Nothing @@ -80,7 +82,9 @@ error' $ "you can only specify one package - too many unknown words: " ++ unwords other - installation = if install then Just (Tasks.PkgsReq [] [] []) else Nothing + installation = if install + then Just (Tasks.PkgsReq [] [] [] []) + else Nothing if build then let states = [BuildFailed|failure] ++ [BuildComplete|complete] ++ @@ -92,7 +96,7 @@ 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 + in Tasks.tasksCmd mhub (Tasks.QueryOpts user limit states archs Nothing Nothing debug Nothing) detail ((tail' || failure) && not notail) hwinfo Nothing taskreq where hasWord :: Words -> Bool hasWord word = any (`elem` findWords word) args diff --git a/src/Install.hs b/src/Install.hs --- a/src/Install.hs +++ b/src/Install.hs @@ -15,6 +15,7 @@ where import Control.Monad.Extra +import Data.Functor ((<&>)) import Data.List.Extra import Data.Either (partitionEithers) import Data.Maybe @@ -41,7 +42,7 @@ data Select = All | Ask - | PkgsReq [String] [String] [String] -- ^ include, add, exclude + | PkgsReq [String] [String] [String] [String] -- include, except, exclude, add deriving Eq installArgs :: String -> Select @@ -51,62 +52,84 @@ ["--all"] -> All ["-A"] -> Ask ["--ask"] -> Ask - ws -> installPairs [] [] [] ws + ws -> installPairs [] [] [] [] ws where - installPairs :: [String] -> [String] -> [String] -> [String] -> Select - installPairs inst add excl [] = PkgsReq inst add excl - installPairs inst add excl (w:ws) + 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') -> installPairs (w':inst) add excl ws' - | w == "--add" = + [] -> 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 --add missing value" - (w':ws') -> installPairs inst (w':add) excl ws' + [] -> 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') -> installPairs inst add (w':excl) ws' - | otherwise = error' "invalid --install-opts" + [] -> 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 + data Request = ReqName | ReqNV | ReqNVR deriving Eq data PkgMgr = DNF | RPM | OSTREE deriving Eq -data ExistingStrategy = ExistingUpdate | ExistingNoReinstall | ExistingSkip +data ExistingStrategy = ExistingNoReinstall | ExistingSkip --- FIXME --include devel, --exclude * +-- FIXME support buildid -- FIXME specify tag or task +-- FIXME support --latest -- FIXME support enterprise builds --- FIXME --arch (including src) -- FIXME --debuginfo -- FIXME --delete after installing -- 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 -> 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 + -> Bool -> Bool -> Maybe PkgMgr -> Maybe String + -> Maybe ExistingStrategy -> Maybe String -> Select -> Maybe String + -> Request -> [String] -> IO () +installCmd dryrun debug yes mhuburl mpkgsurl listmode latest checkremotetime mmgr march mstrategy mprefix select mdisttag request pkgbldtsks = do + checkSelection select let huburl = maybe fedoraKojiHub hubURL mhuburl pkgsurl = fromMaybe (hubToPkgsURL huburl) mpkgsurl when debug $ do putStrLn huburl putStrLn pkgsurl - printDlDir <- setDownloadDir dryrun "rpms" + printDlDir <- setDownloadDir dryrun "koji-tool" when debug printDlDir setNoBuffering - buildrpms <- mapM (kojiRPMs huburl pkgsurl printDlDir) pkgbldtsks - installRPMs dryrun debug mmgr existingStrategy yes buildrpms + buildrpms <- mapM (kojiRPMs huburl pkgsurl printDlDir) $ nubOrd pkgbldtsks + installRPMs dryrun debug mmgr yes buildrpms where + 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 () + 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 existingStrategy mprefix select checkremotetime printDlDir taskid + Just taskid -> kojiTaskRPMs dryrun debug yes huburl pkgsurl listmode march mstrategy mprefix select checkremotetime printDlDir taskid Nothing -> kojiBuildRPMs huburl pkgsurl printDlDir bldtask kojiBuildRPMs :: String -> String -> IO () -> String @@ -119,42 +142,44 @@ dist <- cmd "rpm" ["--eval", "%{dist}"] return $ if dist == "%{dist}" then "" else dist nvrs <- map readNVR <$> kojiBuildOSBuilds debug huburl listmode latest disttag request pkgbld - if listmode - then do - 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 - [] -> error' $ pkgbld ++ " not found for " ++ disttag - [nvr] -> do - putStrLn $ showNVR nvr ++ "\n" - 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 - dlRpms <- decideRpms yes listmode existingStrategy select prefix nvras - when debug $ mapM_ printInstalled dlRpms - let subdir = showNVR nvr - unless (dryrun || null dlRpms) $ do - bld <- kojiGetBuild' huburl nvr - -- FIXME should be NVRA ideally - downloadRpms debug checkremotetime (lookupTimes' bld) subdir (buildURL nvr) dlRpms - -- FIXME once we check file size - can skip if no downloads - printDlDir - return (subdir,dlRpms) - _ -> error $ "multiple build founds for " ++ pkgbld ++ ": " ++ + case nvrs of + [] -> error' $ pkgbld ++ " not found for " ++ disttag + [nvr] -> do + putStrLn $ showNVR nvr ++ "\n" + bid <- kojiGetBuildID' huburl (showNVR nvr) + nvras <- sort . map readNVRA . filter notDebugPkg <$> kojiGetBuildRPMs huburl nvr march bid + results <- + if null nvras + then do + mtid <- kojiGetBuildTaskID huburl (showNVR nvr) + case mtid of + Just (TaskId tid) -> + kojiTaskRPMs dryrun debug yes huburl pkgsurl listmode march mstrategy mprefix select checkremotetime printDlDir tid + Nothing -> error' $ "task id not found for" +-+ showNVR nvr + else do + when debug $ mapM_ (putStrLn . showNVRA) nvras + let prefix = fromMaybe (nvrName nvr) mprefix + dlRpms <- decideRpms yes listmode mstrategy select prefix nvras + when debug $ mapM_ printInstalled dlRpms + let subdir = showNVR nvr + unless listmode $ do + unless (dryrun || null dlRpms) $ do + bld <- kojiGetBuild' huburl nvr + -- FIXME should be NVRA ideally + downloadRpms debug checkremotetime (strictLookupTimes lookupBuildTimes bld) subdir (buildURL nvr) dlRpms + -- FIXME once we check file size - can skip if no downloads + printDlDir + return (subdir,dlRpms) + return $ + if listmode + then ("",[]) + else results + _ -> + if listmode + then do + mapM_ (putStrLn . showNVR) nvrs + return ("",[]) + else error $ "multiple build founds for " ++ pkgbld ++ ": " ++ unwords (map showNVR nvrs) where buildURL :: NVR -> String -> String @@ -166,32 +191,38 @@ notDebugPkg p = not ("-debuginfo-" `isInfixOf` p || "-debugsource-" `isInfixOf` p) -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 +kojiTaskRPMs :: Bool -> Bool -> Yes -> String -> String -> Bool -> Maybe String + -> Maybe ExistingStrategy -> Maybe String -> Select -> Bool + -> IO () -> Int -> IO (FilePath, [(Existence,NVRA)]) +kojiTaskRPMs dryrun debug yes huburl pkgsurl listmode march mstrategy mprefix select checkremotetime printDlDir taskid = do mtaskinfo <- Koji.getTaskInfo huburl taskid True tasks <- case mtaskinfo of Nothing -> error' "failed to get taskinfo" - Just taskinfo -> do - when debug $ mapM_ print taskinfo + Just taskinfo -> case lookupStruct "method" taskinfo :: Maybe String of Nothing -> error' $ "no method found for " ++ show taskid Just method -> case method of - "build" -> Koji.getTaskChildren huburl taskid True + "build" -> do + when debug $ mapM_ print taskinfo >> putStrLn "" + Koji.getTaskChildren huburl taskid True "buildArch" -> return [taskinfo] _ -> error' $ "unsupport method: " ++ method - sysarch <- cmd "rpm" ["--eval", "%{_arch}"] + arch <- + case march of + Nothing -> cmd "rpm" ["--eval", "%{_arch}"] + Just ar -> return ar let (archtid,archtask) = - case find (selectBuildArch sysarch) tasks of - Nothing -> error' $ "no " ++ sysarch ++ " task found" + case find (selectBuildArch arch) tasks of + Nothing -> error' $ "no " ++ arch ++ " task found" Just task' -> case lookupStruct "id" task' of Nothing -> error' "task id not found" Just tid -> (tid,task') when debug $ mapM_ print archtask nvras <- getTaskNVRAs archtid + when (null nvras) $ + error' $ "no rpms found for" +-+ show archtid prefix <- case mprefix of Just pref -> return pref Nothing -> @@ -201,37 +232,31 @@ return $ either id nvrName $ kojiTaskRequestNVR archtask if listmode then do - drpms <- decideRpms yes listmode existingStrategy select prefix nvras + drpms <- decideRpms yes listmode mstrategy select prefix nvras return ("",drpms) - else - if null nvras - then do - (_, 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 existingStrategy select prefix $ + dlRpms <- decideRpms yes listmode mstrategy select prefix $ filter ((/= "src") . rpmArch) nvras when debug $ mapM_ printInstalled dlRpms let subdir = show archtid unless (dryrun || null dlRpms) $ do - downloadRpms debug checkremotetime (lookupTimes' archtask) subdir (taskRPMURL archtid) dlRpms + downloadRpms debug checkremotetime (strictLookupTimes lookupTaskTimes archtask) subdir (taskRPMURL archtid) dlRpms printDlDir return (subdir,dlRpms) where selectBuildArch :: String -> Struct -> Bool - selectBuildArch sysarch t = - let march = lookupStruct "arch" t + selectBuildArch arch t = + let march' = lookupStruct "arch" t mmethod = lookupStruct "method" t - in march `elem` [Just sysarch,Just "noarch"] && + in march' `elem` [Just arch,Just "noarch"] && mmethod == Just "buildArch" getTaskNVRAs :: Int -> IO [NVRA] getTaskNVRAs taskid' = - sort . map readNVRA . filter notDebugPkg . filter (".rpm" `isExtensionOf`) . map fst <$> -- FIXME get stats to show size - Koji.listTaskOutput huburl taskid' False True False + Koji.listTaskOutput huburl taskid' False True False <&> + sort . map readNVRA . filter notDebugPkg . filter (".rpm" `isExtensionOf`) . map fst taskRPMURL :: Int -> String -> String taskRPMURL taskid' rpm = @@ -243,68 +268,83 @@ data Existence = ExistingNVR | ChangedNVR | NotInstalled deriving (Eq, Ord, Show) --- FIXME ExistingStrategy isn't used, so output doesn't reflect it -- FIXME determine and add missing internal deps -decideRpms :: Yes -> Bool -> ExistingStrategy -> Select -> String -> [NVRA] - -> IO [(Existence,NVRA)] -decideRpms yes listmode existingStrategy select prefix nvras = do - classified <- mapM installExists (filter isBinaryRpm nvras) +decideRpms :: Yes -> Bool -> Maybe ExistingStrategy -> Select -> String + -> [NVRA] -> IO [(Existence,NVRA)] +decideRpms yes listmode mstrategy select prefix nvras = do + classified <- mapMaybeM installExists (filter isBinaryRpm nvras) if listmode then do case select of - PkgsReq subpkgs addpkgs exclpkgs -> do - let install = selectRPMs False prefix (subpkgs,addpkgs,exclpkgs) classified - mapM_ printInstalled install + PkgsReq subpkgs exceptpkgs exclpkgs addpkgs -> + mapM_ printInstalled $ + selectRPMs prefix (subpkgs,exceptpkgs,exclpkgs,addpkgs) classified _ -> mapM_ printInstalled classified return [] else case select of - All -> do - promptPkgs yes classified + All -> promptPkgs yes classified Ask -> mapMaybeM (rpmPrompt yes) classified - PkgsReq [] addpkgs [] -> - let add = selectRPMs False prefix ([],addpkgs,[]) classified - in - if all ((== NotInstalled) . fst) classified && yes /= Yes - then (add ++) <$> decideRpms yes listmode existingStrategy Ask prefix nvras - else do - let install = add ++ filter ((/= NotInstalled) . fst) classified - if yes == Yes - then return install - else promptPkgs yes install - PkgsReq subpkgs addpkgs exclpkgs -> do - let install = selectRPMs False prefix (subpkgs,addpkgs,exclpkgs) classified - promptPkgs yes install + PkgsReq subpkgs exceptpkgs exclpkgs addpkgs -> + promptPkgs yes $ + selectRPMs prefix (subpkgs,exceptpkgs,exclpkgs,addpkgs) classified where - installExists :: NVRA -> IO (Existence, NVRA) + installExists :: NVRA -> IO (Maybe (Existence, NVRA)) installExists nvra = do minstalled <- cmdMaybe "rpm" ["-q", rpmName nvra] - return - (case minstalled of - Nothing -> NotInstalled - Just installed -> - if installed == showNVRA nvra then ExistingNVR else ChangedNVR, - nvra) + let existence = + case minstalled of + Nothing -> NotInstalled + Just installed -> + if installed == showNVRA nvra + then ExistingNVR + else ChangedNVR + return $ + case mstrategy of + Just ExistingSkip | existence /= NotInstalled -> Nothing + Just ExistingNoReinstall | existence == ExistingNVR -> Nothing + _ -> Just (existence, nvra) renderInstalled :: (Existence, NVRA) -> String -renderInstalled (exist, nvra) = showNVRA nvra ++ " (" ++ show exist ++ ")" +renderInstalled (exist, nvra) = + case exist of + ExistingNVR -> '=' + ChangedNVR -> '^' + NotInstalled -> '+' + : showNVRA nvra printInstalled :: (Existence, NVRA) -> IO () printInstalled = putStrLn . renderInstalled -selectRPMs :: Bool -> String -> ([String],[String],[String]) - -> [(Existence,NVRA)] -> [(Existence,NVRA)] -selectRPMs recurse prefix (subpkgs,[],[]) rpms = - sort . mconcat $ - flip map subpkgs $ \ pkgpat -> - case filter (match (compile pkgpat) . rpmName . snd) rpms of - [] -> if head pkgpat /= '*' && not recurse - then selectRPMs True prefix ([prefix ++ '-' : pkgpat],[],[]) rpms +defaultRPMs :: [(Existence,NVRA)] -> [(Existence,NVRA)] +defaultRPMs rpms = + let installed = filter ((/= NotInstalled) . fst) rpms + in if null installed + then rpms + else installed + +matchingRPMs :: String -> [String] -> [(Existence,NVRA)] -> [(Existence,NVRA)] +matchingRPMs prefix subpkgs rpms = + nubSort . mconcat $ + flip map (nubOrd subpkgs) $ \ pkgpat -> + case getMatches pkgpat of + [] -> if head pkgpat /= '*' + then + case getMatches (prefix ++ '-' : pkgpat) of + [] -> error' $ "no subpackage match for " ++ pkgpat + result -> result else error' $ "no subpackage match for " ++ pkgpat result -> result -selectRPMs _ prefix ([], [], subpkgs) rpms = + where + getMatches :: String -> [(Existence,NVRA)] + getMatches pkgpat = + filter (match (compile pkgpat) . rpmName . snd) rpms + +nonMatchingRPMs :: String -> [String] -> [(Existence,NVRA)] -> [(Existence,NVRA)] +nonMatchingRPMs _ [] _ = [] +nonMatchingRPMs prefix subpkgs rpms = -- FIXME somehow determine unused excludes - foldl' (exclude subpkgs) [] rpms + nubSort $ foldl' (exclude (nubOrd subpkgs)) [] rpms where rpmnames = map (rpmName . snd) rpms @@ -324,13 +364,22 @@ pat `notElem` rpmnames && (prefix ++ '-' : pat) == rpmname else match comppat rpmname -selectRPMs recurse prefix (subpkgs,addpkgs,exclpkgs) rpms = - let needed = selectRPMs recurse prefix (subpkgs,[],[]) rpms - added = selectRPMs recurse prefix (addpkgs,[],[]) rpms - excluded = selectRPMs recurse prefix (exclpkgs,[],[]) rpms - in nub . sort $ added ++ (needed \\ excluded) +selectRPMs :: String + -> ([String],[String],[String],[String]) -- (subpkgs,except,exclpkgs,addpkgs) + -> [(Existence,NVRA)] -> [(Existence,NVRA)] +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 + promptPkgs :: Yes -> [(Existence,NVRA)] -> IO [(Existence,NVRA)] +promptPkgs _ [] = error' "no rpms found" promptPkgs yes classified = do mapM_ printInstalled classified ok <- prompt yes "install above" @@ -383,7 +432,6 @@ then id else (("pattern", ValueString (if full then pkgpat else dropSuffix "*" pkgpat ++ "*" ++ disttag ++ "*")) :)) [("packageID", ValueInt pkgid), - ("state", ValueInt (fromEnum BuildComplete)), commonBuildQueryOptions (if listmode && not latest || oldkoji then 20 else 1)] when debug $ print opts @@ -411,16 +459,20 @@ case readNVR pat of NVR n _ -> (n, True) -kojiGetBuildRPMs :: String -> NVR -> BuildID -> IO [String] -kojiGetBuildRPMs huburl nvr (BuildId bid) = do +-- empty until build finishes +kojiGetBuildRPMs :: String -> NVR -> Maybe String -> BuildID -> IO [String] +kojiGetBuildRPMs huburl nvr march (BuildId bid) = do rpms <- Koji.listBuildRPMs huburl bid - sysarch <- cmd "rpm" ["--eval", "%{_arch}"] - return $ map getNVRA $ filter (forArch sysarch) rpms + arch <- + case march of + Nothing -> cmd "rpm" ["--eval", "%{_arch}"] + Just ar -> return ar + return $ map getNVRA $ filter (forArch arch) rpms where forArch :: String -> Struct -> Bool - forArch sysarch st = + forArch arch st = case lookupStruct "arch" st of - Just arch -> arch `elem` [sysarch, "noarch"] + Just a -> a `elem` [arch, "noarch"] Nothing -> error $ "No arch found for rpm for: " ++ showNVR nvr getNVRA :: Struct -> String @@ -440,18 +492,18 @@ data InstallType = ReInstall | Install --- FIXME ExistingStrategy should move to decideRpms -installRPMs :: Bool -> Bool -> Maybe PkgMgr -> ExistingStrategy -> Yes +installRPMs :: Bool -> Bool -> Maybe PkgMgr -> Yes -> [(FilePath,[(Existence,NVRA)])] -> IO () -installRPMs _ _ _ _ _ [] = return () -installRPMs dryrun debug mmgr existingStrategy yes classified = do +installRPMs _ _ _ _ [] = return () +installRPMs dryrun debug mmgr yes classified = do case installTypes classified of ([],is) -> doInstall Install is (ris,is) -> do - doInstall ReInstall (ris ++ is) - doInstall Install is + doInstall ReInstall (ris ++ is) -- include any new deps + doInstall Install is -- install any non-deps where - doInstall i dirpkgs = + doInstall :: InstallType -> [(FilePath,NVRA)] -> IO () + doInstall inst dirpkgs = unless (null dirpkgs) $ do mgr <- case mmgr of @@ -464,17 +516,11 @@ DNF -> "dnf" RPM -> "rpm" OSTREE -> "rpm-ostree" - mcom = - case i of - ReInstall -> - case existingStrategy of - ExistingUpdate -> Just (reinstallCommand mgr) - _ -> Nothing - Install -> - case existingStrategy of - ExistingSkip -> Nothing - _ -> Just (installCommand mgr) - in whenJust mcom $ \com -> + 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 @@ -540,7 +586,7 @@ return $ if notfile then Just url else Nothing unless (null urls) $ do putStrLn "downloading..." - cmd_ "curl" $ ["--remote-time", "--fail", "-C-", "--show-error", "--create-dirs", "--output-dir", subdir, "--remote-name-all", "--progress-bar", "--write-out", "%{filename_effective}\n"] ++ urls + cmd_ "curl" $ ["--remote-time", "--fail", "-C-", "--show-error", "--create-dirs", "--output-dir", subdir, "--remote-name-all", "--write-out", "%{filename_effective}\n"] ++ ["--progress-bar" | not debug] ++ urls where outOfDate :: String -> String -> IO Bool outOfDate file url = do diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -19,7 +19,7 @@ import Tasks main :: IO () -main = do +main = simpleCmdArgs (Just Paths_koji_tool.version) "Query and track Koji tasks, and install rpms from Koji." "see https://github.com/juhp/koji-tool#readme" $ @@ -28,10 +28,10 @@ "Query Koji builds (by default lists the most recent builds)" $ buildsCmd <$> hubOpt - <*> optional userOpt + <*> optional (userOpt False) <*> (flagWith' 1 'L' "latest" "Latest build" <|> optionalWith auto 'l' "limit" "INT" "Maximum number of builds to show [default: 10]" 10) - <*> many (parseBuildState <$> strOptionWith 's' "state" "STATE" "Filter builds by state (building,complete,deleted,fail(ed),cancel(ed)") + <*> 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))) @@ -48,27 +48,15 @@ "Query Koji tasks (by default lists the most recent buildArch tasks)" $ tasksCmd <$> hubOpt - <*> optional userOpt - <*> (flagWith' 1 'L' "latest" "Latest build or task" <|> - optionalWith auto 'l' "limit" "INT" "Maximum number of tasks to show [default: 10]" 10) - <*> many (parseTaskState <$> strOptionWith 's' "state" "STATE" "Filter tasks by state (open,close(d),cancel(ed),fail(ed),assigned,free)") - <*> many (strOptionWith 'a' "arch" "ARCH" "Task arch") - <*> optional (Before <$> strOptionWith 'B' "before" "TIMESTAMP" "Tasks completed before timedate [default: now]" <|> - After <$> strOptionWith 'F' "from" "TIMESTAMP" "Tasks completed after timedate") - <*> (fmap normalizeMethod <$> optional (strOptionWith 'm' "method" "METHOD" ("Select tasks by method (default 'buildArch'): " ++ intercalate "," kojiMethods))) + <*> queryOpts False "buildArch" <*> switchWith 'd' "details" "Show more details of builds" - <*> switchWith 'D' "debug" "Pretty-print raw XML result" -- FIXME error if integer (eg mistakenly taskid) - <*> 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" - <|> argumentWith (maybeReader readTaskReq) "PACKAGE|TASKID" - <|> pure TaskQuery) - + <*> switchLongWith "hw-info" "Fetch hw_info.log" + <*> optional (strOptionWith 'g' "grep" "STRING" "Filter matching log lines") + -- -- FIXME any way to pass --help to install? + -- <*> optional (installArgs <$> strOptionWith 'i' "install" "INSTALLOPTS" "Install the package with 'install' options") + <*> taskReqOpt , Subcommand "latest" "Query latest Koji build for tag" $ latestCmd @@ -82,7 +70,8 @@ installCmd <$> switchWith 'n' "dry-run" "Don't actually download anything" <*> switchWith 'D' "debug" "More detailed output" - <*> flagWith No Yes 'y' "yes" "Assume yes to questions (implies --all if not installed)" + -- FIXME add --no + <*> flagWith No Yes 'y' "yes" "Assume yes to questions" <*> hubOpt <*> optional (strOptionWith 'P' "packages-url" "URL" "KojiFiles packages url [default: Fedora]") @@ -90,7 +79,8 @@ <*> switchWith 'L' "latest" "Latest build" <*> switchWith 't' "check-remote-time" "Check remote rpm timestamps" <*> optional pkgMgrOpt - <*> existingOpt + <*> optional archOpt + <*> optional existingOpt <*> optional (strOptionWith 'b' "prefix" "SUBPKGPREFIX" "Prefix to use for subpackages [default: base package]") <*> selectOpt <*> optional disttagOpt @@ -101,12 +91,12 @@ , Subcommand "progress" "Track running Koji tasks by buildlog size" $ progressCmd - <$> switchWith 'D' "debug" "Pretty-print raw XML result" - <*> switchWith 'm' "modules" "Track module builds" - <*> many (TaskId <$> argumentWith auto "TASKID") + <$> switchWith 'm' "modules" "Track module builds" + <*> queryOpts True "build" + <*> taskReqOpt , Subcommand "buildlog-sizes" "Show buildlog sizes for nvr patterns" $ - buildlogSizesCmd <$> strArg "NVRPATTERN" + buildlogSizesCmd <$> strArg "NVRPATTERN|PKG|TASKID" , Subcommand "find" ("Simple quick common queries using words like: [" ++ @@ -122,19 +112,20 @@ intercalate ", " knownHubs ++ ") [default: fedora]")) - userOpt :: Parser UserOpt - userOpt = + userOpt :: Bool -> Parser UserOpt + userOpt mine = User <$> strOptionWith 'u' "user" "USER" "Koji user" - <|> flagWith' UserSelf 'M' "mine" "Your tasks (krb fasid)" + <|> if mine then pure UserSelf else flagWith' UserSelf 'M' "mine" "Your tasks (krb fasid)" selectOpt :: Parser Select selectOpt = - flagLongWith' All "all" "all subpackages" <|> - flagLongWith' Ask "ask" "ask for each subpackge [default if not installed]" <|> + flagLongWith' All "all" "all subpackages [default if not installed]" <|> + flagLongWith' Ask "ask" "ask for each subpackage" <|> PkgsReq - <$> many (strOptionWith 'p' "package" "SUBPKG" "Subpackage (glob) to install") - <*> many (strOptionWith 'a' "add" "SUBPKG" "Additional subpackage (glob) to install") - <*> many (strOptionWith 'x' "exclude" "SUBPKG" "Subpackage (glob) not to install") + <$> 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") disttagOpt :: Parser String disttagOpt = startingDot <$> @@ -171,4 +162,28 @@ existingOpt :: Parser ExistingStrategy existingOpt = flagWith' ExistingNoReinstall 'N' "no-reinstall" "Do not reinstall existing NVRs" <|> - flagWith ExistingUpdate ExistingSkip 'S' "skip-existing" "Ignore already installed subpackages (implies --no-reinstall)" + flagWith' ExistingSkip 'S' "skip-existing" "Ignore already installed subpackages (implies --no-reinstall)" + + -- FIXME check valid arch (eg i686 not i386) + archOpt = strOptionWith 'a' "arch" "ARCH" "Task arch" + + queryOpts :: Bool -> String -> Parser QueryOpts + queryOpts mine defaultMethod = + QueryOpts + <$> optional (userOpt mine) + <*> (flagWith' 1 'L' "latest" "Latest build or task" <|> + optionalWith auto 'l' "limit" "INT" "Maximum number of tasks to show [default: 10]" 10) + <*> many (fmap parseTaskState' $! strOptionWith 's' "state" "STATE" "Filter tasks by state (open,close(d),cancel(ed),fail(ed),assigned,free)") + <*> many archOpt + <*> optional (Before <$> strOptionWith 'B' "before" "TIMESTAMP" "Tasks completed before timedate [default: now]" <|> + After <$> strOptionWith 'F' "from" "TIMESTAMP" "Tasks completed after timedate") + <*> (fmap normalizeMethod <$> optional (strOptionWith 'm' "method" "METHOD" ("Select tasks by method (default '" ++ defaultMethod ++ "'): " ++ intercalate "," kojiMethods))) + <*> switchWith 'D' "debug" "Pretty-print raw XML result" + <*> 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") + + taskReqOpt = + Build <$> strOptionWith 'b' "build" "BUILD" "List child tasks of build" + <|> Pattern <$> strOptionWith 'p' "pattern" "NVRPAT" "Build tasks of matching pattern" + <|> argumentWith (maybeReader readTaskReq) "PACKAGE|TASKID" + <|> pure TaskQuery diff --git a/src/Progress.hs b/src/Progress.hs --- a/src/Progress.hs +++ b/src/Progress.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards #-} module Progress ( progressCmd, @@ -7,11 +6,8 @@ ) where -#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,0)) -#else -import Control.Applicative ((<$>), (<*>)) -#endif -import Control.Monad.Extra (liftM2, unless, when) +import Control.Applicative ((<|>)) +import Control.Monad.Extra (forM, liftM2, unless, when) import Formatting @@ -23,6 +19,7 @@ import Control.Concurrent (threadDelay) import Data.Fixed +import Data.Functor ((<&>)) import Data.Int (Int64) import Data.List.Extra import Data.Maybe @@ -39,28 +36,63 @@ import SimpleCmd import System.FilePath (()) +import Tasks import Time import Utils +-- FIXME check parent status (not children) to drop -- FIXME if failure and no more, then stop -- FIXME catch HTTP exception for connection timeout -progressCmd :: Bool -> Bool -> [TaskID] -> IO () -progressCmd debug modules tids = do - when (modules && not (null tids)) $ error' "cannot combine --modules with tasks" - tasks <- - if null tids - then kojiListBuildTasks $ if modules then Just "mbs/mbs.fedoraproject.org" else Nothing - else return tids +-- FIXME pick up new user builds (if none specified) +progressCmd :: Bool -> QueryOpts -> TaskReq -> IO () +progressCmd modules queryopts@QueryOpts{..} taskreq = do + tasks <- do + tz <- getCurrentTimeZone + let states = + case taskreq of + TaskQuery -> + if null qStates + then openTaskStates + else qStates + _ -> [] + mmethod = + case taskreq of + TaskQuery -> qmMethod <|> Just "build" + _ -> Nothing + muser = + case taskreq of + TaskQuery -> qmUserOpt + _ -> Nothing + ts <- getTasks tz fedoraKojiHub queryopts {qStates = states, qmMethod = mmethod, qmUserOpt = muser} taskreq + if null ts + then do + tids <- kojiListBuildTasks $ + if modules + then Just "mbs/mbs.fedoraproject.org" + else Nothing + forM tids $ \tid -> do + mtaskinfo <- kojiGetTaskInfo fedoraKojiHub tid + case mtaskinfo of + Nothing -> error' $ "taskinfo not found for " ++ displayID tid + Just taskinfo -> return taskinfo + else do + when modules $ error' "cannot combine --modules with tasks" + return ts when (null tasks) $ error' "no build tasks found" - btasks <- mapM initialTaskinfo tasks + btasks <- mapM initialBuildTask tasks tz <- getCurrentTimeZone - loopBuildTasks debug tz btasks + loopBuildTasks qDebug tz btasks +data LogStatus = LogStatus + { logSize :: Int, + logTime :: UTCTime + } + deriving Show + data TaskStatus = TaskStatus - { tstSize :: Int, - tstTime :: UTCTime, - tstState :: TaskState - } + { tstLog :: Maybe LogStatus, + tstState :: TaskState + } deriving Show mkTaskStatus :: Maybe Int -> Maybe UTCTime -> Maybe TaskState -> Maybe TaskStatus @@ -68,7 +100,7 @@ mkTaskStatus _ Nothing _ = Nothing mkTaskStatus _ _ Nothing = Nothing mkTaskStatus (Just size) (Just time) (Just state) = - Just (TaskStatus size time state) + Just (TaskStatus (Just (LogStatus size time)) state) -- FIXME change to (TaskID,Struct,Size,Time,State) data TaskInfoStatus = TaskInfoStatus @@ -78,34 +110,33 @@ data BuildTask = BuildTask TaskID UTCTime (Maybe UTCTime) (Maybe Int) [TaskInfoStatus] -initialTaskinfo :: TaskID -> IO BuildTask -initialTaskinfo tid = do - mtaskinfo <- kojiGetTaskInfo fedoraKojiHub tid - case mtaskinfo of - Nothing -> error' $ "taskinfo not found for " ++ displayID tid - Just taskinfo -> do - let parent = - case lookupStruct "method" taskinfo :: Maybe String of - Nothing -> error' $ "no method found for " ++ displayID tid - Just method -> - case method of - "build" -> tid - "buildArch" -> - case lookupStruct "parent" taskinfo of - Nothing -> error' $ "no parent found for " ++ displayID tid - Just par -> TaskId par - _ -> error' $ "unsupported method: " ++ method - children <- sortOn (\t -> lookupStruct "arch" t :: Maybe String) <$> - kojiGetTaskChildren fedoraKojiHub parent True - let start = - case lookupTime False taskinfo of - Nothing -> - error' $ "task " ++ displayID tid ++ " has no start time" - Just t -> t - mend = lookupTime True taskinfo - return $ - BuildTask tid start mend Nothing $ - map (`TaskInfoStatus` Nothing) children +initialBuildTask :: Struct -> IO BuildTask +initialBuildTask taskinfo = do + let tid = case lookupStruct "id" taskinfo of + Just tid' -> TaskId tid' + Nothing -> error' $ "no taskid found for:" ++ show taskinfo + parent = + case lookupStruct "method" taskinfo :: Maybe String of + Nothing -> error' $ "no method found for " ++ displayID tid + Just method -> + case method of + "build" -> tid + "buildArch" -> + case lookupStruct "parent" taskinfo of + Nothing -> error' $ "no parent found for " ++ displayID tid + Just par -> TaskId par + _ -> error' $ "unsupported method: " ++ method + children <- sortOn (\t -> lookupStruct "arch" t :: Maybe String) <$> + kojiGetTaskChildren fedoraKojiHub parent True + let start = + case lookupTime CreateEvent taskinfo of + Nothing -> + error' $ "task " ++ displayID tid ++ " has no create time" + Just t -> t + mend = lookupTime CompletionEvent taskinfo + return $ + BuildTask parent start mend Nothing $ + map (`TaskInfoStatus` Nothing) children type TaskInfoStatuses = (Struct, (Maybe Int, Maybe UTCTime), @@ -144,7 +175,10 @@ if state `elem` map Just openTaskStates then do threadDelaySeconds 61 - initialTaskinfo tid + mtaskinfo <- kojiGetTaskInfo fedoraKojiHub tid + case mtaskinfo of + Nothing -> error' $ "no taskinfo for " ++ show tid + Just taskinfo -> initialBuildTask taskinfo else return $ BuildTask tid start Nothing msize [] ((TaskInfoStatus task _):_) -> do when debug $ print task @@ -161,12 +195,8 @@ (open,closed) = partition (\tis -> getTaskState (taskInfo tis) `elem` map Just openTaskStates) news mlargest = if not (any (\tis -> lookupStruct "method" (taskInfo tis) /= Just ("buildSRPMFromSCM" :: String)) closed) then Nothing - else Just $ maximum $ mapMaybe (fmap tstSize . taskStatus) closed - mbiggest = case (mlargest,msize) of - (Just large, Just size) -> - Just $ max large size - (Just large, Nothing) -> Just large - (Nothing,_) -> msize + else Just $ maximum $ mapMaybe (\t -> taskStatus t >>= tstLog <&> logSize) closed + mbiggest = max mlargest msize if null open then runProgress (BuildTask tid start mend mbiggest []) else return $ BuildTask tid start mend mbiggest open @@ -177,8 +207,9 @@ -- Just st -> st buildlogSize :: Bool -> Int -> TaskInfoStatus -> IO TaskInfoStatuses -buildlogSize debug n (TaskInfoStatus task oldstatus) = do - exists <- if isJust oldstatus +buildlogSize debug n (TaskInfoStatus task moldstatus) = do + when debug $ putStrLn buildlog + exists <- if isJust moldstatus then return True else httpExists' buildlog when (debug && n>0) $ putChar '.' @@ -186,13 +217,13 @@ (msize,mtime) <- if exists then httpFileSizeTime' buildlog else return (Nothing,Nothing) - when debug $ print (mtime,oldstatus) - if (mtime == fmap tstTime oldstatus || isNothing mtime) && n < 6 - then buildlogSize debug (n+1) (TaskInfoStatus task oldstatus) + when debug $ print (mtime,moldstatus) + if (mtime == fmap logTime moldlog || isNothing mtime) && n < 5 + then buildlogSize debug (n+1) (TaskInfoStatus task moldstatus) else return (task, (fromInteger <$> msize, mtime), - oldstatus) + moldstatus) where tid = show $ fromJust (readID' task) buildlog = "https://kojipkgs.fedoraproject.org/work/tasks" lastFew tid "build.log" @@ -200,9 +231,11 @@ let few = dropWhile (== '0') $ takeEnd 4 tid in if null few then "0" else few + moldlog = moldstatus >>= tstLog :: Maybe LogStatus + waitDelay :: IO () waitDelay = do - case tstTime <$> oldstatus of + case logTime <$> moldlog of Nothing -> when (n>0) $ threadDelaySeconds n Just ot -> do cur <- getCurrentTime @@ -237,29 +270,30 @@ data TaskOutput = TaskOut {_outArch :: Text, moutSize :: Maybe Int, moutSizeStep :: Maybe Int, - _moutSizeChanged :: Bool, + outSizeChanged :: Bool, _moutTime :: Maybe UTCTime, _moutTimeStep :: Maybe Int, - _moutTimeChanged :: Bool, + outTimeChanged :: Bool, _outState :: Text, - _stateChange :: Bool, + outStateChanged :: Bool, _method :: Text, _mduration :: Maybe NominalDiffTime} printLogStatuses :: IO () -> TimeZone -> [TaskInfoStatuses] -> IO () printLogStatuses header tz tss = - let (mxsi, mxsp, taskoutputs) = (formatSize . mapMaybe taskOutput) tss + let (mxsi, mxsp, taskoutputs) = (formatSize . map taskOutput) tss in unless (null taskoutputs) $ do - header - mapM_ (printTaskOut mxsi mxsp) taskoutputs - putChar '\n' + when (any (\t -> outTimeChanged t || outSizeChanged t || outStateChanged t) taskoutputs) $ do + header + mapM_ (printTaskOut mxsi mxsp) taskoutputs + putChar '\n' where printTaskOut :: Int64 -> Int64 -> TaskOutput -> IO () - printTaskOut maxsize maxspd (TaskOut arch msize msizediff sizechanged mtime mtimediff timechanged state statechanged mthd mduration) = - when (timechanged || sizechanged || statechanged) $ - fprintLn (rpadded 7 ' ' stext % - lpadded maxsize ' ' (optioned commas) % "kB" % " " % + printTaskOut maxsize maxspd (TaskOut arch msize msizediff _sizechanged mtime mtimediff _timechanged state _statechanged mthd mduration) = + fprintLn (rpadded 8 ' ' stext % + lpadded (max 6 (maxsize+2)) ' ' (optioned commas) % "kB" % + " " % optioned (parenthesised string % " ") % optioned ("[" % lpadded maxspd ' ' commas % " B/s] ") % optioned (parenthesised (shown % "s") % " ") % @@ -279,7 +313,7 @@ formatSize :: [TaskOutput] -> (Int64, Int64,[TaskOutput]) formatSize ts = - let maxsi = maximum $ 0 : mapMaybe moutSize ts + let maxsi = maximum $ 0 : mapMaybe (fmap (`div` 1000) . moutSize) ts maxsp = maximum $ 0 : mapMaybe moutSizeStep ts in (decimalLength maxsi, decimalLength maxsp, ts) where @@ -292,16 +326,14 @@ "buildSRPMFromSCM" -> "SRPM" _ -> mth - taskOutput :: TaskInfoStatuses -> Maybe TaskOutput - taskOutput (task, (size,time), oldstatus) = - let oldtime = tstTime <$> oldstatus - oldsize = tstSize <$> oldstatus - oldstate = tstState <$> oldstatus + taskOutput :: TaskInfoStatuses -> TaskOutput + taskOutput (task, (size,time), moldstatus) = + let moldlog = moldstatus >>= tstLog + oldtime = logTime <$> moldlog + oldsize = logSize <$> moldlog + oldstate = tstState <$> moldstatus mstate = getTaskState task in - if time == oldtime && size == oldsize && mstate == oldstate - then Nothing - else let method = maybeVal "method not found" (lookupStruct "method") task :: Text arch = maybeVal "arch not found" (lookupStruct "arch") task :: Text sizediff = liftM2 (-) size oldsize @@ -315,8 +347,7 @@ if s == TaskOpen then "" else T.pack $ show s - in Just $ - TaskOut arch size sizediff (size /= oldsize) time timediff (time /= oldtime) state' (mstate /= oldstate) method (durationOfTask task) + in TaskOut arch size sizediff (size /= oldsize) time timediff (time /= oldtime) state' (mstate /= oldstate) method (durationOfTask task) kojiListBuildTasks :: Maybe String -> IO [TaskID] kojiListBuildTasks muser = do diff --git a/src/Tasks.hs b/src/Tasks.hs --- a/src/Tasks.hs +++ b/src/Tasks.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-} +{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards #-} -- SPDX-License-Identifier: BSD-3-Clause @@ -6,8 +6,10 @@ TaskFilter(..), TaskReq(..), BeforeAfter(..), + QueryOpts(..), tasksCmd, - parseTaskState, + getTasks, + parseTaskState', kojiMethods, fedoraKojiHub, taskinfoUrl, @@ -61,113 +63,194 @@ taskArch :: String, _taskMethod :: String, _taskState :: TaskState, - mtaskParent :: Maybe Int, + _mtaskParent :: Maybe Int, taskId :: Int, _mtaskStartTime :: Maybe UTCTime, mtaskEndTime :: Maybe UTCTime } +data QueryOpts = QueryOpts { + qmUserOpt :: Maybe UserOpt, + qLimit :: Int, + qStates :: ![TaskState], + qArchs :: ![String], + qmDate :: Maybe BeforeAfter, + qmMethod :: Maybe String, + qDebug :: Bool, + qmFilter :: Maybe TaskFilter} + -- FIXME short output option -- --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 - when (hub /= fedoraKojiHub && museropt == Just UserSelf) $ +-- FIXME `-# 2` etc to select second result +tasksCmd :: Maybe String -> QueryOpts -> Bool -> Bool -> Bool -> Maybe String + -> TaskReq -> IO () +tasksCmd mhub queryopts@QueryOpts{..} details tail' hwinfo mgrep taskreq = do + when (hub /= fedoraKojiHub && qmUserOpt == Just UserSelf) $ error' "--mine currently only works with Fedora Koji: use --user instead" tz <- getCurrentTimeZone - case taskreq of + tasks <- getTasks tz hub queryopts taskreq + when qDebug $ mapM_ pPrintCompact tasks + let exact = length tasks == 1 + detailed = details || exact + (mapM_ (printTask detailed tz) . filterResults . mapMaybe maybeTaskResult) tasks + where + hub = maybe fedoraKojiHub hubURL mhub + + filterResults :: [TaskResult] -> [TaskResult] + filterResults ts = + case qmFilter of + Nothing -> ts + Just (TaskPackage pkg) -> + filter (isPackage pkg . taskPackage) ts + Just (TaskNVR nvr) -> + filter (isNVR nvr . taskPackage) ts + where + isPackage pkg (Left p) = takeBaseName p == pkg + isPackage pkg (Right (NVR n _)) = n == pkg + + isNVR _ (Left _) = False + isNVR nvr (Right nvr') = nvr `isPrefixOf` showNVR nvr' + + printTask :: Bool -> TimeZone -> TaskResult -> IO () + printTask detailed tz task = do + let mendtime = mtaskEndTime task + mtime <- if isNothing mendtime + then Just <$> getCurrentTime + else return Nothing + if detailed + then do + putStrLn "" + -- FIX for parent/build method show children (like we do with taskid) + (mapM_ putStrLn . formatTaskResult hub mtime tz) task + buildlogSize qDebug tail' hwinfo mgrep hub task + else do + (putStrLn . compactTaskResult hub tz) task + when (tail' || hwinfo || isJust mgrep) $ + buildlogSize qDebug tail' hwinfo mgrep hub task + +maybeTaskResult :: Struct -> Maybe TaskResult +maybeTaskResult st = do + arch <- lookupStruct "arch" st + let mstart_time = lookupTime CreateEvent st + mend_time = lookupTime CompletionEvent st + taskid <- lookupStruct "id" st + method <- lookupStruct "method" st + state <- getTaskState st + let pkgnvr = kojiTaskRequestNVR st + mparent' = lookupStruct "parent" st :: Maybe Int + return $ + TaskResult pkgnvr arch method state mparent' taskid mstart_time mend_time + +pPrintCompact :: Struct -> IO () +pPrintCompact = +#if MIN_VERSION_pretty_simple(4,0,0) + pPrintOpt CheckColorTty + (defaultOutputOptionsDarkBg {outputOptionsCompact = True, + outputOptionsCompactParens = True}) +#else + pPrint +#endif + +defaultTaskMethod :: String +defaultTaskMethod = "buildArch" + +-- FIXME more debug output +getTasks :: TimeZone -> String -> QueryOpts -> TaskReq -> IO [Struct] +getTasks tz hub queryopts@QueryOpts {..} req = + case req of Task taskid -> do - when (isJust museropt || isJust mdate || isJust mfilter') $ - error' "cannot use --task together with --user, timedate, or filter" + when (isJust qmUserOpt) $ + error' "cannot use taskid together with --user" + when (isJust qmDate) $ + error' "cannot use taskid together with timedate" + when (isJust qmFilter) $ + error' "cannot use taskid together with filter" mtask <- kojiGetTaskInfo hub (TaskId taskid) - whenJust mtask$ \task -> do - when debug $ pPrintCompact task - whenJust (maybeTaskResult task) $ \res -> do - let hasparent = isJust $ mtaskParent res - printTask hasparent tz res - if hasparent - then whenJust minstall $ \installopts -> - 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) + case mtask of + Nothing -> error $ "taskid not found: " ++ show taskid + Just task -> do + when qDebug $ pPrintCompact task + case maybeTaskResult task of + Nothing -> error' $ "failed to read task: " ++ show task + -- FIXME maybe should have way to list parent or children + Just _res -> return [task] Build bld -> do - when (isJust mdate || isJust mfilter') $ + when (isJust qmDate || isJust qmFilter) $ error' "cannot use --build together with timedate or filter" mtaskid <- if all isDigit bld - then ((fmap TaskId . lookupStruct "task_id") =<<) <$> getBuild hub (InfoID (read bld)) - else kojiGetBuildTaskID hub bld - whenJust mtaskid $ \(TaskId taskid) -> - tasksCmd (Just hub) museropt limit states archs mdate mmethod details debug mfilter' tail' minstall (Parent taskid) + -- FIXME use kojiGetBuildIdTaskID after next koji release + then ((fmap TaskId . lookupStruct "task_id") =<<) <$> + getBuild hub (InfoID (read bld)) + else kojiGetBuildTaskID hub bld + case mtaskid of + Just (TaskId taskid) -> getTasks tz hub queryopts $ Parent taskid + Nothing -> error' $ "no taskid found for build " ++ bld Package pkg -> do when (head pkg == '-') $ error' $ "bad combination: not a package " ++ pkg - when (isJust mdate || isJust mfilter') $ - error' "cannot use --package together with timedate or filter" + when (isJust qmDate || isJust qmFilter) $ + -- FIXME why not? + error' "cannot use package together with timedate or filter" mpkgid <- getPackageID hub pkg case mpkgid of Nothing -> error' $ "no package id found for " ++ pkg Just pkgid -> do builds <- listBuilds hub [("packageID", ValueInt pkgid), - commonBuildQueryOptions limit] - forM_ builds $ \bld -> do + commonBuildQueryOptions qLimit] + fmap concat <$> + forM builds $ \bld -> do let mtaskid = (fmap TaskId . lookupStruct "task_id") bld - whenJust mtaskid $ \(TaskId taskid) -> - tasksCmd (Just hub) museropt 10 states archs mdate mmethod details debug mfilter' tail' minstall (Parent taskid) + case mtaskid of + -- FIXME gives too many tasks (parent builds): + Just (TaskId taskid) -> getTasks tz hub queryopts $ Parent taskid + Nothing -> return [] Pattern pat -> do let buildquery = [("pattern", ValueString pat), - commonBuildQueryOptions limit] - when debug $ print buildquery + commonBuildQueryOptions qLimit] + when qDebug $ print buildquery builds <- listBuilds hub buildquery - when debug $ print builds - forM_ builds $ \bld -> do + when qDebug $ print builds + fmap concat <$> + forM builds $ \bld -> do let mtaskid = (fmap TaskId . lookupStruct "task_id") bld - whenJust mtaskid $ \(TaskId taskid) -> - tasksCmd (Just hub) museropt 10 states archs mdate mmethod details debug mfilter' tail' minstall (Parent taskid) + case mtaskid of + Just (TaskId taskid) -> getTasks tz hub queryopts $ Parent taskid + Nothing -> return [] _ -> do query <- setupQuery - let queryopts = commonQueryOptions limit "-id" - when debug $ print $ query ++ queryopts - tasks <- listTasks hub query queryopts - when debug $ mapM_ pPrintCompact tasks - let exact = length tasks == 1 - detailed = details || exact - (mapM_ (printTask detailed tz) . filterResults . mapMaybe maybeTaskResult) tasks - whenJust minstall $ \args -> - if exact - 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" + let qopts = commonQueryOptions qLimit "-id" + when qDebug $ print $ query ++ qopts + listTasks hub query qopts where - hub = maybe fedoraKojiHub hubURL mhub - setupQuery = do - case taskreq of + case req of Parent parent -> return $ ("parent", ValueInt parent) : commonParams _ -> do mdatestring <- - case mdate of + case qmDate of Nothing -> return Nothing Just date -> Just <$> cmd "date" ["+%F %T%z", "--date=" ++ dateString date] - when (isNothing mmethod) $ - warning "buildArch tasks" + when (isNothing qmMethod) $ + warning $ defaultTaskMethod +-+ "tasks" whenJust mdatestring $ \date -> - warning $ maybe "" show mdate +-+ date - mowner <- maybeGetKojiUser hub museropt + warning $ maybe "" show qmDate +-+ date + mowner <- maybeGetKojiUser hub qmUserOpt return $ [("owner", ValueInt (getID owner)) | Just owner <- [mowner]] ++ - [("complete" ++ (capitalize . show) date, ValueString datestring) | Just date <- [mdate], Just datestring <- [mdatestring]] ++ + [("complete" ++ (capitalize . show) date, ValueString datestring) | Just date <- [qmDate], Just datestring <- [mdatestring]] ++ commonParams where commonParams = [("decode", ValueBool True)] - ++ [("state", ValueArray (map taskStateToValue states)) | notNull states] - ++ [("arch", ValueArray (map (ValueString . kojiArch) archs)) | notNull archs] - ++ [("method", ValueString method) | let method = fromMaybe "buildArch" mmethod] + ++ [("state", ValueArray (map taskStateToValue qStates)) | notNull qStates] + ++ [("arch", ValueArray (map (ValueString . kojiArch) qArchs)) | notNull qArchs] + ++ [("method", ValueString method) | let method = fromMaybe defaultTaskMethod qmMethod] capitalize :: String -> String capitalize "" = "" @@ -178,71 +261,19 @@ kojiArch "armv7hl" = "armhfp" kojiArch a = a - dateString :: BeforeAfter -> String - -- make time refer to past not future - dateString beforeAfter = - let timedate = getTimedate beforeAfter - in case words timedate of - [t] | t `elem` ["hour", "day", "week", "month", "year"] -> - "last " ++ t - [t] | t `elem` ["today", "yesterday"] -> - t ++ " 00:00" - [t] | any (lower t `isPrefixOf`) ["monday", "tuesday", "wednesday", "thursday", "friday", "saturday", "sunday"] -> - "last " ++ t ++ " 00:00" - [n,_unit] | all isDigit n -> timedate ++ " ago" - _ -> timedate - - maybeTaskResult :: Struct -> Maybe TaskResult - maybeTaskResult st = do - arch <- lookupStruct "arch" st - let mstart_time = lookupTime False st - mend_time = lookupTime True st - taskid <- lookupStruct "id" st - method <- lookupStruct "method" st - state <- getTaskState st - let pkgnvr = kojiTaskRequestNVR st - mparent' = lookupStruct "parent" st :: Maybe Int - return $ - TaskResult pkgnvr arch method state mparent' taskid mstart_time mend_time - - filterResults :: [TaskResult] -> [TaskResult] - filterResults ts = - case mfilter' of - Nothing -> ts - Just (TaskPackage pkg) -> - filter (isPackage pkg . taskPackage) ts - Just (TaskNVR nvr) -> - filter (isNVR nvr . taskPackage) ts - where - isPackage pkg (Left p) = takeBaseName p == pkg - isPackage pkg (Right (NVR n _)) = n == pkg - - isNVR _ (Left _) = False - isNVR nvr (Right nvr') = nvr `isPrefixOf` showNVR nvr' - - printTask :: Bool -> TimeZone -> TaskResult -> IO () - printTask detailed tz task = do - let mendtime = mtaskEndTime task - mtime <- if isNothing mendtime - then Just <$> getCurrentTime - else return Nothing - if detailed - then do - putStrLn "" - -- FIX for parent/build method show children (like we do with taskid) - (mapM_ putStrLn . formatTaskResult hub mtime tz) task - buildlogSize debug tail' hub task - else - (putStrLn . compactTaskResult hub tz) task - - pPrintCompact = -#if MIN_VERSION_pretty_simple(4,0,0) - pPrintOpt CheckColorTty - (defaultOutputOptionsDarkBg {outputOptionsCompact = True, - outputOptionsCompactParens = True}) -#else - pPrint -#endif + dateString :: BeforeAfter -> String + -- make time refer to past not future + dateString beforeAfter = + let timedate = getTimedate beforeAfter + in case words timedate of + [t] | t `elem` ["hour", "day", "week", "month", "year"] -> + "last " ++ t + [t] | t `elem` ["today", "yesterday"] -> + t ++ " 00:00" + [t] | any (lower t `isPrefixOf`) ["monday", "tuesday", "wednesday", "thursday", "friday", "saturday", "sunday"] -> + "last " ++ t ++ " 00:00" + [n,_unit] | all isDigit n -> timedate ++ " ago" + _ -> timedate taskinfoUrl :: String -> Int -> String taskinfoUrl hub tid = @@ -293,9 +324,10 @@ #if !MIN_VERSION_koji(0,0,3) taskStateToValue :: TaskState -> Value taskStateToValue = ValueInt . fromEnum +#endif -parseTaskState :: String -> TaskState -parseTaskState s = +parseTaskState' :: String -> TaskState +parseTaskState' s = case lower s of "free" -> TaskFree "open" -> TaskOpen @@ -306,10 +338,10 @@ "assigned" -> TaskAssigned "fail" -> TaskFailed "failed" -> TaskFailed - _ -> error' $! "unknown task state: " ++ s -#endif + _ -> error' $! "unknown task state: " ++ s ++ + "\nknown states: free, open, closed, canceled, assigned, failed" -data LogFile = BuildLog | RootLog +data LogFile = BuildLog | RootLog | HWInfo deriving Eq data OutputLocation = PackagesOutput | WorkOutput @@ -350,14 +382,16 @@ tailLogUrl :: String -> Int -> LogFile -> String tailLogUrl hub taskid file = - webUrl hub +/+ "getfile?taskID=" ++ show taskid ++ "&name=" ++ logFile file ++ "&offset=-4000" + webUrl hub +/+ "getfile?taskID=" ++ show taskid ++ "&name=" ++ logFile file ++ "&offset=-6000" logFile :: LogFile -> String logFile RootLog = "root.log" logFile BuildLog = "build.log" +logFile HWInfo = "hw_info.log" -buildlogSize :: Bool -> Bool -> String -> TaskResult -> IO () -buildlogSize _debug tail' hub task = do +buildlogSize :: Bool -> Bool -> Bool -> Maybe String -> String -> TaskResult + -> IO () +buildlogSize _debug tail' hwinfo mgrep hub task = do murl <- findOutputURL hub task whenJust murl $ \ url -> do let buildlog = url +/+ logFile BuildLog @@ -372,12 +406,18 @@ fprintLn ("(" % commas % "kB)") (size `div` 1000) -- FIXME check if short build.log ends with srpm file <- - if size < 1500 + if hwinfo then do - putStrLn $ url +/+ logFile RootLog - return RootLog - else return BuildLog - when tail' $ displayLog url file + putStrLn $ url +/+ logFile HWInfo + return HWInfo + else + -- for buildroot failure build.log could be ~3082 bytes + if size < 4000 + then do + putStrLn $ url +/+ logFile RootLog + return RootLog + else return BuildLog + when (tail' || hwinfo || isJust mgrep) $ displayLog url file else do let rootlog = url +/+ logFile RootLog whenM (httpExists' rootlog) $ @@ -387,29 +427,50 @@ displayLog url file = do let logurl = case file of - RootLog -> url +/+ logFile file BuildLog -> tailLogUrl hub (taskId task) file + _ -> url +/+ logFile file req <- parseRequest logurl resp <- httpLBS req let out = U.toString $ getResponseBody resp ls = lines out putStrLn "" - if file == RootLog - then - let excluded = ["Executing command:", "Child return code was: 0", - "child environment: None", "ensuring that dir exists:", - "touching file:", "creating dir:", "kill orphans"] - in putStr $ unlines $ map (dropPrefix "DEBUG ") $ takeEnd 30 $ - filter (\l -> not (any (`isInfixOf` l) excluded)) ls - else - if last ls == "Child return code was: 0" - then putStr out - else putStr . unlines $ - case breakOnEnd ["Child return code was: 1"] ls of - ([],ls') -> ls' - (ls',_) -> ls' + let output + | file == RootLog = + let excluded = ["Executing command:", + "Child return code was: 0", + "child environment: None", + "ensuring that dir exists:", + "touching file:", + "creating dir:", + "kill orphans"] + in + map (dropPrefix "DEBUG ") $ takeEnd 30 $ + filter (\l -> not (any (`isInfixOf` l) excluded)) ls + | last ls == "Child return code was: 0" = ls + | otherwise = + case breakOnEnd ["Child return code was: 1"] ls of + ([],ls') -> ls' + (ls',_) -> ls' + putStr $ unlines $ + case mgrep of + Nothing -> output + Just needle -> + filter (match needle) ls putStrLn $ "\n" ++ logurl + where + match :: String -> String -> Bool + match "" _ = error' "empty grep string not allowed" + match _ "" = False + match ('^':needle) ls = + if last needle == '$' + then needle == ls + else needle `isPrefixOf` ls + match needle ls = + if last needle == '$' + then needle `isSuffixOf` ls + else needle `isInfixOf` ls +-- FIXME turn into a type? kojiMethods :: [String] kojiMethods = nub . sort $ diff --git a/src/Time.hs b/src/Time.hs --- a/src/Time.hs +++ b/src/Time.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, OverloadedStrings #-} module Time ( compactZonedTime, + TimeEvent(..), lookupTime, - lookupTimes, - lookupTimes', + lookupBuildTimes, + lookupTaskTimes, + strictLookupTimes, durationOfTask, formatLocalTime, renderDuration, @@ -16,6 +18,7 @@ import Data.Time.Format import Data.Time.LocalTime import Distribution.Koji.API (Struct, lookupStruct) +import Formatting readTime' :: Double -> UTCTime readTime' = @@ -26,40 +29,56 @@ compactZonedTime tz = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Z" . utcToZonedTime tz -lookupTime :: Bool -> Struct -> Maybe UTCTime -lookupTime completion str = do - case lookupStruct (prefix ++ "_ts") str of - Just ts -> return $ readTime' ts - Nothing -> - lookupStruct (prefix ++ "_time") str >>= - parseTimeM False defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q%EZ" - where - prefix = if completion then "completion" else "start" +data TimeEvent = CreateEvent | StartEvent | CompletionEvent -lookupTimes :: Struct -> Maybe (UTCTime, Maybe UTCTime) -lookupTimes str = do - start <- lookupTime False str - let mend = lookupTime True str +showEvent :: TimeEvent -> String +showEvent CreateEvent = "create" +showEvent StartEvent = "start" +showEvent CompletionEvent = "completion" + +lookupTime :: TimeEvent -> Struct -> Maybe UTCTime +lookupTime event str = do + let ev = showEvent event + in + case lookupStruct (ev ++ "_ts") str of + Just ts -> return $ readTime' ts + Nothing -> + lookupStruct (ev ++ "_time") str >>= + parseTimeM False defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q%EZ" + +lookupTaskTimes :: Struct -> Maybe (UTCTime, Maybe UTCTime) +lookupTaskTimes str = do + start <- lookupTime CreateEvent str + let mend = lookupTime CompletionEvent str return (start,mend) -lookupTimes' :: Struct -> (UTCTime, UTCTime) -lookupTimes' str = - case lookupTimes str of - Nothing -> error "no start time for task" +lookupBuildTimes :: Struct -> Maybe (UTCTime, Maybe UTCTime) +lookupBuildTimes str = do + start <- lookupTime StartEvent str + let mend = lookupTime CompletionEvent str + return (start,mend) + +strictLookupTimes :: (Struct -> Maybe (UTCTime, Maybe UTCTime)) + -> Struct -> (UTCTime, UTCTime) +strictLookupTimes lf st = + case lf st of + Nothing -> error "no start time" -- for build/task Just (start,mend) -> case mend of - Nothing -> error "no end time for task" + Nothing -> error "no end time" -- for build/task Just end -> (start,end) durationOfTask :: Struct -> Maybe NominalDiffTime durationOfTask str = do - (start,mend) <- lookupTimes str + (start,mend) <- lookupTaskTimes str end <- mend return $ diffUTCTime end start formatLocalTime :: Bool -> TimeZone -> UTCTime -> String formatLocalTime start tz t = - formatTime defaultTimeLocale (if start then "Start: %c" else "End: %c") $ + -- FIXME format time with formatting + formatTime defaultTimeLocale + (formatToString (rpadded 11 ' ' string % "%c") (if start then "Created:" else "Completed:")) $ utcToZonedTime tz t renderDuration :: Bool -> NominalDiffTime -> String diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -16,7 +16,7 @@ (["builds"], [["-L", "rust"] ,["-l", "3"] - ,["-L", "-p", "rpm-ostree*.fc36"]]) + ,["-L", "-p", "rpm-ostree*.fc37"]]) , (["tasks"], [["-L"] @@ -29,18 +29,27 @@ (["find"], [["last", "failed", "build"]]) , - (["install", "-n", "-y"], + (["install", "-n", "-y"], [["podman", "-p", "podman"] ++ sysdist ,["-l", "coreutils"] ++ sysdist - ,["-l", "-R", "rpmlint-2.2.0-1.fc36"] + ,["-l", "-R", "rpmlint-2.4.0-3.fc37"] ,["-H", "https://kojihub.stream.centos.org/kojihub", "-d", "el9", "bash", "-p", "bash"] ,["-H", "stream", "-d", "el9", "kernel", "-x", "kernel-devel*", "-x", "*-debug*"] ,["-l", "-H", "stream", "-d", "el9", "grep"] ,["-H", "rpmfusion", "ffmpeg", "-p", "ffmpeg", "-p", "ffmpeg-libs"] ++ sysdist - ,["-l", "-H", "rpmfusion", "ffmpeg"] ++ sysdist]) + ,["-l", "-H", "rpmfusion", "ffmpeg"] ++ sysdist + ,["ghc9.4", + "-e", "*-devel", + "-x", "*-prof", + "-x", "*-doc", + "-x", "ghc9.4", + "-x", "compiler-default", + "-i", "base-devel"] ++ sysdist + ] + ) ] where - sysdist = if havedist then [] else ["-d", "fc35"] + sysdist = if havedist then [] else ["-d", "fc37"] main :: IO () main = do