fbrnch-1.3: src/RpmBuild.hs

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

import Data.Char (isDigit)
import Data.Either (partitionEithers)
import Data.RPM
import Distribution.Fedora hiding (Fedora,EPEL,EPELNext)
import Network.HTTP.Directory (Manager, httpExists, httpManager)
import SimpleCmd.Rpm
import SimplePrompt (prompt_)
import System.Console.Pretty
import System.IO.Extra (withTempDir)
import System.Posix.Files

import Branches
import Common
import Common.System
import Git
import Package

builtRpms :: AnyBranch -> FilePath -> IO [FilePath]
builtRpms br spec = do
  dist <- getBranchDist br
  -- previously was "" for pkggit
  rpmdir <- fromMaybe "" <$> rpmEval "%{_rpmdir}"
  rpms <- rpmspec ["--builtrpms", "--define", "dist " ++ rpmDistTag dist] (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 Nothing _ = return False
    doesSourceDirFileExist (Just srcdir) file =
      doesFileExist (srcdir </> 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 ["--define", "dist " ++ rpmDistTag 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
      srpm <- last . words <$> cmd "rpmbuild" (opts ++ ["-bs", spec])
      putStrLn $ "Created " ++ takeFileName srpm
      return srpm

data ForceShort = ForceBuild | ShortCompile | ShortInstall
  deriving Eq

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

data BCond = BuildWith String | BuildWithout String

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

-- 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
    ifM (not . and <$> mapM doesFileExist rpms)
    (return True) $
    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
    let buildopt =
          case mforceshort of
            Just ShortCompile -> ["-bc", "--short-circuit"]
            Just ShortInstall -> ["-bi", "--short-circuit"]
            _ -> "-bb" : ["--noclean" | noclean]
        sourcediropt = ["--define", "_sourcedir " ++ cwd]
        args = sourcediropt ++ ["--define", "dist " ++ rpmDistTag dist] ++
               buildopt ++ map show bconds ++ [spec]
    date <- cmd "date" ["+%T"]
    rbr <- anyBranchToRelease br
    nvr <- pkgNameVerRel' rbr spec
    putStr $ date ++ " Building " ++ nvr ++ " locally... "
    ok <- do
      let buildlog = ".build-" ++ (showVerRel . nvrVerRel . readNVR) nvr <.> "log"
      whenM (doesFileExist buildlog) $
        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' $ 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 <- grep_ " %autorelease" spec
  dynbr <- grep_ "^%generate_buildrequires" spec
  brs <- mapMaybe primary <$>
    if dynbr
    then do
      installMissingMacros spec
      withTempDir $ \tmpdir -> do
        let srpmdiropt = ["--define", "_srcrpmdir" ++ tmpdir]
        out <- cmdIgnoreErr "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 -> cmdLines "rpm" ["-qp", "--requires", last ws]
    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 :: FilePath -> IO ()
checkSourcesMatch 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
    prompt_ $ color Red $ unwords missing ++ " not in sources, please fix"
    checkOnBranch
    checkSourcesMatch spec
  mgr <- httpManager
  let pkg = takeBaseName spec
  mapM_ (checkLookasideCache mgr pkg) sources
  where
    checkLookasideCache :: Manager -> String -> String -> IO ()
    checkLookasideCache mgr pkg source = do
      let (file,url) =
            case words source of
              ("SHA512":('(':fileparen):"=":[hash]) ->
                let file' = dropSuffix ")" fileparen
                in (file', "https://src.fedoraproject.org/lookaside/pkgs" +/+ pkg +/+ file +/+ "sha512" +/+ hash +/+ file)
              [hash,file'] ->
                (file', "https://src.fedoraproject.org/lookaside/pkgs" +/+ 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]