koji-tool 0.9.5 → 1.0
raw patch · 15 files changed
+828/−572 lines, 15 files
Files
- ChangeLog.md +31/−0
- README.md +64/−34
- TODO +11/−2
- koji-tool.cabal +5/−4
- src/BuildlogSizes.hs +41/−22
- src/Builds.hs +16/−19
- src/Common.hs +7/−2
- src/DownloadDir.hs +7/−28
- src/Find.hs +8/−4
- src/Install.hs +201/−155
- src/Main.hs +51/−36
- src/Progress.hs +116/−85
- src/Tasks.hs +214/−153
- src/Time.hs +42/−23
- test/tests.hs +14/−5
ChangeLog.md view
@@ -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
README.md view
@@ -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/
TODO view
@@ -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
koji-tool.cabal view
@@ -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 <petersen@redhat.com> maintainer: Jens Petersen <petersen@redhat.com>-copyright: 2021-2022 Jens Petersen <petersen@redhat.com>+copyright: 2021-2023 Jens Petersen <petersen@redhat.com> 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
src/BuildlogSizes.hs view
@@ -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
src/Builds.hs view
@@ -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
src/Common.hs view
@@ -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
src/DownloadDir.hs view
@@ -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
src/Find.hs view
@@ -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
src/Install.hs view
@@ -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
src/Main.hs view
@@ -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
src/Progress.hs view
@@ -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
src/Tasks.hs view
@@ -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 $
src/Time.hs view
@@ -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
test/tests.hs view
@@ -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