diff --git a/PaymentServer.cabal b/PaymentServer.cabal
index ad233b8d51579539b5ee8146920761a97681178a..134ce45a529fc52c21f8806b3bc2299dd34f5ea6 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,8 @@ library
, cryptonite
, sqlite-simple
, retry
+ , prometheus-client
+ , servant-prometheus
default-language: Haskell2010
ghc-options: -Wmissing-import-lists -Wunused-imports
pkgconfig-depends: libchallenge_bypass_ristretto_ffi
@@ -69,13 +72,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/nix/PaymentServer.nix b/nix/PaymentServer.nix
index af085ed41911cae1c49807f6b15ab00d013372dd..846f1c154ce298dbd260aace8830642e29e17484 100644
--- a/nix/PaymentServer.nix
+++ b/nix/PaymentServer.nix
@@ -77,6 +77,8 @@ in { system, compiler, flags, pkgs, hsPkgs, pkgconfPkgs, ... }:
(hsPkgs."cryptonite" or (buildDepError "cryptonite"))
(hsPkgs."sqlite-simple" or (buildDepError "sqlite-simple"))
(hsPkgs."retry" or (buildDepError "retry"))
+ (hsPkgs."prometheus-client" or (buildDepError "prometheus-client"))
+ (hsPkgs."servant-prometheus" or (buildDepError "servant-prometheus"))
];
pkgconfig = [
(pkgconfPkgs."libchallenge_bypass_ristretto_ffi" or (pkgConfDepError "libchallenge_bypass_ristretto_ffi"))
diff --git a/nix/pkgs.nix b/nix/pkgs.nix
index 8997dd1f9c75453787358677081b314ae4262e3a..24d76f5e99175d041360587d5739c7e23a509211 100644
--- a/nix/pkgs.nix
+++ b/nix/pkgs.nix
@@ -5,7 +5,10 @@
"stripe-core" = (((hackage.stripe-core)."2.5.0").revisions).default;
"stripe-haskell" = (((hackage.stripe-haskell)."2.5.0").revisions).default;
"stripe-http-client" = (((hackage.stripe-http-client)."2.5.0").revisions).default;
- } // { PaymentServer = ./PaymentServer.nix; }) // {};
+ } // {
+ PaymentServer = ./PaymentServer.nix;
+ servant-prometheus = ./servant-prometheus.nix;
+ }) // {};
};
resolver = "lts-14.1";
}
\ No newline at end of file
diff --git a/nix/servant-prometheus.nix b/nix/servant-prometheus.nix
new file mode 100644
index 0000000000000000000000000000000000000000..fb013289ac659a8bad420e5ef170d2a26517febe
--- /dev/null
+++ b/nix/servant-prometheus.nix
@@ -0,0 +1,112 @@
+let
+ buildDepError = pkg:
+ builtins.throw ''
+ The Haskell package set does not contain the package: ${pkg} (build dependency).
+
+ If you are using Stackage, make sure that you are using a snapshot that contains the package. Otherwise you may need to update the Hackage snapshot you are using, usually by updating haskell.nix.
+ '';
+ sysDepError = pkg:
+ builtins.throw ''
+ The Nixpkgs package set does not contain the package: ${pkg} (system dependency).
+
+ You may need to augment the system package mapping in haskell.nix so that it can be found.
+ '';
+ pkgConfDepError = pkg:
+ builtins.throw ''
+ The pkg-conf packages does not contain the package: ${pkg} (pkg-conf dependency).
+
+ You may need to augment the pkg-conf package mapping in haskell.nix so that it can be found.
+ '';
+ exeDepError = pkg:
+ builtins.throw ''
+ The local executable components do not include the component: ${pkg} (executable dependency).
+ '';
+ legacyExeDepError = pkg:
+ builtins.throw ''
+ The Haskell package set does not contain the package: ${pkg} (executable dependency).
+
+ If you are using Stackage, make sure that you are using a snapshot that contains the package. Otherwise you may need to update the Hackage snapshot you are using, usually by updating haskell.nix.
+ '';
+ buildToolDepError = pkg:
+ builtins.throw ''
+ Neither the Haskell package set or the Nixpkgs package set contain the package: ${pkg} (build tool dependency).
+
+ If this is a system dependency:
+ You may need to augment the system package mapping in haskell.nix so that it can be found.
+
+ If this is a Haskell dependency:
+ If you are using Stackage, make sure that you are using a snapshot that contains the package. Otherwise you may need to update the Hackage snapshot you are using, usually by updating haskell.nix.
+ '';
+in { system, compiler, flags, pkgs, hsPkgs, pkgconfPkgs, ... }:
+ {
+ flags = {};
+ package = {
+ specVersion = "1.10";
+ identifier = { name = "servant-prometheus"; version = "0.1.0.0"; };
+ license = "BSD-3-Clause";
+ copyright = "";
+ maintainer = "Alex Mason <axman6@gmail.com>, Jack Kelly <jack.kelly@data61.csiro.au>";
+ author = "Alex Mason <axman6@gmail.com>, Anchor Engineering <engineering@lists.anchor.net.au>, Servant Contributors";
+ homepage = "";
+ url = "";
+ synopsis = "Helpers for using prometheus with servant";
+ description = "Helpers for using prometheus with servant. Each endpoint has its own metrics allowing more detailed monitoring than wai-middleware-prometheus allows";
+ buildType = "Simple";
+ };
+ components = {
+ "library" = {
+ depends = [
+ (hsPkgs."base" or (buildDepError "base"))
+ (hsPkgs."prometheus-client" or (buildDepError "prometheus-client"))
+ (hsPkgs."servant" or (buildDepError "servant"))
+ (hsPkgs."http-types" or (buildDepError "http-types"))
+ (hsPkgs."text" or (buildDepError "text"))
+ (hsPkgs."time" or (buildDepError "time"))
+ (hsPkgs."unordered-containers" or (buildDepError "unordered-containers"))
+ (hsPkgs."wai" or (buildDepError "wai"))
+ (hsPkgs."bytestring" or (buildDepError "bytestring"))
+ ];
+ };
+ exes = {
+ "bench" = {
+ depends = [
+ (hsPkgs."base" or (buildDepError "base"))
+ (hsPkgs."aeson" or (buildDepError "aeson"))
+ (hsPkgs."servant-prometheus" or (buildDepError "servant-prometheus"))
+ (hsPkgs."servant-server" or (buildDepError "servant-server"))
+ (hsPkgs."prometheus-client" or (buildDepError "prometheus-client"))
+ (hsPkgs."text" or (buildDepError "text"))
+ (hsPkgs."wai" or (buildDepError "wai"))
+ (hsPkgs."warp" or (buildDepError "warp"))
+ (hsPkgs."process" or (buildDepError "process"))
+ ];
+ };
+ };
+ tests = {
+ "spec" = {
+ depends = [
+ (hsPkgs."base" or (buildDepError "base"))
+ (hsPkgs."aeson" or (buildDepError "aeson"))
+ (hsPkgs."servant-prometheus" or (buildDepError "servant-prometheus"))
+ (hsPkgs."servant-server" or (buildDepError "servant-server"))
+ (hsPkgs."servant-client" or (buildDepError "servant-client"))
+ (hsPkgs."servant" or (buildDepError "servant"))
+ (hsPkgs."prometheus-client" or (buildDepError "prometheus-client"))
+ (hsPkgs."http-client" or (buildDepError "http-client"))
+ (hsPkgs."text" or (buildDepError "text"))
+ (hsPkgs."wai" or (buildDepError "wai"))
+ (hsPkgs."warp" or (buildDepError "warp"))
+ (hsPkgs."hspec" or (buildDepError "hspec"))
+ (hsPkgs."unordered-containers" or (buildDepError "unordered-containers"))
+ (hsPkgs."transformers" or (buildDepError "transformers"))
+ ];
+ };
+ };
+ };
+ } // {
+ src = (pkgs.lib).mkDefault (pkgs.fetchgit {
+ url = "https://github.com/PrivateStorageio/servant-prometheus.git";
+ rev = "ec21c5ed50e6f6f8e52916ce71cd68fcd0166cad";
+ sha256 = "0lswszfs52x5rpf7lj46iv77zghcbr4d05dwssi63yzjll1ixizd";
+ });
+ }
\ No newline at end of file
diff --git a/src/PaymentServer/Main.hs b/src/PaymentServer/Main.hs
index f32512abaaeee4eaa4ceeba6623de581aed2bf16..e7d700cfee97dedebb44e8c1f14371d64781f8a3 100644
--- a/src/PaymentServer/Main.hs
+++ b/src/PaymentServer/Main.hs
@@ -72,6 +72,7 @@ import PaymentServer.Issuer
)
import PaymentServer.Server
( paymentServerApp
+ , makeMetricsMiddleware
)
import Options.Applicative
@@ -313,5 +314,6 @@ getApp config =
let
origins = corsOrigins config
app = paymentServerApp origins stripeConfig' issuer db
+ metricsMiddleware <- makeMetricsMiddleware
logger <- mkRequestLogger (def { outputFormat = Detailed True})
- return $ logger app
+ return . logger . metricsMiddleware $ app
diff --git a/src/PaymentServer/Metrics.hs b/src/PaymentServer/Metrics.hs
new file mode 100644
index 0000000000000000000000000000000000000000..92879f8d9a33b9fa6824f29509158b6c40f99f00
--- /dev/null
+++ b/src/PaymentServer/Metrics.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | A module which provides Prometheus metrics publishing. Individual
+-- metrics are defined elsewhere in the codebase but they'll all be published
+-- by this module.
+
+module PaymentServer.Metrics
+ ( MetricsAPI
+ , 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/src/PaymentServer/Processors/Stripe.hs b/src/PaymentServer/Processors/Stripe.hs
index 8506c6b697b2981627fee02edefceca617f2653b..45b5af38613cc4cafff878ba2a4ae79e2097ff2d 100644
--- a/src/PaymentServer/Processors/Stripe.hs
+++ b/src/PaymentServer/Processors/Stripe.hs
@@ -18,14 +18,10 @@ import Control.Exception
( try
, throwIO
)
-import Data.ByteString
- ( ByteString
- )
import Data.Text
( Text
, unpack
)
-import qualified Data.Map as Map
import Text.Read
( readMaybe
)
@@ -41,8 +37,6 @@ import Data.Aeson
import Servant
( Server
, Handler
- , err400
- , err500
, ServerError(ServerError, errHTTPCode, errBody, errHeaders, errReasonPhrase)
, throwError
)
@@ -51,22 +45,12 @@ import Servant.API
, JSON
, Post
, (:>)
- , (:<|>)((:<|>))
- )
-import Web.Stripe.Event
- ( Event(Event, eventId, eventType, eventData)
- , EventId(EventId)
- , EventType(ChargeSucceededEvent)
- , EventData(ChargeEvent)
)
import Web.Stripe.Types
( Charge(Charge, chargeMetaData)
, MetaData(MetaData)
, Currency
)
-import Web.Stripe.Error
- ( StripeError(StripeError)
- )
import Web.Stripe.Charge
( createCharge
, Amount(Amount)
@@ -79,6 +63,9 @@ import Web.Stripe
( stripe
, (-&-)
)
+
+import qualified Prometheus as P
+
import PaymentServer.Persistence
( Voucher
, VoucherDatabase(payForVoucher)
@@ -102,7 +89,8 @@ getVoucher (MetaData (("Voucher", value):xs)) = Just value
getVoucher (MetaData (x:xs)) = getVoucher (MetaData xs)
stripeServer :: VoucherDatabase d => StripeConfig -> d -> Server StripeAPI
-stripeServer stripeConfig d = charge d stripeConfig
+stripeServer stripeConfig d =
+ withSuccessFailureMetrics chargeAttempts chargeSuccesses . charge stripeConfig d
-- | Browser facing API that takes token, voucher and a few other information
-- and calls stripe charges API. If payment succeeds, then the voucher is stored
@@ -126,10 +114,40 @@ instance FromJSON Charges where
v .: "currency"
parseJSON _ = mzero
+
+metricName :: Text -> Text
+metricName name = mappend ("processors.stripe.charge_") name
+
+chargeAttempts :: P.Counter
+chargeAttempts
+ = P.unsafeRegister
+ $ P.counter
+ $ P.Info (metricName "attempts")
+ "The number of attempted charge requests received."
+
+
+chargeSuccesses :: P.Counter
+chargeSuccesses
+ = P.unsafeRegister
+ $ P.counter
+ $ P.Info (metricName "successes")
+ "The number of charge requests successfully processed."
+
+
+-- | run a Servant Handler, recording the attempt and whether or not it
+-- succeeds using the given counters.
+withSuccessFailureMetrics :: P.Counter -> P.Counter -> Handler a -> Handler a
+withSuccessFailureMetrics attemptCount successCount op = do
+ liftIO $ P.incCounter attemptCount
+ result <- op
+ liftIO $ P.incCounter successCount
+ return result
+
+
-- | call the stripe Charge API (with token, voucher in metadata, amount, currency etc
-- and if the Charge is okay, then set the voucher as "paid" in the database.
-charge :: VoucherDatabase d => d -> StripeConfig -> Charges -> Handler Acknowledgement
-charge d stripeConfig (Charges token voucher amount currency) = do
+charge :: VoucherDatabase d => StripeConfig -> d -> Charges -> Handler Acknowledgement
+charge stripeConfig d (Charges token voucher amount currency) = do
currency' <- getCurrency currency
result <- liftIO (try (payForVoucher d voucher (completeStripeCharge currency')))
case result of
diff --git a/src/PaymentServer/Server.hs b/src/PaymentServer/Server.hs
index a789f38a2e6baa1969c3643e82bc6f7ff0500020..8842dab1ee84f211897886dfbc181dcd12c09a4e 100644
--- a/src/PaymentServer/Server.hs
+++ b/src/PaymentServer/Server.hs
@@ -6,6 +6,7 @@
-- interactions.
module PaymentServer.Server
( paymentServerApp
+ , makeMetricsMiddleware
) where
import Network.Wai.Middleware.Cors
@@ -22,6 +23,11 @@ import Servant
, (:>)
, (:<|>)((:<|>))
)
+import Servant.Prometheus
+ ( MeasureQuantiles(WithQuantiles)
+ , monitorServant
+ , makeMeters
+ )
import Web.Stripe.Client
( StripeConfig
@@ -35,6 +41,10 @@ import PaymentServer.Redemption
( RedemptionAPI
, redemptionServer
)
+import PaymentServer.Metrics
+ ( MetricsAPI
+ , metricsServer
+ )
import PaymentServer.Issuer
( Issuer
)
@@ -46,12 +56,14 @@ import PaymentServer.Persistence
type PaymentServerAPI
= "v1" :> "stripe" :> StripeAPI
:<|> "v1" :> "redeem" :> RedemptionAPI
+ :<|> MetricsAPI
-- | Create a server which uses the given database.
paymentServer :: VoucherDatabase d => StripeConfig -> Issuer -> d -> Server PaymentServerAPI
paymentServer stripeConfig issuer database =
stripeServer stripeConfig database
:<|> redemptionServer issuer database
+ :<|> metricsServer
paymentServerAPI :: Proxy PaymentServerAPI
paymentServerAPI = Proxy
@@ -77,3 +89,10 @@ paymentServerApp corsOrigins stripeConfig issuer =
cors' = cors (const $ Just corsResourcePolicy)
in
cors' . app
+
+
+-- | Create middleware which captures metrics for the payment server app.
+makeMetricsMiddleware :: IO (Application -> Application)
+makeMetricsMiddleware = do
+ meters <- makeMeters paymentServerAPI WithQuantiles
+ return $ monitorServant paymentServerAPI meters
diff --git a/stack.yaml b/stack.yaml
index 0af84a35031953cbffd353476578ffa00b37b01f..3a4243691337cedb0356d9a76154c8aef27c46bd 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -41,6 +41,8 @@ extra-deps:
- "stripe-core-2.5.0"
- "stripe-haskell-2.5.0"
- "stripe-http-client-2.5.0"
+ - github: "PrivateStorageio/servant-prometheus"
+ commit: "ec21c5ed50e6f6f8e52916ce71cd68fcd0166cad"
# Override default flag values for local packages and extra-deps
# flags: {}
diff --git a/test/Metrics.hs b/test/Metrics.hs
new file mode 100644
index 0000000000000000000000000000000000000000..54eca21d6760afba4d65108af98511eab0d0561d
--- /dev/null
+++ b/test/Metrics.hs
@@ -0,0 +1,110 @@
+{-# 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
+ ( Info(Info)
+ , unsafeRegister
+ , counter
+ , incCounter
+ )
+
+import PaymentServer.Metrics
+ ( metricsAPI
+ , metricsServer
+ )
+import PaymentServer.Server
+ ( paymentServerApp
+ )
+import PaymentServer.Persistence
+ ( VoucherDatabaseState
+ )
+
+tests :: TestTree
+tests = testGroup "Metrics"
+ [ metricsTests
+ , serverTests
+ ]
+
+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"
+ ]
+
+-- | The metrics endpoint is hooked up to the overall application server.
+serverTests :: TestTree
+serverTests =
+ testCase "metrics endpoint" $
+ let
+ app :: Application
+ app = paymentServerApp mempty undefined undefined (undefined :: VoucherDatabaseState)
+ in
+ flip runSession app $ do
+ response <- readMetrics
+ assertStatus 200 response
diff --git a/test/Persistence.hs b/test/Persistence.hs
index bd280946a62cf0ed731f5b2297047f0a4ea07705..1f2cd6df0aaa22803656ddb3540f105f1166cc19 100644
--- a/test/Persistence.hs
+++ b/test/Persistence.hs
@@ -205,16 +205,24 @@ sqlite3DatabaseVoucherPaymentTests =
sqlite3Tests =
testGroup "SQLite3-specific voucher"
[ testCase "database is busy" $ do
- getDB <- makeDatabase
- db <- getDB
- case db of
+ aDatabase <- makeDatabase
+ normalConnection <- aDatabase
+ case normalConnection of
(SQLiteDB connect) -> do
- conn <- connect
- -- Tweak the timeout down so the test completes quickly
- Sqlite.execute_ conn "PRAGMA busy_timeout = 0"
- -- Acquire a write lock before letting the application code run so that
- -- the application code is denied the write lock.
- Sqlite.withExclusiveTransaction conn $ do
- result <- redeemVoucher db voucher fingerprint
+ -- Acquire a write lock before letting the application code run
+ -- so that the application code is denied the write lock.
+ normalConn <- connect
+ fastBusyConn <- fastBusyConnection connect
+ Sqlite.withExclusiveTransaction normalConn $ do
+ result <- redeemVoucher fastBusyConn voucher fingerprint
assertEqual "Redeeming voucher while database busy" result $ Left DatabaseUnavailable
]
+ where
+ fastBusyConnection
+ :: IO Sqlite.Connection
+ -> IO VoucherDatabaseState
+ fastBusyConnection connect = do
+ conn <- connect
+ -- Tweak the timeout down so the test completes quickly
+ Sqlite.execute_ conn "PRAGMA busy_timeout = 0"
+ return . SQLiteDB . return $ conn
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