1+ {-# LANGUAGE ExplicitNamespaces #-}
12{-# LANGUAGE CPP #-}
3+ {-# LANGUAGE GADTs #-}
4+ {-# LANGUAGE LambdaCase #-}
25
36module Cardano.Tracer.Environment
47 ( TracerEnv (.. )
58 , TracerEnvRTView (.. )
9+ , RawMessage (.. )
10+ , InternalMessage (.. )
11+ , Tag (.. )
12+ , CardanoTracerMessage
13+ , onRawMessage
14+ , onInternal
15+ , onUser
16+ , blockUntilShutdown
17+ , dieOnShutdown
18+ , forever'tilShutdown
19+
20+ , type MessageHandler
21+ , handleMessage
22+ , handleMessages
23+ , handleMessageWithShutdown
24+ , handleMessagesWithShutdown
25+ , handleShutdown
26+ , handleInternal
27+ , handleUser
628 ) where
729
830import Cardano.Logging.Types
31+ import Cardano.Logging.Resources.Types (ResourceStats )
932import Cardano.Tracer.Configuration
1033#if RTVIEW
1134import Cardano.Tracer.Handlers.Notifications.Types
@@ -16,10 +39,14 @@ import Cardano.Tracer.Handlers.State.TraceObjects
1639import Cardano.Tracer.MetaTrace
1740import Cardano.Tracer.Types
1841
42+ import Control.Concurrent (myThreadId )
43+ import Control.Exception (AsyncException (ThreadKilled ), throwTo )
44+ import Control.Concurrent.Chan.Unagi (InChan , OutChan , readChan , tryReadChan , tryRead )
1945import Control.Concurrent.Extra (Lock )
46+ import Data.Foldable (traverse_ )
2047import Data.Text (Text )
2148import Data.Text.Lazy.Builder (Builder )
22-
49+ import Data.Kind ( Type )
2350
2451-- | Environment for all functions.
2552data TracerEnv = TracerEnv
@@ -36,6 +63,7 @@ data TracerEnv = TracerEnv
3663 , teRegistry :: ! HandleRegistry
3764 , teStateDir :: ! (Maybe FilePath
3865 , teMetricsHelp :: ! [(Text , Builder )]
66+ , teInChan :: ! (InChan (CardanoTracerMessage () ))
3967 }
4068
4169#if RTVIEW
@@ -51,3 +79,168 @@ data TracerEnvRTView = TracerEnvRTView
5179#else
5280data TracerEnvRTView = TracerEnvRTView
5381#endif
82+
83+ type CardanoTracerMessage userMsg = RawMessage InternalMessage userMsg
84+
85+ type RawMessage :: Type -> Type -> Type
86+ data RawMessage internal user
87+ = Shutdown
88+ | InternalMessage internal
89+ | UserMessage user
90+
91+ type InternalMessage :: Type
92+ data InternalMessage where
93+ HandleInternalMessage :: Tag ex -> (ex -> IO () ) -> InternalMessage
94+
95+ type Tag :: Type -> Type
96+ data Tag a where
97+ ResourceStatsTag :: Tag (ResourceStats , Trace IO TracerTrace )
98+
99+ -- | Polls the channel until a @Shutdown@ message is received.
100+ blockUntilShutdown :: OutChan (RawMessage internal user ) -> IO ()
101+ blockUntilShutdown outChan = go where
102+ go :: IO ()
103+ go = readChan outChan >>= \ case
104+ Shutdown -> pure ()
105+ _ -> go
106+
107+ -- | Serves a channel with a composable `MessageHandler'-function.
108+ --
109+ -- @
110+ -- onInternal = handleMessageWithShutdown . handleInternal
111+ -- onUser = handleMessageWithShutdown . handleUser
112+ -- dieOnShutdown = handleMessageWithShutdown mempty
113+ -- @
114+ --
115+ -- These handlers are composable with the function Monoid instance.
116+ --
117+ -- @
118+ -- handleMessage (handleInternal handle1 <> handleUser handle2)
119+ -- = handleMessages [handleInternal handle1, handleUser handle2]
120+ -- @
121+ --
122+ -- Where @handleMessage (a <> b <> c)@ is equivalent to @handleMessages [a, b, c]@.
123+ --
124+ -- Instantiations:
125+ --
126+ -- @
127+ -- handleMessage :: (RawMessage internal user -> IO ()) -> OutChan (RawMessage internal user) -> IO ()
128+ -- handleMessage :: MessageHandler internal user -> OutChan (RawMessage internal user) -> IO ()
129+ -- @
130+ handleMessage :: (chan -> IO () ) -> OutChan chan -> IO ()
131+ handleMessage handler outChan = do
132+ (element, _out) <- tryReadChan outChan
133+ tryRead element >>= traverse_ @ Maybe
134+
135+ handleMessages :: [MessageHandler internal user ] -> OutChan (RawMessage internal user ) -> IO ()
136+ handleMessages = handleMessage . mconcat
137+
138+ handleMessageWithShutdown :: MessageHandler internal user -> OutChan (RawMessage internal user ) -> IO ()
139+ handleMessageWithShutdown handler = handleMessage (handler <> handleShutdown)
140+
141+ handleMessagesWithShutdown :: [MessageHandler internal user ] -> OutChan (RawMessage internal user ) -> IO ()
142+ handleMessagesWithShutdown = handleMessageWithShutdown . mconcat
143+
144+ onRawMessage :: (internal -> IO () ) -> (user -> IO () ) -> OutChan (RawMessage internal user ) -> IO ()
145+ onRawMessage internal user = handleMessagesWithShutdown
146+ [ handleInternal internal
147+ , handleUser user
148+ ]
149+
150+ -- onInternal = (`onRawMessage` mempty)
151+ onInternal :: (internal -> IO () ) -> OutChan (RawMessage internal user ) -> IO ()
152+ onInternal = handleMessageWithShutdown . handleInternal
153+
154+ -- onUser = (mempty `onRawMessage`)
155+ onUser :: (user -> IO () ) -> OutChan (RawMessage internal user ) -> IO ()
156+ onUser = handleMessageWithShutdown . handleUser
157+
158+ -- dieOnShutdown = onRawMessage mempty mempty
159+ dieOnShutdown :: OutChan (RawMessage internal user ) -> IO ()
160+ dieOnShutdown = handleMessagesWithShutdown []
161+
162+ forever'tilShutdown :: OutChan (RawMessage internal user ) -> IO () -> IO ()
163+ forever'tilShutdown outChan action = do
164+ (element, _out) <- tryReadChan outChan
165+ tryRead element >>= \ case
166+ Just Shutdown -> pure ()
167+ Just _ -> forever'tilShutdown outChan action
168+ Nothing -> action *> forever'tilShutdown outChan action
169+
170+ -- | Composable handlers, with a functional Monoidal instance,
171+ -- via 'Ap (RawMessage internal user ->) (IO ())':
172+ --
173+ -- @
174+ -- instance Semigroup (MessageHandler internal user) where
175+ -- (<>) = liftA2 (<>)
176+ -- instance Monoid (MessageHandler internal user) where
177+ -- mempty = pure mempty
178+ -- @
179+ --
180+ -- The handler functions are composed together, the incoming argument
181+ -- gets passed pointwise to each function.
182+ --
183+ -- @
184+ -- (handleShutdown <> handleInternal internal <> handleUser user) Shutdown
185+ -- = handleShutdown Shutdown <> handleInternal internal Shutdown <> handleUser user Shutdown
186+ -- = handleShutdown Shutdown <> mempty <> mempty
187+ -- = myThreadId >>= (`throwTo` ThreadKilled)
188+ --
189+ -- (handleShutdown <> handleInternal internal <> handleUser user) (InternalMessage message)
190+ -- = handleShutdown (InternalMessage message) <> handleInternal internal (InternalMessage message) <> handleUser user (InternalMessage message)
191+ -- = internal message
192+ -- @
193+
194+ type MessageHandler :: Type -> Type -> Type
195+ type MessageHandler internal user = RawMessage internal user -> IO ()
196+
197+ handleShutdown :: MessageHandler internal user
198+ handleShutdown = \ case
199+ Shutdown -> myThreadId >>= (`throwTo` ThreadKilled )
200+ _ -> mempty
201+
202+ -- handleInternal :: Monoid m => (internal -> m) -> RawMessage internal user -> m
203+ handleInternal :: (internal -> IO () ) -> MessageHandler internal user
204+ handleInternal handler = \ case
205+ InternalMessage internal -> handler internal
206+ _ -> mempty
207+
208+ -- handleUser :: Monoid m => (user -> m) -> RawMessage internal user -> m
209+ handleUser :: (user -> IO () ) -> MessageHandler internal user
210+ handleUser handler = \ case
211+ UserMessage user -> handler user
212+ _ -> mempty
213+
214+ {- | UNSAFE shorthand
215+
216+ doing \case
217+ A -> res
218+
219+ is shorthand for
220+
221+ \case
222+ A -> res
223+ _ -> mempty
224+
225+ -- mapMaybe' = mapMaybe . partialBinding
226+ -- Just 10 >>= partialBinding \10 -> "10"
227+ partialBinding :: (a -> b) -> (a -> Maybe b)
228+ partialBinding f a = unsafePerformIO do
229+ try @PatternMatchFail (evaluate (f a)) >>= \case
230+ Left (PatternMatchFail err)
231+ | any (`isSuffixOf` err)
232+ [ ": Non-exhaustive patterns in lambda\n"
233+ , ": Non-exhaustive patterns in \\case\n"
234+ , ": Non-exhaustive patterns in \\cases\n"
235+ ]
236+ -> pure @IO (Nothing)
237+ Left err ->
238+ throwIO err
239+ Right b ->
240+ pure @IO (Just b)
241+
242+ doing :: Monoid m => (a -> m) -> (a -> m)
243+ doing f a = case partialBinding f a of
244+ Nothing -> mempty
245+ Just b -> b
246+ -}
0 commit comments