{-# LANGUAGE GADTs #-}
module Observability
( report,
Handler,
Settings (..),
Reporter (..),
decoder,
handler,
)
where
import qualified Conduit
import qualified Control.Exception.Safe as Exception
import qualified Data.Aeson as Aeson
import qualified Environment
import qualified List
import qualified Platform
import qualified Reporter.Bugsnag as Bugsnag
import qualified Reporter.Dev as Dev
import qualified Reporter.File as File
import qualified Reporter.Honeycomb as Honeycomb
import qualified Set
import qualified Text
import Prelude (pure, traverse)
import qualified Prelude
newtype Handler = Handler
{
Handler -> Text -> TracingSpan -> IO ()
report :: Text -> Platform.TracingSpan -> Prelude.IO ()
}
deriving (b -> Handler -> Handler
NonEmpty Handler -> Handler
Handler -> Handler -> Handler
(Handler -> Handler -> Handler)
-> (NonEmpty Handler -> Handler)
-> (forall b. Integral b => b -> Handler -> Handler)
-> Semigroup Handler
forall b. Integral b => b -> Handler -> Handler
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Handler -> Handler
$cstimes :: forall b. Integral b => b -> Handler -> Handler
sconcat :: NonEmpty Handler -> Handler
$csconcat :: NonEmpty Handler -> Handler
<> :: Handler -> Handler -> Handler
$c<> :: Handler -> Handler -> Handler
Prelude.Semigroup, Semigroup Handler
Handler
Semigroup Handler
-> Handler
-> (Handler -> Handler -> Handler)
-> ([Handler] -> Handler)
-> Monoid Handler
[Handler] -> Handler
Handler -> Handler -> Handler
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Handler] -> Handler
$cmconcat :: [Handler] -> Handler
mappend :: Handler -> Handler -> Handler
$cmappend :: Handler -> Handler -> Handler
mempty :: Handler
$cmempty :: Handler
$cp1Monoid :: Semigroup Handler
Prelude.Monoid)
handler :: Settings -> Conduit.Acquire Handler
handler :: Settings -> Acquire Handler
handler Settings
settings = do
case Settings -> [Reporter]
enabledReporters Settings
settings of
[] -> Handler -> Acquire Handler
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure Handler
reportNothingHandler
Reporter
firstReporter : [Reporter]
otherReporters -> do
Handler
firstHandler <- Handler -> Settings -> Reporter -> Acquire Handler
toHandler Handler
reportNothingHandler Settings
settings Reporter
firstReporter
[Handler]
otherHandlers <- (Reporter -> Acquire Handler) -> [Reporter] -> Acquire [Handler]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Handler -> Settings -> Reporter -> Acquire Handler
toHandler Handler
firstHandler Settings
settings) [Reporter]
otherReporters
Handler -> Acquire Handler
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure ([Handler] -> Handler
forall a. Monoid a => [a] -> a
Prelude.mconcat (Handler
firstHandler Handler -> [Handler] -> [Handler]
forall a. a -> [a] -> [a]
: [Handler]
otherHandlers))
reportNothingHandler :: Handler
reportNothingHandler :: Handler
reportNothingHandler = (Text -> TracingSpan -> IO ()) -> Handler
Handler (\Text
_ TracingSpan
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure ())
toHandler :: Handler -> Settings -> Reporter -> Conduit.Acquire Handler
toHandler :: Handler -> Settings -> Reporter -> Acquire Handler
toHandler Handler
backup Settings
settings Reporter {Text
reporterName :: Reporter -> Text
reporterName :: Text
reporterName, Settings -> settings
reporterSettings :: ()
reporterSettings :: Settings -> settings
reporterSettings, settings -> Acquire handler
reporterHandler :: ()
reporterHandler :: settings -> Acquire handler
reporterHandler, handler -> Text -> TracingSpan -> IO ()
reporterReport :: ()
reporterReport :: handler -> Text -> TracingSpan -> IO ()
reporterReport} = do
Handler
handler' <-
Settings -> settings
reporterSettings Settings
settings
settings -> (settings -> Acquire handler) -> Acquire handler
forall a b. a -> (a -> b) -> b
|> settings -> Acquire handler
reporterHandler
Acquire handler
-> (Acquire handler -> Acquire Handler) -> Acquire Handler
forall a b. a -> (a -> b) -> b
|> (handler -> Handler) -> Acquire handler -> Acquire Handler
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map ((Text -> TracingSpan -> IO ()) -> Handler
Handler ((Text -> TracingSpan -> IO ()) -> Handler)
-> (handler -> Text -> TracingSpan -> IO ()) -> handler -> Handler
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< handler -> Text -> TracingSpan -> IO ()
reporterReport)
Handler -> Acquire Handler
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
( (Text -> TracingSpan -> IO ()) -> Handler
Handler
( \Text
requestId TracingSpan
span ->
Handler -> Text -> TracingSpan -> IO ()
report Handler
handler' Text
requestId TracingSpan
span
IO () -> (IO () -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
|> ( \IO ()
io ->
IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a b.
(MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
Exception.withException
IO ()
io
( \SomeException
err ->
SomeException
err
SomeException -> (SomeException -> TracingSpan) -> TracingSpan
forall a b. a -> (a -> b) -> b
|> Text -> TracingSpan -> SomeException -> TracingSpan
reporterExceptionToTracingSpan Text
reporterName TracingSpan
span
TracingSpan -> (TracingSpan -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
|> Handler -> Text -> TracingSpan -> IO ()
report Handler
backup Text
requestId
)
)
IO () -> (IO () -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
|> (SomeException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadCatch m =>
(SomeException -> m a) -> m a -> m a
Exception.handleAny (\SomeException
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure ())
)
)
reporterExceptionToTracingSpan :: Text -> Platform.TracingSpan -> Exception.SomeException -> Platform.TracingSpan
reporterExceptionToTracingSpan :: Text -> TracingSpan -> SomeException -> TracingSpan
reporterExceptionToTracingSpan Text
reporterName TracingSpan
originalTracingSpan SomeException
exceptionDuringReporting =
TracingSpan
Platform.emptyTracingSpan
{ name :: Text
Platform.name = Text
"Failed to report span to " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
reporterName,
succeeded :: Succeeded
Platform.succeeded = SomeException -> Succeeded
Platform.FailedWith SomeException
exceptionDuringReporting,
started :: MonotonicTime
Platform.started = TracingSpan -> MonotonicTime
Platform.finished TracingSpan
originalTracingSpan,
finished :: MonotonicTime
Platform.finished = TracingSpan -> MonotonicTime
Platform.finished TracingSpan
originalTracingSpan,
frame :: Maybe (Text, SrcLoc)
Platform.frame = Maybe (Text, SrcLoc)
forall a. Maybe a
Nothing,
details :: Maybe SomeTracingSpanDetails
Platform.details =
Text -> Maybe SomeTracingSpanDetails -> FailedToReportTracingSpan
FailedToReportTracingSpan
(TracingSpan -> Text
Platform.name TracingSpan
originalTracingSpan)
(TracingSpan -> Maybe SomeTracingSpanDetails
Platform.details TracingSpan
originalTracingSpan)
FailedToReportTracingSpan
-> (FailedToReportTracingSpan -> SomeTracingSpanDetails)
-> SomeTracingSpanDetails
forall a b. a -> (a -> b) -> b
|> FailedToReportTracingSpan -> SomeTracingSpanDetails
forall e. TracingSpanDetails e => e -> SomeTracingSpanDetails
Platform.toTracingSpanDetails
SomeTracingSpanDetails
-> (SomeTracingSpanDetails -> Maybe SomeTracingSpanDetails)
-> Maybe SomeTracingSpanDetails
forall a b. a -> (a -> b) -> b
|> SomeTracingSpanDetails -> Maybe SomeTracingSpanDetails
forall a. a -> Maybe a
Just,
allocated :: Int
Platform.allocated = Int
0,
children :: [TracingSpan]
Platform.children = []
}
data FailedToReportTracingSpan = FailedToReportTracingSpan
{ FailedToReportTracingSpan -> Text
originalTracingSpanName :: Text,
FailedToReportTracingSpan -> Maybe SomeTracingSpanDetails
originalTracingSpanDetails :: Maybe Platform.SomeTracingSpanDetails
}
deriving ((forall x.
FailedToReportTracingSpan -> Rep FailedToReportTracingSpan x)
-> (forall x.
Rep FailedToReportTracingSpan x -> FailedToReportTracingSpan)
-> Generic FailedToReportTracingSpan
forall x.
Rep FailedToReportTracingSpan x -> FailedToReportTracingSpan
forall x.
FailedToReportTracingSpan -> Rep FailedToReportTracingSpan x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep FailedToReportTracingSpan x -> FailedToReportTracingSpan
$cfrom :: forall x.
FailedToReportTracingSpan -> Rep FailedToReportTracingSpan x
Generic)
instance Aeson.ToJSON FailedToReportTracingSpan
instance Platform.TracingSpanDetails FailedToReportTracingSpan
data Reporter where
Reporter ::
{ Reporter -> Text
reporterName :: Text,
()
reporterSettings :: Settings -> settings,
()
reporterHandler :: settings -> Conduit.Acquire handler,
()
reporterReport :: handler -> Text -> Platform.TracingSpan -> Prelude.IO ()
} ->
Reporter
supportedReporters :: [Reporter]
supportedReporters :: [Reporter]
supportedReporters =
[ Text
-> (Settings -> Settings)
-> (Settings -> Acquire Handler)
-> (Handler -> Text -> TracingSpan -> IO ())
-> Reporter
forall settings handler.
Text
-> (Settings -> settings)
-> (settings -> Acquire handler)
-> (handler -> Text -> TracingSpan -> IO ())
-> Reporter
Reporter Text
"stdout" Settings -> Settings
stdout Settings -> Acquire Handler
fileHandler Handler -> Text -> TracingSpan -> IO ()
File.report,
Text
-> (Settings -> ())
-> (() -> Acquire Handler)
-> (Handler -> Text -> TracingSpan -> IO ())
-> Reporter
forall settings handler.
Text
-> (Settings -> settings)
-> (settings -> Acquire handler)
-> (handler -> Text -> TracingSpan -> IO ())
-> Reporter
Reporter Text
"stdout-pretty" Settings -> ()
dev () -> Acquire Handler
devHandler Handler -> Text -> TracingSpan -> IO ()
Dev.report,
Text
-> (Settings -> Settings)
-> (Settings -> Acquire Handler)
-> (Handler -> Text -> TracingSpan -> IO ())
-> Reporter
forall settings handler.
Text
-> (Settings -> settings)
-> (settings -> Acquire handler)
-> (handler -> Text -> TracingSpan -> IO ())
-> Reporter
Reporter Text
"file" Settings -> Settings
file Settings -> Acquire Handler
fileHandler Handler -> Text -> TracingSpan -> IO ()
File.report,
Text
-> (Settings -> Settings)
-> (Settings -> Acquire Handler)
-> (Handler -> Text -> TracingSpan -> IO ())
-> Reporter
forall settings handler.
Text
-> (Settings -> settings)
-> (settings -> Acquire handler)
-> (handler -> Text -> TracingSpan -> IO ())
-> Reporter
Reporter Text
"bugsnag" Settings -> Settings
bugsnag Settings -> Acquire Handler
bugsnagHandler Handler -> Text -> TracingSpan -> IO ()
Bugsnag.report,
Text
-> (Settings -> Settings)
-> (Settings -> Acquire Handler)
-> (Handler -> Text -> TracingSpan -> IO ())
-> Reporter
forall settings handler.
Text
-> (Settings -> settings)
-> (settings -> Acquire handler)
-> (handler -> Text -> TracingSpan -> IO ())
-> Reporter
Reporter Text
"honeycomb" Settings -> Settings
honeycomb Settings -> Acquire Handler
honeycombHandler Handler -> Text -> TracingSpan -> IO ()
Honeycomb.report
]
fileHandler :: File.Settings -> Conduit.Acquire File.Handler
fileHandler :: Settings -> Acquire Handler
fileHandler Settings
settings = IO Handler -> (Handler -> IO ()) -> Acquire Handler
forall a. IO a -> (a -> IO ()) -> Acquire a
Conduit.mkAcquire (Settings -> IO Handler
File.handler Settings
settings) Handler -> IO ()
File.cleanup
devHandler :: () -> Conduit.Acquire Dev.Handler
devHandler :: () -> Acquire Handler
devHandler ()
_ = IO Handler -> (Handler -> IO ()) -> Acquire Handler
forall a. IO a -> (a -> IO ()) -> Acquire a
Conduit.mkAcquire IO Handler
Dev.handler Handler -> IO ()
Dev.cleanup
bugsnagHandler :: Bugsnag.Settings -> Conduit.Acquire Bugsnag.Handler
bugsnagHandler :: Settings -> Acquire Handler
bugsnagHandler Settings
settings = IO Handler -> Acquire Handler
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Conduit.liftIO (Settings -> IO Handler
Bugsnag.handler Settings
settings)
honeycombHandler :: Honeycomb.Settings -> Conduit.Acquire Honeycomb.Handler
honeycombHandler :: Settings -> Acquire Handler
honeycombHandler Settings
settings = IO Handler -> Acquire Handler
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Conduit.liftIO (Settings -> IO Handler
Honeycomb.handler Settings
settings)
data Settings = Settings
{
Settings -> [Reporter]
enabledReporters :: [Reporter],
Settings -> Settings
file :: File.Settings,
Settings -> Settings
bugsnag :: Bugsnag.Settings,
Settings -> Settings
honeycomb :: Honeycomb.Settings,
Settings -> ()
dev :: ()
}
stdout :: Settings -> File.Settings
stdout :: Settings -> Settings
stdout Settings
settings = (Settings -> Settings
file Settings
settings) {logFile :: FilePath
File.logFile = FilePath
"/dev/stdout"}
decoder :: Environment.Decoder Settings
decoder :: Decoder Settings
decoder =
([Reporter] -> Settings -> Settings -> Settings -> () -> Settings)
-> Decoder
([Reporter] -> Settings -> Settings -> Settings -> () -> Settings)
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Reporter] -> Settings -> Settings -> Settings -> () -> Settings
Settings
Decoder
([Reporter] -> Settings -> Settings -> Settings -> () -> Settings)
-> (Decoder
([Reporter] -> Settings -> Settings -> Settings -> () -> Settings)
-> Decoder (Settings -> Settings -> Settings -> () -> Settings))
-> Decoder (Settings -> Settings -> Settings -> () -> Settings)
forall a b. a -> (a -> b) -> b
|> Decoder [Reporter]
-> Decoder
([Reporter] -> Settings -> Settings -> Settings -> () -> Settings)
-> Decoder (Settings -> Settings -> Settings -> () -> Settings)
forall (m :: * -> *) a b. Applicative m => m a -> m (a -> b) -> m b
andMap Decoder [Reporter]
reportersDecoder
Decoder (Settings -> Settings -> Settings -> () -> Settings)
-> (Decoder (Settings -> Settings -> Settings -> () -> Settings)
-> Decoder (Settings -> Settings -> () -> Settings))
-> Decoder (Settings -> Settings -> () -> Settings)
forall a b. a -> (a -> b) -> b
|> Decoder Settings
-> Decoder (Settings -> Settings -> Settings -> () -> Settings)
-> Decoder (Settings -> Settings -> () -> Settings)
forall (m :: * -> *) a b. Applicative m => m a -> m (a -> b) -> m b
andMap Decoder Settings
File.decoder
Decoder (Settings -> Settings -> () -> Settings)
-> (Decoder (Settings -> Settings -> () -> Settings)
-> Decoder (Settings -> () -> Settings))
-> Decoder (Settings -> () -> Settings)
forall a b. a -> (a -> b) -> b
|> Decoder Settings
-> Decoder (Settings -> Settings -> () -> Settings)
-> Decoder (Settings -> () -> Settings)
forall (m :: * -> *) a b. Applicative m => m a -> m (a -> b) -> m b
andMap Decoder Settings
Bugsnag.decoder
Decoder (Settings -> () -> Settings)
-> (Decoder (Settings -> () -> Settings)
-> Decoder (() -> Settings))
-> Decoder (() -> Settings)
forall a b. a -> (a -> b) -> b
|> Decoder Settings
-> Decoder (Settings -> () -> Settings) -> Decoder (() -> Settings)
forall (m :: * -> *) a b. Applicative m => m a -> m (a -> b) -> m b
andMap Decoder Settings
Honeycomb.decoder
Decoder (() -> Settings)
-> (Decoder (() -> Settings) -> Decoder Settings)
-> Decoder Settings
forall a b. a -> (a -> b) -> b
|> Decoder () -> Decoder (() -> Settings) -> Decoder Settings
forall (m :: * -> *) a b. Applicative m => m a -> m (a -> b) -> m b
andMap (() -> Decoder ()
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure ())
reportersDecoder :: Environment.Decoder [Reporter]
reportersDecoder :: Decoder [Reporter]
reportersDecoder =
Variable -> Parser [Reporter] -> Decoder [Reporter]
forall a. Variable -> Parser a -> Decoder a
Environment.variable
Variable :: Text -> Text -> Text -> Variable
Environment.Variable
{ name :: Text
Environment.name = Text
"LOG_ENABLED_LOGGERS",
description :: Text
Environment.description = Text
"Comma-separated list of logging destinations.",
defaultValue :: Text
Environment.defaultValue = Text
"stdout-pretty"
}
(Parser Text
-> (Text -> Result Text [Reporter]) -> Parser [Reporter]
forall a b. Parser a -> (a -> Result Text b) -> Parser b
Environment.custom Parser Text
Environment.text Text -> Result Text [Reporter]
reportersParser)
reportersParser :: Text -> Result Text [Reporter]
reportersParser :: Text -> Result Text [Reporter]
reportersParser Text
reportersString = do
Set Text
names <-
Text
reportersString
Text -> (Text -> List Text) -> List Text
forall a b. a -> (a -> b) -> b
|> Text -> Text -> List Text
Text.split Text
","
List Text
-> (List Text -> Result Text (List Text))
-> Result Text (List Text)
forall a b. a -> (a -> b) -> b
|> (Text -> Result Text Text) -> List Text -> Result Text (List Text)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> Result Text Text
parseLogger
Result Text (List Text)
-> (Result Text (List Text) -> Result Text (Set Text))
-> Result Text (Set Text)
forall a b. a -> (a -> b) -> b
|> (List Text -> Set Text)
-> Result Text (List Text) -> Result Text (Set Text)
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map List Text -> Set Text
forall comparable.
Ord comparable =>
List comparable -> Set comparable
Set.fromList
[Reporter]
supportedReporters
[Reporter] -> ([Reporter] -> [Reporter]) -> [Reporter]
forall a b. a -> (a -> b) -> b
|> (Reporter -> Bool) -> [Reporter] -> [Reporter]
forall a. (a -> Bool) -> List a -> List a
List.filter (\Reporter
reporter -> Text -> Set Text -> Bool
forall comparable.
Ord comparable =>
comparable -> Set comparable -> Bool
Set.member (Reporter -> Text
reporterName Reporter
reporter) Set Text
names)
[Reporter]
-> ([Reporter] -> Result Text [Reporter]) -> Result Text [Reporter]
forall a b. a -> (a -> b) -> b
|> [Reporter] -> Result Text [Reporter]
forall error value. value -> Result error value
Ok
parseLogger :: Text -> Result Text Text
parseLogger :: Text -> Result Text Text
parseLogger Text
name =
let normalizedName :: Text
normalizedName = Text -> Text
Text.trim (Text -> Text
Text.toLower Text
name)
supportedNames :: Set Text
supportedNames =
[Reporter]
supportedReporters
[Reporter] -> ([Reporter] -> List Text) -> List Text
forall a b. a -> (a -> b) -> b
|> (Reporter -> Text) -> [Reporter] -> List Text
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map Reporter -> Text
reporterName
List Text -> (List Text -> Set Text) -> Set Text
forall a b. a -> (a -> b) -> b
|> List Text -> Set Text
forall comparable.
Ord comparable =>
List comparable -> Set comparable
Set.fromList
in if Text -> Set Text -> Bool
forall comparable.
Ord comparable =>
comparable -> Set comparable -> Bool
Set.member Text
normalizedName Set Text
supportedNames
then Text -> Result Text Text
forall error value. value -> Result error value
Ok Text
normalizedName
else Text -> Result Text Text
forall error value. error -> Result error value
Err (Text
"Unknown reporter: " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
normalizedName)