Skip to content
Permalink
Browse files

DEV demo-playground: traces all around

  • Loading branch information...
deepfire committed Jun 14, 2019
1 parent 75d3c1e commit 4c8d0de56f714703483f8757126f5cf030cb7448
@@ -25,6 +25,7 @@ import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Semigroup ((<>))
import qualified Data.Text as T
import Debug.Trace (trace)

import Control.Monad.Class.MonadAsync

@@ -272,7 +273,7 @@ handleSimpleNode p CLI{..} myNodeAddress (TopologyInfo myNodeId topologyFile) =
initFingerprint = (genesisPoint, genesisPoint)
fingerprint frag = (AF.headPoint frag, AF.anchorPoint frag)
logFullChain = do
chain <- ChainDB.toChain chainDB
chain <- trace ("!!!!!!!!!!!!!!!!!!!!!!!!!!!!! logFullChain: " <> show nid) $ ChainDB.toChain chainDB
traceWith tracer $
"Updated chain: " <> condense (Chain.toOldestFirst chain)

@@ -31,6 +31,7 @@ import Control.Monad (forever, replicateM_, void, when)
import Data.Fixed
import Data.Time
import Data.Word (Word64)
import Debug.Trace (trace)

import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork (MonadFork)
@@ -119,8 +120,8 @@ realBlockchainTime registry slotLen start = do
void $ forkLinked registry $ forever $ do
-- In each iteration of the loop, we recompute how long to wait until
-- the next slot. This minimizes clock skew.
next <- waitUntilNextSlotIO slotLen start
atomically $ writeTVar slotVar next
next <- waitUntilNextSlotIO slotLen $ start
atomically $ trace ("####################################### woke up @ " <> show next) $ writeTVar slotVar next
return BlockchainTime {
getCurrentSlot = readTVar slotVar
, onSlotChange = onEachChange registry id first (readTVar slotVar)
@@ -61,7 +61,7 @@ forgeBlock
-> () -- ^ Leader proof ('IsLeader')
-> m (ByronBlock ByronDemoConfig)
forgeBlock cfg els curSlot curNo prevHash txs ussargs () = do
ouroborosPayload <- trace ("forging @ slot " <> show curSlot) $ forgePBftFields (encNodeConfigP cfg) toCBOR toSign
ouroborosPayload <- trace ("forging @ slot " <> show curSlot <> ", ussargs: " <> show ussargs) $ forgePBftFields (encNodeConfigP cfg) toCBOR toSign
return $ forge ouroborosPayload
where
-- TODO: If we reconsider 'ByronDemoConfig', we can probably move this whole
@@ -83,10 +83,12 @@ forgeBlock cfg els curSlot curNo prevHash txs ussargs () = do
CC.Block.ChainValidationState {..} = blsCurrent

usStimuli = promoteUSSArgs cvsUpdateState <$> ussargs
votes = lefts usStimuli
votes = lefts usStimuli & \xs->
if null xs then xs
else trace ("votes: " <> show votes) xs
mProposal = case rights usStimuli of
[] -> Nothing
[p] -> Just p
[p] -> Just $ trace ("proposal: " <> show p) $ p
_ -> error "XXX: unhandled -- multiple pending proposals for block."

completeProposalBody :: CC.UPI.State -> USSArgs -> CC.Update.ProposalBody
@@ -128,7 +130,7 @@ forgeBlock cfg els curSlot curNo prevHash txs ussargs () = do
CC.Block.bodyTxPayload = txPayload
, CC.Block.bodySscPayload = CC.Ssc.SscPayload
, CC.Block.bodyDlgPayload = CC.Delegation.UnsafeAPayload [] ()
, CC.Block.bodyUpdatePayload = CC.Update.APayload mProposal votes ()
, CC.Block.bodyUpdatePayload = trace "US payload" $ CC.Update.APayload mProposal votes ()
}

proof :: CC.Block.Proof
@@ -27,6 +27,7 @@ import Crypto.Random (ChaChaDRG)
import qualified Data.Foldable as Foldable
import Data.Functor.Contravariant (contramap)
import Data.Map.Strict (Map)
import Debug.Trace (trace)

import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork (MonadFork)
@@ -301,6 +302,7 @@ forkBlockProduction
forkBlockProduction IS{..} =
onSlotChange btime $ \currentSlot -> do
drg <- produceDRG
traceWith tracer ("onSlotChange " <> show currentSlot)
mNewBlock <- atomically $ do
varDRG <- newTVar drg
l@ExtLedgerState{..} <- ChainDB.getCurrentLedger chainDB
@@ -314,11 +316,11 @@ forkBlockProduction IS{..} =
case mIsLeader of
Nothing -> return Nothing
Just proof -> do
(prevPoint, prevNo) <- prevPointAndBlockNo currentSlot <$>
(prevPoint, prevNo) <- trace "--------------------------------- before flushTQueue" $ prevPointAndBlockNo currentSlot <$>
ChainDB.getCurrentChain chainDB
txs <- getTxs mempool
ussArgs <- flushTQueue ussaQueue
newBlock <- runProtocol varDRG $
ussArgs <- trace "????????????????????????????????? flushTQueue" $ flushTQueue ussaQueue
newBlock <- trace "================================= after flushTQueue" $ runProtocol varDRG $
produceBlock
proof
l
@@ -22,6 +22,7 @@ import Control.Monad.State
import Control.Monad.Writer

import Data.Void (Void)
import Debug.Trace (trace)

import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork (MonadFork)
@@ -55,8 +56,8 @@ onEachChange registry f initB getA notify = void $ forkLinked registry $ go init
go :: b -> m Void
go b = do
(a, b') <- atomically $ blockUntilChanged f b getA
notify a
go b'
notify $ trace ".................%...%...%..............onEachChange waking up" a
go $ trace "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% onEachChange after action" b'

blockUntilJust :: MonadSTM m => STM m (Maybe a) -> STM m a
blockUntilJust getMaybeA = do

0 comments on commit 4c8d0de

Please sign in to comment.
You can’t perform that action at this time.