module Development.IDE.Core.Tracing
( otTracedHandler
, otTracedAction
, otTracedProvider
, otSetUri
, otTracedGarbageCollection
, withTrace
, withEventTrace
, withTelemetryRecorder
)
where
import Control.Exception.Safe (generalBracket)
import Control.Monad.Catch (ExitCase (..), MonadMask)
import Control.Monad.IO.Unlift
import Data.ByteString (ByteString)
import Data.ByteString.Char8 (pack)
import Data.String (IsString (fromString))
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word16)
import Debug.Trace.Flags (userTracingEnabled)
import Development.IDE.Graph (Action)
import Development.IDE.Graph.Rule
import Development.IDE.Types.Diagnostics (FileDiagnostic,
showDiagnostics)
import Development.IDE.Types.Location (Uri (..))
import Ide.Logger
import Ide.Types (PluginId (..))
import Language.LSP.Protocol.Types (NormalizedFilePath,
fromNormalizedFilePath)
import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent,
beginSpan, endSpan, setTag,
withSpan)
withTrace :: (MonadMask m, MonadIO m) => String -> ((String -> String -> m ()) -> m a) -> m a
withTrace :: forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
String -> ((String -> String -> m ()) -> m a) -> m a
withTrace String
name (String -> String -> m ()) -> m a
act
| Bool
userTracingEnabled
= ByteString -> (SpanInFlight -> m a) -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan (String -> ByteString
forall a. IsString a => String -> a
fromString String
name) ((SpanInFlight -> m a) -> m a) -> (SpanInFlight -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
let setSpan' :: String -> String -> m ()
setSpan' String
k String
v = SpanInFlight -> ByteString -> ByteString -> m ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp (String -> ByteString
forall a. IsString a => String -> a
fromString String
k) (String -> ByteString
forall a. IsString a => String -> a
fromString String
v)
(String -> String -> m ()) -> m a
act String -> String -> m ()
forall {m :: * -> *}. MonadIO m => String -> String -> m ()
setSpan'
| Bool
otherwise = (String -> String -> m ()) -> m a
act (\String
_ String
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
withEventTrace :: (MonadMask m, MonadIO m) => String -> ((ByteString -> m ()) -> m a) -> m a
withEventTrace :: forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
String -> ((ByteString -> m ()) -> m a) -> m a
withEventTrace String
name (ByteString -> m ()) -> m a
act
| Bool
userTracingEnabled
= ByteString -> (SpanInFlight -> m a) -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan (String -> ByteString
forall a. IsString a => String -> a
fromString String
name) ((SpanInFlight -> m a) -> m a) -> (SpanInFlight -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
(ByteString -> m ()) -> m a
act (SpanInFlight -> ByteString -> ByteString -> m ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
addEvent SpanInFlight
sp ByteString
"")
| Bool
otherwise = (ByteString -> m ()) -> m a
act (\ByteString
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
withTelemetryRecorder :: (MonadIO m, MonadMask m) => (Recorder (WithPriority (Doc a)) -> m c) -> m c
withTelemetryRecorder :: forall (m :: * -> *) a c.
(MonadIO m, MonadMask m) =>
(Recorder (WithPriority (Doc a)) -> m c) -> m c
withTelemetryRecorder Recorder (WithPriority (Doc a)) -> m c
k = ByteString -> (SpanInFlight -> m c) -> m c
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan ByteString
"Logger" ((SpanInFlight -> m c) -> m c) -> (SpanInFlight -> m c) -> m c
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp ->
Recorder (WithPriority (Doc a)) -> m c
k (Recorder (WithPriority (Doc a)) -> m c)
-> Recorder (WithPriority (Doc a)) -> m c
forall a b. (a -> b) -> a -> b
$ SpanInFlight -> Recorder (WithPriority (Doc a))
forall a. SpanInFlight -> Recorder (WithPriority (Doc a))
telemetryLogRecorder SpanInFlight
sp
telemetryLogRecorder :: SpanInFlight -> Recorder (WithPriority (Doc a))
telemetryLogRecorder :: forall a. SpanInFlight -> Recorder (WithPriority (Doc a))
telemetryLogRecorder SpanInFlight
sp = (forall (m :: * -> *). MonadIO m => WithPriority (Doc a) -> m ())
-> Recorder (WithPriority (Doc a))
forall msg.
(forall (m :: * -> *). MonadIO m => msg -> m ()) -> Recorder msg
Recorder ((forall (m :: * -> *). MonadIO m => WithPriority (Doc a) -> m ())
-> Recorder (WithPriority (Doc a)))
-> (forall (m :: * -> *).
MonadIO m =>
WithPriority (Doc a) -> m ())
-> Recorder (WithPriority (Doc a))
forall a b. (a -> b) -> a -> b
$ \WithPriority {CallStack
Priority
Doc a
priority :: Priority
callStack_ :: CallStack
payload :: Doc a
priority :: forall a. WithPriority a -> Priority
callStack_ :: forall a. WithPriority a -> CallStack
payload :: forall a. WithPriority a -> a
..} ->
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
addEvent SpanInFlight
sp (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Priority -> String
forall a. Show a => a -> String
show Priority
priority) (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Text
trim (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
renderStrict (SimpleDocStream Any -> Text) -> SimpleDocStream Any -> Text
forall a b. (a -> b) -> a -> b
$ Doc a -> SimpleDocStream Any
forall ann1 ann2. Doc ann1 -> SimpleDocStream ann2
layoutCompact (Doc a -> SimpleDocStream Any) -> Doc a -> SimpleDocStream Any
forall a b. (a -> b) -> a -> b
$ Doc a
payload)
where
trim :: Text -> Text
trim = Int -> Text -> Text
T.take (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral(Word16
forall a. Bounded a => a
maxBound :: Word16) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10)
otTracedHandler
:: MonadUnliftIO m
=> String
-> String
-> (SpanInFlight -> m a)
-> m a
otTracedHandler :: forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> String -> (SpanInFlight -> m a) -> m a
otTracedHandler String
requestType String
label SpanInFlight -> m a
act
| Bool
userTracingEnabled = do
let !name :: String
name =
if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
label
then String
requestType
else String
requestType String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
label
m a -> IO a
runInIO <- m (m a -> IO a)
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ ByteString -> (SpanInFlight -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan (String -> ByteString
forall a. IsString a => String -> a
fromString String
name) (\SpanInFlight
sp -> SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
addEvent SpanInFlight
sp ByteString
"" (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" received") IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a -> IO a
runInIO (SpanInFlight -> m a
act SpanInFlight
sp))
| Bool
otherwise = SpanInFlight -> m a
act (ProcessLocalSpanSerialNumber -> SpanInFlight
SpanInFlight ProcessLocalSpanSerialNumber
0)
otSetUri :: SpanInFlight -> Uri -> IO ()
otSetUri :: SpanInFlight -> Uri -> IO ()
otSetUri SpanInFlight
sp (Uri Text
t) = SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"uri" (Text -> ByteString
encodeUtf8 Text
t)
otTracedAction
:: Show k
=> k
-> NormalizedFilePath
-> RunMode
-> (a -> String)
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult a))
-> Action (RunResult a)
otTracedAction :: forall k a.
Show k =>
k
-> NormalizedFilePath
-> RunMode
-> (a -> String)
-> (([FileDiagnostic] -> Action ()) -> Action (RunResult a))
-> Action (RunResult a)
otTracedAction k
key NormalizedFilePath
file RunMode
mode a -> String
result ([FileDiagnostic] -> Action ()) -> Action (RunResult a)
act
| Bool
userTracingEnabled = (RunResult a, ()) -> RunResult a
forall a b. (a, b) -> a
fst ((RunResult a, ()) -> RunResult a)
-> Action (RunResult a, ()) -> Action (RunResult a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Action SpanInFlight
-> (SpanInFlight -> ExitCase (RunResult a) -> Action ())
-> (SpanInFlight -> Action (RunResult a))
-> Action (RunResult a, ())
forall a b c.
HasCallStack =>
Action a
-> (a -> ExitCase b -> Action c)
-> (a -> Action b)
-> Action (b, c)
forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
(do
SpanInFlight
sp <- ByteString -> Action SpanInFlight
forall (m :: * -> *). MonadIO m => ByteString -> m SpanInFlight
beginSpan (String -> ByteString
forall a. IsString a => String -> a
fromString (k -> String
forall a. Show a => a -> String
show k
key))
SpanInFlight -> ByteString -> ByteString -> Action ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"File" (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
file)
SpanInFlight -> ByteString -> ByteString -> Action ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"Mode" (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ RunMode -> String
forall a. Show a => a -> String
show RunMode
mode)
SpanInFlight -> Action SpanInFlight
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return SpanInFlight
sp
)
(\SpanInFlight
sp ExitCase (RunResult a)
ec -> do
case ExitCase (RunResult a)
ec of
ExitCase (RunResult a)
ExitCaseAbort -> SpanInFlight -> ByteString -> ByteString -> Action ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"aborted" ByteString
"1"
ExitCaseException SomeException
e -> SpanInFlight -> ByteString -> ByteString -> Action ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"exception" (String -> ByteString
pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
ExitCaseSuccess RunResult a
res -> do
SpanInFlight -> ByteString -> ByteString -> Action ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"result" (String -> ByteString
pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> String
result (a -> String) -> a -> String
forall a b. (a -> b) -> a -> b
$ RunResult a -> a
forall value. RunResult value -> value
runValue RunResult a
res)
SpanInFlight -> ByteString -> ByteString -> Action ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"changed" (ByteString -> Action ()) -> ByteString -> Action ()
forall a b. (a -> b) -> a -> b
$ case RunResult a
res of
RunResult RunChanged
x ByteString
_ a
_ STM ()
_ -> String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ RunChanged -> String
forall a. Show a => a -> String
show RunChanged
x
SpanInFlight -> Action ()
forall (m :: * -> *). MonadIO m => SpanInFlight -> m ()
endSpan SpanInFlight
sp)
(\SpanInFlight
sp -> ([FileDiagnostic] -> Action ()) -> Action (RunResult a)
act (IO () -> Action ()
forall a. IO a -> Action a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ())
-> ([FileDiagnostic] -> IO ()) -> [FileDiagnostic] -> Action ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"diagnostics" (ByteString -> IO ())
-> ([FileDiagnostic] -> ByteString) -> [FileDiagnostic] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> ([FileDiagnostic] -> Text) -> [FileDiagnostic] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FileDiagnostic] -> Text
showDiagnostics ))
| Bool
otherwise = ([FileDiagnostic] -> Action ()) -> Action (RunResult a)
act (\[FileDiagnostic]
_ -> () -> Action ()
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
otTracedGarbageCollection :: (MonadMask f, MonadIO f, Show a) => ByteString -> f [a] -> f [a]
otTracedGarbageCollection :: forall (f :: * -> *) a.
(MonadMask f, MonadIO f, Show a) =>
ByteString -> f [a] -> f [a]
otTracedGarbageCollection ByteString
label f [a]
act
| Bool
userTracingEnabled = ([a], ()) -> [a]
forall a b. (a, b) -> a
fst (([a], ()) -> [a]) -> f ([a], ()) -> f [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
f SpanInFlight
-> (SpanInFlight -> ExitCase [a] -> f ())
-> (SpanInFlight -> f [a])
-> f ([a], ())
forall a b c.
HasCallStack =>
f a -> (a -> ExitCase b -> f c) -> (a -> f b) -> f (b, c)
forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
(ByteString -> f SpanInFlight
forall (m :: * -> *). MonadIO m => ByteString -> m SpanInFlight
beginSpan ByteString
label)
(\SpanInFlight
sp ExitCase [a]
ec -> do
case ExitCase [a]
ec of
ExitCase [a]
ExitCaseAbort -> SpanInFlight -> ByteString -> ByteString -> f ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"aborted" ByteString
"1"
ExitCaseException SomeException
e -> SpanInFlight -> ByteString -> ByteString -> f ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"exception" (String -> ByteString
pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
ExitCaseSuccess [a]
res -> SpanInFlight -> ByteString -> ByteString -> f ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"keys" (String -> ByteString
pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show [a]
res)
SpanInFlight -> f ()
forall (m :: * -> *). MonadIO m => SpanInFlight -> m ()
endSpan SpanInFlight
sp)
(f [a] -> SpanInFlight -> f [a]
forall a b. a -> b -> a
const f [a]
act)
| Bool
otherwise = f [a]
act
otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a
otTracedProvider :: forall (m :: * -> *) a.
MonadUnliftIO m =>
PluginId -> ByteString -> m a -> m a
otTracedProvider (PluginId Text
pluginName) ByteString
provider m a
act
| Bool
userTracingEnabled = do
m a -> IO a
runInIO <- m (m a -> IO a)
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ ByteString -> (SpanInFlight -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan (ByteString
provider ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" provider") ((SpanInFlight -> IO a) -> IO a) -> (SpanInFlight -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
SpanInFlight -> ByteString -> ByteString -> IO ()
forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"plugin" (Text -> ByteString
encodeUtf8 Text
pluginName)
m a -> IO a
runInIO m a
act
| Bool
otherwise = m a
act