fbrnch-1.4: src/RpmBuild.hs

module RpmBuild (
  builtRpms,
  buildRPMs,
  installDeps,
  buildRequires,
  getSources,
  getSourcesMacros,
  getDynSourcesMacros,
  generateSrpm,
  generateSrpm',
  BCond(..),
  ForceShort(..),
  isShortCircuit,
  checkSourcesMatch,
  notInstalled,
  rpmEval,
  distRpmOptions
  )
where

import Control.Exception (uninterruptibleMask_)
import Data.Char (isDigit)
import Data.Either (partitionEithers)
import Data.RPM
import qualified Distribution.Fedora as Dist
import Distribution.Fedora (Dist)
import Network.HTTP.Directory (Manager, httpExists, httpManager)
import SimpleCmd.Rpm
import SimplePrompt (promptEnter)
import System.Console.Pretty
import System.IO.Extra (withTempDir)
import System.Posix.Files

import Branches
import Cmd.Update (updatePkg)
import Common
import Common.System
import Git
import Package

distOpt :: Dist -> [String]
distOpt dist =
  ["--define", "dist" +-+ "%{?distprefix}" ++ Dist.rpmDistTag dist]

-- FIXME hardcoding
distRpmOptions :: Branch -> IO [String]
distRpmOptions br =
  map ("--define=" ++) <$>
  case br of
    Rawhide -> do
      dist <- Dist.getRawhideDist
      let ver = case dist of
                  Dist.Fedora n -> show n
                  _ -> error' $ "impossible rawhide version:"  +-+ show dist
      return ["fedora" +-+ ver, "fc" ++ ver +-+ "1"]
    Fedora n -> return ["fedora" +-+ show n, "fc" ++ show n +-+ "1"]
    EPEL n -> return ["rhel" +-+ show n, "el" ++ show n +-+ "1"]
    EPELNext n -> return ["rhel" +-+ show n, "el" ++ show n +-+ "1"]

builtRpms :: AnyBranch -> FilePath -> IO [FilePath]
builtRpms br spec = do
  dist <- getBranchDist br
  rpmdir <- fromMaybe "" <$> rpmEval "%{_rpmdir}"
  autoreleaseOpt <- getAutoReleaseOptions spec
  rpms <- rpmspec (["--builtrpms", "--define", "dist" +-+ Dist.rpmDistTag dist] ++ autoreleaseOpt) (Just (rpmdir </>  "%{arch}/%{name}-%{version}-%{release}.%{arch}.rpm")) spec
  if null rpms
    then error' $ spec +-+ "does not seem to create any rpms"
    else return rpms

rpmEval :: String -> IO (Maybe String)
rpmEval s = do
  res <- cmd "rpm" ["--eval", s]
  return $ if null res || res == s then Nothing else Just res

-- rpmEval' :: String -> IO String
-- rpmEval' s = do
--   mres <- rpmEval s
--   fromMaybe (error' (show s +-+ "undefined!")) mres

getSources :: FilePath -> IO [FilePath]
getSources spec = do
  -- FIXME fallback to ~/rpmbuild/SOURCES?
  msrcdir <- do
    cwd <- getCurrentDirectory
    msourcedir <- rpmEval "%{_sourcedir}"
    case msourcedir of
      Nothing -> return Nothing
      Just srcdir -> do
        canon <- canonicalizePath srcdir
        if canon == cwd
          then return Nothing
          else do
          dir <- doesDirectoryExist srcdir
          if dir
            then return msourcedir
            else return Nothing
  isPkgGit <- isPkgGitRepo
  (patches,srcs) <- partitionEithers . map sourceFieldFile
                    <$> cmdLines "spectool" ["-a", spec]
  forM_ srcs $ \ src -> do
    exists <- doesFileExist src &&^ checkCompression src
    inSrcdir <- doesSourceDirFileExist msrcdir src
    unless exists $ do
      if inSrcdir
        then maybeSourceDir createLink msrcdir src
        else do
        uploaded <-
          if isPkgGit then do
            have_sources <- doesFileExist "sources"
            if have_sources then
              grep_ src "sources"
              else return False
          else return False
        mfedpkg <- findExecutable "fedpkg"
        if uploaded && isJust mfedpkg
          then cmd_ "fedpkg" ["sources"]
          else do
          cmd_ "spectool" ["-g", "-S", spec]
          unlessM (doesFileExist src) $
            error' $ "download failed:" +-+ src
    unless inSrcdir $
      whenJust msrcdir $ \srcdir ->
      createLink src (srcdir </> src)
  forM_ patches $ \patch ->
    unlessM (doesFileExist patch) $ do
    inSrcdir <- doesSourceDirFileExist msrcdir patch
    if inSrcdir
      then maybeSourceDir copyFile msrcdir patch
      else do
      cmd_ "spectool" ["-g", "-P", spec]
      unlessM (doesFileExist patch) $
        error' $ "missing patch:" +-+ patch
  return $ srcs ++ patches
  where
    sourceFieldFile :: String -> Either FilePath FilePath
    sourceFieldFile field =
      case word1 field of
        (f,v) ->
          -- rpmdevtools 9.3 (spectool always lists --all)
          -- "Source0:" or "Patch1:"
          (case lower (dropWhileEnd isDigit (init f)) of
             "source" -> Right
             "patch" -> Left
             _ -> error' $! "illegal field:" +-+ f)
          $ takeFileName v

    checkCompression :: FilePath -> IO Bool
    checkCompression file =
      case
        case takeExtension file of
          ".gz" -> Just "gzip"
          ".tgz" -> Just "gzip"
          ".bz2" -> Just "bzip2"
          ".xz" -> Just "xz"
          ".lz" -> Just "lzip"
          ".zstd" -> Just "zstd"
          _ -> Nothing
      of
        Just prog -> do
          have <- findExecutable prog
          when (isNothing have) $ do
            putStrLn $ "Running 'dnf install'" +-+ prog
            cmd_ "/usr/bin/sudo" $ "/usr/bin/dnf":"install": ["--assumeyes", prog]
          cmdBool prog ["-t", file]
        Nothing -> return True

    maybeSourceDir :: (FilePath -> FilePath -> IO ())
                   -> Maybe FilePath -> FilePath -> IO ()
    maybeSourceDir act mdir file =
      whenJust mdir $ \dir ->
      act (dir </> file) file

    doesSourceDirFileExist :: Maybe FilePath -> FilePath -> IO Bool
    doesSourceDirFileExist msrcdir file =
      doesFileExist (fromMaybe "" msrcdir </> file)

generateSrpm :: Maybe AnyBranch -> FilePath -> IO FilePath
generateSrpm = generateSrpm' False

generateSrpm' :: Bool -> Maybe AnyBranch -> FilePath -> IO FilePath
generateSrpm' force mbr spec = do
  srcs <- getSources spec
  distopt <- case mbr of
               Nothing -> return []
               Just br -> do
                 dist <- getBranchDist br
                 return $ distOpt dist
  msrcrpmdir <- rpmEval "%{_srcrpmdir}"
  srpmfile <- cmd "rpmspec" $ ["-q", "--srpm"] ++ distopt ++ ["--qf", fromMaybe "" msrcrpmdir </> "%{name}-%{version}-%{release}.src.rpm", spec]
  cwd <- getCurrentDirectory
  let sourcediropt = ["--define", "_sourcedir" +-+ cwd]
      opts = distopt ++ sourcediropt
  if force then
    buildSrpm opts
    else do
    exists <- doesFileExist srpmfile
    if not exists
      then buildSrpm opts
      else do
      srpmTime <- getModificationTime srpmfile
      fileTimes <- mapM getModificationTime (spec:srcs)
      if any (srpmTime <) fileTimes
        then buildSrpm opts
        else do
        -- pretty print with ~/
        putStrLn $ srpmfile +-+ "is up to date"
        return srpmfile
  where
    buildSrpm opts = do
      -- 1. prevent Ctrl-c from truncating srpm to corrupted file:
      -- 'Error: Downloaded rpm http://kojipkgs-cache01.s390.fedoraproject.org/work/cli-build/1691493908.5614614.AzJmareV/ghc9.4-9.4.6-22.fc39.src.rpm is corrupted:'
      -- 2. can end with stdout "RPM build warnings:" etc
      -- https://github.com/rpm-software-management/rpm/issues/2494
      outs <- words <$> uninterruptibleMask_ (cmd "rpmbuild" (opts ++ ["-bs", spec]))
      case filter ("src.rpm" `isExtensionOf`) outs of
        [srpm] -> do
          putStrLn $ "Created" +-+ takeFileName srpm
          return srpm
        srpms -> error' $ "could not determined generated srpm filename" +-+ unwords srpms

data BCond = BuildWith String | BuildWithout String

instance Show BCond where
  show (BuildWith s) = "--with=" ++ s
  show (BuildWithout s) = "--without=" ++ s


getAutoReleaseOptions :: FilePath -> IO [String]
getAutoReleaseOptions spec = do
      autorelease <- isAutoRelease spec
      if autorelease
        then do
        -- FIXME upstream bug "--number-only" doesn't work
        calculated <- cmd "rpmautospec" ["calculate-release", spec]
        return ["--define", "_rpmautospec_release_number" +-+ dropPrefix "Calculated release number: " calculated]
        else return []

data ForceShort = ForceBuild | ShortCompile | ShortInstall
  deriving Eq

isShortCircuit :: Maybe ForceShort -> Bool
isShortCircuit ms =
  case ms of
    Just s -> s /= ForceBuild
    Nothing -> False

-- FIXME create build.log
-- Note does not check if bcond changed
-- FIXME check tarball timestamp
buildRPMs :: Bool -> Bool -> Bool -> Maybe ForceShort -> [BCond] -> [FilePath]
          -> AnyBranch -> FilePath -> IO Bool
buildRPMs quiet debug noclean mforceshort bconds rpms br spec = do
  needBuild <-
    if isJust mforceshort
    then return True
    else do
      allexist <- and <$> mapM doesFileExist rpms
      if not allexist
        then return True
        else do
        specTime <- getModificationTime spec
        rpmTimes <- sort <$> mapM getModificationTime rpms
        return $ specTime > head rpmTimes
  if not needBuild then
    putStrLn "Existing rpms are newer than spec file (use --force to rebuild)"
    else do
    installDeps True spec
    void $ getSources spec
    dist <- getBranchDist br
    cwd <- getCurrentDirectory
    autoreleaseOpt <- getAutoReleaseOptions spec
    let buildopt =
          case mforceshort of
            Just ShortCompile -> ["-bc", "--short-circuit"]
            Just ShortInstall -> ["-bi", "--short-circuit"]
            _ -> "-bb" : ["--noclean" | noclean]
        sourcediropt = ["--define", "_sourcedir" +-+ cwd]
        args = sourcediropt ++ distOpt dist ++
               buildopt ++ map show bconds ++ autoreleaseOpt ++ [spec]
    date <- cmd "date" ["+%T"]
    rbr <- anyBranchToRelease br
    nvr <- pkgNameVerRel' rbr spec
    putStr $ date +-+ "Building" +-+ showNVR nvr +-+ "locally... "
    ok <- do
      let buildlog = ".build-" ++ (showVerRel . nvrVerRel) nvr <.> "log"
      whenM (doesFileExist buildlog) $ do
        let backup = buildlog <.> "prev"
        whenM (doesFileExist backup) $ do
          prevsize <- getFileSize backup
          currsize <- getFileSize buildlog
          when (prevsize > currsize) $
            copyFile backup (backup <.> "prev")
        copyFile buildlog (buildlog <.> "prev")
      timeIO $
        if not quiet || isShortCircuit mforceshort
        then do
          putNewLn
          -- FIXME would like to have pipeOutErr
          let buildcmd = unwords $ "rpmbuild" : map quoteArg args ++ "|&" : "tee" : [buildlog +-+ "&& exit ${PIPESTATUS[0]}"]
          when debug $ putStrLn buildcmd
          shellBool buildcmd
        else do
          let buildcmd = unwords $ "rpmbuild" : map quoteArg args ++ [">&", buildlog]
          when debug $ putStrLn buildcmd
          res <- shellBool buildcmd
          if res
            then putStrLn "done"
            else cmd_ "tail" ["-n 100", buildlog]
          return res
    unless ok $
      error' $ showNVR nvr +-+ "failed to build"
  return needBuild
  where
    quoteArg :: String -> String
    quoteArg cs =
      if ' ' `elem` cs then '\'' : cs ++ "'" else cs

-- FIXME print unavailable deps
installDeps :: Bool -> FilePath -> IO ()
installDeps strict spec = do
  missingdeps <- nub <$> (buildRequires spec >>= filterM notInstalled)
  unless (null missingdeps) $ do
    putStrLn $ "Running 'dnf install'" +-+ unwords missingdeps
    cmd_ "/usr/bin/sudo" $ "/usr/bin/dnf":"install": ["--skip-broken" | not strict] ++ ["--assumeyes"] ++ missingdeps

installMissingMacros :: FilePath -> IO ()
installMissingMacros spec = do
  macros <- mapMaybeM needSrpmMacro srpmMacros
  missing <- filterM notInstalled macros
  unless (null missing) $
    cmd_ "/usr/bin/sudo" $ ["/usr/bin/dnf", "install", "--assumeyes"] ++ missing
  where
    srpmMacros :: [(String,String)]
    srpmMacros =
      [("%gometa", "go-rpm-macros"),
       ("fontpkgname", "fonts-rpm-macros"),
       ("%cargo_prep", "rust-packaging")]

    needSrpmMacro :: (String,String) -> IO (Maybe String)
    needSrpmMacro (meta, macros) = do
      contents <- readFile spec
      return $ if meta `isInfixOf` contents then Just macros else Nothing

-- from fedora-haskell-tools
buildRequires :: FilePath -> IO [String]
buildRequires spec = do
  autorelease <- isAutoRelease spec
  dynbr <- grep_ "^%generate_buildrequires" spec
  brs <- mapMaybe primary <$>
    if dynbr
    then do
      installMissingMacros spec
      void $ getSources spec
      withTempDir $ \tmpdir -> do
        let srpmdiropt = ["--define", "_srcrpmdir" +-+ tmpdir]
        (_ok, out, err) <- cmdFull "rpmbuild" (["-br", "--nodeps", spec] ++ srpmdiropt) ""
        -- Wrote: /current/dir/SRPMS/name-version-release.buildreqs.nosrc.rpm
        case words out of
          [] -> error' $ spec +-+ "could not generate source rpm for dynamic buildrequires"
          ws -> do
            let srpm = last ws
            exists <- doesFileExist srpm
            if exists
              then cmdLines "rpm" ["-qp", "--requires", last ws]
              else error' err
    else
      -- FIXME should resolve meta
      rpmspec ["--buildrequires"] Nothing spec
  return $ brs ++ ["rpmautospec" | autorelease]
  where
    primary dep =
      case (head . words) dep of
        '(':rest -> Just rest
        d -> if "rpmlib(" `isPrefixOf` d
             then Nothing
             else Just d

checkSourcesMatch :: Package -> AnyBranch -> FilePath -> IO ()
checkSourcesMatch pkg br spec = do
  -- "^[Ss]ource[0-9]*:"
  sourcefiles <- map (takeFileName . last . words) <$> cmdLines "spectool" [spec]
  sources <- lines <$> readFile "sources"
  gitfiles <- gitLines "ls-files" []
  let missing = filter (\src -> isNothing (find (src `isInfixOf`) sources) &&
                                src `notElem` gitfiles)
                sourcefiles
  unless (null missing) $ do
    promptEnter $ color Red $ unwords missing +-+ "not in sources, press Enter to fix"
    updatePkg True False False True Nothing pkg br
    git_ "status" ["--short"]
    promptEnter "Please Enter to amend commit and continue"
    git_ "commit" ["--amend"]
    unlessM isGitDirClean $
      error' "local changes remain (dirty)"
    checkOnBranch
    checkSourcesMatch pkg br spec
  mgr <- httpManager
  mapM_ (checkLookasideCache mgr) sources
  where
    checkLookasideCache :: Manager -> String -> IO ()
    checkLookasideCache mgr source = do
      let (file,url) =
            case words source of
              ("SHA512":('(':fileparen):"=":[hash]) ->
                let file' = dropSuffix ")" fileparen
                in (file', "https://src.fedoraproject.org/lookaside/pkgs" +/+ unPackage pkg +/+ file +/+ "sha512" +/+ hash +/+ file)
              [hash,file'] ->
                (file', "https://src.fedoraproject.org/lookaside/pkgs" +/+ unPackage pkg +/+ file +/+ "md5" +/+ hash +/+ file)
              _ -> error' $ "invalid/unknown source:\n" ++ source
      unlessM (httpExists mgr url) $ do
        putStrLn $ url +-+ "not found"
        putStrLn $ "uploading" +-+ file +-+ "to lookaside source repo"
        fedpkg_ "upload" [file]

notInstalled :: String -> IO Bool
notInstalled pkg =
  not <$> cmdBool "rpm" ["--quiet", "-q", "--whatprovides", pkg]

getSourcesMacros :: FilePath -> IO ()
getSourcesMacros spec = do
  void $ getSources spec
  installMissingMacros spec

getDynSourcesMacros :: FilePath -> IO ()
getDynSourcesMacros spec =
  whenM (grep_ "^%generate_buildrequires" spec) $
   getSourcesMacros spec