From 7b35a6d60ec4e8f190e3ed328df2ac1f9807ab66 Mon Sep 17 00:00:00 2001 From: Alexander Vieth Date: Wed, 3 Jul 2019 19:01:33 -0400 Subject: [PATCH 1/6] point type factoring in ouroboros-network The ouroboros-network library builds and tests pass. This does not fix the pointSlot mistake: it is still defined, and gives SlotNo 0 to the origin. This will be fixed in a forthcoming commit. --- ouroboros-network/ouroboros-network.cabal | 3 + .../src/Ouroboros/Network/Block.hs | 71 +++++++++++++------ .../src/Ouroboros/Network/Chain.hs | 3 +- .../Ouroboros/Network/ChainProducerState.hs | 2 +- .../src/Ouroboros/Network/Point.hs | 29 ++++++++ .../Network/Protocol/BlockFetch/Codec.hs | 4 +- .../Network/Testing/ConcreteBlock.hs | 2 +- ouroboros-network/test/Test/Chain.hs | 4 +- .../test/Test/ChainGenerators.hs | 21 +++--- .../test/Test/ChainProducerState.hs | 1 + ouroboros-network/test/messages.cddl | 6 +- 11 files changed, 104 insertions(+), 42 deletions(-) create mode 100644 ouroboros-network/src/Ouroboros/Network/Point.hs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 47fc06b4738..a5558f39979 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -49,6 +49,7 @@ library Ouroboros.Network.DeltaQ Ouroboros.Network.NodeToNode Ouroboros.Network.NodeToClient + Ouroboros.Network.Point Ouroboros.Network.Server.Socket Ouroboros.Network.Server.Version.CBOR Ouroboros.Network.Server.Version.Protocol @@ -153,6 +154,7 @@ test-suite tests Ouroboros.Network.DeltaQ Ouroboros.Network.Node Ouroboros.Network.NodeToNode + Ouroboros.Network.Point Ouroboros.Network.Protocol.BlockFetch.Client Ouroboros.Network.Protocol.BlockFetch.Codec Ouroboros.Network.Protocol.BlockFetch.Direct @@ -253,6 +255,7 @@ test-suite cddl Ouroboros.Network.Block Ouroboros.Network.Chain Ouroboros.Network.ChainFragment + Ouroboros.Network.Point Ouroboros.Network.Protocol.BlockFetch.Codec Ouroboros.Network.Protocol.BlockFetch.Type Ouroboros.Network.Protocol.ChainSync.Codec diff --git a/ouroboros-network/src/Ouroboros/Network/Block.hs b/ouroboros-network/src/Ouroboros/Network/Block.hs index 542a6ec5c67..51e5f4db99a 100644 --- a/ouroboros-network/src/Ouroboros/Network/Block.hs +++ b/ouroboros-network/src/Ouroboros/Network/Block.hs @@ -20,6 +20,8 @@ module Ouroboros.Network.Block ( , ChainHash(..) , castHash , Point(..) + , pointSlot + , pointHash , castPoint , blockPoint , ChainUpdate(..) @@ -42,6 +44,9 @@ import Data.Typeable (Typeable) import Data.Word (Word64) import GHC.Generics (Generic) +import Ouroboros.Network.Point (WithOrigin (..), origin, block) +import qualified Ouroboros.Network.Point as Point (Block (..)) + -- | The 0-based index for the Ourboros time slot. newtype SlotNo = SlotNo { unSlotNo :: Word64 } deriving (Show, Eq, Ord, Enum, Bounded, Num, Serialise, Generic) @@ -114,21 +119,34 @@ castHash (BlockHash b) = BlockHash b -- as a check, or in some contexts it disambiguates blocks from different forks -- that were in the same slot. -- -data Point block = Point { - pointSlot :: SlotNo, - pointHash :: ChainHash block - } - deriving (Eq, Ord, Show) +-- It's a newtype rather than a type synonym, because using a type synonym +-- would lead to ambiguity, since HeaderHash is a non-injective type family. +newtype Point block = Point + { getPoint :: WithOrigin (Point.Block SlotNo (HeaderHash block)) + } + +deriving instance StandardHash block => Eq (Point block) +deriving instance StandardHash block => Ord (Point block) +deriving instance StandardHash block => Show (Point block) + +-- Should be +-- pointSlot :: Point block -> WithOrigin SlotNo +-- pointSlot (Point pt) = fmap Point.blockPointSlot pt +pointSlot :: Point block -> SlotNo +pointSlot (Point Origin) = SlotNo 0 +pointSlot (Point (At blk)) = Point.blockPointSlot blk + +pointHash :: Point block -> ChainHash block +pointHash (Point pt) = case pt of + Origin -> GenesisHash + At blk -> BlockHash (Point.blockPointHash blk) castPoint :: (HeaderHash a ~ HeaderHash b) => Point a -> Point b -castPoint (Point a b) = Point a (castHash b) +castPoint (Point Origin) = Point Origin +castPoint (Point (At (Point.Block slot hash))) = Point (block slot hash) blockPoint :: HasHeader block => block -> Point block -blockPoint b = - Point { - pointSlot = blockSlot b, - pointHash = BlockHash (blockHash b) - } +blockPoint b = Point (block (blockSlot b) (blockHash b)) {------------------------------------------------------------------------------- ChainUpdate type @@ -172,19 +190,26 @@ decodeChainHash decodeHash = do 1 -> BlockHash <$> decodeHash _ -> fail "decodeChainHash: invalid tag" -encodePoint :: (ChainHash block -> Encoding) - -> (Point block -> Encoding) -encodePoint encodeHash Point { pointSlot = s, pointHash = h } = - Enc.encodeListLen 2 - <> encode s - <> encodeHash h - -decodePoint :: (forall s. Decoder s (ChainHash block)) - -> (forall s. Decoder s (Point block)) +encodePoint :: (HeaderHash block -> Encoding) + -> (Point block -> Encoding) +encodePoint encodeHash (Point pt) = case pt of + Origin -> Enc.encodeListLen 0 + At blk -> + Enc.encodeListLen 2 + <> encode (Point.blockPointSlot blk) + <> encodeHash (Point.blockPointHash blk) + +decodePoint :: (forall s. Decoder s (HeaderHash block)) + -> (forall s. Decoder s (Point block)) decodePoint decodeHash = do - Dec.decodeListLenOf 2 - Point <$> decode - <*> decodeHash + tag <- Dec.decodeListLen + case tag of + 0 -> return (Point origin) + 2 -> do + slot <- decode + hash <- decodeHash + return (Point (block slot hash)) + _ -> fail "decodePoint: invalid tag" {------------------------------------------------------------------------------- Finger Tree Measure diff --git a/ouroboros-network/src/Ouroboros/Network/Chain.hs b/ouroboros-network/src/Ouroboros/Network/Chain.hs index fb7cc6ceb11..b2c3406af28 100644 --- a/ouroboros-network/src/Ouroboros/Network/Chain.hs +++ b/ouroboros-network/src/Ouroboros/Network/Chain.hs @@ -78,6 +78,7 @@ import Control.Exception (assert) import qualified Data.List as L import Ouroboros.Network.Block +import Ouroboros.Network.Point (origin) -- -- Blockchain type @@ -109,7 +110,7 @@ genesisBlockNo :: BlockNo genesisBlockNo = BlockNo 0 genesisPoint :: Point block -genesisPoint = Point genesisSlotNo GenesisHash +genesisPoint = Point origin valid :: HasHeader block => Chain block -> Bool valid Genesis = True diff --git a/ouroboros-network/src/Ouroboros/Network/ChainProducerState.hs b/ouroboros-network/src/Ouroboros/Network/ChainProducerState.hs index ccf4dbc2341..a303ede46a0 100644 --- a/ouroboros-network/src/Ouroboros/Network/ChainProducerState.hs +++ b/ouroboros-network/src/Ouroboros/Network/ChainProducerState.hs @@ -5,7 +5,7 @@ module Ouroboros.Network.ChainProducerState where -import Ouroboros.Network.Block (castPoint) +import Ouroboros.Network.Block (castPoint, pointSlot) import Ouroboros.Network.Chain (Chain, ChainUpdate (..), HasHeader, HeaderHash, Point (..), blockPoint, genesisPoint, pointOnChain) diff --git a/ouroboros-network/src/Ouroboros/Network/Point.hs b/ouroboros-network/src/Ouroboros/Network/Point.hs new file mode 100644 index 00000000000..11c30373392 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/Point.hs @@ -0,0 +1,29 @@ +module Ouroboros.Network.Point + ( WithOrigin (..) + , Block (..) + , origin + , at + , block + ) where + +data WithOrigin t = Origin | At t + deriving (Eq, Ord, Show) + +instance Functor WithOrigin where + fmap _ Origin = Origin + fmap f (At t) = At (f t) + +data Block slot hash = Block + { blockPointSlot :: !slot + , blockPointHash :: !hash + } + deriving (Eq, Ord, Show) + +at :: t -> WithOrigin t +at = At + +origin :: WithOrigin t +origin = Origin + +block :: slot -> hash -> WithOrigin (Block slot hash) +block slot hash = at (Block slot hash) diff --git a/ouroboros-network/src/Ouroboros/Network/Protocol/BlockFetch/Codec.hs b/ouroboros-network/src/Ouroboros/Network/Protocol/BlockFetch/Codec.hs index c7ca43d9607..9600ee0f740 100644 --- a/ouroboros-network/src/Ouroboros/Network/Protocol/BlockFetch/Codec.hs +++ b/ouroboros-network/src/Ouroboros/Network/Protocol/BlockFetch/Codec.hs @@ -42,10 +42,10 @@ codecBlockFetch encodeBody encodeHeaderHash mkCodecCborLazyBS encode decode where encodePoint' :: Point block -> CBOR.Encoding - encodePoint' = Block.encodePoint $ Block.encodeChainHash encodeHeaderHash + encodePoint' = Block.encodePoint encodeHeaderHash decodePoint' :: forall s. CBOR.Decoder s (Point block) - decodePoint' = Block.decodePoint $ Block.decodeChainHash decodeHeaderHash + decodePoint' = Block.decodePoint decodeHeaderHash encode :: forall (pr :: PeerRole) st st'. PeerHasAgency pr st diff --git a/ouroboros-network/src/Ouroboros/Network/Testing/ConcreteBlock.hs b/ouroboros-network/src/Ouroboros/Network/Testing/ConcreteBlock.hs index b5c33eaa846..d2586fc117b 100644 --- a/ouroboros-network/src/Ouroboros/Network/Testing/ConcreteBlock.hs +++ b/ouroboros-network/src/Ouroboros/Network/Testing/ConcreteBlock.hs @@ -226,7 +226,7 @@ mkAnchoredFragment anchorpoint anchorblockno = mkAnchoredFragmentSimple :: [BlockBody] -> AnchoredFragment Block mkAnchoredFragmentSimple = - mkAnchoredFragment (Point 0 GenesisHash) (BlockNo 0) . zip [1..] + mkAnchoredFragment C.genesisPoint (BlockNo 0) . zip [1..] mkPartialBlock :: SlotNo -> BlockBody -> Block diff --git a/ouroboros-network/test/Test/Chain.hs b/ouroboros-network/test/Test/Chain.hs index 72d7fe861dd..0917229bb05 100644 --- a/ouroboros-network/test/Test/Chain.hs +++ b/ouroboros-network/test/Test/Chain.hs @@ -14,8 +14,8 @@ import Test.QuickCheck import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) -import Ouroboros.Network.Block (blockPrevHash) -import Ouroboros.Network.Chain (Chain (..), Point (..), genesisPoint) +import Ouroboros.Network.Block (blockPrevHash, pointHash, pointSlot) +import Ouroboros.Network.Chain (Chain (..), genesisPoint) import qualified Ouroboros.Network.Chain as Chain import Ouroboros.Network.Testing.Serialise (prop_serialise) diff --git a/ouroboros-network/test/Test/ChainGenerators.hs b/ouroboros-network/test/Test/ChainGenerators.hs index 01d7d042b59..c2b7511433a 100644 --- a/ouroboros-network/test/Test/ChainGenerators.hs +++ b/ouroboros-network/test/Test/ChainGenerators.hs @@ -39,6 +39,8 @@ import Ouroboros.Network.Testing.ConcreteBlock import Ouroboros.Network.Block import Ouroboros.Network.Chain (Chain (..)) import qualified Ouroboros.Network.Chain as Chain +import Ouroboros.Network.Point (WithOrigin (..), block, blockPointHash, + blockPointSlot, origin) import Ouroboros.Network.Protocol.BlockFetch.Type (ChainRange (..)) import Test.QuickCheck @@ -110,12 +112,15 @@ instance Arbitrary ConcreteHeaderHash where instance Arbitrary (Point BlockHeader) where arbitrary = -- Sometimes pick the genesis point - frequency [ (1, pure (Point (SlotNo 0) GenesisHash)) - , (4, Point <$> arbitrary <*> (BlockHash <$> arbitrary)) ] - shrink (Point _ GenesisHash) = [] - shrink (Point s (BlockHash h)) = - Point (SlotNo 0) GenesisHash - : [ Point s' (BlockHash h') | (s', h') <- shrink (s, h), s > SlotNo 0 ] + frequency [ (1, pure (Point Origin)) + , (4, Point <$> (block <$> arbitrary <*> arbitrary)) ] + shrink (Point Origin) = [] + shrink (Point (At blk)) = + Point origin + : [ Point (block s' h') | (s', h') <- shrink (s, h), s > SlotNo 0 ] + where + h = blockPointHash blk + s = blockPointSlot blk instance Arbitrary (Point Block) where arbitrary = (castPoint :: Point BlockHeader -> Point Block) <$> arbitrary @@ -268,8 +273,8 @@ data TestAddBlock = TestAddBlock (Chain Block) Block instance Arbitrary TestAddBlock where arbitrary = do TestBlockChain chain <- arbitrary - block <- genAddBlock chain - return (TestAddBlock chain block) + blk <- genAddBlock chain + return (TestAddBlock chain blk) shrink (TestAddBlock c b) = [ TestAddBlock c' b' diff --git a/ouroboros-network/test/Test/ChainProducerState.hs b/ouroboros-network/test/Test/ChainProducerState.hs index c7afc84d7e0..6604175f5fb 100644 --- a/ouroboros-network/test/Test/ChainProducerState.hs +++ b/ouroboros-network/test/Test/ChainProducerState.hs @@ -16,6 +16,7 @@ import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck +import Ouroboros.Network.Block (pointSlot) import Ouroboros.Network.Chain (Chain, ChainUpdate (..), Point (..), genesisPoint, headPoint, pointOnChain) import qualified Ouroboros.Network.Chain as Chain diff --git a/ouroboros-network/test/messages.cddl b/ouroboros-network/test/messages.cddl index 6a76d3ebb46..33c7add5dc6 100644 --- a/ouroboros-network/test/messages.cddl +++ b/ouroboros-network/test/messages.cddl @@ -84,11 +84,9 @@ msgNoBlocks = [3] msgBlock = [4, bfBody] msgBatchDone = [5] -bfPoint = [slotNo, chainHash] +bfPoint = origin / [slotNo, dummyBlockHash] +origin = [] slotNo = uint ; word64 -chainHash = blockHash / genesisHash -genesisHash = [] -blockHash = [dummyBlockHash] dummyBlockHash = null bfBody = bytes .cbor any From 4363346c222c4b0a328f1a95f47b58146b1c4e98 Mon Sep 17 00:00:00 2001 From: Alexander Vieth Date: Wed, 3 Jul 2019 19:58:23 -0400 Subject: [PATCH 2/6] point type factoring in ouroboros-consensus This package builds and tests pass. One perhaps controversial change is in the Byron ledger definition of ledgerTipPoint. If the ledger state has the genesis hash as its latest, then there are no blocks, so the tip point is set to Origin, rather than a point with slot number 0. I believe this is the how it ought to be. --- .../Ouroboros/Consensus/ChainSyncClient.hs | 2 +- .../src/Ouroboros/Consensus/Ledger/Byron.hs | 14 ++++---- .../Ouroboros/Consensus/Ledger/Mock/State.hs | 2 +- .../src/Ouroboros/Consensus/NodeNetwork.hs | 2 +- .../src/Ouroboros/Consensus/Util/Orphans.hs | 14 +++++--- .../src/Ouroboros/Storage/ChainDB/API.hs | 33 ++++++++++++++----- .../src/Ouroboros/Storage/ChainDB/Model.hs | 4 +-- .../Test/Consensus/ChainSyncClient.hs | 8 ++++- 8 files changed, 54 insertions(+), 25 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs index 235f004fd2a..bf356292e19 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs @@ -143,7 +143,7 @@ chainSyncClient , MonadThrow (STM m) , ProtocolLedgerView blk , Condense (Header blk) - , Condense (ChainHash blk) + , Condense (HeaderHash blk) ) => Tracer m String -> NodeConfig (BlockProtocol blk) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs index da6bd6e2c8c..320aa1ab9be 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs @@ -71,6 +71,7 @@ import Cardano.Crypto.Hash import Ouroboros.Network.Block import Ouroboros.Network.Chain (genesisSlotNo) +import qualified Ouroboros.Network.Point as Point (block, origin) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Crypto.DSIGN.Cardano @@ -264,12 +265,13 @@ instance (ByronGiven, Typeable cfg, ConfigContainsGenesis cfg) fixPMI pmi = reAnnotate $ Annotated pmi () - ledgerTipPoint (ByronLedgerState state _) = Point - { pointSlot = convertSlot (CC.Block.cvsLastSlot state) - , pointHash = case CC.Block.cvsPreviousHash state of - Left _genHash -> GenesisHash - Right hdrHash -> BlockHash hdrHash - } + ledgerTipPoint (ByronLedgerState state _) = case CC.Block.cvsPreviousHash state of + -- In this case there are no blocks in the ledger state. The genesis + -- block does not occupy a slot, so its point is Origin. + Left _genHash -> Point Point.origin + Right hdrHash -> Point (Point.block slot hdrHash) + where + slot = convertSlot (CC.Block.cvsLastSlot state) numGenKeys :: CC.Genesis.Config -> Word8 numGenKeys cfg = case length genKeys of diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/State.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/State.hs index d4f171a8903..9b4a78b53c6 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/State.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/State.hs @@ -18,7 +18,7 @@ import qualified Data.Set as Set import Cardano.Crypto.Hash import Ouroboros.Network.Block (ChainHash, HasHeader, Point (..), - StandardHash) + StandardHash, pointHash) import Ouroboros.Network.Chain (genesisPoint) import Ouroboros.Consensus.Block diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs b/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs index 91493835c5c..301b293ac95 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs @@ -115,7 +115,7 @@ protocolHandlers , ApplyTx blk , ProtocolLedgerView blk , Condense (Header blk) - , Condense (ChainHash blk) + , Condense (HeaderHash blk) , Condense peer , Show (ApplyTxErr blk) --TODO: consider using condense , Condense (GenTx blk) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Util/Orphans.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Util/Orphans.hs index 4e3cbf76449..65e55721b73 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Util/Orphans.hs @@ -12,9 +12,11 @@ import Cardano.Crypto.Hash (Hash) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF -import Ouroboros.Network.Block (ChainHash, HasHeader, Point (..), +import Ouroboros.Network.Block (HasHeader, HeaderHash, Point (..), SlotNo (..)) import Ouroboros.Network.Chain (Chain (..)) +import Ouroboros.Network.Point (WithOrigin (..), blockPointHash, + blockPointSlot) import Ouroboros.Consensus.Util.Condense @@ -25,15 +27,19 @@ import Ouroboros.Consensus.Util.Condense instance Condense SlotNo where condense (SlotNo n) = condense n -instance Condense (ChainHash block) => Condense (Point block) where - condense (Point ptSlot ptHash) = +instance Condense (HeaderHash block) => Condense (Point block) where + condense (Point Origin) = "Origin" + condense (Point (At blk)) = "(Point " <> condense ptSlot <> ", " <> condense ptHash <> ")" + where + ptSlot = blockPointSlot blk + ptHash = blockPointHash blk instance Condense block => Condense (Chain block) where condense Genesis = "Genesis" condense (cs :> b) = condense cs <> " :> " <> condense b -instance (Condense block, HasHeader block, Condense (ChainHash block)) +instance (Condense block, HasHeader block, Condense (HeaderHash block)) => Condense (AnchoredFragment block) where condense (AF.Empty pt) = "EmptyAnchor " <> condense pt condense (cs AF.:> b) = condense cs <> " :> " <> condense b diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/API.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/API.hs index 802df8d9ead..e659a1a6057 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/API.hs @@ -38,11 +38,13 @@ import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow import Ouroboros.Network.AnchoredFragment (AnchoredFragment) -import Ouroboros.Network.Block (ChainHash (..), ChainUpdate, - HasHeader (..), HeaderHash, SlotNo, StandardHash) +import Ouroboros.Network.Block (ChainUpdate, HasHeader (..), + HeaderHash, SlotNo, StandardHash) import Ouroboros.Network.Chain (Chain (..), Point (..), genesisPoint) import qualified Ouroboros.Network.Chain as Chain import Ouroboros.Network.ChainProducerState (ReaderId) +import Ouroboros.Network.Point (WithOrigin (..)) +import qualified Ouroboros.Network.Point as Point (Block (..)) import Ouroboros.Consensus.Block (GetHeader (..)) import Ouroboros.Consensus.Ledger.Extended @@ -319,17 +321,30 @@ data UnknownRange blk = -- -- > StreamFromExclusive (Point { pointSlot = SlotNo 3 , .. } -- > StreamToInclusive (Point { pointSlot = SlotNo 3 , .. } +-- +-- FIXME StreamFrom and StreamTo can be refined to not admit origin points +-- in cases where it doesn't make sense. validBounds :: StreamFrom blk -> StreamTo blk -> Bool validBounds from to = case from of - StreamFromInclusive (Point { pointHash = GenesisHash }) -> False - StreamFromInclusive (Point { pointSlot = sfrom }) -> case to of - StreamToInclusive (Point { pointSlot = sto }) -> sfrom <= sto - StreamToExclusive (Point { pointSlot = sto }) -> sfrom < sto + StreamFromInclusive (Point Origin) -> False + + StreamFromExclusive (Point Origin) -> case to of + StreamToInclusive (Point Origin) -> False + StreamToExclusive (Point Origin) -> False + _ -> True + + StreamFromInclusive (Point (At (Point.Block { Point.blockPointSlot = sfrom }))) -> case to of + StreamToInclusive (Point Origin) -> False + StreamToExclusive (Point Origin) -> False + StreamToInclusive (Point (At (Point.Block { Point.blockPointSlot = sto }))) -> sfrom <= sto + StreamToExclusive (Point (At (Point.Block { Point.blockPointSlot = sto }))) -> sfrom < sto - StreamFromExclusive (Point { pointSlot = sfrom }) -> case to of - StreamToInclusive (Point { pointSlot = sto }) -> sfrom < sto - StreamToExclusive (Point { pointSlot = sto }) -> sfrom < sto + StreamFromExclusive (Point (At (Point.Block { Point.blockPointSlot = sfrom }))) -> case to of + StreamToInclusive (Point Origin) -> False + StreamToExclusive (Point Origin) -> False + StreamToInclusive (Point (At (Point.Block { Point.blockPointSlot = sto }))) -> sfrom < sto + StreamToExclusive (Point (At (Point.Block { Point.blockPointSlot = sto }))) -> sfrom < sto -- | Stream all blocks from the current chain. -- diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Model.hs index eae065d918f..6cded1b60a6 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Model.hs @@ -90,13 +90,13 @@ hasBlock hash = isJust . getBlock hash getBlockByPoint :: HasHeader blk => Point blk -> Model blk -> Either (ChainDbError blk) (Maybe blk) -getBlockByPoint pt = case Chain.pointHash pt of +getBlockByPoint pt = case Block.pointHash pt of GenesisHash -> const $ Left NoGenesisBlock BlockHash hash -> Right . getBlock hash hasBlockByPoint :: HasHeader blk => Point blk -> Model blk -> Bool -hasBlockByPoint pt = case Chain.pointHash pt of +hasBlockByPoint pt = case Block.pointHash pt of GenesisHash -> const False BlockHash hash -> hasBlock hash diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs b/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs index 915be7ab8aa..3947f5c7831 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs @@ -40,6 +40,8 @@ import qualified Ouroboros.Network.Chain as Chain import Ouroboros.Network.ChainProducerState (chainState, initChainProducerState) import qualified Ouroboros.Network.ChainProducerState as CPS +import Ouroboros.Network.Point (WithOrigin (..), blockPointHash, + blockPointSlot) import Ouroboros.Network.Protocol.ChainSync.Client import Ouroboros.Network.Protocol.ChainSync.Codec (codecChainSyncId) import Ouroboros.Network.Protocol.ChainSync.Examples @@ -683,8 +685,12 @@ ppBlock TestBlock { tbSlot = SlotNo s, tbHash = h, tbPrevHash = p } = BlockHash hash -> show hash ppPoint :: Point TestBlock -> String -ppPoint Point { pointSlot = SlotNo s, pointHash = h } = +ppPoint (Point Origin) = "Origin" +ppPoint (Point (At blk)) = "(S:" <> show s <> "; H:" <> show h <> ")" + where + SlotNo s = blockPointSlot blk + h = blockPointHash blk ppChain :: Chain TestBlock -> String From 53a9dad6ee77f45367b24014d28d62d4191946bb Mon Sep 17 00:00:00 2001 From: Alexander Vieth Date: Wed, 3 Jul 2019 20:05:31 -0400 Subject: [PATCH 3/6] byron-proxy logging fix Apparently an update to iohk-monitoring broke it. But how did that get past CI? --- byron-proxy/src/exec/Logging.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/byron-proxy/src/exec/Logging.hs b/byron-proxy/src/exec/Logging.hs index 58e2d74cf8e..419e044f07a 100644 --- a/byron-proxy/src/exec/Logging.hs +++ b/byron-proxy/src/exec/Logging.hs @@ -81,6 +81,8 @@ defaultLoggerConfig = Monitoring.Representation , Monitoring.hasPrometheus = Nothing , Monitoring.hasGUI = Nothing , Monitoring.options = mempty + , Monitoring.hasGraylog = Nothing + , Monitoring.logOutput = Nothing } where stdoutScribe = Monitoring.ScribeDefinition From 7c4e456e0e040295103c047082b9bfb360463884 Mon Sep 17 00:00:00 2001 From: Alexander Vieth Date: Wed, 3 Jul 2019 21:10:09 -0400 Subject: [PATCH 4/6] fix ouroboros-network demo --- ouroboros-network/demo/chain-sync.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ouroboros-network/demo/chain-sync.hs b/ouroboros-network/demo/chain-sync.hs index 5fd9554aa85..230a1e175f1 100644 --- a/ouroboros-network/demo/chain-sync.hs +++ b/ouroboros-network/demo/chain-sync.hs @@ -41,6 +41,7 @@ import Ouroboros.Network.Block import qualified Ouroboros.Network.Chain as Chain import qualified Ouroboros.Network.ChainFragment as CF import qualified Ouroboros.Network.AnchoredFragment as AF +import Ouroboros.Network.Point (WithOrigin (Origin)) import Ouroboros.Network.Testing.ConcreteBlock import Ouroboros.Network.Socket import Network.Mux.Interface @@ -804,7 +805,7 @@ mkTestFetchedBlockHeap points = do -- genesisChainFragment :: AF.AnchoredFragment BlockHeader -genesisChainFragment = AF.Empty (Point 0 GenesisHash) +genesisChainFragment = AF.Empty (Point Origin) shiftAnchoredFragment :: HasHeader block => Int From 7c679aaf3f78878d3f1df084ce6ad208e84afee6 Mon Sep 17 00:00:00 2001 From: Alexander Vieth Date: Thu, 4 Jul 2019 11:18:20 -0400 Subject: [PATCH 5/6] WithOrigin derives Functor and others --- ouroboros-network/src/Ouroboros/Network/Point.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/Point.hs b/ouroboros-network/src/Ouroboros/Network/Point.hs index 11c30373392..3f14a8c0609 100644 --- a/ouroboros-network/src/Ouroboros/Network/Point.hs +++ b/ouroboros-network/src/Ouroboros/Network/Point.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} + module Ouroboros.Network.Point ( WithOrigin (..) , Block (..) @@ -6,12 +11,10 @@ module Ouroboros.Network.Point , block ) where -data WithOrigin t = Origin | At t - deriving (Eq, Ord, Show) +import GHC.Generics (Generic) -instance Functor WithOrigin where - fmap _ Origin = Origin - fmap f (At t) = At (f t) +data WithOrigin t = Origin | At t + deriving (Eq, Ord, Show, Generic, Functor, Foldable, Traversable) data Block slot hash = Block { blockPointSlot :: !slot From 3648d999d8c96e2256473e5ce54e96309ec7e436 Mon Sep 17 00:00:00 2001 From: Alexander Vieth Date: Thu, 4 Jul 2019 15:08:06 -0400 Subject: [PATCH 6/6] pattern synonyms for Point Suggested by mrBliss --- .../src/Ouroboros/Storage/ChainDB/API.hs | 36 +++++++++---------- .../src/Ouroboros/Network/Block.hs | 14 ++++++++ 2 files changed, 32 insertions(+), 18 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/API.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/API.hs index e659a1a6057..728fe85ff7b 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/API.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternSynonyms #-} module Ouroboros.Storage.ChainDB.API ( -- * Main ChainDB API @@ -39,12 +40,11 @@ import Control.Monad.Class.MonadThrow import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block (ChainUpdate, HasHeader (..), - HeaderHash, SlotNo, StandardHash) + HeaderHash, SlotNo, StandardHash, pattern GenesisPoint, + pattern BlockPoint, atSlot) import Ouroboros.Network.Chain (Chain (..), Point (..), genesisPoint) import qualified Ouroboros.Network.Chain as Chain import Ouroboros.Network.ChainProducerState (ReaderId) -import Ouroboros.Network.Point (WithOrigin (..)) -import qualified Ouroboros.Network.Point as Point (Block (..)) import Ouroboros.Consensus.Block (GetHeader (..)) import Ouroboros.Consensus.Ledger.Extended @@ -327,24 +327,24 @@ data UnknownRange blk = validBounds :: StreamFrom blk -> StreamTo blk -> Bool validBounds from to = case from of - StreamFromInclusive (Point Origin) -> False + StreamFromInclusive GenesisPoint -> False - StreamFromExclusive (Point Origin) -> case to of - StreamToInclusive (Point Origin) -> False - StreamToExclusive (Point Origin) -> False - _ -> True + StreamFromExclusive GenesisPoint -> case to of + StreamToInclusive GenesisPoint -> False + StreamToExclusive GenesisPoint -> False + _ -> True - StreamFromInclusive (Point (At (Point.Block { Point.blockPointSlot = sfrom }))) -> case to of - StreamToInclusive (Point Origin) -> False - StreamToExclusive (Point Origin) -> False - StreamToInclusive (Point (At (Point.Block { Point.blockPointSlot = sto }))) -> sfrom <= sto - StreamToExclusive (Point (At (Point.Block { Point.blockPointSlot = sto }))) -> sfrom < sto + StreamFromInclusive (BlockPoint { atSlot = sfrom }) -> case to of + StreamToInclusive GenesisPoint -> False + StreamToExclusive GenesisPoint -> False + StreamToInclusive (BlockPoint { atSlot = sto }) -> sfrom <= sto + StreamToExclusive (BlockPoint { atSlot = sto }) -> sfrom < sto - StreamFromExclusive (Point (At (Point.Block { Point.blockPointSlot = sfrom }))) -> case to of - StreamToInclusive (Point Origin) -> False - StreamToExclusive (Point Origin) -> False - StreamToInclusive (Point (At (Point.Block { Point.blockPointSlot = sto }))) -> sfrom < sto - StreamToExclusive (Point (At (Point.Block { Point.blockPointSlot = sto }))) -> sfrom < sto + StreamFromExclusive (BlockPoint { atSlot = sfrom }) -> case to of + StreamToInclusive GenesisPoint -> False + StreamToExclusive GenesisPoint -> False + StreamToInclusive (BlockPoint { atSlot = sto }) -> sfrom <= sto + StreamToExclusive (BlockPoint { atSlot = sto }) -> sfrom < sto -- | Stream all blocks from the current chain. -- diff --git a/ouroboros-network/src/Ouroboros/Network/Block.hs b/ouroboros-network/src/Ouroboros/Network/Block.hs index 51e5f4db99a..bce9101f931 100644 --- a/ouroboros-network/src/Ouroboros/Network/Block.hs +++ b/ouroboros-network/src/Ouroboros/Network/Block.hs @@ -6,6 +6,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} -- | Abstract view over blocks -- @@ -32,6 +33,11 @@ module Ouroboros.Network.Block ( , encodeChainHash , decodePoint , decodeChainHash + + , pattern GenesisPoint + , pattern BlockPoint + , atSlot + , withHash ) where import Codec.CBOR.Decoding (Decoder) @@ -129,6 +135,14 @@ deriving instance StandardHash block => Eq (Point block) deriving instance StandardHash block => Ord (Point block) deriving instance StandardHash block => Show (Point block) +pattern GenesisPoint :: Point block +pattern GenesisPoint = Point Origin + +pattern BlockPoint :: SlotNo -> HeaderHash block -> Point block +pattern BlockPoint { atSlot, withHash } = Point (At (Point.Block atSlot withHash)) + +{-# COMPLETE GenesisPoint, BlockPoint #-} + -- Should be -- pointSlot :: Point block -> WithOrigin SlotNo -- pointSlot (Point pt) = fmap Point.blockPointSlot pt