609 lines
25 KiB
Haskell
609 lines
25 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
|
|
|
|
module Utils.Metrics
|
|
( withHealthReportMetrics
|
|
, registerGHCMetrics
|
|
, observeHTTPRequestLatency
|
|
, registerReadyMetric
|
|
, registerHealthCheckInterval
|
|
, withJobWorkerState
|
|
, observeYesodCacheSize
|
|
, observeFavouritesQuickActionsDuration
|
|
, LoginOutcome(..), observeLoginOutcome
|
|
, registerJobHeldLocksCount
|
|
, FileChunkStorage(..), observeSourcedChunk, observeSunkChunk
|
|
, observeDeletedUnreferencedFiles, observeDeletedUnreferencedChunks, observeInjectedFiles, observeRechunkedFiles
|
|
, registerJobWorkerQueueDepth
|
|
, observeMissingFiles
|
|
, ARCMetrics, ARCLabel(..)
|
|
, arcMetrics
|
|
, LRUMetrics, LRULabel(..)
|
|
, lruMetrics
|
|
, InjectInhibitMetrics, injectInhibitMetrics
|
|
, PoolMetrics, PoolLabel(..)
|
|
, poolMetrics
|
|
, observeDatabaseConnectionOpened, observeDatabaseConnectionClosed
|
|
, onUseDBConn, onReleaseDBConn, DBConnUseState, DBConnLabel
|
|
, AuthTagEvalOutcome(..), observeAuthTagEvaluation
|
|
, observeFavouritesSkippedDueToDBLoad
|
|
) where
|
|
|
|
import Import.NoModel hiding (Vector, Info)
|
|
import Model
|
|
import Prometheus
|
|
import Prometheus.Metric.GHC
|
|
|
|
import qualified Data.List as List
|
|
|
|
import System.Clock
|
|
import Data.Time.Clock.POSIX
|
|
|
|
import Network.Wai (Middleware)
|
|
import qualified Network.Wai as Wai
|
|
import qualified Network.HTTP.Types as HTTP
|
|
|
|
import Yesod.Core.Types (HandlerData(..), GHState(..))
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import Jobs.Types
|
|
|
|
import qualified Data.Aeson as Aeson
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
|
|
import Data.IntervalMap.Strict (IntervalMap)
|
|
import qualified Data.IntervalMap.Strict as IntervalMap
|
|
|
|
import qualified Data.Foldable as F
|
|
|
|
import qualified Utils.Pool as Custom
|
|
|
|
import GHC.Stack
|
|
|
|
{-# ANN module ("HLint: ignore Use even" :: String) #-}
|
|
|
|
|
|
histogramBuckets :: Rational -- ^ min
|
|
-> Rational -- ^ max
|
|
-> [Double]
|
|
histogramBuckets bMin bMax = map fromRational . takeWhile (<= bMax) . go bMin $ List.cycle factors
|
|
where
|
|
go n [] = [n]
|
|
go n (f:fs) = n : go (f * n) fs
|
|
|
|
factors
|
|
| bMin' `mod` 2 == 0 = [2.5, 2, 2]
|
|
| bMin' `mod` 5 == 0 = [2, 2, 2.5]
|
|
| otherwise = [2, 2.5, 2]
|
|
where
|
|
bMin' :: Integer
|
|
bMin' = floor . List.head . dropWhile (< 1) $ List.iterate (* 10) bMin
|
|
|
|
|
|
{-# NOINLINE healthReportTime #-}
|
|
healthReportTime :: Vector Label2 Gauge
|
|
healthReportTime = unsafeRegister . vector ("check", "status") $ gauge info
|
|
where
|
|
info = Info "uni2work_health_check_time"
|
|
"POSIXTime of last health check performed by this Uni2work-instance"
|
|
|
|
{-# NOINLINE healthReportDuration #-}
|
|
healthReportDuration :: Vector Label2 Histogram
|
|
healthReportDuration = unsafeRegister . vector ("check", "status") $ histogram info buckets
|
|
where
|
|
info = Info "uni2work_health_check_duration_seconds"
|
|
"Duration of last health check performed by this Uni2work-instance"
|
|
buckets = histogramBuckets 5e-6 100e-3
|
|
|
|
data HealthCheckInterval = MkHealthCheckInterval
|
|
|
|
healthCheckInterval :: (HealthCheck -> Maybe NominalDiffTime) -> Metric HealthCheckInterval
|
|
healthCheckInterval hcInts = Metric $ return (MkHealthCheckInterval, collectHealthCheckInterval)
|
|
where
|
|
collectHealthCheckInterval = return . pure . SampleGroup info GaugeType $ do
|
|
(hc, Just int) <- itoList hcInts
|
|
return . Sample "uni2work_health_check_interval_seconds" [("check", toPathPiece hc)] . encodeUtf8 $ tshow (realToFrac int :: Nano)
|
|
info = Info "uni2work_health_check_interval_seconds"
|
|
"Target interval at which health checks are executed by this Uni2work-instance"
|
|
|
|
{-# NOINLINE httpRequestLatency #-}
|
|
httpRequestLatency :: Vector Label3 Histogram
|
|
httpRequestLatency = unsafeRegister . vector ("handler", "method", "status") $ histogram info buckets
|
|
where info = Info "http_request_duration_seconds"
|
|
"HTTP request latency"
|
|
buckets = histogramBuckets 50e-6 500
|
|
|
|
data ReadySince = MkReadySince
|
|
|
|
readyMetric :: POSIXTime -> Metric ReadySince
|
|
readyMetric ts = Metric $ return (MkReadySince, collectReadySince)
|
|
where
|
|
collectReadySince = return [SampleGroup info GaugeType [Sample "ready_time" [] sample]]
|
|
info = Info "ready_time"
|
|
"POSIXTime this Uni2work-instance became ready"
|
|
sample = encodeUtf8 $ tshow (realToFrac ts :: Nano)
|
|
|
|
{-# NOINLINE jobWorkerStateDuration #-}
|
|
jobWorkerStateDuration :: Vector Label4 Histogram
|
|
jobWorkerStateDuration = unsafeRegister . vector ("worker", "state", "jobctl", "task") $ histogram info buckets
|
|
where info = Info "uni2work_job_worker_state_duration_seconds"
|
|
"Duration of time a Uni2work job executor spent in a certain state"
|
|
buckets = histogramBuckets 1e-6 5000
|
|
|
|
{-# NOINLINE jobWorkerStateTransitions #-}
|
|
jobWorkerStateTransitions :: Vector Label4 Counter
|
|
jobWorkerStateTransitions = unsafeRegister . vector ("worker", "state", "jobctl", "task") $ counter info
|
|
where info = Info "uni2work_job_worker_state_transitions_total"
|
|
"Number of times a Uni2work job executor entered a certain state"
|
|
|
|
{-# NOINLINE yesodCacheSize #-}
|
|
yesodCacheSize :: Histogram
|
|
yesodCacheSize = unsafeRegister $ histogram info buckets
|
|
where info = Info "yesod_ghs_cache_items"
|
|
"Number of items in Yesod's ghsCache and ghsCacheBy"
|
|
buckets = 0 : histogramBuckets 1 1e6
|
|
|
|
{-# NOINLINE favouritesQuickActionsDuration #-}
|
|
favouritesQuickActionsDuration :: Histogram
|
|
favouritesQuickActionsDuration = unsafeRegister $ histogram info buckets
|
|
where info = Info "uni2work_favourites_quick_actions_seconds"
|
|
"Duration of time needed to calculate a set of favourite quick actions"
|
|
buckets = histogramBuckets 500e-6 50
|
|
|
|
{-# NOINLINE loginOutcomes #-}
|
|
loginOutcomes :: Vector Label2 Counter
|
|
loginOutcomes = unsafeRegister . vector ("plugin", "outcome") $ counter info
|
|
where info = Info "uni2work_login_attempts_total"
|
|
"Number of login attempts"
|
|
|
|
data JobHeldLocksCount = MkJobHeldLocksCount
|
|
|
|
jobHeldLocksCount :: TVar (Set QueuedJobId) -> Metric JobHeldLocksCount
|
|
jobHeldLocksCount heldLocks = Metric $ return (MkJobHeldLocksCount, collectJobHeldLocksCount)
|
|
where
|
|
collectJobHeldLocksCount = do
|
|
nLocks <- Set.size <$> readTVarIO heldLocks
|
|
let sample = encodeUtf8 $ tshow nLocks
|
|
return [SampleGroup info GaugeType [Sample "uni2work_jobs_held_locks_count" [] sample]]
|
|
info = Info "uni2work_jobs_held_locks_count"
|
|
"Number of job locks currently held by this Uni2work-instance"
|
|
|
|
{-# NOINLINE sourcedFileChunkSizes #-}
|
|
sourcedFileChunkSizes :: Vector Label1 Histogram
|
|
sourcedFileChunkSizes = unsafeRegister . vector "storage" $ histogram info buckets
|
|
where info = Info "uni2work_sourced_file_chunks_bytes"
|
|
"Sizes of file chunks sourced"
|
|
buckets = 0 : histogramBuckets 1 1000000000
|
|
|
|
{-# NOINLINE sunkFileChunkSizes #-}
|
|
sunkFileChunkSizes :: Vector Label1 Histogram
|
|
sunkFileChunkSizes = unsafeRegister . vector "storage" $ histogram info buckets
|
|
where info = Info "uni2work_sunk_file_chunks_bytes"
|
|
"Sizes of file chunks sunk"
|
|
buckets = 0 : histogramBuckets 1 1000000000
|
|
|
|
{-# NOINLINE deletedUnreferencedFiles #-}
|
|
deletedUnreferencedFiles :: Counter
|
|
deletedUnreferencedFiles = unsafeRegister $ counter info
|
|
where info = Info "uni2work_deleted_unreferenced_files_count"
|
|
"Number of unreferenced files deleted"
|
|
|
|
{-# NOINLINE deletedUnreferencedChunks #-}
|
|
deletedUnreferencedChunks :: Counter
|
|
deletedUnreferencedChunks = unsafeRegister $ counter info
|
|
where info = Info "uni2work_deleted_unreferenced_chunks_count"
|
|
"Number of unreferenced chunks deleted"
|
|
|
|
{-# NOINLINE deletedUnreferencedChunksBytes #-}
|
|
deletedUnreferencedChunksBytes :: Counter
|
|
deletedUnreferencedChunksBytes = unsafeRegister $ counter info
|
|
where info = Info "uni2work_deleted_unreferenced_chunks_bytes"
|
|
"Size of unreferenced chunks deleted"
|
|
|
|
{-# NOINLINE injectedFiles #-}
|
|
injectedFiles :: Counter
|
|
injectedFiles = unsafeRegister $ counter info
|
|
where info = Info "uni2work_injected_files_count"
|
|
"Number of files injected from upload cache into database"
|
|
|
|
{-# NOINLINE injectedFilesBytes #-}
|
|
injectedFilesBytes :: Counter
|
|
injectedFilesBytes = unsafeRegister $ counter info
|
|
where info = Info "uni2work_injected_files_bytes"
|
|
"Size of files injected from upload cache into database"
|
|
|
|
{-# NOINLINE rechunkedFiles #-}
|
|
rechunkedFiles :: Counter
|
|
rechunkedFiles = unsafeRegister $ counter info
|
|
where info = Info "uni2work_rechunked_files_count"
|
|
"Number of files rechunked within database"
|
|
|
|
{-# NOINLINE rechunkedFilesBytes #-}
|
|
rechunkedFilesBytes :: Counter
|
|
rechunkedFilesBytes = unsafeRegister $ counter info
|
|
where info = Info "uni2work_rechunked_files_bytes"
|
|
"Size of files rechunked within database"
|
|
|
|
{-# NOINLINE databaseConnectionsOpened #-}
|
|
databaseConnectionsOpened :: Counter
|
|
databaseConnectionsOpened = unsafeRegister $ counter info
|
|
where info = Info "uni2work_database_connections_opened"
|
|
"Number of new connections to database opened"
|
|
|
|
{-# NOINLINE databaseConnectionsClosed #-}
|
|
databaseConnectionsClosed :: Counter
|
|
databaseConnectionsClosed = unsafeRegister $ counter info
|
|
where info = Info "uni2work_database_connections_closed"
|
|
"Number of connections to database closed"
|
|
|
|
data JobWorkerQueueDepth = MkJobWorkerQueueDepth
|
|
|
|
jobWorkerQueueDepth :: TMVar JobState -> Metric JobWorkerQueueDepth
|
|
jobWorkerQueueDepth jSt = Metric $ return (MkJobWorkerQueueDepth, collectJobWorkerQueueDepth)
|
|
where
|
|
collectJobWorkerQueueDepth = maybeT (return []) $ do
|
|
wQueues <- hoist atomically $ do
|
|
JobState{..} <- MaybeT $ tryReadTMVar jSt
|
|
flip ifoldMapM jobWorkers $ \wAsync wQueue
|
|
-> lift $ pure . (jobWorkerName wAsync, ) . jqDepth <$> readTVar wQueue
|
|
return [ SampleGroup info GaugeType
|
|
[ Sample "uni2work_queued_jobs_count" [("worker", showWorkerId wName)] . encodeUtf8 $ tshow wDepth
|
|
| (wName, wDepth) <- wQueues
|
|
]
|
|
]
|
|
info = Info "uni2work_queued_jobs_count"
|
|
"Number of JobQueue entries in this Uni2work-instance"
|
|
|
|
{-# NOINLINE missingFiles #-}
|
|
missingFiles :: Vector Label1 Gauge
|
|
missingFiles = unsafeRegister . vector "ref" $ gauge info
|
|
where info = Info "uni2work_missing_files_count"
|
|
"Number of files referenced from within database that are missing"
|
|
|
|
{-# NOINLINE favouritesSkippedDueToDBLoad #-}
|
|
favouritesSkippedDueToDBLoad :: Counter
|
|
favouritesSkippedDueToDBLoad = unsafeRegister $ counter info
|
|
where info = Info "uni2work_favourites_skipped_due_to_db_load_count"
|
|
"Number of times this Uni2work-instance skipped generating FavouriteQuickActions due to database pressure"
|
|
|
|
relabel :: Text -> Text
|
|
-> SampleGroup -> SampleGroup
|
|
relabel l s (SampleGroup i t ss) = SampleGroup i t . flip map ss $ \(Sample k lbls v) -> Sample k ((l, s) : filter (views _1 $ (/=) l) lbls) v
|
|
|
|
data ARCMetrics = ARCMetrics
|
|
|
|
data ARCLabel = ARCFileSource | ARCMemcachedLocal
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
nullaryPathPiece ''ARCLabel $ camelToPathPiece' 1
|
|
|
|
arcMetrics :: Integral w
|
|
=> ARCLabel
|
|
-> ARCHandle k w v
|
|
-> Metric ARCMetrics
|
|
arcMetrics lbl ah = Metric $ return (ARCMetrics, collectARCMetrics)
|
|
where
|
|
labelArc = relabel "arc"
|
|
|
|
collectARCMetrics = map (labelArc $ toPathPiece lbl) <$> do
|
|
(arc, _) <- readARCHandle ah
|
|
return
|
|
[ SampleGroup sizeInfo GaugeType
|
|
[ Sample "arc_size" [("lru", "ghost-recent")] . encodeUtf8 . tshow $ arcGhostRecentSize arc
|
|
, Sample "arc_size" [("lru", "recent")] . encodeUtf8 . tshow $ arcRecentSize arc
|
|
, Sample "arc_size" [("lru", "frequent")] . encodeUtf8 . tshow $ arcFrequentSize arc
|
|
, Sample "arc_size" [("lru", "ghost-frequent")] . encodeUtf8 . tshow $ arcGhostFrequentSize arc
|
|
]
|
|
, SampleGroup weightInfo GaugeType
|
|
[ Sample "arc_weight" [("lru", "recent")] . encodeUtf8 . tshow . toInteger $ getARCRecentWeight arc
|
|
, Sample "arc_weight" [("lru", "frequent")] . encodeUtf8 . tshow . toInteger $ getARCFrequentWeight arc
|
|
]
|
|
]
|
|
sizeInfo = Info "arc_size"
|
|
"Number of entries in the ARC LRUs"
|
|
weightInfo = Info "arc_weight"
|
|
"Sum of weights of entries in the ARC LRUs"
|
|
|
|
data LRUMetrics = LRUMetrics
|
|
|
|
data LRULabel = LRUFileSourcePrewarm
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
nullaryPathPiece ''LRULabel $ camelToPathPiece' 1
|
|
|
|
lruMetrics :: Integral w
|
|
=> LRULabel
|
|
-> LRUHandle k t w v
|
|
-> Metric LRUMetrics
|
|
lruMetrics lbl lh = Metric $ return (LRUMetrics, collectLRUMetrics)
|
|
where
|
|
labelLru = relabel "lru"
|
|
|
|
collectLRUMetrics = map (labelLru $ toPathPiece lbl) <$> do
|
|
(lru, _) <- readLRUHandle lh
|
|
return
|
|
[ SampleGroup sizeInfo GaugeType
|
|
[ Sample "lru_size" [] . encodeUtf8 . tshow $ lruStoreSize lru
|
|
]
|
|
, SampleGroup weightInfo GaugeType
|
|
[ Sample "lru_weight" [] . encodeUtf8 . tshow . toInteger $ getLRUWeight lru
|
|
]
|
|
]
|
|
sizeInfo = Info "lru_size"
|
|
"Number of entries in the LRU"
|
|
weightInfo = Info "lru_weight"
|
|
"Sum of weights of entries in the LRU"
|
|
|
|
data InjectInhibitMetrics = InjectInhibitMetrics
|
|
|
|
injectInhibitMetrics :: TVar (IntervalMap UTCTime (Set FileContentReference))
|
|
-> Metric InjectInhibitMetrics
|
|
injectInhibitMetrics tvar = Metric $ return (InjectInhibitMetrics, collectInjectInhibitMetrics)
|
|
where
|
|
collectInjectInhibitMetrics = do
|
|
inhibits <- readTVarIO tvar
|
|
return
|
|
[ SampleGroup intervalsInfo GaugeType
|
|
[ Sample "uni2work_inject_inhibited_intervals_count" [] . encodeUtf8 . tshow $ IntervalMap.size inhibits
|
|
]
|
|
, SampleGroup hashesInfo GaugeType
|
|
[ Sample "uni2work_inject_inhibited_hashes_count" [] . encodeUtf8 . tshow . Set.size $ F.fold inhibits
|
|
]
|
|
]
|
|
intervalsInfo = Info "uni2work_inject_inhibited_intervals_count"
|
|
"Number of distinct time intervals in which we don't transfer some files from upload cache to db"
|
|
hashesInfo = Info "uni2work_inject_inhibited_hashes_count"
|
|
"Number of files which we don't transfer from upload cache to db during some interval"
|
|
|
|
data PoolMetrics = PoolMetrics
|
|
|
|
data PoolLabel = PoolDatabaseConnections
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
nullaryPathPiece ''PoolLabel $ camelToPathPiece' 1
|
|
|
|
poolMetrics :: PoolLabel
|
|
-> Custom.Pool' m c' c a
|
|
-> Metric PoolMetrics
|
|
poolMetrics lbl pool = Metric $ return (PoolMetrics, collectPoolMetrics)
|
|
where
|
|
labelPool = relabel "pool" $ toPathPiece lbl
|
|
|
|
collectPoolMetrics = map labelPool <$> do
|
|
(available, inUse, usesCount) <- atomically $ (,,)
|
|
<$> Custom.getPoolAvailableCount pool
|
|
<*> Custom.getPoolInUseCount pool
|
|
<*> Custom.getPoolUsesCount pool
|
|
return
|
|
[ SampleGroup availableInfo GaugeType
|
|
[ Sample "uni2work_pool_available_count" [] . encodeUtf8 $ tshow available
|
|
]
|
|
, SampleGroup inUseInfo GaugeType
|
|
[ Sample "uni2work_pool_in_use_count" [] . encodeUtf8 $ tshow inUse
|
|
]
|
|
, SampleGroup usesInfo CounterType
|
|
[ Sample "uni2work_pool_uses_count" [] . encodeUtf8 $ tshow usesCount
|
|
]
|
|
]
|
|
|
|
availableInfo = Info "uni2work_pool_available_count"
|
|
"Number of open resources available for taking"
|
|
inUseInfo = Info "uni2work_pool_in_use_count"
|
|
"Number of resources currently in use"
|
|
usesInfo = Info "uni2work_pool_uses_count"
|
|
"Number of takes executed against the pool"
|
|
|
|
{-# NOINLINE databaseConnDuration #-}
|
|
databaseConnDuration :: Vector Label1 Histogram
|
|
databaseConnDuration = unsafeRegister . vector "label" $ histogram info buckets
|
|
where
|
|
info = Info "uni2work_database_conn_duration_seconds"
|
|
"Duration of use of a database connection from the pool"
|
|
buckets = histogramBuckets 50e-6 5000
|
|
|
|
data DBConnUseState = DBConnUseState
|
|
{ dbConnUseStart :: !TimeSpec
|
|
, dbConnUseLabel :: !CallStack
|
|
} deriving (Show)
|
|
|
|
onUseDBConn :: (MonadIO m, MonadLogger m) => CallStack -> a -> m DBConnUseState
|
|
onUseDBConn dbConnUseLabel _ = do
|
|
$logDebugS "DB" $ case getCallStack dbConnUseLabel of
|
|
[] -> "no stack"
|
|
xs -> intercalate "; " $ map (\(f, loc) -> pack f <> " @(" <> pack (prettySrcLoc loc) <> ")") xs
|
|
dbConnUseStart <- liftIO $ getTime Monotonic
|
|
return DBConnUseState{..}
|
|
|
|
onReleaseDBConn :: MonadIO m => DBConnUseState -> a -> m ()
|
|
onReleaseDBConn DBConnUseState{..} _ = liftIO $ do
|
|
diff <- realToFrac . subtract dbConnUseStart <$> getTime Monotonic
|
|
let lbl = case reverse $ getCallStack dbConnUseLabel of
|
|
[] -> "unlabeled"
|
|
(_, SrcLoc{..}) : _ -> pack srcLocModule
|
|
withLabel databaseConnDuration lbl $ flip observe diff
|
|
|
|
data AuthTagEvalOutcome = OutcomeAuthorized | OutcomeUnauthorized | OutcomeAuthenticationRequired | OutcomeException
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
|
deriving (Universe, Finite)
|
|
nullaryPathPiece ''AuthTagEvalOutcome $ camelToPathPiece' 1
|
|
|
|
{-# NOINLINE authTagEvaluationDuration #-}
|
|
authTagEvaluationDuration :: Vector Label3 Histogram
|
|
authTagEvaluationDuration = unsafeRegister . vector ("tag", "outcome", "handler") $ histogram info buckets
|
|
where
|
|
info = Info "uni2work_auth_tag_evaluation_duration_seconds"
|
|
"Duration of auth tag evaluations"
|
|
buckets = histogramBuckets 5e-6 1
|
|
|
|
|
|
withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport
|
|
withHealthReportMetrics act = do
|
|
before <- liftIO getPOSIXTime
|
|
report <- act
|
|
after <- liftIO getPOSIXTime
|
|
|
|
let checkVal = toPathPiece $ classifyHealthReport report
|
|
statusVal = toPathPiece $ healthReportStatus report
|
|
timeSample, durationSample :: Double
|
|
timeSample = realToFrac (realToFrac after :: Nano)
|
|
durationSample = realToFrac (realToFrac $ after - before :: Nano)
|
|
liftIO $ withLabel healthReportTime (checkVal, statusVal) $ flip setGauge timeSample
|
|
liftIO $ withLabel healthReportDuration (checkVal, statusVal) $ flip observe durationSample
|
|
|
|
return report
|
|
|
|
registerGHCMetrics :: MonadIO m => m ()
|
|
registerGHCMetrics = void $ register ghcMetrics
|
|
|
|
observeHTTPRequestLatency :: forall site. ParseRoute site => (Route site -> String) -> Middleware
|
|
observeHTTPRequestLatency classifyHandler app req respond' = do
|
|
start <- getTime Monotonic
|
|
app req $ \res -> do
|
|
end <- getTime Monotonic
|
|
let method = decodeUtf8 $ Wai.requestMethod req
|
|
status = tshow . HTTP.statusCode $ Wai.responseStatus res
|
|
route :: Maybe (Route site)
|
|
route = parseRoute ( Wai.pathInfo req
|
|
, over (mapped . _2) (fromMaybe "") . HTTP.queryToQueryText $ Wai.queryString req
|
|
)
|
|
handler' = pack . classifyHandler <$> route
|
|
|
|
labels :: Label3
|
|
labels = (fromMaybe "n/a" handler', method, status)
|
|
withLabel httpRequestLatency labels . flip observe . realToFrac $ end - start
|
|
|
|
respond' res
|
|
|
|
registerReadyMetric :: MonadIO m => m ()
|
|
registerReadyMetric = liftIO $ void . register . readyMetric =<< getPOSIXTime
|
|
|
|
registerHealthCheckInterval :: MonadIO m => (HealthCheck -> Maybe NominalDiffTime) -> m ()
|
|
registerHealthCheckInterval = liftIO . void . register . healthCheckInterval
|
|
|
|
classifyJobWorkerState :: JobWorkerId -> JobWorkerState -> Prometheus.Label4
|
|
classifyJobWorkerState wId jws = (showWorkerId wId, tag, maybe "n/a" pack mJobCtl, maybe "n/a" pack mJob)
|
|
where
|
|
Aeson.Object obj = Aeson.toJSON jws
|
|
Aeson.String tag = obj HashMap.! "state"
|
|
mJobCtl = asum
|
|
[ classifyJobCtl <$> jws ^? _jobWorkerJobCtl
|
|
, "perform" <$ jws ^? _jobWorkerJob
|
|
]
|
|
mJob = classifyJob <$> jws ^? _jobWorkerJob
|
|
|
|
withJobWorkerState :: (MonadIO m, MonadMask m) => JobWorkerId -> JobWorkerState -> m a -> m a
|
|
withJobWorkerState wId newSt = withJobWorkerStateLbls $ classifyJobWorkerState wId newSt
|
|
|
|
withJobWorkerStateLbls :: (MonadIO m, MonadMask m) => Label4 -> m a -> m a
|
|
withJobWorkerStateLbls newLbls act = do
|
|
liftIO $ withLabel jobWorkerStateTransitions newLbls incCounter
|
|
|
|
start <- liftIO $ getTime Monotonic
|
|
res <- handleAll (return . Left) $ Right <$> act
|
|
end <- liftIO $ getTime Monotonic
|
|
|
|
liftIO . withLabel jobWorkerStateDuration newLbls . flip observe . realToFrac $ end - start
|
|
|
|
throwLeft res
|
|
|
|
observeYesodCacheSize :: MonadHandler m => m ()
|
|
observeYesodCacheSize = do
|
|
HandlerData{handlerState} <- liftHandler ask
|
|
liftIO $ do
|
|
GHState{..} <- readIORef handlerState
|
|
let size = fromIntegral $ length ghsCache + length ghsCacheBy
|
|
observe yesodCacheSize size
|
|
|
|
observeFavouritesQuickActionsDuration :: (MonadIO m, MonadMask m) => m a -> m a
|
|
observeFavouritesQuickActionsDuration act = do
|
|
start <- liftIO $ getTime Monotonic
|
|
res <- handleAll (return . Left) $ Right <$> act
|
|
end <- liftIO $ getTime Monotonic
|
|
|
|
liftIO . observe favouritesQuickActionsDuration . realToFrac $ end - start
|
|
|
|
throwLeft res
|
|
|
|
data LoginOutcome
|
|
= LoginSuccessful
|
|
| LoginInvalidCredentials
|
|
| LoginADInvalidCredentials
|
|
| LoginError
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
nullaryPathPiece ''LoginOutcome $ camelToPathPiece' 1
|
|
|
|
observeLoginOutcome :: MonadHandler m
|
|
=> Text -- ^ Plugin
|
|
-> LoginOutcome
|
|
-> m ()
|
|
observeLoginOutcome plugin outcome
|
|
= liftIO $ withLabel loginOutcomes (plugin, toPathPiece outcome) incCounter
|
|
|
|
registerJobHeldLocksCount :: MonadIO m => TVar (Set QueuedJobId) -> m ()
|
|
registerJobHeldLocksCount = liftIO . void . register . jobHeldLocksCount
|
|
|
|
data FileChunkStorage = StorageMinio | StorageDB | StorageARC | StoragePrewarm
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
nullaryPathPiece ''FileChunkStorage $ camelToPathPiece' 1
|
|
|
|
observeSunkChunk, observeSourcedChunk :: (Integral n, MonadIO m) => FileChunkStorage -> n -> m ()
|
|
observeSunkChunk store = liftIO . observeChunkSize sunkFileChunkSizes store . fromIntegral
|
|
observeSourcedChunk store = liftIO . observeChunkSize sourcedFileChunkSizes store . fromIntegral
|
|
|
|
observeChunkSize :: Vector Label1 Histogram -> FileChunkStorage -> Integer -> IO ()
|
|
observeChunkSize metric (toPathPiece -> storageLabel) = withLabel metric storageLabel . flip observe . fromInteger
|
|
|
|
observeDeletedUnreferencedFiles :: MonadIO m => Natural -> m ()
|
|
observeDeletedUnreferencedFiles = liftIO . void . addCounter deletedUnreferencedFiles . fromIntegral
|
|
|
|
observeDeletedUnreferencedChunks :: MonadIO m => Natural -> Word64 -> m ()
|
|
observeDeletedUnreferencedChunks num size = liftIO $ do
|
|
void . addCounter deletedUnreferencedChunks $ fromIntegral num
|
|
void . addCounter deletedUnreferencedChunksBytes $ fromIntegral size
|
|
|
|
observeInjectedFiles :: MonadIO m => Natural -> Word64 -> m ()
|
|
observeInjectedFiles num size = liftIO $ do
|
|
void . addCounter injectedFiles $ fromIntegral num
|
|
void . addCounter injectedFilesBytes $ fromIntegral size
|
|
|
|
observeRechunkedFiles :: MonadIO m => Natural -> Word64 -> m ()
|
|
observeRechunkedFiles num size = liftIO $ do
|
|
void . addCounter rechunkedFiles $ fromIntegral num
|
|
void . addCounter rechunkedFilesBytes $ fromIntegral size
|
|
|
|
registerJobWorkerQueueDepth :: MonadIO m => TMVar JobState -> m ()
|
|
registerJobWorkerQueueDepth = liftIO . void . register . jobWorkerQueueDepth
|
|
|
|
observeMissingFiles :: MonadIO m => Text -> Int -> m ()
|
|
observeMissingFiles refIdent = liftIO . withLabel missingFiles refIdent . flip setGauge . fromIntegral
|
|
|
|
observeDatabaseConnectionOpened, observeDatabaseConnectionClosed :: MonadIO m => m ()
|
|
observeDatabaseConnectionOpened = liftIO $ incCounter databaseConnectionsOpened
|
|
observeDatabaseConnectionClosed = liftIO $ incCounter databaseConnectionsClosed
|
|
|
|
observeAuthTagEvaluation :: MonadUnliftIO m => AuthTag -> String -> m (a, AuthTagEvalOutcome) -> m a
|
|
observeAuthTagEvaluation aTag handler act = do
|
|
start <- liftIO $ getTime Monotonic
|
|
res <- tryAny act
|
|
end <- liftIO $ getTime Monotonic
|
|
|
|
let outcome = case res of
|
|
Right (_, outcome') -> outcome'
|
|
Left _ -> OutcomeException
|
|
|
|
liftIO . withLabel authTagEvaluationDuration (toPathPiece aTag, toPathPiece outcome, pack handler) . flip observe . realToFrac $ end - start
|
|
|
|
either throwIO (views _1 return) res
|
|
|
|
observeFavouritesSkippedDueToDBLoad :: MonadIO m => m ()
|
|
observeFavouritesSkippedDueToDBLoad = liftIO $ incCounter favouritesSkippedDueToDBLoad
|