module Development.IDE.Monitoring.OpenTelemetry (monitoring) where

import           Control.Concurrent.Async         (Async, async, cancel)
import           Control.Monad                    (forever)
import           Data.IORef.Extra                 (atomicModifyIORef'_,
                                                   newIORef, readIORef)
import           Data.Text.Encoding               (encodeUtf8)
import           Debug.Trace.Flags                (userTracingEnabled)
import           Development.IDE.Types.Monitoring (Monitoring (..))
import           OpenTelemetry.Eventlog           (mkValueObserver, observe)
import           System.Time.Extra                (Seconds, sleep)

-- | Dump monitoring to the eventlog using the Opentelemetry package
monitoring :: IO Monitoring
monitoring :: IO Monitoring
monitoring
  | Bool
userTracingEnabled = do
    IORef [IO ()]
actions <- [IO ()] -> IO (IORef [IO ()])
forall a. a -> IO (IORef a)
newIORef []
    let registerCounter :: Text -> IO a -> IO ()
registerCounter Text
name IO a
readA = do
            ValueObserver
observer <- InstrumentName -> IO ValueObserver
forall (m :: * -> *).
MonadIO m =>
InstrumentName -> m ValueObserver
mkValueObserver (Text -> InstrumentName
encodeUtf8 Text
name)
            let update :: IO ()
update = ValueObserver -> Int -> IO ()
forall (m :: * -> *) (a :: Additivity) (m' :: Monotonicity).
MonadIO m =>
Instrument 'Asynchronous a m' -> Int -> m ()
observe ValueObserver
observer (Int -> IO ()) -> (a -> Int) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> IO ()) -> IO a -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a
readA
            IORef [IO ()] -> ([IO ()] -> [IO ()]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
atomicModifyIORef'_ IORef [IO ()]
actions (IO ()
update :)
        registerGauge :: Text -> IO Int64 -> IO ()
registerGauge = Text -> IO Int64 -> IO ()
forall {a}. Integral a => Text -> IO a -> IO ()
registerCounter
    let start :: IO (IO ())
start = do
            Async ()
a <- Seconds -> IO () -> IO (Async ())
regularly Seconds
1 (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> IO [IO ()] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef [IO ()] -> IO [IO ()]
forall a. IORef a -> IO a
readIORef IORef [IO ()]
actions
            IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
a)
    Monitoring -> IO Monitoring
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Monitoring{IO (IO ())
Text -> IO Int64 -> IO ()
forall {a}. Integral a => Text -> IO a -> IO ()
registerCounter :: forall {a}. Integral a => Text -> IO a -> IO ()
registerGauge :: Text -> IO Int64 -> IO ()
start :: IO (IO ())
registerGauge :: Text -> IO Int64 -> IO ()
registerCounter :: Text -> IO Int64 -> IO ()
start :: IO (IO ())
..}
  | Bool
otherwise = IO Monitoring
forall a. Monoid a => a
mempty


regularly :: Seconds -> IO () -> IO (Async ())
regularly :: Seconds -> IO () -> IO (Async ())
regularly Seconds
delay IO ()
act = IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO ()
act IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Seconds -> IO ()
sleep Seconds
delay)