Queued processing

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
 

package.yaml

@@ -52,17 +52,20 @@ 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
     - scientific
     - split
     - text
     - time
+    - unliftio-core
     - yaml
 
 executables:

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

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

src/Effects.hs

@@ -20,12 +20,14 @@ module Effects
     getProjectsForGroup,
     getProjectsForUser,
     getProject,
+    processProjectsForGroupQueued,
     hasCi,
     setMergeMethod,
 
     -- * MergeRequest
     getOpenMergeRequests,
     getOpenMergeRequestsForGroup,
+    getOpenMergeRequestsForGroupQueued,
     enableSourceBranchDeletionAfterMrMerge,
     setSuccessfulPipelineRequirementForMerge,
     unsetSuccessfulPipelineRequirementForMerge,
@@ -66,6 +68,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 +140,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
@@ -176,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

@@ -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
@@ -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 ())
@@ -191,51 +191,49 @@ 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
   gId <- asks groupId
   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)

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)