DeadSpec.hs

{-# OPTIONS_GHC -Wno-type-defaults #-}

module Effectful.OpenTelemetry.Exporter.DeadSpec (spec) where

import Data.Maybe (isJust)
import Effectful
import Effectful.Concurrent (Concurrent, runConcurrent)
import Effectful.Environment (Environment, runEnvironment)
import Effectful.Hspec
import Effectful.Http2Client (HostName, PortNumber)
import Effectful.OpenTelemetry.Protocol (Compression (..), Encoding (..), Resource (..), Scope (..))
import Effectful.OpenTelemetry.Protocol.Attributes qualified as Attributes
import Effectful.OpenTelemetry.Protocol.Resource qualified as Resource
import Effectful.OpenTelemetry.Protocol.Scope qualified as Scope
import Effectful.OpenTelemetry.Tracing
import Effectful.OpenTelemetry.Tracing.Span.Kind qualified as Span.Kind
import Effectful.Retry (Retry, runRetry)
import Effectful.Timeout (Timeout, runTimeout)
import GHC.Stack (HasCallStack)
import Network.URI (URI)
import Network.URI.Static (uri)
import System.Timeout (timeout)
import Prelude

deadEndpoint :: URI
deadEndpoint = [uri|http://127.0.0.1:1/|]

deadHost :: HostName
deadHost = "127.0.0.1"

deadPort :: PortNumber
deadPort = 1

resource :: Resource
resource = Resource{attributes = Attributes.fromList [("service.name", "negative-path")]}

scope :: Scope
scope =
    Scope
        { name = "negative"
        , version = "0.0.0"
        , attributes = mempty
        }

-- | Fail rather than hang if a dead collector ever blocks the caller.
completes
    :: (HasCallStack, Hspec :> es, IOE :> es)
    => Eff '[Environment, Timeout, Retry, Concurrent, IOE] ()
    -> Eff es ()
completes act = do
    done <-
        liftIO . timeout 30_000_000 . runEff . runConcurrent . runRetry . runTimeout . runEnvironment $
            act
    done `shouldSatisfy` isJust

spec :: (HasCallStack, IOE :> es, Hspec :> es) => Eff es ()
spec = describe "connection refusals do not block 'inSpan'" do
    it "HTTP/JSON" . completes . runHttpTracing resource scope Json NoCompression deadEndpoint $ doomed
    it "HTTP/Protobuf" . completes . runHttpTracing resource scope Proto NoCompression deadEndpoint $
        doomed
    it "gRPC" . completes . runGrpcTracing resource scope deadHost deadPort NoCompression $ doomed
  where
    doomed :: (Tracing :> es) => Eff es ()
    doomed = inSpan "doomed" Span.Kind.Internal mempty $ pure ()