From 6e26ae11499c0ec64af6a25bba72f9ef9009d302 Mon Sep 17 00:00:00 2001 From: Leonhard Riedisser Date: Fri, 18 Oct 2024 15:12:02 +0200 Subject: [PATCH 1/2] Switch to queued processing for project-based use cases --- gitlab-helper.cabal | 3 +++ package.yaml | 3 +++ src/App.hs | 8 ++++++- src/Branches.hs | 55 +++++++++++++++++++++++---------------------- src/Effects.hs | 12 ++++++++++ src/Projects.hs | 42 +++++++++++++++++----------------- src/Schedules.hs | 11 +++++---- stack.yaml | 4 +++- stack.yaml.lock | 50 +++++++++++++++++++++++++++++++---------- 9 files changed, 119 insertions(+), 69 deletions(-) diff --git a/gitlab-helper.cabal b/gitlab-helper.cabal index 390d642..a1ee139 100644 --- a/gitlab-helper.cabal +++ b/gitlab-helper.cabal @@ -57,8 +57,10 @@ library , directory , either , envparse + , exceptions , githash , gitlab-api-http-client-mtl + , gitlab-api-http-client-queued-mtl , gitlab-api-types , http-conduit , http-types @@ -69,6 +71,7 @@ library , split , text , time + , unliftio-core , yaml default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 68fd85a..8bbe0ad 100644 --- a/package.yaml +++ b/package.yaml @@ -52,10 +52,12 @@ library: - directory - either - envparse + - exceptions - githash - http-conduit - http-types - gitlab-api-http-client-mtl + - gitlab-api-http-client-queued-mtl - gitlab-api-types - network-uri - optparse-applicative @@ -63,6 +65,7 @@ library: - split - text - time + - unliftio-core - yaml executables: diff --git a/src/App.hs b/src/App.hs index f2e4297..7f93b37 100644 --- a/src/App.hs +++ b/src/App.hs @@ -6,6 +6,8 @@ module App (App (..)) where import Config.Types +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) +import Control.Monad.IO.Unlift (MonadUnliftIO) import Gitlab.Client.MTL (HasApiToken (..), HasBaseUrl (..)) import Relude @@ -15,7 +17,11 @@ newtype App a = App {unApp :: ReaderT Config IO a} Applicative, Monad, MonadIO, - MonadReader Config + MonadReader Config, + MonadThrow, + MonadCatch, + MonadMask, + MonadUnliftIO ) instance HasApiToken App where diff --git a/src/Branches.hs b/src/Branches.hs index 4531316..e9fb620 100644 --- a/src/Branches.hs +++ b/src/Branches.hs @@ -8,7 +8,6 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} module Branches ( showBranchesForGroup, @@ -22,7 +21,7 @@ import qualified Data.Text as T (intercalate) import Data.Time hiding (getCurrentTime) import Effects import Gitlab.Branch -import Gitlab.Client.MTL (UpdateError) +import Gitlab.Client.Queue.MTL import Gitlab.Project import Relude @@ -36,28 +35,31 @@ showBranchesForGroup = do write " ✔ - the branch is merged" write " ✗ - the branch is stale (older than 90 days)" write " ⚬ - the branch is protected" - getProjectsForGroup SkipArchivedProjects >>= \case + results <- processProjectsForGroupQueued SkipArchivedProjects (fmap Right . processProject) + case results of Left err -> write $ show err - Right projects -> do - results <- traverse (getBranchesForProject >=> printResult) projects - writeSummary results - -getBranchesForProject :: Project -> App (Project, Either UpdateError [Branch]) -getBranchesForProject p = (p,) <$> getBranches (projectId p) - -printResult :: (Project, Either UpdateError [Branch]) -> App (Project, Either UpdateError [Branch]) -printResult input@(project, Left err) = do - write $ "=== " <> show (projectName project) - write $ "something went wrong: " <> show err - pure input -printResult input@(project, Right branches) = do + Right res -> do + writeSummary res + +processProject :: Project -> App (ProcessResult (Project, [Branch])) +processProject project = do + getBranches (projectId project) >>= \case + Left err -> pure $ PrintLines $ "=== " <> show (projectName project) :| ["something went wrong: " <> show err] + Right branches -> do + maybeTxts <- printResult (project, branches) + pure + $ case maybeTxts of + Nothing -> Result (project, branches) + Just txts -> PrintLinesWithResult txts (project, branches) + +printResult :: (Project, [Branch]) -> App (Maybe (NonEmpty Text)) +printResult (project, branches) = do let branchesWithoutDefaultBranch = sortOn (commitCommittedDate . branchCommit) $ filter (not . branchDefault) branches - unless (null branchesWithoutDefaultBranch) $ do - write "" - write $ formatWith [bold] ("=== " <> show (projectName project)) - now <- getCurrentTime - traverse_ (\b -> write $ " " <> prettyPrintBranch now b) branchesWithoutDefaultBranch - pure input + now <- getCurrentTime + pure + $ if null branchesWithoutDefaultBranch + then Nothing + else Just $ "" :| (formatWith [bold] ("=== " <> show (projectName project)) : ((\b -> " " <> prettyPrintBranch now b) <$> branchesWithoutDefaultBranch)) prettyPrintBranch :: UTCTime -> Branch -> Text prettyPrintBranch now Branch {..} = @@ -94,13 +96,13 @@ type MergedBranchesCount = Sum Int type Summary = (ProjectCount, BranchesCount, StaleBranchesCount, MergedBranchesCount) -writeSummary :: [(Project, Either UpdateError [Branch])] -> App () +writeSummary :: [(Project, [Branch])] -> App () writeSummary results = do now <- getCurrentTime write "" write . showSummary $ summary now results -summary :: UTCTime -> [(Project, Either UpdateError [Branch])] -> Summary +summary :: UTCTime -> [(Project, [Branch])] -> Summary summary now = foldMap (count now) showSummary :: Summary -> Text @@ -121,9 +123,8 @@ showSummary (projects, branches, stale, merged) = isAre (Sum 1) = "is" isAre _ = "are" -count :: UTCTime -> (Project, Either UpdateError [Branch]) -> Summary -count _ (_, Left _) = mempty -count now (_, Right branches) = (hasBranches, notDefaultCount, stale, merged) +count :: UTCTime -> (Project, [Branch]) -> Summary +count now (_, branches) = (hasBranches, notDefaultCount, stale, merged) where notDefault = filter (not . branchDefault) branches hasBranches = Sum $ if notDefaultCount /= 0 then 1 else 0 diff --git a/src/Effects.hs b/src/Effects.hs index ead107a..f0082d9 100644 --- a/src/Effects.hs +++ b/src/Effects.hs @@ -20,6 +20,7 @@ module Effects getProjectsForGroup, getProjectsForUser, getProject, + processProjectsForGroupQueued, hasCi, setMergeMethod, @@ -66,6 +67,7 @@ import Data.Time (UTCTime) import qualified Data.Time import Gitlab.Branch import Gitlab.Client.MTL +import Gitlab.Client.Queue.MTL import Gitlab.Group hiding (groupId) import Gitlab.Lib (Id (..), Ref (..)) import Gitlab.MergeRequest @@ -137,6 +139,16 @@ getAllUsers = fetchDataPaginated @User @App [uriTemplate|/api/v4/users|] [] getAllGroups :: App (Either UpdateError [Group]) getAllGroups = fetchDataPaginated [uriTemplate|/api/v4/groups?all_available=true|] [] +processProjectsForGroupQueued :: WithArchivedProjects -> (Project -> App (Either UpdateError (ProcessResult a))) -> App (Either UpdateError [a]) +processProjectsForGroupQueued withArchivedProjects action = do + gId <- asks groupId + let template = case withArchivedProjects of + SkipArchivedProjects -> [uriTemplate|/api/v4/groups/{groupId}/projects?include_subgroups=true&archived=false&with_shared=false|] + IncludeArchivedProjects -> [uriTemplate|/api/v4/groups/{groupId}/projects?include_subgroups=true&with_shared=false|] + vars = [("groupId", (stringValue . show) gId)] + queueConfig = QueueConfig {parallelism = 10, bufferSize = 250} -- todo: make these configurable + fetchDataQueued template vars queueConfig action + getProjectsForGroup :: WithArchivedProjects -> App (Either UpdateError [Project]) getProjectsForGroup withArchivedProjects = do gId <- asks groupId diff --git a/src/Projects.hs b/src/Projects.hs index fc43eea..9e05638 100644 --- a/src/Projects.hs +++ b/src/Projects.hs @@ -26,7 +26,7 @@ import Data.Aeson (encode) import qualified Data.Map as M import Data.Text (toLower) import Effects -import Gitlab.Client.MTL (UpdateError) +import Gitlab.Client.Queue.MTL import Gitlab.Group (Group) import Gitlab.Lib (EnabledDisabled (..), Id (..), Name (..), Ref (..)) import Gitlab.Project @@ -191,13 +191,13 @@ runProcessor (OptionSetter withArchivedProjects title skipIf action) = do gId <- asks groupId write "==================================================" write $ title gId - getProjectsForGroup withArchivedProjects >>= \case + res <- processProjectsForGroupQueued withArchivedProjects (fmap Right . process skipIf action) + case res of Left err -> write $ show err - Right projects -> do - res <- traverse (process skipIf action) projects + Right res' -> do write "" write "done: " - let summary = foldl' (\m r -> M.insertWith (<>) r (Sum (1 :: Int)) m) (M.fromList $ (,mempty) <$> universe) res + let summary = foldl' (\m r -> M.insertWith (<>) r (Sum (1 :: Int)) m) (M.fromList $ (,mempty) <$> universe) res' let summaryPrint = M.foldlWithKey' (\acc k (Sum c) -> (show k <> ": " <> show c) : acc) mempty summary traverse_ write summaryPrint runProcessor (Counter withArchivedProjects title skipIf action) = do @@ -205,37 +205,35 @@ runProcessor (Counter withArchivedProjects title skipIf action) = do write "==================================================" write $ title gId write "" - getProjectsForGroup withArchivedProjects >>= \case + res <- processProjectsForGroupQueued withArchivedProjects (fmap Right . countSingle skipIf action) + case res of Left err -> write $ show err - Right projects -> do - res <- traverse (countSingle skipIf action) projects + Right res' -> do write "" - write $ "done. Total: " <> show (getSum $ fold res) <> " deployments" + write $ "done. Total: " <> show (getSum $ fold res') <> " deployments" -process :: (Project -> Bool) -> (Id Project -> App (Either UpdateError ())) -> Project -> App Result +process :: (Project -> Bool) -> (Id Project -> App (Either UpdateError ())) -> Project -> App (ProcessResult Result) process skipIf action project = do - write "" - write $ formatWith [bold] ("=== " <> show (projectName project)) + let headings = "" :| [formatWith [bold] ("=== " <> show (projectName project))] if skipIf project - then write "option is already enabled. Not doing anything" $> AlreadySet + then pure $ PrintLinesWithResult (headings <> ("option is already enabled. Not doing anything" :| [])) AlreadySet else do - write "setting option" res <- action (projectId project) - case res of - Left err -> write ("something went wrong. " <> show err) $> Error - Right _ -> write "done" $> Set + pure $ case res of + Left err -> PrintLinesWithResult ("something went wrong. " <> show err :| []) Error + Right _ -> PrintLinesWithResult ("option set" :| []) Set -countSingle :: (Project -> Bool) -> (Project -> App (Either UpdateError (Sum Int))) -> Project -> App (Sum Int) -countSingle skipIf action project = count >>= \(output, result) -> write (title <> output) $> result +countSingle :: (Project -> Bool) -> (Project -> App (Either UpdateError (Sum Int))) -> Project -> App (ProcessResult (Sum Int)) +countSingle skipIf action project = (\(output, result) -> PrintLinesWithResult (title <> output :| []) result) <$> count where count = if skipIf project then pure ("skipped", mempty) else do res <- action project - case res of - Left err -> pure (formatWith [red] "something went wrong: " <> show err, mempty) - Right s -> pure (show (getSum s) <> " deployments", s) + pure $ case res of + Left err -> (formatWith [red] "something went wrong: " <> show err, mempty) + Right s -> (show (getSum s) <> " deployments", s) title = formatWith [bold] (show (projectName project) <> " (#" <> show (projectId project) <> "): ") data Result = AlreadySet | Set | Error deriving stock (Bounded, Enum, Eq, Ord, Show) diff --git a/src/Schedules.hs b/src/Schedules.hs index 3f73e33..6ddfcc5 100644 --- a/src/Schedules.hs +++ b/src/Schedules.hs @@ -19,7 +19,7 @@ import App (App) import Colourista.Pure import Config.Types (Config (..), WithArchivedProjects (SkipArchivedProjects)) import Effects -import Gitlab.Client.MTL (UpdateError) +import Gitlab.Client.Queue.MTL import Gitlab.Lib (Name (..)) import Gitlab.Project import Relude @@ -29,12 +29,11 @@ showSchedulesForGroup = do gId <- asks groupId write "==================================================" write $ "Listing the projects' schedules for Group " <> show gId - getProjectsForGroup SkipArchivedProjects >>= \case + processProjectsForGroupQueued SkipArchivedProjects (fmap (Right . Result) . getSchedulesForProject) >>= \case Left err -> write $ show err - Right projects -> do - results <- traverse getSchedulesForProject (sortOn (getName . projectName) projects) - traverse_ printResults results - writeSummary results + Right res -> do + traverse_ printResults (sortOn (getName . projectName . fst) res) + writeSummary res getSchedulesForProject :: Project -> App (Project, Either UpdateError [Schedule]) getSchedulesForProject p = (p,) <$> getSchedules (projectId p) diff --git a/stack.yaml b/stack.yaml index a2f215a..b199cf4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,10 +5,12 @@ packages: extra-deps: - github: L7R7/gitlab-api - commit: abff91cfa00788d28f57847aa7b28ad1d4f4a963 + commit: e3bd8278e19154adcf17ecad293d8ef07c1f006b subdirs: - gitlab-api-http-client - gitlab-api-http-client-mtl + - gitlab-api-http-client-queued + - gitlab-api-http-client-queued-mtl - gitlab-api-types system-ghc: true diff --git a/stack.yaml.lock b/stack.yaml.lock index 25b317e..dd5c7d5 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -9,40 +9,66 @@ packages: pantry-tree: sha256: ba41d94e0da3f64b9883530667de2d8772e685776f7a9b56a08eecb3e1732c1c size: 323 - sha256: b791d986aa0517284331d591d03ffdca7be5ad9ad16d8d1870501438d1ff7c05 - size: 23056 + sha256: bf8390d23847c81b0d42e62daa81ca46aa513e87d307dcc1ba61e43866981760 + size: 23140 subdir: gitlab-api-http-client - url: https://github.com/L7R7/gitlab-api/archive/abff91cfa00788d28f57847aa7b28ad1d4f4a963.tar.gz + url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz version: 0.0.0.1 original: subdir: gitlab-api-http-client - url: https://github.com/L7R7/gitlab-api/archive/abff91cfa00788d28f57847aa7b28ad1d4f4a963.tar.gz + url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz - completed: name: gitlab-api-http-client-mtl pantry-tree: sha256: aaa8533e8c0d775331eb6adf4be515ad6ce5085ae952ecf4cc4788f3e2432653 size: 195 - sha256: b791d986aa0517284331d591d03ffdca7be5ad9ad16d8d1870501438d1ff7c05 - size: 23056 + sha256: bf8390d23847c81b0d42e62daa81ca46aa513e87d307dcc1ba61e43866981760 + size: 23140 subdir: gitlab-api-http-client-mtl - url: https://github.com/L7R7/gitlab-api/archive/abff91cfa00788d28f57847aa7b28ad1d4f4a963.tar.gz + url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz version: 0.0.0.1 original: subdir: gitlab-api-http-client-mtl - url: https://github.com/L7R7/gitlab-api/archive/abff91cfa00788d28f57847aa7b28ad1d4f4a963.tar.gz + url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz +- completed: + name: gitlab-api-http-client-queued + pantry-tree: + sha256: 595d620bd2c0c8b9b4b744e612687e5cf1cfae87cb4aab9193a7e7de6f63185b + size: 200 + sha256: bf8390d23847c81b0d42e62daa81ca46aa513e87d307dcc1ba61e43866981760 + size: 23140 + subdir: gitlab-api-http-client-queued + url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.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 +- completed: + name: gitlab-api-http-client-queued-mtl + pantry-tree: + sha256: fe10096fc6ae5458d6871a15171ee249526883bfbc309589e5cec5da86dde036 + size: 207 + sha256: bf8390d23847c81b0d42e62daa81ca46aa513e87d307dcc1ba61e43866981760 + size: 23140 + subdir: gitlab-api-http-client-queued-mtl + url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.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 - completed: name: gitlab-api-types pantry-tree: sha256: 6cf943f17c29a9e25f786446d2d1192d469a1a7208114c40b0db39dcadc77448 size: 725 - sha256: b791d986aa0517284331d591d03ffdca7be5ad9ad16d8d1870501438d1ff7c05 - size: 23056 + sha256: bf8390d23847c81b0d42e62daa81ca46aa513e87d307dcc1ba61e43866981760 + size: 23140 subdir: gitlab-api-types - url: https://github.com/L7R7/gitlab-api/archive/abff91cfa00788d28f57847aa7b28ad1d4f4a963.tar.gz + url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz version: 0.0.0.1 original: subdir: gitlab-api-types - url: https://github.com/L7R7/gitlab-api/archive/abff91cfa00788d28f57847aa7b28ad1d4f4a963.tar.gz + url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz snapshots: - completed: sha256: 098936027eaa1ef14e2b8eb39d9933a973894bb70a68684a1bbf00730249879b From b7656ef0cef9a9eb7ba398ae858b0e09cac2fb26 Mon Sep 17 00:00:00 2001 From: Leonhard Riedisser Date: Fri, 18 Oct 2024 15:19:08 +0200 Subject: [PATCH 2/2] Switch to queued processing for updating merge requests --- src/Effects.hs | 15 ++++++++ src/Projects.hs | 2 +- src/UpdateMergeRequests.hs | 74 +++++++++++++++++++++----------------- stack.yaml | 2 +- stack.yaml.lock | 44 +++++++++++------------ 5 files changed, 81 insertions(+), 56 deletions(-) diff --git a/src/Effects.hs b/src/Effects.hs index f0082d9..41c25db 100644 --- a/src/Effects.hs +++ b/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 diff --git a/src/Projects.hs b/src/Projects.hs index 9e05638..aa9d594 100644 --- a/src/Projects.hs +++ b/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 ()) diff --git a/src/UpdateMergeRequests.hs b/src/UpdateMergeRequests.hs index 4780e72..3ca40c2 100644 --- a/src/UpdateMergeRequests.hs +++ b/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,27 +28,36 @@ 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 @@ -55,29 +65,29 @@ updateMergeRequests projectExcludes action authorIs maybeSearchTerms recheckMerg 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. diff --git a/stack.yaml b/stack.yaml index b199cf4..c8f8aef 100644 --- a/stack.yaml +++ b/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 diff --git a/stack.yaml.lock b/stack.yaml.lock index dd5c7d5..2c482ce 100644 --- a/stack.yaml.lock +++ b/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