From 6a52c4513c8b4346092fbea81ec5b567d14d1753 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 16 Jan 2021 09:56:48 +0000 Subject: [PATCH 1/3] Add tracing for HLS plugins --- ghcide/src/Development/IDE/Core/Tracing.hs | 10 +++++++++- ghcide/src/Development/IDE/Plugin/HLS.hs | 13 +++++++------ 2 files changed, 16 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 25a59768f2..6b6965a3a8 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -5,7 +5,7 @@ module Development.IDE.Core.Tracing , startTelemetry , measureMemory , getInstrumentCached - ) + ,otTracedPlugin) where import Control.Concurrent.Async (Async, async) @@ -36,6 +36,9 @@ import Numeric.Natural (Natural) import OpenTelemetry.Eventlog (Synchronicity(Asynchronous), Instrument, addEvent, beginSpan, endSpan, mkValueObserver, observe, setTag, withSpan, withSpan_) +import Data.ByteString (ByteString) +import Data.Text.Encoding (encodeUtf8) +import Ide.Types (PluginId (..)) -- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span. otTracedHandler @@ -71,6 +74,11 @@ otTracedAction key file success act = actionBracket unless (success res) $ setTag sp "error" "1" return res) +otTracedPlugin :: PluginId -> ByteString -> IO a -> IO a +otTracedPlugin (PluginId pluginName) provider act = + let !msg = "plugin:" <> encodeUtf8 pluginName <> " " <> "provider:" <> provider + in withSpan msg (const act) + startTelemetry :: Bool -> Logger -> Var Values -> IO () startTelemetry allTheTime logger stateRef = do instrumentFor <- getInstrumentCached diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 2d741522e6..c18619b36d 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -32,6 +32,7 @@ import Text.Regex.TDFA.Text() import Development.Shake (Rules) import Ide.PluginUtils (getClientConfig, pluginEnabled, getPluginConfig, responseError, getProcessID) import Development.IDE.Types.Logger (logInfo) +import Development.IDE.Core.Tracing -- --------------------------------------------------------------------- @@ -94,7 +95,7 @@ makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do makeAction (pid,provider) = do pluginConfig <- getPluginConfig lf pid if pluginEnabled pluginConfig plcCodeActionsOn - then provider lf ideState pid docId range context + then otTracedProvider pid "codeAction" $ provider lf ideState pid docId range context else return $ Right (List []) r <- mapM makeAction cas let actions = filter wasRequested . foldMap unL $ rights r @@ -158,7 +159,7 @@ makeCodeLens cas lf ideState params = do makeLens (pid, provider) = do pluginConfig <- getPluginConfig lf pid r <- if pluginEnabled pluginConfig plcCodeLensOn - then provider lf ideState pid params + then otTracedProvider pid "codeLens" $ provider lf ideState pid params else return $ Right (List []) return (pid, r) breakdown :: [(PluginId, Either ResponseError a)] -> ([(PluginId, ResponseError)], [(PluginId, a)]) @@ -303,7 +304,7 @@ makeHover hps lf ideState params makeHover(pid,p) = do pluginConfig <- getPluginConfig lf pid if pluginEnabled pluginConfig plcHoverOn - then p ideState params + then otTracedProvider pid "hover" $ p ideState params else return $ Right Nothing mhs <- mapM makeHover hps -- TODO: We should support ServerCapabilities and declare that @@ -358,7 +359,7 @@ makeSymbols sps lf ideState params makeSymbols (pid,p) = do pluginConfig <- getPluginConfig lf pid if pluginEnabled pluginConfig plcSymbolsOn - then p lf ideState params + then otTracedProvider pid "symbols" $ p lf ideState params else return $ Right [] mhs <- mapM makeSymbols sps case rights mhs of @@ -387,7 +388,7 @@ renameWith providers lspFuncs state params = do makeAction (pid,p) = do pluginConfig <- getPluginConfig lspFuncs pid if pluginEnabled pluginConfig plcRenameOn - then p lspFuncs state params + then otTracedProvider pid "rename" $ p lspFuncs state params else return $ Right $ WorkspaceEdit Nothing Nothing -- TODO:AZ: we need to consider the right way to combine possible renamers results <- mapM makeAction providers @@ -453,7 +454,7 @@ makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier makeAction (pid,p) = do pluginConfig <- getPluginConfig lf pid if pluginEnabled pluginConfig plcCompletionOn - then p lf ideState params + then otTracedProvider pid "completions" $ p lf ideState params else return $ Right $ Completions $ List [] case mprefix of From f12197f325b1f9dfbbcec01632901a11e4eced8b Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 16 Jan 2021 14:11:13 +0000 Subject: [PATCH 2/3] Include URIs in handler traces --- ghcide/src/Development/IDE/Core/Tracing.hs | 21 +++++---- .../src/Development/IDE/LSP/LanguageServer.hs | 36 ++++++++++------ ghcide/src/Development/IDE/LSP/Server.hs | 43 +++++++++++++++++-- 3 files changed, 74 insertions(+), 26 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 6b6965a3a8..caed3e0e64 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -5,7 +5,7 @@ module Development.IDE.Core.Tracing , startTelemetry , measureMemory , getInstrumentCached - ,otTracedPlugin) + ,otTracedProvider,otSetUri) where import Control.Concurrent.Async (Async, async) @@ -33,18 +33,19 @@ import HeapSize (recursiveSize, runHeapsize) import Language.Haskell.LSP.Types (NormalizedFilePath, fromNormalizedFilePath) import Numeric.Natural (Natural) -import OpenTelemetry.Eventlog (Synchronicity(Asynchronous), Instrument, addEvent, beginSpan, endSpan, +import OpenTelemetry.Eventlog (SpanInFlight, Synchronicity(Asynchronous), Instrument, addEvent, beginSpan, endSpan, mkValueObserver, observe, setTag, withSpan, withSpan_) import Data.ByteString (ByteString) import Data.Text.Encoding (encodeUtf8) import Ide.Types (PluginId (..)) +import Development.IDE.Types.Location (Uri (..)) -- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span. otTracedHandler :: String -- ^ Message type -> String -- ^ Message label - -> IO a + -> (SpanInFlight -> IO a) -> IO a otTracedHandler requestType label act = let !name = @@ -52,7 +53,10 @@ otTracedHandler requestType label act = then requestType else requestType <> ":" <> show label -- Add an event so all requests can be quickly seen in the viewer without searching - in withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> act) + in withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> act sp) + +otSetUri :: SpanInFlight -> Uri -> IO () +otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t) -- | Trace a Shake action using opentelemetry. otTracedAction @@ -74,10 +78,11 @@ otTracedAction key file success act = actionBracket unless (success res) $ setTag sp "error" "1" return res) -otTracedPlugin :: PluginId -> ByteString -> IO a -> IO a -otTracedPlugin (PluginId pluginName) provider act = - let !msg = "plugin:" <> encodeUtf8 pluginName <> " " <> "provider:" <> provider - in withSpan msg (const act) +otTracedProvider :: PluginId -> ByteString -> IO a -> IO a +otTracedProvider (PluginId pluginName) provider act = + withSpan (provider <> " provider") $ \sp -> do + setTag sp "plugin" (encodeUtf8 pluginName) + act startTelemetry :: Bool -> Logger -> Var Values -> IO () startTelemetry allTheTime logger stateRef = do diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 9a3c37a166..fd55e614dc 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -147,21 +147,25 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat -- We dispatch notifications synchronously and requests asynchronously -- This is to ensure that all file edits and config changes are applied before a request is handled case msg of - Notification x@NotificationMessage{_params, _method} act -> otTracedHandler "Notification" (show _method) $ do - catch (act lspFuncs ide _params) $ \(e :: SomeException) -> + Notification x@NotificationMessage{_params, _method} act -> + otTracedHandler "Notification" (show _method) $ \sp -> do + traceWithSpan sp _params + catch (act lspFuncs ide _params) $ \(e :: SomeException) -> logError (ideLogger ide) $ T.pack $ "Unexpected exception on notification, please report!\n" ++ "Message: " ++ show x ++ "\n" ++ "Exception: " ++ show e Response x@RequestMessage{_id, _method, _params} wrap act -> void $ async $ - otTracedHandler "Request" (show _method) $ - checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $ + otTracedHandler "Request" (show _method) $ \sp -> do + traceWithSpan sp _params + checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $ \case Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e) Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r) ResponseAndRequest x@RequestMessage{_id, _method, _params} wrap wrapNewReq act -> void $ async $ - otTracedHandler "Request" (show _method) $ - checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $ + otTracedHandler "Request" (show _method) $ \sp -> do + traceWithSpan sp _params + checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $ \(res, newReq) -> do case res of Left e -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e) @@ -170,8 +174,9 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat reqId <- getNextReqId sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams InitialParams x@RequestMessage{_id, _method, _params} act -> - otTracedHandler "Initialize" (show _method) $ - catch (act lspFuncs ide _params) $ \(e :: SomeException) -> + otTracedHandler "Initialize" (show _method) $ \sp -> do + traceWithSpan sp _params + catch (act lspFuncs ide _params) $ \(e :: SomeException) -> logError (ideLogger ide) $ T.pack $ "Unexpected exception on InitializeRequest handler, please report!\n" ++ "Message: " ++ show x ++ "\n" ++ @@ -238,14 +243,17 @@ exitHandler exit = PartialHandlers $ \_ x -> return x -- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety -- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer) data Message c - = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) - -- | Used for cases in which we need to send not only a response, + = forall m req resp . (Show m, Show req, HasTracing req) => + Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) + | -- | Used for cases in which we need to send not only a response, -- but also an additional request to the client. -- For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request. - | forall m rm req resp newReqParams newReqBody . (Show m, Show rm, Show req) => ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) - | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ()) - -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler. - | InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ()) + forall m rm req resp newReqParams newReqBody. (Show m, Show rm, Show req, HasTracing req) => + ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) + | forall m req . (Show m, Show req, HasTracing req) => + Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ()) + | -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler. + InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ()) modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS diff --git a/ghcide/src/Development/IDE/LSP/Server.hs b/ghcide/src/Development/IDE/LSP/Server.hs index 976c25328a..0bbc0ae387 100644 --- a/ghcide/src/Development/IDE/LSP/Server.hs +++ b/ghcide/src/Development/IDE/LSP/Server.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 @@ -6,27 +8,33 @@ module Development.IDE.LSP.Server ( WithMessage(..) , PartialHandlers(..) - ) where + , HasTracing(..) + ,setUriAnd) where +import Control.Lens ((^.)) import Data.Default import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Core as LSP import qualified Language.Haskell.LSP.Messages as LSP +import Language.Haskell.LSP.Types.Lens (HasTextDocument (textDocument), HasUri (uri)) import Development.IDE.Core.Service +import Data.Aeson (Value) +import Development.IDE.Core.Tracing (otSetUri) +import OpenTelemetry.Eventlog (SpanInFlight) data WithMessage c = WithMessage - {withResponse :: forall m req resp . (Show m, Show req) => + {withResponse :: forall m req resp . (Show m, Show req, HasTracing req) => (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work Maybe (LSP.Handler (RequestMessage m req resp)) - ,withNotification :: forall m req . (Show m, Show req) => + ,withNotification :: forall m req . (Show m, Show req, HasTracing req) => Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler (LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work Maybe (LSP.Handler (NotificationMessage m req)) ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody . - (Show m, Show rm, Show req, Show newReqParams, Show newReqBody) => + (Show m, Show rm, Show req, Show newReqParams, Show newReqBody, HasTracing req) => (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work @@ -45,3 +53,30 @@ instance Semigroup (PartialHandlers c) where instance Monoid (PartialHandlers c) where mempty = def + +class HasTracing a where + traceWithSpan :: SpanInFlight -> a -> IO () + traceWithSpan _ _ = pure () + +instance {-# OVERLAPPABLE #-} (HasTextDocument a doc, HasUri doc Uri) => HasTracing a where + traceWithSpan sp a = otSetUri sp (a ^. textDocument . uri) + +instance HasTracing Value +instance HasTracing ExecuteCommandParams +instance HasTracing DidChangeWatchedFilesParams +instance HasTracing DidChangeWorkspaceFoldersParams +instance HasTracing DidChangeConfigurationParams +instance HasTracing InitializeParams +instance HasTracing (Maybe InitializedParams) + +setUriAnd :: + (HasTextDocument params a, HasUri a Uri) => + (lspFuncs -> ide -> params -> IO res) -> + lspFuncs -> + SpanInFlight -> + ide -> + params -> + IO res +setUriAnd k lf sp ide params = do + otSetUri sp (params ^. textDocument . uri) + k lf ide params From 5813991db4c6d2614202846424ea2d0fa359149b Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 17 Jan 2021 14:12:38 +0000 Subject: [PATCH 3/3] Compat with ghc 8.6 --- ghcide/.hlint.yaml | 1 + ghcide/src/Development/IDE/Core/Tracing.hs | 6 ++++++ 2 files changed, 7 insertions(+) diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml index 1a4a53be7b..33f89a6bcf 100644 --- a/ghcide/.hlint.yaml +++ b/ghcide/.hlint.yaml @@ -78,6 +78,7 @@ - Development.IDE.Core.FileStore - Development.IDE.Core.Compile - Development.IDE.Core.Rules + - Development.IDE.Core.Tracing - Development.IDE.GHC.Compat - Development.IDE.GHC.ExactPrint - Development.IDE.GHC.Orphans diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index caed3e0e64..b61aa99eb1 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +#include "ghc-api-version.h" module Development.IDE.Core.Tracing ( otTracedHandler , otTracedAction @@ -78,7 +80,11 @@ otTracedAction key file success act = actionBracket unless (success res) $ setTag sp "error" "1" return res) +#if MIN_GHC_API_VERSION(8,8,0) otTracedProvider :: PluginId -> ByteString -> IO a -> IO a +#else +otTracedProvider :: PluginId -> String -> IO a -> IO a +#endif otTracedProvider (PluginId pluginName) provider act = withSpan (provider <> " provider") $ \sp -> do setTag sp "plugin" (encodeUtf8 pluginName)