Skip to content
Permalink
Browse files

DEV demo-playground: traces all around

  • Loading branch information...
deepfire committed Jun 13, 2019
1 parent 0b0dc11 commit ff427652395e7e791bf1b45dc7ec6f010c77f933
@@ -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)
@@ -52,7 +52,7 @@ forgeBlock
-> () -- ^ Leader proof ('IsLeader')
-> m (ByronBlock ByronDemoConfig)
forgeBlock cfg curSlot curNo prevHash txs () = 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
@@ -73,10 +73,12 @@ forgeBlock cfg curSlot curNo prevHash txs () = 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
@@ -118,7 +120,7 @@ forgeBlock cfg curSlot curNo prevHash txs () = 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
@@ -40,6 +40,7 @@ import Data.Coerce (coerce)
import Data.Either (lefts, rights)
import Data.FingerTree (Measured (..))
import Data.Foldable (find, foldl')
import Data.Function ((&))
import Data.Reflection (Given (..))
import qualified Data.Sequence as Seq
import Data.Set (Set)
@@ -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 ff42765

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