Skip to content
Permalink
Browse files

make demo-playground build

  • Loading branch information...
avieth committed Jun 14, 2019
1 parent 511e792 commit 4913724d5f7481d3acb75916a003a62e84b79b27
@@ -12,6 +12,7 @@ module Run (

import Codec.CBOR.Decoding (Decoder)
import Codec.CBOR.Encoding (Encoding)
import qualified Codec.Serialise as Serialise (encode, decode)
import qualified Control.Concurrent.Async as Async
import Control.Monad
import Control.Tracer
@@ -93,7 +94,7 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do
curNo = succ prevBlockNo

prevHash :: ChainHash blk
prevHash = castHash (pointHash prevPoint)
prevHash = fromTPoint GenesisHash (BlockHash . pointHash) prevPoint

-- The transactions we get are consistent; the only reason not
-- to include all of them would be maximum block size, which
@@ -214,8 +215,8 @@ handleSimpleNode p CLI{..} (TopologyInfo myNodeId topologyFile) = do

encodePoint' :: ProtocolInfo blk -> Point blk -> Encoding
encodePoint' ProtocolInfo{..} =
Block.encodePoint $ Block.encodeChainHash demoEncodeHeaderHash
Block.encodeTPoint (Block.encodeTBlockPoint Serialise.encode demoEncodeHeaderHash)

decodePoint' :: forall s. ProtocolInfo blk -> Decoder s (Point blk)
decodePoint' ProtocolInfo{..} =
Block.decodePoint $ Block.decodeChainHash demoDecodeHeaderHash
Block.decodeTPoint (Block.decodeTBlockPoint Serialise.decode demoDecodeHeaderHash)
@@ -38,6 +38,7 @@ instance ( ProtocolLedgerView (SimpleBlock SimpleMockCrypto ext)
, ForgeExt (BlockProtocol (SimpleBlock SimpleMockCrypto ext))
SimpleMockCrypto
ext
, Eq ext
) => RunDemo (SimpleBlock SimpleMockCrypto ext) where
demoForgeBlock = forgeSimple
demoBlockMatchesHeader = matchesSimpleHeader
@@ -60,10 +60,11 @@ class DemoHeaderHash hh where
class ( ProtocolLedgerView blk
, DemoHeaderHash (HeaderHash blk)
, Condense (Header blk)
, Condense (ChainHash blk)
, Condense (HeaderHash blk)
, Condense blk
, Condense [blk]
, ApplyTx blk
, Eq (Header blk)
) => RunDemo blk where
demoForgeBlock :: (HasNodeState (BlockProtocol blk) m, MonadRandom m)
=> NodeConfig (BlockProtocol blk)
@@ -8,6 +8,7 @@
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wredundant-constraints #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Ouroboros.Consensus.Ledger.Byron
( -- * Byron blocks and headers
@@ -501,9 +502,8 @@ instance Condense (Header (ByronBlock cfg)) where
. unByronHeader
$ hdr

instance Condense (ChainHash (ByronBlock cfg)) where
condense GenesisHash = "genesis"
condense (BlockHash h) = show h
instance Condense CC.Block.HeaderHash where
condense = show

{-------------------------------------------------------------------------------
Serialisation
@@ -304,9 +304,10 @@ instance Condense ext' => Condense (SimpleBlock' c ext ext') where
SimpleStdHeader{..} = simpleHeaderStd
SimpleBody{..} = simpleBody

instance Condense (ChainHash (SimpleBlock' c ext ext')) where
condense GenesisHash = "genesis"
condense (BlockHash hdr) = show hdr
instance Condense (ChainHash (SimpleBlock c ext)) where
condense GenesisHash = "genesis"
-- uses the Condense (Hash a b) instance
condense (BlockHash h) = condense h

{-------------------------------------------------------------------------------
Serialise instances
@@ -198,7 +198,6 @@ nodeKernel
, TraceConstraints up blk
, ApplyTx blk
, Eq (Header blk)
, Condense (HeaderHash blk)
)
=> NodeParams m up blk
-> m (NodeKernel m up blk)
@@ -233,7 +232,7 @@ nodeKernel params@NodeParams { threadRegistry, cfg } = do
type TraceConstraints up blk =
( Condense up
, Condense blk
, Condense (ChainHash blk)
, Condense (HeaderHash blk)
, Condense (Header blk)
)

@@ -264,7 +263,6 @@ initInternalState
, TraceConstraints up blk
, ApplyTx blk
, Eq (Header blk)
, Condense (HeaderHash blk)
)
=> NodeParams m up blk
-> m (InternalState m up blk)
@@ -369,10 +367,10 @@ initBlockFetchConsensusInterface tracer cfg chainDB getCandidates blockFetchSize
then FetchModeDeadline
else FetchModeBulkSync

readFetchedBlocks :: STM m (Point blk -> Bool)
readFetchedBlocks :: STM m (BlockPoint blk -> Bool)
readFetchedBlocks = ChainDB.getIsFetched chainDB

addFetchedBlock :: Point blk -> blk -> m ()
addFetchedBlock :: BlockPoint blk -> blk -> m ()
addFetchedBlock _pt blk = do
ChainDB.addBlock chainDB blk
traceWith tracer $ "Downloaded block: " <> condense blk
@@ -35,7 +35,7 @@ import Control.Monad.Class.MonadThrow
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import Ouroboros.Network.Block (ChainUpdate (..), HasHeader (..),
HeaderHash, SlotNo, StandardHash)
import Ouroboros.Network.Chain (Chain (..), Point)
import Ouroboros.Network.Chain (BlockPoint, Chain (..), Point)
import qualified Ouroboros.Network.Chain as Chain
import Ouroboros.Network.ChainProducerState (ReaderId)

@@ -118,14 +118,14 @@ data ChainDB m blk hdr =
, getTipPoint :: STM m (Point blk)

-- | Get block at the specified point (if it exists)
, getBlock :: Point blk -> m (Maybe blk)
, getBlock :: BlockPoint blk -> m (Maybe blk)

-- | Return membership check function for recent blocks
--
-- This check is only reliable for blocks up to @k@ away from the tip.
-- For blocks older than that the results should be regarded as
-- non-deterministic.
, getIsFetched :: STM m (Point blk -> Bool)
, getIsFetched :: STM m (BlockPoint blk -> Bool)

-- | Stream blocks
--
@@ -160,13 +160,13 @@ data ChainDB m blk hdr =
, newReader :: m (Reader m hdr)

-- | Known to be invalid blocks
, knownInvalidBlocks :: STM m (Set (Point blk))
, knownInvalidBlocks :: STM m (Set (BlockPoint blk))

-- | Check if the specified point is on the current chain
--
-- This lives in @m@, not @STM m@, because if the point is not on the
-- current chain fragment, it might have to query the immutable DB.
, pointOnChain :: Point blk -> m Bool
, pointOnChain :: BlockPoint blk -> m Bool
}

{-------------------------------------------------------------------------------
@@ -39,7 +39,7 @@ import GHC.Stack (HasCallStack)

import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as Fragment
import Ouroboros.Network.Block (ChainHash (..), ChainUpdate (..),
import Ouroboros.Network.Block (BlockPoint, ChainHash (..), ChainUpdate (..),
HasHeader, HeaderHash, Point, TPoint (..), pointHash, fromTPoint)
import qualified Ouroboros.Network.Block as Block
import Ouroboros.Network.Chain (Chain (..))
@@ -78,12 +78,12 @@ hasBlock :: HasHeader blk => HeaderHash blk -> Model blk -> Bool
hasBlock hash = isJust . getBlock hash

getBlockByPoint :: (HasHeader blk, HasCallStack)
=> Point blk -> Model blk -> Maybe blk
getBlockByPoint = getBlock . notGenesis
=> BlockPoint blk -> Model blk -> Maybe blk
getBlockByPoint bp = getBlock (pointHash bp)

hasBlockByPoint :: (HasHeader blk, HasCallStack)
=> Point blk -> Model blk -> Bool
hasBlockByPoint = hasBlock . notGenesis
=> BlockPoint blk -> Model blk -> Bool
hasBlockByPoint bp = hasBlock (pointHash bp)

tipBlock :: Model blk -> Maybe blk
tipBlock = Chain.head . currentChain
@@ -101,8 +101,8 @@ lastK (SecurityParam k) f =
. fmap f
. currentChain

pointOnChain :: HasHeader blk => Model blk -> Point blk -> Bool
pointOnChain m p = Chain.pointOnChain p (currentChain m)
pointOnChain :: HasHeader blk => Model blk -> BlockPoint blk -> Bool
pointOnChain m p = Chain.pointOnChain (Point p) (currentChain m)

{-------------------------------------------------------------------------------
Construction
@@ -212,10 +212,6 @@ readerForward rdrId points m =
Internal auxiliary
-------------------------------------------------------------------------------}

notGenesis :: HasCallStack => Block.TPoint (Block.TBlockPoint slot hash) -> hash
notGenesis Block.Origin = error "Ouroboros.Storage.ChainDB.Model: notGenesis"
notGenesis (Block.Point p) = pointHash p

validate :: forall blk. ProtocolLedgerView blk
=> NodeConfig (BlockProtocol blk)
-> ExtLedgerState blk
@@ -112,8 +112,8 @@ blockFetchExample1 decisionTracer clientStateTracer clientMsgTracer
Map.fromList $ zip [1..] $
map (AnchoredFragment.mapAnchoredFragment blockHeader) candidateChains

anchoredChainPoints c = anchorPoint c
: map (Point . blockPoint) (AnchoredFragment.toOldestFirst c)
anchoredChainPoints c = (fromTPoint [] pure (anchorPoint c))
++ map blockPoint (AnchoredFragment.toOldestFirst c)

blockFetch :: FetchClientRegistry Int BlockHeader Block m
-> TestFetchedBlockHeap m Block
@@ -129,9 +129,13 @@ blockFetchExample1 decisionTracer clientStateTracer clientMsgTracer
driver blockHeap = do
atomically $ do
heap <- getTestFetchedBlocks blockHeap
check $
check $ flip all candidateChains $ \c -> case AnchoredFragment.headPoint c of
-- The origin is always "fetched"
Origin -> True
Point p -> p `Set.member` heap
{-
all (\c -> AnchoredFragment.headPoint c `Set.member` heap)
candidateChains
candidateChains -}


--
@@ -295,17 +299,17 @@ mockBlockFetchServer1 chain =
-- The interface is enough to use in examples and tests.
--
data TestFetchedBlockHeap m block = TestFetchedBlockHeap {
getTestFetchedBlocks :: STM m (Set (Point block)),
addTestFetchedBlock :: Point block -> block -> m ()
getTestFetchedBlocks :: STM m (Set (BlockPoint block)),
addTestFetchedBlock :: BlockPoint block -> block -> m ()
}

-- | Make a 'TestFetchedBlockHeap' using a simple in-memory 'Map', stored in an
-- 'STM' 'TVar'.
--
-- This is suitable for examples and tests.
--
mkTestFetchedBlockHeap :: (MonadSTM m, Ord (Point block))
=> [Point block]
mkTestFetchedBlockHeap :: (MonadSTM m, Ord (BlockPoint block))
=> [BlockPoint block]
-> m (TestFetchedBlockHeap m block)
mkTestFetchedBlockHeap points = do
v <- atomically (newTVar (Set.fromList points))

0 comments on commit 4913724

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