/
ReForwarder.hs
119 lines (100 loc) · 4.26 KB
/
ReForwarder.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
-- | This module initializes a reforwarding service for use by
-- cardano-tracer. It could [re-] serve the three miniprotocols on
-- a new local socket. Currently,
-- - it creates a new Datapoint store: this has a single datapoint
-- empty but datapoints could be added here.
-- - it reforwards trace messages to the new socket, optionally
-- filtering trace messages.
-- - it does not (currently) reforward EKG to the new socket.
module Cardano.Tracer.Handlers.ReForwarder
( initReForwarder
) where
import Control.Monad(when)
import Data.Aeson
import Data.List (isPrefixOf)
import qualified Data.Text as Text
import GHC.Generics
import Ouroboros.Network.Magic (NetworkMagic (..))
import Ouroboros.Network.NodeToClient (withIOManager)
import Cardano.Logging.Forwarding
import Cardano.Logging.Trace
import Cardano.Logging.Tracer.DataPoint
import Cardano.Logging.Types qualified as Log
import Trace.Forward.Utils.DataPoint
import Trace.Forward.Utils.TraceObject (writeToSink,ForwardSink)
import Cardano.Tracer.Configuration
import Cardano.Tracer.MetaTrace
-- | Initialize the reforwarding service if configured to be active.
-- Returns
-- - the function by which logging sources report their log messages
-- - the DataPoint tracer (for the data point store associated with
-- the forwarding trace server).
initReForwarder :: TracerConfig
-> Log.Trace IO TracerTrace
-> IO ( [Log.TraceObject] -> IO ()
, Trace IO DataPoint
)
initReForwarder TracerConfig{networkMagic, hasForwarding}
teTracer = do
mForwarding <- case hasForwarding of
Nothing -> pure Nothing
Just x -> case x of
(ConnectTo{}, _, _) ->
error "initReForwarder: unsupported mode of operation: ConnectTo. Use AcceptAt."
(AcceptAt (LocalSocket socket), mFwdNames, forwConf) -> do
(fwdsink, dpStore :: DataPointStore) <- withIOManager $ \iomgr -> do
traceWith teTracer TracerStartedReforwarder
initForwarding iomgr forwConf
(NetworkMagic networkMagic)
Nothing
(Just (socket, Log.Responder))
pure $ Just ( filteredWriteToSink fwdsink mFwdNames
, dataPointTracer @IO dpStore
)
let traceDP = case mForwarding of
Just (_,tr) -> tr
Nothing -> mempty
modeDP :: Trace IO ReforwarderMode
<- mkDataPointTracer traceDP
traceWith modeDP $ RM "running"
-- Note: currently the only trace for this datapoint
let writesToSink' =
case mForwarding of
Just (writeToSink',_) ->
mapM_ writeToSink'
_ ->
const $ return ()
return (writesToSink', traceDP)
filteredWriteToSink :: ForwardSink Log.TraceObject
-> Maybe [[Text.Text]]
-> Log.TraceObject -> IO ()
filteredWriteToSink fwdsink mFwdNames =
case mFwdNames of
Nothing ->
writeToSink fwdsink
Just fwdNames ->
\logObj->
when (any (`isPrefixOf` Log.toNamespace logObj) fwdNames) $
writeToSink fwdsink logObj
------------------------------------------------------------------------------
-- ReforwarderMode datapoint: type and boilerplate
--
-- | Mode of the reforwarder
newtype ReforwarderMode = RM String
deriving (Eq,Ord,Read,Show,Generic)
deriving instance ToJSON ReforwarderMode
-- | give the 'ReforwarderMode' type a place in the Datapoint Namespace:
instance Log.MetaTrace ReforwarderMode
where
namespaceFor _ = Log.Namespace [] ["Reforwarder","Mode"]
severityFor _ _ = Just Info
documentFor _ = Just "the mode of the reforwarder"
allNamespaces = [ Log.namespaceFor (undefined :: ReforwarderMode) ]