module Development.IDE.Core.Tracing
    ( otTracedHandler
    , otTracedAction
    , otTracedProvider
    , otSetUri
    , otTracedGarbageCollection
    , withTrace
    , withEventTrace
    , withTelemetryLogger
    )
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                        (Logger (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
  = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan (forall a. IsString a => String -> a
fromString String
name) forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
      let setSpan' :: String -> String -> m ()
setSpan' String
k String
v = forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp (forall a. IsString a => String -> a
fromString String
k) (forall a. IsString a => String -> a
fromString String
v)
      (String -> String -> m ()) -> m a
act forall {m :: * -> *}. MonadIO m => String -> String -> m ()
setSpan'
  | Bool
otherwise = (String -> String -> m ()) -> m a
act (\String
_ String
_ -> 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
  = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan (forall a. IsString a => String -> a
fromString String
name) forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
      (ByteString -> m ()) -> m a
act (forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
addEvent SpanInFlight
sp ByteString
"")
  | Bool
otherwise = (ByteString -> m ()) -> m a
act (\ByteString
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Returns a logger that produces telemetry events in a single span
withTelemetryLogger :: (MonadIO m, MonadMask m) => (Logger -> m a) -> m a
withTelemetryLogger :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
(Logger -> m a) -> m a
withTelemetryLogger Logger -> m a
k = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan ByteString
"Logger" 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
    Logger -> m a
k forall a b. (a -> b) -> a -> b
$ (Priority -> Text -> IO ()) -> Logger
Logger forall a b. (a -> b) -> a -> b
$ \Priority
p Text
m ->
            forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
addEvent SpanInFlight
sp (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Priority
p) (Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ Text -> Text
trim Text
m)
    where
        -- eventlog message size is limited by EVENT_PAYLOAD_SIZE_MAX = STG_WORD16_MAX
        trim :: Text -> Text
trim = Int -> Text -> Text
T.take (forall a b. (Integral a, Num b) => a -> b
fromIntegral(forall a. Bounded a => a
maxBound :: Word16) 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
label
            then String
requestType
            else String
requestType forall a. Semigroup a => a -> a -> a
<> String
":" forall a. Semigroup a => a -> a -> a
<> 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 <- forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan (forall a. IsString a => String -> a
fromString String
name) (\SpanInFlight
sp -> forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
addEvent SpanInFlight
sp ByteString
"" (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ String
name forall a. Semigroup a => a -> a -> a
<> String
" received") 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) = 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 = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
        (do
            SpanInFlight
sp <- forall (m :: * -> *). MonadIO m => ByteString -> m SpanInFlight
beginSpan (forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show k
key))
            forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"File" (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ NormalizedFilePath -> String
fromNormalizedFilePath NormalizedFilePath
file)
            forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"Mode" (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show RunMode
mode)
            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 -> forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"aborted" ByteString
"1"
            ExitCaseException SomeException
e -> forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"exception" (String -> ByteString
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
e)
            ExitCaseSuccess RunResult a
res -> do
                forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"result" (String -> ByteString
pack forall a b. (a -> b) -> a -> b
$ a -> String
result forall a b. (a -> b) -> a -> b
$ forall value. RunResult value -> value
runValue RunResult a
res)
                forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"changed" forall a b. (a -> b) -> a -> b
$ case RunResult a
res of
                    RunResult RunChanged
x ByteString
_ a
_ -> forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show RunChanged
x
          forall (m :: * -> *). MonadIO m => SpanInFlight -> m ()
endSpan SpanInFlight
sp)
        (\SpanInFlight
sp -> ([FileDiagnostic] -> Action ()) -> Action (RunResult a)
act (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"diagnostics" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FileDiagnostic] -> Text
showDiagnostics ))
  | Bool
otherwise = ([FileDiagnostic] -> Action ()) -> Action (RunResult a)
act (\[FileDiagnostic]
_ -> 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 = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket
        (forall (m :: * -> *). MonadIO m => ByteString -> m SpanInFlight
beginSpan ByteString
label)
        (\SpanInFlight
sp ExitCase [a]
ec -> do
            case ExitCase [a]
ec of
                ExitCase [a]
ExitCaseAbort -> forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"aborted" ByteString
"1"
                ExitCaseException SomeException
e -> forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"exception" (String -> ByteString
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
e)
                ExitCaseSuccess [a]
res -> forall (m :: * -> *).
MonadIO m =>
SpanInFlight -> ByteString -> ByteString -> m ()
setTag SpanInFlight
sp ByteString
"keys" (String -> ByteString
pack forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [a]
res)
            forall (m :: * -> *). MonadIO m => SpanInFlight -> m ()
endSpan SpanInFlight
sp)
        (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 <- forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ByteString -> (SpanInFlight -> m a) -> m a
withSpan (ByteString
provider forall a. Semigroup a => a -> a -> a
<> ByteString
" provider") forall a b. (a -> b) -> a -> b
$ \SpanInFlight
sp -> do
        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