Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Better Point type factoring, again #706

Merged
merged 6 commits into from
Jul 9, 2019
Merged

Better Point type factoring, again #706

Show file tree
Hide file tree
Changes from 2 commits
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
7b35a6d
point type factoring in ouroboros-network
Jul 3, 2019
4363346
point type factoring in ouroboros-consensus
Jul 3, 2019
53a9dad
byron-proxy logging fix
Jul 4, 2019
7c4e456
fix ouroboros-network demo
Jul 4, 2019
7c679aa
WithOrigin derives Functor and others
Jul 4, 2019
3648d99
pattern synonyms for Point
Jul 4, 2019
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion ouroboros-consensus/src/Ouroboros/Consensus/ChainSyncClient.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
14 changes: 8 additions & 6 deletions ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Byron.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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.
mrBliss marked this conversation as resolved.
Show resolved Hide resolved
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
Expand Down
2 changes: 1 addition & 1 deletion ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/State.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
14 changes: 10 additions & 4 deletions ouroboros-consensus/src/Ouroboros/Consensus/Util/Orphans.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand All @@ -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
Expand Down
33 changes: 24 additions & 9 deletions ouroboros-consensus/src/Ouroboros/Storage/ChainDB/API.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Ok, I will do that when this is merged.

-- 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
mrBliss marked this conversation as resolved.
Show resolved Hide resolved
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
avieth marked this conversation as resolved.
Show resolved Hide resolved
StreamToExclusive (Point (At (Point.Block { Point.blockPointSlot = sto }))) -> sfrom < sto

-- | Stream all blocks from the current chain.
--
Expand Down
4 changes: 2 additions & 2 deletions ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Model.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
8 changes: 7 additions & 1 deletion ouroboros-consensus/test-consensus/Test/Consensus/ChainSyncClient.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
3 changes: 3 additions & 0 deletions ouroboros-network/ouroboros-network.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
71 changes: 48 additions & 23 deletions ouroboros-network/src/Ouroboros/Network/Block.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -20,6 +20,8 @@ module Ouroboros.Network.Block (
, ChainHash(..)
, castHash
, Point(..)
, pointSlot
, pointHash
, castPoint
, blockPoint
, ChainUpdate(..)
Expand All @@ -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)
Expand Down Expand Up @@ -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))
mrBliss marked this conversation as resolved.
Show resolved Hide resolved
}

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
Expand Down Expand Up @@ -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
Expand Down
3 changes: 2 additions & 1 deletion ouroboros-network/src/Ouroboros/Network/Chain.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion ouroboros-network/src/Ouroboros/Network/ChainProducerState.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
29 changes: 29 additions & 0 deletions ouroboros-network/src/Ouroboros/Network/Point.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,29 @@
module Ouroboros.Network.Point
( WithOrigin (..)
, Block (..)
, origin
, at
, block
) where

data WithOrigin t = Origin | At t
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Why Origin instead of Genesis?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Because Genesis is a constructor of Chain block. I thought it better not to overload.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Ok, fine for me. (What about data WithGenesis t = Gen | At t? 😈)

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

We might have places in haddock where we refer to Genesis, which now becomes Origin.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The Chain type is a model / mock impl. We shouldn't give it primacy in names. If we want Genesis for the point types we can use it, and we can rename the Chain one (e.g. GenesisBlock) or use qualified names.

deriving (Eq, Ord, Show)
avieth marked this conversation as resolved.
Show resolved Hide resolved

instance Functor WithOrigin where
fmap _ Origin = Origin
fmap f (At t) = At (f t)

data Block slot hash = Block
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

What about calling this BlockPoint?

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

In this module it is clear that it is a point since (apart from the type, the module is named Point), in most places we use unqualified imports so this might be confusing. Or maybe just leave a comment at the top that this module is supposed to be imported qualified.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I see now it is imported qualified in other places, just dropping a comment at the top might be useful.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

My intuition is also for BlockPoint and not using module-qualified names elsewhere.

{ blockPointSlot :: !slot
, blockPointHash :: !hash
}
deriving (Eq, Ord, Show)

at :: t -> WithOrigin t
at = At

origin :: WithOrigin t
origin = Origin
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Is it worth to duplicate the api?

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Not clear it's worth using functions rather than constructors directly.


block :: slot -> hash -> WithOrigin (Block slot hash)
block slot hash = at (Block slot hash)
4 changes: 2 additions & 2 deletions ouroboros-network/src/Ouroboros/Network/Protocol/BlockFetch/Codec.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion ouroboros-network/src/Ouroboros/Network/Testing/ConcreteBlock.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
Loading