Merge pull request #851 from input-output-hk/nhenin/safety-errors

Exposed Safety Analysis at Contract Creation and Input Application

async-components/async-components.cabal

@@ -61,6 +61,7 @@ library
     , exceptions ^>=0.10
     , general-allocate ^>=0.2
     , hs-opentelemetry-api ^>=0.0.3
+    , hs-opentelemetry-exporter-handle ^>=0.0.1.1
     , hs-opentelemetry-sdk ^>=0.0.3
     , mtl >=2.2 && <3
     , servant-client ^>=0.20

async-components/src/Control/Concurrent/Component/Run.hs

@@ -17,45 +17,94 @@ import Data.Maybe (isJust)
 import Observe.Event (EventBackend)
 import Observe.Event.Backend (hoistEventBackend, noopEventBackend)
 import Observe.Event.Render.OpenTelemetry (RenderSelectorOTel, tracerEventBackend)
+import OpenTelemetry.Exporter.Handle (defaultFormatter, makeHandleExporter)
+import OpenTelemetry.Processor.Batch (batchProcessor, batchTimeoutConfig)
 import OpenTelemetry.Trace
 import OpenTelemetry.Trace.Core (getSpanContext, wrapSpanContext)
+import OpenTelemetry.Trace.Sampler (alwaysOn)
 import System.Environment (lookupEnv)
+import System.IO (Handle)
 import UnliftIO (BufferMode (..), MonadUnliftIO, bracket, hSetBuffering, newMVar, stderr, stdout, withMVar, withRunInIO)
 
 newtype AppM r s a = AppM
   { unAppM :: ReaderT (EventBackend (AppM r s) r s, LogAction IO Message) IO a
   }
   deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadThrow, MonadCatch, MonadMask, MonadFail)
 
-runAppMTraced :: forall s a. InstrumentationLibrary -> RenderSelectorOTel s -> AppM Span s a -> IO a
-runAppMTraced library render app = bracket
-  initializeTracerProvider'
+data TracingConfig s
+  = UseEmptyTracerProvider
+      InstrumentationLibrary
+  | UseDefaultTracerProvider
+      InstrumentationLibrary
+      (RenderSelectorOTel s)
+  | UseHandleDebugTracerProvider
+      Handle
+      InstrumentationLibrary
+      (RenderSelectorOTel s)
+
+mkEventBackend :: TracingConfig s -> IO (EventBackend IO Span s, IO ())
+mkEventBackend = \case
+  UseEmptyTracerProvider library -> do
+    provider <- createTracerProvider [] emptyTracerProviderOptions
+    let tracer = makeTracer provider library tracerOptions
+    dummyContext <- inSpan' tracer "dummy" defaultSpanArguments getSpanContext
+    pure
+      ( noopEventBackend $ wrapSpanContext dummyContext
+      , shutdownTracerProvider provider
+      )
+  UseDefaultTracerProvider library render -> do
+    provider <- initializeTracerProvider
+    let tracer = makeTracer provider library tracerOptions
+    pure
+      ( tracerEventBackend tracer render
+      , shutdownTracerProvider provider
+      )
+  UseHandleDebugTracerProvider handle library render -> do
+    provider <- do
+      (_, tracerOptions') <- getTracerProviderInitializationOptions
+      stderrProc <- batchProcessor batchTimeoutConfig $ makeHandleExporter handle (pure . defaultFormatter)
+      let processors' = [stderrProc]
+      createTracerProvider processors' (tracerOptions'{tracerProviderOptionsSampler = alwaysOn})
+    let tracer = makeTracer provider library tracerOptions
+    pure
+      ( tracerEventBackend tracer render
+      , shutdownTracerProvider provider
+      )
+
+runAppMTraced
+  :: forall s a
+   . InstrumentationLibrary
+  -> RenderSelectorOTel s
+  -> AppM Span s a
+  -> IO a
+runAppMTraced library render app = do
+  otelExporterEndpointConfigured <- isJust <$> lookupEnv "OTEL_EXPORTER_OTLP_ENDPOINT"
+  stderrDebugExporterConfigured <- isJust <$> lookupEnv "OTEL_EXPORTER_STDERR_DEBUG"
+  logAction <- concurrentLogger
+  tracingConfig <- case (otelExporterEndpointConfigured, stderrDebugExporterConfigured) of
+    (True, True) -> do
+      usingLoggerT logAction $
+        logWarning
+          "Both OTEL_EXPORTER_OTLP_ENDPOINT and OTEL_EXPORTER_STDERR_DEBUG are set. Ignoring OTEL_EXPORTER_STDERR_DEBUG."
+      pure $ UseDefaultTracerProvider library render
+    (True, False) -> pure $ UseDefaultTracerProvider library render
+    (_, True) -> pure $ UseHandleDebugTracerProvider stderr library render
+    _ -> pure $ UseEmptyTracerProvider library
+  runAppMTraced' tracingConfig logAction app
+
+runAppMTraced'
+  :: forall s a
+   . TracingConfig s
+  -> LogAction IO Message
+  -> AppM Span s a
+  -> IO a
+runAppMTraced' tracingConfig logAction app = bracket
+  (mkEventBackend tracingConfig)
   snd
   \(backend, _) -> do
     hSetBuffering stderr LineBuffering
     hSetBuffering stdout LineBuffering
-    logAction <- concurrentLogger
     runAppM backend logAction app
-  where
-    initializeTracerProvider' :: IO (EventBackend IO Span s, IO ())
-    initializeTracerProvider' = do
-      endpointConfigured <- isJust <$> lookupEnv "OTEL_EXPORTER_OTLP_ENDPOINT"
-      if endpointConfigured
-        then do
-          provider <- initializeTracerProvider
-          let tracer = makeTracer provider library tracerOptions
-          pure
-            ( tracerEventBackend tracer render
-            , shutdownTracerProvider provider
-            )
-        else do
-          provider <- createTracerProvider [] emptyTracerProviderOptions
-          let tracer = makeTracer provider library tracerOptions
-          dummyContext <- inSpan' tracer "dummy" defaultSpanArguments getSpanContext
-          pure
-            ( noopEventBackend $ wrapSpanContext dummyContext
-            , shutdownTracerProvider provider
-            )
 
 runAppM :: EventBackend IO r s -> LogAction IO Message -> AppM r s a -> IO a
 runAppM eventBackend logAction (AppM action) = do

cabal.project

@@ -14,10 +14,10 @@ repository cardano-haskell-packages
 -- We duplicate the hackage index-state first for haskell.nix, even though cabal ignores it.
 -- This must always match the hackage index-state on the next line.
 -- See https://github.com/input-output-hk/haskell.nix/issues/1869#issuecomment-1449272480
-index-state: 2024-03-07T07:48:20Z
+index-state: 2024-04-02T10:49:14Z
 index-state:
-  , hackage.haskell.org 2024-03-07T07:48:20Z
-  , cardano-haskell-packages 2024-03-05T10:16:08Z
+  , hackage.haskell.org 2024-04-02T10:49:14Z
+  , cardano-haskell-packages 2024-04-02T10:49:14Z
 
 packages:
   async-components
@@ -43,6 +43,7 @@ packages:
   libs/aeson-record
   libs/aeson-via-serialise
   libs/base16-aeson
+  libs/cardano-debug
   libs/plutus-ledger-aeson
   libs/plutus-ledger-ada
   libs/plutus-ledger-slot
@@ -224,4 +225,4 @@ source-repository-package
            plutus-ledger-api
            plutus-tx
            plutus-tx-plugin 
-   --sha256: 0z4fv2pc0d2rpfivl146pwgq3y5kjxw6w9c8rqi154nab1l3614a
+   --sha256: 0z4fv2pc0d2rpfivl146pwgq3y5kjxw6w9c8rqi154nab1l3614a

cardano-integration/src/Test/Integration/Cardano/Local.hs

@@ -157,16 +157,22 @@ withLocalTestnet = withLocalTestnet' defaultOptions
 
 -- | A version of @@withLocalTestnet@@ that accepts custom options.
 withLocalTestnet'
-  :: (MonadUnliftIO m, MonadBaseControl IO m, MonadThrow m)
+  :: forall a m
+   . (MonadUnliftIO m, MonadBaseControl IO m, MonadThrow m)
   => LocalTestnetOptions
   -> (LocalTestnet -> m a)
   -> m a
 withLocalTestnet' options test = runResourceT do
   testnet <- startLocalTestnet options
+  let onHUnitFailure :: HUnitFailure -> m (Either HUnitFailure a)
+      onHUnitFailure ex = do
+        let LocalTestnet{workspace} = testnet
+        void $ unprotect $ W.releaseKey workspace
+        pure $ Left ex
   result <-
     lift $
       (Right <$> test testnet)
-        `catch` (\ex@HUnitFailure{} -> pure $ Left ex)
+        `catch` onHUnitFailure
         `catch` rethrowAsTestnetException testnet
   either throw pure result