From 394ceb35c9c3a64727d47196b62746d798451c6c Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 9 May 2022 18:58:57 +0200 Subject: [PATCH 1/4] Updated trace-forward library --- cabal.project | 14 ++-- .../Forward/Protocol/DataPoint/Acceptor.hs | 11 ++- .../Trace/Forward/Protocol/DataPoint/Codec.hs | 35 ++++---- .../Forward/Protocol/DataPoint/Forwarder.hs | 12 ++- .../Trace/Forward/Protocol/DataPoint/Type.hs | 60 +++++--------- .../Forward/Protocol/TraceObject/Acceptor.hs | 21 +++-- .../Forward/Protocol/TraceObject/Codec.hs | 51 ++++++------ .../Forward/Protocol/TraceObject/Forwarder.hs | 17 ++-- .../Forward/Protocol/TraceObject/Type.hs | 82 ++++++++----------- .../Trace/Forward/Run/TraceObject/Acceptor.hs | 7 +- .../Forward/Run/TraceObject/Forwarder.hs | 9 +- .../src/Trace/Forward/Utils/TraceObject.hs | 4 +- .../Trace/Forward/Protocol/DataPoint/Codec.hs | 11 ++- .../Trace/Forward/Protocol/DataPoint/Tests.hs | 16 ++-- .../Forward/Protocol/TraceObject/Codec.hs | 21 +++-- .../Forward/Protocol/TraceObject/Examples.hs | 6 +- .../Forward/Protocol/TraceObject/Tests.hs | 16 ++-- trace-forward/trace-forward.cabal | 1 + 18 files changed, 180 insertions(+), 214 deletions(-) diff --git a/cabal.project b/cabal.project index 33868d14fee..06978d541ff 100644 --- a/cabal.project +++ b/cabal.project @@ -263,8 +263,8 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/ouroboros-network - tag: c764553561bed8978d2c6753d1608dc65449617a - --sha256: 0hdh7xdrvxw943r6qr0xr4kwszindh5mnsn1lww6qdnxnmn7wcsc + tag: c7b4ead782e88238714db4a305d68a6fbdef7692 + --sha256: 0h79izbcyylf38slncm3vh9vq89hy0phy2ps6q3bpklaz02x12j3 subdir: monoidal-synchronisation network-mux @@ -290,11 +290,13 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/typed-protocols - tag: 181601bc3d9e9d21a671ce01e0b481348b3ca104 - --sha256: 1lr97b2z7l0rpsmmz92rsv27qzd5vavz10cf7n25svya4kkiysp5 + tag: e808e5c084593055fd34709cd159fa9e74c843e1 + --sha256: 01b035im4lxahdwdmmlfg3cjc32mx7p2y0fk64m7vb3wqx0nvys5 subdir: typed-protocols typed-protocols-cborg + typed-protocols-stateful + typed-protocols-stateful-cborg typed-protocols-examples source-repository-package @@ -314,8 +316,8 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/ekg-forward - tag: 297cd9db5074339a2fb2e5ae7d0780debb670c63 - --sha256: 1zcwry3y5rmd9lgxy89wsb3k4kpffqji35dc7ghzbz603y1gy24g + tag: a7b401a95f1963352fbfd940e65f0d609386c2fd + --sha256: 17yxa4panvgfa4q3czpr3k03hpd1bxz6d1jpr4dhhqx1sagp4lri source-repository-package type: git diff --git a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Acceptor.hs b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Acceptor.hs index 040b2d510a8..498324c2067 100644 --- a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Acceptor.hs +++ b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Acceptor.hs @@ -14,8 +14,7 @@ module Trace.Forward.Protocol.DataPoint.Acceptor , dataPointAcceptorPeer ) where -import Network.TypedProtocol.Core (Peer (..), PeerHasAgency (..), - PeerRole (..)) +import Network.TypedProtocol.Peer.Client import Trace.Forward.Protocol.DataPoint.Type @@ -34,15 +33,15 @@ data DataPointAcceptor m a where dataPointAcceptorPeer :: Monad m => DataPointAcceptor m a - -> Peer DataPointForward 'AsClient 'StIdle m a + -> Client DataPointForward 'NonPipelined 'Empty 'StIdle m stm a dataPointAcceptorPeer = \case SendMsgDataPointsRequest request next -> -- Send our message (request for new 'DataPoint's from the forwarder). - Yield (ClientAgency TokIdle) (MsgDataPointsRequest request) $ + Yield (MsgDataPointsRequest request) $ -- We're now into the 'StBusy' state, and now we'll wait for a reply -- from the forwarder. It is assuming that the forwarder will reply -- immediately (even there are no 'DataPoint's). - Await (ServerAgency TokBusy) $ \(MsgDataPointsReply reply) -> + Await $ \(MsgDataPointsReply reply) -> Effect $ dataPointAcceptorPeer <$> next reply @@ -51,5 +50,5 @@ dataPointAcceptorPeer = \case -- 'StDone' state. Once in the 'StDone' state we can actually stop using -- 'done', with a return value. Effect $ - Yield (ClientAgency TokIdle) MsgDone . Done TokDone + Yield MsgDone . Done <$> getResult diff --git a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Codec.hs b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Codec.hs index 39d9e46706a..249833b0d4b 100644 --- a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Codec.hs +++ b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Codec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} @@ -13,10 +14,11 @@ import qualified Codec.CBOR.Encoding as CBOR import Codec.CBOR.Read (DeserialiseFailure) import Control.Monad.Class.MonadST (MonadST) import qualified Data.ByteString.Lazy as LBS +import Data.Singletons import Text.Printf (printf) -import Network.TypedProtocol.Codec (Codec, PeerHasAgency (..), - PeerRole (..), SomeMessage (..)) +import Network.TypedProtocol.Core +import Network.TypedProtocol.Codec (Codec, SomeMessage (..)) import Network.TypedProtocol.Codec.CBOR (mkCodecCborLazyBS) import Trace.Forward.Protocol.DataPoint.Type @@ -36,48 +38,47 @@ codecDataPointForward encodeRequest decodeRequest where -- Encode messages. encode - :: forall (pr :: PeerRole) - (st :: DataPointForward) + :: forall (st :: DataPointForward) (st' :: DataPointForward). - PeerHasAgency pr st - -> Message DataPointForward st st' + Message DataPointForward st st' -> CBOR.Encoding - encode (ClientAgency TokIdle) (MsgDataPointsRequest request) = + encode (MsgDataPointsRequest request) = CBOR.encodeListLen 2 <> CBOR.encodeWord 1 <> encodeRequest request - encode (ClientAgency TokIdle) MsgDone = + encode MsgDone = CBOR.encodeListLen 1 <> CBOR.encodeWord 2 - encode (ServerAgency TokBusy) (MsgDataPointsReply reply) = + encode (MsgDataPointsReply reply) = CBOR.encodeListLen 2 <> CBOR.encodeWord 3 <> encodeReplyList reply -- Decode messages decode - :: forall (pr :: PeerRole) - (st :: DataPointForward) s. - PeerHasAgency pr st + :: forall (st :: DataPointForward) s. + ActiveState st + => Sing st -> CBOR.Decoder s (SomeMessage st) decode stok = do len <- CBOR.decodeListLen key <- CBOR.decodeWord case (key, len, stok) of - (1, 2, ClientAgency TokIdle) -> + (1, 2, SingIdle) -> SomeMessage . MsgDataPointsRequest <$> decodeRequest - (2, 1, ClientAgency TokIdle) -> + (2, 1, SingIdle) -> return $ SomeMessage MsgDone - (3, 2, ServerAgency TokBusy) -> + (3, 2, SingBusy) -> SomeMessage . MsgDataPointsReply <$> decodeReplyList -- Failures per protocol state - (_, _, ClientAgency TokIdle) -> + (_, _, SingIdle) -> fail (printf "codecDataPointForward (%s) unexpected key (%d, %d)" (show stok) key len) - (_, _, ServerAgency TokBusy) -> + (_, _, SingBusy) -> fail (printf "codecDataPointForward (%s) unexpected key (%d, %d)" (show stok) key len) + (_, _, SingDone) -> notActiveState stok diff --git a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Forwarder.hs b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Forwarder.hs index 34c566a81b7..516b1877237 100644 --- a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Forwarder.hs +++ b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Forwarder.hs @@ -9,8 +9,7 @@ module Trace.Forward.Protocol.DataPoint.Forwarder , dataPointForwarderPeer ) where -import Network.TypedProtocol.Core (Peer (..), PeerHasAgency (..), - PeerRole (..)) +import Network.TypedProtocol.Peer.Server import Trace.Forward.Protocol.DataPoint.Type @@ -30,20 +29,19 @@ data DataPointForwarder m a = DataPointForwarder dataPointForwarderPeer :: Monad m => DataPointForwarder m a - -> Peer DataPointForward 'AsServer 'StIdle m a + -> Server DataPointForward 'NonPipelined 'Empty 'StIdle m stm a dataPointForwarderPeer DataPointForwarder{recvMsgDataPointsRequest, recvMsgDone} = -- In the 'StIdle' state the forwarder is awaiting a request message -- from the acceptor. - Await (ClientAgency TokIdle) $ \case + Await $ \case -- The acceptor sent us a request for new 'DataPoint's, so now we're -- in the 'StBusy' state which means it's the forwarder's turn to send -- a reply. MsgDataPointsRequest request -> Effect $ do (reply, next) <- recvMsgDataPointsRequest request - return $ Yield (ServerAgency TokBusy) - (MsgDataPointsReply reply) + return $ Yield (MsgDataPointsReply reply) (dataPointForwarderPeer next) -- The acceptor sent the done transition, so we're in the 'StDone' state -- so all we can do is stop using 'done', with a return value. - MsgDone -> Effect $ Done TokDone <$> recvMsgDone + MsgDone -> Effect $ Done <$> recvMsgDone diff --git a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Type.hs b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Type.hs index aa0f84c0e16..83dd47f9800 100644 --- a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Type.hs +++ b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Type.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -- | The type of the 'DataPoint' forwarding/accepting protocol. @@ -13,17 +14,15 @@ module Trace.Forward.Protocol.DataPoint.Type , DataPointValue , DataPointValues , DataPointForward (..) + , SingDataPointForward (..) , Message (..) - , ClientHasAgency (..) - , ServerHasAgency (..) - , NobodyHasAgency (..) ) where import qualified Data.ByteString.Lazy as LBS import Data.Text (Text) +import Data.Singletons -import Network.TypedProtocol.Core (Protocol (..)) -import Ouroboros.Network.Util.ShowProxy (ShowProxy(..)) +import Network.TypedProtocol.Core -- | A kind to identify our protocol, and the types of the states in the state -- transition diagram of the protocol. @@ -59,8 +58,16 @@ data DataPointForward where -- | Both the acceptor and forwarder are in the terminal state. They're done. StDone :: DataPointForward -instance ShowProxy DataPointForward where - showProxy _ = "DataPointForward" +data SingDataPointForward (st :: DataPointForward) where + SingIdle :: SingDataPointForward StIdle + SingBusy :: SingDataPointForward StBusy + SingDone :: SingDataPointForward StDone + +deriving instance Show (SingDataPointForward (st :: DataPointForward)) +type instance Sing = SingDataPointForward +instance SingI StIdle where sing = SingIdle +instance SingI StBusy where sing = SingBusy +instance SingI StDone where sing = SingDone instance Protocol DataPointForward where @@ -83,39 +90,10 @@ instance Protocol DataPointForward where MsgDone :: Message DataPointForward 'StIdle 'StDone - -- | This is an explanation of our states, in terms of which party has agency - -- in each state. - -- - -- 1. When both peers are in Idle state, the acceptor can send a message - -- to the forwarder (request for new 'DataPoint's), - -- 2. When both peers are in Busy state, the forwarder is expected to send - -- a reply to the acceptor (list of new 'DataPoint's). - -- - -- So we assume that, from __interaction__ point of view: - -- 1. ClientHasAgency (from 'Network.TypedProtocol.Core') corresponds to acceptor's agency. - -- 3. ServerHasAgency (from 'Network.TypedProtocol.Core') corresponds to forwarder's agency. - -- - data ClientHasAgency st where - TokIdle :: ClientHasAgency 'StIdle - - data ServerHasAgency st where - TokBusy :: ServerHasAgency 'StBusy - - data NobodyHasAgency st where - TokDone :: NobodyHasAgency 'StDone - - -- | Impossible cases. - exclusionLemma_ClientAndServerHaveAgency TokIdle tok = case tok of {} - exclusionLemma_NobodyAndClientHaveAgency TokDone tok = case tok of {} - exclusionLemma_NobodyAndServerHaveAgency TokDone tok = case tok of {} - -instance Show (Message DataPointForward from to) where - show MsgDataPointsRequest{} = "MsgDataPointsRequest" - show MsgDataPointsReply{} = "MsgDataPointsReply" - show MsgDone{} = "MsgDone" + type StateToken = SingDataPointForward -instance Show (ClientHasAgency (st :: DataPointForward)) where - show TokIdle = "TokIdle" + type StateAgency StIdle = ClientAgency + type StateAgency StBusy = ServerAgency + type StateAgency StDone = NobodyAgency -instance Show (ServerHasAgency (st :: DataPointForward)) where - show TokBusy{} = "TokBusy" +deriving instance Show (Message DataPointForward from to) diff --git a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Acceptor.hs b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Acceptor.hs index 494439d8e01..321f2669108 100644 --- a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Acceptor.hs +++ b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Acceptor.hs @@ -14,14 +14,13 @@ module Trace.Forward.Protocol.TraceObject.Acceptor , traceObjectAcceptorPeer ) where -import Network.TypedProtocol.Core (Peer (..), PeerHasAgency (..), - PeerRole (..)) +import Network.TypedProtocol.Peer.Client import Trace.Forward.Protocol.TraceObject.Type data TraceObjectAcceptor lo m a where SendMsgTraceObjectsRequest - :: TokBlockingStyle blocking + :: SingBlockingStyle blocking -> NumberOfTraceObjects -> (BlockingReplyList blocking lo -> m (TraceObjectAcceptor lo m a)) -> TraceObjectAcceptor lo m a @@ -35,24 +34,24 @@ data TraceObjectAcceptor lo m a where traceObjectAcceptorPeer :: Monad m => TraceObjectAcceptor lo m a - -> Peer (TraceObjectForward lo) 'AsClient 'StIdle m a + -> Client (TraceObjectForward lo) 'NonPipelined 'Empty 'StIdle m stm a traceObjectAcceptorPeer = \case - SendMsgTraceObjectsRequest TokBlocking request next -> + SendMsgTraceObjectsRequest SingBlocking request next -> -- Send our message (request for new 'TraceObject's from the forwarder). - Yield (ClientAgency TokIdle) (MsgTraceObjectsRequest TokBlocking request) $ + Yield (MsgTraceObjectsRequest SingBlocking request) $ -- We're now into the 'StBusy' state, and now we'll wait for a reply -- from the forwarder. - Await (ServerAgency (TokBusy TokBlocking)) $ \(MsgTraceObjectsReply reply) -> + Await $ \(MsgTraceObjectsReply reply) -> Effect $ traceObjectAcceptorPeer <$> next reply - SendMsgTraceObjectsRequest TokNonBlocking request next -> + SendMsgTraceObjectsRequest SingNonBlocking request next -> -- Send our message (request for new 'TraceObject's from the forwarder). - Yield (ClientAgency TokIdle) (MsgTraceObjectsRequest TokNonBlocking request) $ + Yield (MsgTraceObjectsRequest SingNonBlocking request) $ -- We're now into the 'StBusy' state, and now we'll wait for a reply -- from the forwarder. It is assuming that the forwarder will reply -- immediately (even there are no 'TraceObject's). - Await (ServerAgency (TokBusy TokNonBlocking)) $ \(MsgTraceObjectsReply reply) -> + Await $ \(MsgTraceObjectsReply reply) -> Effect $ traceObjectAcceptorPeer <$> next reply @@ -61,5 +60,5 @@ traceObjectAcceptorPeer = \case -- 'StDone' state. Once in the 'StDone' state we can actually stop using -- 'done', with a return value. Effect $ - Yield (ClientAgency TokIdle) MsgDone . Done TokDone + Yield MsgDone . Done <$> getResult diff --git a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Codec.hs b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Codec.hs index b1e1925d63c..40bc460d89e 100644 --- a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Codec.hs +++ b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Codec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} @@ -14,10 +15,11 @@ import Codec.CBOR.Read (DeserialiseFailure) import Control.Monad.Class.MonadST (MonadST) import qualified Data.ByteString.Lazy as LBS import qualified Data.List.NonEmpty as NE +import Data.Singletons import Text.Printf (printf) -import Network.TypedProtocol.Codec (Codec, PeerHasAgency (..), - PeerRole (..), SomeMessage (..)) +import Network.TypedProtocol.Core (ActiveState, notActiveState) +import Network.TypedProtocol.Codec (Codec, SomeMessage (..)) import Network.TypedProtocol.Codec.CBOR (mkCodecCborLazyBS) import Trace.Forward.Protocol.TraceObject.Type @@ -37,26 +39,24 @@ codecTraceObjectForward encodeRequest decodeRequest where -- Encode messages. encode - :: forall (pr :: PeerRole) - (st :: TraceObjectForward lo) + :: forall (st :: TraceObjectForward lo) (st' :: TraceObjectForward lo). - PeerHasAgency pr st - -> Message (TraceObjectForward lo) st st' + Message (TraceObjectForward lo) st st' -> CBOR.Encoding - encode (ClientAgency TokIdle) (MsgTraceObjectsRequest blocking request) = + encode (MsgTraceObjectsRequest blocking request) = CBOR.encodeListLen 3 <> CBOR.encodeWord 1 <> CBOR.encodeBool (case blocking of - TokBlocking -> True - TokNonBlocking -> False) + SingBlocking -> True + SingNonBlocking -> False) <> encodeRequest request - encode (ClientAgency TokIdle) MsgDone = + encode MsgDone = CBOR.encodeListLen 1 <> CBOR.encodeWord 2 - encode (ServerAgency (TokBusy _)) (MsgTraceObjectsReply reply) = + encode (MsgTraceObjectsReply reply) = CBOR.encodeListLen 2 <> CBOR.encodeWord 3 <> encodeReplyList replyList @@ -68,42 +68,43 @@ codecTraceObjectForward encodeRequest decodeRequest -- Decode messages decode - :: forall (pr :: PeerRole) - (st :: TraceObjectForward lo) s. - PeerHasAgency pr st + :: forall (st :: TraceObjectForward lo) s. + ActiveState st + => Sing st -> CBOR.Decoder s (SomeMessage st) decode stok = do len <- CBOR.decodeListLen key <- CBOR.decodeWord case (key, len, stok) of - (1, 3, ClientAgency TokIdle) -> do + (1, 3, SingIdle) -> do blocking <- CBOR.decodeBool request <- decodeRequest return $! if blocking then - SomeMessage $ MsgTraceObjectsRequest TokBlocking request + SomeMessage $ MsgTraceObjectsRequest SingBlocking request else - SomeMessage $ MsgTraceObjectsRequest TokNonBlocking request + SomeMessage $ MsgTraceObjectsRequest SingNonBlocking request - (2, 1, ClientAgency TokIdle) -> + (2, 1, SingIdle) -> return $ SomeMessage MsgDone - (3, 2, ServerAgency (TokBusy blocking)) -> do + (3, 2, SingBusy blocking) -> do replyList <- decodeReplyList case (blocking, replyList) of - (TokBlocking, x:xs) -> + (SingBlocking, x:xs) -> return $ SomeMessage (MsgTraceObjectsReply (BlockingReply (x NE.:| xs))) - (TokNonBlocking, los) -> + (SingNonBlocking, los) -> return $ SomeMessage (MsgTraceObjectsReply (NonBlockingReply los)) - (TokBlocking, []) -> + (SingBlocking, []) -> fail "codecTraceObjectForward: MsgTraceObjectsReply: empty list not permitted" -- Failures per protocol state - (_, _, ClientAgency TokIdle) -> + (_, _, SingIdle) -> fail (printf "codecTraceObjectForward (%s) unexpected key (%d, %d)" (show stok) key len) - (_, _, ServerAgency (TokBusy TokBlocking)) -> + (_, _, SingBusy SingBlocking) -> fail (printf "codecTraceObjectForward (%s) unexpected key (%d, %d)" (show stok) key len) - (_, _, ServerAgency (TokBusy TokNonBlocking)) -> + (_, _, SingBusy SingNonBlocking) -> fail (printf "codecTraceObjectForward (%s) unexpected key (%d, %d)" (show stok) key len) + (_, _, SingDone) -> notActiveState stok diff --git a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Forwarder.hs b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Forwarder.hs index 0aa2d8937be..2927c1ce1bd 100644 --- a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Forwarder.hs +++ b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Forwarder.hs @@ -9,8 +9,9 @@ module Trace.Forward.Protocol.TraceObject.Forwarder , traceObjectForwarderPeer ) where -import Network.TypedProtocol.Core (Peer (..), PeerHasAgency (..), - PeerRole (..)) +import Data.Singletons + +import Network.TypedProtocol.Peer.Server import Trace.Forward.Protocol.TraceObject.Type @@ -18,7 +19,7 @@ data TraceObjectForwarder lo m a = TraceObjectForwarder { -- | The acceptor sent us a request for new 'TraceObject's. recvMsgTraceObjectsRequest :: forall blocking. - TokBlockingStyle blocking + SingBlockingStyle blocking -> NumberOfTraceObjects -> m (BlockingReplyList blocking lo, TraceObjectForwarder lo m a) @@ -32,20 +33,20 @@ data TraceObjectForwarder lo m a = TraceObjectForwarder traceObjectForwarderPeer :: Monad m => TraceObjectForwarder lo m a - -> Peer (TraceObjectForward lo) 'AsServer 'StIdle m a + -> Server (TraceObjectForward lo) 'NonPipelined 'Empty 'StIdle m stm a traceObjectForwarderPeer TraceObjectForwarder{recvMsgTraceObjectsRequest, recvMsgDone} = -- In the 'StIdle' state the forwarder is awaiting a request message -- from the acceptor. - Await (ClientAgency TokIdle) $ \case + Await $ \case -- The acceptor sent us a request for new 'TraceObject's, so now we're -- in the 'StBusy' state which means it's the forwarder's turn to send -- a reply. MsgTraceObjectsRequest blocking request -> Effect $ do (reply, next) <- recvMsgTraceObjectsRequest blocking request - return $ Yield (ServerAgency (TokBusy blocking)) - (MsgTraceObjectsReply reply) + return $ withSingI blocking $ + Yield (MsgTraceObjectsReply reply) (traceObjectForwarderPeer next) -- The acceptor sent the done transition, so we're in the 'StDone' state -- so all we can do is stop using 'done', with a return value. - MsgDone -> Effect $ Done TokDone <$> recvMsgDone + MsgDone -> Effect $ Done <$> recvMsgDone diff --git a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Type.hs b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Type.hs index e783e00909d..f159f72dcc9 100644 --- a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Type.hs +++ b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Type.hs @@ -13,22 +13,20 @@ module Trace.Forward.Protocol.TraceObject.Type ( TraceObjectForward (..) - , TokBlockingStyle (..) + , SingTraceObjectForward (..) + , SingBlockingStyle (..) , Message (..) - , ClientHasAgency (..) - , ServerHasAgency (..) - , NobodyHasAgency (..) , NumberOfTraceObjects (..) , BlockingReplyList (..) ) where import Codec.Serialise (Serialise (..)) import Data.List.NonEmpty (NonEmpty) -import Data.Proxy (Proxy(..)) +import Data.Singletons import Data.Word (Word16) import GHC.Generics (Generic) -import Network.TypedProtocol.Core (Protocol (..)) +import Network.TypedProtocol.Core import Ouroboros.Network.Util.ShowProxy (ShowProxy(..)) -- | A kind to identify our protocol, and the types of the states in the state @@ -84,22 +82,41 @@ instance (ShowProxy lo) , ")" ] +deriving instance Show (SingTraceObjectForward st) + data StBlockingStyle where -- | In this sub-state the reply need not be prompt. There is no timeout. StBlocking :: StBlockingStyle -- | In this sub-state the peer must reply. There is a timeout. StNonBlocking :: StBlockingStyle + +data SingTraceObjectForward (st :: TraceObjectForward lo) where + SingIdle :: SingTraceObjectForward StIdle + SingBusy :: SingBlockingStyle a + -> SingTraceObjectForward (StBusy a) + SingDone :: SingTraceObjectForward StDone + -- | The value level equivalent of 'StBlockingStyle'. -- -- This is also used in 'MsgTraceObjectsRequest' where it is interpreted (and can be encoded) -- as a 'Bool' with 'True' for blocking, and 'False' for non-blocking. -data TokBlockingStyle (k :: StBlockingStyle) where - TokBlocking :: TokBlockingStyle 'StBlocking - TokNonBlocking :: TokBlockingStyle 'StNonBlocking +data SingBlockingStyle (b :: StBlockingStyle) where + SingBlocking :: SingBlockingStyle StBlocking + SingNonBlocking :: SingBlockingStyle StNonBlocking + +deriving instance Eq (SingBlockingStyle b) +deriving instance Show (SingBlockingStyle b) +type instance Sing = SingBlockingStyle +instance SingI StBlocking where sing = SingBlocking +instance SingI StNonBlocking where sing = SingNonBlocking + +type instance Sing = SingTraceObjectForward +instance SingI StIdle where sing = SingIdle +instance SingI b + => SingI (StBusy b) where sing = SingBusy sing +instance SingI StDone where sing = SingDone -deriving instance Eq (TokBlockingStyle b) -deriving instance Show (TokBlockingStyle b) -- | We have requests for lists of things. In the blocking case the -- corresponding reply must be non-empty, whereas in the non-blocking case @@ -128,7 +145,7 @@ instance Protocol (TraceObjectForward lo) where -- With 'TokNonBlocking' this is a non-blocking operation: the reply -- may be an empty list and this does expect a prompt reply. MsgTraceObjectsRequest - :: TokBlockingStyle blocking + :: SingBlockingStyle blocking -> NumberOfTraceObjects -> Message (TraceObjectForward lo) 'StIdle ('StBusy blocking) @@ -142,40 +159,11 @@ instance Protocol (TraceObjectForward lo) where MsgDone :: Message (TraceObjectForward lo) 'StIdle 'StDone - -- | This is an explanation of our states, in terms of which party has agency - -- in each state. - -- - -- 1. When both peers are in Idle state, the acceptor can send a message - -- to the forwarder (request for new 'TraceObject's), - -- 2. When both peers are in Busy state, the forwarder is expected to send - -- a reply to the acceptor (list of new 'TraceObject's). - -- - -- So we assume that, from __interaction__ point of view: - -- 1. ClientHasAgency (from 'Network.TypedProtocol.Core') corresponds to acceptor's agency. - -- 3. ServerHasAgency (from 'Network.TypedProtocol.Core') corresponds to forwarder's agency. - -- - data ClientHasAgency st where - TokIdle :: ClientHasAgency 'StIdle - - data ServerHasAgency st where - TokBusy :: TokBlockingStyle blocking -> ServerHasAgency ('StBusy blocking) - - data NobodyHasAgency st where - TokDone :: NobodyHasAgency 'StDone - - -- | Impossible cases. - exclusionLemma_ClientAndServerHaveAgency TokIdle tok = case tok of {} - exclusionLemma_NobodyAndClientHaveAgency TokDone tok = case tok of {} - exclusionLemma_NobodyAndServerHaveAgency TokDone tok = case tok of {} - -instance Show lo - => Show (Message (TraceObjectForward lo) from to) where - show MsgTraceObjectsRequest{} = "MsgTraceObjectsRequest" - show MsgTraceObjectsReply{} = "MsgTraceObjectsReply" - show MsgDone{} = "MsgDone" + type StateAgency StIdle = ClientAgency + type StateAgency (StBusy _) = ServerAgency + type StateAgency StDone = NobodyAgency -instance Show (ClientHasAgency (st :: TraceObjectForward lo)) where - show TokIdle = "TokIdle" + type StateToken = SingTraceObjectForward -instance Show (ServerHasAgency (st :: TraceObjectForward lo)) where - show TokBusy{} = "TokBusy" +deriving instance Show lo + => Show (Message (TraceObjectForward lo) from to) diff --git a/trace-forward/src/Trace/Forward/Run/TraceObject/Acceptor.hs b/trace-forward/src/Trace/Forward/Run/TraceObject/Acceptor.hs index 5ee8bd3f60b..755b858fe52 100644 --- a/trace-forward/src/Trace/Forward/Run/TraceObject/Acceptor.hs +++ b/trace-forward/src/Trace/Forward/Run/TraceObject/Acceptor.hs @@ -20,7 +20,6 @@ import Data.Void (Void) import Ouroboros.Network.Mux (MuxMode (..), MuxPeer (..), RunMiniProtocol (..)) import Ouroboros.Network.Driver.Simple (runPeer) -import Ouroboros.Network.Util.ShowProxy (ShowProxy(..)) import qualified Trace.Forward.Protocol.TraceObject.Acceptor as Acceptor import qualified Trace.Forward.Protocol.TraceObject.Codec as Acceptor @@ -30,7 +29,6 @@ import Trace.Forward.Configuration.TraceObject (AcceptorConfiguration acceptTraceObjectsInit :: (CBOR.Serialise lo, - ShowProxy lo, Typeable lo) => AcceptorConfiguration lo -- ^ Acceptor's configuration. -> ([lo] -> IO ()) -- ^ The handler for accepted 'TraceObject's. @@ -41,7 +39,6 @@ acceptTraceObjectsInit config loHandler peerErrorHandler = acceptTraceObjectsResp :: (CBOR.Serialise lo, - ShowProxy lo, Typeable lo) => AcceptorConfiguration lo -- ^ Acceptor's configuration. -> ([lo] -> IO ()) -- ^ The handler for accepted 'TraceObject's. @@ -52,7 +49,6 @@ acceptTraceObjectsResp config loHandler peerErrorHandler = runPeerWithHandler :: (CBOR.Serialise lo, - ShowProxy lo, Typeable lo) => AcceptorConfiguration lo -> ([lo] -> IO ()) @@ -73,13 +69,12 @@ runPeerWithHandler config@AcceptorConfiguration{acceptorTracer, shouldWeStop} lo acceptorActions :: (CBOR.Serialise lo, - ShowProxy lo, Typeable lo) => AcceptorConfiguration lo -- ^ Acceptor's configuration. -> ([lo] -> IO ()) -- ^ The handler for accepted 'TraceObject's. -> Acceptor.TraceObjectAcceptor lo IO () acceptorActions config@AcceptorConfiguration{whatToRequest, shouldWeStop} loHandler = - Acceptor.SendMsgTraceObjectsRequest TokBlocking whatToRequest $ \replyWithTraceObjects -> do + Acceptor.SendMsgTraceObjectsRequest SingBlocking whatToRequest $ \replyWithTraceObjects -> do loHandler $ getTraceObjectsFromReply replyWithTraceObjects ifM (readTVarIO shouldWeStop) (return $ Acceptor.SendMsgDone $ return ()) diff --git a/trace-forward/src/Trace/Forward/Run/TraceObject/Forwarder.hs b/trace-forward/src/Trace/Forward/Run/TraceObject/Forwarder.hs index 79e9a72851d..b1ea9a6f056 100644 --- a/trace-forward/src/Trace/Forward/Run/TraceObject/Forwarder.hs +++ b/trace-forward/src/Trace/Forward/Run/TraceObject/Forwarder.hs @@ -10,7 +10,6 @@ import qualified Data.ByteString.Lazy as LBS import Data.Void (Void) import Ouroboros.Network.Driver.Simple (runPeer) import Ouroboros.Network.Mux (MuxMode (..), MuxPeer (..), RunMiniProtocol (..)) -import Ouroboros.Network.Util.ShowProxy (ShowProxy(..)) import qualified Trace.Forward.Protocol.TraceObject.Forwarder as Forwarder import qualified Trace.Forward.Protocol.TraceObject.Codec as Forwarder @@ -18,8 +17,7 @@ import Trace.Forward.Utils.TraceObject import Trace.Forward.Configuration.TraceObject (ForwarderConfiguration (..)) forwardTraceObjectsInit - :: (CBOR.Serialise lo, - ShowProxy lo) + :: CBOR.Serialise lo => ForwarderConfiguration lo -> ForwardSink lo -> RunMiniProtocol 'InitiatorMode LBS.ByteString IO () Void @@ -27,8 +25,7 @@ forwardTraceObjectsInit config sink = InitiatorProtocolOnly $ runPeerWithSink config sink forwardTraceObjectsResp - :: (CBOR.Serialise lo, - ShowProxy lo) + :: CBOR.Serialise lo => ForwarderConfiguration lo -> ForwardSink lo -> RunMiniProtocol 'ResponderMode LBS.ByteString IO Void () @@ -36,7 +33,7 @@ forwardTraceObjectsResp config sink = ResponderProtocolOnly $ runPeerWithSink config sink runPeerWithSink - :: (ShowProxy lo, CBOR.Serialise lo) + :: CBOR.Serialise lo => ForwarderConfiguration lo -> ForwardSink lo -> MuxPeer LBS.ByteString IO () diff --git a/trace-forward/src/Trace/Forward/Utils/TraceObject.hs b/trace-forward/src/Trace/Forward/Utils/TraceObject.hs index b6058dbf4f4..9fd9a1ae25d 100644 --- a/trace-forward/src/Trace/Forward/Utils/TraceObject.hs +++ b/trace-forward/src/Trace/Forward/Utils/TraceObject.hs @@ -104,13 +104,13 @@ readFromSink sink@ForwardSink{forwardQueue, wasUsed} = { Forwarder.recvMsgTraceObjectsRequest = \blocking (NumberOfTraceObjects n) -> do replyList <- case blocking of - TokBlocking -> do + SingBlocking -> do objs <- atomically $ getNTraceObjects n forwardQueue >>= \case [] -> retry -- No 'TraceObject's yet, just wait... (x:xs) -> return $ x NE.:| xs atomically . modifyTVar' wasUsed . const $ True return $ BlockingReply objs - TokNonBlocking -> do + SingNonBlocking -> do objs <- atomically $ getNTraceObjects n forwardQueue unless (null objs) $ atomically . modifyTVar' wasUsed . const $ True diff --git a/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Codec.hs b/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Codec.hs index 59b5e0f9b1b..d14781adbdd 100644 --- a/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Codec.hs +++ b/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Codec.hs @@ -7,19 +7,18 @@ module Test.Trace.Forward.Protocol.DataPoint.Codec () where import qualified Data.Aeson as A import Test.QuickCheck -import Network.TypedProtocol.Core import Network.TypedProtocol.Codec import Trace.Forward.Protocol.DataPoint.Type import Test.Trace.Forward.Protocol.DataPoint.Item -instance Arbitrary (AnyMessageAndAgency DataPointForward) where +instance Arbitrary (AnyMessage DataPointForward) where arbitrary = oneof - [ pure $ AnyMessageAndAgency (ClientAgency TokIdle) (MsgDataPointsRequest ["NodeInfo"]) - , pure $ AnyMessageAndAgency (ServerAgency TokBusy) (MsgDataPointsReply [("NodeInfo", Nothing)]) - , pure $ AnyMessageAndAgency (ServerAgency TokBusy) (MsgDataPointsReply [("NodeInfo", Just ni)]) - , pure $ AnyMessageAndAgency (ClientAgency TokIdle) MsgDone + [ pure $ AnyMessage (MsgDataPointsRequest ["NodeInfo"]) + , pure $ AnyMessage (MsgDataPointsReply [("NodeInfo", Nothing)]) + , pure $ AnyMessage (MsgDataPointsReply [("NodeInfo", Just ni)]) + , pure $ AnyMessage MsgDone ] where ni = A.encode $ TestNodeInfo diff --git a/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Tests.hs b/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Tests.hs index ca8cafe599c..108e3bddd12 100644 --- a/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Tests.hs +++ b/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Tests.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} @@ -10,6 +11,7 @@ import qualified Codec.Serialise as CBOR import Control.Monad.IOSim (runSimOrThrow) import Control.Monad.Class.MonadST import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow import Control.Monad.ST (runST) import Control.Tracer (nullTracer) @@ -44,7 +46,7 @@ tests = testGroup "Trace.Forward.Protocol.DataPoint" ] prop_codec_DataPointForward - :: AnyMessageAndAgency DataPointForward + :: AnyMessage DataPointForward -> Bool prop_codec_DataPointForward msg = runST $ prop_codecM @@ -53,7 +55,7 @@ prop_codec_DataPointForward msg = runST $ msg prop_codec_splits2_DataPointForward - :: AnyMessageAndAgency DataPointForward + :: AnyMessage DataPointForward -> Bool prop_codec_splits2_DataPointForward msg = runST $ prop_codec_splitsM @@ -64,7 +66,7 @@ prop_codec_splits2_DataPointForward msg = runST $ prop_codec_splits3_DataPointForward - :: AnyMessageAndAgency DataPointForward + :: AnyMessage DataPointForward -> Bool prop_codec_splits3_DataPointForward msg = runST $ prop_codec_splitsM @@ -91,15 +93,17 @@ prop_connect_DataPointForward -> Bool prop_connect_DataPointForward f (NonNegative n) = case runSimOrThrow - (connect + (connect [] [] (dataPointForwarderPeer dataPointForwarderCount) (dataPointAcceptorPeer $ dataPointAcceptorApply f 0 n)) of - (s, c, TerminalStates TokDone TokDone) -> (s, c) == (n, foldr ($) 0 (replicate n f)) + (s, c, TerminalStates SingDone SingDone) -> (s, c) == (n, foldr ($) 0 (replicate n f)) prop_channel :: ( MonadST m , MonadAsync m - , MonadCatch m + , MonadLabelledSTM m + , MonadMask m + , MonadThrow (STM m) ) => (Int -> Int) -> Int diff --git a/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Codec.hs b/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Codec.hs index 1fa69dca1b1..7ea46bb100a 100644 --- a/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Codec.hs +++ b/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Codec.hs @@ -5,7 +5,6 @@ module Test.Trace.Forward.Protocol.TraceObject.Codec () where import Test.QuickCheck -import Network.TypedProtocol.Core import Network.TypedProtocol.Codec import Trace.Forward.Protocol.TraceObject.Type @@ -19,20 +18,20 @@ instance Arbitrary NumberOfTraceObjects where , pure $ NumberOfTraceObjects 100 ] -instance Arbitrary (AnyMessageAndAgency (TraceObjectForward TraceItem)) where +instance Arbitrary (AnyMessage (TraceObjectForward TraceItem)) where arbitrary = oneof - [ AnyMessageAndAgency (ClientAgency TokIdle) . MsgTraceObjectsRequest TokBlocking <$> arbitrary - , AnyMessageAndAgency (ClientAgency TokIdle) . MsgTraceObjectsRequest TokNonBlocking <$> arbitrary - , AnyMessageAndAgency (ServerAgency (TokBusy TokBlocking)) . MsgTraceObjectsReply . BlockingReply <$> arbitrary - , AnyMessageAndAgency (ServerAgency (TokBusy TokNonBlocking)) . MsgTraceObjectsReply . NonBlockingReply <$> arbitrary - , pure $ AnyMessageAndAgency (ClientAgency TokIdle) MsgDone + [ AnyMessage . MsgTraceObjectsRequest SingBlocking <$> arbitrary + , AnyMessage . MsgTraceObjectsRequest SingNonBlocking <$> arbitrary + , AnyMessage . MsgTraceObjectsReply . BlockingReply <$> arbitrary + , AnyMessage . MsgTraceObjectsReply . NonBlockingReply <$> arbitrary + , pure $ AnyMessage MsgDone ] instance Eq (AnyMessage (TraceObjectForward TraceItem)) where - AnyMessage (MsgTraceObjectsRequest TokBlocking r1) - == AnyMessage (MsgTraceObjectsRequest TokBlocking r2) = r1 == r2 - AnyMessage (MsgTraceObjectsRequest TokNonBlocking r1) - == AnyMessage (MsgTraceObjectsRequest TokNonBlocking r2) = r1 == r2 + AnyMessage (MsgTraceObjectsRequest SingBlocking r1) + == AnyMessage (MsgTraceObjectsRequest SingBlocking r2) = r1 == r2 + AnyMessage (MsgTraceObjectsRequest SingNonBlocking r1) + == AnyMessage (MsgTraceObjectsRequest SingNonBlocking r2) = r1 == r2 AnyMessage (MsgTraceObjectsReply (BlockingReply r1)) == AnyMessage (MsgTraceObjectsReply (BlockingReply r2)) = r1 == r2 AnyMessage (MsgTraceObjectsReply (NonBlockingReply r1)) diff --git a/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Examples.hs b/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Examples.hs index 503af34e98f..37f64ab3267 100644 --- a/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Examples.hs +++ b/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Examples.hs @@ -27,7 +27,7 @@ traceObjectAcceptorApply f = go SendMsgDone $ return acc | otherwise = SendMsgTraceObjectsRequest - TokNonBlocking + SingNonBlocking (NumberOfTraceObjects 1) $ \_reply -> return $ go (f acc) (pred n) @@ -45,8 +45,8 @@ traceObjectForwarderCount = go 0 , recvMsgTraceObjectsRequest = \blocking _numOfTO -> return ( case blocking of - TokBlocking -> BlockingReply (NE.fromList [1, 2, 3]) - TokNonBlocking -> NonBlockingReply [1, 2] + SingBlocking -> BlockingReply (NE.fromList [1, 2, 3]) + SingNonBlocking -> NonBlockingReply [1, 2] , go (succ n) ) } diff --git a/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Tests.hs b/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Tests.hs index 268b6a34457..d879567858a 100644 --- a/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Tests.hs +++ b/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Tests.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -8,6 +9,7 @@ module Test.Trace.Forward.Protocol.TraceObject.Tests import qualified Codec.Serialise as CBOR import Control.Monad.Class.MonadST import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow import Control.Monad.ST (runST) import Control.Monad.IOSim (runSimOrThrow) @@ -43,7 +45,7 @@ tests = testGroup "Trace.Forward.Protocol.TraceObject" , testProperty "channel IO" prop_channel_IO_TraceObjectForward ] -prop_codec_TraceObjectForward :: AnyMessageAndAgency (TraceObjectForward TraceItem) -> Bool +prop_codec_TraceObjectForward :: AnyMessage (TraceObjectForward TraceItem) -> Bool prop_codec_TraceObjectForward msg = runST $ prop_codecM (codecTraceObjectForward CBOR.encode CBOR.decode @@ -51,7 +53,7 @@ prop_codec_TraceObjectForward msg = runST $ msg prop_codec_splits2_TraceObjectForward - :: AnyMessageAndAgency (TraceObjectForward TraceItem) + :: AnyMessage (TraceObjectForward TraceItem) -> Bool prop_codec_splits2_TraceObjectForward msg = runST $ prop_codec_splitsM @@ -61,7 +63,7 @@ prop_codec_splits2_TraceObjectForward msg = runST $ msg prop_codec_splits3_TraceObjectForward - :: AnyMessageAndAgency (TraceObjectForward TraceItem) + :: AnyMessage (TraceObjectForward TraceItem) -> Bool prop_codec_splits3_TraceObjectForward msg = runST $ prop_codec_splitsM @@ -88,15 +90,17 @@ prop_connect_TraceObjectForward -> Bool prop_connect_TraceObjectForward f (NonNegative n) = case runSimOrThrow - (connect + (connect [] [] (traceObjectForwarderPeer traceObjectForwarderCount) (traceObjectAcceptorPeer $ traceObjectAcceptorApply f 0 n)) of - (s, c, TerminalStates TokDone TokDone) -> (s, c) == (n, foldr ($) 0 (replicate n f)) + (s, c, TerminalStates SingDone SingDone) -> (s, c) == (n, foldr ($) 0 (replicate n f)) prop_channel :: ( MonadST m , MonadAsync m - , MonadCatch m + , MonadLabelledSTM m + , MonadMask m + , MonadThrow (STM m) ) => (Int -> Int) -> Int diff --git a/trace-forward/trace-forward.cabal b/trace-forward/trace-forward.cabal index 06ffe0aedf3..09a612077ea 100644 --- a/trace-forward/trace-forward.cabal +++ b/trace-forward/trace-forward.cabal @@ -61,6 +61,7 @@ library , extra , io-classes , ouroboros-network-framework + , singletons , serialise , stm , text From 885fe5ab4224624d6539e340feac850dd28bded2 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 9 May 2022 18:59:36 +0200 Subject: [PATCH 2/4] Updated cardano-api `ouroboros-network` exposes now * `mapChainSyncClientSt` * `mapChainSyncClientPipelinedSt` Which are used to implement: * `chainSyncClientWithLedgerState` * `chainSyncClientPipelinedWithLedgerState` --- .../Cardano/Api/ChainSync/ClientPipelined.hs | 7 +- cardano-api/src/Cardano/Api/IPC.hs | 35 +-- cardano-api/src/Cardano/Api/LedgerState.hs | 221 ++++++++---------- cardano-api/src/Cardano/Api/Query.hs | 2 +- 4 files changed, 116 insertions(+), 149 deletions(-) diff --git a/cardano-api/src/Cardano/Api/ChainSync/ClientPipelined.hs b/cardano-api/src/Cardano/Api/ChainSync/ClientPipelined.hs index 1aa02640370..f9c6f074143 100644 --- a/cardano-api/src/Cardano/Api/ChainSync/ClientPipelined.hs +++ b/cardano-api/src/Cardano/Api/ChainSync/ClientPipelined.hs @@ -21,14 +21,17 @@ module Cardano.Api.ChainSync.ClientPipelined ( , pipelineDecisionLowHighMark -- * Type level natural numbers + , Queue (..) + , SingQueueF (..) + , F (..) , N (..) - , Nat (..) , natToInt -- * Utilities , mapChainSyncClientPipelined ) where -import Network.TypedProtocol.Pipelined (N (..), Nat (..), natToInt) +import Network.TypedProtocol.Core import Ouroboros.Network.Protocol.ChainSync.ClientPipelined import Ouroboros.Network.Protocol.ChainSync.PipelineDecision +import Data.Type.Nat diff --git a/cardano-api/src/Cardano/Api/IPC.hs b/cardano-api/src/Cardano/Api/IPC.hs index 92a3996e2c2..90bb0f5c6b9 100644 --- a/cardano-api/src/Cardano/Api/IPC.hs +++ b/cardano-api/src/Cardano/Api/IPC.hs @@ -93,6 +93,7 @@ import Control.Tracer (nullTracer) import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import qualified Ouroboros.Network.Block as Net +import qualified Ouroboros.Network.Driver.Stateful as Stateful import qualified Ouroboros.Network.Mux as Net import Ouroboros.Network.NodeToClient (NodeToClientProtocols (..), NodeToClientVersionData (..)) @@ -102,7 +103,7 @@ import Ouroboros.Network.Protocol.ChainSync.Client as Net.Sync import Ouroboros.Network.Protocol.ChainSync.ClientPipelined as Net.SyncP import Ouroboros.Network.Protocol.LocalStateQuery.Client (LocalStateQueryClient (..)) import qualified Ouroboros.Network.Protocol.LocalStateQuery.Client as Net.Query -import Ouroboros.Network.Protocol.LocalStateQuery.Type (AcquireFailure (..)) +import Ouroboros.Network.Protocol.LocalStateQuery.Type (AcquireFailure (..), State(StateIdle)) import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as Net.Query import Ouroboros.Network.Protocol.LocalTxMonitor.Client (LocalTxMonitorClient (..), localTxMonitorClientPeer) @@ -241,9 +242,7 @@ connectToLocalNodeWithVersion LocalNodeConnectInfo { mkVersionedProtocols localNodeNetworkId ptcl clients' mkVersionedProtocols :: forall block. - ( Consensus.ShowQuery (Consensus.Query block) - , ProtocolClient block - ) + ProtocolClient block => NetworkId -> ProtocolClientInfoArgs block -> (NodeToClientVersion -> LocalNodeClientProtocolsForBlock block) @@ -295,7 +294,7 @@ mkVersionedProtocols networkid ptcl unversionedClients = cChainSyncCodec (Net.Sync.chainSyncClientPeer client) LocalChainSyncClientPipelined clientPipelined - -> Net.MuxPeerPipelined + -> Net.MuxPeer nullTracer cChainSyncCodec (Net.SyncP.chainSyncClientPeerPipelined clientPipelined) @@ -311,20 +310,24 @@ mkVersionedProtocols networkid ptcl unversionedClients = , localStateQueryProtocol = Net.InitiatorProtocolOnly $ - Net.MuxPeer - nullTracer - cStateQueryCodec - (maybe Net.localStateQueryPeerNull - Net.Query.localStateQueryClientPeer - localStateQueryClientForBlock) + Net.MuxPeerRaw $ \channel -> + Stateful.runPeer + nullTracer + cStateQueryCodec + channel + StateIdle + (maybe Net.localStateQueryPeerNull + Net.Query.localStateQueryClientPeer + localStateQueryClientForBlock) + , localTxMonitorProtocol = Net.InitiatorProtocolOnly $ Net.MuxPeer - nullTracer - cTxMonitorCodec - (maybe Net.localTxMonitorPeerNull - localTxMonitorClientPeer - localTxMonitoringClientForBlock) + nullTracer + cTxMonitorCodec + (maybe Net.localTxMonitorPeerNull + localTxMonitorClientPeer + localTxMonitoringClientForBlock) } where Consensus.Codecs { diff --git a/cardano-api/src/Cardano/Api/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs index bf0674fd1ea..79dc956c5e4 100644 --- a/cardano-api/src/Cardano/Api/LedgerState.hs +++ b/cardano-api/src/Cardano/Api/LedgerState.hs @@ -6,9 +6,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Cardano.Api.LedgerState ( -- * Initialization / Accumulation @@ -84,11 +87,13 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder (toLazyText) +import Data.Type.Nat +import Data.Type.Queue (SingQueueF (..)) +import qualified Data.Type.Queue as Queue import Data.Word import qualified Data.Yaml as Yaml import Formatting.Buildable (build) import GHC.Records (HasField (..)) -import Network.TypedProtocol.Pipelined (Nat (..)) import System.FilePath import Cardano.Api.Block @@ -396,27 +401,28 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = do IO () -- ^ Client returns maybe an error. chainSyncClient pipelineSize stateIORef errorIORef env ledgerState0 - = CSP.ChainSyncClientPipelined $ pure $ clientIdle_RequestMoreN Origin Origin Zero initialLedgerStateHistory + = CSP.ChainSyncClientPipelined $ pure $ clientIdle_RequestMoreN Origin Origin SingEmptyF initialLedgerStateHistory where initialLedgerStateHistory = Seq.singleton (0, (ledgerState0, []), Origin) clientIdle_RequestMoreN :: WithOrigin BlockNo -> WithOrigin BlockNo - -> Nat n -- Number of requests inflight. + -> SingQueueF CSP.F q -- Queue of requests inflight. -> LedgerStateHistory - -> CSP.ClientPipelinedStIdle n (BlockInMode CardanoMode) ChainPoint ChainTip IO () - clientIdle_RequestMoreN clientTip serverTip n knownLedgerStates - = case pipelineDecisionMax pipelineSize n clientTip serverTip of - Collect -> case n of - Succ predN -> CSP.CollectResponse Nothing (clientNextN predN knownLedgerStates) - _ -> CSP.SendMsgRequestNextPipelined (clientIdle_RequestMoreN clientTip serverTip (Succ n) knownLedgerStates) + -> CSP.ClientPipelinedStIdle (BlockInMode CardanoMode) ChainPoint ChainTip q IO () + clientIdle_RequestMoreN clientTip serverTip q knownLedgerStates + = case pipelineDecisionMax pipelineSize (queueFDepthNat q) clientTip serverTip of + Collect -> case q of + SingConsF CSP.FCanAwait q' -> CSP.CollectResponse Nothing (clientNextN q' knownLedgerStates) + SingConsF CSP.FMustReply q' -> CSP.CollectResponse Nothing (clientNextN q' knownLedgerStates) + _ -> CSP.SendMsgRequestNextPipelined (clientIdle_RequestMoreN clientTip serverTip (q Queue.|> CSP.FCanAwait) knownLedgerStates) clientNextN - :: Nat n -- Number of requests inflight. + :: SingQueueF CSP.F q -- Queue of requests inflight. -> LedgerStateHistory - -> CSP.ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip IO () - clientNextN n knownLedgerStates = + -> CSP.ClientStNext (BlockInMode CardanoMode) ChainPoint ChainTip q IO () + clientNextN q knownLedgerStates = CSP.ClientStNext { CSP.recvMsgRollForward = \blockInMode@(BlockInMode block@(Block (BlockHeader slotNo _ currBlockNo) _) _era) serverChainTip -> do let newLedgerStateE = applyBlock @@ -429,7 +435,7 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = do validationMode block case newLedgerStateE of - Left err -> clientIdle_DoneN n (Just err) + Left err -> clientIdle_DoneN q (Just err) Right newLedgerState -> do let (knownLedgerStates', committedStates) = pushLedgerState env knownLedgerStates slotNo newLedgerState blockInMode newClientTip = At currBlockNo @@ -445,35 +451,36 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = do =<< readIORef stateIORef writeIORef stateIORef newState if newClientTip == newServerTip - then clientIdle_DoneN n Nothing - else return (clientIdle_RequestMoreN newClientTip newServerTip n knownLedgerStates') + then clientIdle_DoneN q Nothing + else return (clientIdle_RequestMoreN newClientTip newServerTip q knownLedgerStates') , CSP.recvMsgRollBackward = \chainPoint serverChainTip -> do let newClientTip = Origin -- We don't actually keep track of blocks so we temporarily "forget" the tip. newServerTip = fromChainTip serverChainTip truncatedKnownLedgerStates = case chainPoint of ChainPointAtGenesis -> initialLedgerStateHistory ChainPoint slotNo _ -> rollBackLedgerStateHist knownLedgerStates slotNo - return (clientIdle_RequestMoreN newClientTip newServerTip n truncatedKnownLedgerStates) + return (clientIdle_RequestMoreN newClientTip newServerTip q truncatedKnownLedgerStates) } clientIdle_DoneN - :: Nat n -- Number of requests inflight. + :: SingQueueF CSP.F q -- Queue of requests inflight. -> Maybe LedgerStateError -- Return value (maybe an error) - -> IO (CSP.ClientPipelinedStIdle n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()) - clientIdle_DoneN n errorMay = case n of - Succ predN -> return (CSP.CollectResponse Nothing (clientNext_DoneN predN errorMay)) -- Ignore remaining message responses - Zero -> do + -> IO (CSP.ClientPipelinedStIdle (BlockInMode CardanoMode) ChainPoint ChainTip q IO ()) + clientIdle_DoneN q errorMay = case q of + SingConsF CSP.FCanAwait q' -> return (CSP.CollectResponse Nothing (clientNext_DoneN q' errorMay)) -- Ignore remaining message responses + SingConsF CSP.FMustReply q' -> return (CSP.CollectResponse Nothing (clientNext_DoneN q' errorMay)) -- Ignore remaining message responses + SingEmptyF -> do writeIORef errorIORef errorMay return (CSP.SendMsgDone ()) clientNext_DoneN - :: Nat n -- Number of requests inflight. + :: SingQueueF CSP.F q -- Queue of requests inflight. -> Maybe LedgerStateError -- Return value (maybe an error) - -> CSP.ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip IO () - clientNext_DoneN n errorMay = + -> CSP.ClientStNext (BlockInMode CardanoMode) ChainPoint ChainTip q IO () + clientNext_DoneN q errorMay = CSP.ClientStNext { - CSP.recvMsgRollForward = \_ _ -> clientIdle_DoneN n errorMay - , CSP.recvMsgRollBackward = \_ _ -> clientIdle_DoneN n errorMay + CSP.recvMsgRollForward = \_ _ -> clientIdle_DoneN q errorMay + , CSP.recvMsgRollBackward = \_ _ -> clientIdle_DoneN q errorMay } fromChainTip :: ChainTip -> WithOrigin BlockNo @@ -481,6 +488,8 @@ foldBlocks nodeConfigFilePath socketPath validationMode state0 accumulate = do ChainTipAtGenesis -> Origin ChainTip _ _ bno -> At bno + + -- | Wrap a 'ChainSyncClient' with logic that tracks the ledger state. chainSyncClientWithLedgerState :: forall m a. @@ -507,35 +516,18 @@ chainSyncClientWithLedgerState a -- ^ A client that acts just like the wrapped client but doesn't require the -- 'LedgerState' annotation on the block type. -chainSyncClientWithLedgerState env ledgerState0 validationMode (CS.ChainSyncClient clientTop) - = CS.ChainSyncClient (goClientStIdle (Right initialLedgerStateHistory) <$> clientTop) +chainSyncClientWithLedgerState env ledgerState0 validationMode = + CS.mapChainSyncClientSt id id id forward backward (Right initialLedgerStateHistory) where - goClientStIdle - :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) - -> CS.ClientStIdle (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CS.ClientStIdle (BlockInMode CardanoMode ) ChainPoint ChainTip m a - goClientStIdle history client = case client of - CS.SendMsgRequestNext a b -> CS.SendMsgRequestNext (goClientStNext history a) (goClientStNext history <$> b) - CS.SendMsgFindIntersect ps a -> CS.SendMsgFindIntersect ps (goClientStIntersect history a) - CS.SendMsgDone a -> CS.SendMsgDone a - - -- This is where the magic happens. We intercept the blocks and rollbacks - -- and use it to maintain the correct ledger state. - goClientStNext - :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) - -> CS.ClientStNext (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CS.ClientStNext (BlockInMode CardanoMode ) ChainPoint ChainTip m a - goClientStNext (Left err) (CS.ClientStNext recvMsgRollForward recvMsgRollBackward) = CS.ClientStNext - (\blkInMode tip -> CS.ChainSyncClient $ - goClientStIdle (Left err) <$> CS.runChainSyncClient - (recvMsgRollForward (blkInMode, Left err) tip) - ) - (\point tip -> CS.ChainSyncClient $ - goClientStIdle (Left err) <$> CS.runChainSyncClient (recvMsgRollBackward point tip) - ) - goClientStNext (Right history) (CS.ClientStNext recvMsgRollForward recvMsgRollBackward) = CS.ClientStNext - (\blkInMode@(BlockInMode blk@(Block (BlockHeader slotNo _ _) _) _) tip -> CS.ChainSyncClient $ let - newLedgerStateE = case Seq.lookup 0 history of + -- called on every 'MsgRollForward' + forward :: HistoryState + -> BlockInMode CardanoMode + -> ( (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) + , HistoryState + ) + forward state@(Left err) blkInMode = ((blkInMode, Left err), state) + forward (Right history) blkInMode@(BlockInMode blk@(Block (BlockHeader slotNo _ _) _) _) = + let newLedgerStateE = case Seq.lookup 0 history of Nothing -> error "Impossible! History should always be non-empty" Just (_, Left err, _) -> Left err Just (_, Right (oldLedgerState, _), _) -> applyBlock @@ -544,29 +536,25 @@ chainSyncClientWithLedgerState env ledgerState0 validationMode (CS.ChainSyncClie validationMode blk (history', _) = pushLedgerState env history slotNo newLedgerStateE blkInMode - in goClientStIdle (Right history') <$> CS.runChainSyncClient - (recvMsgRollForward (blkInMode, newLedgerStateE) tip) - ) - (\point tip -> let - oldestSlot = case history of + in ((blkInMode, newLedgerStateE), Right history') + + -- called on every 'MsgRollBackward' + backward :: HistoryState -> ChainPoint -> HistoryState + backward state@Left {} _ = state + backward (Right history) point = + let oldestSlot = case history of _ Seq.:|> (s, _, _) -> s Seq.Empty -> error "Impossible! History should always be non-empty" - history' = (\h -> if Seq.null h - then Left (InvalidRollback oldestSlot point) - else Right h) - $ case point of - ChainPointAtGenesis -> initialLedgerStateHistory - ChainPoint slotNo _ -> rollBackLedgerStateHist history slotNo - in CS.ChainSyncClient $ goClientStIdle history' <$> CS.runChainSyncClient (recvMsgRollBackward point tip) - ) - goClientStIntersect - :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) - -> CS.ClientStIntersect (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CS.ClientStIntersect (BlockInMode CardanoMode ) ChainPoint ChainTip m a - goClientStIntersect history (CS.ClientStIntersect recvMsgIntersectFound recvMsgIntersectNotFound) = CS.ClientStIntersect - (\point tip -> CS.ChainSyncClient (goClientStIdle history <$> CS.runChainSyncClient (recvMsgIntersectFound point tip))) - (\tip -> CS.ChainSyncClient (goClientStIdle history <$> CS.runChainSyncClient (recvMsgIntersectNotFound tip))) + state' :: HistoryState + state' = + (\h -> if Seq.null h + then Left (InvalidRollback oldestSlot point) + else Right h + ) $ case point of + ChainPointAtGenesis -> initialLedgerStateHistory + ChainPoint slotNo _ -> rollBackLedgerStateHist history slotNo + in state' initialLedgerStateHistory :: History (Either LedgerStateError LedgerStateEvents) initialLedgerStateHistory = Seq.singleton (0, Right (ledgerState0, []), Origin) @@ -590,40 +578,18 @@ chainSyncClientPipelinedWithLedgerState ChainTip m a -chainSyncClientPipelinedWithLedgerState env ledgerState0 validationMode (CSP.ChainSyncClientPipelined clientTop) - = CSP.ChainSyncClientPipelined (goClientPipelinedStIdle (Right initialLedgerStateHistory) Zero <$> clientTop) +chainSyncClientPipelinedWithLedgerState env ledgerState0 validationMode = + CSP.mapChainSyncClientPipelinedSt id id id forward backward (Right initialLedgerStateHistory) where - goClientPipelinedStIdle - :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) - -> Nat n - -> CSP.ClientPipelinedStIdle n (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CSP.ClientPipelinedStIdle n (BlockInMode CardanoMode ) ChainPoint ChainTip m a - goClientPipelinedStIdle history n client = case client of - CSP.SendMsgRequestNext a b -> CSP.SendMsgRequestNext (goClientStNext history n a) (goClientStNext history n <$> b) - CSP.SendMsgRequestNextPipelined a -> CSP.SendMsgRequestNextPipelined (goClientPipelinedStIdle history (Succ n) a) - CSP.SendMsgFindIntersect ps a -> CSP.SendMsgFindIntersect ps (goClientPipelinedStIntersect history n a) - CSP.CollectResponse a b -> case n of - Succ nPrev -> CSP.CollectResponse ((fmap . fmap) (goClientPipelinedStIdle history n) a) (goClientStNext history nPrev b) - CSP.SendMsgDone a -> CSP.SendMsgDone a - - -- This is where the magic happens. We intercept the blocks and rollbacks - -- and use it to maintain the correct ledger state. - goClientStNext - :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) - -> Nat n - -> CSP.ClientStNext n (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CSP.ClientStNext n (BlockInMode CardanoMode ) ChainPoint ChainTip m a - goClientStNext (Left err) n (CSP.ClientStNext recvMsgRollForward recvMsgRollBackward) = CSP.ClientStNext - (\blkInMode tip -> - goClientPipelinedStIdle (Left err) n <$> recvMsgRollForward - (blkInMode, Left err) tip - ) - (\point tip -> - goClientPipelinedStIdle (Left err) n <$> recvMsgRollBackward point tip - ) - goClientStNext (Right history) n (CSP.ClientStNext recvMsgRollForward recvMsgRollBackward) = CSP.ClientStNext - (\blkInMode@(BlockInMode blk@(Block (BlockHeader slotNo _ _) _) _) tip -> let - newLedgerStateE = case Seq.lookup 0 history of + -- called on every 'MsgRollForward' + forward :: HistoryState + -> BlockInMode CardanoMode + -> ( (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) + , HistoryState + ) + forward state@(Left err) blkInMode = ((blkInMode, Left err), state) + forward (Right history) blkInMode@(BlockInMode blk@(Block (BlockHeader slotNo _ _) _) _) = + let newLedgerStateE = case Seq.lookup 0 history of Nothing -> error "Impossible! History should always be non-empty" Just (_, Left err, _) -> Left err Just (_, Right (oldLedgerState, _), _) -> applyBlock @@ -632,36 +598,29 @@ chainSyncClientPipelinedWithLedgerState env ledgerState0 validationMode (CSP.Cha validationMode blk (history', _) = pushLedgerState env history slotNo newLedgerStateE blkInMode - in goClientPipelinedStIdle (Right history') n <$> recvMsgRollForward - (blkInMode, newLedgerStateE) tip - ) - (\point tip -> let - oldestSlot = case history of + in ((blkInMode, newLedgerStateE), Right history') + + -- called on every 'MsgRollBackward' + backward :: HistoryState -> ChainPoint -> HistoryState + backward state@Left {} _ = state + backward (Right history) point = + let oldestSlot = case history of _ Seq.:|> (s, _, _) -> s Seq.Empty -> error "Impossible! History should always be non-empty" - history' = (\h -> if Seq.null h - then Left (InvalidRollback oldestSlot point) - else Right h) - $ case point of - ChainPointAtGenesis -> initialLedgerStateHistory - ChainPoint slotNo _ -> rollBackLedgerStateHist history slotNo - in goClientPipelinedStIdle history' n <$> recvMsgRollBackward point tip - ) - goClientPipelinedStIntersect - :: Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) - -> Nat n - -> CSP.ClientPipelinedStIntersect (BlockInMode CardanoMode, Either LedgerStateError (LedgerState, [LedgerEvent])) ChainPoint ChainTip m a - -> CSP.ClientPipelinedStIntersect (BlockInMode CardanoMode ) ChainPoint ChainTip m a - goClientPipelinedStIntersect history _ (CSP.ClientPipelinedStIntersect recvMsgIntersectFound recvMsgIntersectNotFound) = CSP.ClientPipelinedStIntersect - (\point tip -> goClientPipelinedStIdle history Zero <$> recvMsgIntersectFound point tip) - (\tip -> goClientPipelinedStIdle history Zero <$> recvMsgIntersectNotFound tip) + state' :: HistoryState + state' = + (\h -> if Seq.null h + then Left (InvalidRollback oldestSlot point) + else Right h + ) $ case point of + ChainPointAtGenesis -> initialLedgerStateHistory + ChainPoint slotNo _ -> rollBackLedgerStateHist history slotNo + in state' initialLedgerStateHistory :: History (Either LedgerStateError LedgerStateEvents) initialLedgerStateHistory = Seq.singleton (0, Right (ledgerState0, []), Origin) -{- HLINT ignore chainSyncClientPipelinedWithLedgerState "Use fmap" -} - -- | A history of k (security parameter) recent ledger states. The head is the -- most recent item. Elements are: -- @@ -671,6 +630,8 @@ chainSyncClientPipelinedWithLedgerState env ledgerState0 validationMode (CSP.Cha -- type LedgerStateHistory = History LedgerStateEvents type History a = Seq (SlotNo, a, WithOrigin (BlockInMode CardanoMode)) +type HistoryState = Either LedgerStateError (History (Either LedgerStateError LedgerStateEvents)) + -- | Add a new ledger state to the history pushLedgerState diff --git a/cardano-api/src/Cardano/Api/Query.hs b/cardano-api/src/Cardano/Api/Query.hs index da103745186..4352813bc97 100644 --- a/cardano-api/src/Cardano/Api/Query.hs +++ b/cardano-api/src/Cardano/Api/Query.hs @@ -84,7 +84,7 @@ import Data.Text (Text) import Data.Typeable import Prelude -import Ouroboros.Network.Protocol.LocalStateQuery.Client (Some (..)) +import Ouroboros.Network.Protocol.LocalStateQuery.Codec (Some (..)) import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch) From b8bc6fbdd7f2cc415f41d7a6b97e7ad0f7c73517 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 9 May 2022 19:00:18 +0200 Subject: [PATCH 3/4] Updated cardano-node --- cardano-node/cardano-node.cabal | 1 + .../src/Cardano/Node/TraceConstraints.hs | 3 + .../src/Cardano/Node/Tracing/Documentation.hs | 2 + .../Cardano/Node/Tracing/Tracers/Diffusion.hs | 22 +- .../Node/Tracing/Tracers/NodeToClient.hs | 231 ++++------ .../Node/Tracing/Tracers/NodeToNode.hs | 214 ++++------ .../Tracing/OrphanInstances/Network.hs | 399 ++++++++---------- cardano-node/src/Cardano/Tracing/Tracers.hs | 8 +- 8 files changed, 384 insertions(+), 496 deletions(-) diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index cfa205f4080..65d3aed8a0b 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -173,6 +173,7 @@ library , psqueues , safe-exceptions , scientific + , singletons , strict-stm , cardano-ledger-shelley , small-steps diff --git a/cardano-node/src/Cardano/Node/TraceConstraints.hs b/cardano-node/src/Cardano/Node/TraceConstraints.hs index d72573c3e3a..fa00e176864 100644 --- a/cardano-node/src/Cardano/Node/TraceConstraints.hs +++ b/cardano-node/src/Cardano/Node/TraceConstraints.hs @@ -4,6 +4,7 @@ module Cardano.Node.TraceConstraints (TraceConstraints) where +import Prelude (Show) import Data.Aeson import Cardano.BM.Tracing (ToObject) @@ -31,6 +32,8 @@ type TraceConstraints blk = , HasKESMetricsData blk , HasKESInfo blk , GetKESInfo blk + , Show blk + , Show (Header blk) , ToObject (ApplyTxErr blk) , ToObject (GenTx blk) diff --git a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs index d9e612d7c30..c5f1f6d7b1d 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Documentation.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Documentation.hs @@ -50,6 +50,7 @@ import Cardano.Node.TraceConstraints import Ouroboros.Consensus.Block.Forging +import Ouroboros.Consensus.Block.NestedContent (HasNestedContent) import Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime) import Ouroboros.Consensus.BlockchainTime.WallClock.Util (TraceBlockchainTimeEvent (..)) import Ouroboros.Consensus.Cardano.Block @@ -175,6 +176,7 @@ docTracers :: forall blk peer remotePeer. , Show (ForgeStateUpdateError blk) , Show (CannotForge blk) , ShowQuery (BlockQuery blk) + , HasNestedContent Header blk ) => FilePath -> FilePath diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs index ce2c5c48cce..1c5526ababf 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs @@ -37,7 +37,7 @@ import Data.Aeson (Value (String), (.=)) import Data.Text (pack) import Network.Mux (MuxTrace (..), WithMuxBearer (..)) import qualified Network.Socket as Socket -import Network.TypedProtocol.Codec (AnyMessageAndAgency (..)) +import Network.TypedProtocol.Codec (AnyMessage (..)) import Text.Show import Cardano.Node.Configuration.TopologyP2P (UseLedger (..)) @@ -74,6 +74,8 @@ severityMux' MuxTraceChannelRecvStart {} = Debug severityMux' MuxTraceChannelRecvEnd {} = Debug severityMux' MuxTraceChannelSendStart {} = Debug severityMux' MuxTraceChannelSendEnd {} = Debug +severityMux' MuxTraceChannelTryRecvStart {} = Debug +severityMux' MuxTraceChannelTryRecvEnd {} = Debug severityMux' MuxTraceHandshakeStart = Debug severityMux' MuxTraceHandshakeClientEnd {} = Info severityMux' MuxTraceHandshakeServerEnd = Debug @@ -107,6 +109,8 @@ namesForMux' MuxTraceChannelRecvStart {} = ["ChannelRecvStart"] namesForMux' MuxTraceChannelRecvEnd {} = ["ChannelRecvEnd"] namesForMux' MuxTraceChannelSendStart {} = ["ChannelSendStart"] namesForMux' MuxTraceChannelSendEnd {} = ["ChannelSendEnd"] +namesForMux' MuxTraceChannelTryRecvStart {} = ["ChannelTryRecvStart"] +namesForMux' MuxTraceChannelTryRecvEnd {} = ["ChannelTryRecvEnd"] namesForMux' MuxTraceHandshakeStart = ["HandshakeStart "] namesForMux' MuxTraceHandshakeClientEnd {} = ["HandshakeClientEnd"] namesForMux' MuxTraceHandshakeServerEnd = ["HandshakeServerEnd"] @@ -271,8 +275,8 @@ severityHandshake' :: severityHandshake' (TraceSendMsg m) = severityHandshake'' m severityHandshake' (TraceRecvMsg m) = severityHandshake'' m -severityHandshake'' :: AnyMessageAndAgency (HS.Handshake nt CBOR.Term) -> SeverityS -severityHandshake'' (AnyMessageAndAgency _agency msg) = severityHandshake''' msg +severityHandshake'' :: AnyMessage (HS.Handshake nt CBOR.Term) -> SeverityS +severityHandshake'' (AnyMessage msg) = severityHandshake''' msg severityHandshake''' :: Message (HS.Handshake nt CBOR.Term) from to -> SeverityS severityHandshake''' HS.MsgProposeVersions {} = Info @@ -289,8 +293,8 @@ namesForHandshake' :: namesForHandshake' (TraceSendMsg m) = "Send" : namesForHandshake'' m namesForHandshake' (TraceRecvMsg m) = "Receive" : namesForHandshake'' m -namesForHandshake'' :: AnyMessageAndAgency (HS.Handshake nt CBOR.Term) -> [Text] -namesForHandshake'' (AnyMessageAndAgency _agency msg) = namesForHandshake''' msg +namesForHandshake'' :: AnyMessage (HS.Handshake nt CBOR.Term) -> [Text] +namesForHandshake'' (AnyMessage msg) = namesForHandshake''' msg namesForHandshake''' :: Message (HS.Handshake nt CBOR.Term) from to -> [Text] namesForHandshake''' HS.MsgProposeVersions {} = ["ProposeVersions"] @@ -348,8 +352,8 @@ severityLocalHandshake' :: severityLocalHandshake' (TraceSendMsg m) = severityLocalHandshake'' m severityLocalHandshake' (TraceRecvMsg m) = severityLocalHandshake'' m -severityLocalHandshake'' :: AnyMessageAndAgency (HS.Handshake nt CBOR.Term) -> SeverityS -severityLocalHandshake'' (AnyMessageAndAgency _agency msg) = severityLocalHandshake''' msg +severityLocalHandshake'' :: AnyMessage (HS.Handshake nt CBOR.Term) -> SeverityS +severityLocalHandshake'' (AnyMessage msg) = severityLocalHandshake''' msg severityLocalHandshake''' :: Message (HS.Handshake nt CBOR.Term) from to -> SeverityS severityLocalHandshake''' HS.MsgProposeVersions {} = Info @@ -366,8 +370,8 @@ namesForLocalHandshake' :: namesForLocalHandshake' (TraceSendMsg m) = "Send" : namesForLocalHandshake'' m namesForLocalHandshake' (TraceRecvMsg m) = "Receive" : namesForLocalHandshake'' m -namesForLocalHandshake'' :: AnyMessageAndAgency (HS.Handshake nt CBOR.Term) -> [Text] -namesForLocalHandshake'' (AnyMessageAndAgency _agency msg) = namesForLocalHandshake''' msg +namesForLocalHandshake'' :: AnyMessage (HS.Handshake nt CBOR.Term) -> [Text] +namesForLocalHandshake'' (AnyMessage msg) = namesForLocalHandshake''' msg namesForLocalHandshake''' :: Message (HS.Handshake nt CBOR.Term) from to -> [Text] namesForLocalHandshake''' HS.MsgProposeVersions {} = ["ProposeVersions"] diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs index 9934ed526ca..dff5bcde57b 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} @@ -30,8 +32,7 @@ module Cardano.Node.Tracing.Tracers.NodeToClient import Cardano.Logging import Cardano.Prelude hiding (Show, show) import Data.Aeson (Value (String), (.=)) -import Data.Text (pack) -import Network.TypedProtocol.Codec (AnyMessageAndAgency (..)) +import Network.TypedProtocol.Codec (AnyMessage (..)) import Text.Show import Cardano.Slotting.Slot (SlotNo) @@ -49,8 +50,10 @@ import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LSQ import qualified Ouroboros.Network.Protocol.LocalTxMonitor.Type as LTM import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS +import Cardano.Node.Tracing.Tracers.NodeToNode (formatMessageWithAgency) -instance LogFormatting (AnyMessageAndAgency ps) + +instance LogFormatting (AnyMessage ps) => LogFormatting (TraceSendRecv ps) where forMachine dtal (TraceSendMsg m) = mconcat [ "kind" .= String "Send" , "msg" .= forMachine dtal m ] @@ -75,7 +78,7 @@ severityTChainSync (BlockFetch.TraceLabelPeer _ v) = severityTChainSync' v severityTChainSync' (TraceSendMsg msg) = severityTChainSync'' msg severityTChainSync' (TraceRecvMsg msg) = severityTChainSync'' msg - severityTChainSync'' (AnyMessageAndAgency _agency msg) = severityTChainSync''' msg + severityTChainSync'' (AnyMessage msg) = severityTChainSync''' msg severityTChainSync''' :: Message (ChainSync header point tip) from to @@ -97,7 +100,7 @@ namesForTChainSync (BlockFetch.TraceLabelPeer _ v) = namesTChainSync v namesTChainSync (TraceSendMsg msg) = "Send" : namesTChainSync' msg namesTChainSync (TraceRecvMsg msg) = "Receive" : namesTChainSync' msg - namesTChainSync' (AnyMessageAndAgency _agency msg) = namesTChainSync'' msg + namesTChainSync' (AnyMessage msg) = namesTChainSync'' msg namesTChainSync'' :: Message (ChainSync header point tip) from to -> [Text] @@ -111,39 +114,25 @@ namesForTChainSync (BlockFetch.TraceLabelPeer _ v) = namesTChainSync v namesTChainSync'' MsgDone {} = ["Done"] -instance LogFormatting (AnyMessageAndAgency (ChainSync blk pt tip)) where - forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgRequestNext{}) = - mconcat [ "kind" .= String "MsgRequestNext" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgAwaitReply{}) = - mconcat [ "kind" .= String "MsgAwaitReply" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgRollForward{}) = - mconcat [ "kind" .= String "MsgRollForward" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgRollBackward{}) = - mconcat [ "kind" .= String "MsgRollBackward" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgFindIntersect{}) = - mconcat [ "kind" .= String "MsgFindIntersect" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgIntersectFound{}) = - mconcat [ "kind" .= String "MsgIntersectFound" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgIntersectNotFound{}) = - mconcat [ "kind" .= String "MsgIntersectNotFound" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgDone{}) = - mconcat [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] +instance ( forall (st :: ChainSync blk pt tip) (st' :: ChainSync blk pt tip). + Show (Message (ChainSync blk pt tip) st st')) + => LogFormatting (AnyMessage (ChainSync blk pt tip)) where + forMachine dtal (AnyMessage msg@ChainSync.MsgRequestNext {}) = + formatMessageWithAgency dtal msg "MsgRequestNext" + forMachine dtal (AnyMessage msg@ChainSync.MsgAwaitReply{}) = + formatMessageWithAgency dtal msg "MsgAwaitReply" + forMachine dtal (AnyMessage msg@ChainSync.MsgRollForward{}) = + formatMessageWithAgency dtal msg "MsgRollForward" + forMachine dtal (AnyMessage msg@ChainSync.MsgRollBackward{}) = + formatMessageWithAgency dtal msg "MsgRollBackward" + forMachine dtal (AnyMessage msg@ChainSync.MsgFindIntersect{}) = + formatMessageWithAgency dtal msg "MsgFindIntersect" + forMachine dtal (AnyMessage msg@ChainSync.MsgIntersectFound{}) = + formatMessageWithAgency dtal msg "MsgIntersectFound" + forMachine dtal (AnyMessage msg@ChainSync.MsgIntersectNotFound{}) = + formatMessageWithAgency dtal msg "MsgIntersectNotFound" + forMachine dtal (AnyMessage msg@ChainSync.MsgDone{}) = + formatMessageWithAgency dtal msg "MsgDone" docTChainSyncNodeToClient :: Documented (BlockFetch.TraceLabelPeer peer (TraceSendRecv (ChainSync x (Point blk) (Tip blk)))) @@ -241,7 +230,7 @@ namesForTTxMonitor (TraceLabelPeer _ v) = namesForTTxMonitor' v namesForTTxMonitor' (TraceSendMsg msg) = "Send" : namesForTTxMonitor'' msg namesForTTxMonitor' (TraceRecvMsg msg) = "Receive" : namesForTTxMonitor'' msg - namesForTTxMonitor'' (AnyMessageAndAgency _agency msg) = namesForTTxMonitor''' msg + namesForTTxMonitor'' (AnyMessage msg) = namesForTTxMonitor''' msg namesForTTxMonitor''' :: Message (LTM.LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo) from to @@ -258,51 +247,32 @@ namesForTTxMonitor (TraceLabelPeer _ v) = namesForTTxMonitor' v namesForTTxMonitor''' LTM.MsgRelease {} = ["Release"] namesForTTxMonitor''' LTM.MsgDone {} = ["Done"] -instance LogFormatting (AnyMessageAndAgency (LTM.LocalTxMonitor txid tx slotNo)) where - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgAcquire {}) = - mconcat [ "kind" .= String "MsgAcquire" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgAcquired {}) = - mconcat [ "kind" .= String "MsgAcquired" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgAwaitAcquire {}) = - mconcat [ "kind" .= String "MsgAwaitAcquire" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgNextTx {}) = - mconcat [ "kind" .= String "MsgNextTx" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgReplyNextTx {}) = - mconcat [ "kind" .= String "MsgReplyNextTx" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgHasTx {}) = - mconcat [ "kind" .= String "MsgHasTx" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgReplyHasTx {}) = - mconcat [ "kind" .= String "MsgReplyHasTx" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgGetSizes {}) = - mconcat [ "kind" .= String "MsgGetSizes" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgReplyGetSizes {}) = - mconcat [ "kind" .= String "MsgReplyGetSizes" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgRelease {}) = - mconcat [ "kind" .= String "MsgRelease" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LTM.MsgDone {}) = - mconcat [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] +instance (forall (st :: LTM.LocalTxMonitor txid tx slotNo) + (st' :: LTM.LocalTxMonitor txid tx slotNo). + Show (Message (LTM.LocalTxMonitor txid tx slotNo) st st')) + => LogFormatting (AnyMessage (LTM.LocalTxMonitor txid tx slotNo)) where + forMachine dtal (AnyMessage msg@LTM.MsgAcquire {}) = + formatMessageWithAgency dtal msg "MsgAcquire" + forMachine dtal (AnyMessage msg@LTM.MsgAcquired {}) = + formatMessageWithAgency dtal msg "MsgAcquired" + forMachine dtal (AnyMessage msg@LTM.MsgAwaitAcquire {}) = + formatMessageWithAgency dtal msg "MsgAwaitAcquire" + forMachine dtal (AnyMessage msg@LTM.MsgNextTx {}) = + formatMessageWithAgency dtal msg "MsgNextTx" + forMachine dtal (AnyMessage msg@LTM.MsgReplyNextTx {}) = + formatMessageWithAgency dtal msg "MsgReplyNextTx" + forMachine dtal (AnyMessage msg@LTM.MsgHasTx {}) = + formatMessageWithAgency dtal msg "MsgHasTx" + forMachine dtal (AnyMessage msg@LTM.MsgReplyHasTx {}) = + formatMessageWithAgency dtal msg "MsgReplyHasTx" + forMachine dtal (AnyMessage msg@LTM.MsgGetSizes {}) = + formatMessageWithAgency dtal msg "MsgGetSizes" + forMachine dtal (AnyMessage msg@LTM.MsgReplyGetSizes {}) = + formatMessageWithAgency dtal msg "MsgReplyGetSizes" + forMachine dtal (AnyMessage msg@LTM.MsgRelease {}) = + formatMessageWithAgency dtal msg "MsgRelease" + forMachine dtal (AnyMessage msg@LTM.MsgDone {}) = + formatMessageWithAgency dtal msg "MsgDone" docTTxMonitor :: Documented (TraceLabelPeer @@ -327,7 +297,7 @@ severityTTxSubmission (BlockFetch.TraceLabelPeer _ v) = severityTTxSubmission' v severityTTxSubmission' (TraceSendMsg msg) = severityTTxSubmission'' msg severityTTxSubmission' (TraceRecvMsg msg) = severityTTxSubmission'' msg - severityTTxSubmission'' (AnyMessageAndAgency _agency msg) = severityTTxSubmission''' msg + severityTTxSubmission'' (AnyMessage msg) = severityTTxSubmission''' msg severityTTxSubmission''' :: Message (LTS.LocalTxSubmission tx reject) from to @@ -346,7 +316,7 @@ namesForTTxSubmission (BlockFetch.TraceLabelPeer _ v) = namesTTxSubmission v namesTTxSubmission (TraceSendMsg msg) = "Send" : namesTTxSubmission' msg namesTTxSubmission (TraceRecvMsg msg) = "Receive" : namesTTxSubmission' msg - namesTTxSubmission' (AnyMessageAndAgency _agency msg) = namesTTxSubmission'' msg + namesTTxSubmission' (AnyMessage msg) = namesTTxSubmission'' msg namesTTxSubmission'' :: Message (LTS.LocalTxSubmission tx reject) from to @@ -357,23 +327,18 @@ namesForTTxSubmission (BlockFetch.TraceLabelPeer _ v) = namesTTxSubmission v namesTTxSubmission'' LTS.MsgDone {} = ["Done"] -instance LogFormatting (AnyMessageAndAgency (LTS.LocalTxSubmission tx err)) where - forMachine _dtal (AnyMessageAndAgency stok LTS.MsgSubmitTx{}) = - mconcat [ "kind" .= String "MsgSubmitTx" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LTS.MsgAcceptTx{}) = - mconcat [ "kind" .= String "MsgAcceptTx" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LTS.MsgRejectTx{}) = - mconcat [ "kind" .= String "MsgRejectTx" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LTS.MsgDone{}) = - mconcat [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] +instance (forall (st :: LTS.LocalTxSubmission tx err) + (st' :: LTS.LocalTxSubmission tx err). + Show (Message (LTS.LocalTxSubmission tx err) st st')) + => LogFormatting (AnyMessage (LTS.LocalTxSubmission tx err)) where + forMachine dtal (AnyMessage msg@LTS.MsgSubmitTx{}) = + formatMessageWithAgency dtal msg "MsgSubmitTx" + forMachine dtal (AnyMessage msg@LTS.MsgAcceptTx{}) = + formatMessageWithAgency dtal msg "MsgAcceptTx" + forMachine dtal (AnyMessage msg@LTS.MsgRejectTx{}) = + formatMessageWithAgency dtal msg "MsgRejectTx" + forMachine dtal (AnyMessage msg@LTS.MsgDone{}) = + formatMessageWithAgency dtal msg "MsgDone" docTTxSubmission :: Documented (BlockFetch.TraceLabelPeer @@ -424,7 +389,7 @@ severityTStateQuery (BlockFetch.TraceLabelPeer _ v) = severityTStateQuery' v severityTStateQuery' (TraceSendMsg msg) = severityTStateQuery'' msg severityTStateQuery' (TraceRecvMsg msg) = severityTStateQuery'' msg - severityTStateQuery'' (AnyMessageAndAgency _agency msg) = severityTStateQuery''' msg + severityTStateQuery'' (AnyMessage msg) = severityTStateQuery''' msg severityTStateQuery''' :: Message (LSQ.LocalStateQuery block point query1) from to @@ -446,7 +411,7 @@ namesForTStateQuery (BlockFetch.TraceLabelPeer _ v) = namesForTStateQuery' v namesForTStateQuery' (TraceSendMsg msg) = "Send" : namesForTStateQuery'' msg namesForTStateQuery' (TraceRecvMsg msg) = "Receive" : namesForTStateQuery'' msg - namesForTStateQuery'' (AnyMessageAndAgency _agency msg) = namesForTStateQuery''' msg + namesForTStateQuery'' (AnyMessage msg) = namesForTStateQuery''' msg namesForTStateQuery''' :: Message (LSQ.LocalStateQuery block point query1) from to @@ -461,40 +426,28 @@ namesForTStateQuery (BlockFetch.TraceLabelPeer _ v) = namesForTStateQuery' v namesForTStateQuery''' LSQ.MsgReAcquire {} = ["ReAcquire"] namesForTStateQuery''' LSQ.MsgDone {} = ["Done"] -instance (forall result. Show (Query blk result)) - => LogFormatting (AnyMessageAndAgency (LSQ.LocalStateQuery blk pt (Query blk))) where - forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgAcquire{}) = - mconcat [ "kind" .= String "MsgAcquire" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgAcquired{}) = - mconcat [ "kind" .= String "MsgAcquired" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgFailure{}) = - mconcat [ "kind" .= String "MsgFailure" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgQuery{}) = - mconcat [ "kind" .= String "MsgQuery" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgResult{}) = - mconcat [ "kind" .= String "MsgResult" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgRelease{}) = - mconcat [ "kind" .= String "MsgRelease" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgReAcquire{}) = - mconcat [ "kind" .= String "MsgReAcquire" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgDone{}) = - mconcat [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] +instance ( forall result. Show (Query blk result) + , forall (st :: LSQ.LocalStateQuery blk pt (Query blk)) + (st' :: LSQ.LocalStateQuery blk pt (Query blk)). + Show (Message (LSQ.LocalStateQuery blk pt (Query blk)) st st') + ) + => LogFormatting (AnyMessage (LSQ.LocalStateQuery blk pt (Query blk))) where + forMachine dtal (AnyMessage msg@LSQ.MsgAcquire{}) = + formatMessageWithAgency dtal msg "MsgAcquire" + forMachine dtal (AnyMessage msg@LSQ.MsgAcquired{}) = + formatMessageWithAgency dtal msg "MsgAcquired" + forMachine dtal (AnyMessage msg@LSQ.MsgFailure{}) = + formatMessageWithAgency dtal msg "MsgFailure" + forMachine dtal (AnyMessage msg@LSQ.MsgQuery{}) = + formatMessageWithAgency dtal msg "MsgQuery" + forMachine dtal (AnyMessage msg@LSQ.MsgResult{}) = + formatMessageWithAgency dtal msg "MsgResult" + forMachine dtal (AnyMessage msg@LSQ.MsgRelease{}) = + formatMessageWithAgency dtal msg "MsgRelease" + forMachine dtal (AnyMessage msg@LSQ.MsgReAcquire{}) = + formatMessageWithAgency dtal msg "MsgReAcquire" + forMachine dtal (AnyMessage msg@LSQ.MsgDone{}) = + formatMessageWithAgency dtal msg "MsgDone" docTStateQuery :: Documented (BlockFetch.TraceLabelPeer peer diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs index fe642a390ec..82a37f241a3 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -30,13 +31,17 @@ module Cardano.Node.Tracing.Tracers.NodeToNode , severityTxSubmission2Node , namesForTxSubmission2Node , docTTxSubmission2Node + -- * Utils + , formatMessageWithAgency ) where +import Prelude (String) import Cardano.Logging import Cardano.Prelude hiding (Show, show) -import Data.Aeson (Value (String), toJSON, (.=)) +import Data.Aeson (Value (String), toJSON, (.=), Object) +import Data.Singletons import Data.Text (pack) -import Network.TypedProtocol.Codec (AnyMessageAndAgency (..)) +import Network.TypedProtocol.Codec (AnyMessage (..)) import Text.Show import Cardano.Node.Queries (ConvertTxId) @@ -68,7 +73,7 @@ severityTChainSyncNode (BlockFetch.TraceLabelPeer _ v) = severityTChainSync' v severityTChainSync' (TraceSendMsg msg) = severityTChainSync'' msg severityTChainSync' (TraceRecvMsg msg) = severityTChainSync'' msg - severityTChainSync'' (AnyMessageAndAgency _agency msg) = severityTChainSync''' msg + severityTChainSync'' (AnyMessage msg) = severityTChainSync''' msg severityTChainSync''' :: Message (ChainSync header point tip) from to @@ -90,7 +95,7 @@ namesForTChainSyncNode (BlockFetch.TraceLabelPeer _ v) = namesTChainSync v namesTChainSync (TraceSendMsg msg) = "Send" : namesTChainSync' msg namesTChainSync (TraceRecvMsg msg) = "Receive" : namesTChainSync' msg - namesTChainSync' (AnyMessageAndAgency _agency msg) = namesTChainSync'' msg + namesTChainSync' (AnyMessage msg) = namesTChainSync'' msg namesTChainSync'' :: Message (ChainSync header point tip) from to -> [Text] @@ -114,7 +119,7 @@ severityTChainSyncSerialised (BlockFetch.TraceLabelPeer _ v) = severityTChainSyn severityTChainSync' (TraceSendMsg msg) = severityTChainSync'' msg severityTChainSync' (TraceRecvMsg msg) = severityTChainSync'' msg - severityTChainSync'' (AnyMessageAndAgency _agency msg) = severityTChainSync''' msg + severityTChainSync'' (AnyMessage msg) = severityTChainSync''' msg severityTChainSync''' :: Message (ChainSync header point tip) from to @@ -135,7 +140,7 @@ namesForTChainSyncSerialised (BlockFetch.TraceLabelPeer _ v) = namesTChainSync v namesTChainSync (TraceSendMsg msg) = "Send" : namesTChainSync' msg namesTChainSync (TraceRecvMsg msg) = "Receive" : namesTChainSync' msg - namesTChainSync' (AnyMessageAndAgency _agency msg) = namesTChainSync'' msg + namesTChainSync' (AnyMessage msg) = namesTChainSync'' msg namesTChainSync'' :: Message (ChainSync header point tip) from to -> [Text] @@ -159,7 +164,7 @@ severityTBlockFetch (BlockFetch.TraceLabelPeer _ v) = severityTBlockFetch' v severityTBlockFetch' (TraceSendMsg msg) = severityTBlockFetch'' msg severityTBlockFetch' (TraceRecvMsg msg) = severityTBlockFetch'' msg - severityTBlockFetch'' (AnyMessageAndAgency _agency msg) = severityTBlockFetch''' msg + severityTBlockFetch'' (AnyMessage msg) = severityTBlockFetch''' msg severityTBlockFetch''' :: Message (BlockFetch x (Point blk)) from to -> SeverityS @@ -177,7 +182,7 @@ namesForTBlockFetch (BlockFetch.TraceLabelPeer _ v) = namesTBlockFetch v namesTBlockFetch (TraceSendMsg msg) = "Send" : namesTBlockFetch' msg namesTBlockFetch (TraceRecvMsg msg) = "Receive" : namesTBlockFetch' msg - namesTBlockFetch' (AnyMessageAndAgency _agency msg) = namesTBlockFetch'' msg + namesTBlockFetch' (AnyMessage msg) = namesTBlockFetch'' msg namesTBlockFetch'' :: Message (BlockFetch x (Point blk)) from to -> [Text] @@ -188,6 +193,25 @@ namesForTBlockFetch (BlockFetch.TraceLabelPeer _ v) = namesTBlockFetch v namesTBlockFetch'' MsgBatchDone {} = ["BatchDone"] namesTBlockFetch'' MsgClientDone {} = ["ClientDone"] + +formatMessageWithAgency :: forall ps (st :: ps) (st' :: ps). + SingI st + => Show (Sing st) + => Show (Message ps st st') + => DetailLevel + -> Message ps st st' + -> String + -> Object +formatMessageWithAgency dtal msg _condensed | dtal >= DMaximum = + mconcat [ "kind" .= String (pack $ show msg) + , "agency" .= String (pack $ show (sing :: Sing st)) + ] +formatMessageWithAgency _ _msg condensed = + mconcat [ "kind" .= String (pack condensed) + , "agency" .= String (pack $ show (sing :: Sing st)) + ] + + instance ( ConvertTxId blk , ConvertRawHash blk , HasHeader blk @@ -196,46 +220,34 @@ instance ( ConvertTxId blk , SerialiseNodeToNodeConstraints blk , HasTxs blk , LedgerSupportsMempool blk - ) - => LogFormatting (AnyMessageAndAgency (BlockFetch blk (Point blk))) where - forMachine DMinimal (AnyMessageAndAgency stok (MsgBlock blk)) = - mconcat [ "kind" .= String "MsgBlock" - , "agency" .= String (pack $ show stok) - , "blockHash" .= renderHeaderHash (Proxy @blk) (blockHash blk) - , "blockSize" .= toJSON (estimateBlockSize (getHeader blk)) - ] - - forMachine dtal (AnyMessageAndAgency stok (MsgBlock blk)) = - mconcat [ "kind" .= String "MsgBlock" - , "agency" .= String (pack $ show stok) - , "blockHash" .= renderHeaderHash (Proxy @blk) (blockHash blk) - , "blockSize" .= toJSON (estimateBlockSize (getHeader blk)) - , "txIds" .= toJSON (presentTx <$> extractTxs blk) - ] + , Show blk) + => LogFormatting (AnyMessage (BlockFetch blk (Point blk))) where + forMachine dtal@DMinimal (AnyMessage msg@(MsgBlock blk)) = + formatMessageWithAgency dtal msg "MsgBlock" + <> mconcat [ "blockHash" .= renderHeaderHash (Proxy @blk) (blockHash blk) + , "blockSize" .= toJSON (estimateBlockSize (getHeader blk)) + ] + + forMachine dtal (AnyMessage msg@(MsgBlock blk)) = + formatMessageWithAgency dtal msg "MsgBlock" + <> mconcat [ "blockHash" .= renderHeaderHash (Proxy @blk) (blockHash blk) + , "blockSize" .= toJSON (estimateBlockSize (getHeader blk)) + , "txIds" .= toJSON (presentTx <$> extractTxs blk) + ] where presentTx :: GenTx blk -> Value presentTx = String . renderTxIdForDetails dtal . txId - forMachine _v (AnyMessageAndAgency stok MsgRequestRange{}) = - mconcat [ "kind" .= String "MsgRequestRange" - , "agency" .= String (pack $ show stok) - ] - forMachine _v (AnyMessageAndAgency stok MsgStartBatch{}) = - mconcat [ "kind" .= String "MsgStartBatch" - , "agency" .= String (pack $ show stok) - ] - forMachine _v (AnyMessageAndAgency stok MsgNoBlocks{}) = - mconcat [ "kind" .= String "MsgNoBlocks" - , "agency" .= String (pack $ show stok) - ] - forMachine _v (AnyMessageAndAgency stok MsgBatchDone{}) = - mconcat [ "kind" .= String "MsgBatchDone" - , "agency" .= String (pack $ show stok) - ] - forMachine _v (AnyMessageAndAgency stok MsgClientDone{}) = - mconcat [ "kind" .= String "MsgClientDone" - , "agency" .= String (pack $ show stok) - ] + forMachine dtal (AnyMessage msg@MsgRequestRange{}) = + formatMessageWithAgency dtal msg "MsgRequestRange" + forMachine dtal (AnyMessage msg@MsgStartBatch{}) = + formatMessageWithAgency dtal msg "MsgStartBatch" + forMachine dtal (AnyMessage msg@MsgNoBlocks{}) = + formatMessageWithAgency dtal msg "MsgNoBlocks" + forMachine dtal (AnyMessage msg@MsgBatchDone{}) = + formatMessageWithAgency dtal msg "MsgBatchDone" + forMachine dtal (AnyMessage msg@MsgClientDone{}) = + formatMessageWithAgency dtal msg "MsgClientDone" docTBlockFetch :: Documented (BlockFetch.TraceLabelPeer peer @@ -287,7 +299,7 @@ severityTBlockFetchSerialised (BlockFetch.TraceLabelPeer _ v) = severityTBlockFe severityTBlockFetch' (TraceSendMsg msg) = severityTBlockFetch'' msg severityTBlockFetch' (TraceRecvMsg msg) = severityTBlockFetch'' msg - severityTBlockFetch'' (AnyMessageAndAgency _agency msg) = severityTBlockFetch''' msg + severityTBlockFetch'' (AnyMessage msg) = severityTBlockFetch''' msg severityTBlockFetch''' :: Message (BlockFetch x (Point blk)) from to -> SeverityS @@ -305,7 +317,7 @@ namesForTBlockFetchSerialised (BlockFetch.TraceLabelPeer _ v) = namesTBlockFetch namesTBlockFetch (TraceSendMsg msg) = "Send" : namesTBlockFetch' msg namesTBlockFetch (TraceRecvMsg msg) = "Receive" : namesTBlockFetch' msg - namesTBlockFetch' (AnyMessageAndAgency _agency msg) = namesTBlockFetch'' msg + namesTBlockFetch' (AnyMessage msg) = namesTBlockFetch'' msg namesTBlockFetch'' :: Message (BlockFetch x (Point blk)) from to -> [Text] @@ -324,45 +336,23 @@ instance ( ConvertTxId blk , StandardHash blk , HasTxs blk ) - => LogFormatting (AnyMessageAndAgency (BlockFetch (Serialised blk) (Point blk))) where - forMachine DMinimal (AnyMessageAndAgency stok (MsgBlock _blk)) = - mconcat [ "kind" .= String "MsgBlock" - , "agency" .= String (pack $ show stok) - -- , "blockHash" .= renderHeaderHash (Proxy @blk) (blockHash blk) - -- , "blockSize" .= toJSON (estimateBlockSize (getHeader blk)) - ] - - forMachine _dtal (AnyMessageAndAgency stok (MsgBlock _blk)) = - mconcat [ "kind" .= String "MsgBlock" - , "agency" .= String (pack $ show stok) - -- , "blockHash" .= renderHeaderHash (Proxy @blk) (blockHash blk) - -- , "blockSize" .= toJSON (estimateBlockSize (getHeader blk)) - -- , "txIds" .= toJSON (presentTx <$> extractTxs blk) - ] - -- where - -- presentTx :: GenTx blk -> Value - -- presentTx = String . renderTxIdForDetails dtal . txId - - forMachine _v (AnyMessageAndAgency stok MsgRequestRange{}) = - mconcat [ "kind" .= String "MsgRequestRange" - , "agency" .= String (pack $ show stok) - ] - forMachine _v (AnyMessageAndAgency stok MsgStartBatch{}) = - mconcat [ "kind" .= String "MsgStartBatch" - , "agency" .= String (pack $ show stok) - ] - forMachine _v (AnyMessageAndAgency stok MsgNoBlocks{}) = - mconcat [ "kind" .= String "MsgNoBlocks" - , "agency" .= String (pack $ show stok) - ] - forMachine _v (AnyMessageAndAgency stok MsgBatchDone{}) = - mconcat [ "kind" .= String "MsgBatchDone" - , "agency" .= String (pack $ show stok) - ] - forMachine _v (AnyMessageAndAgency stok MsgClientDone{}) = - mconcat [ "kind" .= String "MsgClientDone" - , "agency" .= String (pack $ show stok) - ] + => LogFormatting (AnyMessage (BlockFetch (Serialised blk) (Point blk))) where + forMachine dtal@DMinimal (AnyMessage msg@(MsgBlock _blk)) = + formatMessageWithAgency dtal msg "MsgBlock" + + forMachine dtal (AnyMessage msg@(MsgBlock _blk)) = + formatMessageWithAgency dtal msg "MsgBlock" + + forMachine dtal (AnyMessage msg@MsgRequestRange{}) = + formatMessageWithAgency dtal msg "MsgRequestRange" + forMachine dtal (AnyMessage msg@MsgStartBatch{}) = + formatMessageWithAgency dtal msg "MsgStartBatch" + forMachine dtal (AnyMessage msg@MsgNoBlocks{}) = + formatMessageWithAgency dtal msg "MsgNoBlocks" + forMachine dtal (AnyMessage msg@MsgBatchDone{}) = + formatMessageWithAgency dtal msg "MsgBatchDone" + forMachine dtal (AnyMessage msg@MsgClientDone{}) = + formatMessageWithAgency dtal msg "MsgClientDone" forHuman = pack . show @@ -378,7 +368,7 @@ severityTxSubmissionNode (BlockFetch.TraceLabelPeer _ v) = severityTxSubNode v severityTxSubNode (TraceSendMsg msg) = severityTxSubNode' msg severityTxSubNode (TraceRecvMsg msg) = severityTxSubNode' msg - severityTxSubNode' (AnyMessageAndAgency _agency msg) = severityTxSubNode'' msg + severityTxSubNode' (AnyMessage msg) = severityTxSubNode'' msg severityTxSubNode'' :: Message @@ -402,7 +392,7 @@ namesForTxSubmissionNode (BlockFetch.TraceLabelPeer _ v) = namesTxSubNode (TraceSendMsg msg) = "Send" : namesTxSubNode' msg namesTxSubNode (TraceRecvMsg msg) = "Receive" : namesTxSubNode' msg - namesTxSubNode' (AnyMessageAndAgency _agency msg) = namesTxSubNode'' msg + namesTxSubNode' (AnyMessage msg) = namesTxSubNode'' msg namesTxSubNode'' :: Message @@ -419,39 +409,19 @@ namesForTxSubmissionNode (BlockFetch.TraceLabelPeer _ v) = instance (Show txid, Show tx) - => LogFormatting (AnyMessageAndAgency (STX.TxSubmission2 txid tx)) where - forMachine _dtal (AnyMessageAndAgency stok STX.MsgInit) = - mconcat - [ "kind" .= String "MsgInit" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok (STX.MsgRequestTxs txids)) = - mconcat - [ "kind" .= String "MsgRequestTxs" - , "agency" .= String (pack $ show stok) - , "txIds" .= String (pack $ show txids) - ] - forMachine _dtal (AnyMessageAndAgency stok (STX.MsgReplyTxs txs)) = - mconcat - [ "kind" .= String "MsgReplyTxs" - , "agency" .= String (pack $ show stok) - , "txs" .= String (pack $ show txs) - ] - forMachine _dtal (AnyMessageAndAgency stok STX.MsgRequestTxIds {}) = - mconcat - [ "kind" .= String "MsgRequestTxIds" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok (STX.MsgReplyTxIds _)) = - mconcat - [ "kind" .= String "MsgReplyTxIds" - , "agency" .= String (pack $ show stok) - ] - forMachine _dtal (AnyMessageAndAgency stok STX.MsgDone) = - mconcat - [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] + => LogFormatting (AnyMessage (STX.TxSubmission2 txid tx)) where + forMachine dtal (AnyMessage msg@STX.MsgInit) = + formatMessageWithAgency dtal msg "MsgInit" + forMachine dtal (AnyMessage msg@STX.MsgRequestTxs {}) = + formatMessageWithAgency dtal msg "MsgRequestTxs" + forMachine dtal (AnyMessage msg@STX.MsgReplyTxs {}) = + formatMessageWithAgency dtal msg "MsgReplyTxs" + forMachine dtal (AnyMessage msg@STX.MsgRequestTxIds {}) = + formatMessageWithAgency dtal msg "MsgRequestTxIds" + forMachine dtal (AnyMessage msg@STX.MsgReplyTxIds {}) = + formatMessageWithAgency dtal msg "MsgReplyTxIds" + forMachine dtal (AnyMessage msg@STX.MsgDone) = + formatMessageWithAgency dtal msg "MsgDone" docTTxSubmissionNode :: Documented (BlockFetch.TraceLabelPeer peer @@ -570,7 +540,7 @@ severityTxSubmission2Node (BlockFetch.TraceLabelPeer _ v) = severityTxSubNode v severityTxSubNode (TraceSendMsg msg) = severityTxSubNode' msg severityTxSubNode (TraceRecvMsg msg) = severityTxSubNode' msg - severityTxSubNode' (AnyMessageAndAgency _agency msg) = severityTxSubNode'' msg + severityTxSubNode' (AnyMessage msg) = severityTxSubNode'' msg severityTxSubNode'' :: Message @@ -593,7 +563,7 @@ namesForTxSubmission2Node (BlockFetch.TraceLabelPeer _ v) = namesTxSubNode (TraceSendMsg msg) = "Send" : namesTxSubNode' msg namesTxSubNode (TraceRecvMsg msg) = "Receive" : namesTxSubNode' msg - namesTxSubNode' (AnyMessageAndAgency _agency msg) = namesTxSubNode'' msg + namesTxSubNode' (AnyMessage msg) = namesTxSubNode'' msg namesTxSubNode'' :: Message diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs index c98267c5d7d..7696a1bc725 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs @@ -19,16 +19,17 @@ import Cardano.Prelude hiding (group, show) import Prelude (String, id, show) import Control.Monad.Class.MonadTime (DiffTime, Time (..)) -import Data.Aeson (Value (..)) +import Data.Aeson (Value (..), Object) import qualified Data.Aeson as Aeson import Data.Aeson.Types (listValue) import qualified Data.IP as IP import qualified Data.Map.Strict as Map +import Data.Singletons import qualified Data.Set as Set import Data.Text (pack) -import Network.TypedProtocol.Codec (AnyMessageAndAgency (..)) -import Network.TypedProtocol.Core (PeerHasAgency (..)) +import Network.TypedProtocol.Core +import Network.TypedProtocol.Codec (AnyMessage (..)) import Network.Mux (MiniProtocolNum (..), MuxTrace (..), WithMuxBearer (..)) @@ -352,6 +353,8 @@ instance HasSeverityAnnotation (WithMuxBearer peer MuxTrace) where MuxTraceChannelRecvEnd {} -> Debug MuxTraceChannelSendStart {} -> Debug MuxTraceChannelSendEnd {} -> Debug + MuxTraceChannelTryRecvStart {} -> Debug + MuxTraceChannelTryRecvEnd {} -> Debug MuxTraceHandshakeStart -> Debug MuxTraceHandshakeClientEnd {} -> Info MuxTraceHandshakeServerEnd -> Debug @@ -544,14 +547,17 @@ instance (Show header, StandardHash header, Show peer) => HasTextFormatter (TraceLabelPeer peer (TraceFetchClientState header)) where formatText a _ = pack (show a) -instance ToObject peer +instance ( ToObject peer + , StandardHash blk + , Show (Header blk) + ) => Transformable Text IO (TraceLabelPeer peer (NtN.TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)))) where trTransformer = trStructured instance (Show peer, StandardHash blk, Show (Header blk)) => HasTextFormatter (TraceLabelPeer peer (NtN.TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)))) where formatText a _ = pack (show a) -instance (ToObject peer, ToObject (AnyMessageAndAgency (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))) +instance (ToObject peer, ToObject (AnyMessage (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))) => Transformable Text IO (TraceLabelPeer peer (NtN.TraceSendRecv (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk)))) where trTransformer = trStructured @@ -559,23 +565,23 @@ instance ToObject peer => Transformable Text IO (TraceLabelPeer peer (TraceTxSubmissionInbound (GenTxId blk) (GenTx blk))) where trTransformer = trStructured -instance (ToObject peer, ConvertTxId blk, RunNode blk, HasTxs blk) +instance (ToObject peer, ConvertTxId blk, RunNode blk, HasTxs blk, Show blk) => Transformable Text IO (TraceLabelPeer peer (NtN.TraceSendRecv (BlockFetch blk (Point blk)))) where trTransformer = trStructured -instance ToObject localPeer +instance (ToObject localPeer, StandardHash blk) => Transformable Text IO (TraceLabelPeer localPeer (NtN.TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk)))) where trTransformer = trStructured -instance (applyTxErr ~ ApplyTxErr blk, ToObject localPeer) +instance (applyTxErr ~ ApplyTxErr blk, ToObject localPeer, Show (TxId (GenTx blk)), Show (GenTx blk)) => Transformable Text IO (TraceLabelPeer localPeer (NtN.TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo))) where trTransformer = trStructured -instance (applyTxErr ~ ApplyTxErr blk, ToObject localPeer) +instance (applyTxErr ~ ApplyTxErr blk, ToObject localPeer, Show applyTxErr, Show (GenTx blk)) => Transformable Text IO (TraceLabelPeer localPeer (NtN.TraceSendRecv (LocalTxSubmission (GenTx blk) applyTxErr))) where trTransformer = trStructured -instance (LocalStateQuery.ShowQuery (BlockQuery blk), ToObject localPeer) +instance (LocalStateQuery.ShowQuery (BlockQuery blk), ToObject localPeer, StandardHash blk) => Transformable Text IO (TraceLabelPeer localPeer (NtN.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)))) where trTransformer = trStructured @@ -727,217 +733,156 @@ instance Show addr -- -- NOTE: this list is sorted by the unqualified name of the outermost type. +formatMessageWithAgency + :: forall ps (st :: ps) (st' :: ps). + SingI st + => Show (Message ps st st') + => Show (Sing st) + => TracingVerbosity + -> Message ps st st' + -> String + -> Object +formatMessageWithAgency MaximalVerbosity msg _condensed = + mconcat [ "kind" .= String (pack $ show msg) + , "agency" .= String (pack $ show (sing :: Sing st)) + ] +formatMessageWithAgency _ _msg condensed = + mconcat [ "kind" .= String (pack condensed) + , "agency" .= String (pack $ show (sing :: Sing st)) + ] + instance ( ConvertTxId blk , RunNode blk , HasTxs blk + , Show blk ) - => ToObject (AnyMessageAndAgency (BlockFetch blk (Point blk))) where - toObject MinimalVerbosity (AnyMessageAndAgency stok (MsgBlock blk)) = - mconcat [ "kind" .= String "MsgBlock" - , "agency" .= String (pack $ show stok) - , "blockHash" .= renderHeaderHash (Proxy @blk) (blockHash blk) - , "blockSize" .= toJSON (estimateBlockSize (getHeader blk)) - ] + => ToObject (AnyMessage (BlockFetch blk (Point blk))) where + toObject verb@MinimalVerbosity (AnyMessage msg@(MsgBlock blk)) = + formatMessageWithAgency verb msg "MsgBlock" + <> mconcat [ "blockHash" .= renderHeaderHash (Proxy @blk) (blockHash blk) + , "blockSize" .= toJSON (estimateBlockSize (getHeader blk)) + ] - toObject verb (AnyMessageAndAgency stok (MsgBlock blk)) = - mconcat [ "kind" .= String "MsgBlock" - , "agency" .= String (pack $ show stok) - , "blockHash" .= renderHeaderHash (Proxy @blk) (blockHash blk) - , "blockSize" .= toJSON (estimateBlockSize (getHeader blk)) - , "txIds" .= toJSON (presentTx <$> extractTxs blk) - ] + toObject verb (AnyMessage msg@(MsgBlock blk)) = + formatMessageWithAgency verb msg "MsgBlock" + <> mconcat [ "blockHash" .= renderHeaderHash (Proxy @blk) (blockHash blk) + , "blockSize" .= toJSON (estimateBlockSize (getHeader blk)) + , "txIds" .= toJSON (presentTx <$> extractTxs blk) + ] where presentTx :: GenTx blk -> Value presentTx = String . renderTxIdForVerbosity verb . txId - toObject _v (AnyMessageAndAgency stok MsgRequestRange{}) = - mconcat [ "kind" .= String "MsgRequestRange" - , "agency" .= String (pack $ show stok) - ] - toObject _v (AnyMessageAndAgency stok MsgStartBatch{}) = - mconcat [ "kind" .= String "MsgStartBatch" - , "agency" .= String (pack $ show stok) - ] - toObject _v (AnyMessageAndAgency stok MsgNoBlocks{}) = - mconcat [ "kind" .= String "MsgNoBlocks" - , "agency" .= String (pack $ show stok) - ] - toObject _v (AnyMessageAndAgency stok MsgBatchDone{}) = - mconcat [ "kind" .= String "MsgBatchDone" - , "agency" .= String (pack $ show stok) - ] - toObject _v (AnyMessageAndAgency stok MsgClientDone{}) = - mconcat [ "kind" .= String "MsgClientDone" - , "agency" .= String (pack $ show stok) - ] - -instance (forall result. Show (query result)) - => ToObject (AnyMessageAndAgency (LocalStateQuery blk pt query)) where - toObject _verb (AnyMessageAndAgency stok LocalStateQuery.MsgAcquire{}) = - mconcat [ "kind" .= String "MsgAcquire" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalStateQuery.MsgAcquired{}) = - mconcat [ "kind" .= String "MsgAcquired" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalStateQuery.MsgFailure{}) = - mconcat [ "kind" .= String "MsgFailure" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalStateQuery.MsgQuery{}) = - mconcat [ "kind" .= String "MsgQuery" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalStateQuery.MsgResult{}) = - mconcat [ "kind" .= String "MsgResult" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalStateQuery.MsgRelease{}) = - mconcat [ "kind" .= String "MsgRelease" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalStateQuery.MsgReAcquire{}) = - mconcat [ "kind" .= String "MsgReAcquire" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalStateQuery.MsgDone{}) = - mconcat [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] - -instance ToObject (AnyMessageAndAgency (LocalTxMonitor txid tx slotno)) where - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgAcquire {}) = - mconcat [ "kind" .= String "MsgAcuire" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgAcquired {}) = - mconcat [ "kind" .= String "MsgAcuired" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgAwaitAcquire {}) = - mconcat [ "kind" .= String "MsgAwaitAcuire" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgNextTx {}) = - mconcat [ "kind" .= String "MsgNextTx" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgReplyNextTx {}) = - mconcat [ "kind" .= String "MsgReplyNextTx" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgHasTx {}) = - mconcat [ "kind" .= String "MsgHasTx" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgReplyHasTx {}) = - mconcat [ "kind" .= String "MsgReplyHasTx" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgGetSizes {}) = - mconcat [ "kind" .= String "MsgGetSizes" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgReplyGetSizes {}) = - mconcat [ "kind" .= String "MsgReplyGetSizes" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgRelease {}) = - mconcat [ "kind" .= String "MsgRelease" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxMonitor.MsgDone {}) = - mconcat [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] - -instance ToObject (AnyMessageAndAgency (LocalTxSubmission tx err)) where - toObject _verb (AnyMessageAndAgency stok LocalTxSub.MsgSubmitTx{}) = - mconcat [ "kind" .= String "MsgSubmitTx" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxSub.MsgAcceptTx{}) = - mconcat [ "kind" .= String "MsgAcceptTx" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxSub.MsgRejectTx{}) = - mconcat [ "kind" .= String "MsgRejectTx" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok LocalTxSub.MsgDone{}) = - mconcat [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] - -instance ToObject (AnyMessageAndAgency (ChainSync blk pt tip)) where - toObject _verb (AnyMessageAndAgency stok ChainSync.MsgRequestNext{}) = - mconcat [ "kind" .= String "MsgRequestNext" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok ChainSync.MsgAwaitReply{}) = - mconcat [ "kind" .= String "MsgAwaitReply" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok ChainSync.MsgRollForward{}) = - mconcat [ "kind" .= String "MsgRollForward" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok ChainSync.MsgRollBackward{}) = - mconcat [ "kind" .= String "MsgRollBackward" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok ChainSync.MsgFindIntersect{}) = - mconcat [ "kind" .= String "MsgFindIntersect" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok ChainSync.MsgIntersectFound{}) = - mconcat [ "kind" .= String "MsgIntersectFound" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok ChainSync.MsgIntersectNotFound{}) = - mconcat [ "kind" .= String "MsgIntersectNotFound" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok ChainSync.MsgDone{}) = - mconcat [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] + toObject verb (AnyMessage msg@MsgRequestRange{}) = + formatMessageWithAgency verb msg "MsgRequestRange" + toObject verb (AnyMessage msg@MsgStartBatch{}) = + formatMessageWithAgency verb msg "MsgStartBatch" + toObject verb (AnyMessage msg@MsgNoBlocks{}) = + formatMessageWithAgency verb msg "MsgNoBlocks" + toObject verb (AnyMessage msg@MsgBatchDone{}) = + formatMessageWithAgency verb msg "MsgBatchDone" + toObject verb (AnyMessage msg@MsgClientDone{}) = + formatMessageWithAgency verb msg "MsgClientDone" + +instance ( LocalStateQuery.ShowQuery query + , Show pt + ) + => ToObject (AnyMessage (LocalStateQuery blk pt query)) where + toObject verb (AnyMessage msg@LocalStateQuery.MsgAcquire{}) = + formatMessageWithAgency verb msg "MsgAcquire" + toObject verb (AnyMessage msg@LocalStateQuery.MsgAcquired{}) = + formatMessageWithAgency verb msg "MsgAcquired" + toObject verb (AnyMessage msg@LocalStateQuery.MsgFailure{}) = + formatMessageWithAgency verb msg "MsgFailure" + toObject verb (AnyMessage msg@LocalStateQuery.MsgQuery{}) = + formatMessageWithAgency verb msg "MsgQuery" + toObject verb (AnyMessage msg@LocalStateQuery.MsgResult{}) = + formatMessageWithAgency verb msg "MsgResult" + toObject verb (AnyMessage msg@LocalStateQuery.MsgRelease{}) = + formatMessageWithAgency verb msg "MsgRelease" + toObject verb (AnyMessage msg@LocalStateQuery.MsgReAcquire{}) = + formatMessageWithAgency verb msg "MsgReAcquire" + toObject verb (AnyMessage msg@LocalStateQuery.MsgDone{}) = + formatMessageWithAgency verb msg "MsgDone" + +instance ( forall (st :: LocalTxMonitor txid tx slotno) + (st' :: LocalTxMonitor txid tx slotno). + Show (Message (LocalTxMonitor txid tx slotno) st st') + ) + => ToObject (AnyMessage (LocalTxMonitor txid tx slotno)) where + toObject verb (AnyMessage msg@LocalTxMonitor.MsgAcquire {}) = + formatMessageWithAgency verb msg "LocalTxMonitor" + toObject verb (AnyMessage msg@LocalTxMonitor.MsgAcquired {}) = + formatMessageWithAgency verb msg "LocalTxMonitor" + toObject verb (AnyMessage msg@LocalTxMonitor.MsgAwaitAcquire {}) = + formatMessageWithAgency verb msg "LocalTxMonitor" + toObject verb (AnyMessage msg@LocalTxMonitor.MsgNextTx {}) = + formatMessageWithAgency verb msg "LocalTxMonitor" + toObject verb (AnyMessage msg@LocalTxMonitor.MsgReplyNextTx {}) = + formatMessageWithAgency verb msg "LocalTxMonitor" + toObject verb (AnyMessage msg@LocalTxMonitor.MsgHasTx {}) = + formatMessageWithAgency verb msg "LocalTxMonitor" + toObject verb (AnyMessage msg@LocalTxMonitor.MsgReplyHasTx {}) = + formatMessageWithAgency verb msg "LocalTxMonitor" + toObject verb (AnyMessage msg@LocalTxMonitor.MsgGetSizes {}) = + formatMessageWithAgency verb msg "LocalTxMonitor" + toObject verb (AnyMessage msg@LocalTxMonitor.MsgReplyGetSizes {}) = + formatMessageWithAgency verb msg "LocalTxMonitor" + toObject verb (AnyMessage msg@LocalTxMonitor.MsgRelease {}) = + formatMessageWithAgency verb msg "LocalTxMonitor" + toObject verb (AnyMessage msg@LocalTxMonitor.MsgDone {}) = + formatMessageWithAgency verb msg "LocalTxMonitor" + +instance ( forall (st :: LocalTxSubmission tx err) + (st' :: LocalTxSubmission tx err). + Show (Message (LocalTxSubmission tx err) st st') + ) + => ToObject (AnyMessage (LocalTxSubmission tx err)) where + toObject verb (AnyMessage msg@LocalTxSub.MsgSubmitTx{}) = + formatMessageWithAgency verb msg "MsgSubmitTx" + toObject verb (AnyMessage msg@LocalTxSub.MsgAcceptTx{}) = + formatMessageWithAgency verb msg "MsgAcceptTx" + toObject verb (AnyMessage msg@LocalTxSub.MsgRejectTx{}) = + formatMessageWithAgency verb msg "MsgRejectTx" + toObject verb (AnyMessage msg@LocalTxSub.MsgDone{}) = + formatMessageWithAgency verb msg "MsgDone" + +instance ( forall (st :: ChainSync blk pt tip) + (st' :: ChainSync blk pt tip). + Show (Message (ChainSync blk pt tip) st st') + ) + => ToObject (AnyMessage (ChainSync blk pt tip)) where + toObject verb (AnyMessage msg@ChainSync.MsgRequestNext{}) = + formatMessageWithAgency verb msg "MsgRequestNext" + toObject verb (AnyMessage msg@ChainSync.MsgAwaitReply{}) = + formatMessageWithAgency verb msg "MsgAwaitReply" + toObject verb (AnyMessage msg@ChainSync.MsgRollForward{}) = + formatMessageWithAgency verb msg "MsgRollForward" + toObject verb (AnyMessage msg@ChainSync.MsgRollBackward{}) = + formatMessageWithAgency verb msg "MsgRollBackward" + toObject verb (AnyMessage msg@ChainSync.MsgFindIntersect{}) = + formatMessageWithAgency verb msg "MsgFindIntersect" + toObject verb (AnyMessage msg@ChainSync.MsgIntersectFound{}) = + formatMessageWithAgency verb msg "MsgIntersectFound" + toObject verb (AnyMessage msg@ChainSync.MsgIntersectNotFound{}) = + formatMessageWithAgency verb msg "MsgIntersectNotFound" + toObject verb (AnyMessage msg@ChainSync.MsgDone{}) = + formatMessageWithAgency verb msg "MsgDone" instance (Show txid, Show tx) - => ToObject (AnyMessageAndAgency (TxSubmission2 txid tx)) where - toObject _verb (AnyMessageAndAgency stok MsgInit) = - mconcat - [ "kind" .= String "MsgInit" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok (MsgRequestTxs txids)) = - mconcat - [ "kind" .= String "MsgRequestTxs" - , "agency" .= String (pack $ show stok) - , "txIds" .= String (pack $ show txids) - ] - toObject _verb (AnyMessageAndAgency stok (MsgReplyTxs txs)) = - mconcat - [ "kind" .= String "MsgReplyTxs" - , "agency" .= String (pack $ show stok) - , "txs" .= String (pack $ show txs) - ] - toObject _verb (AnyMessageAndAgency stok MsgRequestTxIds{}) = - mconcat - [ "kind" .= String "MsgRequestTxIds" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok (MsgReplyTxIds _)) = - mconcat - [ "kind" .= String "MsgReplyTxIds" - , "agency" .= String (pack $ show stok) - ] - toObject _verb (AnyMessageAndAgency stok MsgDone) = - mconcat - [ "kind" .= String "MsgDone" - , "agency" .= String (pack $ show stok) - ] + => ToObject (AnyMessage (TxSubmission2 txid tx)) where + toObject verb (AnyMessage msg@MsgInit) = + formatMessageWithAgency verb msg "MsgInit" + toObject verb (AnyMessage msg@MsgRequestTxs{}) = + formatMessageWithAgency verb msg "MsgRequestTxs" + toObject verb (AnyMessage msg@MsgReplyTxs{}) = + formatMessageWithAgency verb msg "MsgReplyTxs" + toObject verb (AnyMessage msg@MsgRequestTxIds{}) = + formatMessageWithAgency verb msg "MsgRequestTxIds" + toObject verb (AnyMessage msg@MsgReplyTxIds{}) = + formatMessageWithAgency verb msg "MsgReplyTxIds" + toObject verb (AnyMessage msg@MsgDone) = + formatMessageWithAgency verb msg "MsgDone" instance ToJSON peerAddr => ToJSON (ConnectionId peerAddr) where toJSON ConnectionId { localAddress, remoteAddress } = @@ -1145,7 +1090,7 @@ instance (ToObject peer, ToObject a) => ToObject (TraceLabelPeer peer a) where mconcat [ "peer" .= toObject verb peerid ] <> toObject verb a -instance ToObject (AnyMessageAndAgency ps) +instance ToObject (AnyMessage ps) => ToObject (TraceSendRecv ps) where toObject verb (TraceSendMsg m) = mconcat [ "kind" .= String "Send" , "msg" .= toObject verb m ] @@ -1670,25 +1615,29 @@ instance ToObject PeerSelectionCounters where , "hotPeers" .= hotPeers ev ] -instance (Show (ClientHasAgency st), Show (ServerHasAgency st)) - => ToJSON (PeerHasAgency pr st) where - toJSON (ClientAgency cha) = - Aeson.object [ "kind" .= String "ClientAgency" - , "agency" .= show cha - ] - toJSON (ServerAgency sha) = - Aeson.object [ "kind" .= String "ServerAgency" - , "agency" .= show sha - ] +stateToJSON :: forall st. + ActiveState st + => Show (Sing st) + => Sing st + -> Value +stateToJSON tok = + case activeAgency :: ActiveAgency st of + ClientHasAgency -> Aeson.object [ "kind" .= String "ClientAgency" + , "state" .= String (pack $ show tok) + ] + ServerHasAgency -> Aeson.object [ "kind" .= String "ServerAgency" + , "state" .= String (pack $ show tok) + ] + instance ToJSON ProtocolLimitFailure where - toJSON (ExceededSizeLimit tok) = + toJSON (ExceededSizeLimit (tok :: Sing st)) = Aeson.object [ "kind" .= String "ProtocolLimitFailure" - , "agency" .= toJSON tok + , "state" .= stateToJSON tok ] - toJSON (ExceededTimeLimit tok) = + toJSON (ExceededTimeLimit (tok :: Sing st)) = Aeson.object [ "kind" .= String "ProtocolLimitFailure" - , "agency" .= toJSON tok + , "state" .= stateToJSON tok ] instance Show vNumber => ToJSON (RefuseReason vNumber) where diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs index 5ba1f507dd2..3567a5607fc 100644 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Tracing/Tracers.hs @@ -66,7 +66,7 @@ import Ouroboros.Consensus.Ledger.Extended (ledgerState) import Ouroboros.Consensus.Ledger.Inspect (InspectLedger, LedgerEvent) import Ouroboros.Consensus.Ledger.Query (BlockQuery) import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx, GenTxId, HasTxs, - LedgerSupportsMempool) + LedgerSupportsMempool, TxId) import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) import Ouroboros.Consensus.Mempool.API (MempoolSize (..), TraceEventMempool (..)) import qualified Ouroboros.Consensus.Network.NodeToClient as NodeToClient @@ -1280,6 +1280,10 @@ forgeStateInfoTracer p _ts tracer = Tracer $ \ev -> do nodeToClientTracers' :: ( ToObject localPeer , ShowQuery (BlockQuery blk) + , StandardHash blk + , Show (TxId (GenTx blk)) + , Show (GenTx blk) + , Show (ApplyTxErr blk) ) => TraceSelection -> TracingVerbosity @@ -1311,6 +1315,8 @@ nodeToNodeTracers' , HasTxs blk , Show peer , ToObject peer + , Show (Header blk) + , Show blk ) => TraceSelection -> TracingVerbosity From e5b2193510d312b0f91c6a8ca1c8c3c5256dc50b Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 9 May 2022 19:00:44 +0200 Subject: [PATCH 4/4] Updated cardano-client-demo & benchmarking code --- .../Benchmarking/GeneratorTx/Submission.hs | 8 +-- .../GeneratorTx/SubmissionClient.hs | 36 ++++++------- cardano-client-demo/LedgerState.hs | 2 +- cardano-client-demo/ScanBlocksPipelined.hs | 50 +++++++++++-------- cardano-client-demo/cardano-client-demo.cabal | 2 + 5 files changed, 54 insertions(+), 44 deletions(-) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs index b9f6b08b0d0..e7eb3b772ee 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs @@ -42,7 +42,7 @@ import Cardano.Tracing.OrphanInstances.Consensus () import Cardano.Tracing.OrphanInstances.Network () import Cardano.Tracing.OrphanInstances.Shelley () -import Ouroboros.Network.Protocol.TxSubmission2.Type (TokBlockingStyle (..)) +import Ouroboros.Network.Protocol.TxSubmission2.Type (SingBlockingStyle (..)) import Cardano.Api @@ -121,11 +121,11 @@ mkSubmissionSummary ssThreadName startTime reportsRefs walletTxSource :: forall era. WalletScript era -> TpsThrottle -> TxSource era walletTxSource walletScript tpsThrottle = Active $ worker walletScript where - worker :: forall m blocking . MonadIO m => WalletScript era -> TokBlockingStyle blocking -> Req -> m (TxSource era, [Tx era]) + worker :: forall m blocking . MonadIO m => WalletScript era -> SingBlockingStyle blocking -> Req -> m (TxSource era, [Tx era]) worker script blocking req = do (done, txCount) <- case blocking of - TokBlocking -> liftIO $ consumeTxsBlocking tpsThrottle req - TokNonBlocking -> liftIO $ consumeTxsNonBlocking tpsThrottle req + SingBlocking -> liftIO $ consumeTxsBlocking tpsThrottle req + SingNonBlocking -> liftIO $ consumeTxsNonBlocking tpsThrottle req (txList, newScript) <- liftIO $ unFold script txCount case done of Stop -> return (Exhausted, txList) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs index b26b09b90f9..6a47b3f3d54 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs @@ -55,7 +55,7 @@ import Ouroboros.Network.Protocol.TxSubmission2.Client (ClientStIdle ( ClientStTxs (..), TxSubmissionClient (..)) import Ouroboros.Network.Protocol.TxSubmission2.Type (BlockingReplyList (..), - TokBlockingStyle (..), TxSizeInBytes) + SingBlockingStyle (..), TxSizeInBytes) import Cardano.Api import Cardano.Api.Shelley (fromShelleyTxId, toConsensusGenTx) @@ -75,14 +75,14 @@ data TxSource era = Exhausted | Active (ProduceNextTxs era) -type ProduceNextTxs era = (forall m blocking . MonadIO m => TokBlockingStyle blocking -> Req -> m (TxSource era, [Tx era])) +type ProduceNextTxs era = (forall m blocking . MonadIO m => SingBlockingStyle blocking -> Req -> m (TxSource era, [Tx era])) -produceNextTxs :: forall m blocking era . MonadIO m => TokBlockingStyle blocking -> Req -> LocalState era -> m (LocalState era, [Tx era]) +produceNextTxs :: forall m blocking era . MonadIO m => SingBlockingStyle blocking -> Req -> LocalState era -> m (LocalState era, [Tx era]) produceNextTxs blocking req (txProducer, unack, stats) = do (newTxProducer, txList) <- produceNextTxs' blocking req txProducer return ((newTxProducer, unack, stats), txList) -produceNextTxs' :: forall m blocking era . MonadIO m => TokBlockingStyle blocking -> Req -> TxSource era -> m (TxSource era, [Tx era]) +produceNextTxs' :: forall m blocking era . MonadIO m => SingBlockingStyle blocking -> Req -> TxSource era -> m (TxSource era, [Tx era]) produceNextTxs' _ _ Exhausted = return (Exhausted, []) produceNextTxs' blocking req (Active callback) = callback blocking req @@ -104,10 +104,10 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = TxSubmissionClient $ pure $ client (initialTxSource, UnAcked [], SubmissionThreadStats 0 0 0) where - discardAcknowledged :: TokBlockingStyle a -> Ack -> LocalState era -> m (LocalState era) + discardAcknowledged :: SingBlockingStyle a -> Ack -> LocalState era -> m (LocalState era) discardAcknowledged blocking (Ack ack) (txSource, UnAcked unAcked, stats) = do when (tokIsBlocking blocking && ack /= length unAcked) $ do - let err = "decideAnnouncement: TokBlocking, but length unAcked != ack" + let err = "decideAnnouncement: SingBlocking, but length unAcked != ack" traceWith bmtr (TraceBenchTxSubError err) fail (T.unpack err) let (stillUnacked, acked) = L.splitAtEnd ack unAcked @@ -128,7 +128,7 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = requestTxIds :: forall blocking. LocalState era - -> TokBlockingStyle blocking + -> SingBlockingStyle blocking -> Word16 -> Word16 -> m (ClientStTxIds blocking (GenTxId CardanoBlock) (GenTx CardanoBlock) m ()) @@ -147,7 +147,7 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = traceWith bmtr $ SubmissionClientUnAcked (getTxId . getTxBody <$> outs) case blocking of - TokBlocking -> case NE.nonEmpty newTxs of + SingBlocking -> case NE.nonEmpty newTxs of Nothing -> do traceWith tr EndOfProtocol endOfProtocolCallback stats @@ -155,7 +155,7 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = (Just txs) -> pure $ SendMsgReplyTxIds (BlockingReply $ txToIdSize <$> txs) (client stateC) - TokNonBlocking -> pure $ SendMsgReplyTxIds + SingNonBlocking -> pure $ SendMsgReplyTxIds (NonBlockingReply $ txToIdSize <$> newTxs) (client stateC) @@ -203,17 +203,17 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = fromGenTxId (Block.GenTxIdBabbage (Mempool.ShelleyTxId i)) = fromShelleyTxId i fromGenTxId _ = error "TODO: fix incomplete match" - tokIsBlocking :: TokBlockingStyle a -> Bool + tokIsBlocking :: SingBlockingStyle a -> Bool tokIsBlocking = \case - TokBlocking -> True - TokNonBlocking -> False + SingBlocking -> True + SingNonBlocking -> False - reqIdsTrace :: Ack -> Req -> TokBlockingStyle a -> NodeToNodeSubmissionTrace + reqIdsTrace :: Ack -> Req -> SingBlockingStyle a -> NodeToNodeSubmissionTrace reqIdsTrace ack req = \case - TokBlocking -> ReqIdsBlocking ack req - TokNonBlocking -> ReqIdsNonBlocking ack req + SingBlocking -> ReqIdsBlocking ack req + SingNonBlocking -> ReqIdsNonBlocking ack req - idListTrace :: ToAnnce tx -> TokBlockingStyle a -> NodeToNodeSubmissionTrace + idListTrace :: ToAnnce tx -> SingBlockingStyle a -> NodeToNodeSubmissionTrace idListTrace (ToAnnce toAnn) = \case - TokBlocking -> IdsListBlocking $ length toAnn - TokNonBlocking -> IdsListNonBlocking $ length toAnn + SingBlocking -> IdsListBlocking $ length toAnn + SingNonBlocking -> IdsListNonBlocking $ length toAnn diff --git a/cardano-client-demo/LedgerState.hs b/cardano-client-demo/LedgerState.hs index 53a8dff1ab4..df76b36640e 100644 --- a/cardano-client-demo/LedgerState.hs +++ b/cardano-client-demo/LedgerState.hs @@ -17,7 +17,7 @@ import Data.Sequence (Seq) import qualified Data.Sequence as Seq import qualified Data.Text as T import Data.Word -import Network.TypedProtocol.Pipelined (Nat (..)) +import Data.Type.Nat (Nat (..)) import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley import Ouroboros.Network.Protocol.ChainSync.ClientPipelined (ChainSyncClientPipelined (ChainSyncClientPipelined), diff --git a/cardano-client-demo/ScanBlocksPipelined.hs b/cardano-client-demo/ScanBlocksPipelined.hs index 080202aa90a..95c32609399 100644 --- a/cardano-client-demo/ScanBlocksPipelined.hs +++ b/cardano-client-demo/ScanBlocksPipelined.hs @@ -11,12 +11,16 @@ import Cardano.Slotting.Slot import Control.Monad (when) import Data.Kind import Data.Proxy +import Data.Type.Queue +import Data.Type.Nat import Data.Time import Data.Word (Word32) import qualified GHC.TypeLits as GHC import System.Environment (getArgs) import System.FilePath (()) +import Ouroboros.Network.Protocol.ChainSync.ClientPipelined + -- | Connects to a local cardano node, requests the blocks and prints out the -- number of transactions. To run this, you must first start a local node e.g.: -- @@ -76,16 +80,17 @@ chainSyncClient pipelineSize = ChainSyncClientPipelined $ do startTime <- getCurrentTime let clientIdle_RequestMoreN :: WithOrigin BlockNo -> WithOrigin BlockNo - -> Nat n -> ClientPipelinedStIdle n (BlockInMode CardanoMode) - ChainPoint ChainTip IO () - clientIdle_RequestMoreN clientTip serverTip n = case pipelineDecisionMax pipelineSize n clientTip serverTip of - Collect -> case n of - Succ predN -> CollectResponse Nothing (clientNextN predN) - _ -> SendMsgRequestNextPipelined (clientIdle_RequestMoreN clientTip serverTip (Succ n)) + -> SingQueueF F q -> ClientPipelinedStIdle (BlockInMode CardanoMode) + ChainPoint ChainTip q IO () + clientIdle_RequestMoreN clientTip serverTip q = case pipelineDecisionMax pipelineSize (queueFDepthNat q) clientTip serverTip of + Collect -> case q of + SingConsF FCanAwait q' -> CollectResponse Nothing (clientNextN q') + SingConsF FMustReply q' -> CollectResponse Nothing (clientNextN q') + _ -> SendMsgRequestNextPipelined (clientIdle_RequestMoreN clientTip serverTip (q |> FCanAwait)) - clientNextN :: Nat n -> ClientStNext n (BlockInMode CardanoMode) - ChainPoint ChainTip IO () - clientNextN n = + clientNextN :: SingQueueF F q -> ClientStNext (BlockInMode CardanoMode) + ChainPoint ChainTip q IO () + clientNextN q = ClientStNext { recvMsgRollForward = \(BlockInMode block@(Block (BlockHeader _ _ currBlockNo@(BlockNo blockNo)) _) _) serverChainTip -> do let newClientTip = At currBlockNo @@ -97,27 +102,30 @@ chainSyncClient pipelineSize = ChainSyncClientPipelined $ do rate = fromIntegral blockNo / elapsedTime putStrLn $ "Rate = " ++ show rate ++ " blocks/second" if newClientTip == newServerTip - then clientIdle_DoneN n - else return (clientIdle_RequestMoreN newClientTip newServerTip n) + then clientIdle_DoneN q + else return (clientIdle_RequestMoreN newClientTip newServerTip q) , recvMsgRollBackward = \_ serverChainTip -> do putStrLn "Rollback" let newClientTip = Origin -- We don't actually keep track of blocks so we temporarily "forget" the tip. newServerTip = fromChainTip serverChainTip - return (clientIdle_RequestMoreN newClientTip newServerTip n) + return (clientIdle_RequestMoreN newClientTip newServerTip q) } - clientIdle_DoneN :: Nat n -> IO (ClientPipelinedStIdle n (BlockInMode CardanoMode) - ChainPoint ChainTip IO ()) - clientIdle_DoneN n = case n of - Succ predN -> do + clientIdle_DoneN :: SingQueueF F q -> IO (ClientPipelinedStIdle (BlockInMode CardanoMode) + ChainPoint ChainTip q IO ()) + clientIdle_DoneN q = case q of + SingConsF FCanAwait q' -> do + putStrLn "Chain Sync: done! (Ignoring remaining responses)" + return $ CollectResponse Nothing (clientNext_DoneN q') -- Ignore remaining message responses + SingConsF FMustReply q' -> do putStrLn "Chain Sync: done! (Ignoring remaining responses)" - return $ CollectResponse Nothing (clientNext_DoneN predN) -- Ignore remaining message responses - Zero -> do + return $ CollectResponse Nothing (clientNext_DoneN q') -- Ignore remaining message responses + SingEmptyF -> do putStrLn "Chain Sync: done!" return $ SendMsgDone () - clientNext_DoneN :: Nat n -> ClientStNext n (BlockInMode CardanoMode) - ChainPoint ChainTip IO () + clientNext_DoneN :: SingQueueF F q -> ClientStNext (BlockInMode CardanoMode) + ChainPoint ChainTip q IO () clientNext_DoneN n = ClientStNext { recvMsgRollForward = \_ _ -> clientIdle_DoneN n @@ -133,4 +141,4 @@ chainSyncClient pipelineSize = ChainSyncClientPipelined $ do ChainTipAtGenesis -> Origin ChainTip _ _ bno -> At bno - return (clientIdle_RequestMoreN Origin Origin Zero) + return (clientIdle_RequestMoreN Origin Origin SingEmptyF) diff --git a/cardano-client-demo/cardano-client-demo.cabal b/cardano-client-demo/cardano-client-demo.cabal index 0982c02fff7..305f2551b64 100644 --- a/cardano-client-demo/cardano-client-demo.cabal +++ b/cardano-client-demo/cardano-client-demo.cabal @@ -34,7 +34,9 @@ executable scan-blocks-pipelined , cardano-ledger-byron , cardano-slotting , filepath + , ouroboros-network , time + , typed-protocols executable chain-sync-client-with-ledger-state import: base, project-config