glue-prometheus (empty) → 0.8.0.0
raw patch · 7 files changed
+510/−0 lines, 7 filesdep +basedep +bytestringdep +containers
Dependencies added: base, bytestring, containers, glue-common, glue-core, glue-prometheus, hspec, prometheus-client, text, unliftio
Files
- CHANGELOG.md +9/−0
- LICENSE +30/−0
- glue-prometheus.cabal +66/−0
- src/Glue/Prometheus.hs +263/−0
- test/Glue/PrometheusSpec.hs +127/−0
- test/Main.hs +14/−0
- test/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,9 @@+# Changelog for glue-prometheus++## 0.8.0.0++- First release: Prometheus metrics through prometheus-client for services+ (`instrumentService`, `instrumentServiceEither`) and for glue's combinators through their+ observer hooks: circuit breaker phase and transitions, retries and their waits, keyed+ concurrency slots and refusals, hedge launches, attempt outcomes and winners, and graceful+ shutdown in-flight counts (#15).
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Sean Parsons++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Sean Parsons nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ glue-prometheus.cabal view
@@ -0,0 +1,66 @@+cabal-version: 3.0+name: glue-prometheus+version: 0.8.0.0+synopsis: Make better services and clients.+description: Glue library that records Prometheus metrics for services and glue's combinators through prometheus-client.+license: BSD-3-Clause+license-file: LICENSE+author: Sean Parsons+maintainer: github@futurenotfound.com+category: Network+build-type: Simple+extra-doc-files: CHANGELOG.md+tested-with: GHC == 9.6.7, GHC == 9.8.4, GHC == 9.10.3, GHC == 9.12.3++source-repository head+ type: git+ location: https://github.com/seanparsons/glue.git++common common-options+ default-language: Haskell2010+ ghc-options:+ -Wall+ -Wcompat+ -Widentities+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wmissing-home-modules+ -Wpartial-fields+ -Wredundant-constraints++library+ import: common-options+ hs-source-dirs: src+ exposed-modules: Glue.Prometheus+ build-depends:+ , base >= 4.14 && < 5+ , bytestring >= 0.10 && < 0.13+ , glue-common ^>= 0.8.0+ , glue-core ^>= 0.8.0+ , prometheus-client >= 1.1 && < 1.2+ , text >= 1.2 && < 2.2+ , unliftio >= 0.2 && < 0.3++test-suite glue-prometheus-tests+ import: common-options+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules:+ Glue.PrometheusSpec+ Spec+ build-tool-depends: hspec-discover:hspec-discover+ ghc-options:+ -threaded+ -rtsopts+ -with-rtsopts=-N+ build-depends:+ , base >= 4.14 && < 5+ , containers >= 0.6 && < 0.8+ , glue-common ^>= 0.8.0+ , glue-core ^>= 0.8.0+ , glue-prometheus+ , hspec >= 2.7 && < 2.12+ , prometheus-client >= 1.1 && < 1.2+ , text >= 1.2 && < 2.2+ , unliftio >= 0.2 && < 0.3
+ src/Glue/Prometheus.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Module recording Prometheus metrics for services and glue's combinators through+-- "Prometheus" (prometheus-client).+--+-- Metrics are registered once with the @register...Metrics@ functions and shared by every service+-- or combinator they instrument, each telling them apart by a caller-supplied name. Names follow+-- Prometheus conventions and every label has bounded cardinality: service, breaker and limiter+-- names are chosen by the caller, attempt indices are bounded by the number of backends, and+-- request keys are never used as labels.+--+-- [@glue_service_calls_total{service}@] Calls started.+-- [@glue_service_failures_total{service}@] Calls that failed (a synchronous exception, or @Left@).+-- [@glue_service_duration_seconds{service}@] Histogram of the duration of calls that completed.+-- [@glue_circuit_breaker_state{breaker}@] 0 closed, 1 half-open, 2 open.+-- [@glue_circuit_breaker_transitions_total{breaker,from,to}@] Phase changes (@closed@, @half_open@, @open@).+-- [@glue_retries_total{service}@] Retries made.+-- [@glue_retry_delay_seconds{service}@] Histogram of the wait chosen before each retry.+-- [@glue_concurrency_in_flight{limiter}@] Slots currently held.+-- [@glue_concurrency_refusals_total{limiter}@] Calls refused because their key was full.+-- [@glue_hedge_launches_total{service,attempt}@] Backups launched.+-- [@glue_hedge_attempts_total{service,attempt,outcome}@] Attempts ended (@answered@, @failed@, @cancelled@, @crashed@).+-- [@glue_hedge_wins_total{service,attempt}@] Answers returned, by the attempt that won.+-- [@glue_shutdown_in_flight{service}@] Calls in flight through a graceful shutdown wrapper, sampled at scrape.+module Glue.Prometheus+ ( -- * Services+ ServiceMetrics (..)+ , registerServiceMetrics+ , instrumentService+ , instrumentServiceEither+ -- * Circuit breakers+ , BreakerMetrics (..)+ , registerBreakerMetrics+ , instrumentBreakerOptions+ -- * Retries+ , RetryMetrics (..)+ , registerRetryMetrics+ , instrumentRetryOptions+ -- * Concurrency limits+ , ConcurrencyMetrics (..)+ , registerConcurrencyMetrics+ , instrumentAdmissionStore+ -- * Hedging+ , HedgeMetrics (..)+ , registerHedgeMetrics+ , instrumentHedgeOptions+ -- * Graceful shutdown+ , shutdownInFlightMetric+ ) where++import qualified Data.ByteString.Char8 as BS8+import Data.Text (Text, pack)+import GHC.Clock (getMonotonicTimeNSec)+import Glue.CircuitBreaker (BreakerPhase (..),+ BreakerTransition (..),+ CircuitBreakerOptions (..))+import Glue.ConcurrencyLimit (AdmissionLease (..),+ AdmissionStore (..))+import Glue.Failure (EitherService)+import Glue.Hedging (AttemptOutcome (..), HedgeOptions (..))+import Glue.Retry (RetryOptions (..))+import Glue.Shutdown (ShutdownHandle (..))+import Glue.Types (BasicService)+import Prometheus (Counter, Gauge, Histogram, Info (..),+ Metric (..), Sample (..),+ SampleGroup (..), SampleType (..),+ Vector, addGauge, counter,+ defaultBuckets, gauge, histogram,+ incCounter, observe, register,+ setGauge, vector, withLabel)+import UnliftIO (MonadIO, MonadUnliftIO, liftIO)+import UnliftIO.Exception (throwIO, tryAny)++secondsSince :: MonadIO m => m (m Double)+secondsSince = do+ start <- liftIO getMonotonicTimeNSec+ pure $ do+ end <- liftIO getMonotonicTimeNSec+ pure (fromIntegral (end - start) / 1e9)++-- | Metrics for instrumented services.+data ServiceMetrics = ServiceMetrics+ { serviceCalls :: Vector Text Counter+ , serviceFailures :: Vector Text Counter+ , serviceDuration :: Vector Text Histogram+ }++-- | Registers the service metrics with the global registry.+registerServiceMetrics :: MonadIO n => n ServiceMetrics+registerServiceMetrics =+ ServiceMetrics+ <$> register (vector "service" (counter (Info "glue_service_calls_total" "Calls started.")))+ <*> register (vector "service" (counter (Info "glue_service_failures_total" "Calls that failed.")))+ <*> register (vector "service" (histogram (Info "glue_service_duration_seconds" "Duration of calls that completed.") defaultBuckets))++instrumentVia :: MonadUnliftIO m => (r -> Bool) -> ServiceMetrics -> Text -> BasicService m a r -> BasicService m a r+instrumentVia failed metrics name service request = do+ liftIO $ withLabel (serviceCalls metrics) name incCounter+ elapsed <- secondsSince+ let finish isFailure = do+ seconds <- elapsed+ liftIO $ do+ withLabel (serviceDuration metrics) name (`observe` seconds)+ if isFailure then withLabel (serviceFailures metrics) name incCounter else pure ()+ outcome <- tryAny (service request)+ case outcome of+ Left e -> finish True >> throwIO e+ Right result -> finish (failed result) >> pure result++-- | Records calls, failures (synchronous exceptions) and the duration of completed calls under the+-- given service name. Calls cancelled by an asynchronous exception are counted as calls only.+instrumentService :: MonadUnliftIO m => ServiceMetrics -> Text -> BasicService m a b -> BasicService m a b+instrumentService = instrumentVia (const False)++-- | Variant of 'instrumentService' for services returning failures as values, counting @Left@+-- results (as well as exceptions) as failures.+instrumentServiceEither :: MonadUnliftIO m => ServiceMetrics -> Text -> EitherService m a e b -> EitherService m a e b+instrumentServiceEither = instrumentVia (either (const True) (const False))++-- | Metrics for circuit breakers.+data BreakerMetrics = BreakerMetrics+ { breakerState :: Vector Text Gauge+ , breakerTransitions :: Vector (Text, Text, Text) Counter+ }++-- | Registers the circuit breaker metrics with the global registry.+registerBreakerMetrics :: MonadIO n => n BreakerMetrics+registerBreakerMetrics =+ BreakerMetrics+ <$> register (vector "breaker" (gauge (Info "glue_circuit_breaker_state" "Circuit breaker phase: 0 closed, 1 half-open, 2 open.")))+ <*> register (vector ("breaker", "from", "to") (counter (Info "glue_circuit_breaker_transitions_total" "Circuit breaker phase changes.")))++phaseValue :: BreakerPhase -> Double+phaseValue BreakerClosed = 0+phaseValue BreakerHalfOpen = 1+phaseValue BreakerOpen = 2++phaseLabel :: BreakerPhase -> Text+phaseLabel BreakerClosed = "closed"+phaseLabel BreakerHalfOpen = "half_open"+phaseLabel BreakerOpen = "open"++-- | Records the breaker's phase and its transitions under the given name, keeping any existing+-- 'onBreakerTransition'. The phase gauge starts at closed.+instrumentBreakerOptions :: (MonadIO n, MonadIO m) => BreakerMetrics -> Text -> CircuitBreakerOptions m failure -> n (CircuitBreakerOptions m failure)+instrumentBreakerOptions metrics name options = do+ liftIO $ withLabel (breakerState metrics) name (`setGauge` phaseValue BreakerClosed)+ pure options+ { onBreakerTransition = \transition -> do+ liftIO $ do+ withLabel (breakerState metrics) name (`setGauge` phaseValue (transitionTo transition))+ withLabel (breakerTransitions metrics) (name, phaseLabel (transitionFrom transition), phaseLabel (transitionTo transition)) incCounter+ onBreakerTransition options transition+ }++-- | Metrics for retries.+data RetryMetrics = RetryMetrics+ { retryCount :: Vector Text Counter+ , retryDelay :: Vector Text Histogram+ }++-- | Registers the retry metrics with the global registry.+registerRetryMetrics :: MonadIO n => n RetryMetrics+registerRetryMetrics =+ RetryMetrics+ <$> register (vector "service" (counter (Info "glue_retries_total" "Retries made.")))+ <*> register (vector "service" (histogram (Info "glue_retry_delay_seconds" "Wait chosen before each retry.") defaultBuckets))++-- | Records each retry and its wait under the given service name, keeping any existing 'onRetry'.+instrumentRetryOptions :: MonadIO m => RetryMetrics -> Text -> RetryOptions m a failure -> RetryOptions m a failure+instrumentRetryOptions metrics name options =+ options+ { onRetry = \attempt failure delayMs -> do+ liftIO $ do+ withLabel (retryCount metrics) name incCounter+ withLabel (retryDelay metrics) name (`observe` (fromIntegral delayMs / 1000))+ onRetry options attempt failure delayMs+ }++-- | Metrics for keyed concurrency limits.+data ConcurrencyMetrics = ConcurrencyMetrics+ { concurrencyInFlight :: Vector Text Gauge+ , concurrencyRefusals :: Vector Text Counter+ }++-- | Registers the concurrency limit metrics with the global registry.+registerConcurrencyMetrics :: MonadIO n => n ConcurrencyMetrics+registerConcurrencyMetrics =+ ConcurrencyMetrics+ <$> register (vector "limiter" (gauge (Info "glue_concurrency_in_flight" "Slots currently held.")))+ <*> register (vector "limiter" (counter (Info "glue_concurrency_refusals_total" "Calls refused because their key was full.")))++-- | Records slots held and refusals for every key of the store under one limiter name.+instrumentAdmissionStore :: MonadIO m => ConcurrencyMetrics -> Text -> AdmissionStore m k -> AdmissionStore m k+instrumentAdmissionStore metrics name store =+ store+ { claimSlot = \key -> do+ claimed <- claimSlot store key+ case claimed of+ Nothing -> do+ liftIO $ withLabel (concurrencyRefusals metrics) name incCounter+ pure Nothing+ Just lease -> do+ liftIO $ withLabel (concurrencyInFlight metrics) name (`addGauge` 1)+ pure $ Just lease+ { releaseLease = releaseLease lease >> liftIO (withLabel (concurrencyInFlight metrics) name (`addGauge` (-1)))+ }+ }++-- | Metrics for hedged requests.+data HedgeMetrics = HedgeMetrics+ { hedgeLaunches :: Vector (Text, Text) Counter+ , hedgeAttempts :: Vector (Text, Text, Text) Counter+ , hedgeWins :: Vector (Text, Text) Counter+ }++-- | Registers the hedging metrics with the global registry.+registerHedgeMetrics :: MonadIO n => n HedgeMetrics+registerHedgeMetrics =+ HedgeMetrics+ <$> register (vector ("service", "attempt") (counter (Info "glue_hedge_launches_total" "Backups launched.")))+ <*> register (vector ("service", "attempt", "outcome") (counter (Info "glue_hedge_attempts_total" "Attempts ended, by outcome.")))+ <*> register (vector ("service", "attempt") (counter (Info "glue_hedge_wins_total" "Answers returned, by the attempt that won.")))++outcomeLabel :: AttemptOutcome failure r -> Text+outcomeLabel (AttemptAnswered _) = "answered"+outcomeLabel (AttemptFailed _) = "failed"+outcomeLabel AttemptCancelled = "cancelled"+outcomeLabel (AttemptCrashed _) = "crashed"++-- | Records backup launches, how each attempt ended and which attempt won under the given service+-- name, keeping any existing hooks.+instrumentHedgeOptions :: MonadIO m => HedgeMetrics -> Text -> HedgeOptions m failure r -> HedgeOptions m failure r+instrumentHedgeOptions metrics name options =+ options+ { admitLaunch = \index -> do+ admitted <- admitLaunch options index+ if admitted then liftIO (withLabel (hedgeLaunches metrics) (name, attemptLabel index) incCounter) else pure ()+ pure admitted+ , onAttemptEnded = \index outcome -> do+ liftIO $ withLabel (hedgeAttempts metrics) (name, attemptLabel index, outcomeLabel outcome) incCounter+ onAttemptEnded options index outcome+ , onHedgeWon = \index -> do+ liftIO $ withLabel (hedgeWins metrics) (name, attemptLabel index) incCounter+ onHedgeWon options index+ }+ where+ attemptLabel = pack . show++-- | A metric sampling the in-flight count of each named graceful shutdown wrapper at scrape time.+-- Register it once with every handle to report.+shutdownInFlightMetric :: [(Text, ShutdownHandle IO)] -> Metric ()+shutdownInFlightMetric handles = Metric $ pure ((), collect)+ where+ info = Info "glue_shutdown_in_flight" "Calls in flight through a graceful shutdown wrapper."+ collect = do+ samples <- traverse sample handles+ pure [SampleGroup info GaugeType samples]+ sample (name, handle) = do+ count <- inFlightCount handle+ pure $ Sample (metricName info) [("service", name)] (BS8.pack (show (fromIntegral count :: Double)))
+ test/Glue/PrometheusSpec.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Glue.PrometheusSpec (spec) where++import Data.IORef+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Map.Strict as M+import Data.Text (Text)+import Glue.CircuitBreaker+import Glue.Clock.Virtual+import Glue.ConcurrencyLimit+import Glue.Hedging+import Glue.Prometheus+import Glue.Retry+import Glue.Shutdown+import Prometheus (Metric (..), Sample (..),+ SampleGroup (..), getCounter, getGauge,+ getHistogram, getVectorWith)+import Test.Hspec+import UnliftIO.Async (async, wait)+import UnliftIO.Exception (Exception, SomeException, throwIO, try)+import UnliftIO.STM (atomically, newEmptyTMVarIO, putTMVar,+ readTMVar)++data PrometheusTestException = PrometheusTestException+ deriving (Eq, Show)++instance Exception PrometheusTestException++counters :: Ord l => (m -> IO Double) -> IO [(l, m)] -> IO (M.Map l Double)+counters reader entries = entries >>= fmap M.fromList . traverse (\(l, m) -> (,) l <$> reader m)++observations :: [(Text, M.Map Double Int)] -> M.Map Text Int+observations = M.fromList . fmap (fmap sum)++spec :: Spec+spec = do+ describe "instrumentService" $ do+ it "Records calls, failures and durations per service" $ do+ metrics <- registerServiceMetrics+ let ok = instrumentService metrics "ok" (\(x :: Int) -> pure x)+ failing = instrumentService metrics "failing" (\(_ :: Int) -> throwIO PrometheusTestException :: IO Int)+ _ <- traverse ok [1, 2, 3]+ failing 1 `shouldThrow` (== PrometheusTestException)+ getVectorWith (serviceCalls metrics) getCounter >>= (`shouldBe` M.fromList [("failing", 1), ("ok", 3)]) . M.fromList+ getVectorWith (serviceFailures metrics) getCounter >>= (`shouldBe` M.fromList [("failing", 1)]) . M.fromList+ observations <$> getVectorWith (serviceDuration metrics) getHistogram+ `shouldReturn` M.fromList [("failing", 1), ("ok", 3)]++ it "Counts Left results as failures for Either services" $ do+ metrics <- registerServiceMetrics+ let service = instrumentServiceEither metrics "either" (\(x :: Int) -> pure (if x > 0 then Right x else Left ("bad" :: String)))+ _ <- traverse service [1, 0, -1]+ M.fromList <$> getVectorWith (serviceFailures metrics) getCounter `shouldReturn` M.fromList [("either", 2)]++ describe "instrumentBreakerOptions" $+ it "Tracks the breaker phase and counts transitions, keeping the existing observer" $ do+ metrics <- registerBreakerMetrics+ vc <- newVirtualClock+ seen <- newIORef (0 :: Int)+ options <- instrumentBreakerOptions metrics "backend"+ (defaultCircuitBreakerOptions :: CircuitBreakerOptions IO SomeException)+ { breakerFailureThreshold = 1+ , breakerClock = virtualClock vc+ , onBreakerTransition = const (atomicModifyIORef' seen (\n -> (n + 1, ())))+ }+ counters getGauge (getVectorWith (breakerState metrics) pure) `shouldReturn` M.fromList [("backend", 0)]+ (_, breaker) <- circuitBreaker options (\(_ :: Int) -> throwIO PrometheusTestException :: IO Int)+ _ <- try (breaker 1) :: IO (Either PrometheusTestException Int)+ counters getGauge (getVectorWith (breakerState metrics) pure) `shouldReturn` M.fromList [("backend", 2)]+ counters getCounter (getVectorWith (breakerTransitions metrics) pure)+ `shouldReturn` M.fromList [(("backend", "closed", "open"), 1)]+ readIORef seen `shouldReturn` 1++ describe "instrumentRetryOptions" $+ it "Counts retries and their waits" $ do+ metrics <- registerRetryMetrics+ calls <- newIORef (0 :: Int)+ let options = instrumentRetryOptions metrics "flaky" (defaultRetryOptions :: RetryOptions IO Int SomeException) { maximumRetries = 2 }+ service (x :: Int) = atomicModifyIORef' calls (\n -> (n + 1, n + 1)) >>= \n -> if n < 3 then throwIO PrometheusTestException else pure x+ retryingService options service 5 `shouldReturn` 5+ counters getCounter (getVectorWith (retryCount metrics) pure) `shouldReturn` M.fromList [("flaky", 2)]+ observations <$> getVectorWith (retryDelay metrics) getHistogram `shouldReturn` M.fromList [("flaky", 2)]++ describe "instrumentAdmissionStore" $+ it "Tracks slots in flight and refusals per limiter" $ do+ metrics <- registerConcurrencyMetrics+ store <- instrumentAdmissionStore metrics "providers" <$> newInMemoryAdmissionStore (const 1)+ gate <- newEmptyTMVarIO+ started <- newEmptyTMVarIO+ let held = withSlot store ("a" :: Text) (atomically (putTMVar started ()) >> atomically (readTMVar gate))+ waiting <- async held+ atomically $ readTMVar started+ counters getGauge (getVectorWith (concurrencyInFlight metrics) pure) `shouldReturn` M.fromList [("providers", 1)]+ withSlot store "a" (pure ()) `shouldReturn` Left Saturated+ counters getCounter (getVectorWith (concurrencyRefusals metrics) pure) `shouldReturn` M.fromList [("providers", 1)]+ atomically $ putTMVar gate ()+ wait waiting `shouldReturn` Right ()+ counters getGauge (getVectorWith (concurrencyInFlight metrics) pure) `shouldReturn` M.fromList [("providers", 0)]++ describe "instrumentHedgeOptions" $+ it "Counts backup launches, attempt outcomes and the winner" $ do+ metrics <- registerHedgeMetrics+ let options = instrumentHedgeOptions metrics "search" (defaultHedgeOptions :: HedgeOptions IO SomeException Int)+ hedgeAcross options ((\_ -> throwIO PrometheusTestException) :| [pure]) (7 :: Int) `shouldReturn` 7+ counters getCounter (getVectorWith (hedgeLaunches metrics) pure) `shouldReturn` M.fromList [(("search", "1"), 1)]+ counters getCounter (getVectorWith (hedgeAttempts metrics) pure)+ `shouldReturn` M.fromList [(("search", "0", "failed"), 1), (("search", "1", "answered"), 1)]+ counters getCounter (getVectorWith (hedgeWins metrics) pure) `shouldReturn` M.fromList [(("search", "1"), 1)]++ describe "shutdownInFlightMetric" $+ it "Samples each handle's in-flight count at collection" $ do+ gate <- newEmptyTMVarIO+ started <- newEmptyTMVarIO+ (service, handle) <- gracefulShutdown (defaultShutdownOptions :: ShutdownOptions IO Int) $ \(x :: Int) -> do+ atomically $ putTMVar started ()+ atomically $ readTMVar gate+ pure x+ ((), collect) <- construct (shutdownInFlightMetric [("api", handle)])+ let values = fmap (\groups -> [(labels, value) | SampleGroup _ _ samples <- groups, Sample _ labels value <- samples]) collect+ values `shouldReturn` [([("service", "api")], "0.0")]+ call <- async (service 1)+ atomically $ readTMVar started+ values `shouldReturn` [([("service", "api")], "1.0")]+ atomically $ putTMVar gate ()+ wait call `shouldReturn` 1
+ test/Main.hs view
@@ -0,0 +1,14 @@+module Main where++import qualified Spec+import Test.Hspec.Runner++customConfig :: Config+customConfig = defaultConfig+ { configColorMode = ColorAlways+ , configPrintCpuTime = True+ }+++main :: IO ()+main = hspecWith customConfig Spec.spec
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}