diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.1.0.0 + +- Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +BSD 3-Clause License + +Copyright (c) 2021, NoRedInk +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,12 @@ +# nri-observability + +A library for reporting observability data collected in [nri-prelude][]-backed Haskell applications to various backends. + +This library exposes two categories of modules: + +- `Reporter` modules for sending data to various backends. +- `Log` modules defining `Details` types for common kinds of tracing spans. + +Both can be mixed and matched with `Reporter` and `Details` types defined elsewhere. + +[nri-prelude]: https://github.com/NoRedInk/haskell-libraries/tree/trunk/nri-prelude diff --git a/nri-observability.cabal b/nri-observability.cabal new file mode 100644 --- /dev/null +++ b/nri-observability.cabal @@ -0,0 +1,114 @@ +cabal-version: 1.18 + +-- This file has been generated from package.yaml by hpack version 0.34.2. +-- +-- see: https://github.com/sol/hpack + +name: nri-observability +version: 0.1.0.0 +synopsis: Report log spans collected by nri-prelude. +description: Please see the README at . +category: Web +homepage: https://github.com/NoRedInk/haskell-libraries#readme +bug-reports: https://github.com/NoRedInk/haskell-libraries/issues +author: NoRedInk +maintainer: haskell-open-source@noredink.com +copyright: 2021 NoRedInk Corp. +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-doc-files: + README.md + LICENSE + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/NoRedInk/haskell-libraries + subdir: observability + +library + exposed-modules: + Log.HttpRequest + Log.RedisCommands + Log.SqlQuery + Reporter.Bugsnag + Reporter.Dev + Reporter.File + other-modules: + Platform.ReporterHelpers + Platform.Timer + Reporter.Bugsnag.Internal + Reporter.Dev.Internal + Reporter.File.Internal + Paths_nri_observability + hs-source-dirs: + src + default-extensions: DataKinds DeriveGeneric FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures ScopedTypeVariables Strict TypeOperators + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns -fplugin=NriPrelude.Plugin + build-depends: + aeson >=1.4.6.0 && <1.6 + , aeson-pretty >=0.8.0 && <0.9 + , async >=2.2.2 && <2.3 + , base >=4.12.0.0 && <4.15 + , bugsnag-hs >=0.1.0.0 && <0.3 + , bytestring >=0.10.8.2 && <0.12 + , directory >=1.3.3.0 && <1.4 + , hostname >=1.0 && <1.1 + , http-client >=0.6.0 && <0.8 + , http-client-tls >=0.3.0 && <0.4 + , nri-env-parser >=0.1.0.0 && <0.2 + , nri-prelude >=0.1.0.0 && <0.6 + , random >=1.1 && <1.3 + , safe-exceptions >=0.1.7.0 && <1.3 + , stm >=2.4 && <2.6 + , text >=1.2.3.1 && <1.3 + , time >=1.8.0.2 && <1.12 + , unordered-containers >=0.2.0.0 && <0.3 + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Spec.Platform.Timer + Spec.Reporter.Bugsnag + Spec.Reporter.Dev + Spec.Reporter.File + Log.HttpRequest + Log.RedisCommands + Log.SqlQuery + Platform.ReporterHelpers + Platform.Timer + Reporter.Bugsnag + Reporter.Bugsnag.Internal + Reporter.Dev + Reporter.Dev.Internal + Reporter.File + Reporter.File.Internal + Paths_nri_observability + hs-source-dirs: + tests + src + default-extensions: DataKinds DeriveGeneric FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures ScopedTypeVariables Strict TypeOperators ExtendedDefaultRules + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns -fplugin=NriPrelude.Plugin -threaded -rtsopts "-with-rtsopts=-N -T" -fno-warn-type-defaults + build-depends: + aeson >=1.4.6.0 && <1.6 + , aeson-pretty >=0.8.0 && <0.9 + , async >=2.2.2 && <2.3 + , base >=4.12.0.0 && <4.15 + , bugsnag-hs >=0.1.0.0 && <0.3 + , bytestring >=0.10.8.2 && <0.12 + , directory >=1.3.3.0 && <1.4 + , hostname >=1.0 && <1.1 + , http-client >=0.6.0 && <0.8 + , http-client-tls >=0.3.0 && <0.4 + , nri-env-parser >=0.1.0.0 && <0.2 + , nri-prelude >=0.1.0.0 && <0.6 + , random >=1.1 && <1.3 + , safe-exceptions >=0.1.7.0 && <1.3 + , stm >=2.4 && <2.6 + , text >=1.2.3.1 && <1.3 + , time >=1.8.0.2 && <1.12 + , unordered-containers >=0.2.0.0 && <0.3 + default-language: Haskell2010 diff --git a/src/Log/HttpRequest.hs b/src/Log/HttpRequest.hs new file mode 100644 --- /dev/null +++ b/src/Log/HttpRequest.hs @@ -0,0 +1,77 @@ +-- | A module for creating great logs in code that send or receive HTTP +-- requests. +module Log.HttpRequest + ( Details, + Incoming (Incoming), + Outgoing (Outgoing), + emptyDetails, + method, + host, + path, + queryString, + headers, + httpVersion, + endpoint, + status, + ) +where + +import qualified Data.Aeson as Aeson +import qualified Dict + +-- | A type describing an http request. +-- +-- > emptyDetails +-- > { method = Just "GET" +-- > , host = Just "https://noredink.com" +-- > } +data Details = Details + { -- | The method of the http request. + method :: Maybe Text, + -- | The host the http request is made to. + host :: Maybe Text, + -- | The path portion of the request URI. + path :: Maybe Text, + -- | The query string portion of the request URI. + queryString :: Maybe Text, + -- | The headers on the request. Do not pass headers with sensitive + -- information in there, filter them out first! + headers :: Dict.Dict Text Text, + -- | The version of the http protocol used. + httpVersion :: Maybe Text, + -- | The endpoint called. This is like the path, but with the dynamic parts + -- of the path replaced with arguments. + -- + -- For example: + -- > path /teeth/upperleft/12 + -- > endpoint /teeth/:quadrant/:number + endpoint :: Maybe Text, + -- | The response status of the request. + status :: Maybe Int + } + deriving (Generic) + +-- | An empty details value to be modified by you. +emptyDetails :: Details +emptyDetails = Details Nothing Nothing Nothing Nothing Dict.empty Nothing Nothing Nothing + +instance Aeson.ToJSON Details where + toJSON = Aeson.genericToJSON infoEncodingOptions + toEncoding = Aeson.genericToEncoding infoEncodingOptions + +infoEncodingOptions :: Aeson.Options +infoEncodingOptions = + Aeson.defaultOptions + { Aeson.fieldLabelModifier = Aeson.camelTo2 ' ', + Aeson.omitNothingFields = True + } + +newtype Incoming = Incoming Details + deriving (Aeson.ToJSON) + +instance Platform.TracingSpanDetails Incoming + +newtype Outgoing = Outgoing Details + deriving (Aeson.ToJSON) + +instance Platform.TracingSpanDetails Outgoing diff --git a/src/Log/RedisCommands.hs b/src/Log/RedisCommands.hs new file mode 100644 --- /dev/null +++ b/src/Log/RedisCommands.hs @@ -0,0 +1,50 @@ +-- | A module for creating great logs in code that sends commands to Redis. +module Log.RedisCommands + ( Details, + emptyDetails, + commands, + host, + port, + ) +where + +import qualified Data.Aeson as Aeson + +-- | A type describing redis commands. +-- +-- > emptyDetails +-- > { commands = [ "GET weather" ] +-- > , host = Just "my-redis-host" +-- > } +data Details = Details + { -- | The commands that were sent to redis. Because Redis support for + -- pipelining and transactions it's possible for one logical operation from + -- the application perspective to contain multiple commands. + -- + -- These commands are expected not to contain any sensitive information. + -- Make sure sensitive values are mocked out, for example by replacing them + -- with *****. + commands :: List Text, + -- | The host the redis commands are sent too. + host :: Maybe Text, + -- | The port redis is running on. + port :: Maybe Int + } + deriving (Generic) + +-- | An empty details value to be modified by you. +emptyDetails :: Details +emptyDetails = Details [] Nothing Nothing + +instance Aeson.ToJSON Details where + toJSON = Aeson.genericToJSON infoEncodingOptions + toEncoding = Aeson.genericToEncoding infoEncodingOptions + +infoEncodingOptions :: Aeson.Options +infoEncodingOptions = + Aeson.defaultOptions + { Aeson.fieldLabelModifier = Aeson.camelTo2 ' ', + Aeson.omitNothingFields = True + } + +instance Platform.TracingSpanDetails Details diff --git a/src/Log/SqlQuery.hs b/src/Log/SqlQuery.hs new file mode 100644 --- /dev/null +++ b/src/Log/SqlQuery.hs @@ -0,0 +1,70 @@ +-- | A module for creating great logs in code that makes SQL queries. +module Log.SqlQuery + ( Details, + emptyDetails, + query, + queryTemplate, + sqlOperation, + queriedRelation, + databaseType, + host, + port, + database, + rowsReturned, + mysql, + postgresql, + ) +where + +import qualified Data.Aeson as Aeson + +-- | A type describing an SQL query. +-- +-- > emptyDetails +-- > { query = Just (Log.mkSecret "SELECT cuddles FROM puppies") +-- > , database = Just postgresql +-- > } +data Details = Details + { -- | The full query we're executing. + query :: Maybe (Log.Secret Text), + -- | The query we're executing with values mocked out. + queryTemplate :: Maybe Text, + -- | The SQL operation we're performing (SELECT / INSERT / DELETE / ...). + sqlOperation :: Maybe Text, + -- | The primary relation of the query. + queriedRelation :: Maybe Text, + -- | The type of database. + databaseType :: Maybe Text, + -- | Database host the connection is made to. + host :: Maybe Text, + -- | Port the database is running on. + port :: Maybe Int, + -- | The name of the database that is being queried. + database :: Maybe Text, + -- | The amount of rows this query returned. + rowsReturned :: Maybe Int + } + deriving (Generic) + +-- | An empty details value to be modified by you. +emptyDetails :: Details +emptyDetails = Details Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +instance Aeson.ToJSON Details where + toJSON = Aeson.genericToJSON options + toEncoding = Aeson.genericToEncoding options + +options :: Aeson.Options +options = + Aeson.defaultOptions + { Aeson.fieldLabelModifier = Aeson.camelTo2 ' ', + Aeson.omitNothingFields = True + } + +instance Platform.TracingSpanDetails Details + +mysql :: Text +mysql = "MySQL" + +postgresql :: Text +postgresql = "PostgreSQL" diff --git a/src/Platform/ReporterHelpers.hs b/src/Platform/ReporterHelpers.hs new file mode 100644 --- /dev/null +++ b/src/Platform/ReporterHelpers.hs @@ -0,0 +1,61 @@ +module Platform.ReporterHelpers (toHashMap, srcString) where + +import qualified Data.Aeson as Aeson +import qualified Data.Foldable as Foldable +import qualified Data.HashMap.Strict as HashMap +import qualified GHC.Stack as Stack +import qualified List +import qualified Text +import qualified Prelude + +-- | Our span details are arbitrary JSON structures, but some of our reporters +-- require metadata as a flast list of key,value pairs. +-- +-- Given a type that has the following JSON representation: +-- +-- { +-- "treasure": { +-- "coords: { "x": 12, "y" 14 }, +-- "worth": "Tons!" +-- } +-- } +-- +-- This function will create a flat list of key,value pairs like this: +-- +-- HashMap.fromList +-- [ ("treasure.coords.x", "12" ) +-- , ("treasure.coords.y", "14" ) +-- , ("treasure.worth" , "Tons!") +-- ] +toHashMap :: Aeson.ToJSON a => a -> HashMap.HashMap Text Text +toHashMap x = + case Aeson.toJSON x of + Aeson.Object dict -> + HashMap.foldlWithKey' + (\acc key value -> acc ++ jsonAsText key value) + HashMap.empty + dict + val -> jsonAsText "value" val + +jsonAsText :: Text -> Aeson.Value -> HashMap.HashMap Text Text +jsonAsText key val = + case val of + Aeson.Object dict -> + HashMap.foldlWithKey' + (\acc key2 value -> acc ++ jsonAsText (key ++ "." ++ key2) value) + HashMap.empty + dict + Aeson.Array vals -> + Foldable.toList vals + |> List.indexedMap (\i elem -> jsonAsText (key ++ "." ++ Text.fromInt i) elem) + |> HashMap.unions + Aeson.String str -> HashMap.singleton key str + Aeson.Number n -> HashMap.singleton key (Text.fromList (Prelude.show n)) + Aeson.Bool bool -> HashMap.singleton key (Text.fromList (Prelude.show bool)) + Aeson.Null -> HashMap.empty + +srcString :: Stack.SrcLoc -> Text +srcString frame = + Text.fromList (Stack.srcLocFile frame) + ++ ":" + ++ Text.fromInt (Prelude.fromIntegral (Stack.srcLocStartLine frame)) diff --git a/src/Platform/Timer.hs b/src/Platform/Timer.hs new file mode 100644 --- /dev/null +++ b/src/Platform/Timer.hs @@ -0,0 +1,124 @@ +{-# OPTIONS_GHC -fno-cse #-} + +-- | Helper functions for converting the timestamp format used in our `Span` +-- data to the time formats used by the various platforms we report to. +module Platform.Timer + ( Timer (Timer), + mkTimer, + toUTC, + toLocal, + toPosix, + toPosixMicroseconds, + toISO8601, + difference, + durationInUs, + ) +where + +import qualified Control.Concurrent.MVar as MVar +import qualified Data.Time.Clock as Clock +import qualified Data.Time.Clock.POSIX as Clock.POSIX +import qualified Data.Time.Format as Format +import qualified Data.Time.LocalTime as LocalTime +import qualified Data.Word as Word +import qualified GHC.Clock +import qualified Platform +import qualified System.IO.Unsafe +import qualified Prelude + +-- | Our spans' timestamps are produced by the `GHC.Clock` module and consist of +-- the amount of time passed since some arbitrary (but constant) moment in the +-- past. This is the faster and more accurate way to measure precisely what the +-- running time of spans is. This type helpers convert these times into regular +-- dates. +data Timer = Timer + { -- | The POSIX time in microseconds that corresponds with t=0 according + -- to `GHC.Clock`. We can use this to calculate other `GHC.Clock` + -- values. + tzero :: Word.Word64, + -- | The timezone of the machine this code is running on. Useful for + -- printing local times in development reporters. + timezone :: LocalTime.TimeZone + } + +-- | Create a timer, then cache it. When asked again return the previously +-- created timer. +-- +-- Passing separate timers to multiple reporters could result in those reporters +-- disagreeing very subtly on the exact time when events happen. Having a single +-- timer prevents this from happening. +mkTimer :: Prelude.IO Timer +mkTimer = + MVar.modifyMVar + timerVar + ( \maybeTimer -> + case maybeTimer of + Just timer -> Prelude.pure (Just timer, timer) + Nothing -> do + -- 'Sync our clocks', to find our how monotonic time and actual time relate. + nowTime <- Clock.POSIX.getPOSIXTime + nowClock <- GHC.Clock.getMonotonicTimeNSec + timezone <- LocalTime.getCurrentTimeZone + let tzero = Prelude.floor (1e6 * nowTime) - (nowClock `Prelude.div` 1000) + let timer = Timer {tzero, timezone} + Prelude.pure (Just timer, timer) + ) + +{-# NOINLINE timerVar #-} +timerVar :: MVar.MVar (Maybe Timer) +timerVar = System.IO.Unsafe.unsafePerformIO (MVar.newMVar Nothing) + +toUTC :: Timer -> Platform.MonotonicTime -> Clock.UTCTime +toUTC timer clock = + toPosix timer clock + |> Clock.POSIX.posixSecondsToUTCTime + +toLocal :: Timer -> Platform.MonotonicTime -> LocalTime.LocalTime +toLocal timer clock = + toUTC timer clock + |> LocalTime.utcToLocalTime (timezone timer) + +toPosixMicroseconds :: Timer -> Platform.MonotonicTime -> Word.Word64 +toPosixMicroseconds timer clock = tzero timer + Platform.inMicroseconds clock + +toPosix :: Timer -> Platform.MonotonicTime -> Clock.POSIX.POSIXTime +toPosix timer clock = + toPosixMicroseconds timer clock + |> Prelude.fromIntegral + |> (*) 1e-6 + +toISO8601 :: Timer -> Platform.MonotonicTime -> Text +toISO8601 timer clock = + toUTC timer clock + |> Format.formatTime Format.defaultTimeLocale "%FT%T%QZ" + |> Text.fromList + +-- | We have to be careful when calculating the difference between two times. +-- Because they are unsigned (don't allow negative numbers), subtracting times +-- in the wrong order is going to result in very large numbers: +-- +-- ghci> import GHC.Word +-- ghci> 5 - 2 :: Word64 +-- 3 +-- ghci> 2 - 5 :: Word64 +-- 18446744073709551613 +-- +-- The span data we get from Platform should ensure end times always come +-- before start times. If they're not though one of these extremely long span +-- durations can have a major effect on request duration statistics. +-- +-- This function performs some defensive programming to prevent flukes from +-- doing major damage. +difference :: Platform.MonotonicTime -> Platform.MonotonicTime -> Platform.MonotonicTime +difference start end = + if end > start + then end - start + else 0 + +-- | Get the time covered by a duration in microseconds. +durationInUs :: Platform.TracingSpan -> Word.Word64 +durationInUs span = + difference + (Platform.started span) + (Platform.finished span) + |> Platform.inMicroseconds diff --git a/src/Reporter/Bugsnag.hs b/src/Reporter/Bugsnag.hs new file mode 100644 --- /dev/null +++ b/src/Reporter/Bugsnag.hs @@ -0,0 +1,18 @@ +-- | This reporter sends tracing information for failing requests to Bugsnag, +-- a platform for monitoring applications. Learn more about Bugsnag on their +-- website: +-- +-- +module Reporter.Bugsnag + ( Internal.report, + Internal.Handler, + Internal.handler, + Internal.Settings, + Internal.decoder, + Internal.apiKey, + Internal.appName, + Internal.appEnvironment, + ) +where + +import qualified Reporter.Bugsnag.Internal as Internal diff --git a/src/Reporter/Bugsnag/Internal.hs b/src/Reporter/Bugsnag/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Reporter/Bugsnag/Internal.hs @@ -0,0 +1,567 @@ +-- | Reporting to Bugsnag. +-- +-- This reporter reports failures to Bugsnag. It does nothing for requests that +-- completed without error. +module Reporter.Bugsnag.Internal where + +import qualified Control.Exception.Safe as Exception +import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List +import qualified Data.Proxy as Proxy +import qualified Data.Text.IO +import qualified Data.Typeable as Typeable +import qualified Dict +import qualified Environment +import qualified GHC.Stack as Stack +import qualified List +import qualified Log.HttpRequest as HttpRequest +import qualified Log.RedisCommands as RedisCommands +import qualified Log.SqlQuery as SqlQuery +import qualified Network.Bugsnag as Bugsnag +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client.TLS as HTTP.TLS +import qualified Network.HostName +import qualified Platform +import qualified Platform.ReporterHelpers as Helpers +import qualified Platform.Timer as Timer +import qualified Prelude + +-- This function takes the root span of a completed request and reports it to +-- Bugsnag, if there has been a failure. A request that completed succesfully +-- is not reported. +-- +-- If we squint a bit, the rough shape of data that Bugsnag expects of us is: +-- +-- event {attributes} [breadcrumbs] +-- +-- Meaning: we can use various attributes to describe an event and in addition +-- pass a list of "breadcrumbs", other events that took place before the one the +-- report we're making is about. +-- +-- The root span we pass in is a tree structure. It can have child spans, which +-- in turn can have child spans, etc. Each span is marked with whether it +-- succeeded or failed. If one of the children of a span failed, the span itself +-- failed too. +-- +-- To turn this tree structure into the data that Bugsnag expects we're going to +-- take the following approach. First we're going to find the 'root cause span'. +-- This is the most recently started span that failed. The data in this span and +-- it's parents is going to make up the main event to Bugsnag. All other spans +-- that completed before the root cause span started we'll turn into +-- breadcrumbs. For some span tree it might look like this: +-- +-- ^ failed span, a = 1 -> event { a = 1, +-- t succeeded span +-- i failed span, b = 2 -> b = 2, +-- m failed span, c = 3 -> c = 3 } +-- e succeeded span -> [ breadcrumb1 +-- ^ succeeded span -> , breadcrumb2 ] +-- +-- A span that happened _after_ the root cause event completed we're not +-- reporting. +-- +-- Example usage: +-- +-- > settings <- Bugsnag.decode +-- > handler <- Bugsnag.handler settings +-- > Bugsnag.report handler "request-id" span +report :: Handler -> Text -> Platform.TracingSpan -> Prelude.IO () +report Handler {http, timer, defaultEvent, apiKey'} requestId span = + if failed span + then send http apiKey' (toEvent requestId timer defaultEvent span) + else Prelude.pure () + +-- | Contextual information this reporter needs to do its work. You can create +-- one using 'handler'. +data Handler = Handler + { http :: HTTP.Manager, + timer :: Timer.Timer, + defaultEvent :: Bugsnag.Event, + apiKey' :: Log.Secret Bugsnag.ApiKey + } + +-- | Create a 'Handler' for a specified set of 'Settings'. Do this once when +-- your application starts and reuse the 'Handler' you get. +handler :: Settings -> Prelude.IO Handler +handler settings = do + http <- HTTP.TLS.getGlobalManager + defaultEvent <- mkDefaultEvent settings + timer <- Timer.mkTimer + Prelude.pure + Handler + { http, + timer, + defaultEvent, + apiKey' = apiKey settings + } + +send :: HTTP.Manager -> Log.Secret Bugsnag.ApiKey -> Bugsnag.Event -> Prelude.IO () +send manager key event = do + result <- Bugsnag.sendEvents manager (Log.unSecret key) [event] + case result of + Prelude.Left err -> Exception.throwIO err + Prelude.Right _ -> Prelude.pure () + +toEvent :: Text -> Timer.Timer -> Bugsnag.Event -> Platform.TracingSpan -> Bugsnag.Event +toEvent requestId timer defaultEvent span = + rootCause [] emptyCrumbs timer rootEvent span + where + rootEvent = + defaultEvent + { Bugsnag.event_metaData = + mergeMetaData + (Bugsnag.event_metaData defaultEvent) + (Just rootMetaData) + } + rootMetaData = + [ "response time in ms" + .= ( Timer.durationInUs span + |> Prelude.fromIntegral + |> (*) 1e-3 :: + Float + ), + "megabytes allocated" + .= ( Prelude.fromIntegral (Platform.allocated span) + / (1024 * 1024) :: + Float + ), + "request id" .= requestId + ] + |> Aeson.object + |> HashMap.singleton "request" + +-- | Find the most recently started span that failed. This span is closest to +-- the failure and we'll use the data in it and its parents to build the +-- exception we send to Bugsnag. We'll send information about spans that ran +-- before the root cause span started as breadcrumbs. +rootCause :: + [Bugsnag.StackFrame] -> + Crumbs -> + Timer.Timer -> + Bugsnag.Event -> + Platform.TracingSpan -> + Bugsnag.Event +rootCause frames breadcrumbs timer event span = + let newFrames = + case Platform.frame span of + Nothing -> frames + Just (name, src) -> toStackFrame name src : frames + newEvent = decorateEventWithTracingSpanData span event + childTracingSpans = Platform.children span + in -- We're not interested in child spans that happened _after_ the root + -- cause took place. These are not breadcrumbs (leading up to the error) + -- nor can they have caused the error itself because they happened after. + -- Since child spans are ordered most-recent first we can keep dropping + -- child spans until we hit the one where the most recent error happened. + case Data.List.dropWhile (not << failed) childTracingSpans of + child : preErrorTracingSpans -> + rootCause + newFrames + ( breadcrumbs + |> followedBy (addCrumb (startBreadcrumb timer span)) + |> followedBy (addCrumbs timer preErrorTracingSpans) + ) + timer + newEvent + child + [] -> + newEvent + { Bugsnag.event_exceptions = [toException newFrames span], + Bugsnag.event_breadcrumbs = + -- This is the innermost span that failed, so all it's children + -- succeeded. We're going to assume that the error happened + -- after the last of these child spans, making all child spans + -- breadcrumbs. + breadcrumbs + |> followedBy (addCrumbs timer childTracingSpans) + |> crumbsAsList + |> List.reverse + |> Just, + Bugsnag.event_unhandled = case Platform.succeeded span of + Platform.Succeeded -> Nothing + -- `Failed` indicates a span was marked as failed by the application + -- author. Something went wrong, but we wrote logic to handle it. + Platform.Failed -> Just False + -- `FailedWith` indicates a Haskell exception was thrown. We don't throw + -- in our applications, so this indicates a library is doing something + -- we didn't expect. + Platform.FailedWith _ -> Just True + } + +-- | This function is passed a list of spans and outputs a type representing a +-- flat list of breadcrumbs. +-- +-- Each span can contain child spans requiring us to recurse. +-- +-- Our Bugsnag library asks for a value of type `[Bugsnag.Breadcrumb]`, so a +-- list. It's very performant to add single items to the front of a list, but +-- appending two lists is costly. So we want to avoid appending in our +-- breadcrumb collection, because if the span tree gets large we'd be doing a +-- lot of it. +-- +-- To help us avoid doing appends we create a helper type `Crumbs a`. The only +-- helper function it exposes for adding a breadcrumb is one that cons that +-- breadcrumb to the front of the list, ensuring no appends take place. +addCrumbs :: Timer.Timer -> [Platform.TracingSpan] -> Crumbs +addCrumbs timer spans = + case spans of + [] -> emptyCrumbs + span : after -> + addCrumbs timer after + |> followedBy (addCrumbsForTracingSpan timer span) + +addCrumbsForTracingSpan :: Timer.Timer -> Platform.TracingSpan -> Crumbs +addCrumbsForTracingSpan timer span = + case Platform.children span of + [] -> + addCrumb (doBreadcrumb timer span) + children -> + addCrumb (startBreadcrumb timer span) + |> followedBy (addCrumbs timer children) + |> followedBy (addCrumb (endBreadcrumb timer span)) + +-- | A type representing a list of breadcrumbs. We're not using just a list +-- directly, because then in constructing the full list of breadcrumbs we'd have +-- to do list appends often, which aren't very efficient. Instead we store a +-- function that describes creation of the eventual list of breadcrumbs from an +-- initially empty list. +newtype Crumbs = Crumbs ([Bugsnag.Breadcrumb] -> [Bugsnag.Breadcrumb]) + +emptyCrumbs :: Crumbs +emptyCrumbs = Crumbs identity + +-- | Combine breadcrumbs, placing one set after the other. +-- +-- earlyCrumbs +-- |> followedBy laterCrumbs +followedBy :: Crumbs -> Crumbs -> Crumbs +followedBy (Crumbs f) (Crumbs g) = Crumbs (f << g) + +crumbsAsList :: Crumbs -> [Bugsnag.Breadcrumb] +crumbsAsList (Crumbs f) = f [] + +addCrumb :: Bugsnag.Breadcrumb -> Crumbs +addCrumb crumb = Crumbs (crumb :) + +endBreadcrumb :: Timer.Timer -> Platform.TracingSpan -> Bugsnag.Breadcrumb +endBreadcrumb timer span = + Bugsnag.defaultBreadcrumb + { Bugsnag.breadcrumb_name = "Finished: " ++ Platform.name span, + Bugsnag.breadcrumb_type = Bugsnag.logBreadcrumbType, + Bugsnag.breadcrumb_timestamp = Timer.toISO8601 timer (Platform.finished span) + } + +startBreadcrumb :: Timer.Timer -> Platform.TracingSpan -> Bugsnag.Breadcrumb +startBreadcrumb timer span = + (doBreadcrumb timer span) + { Bugsnag.breadcrumb_name = "Starting: " ++ Platform.name span + } + +doBreadcrumb :: Timer.Timer -> Platform.TracingSpan -> Bugsnag.Breadcrumb +doBreadcrumb timer span = + let defaultBreadcrumb = + Bugsnag.defaultBreadcrumb + { Bugsnag.breadcrumb_name = Platform.name span, + Bugsnag.breadcrumb_type = Bugsnag.manualBreadcrumbType, + Bugsnag.breadcrumb_timestamp = Timer.toISO8601 timer (Platform.started span), + Bugsnag.breadcrumb_metaData = stackFrameMetaData ++ durationMetaData + } + stackFrameMetaData = + case Platform.frame span of + Nothing -> Nothing + Just (_, frame) -> + Stack.srcLocFile frame ++ ":" ++ Prelude.show (Stack.srcLocStartLine frame) + |> Text.fromList + |> HashMap.singleton "stack frame" + |> Just + durationMetaData = + Just + ( HashMap.singleton + "duration in milliseconds" + ( Timer.durationInUs span + |> Prelude.fromIntegral + |> (*) 1e-3 + |> Text.fromFloat + ) + ) + in case Platform.details span of + Nothing -> defaultBreadcrumb + Just details -> customizeBreadcrumb span details defaultBreadcrumb + +customizeBreadcrumb :: Platform.TracingSpan -> Platform.SomeTracingSpanDetails -> Bugsnag.Breadcrumb -> Bugsnag.Breadcrumb +customizeBreadcrumb span details breadcrumb = + details + |> Platform.renderTracingSpanDetails + [ Platform.Renderer (outgoingHttpRequestAsBreadcrumb breadcrumb), + Platform.Renderer (sqlQueryAsBreadcrumb breadcrumb), + Platform.Renderer (redisQueryAsBreadcrumb breadcrumb), + Platform.Renderer (logAsBreadcrumb span breadcrumb), + Platform.Renderer (unknownAsBreadcrumb breadcrumb) + ] + |> Maybe.withDefault breadcrumb + +outgoingHttpRequestAsBreadcrumb :: Bugsnag.Breadcrumb -> HttpRequest.Outgoing -> Bugsnag.Breadcrumb +outgoingHttpRequestAsBreadcrumb breadcrumb (HttpRequest.Outgoing details) = + breadcrumb + { Bugsnag.breadcrumb_type = Bugsnag.requestBreadcrumbType, + Bugsnag.breadcrumb_metaData = + Bugsnag.breadcrumb_metaData breadcrumb ++ Just (Helpers.toHashMap details) + } + +sqlQueryAsBreadcrumb :: Bugsnag.Breadcrumb -> SqlQuery.Details -> Bugsnag.Breadcrumb +sqlQueryAsBreadcrumb breadcrumb details = + breadcrumb + { Bugsnag.breadcrumb_type = Bugsnag.requestBreadcrumbType, + Bugsnag.breadcrumb_metaData = + Bugsnag.breadcrumb_metaData breadcrumb ++ Just (Helpers.toHashMap details) + } + +redisQueryAsBreadcrumb :: Bugsnag.Breadcrumb -> RedisCommands.Details -> Bugsnag.Breadcrumb +redisQueryAsBreadcrumb breadcrumb details = + breadcrumb + { Bugsnag.breadcrumb_type = Bugsnag.requestBreadcrumbType, + Bugsnag.breadcrumb_metaData = + Bugsnag.breadcrumb_metaData breadcrumb ++ Just (Helpers.toHashMap details) + } + +logAsBreadcrumb :: Platform.TracingSpan -> Bugsnag.Breadcrumb -> Log.LogContexts -> Bugsnag.Breadcrumb +logAsBreadcrumb span breadcrumb details = + breadcrumb + { Bugsnag.breadcrumb_type = + if List.isEmpty (Platform.children span) + then Bugsnag.logBreadcrumbType + else Bugsnag.processBreadcrumbType, + Bugsnag.breadcrumb_metaData = + Bugsnag.breadcrumb_metaData breadcrumb ++ Just (Helpers.toHashMap details) + } + +unknownAsBreadcrumb :: Bugsnag.Breadcrumb -> Platform.SomeTracingSpanDetails -> Bugsnag.Breadcrumb +unknownAsBreadcrumb breadcrumb details = + breadcrumb + { Bugsnag.breadcrumb_type = Bugsnag.manualBreadcrumbType, + Bugsnag.breadcrumb_metaData = + Bugsnag.breadcrumb_metaData breadcrumb ++ Just (Helpers.toHashMap details) + } + +decorateEventWithTracingSpanData :: Platform.TracingSpan -> Bugsnag.Event -> Bugsnag.Event +decorateEventWithTracingSpanData span event = + Platform.details span + |> Maybe.andThen + ( Platform.renderTracingSpanDetails + [ Platform.Renderer (renderIncomingHttpRequest event), + Platform.Renderer (renderLog event), + Platform.Renderer (renderRemainingTracingSpanDetails span event) + ] + ) + |> Maybe.withDefault event + +renderRemainingTracingSpanDetails :: Platform.TracingSpan -> Bugsnag.Event -> Platform.SomeTracingSpanDetails -> Bugsnag.Event +renderRemainingTracingSpanDetails span event details = + event + { Bugsnag.event_metaData = + Aeson.toJSON details + |> HashMap.singleton (Platform.name span) + |> Just + |> (++) (Bugsnag.event_metaData event) + } + +renderLog :: Bugsnag.Event -> Log.LogContexts -> Bugsnag.Event +renderLog event details = + event + { Bugsnag.event_metaData = + Aeson.toJSON details + |> HashMap.singleton "custom" + |> HashMap.unionWith + mergeJson + (Bugsnag.event_metaData event |> Maybe.withDefault HashMap.empty) + |> Just + } + +mergeJson :: Aeson.Value -> Aeson.Value -> Aeson.Value +mergeJson (Aeson.Object x) (Aeson.Object y) = Aeson.Object (HashMap.unionWith mergeJson x y) +mergeJson _ last = last + +mergeMetaData :: + Maybe (HashMap.HashMap Text Aeson.Value) -> + Maybe (HashMap.HashMap Text Aeson.Value) -> + Maybe (HashMap.HashMap Text Aeson.Value) +mergeMetaData Nothing x = x +mergeMetaData x Nothing = x +mergeMetaData (Just x) (Just y) = Just (HashMap.unionWith mergeJson x y) + +renderIncomingHttpRequest :: + Bugsnag.Event -> + HttpRequest.Incoming -> + Bugsnag.Event +renderIncomingHttpRequest event (HttpRequest.Incoming request) = + event + { Bugsnag.event_context = HttpRequest.endpoint request, + Bugsnag.event_request = + Just + Bugsnag.defaultRequest + { Bugsnag.request_httpMethod = HttpRequest.method request, + Bugsnag.request_headers = + HttpRequest.headers request + |> Dict.toList + |> HashMap.fromList + |> Just + }, + -- Extra request data that Bugsnag doesn't ask for in its API, but which + -- we can make appear on the 'request' tab anyway by logging it on the + -- 'request' key of the event metadata. + Bugsnag.event_metaData = + mergeMetaData + (Bugsnag.event_metaData event) + ( [ "endpoint" .= HttpRequest.endpoint request, + "http version" .= HttpRequest.httpVersion request, + "response status" .= HttpRequest.status request, + "path" .= HttpRequest.path request, + "query string" .= HttpRequest.queryString request + ] + |> Aeson.object + |> HashMap.singleton "request" + |> Just + ) + } + +failed :: Platform.TracingSpan -> Bool +failed span = + case Platform.succeeded span of + Platform.Succeeded -> False + Platform.Failed -> True + Platform.FailedWith _ -> True + +toException :: [Bugsnag.StackFrame] -> Platform.TracingSpan -> Bugsnag.Exception +toException frames span = + case Platform.succeeded span of + Platform.Succeeded -> Bugsnag.defaultException + Platform.Failed -> + Bugsnag.defaultException + { Bugsnag.exception_errorClass = Platform.name span, + Bugsnag.exception_stacktrace = frames + } + Platform.FailedWith (Exception.SomeException exception) -> + Bugsnag.defaultException + { Bugsnag.exception_errorClass = typeName exception, + Bugsnag.exception_stacktrace = frames, + Bugsnag.exception_message = + Exception.displayException exception + |> Text.fromList + |> Just + } + +toStackFrame :: Text -> Stack.SrcLoc -> Bugsnag.StackFrame +toStackFrame functionName frame = + Bugsnag.defaultStackFrame + { Bugsnag.stackFrame_file = Text.fromList (Stack.srcLocFile frame), + Bugsnag.stackFrame_lineNumber = Stack.srcLocStartLine frame, + Bugsnag.stackFrame_columnNumber = Just (Stack.srcLocStartCol frame), + Bugsnag.stackFrame_method = functionName, + Bugsnag.stackFrame_inProject = Just True + } + +typeName :: forall a. Typeable.Typeable a => a -> Text +typeName _ = + Typeable.typeRep (Proxy.Proxy :: Proxy.Proxy a) + |> Prelude.show + |> Text.fromList + +-- | Configuration settings for this reporter. A value of this type can be read +-- from the environment using the 'decoder' function. +data Settings = Settings + { -- | The Bugsnag API key to use. This determines which Bugsnag project your + -- errors will end up in. + -- + -- [@environment variable@] LOG_FILE + -- [@default value@] app.log + apiKey :: Log.Secret Bugsnag.ApiKey, + -- | The name of this application. This will be attached to all bugsnag + -- reports. + -- + -- [@environment variable@] LOG_ROOT_NAMESPACE + -- [@default value@] your-application-name-here + appName :: Namespace, + -- | The environment this application is running in. This will be attached + -- to all bugsnage reports. + -- + -- [@environment variable@] ENVIRONMENT + -- [@default value@] development + appEnvironment :: Environment + } + +-- | Read 'Settings' from environment variables. Default variables will be used +-- in case no environment variable is set for an option. +decoder :: Environment.Decoder Settings +decoder = + Prelude.pure Settings + |> andMap apiKeyDecoder + |> andMap namespaceDecoder + |> andMap environmentDecoder + +apiKeyDecoder :: Environment.Decoder (Log.Secret Bugsnag.ApiKey) +apiKeyDecoder = + Environment.variable + Environment.Variable + { Environment.name = "BUGSNAG_API_KEY", + Environment.description = "The API key of the Bugsnag project we should send items too.", + Environment.defaultValue = "*****" + } + (Environment.text |> map Bugsnag.apiKey |> Environment.secret) + +newtype Namespace = Namespace {unNamespace :: Text} + +namespaceDecoder :: Environment.Decoder Namespace +namespaceDecoder = + Environment.variable + Environment.Variable + { Environment.name = "LOG_ROOT_NAMESPACE", + Environment.description = "Root of the log namespace. This should be the name of the application.", + Environment.defaultValue = "your-application-name-here" + } + (map Namespace Environment.text) + +newtype Environment = Environment {unEnvironment :: Text} + +environmentDecoder :: Environment.Decoder Environment +environmentDecoder = + Environment.variable + Environment.Variable + { Environment.name = "ENVIRONMENT", + Environment.description = "Environment to display in logs.", + Environment.defaultValue = "development" + } + (map Environment Environment.text) + +mkDefaultEvent :: Settings -> Prelude.IO Bugsnag.Event +mkDefaultEvent settings = do + revision <- getRevision + hostname <- Network.HostName.getHostName + let appId = unNamespace (appName settings) + let app = + Bugsnag.defaultApp + { Bugsnag.app_id = Just appId, + -- Same format as what bugsnag-build-notify uses for appVersion + Bugsnag.app_version = Just (appId ++ "-" ++ unRevision revision), + Bugsnag.app_releaseStage = Just (unEnvironment (appEnvironment settings)), + Bugsnag.app_type = Just "haskell" + } + let device = + Bugsnag.defaultDevice + { Bugsnag.device_hostname = Just (Text.fromList hostname) + } + Prelude.pure + Bugsnag.defaultEvent + { Bugsnag.event_app = Just app, + Bugsnag.event_device = Just device + } + +newtype Revision = Revision {unRevision :: Text} + +getRevision :: Prelude.IO Revision +getRevision = do + eitherRevision <- Exception.tryAny <| Data.Text.IO.readFile "revision" + case eitherRevision of + Prelude.Left _err -> Prelude.pure (Revision "no revision file found") + Prelude.Right version -> Prelude.pure (Revision version) diff --git a/src/Reporter/Dev.hs b/src/Reporter/Dev.hs new file mode 100644 --- /dev/null +++ b/src/Reporter/Dev.hs @@ -0,0 +1,19 @@ +-- | Reporting for development +-- +-- This reporter logs basic information about requests in a human-readable +-- format, for use in a development console. +-- +-- The development logs produced are quite sparse. To dig deeper this reporter +-- will also make tracing data available in the log-explorer tool. You can find +-- it here: +-- +-- +module Reporter.Dev + ( Internal.report, + Internal.Handler, + Internal.handler, + Internal.cleanup, + ) +where + +import qualified Reporter.Dev.Internal as Internal diff --git a/src/Reporter/Dev/Internal.hs b/src/Reporter/Dev/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Reporter/Dev/Internal.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE NumericUnderscores #-} + +module Reporter.Dev.Internal where + +import qualified Control.Concurrent +import qualified Control.Concurrent.Async as Async +import qualified Control.Concurrent.MVar as MVar +import qualified Control.Exception.Safe as Exception +import qualified Data.Text.IO +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Builder as Builder +import qualified Log.HttpRequest as HttpRequest +import qualified Platform +import qualified Platform.Timer as Timer +import qualified Prelude + +-- Print basic information about requests to stdout and make more detailed +-- information available to the log-explorer tool. +-- +-- Example usage: +-- > handler <- Dev.handler +-- > Dev.report handler "request-id" span +report :: Handler -> Text -> Platform.TracingSpan -> Prelude.IO () +report handler' _requestId span = do + Platform.writeSpanToDevLog span + MVar.putMVar (writeLock handler') (mkLog (timer handler') span) + +mkLog :: Timer.Timer -> Platform.TracingSpan -> Builder.Builder +mkLog timer span = + time timer span + ++ " " + ++ name span + ++ " " + ++ failed span + +time :: Timer.Timer -> Platform.TracingSpan -> Builder.Builder +time timer span = + Timer.toLocal timer (Platform.started span) + |> Prelude.show + |> Builder.fromString + +name :: Platform.TracingSpan -> Builder.Builder +name span = + Platform.details span + |> Maybe.andThen + ( Platform.renderTracingSpanDetails + [ Platform.Renderer nameIncomingRequest + ] + ) + |> Maybe.withDefault (Builder.fromText (Platform.name span)) + +nameIncomingRequest :: HttpRequest.Incoming -> Builder.Builder +nameIncomingRequest (HttpRequest.Incoming details) = + HttpRequest.endpoint details + |> Maybe.withDefault "Incoming HTTP request" + |> Builder.fromText + +failed :: Platform.TracingSpan -> Builder.Builder +failed span = + case Platform.succeeded span of + Platform.Succeeded -> "" + Platform.Failed -> "❌" + Platform.FailedWith err -> + "❌\n" + ++ Builder.fromString (Exception.displayException err) + +data Handler = Handler + { timer :: Timer.Timer, + -- If we let each request log to stdout directly the result will be lots + -- of unreadable interleaved output from requests that are handled + -- concurrently. To prevent this we use an MVar as a lock. + -- + -- After a request is done it can write it's log to the MVar. If the + -- MVar already contains a log this operation will block until the MVar + -- is empty. We have a logging thread running separately that takes logs + -- from the MVar and prints them to stdout one at a time. + writeLock :: MVar.MVar Builder.Builder, + loggingThread :: Async.Async () + } + +-- | Create a 'Handler'. Do this once when your application starts and reuse +-- the 'Handler' you get. +handler :: Prelude.IO Handler +handler = do + writeLock <- MVar.newEmptyMVar + counter <- MVar.newMVar 0 + loggingThread <- Async.async (logLoop counter writeLock) + timer <- Timer.mkTimer + Prelude.pure Handler {timer, writeLock, loggingThread} + +-- | Clean up your handler after you're done with it. Call this before your +-- application shuts down. +cleanup :: Handler -> Prelude.IO () +cleanup = Async.cancel << loggingThread + +-- | Waits for a log message to become available in the MVar, logs it, then +-- waits for the next one. This is intended to be ran on a separate thread. +logLoop :: MVar.MVar Int -> MVar.MVar Builder.Builder -> Prelude.IO () +logLoop counter lock = do + line <- MVar.takeMVar lock + Builder.toLazyText line + |> Data.Text.Lazy.toStrict + |> Data.Text.IO.putStrLn + ownCount <- MVar.modifyMVar counter (\n -> Prelude.pure (n + 1, n + 1)) + Async.concurrently_ + (logLoop counter lock) + ( do + -- After a few seconds of inactivity, advertise for log-explorer. + Control.Concurrent.threadDelay 3_000_000 {- 3 seconds -} + currentCount <- MVar.readMVar counter + if ownCount == currentCount + then Prelude.putStrLn "🕵️ Need more detail? Try running the `log-explorer` command!\n" + else Prelude.pure () + ) diff --git a/src/Reporter/File.hs b/src/Reporter/File.hs new file mode 100644 --- /dev/null +++ b/src/Reporter/File.hs @@ -0,0 +1,26 @@ +-- | Reporting to a file. +-- +-- This reporter logs debugging information about completed requests to a file +-- or `stdout` (in that case, pass in `/dev/stdout` as the file to log to). +-- +-- Every line this reporter logs is a JSON string. This 'structured logging' +-- output is optimized for external logging platforms that display these logs in +-- a pretty UI. +-- +-- This logger supports sampling of successful requests, to help save money when +-- sending logs to external services. +module Reporter.File + ( Internal.report, + Internal.Handler, + Internal.handler, + Internal.cleanup, + Internal.Settings, + Internal.decoder, + Internal.logFile, + Internal.appName, + Internal.appEnvironment, + Internal.fractionOfSuccessRequestsLogged, + ) +where + +import qualified Reporter.File.Internal as Internal diff --git a/src/Reporter/File/Internal.hs b/src/Reporter/File/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Reporter/File/Internal.hs @@ -0,0 +1,222 @@ +module Reporter.File.Internal where + +import qualified Control.Concurrent.Async as Async +import qualified Control.Concurrent.STM as STM +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encoding +import qualified Data.ByteString.Lazy as ByteString +import qualified Data.Foldable +import qualified Environment +import qualified Network.HostName +import qualified Platform +import qualified Platform.ReporterHelpers as Helpers +import qualified Platform.Timer as Timer +import qualified System.IO +import qualified System.Random as Random +import qualified Prelude + +-- Log tracing information for a request to a file. Tracing information contains +-- nested spans but will appear flattend in the log. Each tracing span will +-- appear on its own line in the log, ordered by its start date. +-- +-- Example usage: +-- +-- > settings <- File.decode +-- > handler <- File.handler settings +-- > File.report handler "request-id" span +report :: Handler -> Text -> Platform.TracingSpan -> Prelude.IO () +report Handler {skipLogging, writeQueue, logContext} requestId span = do + skip <- skipLogging span + if skip + then Prelude.pure () + else + logItemRecursively logContext {requestId} span [] + |> STM.writeTBQueue writeQueue + |> (`STM.orElse` Prelude.pure ()) -- Drop the log if the queue is full. + |> STM.atomically + +logItemRecursively :: + LogContext -> + Platform.TracingSpan -> + [ByteString.ByteString] -> + [ByteString.ByteString] +logItemRecursively logContext span acc = + logItemRecursivelyHelper logContext span acc + |> List.reverse + +logItemRecursivelyHelper :: + LogContext -> + Platform.TracingSpan -> + [ByteString.ByteString] -> + [ByteString.ByteString] +logItemRecursivelyHelper logContext span acc = + List.foldr -- The right-most child is the oldest, so that's where we start + ( logItemRecursivelyHelper + logContext + { namespace = Platform.name span : namespace logContext + } + ) + (logItem logContext span : acc) + (Platform.children span) + +logItem :: LogContext -> Platform.TracingSpan -> ByteString.ByteString +logItem LogContext {timer, namespace, environment, requestId, hostname} span = + (Aeson..=) "name" (Platform.name span) + ++ (Aeson..=) "start_utc" (Timer.toUTC timer (Platform.started span)) + ++ (Aeson..=) "duration_ms" (Prelude.fromIntegral (Timer.durationInUs span) / 1000) + ++ (Aeson..=) "env" environment + ++ (Aeson..=) "namespace" namespace + ++ (Aeson..=) "request-id" requestId + ++ (Aeson..=) "hostname" hostname + ++ ( case Platform.frame span of + Nothing -> Prelude.mempty + Just (_, srcLoc) -> + (Aeson..=) "src" (Helpers.srcString srcLoc) + ) + ++ (Aeson..=) "allocated_mb" (toFloat (Platform.allocated span) / 1e6) + ++ (Aeson..=) "details" (Platform.details span) + |> Aeson.pairs + |> Data.Aeson.Encoding.encodingToLazyByteString + +data Handler = Handler + { fileHandle :: System.IO.Handle, + logContext :: LogContext, + skipLogging :: Platform.TracingSpan -> Prelude.IO Bool, + writeQueue :: STM.TBQueue [ByteString.ByteString], + loggingThread :: Async.Async () + } + +data LogContext = LogContext + { timer :: Timer.Timer, + namespace :: [Text], + environment :: Text, + requestId :: Text, + hostname :: Text + } + +-- | Create a 'Handler' for a specified set of 'Settings'. Do this once when +-- your application starts and reuse the 'Handler' you get. +handler :: Settings -> Prelude.IO Handler +handler settings = do + let skipLogging span = + case Platform.succeeded span of + Platform.Succeeded -> do + roll <- Random.randomRIO (0.0, 1.0) + Prelude.pure (roll > fractionOfSuccessRequestsLogged settings) + Platform.Failed -> Prelude.pure False + Platform.FailedWith _ -> Prelude.pure False + fileHandle <- System.IO.openFile (logFile settings) System.IO.AppendMode + hostname <- map Text.fromList Network.HostName.getHostName + writeQueue <- STM.atomically (STM.newTBQueue 100) + loggingThread <- Async.async (logLoop writeQueue fileHandle) + timer <- Timer.mkTimer + let logContext = + LogContext + { timer, + hostname, + requestId = "", -- This changes per request and so is set later. + namespace = [appName settings], + environment = appEnvironment settings + } + Prelude.pure + Handler + { fileHandle, + skipLogging, + writeQueue, + loggingThread, + logContext + } + +logLoop :: + STM.TBQueue [ByteString.ByteString] -> + System.IO.Handle -> + Prelude.IO () +logLoop writeQueue fileHandle = do + lines <- STM.atomically (STM.readTBQueue writeQueue) + Data.Foldable.for_ lines <| \line -> do + ByteString.hPut fileHandle line + ByteString.hPut fileHandle "\n" + logLoop writeQueue fileHandle + +cleanup :: Handler -> Prelude.IO () +cleanup Handler {loggingThread, fileHandle} = do + Async.cancel loggingThread + System.IO.hClose fileHandle + +-- | Configuration settings for this reporter. A value of this type can be read +-- from the environment using the 'decoder' function. +data Settings = Settings + { -- | The file to log too. On unix systems you can set this to @/dev/stdout@ + -- in order to log to stdout. + -- + -- [@environment variable@] LOG_FILE + -- [@default value@] app.log + logFile :: Prelude.FilePath, + -- | The name of this application. This will be attached to all logs. + -- + -- [@environment variable@] LOG_ROOT_NAMESPACE + -- [@default value@] your-application-name-here + appName :: Text, + -- | The environment this application is running in. This will be attached + -- to all logs. + -- + -- [@environment variable@] ENVIRONMENT + -- [@default value@] development + appEnvironment :: Text, + -- | The fraction of requests that should be logged. Set to 1 if you want to + -- log everything, and a lower value to save money. + -- + -- [@environment variable@] FRACTION_OF_SUCCESS_REQUESTS_LOGGED + -- [@default value@] 1 + fractionOfSuccessRequestsLogged :: Float + } + +-- | Read 'Settings' from environment variables. Default variables will be used +-- in case no environment variable is set for an option. +decoder :: Environment.Decoder Settings +decoder = + Prelude.pure Settings + |> andMap logFileDecoder + |> andMap appNameDecoder + |> andMap environmentDecoder + |> andMap fractionOfSuccessRequestsLoggedDecoder + +logFileDecoder :: Environment.Decoder Prelude.FilePath +logFileDecoder = + Environment.variable + Environment.Variable + { Environment.name = "LOG_FILE", + Environment.description = "File to log too.", + Environment.defaultValue = "app.log" + } + Environment.filePath + +appNameDecoder :: Environment.Decoder Text +appNameDecoder = + Environment.variable + Environment.Variable + { Environment.name = "LOG_ROOT_NAMESPACE", + Environment.description = "Root of the log namespace. This should be the name of the application.", + Environment.defaultValue = "your-application-name-here" + } + Environment.text + +environmentDecoder :: Environment.Decoder Text +environmentDecoder = + Environment.variable + Environment.Variable + { Environment.name = "ENVIRONMENT", + Environment.description = "Environment to display in logs.", + Environment.defaultValue = "development" + } + Environment.text + +fractionOfSuccessRequestsLoggedDecoder :: Environment.Decoder Float +fractionOfSuccessRequestsLoggedDecoder = + Environment.variable + Environment.Variable + { Environment.name = "FRACTION_OF_SUCCESS_REQUESTS_LOGGED", + Environment.description = "The fraction of successful requests logged. Defaults to logging all successful requests.", + Environment.defaultValue = "1" + } + Environment.float diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,21 @@ +module Main (main) where + +import qualified Spec.Platform.Timer +import qualified Spec.Reporter.Bugsnag +import qualified Spec.Reporter.Dev +import qualified Spec.Reporter.File +import qualified Test +import qualified Prelude + +main :: Prelude.IO () +main = Test.run tests + +tests :: Test.Test +tests = + Test.describe + "nri-observability" + [ Spec.Platform.Timer.tests, + Spec.Reporter.Bugsnag.tests, + Spec.Reporter.Dev.tests, + Spec.Reporter.File.tests + ] diff --git a/tests/Spec/Platform/Timer.hs b/tests/Spec/Platform/Timer.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/Platform/Timer.hs @@ -0,0 +1,27 @@ +module Spec.Platform.Timer (tests) where + +import qualified Data.Time.Clock.POSIX as Clock.POSIX +import qualified Expect +import qualified GHC.Clock +import qualified Platform.Timer as Timer +import qualified Test +import qualified Prelude + +tests :: Test.Test +tests = + Test.describe + "Observability.Timer" + [ Test.test "can reproduce the current time" <| \_ -> do + timer <- Expect.fromIO <| Timer.mkTimer + clock <- + GHC.Clock.getMonotonicTimeNSec + |> map (\t -> Prelude.fromIntegral (t `Prelude.div` 1000)) + |> Expect.fromIO + expectedNow <- Expect.fromIO <| Clock.POSIX.getPOSIXTime + let actualNow = Timer.toPosix timer clock + actualNow + |> Expect.all + [ Expect.atLeast (expectedNow - 1), + Expect.atMost (expectedNow + 1) + ] + ] diff --git a/tests/Spec/Reporter/Bugsnag.hs b/tests/Spec/Reporter/Bugsnag.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/Reporter/Bugsnag.hs @@ -0,0 +1,444 @@ +module Spec.Reporter.Bugsnag (tests) where + +import qualified Control.Exception.Safe as Exception +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encode.Pretty +import qualified Data.ByteString.Lazy +import qualified Data.Text.Encoding +import qualified Data.Time.LocalTime as LocalTime +import qualified Dict +import qualified Expect +import qualified GHC.Stack as Stack +import qualified Log +import qualified Log.HttpRequest as HttpRequest +import qualified Log.RedisCommands as RedisCommands +import qualified Log.SqlQuery as SqlQuery +import qualified Network.Bugsnag +import qualified Platform +import qualified Platform.Timer as Timer +import qualified Reporter.Bugsnag.Internal as Bugsnag +import Test (Test, describe, test) +import qualified Prelude + +tests :: Test +tests = + describe + "Observability.Bugsnag" + [ test "encodes span marked as failed as an exception" <| \_ -> + emptyTracingSpan + { Platform.name = "root span", + Platform.succeeded = Platform.Failed + } + |> encodesTo "bugsnag-failure-without-exception", + test "if an exception was thrown use that exceptions name" <| \_ -> + emptyTracingSpan + { Platform.succeeded = + Platform.FailedWith (Exception.SomeException (CustomException "something went wrong")) + } + |> encodesTo "bugsnag-failure-with-exception", + test "identifies the most recently started failing span as the root cause failure" <| \_ -> + emptyTracingSpan + { Platform.name = "parent of root cause", + Platform.succeeded = Platform.Failed, + Platform.children = + [ emptyTracingSpan + { Platform.name = "after root cause", + Platform.succeeded = Platform.Succeeded + }, + emptyTracingSpan + { Platform.name = "root cause", + Platform.succeeded = Platform.Failed, + Platform.children = + [ emptyTracingSpan + { Platform.name = "child of root cause", + Platform.succeeded = Platform.Succeeded + } + ] + }, + emptyTracingSpan + { Platform.name = "before root cause", + Platform.succeeded = Platform.Succeeded + } + ] + } + |> encodesTo "bugsnag-failure-with-root-cause", + test "shows stack trace from the root span to the root cause span" <| \_ -> + emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.frame = Just ("function1", Stack.SrcLoc "package1" "Module2" "Filename1.hs" 0 1 2 3), + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Succeeded, + Platform.frame = Just ("function2", Stack.SrcLoc "package2" "Module2" "Filename2.hs" 10 11 12 13) + }, + emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.frame = Just ("function3", Stack.SrcLoc "package3" "Module3" "Filename3.hs" 20 21 22 23), + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Succeeded, + Platform.frame = Just ("function4", Stack.SrcLoc "package4" "Module4" "Filename4.hs" 30 31 32 33) + } + ] + }, + emptyTracingSpan + { Platform.succeeded = Platform.Succeeded, + Platform.frame = Just ("function5", Stack.SrcLoc "package5" "Module5" "Filename5.hs" 40 41 42 43) + } + ] + } + |> encodesTo "bugsnag-failure-stack-trace", + test "encodes information about an incoming http request" <| \_ -> + emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.details = + HttpRequest.emptyDetails + { HttpRequest.httpVersion = Just "1", + HttpRequest.method = Just "GET", + HttpRequest.path = Just "/hats/5", + HttpRequest.queryString = Just "?top=flat", + HttpRequest.endpoint = Just "GET /hats/:hat_id", + HttpRequest.headers = Dict.fromList [("Accept", "application/json")], + HttpRequest.status = Just 500 + } + |> HttpRequest.Incoming + |> Platform.toTracingSpanDetails + |> Just + } + |> encodesTo "bugsnag-failure-incoming-http-request", + test "renders sql query failures correctly" <| \_ -> + emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.details = + SqlQuery.emptyDetails + { SqlQuery.query = Just (Log.mkSecret "SELECT name FROM ants WHERE id = 3"), + SqlQuery.databaseType = Just SqlQuery.postgresql, + SqlQuery.queryTemplate = Just "SELECT name FROM ants WHERE id = ${id}", + SqlQuery.sqlOperation = Just "SELECT", + SqlQuery.queriedRelation = Just "ants", + SqlQuery.host = Just "http://antsonline.com", + SqlQuery.port = Just 5432, + SqlQuery.database = Just "nri", + SqlQuery.rowsReturned = Just 5 + } + |> Platform.toTracingSpanDetails + |> Just + } + |> encodesTo "bugsnag-failure-sql", + test "renders redis query failures correctly" <| \_ -> + emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.details = + RedisCommands.emptyDetails + { RedisCommands.host = Just "cache.noredink.com", + RedisCommands.port = Just 6379, + RedisCommands.commands = ["GET somekey"] + } + |> Platform.toTracingSpanDetails + |> Just + } + |> encodesTo "bugsnag-failure-redis", + test "renders outgoing http request failures correctly" <| \_ -> + emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.details = + HttpRequest.emptyDetails + { HttpRequest.host = Just "http://antsonline.com", + HttpRequest.path = Just "/bulletin", + HttpRequest.method = Just "GET" + } + |> HttpRequest.Outgoing + |> Platform.toTracingSpanDetails + |> Just + } + ] + } + |> encodesTo "bugsnag-failure-http", + test "renders log failures correctly" <| \_ -> + emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.name = "log message", + Platform.details = + Log.LogContexts + [ Log.context "number" (4 :: Int), + Log.context "text" ("Hi!" :: Text) + ] + |> Platform.toTracingSpanDetails + |> Just + } + |> encodesTo "bugsnag-failure-log", + test "renders withContext failures correctly" <| \_ -> + emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.name = "some context", + Platform.details = + Log.LogContexts + [ Log.context "number" (4 :: Int) + ] + |> Platform.toTracingSpanDetails + |> Just, + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Succeeded + } + ] + } + |> encodesTo "bugsnag-failure-with-context", + test "merges unknown span details from nested spans into metadata" <| \_ -> + emptyTracingSpan + { Platform.name = "measure weather", + Platform.succeeded = Platform.Failed, + Platform.details = + CustomDetails "32 C" + |> Platform.toTracingSpanDetails + |> Just, + Platform.children = + [ emptyTracingSpan + { Platform.name = "measure humidity", + Platform.succeeded = Platform.Failed, + Platform.details = + CustomDetails "25 %" + |> Platform.toTracingSpanDetails + |> Just + } + ] + } + |> encodesTo "bugsnag-failure-unknown", + test "non-failing spans are encoded as breadcrumbs in the right order" <| \_ -> + emptyTracingSpan + { Platform.name = "root-span (failed)", + Platform.succeeded = Platform.Failed, + Platform.children = + [ emptyTracingSpan + { Platform.name = "child-3 (leaf)", + Platform.succeeded = Platform.Succeeded + }, + emptyTracingSpan + { Platform.name = "child-2 (failed)", + Platform.succeeded = Platform.Failed, + Platform.children = + [ emptyTracingSpan + { Platform.name = "child-3-grandchild-3 (failed, root cause)", + Platform.succeeded = Platform.Failed, + Platform.children = + [ emptyTracingSpan + { Platform.name = "child-3-grandchild-3-greatgrandchild-2 (leaf)", + Platform.succeeded = Platform.Succeeded + }, + emptyTracingSpan + { Platform.name = "child-3-grandchild-3-greatgrandchild-1 (leaf)", + Platform.succeeded = Platform.Succeeded + } + ] + }, + emptyTracingSpan + { Platform.name = "child-2-grandchild-2", + Platform.succeeded = Platform.Succeeded, + Platform.children = + [ emptyTracingSpan + { Platform.name = "child-2-grandchild-2-greatgrandchild-2 (leaf)", + Platform.succeeded = Platform.Failed + }, + emptyTracingSpan + { Platform.name = "child-2-grandchild-2-greatgrandchild-1 (leaf)", + Platform.succeeded = Platform.Succeeded + } + ] + }, + emptyTracingSpan + { Platform.name = "child-2-grandchild-1 (leaf)", + Platform.succeeded = Platform.Succeeded + } + ] + }, + emptyTracingSpan + { Platform.name = "child-1 (leaf)", + Platform.succeeded = Platform.Succeeded + } + ] + } + |> encodesTo "bugsnag-breadcrumbs-right-order", + test "renders sql query breadcrumbs correctly" <| \_ -> + emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Succeeded, + Platform.details = + SqlQuery.emptyDetails + { SqlQuery.query = Just (Log.mkSecret "SELECT name FROM ants WHERE id = 3"), + SqlQuery.databaseType = Just SqlQuery.postgresql, + SqlQuery.queryTemplate = Just "SELECT name FROM ants WHERE id = ${id}", + SqlQuery.sqlOperation = Just "SELECT", + SqlQuery.queriedRelation = Just "ants", + SqlQuery.host = Just "http://antsonline.com", + SqlQuery.port = Just 5432, + SqlQuery.database = Just "nri", + SqlQuery.rowsReturned = Just 5 + } + |> Platform.toTracingSpanDetails + |> Just + } + ] + } + |> encodesTo "bugsnag-breadcrumbs-sql", + test "renders redis query breadcrumbs correctly" <| \_ -> + emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Succeeded, + Platform.details = + RedisCommands.emptyDetails + { RedisCommands.host = Just "cache.noredink.com", + RedisCommands.port = Just 6379, + RedisCommands.commands = ["GET somekey"] + } + |> Platform.toTracingSpanDetails + |> Just + } + ] + } + |> encodesTo "bugsnag-breadcrumbs-redis", + test "renders outgoing http request breadcrumbs correctly" <| \_ -> + emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Succeeded, + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Succeeded, + Platform.details = + HttpRequest.emptyDetails + { HttpRequest.host = Just "http://antsonline.com", + HttpRequest.path = Just "/bulletin", + HttpRequest.method = Just "GET" + } + |> HttpRequest.Outgoing + |> Platform.toTracingSpanDetails + |> Just + } + ] + } + ] + } + |> encodesTo "bugsnag-breadcrumbs-http", + test "renders log breadcrumbs correctly" <| \_ -> + emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Succeeded, + Platform.details = + Log.LogContexts + [ Log.context "number" (4 :: Int), + Log.context "text" ("Hi!" :: Text) + ] + |> Platform.toTracingSpanDetails + |> Just + } + ] + } + |> encodesTo "bugsnag-breadcrumbs-log", + test "renders withContext breadcrumbs correctly" <| \_ -> + emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Succeeded, + Platform.details = + Log.LogContexts + [ Log.context "number" (4 :: Int) + ] + |> Platform.toTracingSpanDetails + |> Just, + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Succeeded + } + ] + } + ] + } + |> encodesTo "bugsnag-breadcrumbs-with-context", + test "renders unknown spans breadcrumbs correctly" <| \_ -> + emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Succeeded, + Platform.details = + CustomDetails "The deets!" + |> Platform.toTracingSpanDetails + |> Just + } + ] + } + |> encodesTo "bugsnag-breadcrumbs-unknown", + test "renders timestamps correctly" <| \_ -> + emptyTracingSpan + { Platform.succeeded = Platform.Failed, + Platform.started = ms 4, + Platform.finished = ms 9, -- 8 ms + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Succeeded, + Platform.name = "outer", + Platform.started = ms 5, + Platform.finished = ms 8, -- 8 ms + Platform.children = + [ emptyTracingSpan + { Platform.succeeded = Platform.Succeeded, + Platform.name = "inner", + Platform.started = ms 6, -- 6 ms + Platform.finished = ms 7, -- 7 ms + Platform.children = + [] + } + ] + } + ] + } + |> encodesTo "bugsnag-breadcrumbs-timestamps" + ] + +newtype CustomException = CustomException Text deriving (Show) + +instance Exception.Exception CustomException + +newtype CustomDetails = CustomDetails Text + deriving (Aeson.ToJSON) + +instance Platform.TracingSpanDetails CustomDetails + +ms :: Int -> Platform.MonotonicTime +ms n = Prelude.fromIntegral (n * 1000) + +timer :: Timer.Timer +timer = Timer.Timer 0 LocalTime.utc + +emptyTracingSpan :: Platform.TracingSpan +emptyTracingSpan = + Platform.emptyTracingSpan + { Platform.name = "some span", + Platform.started = 0, + Platform.finished = 0, + Platform.frame = Nothing, + Platform.details = Nothing, + Platform.succeeded = Platform.Succeeded, + Platform.allocated = 0, + Platform.children = [] + } + +encodesTo :: Text -> Platform.TracingSpan -> Expect.Expectation +encodesTo filename span = + span + |> Bugsnag.toEvent "request-id-1234" timer Network.Bugsnag.defaultEvent + |> Data.Aeson.Encode.Pretty.encodePretty + |> Data.ByteString.Lazy.toStrict + |> Data.Text.Encoding.decodeUtf8 + |> Expect.equalToContentsOf ("tests/golden-results/" ++ filename ++ ".json") diff --git a/tests/Spec/Reporter/Dev.hs b/tests/Spec/Reporter/Dev.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/Reporter/Dev.hs @@ -0,0 +1,76 @@ +module Spec.Reporter.Dev (tests) where + +import qualified Control.Exception.Safe as Exception +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Builder +import qualified Data.Time.LocalTime as LocalTime +import qualified Expect +import qualified Log.HttpRequest as HttpRequest +import qualified Platform +import qualified Platform.Timer as Timer +import qualified Reporter.Dev.Internal as Dev +import qualified Test +import qualified Prelude + +tests :: Test.Test +tests = + Test.describe + "Observability.Dev" + [ logTest + "log span without details or children" + emptyTracingSpan + { Platform.name = "root-span", + Platform.started = ms 5 + }, + logTest + "log span with exception" + emptyTracingSpan + { Platform.name = "root-span", + Platform.succeeded = Platform.FailedWith (Exception.SomeException (CustomException "toast!")) + }, + logTest + "logs information about an incoming http request" + emptyTracingSpan + { Platform.details = + HttpRequest.emptyDetails + { HttpRequest.endpoint = Just "/hats/:hat_id" + } + |> HttpRequest.Incoming + |> Platform.toTracingSpanDetails + |> Just + } + ] + +logTest :: Text -> Platform.TracingSpan -> Test.Test +logTest name span = + Test.test name <| \_ -> do + let logfile = Text.replace " " "-" name + let logpath = "tests/golden-results/dev-reporter-" ++ logfile + span + |> Dev.mkLog timer + |> Data.Text.Lazy.Builder.toLazyText + |> Data.Text.Lazy.toStrict + |> Expect.equalToContentsOf logpath + +newtype CustomException = CustomException Text deriving (Show) + +instance Exception.Exception CustomException + +ms :: Int -> Platform.MonotonicTime +ms n = Prelude.fromIntegral (n * 1000) + +timer :: Timer.Timer +timer = Timer.Timer 0 LocalTime.utc + +emptyTracingSpan :: Platform.TracingSpan +emptyTracingSpan = + Platform.emptyTracingSpan + { Platform.name = "Example TracingSpan", + Platform.started = 0, + Platform.finished = 0, + Platform.frame = Nothing, + Platform.details = Nothing, + Platform.succeeded = Platform.Succeeded, + Platform.allocated = 0, + Platform.children = [] + } diff --git a/tests/Spec/Reporter/File.hs b/tests/Spec/Reporter/File.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/Reporter/File.hs @@ -0,0 +1,186 @@ +module Spec.Reporter.File (tests) where + +import qualified Control.Exception.Safe as Exception +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encode.Pretty +import qualified Data.ByteString.Lazy +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Encoding +import qualified Data.Time.LocalTime as LocalTime +import qualified Dict +import qualified Expect +import qualified Log.HttpRequest as HttpRequest +import qualified Log.RedisCommands as RedisCommands +import qualified Log.SqlQuery as SqlQuery +import qualified Platform +import qualified Platform.Timer as Timer +import qualified Reporter.File.Internal as File +import qualified Test +import qualified Prelude + +tests :: Test.Test +tests = + Test.describe + "Observability.FileSpec" + [ logTest + "logs span without details or children" + emptyTracingSpan + { Platform.name = "root-span", + Platform.finished = ms 7 + }, + logTest + "logs span that failed with an exception" + emptyTracingSpan + { Platform.name = "root-span", + Platform.succeeded = Platform.FailedWith (Exception.SomeException (CustomException "help!")) + }, + logTest + "logs nested spans" + emptyTracingSpan + { Platform.name = "root-span", + Platform.children = + [ emptyTracingSpan + { Platform.name = "child1", + Platform.children = + [ emptyTracingSpan + { Platform.name = "grandchild", + Platform.children = [] + } + ] + }, + emptyTracingSpan + { Platform.name = "child2", + Platform.children = [] + } + ] + }, + logTest + "logs information about an incoming http request" + emptyTracingSpan + { Platform.details = + HttpRequest.emptyDetails + { HttpRequest.httpVersion = Just "1", + HttpRequest.method = Just "GET", + HttpRequest.path = Just "/hats/5", + HttpRequest.queryString = Just "?top=flat", + HttpRequest.endpoint = Just "/hats/:hat_id", + HttpRequest.headers = Dict.fromList [("Accept", "application/json")], + HttpRequest.status = Just 500 + } + |> HttpRequest.Incoming + |> Platform.toTracingSpanDetails + |> Just + }, + logTest + "logs information about an SQL query" + emptyTracingSpan + { Platform.details = + SqlQuery.emptyDetails + { SqlQuery.databaseType = Just SqlQuery.postgresql, + SqlQuery.query = Just (Log.mkSecret "SELECT name FROM ants WHERE id = ?"), + SqlQuery.queryTemplate = Just "SELECT name FROM ants WHERE id = ${id}", + SqlQuery.sqlOperation = Just "SELECT", + SqlQuery.queriedRelation = Just "ants", + SqlQuery.host = Just "http://antsonline.com", + SqlQuery.port = Just 5432, + SqlQuery.database = Just "nri", + SqlQuery.rowsReturned = Just 5 + } + |> Platform.toTracingSpanDetails + |> Just + }, + logTest + "logs information about a redis query" + emptyTracingSpan + { Platform.details = + RedisCommands.emptyDetails + { RedisCommands.host = Just "cache.noredink.com", + RedisCommands.port = Just 6379, + RedisCommands.commands = ["GET somekey"] + } + |> Platform.toTracingSpanDetails + |> Just + }, + logTest + "logs information about an outoing http request" + emptyTracingSpan + { Platform.details = + HttpRequest.emptyDetails + { HttpRequest.httpVersion = Just "1", + HttpRequest.method = Just "GET", + HttpRequest.path = Just "/hats/5", + HttpRequest.queryString = Just "?top=flat", + HttpRequest.endpoint = Just "/hats/:hat_id", + HttpRequest.headers = Dict.fromList [("Accept", "application/json")], + HttpRequest.status = Just 500 + } + |> HttpRequest.Incoming + |> Platform.toTracingSpanDetails + |> Just + }, + logTest + "logs log messages" + emptyTracingSpan + { Platform.details = + Log.LogContexts + [ Log.context "number" (4 :: Int), + Log.context "text" ("Hi!" :: Text) + ] + |> Platform.toTracingSpanDetails + |> Just + } + ] + +logTest :: Text -> Platform.TracingSpan -> Test.Test +logTest name span = + Test.test name <| \_ -> do + let logContext = + File.LogContext + { File.requestId = "request-id", + File.namespace = ["app"], + File.environment = "narnia", + File.hostname = "some-host", + File.timer = Timer.Timer 0 LocalTime.utc + } + let reEncodingResult = + File.logItemRecursively logContext span [] + -- Pretty-print each log entry to make test files more readable. + |> Prelude.traverse reEncodePretty + case reEncodingResult of + Err err -> Expect.fail err + Ok reEncoded -> + Text.join "\n" reEncoded + |> Expect.equalToContentsOf + ( Text.fromList "tests/golden-results/file-reporter-" + ++ Text.replace " " "-" name + ) + +reEncodePretty :: Data.ByteString.Lazy.ByteString -> Result Text Text +reEncodePretty str = + case Aeson.eitherDecode' str of + Prelude.Left err -> Err (Text.fromList err) + Prelude.Right (json :: Aeson.Value) -> + Data.Aeson.Encode.Pretty.encodePretty json + |> Data.Text.Lazy.Encoding.decodeUtf8 + |> Data.Text.Lazy.toStrict + |> Ok + +newtype CustomException = CustomException Text deriving (Show) + +instance Exception.Exception CustomException + +ms :: Int -> Platform.MonotonicTime +ms n = Prelude.fromIntegral (1000 * n) + +emptyTracingSpan :: Platform.TracingSpan +emptyTracingSpan = + Platform.emptyTracingSpan + { Platform.name = "", + Platform.started = 0, + Platform.finished = 0, + Platform.frame = Nothing, + Platform.details = Nothing, + Platform.succeeded = Platform.Succeeded, + Platform.allocated = 0, + Platform.children = [] + }