diff --git a/docs/contributing/contributing.md b/docs/contributing/contributing.md index 20762ccbd1d..b885aa12c6d 100644 --- a/docs/contributing/contributing.md +++ b/docs/contributing/contributing.md @@ -229,7 +229,7 @@ See the [tutorial](./plugin-tutorial.md) on writing a plugin in HLS. ### Metrics -HLS opens a metrics server on port 8000 exposing GC and ghcide metrics. The ghcide metrics currently exposed are: +When ghcide is built with the `ekg` flag, HLS opens a metrics server on port 8999 exposing GC and ghcide metrics. The ghcide metrics currently exposed are: - `ghcide.values_count`- count of build results in the store - `ghcide.database_count` - count of build keys in the store (these two would be the same in the absence of GC) diff --git a/ghcide/exe/Arguments.hs b/ghcide/exe/Arguments.hs index 4b5e8ae0fa0..5a9c443bc6d 100644 --- a/ghcide/exe/Arguments.hs +++ b/ghcide/exe/Arguments.hs @@ -1,6 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE CPP #-} module Arguments(Arguments(..), getArguments) where import Development.IDE (IdeState) @@ -19,6 +20,9 @@ data Arguments = Arguments ,argsVerbose :: Bool ,argsCommand :: Command ,argsConservativeChangeTracking :: Bool +#ifdef MONITORING_EKG + ,argsMonitoringPort :: Int +#endif } getArguments :: IdePlugins IdeState -> IO Arguments @@ -40,6 +44,9 @@ arguments plugins = Arguments <*> switch (short 'd' <> long "verbose" <> help "Include internal events in logging output") <*> (commandP plugins <|> lspCommand <|> checkCommand) <*> switch (long "conservative-change-tracking" <> help "disable reactive change tracking (for testing/debugging)") +#ifdef MONITORING_EKG + <*> option auto (long "monitoring-port" <> metavar "PORT" <> value 8999 <> showDefault <> help "Port to use for monitoring") +#endif where checkCommand = Check <$> many (argument str (metavar "FILES/DIRS...")) lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP client") diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 37bab4d72eb..ff7e554b5a8 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -1,6 +1,7 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Main(main) where @@ -24,7 +25,6 @@ import Development.IDE.Types.Logger (Logger (Logger), LoggingColumn (DataColumn, PriorityColumn), Pretty (pretty), Priority (Debug, Info, Error), - Recorder (Recorder), WithPriority (WithPriority, priority), cfilter, cmapWithPrio, makeDefaultStderrRecorder, layoutPretty, renderStrict, defaultLayoutOptions) @@ -43,6 +43,11 @@ import System.Exit (exitSuccess) import System.IO (hPutStrLn, stderr) import System.Info (compilerVersion) +#ifdef MONITORING_EKG +import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry +import qualified Development.IDE.Monitoring.EKG as EKG +#endif + data Log = LogIDEMain IDEMain.Log | LogRules Rules.Log @@ -142,4 +147,10 @@ main = withTelemetryLogger $ \telemetryLogger -> do , optCheckProject = pure $ checkProject config , optRunSubset = not argsConservativeChangeTracking } +#ifdef MONITORING_EKG + , IDEMain.argsMonitoring = OpenTelemetry.monitoring <> EKG.monitoring logger argsMonitoringPort +#ifdef MONITORING_EKG +#endif +#endif + } diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 9cf6ac7ef46..4852a6e687f 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -30,6 +30,11 @@ flag ghc-patched-unboxed-bytecode default: False manual: True +flag ekg + description: Enable EKG monitoring of the build graph and other metrics on port 8999 + default: False + manual: True + library default-language: Haskell2010 build-depends: @@ -48,8 +53,6 @@ library dependent-map, dependent-sum, dlist, - ekg-wai, - ekg-core, exceptions, extra >= 1.7.4, enummapset, @@ -197,6 +200,8 @@ library Development.IDE.Types.KnownTargets Development.IDE.Types.Location Development.IDE.Types.Logger + Development.IDE.Types.Monitoring + Development.IDE.Monitoring.OpenTelemetry Development.IDE.Types.Options Development.IDE.Types.Shake Development.IDE.Plugin @@ -235,6 +240,14 @@ library exposed-modules: Development.IDE.GHC.Compat.CPP + if flag(ekg) + build-depends: + ekg-wai, + ekg-core, + cpp-options: -DMONITORING_EKG + exposed-modules: + Development.IDE.Monitoring.EKG + flag test-exe description: Build the ghcide-test-preprocessor executable default: True @@ -355,6 +368,11 @@ executable ghcide if !flag(executable) buildable: False + if flag(ekg) + build-depends: + ekg-wai, + ekg-core, + cpp-options: -DMONITORING_EKG test-suite ghcide-tests type: exitcode-stdio-1.0 diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index 28183651f93..8ef090e84e1 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -18,30 +18,30 @@ module Development.IDE.Core.Service( Log(..), ) where -import Control.Applicative ((<|>)) +import Control.Applicative ((<|>)) import Development.IDE.Core.Debouncer -import Development.IDE.Core.FileExists (fileExistsRules) -import Development.IDE.Core.OfInterest hiding (Log, LogShake) +import Development.IDE.Core.FileExists (fileExistsRules) +import Development.IDE.Core.OfInterest hiding (Log, LogShake) import Development.IDE.Graph -import Development.IDE.Types.Logger as Logger (Logger, - Pretty (pretty), - Priority (Debug), - Recorder, - WithPriority, - cmapWithPrio) -import Development.IDE.Types.Options (IdeOptions (..)) +import Development.IDE.Types.Logger as Logger (Logger, + Pretty (pretty), + Priority (Debug), + Recorder, + WithPriority, + cmapWithPrio) +import Development.IDE.Types.Options (IdeOptions (..)) import Ide.Plugin.Config -import qualified Language.LSP.Server as LSP -import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Server as LSP +import qualified Language.LSP.Types as LSP import Control.Monad -import qualified Development.IDE.Core.FileExists as FileExists -import qualified Development.IDE.Core.OfInterest as OfInterest -import Development.IDE.Core.Shake hiding (Log) -import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Types.Shake (WithHieDb) -import System.Environment (lookupEnv) -import System.Metrics +import qualified Development.IDE.Core.FileExists as FileExists +import qualified Development.IDE.Core.OfInterest as OfInterest +import Development.IDE.Core.Shake hiding (Log) +import qualified Development.IDE.Core.Shake as Shake +import Development.IDE.Types.Monitoring (Monitoring) +import Development.IDE.Types.Shake (WithHieDb) +import System.Environment (lookupEnv) data Log = LogShake Shake.Log @@ -68,7 +68,7 @@ initialise :: Recorder (WithPriority Log) -> IdeOptions -> WithHieDb -> IndexQueue - -> Maybe Store + -> Monitoring -> IO IdeState initialise recorder defaultConfig mainRule lspEnv logger debouncer options withHieDb hiedbChan metrics = do shakeProfiling <- do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 26a9c7140b2..4b8c826808b 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -118,7 +118,6 @@ import Data.Typeable import Data.Unique import Data.Vector (Vector) import qualified Data.Vector as Vector -import Debug.Trace.Flags (userTracingEnabled) import Development.IDE.Core.Debouncer import Development.IDE.Core.FileUtils (getModTime) import Development.IDE.Core.PositionMapping @@ -168,8 +167,8 @@ import qualified "list-t" ListT import qualified StmContainers.Map as STM import System.FilePath hiding (makeRelative) import System.IO.Unsafe (unsafePerformIO) -import System.Metrics (Store, registerCounter, registerGauge) import System.Time.Extra +import Development.IDE.Types.Monitoring (Monitoring(..)) data Log = LogCreateHieDbExportsMapStart @@ -464,6 +463,7 @@ data IdeState = IdeState ,shakeSession :: MVar ShakeSession ,shakeExtras :: ShakeExtras ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) + ,stopMonitoring :: IO () } @@ -559,11 +559,13 @@ shakeOpen :: Recorder (WithPriority Log) -> WithHieDb -> IndexQueue -> ShakeOptions - -> Maybe Store + -> Monitoring -> Rules () -> IO IdeState shakeOpen recorder lspEnv defaultConfig logger debouncer - shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) withHieDb indexQueue opts metrics rules = mdo + shakeProfileDir (IdeReportProgress reportProgress) + ideTesting@(IdeTesting testing) + withHieDb indexQueue opts monitoring rules = mdo let log :: Logger.Priority -> Log -> IO () log = logWith recorder @@ -611,7 +613,6 @@ shakeOpen recorder lspEnv defaultConfig logger debouncer rules shakeSession <- newEmptyMVar shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir - let ideState = IdeState{..} IdeOptions { optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled @@ -619,44 +620,30 @@ shakeOpen recorder lspEnv defaultConfig logger debouncer , optCheckParents } <- getIdeOptionsIO shakeExtras - void $ startTelemetry shakeDb shakeExtras startProfilingTelemetry otProfilingEnabled logger $ state shakeExtras checkParents <- optCheckParents - for_ metrics $ \store -> do - let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras - readDirtyKeys = fromIntegral . countRelevantKeys checkParents . HSet.toList <$> readTVarIO(dirtyKeys shakeExtras) - readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras) - readExportsMap = fromIntegral . HMap.size . getExportsMap <$> readTVarIO (exportsMap shakeExtras) - readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb - readDatabaseStep = fromIntegral <$> shakeGetBuildStep shakeDb - - registerGauge "ghcide.values_count" readValuesCounter store - registerGauge "ghcide.dirty_keys_count" readDirtyKeys store - registerGauge "ghcide.indexing_pending_count" readIndexPending store - registerGauge "ghcide.exports_map_count" readExportsMap store - registerGauge "ghcide.database_count" readDatabaseCount store - registerCounter "ghcide.num_builds" readDatabaseStep store - return ideState + -- monitoring + let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras + readDirtyKeys = fromIntegral . countRelevantKeys checkParents . HSet.toList <$> readTVarIO(dirtyKeys shakeExtras) + readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras) + readExportsMap = fromIntegral . HMap.size . getExportsMap <$> readTVarIO (exportsMap shakeExtras) + readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb + readDatabaseStep = fromIntegral <$> shakeGetBuildStep shakeDb -startTelemetry :: ShakeDatabase -> ShakeExtras -> IO (Async ()) -startTelemetry db extras@ShakeExtras{..} - | userTracingEnabled = do - countKeys <- mkValueObserver "cached keys count" - countDirty <- mkValueObserver "dirty keys count" - countBuilds <- mkValueObserver "builds count" - IdeOptions{optCheckParents} <- getIdeOptionsIO extras - checkParents <- optCheckParents - regularly 1 $ do - observe countKeys . countRelevantKeys checkParents =<< getStateKeys extras - readTVarIO dirtyKeys >>= observe countDirty . countRelevantKeys checkParents . HSet.toList - shakeGetBuildStep db >>= observe countBuilds + registerGauge monitoring "ghcide.values_count" readValuesCounter + registerGauge monitoring "ghcide.dirty_keys_count" readDirtyKeys + registerGauge monitoring "ghcide.indexing_pending_count" readIndexPending + registerGauge monitoring "ghcide.exports_map_count" readExportsMap + registerGauge monitoring "ghcide.database_count" readDatabaseCount + registerCounter monitoring "ghcide.num_builds" readDatabaseStep + + stopMonitoring <- start monitoring + + let ideState = IdeState{..} + return ideState - | otherwise = async (pure ()) - where - regularly :: Seconds -> IO () -> IO (Async ()) - regularly delay act = async $ forever (act >> sleep delay) getStateKeys :: ShakeExtras -> IO [Key] getStateKeys = (fmap.fmap) fst . atomically . ListT.toList . STM.listT . state @@ -679,6 +666,7 @@ shakeShut IdeState{..} = do for_ runner cancelShakeSession void $ shakeDatabaseProfile shakeDb progressStop $ progress shakeExtras + stopMonitoring -- | This is a variant of withMVar where the first argument is run unmasked and if it throws diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 1180b00afc8..f9fc05e161f 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -Wno-orphans #-} module Development.IDE.Main @@ -11,14 +12,12 @@ module Development.IDE.Main ,testing ,Log(..) ) where -import Control.Concurrent.Async (async, waitCatch) -import Control.Concurrent.Extra (killThread, withNumCapabilities) +import Control.Concurrent.Extra (withNumCapabilities) import Control.Concurrent.STM.Stats (atomically, dumpSTMStats) import Control.Exception.Safe (SomeException, catchAny, - displayException, - onException) -import Control.Monad.Extra (concatMapM, join, unless, + displayException) +import Control.Monad.Extra (concatMapM, unless, when) import qualified Data.Aeson.Encode.Pretty as A import Data.Default (Default (def)) @@ -31,13 +30,11 @@ import Data.Maybe (catMaybes, isJust) import qualified Data.Text as T import Data.Text.Lazy.Encoding (decodeUtf8) import qualified Data.Text.Lazy.IO as LT -import Data.Traversable (for) import Data.Typeable (typeOf) import Development.IDE (Action, GhcVersion (..), Priority (Debug, Error), Rules, ghcVersion, - hDuplicateTo', - logInfo) + hDuplicateTo') import Development.IDE.Core.Debouncer (Debouncer, newAsyncDebouncer) import Development.IDE.Core.FileStore (isWatchSupported) @@ -130,12 +127,15 @@ import System.IO (BufferMode (LineBufferin hSetEncoding, stderr, stdin, stdout, utf8) import System.Random (newStdGen) -import qualified System.Metrics as Monitoring -import System.Remote.Monitoring.Wai -import qualified System.Remote.Monitoring.Wai as Monitoring import System.Time.Extra (Seconds, offsetTime, showDuration) import Text.Printf (printf) +import Development.IDE.Types.Monitoring (Monitoring) +import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry + +#ifdef MONITORING_EKG +import qualified Development.IDE.Monitoring.EKG as EKG +#endif data Log = LogHeapStats !HeapStats.Log @@ -238,10 +238,9 @@ data Arguments = Arguments , argsHandleIn :: IO Handle , argsHandleOut :: IO Handle , argsThreads :: Maybe Natural - , argsMonitoringPort :: Maybe Natural + , argsMonitoring :: IO Monitoring } - defaultArguments :: Recorder (WithPriority Log) -> Logger -> Arguments defaultArguments recorder logger = Arguments { argsProjectRoot = Nothing @@ -276,7 +275,10 @@ defaultArguments recorder logger = Arguments -- the language server tests without the redirection. putStr " " >> hFlush stdout return newStdout - , argsMonitoringPort = Just 8000 + , argsMonitoring = OpenTelemetry.monitoring +#ifdef MONITORING_EKG + <> EKG.monitoring logger 8999 +#endif } @@ -364,24 +366,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re -- FIXME: Remove this after GHC 9 gets fully supported when (ghcVersion == GHC90) $ log Warning LogOnlyPartialGhc9Support - server <- fmap join $ for argsMonitoringPort $ \p -> do - store <- Monitoring.newStore - Monitoring.registerGcMetrics store - let startServer = Monitoring.forkServerWith store "localhost" (fromIntegral p) - -- this can fail if the port is busy, throwing an async exception back to us - -- to handle that, wrap the server thread in an async - mb_server <- async startServer >>= waitCatch - case mb_server of - Right s -> do - logInfo logger $ T.pack $ - "Started monitoring server on port " <> show p - return $ Just s - Left e -> do - logInfo logger $ T.pack $ - "Unable to bind monitoring server on port " - <> show p <> ":" <> show e - return Nothing - + monitoring <- argsMonitoring initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig @@ -392,9 +377,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re options withHieDb hieChan - (Monitoring.serverMetricStore <$> server) - `onException` - traverse_ (killThread . serverThreadId) server + monitoring dumpSTMStats Check argFiles -> do dir <- maybe IO.getCurrentDirectory return argsProjectRoot @@ -427,7 +410,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan Nothing + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -480,7 +463,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan Nothing + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig rules Nothing logger debouncer options hiedb hieChan mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide diff --git a/ghcide/src/Development/IDE/Monitoring/EKG.hs b/ghcide/src/Development/IDE/Monitoring/EKG.hs new file mode 100644 index 00000000000..3ffe300d07a --- /dev/null +++ b/ghcide/src/Development/IDE/Monitoring/EKG.hs @@ -0,0 +1,34 @@ +module Development.IDE.Monitoring.EKG(monitoring) where +import Control.Concurrent (killThread) +import Control.Concurrent.Async (async, waitCatch) +import Data.Text (pack) +import Development.IDE.Types.Logger (Logger, logInfo) +import Development.IDE.Types.Monitoring (Monitoring (..)) +import qualified System.Metrics as Monitoring +import qualified System.Remote.Monitoring.Wai as Monitoring + +-- | Monitoring using EKG +monitoring :: Logger -> Int -> IO Monitoring +monitoring logger port = do + store <- Monitoring.newStore + Monitoring.registerGcMetrics store + let registerCounter name read = Monitoring.registerGauge name read store + registerGauge name read = Monitoring.registerGauge name read store + start = do + server <- do + let startServer = Monitoring.forkServerWith store "localhost" port + -- this can fail if the port is busy, throwing an async exception back to us + -- to handle that, wrap the server thread in an async + mb_server <- async startServer >>= waitCatch + case mb_server of + Right s -> do + logInfo logger $ pack $ + "Started monitoring server on port " <> show port + return $ Just s + Left e -> do + logInfo logger $ pack $ + "Unable to bind monitoring server on port " + <> show port <> ":" <> show e + return Nothing + return $ mapM_ (killThread . Monitoring.serverThreadId) server + return $ Monitoring {..} diff --git a/ghcide/src/Development/IDE/Monitoring/OpenTelemetry.hs b/ghcide/src/Development/IDE/Monitoring/OpenTelemetry.hs new file mode 100644 index 00000000000..2a6efa3d2e6 --- /dev/null +++ b/ghcide/src/Development/IDE/Monitoring/OpenTelemetry.hs @@ -0,0 +1,31 @@ +module Development.IDE.Monitoring.OpenTelemetry (monitoring) where + +import Control.Concurrent.Async (Async, async, cancel) +import Control.Monad (forever) +import Data.IORef.Extra (atomicModifyIORef'_, + newIORef, readIORef) +import Data.Text.Encoding (encodeUtf8) +import Debug.Trace.Flags (userTracingEnabled) +import Development.IDE.Types.Monitoring (Monitoring (..)) +import OpenTelemetry.Eventlog (mkValueObserver, observe) +import System.Time.Extra (Seconds, sleep) + +-- | Dump monitoring to the eventlog using the Opentelemetry package +monitoring :: IO Monitoring +monitoring + | userTracingEnabled = do + actions <- newIORef [] + let registerCounter name read = do + observer <- mkValueObserver (encodeUtf8 name) + let update = observe observer . fromIntegral =<< read + atomicModifyIORef'_ actions (update :) + registerGauge = registerCounter + let start = do + a <- regularly 1 $ sequence_ =<< readIORef actions + return (cancel a) + return Monitoring{..} + | otherwise = mempty + + +regularly :: Seconds -> IO () -> IO (Async ()) +regularly delay act = async $ forever (act >> sleep delay) diff --git a/ghcide/src/Development/IDE/Types/Monitoring.hs b/ghcide/src/Development/IDE/Types/Monitoring.hs new file mode 100644 index 00000000000..08d3d88128c --- /dev/null +++ b/ghcide/src/Development/IDE/Types/Monitoring.hs @@ -0,0 +1,30 @@ +module Development.IDE.Types.Monitoring +(Monitoring(..) +) where + +import Data.Int +import Data.Text (Text) + +-- | An abstraction for runtime monitoring. +data Monitoring = Monitoring { + registerGauge :: Text -> IO Int64 -> IO (), + registerCounter :: Text -> IO Int64 -> IO (), + start :: IO (IO ()) + } + +instance Semigroup Monitoring where + a <> b = Monitoring { + registerGauge = \n v -> registerGauge a n v >> registerGauge b n v, + registerCounter = \n v -> registerCounter a n v >> registerCounter b n v, + start = do + a' <- start a + b' <- start b + return $ a' >> b' + } + +instance Monoid Monitoring where + mempty = Monitoring { + registerGauge = \_ _ -> return (), + registerCounter = \_ _ -> return (), + start = return $ return () + }