diff --git a/PaymentServer.cabal b/PaymentServer.cabal index ad233b8d51579539b5ee8146920761a97681178a..f6997bde9da04ae348826d79e4b9c5e569c41931 100644 --- a/PaymentServer.cabal +++ b/PaymentServer.cabal @@ -20,6 +20,7 @@ library , PaymentServer.Issuer , PaymentServer.Persistence , PaymentServer.Redemption + , PaymentServer.Metrics , PaymentServer.Server , PaymentServer.Main build-depends: base >= 4.7 && < 5 @@ -43,6 +44,7 @@ library , cryptonite , sqlite-simple , retry + , prometheus-client default-language: Haskell2010 ghc-options: -Wmissing-import-lists -Wunused-imports pkgconfig-depends: libchallenge_bypass_ristretto_ffi @@ -69,13 +71,20 @@ test-suite PaymentServer-tests hs-source-dirs: test main-is: Spec.hs other-modules: Persistence + , Metrics build-depends: base + , bytestring , text , tasty , tasty-hunit , directory , async , sqlite-simple + , http-types + , wai + , wai-extra + , servant-server + , prometheus-client , PaymentServer default-language: Haskell2010 diff --git a/src/PaymentServer/Metrics.hs b/src/PaymentServer/Metrics.hs new file mode 100644 index 0000000000000000000000000000000000000000..1c6c30e5fdbc266f1aa881469edd62f2c65b777f --- /dev/null +++ b/src/PaymentServer/Metrics.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module PaymentServer.Metrics + ( metricsAPI + , metricsServer + ) where + +import Data.Text.Lazy + ( Text + ) +import Data.Text.Lazy.Encoding + ( decodeUtf8 + ) + +import Prometheus + ( exportMetricsAsText + ) + +import Servant + ( Proxy(Proxy) + , Server + , Handler + , Get + , PlainText + , (:>) + ) + +type MetricsAPI = "metrics" :> Get '[PlainText] Text + +metricsAPI :: Proxy MetricsAPI +metricsAPI = Proxy + +metricsServer :: Server MetricsAPI +metricsServer = metrics + +metrics :: Handler Text +metrics = exportMetricsAsText >>= return . decodeUtf8 diff --git a/test/Metrics.hs b/test/Metrics.hs new file mode 100644 index 0000000000000000000000000000000000000000..fe383adf174bc5cffc6d7e5018931dd69fb19c86 --- /dev/null +++ b/test/Metrics.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Tests related to PaymentServer.Metrics and the metrics it exposes. + +module Metrics + ( tests + ) where + +import Data.ByteString.Lazy.Char8 + ( pack + ) + +import Test.Tasty + ( TestTree + , testGroup + ) + +import Test.Tasty.HUnit + ( testCase + , assertEqual + ) + +import Network.HTTP.Types + ( methodGet + ) +import Network.Wai + ( defaultRequest + , requestMethod + ) +import Network.Wai.Test + ( Session + , SResponse + , runSession + , setPath + , request + , assertStatus + , assertContentType + , assertBody + ) + +import Servant + ( Application + , serve + ) + +import Prometheus + ( Metric + , Info(Info) + , unsafeRegister + , counter + , incCounter + ) + +import PaymentServer.Metrics + ( metricsAPI + , metricsServer + ) +import PaymentServer.Server + ( paymentServerApp + ) +import PaymentServer.Persistence + ( VoucherDatabaseState + ) + +tests :: TestTree +tests = testGroup "Metrics" + [ metricsTests + ] + +readMetrics :: Session SResponse +readMetrics = request $ setPath defaultRequest { requestMethod = methodGet } "/metrics" + +-- Register a counter at the top-level because the registry is global and this +-- lets us avoid thinking about collisions or unregistration. unsafeRegister +-- is (only) safe for defining a top-level symbol. +aCounter = unsafeRegister $ counter (Info "a_counter" "A test counter.") + +metricsTests :: TestTree +metricsTests = + -- | A ``GET /metrics`` request receives a text/plain OK response containing + -- current Prometheus-formatted metrics information. + testCase "plaintext metrics response" $ + let + app :: Application + app = serve metricsAPI metricsServer + in + flip runSession app $ do + incCounter aCounter + response <- readMetrics + assertStatus 200 response + assertContentType "text/plain" response + assertBody expectedMetrics response + where + expectedMetrics = pack . unlines $ + [ "# HELP a_counter A test counter." + , "# TYPE a_counter counter" + , "a_counter 1.0" + ] diff --git a/test/Spec.hs b/test/Spec.hs index 5821f6551290e304aabbdcad998dcc98a44c23ff..e52ca131e7af29d3b094334ff21b853fe43701dd 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -11,10 +11,12 @@ import Test.Tasty ) import qualified Persistence +import qualified Metrics tests :: TestTree tests = testGroup "Tests" [ Persistence.tests + , Metrics.tests ] main = defaultMain tests