Metrics

src/HTTP.hs

@@ -0,0 +1,125 @@
+{-# LANGUAGE LambdaCase #-}
+
+module HTTP
+  ( post,
+    postWith,
+    get,
+    getWith,
+    Retry (..),
+    Trace (..),
+    HTTPMetric(..),
+    tracerMetrics
+  )
+where
+
+import Control.Exception.Annotated (catch, throw)
+import Control.Monad.Catch (Handler (Handler), SomeException)
+import Control.Retry (RetryStatus (RetryStatus, rsIterNumber), recovering, retryPolicyDefault)
+import Data.ByteString.Lazy (ByteString)
+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
+import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), Response (..), method)
+import Network.HTTP.Types (methodGet, methodHead, status408, status429, status500, status502, status503, status504)
+import Network.Wreq qualified as Wreq
+import Network.Wreq.Types qualified as Wreq
+import Tracer
+import System.Metrics.Distribution (Distribution)
+import System.Metrics.Counter (Counter)
+import qualified System.Metrics.Counter as Counter
+import qualified System.Metrics.Distribution as Distribution
+
+data Trace
+  = Retrying Int
+  | Failing SomeException
+  | Success POSIXTime POSIXTime
+  deriving (Show)
+
+data Retry = SafeTransient | Transient | NoRetry
+  deriving (Eq)
+
+retryRules :: Retry -> [RetryStatus -> Handler IO Bool]
+retryRules NoRetry = []
+retryRules rules =
+  [ const $ Handler $ \case
+      HttpExceptionRequest req ConnectionClosed -> pure $ safe req
+      HttpExceptionRequest req ConnectionTimeout -> pure $ safe req
+      HttpExceptionRequest req ResponseTimeout -> pure $ safe req
+      HttpExceptionRequest req (StatusCodeException res _) -> pure (safe req && retryStatus res)
+      _ -> pure False
+  ]
+  where
+    safe req = rules == SafeTransient || method req == methodGet || method req == methodHead
+    retryStatus res =
+      responseStatus res == status503
+        || responseStatus res == status408
+        || responseStatus res == status429
+        || responseStatus res == status500
+        || responseStatus res == status502
+        || responseStatus res == status504
+
+traceRetry :: Tracer Trace -> RetryStatus -> IO ()
+traceRetry tracer RetryStatus {rsIterNumber = n} | n > 0 = trace tracer $ Retrying n
+traceRetry _wtracer _rs = pure ()
+
+post :: (Wreq.Postable a) => Tracer Trace -> Retry -> String -> a -> IO (Wreq.Response ByteString)
+post tracer rules url postable = do
+  start <- getPOSIXTime
+  res <-
+    recovering
+      retryPolicyDefault
+      (retryRules rules)
+      (\rs -> traceRetry tracer rs >> Wreq.post url postable)
+      `catch` (\e -> trace tracer (Failing e) >> throw e)
+  end <- getPOSIXTime
+  trace tracer $ Success start end
+  pure res
+
+postWith :: (Wreq.Postable a) => Tracer Trace -> Retry -> Wreq.Options -> String -> a -> IO (Wreq.Response ByteString)
+postWith tracer rules opts url postable = do
+  start <- getPOSIXTime
+  res <-
+    recovering
+      retryPolicyDefault
+      (retryRules rules)
+      (\rs -> traceRetry tracer rs >> Wreq.postWith opts url postable)
+      `catch` (\e -> trace tracer (Failing e) >> throw e)
+  end <- getPOSIXTime
+  trace tracer $ Success start end
+  pure res
+
+get :: Tracer Trace -> Retry -> String -> IO (Response ByteString)
+get tracer rules url = do
+  start <- getPOSIXTime
+  res <-
+    recovering
+      retryPolicyDefault
+      (retryRules rules)
+      (\rs -> traceRetry tracer rs >> Wreq.get url)
+      `catch` (\e -> trace tracer (Failing e) >> throw e)
+  end <- getPOSIXTime
+  trace tracer $ Success start end
+  pure res
+
+getWith :: Tracer Trace -> Retry -> Wreq.Options -> String -> IO (Response ByteString)
+getWith tracer rules opts url = do
+  start <- getPOSIXTime
+  res <-
+    recovering
+      retryPolicyDefault
+      (retryRules rules)
+      (\rs -> traceRetry tracer rs >> Wreq.getWith opts url)
+      `catch` (\e -> trace tracer (Failing e) >> throw e)
+  end <- getPOSIXTime
+  trace tracer $ Success start end
+  pure res
+
+data HTTPMetric = HTTPMetric
+  { httpRequests :: Distribution,
+    httpRetries :: Counter,
+    httpFailures :: Counter
+  }
+
+tracerMetrics :: HTTPMetric -> Tracer HTTP.Trace
+tracerMetrics m = Tracer $ \case
+  HTTP.Retrying _ -> Counter.inc (httpRetries m)
+  HTTP.Failing _ -> Counter.inc (httpFailures m)
+  HTTP.Success start end -> Distribution.add (httpRequests m) (realToFrac end - realToFrac start)