Switch to queued processing for updating merge requests

src/Effects.hs

@@ -27,6 +27,7 @@ module Effects
     -- * MergeRequest
     getOpenMergeRequests,
     getOpenMergeRequestsForGroup,
+    getOpenMergeRequestsForGroupQueued,
     enableSourceBranchDeletionAfterMrMerge,
     setSuccessfulPipelineRequirementForMerge,
     unsetSuccessfulPipelineRequirementForMerge,
@@ -188,6 +189,20 @@ getOpenMergeRequests project maybeAuthorIs recheckMergeStatus = do
       let template = [uriTemplate|/api/v4/projects/{projectId}/merge_requests?state=opened&author_id={authorId}&with_merge_status_recheck={recheckMergeStatus}|]
       fetchDataPaginated template [("projectId", (stringValue . show) project), ("authorId", (stringValue . show) i), ("recheckMergeStatus", recheckMergeStatusToBooleanValue recheckMergeStatus)]
 
+getOpenMergeRequestsForGroupQueued :: Maybe AuthorIs -> Maybe SearchTerm -> MergeStatusRecheck -> (MergeRequest -> App (Either UpdateError (ProcessResult a))) -> App (Either UpdateError [a])
+getOpenMergeRequestsForGroupQueued maybeAuthorIs maybeSearchTerm recheckMergeStatus action = do
+  grp <- asks groupId
+  let template = [uriTemplate|/api/v4/groups/{groupId}/merge_requests?state=opened{&author_id,search,with_merge_status_recheck}|]
+      vars =
+        mconcat
+          [ [("groupId", (stringValue . show) grp)],
+            foldMap (\(AuthorIs i) -> [("author_id", (stringValue . show) i)]) maybeAuthorIs,
+            foldMap (\(SearchTerm s) -> [("search", stringValue s)]) maybeSearchTerm,
+            [("with_merge_status_recheck", recheckMergeStatusToBooleanValue recheckMergeStatus)]
+          ]
+      queueConfig = QueueConfig {parallelism = 10, bufferSize = 250} -- todo: make these configurable
+  fetchDataQueued template vars queueConfig action
+
 getOpenMergeRequestsForGroup :: Maybe AuthorIs -> Maybe SearchTerm -> MergeStatusRecheck -> App (Either UpdateError [MergeRequest])
 getOpenMergeRequestsForGroup maybeAuthorIs maybeSearchTerm recheckMergeStatus = do
   grp <- asks groupId

src/Projects.hs

@@ -140,7 +140,7 @@ enableSuccessfulPipelineForMergeRequirement execution =
 
 projectHasCi :: Either UpdateError Project -> App (Either UpdateError Bool)
 projectHasCi (Left err) = pure $ Left err
-projectHasCi (Right (Project pId _ _ (Just ref) _ _ _ _ _ _ _ _ _ _)) = hasCi pId ref
+projectHasCi (Right (Project pId _ _ (Just ref) _ _ _ _ _ _ _ _ _ _ _)) = hasCi pId ref
 projectHasCi (Right _) = pure $ Right False -- no default branch, no CI
 
 configureOption :: Execution -> Id Project -> Either UpdateError Bool -> App (Either UpdateError ())

src/UpdateMergeRequests.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 
 module UpdateMergeRequests
   ( updateMergeRequests,
@@ -10,6 +10,7 @@ import App (App)
 import Config.Types
 import Data.Text (isInfixOf, strip, stripPrefix, toLower)
 import Effects
+import Gitlab.Client.Queue.MTL (ProcessResult (..), UpdateError)
 import Gitlab.Lib (Id)
 import Gitlab.MergeRequest
 import Gitlab.Project (Project)
@@ -27,57 +28,66 @@ updateMergeRequests _ (Merge _) _ Nothing _ Execute =
   write "I don't think you want to blindly merge all merge requests for this group. Consider adding a filter. Exiting now."
 updateMergeRequests projectExcludes action authorIs maybeSearchTerms recheckMergeStatus execute = do
   let searchTerm' = either id (\(SearchTermTitle s) -> SearchTerm s) <$> maybeSearchTerms
-  getOpenMergeRequestsForGroup authorIs searchTerm' recheckMergeStatus >>= \case
-    Left err -> write $ show err
-    Right [] -> write "no MRs to process"
-    Right allMergeRequests -> do
-      let titleFilter mr = case maybeSearchTerms of
-            Just (Right (SearchTermTitle s)) -> toLower (toText s) `isInfixOf` toLower (mergeRequestTitle mr)
-            _ -> True
-          filteredMergeRequests = filter (\mr -> titleFilter mr && mergeRequestProjectId mr `notElem` projectExcludes) allMergeRequests
-      case filteredMergeRequests of
-        [] -> write "no MRs to process after applying filters"
-        mergeRequests -> forM_ mergeRequests $ \mr -> do
-          write $ "processing MR #" <> show (mergeRequestIid mr) <> " in Project #" <> show (mergeRequestProjectId mr) <> " with state " <> show (mergeRequestDetailedMergeStatus mr) <> ": " <> mergeRequestTitle mr
-          res <- performAction mr
-          case res of
-            Left err -> write $ "failed to update merge request: " <> show err
-            Right _ -> pure ()
+  res <- getOpenMergeRequestsForGroupQueued authorIs searchTerm' recheckMergeStatus $ \mr -> do
+    if titleFilter mr && excludeFilter mr
+      then do
+        (txt, res) <- performAction mr
+        pure $ PrintLinesWithResult (mconcat (mrTextLine mr <> maybe [] (\t -> [" >> ", t]) txt) :| []) () <$ res
+      else pure $ Right Empty
+  case res of
+    Left err -> write $ "failed to update merge requests: " <> show err
+    Right [] -> write "no merge requests to process"
+    Right updates -> write $ show (length updates) <> " merge requests"
   where
+    mrTextLine mr =
+      [ "#",
+        show (mergeRequestIid mr),
+        " in Project #",
+        show (mergeRequestProjectId mr),
+        " with state ",
+        show (mergeRequestDetailedMergeStatus mr),
+        ": ",
+        mergeRequestTitle mr
+      ]
+    titleFilter mr = case maybeSearchTerms of
+      Just (Right (SearchTermTitle s)) -> toLower (toText s) `isInfixOf` toLower (mergeRequestTitle mr)
+      _ -> True
+    excludeFilter mr = mergeRequestProjectId mr `notElem` projectExcludes
+    performAction :: MergeRequest -> App (Maybe Text, Either UpdateError ())
     performAction mr =
       let pId = mergeRequestProjectId mr
        in case action of
-            List -> pure $ Right ()
+            List -> pure (Nothing, Right ())
             Rebase -> rebaseAction pId (mergeRequestIid mr)
             (Merge mergeCiOption) -> case detailedMergeStatusToDecision (mergeRequestDetailedMergeStatus mr) of
               MergeShouldWork -> mergeAction pId (mergeRequestIid mr) mergeCiOption
               MergeMayWork -> mergeAttemptAction pId (mergeRequestIid mr) mergeCiOption
               MergeWontWork -> mergeWontWorkAction (mergeRequestDetailedMergeStatus mr)
             SetToDraft ->
               if mergeRequestWip mr
-                then Right () <$ write "merge request is already in state \"Draft\""
+                then pure (Just "merge request is already in state \"Draft\"", Right ())
                 else setToDraftAction pId (mergeRequestIid mr) (mergeRequestTitle mr)
             MarkAsReady ->
               if mergeRequestWip mr
                 then markAsReadyAction pId (mergeRequestIid mr) (mergeRequestTitle mr)
-                else Right () <$ write "merge request is already marked as ready"
+                else pure (Just "merge request is already marked as ready", Right ())
 
     (rebaseAction, mergeAction, mergeAttemptAction, mergeWontWorkAction, setToDraftAction, markAsReadyAction) = case execute of
       Execute ->
-        ( rebaseMergeRequest,
-          mergeMergeRequest,
-          mergeMergeRequest,
-          \detailedStatus -> Right () <$ write ("The merge status is " <> show detailedStatus <> ", skipping the merge as it wouldn't succeed"),
-          \pId mrIid mrTitle -> setMergeRequestTitle pId mrIid ("Draft: " <> mrTitle),
-          \pId mrIid mrTitle -> setMergeRequestTitle pId mrIid (strip $ fromMaybe mrTitle (stripPrefix "Draft:" mrTitle))
+        ( \pId mId -> (Nothing,) <$> rebaseMergeRequest pId mId,
+          \pId mId mco -> (Nothing,) <$> mergeMergeRequest pId mId mco,
+          \pId mId mco -> (Nothing,) <$> mergeMergeRequest pId mId mco,
+          \detailedStatus -> pure (Just $ "The merge status is " <> show detailedStatus <> ", skipping the merge as it wouldn't succeed", Right ()),
+          \pId mrIid mrTitle -> (Nothing,) <$> setMergeRequestTitle pId mrIid ("Draft: " <> mrTitle),
+          \pId mrIid mrTitle -> (Nothing,) <$> setMergeRequestTitle pId mrIid (strip $ fromMaybe mrTitle (stripPrefix "Draft:" mrTitle))
         )
       DryRun ->
-        ( \_ _ -> Right () <$ write "dry run. skipping rebase",
-          \_ _ _ -> Right () <$ write "dry run. skipping merge",
-          \_ _ _ -> Right () <$ write "dry run. skipping merge attempt",
-          \detailedStatus -> Right () <$ write ("The merge status is " <> show detailedStatus <> ", skipping the merge as it wouldn't succeed"),
-          \_ _ _ -> Right () <$ write "dry run. skipping draft toggle",
-          \_ _ _ -> Right () <$ write "dry run. skipping draft toggle"
+        ( \_ _ -> pure (Just "dry run. skipping rebase", Right ()),
+          \_ _ _ -> pure (Just "dry run. skipping merge", Right ()),
+          \_ _ _ -> pure (Just "dry run. skipping merge attempt", Right ()),
+          \detailedStatus -> pure (Just $ "The merge status is " <> show detailedStatus <> ", skipping the merge as it wouldn't succeed", Right ()),
+          \_ _ _ -> pure (Just "dry run. skipping draft toggle", Right ()),
+          \_ _ _ -> pure (Just "dry run. skipping draft toggle", Right ())
         )
 
 -- | Depending on the merge status of a merge request, trying a merge may or may not make sense.

stack.yaml

@@ -5,7 +5,7 @@ packages:
 
 extra-deps:
   - github: L7R7/gitlab-api
-    commit: e3bd8278e19154adcf17ecad293d8ef07c1f006b
+    commit: 5cefe4d85180c31f927014bcc1b9b4f0b106d4a4
     subdirs:
       - gitlab-api-http-client
       - gitlab-api-http-client-mtl

stack.yaml.lock

@@ -9,66 +9,66 @@ packages:
     pantry-tree:
       sha256: ba41d94e0da3f64b9883530667de2d8772e685776f7a9b56a08eecb3e1732c1c
       size: 323
-    sha256: bf8390d23847c81b0d42e62daa81ca46aa513e87d307dcc1ba61e43866981760
-    size: 23140
+    sha256: 3a17d37c9b47a890bf1442542380b19ca258de80114a5acacab7bc6d463e1fa5
+    size: 23468
     subdir: gitlab-api-http-client
-    url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
+    url: https://github.com/L7R7/gitlab-api/archive/5cefe4d85180c31f927014bcc1b9b4f0b106d4a4.tar.gz
     version: 0.0.0.1
   original:
     subdir: gitlab-api-http-client
-    url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
+    url: https://github.com/L7R7/gitlab-api/archive/5cefe4d85180c31f927014bcc1b9b4f0b106d4a4.tar.gz
 - completed:
     name: gitlab-api-http-client-mtl
     pantry-tree:
       sha256: aaa8533e8c0d775331eb6adf4be515ad6ce5085ae952ecf4cc4788f3e2432653
       size: 195
-    sha256: bf8390d23847c81b0d42e62daa81ca46aa513e87d307dcc1ba61e43866981760
-    size: 23140
+    sha256: 3a17d37c9b47a890bf1442542380b19ca258de80114a5acacab7bc6d463e1fa5
+    size: 23468
     subdir: gitlab-api-http-client-mtl
-    url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
+    url: https://github.com/L7R7/gitlab-api/archive/5cefe4d85180c31f927014bcc1b9b4f0b106d4a4.tar.gz
     version: 0.0.0.1
   original:
     subdir: gitlab-api-http-client-mtl
-    url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
+    url: https://github.com/L7R7/gitlab-api/archive/5cefe4d85180c31f927014bcc1b9b4f0b106d4a4.tar.gz
 - completed:
     name: gitlab-api-http-client-queued
     pantry-tree:
-      sha256: 595d620bd2c0c8b9b4b744e612687e5cf1cfae87cb4aab9193a7e7de6f63185b
+      sha256: ed326dfdfc0116ce4e56cdafed2d39eab4d28537b498486bbddac62e2dd17acb
       size: 200
-    sha256: bf8390d23847c81b0d42e62daa81ca46aa513e87d307dcc1ba61e43866981760
-    size: 23140
+    sha256: 3a17d37c9b47a890bf1442542380b19ca258de80114a5acacab7bc6d463e1fa5
+    size: 23468
     subdir: gitlab-api-http-client-queued
-    url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
+    url: https://github.com/L7R7/gitlab-api/archive/5cefe4d85180c31f927014bcc1b9b4f0b106d4a4.tar.gz
     version: 0.0.0.1
   original:
     subdir: gitlab-api-http-client-queued
-    url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
+    url: https://github.com/L7R7/gitlab-api/archive/5cefe4d85180c31f927014bcc1b9b4f0b106d4a4.tar.gz
 - completed:
     name: gitlab-api-http-client-queued-mtl
     pantry-tree:
       sha256: fe10096fc6ae5458d6871a15171ee249526883bfbc309589e5cec5da86dde036
       size: 207
-    sha256: bf8390d23847c81b0d42e62daa81ca46aa513e87d307dcc1ba61e43866981760
-    size: 23140
+    sha256: 3a17d37c9b47a890bf1442542380b19ca258de80114a5acacab7bc6d463e1fa5
+    size: 23468
     subdir: gitlab-api-http-client-queued-mtl
-    url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
+    url: https://github.com/L7R7/gitlab-api/archive/5cefe4d85180c31f927014bcc1b9b4f0b106d4a4.tar.gz
     version: 0.0.0.1
   original:
     subdir: gitlab-api-http-client-queued-mtl
-    url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
+    url: https://github.com/L7R7/gitlab-api/archive/5cefe4d85180c31f927014bcc1b9b4f0b106d4a4.tar.gz
 - completed:
     name: gitlab-api-types
     pantry-tree:
-      sha256: 6cf943f17c29a9e25f786446d2d1192d469a1a7208114c40b0db39dcadc77448
+      sha256: da72f92455a70bbd0e5248352dd61adf81b5525435ec2ad00e36be24c3a53236
       size: 725
-    sha256: bf8390d23847c81b0d42e62daa81ca46aa513e87d307dcc1ba61e43866981760
-    size: 23140
+    sha256: 3a17d37c9b47a890bf1442542380b19ca258de80114a5acacab7bc6d463e1fa5
+    size: 23468
     subdir: gitlab-api-types
-    url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
+    url: https://github.com/L7R7/gitlab-api/archive/5cefe4d85180c31f927014bcc1b9b4f0b106d4a4.tar.gz
     version: 0.0.0.1
   original:
     subdir: gitlab-api-types
-    url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
+    url: https://github.com/L7R7/gitlab-api/archive/5cefe4d85180c31f927014bcc1b9b4f0b106d4a4.tar.gz
 snapshots:
 - completed:
     sha256: 098936027eaa1ef14e2b8eb39d9933a973894bb70a68684a1bbf00730249879b