{-# 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