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

Author: koslambrou

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`

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,80 @@ 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 ->
+        (,) <$> o .: "dataHash" <*> o .: "data"
+
+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 ->
+        (,)
+          <$> o .: "purpose"
+          <*> ((,) <$> o .: "data" <*> o .: "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"

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`

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 (
   (<!),
  )
 import Cardano.Ledger.Coin (Coin)
-import Cardano.Ledger.Credential (Credential (..), credToText)
+import Cardano.Ledger.Credential (Credential (..), credToText, parseCredential)
 import Cardano.Ledger.Shelley.RewardProvenance ()
 import Cardano.Ledger.TxIn (TxId (..))
 import Cardano.Slotting.Slot (EpochNo)
@@ -135,14 +132,16 @@ import Control.Monad.Trans (lift)
 import Control.Monad.Trans.State.Strict (get, put)
 import Data.Aeson (
   FromJSON (..),
+  FromJSONKey (..),
   KeyValue (..),
   ToJSON (..),
   ToJSONKey (..),
   withObject,
   (.:),
   (.:?),
  )
-import Data.Aeson.Types (toJSONKeyText)
+import qualified Data.Aeson as Aeson
+import Data.Aeson.Types (FromJSONKeyFunction (..), toJSONKeyText)
 import Data.Data (Typeable)
 import Data.Default
 import Data.Kind
@@ -158,6 +157,7 @@ import Data.Word (Word16)
 import GHC.Generics (Generic)
 import Lens.Micro (Lens', lens, (^.))
 import NoThunks.Class (NoThunks)
+import Text.Read (readMaybe)
 
 newtype GovActionIx = GovActionIx {unGovActionIx :: Word16}
   deriving
@@ -170,6 +170,7 @@ newtype GovActionIx = GovActionIx {unGovActionIx :: Word16}
     , EncCBOR
     , DecCBOR
     , ToJSON
+    , FromJSON
     )
 
 data GovActionId = GovActionId
@@ -216,6 +217,26 @@ govActionIdToText (GovActionId (TxId txidHash) (GovActionIx ix)) =
     <> 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,14 +594,22 @@ 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
         , "govAction" .= pProcGovAction
         , "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

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)