From c7303f101642d7819b8c32666cd894c92f9f346a Mon Sep 17 00:00:00 2001 From: Konstantinos Lambrou-Latreille Date: Tue, 19 May 2026 13:59:33 -0400 Subject: [PATCH] Add ToJSON/FromJSON instances for EraTxWits * Add ToJSON, FromJSON and NFData as EraTxWits superclass constraints * Add ToJSON/FromJSON for WitVKey, BootstrapWitness * Add ToJSONKey/FromJSONKey for AccountId * Add ToJSON/FromJSON for Inclusive and Exclusive * Add FromJSON for TxIn; fix txInToText to use unTxIx * Add FromJSON for PoolCert * Add ToJSON/FromJSON for ShelleyTxWits era * Add FromJSON for AsIx, AlonzoPlutusPurpose AsIx, TxDats, Redeemers, AlonzoTxWits * Add FromJSON for ConwayDelegCert, ConwayGovCert, ConwayTxCert era, ConwayPlutusPurpose * Add FromJSON for GovActionId, Voter, Vote, VotingProcedure, ProposalProcedure, GovAction, GovPurposeId * Add ToJSON/FromJSON for AccountBalanceInterval, DijkstraScript * Add FromJSON for DijkstraDelegCert, DijkstraTxCert era * Add round-trip JSON property test for TxWits era --- eras/alonzo/impl/CHANGELOG.md | 3 + .../impl/src/Cardano/Ledger/Alonzo/TxWits.hs | 83 +++++++++++++++++++ eras/conway/impl/CHANGELOG.md | 3 + .../Ledger/Conway/Governance/Procedures.hs | 79 +++++++++++++++--- .../impl/src/Cardano/Ledger/Conway/Scripts.hs | 21 ++++- .../impl/src/Cardano/Ledger/Conway/TxCert.hs | 47 ++++++++++- eras/dijkstra/impl/CHANGELOG.md | 3 + .../src/Cardano/Ledger/Dijkstra/Scripts.hs | 39 ++++++++- .../src/Cardano/Ledger/Dijkstra/TxCert.hs | 34 +++++++- eras/shelley/impl/CHANGELOG.md | 1 + .../impl/src/Cardano/Ledger/Shelley/TxWits.hs | 24 ++++++ libs/cardano-ledger-core/CHANGELOG.md | 8 ++ .../src/Cardano/Ledger/Address.hs | 2 +- .../src/Cardano/Ledger/BaseTypes.hs | 4 +- .../src/Cardano/Ledger/Core.hs | 3 + .../src/Cardano/Ledger/Core/TxCert.hs | 13 ++- .../src/Cardano/Ledger/Keys/Bootstrap.hs | 53 +++++++++++- .../src/Cardano/Ledger/Keys/WitVKey.hs | 39 ++++++++- .../src/Cardano/Ledger/TxIn.hs | 49 +++++++---- .../testlib/Test/Cardano/Ledger/Era.hs | 2 + 20 files changed, 473 insertions(+), 37 deletions(-) diff --git a/eras/alonzo/impl/CHANGELOG.md b/eras/alonzo/impl/CHANGELOG.md index 6e756500dbe..c20d6bc78cc 100644 --- a/eras/alonzo/impl/CHANGELOG.md +++ b/eras/alonzo/impl/CHANGELOG.md @@ -3,6 +3,9 @@ ## 1.16.0.0 * Add `ToJSON` and `FromJSON` instances for `AlonzoTxAuxData era` +* Add `FromJSON` instance for `AsIx ix it` +* Add `FromJSON` instance for `AlonzoPlutusPurpose AsIx era` +* Add `ToJSON` and `FromJSON` instances for `TxDats era`, `Redeemers era`, and `AlonzoTxWits era` * Replace `scriptsProvided` and `scriptsNeeded` in `mkScriptIntegrity` signature with `Set Language` * Add `plutusLanguagesUsedStAnnTx` to `AlonzoEraUTxO` and a helper to implement it `plutusLanguagesUsedAlonzoStAnnTx` * Add `plutusScriptsWithContextStAnnTx` to `AlonzoEraUTxO` and a helper to implement it `plutusScriptsWithContextAlonzoStAnnTx` diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs index 52a0e3ca9b8..9825c0c407c 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs @@ -122,7 +122,10 @@ import Cardano.Ledger.Shelley.TxWits ( import Control.DeepSeq (NFData) import Control.Monad (when, (>=>)) import Control.Monad.Trans.Fail (runFail) +import Data.Aeson (FromJSON (..), ToJSON (..), object, withArray, withObject, (.:), (.=)) +import qualified Data.Aeson as Aeson import Data.Coerce (coerce) +import qualified Data.Foldable as Foldable import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -746,3 +749,83 @@ encodeWithSetTag xs = (natVersion @9) (encodeTag setTag <> encCBOR xs) (encCBOR xs) + +instance (Era era, ToJSON (Data era)) => ToJSON (TxDats era) where + toJSON (TxDats m) = + Aeson.toJSON + [ object ["dataHash" .= k, "data" .= v] + | (k, v) <- Map.toList m + ] + +instance (Era era, FromJSON (Data era)) => FromJSON (TxDats era) where + parseJSON = withArray "TxDats" $ \arr -> do + pairs <- mapM parsePair (Foldable.toList arr) + pure $ TxDats (Map.fromList pairs) + where + parsePair = withObject "TxDat" $ \o -> do + !datHash <- o .: "dataHash" + !dat <- o .: "data" + pure (datHash, dat) + +instance + ( AlonzoEraScript era + , ToJSON (Data era) + , ToJSON (PlutusPurpose AsIx era) + ) => + ToJSON (Redeemers era) + where + toJSON (Redeemers rdmrs) = + Aeson.toJSON + [ object ["purpose" .= k, "data" .= d, "exUnits" .= ex] + | (k, (d, ex)) <- Map.toList rdmrs + ] + +instance + ( AlonzoEraScript era + , FromJSON (Data era) + , FromJSON (PlutusPurpose AsIx era) + ) => + FromJSON (Redeemers era) + where + parseJSON = withArray "Redeemers" $ \arr -> do + pairs <- mapM parseRedeemer (Foldable.toList arr) + pure $ Redeemers (Map.fromList pairs) + where + parseRedeemer = withObject "Redeemer" $ \o -> do + !purpose <- o .: "purpose" + !dat <- o .: "data" + !exUnits <- o .: "exUnits" + pure (purpose, (dat, exUnits)) + +instance + ( AlonzoEraScript era + , ToJSON (Script era) + , ToJSON (Data era) + , ToJSON (PlutusPurpose AsIx era) + ) => + ToJSON (AlonzoTxWits era) + where + toJSON (AlonzoTxWits vkeys boots scripts dats rdmrs) = + object + [ "addrWits" .= Set.toList vkeys + , "bootWits" .= Set.toList boots + , "scriptWits" .= scripts + , "datums" .= dats + , "redeemers" .= rdmrs + ] + +instance + ( AlonzoEraScript era + , FromJSON (Script era) + , FromJSON (Data era) + , FromJSON (PlutusPurpose AsIx era) + ) => + FromJSON (AlonzoTxWits era) + where + parseJSON = withObject "AlonzoTxWits" $ \o -> + AlonzoTxWits + <$> (Set.fromList <$> o .: "addrWits") + <*> (Set.fromList <$> o .: "bootWits") + <*> o .: "scriptWits" + <*> o .: "datums" + <*> o .: "redeemers" diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index f5b12384b78..26335818550 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -2,6 +2,9 @@ ## 1.23.0.0 +* Add `FromJSON` instances for `GovActionId`, `Voter`, `Vote`, `VotingProcedure`, `ProposalProcedure`, `GovAction`, and `GovPurposeId` +* Add `FromJSON` instances for `ConwayDelegCert`, `ConwayGovCert`, and `ConwayTxCert era` +* Add `FromJSON` instance for `ConwayPlutusPurpose f era` * Add `ToJSON` instance for `DefaultVote`. * Add `injectStakeCredentials`, `injectDRepsThenDelegs` to `Cardano.Ledger.Conway.Transition` * Add `ConwayExtraConfig` type and `cgExtraConfig` field to `ConwayGenesis` diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs index f535898f607..88564bf04d6 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs @@ -2,12 +2,10 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} @@ -21,7 +19,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -125,7 +122,7 @@ import Cardano.Ledger.Binary.Coders ( ( Text.pack "#" <> Text.pack (show ix) +instance FromJSON GovActionId where + parseJSON = withObject "GovActionId" $ \o -> + GovActionId + <$> o .: "txId" + <*> o .: "govActionIx" + +instance FromJSONKey GovActionId where + fromJSONKey = FromJSONKeyTextParser parseGovActionId + +parseGovActionId :: MonadFail m => Text.Text -> m GovActionId +parseGovActionId t = case Text.splitOn "#" t of + [txIdText, ixText] -> do + txId <- case Aeson.fromJSON (Aeson.String txIdText) of + Aeson.Success v -> pure v + Aeson.Error e -> fail $ "GovActionId: invalid txId: " <> e + ix <- + maybe (fail "GovActionId: invalid index") (pure . GovActionIx) (readMaybe $ Text.unpack ixText) + pure $ GovActionId txId ix + _ -> fail "GovActionId: expected 'txhash#ix'" + data GovActionState era = GovActionState { gasId :: !GovActionId , gasCommitteeVotes :: !(Map (Credential HotCommitteeRole) Vote) @@ -273,7 +294,7 @@ deriving via EraPParams era => ToJSON (GovActionState era) instance EraPParams era => ToKeyValuePairs (GovActionState era) where - toKeyValuePairs gas@(GovActionState _ _ _ _ _ _ _) = + toKeyValuePairs gas = let GovActionState {..} = gas in [ "actionId" .= gasId , "committeeVotes" .= gasCommitteeVotes @@ -352,6 +373,22 @@ instance ToJSONKey Voter where StakePoolVoter kh -> "stakepool-" <> credToText (KeyHashObj kh) +instance FromJSON Voter + +instance FromJSONKey Voter where + fromJSONKey = FromJSONKeyTextParser parseVoter + +parseVoter :: MonadFail m => Text.Text -> m Voter +parseVoter t = case Text.splitOn "-" t of + ("committee" : rest) -> CommitteeVoter <$> parseCredential (Text.intercalate "-" rest) + ("drep" : rest) -> DRepVoter <$> parseCredential (Text.intercalate "-" rest) + ("stakepool" : rest) -> do + cred <- parseCredential (Text.intercalate "-" rest) + case cred of + KeyHashObj kh -> pure $ StakePoolVoter kh + ScriptHashObj _ -> fail "StakePool voter cannot be a script hash" + _ -> fail $ "Invalid Voter: " <> show t + instance DecCBOR Voter where decCBOR = decodeRecordSum "Voter" $ \case 0 -> (2,) . CommitteeVoter . KeyHashObj <$> decCBOR @@ -387,6 +424,8 @@ data Vote instance ToJSON Vote +instance FromJSON Vote + instance NoThunks Vote instance NFData Vote @@ -401,7 +440,7 @@ newtype VotingProcedures era = VotingProcedures { unVotingProcedures :: Map Voter (Map GovActionId (VotingProcedure era)) } deriving stock (Generic, Eq, Show) - deriving newtype (NoThunks, EncCBOR, ToJSON) + deriving newtype (NoThunks, EncCBOR, ToJSON, FromJSON) deriving newtype instance Era era => NFData (VotingProcedures era) @@ -485,6 +524,12 @@ instance EraPParams era => ToKeyValuePairs (VotingProcedure era) where , "decision" .= vProcVote ] +instance EraPParams era => FromJSON (VotingProcedure era) where + parseJSON = withObject "VotingProcedure" $ \o -> + VotingProcedure + <$> o .: "decision" + <*> o .: "anchor" + -- | Attaches indices to a sequence of proposal procedures. The indices grow -- from left to right. indexedGovProps :: @@ -549,7 +594,7 @@ deriving via EraPParams era => ToJSON (ProposalProcedure era) instance EraPParams era => ToKeyValuePairs (ProposalProcedure era) where - toKeyValuePairs proposalProcedure@(ProposalProcedure _ _ _ _) = + toKeyValuePairs proposalProcedure = let ProposalProcedure {..} = proposalProcedure in [ "deposit" .= pProcDeposit , "returnAddr" .= pProcReturnAddr @@ -557,6 +602,14 @@ instance EraPParams era => ToKeyValuePairs (ProposalProcedure era) where , "anchor" .= pProcAnchor ] +instance EraPParams era => FromJSON (ProposalProcedure era) where + parseJSON = withObject "ProposalProcedure" $ \o -> + ProposalProcedure + <$> o .: "deposit" + <*> o .: "returnAddr" + <*> o .: "govAction" + <*> o .: "anchor" + data Committee era = Committee { committeeMembers :: !(Map (Credential ColdCommitteeRole) EpochNo) -- ^ Committee members with epoch number when each of them expires @@ -663,6 +716,10 @@ deriving newtype instance ToJSONKey (GovPurposeId (p :: GovActionPurpose)) deriving newtype instance ToJSON (GovPurposeId (p :: GovActionPurpose)) +deriving newtype instance FromJSON (GovPurposeId (p :: GovActionPurpose)) + +deriving newtype instance FromJSONKey (GovPurposeId (p :: GovActionPurpose)) + deriving newtype instance Show (GovPurposeId (p :: GovActionPurpose)) -- | Abstract data type for representing relationship of governance action with the same purpose @@ -736,7 +793,7 @@ instance (forall p. Typeable p => EncCBOR (f (GovPurposeId (p :: GovActionPurpose)))) => EncCBOR (GovRelation f) where - encCBOR govPurpose@(GovRelation _ _ _ _) = + encCBOR govPurpose = let GovRelation {..} = govPurpose in encodeListLen 4 <> encCBOR grPParamUpdate @@ -748,7 +805,7 @@ instance (forall p. ToJSON (f (GovPurposeId (p :: GovActionPurpose)))) => ToKeyValuePairs (GovRelation f) where - toKeyValuePairs govPurpose@(GovRelation _ _ _ _) = + toKeyValuePairs govPurpose = let GovRelation {..} = govPurpose in [ "PParamUpdate" .= grPParamUpdate , "HardFork" .= grHardFork @@ -868,6 +925,8 @@ instance EraPParams era => NFData (GovAction era) instance EraPParams era => ToJSON (GovAction era) +instance EraPParams era => FromJSON (GovAction era) + instance EraPParams era => DecCBOR (GovAction era) where decCBOR = decode $ Summands "GovAction" $ \case diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Scripts.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Scripts.hs index 86d00a16447..424669a81f5 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Scripts.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Scripts.hs @@ -53,7 +53,7 @@ import Cardano.Ledger.Plutus.Language import Cardano.Ledger.Shelley.Scripts (ShelleyEraScript (..)) import Cardano.Ledger.TxIn (TxIn) import Control.DeepSeq (NFData (..), rwhnf) -import Data.Aeson (ToJSON (..), (.=)) +import Data.Aeson (FromJSON (..), ToJSON (..), withObject, (.:), (.=)) import Data.MemPack import Data.Typeable import Data.Word (Word32) @@ -312,6 +312,25 @@ instance where kindObjectWithValue name n = kindObjectValue name ["value" .= n] +instance + ( forall a b. (FromJSON a, FromJSON b) => FromJSON (f a b) + , FromJSON (TxCert era) + , EraPParams era + ) => + FromJSON (ConwayPlutusPurpose f era) + where + parseJSON = withObject "ConwayPlutusPurpose" $ \o -> do + kind <- o .: "kind" + value <- o .: "value" + case (kind :: String) of + "ConwaySpending" -> ConwaySpending <$> parseJSON value + "ConwayMinting" -> ConwayMinting <$> parseJSON value + "ConwayCertifying" -> ConwayCertifying <$> parseJSON value + "ConwayRewarding" -> ConwayRewarding <$> parseJSON value + "ConwayVoting" -> ConwayVoting <$> parseJSON value + "ConwayProposing" -> ConwayProposing <$> parseJSON value + _ -> fail $ "Unknown ConwayPlutusPurpose kind: " <> kind + pattern VotingPurpose :: ConwayEraScript era => f Word32 Voter -> PlutusPurpose f era pattern VotingPurpose c <- (toVotingPurpose -> Just c) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs index 0d6c573c2a7..973c5ea382a 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs @@ -88,7 +88,9 @@ import Cardano.Ledger.Shelley.TxCert ( ) import Cardano.Ledger.Val (Val (..)) import Control.DeepSeq (NFData) -import Data.Aeson (FromJSON (..), ToJSON (..), withObject, (.:?), (.=)) +import Data.Aeson (FromJSON (..), ToJSON (..), withObject, (.:), (.:?), (.=)) +import qualified Data.Aeson as Aeson +import Data.Aeson.Types (Parser) import Data.Foldable as F (foldMap', foldl') import qualified Data.Map.Strict as Map import Data.Monoid (Sum (getSum)) @@ -548,6 +550,20 @@ instance ToJSON ConwayDelegCert where , "deposit" .= toJSON deposit ] +instance FromJSON ConwayDelegCert where + parseJSON = withObject "ConwayDelegCert" $ \o -> do + kind <- o .: "kind" :: Parser Aeson.Value + case kind of + Aeson.String "RegCert" -> + ConwayRegCert <$> o .: "credential" <*> o .: "deposit" + Aeson.String "UnRegCert" -> + ConwayUnRegCert <$> o .: "credential" <*> o .: "refund" + Aeson.String "DelegCert" -> + ConwayDelegCert <$> o .: "credential" <*> o .: "delegatee" + Aeson.String "RegDelegCert" -> + ConwayRegDelegCert <$> o .: "credential" <*> o .: "delegatee" <*> o .: "deposit" + _ -> fail $ "Unknown ConwayDelegCert kind: " <> show kind + data ConwayGovCert = ConwayRegDRep !(Credential DRepRole) !Coin !(StrictMaybe Anchor) | ConwayUnRegDRep !(Credential DRepRole) !Coin @@ -594,6 +610,22 @@ instance ToJSON ConwayGovCert where , "anchor" .= toJSON anchor ] +instance FromJSON ConwayGovCert where + parseJSON = withObject "ConwayGovCert" $ \o -> do + kind <- o .: "kind" :: Parser Aeson.Value + case kind of + Aeson.String "RegDRep" -> + ConwayRegDRep <$> o .: "dRep" <*> o .: "deposit" <*> o .: "anchor" + Aeson.String "UnRegDRep" -> + ConwayUnRegDRep <$> o .: "dRep" <*> o .: "refund" + Aeson.String "UpdateDRep" -> + ConwayUpdateDRep <$> o .: "dRep" <*> o .: "anchor" + Aeson.String "AuthCommitteeHotKey" -> + ConwayAuthCommitteeHotKey <$> o .: "coldCredential" <*> o .: "hotCredential" + Aeson.String "ResignCommitteeColdKey" -> + ConwayResignCommitteeColdKey <$> o .: "coldCredential" <*> o .: "anchor" + _ -> fail $ "Unknown ConwayGovCert kind: " <> show kind + instance EncCBOR ConwayGovCert where encCBOR = \case ConwayAuthCommitteeHotKey cred key -> @@ -639,6 +671,19 @@ instance Era era => ToJSON (ConwayTxCert era) where ConwayTxCertPool poolCert -> toJSON poolCert ConwayTxCertGov govCert -> toJSON govCert +instance Era era => FromJSON (ConwayTxCert era) where + parseJSON = withObject "ConwayTxCert" $ \o -> do + kind <- o .: "kind" :: Parser Aeson.Value + case kind of + Aeson.String k + | k `elem` ["RegCert", "UnRegCert", "DelegCert", "RegDelegCert"] -> + ConwayTxCertDeleg <$> parseJSON (Aeson.Object o) + | k `elem` ["RegPool", "RetirePool"] -> + ConwayTxCertPool <$> parseJSON (Aeson.Object o) + | k `elem` ["RegDRep", "UnRegDRep", "UpdateDRep", "AuthCommitteeHotKey", "ResignCommitteeColdKey"] -> + ConwayTxCertGov <$> parseJSON (Aeson.Object o) + _ -> fail $ "Unknown ConwayTxCert kind: " <> show kind + instance ( ShelleyEraTxCert era , TxCert era ~ ConwayTxCert era diff --git a/eras/dijkstra/impl/CHANGELOG.md b/eras/dijkstra/impl/CHANGELOG.md index ed04cc60f33..4336ef1450c 100644 --- a/eras/dijkstra/impl/CHANGELOG.md +++ b/eras/dijkstra/impl/CHANGELOG.md @@ -2,6 +2,9 @@ ## 0.3.0.0 +* Add `ToJSON` and `FromJSON` instances for `AccountBalanceInterval era` +* Add `FromJSON` instance for `DijkstraScript era` +* Add `FromJSON` instances for `DijkstraDelegCert` and `DijkstraTxCert era` * Add `DijkstraEraUTxO` type class with `subTransactionsStAnnTx` method * Add `TranslateEra` instance for `DijkstraEra VState` * Fix `TranslateEra` instance for `DijkstraEra CertState` diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Scripts.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Scripts.hs index a3639fbad45..847b2000fce 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Scripts.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Scripts.hs @@ -91,7 +91,7 @@ import Cardano.Ledger.Shelley.Scripts import Cardano.Ledger.TxIn (TxIn) import Control.Applicative ((<|>)) import Control.DeepSeq (NFData (..), rwhnf) -import Data.Aeson (FromJSON (parseJSON), KeyValue (..), ToJSON (toJSON), (.:)) +import Data.Aeson (FromJSON (..), KeyValue (..), ToJSON (..), withObject, (.:)) import qualified Data.Aeson as Aeson import Data.Aeson.Types (Parser) import qualified Data.Map.Strict as Map @@ -210,6 +210,26 @@ instance where kindObjectWithValue name n = kindObjectValue name ["value" .= n] +instance + ( forall a b. (FromJSON a, FromJSON b) => FromJSON (f a b) + , FromJSON (TxCert era) + , EraPParams era + ) => + FromJSON (DijkstraPlutusPurpose f era) + where + parseJSON = withObject "DijkstraPlutusPurpose" $ \o -> do + kind <- o .: "kind" + value <- o .: "value" + case (kind :: String) of + "DijkstraSpending" -> DijkstraSpending <$> parseJSON value + "DijkstraMinting" -> DijkstraMinting <$> parseJSON value + "DijkstraCertifying" -> DijkstraCertifying <$> parseJSON value + "DijkstraRewarding" -> DijkstraRewarding <$> parseJSON value + "DijkstraVoting" -> DijkstraVoting <$> parseJSON value + "DijkstraProposing" -> DijkstraProposing <$> parseJSON value + "DijkstraGuarding" -> DijkstraGuarding <$> parseJSON value + _ -> fail $ "Unknown DijkstraPlutusPurpose kind: " <> kind + deriving instance (EraTxCert era, EraPParams era) => Eq (DijkstraPlutusPurpose AsItem era) deriving instance (EraTxCert era, EraPParams era) => Eq (DijkstraPlutusPurpose AsIx era) @@ -638,8 +658,23 @@ instance Typeable era => DecCBOR (AccountBalanceInterval era) where (Nothing, Just u) -> pure $ AccountBalanceUpperBound u _ -> cborError $ DecoderErrorCustom "AccountBalanceInterval" "Both interval bounds cannot be nil." +instance ToJSON (AccountBalanceInterval era) where + toJSON = \case + AccountBalanceLowerBound l -> kindObjectValue "lowerBound" ["lower" .= l] + AccountBalanceUpperBound u -> kindObjectValue "upperBound" ["upper" .= u] + AccountBalanceBothBounds l u -> kindObjectValue "bothBounds" ["lower" .= l, "upper" .= u] + +instance FromJSON (AccountBalanceInterval era) where + parseJSON = withObject "AccountBalanceInterval" $ \o -> do + kind <- o .: "kind" + case (kind :: String) of + "lowerBound" -> AccountBalanceLowerBound <$> o .: "lower" + "upperBound" -> AccountBalanceUpperBound <$> o .: "upper" + "bothBounds" -> AccountBalanceBothBounds <$> o .: "lower" <*> o .: "upper" + _ -> fail $ "Unknown AccountBalanceInterval kind: " <> kind + newtype AccountBalanceIntervals era = AccountBalanceIntervals {unAccountBalanceIntervals :: Map.Map AccountId (AccountBalanceInterval era)} deriving (Generic) - deriving newtype (Show, Ord, Eq, NoThunks, NFData, EncCBOR, DecCBOR) + deriving newtype (Show, Ord, Eq, NoThunks, NFData, EncCBOR, DecCBOR, ToJSON, FromJSON) diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxCert.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxCert.hs index 037b929d2f4..29960e684c3 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxCert.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxCert.hs @@ -80,7 +80,9 @@ import Cardano.Ledger.Shelley.TxCert ( ) import Cardano.Ledger.Val (Val (..)) import Control.DeepSeq (NFData) -import Data.Aeson (KeyValue ((.=)), ToJSON (..)) +import Data.Aeson (FromJSON (..), KeyValue ((.=)), ToJSON (..), (.:)) +import qualified Data.Aeson as Aeson +import Data.Aeson.Types (Parser) import Data.Foldable (Foldable (..)) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) @@ -168,6 +170,17 @@ instance ToJSON DijkstraDelegCert where , "deposit" .= toJSON deposit ] +instance FromJSON DijkstraDelegCert where + parseJSON = Aeson.withObject "DijkstraDelegCert" $ \o -> do + kind <- o .: "kind" :: Parser Aeson.Value + case kind of + Aeson.String "RegCert" -> DijkstraRegCert <$> o .: "credential" <*> o .: "deposit" + Aeson.String "UnRegCert" -> DijkstraUnRegCert <$> o .: "credential" <*> o .: "refund" + Aeson.String "DelegCert" -> DijkstraDelegCert <$> o .: "credential" <*> o .: "delegatee" + Aeson.String "RegDelegCert" -> + DijkstraRegDelegCert <$> o .: "credential" <*> o .: "delegatee" <*> o .: "deposit" + _ -> fail $ "Unknown DijkstraDelegCert kind: " <> show kind + data DijkstraTxCert era = DijkstraTxCertDeleg !DijkstraDelegCert | DijkstraTxCertPool !PoolCert @@ -189,6 +202,25 @@ instance Era era => ToJSON (DijkstraTxCert era) where DijkstraTxCertPool poolCert -> toJSON poolCert DijkstraTxCertGov govCert -> toJSON govCert +instance Era era => FromJSON (DijkstraTxCert era) where + parseJSON = Aeson.withObject "DijkstraTxCert" $ \o -> do + kind <- o .: "kind" :: Parser Aeson.Value + case kind of + Aeson.String k + | k `elem` ["RegCert", "UnRegCert", "DelegCert", "RegDelegCert"] -> + DijkstraTxCertDeleg <$> parseJSON (Aeson.Object o) + | k `elem` ["RegPool", "RetirePool"] -> + DijkstraTxCertPool <$> parseJSON (Aeson.Object o) + | k + `elem` [ "RegDRep" + , "UnRegDRep" + , "UpdateDRep" + , "AuthCommitteeHotKey" + , "ResignCommitteeColdKey" + ] -> + DijkstraTxCertGov <$> parseJSON (Aeson.Object o) + _ -> fail $ "Unknown DijkstraTxCert kind: " <> show kind + instance ( EraTxCert era , TxCert era ~ DijkstraTxCert era diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index a87578734a9..55d946b567d 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -3,6 +3,7 @@ ## 1.19.0.0 * Add `ToJSON` and `FromJSON` instances for `ShelleyTxAuxData era` +* Add `ToJSON` and `FromJSON` instances for `ShelleyTxWits era` * Change `NoThunks` instance for `BlockTransitionError` to not check for thunks in its contents * Add `NFData` constraint to `BlockTransitionError` constructor. * Add `injectStakeCredentials`, `injectStakePools`, `resolveInjectionSource`, `injectInitialFundsAndStaking` to `Cardano.Ledger.Shelley.Transition` diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs index f0902e20e65..a1b3f0475fa 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxWits.hs @@ -7,6 +7,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -34,6 +36,7 @@ module Cardano.Ledger.Shelley.TxWits ( mapTraverseableDecoderA, ) where +import Cardano.Ledger.BaseTypes (KeyValuePairs (..), ToKeyValuePairs (..)) import Cardano.Ledger.Binary ( Annotator (..), DecCBOR (decCBOR), @@ -65,6 +68,8 @@ import Cardano.Ledger.Shelley.Era (ShelleyEra) import Cardano.Ledger.Shelley.Scripts () import Cardano.Ledger.Shelley.TxAuxData () import Control.DeepSeq (NFData) +import Data.Aeson (FromJSON (parseJSON), KeyValue ((.=)), ToJSON, (.:)) +import qualified Data.Aeson as Aeson import Data.Functor.Classes (Eq1 (liftEq)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -194,6 +199,25 @@ instance EraScript era => Semigroup (ShelleyTxWits era) where instance EraScript era => Monoid (ShelleyTxWits era) where mempty = ShelleyTxWits mempty mempty mempty +instance (EraScript era, ToJSON (Script era)) => ToKeyValuePairs (ShelleyTxWits era) where + toKeyValuePairs ShelleyTxWits {addrWits, scriptWits, bootWits} = + [ "addrWits" .= Set.toList addrWits + , "scriptWits" .= scriptWits + , "bootWits" .= Set.toList bootWits + ] + +deriving via + KeyValuePairs (ShelleyTxWits era) + instance + (EraScript era, ToJSON (Script era)) => ToJSON (ShelleyTxWits era) + +instance (EraScript era, FromJSON (Script era)) => FromJSON (ShelleyTxWits era) where + parseJSON = Aeson.withObject "ShelleyTxWits" $ \o -> + ShelleyTxWits + <$> (Set.fromList <$> o .: "addrWits") + <*> o .: "scriptWits" + <*> (Set.fromList <$> o .: "bootWits") + pattern ShelleyTxWits :: forall era. EraScript era => diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 3e765cc4e78..ffcc03c3d1f 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -34,6 +34,13 @@ * Rename `kindObject` (which returned `Value`) to `kindObjectValue` * Add `kindObject :: Text -> [Pair] -> Object` returning an `Aeson.Object` * Add `NFData (Script era)`, `ToJSON (Script era)`, `FromJSON (Script era)`, `ToJSON (NativeScript era)`, and `FromJSON (NativeScript era)` as superclass constraints to `EraScript` +* Add `ToJSON`, `FromJSON` and `NFData` as `EraTxWits` superclass constraints +* Add `ToJSONKey` and `FromJSONKey` instances to `AccountId` +* Add `ToJSON` and `FromJSON` instances for `Inclusive a` and `Exclusive a` +* Add `ToJSON` and `FromJSON` instances for `WitVKey kr` +* Add `ToJSON` and `FromJSON` instances for `BootstrapWitness` +* Add `FromJSON` instance for `TxIn`; fix `txInToText` to use `unTxIx` instead of `show` +* Add `FromJSON` instance for `PoolCert` ### `cddl` @@ -56,6 +63,7 @@ * Add `Arbitrary (NativeScript era)` and `ToExpr (NativeScript era)` constraints to `EraConstraints` * Add round-trip JSON property test for `NativeScript era` and `Script era` to the shared era spec * Add round-trip JSON property test for `TxAuxData era` to the shared era spec +* Add round-trip JSON property test for `TxWits era` to the shared era spec ## 1.20.0.0 diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Address.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Address.hs index ea40ed76122..0c0b096b144 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Address.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Address.hs @@ -188,7 +188,7 @@ data AccountAddress = AccountAddress newtype AccountId = AccountId {unAccountId :: Credential Staking} deriving (Show, Eq, Generic, Ord) - deriving newtype (NFData, NoThunks, ToJSON, FromJSON, EncCBOR, DecCBOR) + deriving newtype (NFData, NoThunks, ToJSON, ToJSONKey, FromJSON, FromJSONKey, EncCBOR, DecCBOR) -- | Deprecated pattern synonym for backward compatibility pattern RewardAccount :: Network -> Credential Staking -> AccountAddress diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs index 4087e12df97..f858dd86608 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs @@ -804,10 +804,10 @@ deriving instance Show EpochErr instance Exception EpochErr newtype Inclusive a = Inclusive {unInclusive :: a} - deriving newtype (Generic, Show, Eq, Ord, NoThunks, NFData, EncCBOR, DecCBOR) + deriving newtype (Generic, Show, Eq, Ord, NoThunks, NFData, EncCBOR, DecCBOR, ToJSON, FromJSON) newtype Exclusive a = Exclusive {unExclusive :: a} - deriving newtype (Generic, Show, Eq, Ord, NoThunks, NFData, EncCBOR, DecCBOR) + deriving newtype (Generic, Show, Eq, Ord, NoThunks, NFData, EncCBOR, DecCBOR, ToJSON, FromJSON) -- | Relationship descriptor for the expectation in the 'Mismatch' type. type data Relation diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs index 4c5f163c435..1d30aa216e7 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs @@ -505,6 +505,9 @@ class , ToCBOR (TxWits era) , EncCBOR (TxWits era) , DecCBOR (Annotator (TxWits era)) + , NFData (TxWits era) + , ToJSON (TxWits era) + , FromJSON (TxWits era) ) => EraTxWits era where diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core/TxCert.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core/TxCert.hs index 01c1f06dc87..abcbf13ffc8 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core/TxCert.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core/TxCert.hs @@ -34,9 +34,12 @@ import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..), asWitness) import Cardano.Ledger.Slot (EpochNo (..)) import Cardano.Ledger.State.StakePool (StakePoolParams (sppId)) import Control.DeepSeq (NFData (..), rwhnf) -import Data.Aeson (ToJSON (..), (.=)) +import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=)) +import qualified Data.Aeson as Aeson +import Data.Aeson.Types (Parser) import Data.Kind (Type) import Data.Maybe (isJust) +import Data.Text (Text) import Data.Void (Void) import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) @@ -157,6 +160,14 @@ instance ToJSON PoolCert where , "epochNo" .= toJSON epochNo ] +instance FromJSON PoolCert where + parseJSON = Aeson.withObject "PoolCert" $ \o -> do + kind <- o .: "kind" :: Parser Text + case kind of + "RegPool" -> RegPool <$> o .: "poolParams" + "RetirePool" -> RetirePool <$> o .: "poolId" <*> o .: "epochNo" + _ -> fail $ "Unknown PoolCert kind: " <> show kind + poolCertKeyHashWitness :: PoolCert -> KeyHash Witness poolCertKeyHashWitness = \case RegPool stakePoolParams -> asWitness $ sppId stakePoolParams diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/Bootstrap.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/Bootstrap.hs index 0b80b39e6c3..4fbdb19f023 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/Bootstrap.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/Bootstrap.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} @@ -50,7 +51,11 @@ import Cardano.Ledger.Keys.Internal ( ) import Control.DeepSeq (NFData (..), rwhnf) import Control.Monad (unless) +import Data.Aeson (FromJSON (parseJSON), KeyValue ((.=)), ToJSON (toJSON), (.:)) +import qualified Data.Aeson as Aeson +import Data.Aeson.Types (Parser) import Data.ByteString (ByteString) +import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Short as SBS @@ -60,6 +65,8 @@ import Data.MemPack.Buffer (byteArrayToShortByteString) import Data.Ord (comparing) import qualified Data.Primitive.ByteArray as BA import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text.Encoding as Text import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) import Quiet @@ -91,7 +98,7 @@ instance NFData BootstrapWitness where instance NoThunks BootstrapWitness instance EncCBOR BootstrapWitness where - encCBOR bw@(BootstrapWitness _ _ _ _) = + encCBOR bw@(BootstrapWitness {}) = let BootstrapWitness {..} = bw in encodeListLen 4 <> encCBOR bwKey @@ -108,6 +115,50 @@ instance DecCBOR BootstrapWitness where instance Ord BootstrapWitness where compare = comparing bootstrapWitKeyHash +instance ToJSON BootstrapWitness where + toJSON (BootstrapWitness (VKey vk) (SignedDSIGN sig) (ChainCode cc) attrs) = + let + encodeHex :: ByteString -> Text + encodeHex = Text.decodeUtf8 . Base16.encode + toBS :: BA.ByteArray -> ByteString + toBS = SBS.fromShort . byteArrayToShortByteString + in + Aeson.object + [ "key" .= encodeHex (DSIGN.rawSerialiseVerKeyDSIGN vk) + , "signature" .= encodeHex (DSIGN.rawSerialiseSigDSIGN sig) + , "chainCode" .= encodeHex (toBS cc) + , "attributes" .= encodeHex (toBS attrs) + ] + +instance FromJSON BootstrapWitness where + parseJSON = + let + decodeHex :: Text -> Parser ByteString + decodeHex t = either fail pure $ Base16.decode (Text.encodeUtf8 t) + in + Aeson.withObject "BootstrapWitness" $ \o -> do + !keyHex <- o .: "key" + !sigHex <- o .: "signature" + !ccHex <- o .: "chainCode" + !attrsHex <- o .: "attributes" + !keyBytes <- decodeHex keyHex + !sigBytes <- decodeHex sigHex + !ccBytes <- decodeHex ccHex + !attrsBytes <- decodeHex attrsHex + !vk <- + maybe (fail "BootstrapWitness: invalid key bytes") pure (DSIGN.rawDeserialiseVerKeyDSIGN keyBytes) + !sig <- + maybe + (fail "BootstrapWitness: invalid signature bytes") + pure + (DSIGN.rawDeserialiseSigDSIGN sigBytes) + pure $ + BootstrapWitness + (VKey vk) + (SignedDSIGN sig) + (ChainCode (byteStringToByteArray ccBytes)) + (byteStringToByteArray attrsBytes) + -- | Rebuild the addrRoot of the corresponding address. bootstrapWitKeyHash :: BootstrapWitness -> diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/WitVKey.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/WitVKey.hs index 0450be3ae52..23d0f1ee0c6 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/WitVKey.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/WitVKey.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} @@ -14,7 +15,13 @@ module Cardano.Ledger.Keys.WitVKey ( ) where import Cardano.Crypto.DSIGN.Class ( - SignedDSIGN, + DSIGNAlgorithm ( + rawDeserialiseSigDSIGN, + rawDeserialiseVerKeyDSIGN, + rawSerialiseSigDSIGN, + rawSerialiseVerKeyDSIGN + ), + SignedDSIGN (..), ) import Cardano.Ledger.Binary ( DecCBOR (..), @@ -31,9 +38,20 @@ import Cardano.Ledger.Hashes ( hashKey, hashTxBodySignature, ) -import Cardano.Ledger.Keys.Internal (DSIGN, KeyRole (..), VKey, asWitness) +import Cardano.Ledger.Keys.Internal ( + DSIGN, + KeyRole (..), + VKey (..), + asWitness, + ) import Control.DeepSeq +import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=)) +import qualified Data.Aeson as Aeson +import Data.Aeson.Types (Parser) +import qualified Data.ByteString.Base16 as B16 import Data.Ord (comparing) +import Data.Text (Text) +import qualified Data.Text.Encoding as Text import Data.Typeable (Typeable) import GHC.Generics (Generic) import NoThunks.Class (AllowThunksIn (..), NoThunks (..)) @@ -68,6 +86,23 @@ instance Typeable kr => Ord (WitVKey kr) where -- compliance with Ord laws. comparing wvkKeyHash x y <> comparing (hashTxBodySignature . wvkSignature) x y +instance ToJSON (WitVKey kr) where + toJSON (WitVKey (VKey vk) (SignedDSIGN sig)) = + Aeson.object + [ "key" .= Text.decodeUtf8 (B16.encode (rawSerialiseVerKeyDSIGN vk)) + , "signature" .= Text.decodeUtf8 (B16.encode (rawSerialiseSigDSIGN sig)) + ] + +instance Typeable kr => FromJSON (WitVKey kr) where + parseJSON = Aeson.withObject "WitVKey" $ \o -> do + !keyHex <- o .: "key" :: Parser Text + !sigHex <- o .: "signature" :: Parser Text + !keyBytes <- either fail pure $ B16.decode (Text.encodeUtf8 keyHex) + !sigBytes <- either fail pure $ B16.decode (Text.encodeUtf8 sigHex) + !vk <- maybe (fail "WitVKey: invalid key bytes") pure (rawDeserialiseVerKeyDSIGN keyBytes) + !sig <- maybe (fail "WitVKey: invalid signature bytes") pure (rawDeserialiseSigDSIGN sigBytes) + pure $ WitVKey (VKey vk) (SignedDSIGN sig) + instance EncCBOR (WitVKey kr) where encCBOR (WitVKey k sig) = encodeListLen 2 diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/TxIn.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/TxIn.hs index 28e825e1b6a..479573415f4 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/TxIn.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/TxIn.hs @@ -11,6 +11,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -23,7 +24,7 @@ module Cardano.Ledger.TxIn ( ) where import Cardano.Crypto.Hash.Class (hashToTextAsHex) -import Cardano.Ledger.BaseTypes (TxIx (..), mkTxIxPartial) +import Cardano.Ledger.BaseTypes (TxIx (..), mkTxIxPartial, txIxFromIntegral) import Cardano.Ledger.Binary ( DecCBOR (..), DecShareCBOR (..), @@ -36,14 +37,17 @@ import Cardano.Ledger.Binary ( ) import Cardano.Ledger.Hashes (EraIndependentTxBody, SafeHash, extractHash) import Control.DeepSeq (NFData) -import Data.Aeson (FromJSON, ToJSON (..)) +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.Aeson as Aeson import Data.Aeson.Types (ToJSONKey (..), toJSONKeyText) import Data.MemPack import Data.Text (Text) import qualified Data.Text as Text +import Data.Word (Word16) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import NoThunks.Class (NoThunks (..)) +import Text.Read (readMaybe) -- =================================================================================== -- Because we expect other Era's to import and use TxId, TxIn, TxOut, we use the weakest @@ -60,19 +64,6 @@ newtype TxId = TxId {unTxId :: SafeHash EraIndependentTxBody} deriving (Show, Eq, Ord, Generic) deriving newtype (NoThunks, ToJSON, FromJSON, EncCBOR, DecCBOR, NFData, MemPack) -instance ToJSON TxIn where - toJSON = toJSON . txInToText - toEncoding = toEncoding . txInToText - -instance ToJSONKey TxIn where - toJSONKey = toJSONKeyText txInToText - -txInToText :: TxIn -> Text -txInToText (TxIn (TxId txidHash) ix) = - hashToTextAsHex (extractHash txidHash) - <> Text.pack "#" - <> Text.pack (show ix) - -- | The input of a UTxO. data TxIn = TxIn !TxId {-# UNPACK #-} !TxIx deriving (Generic, Eq, Ord, Show) @@ -94,6 +85,34 @@ instance NFData TxIn instance NoThunks TxIn +instance ToJSON TxIn where + toJSON = toJSON . txInToText + toEncoding = toEncoding . txInToText + +instance ToJSONKey TxIn where + toJSONKey = toJSONKeyText txInToText + +instance FromJSON TxIn where + parseJSON v = do + t <- parseJSON @Text v + case Text.splitOn "#" t of + [txIdText, txIxText] -> do + txId <- parseJSON (Aeson.String txIdText) + txIx <- + maybe + (fail "TxIn: invalid index") + pure + (readMaybe $ Text.unpack txIxText) + txIx' <- txIxFromIntegral @Word16 txIx + pure $ TxIn txId txIx' + _ -> fail "TxIn: expected 'TxId#TxIx'" + +txInToText :: TxIn -> Text +txInToText (TxIn (TxId txidHash) ix) = + hashToTextAsHex (extractHash txidHash) + <> Text.pack "#" + <> Text.pack (show (unTxIx ix)) + instance EncCBOR TxIn where encCBOR (TxIn txId index) = encodeListLen 2 diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs index 6cea566fe8e..376c4df319e 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs @@ -174,6 +174,8 @@ ledgerEraTestMain extraEraSpec = roundTripAesonProperty @(Script era) prop (show $ typeRep $ Proxy @(TxAuxData era)) $ roundTripAesonProperty @(TxAuxData era) + prop (show $ typeRep $ Proxy @(TxWits era)) $ + roundTripAesonProperty @(TxWits era) describe "Era-specific spec" extraEraSpec -- | This is a helper function that uses `mkTestAccountState` to register an account.