Browse Source

Merge pull request #408 from input-output-hk/405-trace-transformer-class

[#405] trace transformer class
master
Alexander Diemand 3 years ago committed by GitHub
parent
commit
38d601eb3d
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
  1. BIN
      docs/IOHK-Monitoring.pdf
  2. 7
      docs/references.fmt
  3. 5
      iohk-monitoring/src/Cardano/BM/Backend/Log.lhs
  4. 6
      iohk-monitoring/src/Cardano/BM/Backend/Prometheus.lhs
  5. 154
      iohk-monitoring/src/Cardano/BM/Data/Tracer.lhs
  6. 15
      iohk-monitoring/src/Cardano/BM/Tracing.lhs
  7. 79
      iohk-monitoring/test/Cardano/BM/Test/Structured.lhs
  8. 1
      iohk-monitoring/test/Cardano/BM/Test/Trace.lhs
  9. 10
      iohk-monitoring/test/Cardano/BM/Test/Tracer.lhs
  10. 2
      iohk-monitoring/test/Test.lhs

BIN
docs/IOHK-Monitoring.pdf

Binary file not shown.

7
docs/references.fmt

@ -205,10 +205,12 @@
%format Monitor = "\hyperref[code:Monitor]{Monitor}"
%format MonitorState = "\hyperref[code:MonitorState]{MonitorState}"
%format evalMonitoringAction = "\hyperref[code:evalMonitoringAction]{evalMonitoringAction}"
%format Monitor = "\hyperref[code:Monitor]{Monitor}"
%format spawnPrometheus = "\hyperref[code:spawnPrometheus]{spawnPrometheus}"
%format passToPrometheus = "\hyperref[code:passToPrometheus]{passToPrometheus}"
%format TraceAcceptor = "\hyperref[code:TraceAcceptor]{TraceAcceptor}"
%format TraceForwarder = "\hyperref[code:TraceForwarder]{TraceForwarder}"
%format Cardano.BM.Arbitrary.Aggregated = "\hyperref[code:Cardano.BM.Arbitrary.Aggregated]{Cardano.BM.Arbitrary.Aggregated}"
%format Cardano.BM.Test.LogItem = "\hyperref[code:Cardano.BM.Test.LogItem]{Cardano.BM.Test.LogItem}"
%format Cardano.BM.Test.Aggregated = "\hyperref[code:Cardano.BM.Test.Aggregated]{Cardano.BM.Test.Aggregated}"
%format Cardano.BM.Test.STM = "\hyperref[code:Cardano.BM.Test.STM]{Cardano.BM.Test.STM}"
%format Cardano.BM.Test.Trace = "\hyperref[code:Cardano.BM.Test.Trace]{Cardano.BM.Test.Trace}"
@ -231,7 +233,8 @@
%format propNaming = "\hyperref[code:propNaming]{propNaming}"
%format propCleanup = "\hyperref[code:propCleanup]{propCleanup}"
%format Cardano.BM.Test.Structured = "\hyperref[code:Cardano.BM.Test.Structured]{Cardano.BM.Test.Structured}"
%format logText = "\hyperref[code:logText]{logText}"
%format logSimpleText = "\hyperref[code:logSimpleText]{logSimpleText}"
%format logStructured = "\hyperref[code:logStructured]{logStructured}"
%format Cardano.BM.Test.Tracer = "\hyperref[code:Cardano.BM.Test.Tracer]{Cardano.BM.Test.Tracer}"
%endif

5
iohk-monitoring/src/Cardano/BM/Backend/Log.lhs

@ -43,6 +43,7 @@ import Data.Text (Text, isPrefixOf, pack, unpack)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder (Builder, fromText, toLazyText)
import Data.Text.Lazy.Encoding as TL (decodeUtf8)
import qualified Data.Text.Lazy.IO as TIO
import Data.Time (diffUTCTime)
import Data.Time.Clock (UTCTime, getCurrentTime)
@ -292,8 +293,8 @@ passN backend katip (LogObject loname lometa loitem) = do
(severity lometa, text, maylo)
(LogError text) ->
(severity lometa, text, Nothing)
(LogStructured _) ->
(severity lometa, "", Just loitem)
(LogStructured s) ->
(severity lometa, TL.toStrict $ decodeUtf8 s, Nothing {- Just loitem -})
(LogValue name value) ->
(severity lometa, name <> " = " <> pack (showSI value), Nothing)
(ObserveDiff _) ->

6
iohk-monitoring/src/Cardano/BM/Backend/Prometheus.lhs

@ -2,8 +2,6 @@
\subsection{Cardano.BM.Backend.Prometheus}
\label{module:Cardano.BM.Backend.Prometheus}
%if style == newcode
\begin{code}
@ -26,7 +24,9 @@ import System.Remote.Monitoring.Prometheus (registerEKGStore,
\end{code}
%endif
\subsubsection{Spawn Prometheus client from existing EKG server}\label{code:Monitor}\index{Monitor}
\subsubsection{Spawn Prometheus client from existing EKG server}
\label{code:spawnPrometheus}\index{spawnPrometheus}
\label{code:passToPrometheus}\index{passToPrometheus}
\begin{code}
spawnPrometheus :: EKG.Server -> Port -> IO (Async.Async ())

154
iohk-monitoring/src/Cardano/BM/Data/Tracer.lhs

@ -4,34 +4,53 @@
%if style == newcode
\begin{code}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Cardano.BM.Data.Tracer
( Tracer (..)
, Transformable (..)
, ToLogObject (..)
, ToObject (..)
, traceWith
-- , Contravariant(..)
-- * tracer transformers
, natTracer
, nullTracer
, stdoutTracer
, debugTracer
, showTracing
, trStructured
-- * conditional tracing
, condTracing
, condTracingM
-- * severity transformers
, severityDebug
, severityInfo
, severityNotice
, severityWarning
, severityError
, severityCritical
, severityAlert
, severityEmergency
-- * privacy annotation transformers
, annotateConfidential
, annotatePublic
) where
import Data.Aeson (Object, ToJSON (..), Value (..))
import Control.Monad.IO.Class (MonadIO (..))
import Data.Aeson (Object, ToJSON (..), Value (..), encode)
import qualified Data.HashMap.Strict as HM
import Data.Text (Text)
import Data.Text (Text, pack, unpack)
import Data.Word (Word64)
import Cardano.BM.Data.Aggregated
import Cardano.BM.Data.LogItem (LogObject (..), LOContent (..),
PrivacyAnnotation (..), mkLOMeta)
LOMeta (..), PrivacyAnnotation (..), mkLOMeta)
import Cardano.BM.Data.Severity (Severity (..))
import Control.Tracer
@ -89,15 +108,12 @@ for further processing of the messages.
The function |toLogObject| can be specialized for various environments
\begin{code}
class Monad m => ToLogObject m where
toLogObject :: ToObject a => Tracer m (LogObject a) -> Tracer m a
toLogObject :: (ToObject a, Transformable a m b) => Tracer m (LogObject a) -> Tracer m b
instance ToLogObject IO where
toLogObject :: ToObject a => Tracer IO (LogObject a) -> Tracer IO a
toLogObject tr = Tracer $ \a -> do
lo <- LogObject <$> pure ""
<*> (mkLOMeta Debug Public)
<*> pure (LogMessage a)
traceWith tr lo
toLogObject :: (MonadIO m, ToObject a, Transformable a m b) => Tracer m (LogObject a) -> Tracer m b
toLogObject tr =
trTransformer tr
\end{code}
@ -133,9 +149,9 @@ class ToJSON a => ToObject a where
toObject :: a -> Object
default toObject :: a -> Object
toObject v = case toJSON v of
Object o -> o
Object o -> o
s@(String _) -> HM.singleton "string" s
_ -> mempty
_ -> mempty
instance ToObject () where
toObject _ = mempty
@ -146,3 +162,107 @@ instance ToJSON a => ToObject (LogObject a)
instance ToJSON a => ToObject (LOContent a)
\end{code}
\subsubsection{A transformable Tracer}
Parameterised over the source Tracer (\emph{b}) and
the target Tracer (\emph{a}).
\begin{code}
class Monad m => Transformable a m b where
trTransformer :: Tracer m (LogObject a) -> Tracer m b
default trTransformer :: Tracer m (LogObject a) -> Tracer m b
trTransformer _ = nullTracer
trFromIntegral :: (Integral b, MonadIO m) => Tracer m (LogObject a) -> Text -> Tracer m b
trFromIntegral tr name = Tracer $ \arg ->
traceWith tr =<<
LogObject <$> pure ""
<*> (mkLOMeta Debug Public)
<*> pure (LogValue name $ PureI $ fromIntegral arg)
trFromReal :: (Real b, MonadIO m) => Tracer m (LogObject a) -> Text -> Tracer m b
trFromReal tr name = Tracer $ \arg ->
traceWith tr =<<
LogObject <$> pure ""
<*> (mkLOMeta Debug Public)
<*> pure (LogValue name $ PureD $ realToFrac arg)
instance Transformable a IO Int where
trTransformer tr = trFromIntegral tr "int"
instance Transformable a IO Integer where
trTransformer tr = trFromIntegral tr "integer"
instance Transformable a IO Word64 where
trTransformer tr = trFromIntegral tr "word64"
instance Transformable a IO Double where
trTransformer tr = trFromReal tr "double"
instance Transformable a IO Float where
trTransformer tr = trFromReal tr "float"
instance Transformable Text IO Text where
trTransformer tr = Tracer $ \arg ->
traceWith tr =<<
LogObject <$> pure ""
<*> (mkLOMeta Debug Public)
<*> pure (LogMessage arg)
instance Transformable String IO String where
trTransformer tr = Tracer $ \arg ->
traceWith tr =<<
LogObject <$> pure ""
<*> (mkLOMeta Debug Public)
<*> pure (LogMessage arg)
instance Transformable Text IO String where
trTransformer tr = Tracer $ \arg ->
traceWith tr =<<
LogObject <$> pure ""
<*> (mkLOMeta Debug Public)
<*> pure (LogMessage $ pack arg)
instance Transformable String IO Text where
trTransformer tr = Tracer $ \arg ->
traceWith tr =<<
LogObject <$> pure ""
<*> (mkLOMeta Debug Public)
<*> pure (LogMessage $ unpack arg)
trStructured :: (MonadIO m, ToJSON b) => Tracer m (LogObject a) -> Tracer m b
trStructured tr = Tracer $ \arg ->
traceWith tr =<<
LogObject <$> pure ""
<*> (mkLOMeta Debug Public)
<*> pure (LogStructured $ encode arg)
\end{code}
\subsubsection{Transformers for setting severity level}
The log |Severity| level of a LogObject can be altered.
\begin{code}
setSeverity :: Tracer m (LogObject a) -> Severity -> Tracer m (LogObject a)
setSeverity tr sev = Tracer $ \lo@(LogObject _nm meta@(LOMeta _ts _tid _sev _pr) _lc) ->
traceWith tr $ lo { loMeta = meta { severity = sev } }
severityDebug, severityInfo, severityNotice,
severityWarning, severityError, severityCritical,
severityAlert, severityEmergency :: Tracer m (LogObject a) -> Tracer m (LogObject a)
severityDebug tr = setSeverity tr Debug
severityInfo tr = setSeverity tr Info
severityNotice tr = setSeverity tr Notice
severityWarning tr = setSeverity tr Warning
severityError tr = setSeverity tr Error
severityCritical tr = setSeverity tr Critical
severityAlert tr = setSeverity tr Alert
severityEmergency tr = setSeverity tr Emergency
\end{code}
\subsubsection{Transformers for setting privacy annotation}
The privacy annotation (|PrivacyAnnotation|) of the LogObject can
be altered with the following functions.
\begin{code}
setPrivacy :: Tracer m (LogObject a) -> PrivacyAnnotation -> Tracer m (LogObject a)
setPrivacy tr prannot = Tracer $ \lo@(LogObject _nm meta@(LOMeta _ts _tid _sev _pr) _lc) ->
traceWith tr $ lo { loMeta = meta { privacy = prannot } }
annotateConfidential, annotatePublic :: Tracer m (LogObject a) -> Tracer m (LogObject a)
annotateConfidential tr = setPrivacy tr Confidential
annotatePublic tr = setPrivacy tr Public
\end{code}

15
iohk-monitoring/src/Cardano/BM/Tracing.lhs

@ -7,17 +7,28 @@
module Cardano.BM.Tracing
( Tracer (..)
, Trace
, LogObject (..)
, PrivacyAnnotation (..)
, Severity (..)
, ToLogObject (..)
, ToObject (..)
, appendName
, defaultConfigStdout
, defaultConfigTesting
, mkLOMeta
, nullTracer
, traceWith
, setupTrace
, traceWith
) where
import Control.Tracer (Tracer (..), nullTracer, traceWith)
import Cardano.BM.Data.LogItem (LogObject (..))
import Cardano.BM.Configuration.Static (defaultConfigStdout,
defaultConfigTesting)
import Cardano.BM.Data.LogItem (LogObject (..),
PrivacyAnnotation (..), mkLOMeta)
import Cardano.BM.Data.Severity (Severity (..))
import Cardano.BM.Data.Trace (Trace)
import Cardano.BM.Data.Tracer (ToLogObject (..), ToObject (..))
import Cardano.BM.Setup (setupTrace)
import Cardano.BM.Trace (appendName)

79
iohk-monitoring/test/Cardano/BM/Test/Structured.lhs

@ -4,19 +4,29 @@
%if style == newcode
\begin{code}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Cardano.BM.Test.Structured (
tests
) where
import qualified Control.Concurrent.STM as STM
import Data.Aeson (ToJSON (..), Value (..), object, (.=))
import Data.Text (Text)
import Cardano.BM.Configuration.Static (defaultConfigTesting)
import Cardano.BM.Data.Tracer (toLogObject, traceWith)
import Cardano.BM.Configuration.Static
import Cardano.BM.Data.LogItem
import Cardano.BM.Data.Tracer (Tracer (..), Transformable (..),
annotateConfidential, severityNotice,
toLogObject, traceWith, trStructured)
import Cardano.BM.Data.Severity
import Cardano.BM.Data.SubTrace
import Cardano.BM.Backend.Switchboard (MockSwitchboard (..))
import qualified Cardano.BM.Setup as Setup
import Cardano.BM.Trace (Trace)
import Cardano.BM.Test.Trace (TraceConfiguration (..), setupTrace)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion , assertBool, testCase)
@ -26,23 +36,64 @@ import Test.Tasty.HUnit (Assertion , assertBool, testCase)
\begin{code}
tests :: TestTree
tests = testGroup "Testing Structured Logging" [
testCase "logging simple text" logText
-- , testCase "logging data structures" logStructures
]
testCase "logging simple text" logSimpleText
, testCase "logging data structures" logStructured
]
\end{code}
\subsubsection{Simple logging of text.}\label{code:logText}
\subsubsection{Simple logging of text}\label{code:logSimpleText}
\begin{code}
logText :: Assertion
logText = do
logSimpleText :: Assertion
logSimpleText = do
cfg <- defaultConfigTesting
baseTrace :: Trace IO Text <- Setup.setupTrace (Right cfg) "logText"
let logTrace = toLogObject $ baseTrace
baseTrace :: Tracer IO (LogObject Text) <- Setup.setupTrace (Right cfg) "logSimpleText"
traceWith logTrace "This is a simple message."
traceWith logTrace ".. and another!"
traceWith (toLogObject baseTrace) ("This is a simple message." :: Text)
traceWith (toLogObject baseTrace) (".. and another!" :: String)
assertBool "OK" True
\end{code}
\subsubsection{Structured logging}\label{code:logStructured}
\begin{code}
data Pet = Pet { name :: Text, age :: Int}
deriving (Show)
instance ToJSON Pet where
toJSON (Pet n a) =
object [ "kind" .= String "Pet"
, "name" .= toJSON n
, "age" .= toJSON a ]
instance Transformable Text IO Pet where
trTransformer = trStructured -- transform to JSON structure
logStructured :: Assertion
logStructured = do
cfg <- defaultConfigStdout
-- baseTrace :: Tracer IO (LogObject Text) <- Setup.setupTrace (Right cfg) "logStructured"
msgs <- STM.newTVarIO []
baseTrace <- setupTrace $ TraceConfiguration cfg (MockSB msgs) "logStructured" Neutral
let noticeTracer = severityNotice baseTrace
let confidentialTracer = annotateConfidential baseTrace
traceWith (toLogObject noticeTracer) (42 :: Integer)
traceWith (toLogObject confidentialTracer) (Pet "bella" 8)
ms <- STM.readTVarIO msgs
assertBool
("assert number of messages traced == 2: " ++ (show $ length ms))
(2 == length ms)
assertBool
("verify traced integer with severity Notice: " ++ (show ms))
(Notice == severity (loMeta (ms !! 1)))
assertBool
("verify traced structure with privacy annotation Confidential: " ++ (show ms))
(Confidential == privacy (loMeta (ms !! 0)))
\end{code}

1
iohk-monitoring/test/Cardano/BM/Test/Trace.lhs

@ -10,6 +10,7 @@
module Cardano.BM.Test.Trace (
TraceConfiguration (..)
, setupTrace
, tests
) where

10
iohk-monitoring/test/Cardano/BM/Test/Tracer.lhs

@ -83,12 +83,12 @@ tracingInNamedContext = do
callFun2 :: Tracer IO (LogObject Text) -> IO Int
callFun2 logTrace = do
let logTrace' = appendNamed' "fun2" logTrace
traceWith (toLogObject logTrace') "in function 2"
traceWith (toLogObject logTrace') ("in function 2" :: Text)
callFun3 logTrace'
callFun3 :: Tracer IO (LogObject Text) -> IO Int
callFun3 logTrace = do
traceWith (toLogObject $ appendNamed' "fun3" $ logTrace) "in function 3"
traceWith (toLogObject $ appendNamed' "fun3" $ logTrace) ("in function 3" :: Text)
return 42
\end{code}
@ -129,15 +129,15 @@ filterAppendNameTracing test name = (appendNamed' name) . (condTracingM test)
tracingWithPredicateFilter :: Assertion
tracingWithPredicateFilter = do
let appendF = filterAppendNameTracing oracle
logTrace = appendF "example4" (renderNamedItemTracing' stdoutTracer)
logTrace :: Tracer IO (LogObject Text) = appendF "example4" (renderNamedItemTracing' stdoutTracer)
traceWith (toLogObject logTrace) ("Hello" :: String)
let logTrace' = appendF "inner" logTrace
traceWith (toLogObject logTrace') "World"
traceWith (toLogObject logTrace') ("World" :: String)
let logTrace'' = appendF "innest" logTrace'
traceWith (toLogObject logTrace'') "!!"
traceWith (toLogObject logTrace'') ("!!" :: String)
assertBool "OK" True
where

2
iohk-monitoring/test/Test.lhs

@ -56,6 +56,7 @@ tests =
\section{Tests}
%include ../test/Cardano/BM/Test/LogItem.lhs
%include ../test/Cardano/BM/Test/Aggregated.lhs
%include ../test/Cardano/BM/Test/STM.lhs
%include ../test/Cardano/BM/Test/Trace.lhs
@ -63,3 +64,4 @@ tests =
%include ../test/Cardano/BM/Test/Rotator.lhs
%include ../test/Cardano/BM/Test/Structured.lhs
%include ../test/Cardano/BM/Test/Tracer.lhs
%include ../test/Cardano/BM/Test/Monitoring.lhs

Loading…
Cancel
Save