diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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). diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/glue-prometheus.cabal b/glue-prometheus.cabal new file mode 100644 --- /dev/null +++ b/glue-prometheus.cabal @@ -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 diff --git a/src/Glue/Prometheus.hs b/src/Glue/Prometheus.hs new file mode 100644 --- /dev/null +++ b/src/Glue/Prometheus.hs @@ -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))) diff --git a/test/Glue/PrometheusSpec.hs b/test/Glue/PrometheusSpec.hs new file mode 100644 --- /dev/null +++ b/test/Glue/PrometheusSpec.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}