Neil/missing hashes

cabal.project

@@ -66,8 +66,8 @@ package bitvec
 source-repository-package
     type: git
     location: https://github.com/CardanoSolutions/ouroboros-consensus
-    tag: 79da9a368cb6d2e7ed5ff5e89bb318b94c3c606d
-    --sha256: 02wjbvgbfdr5rybncxgx6slxh4gzx1vh4i34n6h834qghiq4yykb
+    tag: b56731a6305ba9bf7d858716f64098fec97490fc
+    --sha256: 05hv6j1hbxbdajzgv2l8m5p8bvva3nqiapy4mwm1qy8qzmz1d6g4
     subdir:
       ouroboros-consensus
       ouroboros-consensus-cardano

cardano-node/src/Cardano/Node/LedgerEvent.hs

@@ -25,7 +25,9 @@ module Cardano.Node.LedgerEvent (
   , LedgerNewEpochEvent (..)
   , LedgerRewardUpdateEvent (..)
   , Versioned (..)
+  , deserializeVersioned
   , ledgerEventName
+  , serializeVersioned
 
     -- ** Using Ledger events
   , StandardLedgerEventHandler
@@ -88,7 +90,7 @@ import qualified Codec.CBOR.Decoding as CBOR
 import qualified Codec.CBOR.Encoding as CBOR
 import qualified Codec.CBOR.Read as CBOR
 import qualified Codec.CBOR.Write as CBOR
-import           Control.Arrow ((&&&))
+import           Control.Arrow ((&&&), (***))
 import           Control.Concurrent.STM (newTChanIO, readTChan, writeTChan)
 import           Control.Monad.Fail (MonadFail (..))
 import           Control.State.Transition (Event)
@@ -157,7 +159,7 @@ instance Crypto crypto => DecCBOR (LedgerEvent crypto) where
         SumD LedgerBody
       decRaw n = Invalid n
 
-type LedgerEvents = NE.NonEmpty (LedgerEvent StandardCrypto) -- ^ convenient alias to refer to a list of LedgerEvents
+type LedgerEvents = [LedgerEvent StandardCrypto] -- ^ convenient alias to refer to a list of LedgerEvents
 
 -- TODO(KtorZ): Discuss that design choice; I believe we should favor a more
 -- 'flat' structure for events instead of preserving whatever the ledger imposes
@@ -709,7 +711,7 @@ data AnchoredEvents =
     , blockHeaderHash :: !ShortByteString
     , slotNo :: !SlotNo
     , blockNo :: !BlockNo
-    , ledgerEvents :: !(NonEmpty (LedgerEvent StandardCrypto))
+    , ledgerEvents :: ![LedgerEvent StandardCrypto]
     }
   deriving (Eq, Show)
 
@@ -732,6 +734,7 @@ instance DecCBOR AnchoredEvents where
       <! From
 
 data Versioned a = Versioned Version a
+  deriving (Eq, Ord, Show)
 
 serializeVersioned :: EncCBOR a => Versioned a -> ByteString
 serializeVersioned (Versioned version x) =
@@ -847,5 +850,6 @@ mkVersionedAnchoredEvents prevHash headerHash slotNo blockNo auxEvents =
     chainHashToOriginHash :: ChainHash b -> WithOrigin (HeaderHash b)
     chainHashToOriginHash GenesisHash = Origin
     chainHashToOriginHash (BlockHash bh) = At bh
-    versionedEvents = mapMaybe (sequence . (eventCodecVersion &&& fromAuxLedgerEvent)) auxEvents
-    versionedGroups = map (first NE.head . NE.unzip) . NE.groupBy ((==) `on` fst) $ versionedEvents
+    versionedEvents = map (eventCodecVersion &&& fromAuxLedgerEvent) auxEvents
+    versionedGroups = map makeGroup $ NE.groupWith fst versionedEvents
+    makeGroup = (NE.head *** catMaybes . NE.toList) . NE.unzip

cardano-node/test/Test/Cardano/Node/LedgerEvent.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Test.Cardano.Node.LedgerEvent where
 
@@ -13,6 +14,7 @@ import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Base16 as Hex
 import           Data.ByteString.Lazy (fromStrict)
 import           Data.ByteString.Short (ShortByteString, toShort)
+import           Data.Foldable (for_, toList)
 import           Data.Map (Map)
 import           Data.Maybe (fromJust)
 import           Data.Set (Set)
@@ -40,29 +42,30 @@ prop_roundtrip_LedgerEvent_CBOR :: Property
 prop_roundtrip_LedgerEvent_CBOR =
   Hedgehog.property $ do
     version <- Hedgehog.forAll Gen.enumBounded
-    event <- Hedgehog.forAll genAnchoredEvent
-    footnote ("serialized event: " <> show (Hex.encode $ serializeAnchoredEvent version event))
-    Hedgehog.tripping event
-      (serializeAnchoredEvent version)
-      (fmap snd . deserializeAnchoredEvent . fromStrict)
+    event <- Hedgehog.forAll genAnchoredEvents
+    footnote ("serialized event: " <> show (Hex.encode $ serializeVersioned $ Versioned version event))
+    Hedgehog.tripping (Versioned version event)
+      serializeVersioned
+      (fmap snd . deserializeVersioned . fromStrict)
 
 prop_LedgerEvent_CDDL_conformance :: Property
 prop_LedgerEvent_CDDL_conformance =
   Hedgehog.property $ do
   version <- Hedgehog.forAll Gen.enumBounded
-  event <- Hedgehog.forAll genAnchoredEvent
+  event <- Hedgehog.forAll genAnchoredEvents
   Hedgehog.label (labelName event)
   -- FIXME: We do want to validate full anchored events here, not just ledger events.
   -- This requires the `cddl-cat` Rust crate to support the '.cbor' control
   -- operator which should make for a straightforward and nice contribution.
-  let bytes = serialize' version (ledgerEvent event)
-  case CDDL.validate specification bytes of
-    Right () ->
-      Hedgehog.success
-    Left (CDDL.ValidationError { CDDL.cbor = cbor, CDDL.hint = hint }) -> do
-      Hedgehog.footnote hint
-      Hedgehog.footnote cbor
-      Hedgehog.failure
+  for_ (ledgerEvents event) $ \le -> do
+    let bytes = serialize' version le
+    case CDDL.validate specification bytes of
+      Right () ->
+        Hedgehog.success
+      Left (CDDL.ValidationError { CDDL.cbor = cbor, CDDL.hint = hint }) -> do
+        Hedgehog.footnote hint
+        Hedgehog.footnote cbor
+        Hedgehog.failure
 
 --
 -- Generators
@@ -72,17 +75,20 @@ type StakePoolId = KeyHash 'StakePool StandardCrypto
 
 type StakeCredential = Credential 'Staking StandardCrypto
 
-genAnchoredEvent :: Hedgehog.Gen AnchoredEvent
-genAnchoredEvent =
-  AnchoredEvent
+genAnchoredEvents :: Hedgehog.Gen AnchoredEvents
+genAnchoredEvents =
+  AnchoredEvents
     <$> (At <$> genBlockHeaderHash)
     <*> genBlockHeaderHash
     <*> genSlotNo
     <*> genBlockNo
-    <*> Gen.choice (mconcat
-      [ fmap LedgerNewEpochEvent <$> genLedgerNewEpochEvent
-      , fmap LedgerRewardUpdateEvent <$> genLedgerRewardUpdateEvent
-      ])
+    <*> Gen.list
+          (Range.linear 0 20)
+          (Gen.choice
+            (mconcat
+              [ fmap LedgerNewEpochEvent <$> genLedgerNewEpochEvent
+              , fmap LedgerRewardUpdateEvent <$> genLedgerRewardUpdateEvent
+              ]))
 
 genLedgerNewEpochEvent :: [Hedgehog.Gen (LedgerNewEpochEvent StandardCrypto)]
 genLedgerNewEpochEvent =
@@ -191,10 +197,10 @@ genStakeCredentialMap genValue =
   Gen.map (Range.linear 0 3) ((,) <$> genCredential <*> genValue)
 
 labelName
-  :: AnchoredEvent
+  :: AnchoredEvents
   -> Hedgehog.LabelName
 labelName =
-  fromString . T.unpack . ledgerEventName . ledgerEvent
+  fromString . T.unpack . T.intercalate "," . map ledgerEventName . toList . ledgerEvents
 
 unsafeHashFromBytes
   :: (HashAlgorithm algo)