From cc069ca1e4e205bcd034a656ec5bad5782a1f308 Mon Sep 17 00:00:00 2001 From: Leonhard Riedisser Date: Tue, 1 Oct 2024 11:19:25 +0200 Subject: [PATCH] Switch to gitlab-api-types for the GitLab API data --- gitlab-ci-build-statuses.cabal | 2 + package.yaml | 2 + src/Config/Backbone.hs | 9 ++- src/Config/Config.hs | 6 +- src/Config/Interpreters.hs | 4 ++ src/Core/BuildStatuses.hs | 60 +++++--------------- src/Core/Jobs.hs | 8 ++- src/Core/OverallStatus.hs | 33 +++++------ src/Core/Runners.hs | 29 +++------- src/Core/Shared.hs | 16 ------ src/Metrics/Metrics.hs | 9 +-- src/Ports/Inbound/HTTP/BuildStatuses/Html.hs | 30 +++++----- src/Ports/Inbound/HTTP/Runners/Html.hs | 6 +- src/Ports/Inbound/HTTP/Util.hs | 1 + src/Ports/Inbound/Jobs/BuildStatuses.hs | 2 + src/Ports/Inbound/Jobs/Runners.hs | 2 + src/Ports/Outbound/Gitlab/Helpers.hs | 3 +- src/Ports/Outbound/Gitlab/Instances.hs | 56 +++++++----------- src/Ports/Outbound/Gitlab/Jobs.hs | 6 +- src/Ports/Outbound/Gitlab/Pipelines.hs | 3 +- src/Ports/Outbound/Gitlab/Projects.hs | 12 +++- src/Ports/Outbound/Gitlab/Runners.hs | 23 +++++--- src/UseCases/BuildStatuses.hs | 12 ++-- src/UseCases/Runners.hs | 4 +- src/UseCases/Shared.hs | 2 +- stack.yaml | 6 ++ test/ConfigSpec.hs | 1 + test/GetStatusForProjectSpec.hs | 6 +- test/TestUtils.hs | 7 +++ 29 files changed, 173 insertions(+), 187 deletions(-) diff --git a/gitlab-ci-build-statuses.cabal b/gitlab-ci-build-statuses.cabal index 83b2070..d9b7ebc 100644 --- a/gitlab-ci-build-statuses.cabal +++ b/gitlab-ci-build-statuses.cabal @@ -82,6 +82,7 @@ library , either , extra , githash + , gitlab-api-types , higgledy , http-conduit , http-link-header @@ -142,6 +143,7 @@ test-suite gitlab-ci-build-statuses-test build-depends: base >=4.7 && <5 , containers + , gitlab-api-types , gitlab-ci-build-statuses , hedgehog , hspec diff --git a/package.yaml b/package.yaml index 42c3fee..58579d2 100644 --- a/package.yaml +++ b/package.yaml @@ -57,6 +57,7 @@ library: - either - extra - githash + - gitlab-api-types - higgledy - http-conduit - http-link-header @@ -106,6 +107,7 @@ tests: dependencies: - gitlab-ci-build-statuses - containers + - gitlab-api-types - hedgehog - hspec - hspec-hedgehog diff --git a/src/Config/Backbone.hs b/src/Config/Backbone.hs index c39a499..71a1d47 100644 --- a/src/Config/Backbone.hs +++ b/src/Config/Backbone.hs @@ -14,11 +14,14 @@ where import Config.Config import Control.Lens -import Core.BuildStatuses (BuildStatuses, Project) -import Core.Runners (Runner, RunnersJobs) -import Core.Shared +import Core.BuildStatuses (BuildStatuses) +import Core.Runners (RunnersJobs) import Data.Cache (Cache) import GitHash +import Gitlab.Group (Group) +import Gitlab.Lib (Id) +import Gitlab.Project (Project) +import Gitlab.Runner (Runner) import Katip (LogContexts, LogEnv, Namespace) import Metrics.Metrics import Ports.Outbound.Gitlab.Projects qualified as Projects (initCache) diff --git a/src/Config/Config.hs b/src/Config/Config.hs index e21790f..3642e6a 100644 --- a/src/Config/Config.hs +++ b/src/Config/Config.hs @@ -22,13 +22,15 @@ where import Barbies import Config.Util import Control.Lens -import Core.BuildStatuses (Project) -import Core.Shared (DataUpdateIntervalSeconds (..), Group, Id (..), Url (..)) +import Core.Shared (DataUpdateIntervalSeconds (..)) import Data.Biapplicative import Data.ByteString qualified as B hiding (pack) import Data.Char (toLower) import Data.Generic.HKD import Data.List.Extra (splitOn) +import Gitlab.Group (Group) +import Gitlab.Lib (Id (..), Url (..)) +import Gitlab.Project (Project) import Katip (Severity (..)) import Network.URI (parseAbsoluteURI) import Relude hiding (lookupEnv) diff --git a/src/Config/Interpreters.hs b/src/Config/Interpreters.hs index eb492cb..8967e41 100644 --- a/src/Config/Interpreters.hs +++ b/src/Config/Interpreters.hs @@ -9,6 +9,10 @@ import Core.BuildStatuses import Core.Runners import Core.Shared import Data.Cache (Cache) +import Gitlab.Group (Group) +import Gitlab.Lib (Id, Url) +import Gitlab.Project (Project) +import Gitlab.Runner (Runner) import Metrics.Metrics import Polysemy import Polysemy.Reader diff --git a/src/Core/BuildStatuses.hs b/src/Core/BuildStatuses.hs index afa19dc..376ab5e 100644 --- a/src/Core/BuildStatuses.hs +++ b/src/Core/BuildStatuses.hs @@ -3,10 +3,10 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Core.BuildStatuses - ( BuildStatus (..), - BuildStatuses (..), + ( BuildStatuses (..), filterResults, Result (..), ProjectsApi (..), @@ -22,24 +22,24 @@ module Core.BuildStatuses getSinglePipeline, DetailedPipeline (..), Pipeline (..), - Project (..), - ProjectNamespace (..), - ProjectNamespaceFullPath (..), isHealthy, toResult, ) where -import Core.Shared +import Core.Shared (UpdateError) import Data.Time (UTCTime (..)) -import Path +import Gitlab.Group +import Gitlab.Job (JobStatus (..)) +import Gitlab.Lib (Id, Name, Ref, Url) +import Gitlab.Project (Project (..), ProjectNamespace (..), ProjectNamespaceFullPath) import Polysemy import Relude data Pipeline = Pipeline { pipelineId :: Id Pipeline, pipelineRef :: Ref, - pipelineStatus :: BuildStatus, + pipelineStatus :: JobStatus, pipelineWebUrl :: Url Pipeline } deriving stock (Generic, Show) @@ -54,27 +54,11 @@ data Result = Result { projId :: Id Project, name :: Name Project, namespace :: ProjectNamespaceFullPath, - buildStatus :: BuildStatus, + buildStatus :: JobStatus, url :: Either (Url Project) (Url Pipeline) } deriving stock (Eq, Show) -data BuildStatus - = Unknown - | Cancelled - | Created - | Failed - | Manual - | Pending - | Preparing - | Running - | Scheduled - | Skipped - | Successful - | SuccessfulWithWarnings - | WaitingForResource - deriving stock (Bounded, Enum, Eq, Show, Ord) - data BuildStatuses = NoSuccessfulUpdateYet | Statuses (UTCTime, [Result]) filterResults :: BuildStatuses -> (Result -> Bool) -> BuildStatuses @@ -84,32 +68,14 @@ filterResults (Statuses (t, res)) f = Statuses (t, filter f res) data DetailedPipeline = DetailedPipeline { detailedPipelineId :: Id Pipeline, detailedPipelineRef :: Ref, - detailedPipelineStatus :: BuildStatus, + detailedPipelineStatus :: JobStatus, detailedPipelineWebUrl :: Url Pipeline } -data Project = Project - { projectId :: Id Project, - projectName :: Name Project, - projectWebUrl :: Url Project, - projectDefaultBranch :: Maybe Ref, - projectNamespace :: ProjectNamespace - } - deriving stock (Eq, Generic, Show) - +-- todo: is this right? instance Ord Project where p1 <= p2 = projectId p1 <= projectId p2 -data ProjectNamespace = ProjectNamespace - { projectNamespaceId :: Id ProjectNamespace, - projectNamespaceFullPath :: ProjectNamespaceFullPath - } - deriving stock (Eq, Generic, Show) - -newtype ProjectNamespaceFullPath = ProjectNamespaceFullPath (Path Rel Dir) - deriving stock (Generic) - deriving newtype (Eq, Ord, Show) - data PipelinesApi m a where GetLatestPipelineForRef :: Id Project -> Ref -> PipelinesApi m (Either UpdateError Pipeline) GetSinglePipeline :: Id Project -> Id Pipeline -> PipelinesApi m (Either UpdateError DetailedPipeline) @@ -133,7 +99,7 @@ data BuildStatusesApi m a where makeSem ''BuildStatusesApi -isHealthy :: BuildStatus -> Bool +isHealthy :: JobStatus -> Bool isHealthy Unknown = False isHealthy Cancelled = False isHealthy Created = True @@ -148,6 +114,6 @@ isHealthy Successful = True isHealthy SuccessfulWithWarnings = False isHealthy WaitingForResource = True -toResult :: Project -> Maybe (BuildStatus, Url Pipeline) -> Result +toResult :: Project -> Maybe (JobStatus, Url Pipeline) -> Result toResult Project {..} Nothing = Result projectId projectName (projectNamespaceFullPath projectNamespace) Unknown (Left projectWebUrl) toResult Project {..} (Just (status, url)) = Result projectId projectName (projectNamespaceFullPath projectNamespace) status (Right url) diff --git a/src/Core/Jobs.hs b/src/Core/Jobs.hs index f9b355c..3dfdb68 100644 --- a/src/Core/Jobs.hs +++ b/src/Core/Jobs.hs @@ -10,17 +10,19 @@ module Core.Jobs ) where -import Core.BuildStatuses (BuildStatus, Project) import Core.Shared +import Gitlab.Job (JobStatus) +import Gitlab.Lib (Id) +import Gitlab.Project (Project) import Polysemy (makeSem) import Relude data Job = Job { jobId :: Id Job, - jobStatus :: BuildStatus + jobStatus :: JobStatus } data JobsApi m a where - GetJobsWithStatuses :: Id Project -> NonEmpty BuildStatus -> JobsApi m (Either UpdateError [Job]) + GetJobsWithStatuses :: Id Project -> NonEmpty JobStatus -> JobsApi m (Either UpdateError [Job]) makeSem ''JobsApi diff --git a/src/Core/OverallStatus.hs b/src/Core/OverallStatus.hs index 8139147..8ac5331 100644 --- a/src/Core/OverallStatus.hs +++ b/src/Core/OverallStatus.hs @@ -5,8 +5,9 @@ module Core.OverallStatus ) where -import Core.BuildStatuses (BuildStatus, BuildStatuses (..), Result (buildStatus)) -import Core.BuildStatuses qualified as B (BuildStatus (..)) +import Core.BuildStatuses (BuildStatuses (..), Result (buildStatus)) +import Gitlab.Job (JobStatus) +import Gitlab.Job qualified as J (JobStatus (..)) import Relude data OverallStatus @@ -54,17 +55,17 @@ overallStatus :: BuildStatuses -> OverallStatus overallStatus NoSuccessfulUpdateYet = Unknown overallStatus (Statuses (_, statuses)) = foldMap (resultToOverall . buildStatus) statuses -resultToOverall :: BuildStatus -> OverallStatus -resultToOverall B.Unknown = Unknown -resultToOverall B.Cancelled = Failed -resultToOverall B.Created = Running -resultToOverall B.Failed = Failed -resultToOverall B.Manual = Warning -resultToOverall B.Pending = Running -resultToOverall B.Preparing = Running -resultToOverall B.Running = Running -resultToOverall B.Scheduled = Running -resultToOverall B.Skipped = Warning -resultToOverall B.Successful = Successful -resultToOverall B.SuccessfulWithWarnings = Warning -resultToOverall B.WaitingForResource = Warning +resultToOverall :: JobStatus -> OverallStatus +resultToOverall J.Unknown = Unknown +resultToOverall J.Cancelled = Failed +resultToOverall J.Created = Running +resultToOverall J.Failed = Failed +resultToOverall J.Manual = Warning +resultToOverall J.Pending = Running +resultToOverall J.Preparing = Running +resultToOverall J.Running = Running +resultToOverall J.Scheduled = Running +resultToOverall J.Skipped = Warning +resultToOverall J.Successful = Successful +resultToOverall J.SuccessfulWithWarnings = Warning +resultToOverall J.WaitingForResource = Warning diff --git a/src/Core/Runners.hs b/src/Core/Runners.hs index 6570a46..791996b 100644 --- a/src/Core/Runners.hs +++ b/src/Core/Runners.hs @@ -2,14 +2,11 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Core.Runners - ( Runner (..), - Description (..), - Tag (..), - Job (..), + ( Job (..), Stage (..), - IpAddress (..), RunnersJobs (..), RunnersApi (..), getOnlineRunnersForGroup, @@ -21,28 +18,18 @@ module Core.Runners ) where -import Core.BuildStatuses (Project) -import Core.Shared +import Core.Shared (UpdateError) import Data.Time (UTCTime) +import Gitlab.Group (Group) +import Gitlab.Lib (Id, Name, Ref, Url) +import Gitlab.Project (Project) +import Gitlab.Runner import Polysemy (makeSem) import Relude -data Runner = Runner - { runnerId :: Id Runner, - runnerName :: Maybe (Name Runner), - runnerDescription :: Description, - runnerIpAddress :: Maybe IpAddress, - runnerTagList :: [Tag] - } - deriving stock (Eq, Generic) - instance Ord Runner where compare r1 r2 = compare (runnerId r1) (runnerId r2) -newtype Description = Description Text deriving newtype (Eq) - -newtype Tag = Tag Text deriving newtype (Eq) - data Job = Job { jobId :: Id Job, jobProjectId :: Id Project, @@ -55,8 +42,6 @@ data Job = Job newtype Stage = Stage Text -newtype IpAddress = IpAddress Text deriving newtype (Eq) - data RunnersJobs = NoSuccessfulUpdateYet | RunnersJobs (UTCTime, Map Runner [Job]) data RunnersApi m a where diff --git a/src/Core/Shared.hs b/src/Core/Shared.hs index 8a644ca..540a42e 100644 --- a/src/Core/Shared.hs +++ b/src/Core/Shared.hs @@ -2,23 +2,15 @@ module Core.Shared ( DataUpdateIntervalSeconds (..), - Group, - Id (..), - Url (..), - Name (..), UpdateError (..), - Ref (..), ) where import Data.ByteString.Lazy qualified as L import Network.HTTP.Simple (HttpException, Request, Response) import Network.HTTP.Types (Status) -import Network.URI import Relude -data Group - data UpdateError = HttpError HttpException | JSONError Request (Response L.ByteString) String @@ -30,11 +22,3 @@ newtype DataUpdateIntervalSeconds = DataUpdateIntervalSeconds Int deriving stock (Show) deriving (Num) via Int deriving newtype (Eq) - -newtype Id a = Id Int deriving newtype (Eq, Hashable, Ord, Show) - -newtype Url a = Url URI deriving newtype (Eq, Show) - -newtype Ref = Ref Text deriving newtype (Eq, Ord, Show) - -newtype Name a = Name Text deriving newtype (Eq, Show) diff --git a/src/Metrics/Metrics.hs b/src/Metrics/Metrics.hs index 7be563b..da49e21 100644 --- a/src/Metrics/Metrics.hs +++ b/src/Metrics/Metrics.hs @@ -27,7 +27,7 @@ module Metrics.Metrics ) where -import Core.BuildStatuses (BuildStatus, BuildStatusesApi, Result (..), getStatuses, isHealthy) +import Core.BuildStatuses (BuildStatusesApi, Result (..), getStatuses, isHealthy) import Core.BuildStatuses qualified as B (BuildStatuses (..)) import Core.Runners (RunnersJobsApi, getJobs) import Core.Runners qualified as R (RunnersJobs (..)) @@ -36,6 +36,7 @@ import Data.List.Extra (enumerate) import Data.Map hiding (partition) import Data.Text (toLower) import GHC.Clock (getMonotonicTime) +import Gitlab.Job (JobStatus) import Metrics.PrometheusUtils (VectorWithLabel (VectorWithLabel)) import Polysemy import Polysemy.Reader qualified as R @@ -167,13 +168,13 @@ updatePipelinesOverviewMetricIO :: PipelinesOverviewGauge -> B.BuildStatuses -> updatePipelinesOverviewMetricIO _ B.NoSuccessfulUpdateYet = pass updatePipelinesOverviewMetricIO overviewGauge (B.Statuses (_, results)) = traverse_ (updateSingle overviewGauge) (Data.Map.toList (countByBuildStatus results)) -updateSingle :: PipelinesOverviewGauge -> (BuildStatus, Double) -> IO () +updateSingle :: PipelinesOverviewGauge -> (JobStatus, Double) -> IO () updateSingle (PipelinesOverviewGauge overviewGauge) (status, count) = withLabel overviewGauge ((toLower . show) status) (`setGauge` count) -countByBuildStatus :: [Result] -> Map BuildStatus Double +countByBuildStatus :: [Result] -> Map JobStatus Double countByBuildStatus results = countOccurrences buildStatus results `union` resetValues -resetValues :: Map BuildStatus Double +resetValues :: Map JobStatus Double resetValues = Data.Map.fromList $ (,0) <$> enumerate updateMetricsRegularly :: (Member BuildStatusesApi r, Member RunnersJobsApi r, Member MetricsApi r, Member (Time t d) r) => Sem r () diff --git a/src/Ports/Inbound/HTTP/BuildStatuses/Html.hs b/src/Ports/Inbound/HTTP/BuildStatuses/Html.hs index ed55a60..db328fa 100644 --- a/src/Ports/Inbound/HTTP/BuildStatuses/Html.hs +++ b/src/Ports/Inbound/HTTP/BuildStatuses/Html.hs @@ -18,6 +18,8 @@ import Core.OverallStatus qualified as O (OverallStatus (Successful, Unknown, Wa import Core.Shared import Data.Map qualified as M import Data.Time (UTCTime) +import Gitlab.Job (JobStatus (..)) +import Gitlab.Project (ProjectNamespaceFullPath (..)) import Lucid import Lucid.Base (commuteHtmlT, makeAttribute) import Path (toFilePath) @@ -125,7 +127,7 @@ statusesToHtml Plain dataUpdateInterval now (Statuses (lastUpdated, results)) = resultToHtml :: (Monad m) => Result -> HtmlT m () resultToHtml Result {..} = - a_ [href_ (either show show url), target_ "_blank", classesForStatus buildStatus, title_ (buildStatusToString buildStatus)] $ div_ (toHtml name) + a_ [href_ (either show show url), target_ "_blank", classesForStatus buildStatus, title_ (jobStatusToString buildStatus)] $ div_ (toHtml name) where classesForStatus Unknown = class_ "status unknown" classesForStatus Cancelled = class_ "status cancelled" @@ -141,19 +143,19 @@ resultToHtml Result {..} = classesForStatus SuccessfulWithWarnings = class_ "status passed-with-warnings" classesForStatus WaitingForResource = class_ "status waiting-for-resource" - buildStatusToString Unknown = "unknown" - buildStatusToString Cancelled = "cancelled" - buildStatusToString Created = "created" - buildStatusToString Failed = "failed" - buildStatusToString Manual = "manual" - buildStatusToString Pending = "pending" - buildStatusToString Preparing = "preparing" - buildStatusToString Running = "running" - buildStatusToString Scheduled = "scheduled" - buildStatusToString Skipped = "skipped" - buildStatusToString Successful = "successful" - buildStatusToString SuccessfulWithWarnings = "successful with warnings" - buildStatusToString WaitingForResource = "waiting for resource" + jobStatusToString Unknown = "unknown" + jobStatusToString Cancelled = "cancelled" + jobStatusToString Created = "created" + jobStatusToString Failed = "failed" + jobStatusToString Manual = "manual" + jobStatusToString Pending = "pending" + jobStatusToString Preparing = "preparing" + jobStatusToString Running = "running" + jobStatusToString Scheduled = "scheduled" + jobStatusToString Skipped = "skipped" + jobStatusToString Successful = "successful" + jobStatusToString SuccessfulWithWarnings = "successful with warnings" + jobStatusToString WaitingForResource = "waiting for resource" emptyResults :: Frontend emptyResults = do diff --git a/src/Ports/Inbound/HTTP/Runners/Html.hs b/src/Ports/Inbound/HTTP/Runners/Html.hs index a128713..016da4d 100644 --- a/src/Ports/Inbound/HTTP/Runners/Html.hs +++ b/src/Ports/Inbound/HTTP/Runners/Html.hs @@ -14,10 +14,12 @@ import Config.Backbone import Config.Config import Core.Runners hiding (getJobs) import Core.Runners qualified as R (getJobs) -import Core.Shared (DataUpdateIntervalSeconds, Ref (Ref)) +import Core.Shared (DataUpdateIntervalSeconds) import Data.Map (toList) import Data.Text qualified as T import Data.Time (UTCTime) +import Gitlab.Lib (Ref (..)) +import Gitlab.Runner import Lucid import Lucid.Base (commuteHtmlT, makeAttribute) import Polysemy @@ -133,7 +135,7 @@ deriving newtype instance ToHtml IpAddress deriving newtype instance ToHtml Description -deriving newtype instance ToHtml Core.Runners.Tag +deriving newtype instance ToHtml RunnerTag truncateRef :: (Monad m) => Ref -> HtmlT m () truncateRef (Ref ref) | T.length ref <= 26 = toHtml ref diff --git a/src/Ports/Inbound/HTTP/Util.hs b/src/Ports/Inbound/HTTP/Util.hs index d05b2ed..c18a5b8 100644 --- a/src/Ports/Inbound/HTTP/Util.hs +++ b/src/Ports/Inbound/HTTP/Util.hs @@ -6,6 +6,7 @@ module Ports.Inbound.HTTP.Util (AutoRefresh (..), ViewMode (..), FilterMode (..) import Core.Shared import Data.Time (UTCTime, diffUTCTime) import Data.Time.Format.ISO8601 (iso8601Show) +import Gitlab.Lib (Id (..), Name (..)) import Lucid import Relude import Servant (FromHttpApiData (..), ToHttpApiData (..)) diff --git a/src/Ports/Inbound/Jobs/BuildStatuses.hs b/src/Ports/Inbound/Jobs/BuildStatuses.hs index 215f404..90c0f09 100644 --- a/src/Ports/Inbound/Jobs/BuildStatuses.hs +++ b/src/Ports/Inbound/Jobs/BuildStatuses.hs @@ -10,6 +10,8 @@ import Config.Config (ExtraProjectsList) import Core.BuildStatuses (BuildStatusesApi, PipelinesApi, ProjectsApi, ProjectsWithoutExcludesApi) import Core.Effects (Logger, ParTraverse, addContext, addNamespace, logDebug) import Core.Shared +import Gitlab.Group (Group) +import Gitlab.Lib (Id) import Metrics.Metrics import Polysemy import Polysemy.Reader qualified as R diff --git a/src/Ports/Inbound/Jobs/Runners.hs b/src/Ports/Inbound/Jobs/Runners.hs index 16665d2..70b5ed3 100644 --- a/src/Ports/Inbound/Jobs/Runners.hs +++ b/src/Ports/Inbound/Jobs/Runners.hs @@ -10,6 +10,8 @@ import Config.Config (ProjectExcludeList) import Core.Effects (Logger, ParTraverse, addContext, addNamespace, logDebug) import Core.Runners import Core.Shared +import Gitlab.Group (Group) +import Gitlab.Lib (Id) import Metrics.Metrics import Polysemy import Polysemy.Reader qualified as R diff --git a/src/Ports/Outbound/Gitlab/Helpers.hs b/src/Ports/Outbound/Gitlab/Helpers.hs index 8e7a0ce..eb74bc2 100644 --- a/src/Ports/Outbound/Gitlab/Helpers.hs +++ b/src/Ports/Outbound/Gitlab/Helpers.hs @@ -7,9 +7,10 @@ module Ports.Outbound.Gitlab.Helpers (fetchData, fetchDataPaginated) where import Burrito import Config.Config (ApiToken (..), GitlabHost) import Control.Exception (try) -import Core.Shared (UpdateError (..), Url (..)) +import Core.Shared (UpdateError (..)) import Data.Aeson hiding (Result, Value) import Data.Either.Combinators (mapLeft) +import Gitlab.Lib (Url (..)) import Metrics.Metrics (OutgoingHttpRequestsHistogram (..)) import Metrics.PrometheusUtils (VectorWithLabel (VectorWithLabel)) import Network.HTTP.Simple (Request, getResponseBody, getResponseStatus, httpLBS, parseRequest) diff --git a/src/Ports/Outbound/Gitlab/Instances.hs b/src/Ports/Outbound/Gitlab/Instances.hs index 8eb7047..8108179 100644 --- a/src/Ports/Outbound/Gitlab/Instances.hs +++ b/src/Ports/Outbound/Gitlab/Instances.hs @@ -2,12 +2,14 @@ {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Ports.Outbound.Gitlab.Instances (buildStatusToApiString) where +module Ports.Outbound.Gitlab.Instances (jobStatusToApiString) where import Core.BuildStatuses -import Core.Shared import Data.Aeson hiding (Result, Value) import Data.Aeson.Casing (aesonPrefix, snakeCase) +import Gitlab.Job (JobStatus (..)) +import Gitlab.Lib (Id (..), Name (..), Ref (..), Url (..)) +import Gitlab.Project (ProjectNamespaceFullPath (..)) import Network.URI (parseURI) import Relude @@ -19,23 +21,20 @@ instance FromJSON DetailedPipeline where detailedPipelineStatus <- dp .: "detailed_status" >>= \ds -> ds .: "group" pure DetailedPipeline {..} -instance FromJSON BuildStatus where - parseJSON = withText "BuildStatus" $ \x -> maybe (fail $ mconcat ["couldn't parse build status from '", show x, "'"]) pure (inverseMap buildStatusToApiString x) - -buildStatusToApiString :: (IsString p) => BuildStatus -> p -buildStatusToApiString Unknown = "unknown" -buildStatusToApiString Cancelled = "canceled" -buildStatusToApiString Created = "created" -buildStatusToApiString Failed = "failed" -buildStatusToApiString Manual = "manual" -buildStatusToApiString Pending = "pending" -buildStatusToApiString Preparing = "preparing" -buildStatusToApiString Running = "running" -buildStatusToApiString Scheduled = "scheduled" -buildStatusToApiString Skipped = "skipped" -buildStatusToApiString Successful = "success" -buildStatusToApiString SuccessfulWithWarnings = "success-with-warnings" -buildStatusToApiString WaitingForResource = "waiting_for_resource" +jobStatusToApiString :: (IsString p) => JobStatus -> p +jobStatusToApiString Unknown = "unknown" +jobStatusToApiString Cancelled = "canceled" +jobStatusToApiString Created = "created" +jobStatusToApiString Failed = "failed" +jobStatusToApiString Manual = "manual" +jobStatusToApiString Pending = "pending" +jobStatusToApiString Preparing = "preparing" +jobStatusToApiString Running = "running" +jobStatusToApiString Scheduled = "scheduled" +jobStatusToApiString Skipped = "skipped" +jobStatusToApiString Successful = "success" +jobStatusToApiString SuccessfulWithWarnings = "success-with-warnings" +jobStatusToApiString WaitingForResource = "waiting_for_resource" instance FromJSON Pipeline where parseJSON = genericParseJSON $ aesonPrefix snakeCase @@ -43,25 +42,14 @@ instance FromJSON Pipeline where instance FromJSON (Url a) where parseJSON = withText "URI" $ \v -> Url <$> maybe (fail "Bad URI") pure (parseURI (toString v)) -instance FromJSON Project where - parseJSON = withObject "project" $ \project -> do - projectId <- project .: "id" - projectName <- project .: "name" - projectWebUrl <- project .: "web_url" - projectDefaultBranch <- project .: "default_branch" - projectNamespace <- project .: "namespace" - pure Project {..} - -instance FromJSON ProjectNamespace where - parseJSON = withObject "namespace" $ \namespace -> do - projectNamespaceId <- namespace .: "id" - projectNamespaceFullPath <- namespace .: "full_path" - pure ProjectNamespace {..} - +-- todo derive via codec deriving newtype instance FromJSON (Id a) +-- todo derive via codec deriving newtype instance FromJSON (Name a) +-- todo derive via codec deriving newtype instance FromJSON Ref +-- todo derive via codec deriving newtype instance FromJSON ProjectNamespaceFullPath diff --git a/src/Ports/Outbound/Gitlab/Jobs.hs b/src/Ports/Outbound/Gitlab/Jobs.hs index 50569e7..1a74122 100644 --- a/src/Ports/Outbound/Gitlab/Jobs.hs +++ b/src/Ports/Outbound/Gitlab/Jobs.hs @@ -10,13 +10,13 @@ module Ports.Outbound.Gitlab.Jobs (jobsApiToIO) where import Burrito import Config.Config (ApiToken (..), GitlabHost) import Core.Jobs -import Core.Shared (Url (..)) import Data.Aeson +import Gitlab.Lib (Url (..)) import Metrics.Metrics (OutgoingHttpRequestsHistogram) import Polysemy import Polysemy.Reader qualified as R import Ports.Outbound.Gitlab.Helpers -import Ports.Outbound.Gitlab.Instances (buildStatusToApiString) +import Ports.Outbound.Gitlab.Instances (jobStatusToApiString) import Relude jobsApiToIO :: (Member (Embed IO) r, Member (R.Reader (Url GitlabHost)) r, Member (R.Reader ApiToken) r, Member (R.Reader OutgoingHttpRequestsHistogram) r) => InterpreterFor JobsApi r @@ -30,7 +30,7 @@ jobsApiToIO' :: (Member (Embed IO) r) => Url GitlabHost -> ApiToken -> OutgoingH jobsApiToIO' baseUrl apiToken histogram = interpret $ \case GetJobsWithStatuses projectId statuses -> do let template = [uriTemplate|/api/v4/projects/{projectId}/jobs{?scope%5B%5D*}|] - embed $ fetchDataPaginated baseUrl apiToken template [("projectId", (stringValue . show) projectId), ("scope%5B%5D", listValue (buildStatusToApiString <$> toList statuses))] histogram + embed $ fetchDataPaginated baseUrl apiToken template [("projectId", (stringValue . show) projectId), ("scope%5B%5D", listValue (jobStatusToApiString <$> toList statuses))] histogram instance FromJSON Job where parseJSON = withObject "job" $ \job -> do diff --git a/src/Ports/Outbound/Gitlab/Pipelines.hs b/src/Ports/Outbound/Gitlab/Pipelines.hs index a721aa8..879789f 100644 --- a/src/Ports/Outbound/Gitlab/Pipelines.hs +++ b/src/Ports/Outbound/Gitlab/Pipelines.hs @@ -10,7 +10,8 @@ module Ports.Outbound.Gitlab.Pipelines (pipelinesApiToIO) where import Burrito import Config.Config (ApiToken (..), GitlabHost) import Core.BuildStatuses (PipelinesApi (..)) -import Core.Shared (Id (Id), Ref (Ref), UpdateError (..), Url (..)) +import Core.Shared (UpdateError (..)) +import Gitlab.Lib (Id (..), Ref (..), Url (..)) import Metrics.Metrics (OutgoingHttpRequestsHistogram) import Polysemy import Polysemy.Reader qualified as R diff --git a/src/Ports/Outbound/Gitlab/Projects.hs b/src/Ports/Outbound/Gitlab/Projects.hs index d9eb290..1a6cea8 100644 --- a/src/Ports/Outbound/Gitlab/Projects.hs +++ b/src/Ports/Outbound/Gitlab/Projects.hs @@ -9,11 +9,13 @@ module Ports.Outbound.Gitlab.Projects (initCache, projectsApiToIO, projectsWitho import Burrito import Config.Config (ApiToken (..), GitlabHost, ProjectCacheTtlSeconds (ProjectCacheTtlSeconds), ProjectExcludeList (ProjectExcludeList), SharedProjects (Exclude, Include)) -import Core.BuildStatuses (Project (projectId), ProjectsApi (..), ProjectsWithoutExcludesApi (..), getProjects) +import Core.BuildStatuses (ProjectsApi (..), ProjectsWithoutExcludesApi (..), getProjects) import Core.Effects -import Core.Shared (Group, Id (..), Url (..)) import Data.Aeson (ToJSON) import Data.Cache +import Gitlab.Group (Group) +import Gitlab.Lib (Id (..), Url (..)) +import Gitlab.Project (Project (..)) import Metrics.Metrics (CacheResult (..), CacheTag (CacheTag), MetricsApi, OutgoingHttpRequestsHistogram, recordCacheLookupResult) import Polysemy import Polysemy.Reader qualified as R @@ -53,7 +55,7 @@ projectsApiToIO = interpret $ \case case cached of (Just projects) -> pure (Right projects, Hit) Nothing -> do - let template = [uriTemplate|/api/v4/groups/{groupId}/projects?simple=true&include_subgroups=true&archived=false{&with_shared}|] + let template = [uriTemplate|/api/v4/groups/{groupId}/projects?include_subgroups=true&archived=false{&with_shared}|] result <- fetchDataPaginated baseUrl apiToken template [("groupId", (stringValue . show) groupId), ("with_shared", withShared sharedProjects)] histogram traverse_ (insert cache groupId) result pure (result, Miss) @@ -82,4 +84,8 @@ projectsWithoutExcludesApiInTermsOfProjects = interpret $ \case let filtered = filter (\p -> projectId p `notElem` excludeList) ps pure filtered +-- todo derive via codec deriving newtype instance ToJSON (Id a) + +-- todo: move to gitlab-api-types? +deriving newtype instance Hashable (Id a) diff --git a/src/Ports/Outbound/Gitlab/Runners.hs b/src/Ports/Outbound/Gitlab/Runners.hs index da9724a..841bcc1 100644 --- a/src/Ports/Outbound/Gitlab/Runners.hs +++ b/src/Ports/Outbound/Gitlab/Runners.hs @@ -10,11 +10,14 @@ module Ports.Outbound.Gitlab.Runners (initCache, runnersApiToIO) where import Burrito import Config.Config (ApiToken (..), GitlabHost, RunnerCacheTtlSeconds (RunnerCacheTtlSeconds)) import Core.BuildStatuses -import Core.Runners (Description (..), IpAddress (..), Job (..), Runner, RunnersApi (..), Stage (..), Tag (..)) -import Core.Shared (Group, Id, UpdateError, Url (..)) +import Core.Runners (Job (..), RunnersApi (..), Stage (..)) +import Core.Shared (UpdateError) import Data.Aeson -import Data.Aeson.Casing (aesonPrefix, snakeCase) import Data.Cache +import Gitlab.Group (Group) +import Gitlab.Lib (Id (..), Url) +import Gitlab.Project (Project (..)) +import Gitlab.Runner import Metrics.Metrics (CacheResult (..), CacheTag (CacheTag), MetricsApi, OutgoingHttpRequestsHistogram, recordCacheLookupResult) import Polysemy import Polysemy.Reader qualified as R @@ -87,7 +90,7 @@ runnersApiToIO' baseUrl apiToken histogram groupCache projectCache = interpret $ (Just runners) -> pure (Right runners, Hit) Nothing -> do projects <- getProjectsNotOnExcludeListOrEmpty groupId - result <- sequence <$> traverse (\(Project projectId _ _ _ _) -> fmap (projectId,) <$> getRunnersForProject projectId) projects + result <- sequence <$> traverse (\project -> let pId = projectId project in fmap (pId,) <$> getRunnersForProject pId) projects embed $ traverse_ (insert projectCache groupId) result pure (result, Miss) recordCacheLookupResult (CacheTag "project-runners") cacheResult @@ -124,13 +127,17 @@ instance FromJSON Job where jobWebUrl <- job .: "web_url" pure Job {..} +-- todo derive via codec deriving newtype instance FromJSON Stage +-- todo derive via codec deriving newtype instance FromJSON IpAddress -instance FromJSON Runner where - parseJSON = genericParseJSON $ aesonPrefix snakeCase - +-- todo derive via codec deriving newtype instance FromJSON Description -deriving newtype instance FromJSON Tag +-- todo derive via codec +deriving newtype instance FromJSON RunnerTag + +-- todo: move to gitlab-api-types? +deriving newtype instance Hashable (Id a) diff --git a/src/UseCases/BuildStatuses.hs b/src/UseCases/BuildStatuses.hs index 953699c..86e08f3 100644 --- a/src/UseCases/BuildStatuses.hs +++ b/src/UseCases/BuildStatuses.hs @@ -12,9 +12,13 @@ where import Config.Config (ExtraProjectsList (ExtraProjectsList)) import Core.BuildStatuses import Core.Effects (Logger, ParTraverse, addContext, logDebug, logWarn, traverseP) -import Core.Shared +import Core.Shared (UpdateError (..)) import Data.List (partition) import Data.Text qualified as T (intercalate, toLower) +import Gitlab.Group (Group) +import Gitlab.Job (JobStatus (..)) +import Gitlab.Lib (Id, Name (..), Ref, Url) +import Gitlab.Project (Project (..)) import Polysemy import Polysemy.Reader qualified as R import Relude @@ -62,7 +66,7 @@ currentBuildStatuses :: currentBuildStatuses = do projects <- findProjects results <- traverseP evalProject projects - pure $ sortOn (T.toLower . coerce . name) results + pure $ sortOn (T.toLower . getName . name) results findProjects :: ( Member ProjectsApi r, @@ -116,7 +120,7 @@ getStatusForProject :: ) => Id Project -> Maybe Ref -> - Sem r (Maybe (BuildStatus, Url Pipeline)) + Sem r (Maybe (JobStatus, Url Pipeline)) getStatusForProject _ Nothing = pure Nothing getStatusForProject projectId (Just defaultBranch) = addContext "projectId" projectId $ do pipeline <- getLatestPipelineForRef projectId defaultBranch @@ -134,7 +138,7 @@ detailedStatusForPipeline :: ) => Id Project -> Id Pipeline -> - Sem r (Maybe BuildStatus) + Sem r (Maybe JobStatus) detailedStatusForPipeline projectId pipelineId = addContext "pipelineId" pipelineId $ do singlePipelineResult <- getSinglePipeline projectId pipelineId diff --git a/src/UseCases/Runners.hs b/src/UseCases/Runners.hs index aca6170..4917c0b 100644 --- a/src/UseCases/Runners.hs +++ b/src/UseCases/Runners.hs @@ -8,9 +8,11 @@ module UseCases.Runners (updateRunnersJobs) where import Config.Config (ProjectExcludeList (ProjectExcludeList)) import Core.Effects import Core.Runners -import Core.Shared import Data.List.Extra (nubOrdOn) import Data.Map (fromAscListWith, mapKeys) +import Gitlab.Group (Group) +import Gitlab.Lib (Id) +import Gitlab.Runner (Runner (..)) import Polysemy import Polysemy.Reader qualified as R import Relude diff --git a/src/UseCases/Shared.hs b/src/UseCases/Shared.hs index 6d2f631..721404a 100644 --- a/src/UseCases/Shared.hs +++ b/src/UseCases/Shared.hs @@ -2,7 +2,7 @@ module UseCases.Shared () where -import Core.Shared import Data.Aeson (ToJSON) +import Gitlab.Lib (Id (..)) deriving newtype instance ToJSON (Id a) diff --git a/stack.yaml b/stack.yaml index 5c958b1..1c0f7bb 100644 --- a/stack.yaml +++ b/stack.yaml @@ -7,6 +7,12 @@ extra-deps: - higgledy-0.4.2.1@sha256:51ed682047dfef1c3640a32adc59f1d350044dbb69ba04264462e7df11bc6c35,2380 - polysemy-time-0.7.0.0@sha256:da0a87c16fa520710e883e9669d55ea262643783eda492d1a1bc7b1a3cc63786,4123 - validation-selective-0.2.0.0@sha256:cc847f1a110e3b1bd437a5356f115881b61cafcb11781b570b180efd88bf0907,3917 + - validity-network-uri-0.0.0.1@sha256:ecb0b4e62b6a4620e1049340371441667a5ccbe5d76b225f74ac6767357da29a,926 + - validity-path-0.4.0.1@sha256:559046896c92ddb2b1f831c8d6b33a07246d9e98a6e27d226f451ee69af882d0,1432 + - github: L7R7/gitlab-api + commit: e3bd8278e19154adcf17ecad293d8ef07c1f006b + subdirs: + - gitlab-api-types ghc-options: $everything: -split-sections diff --git a/test/ConfigSpec.hs b/test/ConfigSpec.hs index 6ffb7fb..0c0dc68 100644 --- a/test/ConfigSpec.hs +++ b/test/ConfigSpec.hs @@ -5,6 +5,7 @@ module ConfigSpec where import Config.Config import Core.Shared +import Gitlab.Lib (Id (..), Url (..)) import Katip import Network.URI.Static import Relude diff --git a/test/GetStatusForProjectSpec.hs b/test/GetStatusForProjectSpec.hs index c475e99..3c6690c 100644 --- a/test/GetStatusForProjectSpec.hs +++ b/test/GetStatusForProjectSpec.hs @@ -6,8 +6,10 @@ module GetStatusForProjectSpec where import Config.Config (ExtraProjectsList (ExtraProjectsList), ProjectExcludeList (ProjectExcludeList)) import Core.BuildStatuses -import Core.Shared import Data.Map qualified as M +import Gitlab.Job (JobStatus (..)) +import Gitlab.Lib (Id (..), Name (..), Ref (..), Url (..)) +import Gitlab.Project import Network.URI.Static import Path import Polysemy @@ -46,7 +48,7 @@ spec = do ( M.fromList [ ( Id 42, [ Project (Id 312) (Name "myProj") (Url $$(staticURI "https://my.gitlab.com/projects/512/foo")) Nothing (ProjectNamespace (Id 12) (ProjectNamespaceFullPath $(mkRelDir "foo"))), - Project (Id 311) (Name "my-other-project") (Url $$(staticURI "https://my.gitlab.com/projects/311/bar")) (Just $ Ref "main") (ProjectNamespace (Id 13) (ProjectNamespaceFullPath $(mkRelDir "bar"))) + Project (Id 311) (Name "my-other-project") (Url $$(staticURI "https://my.gitlab.com/projects/311/bar")) (Just $ Ref "main") True FastForward (ProjectNamespace (Id 13) (ProjectNamespaceFullPath $(mkRelDir "bar"))) ] ) ] diff --git a/test/TestUtils.hs b/test/TestUtils.hs index 0644455..4e63267 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module TestUtils where @@ -7,6 +8,9 @@ import Core.BuildStatuses import Core.Effects import Core.Shared import Data.Map qualified as M +import Gitlab.Group (Group) +import Gitlab.Lib (Id (..), Ref (..)) +import Gitlab.Project (Project) import Polysemy import Relude @@ -35,3 +39,6 @@ noOpLogger = do AddContext _ _ action -> raise . noOpLogger =<< runT action AddContexts _ action -> raise . noOpLogger =<< runT action AddNamespace _ action -> raise . noOpLogger =<< runT action + +-- todo: ? +deriving newtype instance Ord (Ref)