Skip to content

Commit 6e26ae1

Browse files
L7R7L7R7
committed
Switch to queued processing for project-based use cases
1 parent 21a1cbd commit 6e26ae1

File tree

9 files changed

+119
-69
lines changed

9 files changed

+119
-69
lines changed

‎gitlab-helper.cabal‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -57,8 +57,10 @@ library
5757
, directory
5858
, either
5959
, envparse
60+
, exceptions
6061
, githash
6162
, gitlab-api-http-client-mtl
63+
, gitlab-api-http-client-queued-mtl
6264
, gitlab-api-types
6365
, http-conduit
6466
, http-types
@@ -69,6 +71,7 @@ library
6971
, split
7072
, text
7173
, time
74+
, unliftio-core
7275
, yaml
7376
default-language: Haskell2010
7477

‎package.yaml‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -52,17 +52,20 @@ library:
5252
- directory
5353
- either
5454
- envparse
55+
- exceptions
5556
- githash
5657
- http-conduit
5758
- http-types
5859
- gitlab-api-http-client-mtl
60+
- gitlab-api-http-client-queued-mtl
5961
- gitlab-api-types
6062
- network-uri
6163
- optparse-applicative
6264
- scientific
6365
- split
6466
- text
6567
- time
68+
- unliftio-core
6669
- yaml
6770

6871
executables:

‎src/App.hs‎

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,8 @@
66
module App (App (..)) where
77

88
import Config.Types
9+
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
10+
import Control.Monad.IO.Unlift (MonadUnliftIO)
911
import Gitlab.Client.MTL (HasApiToken (..), HasBaseUrl (..))
1012
import Relude
1113

@@ -15,7 +17,11 @@ newtype App a = App {unApp :: ReaderT Config IO a}
1517
Applicative,
1618
Monad,
1719
MonadIO,
18-
MonadReader Config
20+
MonadReader Config,
21+
MonadThrow,
22+
MonadCatch,
23+
MonadMask,
24+
MonadUnliftIO
1925
)
2026

2127
instance HasApiToken App where

‎src/Branches.hs‎

Lines changed: 28 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,6 @@
88
{-# LANGUAGE PolyKinds #-}
99
{-# LANGUAGE RecordWildCards #-}
1010
{-# LANGUAGE ScopedTypeVariables #-}
11-
{-# LANGUAGE TupleSections #-}
1211

1312
module Branches
1413
( showBranchesForGroup,
@@ -22,7 +21,7 @@ import qualified Data.Text as T (intercalate)
2221
import Data.Time hiding (getCurrentTime)
2322
import Effects
2423
import Gitlab.Branch
25-
import Gitlab.Client.MTL (UpdateError)
24+
import Gitlab.Client.Queue.MTL
2625
import Gitlab.Project
2726
import Relude
2827

@@ -36,28 +35,31 @@ showBranchesForGroup = do
3635
write " ✔ - the branch is merged"
3736
write " ✗ - the branch is stale (older than 90 days)"
3837
write " ⚬ - the branch is protected"
39-
getProjectsForGroup SkipArchivedProjects >>= \case
38+
results <- processProjectsForGroupQueued SkipArchivedProjects (fmap Right . processProject)
39+
case results of
4040
Left err -> write $ show err
41-
Right projects -> do
42-
results <- traverse (getBranchesForProject >=> printResult) projects
43-
writeSummary results
44-
45-
getBranchesForProject :: Project -> App (Project, Either UpdateError [Branch])
46-
getBranchesForProject p = (p,) <$> getBranches (projectId p)
47-
48-
printResult :: (Project, Either UpdateError [Branch]) -> App (Project, Either UpdateError [Branch])
49-
printResult input@(project, Left err) = do
50-
write $ "=== " <> show (projectName project)
51-
write $ "something went wrong: " <> show err
52-
pure input
53-
printResult input@(project, Right branches) = do
41+
Right res -> do
42+
writeSummary res
43+
44+
processProject :: Project -> App (ProcessResult (Project, [Branch]))
45+
processProject project = do
46+
getBranches (projectId project) >>= \case
47+
Left err -> pure $ PrintLines $ "=== " <> show (projectName project) :| ["something went wrong: " <> show err]
48+
Right branches -> do
49+
maybeTxts <- printResult (project, branches)
50+
pure
51+
$ case maybeTxts of
52+
Nothing -> Result (project, branches)
53+
Just txts -> PrintLinesWithResult txts (project, branches)
54+
55+
printResult :: (Project, [Branch]) -> App (Maybe (NonEmpty Text))
56+
printResult (project, branches) = do
5457
let branchesWithoutDefaultBranch = sortOn (commitCommittedDate . branchCommit) $ filter (not . branchDefault) branches
55-
unless (null branchesWithoutDefaultBranch) $ do
56-
write ""
57-
write $ formatWith [bold] ("=== " <> show (projectName project))
58-
now <- getCurrentTime
59-
traverse_ (\b -> write $ " " <> prettyPrintBranch now b) branchesWithoutDefaultBranch
60-
pure input
58+
now <- getCurrentTime
59+
pure
60+
$ if null branchesWithoutDefaultBranch
61+
then Nothing
62+
else Just $ "" :| (formatWith [bold] ("=== " <> show (projectName project)) : ((\b -> " " <> prettyPrintBranch now b) <$> branchesWithoutDefaultBranch))
6163

6264
prettyPrintBranch :: UTCTime -> Branch -> Text
6365
prettyPrintBranch now Branch {..} =
@@ -94,13 +96,13 @@ type MergedBranchesCount = Sum Int
9496

9597
type Summary = (ProjectCount, BranchesCount, StaleBranchesCount, MergedBranchesCount)
9698

97-
writeSummary :: [(Project, Either UpdateError [Branch])] -> App ()
99+
writeSummary :: [(Project, [Branch])] -> App ()
98100
writeSummary results = do
99101
now <- getCurrentTime
100102
write ""
101103
write . showSummary $ summary now results
102104

103-
summary :: UTCTime -> [(Project, Either UpdateError [Branch])] -> Summary
105+
summary :: UTCTime -> [(Project, [Branch])] -> Summary
104106
summary now = foldMap (count now)
105107

106108
showSummary :: Summary -> Text
@@ -121,9 +123,8 @@ showSummary (projects, branches, stale, merged) =
121123
isAre (Sum 1) = "is"
122124
isAre _ = "are"
123125

124-
count :: UTCTime -> (Project, Either UpdateError [Branch]) -> Summary
125-
count _ (_, Left _) = mempty
126-
count now (_, Right branches) = (hasBranches, notDefaultCount, stale, merged)
126+
count :: UTCTime -> (Project, [Branch]) -> Summary
127+
count now (_, branches) = (hasBranches, notDefaultCount, stale, merged)
127128
where
128129
notDefault = filter (not . branchDefault) branches
129130
hasBranches = Sum $ if notDefaultCount /= 0 then 1 else 0

‎src/Effects.hs‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ module Effects
2020
getProjectsForGroup,
2121
getProjectsForUser,
2222
getProject,
23+
processProjectsForGroupQueued,
2324
hasCi,
2425
setMergeMethod,
2526

@@ -66,6 +67,7 @@ import Data.Time (UTCTime)
6667
import qualified Data.Time
6768
import Gitlab.Branch
6869
import Gitlab.Client.MTL
70+
import Gitlab.Client.Queue.MTL
6971
import Gitlab.Group hiding (groupId)
7072
import Gitlab.Lib (Id (..), Ref (..))
7173
import Gitlab.MergeRequest
@@ -137,6 +139,16 @@ getAllUsers = fetchDataPaginated @User @App [uriTemplate|/api/v4/users|] []
137139
getAllGroups :: App (Either UpdateError [Group])
138140
getAllGroups = fetchDataPaginated [uriTemplate|/api/v4/groups?all_available=true|] []
139141

142+
processProjectsForGroupQueued :: WithArchivedProjects -> (Project -> App (Either UpdateError (ProcessResult a))) -> App (Either UpdateError [a])
143+
processProjectsForGroupQueued withArchivedProjects action = do
144+
gId <- asks groupId
145+
let template = case withArchivedProjects of
146+
SkipArchivedProjects -> [uriTemplate|/api/v4/groups/{groupId}/projects?include_subgroups=true&archived=false&with_shared=false|]
147+
IncludeArchivedProjects -> [uriTemplate|/api/v4/groups/{groupId}/projects?include_subgroups=true&with_shared=false|]
148+
vars = [("groupId", (stringValue . show) gId)]
149+
queueConfig = QueueConfig {parallelism = 10, bufferSize = 250} -- todo: make these configurable
150+
fetchDataQueued template vars queueConfig action
151+
140152
getProjectsForGroup :: WithArchivedProjects -> App (Either UpdateError [Project])
141153
getProjectsForGroup withArchivedProjects = do
142154
gId <- asks groupId

‎src/Projects.hs‎

Lines changed: 20 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -26,7 +26,7 @@ import Data.Aeson (encode)
2626
import qualified Data.Map as M
2727
import Data.Text (toLower)
2828
import Effects
29-
import Gitlab.Client.MTL (UpdateError)
29+
import Gitlab.Client.Queue.MTL
3030
import Gitlab.Group (Group)
3131
import Gitlab.Lib (EnabledDisabled (..), Id (..), Name (..), Ref (..))
3232
import Gitlab.Project
@@ -191,51 +191,49 @@ runProcessor (OptionSetter withArchivedProjects title skipIf action) = do
191191
gId <- asks groupId
192192
write "=================================================="
193193
write $ title gId
194-
getProjectsForGroup withArchivedProjects >>= \case
194+
res <- processProjectsForGroupQueued withArchivedProjects (fmap Right . process skipIf action)
195+
case res of
195196
Left err -> write $ show err
196-
Right projects -> do
197-
res <- traverse (process skipIf action) projects
197+
Right res' -> do
198198
write ""
199199
write "done: "
200-
let summary = foldl' (\m r -> M.insertWith (<>) r (Sum (1 :: Int)) m) (M.fromList $ (,mempty) <$> universe) res
200+
let summary = foldl' (\m r -> M.insertWith (<>) r (Sum (1 :: Int)) m) (M.fromList $ (,mempty) <$> universe) res'
201201
let summaryPrint = M.foldlWithKey' (\acc k (Sum c) -> (show k <> ": " <> show c) : acc) mempty summary
202202
traverse_ write summaryPrint
203203
runProcessor (Counter withArchivedProjects title skipIf action) = do
204204
gId <- asks groupId
205205
write "=================================================="
206206
write $ title gId
207207
write ""
208-
getProjectsForGroup withArchivedProjects >>= \case
208+
res <- processProjectsForGroupQueued withArchivedProjects (fmap Right . countSingle skipIf action)
209+
case res of
209210
Left err -> write $ show err
210-
Right projects -> do
211-
res <- traverse (countSingle skipIf action) projects
211+
Right res' -> do
212212
write ""
213-
write $ "done. Total: " <> show (getSum $ fold res) <> " deployments"
213+
write $ "done. Total: " <> show (getSum $ fold res') <> " deployments"
214214

215-
process :: (Project -> Bool) -> (Id Project -> App (Either UpdateError ())) -> Project -> App Result
215+
process :: (Project -> Bool) -> (Id Project -> App (Either UpdateError ())) -> Project -> App (ProcessResult Result)
216216
process skipIf action project = do
217-
write ""
218-
write $ formatWith [bold] ("=== " <> show (projectName project))
217+
let headings = "" :| [formatWith [bold] ("=== " <> show (projectName project))]
219218
if skipIf project
220-
then write "option is already enabled. Not doing anything" $> AlreadySet
219+
then pure $ PrintLinesWithResult (headings <> ("option is already enabled. Not doing anything" :| [])) AlreadySet
221220
else do
222-
write "setting option"
223221
res <- action (projectId project)
224-
case res of
225-
Left err -> write ("something went wrong. " <> show err) $> Error
226-
Right _ -> write "done" $> Set
222+
pure $ case res of
223+
Left err -> PrintLinesWithResult ("something went wrong. " <> show err :| []) Error
224+
Right _ -> PrintLinesWithResult ("option set" :| []) Set
227225

228-
countSingle :: (Project -> Bool) -> (Project -> App (Either UpdateError (Sum Int))) -> Project -> App (Sum Int)
229-
countSingle skipIf action project = count >>= \(output, result) -> write (title <> output) $> result
226+
countSingle :: (Project -> Bool) -> (Project -> App (Either UpdateError (Sum Int))) -> Project -> App (ProcessResult (Sum Int))
227+
countSingle skipIf action project = (\(output, result) -> PrintLinesWithResult (title <> output :| []) result) <$> count
230228
where
231229
count =
232230
if skipIf project
233231
then pure ("skipped", mempty)
234232
else do
235233
res <- action project
236-
case res of
237-
Left err -> pure (formatWith [red] "something went wrong: " <> show err, mempty)
238-
Right s -> pure (show (getSum s) <> " deployments", s)
234+
pure $ case res of
235+
Left err -> (formatWith [red] "something went wrong: " <> show err, mempty)
236+
Right s -> (show (getSum s) <> " deployments", s)
239237
title = formatWith [bold] (show (projectName project) <> " (#" <> show (projectId project) <> "): ")
240238

241239
data Result = AlreadySet | Set | Error deriving stock (Bounded, Enum, Eq, Ord, Show)

‎src/Schedules.hs‎

Lines changed: 5 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,7 @@ import App (App)
1919
import Colourista.Pure
2020
import Config.Types (Config (..), WithArchivedProjects (SkipArchivedProjects))
2121
import Effects
22-
import Gitlab.Client.MTL (UpdateError)
22+
import Gitlab.Client.Queue.MTL
2323
import Gitlab.Lib (Name (..))
2424
import Gitlab.Project
2525
import Relude
@@ -29,12 +29,11 @@ showSchedulesForGroup = do
2929
gId <- asks groupId
3030
write "=================================================="
3131
write $ "Listing the projects' schedules for Group " <> show gId
32-
getProjectsForGroup SkipArchivedProjects >>= \case
32+
processProjectsForGroupQueued SkipArchivedProjects (fmap (Right . Result) . getSchedulesForProject) >>= \case
3333
Left err -> write $ show err
34-
Right projects -> do
35-
results <- traverse getSchedulesForProject (sortOn (getName . projectName) projects)
36-
traverse_ printResults results
37-
writeSummary results
34+
Right res -> do
35+
traverse_ printResults (sortOn (getName . projectName . fst) res)
36+
writeSummary res
3837

3938
getSchedulesForProject :: Project -> App (Project, Either UpdateError [Schedule])
4039
getSchedulesForProject p = (p,) <$> getSchedules (projectId p)

‎stack.yaml‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -5,10 +5,12 @@ packages:
55

66
extra-deps:
77
- github: L7R7/gitlab-api
8-
commit: abff91cfa00788d28f57847aa7b28ad1d4f4a963
8+
commit: e3bd8278e19154adcf17ecad293d8ef07c1f006b
99
subdirs:
1010
- gitlab-api-http-client
1111
- gitlab-api-http-client-mtl
12+
- gitlab-api-http-client-queued
13+
- gitlab-api-http-client-queued-mtl
1214
- gitlab-api-types
1315

1416
system-ghc: true

‎stack.yaml.lock‎

Lines changed: 38 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -9,40 +9,66 @@ packages:
99
pantry-tree:
1010
sha256: ba41d94e0da3f64b9883530667de2d8772e685776f7a9b56a08eecb3e1732c1c
1111
size: 323
12-
sha256: b791d986aa0517284331d591d03ffdca7be5ad9ad16d8d1870501438d1ff7c05
13-
size: 23056
12+
sha256: bf8390d23847c81b0d42e62daa81ca46aa513e87d307dcc1ba61e43866981760
13+
size: 23140
1414
subdir: gitlab-api-http-client
15-
url: https://github.com/L7R7/gitlab-api/archive/abff91cfa00788d28f57847aa7b28ad1d4f4a963.tar.gz
15+
url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
1616
version: 0.0.0.1
1717
original:
1818
subdir: gitlab-api-http-client
19-
url: https://github.com/L7R7/gitlab-api/archive/abff91cfa00788d28f57847aa7b28ad1d4f4a963.tar.gz
19+
url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
2020
- completed:
2121
name: gitlab-api-http-client-mtl
2222
pantry-tree:
2323
sha256: aaa8533e8c0d775331eb6adf4be515ad6ce5085ae952ecf4cc4788f3e2432653
2424
size: 195
25-
sha256: b791d986aa0517284331d591d03ffdca7be5ad9ad16d8d1870501438d1ff7c05
26-
size: 23056
25+
sha256: bf8390d23847c81b0d42e62daa81ca46aa513e87d307dcc1ba61e43866981760
26+
size: 23140
2727
subdir: gitlab-api-http-client-mtl
28-
url: https://github.com/L7R7/gitlab-api/archive/abff91cfa00788d28f57847aa7b28ad1d4f4a963.tar.gz
28+
url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
2929
version: 0.0.0.1
3030
original:
3131
subdir: gitlab-api-http-client-mtl
32-
url: https://github.com/L7R7/gitlab-api/archive/abff91cfa00788d28f57847aa7b28ad1d4f4a963.tar.gz
32+
url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
33+
- completed:
34+
name: gitlab-api-http-client-queued
35+
pantry-tree:
36+
sha256: 595d620bd2c0c8b9b4b744e612687e5cf1cfae87cb4aab9193a7e7de6f63185b
37+
size: 200
38+
sha256: bf8390d23847c81b0d42e62daa81ca46aa513e87d307dcc1ba61e43866981760
39+
size: 23140
40+
subdir: gitlab-api-http-client-queued
41+
url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
42+
version: 0.0.0.1
43+
original:
44+
subdir: gitlab-api-http-client-queued
45+
url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
46+
- completed:
47+
name: gitlab-api-http-client-queued-mtl
48+
pantry-tree:
49+
sha256: fe10096fc6ae5458d6871a15171ee249526883bfbc309589e5cec5da86dde036
50+
size: 207
51+
sha256: bf8390d23847c81b0d42e62daa81ca46aa513e87d307dcc1ba61e43866981760
52+
size: 23140
53+
subdir: gitlab-api-http-client-queued-mtl
54+
url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
55+
version: 0.0.0.1
56+
original:
57+
subdir: gitlab-api-http-client-queued-mtl
58+
url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
3359
- completed:
3460
name: gitlab-api-types
3561
pantry-tree:
3662
sha256: 6cf943f17c29a9e25f786446d2d1192d469a1a7208114c40b0db39dcadc77448
3763
size: 725
38-
sha256: b791d986aa0517284331d591d03ffdca7be5ad9ad16d8d1870501438d1ff7c05
39-
size: 23056
64+
sha256: bf8390d23847c81b0d42e62daa81ca46aa513e87d307dcc1ba61e43866981760
65+
size: 23140
4066
subdir: gitlab-api-types
41-
url: https://github.com/L7R7/gitlab-api/archive/abff91cfa00788d28f57847aa7b28ad1d4f4a963.tar.gz
67+
url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
4268
version: 0.0.0.1
4369
original:
4470
subdir: gitlab-api-types
45-
url: https://github.com/L7R7/gitlab-api/archive/abff91cfa00788d28f57847aa7b28ad1d4f4a963.tar.gz
71+
url: https://github.com/L7R7/gitlab-api/archive/e3bd8278e19154adcf17ecad293d8ef07c1f006b.tar.gz
4672
snapshots:
4773
- completed:
4874
sha256: 098936027eaa1ef14e2b8eb39d9933a973894bb70a68684a1bbf00730249879b

0 commit comments

Comments
 (0)