6 files changed, 112 insertions(+), 22 deletions(-)

M 18xx-log-parser.cabal
M src/LogParser/Cache.hs
M src/LogParser/Server.hs
M stack.yaml
M stack.yaml.lock
M test/CacheSpec.hs

@@ 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

@@ 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

@@ 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

@@ 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: {}

@@ 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

@@ 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