koji-tool 0.9.3 → 0.9.4
raw patch · 11 files changed
+348/−210 lines, 11 filesdep ~http-directorydep ~time
Dependency ranges changed: http-directory, time
Files
- ChangeLog.md +12/−0
- README.md +14/−12
- TODO +1/−0
- koji-tool.cabal +4/−4
- src/BuildlogSizes.hs +3/−3
- src/DownloadDir.hs +1/−1
- src/Find.hs +3/−2
- src/Install.hs +99/−89
- src/Main.hs +9/−7
- src/Progress.hs +193/−90
- src/Utils.hs +9/−2
ChangeLog.md view
@@ -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
README.md view
@@ -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
TODO view
@@ -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
koji-tool.cabal view
@@ -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
src/BuildlogSizes.hs view
@@ -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
src/DownloadDir.hs view
@@ -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
src/Find.hs view
@@ -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] ++
src/Install.hs view
@@ -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 =
src/Main.hs view
@@ -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)"
src/Progress.hs view
@@ -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
src/Utils.hs view
@@ -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