Skip to content
Permalink
Browse files

Cleanup

  • Loading branch information...
edsko committed May 16, 2019
1 parent a7a6361 commit 14a471c53466feec3c0125399247359d8bc86d93
@@ -60,7 +60,9 @@ fromProtocol MockPBFT =
where
-- TODO: This is nasty
genesisConfig = error "genesis config not needed when using mock ledger"
fromProtocol (RealPBFT fp) = do
fromProtocol (RealPBFT _fp) = do
-- mainnet might not be what we want: we need initial stake /and the
-- private keys for that initial stake/
genesisConfig <- readMainetCfg
return $ Some $ DemoMockPBFT (defaultDemoPBftParams genesisConfig)

@@ -59,13 +59,13 @@ runNode cli@CLI{..} = do
handleTxSubmission topology tx
SimpleNode topology protocol -> do
Some p <- fromProtocol protocol
case demoProtocolConstraints p of
case runDemo p of
Dict -> handleSimpleNode p cli topology

-- | Sets up a simple node, which will run the chain sync protocol and block
-- fetch protocol, and, if core, will also look at the mempool when trying to
-- create a new block.
handleSimpleNode :: forall p. DemoProtocolConstraints p
handleSimpleNode :: forall p. RunDemo p
=> DemoProtocol p -> CLI -> TopologyInfo -> IO ()
handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do
putStrLn $ "System started at " <> show systemStart
@@ -125,7 +125,7 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do
}

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

undefined
{-
@@ -196,7 +196,6 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do
, ncWithChan = NamedPipe.withPipeChannel "block-fetch" direction
}


addDownstream' :: NodeKernel IO NodeId (Block p) (Header p)
-> NodeId
-> IO ()
@@ -1,13 +1,14 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

-- | Instantiations of the protocol stack used in tests and demos
module Ouroboros.Consensus.Demo (
@@ -18,14 +19,13 @@ module Ouroboros.Consensus.Demo (
, DemoLeaderSchedule
, DemoMockPBFT
, DemoRealPBFT
, RunDemo(..)
, Block
, Header
, NumCoreNodes(..)
, ProtocolInfo(..)
, protocolInfo
, DemoProtocolConstraints
, demoProtocolConstraints
, RunDemo(..)
, runDemo
-- * Support for runnig the demos
, defaultSecurityParam
, defaultDemoPraosParams
@@ -34,6 +34,7 @@ module Ouroboros.Consensus.Demo (
, HasCreator(..)
) where

import Codec.Serialise (Serialise)
import Control.Monad.Except
import Crypto.Random (MonadRandom)
import qualified Data.Bimap as Bimap
@@ -119,28 +120,6 @@ data ProtocolInfo p = ProtocolInfo {
, pInfoInitState :: NodeState p
}

type DemoProtocolConstraints p = (
OuroborosTag p
, ProtocolLedgerView (Block p)
-- , SupportedBlock p (SimpleHeader p SimpleBlockMockCrypto)
, HasCreator p
, Condense (Payload p (PreHeader (Block p)))
, Eq (Payload p (PreHeader (Block p)))
, Show (Payload p (PreHeader (Block 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)
demoProtocolConstraints DemoBFT{} = Dict
demoProtocolConstraints DemoPraos{} = Dict
demoProtocolConstraints DemoLeaderSchedule{} = Dict
demoProtocolConstraints DemoMockPBFT{} = Dict
demoProtocolConstraints DemoRealPBFT{} = Dict

newtype NumCoreNodes = NumCoreNodes Int
deriving (Show)

@@ -388,11 +367,38 @@ instance HasCreator DemoRealPBFT where
. Cardano.Block.blockHeader
$ b


{-
type DemoProtocolConstraints p =
demoProtocolConstraints :: DemoProtocol p -> Dict (DemoProtocolConstraints p)
demoProtocolConstraints DemoBFT{} = Dict
demoProtocolConstraints DemoPraos{} = Dict
demoProtocolConstraints DemoLeaderSchedule{} = Dict
demoProtocolConstraints DemoMockPBFT{} = Dict
demoProtocolConstraints DemoRealPBFT{} = Dict
-}

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

class RunDemo p where
class ( OuroborosTag p
, ProtocolLedgerView (Block p)
, HasCreator p
, Condense (Payload p (PreHeader (Block p)))
, Eq (Payload p (PreHeader (Block p)))
, Show (Payload p (PreHeader (Block p)))
, BlockProtocol (Block p) ~ p
, HeaderHash (Block p) ~ HeaderHash (Header p)
, StandardHash (Header p)
, HasHeader (Header p)
, LedgerConfigView (Block p)
, SupportedPreHeader p (PreHeader (Block p))
, Condense (Block p)
, Condense [Block p]
) => RunDemo p where
demoForgeBlock :: (HasNodeState p m, MonadRandom m)
=> NodeConfig p
-> SlotNo -- ^ Current slot
@@ -404,6 +410,13 @@ class RunDemo p where

demoGetHeader :: Block p -> Header p

runDemo :: DemoProtocol p -> Dict (RunDemo p)
runDemo DemoBFT{} = Dict
runDemo DemoPraos{} = Dict
runDemo DemoLeaderSchedule{} = Dict
runDemo DemoMockPBFT{} = Dict
runDemo DemoRealPBFT{} = Dict

instance RunDemo DemoBFT where
demoForgeBlock = forgeSimpleBlock
demoGetHeader = simpleHeader
@@ -4,6 +4,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
@@ -12,6 +13,21 @@

module Ouroboros.Consensus.Ledger.Byron where

import Codec.Serialise (Serialise (..))
import Control.Monad.Except
import Crypto.Random (MonadRandom)
import Data.Bifunctor (bimap)
import qualified Data.Bimap as Bimap
import Data.ByteString (ByteString)
import Data.Coerce
import Data.FingerTree (Measured (..))
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 Cardano.Binary (Annotated (..), reAnnotate)
import qualified Cardano.Chain.Block as CC.Block
import qualified Cardano.Chain.Common as CC.Common
@@ -26,19 +42,9 @@ import qualified Cardano.Chain.Update.Validation.Interface as CC.UPI
import qualified Cardano.Chain.UTxO as CC.UTxO
import qualified Cardano.Crypto as Crypto
import Cardano.Prelude (panic)
import Control.Monad.Except
import Crypto.Random (MonadRandom)
import Data.Bifunctor (bimap)
import qualified Data.Bimap as Bimap
import Data.ByteString (ByteString)
import Data.Coerce
import Data.FingerTree (Measured (..))
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.Network.Block

import Ouroboros.Consensus.Crypto.DSIGN
import Ouroboros.Consensus.Crypto.Hash
import Ouroboros.Consensus.Ledger.Abstract
@@ -47,7 +53,7 @@ import Ouroboros.Consensus.Node (CoreNodeId)
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Protocol.ExtNodeConfig
import Ouroboros.Consensus.Protocol.PBFT
import Ouroboros.Network.Block
import Ouroboros.Consensus.Util.Condense

-- | Hard-coded number of slots per epoch in the Byron era
byronEpochSlots :: CC.Slot.EpochSlots
@@ -62,6 +68,9 @@ byronEpochSlots = CC.Slot.EpochSlots 21600
newtype ByronBlock cfg = ByronBlock { unByronBlock :: CC.Block.ABlock ByteString }
deriving (Eq, Show)

instance Condense (ByronBlock cfg) where
condense = show -- TODO

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

byronHeader :: ByronBlock cfg -> ByronHeader
@@ -108,6 +117,10 @@ instance HasHeader ByronHeader where
instance StandardHash (ByronBlock cfg)
instance StandardHash ByronHeader

instance Typeable cfg => LedgerConfigView (ByronBlock cfg) where
ledgerConfigView EncNodeConfig{..} =
ByronLedgerConfig $ pbftGenesisConfig (pbftParams encNodeConfigP)

instance UpdateLedger (ByronBlock cfg) where
data LedgerState (ByronBlock cfg) = ByronLedgerState
{ blsCurrent :: CC.Block.ChainValidationState

0 comments on commit 14a471c

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