{-# 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)