From 2e34a0b44cad03dc3535d451a0d4aa7bf56a69f0 Mon Sep 17 00:00:00 2001 From: nick hansen Date: Sun, 18 Apr 2021 01:29:00 -0700 Subject: [PATCH] add some metrics --- 18xx-log-parser.cabal | 3 ++ src/LogParser/Cache.hs | 80 ++++++++++++++++++++++++++++++++--------- src/LogParser/Server.hs | 19 ++++++++-- stack.yaml | 3 ++ stack.yaml.lock | 21 +++++++++++ test/CacheSpec.hs | 8 ++--- 6 files changed, 112 insertions(+), 22 deletions(-) diff --git a/18xx-log-parser.cabal b/18xx-log-parser.cabal index 31424cd..5c36e9e 100644 --- a/18xx-log-parser.cabal +++ b/18xx-log-parser.cabal @@ -46,6 +46,9 @@ library , shakespeare , http-types , warp + , prometheus-client >= 1.0.1 + , wai-middleware-prometheus + , prometheus-metrics-ghc default-language: Haskell2010 if flag(dev) cpp-options: -DDEV diff --git a/src/LogParser/Cache.hs b/src/LogParser/Cache.hs index fcefcb6..9e2c90d 100644 --- a/src/LogParser/Cache.hs +++ b/src/LogParser/Cache.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} @@ -21,9 +23,12 @@ import Data.Function import Data.Hashable import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set +import Data.Text (Text) import Data.Time.Clock +import Prometheus type Id = Int @@ -33,22 +38,39 @@ data CacheData a = CD { dataStore :: Map Id (a,UTCTime) , maxDataCount :: Int } -newtype Cache a = Cache { unwrapCache :: TVar (CacheData a) } - - -emptyCache :: NominalDiffTime -> Int -> IO (Cache a) -emptyCache maxAge maxCount = - fmap Cache . newTVarIO $ CD Map.empty Map.empty maxAge maxCount - +data CacheMetrics = CM { metricPopulation :: Gauge + , metricQueries :: Vector Label1 Counter + , metricEvictions :: Counter + } + +data Cache a = Cache (TVar (CacheData a)) + | InstrumentedCache CacheMetrics (TVar (CacheData a)) + +unwrapCache :: Cache a -> TVar (CacheData a) +unwrapCache (Cache c) = c +unwrapCache (InstrumentedCache _ c) = c + +emptyCache :: (Maybe Text) -> NominalDiffTime -> Int -> IO (Cache a) +emptyCache metricPrefix maxAge maxCount = do + wrap <- case metricPrefix of + Nothing -> pure Cache + Just pfx -> do + pop <- register (gauge $ Info (pfx <> "_population_count") "Current entry count") + q <- register (vector "result" $ counter $ Info (pfx <> "_queries") "Cache lookups") + ev <- register (counter $ Info (pfx <> "_eviction_count") "Evicted entries") + setGauge pop 0 + pure $ InstrumentedCache $ CM pop q ev + fmap wrap . newTVarIO $ CD Map.empty Map.empty maxAge maxCount cacheInsert :: Hashable a => a -> Cache a -> IO Id cacheInsert = cacheInsert' getCurrentTime cacheInsert' :: Hashable a => IO UTCTime -> a -> Cache a -> IO Id -cacheInsert' getTime x (Cache c) = do +cacheInsert' getTime x cache = do let h = hash x + c = unwrapCache cache now <- getTime - pruneCache now (Cache c) + pruneCache now cache atomically $ do cd@CD{dataStore,dataAge} <- readTVar c let cd' = case Map.lookup h dataStore of @@ -64,6 +86,7 @@ cacheInsert' getTime x (Cache c) = do & insertId h now } writeTVar c cd' + reportCachePopulation cache pure h insertId,deleteId :: Id -> UTCTime -> Map UTCTime (Set Id) -> Map UTCTime (Set Id) @@ -82,10 +105,11 @@ cacheLookup :: Id -> Cache a -> IO (Maybe a) cacheLookup = cacheLookup' getCurrentTime cacheLookup' :: IO UTCTime -> Id -> Cache a -> IO (Maybe a) -cacheLookup' getTime h (Cache c) = do +cacheLookup' getTime h cache = do now <- getTime - pruneCache now (Cache c) - atomically $ do + pruneCache now cache + let c = unwrapCache cache + result <- atomically $ do cd@CD{dataStore,dataAge} <- readTVar c case Map.lookup h dataStore of Just (dat, previously) -> do @@ -96,13 +120,26 @@ cacheLookup' getTime h (Cache c) = do } pure $ Just dat Nothing -> pure Nothing + case cache of + Cache _ -> pure () + InstrumentedCache CM{metricQueries} _ -> + if isJust result then + withLabel metricQueries "hit" incCounter + else + withLabel metricQueries "miss" incCounter + pure result pruneCache :: UTCTime -> Cache a -> IO () -pruneCache now (Cache c) = go +pruneCache now cache = go where + c = unwrapCache cache go = do didPrune <- maybePruneOldest - if didPrune then go else pure () + if didPrune then + reportPrune >> go + + else + reportCachePopulation cache maybePruneOldest = atomically $ do cd@CD{dataStore,dataAge,maxDataAge,maxDataCount} <- readTVar c @@ -120,9 +157,20 @@ pruneCache now (Cache c) = go } pure True + reportPrune = case cache of + InstrumentedCache CM{metricEvictions} _ -> + incCounter metricEvictions + _ -> pure () + +reportCachePopulation :: Cache a -> IO () +reportCachePopulation (InstrumentedCache CM{metricPopulation} c) = do + CD{dataStore} <- readTVarIO c + setGauge metricPopulation $ fromIntegral $ Map.size dataStore +reportCachePopulation _ = pure () + assertCacheSize :: Int -> Cache a -> IO () -assertCacheSize sz (Cache c) = do - CD{dataStore,dataAge} <- readTVarIO c +assertCacheSize sz cache = do + CD{dataStore,dataAge} <- readTVarIO $ unwrapCache cache when (Map.size dataStore /= sz) $ throwIO (AssertionFailed $ "Expected dataStore of size " <> show sz <> " but got size " <> show (Map.size dataStore)) when ( ( dataStore diff --git a/src/LogParser/Server.hs b/src/LogParser/Server.hs index a5ec62b..fb7bfb2 100644 --- a/src/LogParser/Server.hs +++ b/src/LogParser/Server.hs @@ -15,11 +15,15 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.IO as LTIO import Data.Time.Clock +import GHC.Stats import Network.HTTP.Types.Status import Network.Wai (Application) +import qualified Network.Wai.Middleware.Prometheus as Prom import qualified Network.Wai.Handler.Warp as Warp import Pipes import qualified Pipes.Prelude as P +import qualified Prometheus as Prom +import qualified Prometheus.Metric.GHC as Prom import System.Environment import Text.Blaze.Html (Html) import Text.Blaze.Html.Renderer.Text (renderHtml) @@ -46,14 +50,20 @@ runApp = do app :: (S.ScottyM () -> IO a) -> IO a app run = do + -- enable GHC Prometheus metrics + rtsStatsEnabled <- liftIO getRTSStatsEnabled + when rtsStatsEnabled $ Prom.register Prom.ghcMetrics >> pure () + + -- initialize the game cache cacheMaxAge <- (nominalDay *) . fromMaybe 3 . fmap secondsToNominalDiffTime . (readMaybe =<<) <$> lookupEnv "DATA_CACHE_DURATION_DAYS" cacheMaxSize <- fromMaybe 1000 . (readMaybe =<<) <$> lookupEnv "DATA_CACHE_SIZE" - cache <- emptyCache cacheMaxAge cacheMaxSize - run $ routes cache + cache <- emptyCache (Just "logparser_game_cache") cacheMaxAge cacheMaxSize + + run $ middlewares >> routes cache routes :: Cache TidyDataCollection -> S.ScottyM () routes cache = do @@ -166,3 +176,8 @@ testList = #else [] #endif + + +middlewares :: S.ScottyM () +middlewares = do + S.middleware $ Prom.prometheus Prom.def diff --git a/stack.yaml b/stack.yaml index f31ad85..dbd72d3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -42,6 +42,9 @@ packages: # extra-deps: [] extra-deps: - base32-0.2.0.0 +- wai-middleware-prometheus-1.0.0 +- prometheus-metrics-ghc-1.0.1.1 +- prometheus-client-1.0.1 # Override default flag values for local packages and extra-deps # flags: {} diff --git a/stack.yaml.lock b/stack.yaml.lock index 8ace336..4a05aa3 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -11,6 +11,27 @@ packages: sha256: 10c0a5a0a1d4c40b41f0190cf80b114fb527caf7458feec819d87ccfe41317cb original: hackage: base32-0.2.0.0 +- completed: + hackage: wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314 + pantry-tree: + size: 307 + sha256: 6d64803c639ed4c7204ea6fab0536b97d3ee16cdecb9b4a883cd8e56d3c61402 + original: + hackage: wai-middleware-prometheus-1.0.0 +- completed: + hackage: prometheus-metrics-ghc-1.0.1.1@sha256:d378a7186a967140fe0e09d325fe5e3bfd7b77a1123934b40f81fdfed2eacbdc,1233 + pantry-tree: + size: 293 + sha256: 0732085a4148b269bbc15eeb7ab422e65ac287878a42a7388a7b6e140ec740e5 + original: + hackage: prometheus-metrics-ghc-1.0.1.1 +- completed: + hackage: prometheus-client-1.0.1@sha256:eef0399a1b4296624c7cde11c72d93ec53329a92b1a2f6cbdceeeff2b8c20308,2518 + pantry-tree: + size: 1225 + sha256: 4e9cf0b88a280d2053ed72bfea6f47ffa9b1eaa27422ef171011b77ccef28fdf + original: + hackage: prometheus-client-1.0.1 snapshots: - completed: size: 533053 diff --git a/test/CacheSpec.hs b/test/CacheSpec.hs index bffb6f9..e11e237 100644 --- a/test/CacheSpec.hs +++ b/test/CacheSpec.hs @@ -20,7 +20,7 @@ spec = do describe "cache" $ do it "retrieves items" $ ( do - c <- emptyCache nominalDay 1 + c <- emptyCache Nothing nominalDay 1 i <- cacheInsert' now "foo" c cacheLookup' now i c <* assertCacheSize 1 c @@ -30,7 +30,7 @@ spec = do it "prunes based on size" $ ( do - c <- emptyCache nominalDay 2 + c <- emptyCache Nothing nominalDay 2 i1 <- cacheInsert' now "foo" c i2 <- cacheInsert' (nowPlus 1) "bar" c i3 <- cacheInsert' (nowPlus 2) "baz" c @@ -42,7 +42,7 @@ spec = do it "prunes based on time" $ ( do - c <- emptyCache (secondsToNominalDiffTime 3) 5 + c <- emptyCache Nothing (secondsToNominalDiffTime 3) 5 i1 <- cacheInsert' now "foo" c i2 <- cacheInsert' (nowPlus 2) "bar" c mapM (\i -> cacheLookup' (nowPlus 4) i c) [i1, i2] @@ -53,7 +53,7 @@ spec = do it "refreshes the timeout" $ ( do - c <- emptyCache (secondsToNominalDiffTime 4) 5 + c <- emptyCache Nothing (secondsToNominalDiffTime 4) 5 i1 <- cacheInsert' now "foo" c i2 <- cacheInsert' (nowPlus 1) "bar" c r1 <- cacheLookup' (nowPlus 3) i1 c -- 2.45.2