{-# language BangPatterns #-}
{-# language OverloadedStrings #-}
module Prometheus.Metric.Summary (
    Summary
,   Quantile
,   summary
,   defaultQuantiles
,   observe
,   observeDuration
,   getSummary
) where

import Prometheus.Info
import Prometheus.Metric
import Prometheus.Metric.Observer
import Prometheus.MonadMonitor

import Control.Concurrent.MVar
import Control.DeepSeq
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Primitive
import qualified Data.ByteString.UTF8 as BS
import qualified Data.Text as T
import DataSketches.Quantiles.RelativeErrorQuantile
import qualified DataSketches.Quantiles.RelativeErrorQuantile as ReqSketch
import Data.Maybe (mapMaybe)
import Prelude hiding (maximum)
import qualified Prelude
import Data.Word

data Summary = MkSummary
  { Summary -> MVar (ReqSketch (PrimState IO))
reqSketch :: MVar (ReqSketch (PrimState IO))
  , Summary -> [Quantile]
quantiles :: [Quantile]
  }

instance NFData Summary where
  rnf :: Summary -> ()
rnf (MkSummary MVar (ReqSketch (PrimState IO))
a [Quantile]
b) = MVar (ReqSketch RealWorld)
MVar (ReqSketch (PrimState IO))
a MVar (ReqSketch RealWorld) -> () -> ()
forall a b. a -> b -> b
`seq` [Quantile]
b [Quantile] -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` ()


type Quantile = (Rational, Rational)

-- | K is a parameter divisible by two, in the range 4-1024 used in the RelativeErrorQuantile algorithm to 
-- determine how many items must be retained per compaction section. As the value increases, the accuracy
-- of the sketch increases as well. This function iterates on the k value starting from 6 
-- (conservative on space, but reasonably accurate) until it finds a K value that satisfies the specified 
-- error bounds for the given quantile. Note: this algorithm maintains highest accuracy for the upper tail 
-- of the quantile when passed the 'HighRanksAreAccurate', sampling out more items at lower ranks during 
-- the compaction process. Thus, extremely tight error bounds on low quantile values may cause this 
-- function to return 'Nothing'.
--
-- If another smart constructor was exposed for summary creation, specific k values & LowRanksAreAccurate
-- could be used to refine accuracy settings to bias towards lower quantiles when retaining accurate samples.
determineK :: Quantile -> Maybe Word32
determineK :: Quantile -> Maybe Word32
determineK (Rational
rank_, Rational
acceptableError) = Word32 -> Maybe Word32
forall {t}. Integral t => t -> Maybe t
go Word32
6
    where
        go :: t -> Maybe t
go t
k =
            let rse :: Double
rse = Int -> Double -> RankAccuracy -> Word64 -> Double
relativeStandardError (t -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral t
k) (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
rank_) RankAccuracy
HighRanksAreAccurate Word64
50000
            in if Double -> Double
forall a. Num a => a -> a
abs (Double
rse Double -> Double -> Double
forall a. Num a => a -> a -> a
- Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
rank_) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
acceptableError
                then t -> Maybe t
forall a. a -> Maybe a
Just t
k
                else if t
k t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
1024
                    then t -> Maybe t
go (t
k t -> t -> t
forall a. Num a => a -> a -> a
+ t
2)
                    else Maybe t
forall a. Maybe a
Nothing


-- | Creates a new summary metric with a given name, help string, and a list of
-- quantiles. A reasonable set set of quantiles is provided by
-- 'defaultQuantiles'.
summary :: Info -> [Quantile] -> Metric Summary
summary :: Info -> [Quantile] -> Metric Summary
summary Info
info [Quantile]
quantiles_ = IO (Summary, IO [SampleGroup]) -> Metric Summary
forall s. IO (s, IO [SampleGroup]) -> Metric s
Metric (IO (Summary, IO [SampleGroup]) -> Metric Summary)
-> IO (Summary, IO [SampleGroup]) -> Metric Summary
forall a b. (a -> b) -> a -> b
$ do
    ReqSketch RealWorld
rs <- Word32 -> RankAccuracy -> IO (ReqSketch (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Word32 -> RankAccuracy -> m (ReqSketch (PrimState m))
mkReqSketch Word32
kInt RankAccuracy
HighRanksAreAccurate
    MVar (ReqSketch RealWorld)
mv <- ReqSketch RealWorld -> IO (MVar (ReqSketch RealWorld))
forall a. a -> IO (MVar a)
newMVar (ReqSketch RealWorld -> IO (MVar (ReqSketch RealWorld)))
-> ReqSketch RealWorld -> IO (MVar (ReqSketch RealWorld))
forall a b. (a -> b) -> a -> b
$ ReqSketch RealWorld
rs {criterion = (:<=)}
    let summary_ :: Summary
summary_ = MVar (ReqSketch (PrimState IO)) -> [Quantile] -> Summary
MkSummary MVar (ReqSketch RealWorld)
MVar (ReqSketch (PrimState IO))
mv [Quantile]
quantiles_
    (Summary, IO [SampleGroup]) -> IO (Summary, IO [SampleGroup])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Summary
summary_, Info -> Summary -> IO [SampleGroup]
collectSummary Info
info Summary
summary_)
    where
        kInt :: Word32
kInt = Word32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ case (Quantile -> Maybe Word32) -> [Quantile] -> [Word32]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Quantile -> Maybe Word32
determineK [Quantile]
quantiles_ of
          [] -> [Char] -> Word32
forall a. HasCallStack => [Char] -> a
error [Char]
"Unable to create a Summary meeting the provided quantile precision requirements"
          [Word32]
xs -> [Word32] -> Word32
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
Prelude.maximum [Word32]
xs

instance Observer Summary where
    -- | Adds a new observation to a summary metric.
    observe :: forall (m :: * -> *). MonadMonitor m => Summary -> Double -> m ()
observe Summary
s Double
v = IO () -> m ()
forall (m :: * -> *). MonadMonitor m => IO () -> m ()
doIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar (ReqSketch RealWorld)
-> (ReqSketch RealWorld -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Summary -> MVar (ReqSketch (PrimState IO))
reqSketch Summary
s) (ReqSketch (PrimState IO) -> Double -> IO ()
forall (m :: * -> *).
PrimMonad m =>
ReqSketch (PrimState m) -> Double -> m ()
`ReqSketch.insert` Double
v)

-- | Retrieves a list of tuples containing a quantile and its associated value.
getSummary :: MonadIO m => Summary -> m [(Rational, Double)]
getSummary :: forall (m :: * -> *).
MonadIO m =>
Summary -> m [(Rational, Double)]
getSummary (MkSummary MVar (ReqSketch (PrimState IO))
sketchVar [Quantile]
quantiles_) = IO [(Rational, Double)] -> m [(Rational, Double)]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Rational, Double)] -> m [(Rational, Double)])
-> IO [(Rational, Double)] -> m [(Rational, Double)]
forall a b. (a -> b) -> a -> b
$ MVar (ReqSketch RealWorld)
-> (ReqSketch RealWorld -> IO [(Rational, Double)])
-> IO [(Rational, Double)]
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar (ReqSketch RealWorld)
MVar (ReqSketch (PrimState IO))
sketchVar ((ReqSketch RealWorld -> IO [(Rational, Double)])
 -> IO [(Rational, Double)])
-> (ReqSketch RealWorld -> IO [(Rational, Double)])
-> IO [(Rational, Double)]
forall a b. (a -> b) -> a -> b
$ \ReqSketch RealWorld
sketch -> do
  [Quantile]
-> (Quantile -> IO (Rational, Double)) -> IO [(Rational, Double)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Quantile]
quantiles_ ((Quantile -> IO (Rational, Double)) -> IO [(Rational, Double)])
-> (Quantile -> IO (Rational, Double)) -> IO [(Rational, Double)]
forall a b. (a -> b) -> a -> b
$ \Quantile
qv ->
    (,) (Rational -> Double -> (Rational, Double))
-> IO Rational -> IO (Double -> (Rational, Double))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> IO Rational
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Quantile -> Rational
forall a b. (a, b) -> a
fst Quantile
qv) IO (Double -> (Rational, Double))
-> IO Double -> IO (Rational, Double)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReqSketch (PrimState IO) -> Double -> IO Double
forall (m :: * -> *).
PrimMonad m =>
ReqSketch (PrimState m) -> Double -> m Double
ReqSketch.quantile ReqSketch RealWorld
ReqSketch (PrimState IO)
sketch (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ Quantile -> Rational
forall a b. (a, b) -> a
fst Quantile
qv)

collectSummary :: Info -> Summary -> IO [SampleGroup]
collectSummary :: Info -> Summary -> IO [SampleGroup]
collectSummary Info
info (MkSummary MVar (ReqSketch (PrimState IO))
sketchVar [Quantile]
quantiles_) = MVar (ReqSketch RealWorld)
-> (ReqSketch RealWorld -> IO [SampleGroup]) -> IO [SampleGroup]
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar (ReqSketch RealWorld)
MVar (ReqSketch (PrimState IO))
sketchVar ((ReqSketch RealWorld -> IO [SampleGroup]) -> IO [SampleGroup])
-> (ReqSketch RealWorld -> IO [SampleGroup]) -> IO [SampleGroup]
forall a b. (a -> b) -> a -> b
$ \ReqSketch RealWorld
sketch -> do
    Double
itemSum <- ReqSketch (PrimState IO) -> IO Double
forall (m :: * -> *).
PrimMonad m =>
ReqSketch (PrimState m) -> m Double
ReqSketch.sum ReqSketch RealWorld
ReqSketch (PrimState IO)
sketch
    Word64
count_ <- ReqSketch (PrimState IO) -> IO Word64
forall (m :: * -> *).
PrimMonad m =>
ReqSketch (PrimState m) -> m Word64
ReqSketch.count ReqSketch RealWorld
ReqSketch (PrimState IO)
sketch
    [(Rational, Double)]
estimatedQuantileValues <- [Quantile]
-> (Quantile -> IO (Rational, Double)) -> IO [(Rational, Double)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Quantile]
quantiles_ ((Quantile -> IO (Rational, Double)) -> IO [(Rational, Double)])
-> (Quantile -> IO (Rational, Double)) -> IO [(Rational, Double)]
forall a b. (a -> b) -> a -> b
$ \Quantile
qv ->
      (,) (Rational -> Double -> (Rational, Double))
-> IO Rational -> IO (Double -> (Rational, Double))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> IO Rational
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Quantile -> Rational
forall a b. (a, b) -> a
fst Quantile
qv) IO (Double -> (Rational, Double))
-> IO Double -> IO (Rational, Double)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReqSketch (PrimState IO) -> Double -> IO Double
forall (m :: * -> *).
PrimMonad m =>
ReqSketch (PrimState m) -> Double -> m Double
ReqSketch.quantile ReqSketch RealWorld
ReqSketch (PrimState IO)
sketch (Rational -> Double
toDouble (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ Quantile -> Rational
forall a b. (a, b) -> a
fst Quantile
qv)
    let sumSample :: Sample
sumSample = Text -> LabelPairs -> ByteString -> Sample
Sample (Info -> Text
metricName Info
info Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_sum") [] (Double -> ByteString
forall s. Show s => s -> ByteString
bsShow Double
itemSum)
    let countSample :: Sample
countSample = Text -> LabelPairs -> ByteString -> Sample
Sample (Info -> Text
metricName Info
info Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_count") [] (Word64 -> ByteString
forall s. Show s => s -> ByteString
bsShow Word64
count_)
    [SampleGroup] -> IO [SampleGroup]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Info -> SampleType -> [Sample] -> SampleGroup
SampleGroup Info
info SampleType
SummaryType ([Sample] -> SampleGroup) -> [Sample] -> SampleGroup
forall a b. (a -> b) -> a -> b
$ ((Rational, Double) -> Sample) -> [(Rational, Double)] -> [Sample]
forall a b. (a -> b) -> [a] -> [b]
map (Rational, Double) -> Sample
toSample [(Rational, Double)]
estimatedQuantileValues [Sample] -> [Sample] -> [Sample]
forall a. [a] -> [a] -> [a]
++ [Sample
sumSample, Sample
countSample]]
    where
        bsShow :: Show s => s -> BS.ByteString
        bsShow :: forall s. Show s => s -> ByteString
bsShow = [Char] -> ByteString
BS.fromString ([Char] -> ByteString) -> (s -> [Char]) -> s -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> [Char]
forall a. Show a => a -> [Char]
show

        toSample :: (Rational, Double) -> Sample
        toSample :: (Rational, Double) -> Sample
toSample (Rational
q, Double
estimatedValue) =
            Text -> LabelPairs -> ByteString -> Sample
Sample (Info -> Text
metricName Info
info) [(Text
"quantile", [Char] -> Text
T.pack ([Char] -> Text) -> (Double -> [Char]) -> Double -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> [Char]
forall a. Show a => a -> [Char]
show (Double -> Text) -> Double -> Text
forall a b. (a -> b) -> a -> b
$ Rational -> Double
toDouble Rational
q)] (ByteString -> Sample) -> ByteString -> Sample
forall a b. (a -> b) -> a -> b
$
                Double -> ByteString
forall s. Show s => s -> ByteString
bsShow Double
estimatedValue

        toDouble :: Rational -> Double
        toDouble :: Rational -> Double
toDouble = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational

defaultQuantiles :: [Quantile]
defaultQuantiles :: [Quantile]
defaultQuantiles = [(Rational
0.5, Rational
0.05), (Rational
0.9, Rational
0.01), (Rational
0.99, Rational
0.001)]