Skip to content

Commit 0fa05b8

Browse files
wz1000wz1000
committed
restore telemetry
1 parent 49b35e0 commit 0fa05b8

File tree

8 files changed

+72
-62
lines changed

8 files changed

+72
-62
lines changed

‎cabal.project

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -24,14 +24,14 @@ package ghcide
2424

2525
source-repository-package
2626
type: git
27-
location: https://github.com/alanz/lsp.git
28-
tag: a720ad10577e0c9151da40ff2ff43b18241814ae
27+
location: https://github.com/wz1000/haskell-lsp.git
28+
tag: f42dd88fc1228ce01c0c938a2e2d9a25f425f755
2929
subdir: lsp-types
3030

3131
source-repository-package
3232
type: git
33-
location: https://github.com/alanz/lsp.git
34-
tag: a720ad10577e0c9151da40ff2ff43b18241814ae
33+
location: https://github.com/wz1000/haskell-lsp.git
34+
tag: f42dd88fc1228ce01c0c938a2e2d9a25f425f755
3535

3636
source-repository-package
3737
type: git

‎ghcide/ghcide.cabal

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -91,7 +91,8 @@ library
9191
bytestring-encoding,
9292
opentelemetry >=0.6.1,
9393
heapsize ==0.3.*,
94-
unliftio
94+
unliftio,
95+
unliftio-core
9596
if flag(ghc-lib)
9697
build-depends:
9798
ghc-lib >= 8.8,

‎ghcide/src/Development/IDE/Core/Tracing.hs

Lines changed: 15 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,7 @@ import Development.IDE.Core.RuleTypes (GhcSession (GhcSession),
2828
GhcSessionIO (GhcSessionIO))
2929
import Development.IDE.Types.Logger (logInfo, Logger, logDebug)
3030
import Development.IDE.Types.Shake (ValueWithDiagnostics(..), Key (..), Value, Values)
31-
import Development.Shake (Action, actionBracket, liftIO)
31+
import Development.Shake (Action, actionBracket)
3232
import Ide.PluginUtils (installSigUsr1Handler)
3333
import Foreign.Storable (Storable (sizeOf))
3434
import HeapSize (recursiveSize, runHeapsize)
@@ -42,20 +42,24 @@ import Data.ByteString (ByteString)
4242
import Data.Text.Encoding (encodeUtf8)
4343
import Ide.Types (PluginId (..))
4444
import Development.IDE.Types.Location (Uri (..))
45+
import Control.Monad.IO.Unlift
4546

4647
-- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span.
4748
otTracedHandler
48-
:: String -- ^ Message type
49+
:: MonadUnliftIO m
50+
=> String -- ^ Message type
4951
-> String -- ^ Message label
50-
-> (SpanInFlight -> IO a)
51-
-> IO a
52+
-> (SpanInFlight -> m a)
53+
-> m a
5254
otTracedHandler requestType label act =
5355
let !name =
5456
if null label
5557
then requestType
5658
else requestType <> ":" <> show label
5759
-- Add an event so all requests can be quickly seen in the viewer without searching
58-
in withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> act sp)
60+
in do
61+
runInIO <- askRunInIO
62+
liftIO $ withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> runInIO (act sp))
5963

6064
otSetUri :: SpanInFlight -> Uri -> IO ()
6165
otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t)
@@ -81,14 +85,15 @@ otTracedAction key file success act = actionBracket
8185
return res)
8286

8387
#if MIN_GHC_API_VERSION(8,8,0)
84-
otTracedProvider :: PluginId -> ByteString -> IO a -> IO a
88+
otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a
8589
#else
86-
otTracedProvider :: PluginId -> String -> IO a -> IO a
90+
otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a
8791
#endif
88-
otTracedProvider (PluginId pluginName) provider act =
89-
withSpan (provider <> " provider") $ \sp -> do
92+
otTracedProvider (PluginId pluginName) provider act = do
93+
runInIO <- askRunInIO
94+
liftIO $ withSpan (provider <> " provider") $ \sp -> do
9095
setTag sp "plugin" (encodeUtf8 pluginName)
91-
act
96+
runInIO act
9297

9398
startTelemetry :: Bool -> Logger -> Var Values -> IO ()
9499
startTelemetry allTheTime logger stateRef = do

‎ghcide/src/Development/IDE/LSP/LanguageServer.hs

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ import UnliftIO.Async
3232
import UnliftIO.Concurrent
3333
import Control.Monad.IO.Class
3434
import Control.Monad.Reader
35+
import Ide.Types (traceWithSpan)
3536

3637
import Development.IDE.Core.IdeConfiguration
3738
import Development.IDE.Core.Shake
@@ -132,7 +133,8 @@ runLanguageServer options onConfigurationChange userHandlers getIdeState = do
132133
handleInit
133134
:: IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage
134135
-> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))
135-
handleInit exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ _ params) = do
136+
handleInit exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do
137+
liftIO $ traceWithSpan sp params
136138
let root = LSP.resRootPath env
137139
ide <- liftIO $ getIdeState env (makeLSPVFSHandle env) root
138140

‎ghcide/src/Development/IDE/LSP/Server.hs

Lines changed: 15 additions & 40 deletions
Original file line numberDiff line numberDiff line change
@@ -10,18 +10,14 @@
1010
{-# LANGUAGE GADTs #-}
1111
module Development.IDE.LSP.Server where
1212

13-
import Language.LSP.Server (LspM, Handler, Handlers)
13+
import Language.LSP.Server (LspM, Handlers)
1414
import Language.LSP.Types
15-
import Language.LSP.Types.Lens
16-
import Control.Lens ((^.))
1715
import qualified Language.LSP.Server as LSP
1816
import Development.IDE.Core.Shake
1917
import UnliftIO.Chan
2018
import Control.Monad.Reader
21-
import Data.Aeson (Value)
22-
import Development.IDE.Core.Tracing (otSetUri)
23-
import OpenTelemetry.Eventlog (SpanInFlight, setTag)
24-
import Data.Text.Encoding (encodeUtf8)
19+
import Ide.Types (HasTracing, traceWithSpan)
20+
import Development.IDE.Core.Tracing
2521

2622
data ReactorMessage
2723
= ReactorNotification (IO ())
@@ -31,51 +27,30 @@ type ReactorChan = Chan ReactorMessage
3127
type ServerM c = ReaderT (ReactorChan, IdeState) (LspM c)
3228

3329
requestHandler
34-
:: forall (m :: Method FromClient Request) c.
30+
:: forall (m :: Method FromClient Request) c. (HasTracing (MessageParams m)) =>
3531
SMethod m
3632
-> (IdeState -> MessageParams m -> LspM c (Either ResponseError (ResponseResult m)))
3733
-> Handlers (ServerM c)
38-
requestHandler m k = LSP.requestHandler m $ \RequestMessage{_id,_params} resp -> do
34+
requestHandler m k = LSP.requestHandler m $ \RequestMessage{_method,_id,_params} resp -> do
3935
st@(chan,ide) <- ask
4036
env <- LSP.getLspEnv
4137
let resp' = flip runReaderT st . resp
42-
writeChan chan $ ReactorRequest (SomeLspId _id) (LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left)
38+
trace x = otTracedHandler "Request" (show _method) $ \sp -> do
39+
traceWithSpan sp _params
40+
x
41+
writeChan chan $ ReactorRequest (SomeLspId _id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left)
4342

4443
notificationHandler
45-
:: forall (m :: Method FromClient Notification) c.
44+
:: forall (m :: Method FromClient Notification) c. (HasTracing (MessageParams m)) =>
4645
SMethod m
4746
-> (IdeState -> MessageParams m -> LspM c ())
4847
-> Handlers (ServerM c)
49-
notificationHandler m k = LSP.notificationHandler m $ \NotificationMessage{_params}-> do
48+
notificationHandler m k = LSP.notificationHandler m $ \NotificationMessage{_params,_method}-> do
5049
(chan,ide) <- ask
5150
env <- LSP.getLspEnv
52-
writeChan chan $ ReactorNotification (LSP.runLspT env $ k ide _params)
51+
let trace x = otTracedHandler "Notification" (show _method) $ \sp -> do
52+
traceWithSpan sp _params
53+
x
54+
writeChan chan $ ReactorNotification (trace $ LSP.runLspT env $ k ide _params)
5355

54-
class HasTracing a where
55-
traceWithSpan :: SpanInFlight -> a -> IO ()
56-
traceWithSpan _ _ = pure ()
5756

58-
instance {-# OVERLAPPABLE #-} (HasTextDocument a doc, HasUri doc Uri) => HasTracing a where
59-
traceWithSpan sp a = otSetUri sp (a ^. textDocument . uri)
60-
61-
instance HasTracing Value
62-
instance HasTracing ExecuteCommandParams
63-
instance HasTracing DidChangeWatchedFilesParams
64-
instance HasTracing DidChangeWorkspaceFoldersParams
65-
instance HasTracing DidChangeConfigurationParams
66-
instance HasTracing InitializeParams
67-
instance HasTracing (Maybe InitializedParams)
68-
instance HasTracing WorkspaceSymbolParams where
69-
traceWithSpan sp (WorkspaceSymbolParams _ _ query) = setTag sp "query" (encodeUtf8 query)
70-
71-
setUriAnd ::
72-
(HasTextDocument params a, HasUri a Uri) =>
73-
(lspFuncs -> ide -> params -> IO res) ->
74-
lspFuncs ->
75-
SpanInFlight ->
76-
ide ->
77-
params ->
78-
IO res
79-
setUriAnd k lf sp ide params = do
80-
otSetUri sp (params ^. textDocument . uri)
81-
k lf ide params

‎ghcide/src/Development/IDE/Plugin/HLS.hs

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,6 @@ module Development.IDE.Plugin.HLS
1010

1111
import Control.Exception(SomeException)
1212
import Control.Monad
13-
import Control.Monad.IO.Class
1413
import qualified Data.Aeson as J
1514
import Data.Either
1615
import qualified Data.List as List
@@ -20,14 +19,13 @@ import Development.IDE.Core.Shake
2019
import Development.IDE.LSP.Server
2120
import Development.IDE.Plugin
2221
import Ide.Plugin.Config
23-
import Ide.PluginUtils
2422
import Ide.Types as HLS
2523
import qualified Language.LSP.Server as LSP
2624
import qualified Language.LSP.Types as J
2725
import Language.LSP.Types
2826
import Text.Regex.TDFA.Text()
2927
import Development.Shake (Rules)
30-
import Ide.PluginUtils (getClientConfig, pluginEnabled, getPluginConfig, responseError, getProcessID)
28+
import Ide.PluginUtils (getClientConfig)
3129
import Development.IDE.Core.Tracing
3230
import UnliftIO.Async (forConcurrently)
3331
import UnliftIO.Exception (catchAny)
@@ -36,6 +34,7 @@ import qualified Data.Dependent.Map as DMap
3634
import Data.Dependent.Sum
3735
import Data.List.NonEmpty (nonEmpty,NonEmpty,toList)
3836
import UnliftIO (MonadUnliftIO)
37+
import Data.String
3938

4039
-- ---------------------------------------------------------------------
4140
--
@@ -148,7 +147,7 @@ extensiblePlugins xs = Plugin mempty handlers
148147
Nothing
149148
Just fs -> do
150149
let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e)
151-
es <- runConcurrently msg fs ide params
150+
es <- runConcurrently msg (show m) fs ide params
152151
let (errs,succs) = partitionEithers $ toList es
153152
case nonEmpty succs of
154153
Nothing -> pure $ Left $ combineErrors errs
@@ -159,11 +158,12 @@ extensiblePlugins xs = Plugin mempty handlers
159158
runConcurrently
160159
:: MonadUnliftIO m
161160
=> (SomeException -> PluginId -> T.Text)
161+
-> String -- ^ label
162162
-> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))
163163
-> a
164164
-> b
165165
-> m (NonEmpty (Either ResponseError d))
166-
runConcurrently msg fs a b = fmap join $ forConcurrently fs $ \(pid,f) ->
166+
runConcurrently msg method fs a b = fmap join $ forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do
167167
f a b
168168
`catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing)
169169

‎hls-plugin-api/hls-plugin-api.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -49,6 +49,7 @@ library
4949
, dependent-map
5050
, dependent-sum
5151
, dlist
52+
, opentelemetry
5253

5354
if os(windows)
5455
build-depends:

‎hls-plugin-api/src/Ide/Types.hs

Lines changed: 27 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,8 @@
1212
{-# LANGUAGE DeriveGeneric #-}
1313
{-# LANGUAGE ConstraintKinds #-}
1414
{-# LANGUAGE CPP #-}
15+
{-# LANGUAGE FlexibleInstances #-}
16+
{-# LANGUAGE UndecidableInstances #-}
1517

1618
module Ide.Types
1719
where
@@ -46,6 +48,8 @@ import qualified Data.DList as DList
4648
import qualified Data.Default
4749
import System.IO.Unsafe
4850
import Control.Monad
51+
import OpenTelemetry.Eventlog
52+
import Data.Text.Encoding (encodeUtf8)
4953

5054
-- ---------------------------------------------------------------------
5155

@@ -64,7 +68,7 @@ data PluginDescriptor ideState =
6468
-- | Methods that can be handled by plugins.
6569
-- 'ExtraParams' captures any extra data the IDE passes to the handlers for this method
6670
-- Only methods for which we know how to combine responses can be instances of 'PluginMethod'
67-
class PluginMethod m where
71+
class HasTracing (MessageParams m) => PluginMethod m where
6872

6973
-- | Parse the configuration to check if this plugin is enabled
7074
pluginEnabled :: SMethod m -> PluginId -> Config -> Bool
@@ -319,6 +323,28 @@ data FallbackCodeActionParams =
319323

320324
-- ---------------------------------------------------------------------
321325

326+
otSetUri :: SpanInFlight -> Uri -> IO ()
327+
otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t)
328+
329+
class HasTracing a where
330+
traceWithSpan :: SpanInFlight -> a -> IO ()
331+
traceWithSpan _ _ = pure ()
332+
333+
instance {-# OVERLAPPABLE #-} (HasTextDocument a doc, HasUri doc Uri) => HasTracing a where
334+
traceWithSpan sp a = otSetUri sp (a ^. J.textDocument . J.uri)
335+
336+
instance HasTracing Value
337+
instance HasTracing ExecuteCommandParams
338+
instance HasTracing DidChangeWatchedFilesParams
339+
instance HasTracing DidChangeWorkspaceFoldersParams
340+
instance HasTracing DidChangeConfigurationParams
341+
instance HasTracing InitializeParams
342+
instance HasTracing (Maybe InitializedParams)
343+
instance HasTracing WorkspaceSymbolParams where
344+
traceWithSpan sp (WorkspaceSymbolParams _ _ query) = setTag sp "query" (encodeUtf8 query)
345+
346+
-- ---------------------------------------------------------------------
347+
322348
{-# NOINLINE pROCESS_ID #-}
323349
pROCESS_ID :: T.Text
324350
pROCESS_ID = unsafePerformIO getPid

0 commit comments

Comments
 (0)