module Koji ( kojiNVRTags, kojiBuildStatus, kojiBuildTags, kojiGetBuildID, kojiGetBuildState, kojiGetBuildTaskID, kojiLatestNVR, kojiOpenTasks, kojiScratchBuild, kojiUserSideTags, buildIDInfo, BuildInfo(BuildInfoNVR), BuildState(..), kojiBuildBranch, kojiBuildBranchNoWait, kojiSource, kojiBuildTarget', kojiTagArchs, kojiWaitRepoNVR, kojiWaitRepoNVRs, kojiWaitRepo, kojiWatchTask, kojiWaitTask, putTaskinfoUrl, TaskID, displayID, fedoraHub, getKojiProfileHub, maybeTimeout, createKojiSidetag, targetMaybeSidetag ) where import Data.Char (isDigit) import qualified Data.ByteString.Lazy.Char8 as B import Data.Fixed (Micro) import Data.RPM.NVR (NVR, maybeNVR) import Data.Time.Clock import Data.Time.Format import Data.Time.LocalTime import Distribution.Koji import qualified Distribution.Koji.API as Koji import Distribution.Fedora.Branch (branchRelease) import Distribution.Fedora.Release (releaseDistTag) import Fedora.Krb (fasIdFromKrb, krbTicket) import Safe (headMay, tailSafe) import Say (sayString) import SimplePrompt (promptEnter, promptNonEmpty, yesNo) import System.Environment (lookupEnv) import System.Exit import System.Process.Typed import System.Timeout (timeout) import System.Time.Extra (sleep) import Branches import Common import Common.System import Git import Package (fedpkg) import Pagure import Types fedoraHub :: String fedoraHub = fedoraKojiHub getKojiProfile :: IO (Maybe String) getKojiProfile = lookupEnv "FBRNCH_KOJI_PROFILE" getKojiProfileHub' :: Maybe String -> IO String getKojiProfileHub' mprofile = do case mprofile of Nothing -> return fedoraKojiHub Just p -> do let file = "/etc/koji.conf.d" p <.> "conf" exists <- doesFileExist file if exists then do serv <- grep "^server =" $ "/etc/koji.conf.d" p <.> "conf" case serv of [sl] -> case words sl of ["server","=",hub] -> return hub _ -> error' $ "Invalid server config in" +-+ file _ -> error' $ "Undefined server in" +-+ file else error' $ "Undefined koji profile:" +-+ p getKojiProfileHub :: IO String getKojiProfileHub = getKojiProfile >>= getKojiProfileHub' kojiNVRTags :: NVR -> IO [String] kojiNVRTags nvr = do hub <- getKojiProfileHub mbldid <- kojiGetBuildID hub $ showNVR nvr case mbldid of Nothing -> error' $ showNVR nvr +-+ "koji build not found" Just bldid -> kojiBuildTags hub (buildIDInfo bldid) kojiBuildStatus :: NVR -> IO (Maybe BuildState) kojiBuildStatus nvr = do hub <- getKojiProfileHub kojiGetBuildState hub (BuildInfoNVR (showNVR nvr)) kojiLatestNVR :: String -> String -> IO (Maybe NVR) kojiLatestNVR tag pkg = do hub <- getKojiProfileHub mbld <- kojiLatestBuild hub tag pkg return $ case mbld of Nothing -> Nothing Just bld -> lookupStruct "nvr" bld >>= maybeNVR kojiOpenTasks :: Package -> Maybe String -> String -> IO [TaskID] kojiOpenTasks pkg mref target = do hub <- getKojiProfileHub user <- fasIdFromKrb muserid <- kojiGetUserID hub user let userid = fromMaybe (error' $ "Koji failed to return userid for '" ++ user ++ "'") muserid commit <- maybe (git "rev-parse" ["HEAD"]) return mref let source = kojiSource pkg commit kojiUserBuildTasks hub userid (Just source) (Just target) -- * Koji building kojiScratchBuild :: String -> [String] -> FilePath -> IO String kojiScratchBuild target args srpm = do Right url <- kojiBuild' True target $ args ++ ["--scratch", "--no-rebuild-srpm", srpm] return url type KojiBuildTask = Either TaskID String -- FIXME setTermTitle nvr kojiBuild' :: Bool -> String -> [String] -> IO KojiBuildTask kojiBuild' wait target args = do krbTicket let srpm = if null args then error' "no args passed to koji build" else ".src.rpm" `isSuffixOf` last args -- FIXME use tee functionality when srpm $ putStrLn "koji srpm build: uploading..." mprofile <- getKojiProfile -- can fail like: -- [ERROR] koji: Request error: POST::https://koji.fedoraproject.org/kojihub/ssllogin:: -- [ERROR] koji: AuthError: unable to obtain a session -- readCreateProcess: koji "build" "--nowait" "f33-build-side-25385" "--fail-fast" "--background" ... (exit 1): failed (ret,out) <- readProcessStdout $ proc "koji" $ kojiProfileOpt mprofile ++ ["build", "--nowait", target] ++ args -- for srpm: drop uploading line until doing tee -- for git: drop "Created task: " -- init to drop final newline unless (B.null out) $ -- FIXME include output example here logMsg $ (dropPrefix "Task info: " . B.unpack . B.init . B.unlines . tailSafe . B.lines) out if ret == ExitSuccess then do let kojiurl = B.unpack $ last $ B.words out task = (TaskId . read) $ takeWhileEnd isDigit kojiurl when wait $ do -- FIXME get actual build time timeIO $ kojiWatchTask task cmd_ "date" ["+%T"] return $ if wait then Right kojiurl else Left task else do promptEnter "Press Enter to resubmit Koji build" kojiBuild' wait target args -- kojiBuild :: String -> [String] -> IO String -- kojiBuild target args = do -- Right url <- kojiBuild' True target args -- return url kojiProfileOpt :: Maybe String -> [String] kojiProfileOpt Nothing = [] kojiProfileOpt (Just p) = ["--profile", p] -- FIXME filter/simplify output -- FIXME implement native watchTask kojiWatchTask :: TaskID -> IO () kojiWatchTask task = do mprofile <- getKojiProfile -- FIXME can error: -- eg1 [ERROR] koji: HTTPError: 503 Server Error: Service Unavailable for url: https://koji.fedoraproject.org/kojihub -- eg2 [ERROR] koji: ServerOffline: database outage: - user error (Error 1014: database outage) -- eg3 [ERROR] koji: ReadTimeout: HTTPSConnectionPool(host='koji.fedoraproject.org', port=443): Read timed out. (read timeout=43200) -- This might error with exit 0 occasionally so we check the taskstate always void $ cmdBool "koji" $ kojiProfileOpt mprofile ++ ["watch-task", displayID task] hub <- getKojiProfileHub' mprofile mst <- kojiGetTaskState hub task case mst of Just TaskClosed -> return () Just TaskFailed -> do whenJustM (findExecutable "koji-tool") $ \kojitool -> do cmdLog_ kojitool ["tasks", "--hub", hub, "--children", displayID task, "--tail", "-s", "fail"] putTaskinfoUrl hub task error' "Task failed!" Just TaskCanceled -> return () _ -> kojiWatchTask task putTaskinfoUrl :: String -> TaskID -> IO () putTaskinfoUrl hub tid = putStrLn $ dropSuffix "hub" hub +/+ "taskinfo?taskID=" ++ show (getID tid) -- FIXME during network disconnection: -- Connection timed out: retrying -- Connection timed out: retrying -- Network.Socket.connect: : does not exist (No route to host) kojiWaitTask :: TaskID -> IO Bool kojiWaitTask task = do hub <- getKojiProfileHub -- FIXME can error: -- eg1 [ERROR] koji: HTTPError: 503 Server Error: Service Unavailable for url: https://koji.fedoraproject.org/kojihub -- eg2 [ERROR] koji: ServerOffline: database outage: - user error (Error 1014: database outage) mst <- maybeTimeout 45 $ kojiGetTaskState hub task case mst of Just ts -> if ts `elem` openTaskStates then do sleep 20 kojiWaitTask task else return $ ts == TaskClosed Nothing -> do error $ "failed to get info for koji task" +-+ displayID task kojiSource :: Package -> String -> String kojiSource pkg ref = "git+https://" ++ srcfpo ++ "/rpms" +/+ unPackage pkg ++ ".git#" ++ ref kojiBuildBranch' :: Bool -> String -> Package -> Maybe String -> [String] -> IO KojiBuildTask kojiBuildBranch' wait target pkg mref args = do commit <- maybe (git "rev-parse" ["HEAD"]) return mref kojiBuild' wait target $ args ++ [kojiSource pkg commit] kojiBuildBranch :: String -> Package -> Maybe String -> [String] -> IO () kojiBuildBranch target pkg mref args = checkResult <$> kojiBuildBranch' True target pkg mref args where checkResult = either (\ task -> error' (displayID task +-+ "not completed")) (const ()) kojiBuildBranchNoWait ::String -> Package -> Maybe String -> [String] -> IO TaskID kojiBuildBranchNoWait target pkg mref args = do Left task <- kojiBuildBranch' False target pkg mref args return task -- remove once in koji-hs kojiBuildTarget' :: String -- ^ hubUrl -> String -- ^ target -> IO (String, String) -- ^ (build-tag,dest-tag) kojiBuildTarget' hub target = do mres <- kojiBuildTarget hub target case mres of Nothing -> error' $ "failed to get BuildTarget for" +-+ target Just res -> return res -- FIXME should be NonEmpty -- FIXME add back knowntag? kojiWaitRepoNVRs :: Bool -> Bool -> String -> [NVR] -> IO () kojiWaitRepoNVRs _ _ _ [] = error' "no NVRs given to wait for" kojiWaitRepoNVRs dryrun quiet target nvrs = do hub <- getKojiProfileHub (buildtag,_desttag) <- kojiBuildTarget' hub target unless dryrun $ do tz <- getCurrentTimeZone unless quiet $ logSay tz $ "Waiting for" +-+ buildtag +-+ "to have" +-+ case nvrs of [nvr] -> showNVR nvr _ -> "builds" mprofile <- getKojiProfile -- FIXME use knowntag to quieten output: for override outputs, eg -- "nvr ghc-rpm-macros-2.7.5-1.fc41 is not current in tag f41-build -- latest build is ghc-rpm-macros-2.7.2-4.fc41" -- or "No clang18 builds in tag epel10.1-build" void $ timeIO $ cmd "koji" (kojiProfileOpt mprofile ++ ["wait-repo", "--request", "--quiet"] ++ ["--build=" ++ showNVR nvr | nvr <- nvrs] ++ [buildtag]) kojiWaitRepoNVR :: Bool -> Bool -> String -> NVR -> IO () kojiWaitRepoNVR dryrun quiet target nvr = kojiWaitRepoNVRs dryrun quiet target [nvr] -- FIXME display more status/age info kojiWaitRepo :: Bool -> Bool -> String -> IO () kojiWaitRepo dryrun quiet target = do hub <- getKojiProfileHub (buildtag,_desttag) <- kojiBuildTarget' hub target tz <- getCurrentTimeZone unless quiet $ logSay tz $ "Waiting for" +-+ buildtag unless dryrun $ do mprofile <- getKojiProfile void $ timeIO $ cmd "koji" $ kojiProfileOpt mprofile ++ ["wait-repo", "--request", "--quiet", buildtag] kojiTagArchs :: String -> IO [String] kojiTagArchs tag = do hub <- getKojiProfileHub st <- Koji.getTag hub (Koji.InfoString tag) Nothing return $ maybe [] words $ lookupStruct "arches" st kojiUserSideTags :: Maybe Branch -> IO [String] kojiUserSideTags mbr = do hub <- getKojiProfileHub user <- fasIdFromKrb mapMaybe (headMay . words) <$> case mbr of Nothing -> do maybeTimeout 55 $ kojiListSideTags hub Nothing (Just user) Just br -> do mtags <- kojiBuildTarget hub (showBranch br) case mtags of Nothing -> return [] Just (buildtag,_desttag) -> kojiListSideTags hub (Just buildtag) (Just user) maybeTimeout :: Micro -> IO a -> IO a maybeTimeout secs act = do mres <- timeout (fromEnum secs) act case mres of Nothing -> do warning "Connection timed out: retrying" maybeTimeout (secs + 5) act Just res -> return res createKojiSidetag :: Bool -> Branch -> IO String createKojiSidetag dryrun br = do hub <- getKojiProfileHub (buildtag,_desttag) <- kojiBuildTarget' hub (showBranch br) out <- if dryrun then return $ "Side tag '" ++ buildtag ++ "'" else do krbTicket ls <- lines <$> fedpkg "request-side-tag" ["--base-tag", buildtag] case ls of [] -> error' "no output from request-side-tag" (l:_) -> return l if "Side tag '" `isPrefixOf` out then do putNewLn let sidetag = init . dropWhileEnd (/= '\'') $ dropPrefix "Side tag '" out putStrLn $ "Sidetag" +-+ sidetag +-+ "created" -- logMsg $ "Waiting for" +-+ sidetag +-+ "repo" -- unless dryrun $ -- cmd_ koji ["wait-repo", sidetag] return sidetag else error' "'fedpkg request-side-tag' failed" targetMaybeSidetag :: Bool -> Bool -> Bool -> Branch -> Maybe SideTagTarget -> IO String targetMaybeSidetag dryrun strict create br msidetagTarget = case msidetagTarget of Nothing -> return $ showBranch br Just (Target t) -> do disttag <- releaseDistTag <$> branchRelease br if t == "rawhide" && br == Rawhide then return disttag else do unless (disttag `isPrefixOf` t) $ do let msg = "Branch" +-+ showBranch br +-+ "does not match target" +-+ t in if strict then do ok <- yesNo $ msg ++ "! Are you sure?" unless ok $ error' "aborted" else whenM isPkgGitRepo $ warning ("Warning:" +-+ msg) return t Just SideTag -> do tags <- kojiUserSideTags (Just br) case tags of [] -> if create then createKojiSidetag dryrun br else error' "no existing side-tag" [tag] -> return tag _ -> do putStrLn $ "User side-tags found for" +-+ showBranch br ++ ":" let num = length tags nums = map show [1..num] numtags = zip nums $ sort tags mapM_ (putStrLn . \(n,s) -> n ++ ":" +-+ s) numtags tag <- promptTags numtags $ "Choose" +-+ (if num == 2 then "1 or 2" else "1-" ++ show num) +-+ "or enter sidetag; or 0 to abort" putStrLn $ "will use" +-+ tag putNewLn return tag logSay :: TimeZone -> String -> IO () logSay tz str = do now <- utcToLocalTime tz <$> getCurrentTime sayString $ formatTime defaultTimeLocale "%T" now +-+ str promptTags :: [(String,String)] -> String -> IO String promptTags numtags txt = do ans <- promptNonEmpty txt if ans `elem` map snd numtags then return ans else case lookup ans numtags of Just t -> return t Nothing -> if lower ans `elem` ["0", "q", "quit", "no"] then error' "aborting" else promptTags numtags txt