Polling.hs

module Effectful.OpenTelemetry.Exporter.Grafana.Polling where

import Control.Monad (unless)
import Data.Either (isLeft)
import Data.Functor (void)
import Data.Maybe (fromMaybe)
import Effectful
import Effectful.Exception (bracket, catchSync)
import Effectful.HUnit (HUnit, assertFailure)
import Effectful.Hspec
import Effectful.HttpClient (httpLbs, parseRequest_, runHttpClientTls)
import Effectful.Retry
    ( Retry
    , capDelay
    , constantDelay
    , exponentialBackoff
    , limitRetriesByCumulativeDelay
    , retrying
    )
import Effectful.Timeout (Timeout, timeout)
import GHC.Stack (HasCallStack)
import Network.HTTP.Client (responseStatus)
import Network.HTTP.Types.Status (statusIsSuccessful)
import Network.Simple.TCP (closeSock, connectSock)
import Network.URI (URI (..), URIAuth (..))
import Prelude

pollRetrying
    :: forall es a
     . (Retry :> es, Timeout :> es)
    => Eff es (Either String a)
    -> Eff es (Either String a)
pollRetrying =
    retrying
        ( limitRetriesByCumulativeDelay 30_000_000
            . capDelay 2_000_000
            $ exponentialBackoff 250_000
        )
        (const $ pure . isLeft)
        . const
        . attempt
  where
    attempt :: Eff es (Either String a) -> Eff es (Either String a)
    attempt = fmap (fromMaybe $ Left "attempt timed out") . timeout 5_000_000

pollOrFail
    :: (HasCallStack, Retry :> es, HUnit :> es, Timeout :> es)
    => Eff es (Either String a)
    -> (a -> Eff es r)
    -> Eff es r
pollOrFail fetch onFound =
    pollRetrying fetch >>= \case
        Left reason -> assertFailure reason
        Right a -> onFound a

-- | Skip the surrounded example via 'pendingWith' when nothing is accepting
-- connections, for a collector with no @\/ready@ endpoint of its own.
withListening
    :: (IOE :> es, Hspec :> es)
    => String
    -> URI
    -> Eff es ()
    -> Eff es ()
withListening backend backendUri body = do
    listening <- isListening backendUri
    if listening
        then body
        else pendingWith (backend <> " is not listening at " <> show backendUri)

-- | Like 'withListening', but as a statement rather than a wrapper
checkListening :: (IOE :> es, Hspec :> es) => String -> URI -> Eff es ()
checkListening backend backendUri = do
    listening <- isListening backendUri
    unless listening $ pendingWith (backend <> " is not listening at " <> show backendUri)

-- | 'checkListening', plus waiting for the backend to report readiness.
checkReady :: (IOE :> es, Hspec :> es, Retry :> es) => String -> URI -> Eff es ()
checkReady backend backendUri = do
    checkListening backend backendUri
    waitReady backendUri

isListening :: (IOE :> es) => URI -> Eff es Bool
isListening baseUri = case baseUri of
    URI{uriAuthority = Just URIAuth{uriRegName, ..}}
        | ':' : port <- uriPort -> do
            (bracket (connectSock uriRegName port) (closeSock . fst) . const $ pure True)
                `catchSync` const (pure False)
    _ -> pure False

-- | Query the backend readiness via the standard Grafana-stack @\/ready@ endpoint.
waitReady :: (IOE :> es, Retry :> es) => URI -> Eff es ()
waitReady baseUri = do
    let url = show baseUri{uriPath = "/ready"}
    void
        . retrying
            (limitRetriesByCumulativeDelay 30_000_000 $ constantDelay 1_000_000)
            (const $ pure . not . statusIsSuccessful)
        . const
        . runHttpClientTls
        $ responseStatus <$> httpLbs (parseRequest_ url)