Add first version of a metric for outgoing HTTP requests

This is a work in progress and is very heavy inspired by fimad/prometheus-haskell#22 (comment)

src/App.hs

@@ -7,7 +7,7 @@ module App where
 import Config
 import Core.Lib
 import Env
-import Inbound.HTTP.Metrics (HasPipelinesOverviewGauge (..), Metrics, currentPipelinesOverview)
+import Inbound.HTTP.Metrics (HasOutgoingHttpRequestsHistogram (..), HasPipelinesOverviewGauge (..), Metrics (..), currentPipelinesOverview)
 import Katip
 import RIO
 
@@ -49,4 +49,7 @@ instance HasUiUpdateInterval App where
   uiUpdateIntervalL = lens (uiUpdateIntervalSecs . config) (\app u -> app {config = (config app) {uiUpdateIntervalSecs = u}})
 
 instance HasPipelinesOverviewGauge App where
-  getPipelinesOverviewGaugeL = lens (currentPipelinesOverview . metrics) (\app cpo -> app {metrics = (metrics app) {currentPipelinesOverview = cpo}})
+  pipelinesOverviewGaugeL = lens (currentPipelinesOverview . metrics) (\app cpo -> app {metrics = (metrics app) {currentPipelinesOverview = cpo}})
+
+instance HasOutgoingHttpRequestsHistogram App where
+  outgoingHttpRequestsHistogramL = lens (outgoingHttpRequestsHistogram . metrics) (\app ohrh -> app {metrics = (metrics app) {outgoingHttpRequestsHistogram = ohrh}})

src/Inbound/HTTP/Metrics.hs

@@ -5,11 +5,13 @@
 
 module Inbound.HTTP.Metrics
   ( HasPipelinesOverviewGauge (..),
+    HasOutgoingHttpRequestsHistogram (..),
     Metrics (..),
     registerAppMetrics,
     registerGhcMetrics,
     updateMetricsRegularly,
     updatePipelinesOverviewMetric,
+    VectorWithLabel (..),
   )
 where
 
@@ -27,16 +29,21 @@ registerGhcMetrics = register ghcMetrics
 
 type PipelinesOverviewGauge = Vector Label1 Gauge
 
-newtype Metrics = Metrics {currentPipelinesOverview :: PipelinesOverviewGauge}
+type OutgoingHttpRequestsHistogram = Vector Label1 Histogram
+
+data Metrics = Metrics {currentPipelinesOverview :: PipelinesOverviewGauge, outgoingHttpRequestsHistogram :: OutgoingHttpRequestsHistogram}
 
 registerPipelinesOverviewMetric :: IO PipelinesOverviewGauge
 registerPipelinesOverviewMetric =
   register $
     vector "build_status" $
       gauge (Info "build_pipelines_by_status_gauge" "Gauge that indicates the count of the pipeline statuses grouped by their result")
 
+registerOutgoingHttpRequestsHistogram :: IO OutgoingHttpRequestsHistogram
+registerOutgoingHttpRequestsHistogram = register $ vector "path" $ histogram (Info "outgoing_http_requests_histogram" "Histogram indicating how long outgoing HTTP request durations") defaultBuckets
+
 registerAppMetrics :: IO Metrics
-registerAppMetrics = Metrics <$> registerPipelinesOverviewMetric
+registerAppMetrics = Metrics <$> registerPipelinesOverviewMetric <*> registerOutgoingHttpRequestsHistogram
 
 updatePipelinesOverviewMetric :: PipelinesOverviewGauge -> BuildStatuses -> IO ()
 updatePipelinesOverviewMetric _ NoSuccessfulUpdateYet = pure ()
@@ -61,7 +68,7 @@ resetValues = fromList $ (,0) <$> enumerate
 
 updateMetrics :: (HasBuildStatuses env, HasPipelinesOverviewGauge env) => RIO env ()
 updateMetrics = do
-  pipelinesGauge <- view getPipelinesOverviewGaugeL
+  pipelinesGauge <- view pipelinesOverviewGaugeL
   statuses <- getStatuses
   liftIO $ updatePipelinesOverviewMetric pipelinesGauge statuses
 
@@ -71,7 +78,17 @@ updateMetricsRegularly = forever $ do
   threadDelay $ 10 * 1000000
 
 class HasPipelinesOverviewGauge env where
-  getPipelinesOverviewGaugeL :: Lens' env PipelinesOverviewGauge
+  pipelinesOverviewGaugeL :: Lens' env PipelinesOverviewGauge
+
+class HasOutgoingHttpRequestsHistogram env where
+  outgoingHttpRequestsHistogramL :: Lens' env OutgoingHttpRequestsHistogram
 
 countOccurrences :: (Ord k, Num a) => (t -> k) -> [t] -> Map k a
 countOccurrences f xs = fromListWith (+) [(f x, 1) | x <- xs]
+
+data VectorWithLabel l m = VectorWithLabel (Vector l m) l
+
+instance (Label l, Observer m) => Observer (VectorWithLabel l m) where
+  observe (VectorWithLabel vctr label) value = withLabel vctr label f
+    where
+      f metric = observe metric value

src/Outbound/Gitlab/GitlabAPI.hs

@@ -10,14 +10,16 @@ import Core.Lib (GroupId, HasGetPipelines (..), HasGetProjects (..), PipelineId
 import Data.Aeson (FromJSON)
 import Data.Coerce (coerce)
 import Env (HasApiToken, apiTokenL, baseUrlL, groupIdL)
+import Inbound.HTTP.Metrics
 import Network.HTTP.Simple (Request, getResponseBody, httpJSONEither, parseRequest_, setRequestHeader)
+import Prometheus (observeDuration)
 import RIO
 
 instance HasGetProjects App where
   getProjects = do
     baseUrl <- view baseUrlL
     group <- view groupIdL
-    fetchData $ projectsRequest baseUrl group
+    fetchData "/api/v4/groups/{groupId}/projects" $ projectsRequest baseUrl group
 
 projectsRequest :: BaseUrl -> GroupId -> Request
 projectsRequest baseUrl gId =
@@ -26,19 +28,20 @@ projectsRequest baseUrl gId =
 instance HasGetPipelines App where
   getPipelines pId = do
     baseUrl <- view baseUrlL
-    fetchData $ pipelinesRequest baseUrl pId
+    fetchData "/api/v4/projects/{projectId}/pipelines" $ pipelinesRequest baseUrl pId
   getSinglePipeline project pipeline = do
     baseUrl <- view baseUrlL
-    fetchData $ singlePipelineRequest baseUrl project pipeline
+    fetchData "/api/v4/projects/{projectId}/pipelines/{pipelineId}" $ singlePipelineRequest baseUrl project pipeline
 
 pipelinesRequest :: BaseUrl -> ProjectId -> Request
 pipelinesRequest (BaseUrl baseUrl) (ProjectId i) = parseRequest_ $ mconcat [baseUrl, "/api/v4/projects/", show i, "/pipelines?scope=branches"]
 
 singlePipelineRequest :: BaseUrl -> ProjectId -> PipelineId -> Request
 singlePipelineRequest (BaseUrl baseUrl) (ProjectId project) (PipelineId pipeline) = parseRequest_ $ mconcat [baseUrl, "/api/v4/projects/", show project, "/pipelines/", show pipeline]
 
-fetchData :: (HasApiToken env, FromJSON a) => Request -> RIO env (Either UpdateError a)
-fetchData request = do
+fetchData :: (HasApiToken env, HasOutgoingHttpRequestsHistogram env, FromJSON a) => Text -> Request -> RIO env (Either UpdateError a)
+fetchData metricLabel request = do
   token <- view apiTokenL
-  result <- try (mapLeft ConversionError . getResponseBody <$> httpJSONEither (setRequestHeader "PRIVATE-TOKEN" [coerce token] request))
+  histogram <- view outgoingHttpRequestsHistogramL
+  result <- liftIO $ observeDuration (VectorWithLabel histogram metricLabel) (try (mapLeft ConversionError . getResponseBody <$> httpJSONEither (setRequestHeader "PRIVATE-TOKEN" [coerce token] request)))
   pure . join $ mapLeft HttpError result