1
+ {-# LANGUAGE BlockArguments #-}
1
2
{-# LANGUAGE CPP #-}
2
3
{-# LANGUAGE DataKinds #-}
3
4
{-# LANGUAGE FlexibleContexts #-}
@@ -20,13 +21,11 @@ import Data.Word (Word64)
20
21
21
22
import qualified Ouroboros.Network.AnchoredFragment as AF
22
23
import Ouroboros.Network.Block (BlockNo (.. ), blockNo , unBlockNo )
23
- import Ouroboros.Network.NodeToClient (LocalConnectionId )
24
- import Ouroboros.Network.NodeToNode (RemoteAddress )
25
24
26
25
import Ouroboros.Consensus.Block (SlotNo (.. ))
27
26
import Ouroboros.Consensus.HardFork.Combinator
28
27
import Ouroboros.Consensus.Ledger.Abstract (IsLedger )
29
- import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState , ledgerState )
28
+ import Ouroboros.Consensus.Ledger.Extended (ledgerState )
30
29
import Ouroboros.Consensus.Node (NodeKernel (.. ))
31
30
import Ouroboros.Consensus.Node.Tracers
32
31
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
@@ -45,6 +44,8 @@ data TraceStartLeadershipCheckPlus =
45
44
tsSlotNo :: SlotNo
46
45
, tsUtxoSize :: Int
47
46
, tsDelegMapSize :: Int
47
+ , tsDRepCount :: Int
48
+ , tsDRepMapSize :: Int
48
49
, tsChainDensity :: Double
49
50
}
50
51
@@ -58,47 +59,41 @@ forgeTracerTransform ::
58
59
=> NodeKernelData blk
59
60
-> Trace IO (ForgeTracerType blk)
60
61
-> IO (Trace IO (ForgeTracerType blk))
61
- forgeTracerTransform nodeKern (Trace tr) =
62
- contramapM (Trace tr)
63
- (\ case
64
- (lc, Right (Left slc@ (TraceStartLeadershipCheck slotNo))) -> do
65
- query <- mapNodeKernelDataIO
66
- (\ nk ->
67
- (,,)
68
- <$> nkQueryLedger (ledgerUtxoSize . ledgerState) nk
69
- <*> nkQueryLedger (ledgerDelegMapSize . ledgerState) nk
70
- <*> nkQueryChain fragmentChainDensity nk)
71
- nodeKern
72
- case query of
73
- SNothing -> pure (lc, Right (Left slc))
74
- SJust (utxoSize, delegMapSize, chainDensity) ->
75
- let msg = TraceStartLeadershipCheckPlus
76
- slotNo
77
- utxoSize
78
- delegMapSize
79
- (fromRational chainDensity)
80
- in pure (lc, Right (Right msg))
81
- (lc, Right a) ->
82
- pure (lc, Right a)
83
- (lc, Left control) ->
84
- pure (lc, Left control))
85
-
86
- nkQueryLedger ::
87
- IsLedger (LedgerState blk )
88
- => (ExtLedgerState blk -> a )
89
- -> NodeKernel IO RemoteAddress LocalConnectionId blk
90
- -> IO a
91
- nkQueryLedger f NodeKernel {getChainDB} =
92
- f <$> atomically (ChainDB. getCurrentLedger getChainDB)
62
+ forgeTracerTransform (NodeKernelData ref) (Trace tr) =
63
+ let secondM f (x, y) = do -- avoiding new dep on extra pkg
64
+ y' <- f y
65
+ pure (x, y')
66
+ in contramapM (Trace tr) $ secondM
67
+ \ case
68
+ Right (Left slc@ (TraceStartLeadershipCheck tsSlotNo)) -> do
69
+ query <- readIORef ref >>= traverse
70
+ \ NodeKernel {getChainDB} -> do
71
+ ledger <- fmap ledgerState . atomically $
72
+ ChainDB. getCurrentLedger getChainDB
73
+ chain <- atomically $ ChainDB. getCurrentChain getChainDB
74
+ pure TraceStartLeadershipCheckPlus {
75
+ tsSlotNo
76
+ , tsUtxoSize = ledgerUtxoSize ledger
77
+ , tsDelegMapSize = ledgerDelegMapSize ledger
78
+ , tsDRepCount = ledgerDRepCount ledger
79
+ , tsDRepMapSize = ledgerDRepMapSize ledger
80
+ , tsChainDensity = fragmentChainDensity chain }
81
+ pure . Right $ case query of
82
+ SNothing -> Left slc
83
+ SJust tslcp -> Right tslcp
84
+ Right a ->
85
+ pure $ Right a
86
+ Left control ->
87
+ pure $ Left control
93
88
94
89
fragmentChainDensity ::
95
90
#if __GLASGOW_HASKELL__ >= 906
96
91
(AF. HasHeader blk, AF. HasHeader (Header blk))
97
92
#else
98
93
AF. HasHeader (Header blk)
99
94
#endif
100
- => AF. AnchoredFragment (Header blk) -> Rational
101
- fragmentChainDensity frag = calcDensity blockD slotD
95
+ => AF. AnchoredFragment (Header blk) -> Double
96
+ fragmentChainDensity frag = fromRational $ calcDensity blockD slotD
102
97
where
103
98
calcDensity :: Word64 -> Word64 -> Rational
104
99
calcDensity bl sl
@@ -119,18 +114,3 @@ fragmentChainDensity frag = calcDensity blockD slotD
119
114
-- don't let it contribute to the number of blocks
120
115
Right 0 -> 1
121
116
Right b -> b
122
-
123
- nkQueryChain ::
124
- (AF. AnchoredFragment (Header blk ) -> a )
125
- -> NodeKernel IO RemoteAddress LocalConnectionId blk
126
- -> IO a
127
- nkQueryChain f NodeKernel {getChainDB} =
128
- f <$> atomically (ChainDB. getCurrentChain getChainDB)
129
-
130
-
131
- mapNodeKernelDataIO ::
132
- (NodeKernel IO RemoteAddress LocalConnectionId blk -> IO a )
133
- -> NodeKernelData blk
134
- -> IO (StrictMaybe a )
135
- mapNodeKernelDataIO f (NodeKernelData ref) =
136
- readIORef ref >>= traverse f
0 commit comments