diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,17 @@ # Version history of koji-tool +## 0.9.4 (2022-09-09) +- 'install': rework install logic to combine reinstall and install pkgs +- 'install': do not choose rebuildSRPM subtask +- 'install': show correct top download dir +- 'install': --add to specify additional package +- 'install': change rpms prompt to require Enter for consistency with dnf +- 'progress': another major logic refactor: + determine poll delay from last-modified time +- 'progress': skip wait for a build.log after [1..6] sec tries +- 'progress': put interval times into task outputs +- 'progress': only print task header if updated task outputs + ## 0.9.3 (2022-08-03) - 'builds' for a package now use specified query options - 'builds': add --install and --tasks options diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,7 +5,7 @@ and check buildlog sizes. [Koji](https://pagure.io/koji/) is the RPM package buildsystem used by -Fedora, CentOS, and some other projects. +Fedora Linux, CentOS, and some other projects. By default Fedora Koji is used. @@ -23,7 +23,7 @@ ## Commands ```shellsession $ koji-tool --version -0.9.3 +0.9.4 $ koji-tool --help Query and track Koji tasks, and install rpms from Koji. @@ -35,9 +35,9 @@ --version Show version Available commands: - builds Query Koji builds (by default lists most recent + builds Query Koji builds (by default lists the most recent builds) - tasks Query Koji tasks (by default lists most recent + tasks Query Koji tasks (by default lists the most recent buildArch tasks) latest Query latest Koji build for tag install Install rpm packages directly from a Koji build task @@ -72,7 +72,7 @@ [-i|--install INSTALLOPTS] [-D|--debug] [(-b|--build NVR/BUILDID) | (-p|--pattern NVRPAT) | PACKAGE] - Query Koji builds (by default lists most recent builds) + Query Koji builds (by default lists the most recent builds) Available options: -H,--hub HUB KojiHub shortname or url (HUB = fedora, stream, @@ -140,7 +140,7 @@ [-T|--tail] [-i|--install INSTALLOPTS] [(-b|--build BUILD) | (-p|--pattern NVRPAT) | PACKAGE|TASKID] - Query Koji tasks (by default lists most recent buildArch tasks) + Query Koji tasks (by default lists the most recent buildArch tasks) Available options: -H,--hub HUB KojiHub shortname or url (HUB = fedora, stream, @@ -257,9 +257,10 @@ [-t|--check-remote-time] [--rpm | --rpm-ostree | --dnf] [(-N|--no-reinstall) | (-S|--skip-existing)] [-b|--prefix SUBPKGPREFIX] - [(-a|--all) | (-A|--ask) | [-p|--package SUBPKG] - [-x|--exclude SUBPKG]] [-d|--disttag DISTTAG] - [(-R|--nvr) | (-V|--nv)] PKG|NVR|TASKID... + [--all | --ask | [-p|--package SUBPKG] + [-a|--add SUBPKG] [-x|--exclude SUBPKG]] + [-d|--disttag DISTTAG] [(-R|--nvr) | (-V|--nv)] + PKG|NVR|TASKID... Install rpm packages directly from a Koji build task Available options: @@ -277,12 +278,13 @@ --rpm-ostree Use rpm-ostree instead of dnf --dnf Use dnf to install [default unless ostree] -N,--no-reinstall Do not reinstall existing NVRs - -S,--skip-existing Ignore already installed subpackages (imples + -S,--skip-existing Ignore already installed subpackages (implies --no-reinstall) -b,--prefix SUBPKGPREFIX Prefix to use for subpackages [default: base package] - -a,--all all subpackages - -A,--ask ask for each subpackge [default if not installed] + --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 -d,--disttag DISTTAG Select a disttag different to system -R,--nvr Give an N-V-R instead of package name diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -43,6 +43,7 @@ - accept task or build url - cache and compare sizes with previous build(s) - estimate task/build ETA +- newrepo tasks (createrepo.log) - show the build duration - support builds as well as tasks 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.3 +version: 0.9.4 synopsis: Koji CLI tool for querying tasks and installing builds description: koji-tool is a CLI interface to Koji with commands to query @@ -51,14 +51,14 @@ formatting >= 7, Glob, http-conduit, - http-directory >= 0.1.9, + http-directory >= 0.1.10, koji >= 0.0.2, pretty-simple, rpm-nvr >= 0.1.2, simple-cmd >= 0.2.2, simple-cmd-args >= 0.1.8, text, - time, + time >= 1.9.1, utf8-string, xdg-userdirs if impl(ghc<8.4) @@ -89,4 +89,4 @@ ghc-options: -Wall build-depends: base >= 4 && < 5 , simple-cmd - build-tools: koji-tool + build-tool-depends: koji-tool:koji-tool diff --git a/src/BuildlogSizes.hs b/src/BuildlogSizes.hs --- a/src/BuildlogSizes.hs +++ b/src/BuildlogSizes.hs @@ -36,6 +36,7 @@ import Common (commonBuildQueryOptions) -- FIXME split off arch suffix +-- FIXME show build duration buildlogSizesCmd :: String -> IO () buildlogSizesCmd nvrpat = do if all isDigit nvrpat -- check if taskid (not buildid) @@ -55,10 +56,9 @@ putStrLn nvr nvrBuildlogSizes nvr Nothing -> do - let mextra = lookupStruct "extra" bld - mtid = + let mtid = lookupStruct "task_id" bld <|> - (mextra >>= lookupStruct "task_id") + (lookupStruct "extra" bld >>= lookupStruct "task_id") case mtid :: Maybe Int of Nothing -> error "no taskid found!" Just tid -> buildlogSizes tid diff --git a/src/DownloadDir.hs b/src/DownloadDir.hs --- a/src/DownloadDir.hs +++ b/src/DownloadDir.hs @@ -38,7 +38,7 @@ return $ putStrLn $ "Packages downloaded to " ++ - (if isRelative path then "~" path else path) subdir + if isRelative path then "~" path else path where setCWD :: FilePath -> IO FilePath setCWD dir = do diff --git a/src/Find.hs b/src/Find.hs --- a/src/Find.hs +++ b/src/Find.hs @@ -45,9 +45,10 @@ allWords :: [String] allWords = concatMap findWords [minBound..] --- FIXME: arch +-- FIXME: time: today, yesterday, week -- FIXME: method -- FIXME: mlt (or mlft) +-- FIXME: separate last and latest? findCmd :: Maybe String -> Bool -> [String] -> IO () findCmd _ _ [] = error' $ "find handles these words:\n\n" ++ unlines (wordsList unwords) @@ -79,7 +80,7 @@ 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] ++ diff --git a/src/Install.hs b/src/Install.hs --- a/src/Install.hs +++ b/src/Install.hs @@ -15,8 +15,8 @@ where import Control.Monad.Extra -import Data.Char import Data.List.Extra +import Data.Either (partitionEithers) import Data.Maybe import Data.RPM.NV hiding (name) import Data.RPM.NVR @@ -41,7 +41,7 @@ data Select = All | Ask - | PkgsReq [String] [String] -- ^ include, except/exclude + | PkgsReq [String] [String] [String] -- ^ include, add, exclude deriving Eq installArgs :: String -> Select @@ -51,19 +51,23 @@ ["--all"] -> All ["-A"] -> Ask ["--ask"] -> Ask - ws -> installPairs [] [] ws + ws -> installPairs [] [] [] ws where - installPairs :: [String] -> [String] -> [String] -> Select - installPairs pa xa [] = PkgsReq pa xa - installPairs pa xa (w:ws) + installPairs :: [String] -> [String] -> [String] -> [String] -> Select + installPairs inst add excl [] = PkgsReq inst add excl + installPairs inst add excl (w:ws) | w `elem` ["-p","--package"] = case ws of [] -> error' "--install-opts --package missing value" - (w':ws') -> installPairs (w':pa) xa ws' + (w':ws') -> installPairs (w':inst) add excl ws' + | w == "--add" = + case ws of + [] -> error' "--install-opts --add missing value" + (w':ws') -> installPairs inst (w':add) excl ws' | w `elem` ["-x","--exclude"] = case ws of [] -> error' "--install-opts --exclude missing value" - (w':ws') -> installPairs pa (w':xa) ws' + (w':ws') -> installPairs inst add (w':excl) ws' | otherwise = error' "invalid --install-opts" data Request = ReqName | ReqNV | ReqNVR @@ -175,17 +179,18 @@ Nothing -> error' $ "no method found for " ++ show taskid Just method -> case method of - "build" -> Koji.getTaskChildren huburl taskid False + "build" -> Koji.getTaskChildren huburl taskid True "buildArch" -> return [taskinfo] _ -> error' $ "unsupport method: " ++ method sysarch <- cmd "rpm" ["--eval", "%{_arch}"] let (archtid,archtask) = - case find (\t -> let march = lookupStruct "arch" t in march `elem` [Just sysarch,Just "noarch"]) tasks of + case find (selectBuildArch sysarch) tasks of Nothing -> error' $ "no " ++ sysarch ++ " 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 prefix <- case mprefix of Just pref -> return pref @@ -193,10 +198,7 @@ case find ((== "src") . rpmArch) nvras of Just src -> return $ rpmName src Nothing -> - return $ - either id nvrName $ - kojiTaskRequestPkgNVR $ - fromMaybe archtask mtaskinfo + return $ kojiTaskRequestPkg archtask if listmode then do drpms <- decideRpms yes listmode existingStrategy select prefix nvras @@ -218,6 +220,13 @@ printDlDir return (subdir,dlRpms) where + selectBuildArch :: String -> Struct -> Bool + selectBuildArch sysarch t = + let march = lookupStruct "arch" t + mmethod = lookupStruct "method" t + in march `elem` [Just sysarch,Just "noarch"] && + mmethod == Just "buildArch" + getTaskNVRAs :: Int -> IO [NVRA] getTaskNVRAs taskid' = sort . map readNVRA . filter notDebugPkg . filter (".rpm" `isExtensionOf`) . map fst <$> @@ -231,10 +240,11 @@ if null few then "0" else few in dropSuffix "packages" pkgsurl +/+ "work/tasks/" ++ lastFew +/+ show taskid' +/+ rpm -data Existence = NVRInstalled | NVRChanged | NotInstalled +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 @@ -242,8 +252,8 @@ if listmode then do case select of - PkgsReq subpkgs exclpkgs -> do - let install = selectRPMs False prefix (subpkgs,exclpkgs) classified + PkgsReq subpkgs addpkgs exclpkgs -> do + let install = selectRPMs False prefix (subpkgs,addpkgs,exclpkgs) classified mapM_ printInstalled install _ -> mapM_ printInstalled classified return [] @@ -252,16 +262,18 @@ All -> do promptPkgs yes classified Ask -> mapMaybeM (rpmPrompt yes) classified - PkgsReq [] [] -> - if all ((== NotInstalled) . fst) classified && yes /= Yes - then decideRpms yes listmode existingStrategy Ask prefix nvras - else do - let install = filter ((/= NotInstalled) . fst) classified - if yes == Yes - then return install - else promptPkgs yes install - PkgsReq subpkgs exclpkgs -> do - let install = selectRPMs False prefix (subpkgs,exclpkgs) 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 where installExists :: NVRA -> IO (Existence, NVRA) @@ -271,7 +283,7 @@ (case minstalled of Nothing -> NotInstalled Just installed -> - if installed == showNVRA nvra then NVRInstalled else NVRChanged, + if installed == showNVRA nvra then ExistingNVR else ChangedNVR, nvra) renderInstalled :: (Existence, NVRA) -> String @@ -280,17 +292,17 @@ printInstalled :: (Existence, NVRA) -> IO () printInstalled = putStrLn . renderInstalled -selectRPMs :: Bool -> String -> ([String],[String]) -> [(Existence,NVRA)] - -> [(Existence,NVRA)] -selectRPMs recurse prefix (subpkgs,[]) rpms = +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 + then selectRPMs True prefix ([prefix ++ '-' : pkgpat],[],[]) rpms else error' $ "no subpackage match for " ++ pkgpat result -> result -selectRPMs _ prefix ([], subpkgs) rpms = +selectRPMs _ prefix ([], [], subpkgs) rpms = -- FIXME somehow determine unused excludes foldl' (exclude subpkgs) [] rpms where @@ -312,10 +324,11 @@ pat `notElem` rpmnames && (prefix ++ '-' : pat) == rpmname else match comppat rpmname -selectRPMs recurse prefix (subpkgs,exclpkgs) rpms = - let needed = selectRPMs recurse prefix (subpkgs,[]) rpms - excluded = selectRPMs recurse prefix (exclpkgs,[]) rpms - in nub . sort $ needed \\ excluded +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) promptPkgs :: Yes -> [(Existence,NVRA)] -> IO [(Existence,NVRA)] promptPkgs yes classified = do @@ -338,22 +351,9 @@ "no" -> return False _ -> prompt yes str -promptChar :: Yes -> String -> IO Bool -promptChar yes str = do - if yes == Yes - then return True - else do - putStr $ str ++ " [y/n]: " - c <- getChar - unless (c == '\n') $ putStrLn "" - case toLower c of - 'y' -> return True - 'n' -> return False - _ -> promptChar yes str - rpmPrompt :: Yes -> (Existence,NVRA) -> IO (Maybe (Existence,NVRA)) rpmPrompt yes (exist,nvra) = do - ok <- promptChar yes $ renderInstalled (exist,nvra) + ok <- prompt yes $ renderInstalled (exist,nvra) return $ if ok then Just (exist,nvra) @@ -438,52 +438,62 @@ hSetBuffering stdin NoBuffering hSetBuffering stdout NoBuffering +data InstallType = ReInstall | Install + -- FIXME ExistingStrategy should move to decideRpms installRPMs :: Bool -> Bool -> Maybe PkgMgr -> ExistingStrategy -> Yes -> [(FilePath,[(Existence,NVRA)])] -> IO () installRPMs _ _ _ _ _ [] = return () -installRPMs dryrun debug mmgr existingStrategy yes classified = - forM_ (groupClasses classified) $ \(cl,dirpkgs) -> - unless (null dirpkgs) $ do - mgr <- - case mmgr of - Nothing -> do - mostree <- findExecutable "rpm-ostree" - return $ if isJust mostree then OSTREE else DNF - Just m -> return m - let pkgmgr = - case mgr of - DNF -> "dnf" - RPM -> "rpm" - OSTREE -> "rpm-ostree" - mcom = - case cl of - NVRInstalled -> - case existingStrategy of - ExistingUpdate -> Just (reinstallCommand mgr) - _ -> Nothing - NVRChanged -> - case existingStrategy of - ExistingSkip -> Nothing - _ -> Just (installCommand mgr) - _ -> Just (installCommand mgr) - in whenJust mcom $ \com -> - if dryrun - then mapM_ putStrLn $ ("would" +-+ unwords (pkgmgr : com) ++ ":") : map showRpmFile dirpkgs - else do - when debug $ mapM_ (putStrLn . showRpmFile) dirpkgs - (case mgr of - OSTREE -> cmd_ - _ -> sudo_) pkgmgr $ - com ++ map showRpmFile dirpkgs ++ ["--assumeyes" | yes == Yes && mgr == DNF] +installRPMs dryrun debug mmgr existingStrategy yes classified = do + case installTypes classified of + ([],is) -> doInstall Install is + (ris,is) -> do + doInstall ReInstall (ris ++ is) + doInstall Install is where - groupClasses = - groupSort . concatMap mapDir + doInstall i dirpkgs = + unless (null dirpkgs) $ do + mgr <- + case mmgr of + Nothing -> do + mostree <- findExecutable "rpm-ostree" + return $ if isJust mostree then OSTREE else DNF + Just m -> return m + let pkgmgr = + case mgr of + DNF -> "dnf" + RPM -> "rpm" + OSTREE -> "rpm-ostree" + mcom = + case i of + ReInstall -> + case existingStrategy of + ExistingUpdate -> Just (reinstallCommand mgr) + _ -> Nothing + Install -> + case existingStrategy of + ExistingSkip -> Nothing + _ -> Just (installCommand mgr) + in whenJust mcom $ \com -> + if dryrun + then mapM_ putStrLn $ ("would" +-+ unwords (pkgmgr : com) ++ ":") : map showRpmFile dirpkgs + else do + when debug $ mapM_ (putStrLn . showRpmFile) dirpkgs + (case mgr of + OSTREE -> cmd_ + _ -> sudo_) pkgmgr $ + com ++ map showRpmFile dirpkgs ++ ["--assumeyes" | yes == Yes && mgr == DNF] + + installTypes :: [(FilePath,[(Existence,NVRA)])] + -> ([(FilePath,NVRA)],[(FilePath,NVRA)]) + installTypes = partitionEithers . concatMap mapDir where mapDir :: (FilePath,[(Existence,NVRA)]) - -> [(Existence,(FilePath,NVRA))] + -> [Either (FilePath,NVRA) (FilePath,NVRA)] mapDir (dir,cls) = - map (\(e,n) -> (e,(dir,n))) cls + map (\(e,n) -> combineExist e (dir,n)) cls + + combineExist e = if e == ExistingNVR then Left else Right reinstallCommand :: PkgMgr -> [String] reinstallCommand mgr = diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -25,7 +25,7 @@ "see https://github.com/juhp/koji-tool#readme" $ subcommands [ Subcommand "builds" - "Query Koji builds (by default lists most recent builds)" $ + "Query Koji builds (by default lists the most recent builds)" $ buildsCmd <$> hubOpt <*> optional userOpt @@ -45,7 +45,7 @@ pure BuildQuery) , Subcommand "tasks" - "Query Koji tasks (by default lists most recent buildArch tasks)" $ + "Query Koji tasks (by default lists the most recent buildArch tasks)" $ tasksCmd <$> hubOpt <*> optional userOpt @@ -102,7 +102,6 @@ "Track running Koji tasks by buildlog size" $ progressCmd <$> switchWith 'D' "debug" "Pretty-print raw XML result" - <*> optionalWith auto 'i' "interval" "MINUTES" "Polling interval between updates (default 2 min)" 2 <*> switchWith 'm' "modules" "Track module builds" <*> many (TaskId <$> argumentWith auto "TASKID") @@ -130,9 +129,12 @@ selectOpt :: Parser Select selectOpt = - flagWith' All 'a' "all" "all subpackages" <|> - flagWith' Ask 'A' "ask" "ask for each subpackge [default if not installed]" <|> - PkgsReq <$> many (strOptionWith 'p' "package" "SUBPKG" "Subpackage (glob) to install") <*> many (strOptionWith 'x' "exclude" "SUBPKG" "Subpackage (glob) not to install") + flagLongWith' All "all" "all subpackages" <|> + flagLongWith' Ask "ask" "ask for each subpackge [default if not installed]" <|> + 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") disttagOpt :: Parser String disttagOpt = startingDot <$> @@ -169,4 +171,4 @@ existingOpt :: Parser ExistingStrategy existingOpt = flagWith' ExistingNoReinstall 'N' "no-reinstall" "Do not reinstall existing NVRs" <|> - flagWith ExistingUpdate ExistingSkip 'S' "skip-existing" "Ignore already installed subpackages (imples --no-reinstall)" + flagWith ExistingUpdate ExistingSkip 'S' "skip-existing" "Ignore already installed subpackages (implies --no-reinstall)" diff --git a/src/Progress.hs b/src/Progress.hs --- a/src/Progress.hs +++ b/src/Progress.hs @@ -11,7 +11,7 @@ #else import Control.Applicative ((<$>), (<*>)) #endif -import Control.Monad.Extra (unless, when) +import Control.Monad.Extra (liftM2, unless, when) import Formatting @@ -29,8 +29,9 @@ #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif -import Data.Time (diffUTCTime, getCurrentTime, NominalDiffTime) -import Data.RPM.NVR +import Data.Time (diffUTCTime, getCurrentTime, getCurrentTimeZone, + localTimeOfDay, NominalDiffTime, nominalDiffTimeToSeconds, + TimeZone, utcToLocalTime) import Data.Text (Text) import qualified Data.Text as T import Distribution.Koji @@ -40,22 +41,44 @@ import Time import Utils -progressCmd :: Bool -> Int -> Bool -> [TaskID] -> IO () -progressCmd debug waitdelay modules tids = do - when (waitdelay < 1) $ error' "minimum interval is 1 min" +-- 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 when (null tasks) $ error' "no build tasks found" - btasks <- mapM kojiTaskinfoRecursive tasks - loopBuildTasks debug waitdelay btasks + btasks <- mapM initialTaskinfo tasks + tz <- getCurrentTimeZone + loopBuildTasks debug tz btasks -type BuildTask = (TaskID, UTCTime, Maybe UTCTime, Maybe Int, [TaskInfoSize]) +data TaskStatus = TaskStatus + { tstSize :: Int, + tstTime :: UTCTime, + tstState :: TaskState + } + deriving Show -kojiTaskinfoRecursive :: TaskID -> IO BuildTask -kojiTaskinfoRecursive tid = do +mkTaskStatus :: Maybe Int -> Maybe UTCTime -> Maybe TaskState -> Maybe TaskStatus +mkTaskStatus Nothing _ _ = Nothing +mkTaskStatus _ Nothing _ = Nothing +mkTaskStatus _ _ Nothing = Nothing +mkTaskStatus (Just size) (Just time) (Just state) = + Just (TaskStatus size time state) + +-- FIXME change to (TaskID,Struct,Size,Time,State) +data TaskInfoStatus = TaskInfoStatus + { taskInfo :: Struct, + taskStatus :: Maybe TaskStatus} + +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 @@ -79,80 +102,96 @@ error' $ "task " ++ displayID tid ++ " has no start time" Just t -> t mend = lookupTime True taskinfo - return (tid, start, mend, Nothing, zip children (repeat Nothing)) + return $ + BuildTask tid start mend Nothing $ + map (`TaskInfoStatus` Nothing) children --- FIXME change to (TaskID,Struct,Size) -type TaskInfoSize = (Struct,Maybe Int) -type TaskInfoSizes = (Struct,(Maybe Int,Maybe Int)) +type TaskInfoStatuses = (Struct, + (Maybe Int, Maybe UTCTime), + Maybe TaskStatus) -loopBuildTasks :: Bool -> Int -> [BuildTask] -> IO () +loopBuildTasks :: Bool -> TimeZone -> [BuildTask] -> IO () loopBuildTasks _ _ [] = return () -loopBuildTasks debug waitdelay bts = do +loopBuildTasks debug tz bts = do curs <- filter tasksOpen <$> mapM runProgress bts unless (null curs) $ do - threadDelayMinutes waitdelay news <- mapM updateBuildTask curs - loopBuildTasks debug waitdelay news + loopBuildTasks debug tz news where - threadDelayMinutes :: Int -> IO () - threadDelayMinutes m = - -- convert minutes to microseconds - threadDelay (fromEnum (fromIntegral (m * 60) :: Micro)) + tasksOpen :: BuildTask -> Bool + tasksOpen (BuildTask _ _ _ _ ts) = not (null ts) + updateBuildTask :: BuildTask -> IO BuildTask + updateBuildTask (BuildTask tid start mend msize ts) = do + news <- mapM updateTask ts + return (BuildTask tid start mend msize news) + + updateTask :: TaskInfoStatus -> IO TaskInfoStatus + updateTask (TaskInfoStatus task mstatus) = do + let tid = fromJust (readID task) + mnew <- kojiGetTaskInfo fedoraKojiHub tid + case mnew of + Nothing -> error' $ "TaskInfo not found for " ++ displayID tid + Just new -> return (TaskInfoStatus new mstatus) + + -- FIXME use last-modified to predict next update runProgress :: BuildTask -> IO BuildTask - runProgress (tid,start,mend,msize,tasks) = + runProgress (BuildTask tid start mend msize tasks) = case tasks of [] -> do state <- kojiGetTaskState fedoraKojiHub tid if state `elem` map Just openTaskStates then do - threadDelayMinutes waitdelay - kojiTaskinfoRecursive tid - else return (tid, start, Nothing, msize, []) - ((task,_):_) -> do + threadDelaySeconds 61 + initialTaskinfo tid + else return $ BuildTask tid start Nothing msize [] + ((TaskInfoStatus task _):_) -> do when debug $ print task - let epkgnvr = kojiTaskRequestPkgNVR task + statuses <- mapM (buildlogSize debug 0) tasks end <- maybe getCurrentTime return mend - let duration = diffUTCTime end start - logMsg $ either id showNVR epkgnvr ++ " (" ++ displayID tid ++ ")" +-+ maybe "" (\s -> show (s `div` 1000) ++ "kB,") msize +-+ renderDuration True duration - sizes <- mapM buildlogSize tasks - printLogSizes waitdelay sizes - putStrLn "" - let news = map (\(t,(s,_)) -> (t,s)) sizes - (open,closed) = partition (\ (t,_) -> getTaskState t `elem` map Just openTaskStates) news - mlargest = if not (any (\(t,_) -> lookupStruct "method" t /= Just ("buildSRPMFromSCM" :: String)) closed) + let header = + let pkg = kojiTaskRequestPkg task + duration = diffUTCTime end start + in + -- FIXME mostly redundant for a single build task + logMsg $ pkg +-+ "(" ++ displayID tid ++ ")" +-+ maybe "" (\s -> show (s `div` 1000) ++ "kB,") msize +-+ renderDuration True duration + printLogStatuses header tz statuses + let news = map (\(task',(s,t),_) -> TaskInfoStatus task' (mkTaskStatus s t (getTaskState task'))) statuses + (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 maximum $ map snd closed + else Just $ maximum $ mapMaybe (fmap tstSize . taskStatus) closed mbiggest = case (mlargest,msize) of - (Just large, Just size) -> Just $ max large size + (Just large, Just size) -> + Just $ max large size (Just large, Nothing) -> Just large (Nothing,_) -> msize if null open - then runProgress (tid,start,mend,mbiggest,[]) - else return (tid, start, mend, mbiggest, open) - - tasksOpen :: BuildTask -> Bool - tasksOpen (_,_,_,_,ts) = not (null ts) - - updateBuildTask :: BuildTask -> IO BuildTask - updateBuildTask (tid,start,mend,msize,ts) = do - news <- mapM updateTask ts - return (tid, start, mend, msize, news) + then runProgress (BuildTask tid start mend mbiggest []) + else return $ BuildTask tid start mend mbiggest open - updateTask :: TaskInfoSize -> IO TaskInfoSize - updateTask (task,size) = do - let tid = fromJust (readID task) - mnew <- kojiGetTaskInfo fedoraKojiHub tid - case mnew of - Nothing -> error' $ "TaskInfo not found for " ++ displayID tid - Just new -> return (new,size) + -- getTaskState' task = + -- case getTaskState task of + -- Nothing -> error' $ "undefined task state: " ++ show task + -- Just st -> st -buildlogSize :: TaskInfoSize -> IO TaskInfoSizes -buildlogSize (task, old) = do - exists <- if isJust old then return True +buildlogSize :: Bool -> Int -> TaskInfoStatus -> IO TaskInfoStatuses +buildlogSize debug n (TaskInfoStatus task oldstatus) = do + exists <- if isJust oldstatus + then return True else httpExists' buildlog - size <- if exists then httpFileSize' buildlog else return Nothing - return (task,(fromInteger <$> size,old)) + when (debug && n>0) $ putChar '.' + waitDelay + (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) + else + return (task, + (fromInteger <$> msize, mtime), + oldstatus) where tid = show $ fromJust (readID' task) buildlog = "https://kojipkgs.fedoraproject.org/work/tasks" lastFew tid "build.log" @@ -160,37 +199,87 @@ let few = dropWhile (== '0') $ takeEnd 4 tid in if null few then "0" else few + waitDelay :: IO () + waitDelay = do + case tstTime <$> oldstatus of + Nothing -> when (n>0) $ threadDelaySeconds n + Just ot -> do + cur <- getCurrentTime + let delay = delayTime (diffUTCTime cur ot) + when debug $ print delay + threadDelaySeconds delay + + delayTime :: NominalDiffTime -> Int + delayTime dt = + -- FIXME vary by small amounts + let expect = 132 :: Pico + lag = nominalDiffTimeToSeconds dt + in if lag > expect + then n + else fromEnum (expect - lag ) `div` trillion + +million, trillion :: Int +million = 1000000 +trillion = million * million + +secDuration :: NominalDiffTime -> Int +secDuration dt = + let lag = nominalDiffTimeToSeconds dt + in fromEnum lag `div` trillion + +threadDelaySeconds :: Int -> IO () +threadDelaySeconds m = + -- convert seconds to microseconds + threadDelay (fromEnum (fromIntegral m :: Micro)) + + data TaskOutput = TaskOut {_outArch :: Text, moutSize :: Maybe Int, - moutSpeed :: Maybe Int, + moutSizeStep :: Maybe Int, + _moutSizeChanged :: Bool, + _moutTime :: Maybe UTCTime, + _moutTimeStep :: Maybe Int, + _moutTimeChanged :: Bool, _outState :: Text, + _stateChange :: Bool, _method :: Text, _mduration :: Maybe NominalDiffTime} -printLogSizes :: Int -> [TaskInfoSizes] -> IO () -printLogSizes waitdelay tss = - let (mxsi, mxsp, taskoutputs) = (formatSize . map taskOutput) tss - in mapM_ (printTaskOut mxsi mxsp) taskoutputs +printLogStatuses :: IO () -> TimeZone -> [TaskInfoStatuses] -> IO () +printLogStatuses header tz tss = + let (mxsi, mxsp, taskoutputs) = (formatSize . mapMaybe taskOutput) tss + in + unless (null taskoutputs) $ do + header + mapM_ (printTaskOut mxsi mxsp) taskoutputs + putChar '\n' where printTaskOut :: Int64 -> Int64 -> TaskOutput -> IO () - printTaskOut mxsi mxsp (TaskOut a msi msp st mth mdur) = - fprintLn (rpadded 8 ' ' stext % - lpadded mxsi ' ' (optioned commas) % "kB" % " " % - optioned ("[" % lpadded mxsp ' ' commas % " B/min]") % " " % + 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" % " " % + optioned (parenthesised string % " ") % + optioned ("[" % lpadded maxspd ' ' commas % " B/s] ") % + optioned (parenthesised (shown % "s") % " ") % + lpadded 8 ' ' (optioned (string % " ")) % stext % " " % - optioned string % " " % stext) - a - ((`div` 1000) <$> msi) - ((`div` waitdelay) <$> msp) - st - (renderDuration True <$> mdur) - (abridgeMethod mth) + stext) + arch + ((`div` 1000) <$> msize) + (show . localTimeOfDay . utcToLocalTime tz <$> mtime) + (if msizediff == Just 0 + then Just 0 + else liftM2 div msizediff mtimediff) + mtimediff + (renderDuration True <$> mduration) + state + (abridgeMethod mthd) formatSize :: [TaskOutput] -> (Int64, Int64,[TaskOutput]) formatSize ts = let maxsi = maximum $ 0 : mapMaybe moutSize ts - -- was "198,689" - maxsp = maximum $ 0 : mapMaybe moutSpeed ts + maxsp = maximum $ 0 : mapMaybe moutSizeStep ts in (decimalLength maxsi, decimalLength maxsp, ts) where decimalLength = fromIntegral . length . show @@ -202,17 +291,31 @@ "buildSRPMFromSCM" -> "SRPM" _ -> mth - taskOutput :: TaskInfoSizes -> TaskOutput - taskOutput (task, (size,old)) = - let method = maybeVal "method not found" (lookupStruct "method") task :: Text - arch = maybeVal "arch not found" (lookupStruct "arch") task :: Text - diff = (-) <$> size <*> old - state = maybeVal "No state found" getTaskState task - state' = - if state == TaskOpen - then "" - else T.pack $ show state - in TaskOut arch size diff state' method (durationOfTask task) + taskOutput :: TaskInfoStatuses -> Maybe TaskOutput + taskOutput (task, (size,time), oldstatus) = + let oldtime = tstTime <$> oldstatus + oldsize = tstSize <$> oldstatus + oldstate = tstState <$> oldstatus + 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 + timediff = if time == oldtime + then Nothing + else secDuration <$> liftM2 diffUTCTime time oldtime + state' = + case mstate of + Nothing -> error' "No state found" + Just s -> + 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) kojiListBuildTasks :: Maybe String -> IO [TaskID] kojiListBuildTasks muser = do diff --git a/src/Utils.hs b/src/Utils.hs --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,6 +1,7 @@ module Utils ( kojiTaskRequestNVR, kojiTaskRequestPkgNVR, + kojiTaskRequestPkg, kojiGetBuildID', kojiGetBuild', showValue, @@ -9,7 +10,8 @@ ) where -import Data.List.Extra (dropSuffix, isInfixOf, isPrefixOf, isSuffixOf, replace) +import Data.List.Extra (dropSuffix, isInfixOf, isPrefixOf, isSuffixOf, replace, + takeWhileEnd) import Data.RPM (dropArch) import Data.RPM.NVR import Data.RPM.NVRA @@ -27,6 +29,7 @@ _ -> Nothing -- FIXME this should really be a triple +-- FIXME should not use on build kojiTaskRequestPkgNVR :: Struct -> Either String NVR kojiTaskRequestPkgNVR task = case lookupStruct "request" task of @@ -40,10 +43,14 @@ Right $ dropArch nvra _ -> let base = takeBaseName src in Left $ + -- fedora-ci_fc87dcd7db694cdfac703cf5af128a72_c1f53c859616fdbf40811058b60bebe2930e3271_0;forks:petersen:rpms:grub2.f38.src.rpm if "fedora-ci_" `isPrefixOf` base - then tail $ dropWhile (/= ';') base + then takeWhileEnd (/= ':') $ tail $ dropWhile (/= ';') base else base _ -> error' "could determine package from build request" + +kojiTaskRequestPkg :: Struct -> String +kojiTaskRequestPkg = either id showNVR . kojiTaskRequestPkgNVR kojiGetBuildID' :: String -> String -> IO BuildID kojiGetBuildID' hub nvr = do