Skip to content
Permalink
Browse files

Continue chipping away at the demo

  • Loading branch information...
edsko committed May 15, 2019
1 parent 7222f3c commit a7a63612ce5b459c91c2c057784201ae12621112
@@ -98,6 +98,8 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do
let callbacks :: NodeCallbacks IO (Block p)
callbacks = NodeCallbacks {
produceBlock = \proof l slot prevPoint prevBlockNo -> do
undefined
{-
let curNo = succ prevBlockNo
prevHash = castHash (pointHash prevPoint)
@@ -117,12 +119,16 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do
prevHash
txs
proof
-}

, produceDRG = drgNew
}

chainDB <- ChainDB.openDB encode pInfoConfig pInfoInitLedger Mock.simpleHeader
chainDB :: ChainDB IO (Block p) (Header p) <-
ChainDB.openDB encode pInfoConfig pInfoInitLedger demoGetHeader

undefined
{-
btime <- realBlockchainTime registry slotDuration systemStart
let tracer = contramap ((show myNodeId <> " | ") <>) stdoutTracer
nodeParams = NodeParams
@@ -149,6 +155,7 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do
forM_ (consumers nodeSetup) (addDownstream' kernel)
Async.wait mempoolThread
-}
where
nid :: Int
nid = case myNodeId of
@@ -18,7 +18,7 @@ module Ouroboros.Consensus.Demo (
, DemoLeaderSchedule
, DemoMockPBFT
, DemoRealPBFT
, DemoForgeBlock(..)
, RunDemo(..)
, Block
, Header
, NumCoreNodes(..)
@@ -34,7 +34,6 @@ module Ouroboros.Consensus.Demo (
, HasCreator(..)
) where

import Codec.Serialise (Serialise)
import Control.Monad.Except
import Crypto.Random (MonadRandom)
import qualified Data.Bimap as Bimap
@@ -52,7 +51,8 @@ import qualified Cardano.Chain.Genesis as Cardano.Genesis
import qualified Cardano.Crypto as Cardano
import qualified Cardano.Crypto.Signing as Cardano.KeyGen

import Ouroboros.Network.Block (BlockNo, ChainHash, SlotNo)
import Ouroboros.Network.Block (BlockNo, ChainHash, HasHeader,
HeaderHash, SlotNo, StandardHash)

import Ouroboros.Consensus.Crypto.DSIGN
import Ouroboros.Consensus.Crypto.DSIGN.Mock (verKeyIdFromSigned)
@@ -100,7 +100,7 @@ data DemoProtocol p where
DemoRealPBFT :: PBftParams -> DemoProtocol DemoRealPBFT

type family Block p = b | b -> p where
Block DemoRealPBFT = ByronBlock
Block DemoRealPBFT = ByronBlock ByronDemoConfig

-- Demos using mock ledger/block
Block p = SimpleBlock p SimpleBlockMockCrypto
@@ -126,9 +126,12 @@ type DemoProtocolConstraints p = (
, HasCreator p
, Condense (Payload p (PreHeader (Block p)))
, Eq (Payload p (PreHeader (Block p)))
, Serialise (Payload p (PreHeader (Block p)))
, Show (Payload p (PreHeader (Block p)))
, DemoForgeBlock p
, RunDemo p
, BlockProtocol (Block p) ~ p
, HeaderHash (Block p) ~ HeaderHash (Header p)
, StandardHash (Header p)
, HasHeader (Header p)
)

demoProtocolConstraints :: DemoProtocol p -> Dict (DemoProtocolConstraints p)
@@ -386,10 +389,10 @@ instance HasCreator DemoRealPBFT where
$ b

{-------------------------------------------------------------------------------
Forging blocks
Additional functions needed to run the demo
-------------------------------------------------------------------------------}

class DemoForgeBlock p where
class RunDemo p where
demoForgeBlock :: (HasNodeState p m, MonadRandom m)
=> NodeConfig p
-> SlotNo -- ^ Current slot
@@ -399,17 +402,24 @@ class DemoForgeBlock p where
-> IsLeader p
-> m (Block p)

instance DemoForgeBlock DemoBFT where
demoGetHeader :: Block p -> Header p

instance RunDemo DemoBFT where
demoForgeBlock = forgeSimpleBlock
demoGetHeader = simpleHeader

instance DemoForgeBlock DemoPraos where
instance RunDemo DemoPraos where
demoForgeBlock = forgeSimpleBlock
demoGetHeader = simpleHeader

instance DemoForgeBlock DemoLeaderSchedule where
instance RunDemo DemoLeaderSchedule where
demoForgeBlock = forgeSimpleBlock
demoGetHeader = simpleHeader

instance DemoForgeBlock DemoMockPBFT where
instance RunDemo DemoMockPBFT where
demoForgeBlock = forgeSimpleBlock
demoGetHeader = simpleHeader

instance DemoForgeBlock DemoRealPBFT where
instance RunDemo DemoRealPBFT where
demoForgeBlock = forgeByronDemoBlock
demoGetHeader = byronHeader
@@ -37,6 +37,7 @@ import Data.Foldable (find)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import Data.Typeable
import Data.Word
import Ouroboros.Consensus.Crypto.DSIGN
import Ouroboros.Consensus.Crypto.Hash
@@ -53,43 +54,70 @@ byronEpochSlots :: CC.Slot.EpochSlots
byronEpochSlots = CC.Slot.EpochSlots 21600

-- | Newtype wrapper to avoid orphan instances
newtype ByronBlock = ByronBlock { unByronBlock :: CC.Block.ABlock ByteString }
--
-- The phantom type parameter is there to record the additional information
-- we need to work with this block. Most of the code here does not care,
-- but we may need different additional information when running the chain
-- for real as when we are running the demo.
newtype ByronBlock cfg = ByronBlock { unByronBlock :: CC.Block.ABlock ByteString }
deriving (Eq, Show)

newtype ByronHeader = ByronHeader { unByronHeader :: CC.Block.AHeader ByteString }

byronHeader :: ByronBlock -> ByronHeader
byronHeader :: ByronBlock cfg -> ByronHeader
byronHeader (ByronBlock b) = ByronHeader (CC.Block.blockHeader b)

instance StandardHash ByronBlock
instance Typeable cfg => Measured BlockMeasure (ByronBlock cfg) where
measure = blockMeasure

instance Measured BlockMeasure ByronBlock where
instance Measured BlockMeasure ByronHeader where
measure = blockMeasure

convertSlot :: CC.Slot.FlatSlotId -> SlotNo
convertSlot = fromIntegral @Word64 . coerce

instance HasHeader ByronBlock where
type HeaderHash ByronBlock = CC.Block.HeaderHash
instance Typeable cfg => HasHeader (ByronBlock cfg) where
type HeaderHash (ByronBlock cfg) = CC.Block.HeaderHash

blockHash = CC.Block.blockHashAnnotated . unByronBlock
-- TODO distinguish the genesis hash? How do we do this after the fact?
blockPrevHash = BlockHash . CC.Block.blockPrevHash . unByronBlock
blockSlot = convertSlot . CC.Block.blockSlot . unByronBlock
blockNo = BlockNo . CC.Common.unChainDifficulty . CC.Block.blockDifficulty . unByronBlock
blockHash = blockHash . byronHeader
blockPrevHash = castHash . blockPrevHash . byronHeader
blockSlot = blockSlot . byronHeader
blockNo = blockNo . byronHeader
blockInvariant = const True

instance HasHeader ByronHeader where
type HeaderHash ByronHeader = CC.Block.HeaderHash

-- Implementation of 'blockHash' derived from
--
-- > blockHashAnnotated :: ABlock ByteString -> HeaderHash
-- > blockHashAnnotated = hashDecoded . fmap wrapHeaderBytes . blockHeader
--
-- I couldn't find a version for headers
blockHash = Crypto.hashDecoded . fmap CC.Block.wrapHeaderBytes . unByronHeader

-- We should distinguish the genesis hash
-- TODO: I think this already lives somewhere. I don't know where. In fact,
-- I think Erik or Ru already wrote this very 'HasHeader' instance :/
blockPrevHash = BlockHash . CC.Block.headerPrevHash . unByronHeader

instance UpdateLedger ByronBlock where
data LedgerState ByronBlock = ByronLedgerState
blockSlot = convertSlot . CC.Block.headerSlot . unByronHeader
blockNo = BlockNo . CC.Common.unChainDifficulty . CC.Block.headerDifficulty . unByronHeader
blockInvariant = const True

instance StandardHash (ByronBlock cfg)
instance StandardHash ByronHeader

instance UpdateLedger (ByronBlock cfg) where
data LedgerState (ByronBlock cfg) = ByronLedgerState
{ blsCurrent :: CC.Block.ChainValidationState
-- | Slot-bounded snapshots of the chain state
, blsSnapshots :: Seq.Seq (SlotBounded CC.Block.ChainValidationState)
}
deriving (Eq, Show)
newtype LedgerError ByronBlock = ByronLedgerError CC.Block.ChainValidationError
newtype LedgerError (ByronBlock cfg) = ByronLedgerError CC.Block.ChainValidationError
deriving (Eq, Show)
newtype LedgerConfig ByronBlock = ByronLedgerConfig Genesis.Config
newtype LedgerConfig (ByronBlock cfg) = ByronLedgerConfig Genesis.Config

applyLedgerBlock (ByronLedgerConfig cfg) (ByronBlock block) (ByronLedgerState state snapshots)
= mapExcept (bimap ByronLedgerError id) $ do
@@ -170,14 +198,14 @@ instance UpdateLedger ByronBlock where
Support for PBFT consensus algorithm
-------------------------------------------------------------------------------}

type instance BlockProtocol ByronBlock = PBft PBftCardanoCrypto
type instance BlockProtocol (ByronBlock cfg) = ExtNodeConfig cfg (PBft PBftCardanoCrypto)

instance HasPreHeader ByronBlock where
type PreHeader ByronBlock = CC.Block.ToSign
instance Typeable cfg => HasPreHeader (ByronBlock cfg) where
type PreHeader (ByronBlock cfg) = CC.Block.ToSign
blockPreHeader = unAnnotated . CC.Block.recoverSignedBytes byronEpochSlots
. CC.Block.blockHeader . unByronBlock

instance HasPayload (PBft PBftCardanoCrypto) ByronBlock where
instance Typeable cfg => HasPayload (PBft PBftCardanoCrypto) (ByronBlock cfg) where
blockPayload _ (ByronBlock aBlock) = PBftPayload
{ pbftIssuer = VerKeyCardanoDSIGN
. Crypto.pskIssuerVK
@@ -196,7 +224,7 @@ instance HasPayload (PBft PBftCardanoCrypto) ByronBlock where
$ aBlock
}

instance ProtocolLedgerView ByronBlock where
instance Typeable cfg => ProtocolLedgerView (ByronBlock cfg) where
protocolLedgerView _ns (ByronLedgerState ls _) = PBftLedgerView
-- Delegation map
( Delegation.unMap
@@ -267,7 +295,7 @@ forgeByronDemoBlock
-> ChainHash ByronHeader -- ^ Previous hash
-> Map (Hash ShortHash Mock.Tx) Mock.Tx -- ^ Txs to add in the block
-> () -- Leader proof (IsLeader)
-> m ByronBlock
-> m (ByronBlock ByronDemoConfig)
forgeByronDemoBlock = undefined
{-
forgeBlockFromMock

0 comments on commit a7a6361

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