diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +# 0.2.0.0 + +- Breaking change: drop `Platform.TracingSpan` constructor. +- Add `Platform.emptyTracingSpan` export. +- Relax version bounds to encompas `tasty-1.4`. + # 0.1.0.4 - Relax version bounds to encompass `time-1.11`. diff --git a/nri-prelude.cabal b/nri-prelude.cabal --- a/nri-prelude.cabal +++ b/nri-prelude.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 78e78340e6d53b7211e9af9137b20a84a26342b67db26230ee0cd16118435aaa +-- hash: 1d5765ce153ffbf242d9ddffda10b587f0f07d26102b94f271297e3aad8d24ab name: nri-prelude -version: 0.1.0.4 +version: 0.2.0.0 synopsis: A Prelude inspired by the Elm programming language description: Please see the README at . category: Web @@ -87,7 +87,7 @@ , pretty-show >=1.9.5 && <1.11 , resourcet >=1.2.2 && <1.3 , safe-exceptions >=0.1.7.0 && <1.3 - , tasty >=1.2.3 && <1.4 + , tasty >=1.2.3 && <1.5 , tasty-test-reporter >=0.1.1.1 && <0.2 , terminal-size >=0.3.2.1 && <0.4 , text >=1.2.3.1 && <1.3 @@ -161,7 +161,7 @@ , pretty-show >=1.9.5 && <1.11 , resourcet >=1.2.2 && <1.3 , safe-exceptions >=0.1.7.0 && <1.3 - , tasty >=1.2.3 && <1.4 + , tasty >=1.2.3 && <1.5 , tasty-test-reporter >=0.1.1.1 && <0.2 , terminal-size >=0.3.2.1 && <0.4 , text >=1.2.3.1 && <1.3 diff --git a/src/Log.hs b/src/Log.hs --- a/src/Log.hs +++ b/src/Log.hs @@ -51,7 +51,7 @@ -- -- info "I added 1 and 1" [context "answer" 2] info :: Stack.HasCallStack => Text -> [Context] -> Task e () -info message contexts = Stack.withFrozenCallStack log message True contexts +info message contexts = Stack.withFrozenCallStack log message ReportAsSucceeded contexts -- | A log message when the user is annoyed, but not blocked. -- @@ -65,7 +65,7 @@ in Stack.withFrozenCallStack log message - False + ReportAsFailed (Context "triage" triage : contexts) -- | Like @userIsAnnoyed@, but when the user is userIsConfused. @@ -75,7 +75,7 @@ in Stack.withFrozenCallStack log message - False + ReportAsFailed (Context "triage" triage : contexts) -- | Like @userIsAnnoyed@, but when the user is in pain. @@ -85,7 +85,7 @@ in Stack.withFrozenCallStack log message - False + ReportAsFailed (Context "triage" triage : contexts) -- | Like @userIsAnnoyed@, but when the user is blocked. @@ -95,7 +95,7 @@ in Stack.withFrozenCallStack log message - False + ReportAsFailed (Context "triage" triage : contexts) -- | Mark a block of code as a logical unit by giving it a name. This name will @@ -247,10 +247,13 @@ UserConfused -> "The UI did something unexpected and it's unclear why." UserInPain -> "This is causing pain to users and workaround is not obvious." -log :: Stack.HasCallStack => Text -> Bool -> [Context] -> Task e () -log msg succeeded contexts = +-- ReportAsFailed marks the request as a failure in logging, but has no impact on the resulting Task. E.g. will not trigger a 500 error but will report an error to, e.g. BugSnag. +data ReportStatus = ReportAsFailed | ReportAsSucceeded + +log :: Stack.HasCallStack => Text -> ReportStatus -> [Context] -> Task e () +log msg reportStatus contexts = Internal.tracingSpan msg <| do Platform.setTracingSpanDetails (LogContexts contexts) - if succeeded - then Task.succeed () - else Platform.markTracingSpanFailed + case reportStatus of + ReportAsSucceeded -> Task.succeed () + ReportAsFailed -> Platform.markTracingSpanFailed diff --git a/src/Platform.hs b/src/Platform.hs --- a/src/Platform.hs +++ b/src/Platform.hs @@ -24,9 +24,18 @@ Internal.markTracingSpanFailedIO, -- * Interpreting tracingSpans for reporting to monitoring platforms - Internal.TracingSpan (..), - Internal.Succeeded (..), - Internal.TracingSpanDetails (..), + Internal.TracingSpan, + Internal.emptyTracingSpan, + Internal.name, + Internal.started, + Internal.finished, + Internal.frame, + Internal.details, + Internal.succeeded, + Internal.allocated, + Internal.children, + Internal.Succeeded (Succeeded, Failed, FailedWith), + Internal.TracingSpanDetails (toTracingSpanDetails, fromTracingSpanDetails), Internal.SomeTracingSpanDetails, Internal.Renderer (Renderer), Internal.renderTracingSpanDetails, diff --git a/src/Platform/Internal.hs b/src/Platform/Internal.hs --- a/src/Platform/Internal.hs +++ b/src/Platform/Internal.hs @@ -20,6 +20,7 @@ import qualified List import Maybe (Maybe (..)) import Result (Result (Err, Ok)) +import qualified System.Mem import Text (Text) import qualified Tuple import Prelude @@ -138,6 +139,12 @@ -- path to the tracingSpan closest to the failure from the root -- tracingSpan. succeeded :: Succeeded, + -- | The amount of bytes were allocated on the current thread while this + -- span was running. This is a proxy for the amount of work done. If + -- this number is low but the span took a long time to complete this + -- indicates the thread was blocked for some time, or that work was done + -- on other threads. + allocated :: Int, -- | Any subtracingSpans nested inside this tracingSpan. These are -- ordered in reverse chronological order, so most recent tracingSpan -- first, because it's cheaper to append new tracingSpans onto the left @@ -146,6 +153,23 @@ } deriving (Prelude.Show) +-- | A tracing span containing default empty values for all fields. Usually we +-- don't need this because TracingSpans get created for us when we evaluate +-- tasks. This can be useful when testing reporting code to see if it produces +-- the right outputs given a specific tracing span as input. +emptyTracingSpan :: TracingSpan +emptyTracingSpan = + TracingSpan + { name = "", + started = 0, + finished = 0, + frame = Nothing, + details = Nothing, + succeeded = Succeeded, + allocated = 0, + children = [] + } + -- | The @Succeeded@ type is used to indicate whether or not a particular -- @TracingSpan@ ran without encountering user-facing problems. data Succeeded @@ -372,6 +396,7 @@ tracingSpanRef <- Stack.withFrozenCallStack startTracingSpan clock name' |> andThen IORef.newIORef + allocationCounterStartVal <- System.Mem.getAllocationCounter pure LogHandler { requestId, @@ -384,7 +409,7 @@ updateIORef tracingSpanRef (\tracingSpan' -> tracingSpan' {succeeded = succeeded tracingSpan' ++ Failed}), - finishTracingSpan = finalizeTracingSpan clock tracingSpanRef >> andThen onFinish + finishTracingSpan = finalizeTracingSpan clock allocationCounterStartVal tracingSpanRef >> andThen onFinish } -- | Set the details for a tracingSpan created using the @tracingSpan@ @@ -467,13 +492,15 @@ |> Shortcut.map (Tuple.mapFirst Data.Text.pack), details = Nothing, succeeded = Succeeded, + allocated = 0, children = [] } -- | Some final properties to set on a tracingSpan before calling it done. -finalizeTracingSpan :: Clock -> IORef.IORef TracingSpan -> Maybe Exception.SomeException -> IO TracingSpan -finalizeTracingSpan clock tracingSpanRef maybeException = do +finalizeTracingSpan :: Clock -> Int -> IORef.IORef TracingSpan -> Maybe Exception.SomeException -> IO TracingSpan +finalizeTracingSpan clock allocationCounterStartVal tracingSpanRef maybeException = do finished <- monotonicTimeInMsec clock + allocationCounterEndVal <- System.Mem.getAllocationCounter tracingSpan' <- IORef.readIORef tracingSpanRef pure tracingSpan' @@ -490,7 +517,10 @@ Just exception -> FailedWith exception Nothing -> map Platform.Internal.succeeded (children tracingSpan') - |> Prelude.mconcat + |> Prelude.mconcat, + -- The allocation counter counts down as it allocations bytest. We + -- subtract in this order to get a positive number. + allocated = allocationCounterStartVal - allocationCounterEndVal } appendTracingSpanToParent :: IORef.IORef TracingSpan -> TracingSpan -> IO () diff --git a/tests/LogSpec.hs b/tests/LogSpec.hs --- a/tests/LogSpec.hs +++ b/tests/LogSpec.hs @@ -187,6 +187,13 @@ Prelude.pure ( do Internal.finishTracingSpan handler Nothing - IORef.readIORef recordedTracingSpans, + IORef.readIORef recordedTracingSpans + |> map (map (recurse (\span -> span {Internal.allocated = 0}))), handler ) + +recurse :: (Internal.TracingSpan -> Internal.TracingSpan) -> Internal.TracingSpan -> Internal.TracingSpan +recurse f span = + (f span) + { Internal.children = map (recurse f) (Internal.children span) + }