126 lines
4.1 KiB
Haskell
126 lines
4.1 KiB
Haskell
{-# 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)
|