Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
WIP debug
  • Loading branch information
deepfire committed Jun 13, 2019
1 parent c79bbc4 commit d3fc00e
Show file tree
Hide file tree
Showing 5 changed files with 35 additions and 31 deletions.
45 changes: 22 additions & 23 deletions ouroboros-consensus/demo-playground/Run.hs
Expand Up @@ -128,29 +128,6 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do

withThreadRegistry $ \registry -> do

let callbacks :: NodeCallbacks IO (Block p)
callbacks = NodeCallbacks {
produceDRG = drgNew
, produceBlock = \proof els slot prevPoint prevBlockNo txs ussArgs -> do
let curNo :: BlockNo
curNo = succ prevBlockNo

prevHash :: ChainHash (Header p)
prevHash = castHash (pointHash prevPoint)

-- The transactions we get are consistent; the only reason not
-- to include all of them would be maximum block size, which
-- we ignore for now.
demoForgeBlock pInfoConfig
els
slot
curNo
prevHash
txs
ussArgs
proof
}

chainDB :: ChainDB IO (Block p) (Header p) <- ChainDB.openDB
(demoEncodePreHeader pInfoConfig) pInfoConfig pInfoInitLedger
demoGetHeader
Expand All @@ -167,6 +144,28 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do
btime <- realBlockchainTime registry slotDuration systemStart
let tracer = contramap ((show myNodeId <> " | ") <>)
(Monitoring.toLogObject baseTracer)
callbacks :: NodeCallbacks IO (Block p)
callbacks = NodeCallbacks {
produceDRG = drgNew
, produceBlock = \proof els slot prevPoint prevBlockNo txs ussArgs -> do
let curNo :: BlockNo
curNo = succ prevBlockNo

prevHash :: ChainHash (Header p)
prevHash = castHash (pointHash prevPoint)

-- The transactions we get are consistent; the only reason not
-- to include all of them would be maximum block size, which
-- we ignore for now.
demoForgeBlock pInfoConfig
els
slot
curNo
prevHash
txs
ussArgs
proof
}
nodeParams = NodeParams
{ encoder = demoEncodePreHeader pInfoConfig
, tracer = tracer
Expand Down
1 change: 1 addition & 0 deletions ouroboros-consensus/ouroboros-consensus.cabal
Expand Up @@ -164,6 +164,7 @@ library
typed-protocols,
io-sim-classes,
contra-tracer,
iohk-monitoring,

-- TODO: Ideally we'd refactor this so that this
-- only needs to live in the demo-playground
Expand Down
17 changes: 10 additions & 7 deletions ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs
Expand Up @@ -30,6 +30,7 @@ import Data.Coerce
import Data.Either (lefts, rights)
import Data.FingerTree (Measured (..))
import Data.Foldable (find)
import Data.Function ((&))
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
Expand Down Expand Up @@ -529,7 +530,7 @@ forgeByronDemoBlock
-> () -- ^ Leader proof (IsLeader)
-> m (ByronBlock ByronDemoConfig)
forgeByronDemoBlock cfg els curSlot curNo prevHash txs ussargs () = do
ouroborosPayload <- trace ("forging @ slot " <> show curSlot) $ mkPayload toCBOR cfg () preHeader
ouroborosPayload <- trace ("forging @ slot " <> show curSlot <> ", ussArgs: " <> show ussargs) $ mkPayload toCBOR cfg () preHeader
-- traceM $ "Forge block: " ++ show (forgeBlock ouroborosPayload)
-- processUSStimuli ussa

Expand All @@ -540,11 +541,13 @@ forgeByronDemoBlock cfg els curSlot curNo prevHash txs ussargs () = do
ByronLedgerState {..} = ledgerState els
CC.Block.ChainValidationState {..} = blsCurrent

usStimuli = promoteUSSArgs cvsUpdateState <$> ussargs
votes = lefts usStimuli
mProposal = case rights usStimuli of
[] -> Nothing
[p] -> Just p
usStimuliArgs = promoteUSSArgs cvsUpdateState <$> ussargs
votes = lefts usStimuliArgs &
if null votes then id
else trace $ "minting votes into a block: " <> show votes
mProposal = case trace "mProposal consideration" (rights usStimuliArgs) of
[] -> trace "No proposals this slot." Nothing
[p] -> trace ("minting proposal into a block: " <> show p) $ Just p
_ -> error "XXX: unhandled -- multiple pending proposals for block."

completeProposalBody :: CC.UPI.State -> USSArgs -> CC.Update.ProposalBody
Expand Down Expand Up @@ -586,7 +589,7 @@ forgeByronDemoBlock cfg els curSlot curNo prevHash txs ussargs () = do
CC.Block.bodyTxPayload = txPayload
, CC.Block.bodySscPayload = CC.Ssc.SscPayload
, CC.Block.bodyDlgPayload = Delegation.UnsafeAPayload [] ()
, CC.Block.bodyUpdatePayload = CC.Update.APayload mProposal votes ()
, CC.Block.bodyUpdatePayload = trace "bodyupdatepayload" $ CC.Update.APayload mProposal votes ()
}

proof :: CC.Block.Proof
Expand Down
1 change: 1 addition & 0 deletions ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock.hs
Expand Up @@ -44,6 +44,7 @@ import Codec.CBOR.Decoding (decodeListLenOf)
import Codec.CBOR.Encoding (encodeListLen)
import Codec.Serialise
import Control.Monad.Except
import Control.Tracer (Tracer)
import Crypto.Random (MonadRandom)
import qualified Data.ByteString.Lazy as BL
import Data.FingerTree (Measured (measure))
Expand Down
2 changes: 1 addition & 1 deletion ouroboros-consensus/test-consensus/Test/Dynamic/Network.hs
Expand Up @@ -111,7 +111,7 @@ broadcastNetwork registry btime numCoreNodes pInfo initRNG numSlots = do
-- We ignore the transactions from the mempool (which will be
-- empty), and instead produce some random transactions
txs <- genTxs addrs (getUtxo l)
demoForgeBlock pInfoConfig
demoForgeBlock nullTracer pInfoConfig
slot
curNo
prevHash
Expand Down

0 comments on commit d3fc00e

Please sign in to comment.