{-# LANGUAGE RankNTypes, GADTs #-}
{-# LANGUAGE StandaloneDeriving, ScopedTypeVariables, TypeOperators #-}

module System.Metrics.Store
( MetricsStore
, newMetricsStore
, withMetricsStore

, getMetricFromStore
) where

import qualified Data.Dependent.Map as DM
import qualified Data.Text as T
import Control.Concurrent
import Control.Concurrent.STM.TQueue
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Identity
import Control.Monad.STM
import Data.GADT.Compare
import Data.Proxy
import Data.Typeable(eqT)
import GHC.TypeLits
import System.Remote.Monitoring
import Type.Reflection

import Data.Dyn
import System.Metrics.Monad.Class

type DynOrd = Dyn Ord

data SomeMetric tracker where
  MkSomeMetric :: (Typeable metric, TrackerLike tracker, KnownSymbol name, Ord (metric tracker name))
               => metric tracker name -> SomeMetric tracker

deriving instance Typeable (SomeMetric t)

instance GEq SomeMetric where
  geq :: SomeMetric a -> SomeMetric b -> Maybe (a :~: b)
geq (MkSomeMetric metric a name
_) (MkSomeMetric metric b name
_) = Maybe (a :~: b)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT

instance GCompare SomeMetric where
  gcompare :: SomeMetric a -> SomeMetric b -> GOrdering a b
gcompare sm1 :: SomeMetric a
sm1@(MkSomeMetric (metric a name
m1 :: mTy1 tTy1 nTy1)) sm2 :: SomeMetric b
sm2@(MkSomeMetric (metric b name
m2 :: mTy2 tTy2 nTy2)) =
    case Maybe (a :~: b)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (tTy1 :~: tTy2) of
      Just a :~: b
Refl -> case DynOrd -> DynOrd -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (metric a name -> DynOrd
forall a (ctx :: * -> Constraint).
(Typeable a, ctx a) =>
a -> Dyn ctx
toDyn metric a name
m1 :: DynOrd) (metric b name -> DynOrd
forall a (ctx :: * -> Constraint).
(Typeable a, ctx a) =>
a -> Dyn ctx
toDyn metric b name
m2) of
        Ordering
LT -> GOrdering a b
forall k (a :: k) (b :: k). GOrdering a b
GLT
        Ordering
EQ -> GOrdering a b
forall k (a :: k). GOrdering a a
GEQ
        Ordering
GT -> GOrdering a b
forall k (a :: k) (b :: k). GOrdering a b
GGT
      Maybe (a :~: b)
Nothing -> case SomeTypeRep -> SomeTypeRep -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SomeMetric a -> SomeTypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep SomeMetric a
sm1) (SomeMetric b -> SomeTypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep SomeMetric b
sm2) of
        Ordering
LT -> GOrdering a b
forall k (a :: k) (b :: k). GOrdering a b
GLT
        Ordering
EQ -> [Char] -> GOrdering a b
forall a. HasCallStack => [Char] -> a
error [Char]
"SomeTypeReps are equal though eqT proved them wrong"
        Ordering
GT -> GOrdering a b
forall k (a :: k) (b :: k). GOrdering a b
GGT

data MetricsState = MetricsState
  { MetricsState -> Server
server :: Server
  , MetricsState -> DMap SomeMetric Identity
metrics :: DM.DMap SomeMetric Identity
  }

data MetricRequest where
  MetricRequest :: (TrackerLike tracker, KnownSymbol name, Typeable metric, Ord (metric tracker name))
                => metric tracker name
                -> MVar tracker
                -> MetricRequest

newtype MetricsStore = MetricsStore { MetricsStore -> TQueue MetricRequest
mReqQueue :: TQueue MetricRequest }

newMetricsStore :: MonadIO m => Server -> m (MetricsStore, m ())
newMetricsStore :: Server -> m (MetricsStore, m ())
newMetricsStore Server
srv = IO (MetricsStore, m ()) -> m (MetricsStore, m ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MetricsStore, m ()) -> m (MetricsStore, m ()))
-> IO (MetricsStore, m ()) -> m (MetricsStore, m ())
forall a b. (a -> b) -> a -> b
$ do
  TQueue MetricRequest
queue <- IO (TQueue MetricRequest)
forall a. IO (TQueue a)
newTQueueIO
  ThreadId
threadId <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ TQueue MetricRequest -> MetricsState -> IO ()
forall b. TQueue MetricRequest -> MetricsState -> IO b
act TQueue MetricRequest
queue (MetricsState -> IO ()) -> MetricsState -> IO ()
forall a b. (a -> b) -> a -> b
$ Server -> DMap SomeMetric Identity -> MetricsState
MetricsState Server
srv DMap SomeMetric Identity
forall a. Monoid a => a
mempty
  (MetricsStore, m ()) -> IO (MetricsStore, m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TQueue MetricRequest -> MetricsStore
MetricsStore TQueue MetricRequest
queue, IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> IO ()
killThread ThreadId
threadId)
  where
    act :: TQueue MetricRequest -> MetricsState -> IO b
act TQueue MetricRequest
queue MetricsState
state = do
      MetricRequest
req <- STM MetricRequest -> IO MetricRequest
forall a. STM a -> IO a
atomically (TQueue MetricRequest -> STM MetricRequest
forall a. TQueue a -> STM a
readTQueue TQueue MetricRequest
queue)
      MetricsState
state' <- (\(MetricRequest metric tracker name
metric MVar tracker
mvar) -> MetricsState
-> metric tracker name -> MVar tracker -> IO MetricsState
forall (metric :: * -> Symbol -> *) tracker (name :: Symbol).
(TrackerLike tracker, KnownSymbol name, Typeable metric,
 Ord (metric tracker name)) =>
MetricsState
-> metric tracker name -> MVar tracker -> IO MetricsState
handleReq MetricsState
state metric tracker name
metric MVar tracker
mvar) MetricRequest
req
      TQueue MetricRequest -> MetricsState -> IO b
act TQueue MetricRequest
queue MetricsState
state'

    handleReq :: forall metric tracker name. (TrackerLike tracker, KnownSymbol name, Typeable metric, Ord (metric tracker name))
              => MetricsState
              -> metric tracker name
              -> MVar tracker
              -> IO MetricsState
    handleReq :: MetricsState
-> metric tracker name -> MVar tracker -> IO MetricsState
handleReq MetricsState
state metric tracker name
metric MVar tracker
mvar = do
      let asSome :: SomeMetric tracker
asSome = metric tracker name -> SomeMetric tracker
forall (metric :: * -> Symbol -> *) tracker (name :: Symbol).
(Typeable metric, TrackerLike tracker, KnownSymbol name,
 Ord (metric tracker name)) =>
metric tracker name -> SomeMetric tracker
MkSomeMetric metric tracker name
metric
      (tracker
tracker, MetricsState
state') <- case SomeMetric tracker
-> DMap SomeMetric Identity -> Maybe (Identity tracker)
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> DMap k2 f -> Maybe (f v)
DM.lookup SomeMetric tracker
asSome (DMap SomeMetric Identity -> Maybe (Identity tracker))
-> DMap SomeMetric Identity -> Maybe (Identity tracker)
forall a b. (a -> b) -> a -> b
$ MetricsState -> DMap SomeMetric Identity
metrics MetricsState
state of
        Just Identity tracker
existing -> (tracker, MetricsState) -> IO (tracker, MetricsState)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Identity tracker -> tracker
forall a. Identity a -> a
runIdentity Identity tracker
existing, MetricsState
state)
        Maybe (Identity tracker)
Nothing -> do
          let trackerName :: [Char]
trackerName = Proxy name -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal (Proxy name
forall k (t :: k). Proxy t
Proxy :: Proxy name)
          tracker
newTracker <- Text -> Store -> IO tracker
forall tracker. TrackerLike tracker => Text -> Store -> IO tracker
createTracker ([Char] -> Text
T.pack [Char]
trackerName) (Store -> IO tracker) -> Store -> IO tracker
forall a b. (a -> b) -> a -> b
$ Server -> Store
serverMetricStore (Server -> Store) -> Server -> Store
forall a b. (a -> b) -> a -> b
$ MetricsState -> Server
server MetricsState
state
          (tracker, MetricsState) -> IO (tracker, MetricsState)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (tracker
newTracker, MetricsState
state { metrics :: DMap SomeMetric Identity
metrics = SomeMetric tracker
-> Identity tracker
-> DMap SomeMetric Identity
-> DMap SomeMetric Identity
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (v :: k1).
GCompare k2 =>
k2 v -> f v -> DMap k2 f -> DMap k2 f
DM.insert SomeMetric tracker
asSome (tracker -> Identity tracker
forall a. a -> Identity a
Identity tracker
newTracker) (DMap SomeMetric Identity -> DMap SomeMetric Identity)
-> DMap SomeMetric Identity -> DMap SomeMetric Identity
forall a b. (a -> b) -> a -> b
$ MetricsState -> DMap SomeMetric Identity
metrics MetricsState
state })
      MVar tracker -> tracker -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar tracker
mvar tracker
tracker
      MetricsState -> IO MetricsState
forall (f :: * -> *) a. Applicative f => a -> f a
pure MetricsState
state'

withMetricsStore :: (MonadIO m, MonadMask m) => Server -> (MetricsStore -> m a) -> m a
withMetricsStore :: Server -> (MetricsStore -> m a) -> m a
withMetricsStore Server
srv MetricsStore -> m a
f = m (MetricsStore, m ())
-> ((MetricsStore, m ()) -> m ())
-> ((MetricsStore, m ()) -> m a)
-> m a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket
  (Server -> m (MetricsStore, m ())
forall (m :: * -> *). MonadIO m => Server -> m (MetricsStore, m ())
newMetricsStore Server
srv)
  (MetricsStore, m ()) -> m ()
forall a b. (a, b) -> b
snd
  (MetricsStore -> m a
f (MetricsStore -> m a)
-> ((MetricsStore, m ()) -> MetricsStore)
-> (MetricsStore, m ())
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MetricsStore, m ()) -> MetricsStore
forall a b. (a, b) -> a
fst)

getMetricFromStore :: (TrackerLike tracker, KnownSymbol name, Typeable metric, Ord (metric tracker name))
                   => MetricsStore
                   -> metric tracker name
                   -> IO tracker
getMetricFromStore :: MetricsStore -> metric tracker name -> IO tracker
getMetricFromStore MetricsStore
store metric tracker name
metric = do
  MVar tracker
mvar <- IO (MVar tracker)
forall a. IO (MVar a)
newEmptyMVar
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue MetricRequest -> MetricRequest -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (MetricsStore -> TQueue MetricRequest
mReqQueue MetricsStore
store) (MetricRequest -> STM ()) -> MetricRequest -> STM ()
forall a b. (a -> b) -> a -> b
$ metric tracker name -> MVar tracker -> MetricRequest
forall tracker (name :: Symbol) (metric :: * -> Symbol -> *).
(TrackerLike tracker, KnownSymbol name, Typeable metric,
 Ord (metric tracker name)) =>
metric tracker name -> MVar tracker -> MetricRequest
MetricRequest metric tracker name
metric MVar tracker
mvar
  MVar tracker -> IO tracker
forall a. MVar a -> IO a
takeMVar MVar tracker
mvar