Merge #2039

2039: Update: fix ValueNotConservedUTxO serialization r=mrBliss a=mrBliss

This updates the dependencies on `cardano-ledger-specs` and `ouroboros-network`
to bring in IntersectMBO/cardano-ledger#1955

Other visible change: IntersectMBO/ouroboros-network#2714

Co-authored-by: Thomas Winant <thomas@well-typed.com>

cabal.project

@@ -110,8 +110,8 @@ source-repository-package
 source-repository-package
  type: git
  location: https://github.com/input-output-hk/cardano-ledger-specs
- tag: 623bbb8d4b13bcb0157c5c576a69536387f1b5be
- --sha256: 0nspz67p6ixw4zr6q4r2gzn37583mlag8f1g5pk0i4f1yisi69d1
+ tag: d6179d72c52588460c1d57b932a2fd0724c5db32
+ --sha256: 0fwhnib6raiq2lisbabchdd45wmlj1kfd21a3zbdmgc468j16clw
  subdir:
  byron/chain/executable-spec
  byron/crypto
@@ -159,8 +159,8 @@ source-repository-package
 source-repository-package
  type: git
  location: https://github.com/input-output-hk/ouroboros-network
- tag: 116ed8b475632ac13ab05c3561d4b23b44f4a230
- --sha256: 1ml9r3scnsqqpigiwlsjky9a4zlrp6797sg2m4yrvj7jq3hph2lq
+ tag: 95a7cd5be1cf565c3a15b2082b4ea5b7de82aefc
+ --sha256: 0czf50wscpg259841npgqscmmqqzg9kvikciryn4d08gxswswqky
  subdir:
  io-sim
  io-sim-classes

cardano-api/src/Cardano/Api/LocalChainSync.hs

@@ -12,7 +12,7 @@ import Control.Concurrent.STM
 
 import Ouroboros.Consensus.Ledger.Query (Query, ShowQuery)
 import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx)
-import Ouroboros.Network.Block (Tip)
+import Ouroboros.Network.Block (Point, Tip)
 import Ouroboros.Network.Protocol.ChainSync.Client (ClientStIdle (..),
  ClientStNext (..))
 import Ouroboros.Network.Util.ShowProxy (ShowProxy)
@@ -34,11 +34,11 @@ getLocalTip connctInfo = do
 
 chainSyncGetCurrentTip :: forall blk.
  TMVar (Tip blk)
- -> ChainSyncClient blk (Tip blk) IO ()
+ -> ChainSyncClient blk (Point blk) (Tip blk) IO ()
 chainSyncGetCurrentTip tipVar =
  ChainSyncClient (pure clientStIdle)
  where
- clientStIdle :: ClientStIdle blk (Tip blk) IO ()
+ clientStIdle :: ClientStIdle blk (Point blk) (Tip blk) IO ()
  clientStIdle =
  SendMsgRequestNext clientStNext (pure clientStNext)
 
@@ -47,7 +47,7 @@ chainSyncGetCurrentTip tipVar =
  -- While currently we can have protocols return things, the current OuroborosApplication
  -- stuff gets in the way of returning an overall result, but that's being worked on,
  -- and this can be improved when that's ready.
- clientStNext :: ClientStNext blk (Tip blk) IO ()
+ clientStNext :: ClientStNext blk (Point blk) (Tip blk) IO ()
  clientStNext = ClientStNext
  { recvMsgRollForward = \_blk tip -> ChainSyncClient $ do
  void $ atomically $ tryPutTMVar tipVar tip

cardano-api/src/Cardano/Api/Typed.hs

@@ -2625,6 +2625,7 @@ data LocalNodeClientProtocols block =
  localChainSyncClient
  :: Maybe (ChainSyncClient
  block
+ (Point block)
  (Tip block)
  IO ())
 
@@ -2637,6 +2638,7 @@ data LocalNodeClientProtocols block =
  , localStateQueryClient
  :: Maybe (LocalStateQueryClient
  block
+ (Point block)
  (Query block)
  IO ())
  }
@@ -2765,7 +2767,7 @@ queryNodeLocalState connctInfo pointAndQuery = do
  localStateQuerySingle
  :: TMVar (Either AcquireFailure result)
  -> (Point block, Query block result)
- -> LocalStateQueryClient block (Query block) IO ()
+ -> LocalStateQueryClient block (Point block) (Query block) IO ()
  localStateQuerySingle resultVar (point, query) =
  LocalStateQueryClient $ pure $
  SendMsgAcquire point $

cardano-node-chairman/app/Cardano/Chairman.hs

@@ -394,7 +394,7 @@ chainSyncClient
  -> SocketPath
  -> ChainsVar m blk
  -> SecurityParam
- -> ChainSyncClient blk (Tip blk) m ()
+ -> ChainSyncClient blk (Point blk) (Tip blk) m ()
 chainSyncClient tracer sockPath chainsVar securityParam = ChainSyncClient $ pure $
  -- Notify the core node about the our latest points at which we are
  -- synchronised. This client is not persistent and thus it just
@@ -407,10 +407,10 @@ chainSyncClient tracer sockPath chainsVar securityParam = ChainSyncClient $ pure
  , recvMsgIntersectNotFound = \ _ -> ChainSyncClient (pure clientStIdle)
  }
  where
- clientStIdle :: ClientStIdle blk (Tip blk) m ()
+ clientStIdle :: ClientStIdle blk (Point blk) (Tip blk) m ()
  clientStIdle = SendMsgRequestNext clientStNext (pure clientStNext)
 
- clientStNext :: ClientStNext blk (Tip blk) m ()
+ clientStNext :: ClientStNext blk (Point blk) (Tip blk) m ()
  clientStNext = ClientStNext
  { recvMsgRollForward = \blk _tip -> ChainSyncClient $ do
  -- add block & check if there is consensus on immutable chain
@@ -454,7 +454,7 @@ localInitiatorNetworkApplication
  , MonadThrow (STM m)
  )
  => Tracer m (ChairmanTrace blk)
- -> Tracer m (TraceSendRecv (ChainSync blk (Tip blk)))
+ -> Tracer m (TraceSendRecv (ChainSync blk (Point blk) (Tip blk)))
  -- ^ tracer which logs all chain-sync messages send and received by the client
  -- (see 'Ouroboros.Network.Protocol.ChainSync.Type' in 'ouroboros-network'
  -- package)

cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs

@@ -382,7 +382,7 @@ instance ( ConvertTxId blk
  , RunNode blk
  , HasTxs blk
  )
- => ToObject (AnyMessageAndAgency (BlockFetch blk)) where
+ => ToObject (AnyMessageAndAgency (BlockFetch blk (Point blk))) where
  toObject MaximalVerbosity (AnyMessageAndAgency _ (MsgBlock blk)) =
  mkObject [ "kind" .= String "MsgBlock"
  , "blockHash" .= renderHeaderHash (Proxy @blk) (blockHash blk)
@@ -409,7 +409,7 @@ instance ( ConvertTxId blk
  toObject _v (AnyMessageAndAgency _ MsgClientDone{}) =
  mkObject [ "kind" .= String "MsgClientDone" ]
 
-instance ToObject (AnyMessageAndAgency (LocalStateQuery blk query)) where
+instance ToObject (AnyMessageAndAgency (LocalStateQuery blk pt query)) where
  toObject _verb (AnyMessageAndAgency _ LocalStateQuery.MsgAcquire{}) =
  mkObject [ "kind" .= String "MsgAcquire" ]
  toObject _verb (AnyMessageAndAgency _ LocalStateQuery.MsgAcquired{}) =
@@ -437,7 +437,7 @@ instance ToObject (AnyMessageAndAgency (LocalTxSubmission tx err)) where
  toObject _verb (AnyMessageAndAgency _ LocalTxSub.MsgDone{}) =
  mkObject [ "kind" .= String "MsgDone" ]
 
-instance ToObject (AnyMessageAndAgency (ChainSync blk tip)) where
+instance ToObject (AnyMessageAndAgency (ChainSync blk pt tip)) where
  toObject _verb (AnyMessageAndAgency _ ChainSync.MsgRequestNext{}) =
  mkObject [ "kind" .= String "MsgRequestNext" ]
  toObject _verb (AnyMessageAndAgency _ ChainSync.MsgAwaitReply{}) =

cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs

@@ -51,6 +51,7 @@ import qualified Cardano.Ledger.Core as Core
 
 -- TODO: this should be exposed via Cardano.Api
 import Shelley.Spec.Ledger.API
+import Shelley.Spec.Ledger.Coin (DeltaCoin (..))
 import Shelley.Spec.Ledger.BlockChain (LastAppliedBlock (..))
 import Shelley.Spec.Ledger.PParams (PParamsUpdate)
 
@@ -102,8 +103,11 @@ instance ShelleyBasedEra era => ToObject (Header (ShelleyBlock era)) where
  , "blockNo" .= condense (blockNo b)
 -- , "delegate" .= condense (headerSignerVk h)
  ]
-instance (ShelleyBasedEra era, ToObject (PredicateFailure (UTXO era)))
- => ToObject (ApplyTxError era) where
+
+instance ( ShelleyBasedEra era
+ , ToObject (PredicateFailure (UTXO era))
+ , ToObject (PredicateFailure (UTXOW era))
+ ) => ToObject (ApplyTxError era) where
  toObject verb (ApplyTxError predicateFailures) =
  HMS.unions $ map (toObject verb) predicateFailures
 
@@ -146,8 +150,10 @@ instance ToObject HotKey.KESEvolutionError where
  , "targetPeriod" .= targetPeriod
  ]
 
-instance (ShelleyBasedEra era, ToObject (PredicateFailure (UTXO era)))
- => ToObject (ShelleyLedgerError era) where
+instance ( ShelleyBasedEra era
+ , ToObject (PredicateFailure (UTXO era))
+ , ToObject (PredicateFailure (UTXOW era))
+ ) => ToObject (ShelleyLedgerError era) where
  toObject verb (BBodyError (BlockTransitionError fs)) =
  mkObject [ "kind" .= String "BBodyError"
  , "failures" .= map (toObject verb) fs
@@ -209,8 +215,10 @@ instance Core.Crypto crypto => ToObject (ChainTransitionError crypto) where
  , "failures" .= map (toObject verb) fs
  ]
 
-instance (ShelleyBasedEra era, ToObject (PredicateFailure (UTXO era)))
- => ToObject (ChainPredicateFailure era) where
+instance ( ShelleyBasedEra era
+ , ToObject (PredicateFailure (UTXO era))
+ , ToObject (PredicateFailure (UTXOW era))
+ ) => ToObject (ChainPredicateFailure era) where
  toObject _verb (HeaderSizeTooLargeCHAIN hdrSz maxHdrSz) =
  mkObject [ "kind" .= String "HeaderSizeTooLarge"
  , "headerSize" .= hdrSz
@@ -254,8 +262,10 @@ instance ToObject (PrtlSeqFailure crypto) where
  , "currentBlockHash" .= String (textShow currentHash)
  ]
 
-instance (ShelleyBasedEra era, ToObject (PredicateFailure (UTXO era)))
- => ToObject (BbodyPredicateFailure era) where
+instance ( ShelleyBasedEra era
+ , ToObject (PredicateFailure (UTXO era))
+ , ToObject (PredicateFailure (UTXOW era))
+ ) => ToObject (BbodyPredicateFailure era) where
  toObject _verb (WrongBlockBodySizeBBODY actualBodySz claimedBodySz) =
  mkObject [ "kind" .= String "WrongBlockBodySizeBBODY"
  , "actualBlockBodySize" .= actualBodySz
@@ -269,13 +279,17 @@ instance (ShelleyBasedEra era, ToObject (PredicateFailure (UTXO era)))
  toObject verb (LedgersFailure f) = toObject verb f
 
 
-instance (ShelleyBasedEra era, ToObject (PredicateFailure (UTXO era)))
- => ToObject (LedgersPredicateFailure era) where
+instance ( ShelleyBasedEra era
+ , ToObject (PredicateFailure (UTXO era))
+ , ToObject (PredicateFailure (UTXOW era))
+ ) => ToObject (LedgersPredicateFailure era) where
  toObject verb (LedgerFailure f) = toObject verb f
 
 
-instance (ShelleyBasedEra era, ToObject (PredicateFailure (UTXO era)))
- => ToObject (LedgerPredicateFailure era) where
+instance ( ShelleyBasedEra era
+ , ToObject (PredicateFailure (UTXO era))
+ , ToObject (PredicateFailure (UTXOW era))
+ ) => ToObject (LedgerPredicateFailure era) where
  toObject verb (UtxowFailure f) = toObject verb f
  toObject verb (DelegsFailure f) = toObject verb f
 
@@ -380,7 +394,7 @@ renderBadInputsUTxOErr txIns
  | Set.null txIns = String "The transaction contains no inputs."
  | otherwise = String "The transaction contains inputs that do not exist in the UTxO set."
 
-renderValueNotConservedErr :: Coin -> Coin -> Value
+renderValueNotConservedErr :: DeltaCoin -> DeltaCoin -> Value
 renderValueNotConservedErr consumed produced
  | consumed > produced = String "This transaction has consumed more Lovelace than it has produced."
  | consumed < produced = String "This transaction has produced more Lovelace than it has consumed."
@@ -677,6 +691,7 @@ deriving newtype instance ShelleyBasedEra era => ToJSON (MetaDataHash era)
 
 deriving instance ShelleyBasedEra era => ToJSON (TxIn era)
 deriving newtype instance ToJSON (TxId era)
+deriving newtype instance ToJSON DeltaCoin
 instance ShelleyBasedEra era => ToJSONKey (TxIn era) where
  toJSONKey = ToJSONKeyText txInToText (Aeson.text . txInToText)