Merge pull request #311 from rhendric/rhendric/update-prs

Reuse an existing auto-update PR

src/GH.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# OPTIONS_GHC -fno-warn-type-defaults #-}
 
 module GH
@@ -15,10 +16,12 @@ module GH
     openAutoUpdatePR,
     openPullRequests,
     pr,
+    prUpdate,
   )
 where
 
 import Control.Applicative (some)
+import Data.Aeson (FromJSON)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import qualified Data.Vector as V
@@ -43,10 +46,10 @@ releaseUrl env url = do
   urlParts <- parseURL url
   gReleaseUrl (authFrom env) urlParts
 
-pr :: MonadIO m => UpdateEnv -> Text -> Text -> Text -> Text -> ExceptT Text m Text
+pr :: MonadIO m => UpdateEnv -> Text -> Text -> Text -> Text -> ExceptT Text m (Bool, Text)
 pr env title body prHead base = do
   ExceptT $
-    bimap (T.pack . show) (GH.getUrl . GH.pullRequestUrl)
+    bimap (T.pack . show) ((False, ) . GH.getUrl . GH.pullRequestUrl)
       <$> ( liftIO $
               ( GH.github
                   (authFrom env)
@@ -58,6 +61,33 @@ pr env title body prHead base = do
               )
           )
 
+prUpdate :: forall m. MonadIO m => UpdateEnv -> Text -> Text -> Text -> Text -> ExceptT Text m (Bool, Text)
+prUpdate env title body prHead base = do
+  let runRequest :: FromJSON a => GH.Request k a -> ExceptT Text m a
+      runRequest = ExceptT . fmap (first (T.pack . show)) . liftIO . GH.github (authFrom env)
+  let inNixpkgs f = f (N "nixos") (N "nixpkgs")
+
+  prs <- runRequest $
+    inNixpkgs GH.pullRequestsForR (GH.optionsHead prHead) GH.FetchAll
+
+  case V.toList prs of
+    [] -> pr env title body prHead base
+
+    (_:_:_) -> throwE $ "Too many open PRs from " <> prHead
+
+    [thePR] -> do
+      let withExistingPR :: (GH.Name GH.Owner -> GH.Name GH.Repo -> GH.IssueNumber -> a) -> a
+          withExistingPR f = inNixpkgs f (GH.simplePullRequestNumber thePR)
+
+      _ <- runRequest $
+        withExistingPR GH.updatePullRequestR $
+          GH.EditPullRequest (Just title) Nothing Nothing Nothing Nothing
+
+      _ <- runRequest $
+        withExistingPR GH.createCommentR body
+
+      return (True, GH.getUrl $ GH.simplePullRequestUrl thePR)
+
 data URLParts = URLParts
   { owner :: GH.Name GH.Owner,
     repo :: GH.Name GH.Repo,

src/Git.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 
 module Git
-  ( checkAutoUpdateBranchDoesntExist,
+  ( findAutoUpdateBranchMessage,
     mergeBase,
     cleanAndResetTo,
     cleanup,
@@ -187,14 +187,16 @@ mergeBase = do
     (procGit ["merge-base", "upstream/master", "upstream/staging"])
     & fmap T.strip
 
-checkAutoUpdateBranchDoesntExist :: MonadIO m => Text -> ExceptT Text m ()
-checkAutoUpdateBranchDoesntExist pName = do
+-- Return Nothing if a remote branch for this package doesn't exist. If a
+-- branch does exist, return a Just of its last commit message.
+findAutoUpdateBranchMessage :: MonadIO m => Text -> ExceptT Text m (Maybe Text)
+findAutoUpdateBranchMessage pName = do
   remoteBranches <-
-    readProcessInterleavedNoIndexIssue_ (procGit ["branch", "--remote"])
-      & fmapRT (T.lines >>> fmap T.strip)
-  when
-    (("origin/" <> branchPrefix <> pName) `elem` remoteBranches)
-    (throwE "Update branch already on origin.")
+    readProcessInterleavedNoIndexIssue_ (procGit ["branch", "--remote", "--format=%(refname:short) %(subject)"])
+      & fmapRT (T.lines >>> fmap (T.strip >>> T.breakOn " "))
+  return $
+    lookup ("origin/" <> branchPrefix <> pName) remoteBranches
+      & fmap (T.drop 1)
 
 inNixpkgsRepo :: IO Bool
 inNixpkgsRepo = do

src/Update.hs

@@ -23,8 +23,10 @@ import CVE (CVE, cveID, cveLI)
 import qualified Check
 import Control.Concurrent
 import Control.Exception (IOException, catch, bracket)
+import Control.Monad.Writer (execWriterT, tell)
 import qualified Data.ByteString.Lazy.Char8 as BSL
 import Data.Maybe (fromJust)
+import Data.Monoid (Alt(..))
 import qualified Data.Set as S
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
@@ -252,13 +254,22 @@ updateAttrPath log mergeBase updateEnv@UpdateEnv {..} attrPath = do
   successOrFailure <- runExceptT $ do
     hasUpdateScript <- Nix.hasUpdateScript attrPath
 
-    whenBatch updateEnv do
-      Skiplist.attrPath attrPath
-      when pr do
-        liftIO $ log "Checking auto update branch doesn't exist..."
-        Git.checkAutoUpdateBranchDoesntExist packageName
-        unless hasUpdateScript do
-          GH.checkExistingUpdatePR updateEnv attrPath
+    existingCommitMsg <- fmap getAlt . execWriterT $
+      whenBatch updateEnv do
+        Skiplist.attrPath attrPath
+        when pr do
+          liftIO $ log "Checking auto update branch..."
+          mbLastCommitMsg <- lift $ Git.findAutoUpdateBranchMessage packageName
+          tell $ Alt mbLastCommitMsg
+          unless hasUpdateScript do
+            case mbLastCommitMsg of
+              Nothing -> liftIO $ log "No auto update branch exists"
+              Just msg -> do
+                lift $ tryAssert
+                  "An auto update branch exists targeting the same version"
+                  (not $ U.titleTargetsSameVersion updateEnv msg)
+                liftIO $ log "An auto update branch exists but it is out of date"
+            lift $ GH.checkExistingUpdatePR updateEnv attrPath
 
     unless hasUpdateScript do
       Nix.assertNewerVersion updateEnv
@@ -354,6 +365,13 @@ updateAttrPath log mergeBase updateEnv@UpdateEnv {..} attrPath = do
     whenBatch updateEnv do
       when pr do
         when hasUpdateScript do
+          tryAssert
+            "An auto update branch exists targeting the same version"
+            (not $ any (U.titleTargetsSameVersion updateEnv) existingCommitMsg)
+
+          -- Note that this check looks for PRs with the same old and new
+          -- version numbers, so it won't stop us from updating an existing PR
+          -- if this run updates the package to a newer version.
           GH.checkExistingUpdatePR updateEnv' attrPath
 
     Nix.build attrPath
@@ -371,7 +389,7 @@ updateAttrPath log mergeBase updateEnv@UpdateEnv {..} attrPath = do
             if Outpaths.numPackageRebuilds opDiff <= 500
             then "master"
             else "staging"
-    publishPackage log updateEnv' oldSrcUrl newSrcUrl attrPath result opReport prBase rewriteMsgs
+    publishPackage log updateEnv' oldSrcUrl newSrcUrl attrPath result opReport prBase rewriteMsgs (isJust existingCommitMsg)
 
   case successOrFailure of
     Left failure -> do
@@ -389,8 +407,9 @@ publishPackage ::
   Text ->
   Text ->
   [Text] ->
+  Bool ->
   ExceptT Text IO ()
-publishPackage log updateEnv oldSrcUrl newSrcUrl attrPath result opReport prBase rewriteMsgs = do
+publishPackage log updateEnv oldSrcUrl newSrcUrl attrPath result opReport prBase rewriteMsgs branchExists = do
   cachixTestInstructions <- doCachix log updateEnv result
   resultCheckReport <-
     case Skiplist.checkResult (packageName updateEnv) of
@@ -411,6 +430,7 @@ publishPackage log updateEnv oldSrcUrl newSrcUrl attrPath result opReport prBase
       then liftIO $ NixpkgsReview.runReport log commitRev
       else return ""
   -- Try to push it three times
+  -- (these pushes use --force, so it doesn't matter if branchExists is True)
   when
     (doPR . options $ updateEnv)
     (Git.push updateEnv <|> Git.push updateEnv <|> Git.push updateEnv)
@@ -441,7 +461,12 @@ publishPackage log updateEnv oldSrcUrl newSrcUrl attrPath result opReport prBase
   if (doPR . options $ updateEnv)
     then do
       let ghUser = GH.untagName . githubUser . options $ updateEnv
-      pullRequestUrl <- GH.pr updateEnv (prTitle updateEnv attrPath) prMsg (ghUser <> ":" <> (branchName updateEnv)) prBase
+      let mkPR = if branchExists then GH.prUpdate else GH.pr
+      (reusedPR, pullRequestUrl) <- mkPR updateEnv (prTitle updateEnv attrPath) prMsg (ghUser <> ":" <> (branchName updateEnv)) prBase
+      when branchExists $ liftIO $ log
+        if reusedPR
+        then "Updated existing PR"
+        else "Reused existing auto update branch, but no corresponding open PR was found, so created a new PR"
       liftIO $ log pullRequestUrl
     else liftIO $ T.putStrLn prMsg
 

src/Utils.hs

@@ -24,6 +24,7 @@ module Utils
     runLog,
     srcOrMain,
     stripQuotes,
+    titleTargetsSameVersion,
     tRead,
     whenBatch,
     regDirMode,
@@ -136,6 +137,11 @@ prTitle updateEnv attrPath =
       nV = newVersion updateEnv
    in T.strip [interpolate| $attrPath: $oV -> $nV |]
 
+titleTargetsSameVersion :: UpdateEnv -> Text -> Bool
+titleTargetsSameVersion updateEnv = T.isSuffixOf [interpolate| -> $nV |]
+  where
+    nV = newVersion updateEnv
+
 regDirMode :: FileMode
 regDirMode =
   directoryMode .|. ownerModes .|. groupModes .|. otherReadMode