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 ())

-- | Returns a logger that produces telemetry events in a single span
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 ->
    -- Tracy doesn't like when we create a new span for every log line.
    -- To workaround that, we create a single span for all log events.
    -- This is fine since we don't care about the span itself, only about the events
    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

-- | Returns a logger that produces telemetry events in a single span.
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
    -- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX
    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)

-- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span.
otTracedHandler
    :: MonadUnliftIO m
    => String -- ^ Message type
    -> String -- ^ Message label
    -> (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
    -- Add an event so all requests can be quickly seen in the viewer without searching
    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)

-- | Trace a Shake action using opentelemetry.
otTracedAction
    :: Show k
    => k -- ^ The Action's Key
    -> NormalizedFilePath -- ^ Path to the file the action was run for
    -> RunMode
    -> (a -> String)
    -> (([FileDiagnostic] -> Action ()) -> Action (RunResult a)) -- ^ The action
    -> 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