From 2ccd1cdac9e850ed6e0c1ac2ddf5df1f40c5849a Mon Sep 17 00:00:00 2001 From: Diego Diverio Date: Wed, 28 Dec 2022 10:26:16 +0100 Subject: [PATCH 1/9] Add metrics server to Hoff. --- app/Main.hs | 5 ++++- hoff.cabal | 4 ++++ nix/haskell-dependencies.nix | 2 ++ src/Metrics/Metrics.hs | 23 +++++++++++++++++++++++ src/Metrics/Server.hs | 26 ++++++++++++++++++++++++++ stack-shell.nix | 2 +- 6 files changed, 60 insertions(+), 2 deletions(-) create mode 100644 src/Metrics/Metrics.hs create mode 100644 src/Metrics/Server.hs diff --git a/app/Main.hs b/app/Main.hs index 668d11d9..fc98d62c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -30,6 +30,8 @@ import Project (ProjectState, emptyProjectState, loadProjectState, saveProjectSt import Project (ProjectInfo (ProjectInfo), Owner) import Server (buildServer) +import Metrics.Server + import qualified Paths_hoff (version) import qualified Configuration as Config @@ -234,7 +236,8 @@ runMain options = do putStrLn $ "Listening for webhooks on port " ++ (show port) ++ "." runServer <- fmap fst $ buildServer port tlsConfig infos secret ghTryEnqueue getProjectState getOwnerState serverThread <- Async.async runServer + metricsThread <- Async.async $ runMetricsServer defaultServerConfig -- Note that a stop signal is never enqueued. The application just runs until -- until it is killed, or until any of the threads stop due to an exception. - void $ Async.waitAny $ serverThread : ghThread : projectThreads + void $ Async.waitAny $ metricsThread : serverThread : ghThread : projectThreads diff --git a/hoff.cabal b/hoff.cabal index f6043349..c0fc21d0 100644 --- a/hoff.cabal +++ b/hoff.cabal @@ -28,6 +28,8 @@ library , Logic , Project , Server + , Metrics.Server + , Metrics.Metrics , Time , Types , WebInterface @@ -53,6 +55,7 @@ library , monad-logger , process , process-extras + , prometheus-client , scotty , stm , text @@ -60,6 +63,7 @@ library , time , vector , wai + , wai-middleware-prometheus , warp , warp-tls other-modules: Paths_hoff diff --git a/nix/haskell-dependencies.nix b/nix/haskell-dependencies.nix index 6dc90ffa..10d9a118 100644 --- a/nix/haskell-dependencies.nix +++ b/nix/haskell-dependencies.nix @@ -29,6 +29,7 @@ haskellPackages: with haskellPackages; [ optparse-applicative process process-extras + prometheus scotty stm text @@ -37,6 +38,7 @@ haskellPackages: with haskellPackages; [ uuid vector wai + wai-middleware-prometheus warp warp-tls ] diff --git a/src/Metrics/Metrics.hs b/src/Metrics/Metrics.hs new file mode 100644 index 00000000..ad5d1b30 --- /dev/null +++ b/src/Metrics/Metrics.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} +module Metrics.Metrics where + +import Prometheus + +data ProjectMetrics = ProjectMetrics + { projectMetricsProcessedPR :: Counter + , projectMetricsMergedPR :: Counter + , projectMetricsFailedPR :: Counter + , projectMetricsQueueAdded :: Counter + , projectMetricsQueueRemoved :: Counter + } + +registerProjectMetrics :: IO ProjectMetrics +registerProjectMetrics = ProjectMetrics + <$> register (counter (Info "hoff_project_processed_pull_requests" + "Number of processed pull requests")) + <*> register (counter (Info "hoff_project_merged_pull_requests" + "Number of merged pull requests")) + <*> register (counter (Info "hoff_project_failed_pull_requests" + "Number of failed pull requests")) + <*> register (counter (Info "hoff_project_queue_added" "Number of items added to the queue")) + <*> register (counter (Info "hoff_project_queue_added" "Number of items removed from the queue")) diff --git a/src/Metrics/Server.hs b/src/Metrics/Server.hs new file mode 100644 index 00000000..fa079bfb --- /dev/null +++ b/src/Metrics/Server.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Metrics.Server where + +import qualified Network.Wai.Handler.Warp as Warp +import qualified Network.Wai.Middleware.Prometheus as PrometheusWai +import Data.Function ((&)) + +data MetricsServerConfig = MetricsServerConfig + { metricsConfigHost :: Warp.HostPreference + , metricsConfigPort :: Warp.Port + } + +defaultServerConfig :: MetricsServerConfig +defaultServerConfig = MetricsServerConfig + { metricsConfigHost = "*" + , metricsConfigPort = 3001 + } + +serverConfig :: MetricsServerConfig -> Warp.Settings +serverConfig config = Warp.defaultSettings + & Warp.setHost (metricsConfigHost config) + & Warp.setPort (metricsConfigPort config) + +runMetricsServer :: MetricsServerConfig -> IO () +runMetricsServer config = Warp.runSettings (serverConfig config) PrometheusWai.metricsApp diff --git a/stack-shell.nix b/stack-shell.nix index 07bda9b2..f44decdb 100644 --- a/stack-shell.nix +++ b/stack-shell.nix @@ -5,7 +5,7 @@ let mkDependencies = import ./nix/haskell-dependencies.nix; in nixpkgs.haskell.lib.buildStackProject { - name = "sharkmachine"; + name = "hoff"; # Not the GHC given by stack! ghc = nixpkgs.haskellPackages.ghcWithHoogle mkDependencies; buildInputs = with nixpkgs; [ From 155a63ee9e8ee58a99d473d10c52cdaae99d5182 Mon Sep 17 00:00:00 2001 From: Diego Diverio Date: Wed, 28 Dec 2022 14:21:41 +0100 Subject: [PATCH 2/9] Add option to set the port on which the metrics server runs.. --- app/Main.hs | 14 +++++++++++--- src/Configuration.hs | 14 +++++++++++++- 2 files changed, 24 insertions(+), 4 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index fc98d62c..c39467f9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -14,6 +14,7 @@ import Control.Monad (forM, unless, void) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger (runStdoutLoggingT) import Data.List (zip4) +import Data.Maybe (maybeToList) import Data.Version (showVersion) import System.Exit (die) import System.IO (BufferMode (LineBuffering), hSetBuffering, stderr, stdout) @@ -24,7 +25,7 @@ import qualified GitHub.Auth as Github3 import qualified System.Directory as FileSystem import qualified Options.Applicative as Opts -import Configuration (Configuration) +import Configuration (Configuration, MetricsConfiguration (..)) import EventLoop (runGithubEventLoop, runLogicEventLoop) import Project (ProjectState, emptyProjectState, loadProjectState, saveProjectState) import Project (ProjectInfo (ProjectInfo), Owner) @@ -236,8 +237,15 @@ runMain options = do putStrLn $ "Listening for webhooks on port " ++ (show port) ++ "." runServer <- fmap fst $ buildServer port tlsConfig infos secret ghTryEnqueue getProjectState getOwnerState serverThread <- Async.async runServer - metricsThread <- Async.async $ runMetricsServer defaultServerConfig + metricsThread <- runMetricsThread config -- Note that a stop signal is never enqueued. The application just runs until -- until it is killed, or until any of the threads stop due to an exception. - void $ Async.waitAny $ metricsThread : serverThread : ghThread : projectThreads + void $ Async.waitAny $ [serverThread, ghThread] ++ metricsThread ++ projectThreads + +runMetricsThread :: Configuration -> IO [Async.Async ()] +runMetricsThread configuration = + forM (maybeToList $ Config.metricsConfig configuration) $ + \metricsConf -> do + let servConfig = defaultServerConfig { metricsConfigPort = metricsPort metricsConf } + Async.async $ runMetricsServer servConfig diff --git a/src/Configuration.hs b/src/Configuration.hs index 443b7e64..a08cae8a 100644 --- a/src/Configuration.hs +++ b/src/Configuration.hs @@ -15,6 +15,7 @@ module Configuration TriggerConfiguration (..), UserConfiguration (..), MergeWindowExemptionConfiguration (..), + MetricsConfiguration (..), loadConfiguration ) where @@ -24,6 +25,7 @@ import Data.ByteString (readFile) import Data.Text (Text) import GHC.Generics import Prelude hiding (readFile) +import qualified Network.Wai.Handler.Warp as Warp data ProjectConfiguration = ProjectConfiguration { @@ -62,6 +64,12 @@ data TlsConfiguration = TlsConfiguration } deriving (Generic, Show) +data MetricsConfiguration = MetricsConfiguration + { + metricsPort :: Warp.Port + } + deriving (Generic, Show) + newtype MergeWindowExemptionConfiguration = MergeWindowExemptionConfiguration [Text] deriving (Generic, Show) @@ -95,7 +103,10 @@ data Configuration = Configuration -- List of users that are exempted from the merge window. This is useful for -- bots that automatically merge low impact changes. - mergeWindowExemption :: MergeWindowExemptionConfiguration + mergeWindowExemption :: MergeWindowExemptionConfiguration, + + -- Configuration for the Prometheus metrics server. + metricsConfig :: Maybe MetricsConfiguration } deriving (Generic) @@ -105,6 +116,7 @@ instance FromJSON TlsConfiguration instance FromJSON TriggerConfiguration instance FromJSON UserConfiguration instance FromJSON MergeWindowExemptionConfiguration +instance FromJSON MetricsConfiguration -- Reads and parses the configuration. Returns Nothing if parsing failed, but -- crashes if the file could not be read. From 76434c35da805131cb54a82b27ca2a978f74e1d3 Mon Sep 17 00:00:00 2001 From: Diego Diverio Date: Wed, 28 Dec 2022 16:54:52 +0100 Subject: [PATCH 3/9] Refactor. --- app/Main.hs | 125 ++++++++++++++++++++++------------------- src/Logic.hs | 1 + src/Metrics/Metrics.hs | 41 +++++++++----- 3 files changed, 97 insertions(+), 70 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index c39467f9..77511209 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -95,6 +95,11 @@ initializeProjectState fname = do main :: IO () main = Opts.execParser commandLineParser >>= runMain +getProjectInfo :: Config.ProjectConfiguration -> ProjectInfo +getProjectInfo pconfig = ProjectInfo owner repository + where owner = Config.owner pconfig + repository = Config.repository pconfig + runMain :: Options -> IO () runMain options = do -- When the runtime detects that stdout is not connected to a console, it @@ -128,11 +133,7 @@ runMain options = do -- up, so the server will reject new events). projectQueues <- forM (Config.projects config) $ \ pconfig -> do projectQueue <- Logic.newEventQueue 10 - let - owner = Config.owner pconfig - repository = Config.repository pconfig - projectInfo = ProjectInfo owner repository - return (projectInfo, projectQueue) + return (getProjectInfo pconfig, projectQueue) -- Define a function that enqueues an event in the right project queue. let @@ -150,12 +151,7 @@ runMain options = do -- Restore the previous state from disk if possible, or start clean. projectStates <- forM (Config.projects config) $ \ pconfig -> do projectState <- initializeProjectState (Config.stateFile pconfig) - let - -- TODO: DRY. - owner = Config.owner pconfig - repository = Config.repository pconfig - projectInfo = ProjectInfo owner repository - return (projectInfo, projectState) + return (getProjectInfo pconfig, projectState) -- Keep track of the most recent state for every project, so the webinterface -- can use it to serve a status page. @@ -168,21 +164,77 @@ runMain options = do -- TODO: This is very, very ugly. Get these per-project collections sorted -- out. zipped = zip4 (Config.projects config) projectQueues stateVars projectStates - tuples = map (\(cfg, (_, a), (_, b), (_, c)) -> (cfg, a, b, c)) zipped - projectThreads <- forM tuples $ \ (projectConfig, projectQueue, stateVar, projectState) -> do + tuples = map (\(cfg, (_, a), (_, b), (_, c)) -> ProjectThreadData cfg a b c) zipped + projectThreads <- forM tuples $ projectThread config options + + let + -- When the webhook server receives an event, enqueue it on the webhook + -- event queue if it is not full. + ghTryEnqueue = Github.tryEnqueueEvent ghQueue + + -- Allow the webinterface to retrieve the latest project state per project. + getProjectState projectInfo = + fmap Logic.readStateVar $ lookup projectInfo stateVars + getOwnerState :: Owner -> IO [(ProjectInfo, ProjectState)] + getOwnerState owner = do + let states = filter (\(projectInfo, _) -> Project.owner projectInfo == owner) stateVars + mapM (\(info, state) -> Logic.readStateVar state >>= \sVar -> pure (info, sVar)) states + + let + port = Config.port config + tlsConfig = Config.tls config + secret = Config.secret config + -- TODO: Do this in a cleaner way. + infos = getProjectInfo <$> Config.projects config + putStrLn $ "Listening for webhooks on port " ++ show port ++ "." + runServer <- fst <$> buildServer port tlsConfig infos secret ghTryEnqueue getProjectState getOwnerState + serverThread <- Async.async runServer + metricsThread <- runMetricsThread config + + -- Note that a stop signal is never enqueued. The application just runs until + -- until it is killed, or until any of the threads stop due to an exception. + void $ Async.waitAny $ [serverThread, ghThread] ++ metricsThread ++ projectThreads + +data ProjectThreadData = ProjectThreadData + { projectThreadConfig :: Config.ProjectConfiguration + , projectThreadQueue :: Logic.EventQueue + , projectThreadStateVar :: Logic.StateVar + , projectThreadState :: ProjectState + } + +projectThread :: Configuration + -> Options + -> ProjectThreadData + -> IO (Async.Async ()) +projectThread config options projectThreadData = do -- At startup, enqueue a synchronize event. This will bring the state in -- sync with the current state of GitHub, accounting for any webhooks that -- we missed while not running, or just to fill the state initially after -- setting up a new project. liftIO $ Logic.enqueueEvent projectQueue Logic.Synchronize - - let + -- Start a worker thread to run the main event loop for the project. + Async.async + $ void + $ runStdoutLoggingT + $ runLogicEventLoop + (Config.trigger config) + projectConfig + (Config.mergeWindowExemption config) + runTime + runGit + runGithub + getNextEvent + publish + (projectThreadState projectThreadData) + where -- When the event loop publishes the current project state, save it to -- the configured file, and make the new state available to the -- webinterface. + projectConfig = projectThreadConfig projectThreadData + projectQueue = projectThreadQueue projectThreadData publish newState = do liftIO $ saveProjectState (Config.stateFile projectConfig) newState - liftIO $ Logic.updateStateVar stateVar newState + liftIO $ Logic.updateStateVar (projectThreadStateVar projectThreadData) newState -- When the event loop wants to get the next event, take one off the queue. getNextEvent = liftIO $ Logic.dequeueEvent projectQueue @@ -200,48 +252,7 @@ runMain options = do then GithubApi.runGithubReadOnly auth projectInfo else GithubApi.runGithub auth projectInfo runTime = Time.runTime - -- Start a worker thread to run the main event loop for the project. - Async.async - $ void - $ runStdoutLoggingT - $ runLogicEventLoop - (Config.trigger config) - projectConfig - (Config.mergeWindowExemption config) - runTime - runGit - runGithub - getNextEvent - publish - projectState - - let - -- When the webhook server receives an event, enqueue it on the webhook - -- event queue if it is not full. - ghTryEnqueue = Github.tryEnqueueEvent ghQueue - - -- Allow the webinterface to retrieve the latest project state per project. - getProjectState projectInfo = - fmap Logic.readStateVar $ lookup projectInfo stateVars - getOwnerState :: Owner -> IO [(ProjectInfo, ProjectState)] - getOwnerState owner = do - let states = filter (\(projectInfo, _) -> Project.owner projectInfo == owner) stateVars - mapM (\(info, state) -> Logic.readStateVar state >>= \sVar -> pure (info, sVar)) states - - let - port = Config.port config - tlsConfig = Config.tls config - secret = Config.secret config - -- TODO: Do this in a cleaner way. - infos = fmap (\ pc -> ProjectInfo (Config.owner pc) (Config.repository pc)) $ Config.projects config - putStrLn $ "Listening for webhooks on port " ++ (show port) ++ "." - runServer <- fmap fst $ buildServer port tlsConfig infos secret ghTryEnqueue getProjectState getOwnerState - serverThread <- Async.async runServer - metricsThread <- runMetricsThread config - -- Note that a stop signal is never enqueued. The application just runs until - -- until it is killed, or until any of the threads stop due to an exception. - void $ Async.waitAny $ [serverThread, ghThread] ++ metricsThread ++ projectThreads runMetricsThread :: Configuration -> IO [Async.Async ()] runMetricsThread configuration = diff --git a/src/Logic.hs b/src/Logic.hs index 9b59fe0d..40d67eef 100644 --- a/src/Logic.hs +++ b/src/Logic.hs @@ -18,6 +18,7 @@ module Logic Event (..), EventQueue, IntegrationFailure (..), + StateVar, dequeueEvent, enqueueEvent, enqueueStopSignal, diff --git a/src/Metrics/Metrics.hs b/src/Metrics/Metrics.hs index ad5d1b30..f7b564d7 100644 --- a/src/Metrics/Metrics.hs +++ b/src/Metrics/Metrics.hs @@ -1,23 +1,38 @@ {-# LANGUAGE OverloadedStrings #-} module Metrics.Metrics where +import Data.Text import Prometheus +type ProjectLabel = Text + data ProjectMetrics = ProjectMetrics - { projectMetricsProcessedPR :: Counter - , projectMetricsMergedPR :: Counter - , projectMetricsFailedPR :: Counter - , projectMetricsQueueAdded :: Counter - , projectMetricsQueueRemoved :: Counter + { projectMetricsProcessedPR :: Vector ProjectLabel Counter + , projectMetricsMergedPR :: Vector ProjectLabel Counter + , projectMetricsFailedPR :: Vector ProjectLabel Counter + , projectMetricsQueueAdded :: Vector ProjectLabel Counter + , projectMetricsQueueRemoved :: Vector ProjectLabel Counter } registerProjectMetrics :: IO ProjectMetrics registerProjectMetrics = ProjectMetrics - <$> register (counter (Info "hoff_project_processed_pull_requests" - "Number of processed pull requests")) - <*> register (counter (Info "hoff_project_merged_pull_requests" - "Number of merged pull requests")) - <*> register (counter (Info "hoff_project_failed_pull_requests" - "Number of failed pull requests")) - <*> register (counter (Info "hoff_project_queue_added" "Number of items added to the queue")) - <*> register (counter (Info "hoff_project_queue_added" "Number of items removed from the queue")) + <$> register (vector "project" (counter (Info "hoff_project_processed_pull_requests" + "Number of processed pull requests"))) + <*> register (vector "project" (counter (Info "hoff_project_merged_pull_requests" + "Number of merged pull requests"))) + <*> register (vector "project" (counter (Info "hoff_project_failed_pull_requests" + "Number of failed pull requests"))) + <*> register (vector "project" (counter (Info "hoff_project_queue_added" "Number of items added to the queue"))) + <*> register (vector "project" (counter (Info "hoff_project_queue_added" "Number of items removed from the queue"))) + +incProjectProcessedPR :: ProjectMetrics -> ProjectLabel -> IO () +incProjectProcessedPR metrics project = + withLabel (projectMetricsProcessedPR metrics) project incCounter + +incProjectMergedPR :: ProjectMetrics -> ProjectLabel -> IO () +incProjectMergedPR metrics project = + withLabel (projectMetricsMergedPR metrics) project incCounter + +incProjectFailedPR :: ProjectMetrics -> ProjectLabel -> IO () +incProjectFailedPR metrics project = + withLabel (projectMetricsFailedPR metrics) project incCounter From ffcca38a20107fd6c65fe7d1ff04c262d5f4502b Mon Sep 17 00:00:00 2001 From: Diego Diverio Date: Mon, 2 Jan 2023 13:07:56 +0100 Subject: [PATCH 4/9] Added support for a metric counting the number of merges per project. --- app/Main.hs | 13 +++++++++---- doc/example-dev-config.json | 3 +++ src/EventLoop.hs | 8 ++++++-- src/Logic.hs | 15 ++++++++++++-- src/Metrics/Metrics.hs | 39 +++++++++++++++++++++++++++++++++++-- 5 files changed, 68 insertions(+), 10 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 77511209..7c985509 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -31,6 +31,7 @@ import Project (ProjectState, emptyProjectState, loadProjectState, saveProjectSt import Project (ProjectInfo (ProjectInfo), Owner) import Server (buildServer) +import qualified Metrics.Metrics as Metrics import Metrics.Server import qualified Paths_hoff (version) @@ -161,11 +162,10 @@ runMain options = do -- Start a main event loop for every project. let - -- TODO: This is very, very ugly. Get these per-project collections sorted - -- out. zipped = zip4 (Config.projects config) projectQueues stateVars projectStates tuples = map (\(cfg, (_, a), (_, b), (_, c)) -> ProjectThreadData cfg a b c) zipped - projectThreads <- forM tuples $ projectThread config options + metrics <- Metrics.registerProjectMetrics + projectThreads <- forM tuples $ projectThread config options metrics let -- When the webhook server receives an event, enqueue it on the webhook @@ -204,9 +204,10 @@ data ProjectThreadData = ProjectThreadData projectThread :: Configuration -> Options + -> Metrics.ProjectMetrics -> ProjectThreadData -> IO (Async.Async ()) -projectThread config options projectThreadData = do +projectThread config options metrics projectThreadData = do -- At startup, enqueue a synchronize event. This will bring the state in -- sync with the current state of GitHub, accounting for any webhooks that -- we missed while not running, or just to fill the state initially after @@ -215,11 +216,14 @@ projectThread config options projectThreadData = do -- Start a worker thread to run the main event loop for the project. Async.async $ void + -- Implement a newtype for a logging monad that also embodies MonadMonitor $ runStdoutLoggingT + $ Metrics.runLoggingMonitorT $ runLogicEventLoop (Config.trigger config) projectConfig (Config.mergeWindowExemption config) + runMetrics runTime runGit runGithub @@ -252,6 +256,7 @@ projectThread config options projectThreadData = do then GithubApi.runGithubReadOnly auth projectInfo else GithubApi.runGithub auth projectInfo runTime = Time.runTime + runMetrics = Metrics.runMetrics metrics (Config.repository projectConfig) runMetricsThread :: Configuration -> IO [Async.Async ()] diff --git a/doc/example-dev-config.json b/doc/example-dev-config.json index c7867ad5..58d1b43d 100644 --- a/doc/example-dev-config.json +++ b/doc/example-dev-config.json @@ -19,5 +19,8 @@ "mergeWindowExemption": ["hoffbot"], "trigger": { "commentPrefix": "@hoffbot" + }, + "metrics": { + "metricsPort": "3333" } } diff --git a/src/EventLoop.hs b/src/EventLoop.hs index 2355b7c6..bd527980 100644 --- a/src/EventLoop.hs +++ b/src/EventLoop.hs @@ -42,6 +42,8 @@ import qualified Github import qualified GithubApi import qualified Logic import qualified Project +import Prometheus (MonadMonitor) +import qualified Metrics.Metrics as Metrics eventFromPullRequestPayload :: PullRequestPayload -> Logic.Event eventFromPullRequestPayload payload = @@ -128,10 +130,12 @@ runSum runF runG = go runLogicEventLoop :: MonadIO m => MonadLogger m + => MonadMonitor m => TriggerConfiguration -> ProjectConfiguration -> MergeWindowExemptionConfiguration -- Interpreters for Git and GitHub actions. + -> (forall a. Metrics.MetricsOperationFree a -> m a) -> (forall a. Time.TimeOperationFree a -> m a) -> (forall a. Git.GitOperationFree a -> m a) -> (forall a. GithubApi.GithubOperationFree a -> m a) @@ -145,10 +149,10 @@ runLogicEventLoop -> m ProjectState runLogicEventLoop triggerConfig projectConfig mergeWindowExemptionConfig - runTime runGit runGithub + runMetrics runTime runGit runGithub getNextEvent publish initialState = let - runAll = foldFree (runSum runTime (runSum runGit runGithub)) + runAll = foldFree (runSum (runSum runMetrics runTime) (runSum runGit runGithub)) runAction = Logic.runAction projectConfig handleAndContinue state0 event = do diff --git a/src/Logic.hs b/src/Logic.hs index 40d67eef..3d310456 100644 --- a/src/Logic.hs +++ b/src/Logic.hs @@ -74,6 +74,7 @@ import qualified Git import qualified GithubApi import qualified Project as Pr import qualified Time +import Metrics.Metrics data ActionFree a = TryIntegrate @@ -94,6 +95,7 @@ data ActionFree a | GetLatestVersion Sha (Either TagName Integer -> a) | GetChangelog TagName Sha (Maybe Text -> a) | GetDateTime (UTCTime -> a) + | IncreaseMergeMetric a deriving (Functor) data PRCloseCause = @@ -103,7 +105,7 @@ data PRCloseCause = type Action = Free ActionFree -type Operation = Free (Sum TimeOperationFree (Sum GitOperationFree GithubOperationFree)) +type Operation = Free (Sum (Sum MetricsOperationFree TimeOperationFree) (Sum GitOperationFree GithubOperationFree)) type PushWithTagResult = (Either Text TagName, PushResult) @@ -113,7 +115,7 @@ type PushWithTagResult = (Either Text TagName, PushResult) data IntegrationFailure = IntegrationFailure BaseBranch GitIntegrationFailure doTime :: TimeOperation a -> Operation a -doTime = hoistFree InL +doTime = hoistFree (InL . InR) doGit :: GitOperation a -> Operation a doGit = hoistFree (InR . InL) @@ -121,6 +123,9 @@ doGit = hoistFree (InR . InL) doGithub :: GithubOperation a -> Operation a doGithub = hoistFree (InR . InR) +doMetrics :: MetricsOperation a -> Operation a +doMetrics = hoistFree (InL . InL) + tryIntegrate :: Text -> (PullRequestId, Branch, Sha) -> [PullRequestId] -> Bool -> Action (Either IntegrationFailure Sha) tryIntegrate mergeMessage candidate train alwaysAddMergeCommit = liftF $ TryIntegrate mergeMessage candidate train alwaysAddMergeCommit id @@ -161,6 +166,9 @@ getChangelog prevTag curHead = liftF $ GetChangelog prevTag curHead id getDateTime :: Action UTCTime getDateTime = liftF $ GetDateTime id +registerMergedPR :: Action () +registerMergedPR = liftF $ IncreaseMergeMetric () + -- | Interpreter that translates high-level actions into more low-level ones. runAction :: ProjectConfiguration -> Action a -> Operation a runAction config = foldFree $ \case @@ -232,6 +240,8 @@ runAction config = foldFree $ \case GetDateTime cont -> doTime $ cont <$> Time.getDateTime + IncreaseMergeMetric cont -> doMetrics $ cont <$ increaseMergedPRTotal + where trainBranch :: [PullRequestId] -> Maybe Git.Branch trainBranch [] = Nothing @@ -813,6 +823,7 @@ pushCandidate (pullRequestId, pullRequest) newHead state = -- the integration candidate, so we proceed with the next pull request. PushOk -> do cleanupTestBranch pullRequestId + registerMergedPR pure $ Pr.updatePullRequests (unspeculateConflictsAfter pullRequest) $ Pr.updatePullRequests (unspeculateFailuresAfter pullRequest) $ Pr.setIntegrationStatus pullRequestId Promoted state diff --git a/src/Metrics/Metrics.hs b/src/Metrics/Metrics.hs index f7b564d7..7eb836ab 100644 --- a/src/Metrics/Metrics.hs +++ b/src/Metrics/Metrics.hs @@ -1,8 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Metrics.Metrics where import Data.Text import Prometheus +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Free (Free) +import Control.Monad.Logger (LoggingT, MonadLogger) +import Control.Monad.Free.Ap (liftF) type ProjectLabel = Text @@ -14,6 +20,35 @@ data ProjectMetrics = ProjectMetrics , projectMetricsQueueRemoved :: Vector ProjectLabel Counter } +data MetricsOperationFree a + = MergeBranch a + | MergeFailure a + deriving (Functor) + +type MetricsOperation = Free MetricsOperationFree + +newtype LoggingMonitorT m a = LoggingMonitorT { runLoggingMonitorT :: LoggingT m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadLogger) + +instance MonadIO m => MonadMonitor (LoggingMonitorT m) where + doIO = liftIO + +increaseMergedPRTotal :: MetricsOperation () +increaseMergedPRTotal = liftF $ MergeBranch () + +runMetrics + :: (MonadMonitor m, MonadIO m) + => ProjectMetrics + -> ProjectLabel + -> MetricsOperationFree a + -> m a +runMetrics metrics label operation = + case operation of + MergeBranch cont -> cont <$ + incProjectMergedPR metrics label + MergeFailure cont -> cont <$ + incProjectFailedPR metrics label + registerProjectMetrics :: IO ProjectMetrics registerProjectMetrics = ProjectMetrics <$> register (vector "project" (counter (Info "hoff_project_processed_pull_requests" @@ -29,10 +64,10 @@ incProjectProcessedPR :: ProjectMetrics -> ProjectLabel -> IO () incProjectProcessedPR metrics project = withLabel (projectMetricsProcessedPR metrics) project incCounter -incProjectMergedPR :: ProjectMetrics -> ProjectLabel -> IO () +incProjectMergedPR :: (MonadMonitor m, MonadIO m) => ProjectMetrics -> ProjectLabel -> m () incProjectMergedPR metrics project = withLabel (projectMetricsMergedPR metrics) project incCounter -incProjectFailedPR :: ProjectMetrics -> ProjectLabel -> IO () +incProjectFailedPR :: (MonadMonitor m, MonadIO m) => ProjectMetrics -> ProjectLabel -> m () incProjectFailedPR metrics project = withLabel (projectMetricsFailedPR metrics) project incCounter From 7986ac030f78586d3ed049811570e4211b5438e1 Mon Sep 17 00:00:00 2001 From: Diego Diverio Date: Mon, 2 Jan 2023 14:27:33 +0100 Subject: [PATCH 5/9] Refactor and add stylish-haskell to Nix imports. --- app/Main.hs | 5 +++-- default.nix | 1 + nix/haskell-dependencies.nix | 1 + src/Logic.hs | 4 ++-- src/Metrics/Metrics.hs | 38 +++++++++++++----------------------- src/Metrics/Server.hs | 15 +++++++------- 6 files changed, 28 insertions(+), 36 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 7c985509..5b367c45 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -256,12 +256,13 @@ projectThread config options metrics projectThreadData = do then GithubApi.runGithubReadOnly auth projectInfo else GithubApi.runGithub auth projectInfo runTime = Time.runTime - runMetrics = Metrics.runMetrics metrics (Config.repository projectConfig) + runMetrics = Metrics.runMetrics metrics $ Config.repository projectConfig runMetricsThread :: Configuration -> IO [Async.Async ()] runMetricsThread configuration = forM (maybeToList $ Config.metricsConfig configuration) $ \metricsConf -> do - let servConfig = defaultServerConfig { metricsConfigPort = metricsPort metricsConf } + let servConfig = MetricsServerConfig + { metricsConfigPort = metricsPort metricsConf, metricsConfigHost = "*" } Async.async $ runMetricsServer servConfig diff --git a/default.nix b/default.nix index 0d56e6b0..39f28897 100644 --- a/default.nix +++ b/default.nix @@ -8,6 +8,7 @@ in pkgs.dpkg pkgs.git pkgs.haskellPackages.haskell-language-server + pkgs.haskellPackages.stylish-haskell pkgs.niv pkgs.shellcheck pkgs.stack diff --git a/nix/haskell-dependencies.nix b/nix/haskell-dependencies.nix index 10d9a118..41cbf1b6 100644 --- a/nix/haskell-dependencies.nix +++ b/nix/haskell-dependencies.nix @@ -31,6 +31,7 @@ haskellPackages: with haskellPackages; [ process-extras prometheus scotty + stylish-haskell stm text text-format diff --git a/src/Logic.hs b/src/Logic.hs index 3d310456..20944ef1 100644 --- a/src/Logic.hs +++ b/src/Logic.hs @@ -522,7 +522,7 @@ handleCommentAdded triggerConfig projectConfig mergeWindowExemption prId author -- take no further action Unknown command -> do let prefix = Text.toCaseFold $ Config.commentPrefix triggerConfig - cmdstr = fmap Text.strip $ Text.stripPrefix prefix command + cmdstr = Text.strip <$> Text.stripPrefix prefix command comment = case cmdstr of Just str -> "`" <> str <> "` was not recognized as a valid command." Nothing -> "That was not a valid command." @@ -803,7 +803,7 @@ pushCandidate (pullRequestId, pullRequest) newHead state = mChangelog <- getChangelog previousTag newHead let tagName = versionToTag $ v + 1 - changelog = maybe "Failed to get the changelog" id mChangelog + changelog = fromMaybe "Failed to get the changelog" mChangelog tagMessage = messageForTag tagName approvalKind changelog (tagResult, pushResult) <- tryPromoteWithTag prBranch newHead tagName tagMessage when (pushResult == PushOk) $ commentToUser $ diff --git a/src/Metrics/Metrics.hs b/src/Metrics/Metrics.hs index 7eb836ab..c56f4478 100644 --- a/src/Metrics/Metrics.hs +++ b/src/Metrics/Metrics.hs @@ -1,7 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Metrics.Metrics where + +module Metrics.Metrics +( + MetricsOperation, + MetricsOperationFree (..), + ProjectMetrics (..), + runMetrics, + runLoggingMonitorT, + increaseMergedPRTotal, + registerProjectMetrics + ) +where import Data.Text import Prometheus @@ -13,16 +24,11 @@ import Control.Monad.Free.Ap (liftF) type ProjectLabel = Text data ProjectMetrics = ProjectMetrics - { projectMetricsProcessedPR :: Vector ProjectLabel Counter - , projectMetricsMergedPR :: Vector ProjectLabel Counter - , projectMetricsFailedPR :: Vector ProjectLabel Counter - , projectMetricsQueueAdded :: Vector ProjectLabel Counter - , projectMetricsQueueRemoved :: Vector ProjectLabel Counter + { projectMetricsMergedPR :: Vector ProjectLabel Counter } data MetricsOperationFree a = MergeBranch a - | MergeFailure a deriving (Functor) type MetricsOperation = Free MetricsOperationFree @@ -46,28 +52,12 @@ runMetrics metrics label operation = case operation of MergeBranch cont -> cont <$ incProjectMergedPR metrics label - MergeFailure cont -> cont <$ - incProjectFailedPR metrics label registerProjectMetrics :: IO ProjectMetrics registerProjectMetrics = ProjectMetrics - <$> register (vector "project" (counter (Info "hoff_project_processed_pull_requests" - "Number of processed pull requests"))) - <*> register (vector "project" (counter (Info "hoff_project_merged_pull_requests" + <$> register (vector "project" (counter (Info "hoff_project_merged_pull_requests" "Number of merged pull requests"))) - <*> register (vector "project" (counter (Info "hoff_project_failed_pull_requests" - "Number of failed pull requests"))) - <*> register (vector "project" (counter (Info "hoff_project_queue_added" "Number of items added to the queue"))) - <*> register (vector "project" (counter (Info "hoff_project_queue_added" "Number of items removed from the queue"))) - -incProjectProcessedPR :: ProjectMetrics -> ProjectLabel -> IO () -incProjectProcessedPR metrics project = - withLabel (projectMetricsProcessedPR metrics) project incCounter incProjectMergedPR :: (MonadMonitor m, MonadIO m) => ProjectMetrics -> ProjectLabel -> m () incProjectMergedPR metrics project = withLabel (projectMetricsMergedPR metrics) project incCounter - -incProjectFailedPR :: (MonadMonitor m, MonadIO m) => ProjectMetrics -> ProjectLabel -> m () -incProjectFailedPR metrics project = - withLabel (projectMetricsFailedPR metrics) project incCounter diff --git a/src/Metrics/Server.hs b/src/Metrics/Server.hs index fa079bfb..c096b195 100644 --- a/src/Metrics/Server.hs +++ b/src/Metrics/Server.hs @@ -1,6 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} -module Metrics.Server where +module Metrics.Server +( + MetricsServerConfig (..), + serverConfig, + runMetricsServer + ) +where import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Middleware.Prometheus as PrometheusWai @@ -10,13 +16,6 @@ data MetricsServerConfig = MetricsServerConfig { metricsConfigHost :: Warp.HostPreference , metricsConfigPort :: Warp.Port } - -defaultServerConfig :: MetricsServerConfig -defaultServerConfig = MetricsServerConfig - { metricsConfigHost = "*" - , metricsConfigPort = 3001 - } - serverConfig :: MetricsServerConfig -> Warp.Settings serverConfig config = Warp.defaultSettings & Warp.setHost (metricsConfigHost config) From 034d0de79f5c2cec8f50a4edea375168c59e03b9 Mon Sep 17 00:00:00 2001 From: Diego Diverio Date: Mon, 2 Jan 2023 14:54:26 +0100 Subject: [PATCH 6/9] Update tests. --- src/Metrics/Metrics.hs | 10 +++++++++- tests/EventLoopSpec.hs | 20 ++++++++++++++------ tests/Spec.hs | 1 + 3 files changed, 24 insertions(+), 7 deletions(-) diff --git a/src/Metrics/Metrics.hs b/src/Metrics/Metrics.hs index c56f4478..02d1c2eb 100644 --- a/src/Metrics/Metrics.hs +++ b/src/Metrics/Metrics.hs @@ -9,6 +9,7 @@ module Metrics.Metrics ProjectMetrics (..), runMetrics, runLoggingMonitorT, + runNoMonitorT, increaseMergedPRTotal, registerProjectMetrics ) @@ -18,7 +19,7 @@ import Data.Text import Prometheus import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Free (Free) -import Control.Monad.Logger (LoggingT, MonadLogger) +import Control.Monad.Logger (LoggingT, MonadLogger, NoLoggingT) import Control.Monad.Free.Ap (liftF) type ProjectLabel = Text @@ -36,9 +37,16 @@ type MetricsOperation = Free MetricsOperationFree newtype LoggingMonitorT m a = LoggingMonitorT { runLoggingMonitorT :: LoggingT m a } deriving (Functor, Applicative, Monad, MonadIO, MonadLogger) +newtype NoMonitorT m a = NoMonitorT { runNoMonitorT :: NoLoggingT m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadLogger) + instance MonadIO m => MonadMonitor (LoggingMonitorT m) where doIO = liftIO + +instance MonadIO m => MonadMonitor (NoMonitorT m) where + doIO _ = return () + increaseMergedPRTotal :: MetricsOperation () increaseMergedPRTotal = liftF $ MergeBranch () diff --git a/tests/EventLoopSpec.hs b/tests/EventLoopSpec.hs index 45b34796..9d5cbe23 100644 --- a/tests/EventLoopSpec.hs +++ b/tests/EventLoopSpec.hs @@ -37,6 +37,7 @@ import qualified Data.Time.Calendar.OrdinalDate as T import Configuration (ProjectConfiguration, TriggerConfiguration, UserConfiguration, MergeWindowExemptionConfiguration (..)) import Git (BaseBranch (..), Branch (..), RefSpec (refSpec), Sha (..)) import GithubApi (GithubOperationFree) +import Metrics.Metrics (MetricsOperationFree (..), runNoMonitorT) import Project (BuildStatus (..), IntegrationStatus (..), ProjectState, PullRequestId (..)) import qualified Configuration as Config @@ -224,6 +225,10 @@ fakeRunGithub action = case action of fakeRunTime :: Monad m => Time.TimeOperationFree a -> m a fakeRunTime (Time.GetDateTime cont) = pure (cont (T.UTCTime (T.fromMondayStartWeek 2021 2 1) (T.secondsToDiffTime 0))) +fakeRunMetrics :: Monad m => MetricsOperationFree a -> m a +fakeRunMetrics action = case action of + MergeBranch cont -> pure cont + -- Runs the main loop in a separate thread, and feeds it the given events. runMainEventLoop :: ProjectConfiguration @@ -240,17 +245,20 @@ runMainEventLoop projectConfig initialState events = do -- 'runStdoutLoggingT'. You should also remove 'parallel' from main then. queue <- Logic.newEventQueue 10 let - publish _ = return () -- Do nothing when a new state is published. - getNextEvent = liftIO $ Logic.dequeueEvent queue - runGit = Git.runGit userConfig (Config.checkout projectConfig) - runGithub = fakeRunGithub - runTime = fakeRunTime - finalStateAsync <- async + publish _ = return () -- Do nothing when a new state is published. + getNextEvent = liftIO $ Logic.dequeueEvent queue + runMetrics = fakeRunMetrics + runGit = Git.runGit userConfig (Config.checkout projectConfig) + runGithub = fakeRunGithub + runTime = fakeRunTime + finalStateAsync <- async $ runNoLoggingT + $ runNoMonitorT $ EventLoop.runLogicEventLoop triggerConfig projectConfig mergeWindowExemptionConfig + runMetrics runTime runGit runGithub diff --git a/tests/Spec.hs b/tests/Spec.hs index 75305ebd..915703c6 100644 --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -232,6 +232,7 @@ runActionRws = GetLatestVersion _ cont -> cont <$> takeResultGetLatestVersion GetChangelog _ _ cont -> cont <$> takeResultGetChangelog GetDateTime cont -> cont <$> takeResultGetDateTime + IncreaseMergeMetric cont -> pure cont -- Simulates running the action. Use the provided results as result for various -- operations. Results are consumed one by one. From 8f2ecef0a8996571b5fe54c63ef93116a8fd5b9b Mon Sep 17 00:00:00 2001 From: Diego Diverio Date: Tue, 3 Jan 2023 11:32:04 +0100 Subject: [PATCH 7/9] Apply code suggestions, refactor and add config for host. --- app/Main.hs | 30 +++++++++++++++--------------- doc/example-dev-config.json | 3 ++- nix/haskell-dependencies.nix | 1 - src/Configuration.hs | 3 ++- src/EventLoop.hs | 2 +- src/Logic.hs | 11 +++++++++-- src/Metrics/Server.hs | 3 ++- 7 files changed, 31 insertions(+), 22 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 5b367c45..401d22ec 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -13,8 +13,8 @@ import Control.Applicative ((<**>)) import Control.Monad (forM, unless, void) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger (runStdoutLoggingT) -import Data.List (zip4) import Data.Maybe (maybeToList) +import Data.String (fromString) import Data.Version (showVersion) import System.Exit (die) import System.IO (BufferMode (LineBuffering), hSetBuffering, stderr, stdout) @@ -25,14 +25,15 @@ import qualified GitHub.Auth as Github3 import qualified System.Directory as FileSystem import qualified Options.Applicative as Opts -import Configuration (Configuration, MetricsConfiguration (..)) +import Configuration (Configuration, MetricsConfiguration (metricsPort, metricsHost)) import EventLoop (runGithubEventLoop, runLogicEventLoop) import Project (ProjectState, emptyProjectState, loadProjectState, saveProjectState) import Project (ProjectInfo (ProjectInfo), Owner) import Server (buildServer) import qualified Metrics.Metrics as Metrics -import Metrics.Server +import Metrics.Server (runMetricsServer, MetricsServerConfig(MetricsServerConfig, + metricsConfigPort, metricsConfigHost)) import qualified Paths_hoff (version) @@ -112,8 +113,8 @@ runMain options = do hSetBuffering stderr LineBuffering putStrLn $ "Starting Hoff v" ++ version - putStrLn $ "Config file: " ++ (configFilePath options) - putStrLn $ "Read-only: " ++ (show $ readOnly options) + putStrLn $ "Config file: " ++ configFilePath options + putStrLn $ "Read-only: " ++ show (readOnly options) -- Load configuration from the file specified as first program argument. config <- loadConfigOrExit $ configFilePath options @@ -162,10 +163,10 @@ runMain options = do -- Start a main event loop for every project. let - zipped = zip4 (Config.projects config) projectQueues stateVars projectStates - tuples = map (\(cfg, (_, a), (_, b), (_, c)) -> ProjectThreadData cfg a b c) zipped + zipped = zip3 (Config.projects config) projectQueues stateVars + projectsThreadData = map (\(cfg, (_, a), (_, b)) -> ProjectThreadData cfg a b) zipped metrics <- Metrics.registerProjectMetrics - projectThreads <- forM tuples $ projectThread config options metrics + projectThreads <- forM projectsThreadData $ projectThread config options metrics let -- When the webhook server receives an event, enqueue it on the webhook @@ -173,12 +174,11 @@ runMain options = do ghTryEnqueue = Github.tryEnqueueEvent ghQueue -- Allow the webinterface to retrieve the latest project state per project. - getProjectState projectInfo = - fmap Logic.readStateVar $ lookup projectInfo stateVars + getProjectState projectInfo = Logic.readStateVar <$> lookup projectInfo stateVars getOwnerState :: Owner -> IO [(ProjectInfo, ProjectState)] getOwnerState owner = do let states = filter (\(projectInfo, _) -> Project.owner projectInfo == owner) stateVars - mapM (\(info, state) -> Logic.readStateVar state >>= \sVar -> pure (info, sVar)) states + mapM (\(info, state) -> Logic.readStateVar state >>= \sVar -> pure (info, sVar)) states let port = Config.port config @@ -199,7 +199,6 @@ data ProjectThreadData = ProjectThreadData { projectThreadConfig :: Config.ProjectConfiguration , projectThreadQueue :: Logic.EventQueue , projectThreadStateVar :: Logic.StateVar - , projectThreadState :: ProjectState } projectThread :: Configuration @@ -213,10 +212,10 @@ projectThread config options metrics projectThreadData = do -- we missed while not running, or just to fill the state initially after -- setting up a new project. liftIO $ Logic.enqueueEvent projectQueue Logic.Synchronize + projectThreadState <- Logic.readStateVar $ projectThreadStateVar projectThreadData -- Start a worker thread to run the main event loop for the project. Async.async $ void - -- Implement a newtype for a logging monad that also embodies MonadMonitor $ runStdoutLoggingT $ Metrics.runLoggingMonitorT $ runLogicEventLoop @@ -229,7 +228,7 @@ projectThread config options metrics projectThreadData = do runGithub getNextEvent publish - (projectThreadState projectThreadData) + projectThreadState where -- When the event loop publishes the current project state, save it to -- the configured file, and make the new state available to the @@ -264,5 +263,6 @@ runMetricsThread configuration = forM (maybeToList $ Config.metricsConfig configuration) $ \metricsConf -> do let servConfig = MetricsServerConfig - { metricsConfigPort = metricsPort metricsConf, metricsConfigHost = "*" } + { metricsConfigPort = metricsPort metricsConf + , metricsConfigHost = fromString $ metricsHost metricsConf } Async.async $ runMetricsServer servConfig diff --git a/doc/example-dev-config.json b/doc/example-dev-config.json index 58d1b43d..6c077986 100644 --- a/doc/example-dev-config.json +++ b/doc/example-dev-config.json @@ -21,6 +21,7 @@ "commentPrefix": "@hoffbot" }, "metrics": { - "metricsPort": "3333" + "metricsPort": 3333, + "metricsHost": "*" } } diff --git a/nix/haskell-dependencies.nix b/nix/haskell-dependencies.nix index 41cbf1b6..10d9a118 100644 --- a/nix/haskell-dependencies.nix +++ b/nix/haskell-dependencies.nix @@ -31,7 +31,6 @@ haskellPackages: with haskellPackages; [ process-extras prometheus scotty - stylish-haskell stm text text-format diff --git a/src/Configuration.hs b/src/Configuration.hs index a08cae8a..fbabfde8 100644 --- a/src/Configuration.hs +++ b/src/Configuration.hs @@ -66,7 +66,8 @@ data TlsConfiguration = TlsConfiguration data MetricsConfiguration = MetricsConfiguration { - metricsPort :: Warp.Port + metricsPort :: Warp.Port, + metricsHost :: String } deriving (Generic, Show) diff --git a/src/EventLoop.hs b/src/EventLoop.hs index bd527980..8a1022a6 100644 --- a/src/EventLoop.hs +++ b/src/EventLoop.hs @@ -26,6 +26,7 @@ import Control.Monad.STM (atomically) import Control.Monad.Free (foldFree) import Data.Foldable (traverse_) import Data.Functor.Sum (Sum (InL, InR)) +import Prometheus (MonadMonitor) import Data.Text (Text) import qualified Data.Text as Text @@ -42,7 +43,6 @@ import qualified Github import qualified GithubApi import qualified Logic import qualified Project -import Prometheus (MonadMonitor) import qualified Metrics.Metrics as Metrics eventFromPullRequestPayload :: PullRequestPayload -> Logic.Event diff --git a/src/Logic.hs b/src/Logic.hs index 20944ef1..a85415db 100644 --- a/src/Logic.hs +++ b/src/Logic.hs @@ -64,6 +64,7 @@ import Git (Branch (..), BaseBranch (..), GitOperation, GitOperationFree, PushRe TagResult (..)) import GithubApi (GithubOperation, GithubOperationFree) +import Metrics.Metrics (MetricsOperationFree, MetricsOperation, increaseMergedPRTotal) import Project (Approval (..), ApprovedFor (..), BuildStatus (..), IntegrationStatus (..), MergeWindow(..), ProjectState, PullRequest, PullRequestStatus (..)) import Time (TimeOperation, TimeOperationFree) @@ -74,7 +75,7 @@ import qualified Git import qualified GithubApi import qualified Project as Pr import qualified Time -import Metrics.Metrics + data ActionFree a = TryIntegrate @@ -105,7 +106,13 @@ data PRCloseCause = type Action = Free ActionFree -type Operation = Free (Sum (Sum MetricsOperationFree TimeOperationFree) (Sum GitOperationFree GithubOperationFree)) +type Operation = Free (Sum + (Sum + MetricsOperationFree + TimeOperationFree) + (Sum + GitOperationFree + GithubOperationFree)) type PushWithTagResult = (Either Text TagName, PushResult) diff --git a/src/Metrics/Server.hs b/src/Metrics/Server.hs index c096b195..6e9787c9 100644 --- a/src/Metrics/Server.hs +++ b/src/Metrics/Server.hs @@ -5,7 +5,7 @@ module Metrics.Server MetricsServerConfig (..), serverConfig, runMetricsServer - ) +) where import qualified Network.Wai.Handler.Warp as Warp @@ -16,6 +16,7 @@ data MetricsServerConfig = MetricsServerConfig { metricsConfigHost :: Warp.HostPreference , metricsConfigPort :: Warp.Port } + serverConfig :: MetricsServerConfig -> Warp.Settings serverConfig config = Warp.defaultSettings & Warp.setHost (metricsConfigHost config) From b7e8624f102d67765c1fe27f473dbb026987c1c8 Mon Sep 17 00:00:00 2001 From: Diego Diverio Date: Tue, 3 Jan 2023 16:25:59 +0100 Subject: [PATCH 8/9] Add GHC Metrics. --- app/Main.hs | 1 + hoff.cabal | 1 + nix/haskell-dependencies.nix | 1 + src/Metrics/Metrics.hs | 6 ++++++ 4 files changed, 9 insertions(+) diff --git a/app/Main.hs b/app/Main.hs index 401d22ec..c81da773 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -166,6 +166,7 @@ runMain options = do zipped = zip3 (Config.projects config) projectQueues stateVars projectsThreadData = map (\(cfg, (_, a), (_, b)) -> ProjectThreadData cfg a b) zipped metrics <- Metrics.registerProjectMetrics + Metrics.registerGHCMetrics projectThreads <- forM projectsThreadData $ projectThread config options metrics let diff --git a/hoff.cabal b/hoff.cabal index c0fc21d0..b87b6ae8 100644 --- a/hoff.cabal +++ b/hoff.cabal @@ -56,6 +56,7 @@ library , process , process-extras , prometheus-client + , prometheus-metrics-ghc , scotty , stm , text diff --git a/nix/haskell-dependencies.nix b/nix/haskell-dependencies.nix index 10d9a118..741d6c40 100644 --- a/nix/haskell-dependencies.nix +++ b/nix/haskell-dependencies.nix @@ -30,6 +30,7 @@ haskellPackages: with haskellPackages; [ process process-extras prometheus + prometheus-metrics-ghc scotty stm text diff --git a/src/Metrics/Metrics.hs b/src/Metrics/Metrics.hs index 02d1c2eb..7fdf4663 100644 --- a/src/Metrics/Metrics.hs +++ b/src/Metrics/Metrics.hs @@ -11,16 +11,19 @@ module Metrics.Metrics runLoggingMonitorT, runNoMonitorT, increaseMergedPRTotal, + registerGHCMetrics, registerProjectMetrics ) where import Data.Text import Prometheus +import Prometheus.Metric.GHC (ghcMetrics) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Free (Free) import Control.Monad.Logger (LoggingT, MonadLogger, NoLoggingT) import Control.Monad.Free.Ap (liftF) +import Control.Monad (void) type ProjectLabel = Text @@ -61,6 +64,9 @@ runMetrics metrics label operation = MergeBranch cont -> cont <$ incProjectMergedPR metrics label +registerGHCMetrics :: IO () +registerGHCMetrics = void $ register ghcMetrics + registerProjectMetrics :: IO ProjectMetrics registerProjectMetrics = ProjectMetrics <$> register (vector "project" (counter (Info "hoff_project_merged_pull_requests" From a5f21e03575677fe65e6ba74c3dd8a104a606d1f Mon Sep 17 00:00:00 2001 From: Diego Diverio Date: Tue, 3 Jan 2023 16:28:33 +0100 Subject: [PATCH 9/9] Refactor. --- app/Main.hs | 3 ++- src/Configuration.hs | 2 +- src/Metrics/Metrics.hs | 2 +- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index c81da773..8f78dcbd 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -44,6 +44,7 @@ import qualified GithubApi import qualified Logic import qualified Project import qualified Time +import qualified Data.Text as Text version :: String version = showVersion Paths_hoff.version @@ -265,5 +266,5 @@ runMetricsThread configuration = \metricsConf -> do let servConfig = MetricsServerConfig { metricsConfigPort = metricsPort metricsConf - , metricsConfigHost = fromString $ metricsHost metricsConf } + , metricsConfigHost = fromString $ Text.unpack $ metricsHost metricsConf } Async.async $ runMetricsServer servConfig diff --git a/src/Configuration.hs b/src/Configuration.hs index fbabfde8..6137aec3 100644 --- a/src/Configuration.hs +++ b/src/Configuration.hs @@ -67,7 +67,7 @@ data TlsConfiguration = TlsConfiguration data MetricsConfiguration = MetricsConfiguration { metricsPort :: Warp.Port, - metricsHost :: String + metricsHost :: Text } deriving (Generic, Show) diff --git a/src/Metrics/Metrics.hs b/src/Metrics/Metrics.hs index 7fdf4663..8521bf1b 100644 --- a/src/Metrics/Metrics.hs +++ b/src/Metrics/Metrics.hs @@ -28,7 +28,7 @@ import Control.Monad (void) type ProjectLabel = Text data ProjectMetrics = ProjectMetrics - { projectMetricsMergedPR :: Vector ProjectLabel Counter + { projectMetricsMergedPR :: Vector ProjectLabel Counter } data MetricsOperationFree a