diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs index e2d98eddf78..af229b362f0 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Submission.hs @@ -45,7 +45,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 hiding (Active) import Cardano.TxGenerator.Types (TPSRate, TxGenError) @@ -124,11 +124,11 @@ mkSubmissionSummary startTime reportsRefs txStreamSource :: forall era. MVar (StreamState (TxStream IO era)) -> TpsThrottle -> TxSource era txStreamSource streamRef tpsThrottle = Active worker where - worker :: forall m blocking . MonadIO m => TokBlockingStyle blocking -> Req -> m (TxSource era, [Tx era]) + worker :: forall m blocking . MonadIO m => SingBlockingStyle blocking -> Req -> m (TxSource era, [Tx era]) worker 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 <- liftIO $ unFold 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 e227292c8af..3dc7f92329f 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs @@ -50,10 +50,12 @@ import qualified Ouroboros.Consensus.Shelley.Ledger.Mempool as Mempool (TxId (Sh import qualified Ouroboros.Consensus.Cardano.Block as Block (TxId (GenTxIdAllegra, GenTxIdAlonzo, GenTxIdBabbage, GenTxIdConway, GenTxIdMary, GenTxIdShelley)) +import Ouroboros.Network.Protocol.TxSubmission2.Type + (NumTxIdsToAck (..), NumTxIdsToReq (..)) import Ouroboros.Network.Protocol.TxSubmission2.Client (ClientStIdle (..), ClientStTxIds (..), ClientStTxs (..), TxSubmissionClient (..)) import Ouroboros.Network.Protocol.TxSubmission2.Type (BlockingReplyList (..), - TokBlockingStyle (..), TxSizeInBytes) + SingBlockingStyle (..), TxSizeInBytes) import Cardano.Api hiding (Active) import Cardano.Api.Shelley (fromShelleyTxId, toConsensusGenTx) @@ -75,14 +77,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 +106,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,9 +130,9 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = requestTxIds :: forall blocking. LocalState era - -> TokBlockingStyle blocking - -> Word16 - -> Word16 + -> SingBlockingStyle blocking + -> NumTxIdsToAck + -> NumTxIdsToReq -> m (ClientStTxIds blocking (GenTxId CardanoBlock) (GenTx CardanoBlock) m ()) requestTxIds state blocking ackNum reqNum = do let ack = Ack $ fromIntegral ackNum @@ -145,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 @@ -153,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) @@ -198,17 +200,17 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = fromGenTxId (Block.GenTxIdConway (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/cabal.project b/cabal.project index 915414234ca..04cbd47ae44 100644 --- a/cabal.project +++ b/cabal.project @@ -14,7 +14,7 @@ repository cardano-haskell-packages -- you need to run if you change them index-state: , hackage.haskell.org 2024-06-23T23:01:13Z - , cardano-haskell-packages 2024-07-24T14:16:32Z + , cardano-haskell-packages 2024-07-30T13:21:24Z packages: cardano-node @@ -65,3 +65,53 @@ allow-newer: katip:Win32 -- IMPORTANT -- Do NOT add more source-repository-package stanzas here unless they are strictly -- temporary! Please read the section in CONTRIBUTING about updating dependencies. + +-- coot/typed-protocols-new-api +source-repository-package + type: git + location: https://github.com/input-output-hk/typed-protocols + tag: f36ac61d188be2252eed859937fdf3f98c9d0bbb + --sha256: sha256-QWTulG6okgE5nNbl8l/lkTv7IaxZ/nLHhSsc7Dmhgtc= + subdir: + typed-protocols + typed-protocols-cborg + typed-protocols-stateful + typed-protocols-stateful-cborg + typed-protocols-examples + +-- coot/typed-protocols-new-api +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-network + tag: 0789fc1e6df63065671eaa5f9845a479bc78518f + --sha256: sha256-tOo0OzbtHiwEKEYtFHarCvmXlGLBX1N5kmCMZtI5m9s= + subdir: network-mux + ouroboros-network + ouroboros-network-api + ouroboros-network-framework + ouroboros-network-protocols + ouroboros-network-testing + +-- coot/typed-protocols-new-api +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-consensus + tag: e237a013d568e106712f2de626886286ca296f83 + --sha256: sha256-hI+SYQmQoIr01uVsI6g45ih/5evPD8A2HoHS/R7wv94= + subdir: ouroboros-consensus + ouroboros-consensus-cardano + ouroboros-consensus-diffusion + +-- coot/typed-protocols-new-api +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-api + tag: 628906befc8587b1061f787875174b0dc6d708fb + --sha256: sha256-gVw4aFRB/J5URrpt50AXxIjrT9B4/naQ/xPkSDK+z54= + subdir: cardano-api + +source-repository-package + type: git + location: https://github.com/input-output-hk/ekg-forward + tag: 59c99bb78a0f3da8cccc9a0f7a32bc84607e3f58 + --sha256: sha256-I7xSHeMwH+1RIi0lwlvxaI76uut57gxE8U4klaTSxCM= diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 9eea3235821..26ebd7e0a8f 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -200,6 +200,7 @@ library , safe-exceptions , scientific , si-timers + , singletons , sop-core , stm , strict-sop-core diff --git a/cardano-node/src/Cardano/Node/TraceConstraints.hs b/cardano-node/src/Cardano/Node/TraceConstraints.hs index 06fbed78e1c..a632cc58358 100644 --- a/cardano-node/src/Cardano/Node/TraceConstraints.hs +++ b/cardano-node/src/Cardano/Node/TraceConstraints.hs @@ -7,6 +7,8 @@ module Cardano.Node.TraceConstraints (TraceConstraints) where +import Prelude (Show) + import Cardano.BM.Tracing (ToObject) import Cardano.Ledger.Credential import Cardano.Ledger.Crypto (StandardCrypto) @@ -44,6 +46,8 @@ type TraceConstraints blk = , HasKESInfo blk , GetKESInfo blk , RunNode blk + , Show blk + , Show (Header blk) , ToObject (ApplyTxErr blk) , ToObject (GenTx blk) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs index 2eef28c0d34..19818ed8139 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers.hs @@ -445,6 +445,11 @@ mkNodeToNodeTracers configReflection trBase trForward mbTrEKG _trDataPoint trCon ["TxSubmission", "Remote"] configureTracers configReflection trConfig [txSubmission2Tracer] + !keepAliveTracer <- mkCardanoTracer + trBase trForward mbTrEKG + ["KeepAlive", "Remote"] + configureTracers configReflection trConfig [keepAliveTracer] + pure $ NtN.Tracers { NtN.tChainSyncTracer = Tracer $ traceWith chainSyncTracer @@ -456,6 +461,8 @@ mkNodeToNodeTracers configReflection trBase trForward mbTrEKG _trDataPoint trCon traceWith blockFetchSerialisedTr , NtN.tTxSubmission2Tracer = Tracer $ traceWith txSubmission2Tracer + , NtN.tKeepAliveTracer = Tracer $ + traceWith keepAliveTracer } mkDiffusionTracers diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs index 72d69e6a1f6..98b40fbeecb 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs @@ -21,7 +21,7 @@ import Data.Text (pack) import Formatting import Network.Mux (MuxTrace (..), WithMuxBearer (..)) import Network.Mux.Types -import Network.TypedProtocol.Codec (AnyMessageAndAgency (..)) +import Network.TypedProtocol.Codec (AnyMessage (..)) import qualified Data.List as List import qualified Ouroboros.Network.Diffusion as ND @@ -527,16 +527,16 @@ instance (Show adr, Show ver) => LogFormatting (NtN.HandshakeTr adr ver) where forHuman (WithMuxBearer b ev) = "With mux bearer " <> showT b <> ". " <> showT ev -instance MetaTrace (AnyMessageAndAgency (HS.Handshake nt term)) where - namespaceFor (AnyMessageAndAgency _stok HS.MsgProposeVersions {}) = +instance MetaTrace (AnyMessage (HS.Handshake nt term)) where + namespaceFor (AnyMessage HS.MsgProposeVersions {}) = Namespace [] ["ProposeVersions"] - namespaceFor (AnyMessageAndAgency _stok HS.MsgReplyVersions {}) = + namespaceFor (AnyMessage HS.MsgReplyVersions {}) = Namespace [] ["ReplyVersions"] - namespaceFor (AnyMessageAndAgency _stok HS.MsgQueryReply {}) = + namespaceFor (AnyMessage HS.MsgQueryReply {}) = Namespace [] ["MsgQueryReply"] - namespaceFor (AnyMessageAndAgency _stok HS.MsgAcceptVersion {}) = + namespaceFor (AnyMessage HS.MsgAcceptVersion {}) = Namespace [] ["AcceptVersion"] - namespaceFor (AnyMessageAndAgency _stok HS.MsgRefuse {}) = + namespaceFor (AnyMessage HS.MsgRefuse {}) = Namespace [] ["Refuse"] severityFor (Namespace _ ["ProposeVersions"]) _ = Just Info diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToClient.hs index 870de3235ca..6c7dd7c08b2 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 PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -20,12 +22,13 @@ import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS import Data.Aeson (Value (String), (.=)) import Data.Text (Text, pack) -import Network.TypedProtocol.Codec (AnyMessageAndAgency (..)) +import Network.TypedProtocol.Codec (AnyMessage (..), pattern AnyMessageAndAgency) {-# ANN module ("HLint: ignore Redundant bracket" :: Text) #-} -instance LogFormatting (AnyMessageAndAgency ps) + +instance LogFormatting (AnyMessage ps) => LogFormatting (TraceSendRecv ps) where forMachine dtal (TraceSendMsg m) = mconcat [ "kind" .= String "Send" , "msg" .= forMachine dtal m ] @@ -38,7 +41,7 @@ instance LogFormatting (AnyMessageAndAgency ps) asMetrics (TraceSendMsg m) = asMetrics m asMetrics (TraceRecvMsg m) = asMetrics m -instance MetaTrace (AnyMessageAndAgency ps) => +instance MetaTrace (AnyMessage ps) => MetaTrace (TraceSendRecv ps) where namespaceFor (TraceSendMsg msg) = nsPrependInner "Send" (namespaceFor msg) @@ -48,47 +51,47 @@ instance MetaTrace (AnyMessageAndAgency ps) => severityFor (Namespace out ("Send" : tl)) (Just (TraceSendMsg msg)) = severityFor (Namespace out tl) (Just msg) severityFor (Namespace out ("Send" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace (AnyMessageAndAgency ps)) Nothing + severityFor (Namespace out tl :: Namespace (AnyMessage ps)) Nothing severityFor (Namespace out ("Receive" : tl)) (Just (TraceSendMsg msg)) = severityFor (Namespace out tl) (Just msg) severityFor (Namespace out ("Receive" : tl)) Nothing = - severityFor (Namespace out tl :: Namespace (AnyMessageAndAgency ps)) Nothing + severityFor (Namespace out tl :: Namespace (AnyMessage ps)) Nothing severityFor _ _ = Nothing privacyFor (Namespace out ("Send" : tl)) (Just (TraceSendMsg msg)) = privacyFor (Namespace out tl) (Just msg) privacyFor (Namespace out ("Send" : tl)) Nothing = - privacyFor (Namespace out tl :: Namespace (AnyMessageAndAgency ps)) Nothing + privacyFor (Namespace out tl :: Namespace (AnyMessage ps)) Nothing privacyFor (Namespace out ("Receive" : tl)) (Just (TraceSendMsg msg)) = privacyFor (Namespace out tl) (Just msg) privacyFor (Namespace out ("Receive" : tl)) Nothing = - privacyFor (Namespace out tl :: Namespace (AnyMessageAndAgency ps)) Nothing + privacyFor (Namespace out tl :: Namespace (AnyMessage ps)) Nothing privacyFor _ _ = Nothing detailsFor (Namespace out ("Send" : tl)) (Just (TraceSendMsg msg)) = detailsFor (Namespace out tl) (Just msg) detailsFor (Namespace out ("Send" : tl)) Nothing = - detailsFor (Namespace out tl :: Namespace (AnyMessageAndAgency ps)) Nothing + detailsFor (Namespace out tl :: Namespace (AnyMessage ps)) Nothing detailsFor (Namespace out ("Receive" : tl)) (Just (TraceSendMsg msg)) = detailsFor (Namespace out tl) (Just msg) detailsFor (Namespace out ("Receive" : tl)) Nothing = - detailsFor (Namespace out tl :: Namespace (AnyMessageAndAgency ps)) Nothing + detailsFor (Namespace out tl :: Namespace (AnyMessage ps)) Nothing detailsFor _ _ = Nothing metricsDocFor (Namespace out ("Send" : tl)) = - metricsDocFor (nsCast (Namespace out tl) :: Namespace (AnyMessageAndAgency ps)) + metricsDocFor (nsCast (Namespace out tl) :: Namespace (AnyMessage ps)) metricsDocFor (Namespace out ("Receive" : tl)) = - metricsDocFor (nsCast (Namespace out tl) :: Namespace (AnyMessageAndAgency ps)) + metricsDocFor (nsCast (Namespace out tl) :: Namespace (AnyMessage ps)) metricsDocFor _ = [] documentFor (Namespace out ("Send" : tl)) = - documentFor (nsCast (Namespace out tl) :: Namespace (AnyMessageAndAgency ps)) + documentFor (nsCast (Namespace out tl) :: Namespace (AnyMessage ps)) documentFor (Namespace out ("Receive" : tl)) = - documentFor (nsCast (Namespace out tl) :: Namespace (AnyMessageAndAgency ps)) + documentFor (nsCast (Namespace out tl) :: Namespace (AnyMessage ps)) documentFor _ = Nothing allNamespaces = - let cn = allNamespaces :: [Namespace (AnyMessageAndAgency ps)] + let cn = allNamespaces :: [Namespace (AnyMessage ps)] in fmap (nsPrependInner "Send") cn ++ fmap (nsPrependInner "Receive") cn @@ -96,7 +99,7 @@ instance MetaTrace (AnyMessageAndAgency ps) => -- -- TChainSync Tracer -- -------------------------------------------------------------------------------- -instance LogFormatting (AnyMessageAndAgency (ChainSync blk pt tip)) where +instance LogFormatting (AnyMessage (ChainSync blk pt tip)) where forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgRequestNext{}) = mconcat [ "kind" .= String "MsgRequestNext" , "agency" .= String (pack $ show stok) @@ -130,7 +133,7 @@ instance LogFormatting (AnyMessageAndAgency (ChainSync blk pt tip)) where , "agency" .= String (pack $ show stok) ] -instance MetaTrace (AnyMessageAndAgency (ChainSync blk pt tip)) where +instance MetaTrace (AnyMessage (ChainSync blk pt tip)) where namespaceFor (AnyMessageAndAgency _agency (MsgRequestNext {})) = Namespace [] ["RequestNext"] namespaceFor (AnyMessageAndAgency _agency (MsgAwaitReply {})) = @@ -220,7 +223,7 @@ instance MetaTrace (AnyMessageAndAgency (ChainSync blk pt tip)) where -- LocalTxMonitor Tracer -------------------------------------------------------------------------------- -instance LogFormatting (AnyMessageAndAgency (LTM.LocalTxMonitor txid tx slotNo)) where +instance LogFormatting (AnyMessage (LTM.LocalTxMonitor txid tx slotNo)) where forMachine _dtal (AnyMessageAndAgency stok LTM.MsgAcquire {}) = mconcat [ "kind" .= String "MsgAcquire" , "agency" .= String (pack $ show stok) @@ -266,28 +269,28 @@ instance LogFormatting (AnyMessageAndAgency (LTM.LocalTxMonitor txid tx slotNo)) , "agency" .= String (pack $ show stok) ] -instance MetaTrace (AnyMessageAndAgency (LTM.LocalTxMonitor txid tx slotNo)) where - namespaceFor (AnyMessageAndAgency _agency LTM.MsgAcquire {}) = +instance MetaTrace (AnyMessage (LTM.LocalTxMonitor txid tx slotNo)) where + namespaceFor (AnyMessage LTM.MsgAcquire {}) = Namespace [] ["Acquire"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgAcquired {}) = + namespaceFor (AnyMessage LTM.MsgAcquired {}) = Namespace [] ["Acquired"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgAwaitAcquire {}) = + namespaceFor (AnyMessage LTM.MsgAwaitAcquire {}) = Namespace [] ["AwaitAcquire"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgNextTx {}) = + namespaceFor (AnyMessage LTM.MsgNextTx {}) = Namespace [] ["NextTx"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgReplyNextTx {}) = + namespaceFor (AnyMessage LTM.MsgReplyNextTx {}) = Namespace [] ["ReplyNextTx"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgHasTx {}) = + namespaceFor (AnyMessage LTM.MsgHasTx {}) = Namespace [] ["HasTx"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgReplyHasTx {}) = + namespaceFor (AnyMessage LTM.MsgReplyHasTx {}) = Namespace [] ["ReplyHasTx"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgGetSizes {}) = + namespaceFor (AnyMessage LTM.MsgGetSizes {}) = Namespace [] ["GetSizes"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgReplyGetSizes {}) = + namespaceFor (AnyMessage LTM.MsgReplyGetSizes {}) = Namespace [] ["ReplyGetSizes"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgRelease {}) = + namespaceFor (AnyMessage LTM.MsgRelease {}) = Namespace [] ["Release"] - namespaceFor (AnyMessageAndAgency _agency LTM.MsgDone {}) = + namespaceFor (AnyMessage LTM.MsgDone {}) = Namespace [] ["Done"] severityFor (Namespace _ ["Acquire"]) _ = Just Info @@ -344,7 +347,7 @@ instance MetaTrace (AnyMessageAndAgency (LTM.LocalTxMonitor txid tx slotNo)) whe -- LocalTxSubmission Tracer -------------------------------------------------------------------------------- -instance LogFormatting (AnyMessageAndAgency (LTS.LocalTxSubmission tx err)) where +instance LogFormatting (AnyMessage (LTS.LocalTxSubmission tx err)) where forMachine _dtal (AnyMessageAndAgency stok LTS.MsgSubmitTx{}) = mconcat [ "kind" .= String "MsgSubmitTx" , "agency" .= String (pack $ show stok) @@ -362,14 +365,14 @@ instance LogFormatting (AnyMessageAndAgency (LTS.LocalTxSubmission tx err)) wher , "agency" .= String (pack $ show stok) ] -instance MetaTrace (AnyMessageAndAgency (LTS.LocalTxSubmission tx err)) where - namespaceFor (AnyMessageAndAgency _agency LTS.MsgSubmitTx{}) = +instance MetaTrace (AnyMessage (LTS.LocalTxSubmission tx err)) where + namespaceFor (AnyMessage LTS.MsgSubmitTx{}) = Namespace [] ["SubmitTx"] - namespaceFor (AnyMessageAndAgency _agency LTS.MsgAcceptTx{}) = + namespaceFor (AnyMessage LTS.MsgAcceptTx{}) = Namespace [] ["AcceptTx"] - namespaceFor (AnyMessageAndAgency _agency LTS.MsgRejectTx{}) = + namespaceFor (AnyMessage LTS.MsgRejectTx{}) = Namespace [] ["RejectTx"] - namespaceFor (AnyMessageAndAgency _agency LTS.MsgDone{}) = + namespaceFor (AnyMessage LTS.MsgDone{}) = Namespace [] ["Done"] severityFor (Namespace _ ["SubmitTx"]) _ = Just Info @@ -401,7 +404,7 @@ instance MetaTrace (AnyMessageAndAgency (LTS.LocalTxSubmission tx err)) where -------------------------------------------------------------------------------- instance (forall result. Show (Query blk result)) - => LogFormatting (AnyMessageAndAgency (LSQ.LocalStateQuery blk pt (Query blk))) where + => LogFormatting (AnyMessage (LSQ.LocalStateQuery blk pt (Query blk))) where forMachine _dtal (AnyMessageAndAgency stok LSQ.MsgAcquire{}) = mconcat [ "kind" .= String "MsgAcquire" , "agency" .= String (pack $ show stok) @@ -435,22 +438,22 @@ instance (forall result. Show (Query blk result)) , "agency" .= String (pack $ show stok) ] -instance MetaTrace (AnyMessageAndAgency (LSQ.LocalStateQuery blk pt (Query blk))) where - namespaceFor (AnyMessageAndAgency _agency LSQ.MsgAcquire{}) = +instance MetaTrace (AnyMessage (LSQ.LocalStateQuery blk pt (Query blk))) where + namespaceFor (AnyMessage LSQ.MsgAcquire{}) = Namespace [] ["Acquire"] - namespaceFor (AnyMessageAndAgency _agency LSQ.MsgAcquired{}) = + namespaceFor (AnyMessage LSQ.MsgAcquired{}) = Namespace [] ["Acquired"] - namespaceFor (AnyMessageAndAgency _agency LSQ.MsgFailure{}) = + namespaceFor (AnyMessage LSQ.MsgFailure{}) = Namespace [] ["Failure"] - namespaceFor (AnyMessageAndAgency _agency LSQ.MsgQuery{}) = + namespaceFor (AnyMessage LSQ.MsgQuery{}) = Namespace [] ["Query"] - namespaceFor (AnyMessageAndAgency _agency LSQ.MsgResult{}) = + namespaceFor (AnyMessage LSQ.MsgResult{}) = Namespace [] ["Result"] - namespaceFor (AnyMessageAndAgency _agency LSQ.MsgRelease{}) = + namespaceFor (AnyMessage LSQ.MsgRelease{}) = Namespace [] ["Release"] - namespaceFor (AnyMessageAndAgency _agency LSQ.MsgReAcquire{}) = + namespaceFor (AnyMessage LSQ.MsgReAcquire{}) = Namespace [] ["ReAcquire"] - namespaceFor (AnyMessageAndAgency _agency LSQ.MsgDone{}) = + namespaceFor (AnyMessage LSQ.MsgDone{}) = Namespace [] ["Done"] severityFor (Namespace _ ["Acquire"]) _ = Just Info diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs index d8157a26750..beb727ad815 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs @@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -22,12 +24,13 @@ import Ouroboros.Consensus.Node.Run (SerialiseNodeToNodeConstraints, e import Ouroboros.Network.Block (Point, Serialised (..), blockHash) import Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch (..), Message (..)) import qualified Ouroboros.Network.Protocol.TxSubmission2.Type as STX +import qualified Ouroboros.Network.Protocol.KeepAlive.Type as KA import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) import Data.Aeson (ToJSON (..), Value (String), (.=)) -import Data.Proxy (Proxy (..)) +import Data.Singletons import Data.Text (pack) -import Network.TypedProtocol.Codec (AnyMessageAndAgency (..)) +import Network.TypedProtocol.Codec (AnyMessage (..), pattern AnyMessageAndAgency) -------------------------------------------------------------------------------- -- BlockFetch Tracer @@ -40,7 +43,7 @@ instance ( ConvertTxId blk , HasTxs blk , LedgerSupportsMempool blk ) - => LogFormatting (AnyMessageAndAgency (BlockFetch blk (Point blk))) where + => LogFormatting (AnyMessage (BlockFetch blk (Point blk))) where forMachine DMinimal (AnyMessageAndAgency stok (MsgBlock blk)) = mconcat [ "kind" .= String "MsgBlock" , "agency" .= String (pack $ show stok) @@ -84,18 +87,18 @@ instance ( ConvertTxId blk instance ToJSON SizeInBytes where toJSON (SizeInBytes s) = toJSON s -instance MetaTrace (AnyMessageAndAgency (BlockFetch blk1 (Point blk2))) where - namespaceFor (AnyMessageAndAgency _stok MsgRequestRange{}) = +instance MetaTrace (AnyMessage (BlockFetch blk1 (Point blk2))) where + namespaceFor (AnyMessage MsgRequestRange{}) = Namespace [] ["RequestRange"] - namespaceFor (AnyMessageAndAgency _stok MsgStartBatch{}) = + namespaceFor (AnyMessage MsgStartBatch{}) = Namespace [] ["StartBatch"] - namespaceFor (AnyMessageAndAgency _stok MsgNoBlocks{}) = + namespaceFor (AnyMessage MsgNoBlocks{}) = Namespace [] ["NoBlocks"] - namespaceFor (AnyMessageAndAgency _stok MsgBlock{}) = + namespaceFor (AnyMessage MsgBlock{}) = Namespace [] ["Block"] - namespaceFor (AnyMessageAndAgency _stok MsgBatchDone{}) = + namespaceFor (AnyMessage MsgBatchDone{}) = Namespace [] ["BatchDone"] - namespaceFor (AnyMessageAndAgency _stok MsgClientDone{}) = + namespaceFor (AnyMessage MsgClientDone{}) = Namespace [] ["ClientDone"] severityFor (Namespace _ ["RequestRange"]) _ = Just Info @@ -140,7 +143,7 @@ instance ( ConvertTxId blk , HasTxs blk , HasTxId (GenTx blk) ) - => LogFormatting (AnyMessageAndAgency (BlockFetch (Serialised blk) (Point blk))) where + => LogFormatting (AnyMessage (BlockFetch (Serialised blk) (Point blk))) where forMachine _dtal (AnyMessageAndAgency stok (MsgBlock blk')) = mconcat [ "kind" .= String "MsgBlock" , "agency" .= String (pack $ show stok) @@ -175,7 +178,7 @@ instance ( ConvertTxId blk -------------------------------------------------------------------------------- instance (Show txid, Show tx) - => LogFormatting (AnyMessageAndAgency (STX.TxSubmission2 txid tx)) where + => LogFormatting (AnyMessage (STX.TxSubmission2 txid tx)) where forMachine _dtal (AnyMessageAndAgency stok STX.MsgInit) = mconcat [ "kind" .= String "MsgInit" @@ -209,18 +212,18 @@ instance (Show txid, Show tx) , "agency" .= String (pack $ show stok) ] -instance MetaTrace (AnyMessageAndAgency (STX.TxSubmission2 txid tx)) where - namespaceFor (AnyMessageAndAgency _stok STX.MsgInit {}) = +instance MetaTrace (AnyMessage (STX.TxSubmission2 txid tx)) where + namespaceFor (AnyMessage STX.MsgInit {}) = Namespace [] ["MsgInit"] - namespaceFor (AnyMessageAndAgency _stok STX.MsgRequestTxs {}) = + namespaceFor (AnyMessage STX.MsgRequestTxs {}) = Namespace [] ["RequestTxIds"] - namespaceFor (AnyMessageAndAgency _stok STX.MsgReplyTxs {}) = + namespaceFor (AnyMessage STX.MsgReplyTxs {}) = Namespace [] ["ReplyTxIds"] - namespaceFor (AnyMessageAndAgency _stok STX.MsgRequestTxIds {}) = + namespaceFor (AnyMessage STX.MsgRequestTxIds {}) = Namespace [] ["RequestTxs"] - namespaceFor (AnyMessageAndAgency _stok STX.MsgReplyTxIds {}) = + namespaceFor (AnyMessage STX.MsgReplyTxIds {}) = Namespace [] ["ReplyTxs"] - namespaceFor (AnyMessageAndAgency _stok STX.MsgDone {}) = + namespaceFor (AnyMessage STX.MsgDone {}) = Namespace [] ["Done"] severityFor (Namespace _ ["MsgInit"]) _ = Just Info @@ -328,3 +331,50 @@ instance MetaTrace (AnyMessageAndAgency (STX.TxSubmission2 txid tx)) where , Namespace [] ["ReplyTxs"] , Namespace [] ["Done"] ] + +-------------------------------------------------------------------------------- +-- KeepAlive Tracer +-------------------------------------------------------------------------------- + +instance LogFormatting (AnyMessage KA.KeepAlive) where + forMachine _dtal (AnyMessageAndAgency stok (KA.MsgKeepAlive cookie)) = + mconcat + [ "kind" .= String "MsgKeepAlive" + , "agency" .= String (pack $ show stok) + , "cookie" .= KA.unCookie cookie + ] + forMachine _dtal (AnyMessageAndAgency stok (KA.MsgKeepAliveResponse cookie)) = + mconcat + [ "kind" .= String "MsgKeepAliveReply" + , "agency" .= String (pack $ show stok) + , "cookie" .= KA.unCookie cookie + ] + forMachine _dtal (AnyMessageAndAgency stok KA.MsgDone) = + mconcat + [ "kind" .= String "MsgDone" + , "agency" .= String (pack $ show stok) + ] + +instance MetaTrace (AnyMessage KA.KeepAlive) where + namespaceFor (AnyMessage KA.MsgKeepAlive {}) = + Namespace [] ["MsgKeepAlive"] + namespaceFor (AnyMessage KA.MsgKeepAliveResponse {}) = + Namespace [] ["MsgKeepAliveResponse"] + namespaceFor (AnyMessage KA.MsgDone) = + Namespace [] ["MsgDone"] + + severityFor _ _ = Just Info + + documentFor (Namespace _ ["MsgKeepAlive"]) = Just + "Send a keep alive message." + documentFor (Namespace _ ["MsgKeepAliveResponse"]) = Just + "Keep alive response." + documentFor (Namespace _ ["MsgDone"]) = Just + "The client side terminating message of the protocol." + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["MsgKeepAlive"] + , Namespace [] ["MsgKeepAliveResponse"] + , Namespace [] ["MsgDone"] + ] diff --git a/cardano-node/src/Cardano/Tracing/Config.hs b/cardano-node/src/Cardano/Tracing/Config.hs index fb93f72115a..fa75458b9c8 100644 --- a/cardano-node/src/Cardano/Tracing/Config.hs +++ b/cardano-node/src/Cardano/Tracing/Config.hs @@ -173,6 +173,7 @@ type TraceTxInbound = ("TraceTxInbound" :: Symbol) type TraceTxOutbound = ("TraceTxOutbound" :: Symbol) type TraceTxSubmissionProtocol = ("TraceTxSubmissionProtocol" :: Symbol) type TraceTxSubmission2Protocol = ("TraceTxSubmission2Protocol" :: Symbol) +type TraceKeepAliveProtocol = ("TraceKeepAliveProtocol" :: Symbol) type TraceGsm = ("TraceGsm" :: Symbol) newtype OnOff (name :: Symbol) = OnOff { isOn :: Bool } deriving (Eq, Show) @@ -242,6 +243,7 @@ data TraceSelection , traceTxOutbound :: OnOff TraceTxOutbound , traceTxSubmissionProtocol :: OnOff TraceTxSubmissionProtocol , traceTxSubmission2Protocol :: OnOff TraceTxSubmission2Protocol + , traceKeepAliveProtocol :: OnOff TraceKeepAliveProtocol , traceGsm :: OnOff TraceGsm } deriving (Eq, Show) @@ -305,6 +307,7 @@ data PartialTraceSelection , pTraceTxOutbound :: Last (OnOff TraceTxOutbound) , pTraceTxSubmissionProtocol :: Last (OnOff TraceTxSubmissionProtocol) , pTraceTxSubmission2Protocol :: Last (OnOff TraceTxSubmission2Protocol) + , pTraceKeepAliveProtocol :: Last (OnOff TraceKeepAliveProtocol) , pTraceGsm :: Last (OnOff TraceGsm) } deriving (Eq, Generic, Show) @@ -369,6 +372,7 @@ instance FromJSON PartialTraceSelection where <*> parseTracer (Proxy @TraceTxOutbound) v <*> parseTracer (Proxy @TraceTxSubmissionProtocol) v <*> parseTracer (Proxy @TraceTxSubmission2Protocol) v + <*> parseTracer (Proxy @TraceKeepAliveProtocol) v <*> parseTracer (Proxy @TraceGsm) v @@ -430,6 +434,7 @@ defaultPartialTraceConfiguration = , pTraceTxOutbound = pure $ OnOff False , pTraceTxSubmissionProtocol = pure $ OnOff False , pTraceTxSubmission2Protocol = pure $ OnOff False + , pTraceKeepAliveProtocol = pure $ OnOff False , pTraceGsm = pure $ OnOff True } @@ -493,6 +498,7 @@ partialTraceSelectionToEither (Last (Just (PartialTraceDispatcher pTraceSelectio traceTxOutbound <- proxyLastToEither (Proxy @TraceTxOutbound) pTraceTxOutbound traceTxSubmissionProtocol <- proxyLastToEither (Proxy @TraceTxSubmissionProtocol) pTraceTxSubmissionProtocol traceTxSubmission2Protocol <- proxyLastToEither (Proxy @TraceTxSubmission2Protocol) pTraceTxSubmission2Protocol + traceKeepAliveProtocol <- proxyLastToEither (Proxy @TraceKeepAliveProtocol) pTraceKeepAliveProtocol traceGsm <- proxyLastToEither (Proxy @TraceGsm) pTraceGsm Right $ TraceDispatcher $ TraceSelection { traceVerbosity = traceVerbosity @@ -549,6 +555,7 @@ partialTraceSelectionToEither (Last (Just (PartialTraceDispatcher pTraceSelectio , traceTxOutbound = traceTxOutbound , traceTxSubmissionProtocol = traceTxSubmissionProtocol , traceTxSubmission2Protocol = traceTxSubmission2Protocol + , traceKeepAliveProtocol = traceKeepAliveProtocol , traceGsm = traceGsm } @@ -609,6 +616,7 @@ partialTraceSelectionToEither (Last (Just (PartialTracingOnLegacy pTraceSelectio traceTxOutbound <- proxyLastToEither (Proxy @TraceTxOutbound) pTraceTxOutbound traceTxSubmissionProtocol <- proxyLastToEither (Proxy @TraceTxSubmissionProtocol) pTraceTxSubmissionProtocol traceTxSubmission2Protocol <- proxyLastToEither (Proxy @TraceTxSubmission2Protocol) pTraceTxSubmission2Protocol + traceKeepAliveProtocol <- proxyLastToEither (Proxy @TraceKeepAliveProtocol) pTraceKeepAliveProtocol traceGsm <- proxyLastToEither (Proxy @TraceGsm) pTraceGsm Right $ TracingOnLegacy $ TraceSelection { traceVerbosity = traceVerbosity @@ -665,6 +673,7 @@ partialTraceSelectionToEither (Last (Just (PartialTracingOnLegacy pTraceSelectio , traceTxOutbound = traceTxOutbound , traceTxSubmissionProtocol = traceTxSubmissionProtocol , traceTxSubmission2Protocol = traceTxSubmission2Protocol + , traceKeepAliveProtocol = traceKeepAliveProtocol , traceGsm = traceGsm } diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs index 1b89661c375..6d5776f8381 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RecordWildCards #-} @@ -86,6 +87,8 @@ import Ouroboros.Network.Protocol.ChainSync.Type (ChainSync) import qualified Ouroboros.Network.Protocol.ChainSync.Type as ChainSync import Ouroboros.Network.Protocol.Handshake (HandshakeException (..), HandshakeProtocolError (..), RefuseReason (..)) +import Ouroboros.Network.Protocol.KeepAlive.Type (KeepAlive) +import qualified Ouroboros.Network.Protocol.KeepAlive.Type as KeepAlive import Ouroboros.Network.Protocol.LocalStateQuery.Type (LocalStateQuery) import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery import Ouroboros.Network.Protocol.LocalTxMonitor.Type (LocalTxMonitor) @@ -98,7 +101,6 @@ import Ouroboros.Network.Protocol.TxSubmission2.Type as TxSubmission2 import Ouroboros.Network.RethrowPolicy (ErrorCommand (..)) import Ouroboros.Network.Server2 (ServerTrace (..)) import qualified Ouroboros.Network.Server2 as Server -import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) import Ouroboros.Network.Snocket (LocalAddress (..)) import Ouroboros.Network.Subscription (ConnectResult (..), DnsTrace (..), SubscriberError (..), SubscriptionTrace (..), WithDomainName (..), @@ -125,8 +127,8 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Network.Mux (MiniProtocolNum (..), MuxTrace (..), WithMuxBearer (..)) import Network.Socket (SockAddr (..)) -import Network.TypedProtocol.Codec (AnyMessageAndAgency (..)) -import Network.TypedProtocol.Core (PeerHasAgency (..)) +import Network.TypedProtocol.Core +import Network.TypedProtocol.Codec (AnyMessage (..), pattern AnyMessageAndAgency) {- HLINT ignore "Use record patterns" -} @@ -622,14 +624,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 @@ -637,23 +642,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 @@ -661,6 +666,10 @@ instance (ToObject peer, Show (TxId (GenTx blk)), Show (GenTx blk)) => Transformable Text IO (TraceLabelPeer peer (NtN.TraceSendRecv (TxSubmission2 (GenTxId blk) (GenTx blk)))) where trTransformer = trStructured +instance (ToObject peer) + => Transformable Text IO (TraceLabelPeer peer (NtN.TraceSendRecv KeepAlive)) where + trTransformer = trStructured + instance (ToObject peer, Show (TxId (GenTx blk)), Show (GenTx blk)) => Transformable Text IO (TraceLabelPeer peer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk))) where trTransformer = trStructured @@ -805,11 +814,30 @@ instance Show addr -- -- NOTE: this list is sorted by the unqualified name of the outermost type. +formatMessageWithAgency + :: forall ps (st :: ps) (st' :: ps). + StateTokenI st + => Show (Message ps st st') + => Show (StateToken st) + => TracingVerbosity + -> Message ps st st' + -> String + -> Aeson.Object +formatMessageWithAgency MaximalVerbosity msg _condensed = + mconcat [ "kind" .= String (pack $ show msg) + , "agency" .= String (pack $ show (stateToken :: StateToken st)) + ] +formatMessageWithAgency _ _msg condensed = + mconcat [ "kind" .= String (pack condensed) + , "agency" .= String (pack $ show (stateToken :: StateToken st)) + ] + instance ( ConvertTxId blk , RunNode blk , HasTxs blk + , Show blk ) - => ToObject (AnyMessageAndAgency (BlockFetch blk (Point blk))) where + => ToObject (AnyMessage (BlockFetch blk (Point blk))) where toObject MinimalVerbosity (AnyMessageAndAgency stok (MsgBlock blk)) = mconcat [ "kind" .= String "MsgBlock" , "agency" .= String (pack $ show stok) @@ -828,194 +856,125 @@ instance ( ConvertTxId blk 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 (AnyMessageAndAgency _ msg@MsgRequestRange{}) = + formatMessageWithAgency verb msg "MsgRequestRange" + toObject verb (AnyMessageAndAgency _ msg@MsgStartBatch{}) = + formatMessageWithAgency verb msg "MsgStartBatch" + toObject verb (AnyMessageAndAgency _ msg@MsgNoBlocks{}) = + formatMessageWithAgency verb msg "MsgNoBlocks" + toObject verb (AnyMessageAndAgency _ msg@MsgBatchDone{}) = + formatMessageWithAgency verb msg "MsgBatchDone" + toObject verb (AnyMessageAndAgency _ 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 ToObject (AnyMessage KeepAlive) where + toObject verb (AnyMessage msg@KeepAlive.MsgKeepAlive {}) = + formatMessageWithAgency verb msg "MsgKeepAlive" + toObject verb (AnyMessage msg@KeepAlive.MsgKeepAliveResponse {}) = + formatMessageWithAgency verb msg "MsgKeepAliveResponse" + toObject verb (AnyMessage msg@KeepAlive.MsgDone) = + formatMessageWithAgency verb msg "MsgDone" + instance ToJSON peerAddr => ToJSON (ConnectionId peerAddr) where toJSON ConnectionId { localAddress, remoteAddress } = @@ -1234,7 +1193,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 ] @@ -2084,25 +2043,29 @@ instance ToObject PeerSelectionCounters where , "activeBootstrapPeersDemotions" .= numberOfActiveBootstrapPeersDemotions ] -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 (StateToken st) + => StateToken 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 :: StateToken st)) = Aeson.object [ "kind" .= String "ProtocolLimitFailure" - , "agency" .= toJSON tok + , "state" .= stateToJSON tok ] - toJSON (ExceededTimeLimit tok) = + toJSON (ExceededTimeLimit (tok :: StateToken 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 934a5091612..c72c8e85d63 100644 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Tracing/Tracers.hs @@ -71,7 +71,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 (MempoolSize (..), TraceEventMempool (..)) import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server @@ -522,6 +522,7 @@ mkTracers _ _ _ _ _ enableP2P = , NodeToNode.tBlockFetchTracer = nullTracer , NodeToNode.tBlockFetchSerialisedTracer = nullTracer , NodeToNode.tTxSubmission2Tracer = nullTracer + , NodeToNode.tKeepAliveTracer = nullTracer } , diffusionTracers = Diffusion.nullTracers , diffusionTracersExtra = @@ -1379,6 +1380,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 @@ -1410,6 +1415,8 @@ nodeToNodeTracers' , HasTxs blk , Show peer , ToObject peer + , Show (Header blk) + , Show blk ) => TraceSelection -> TracingVerbosity @@ -1432,6 +1439,9 @@ nodeToNodeTracers' trSel verb tr = , NodeToNode.tTxSubmission2Tracer = tracerOnOff (traceTxSubmissionProtocol trSel) verb "TxSubmissionProtocol" tr + , NodeToNode.tKeepAliveTracer = + tracerOnOff (traceKeepAliveProtocol trSel) + verb "KeepAliveProtocol" tr } teeTraceBlockFetchDecision diff --git a/flake.lock b/flake.lock index f28128d62f2..e6d45b0dd8a 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1721831314, - "narHash": "sha256-I1j5HPSbbh3l1D0C9oP/59YB4e+64K9NDRl7ueD1c/Y=", + "lastModified": 1722347096, + "narHash": "sha256-0hNZ2kvXB/lgWeamza/KqJMDShA8iT9Tsb7Nsm43M7c=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "8815ee7598bc39a02db8896b788f69accf892790", + "rev": "98a4c7fdf12f313ad9312ff43aecde270368cbf1", "type": "github" }, "original": { @@ -544,11 +544,11 @@ "hackageNix": { "flake": false, "locked": { - "lastModified": 1719794527, - "narHash": "sha256-qHo/KumtwAzPkfLWODu/6EFY/LeK+C7iPJyAUdT8tGA=", + "lastModified": 1721953589, + "narHash": "sha256-ctYOxCvXQS5MPILV8YPyUhylKhgIhOM4Dc5g0vGNFbM=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "da2a3bc9bd1b3dd41bb147279529c471c615fd3e", + "rev": "3f0675337984f15834fcd52b97fc766e30f4d684", "type": "github" }, "original": { @@ -564,10 +564,8 @@ "cabal-34": "cabal-34", "cabal-36": "cabal-36", "cardano-shell": "cardano-shell", - "flake-compat": "flake-compat_3", + "flake-compat": "flake-compat_2", "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", - "ghc910X": "ghc910X", - "ghc911": "ghc911", "hackage": [ "hackageNix" ], @@ -584,7 +582,8 @@ "hydra": "hydra", "iserv-proxy": "iserv-proxy", "nixpkgs": [ - "nixpkgs" + "haskellNix", + "nixpkgs-unstable" ], "nixpkgs-2003": "nixpkgs-2003", "nixpkgs-2105": "nixpkgs-2105", @@ -598,11 +597,11 @@ "stackage": "stackage" }, "locked": { - "lastModified": 1718797200, - "narHash": "sha256-ueFxTuZrQ3ZT/Fj5sSeUWlqKa4+OkUU1xW0E+q/XTfw=", + "lastModified": 1720058742, + "narHash": "sha256-QcJiQDEvR6F653AhYBUA6Jukg7DGdkuBj/EsGDZCCLo=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "cb139fa956158397aa398186bb32dd26f7318784", + "rev": "cbd75e3669c44a383e7d80e35c8e96aa795336f3", "type": "github" }, "original": { diff --git a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Acceptor.hs b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Acceptor.hs index db5cf3e7fe0..353564d41b6 100644 --- a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Acceptor.hs +++ b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Acceptor.hs @@ -14,7 +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 @@ -33,15 +33,15 @@ data DataPointAcceptor m a where dataPointAcceptorPeer :: Monad m => DataPointAcceptor m a - -> Peer DataPointForward 'AsClient 'StIdle m a + -> Client DataPointForward 'NonPipelined 'StIdle m 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 @@ -50,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 b339c3f989b..a4732d04a99 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,11 +14,12 @@ 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 Network.TypedProtocol.Codec (Codec, PeerHasAgency (..), PeerRole (..), - SomeMessage (..)) -import Network.TypedProtocol.Codec.CBOR (mkCodecCborLazyBS) import Text.Printf (printf) +import Network.TypedProtocol.Core +import Network.TypedProtocol.Codec (Codec, SomeMessage (..)) +import Network.TypedProtocol.Codec.CBOR (mkCodecCborLazyBS) + import Trace.Forward.Protocol.DataPoint.Type codecDataPointForward @@ -35,48 +37,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 + => StateToken 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 d469da0be8b..f58c915a1d3 100644 --- a/trace-forward/src/Trace/Forward/Protocol/DataPoint/Forwarder.hs +++ b/trace-forward/src/Trace/Forward/Protocol/DataPoint/Forwarder.hs @@ -9,7 +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 @@ -29,20 +29,19 @@ data DataPointForwarder m a = DataPointForwarder dataPointForwarderPeer :: Monad m => DataPointForwarder m a - -> Peer DataPointForward 'AsServer 'StIdle m a + -> Server DataPointForward 'NonPipelined 'StIdle m 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 c3d493222bd..7b3304d37e1 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,16 @@ module Trace.Forward.Protocol.DataPoint.Type , DataPointValue , DataPointValues , DataPointForward (..) + , SingDataPointForward (..) , Message (..) - , ClientHasAgency (..) - , ServerHasAgency (..) - , NobodyHasAgency (..) ) where import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) import qualified Data.ByteString.Lazy as LBS import Data.Text (Text) -import Network.TypedProtocol.Core (Protocol (..)) + +import Network.TypedProtocol.Core -- | A kind to identify our protocol, and the types of the states in the state -- transition diagram of the protocol. @@ -62,6 +62,16 @@ data DataPointForward where 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)) +instance StateTokenI StIdle where stateToken = SingIdle +instance StateTokenI StBusy where stateToken = SingBusy +instance StateTokenI StDone where stateToken = SingDone + instance Protocol DataPointForward where -- | The messages in the trace forwarding/accepting protocol. @@ -83,39 +93,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 16b9ccddd36..9d18894d9c5 100644 --- a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Acceptor.hs +++ b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Acceptor.hs @@ -14,13 +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 @@ -34,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 'StIdle m 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 @@ -60,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 31fc7edea91..5651107b669 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,11 +15,12 @@ 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 Network.TypedProtocol.Codec (Codec, PeerHasAgency (..), PeerRole (..), - SomeMessage (..)) -import Network.TypedProtocol.Codec.CBOR (mkCodecCborLazyBS) import Text.Printf (printf) +import Network.TypedProtocol.Core (ActiveState, StateToken, notActiveState) +import Network.TypedProtocol.Codec (Codec, SomeMessage (..)) +import Network.TypedProtocol.Codec.CBOR (mkCodecCborLazyBS) + import Trace.Forward.Protocol.TraceObject.Type codecTraceObjectForward @@ -36,26 +38,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 @@ -67,42 +67,43 @@ codecTraceObjectForward encodeRequest decodeRequest -- Decode messages decode - :: forall (pr :: PeerRole) - (st :: TraceObjectForward lo) s. - PeerHasAgency pr st + :: forall (st :: TraceObjectForward lo) s. + ActiveState st + => StateToken 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 c537eaea4ae..eac626ac88a 100644 --- a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Forwarder.hs +++ b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Forwarder.hs @@ -9,7 +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 @@ -17,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) @@ -31,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 'StIdle m 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 0419f268dcf..6c1f8cc3d73 100644 --- a/trace-forward/src/Trace/Forward/Protocol/TraceObject/Type.hs +++ b/trace-forward/src/Trace/Forward/Protocol/TraceObject/Type.hs @@ -13,23 +13,21 @@ module Trace.Forward.Protocol.TraceObject.Type ( TraceObjectForward (..) - , TokBlockingStyle (..) + , SingTraceObjectForward (..) + , SingBlockingStyle (..) , Message (..) - , ClientHasAgency (..) - , ServerHasAgency (..) - , NobodyHasAgency (..) , NumberOfTraceObjects (..) , BlockingReplyList (..) ) where -import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) - 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 -- transition diagram of the protocol. @@ -84,22 +82,40 @@ 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 + +instance StateTokenI StIdle where stateToken = SingIdle +instance SingI b + => StateTokenI (StBusy b) where stateToken = SingBusy sing +instance StateTokenI StDone where stateToken = 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 +144,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 +158,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 5acf265a0db..3661bc613e5 100644 --- a/trace-forward/src/Trace/Forward/Run/TraceObject/Acceptor.hs +++ b/trace-forward/src/Trace/Forward/Run/TraceObject/Acceptor.hs @@ -30,8 +30,8 @@ import Trace.Forward.Utils.TraceObject (getTraceObjectsFromReply) acceptTraceObjectsInit :: (CBOR.Serialise lo, - ShowProxy lo, - Typeable lo) + Typeable lo, + ShowProxy lo) => AcceptorConfiguration lo -- ^ Acceptor's configuration. -> (initiatorCtx -> [lo] -> IO ()) -- ^ The handler for accepted 'TraceObject's. -> (initiatorCtx -> IO ()) -- ^ The handler for exceptions from 'runPeer'. @@ -41,8 +41,8 @@ acceptTraceObjectsInit config loHandler peerErrorHandler = acceptTraceObjectsResp :: (CBOR.Serialise lo, - ShowProxy lo, - Typeable lo) + Typeable lo, + ShowProxy lo) => AcceptorConfiguration lo -- ^ Acceptor's configuration. -> (responderCtx -> [lo] -> IO ()) -- ^ The handler for accepted 'TraceObject's. -> (responderCtx -> IO ()) -- ^ The handler for exceptions from 'runPeer'. @@ -52,8 +52,8 @@ acceptTraceObjectsResp config loHandler peerErrorHandler = do runPeerWithHandler :: (CBOR.Serialise lo, - ShowProxy lo, - Typeable lo) + Typeable lo, + ShowProxy lo) => AcceptorConfiguration lo -> (ctx -> [lo] -> IO ()) -> (ctx -> IO ()) @@ -73,13 +73,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 8d9308c0f2a..9940e751f47 100644 --- a/trace-forward/src/Trace/Forward/Run/TraceObject/Forwarder.hs +++ b/trace-forward/src/Trace/Forward/Run/TraceObject/Forwarder.hs @@ -19,8 +19,7 @@ import qualified Trace.Forward.Protocol.TraceObject.Forwarder as Forwarder import Trace.Forward.Utils.TraceObject forwardTraceObjectsInit - :: (CBOR.Serialise lo, - ShowProxy lo) + :: (CBOR.Serialise lo, ShowProxy lo) => ForwarderConfiguration lo -> ForwardSink lo -> RunMiniProtocol 'InitiatorMode initiatorCtx responderCtx LBS.ByteString IO () Void @@ -28,8 +27,7 @@ forwardTraceObjectsInit config sink = InitiatorProtocolOnly $ runPeerWithSink config sink forwardTraceObjectsResp - :: (CBOR.Serialise lo, - ShowProxy lo) + :: (CBOR.Serialise lo, ShowProxy lo) => ForwarderConfiguration lo -> ForwardSink lo -> RunMiniProtocol 'ResponderMode initiatorCtx responderCtx LBS.ByteString IO Void () @@ -37,7 +35,8 @@ forwardTraceObjectsResp config sink = ResponderProtocolOnly $ runPeerWithSink config sink runPeerWithSink - :: (ShowProxy lo, CBOR.Serialise lo) + :: (CBOR.Serialise lo, + ShowProxy lo) => ForwarderConfiguration lo -> ForwardSink lo -> MiniProtocolCb ctx LBS.ByteString IO () diff --git a/trace-forward/src/Trace/Forward/Utils/TraceObject.hs b/trace-forward/src/Trace/Forward/Utils/TraceObject.hs index c6f38c3386d..c585289b938 100644 --- a/trace-forward/src/Trace/Forward/Utils/TraceObject.hs +++ b/trace-forward/src/Trace/Forward/Utils/TraceObject.hs @@ -124,7 +124,7 @@ readFromSink sink@ForwardSink{forwardQueue, wasUsed} = { Forwarder.recvMsgTraceObjectsRequest = \blocking (NumberOfTraceObjects n) -> do replyList <- case blocking of - TokBlocking -> do + SingBlocking -> do objs <- atomically $ do queue <- readTVar forwardQueue res <- getNTraceObjectsBlocking n queue >>= \case @@ -133,7 +133,7 @@ readFromSink sink@ForwardSink{forwardQueue, wasUsed} = modifyTVar' wasUsed . const $ True pure res return $ BlockingReply objs - TokNonBlocking -> do + SingNonBlocking -> do objs <- atomically $ do queue <- readTVar forwardQueue res <- getNTraceObjectsNonBlocking n queue 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 7162a7c4d3f..fe359908ad3 100644 --- a/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Codec.hs +++ b/trace-forward/test/Test/Trace/Forward/Protocol/DataPoint/Codec.hs @@ -7,17 +7,17 @@ module Test.Trace.Forward.Protocol.DataPoint.Codec () where import qualified Data.Aeson as A import Network.TypedProtocol.Codec +import Trace.Forward.Protocol.DataPoint.Type + import Test.QuickCheck import Test.Trace.Forward.Protocol.DataPoint.Item -import Trace.Forward.Protocol.DataPoint.Type - -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 7b8cb7815f6..c8116feba2c 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 #-} @@ -43,7 +44,7 @@ tests = testGroup "Trace.Forward.Protocol.DataPoint" ] prop_codec_DataPointForward - :: AnyMessageAndAgency DataPointForward + :: AnyMessage DataPointForward -> Bool prop_codec_DataPointForward msg = runST $ prop_codecM @@ -52,7 +53,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 @@ -63,7 +64,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 @@ -93,7 +94,7 @@ prop_connect_DataPointForward f (NonNegative n) = (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 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 c5d4176dfbe..2de448ef012 100644 --- a/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Codec.hs +++ b/trace-forward/test/Test/Trace/Forward/Protocol/TraceObject/Codec.hs @@ -17,20 +17,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 4d6609ff559..81112fe54e6 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 #-} @@ -42,7 +43,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 @@ -50,7 +51,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 @@ -60,7 +61,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 @@ -90,7 +91,7 @@ prop_connect_TraceObjectForward f (NonNegative n) = (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 diff --git a/trace-forward/trace-forward.cabal b/trace-forward/trace-forward.cabal index 6a9c67a7972..23af17862b5 100644 --- a/trace-forward/trace-forward.cabal +++ b/trace-forward/trace-forward.cabal @@ -64,12 +64,13 @@ library , deepseq , extra , io-classes - , ouroboros-network-api ^>= 0.7.3 - , ouroboros-network-framework + , ouroboros-network-api >= 0.3 + , ouroboros-network-framework >= 0.7 + , singletons , serialise , stm , text - , typed-protocols ^>= 0.1 + , typed-protocols ^>= 0.2 , typed-protocols-cborg test-suite test